diff -Nru ecl-16.1.2/CHANGELOG ecl-16.1.3+ds/CHANGELOG --- ecl-16.1.2/CHANGELOG 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/CHANGELOG 2016-12-19 10:25:00.000000000 +0000 @@ -1,20 +1,20 @@ * Announcement of ECL - + ECL stands for Embeddable Common-Lisp. The ECL project aims to produce an implementation of the Common-Lisp language which complies to the ANSI X3J13 definition of the language. - + The term embeddable refers to the fact that ECL includes a lisp to C compiler, which produces libraries (static or dynamic) that can be called from C programs. Furthermore, ECL can produce standalone executables from your lisp code and can itself be linked to your programs as a shared library. - + ECL supports the operating systems Linux, FreeBSD, NetBSD, OpenBSD, Solaris (at least v. 9), Microsoft Windows and OSX, running on top of the Intel, Sparc, Alpha, ARM and PowerPC processors. Porting to other architectures should be rather easy. - + * Known issues - In Windows ECL comes with bytecodes compiler by default, because C @@ -23,33 +23,190 @@ have a C compiler accessible to ECL, you may use (ext:install-c-compiler) to switch back to the Lisp-to-C compiler. - - In order to test package programmer has to install ECL on desired - destination (specified with "--prefix" parameter given to configure - script). - -* Pending changes since 16.0.0 + - Before issuing =make check= on the package package developer has to + install ECL on the preferred destination (specified with "--prefix" + parameter given to configure script). + +* Pending changes since 16.1.3 +* 16.1.3 changes since 16.1.2 +** Announcement +Dear Community, + +After almost a year of development we are proud to present a new release of +ECL tagged with version =16.1.3=. All changes are backward compatible +fixing bugs and other issues, implementing new interfaces and cleaning up +the code base. + +ECL manual has been updated in a few places. Work on a new documentation is +still pending. It is still incomplete, but you may check see it here: +https://common-lisp.net/project/ecl/static/ecldoc/. + +Before this release we have performed extensive tests on various platforms +(Linux, FreeBSD, OpenBSD, NetBSD, OSX, Windows MSVC, Windows MinGW, Windows +Cygwin, Android and Haiku). For details please consult +https://gitlab.com/embeddable-common-lisp/ecl/issues/307. Extra attention +has been paid to Windows testing to improve that platform support. + +Best regards, +ECL Development Team + +** API changes +- Added better interface for package-locks. + + Introduced functions: + =ext:package-locked-p package= + =ext:lock-package package= + =ext:unlock-package package= + =ext:without-package-locks= + =ext:with-unlocked-package= + + To use these functions user has to require the module + #+BEGIN_SRC lisp + (require '#:package-locks) + #+END_SRC + + =defpackage= accepts new option =lock= to allow locking package on + creation: + + #+BEGIN_SRC lisp + (defpackage foo (:lock t)) + #+END_SRC + +- =mp:holding-lock-p=: introduce new function for multiprocessing. Function + verifies if lock is hold by the thread which calls the function. Usage: + =(mp:holding-lock-p my-lock)=. + +- =make-random-state=: fix problem with simple-vectors. The correct + initialization types for =make-random-state= are: =(OR RANDOM-STATE + FIXNUM (MEMBER T NIL))=. + + Initializing a random state with an appropriate array (element type and + arity dependent on platform) is also possible. + +- =ext:random-state-array=: new extension for random-states. Usage: + =(ext:random-state-array random-state)=. + +- =ext:terminate-process=: new extension for external processes. Usage: + =(ext:terminate-process process)= with a second, optional boolean + argument whenever termination should be forced or not. + +** Enhancements +- Implemented =CDR-7=. + https://common-lisp.net/project/cdr/document/7/index.html + +- implemented CDRs: =CDR-1=, =CDR-5=, =CDR-14=. Both =CDR-1= and =CDR-5= + were already implemented, CDR-14 made us to list them in =*features*= + (https://common-lisp.net/project/cdr/document/14/index.html). + +- if ECL is build with =--with-cxx= option, =:CXX-CORE= is present in + =*features*=. + +- deprecated configure option =--with-local-gmp= has been removed - use + =--enable-gmp= (defaults to auto). + +- configure options has been revised. + +- ASDF has been upgraded to version 3.1.7.26 (with a few patches scheduled + for 3.2.0). + +- bundled CLX has been purged. Lately I've fixed ECL support on portable + CLX maintained by sharplispers on https://github.com/sharplispers/clx + (available via QuickLisp). + +- initial port for the Haiku platform. The port is done by Kacper Kasper's + work, one of Haiku developers. Threads are not supported yet. + +- refactored ECL internal tests framework. Tests in =src/tests= are now + asdf-loadable (with =load-source-op=) and divided into test suites. =make + check= target runs all regression and feature tests which aren't supposed + to fail. + +- removed 15000 lines of obsolete code. Files not included in the + buildsystem but lingering in the codebase or options failing to + build. All info is added in the new documentation in the section "Removed + interfaces". + +- improved man page and help output. Man page now contains up-to-date list + of flags, as well as explanation of flag's behavior. + +- deprecated long flags with one dash, added two-dash version. Flags that + aren't one-character, but start with one dash (e.g. =-eval=) are now + deprecated; long version =--eval= was added instead. + +- indented C/C++ code to follow emacs's gnu C style. This is a first step + towards coding standards in the documentation. Additionally all in the + src/c/ directory are listed in the appropraite documentation section + (new-doc). + +- refactored =list_current_directory in unixfsys.d=. Function was + obfuscated with ifdefs with non-even pairs of =#\{= and =#\}=. + +** Issues fixed +- ECL signals floating point exceptions in top-level console. + +- =mp:rwlock= is treated as built-in class (previously process crashed if + =class-of= was called on such object). + +- ECL builds now succesfully with =--with-ieee-fp=no= option. + +- =ext:file-stream-fd=: doesn't cause an internal-error if called with + something not being a =file-stream= (signals a =SIMPLE-TYPE-ERROR= + condtition). + +- =stable-sort=: bugfix and improvement in speed. Adapted from SBCL by + Diogo Franco. + +- typep: accept =*= type specifier as abbreviation of =T= as described in + =2.4.3 Type Specifiers= of the specification. + +- MOP: fix problemes when redefining non-standard and anonymous + classes. Bugs identified and fixed by Pascal Costanza. + +- =getcwd=: fix issue with too long pathname. This fixes the regression, + which crashed ECL at start when pathname exceeded 128 characters limit. + +- =make-random-state=: fix a problem with simple-vectors. Until now =#$= + reader macro accepted simple vectors as an argument, what lead to bugs if + vector didn't match specific requirements like the element type or the + arity. Now we sanitize this. + +- =make-load-form=: provide implementation for random-state objects. + +- thread fix on msvc: on windows importing thread was closing the thread + handler so the thread wakeup wasn't working because the handler is not + more valid. + +- import thread wasn't set upping a proper environment: on some case the + thread was mistakenly thinking that the thread was already registered. + +- =ECL_HANDLER_CASE= and =ECL_RESTART_CASE= didn't work as expected. Bug + identified and fixed by Vadim Penzin. + +* 16.1.2 changes since 16.0.0 + ** API changes - - si:do-setf accepts optional parameter stores. New lambda-list: - =(access-fn function &optional (stores `(,(gensym))))= + - =si:do-defsetf= accepts optional parameter stores.\\ + New lambda-list:\\ + =(access-fn function &optional (stores-no 1))=.\\ This change is backward compatible. - - New MP functions: - mp:with-rwlock - mp:try-get-semaphore (non-blocking) - mp:mailbox-try-read (non-blocking) - mp:mailbox-try-send (non-blocking) - - - Added back removed C interfaces - ecl_import_current_thread - ecl_release_current_thread + - New MP functions:\\ + =mp:with-rwlock=\\ + =mp:try-get-semaphore= (non-blocking)\\ + =mp:mailbox-try-read= (non-blocking)\\ + =mp:mailbox-try-send= (non-blocking) + + - Added back removed C interfaces\\ + =ecl_import_current_thread=\\ + =ecl_release_current_thread= - - When cl-truename encounters a broken symlink, it returns its path + - When =cl-truename= encounters a broken symlink, it returns its path instead of signalling a file-error - Deprecated variables has been removed - c::*suppress-compiler-warnings*, c::*suppress-compiler-notes* - + =c::*suppress-compiler-warnings*=, =c::*suppress-compiler-notes*= + - Random state might be initialized by a random seed (truncated to 32bit value) or by a precomputed array. @@ -59,51 +216,55 @@ - C99 supporting compiler is mandatory for C backend. - - COMPILER::*cc_is_cxx*: New variable to switch the output extension of + - =COMPILER::*CC_IS_CXX*=: New variable to switch the output extension of emitted compiler code to ".cxx" when configured with "--with-c++". This eliminates compiler warnings that compiling C++ with a ".c" extension is deprecated; this is seen mostly with Clang++. - - Added Clang-specific pragmas to disable return type, unused value and - excessive parentheses warnings, which are fairly harmless, but annoying - and clutter user output. - - - GRAY:CLOSE isn't specialized on T to preserve compatibility with some + - =GRAY:CLOSE= isn't specialized on =T= to preserve compatibility with some libraries. ** Enhancements: - - Added code walker (present as *feature* :walker) + - Added code walker (present in =*features*= as =:walker=) - - Testing framework cleanup + - Testing framework initial cleanup - - Format fallbacks to prin1 if infinity or NaN are passed to it + - Format fallbacks to =prin1= if infinity or NaN are passed to it - Annotations are added at runtime (better integration with SLIME) - Mersenne-Twister RNG has new 64 bit implementation for appropriate machines - - Add sockets implementation for android platform + - Add sockets implementation for the android platform - Add android build target (official android support) + - Added Clang-specific pragmas to disable return type, unused value and + excessive parentheses warnings, which are fairly harmless, but annoying + and clutter user output. + ** Issues fixed: - - si:open-unix-socket-stream accepts both string and base-string + - =si:open-unix-socket-stream= accepts both string and base-string (automatic coercion is performed) - - Long form of DEFSETF accepts multiple-values as a store forms: + - Long form of =DEFSETF= accepts multiple-values as a store forms: - (defsetf gah (x) (y z) `(list ,x ,y ,z)) - (setf (gah 3) (values 3 4)) + #+BEGIN_SRC lisp + (defsetf gah (x) (y z) `(list ,x ,y ,z)) + (setf (gah 3) (values 3 4)) + #+END_SRC - Building with single-threaded boehm works if ECL threads are disabled - Using labels works with sharp-S-reader - (read-from-string - "(#1=\"Hello\" #S(sharp-s-reader.1.example-struct :A #1#))") + #+BEGIN_SRC lisp + (read-from-string + "(#1=\"Hello\" #S(sharp-s-reader.1.example-struct :A #1#))") + #+END_SRC - Generated C code works well with IEEE 754 infinities (regression tests created) @@ -111,12 +272,12 @@ - User-defined heap sizes can now exceed the size of a fixnum on 32-bit - The heap size limit was intended to be 1GB on 32-bit or 4GB on 64-bit - but inconsistency between ECL_FIXNUM_BITS and FIXNUM_BITS in the code + but inconsistency between =ECL_FIXNUM_BITS= and =FIXNUM_BITS= in the code prevented the heap to grow for 64-bit. This now occurs, and a few other less visible bugs were fixed by restoring consistency to - ECL_FIXNUM_BITS. + =ECL_FIXNUM_BITS=. - - EXT:EXTERNAL-PROCESS-WAIT potential race condition fix + - =EXT:EXTERNAL-PROCESS-WAIT= potential race condition fix - Building with object files not created by ECL works (CFFI wrappers) @@ -128,13 +289,13 @@ - Random state initial state generation was buggy and insecure (entropy from urandom was rejected) - - Fix `listen' on streams when FILE_CNT isn't available (use read instad + - Fix =listen= on streams when =FILE_CNT= isn't available (use read instad of fread) - - `FIND' compiled with C compiler didn't respect `START' nor `END' + - =FIND= compiled with C compiler didn't respect =START= nor =END= arguments. Compiler macro is fixed now and should work as expected - - `compute-applicable-methods-using-classes` bugfix + - =compute-applicable-methods-using-classes= bugfix * 16.0.0 changes since 15.3.7 ** API changes @@ -189,7 +350,7 @@ - Dead code removal, tabulators were replaced by spaces - Better quality of generated code (explicit casting when necessary) - + ** Issues fixed: - Various fixes of bogus declarations @@ -235,30 +396,30 @@ - Other minor tweaks -* 15.3.7 changes since 15.2.21 +* 15.3.7 changes since 15.2.21 ** Issues fixed: - + - DEFUN functions not defined as toplevel forms were also directly referenced by other code in the same file. - + - STABLE-SORT works as desired (bogus optimization for strings fixed). - + - broken --with-sse=yes configure flag works once again. - + ** Enhancements: - + - autoconf scripts are rewritten to support version 2.69 stack. - + - stack direction is now correctly determined, fixing gcc 5.x builds. - + - compilation of ECL under MSVC (2008/2010/2012) even with custom code pages. - + - In compiled code it is possible to declare variables to have a C type such as in (declare (:double a)) and then the variable is enforced to be unboxed to such type. - + - New form FFI:C-PROGN used to interleave C statements with lisp code, where the lisp code may refer to any number of variables. Example: @@ -272,18 +433,18 @@ (print iterator) "}"))) #+END_SRC - + * 15.2.21 changes since 13.5.1 - + - Features coverity scan model, ffi-unload-module implementation, probably more. - + - Build system enhancements, parallel builds, fixes, simplifications, cleanups, maintenance. minor cleanup, maintenance. - + - Numerous fixes. - + * 13.5.1 changes since 12.7.1 ** Visible changes: @@ -380,19 +541,19 @@ structures as well. * 12.7.1 changes - + Some highlights of this release are: - + - ECL now ships with the whole of the Unicode names database, optimally compressed using constant C tables. This means ECL now recognizes all valid Unicode (and ASCII) names for the whole range of characters, and can print them as well. - + - ECL has changed the way it stores compiled data in the C files, so that it works around the limit of 65k characters per string. - + - ECL now builds with Microsoft Visual Studio C++ 2012. - + - We bend the knee and accepted WHILE/IF statements intertwined with FOR/AS, though this is still not valid ANSI Common Lisp. diff -Nru ecl-16.1.2/contrib/asdf/asdf.lisp ecl-16.1.3+ds/contrib/asdf/asdf.lisp --- ecl-16.1.2/contrib/asdf/asdf.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/contrib/asdf/asdf.lisp 2016-12-19 10:25:00.000000000 +0000 @@ -1,5 +1,5 @@ -;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*- -;;; This is ASDF 3.1.5.4: Another System Definition Facility. +;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*- +;;; This is ASDF 3.1.8.2: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to . @@ -19,7 +19,7 @@ ;;; http://www.opensource.org/licenses/mit-license.html on or about ;;; Monday; July 13, 2009) ;;; -;;; Copyright (c) 2001-2015 Daniel Barlow and contributors +;;; Copyright (c) 2001-2016 Daniel Barlow and contributors ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the @@ -45,44 +45,6 @@ ;;; The problem with writing a defsystem replacement is bootstrapping: ;;; we can't use defsystem to compile it. Hence, all in one file. -#+xcvb (module ()) - -(in-package :cl-user) - -#+cmu -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf ext:*gc-verbose* nil)) - -;;; pre 1.3.0 ABCL versions do not support the bundle-op on Mac OS X -#+abcl -(eval-when (:load-toplevel :compile-toplevel :execute) - (unless (and (member :darwin *features*) - (second (third (sys::arglist 'directory)))) - (push :abcl-bundle-op-supported *features*))) - -;; Punt on hard package upgrade: from ASDF1 always, and even from ASDF2 on most implementations. -(eval-when (:load-toplevel :compile-toplevel :execute) - (unless (member :asdf3 *features*) - (let* ((existing-version - (when (find-package :asdf) - (or (symbol-value (find-symbol (string :*asdf-version*) :asdf)) - (let ((ver (symbol-value (find-symbol (string :*asdf-revision*) :asdf)))) - (etypecase ver - (string ver) - (cons (format nil "~{~D~^.~}" ver)) - (null "1.0")))))) - (first-dot (when existing-version (position #\. existing-version))) - (second-dot (when first-dot (position #\. existing-version :start (1+ first-dot)))) - (existing-major-minor (subseq existing-version 0 second-dot)) - (existing-version-number (and existing-version (read-from-string existing-major-minor))) - (away (format nil "~A-~A" :asdf existing-version))) - (when (and existing-version - (< existing-version-number - #+(or allegro clisp lispworks sbcl) 2.0 - #-(or allegro clisp lispworks sbcl) 2.27)) - (rename-package :asdf away) - (when *load-verbose* - (format t "~&; Renamed old ~A package away to ~A~%" :asdf away)))))) ;;;; --------------------------------------------------------------------------- ;;;; Handle ASDF package upgrade, including implementation-dependent magic. ;; @@ -856,10 +818,10 @@ #:make-broadcast-stream #:file-namestring) #+genera (:shadowing-import-from :scl #:boolean) #+genera (:export #:boolean #:ensure-directories-exist #:read-sequence #:write-sequence) - #+mcl (:shadow #:user-homedir-pathname)) + #+(or mcl cmucl) (:shadow #:user-homedir-pathname)) (in-package :uiop/common-lisp) -#-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) +#-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "ASDF is not supported on your implementation. Please help us port it.") ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust implementation defaults. @@ -867,13 +829,14 @@ ;;;; Early meta-level tweaks -#+(or abcl allegro clasp clisp cmu ecl mkcl clozure lispworks mkcl sbcl scl) +#+(or allegro clasp clisp clozure cmucl ecl mkcl sbcl) (eval-when (:load-toplevel :compile-toplevel :execute) - ;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode - ;; but loaded in a non-unicode setting (e.g. on Allegro) won't tell a lie. (when (and #+allegro (member :ics *features*) - #+(or clasp clisp cmu ecl mkcl) (member :unicode *features*) + #+(or clasp clisp cmucl ecl mkcl) (member :unicode *features*) + #+clozure (member :openmcl-unicode-strings *features*) #+sbcl (member :sb-unicode *features*)) + ;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode + ;; but loaded in a non-unicode setting (e.g. on Allegro) won't tell a lie. (pushnew :asdf-unicode *features*))) #+allegro @@ -901,7 +864,13 @@ (wait-on-semaphore (external-process-completed proc)))) (values (external-process-%exit-code proc) (external-process-%status proc)))))) -#+clozure (in-package :uiop/common-lisp) +#+clozure (in-package :uiop/common-lisp) ;; back in this package. + +#+cmucl +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf ext:*gc-verbose* nil) + (defun user-homedir-pathname () + (first (ext:search-list (cl:user-homedir-pathname))))) #+cormanlisp (eval-when (:load-toplevel :compile-toplevel :execute) @@ -954,6 +923,17 @@ (scl:send stream :string-out sequence start end) sequence))) +#+lispworks +(eval-when (:load-toplevel :compile-toplevel :execute) + ;; lispworks 3 and earlier cannot be checked for so we always assume + ;; at least version 4 + (unless (member :lispworks4 *features*) + (pushnew :lispworks5+ *features*) + (unless (member :lispworks5 *features*) + (pushnew :lispworks6+ *features*) + (unless (member :lispworks6 *features*) + (pushnew :lispworks7+ *features*))))) + #.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick (read-from-string "(eval-when (:load-toplevel :compile-toplevel :execute) @@ -1065,10 +1045,11 @@ #:list-to-hash-set #:ensure-gethash ;; hash-table #:ensure-function #:access-at #:access-at-count ;; functions #:call-function #:call-functions #:register-hook-function + #:lexicographic< #:lexicographic<= ;; version + #:parse-version #:unparse-version #:version< #:version<= #:version-compatible-p #:match-condition-p #:match-any-condition-p ;; conditions #:call-with-muffled-conditions #:with-muffled-conditions - #:lexicographic< #:lexicographic<= - #:parse-version #:unparse-version #:version< #:version<= #:version-compatible-p)) ;; version + #:not-implemented-error #:parameter-error)) (in-package :uiop/utility) ;;;; Defining functions in a way compatible with hot-upgrade: @@ -1239,8 +1220,7 @@ #-scl base-char ;; LW6 has BASE-CHAR < SIMPLE-CHAR < CHARACTER ;; LW7 has BASE-CHAR < BMP-CHAR < SIMPLE-CHAR = CHARACTER - #+(and lispworks (not (or lispworks4 lispworks5 lispworks6))) - lw:bmp-char + #+lispworks7+ lw:bmp-char #+lispworks lw:simple-char character) :unless (and next (subtypep next type)) @@ -1553,10 +1533,11 @@ ;;; Version handling (with-upgradability () (defun unparse-version (version-list) + "From a parsed version (a list of natural numbers), compute the version string" (format nil "~{~D~^.~}" version-list)) (defun parse-version (version-string &optional on-error) - "Parse a VERSION-STRING as a series of natural integers separated by dots. + "Parse a VERSION-STRING as a series of natural numbers separated by dots. Return a (non-null) list of integers if the string is valid; otherwise return NIL. @@ -1582,22 +1563,28 @@ (call-function on-error "~S: ~S contains leading zeros" 'parse-version version-string)) version-list))) - (defun lexicographic< (< x y) + (defun lexicographic< (element< x y) + "Lexicographically compare two lists of using the function element< to compare elements. +element< is a strict total order; the resulting order on X and Y will also be strict." (cond ((null y) nil) ((null x) t) - ((funcall < (car x) (car y)) t) - ((funcall < (car y) (car x)) nil) - (t (lexicographic< < (cdr x) (cdr y))))) - - (defun lexicographic<= (< x y) - (not (lexicographic< < y x))) + ((funcall element< (car x) (car y)) t) + ((funcall element< (car y) (car x)) nil) + (t (lexicographic< element< (cdr x) (cdr y))))) + + (defun lexicographic<= (element< x y) + "Lexicographically compare two lists of using the function element< to compare elements. +element< is a strict total order; the resulting order on X and Y will be a non-strict total order." + (not (lexicographic< element< y x))) (defun version< (version1 version2) + "Compare two version strings" (let ((v1 (parse-version version1 nil)) (v2 (parse-version version2 nil))) (lexicographic< '< v1 v2))) (defun version<= (version1 version2) + "Compare two version strings" (not (version< version2 version1))) (defun version-compatible-p (provided-version required-version) @@ -1616,13 +1603,13 @@ (defparameter +simple-condition-format-control-slot+ #+abcl 'system::format-control #+allegro 'excl::format-control + #+(or clasp ecl mkcl) 'si::format-control #+clisp 'system::$format-control #+clozure 'ccl::format-control - #+(or cmu scl) 'conditions::format-control - #+(or clasp ecl mkcl) 'si::format-control + #+(or cmucl scl) 'conditions::format-control #+(or gcl lispworks) 'conditions::format-string #+sbcl 'sb-kernel:format-control - #-(or abcl allegro clasp clisp clozure cmu ecl gcl lispworks mkcl sbcl scl) nil + #-(or abcl allegro clasp clisp clozure cmucl ecl gcl lispworks mkcl sbcl scl) nil "Name of the slot for FORMAT-CONTROL in simple-condition") (defun match-condition-p (x condition) @@ -1637,7 +1624,7 @@ (function (funcall x condition)) (string (and (typep condition 'simple-condition) ;; On SBCL, it's always set and the check triggers a warning - #+(or allegro clozure cmu lispworks scl) + #+(or allegro clozure cmucl lispworks scl) (slot-boundp condition +simple-condition-format-control-slot+) (ignore-errors (equal (simple-condition-format-control condition) x)))))) @@ -1655,6 +1642,51 @@ "Shorthand syntax for CALL-WITH-MUFFLED-CONDITIONS" `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions))) +;;; Conditions + +(with-upgradability () + (define-condition not-implemented-error (error) + ((functionality :initarg :functionality) + (format-control :initarg :format-control) + (format-arguments :initarg :format-arguments)) + (:report (lambda (condition stream) + (format stream "Not implemented: ~s~@[ ~?~]" + (slot-value condition 'functionality) + (slot-value condition 'format-control) + (slot-value condition 'format-arguments))))) + + (defun not-implemented-error (functionality &optional format-control &rest format-arguments) + "Signal an error because some FUNCTIONALITY is not implemented in the current version +of the software on the current platform; it may or may not be implemented in different combinations +of version of the software and of the underlying platform. Optionally, report a formatted error +message." + (error 'not-implemented-error + :functionality functionality + :format-control format-control + :format-arguments format-arguments)) + + (define-condition parameter-error (error) + ((functionality :initarg :functionality) + (format-control :initarg :format-control) + (format-arguments :initarg :format-arguments)) + (:report (lambda (condition stream) + (apply 'format stream + (slot-value condition 'format-control) + (slot-value condition 'functionality) + (slot-value condition 'format-arguments))))) + + ;; Note that functionality MUST be passed as the second argument to parameter-error, just after + ;; the format-control. If you want it to not appear in first position in actual message, use + ;; ~* and ~:* to adjust parameter order. + (defun parameter-error (format-control functionality &rest format-arguments) + "Signal an error because some FUNCTIONALITY or its specific implementation on a given underlying +platform does not accept a given parameter or combination of parameters. Report a formatted error +message, that takes the functionality as its first argument (that can be skipped with ~*)." + (error 'parameter-error + :functionality functionality + :format-control format-control + :format-arguments format-arguments))) + ;;;; --------------------------------------------------------------------------- ;;;; Access to the Operating System @@ -1714,13 +1746,18 @@ "Is the underlying operating system an (emulated?) MacOS 9 or earlier?" (featurep :mcl)) + (defun os-haiku-p () + "Is the underlying operating system Haiku?" + (featurep :haiku)) + (defun detect-os () "Detects the current operating system. Only needs be run at compile-time, except on ABCL where it might change between FASL compilation and runtime." (loop* :with o :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-macosx . os-macosx-p) (:os-windows . os-windows-p) - (:genera . os-genera-p) (:os-oldmac . os-oldmac-p)) + (:genera . os-genera-p) (:os-oldmac . os-oldmac-p) + (:haiku . os-haiku-p)) :when (and (or (not o) (eq feature :os-macosx)) (funcall detect)) :do (setf o feature) (pushnew feature *features*) :else :do (setf *features* (remove feature *features*)) @@ -1744,7 +1781,7 @@ #+(or abcl clasp clisp ecl xcl) (ext:getenv x) #+allegro (sys:getenv x) #+clozure (ccl:getenv x) - #+cmu (unix:unix-getenv x) + #+cmucl (unix:unix-getenv x) #+scl (cdr (assoc x ext:*environment-list* :test #'string=)) #+cormanlisp (let* ((buffer (ct:malloc 1)) @@ -1765,7 +1802,7 @@ (ccl:%get-cstring value)))) #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x) #+sbcl (sb-ext:posix-getenv x) - #-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) + #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "~S is not supported on your implementation" 'getenv)) (defsetf getenv (x) (val) @@ -1774,12 +1811,12 @@ #+allegro `(setf (sys:getenv ,x) ,val) #+clisp `(system::setenv ,x ,val) #+clozure `(ccl:setenv ,x ,val) - #+cmu `(unix:unix-setenv ,x ,val 1) + #+cmucl `(unix:unix-setenv ,x ,val 1) #+ecl `(ext:setenv ,x ,val) #+lispworks `(hcl:setenv ,x ,val) #+mkcl `(mkcl:setenv ,x ,val) #+sbcl `(progn (require :sb-posix) (symbol-call :sb-posix :setenv ,x ,val 1)) - #-(or allegro clisp clozure cmu ecl lispworks mkcl sbcl) + #-(or allegro clisp clozure cmucl ecl lispworks mkcl sbcl) '(error "~S ~S is not supported on your implementation" 'setf 'getenv)) (defun getenvp (x) @@ -1871,20 +1908,24 @@ ccl::*openmcl-major-version* ccl::*openmcl-minor-version* (logand (ccl-fasl-version) #xFF)) - #+cmu (substitute #\- #\/ s) + #+cmucl (substitute #\- #\/ s) #+scl (format nil "~A~A" s ;; ANSI upper case vs lower case. (ecase ext:*case-mode* (:upper "") (:lower "l"))) - #+clasp (format nil "~A-~A" - s (core:lisp-implementation-id)) - #+(and ecl (not clasp)) (format nil "~A~@[-~A~]" s - (let ((vcs-id (ext:lisp-implementation-vcs-id))) - (subseq vcs-id 0 (min (length vcs-id) 8)))) + #+ecl (format nil "~A~@[-~A~]" s + (let ((vcs-id (ext:lisp-implementation-vcs-id))) + (subseq vcs-id 0 (min (length vcs-id) 8)))) #+gcl (subseq s (1+ (position #\space s))) #+genera (multiple-value-bind (major minor) (sct:get-system-version "System") (format nil "~D.~D" major minor)) #+mcl (subseq s 8) ; strip the leading "Version " + ;; seems like there should be a shorter way to do this, like ACALL. + #+mkcl (or + (let ((fname (find-symbol* '#:git-describe-this-mkcl :mkcl nil))) + (when (and fname (fboundp fname)) + (funcall fname))) + s) s)))) (defun implementation-identifier () @@ -1894,7 +1935,7 @@ #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\"")) (format nil "~(~a~@{~@[-~a~]~}~)" (or (implementation-type) (lisp-implementation-type)) - (or (lisp-version-string) (lisp-implementation-version)) + (lisp-version-string) (or (operating-system) (software-type)) (or (architecture) (machine-type)))))) @@ -1905,7 +1946,7 @@ (defun hostname () "return the hostname of the current host" ;; Note: untested on RMCL - #+(or abcl clasp clozure cmu ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance) + #+(or abcl clasp clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance) #+cormanlisp "localhost" ;; is there a better way? Does it matter? #+allegro (symbol-call :excl.osi :gethostname) #+clisp (first (split-string (machine-instance) :separator " ")) @@ -1915,7 +1956,7 @@ ;;; Current directory (with-upgradability () - #+cmu + #+cmucl (defun parse-unix-namestring* (unix-namestring) "variant of LISP::PARSE-UNIX-NAMESTRING that returns a pathname object" (multiple-value-bind (host device directory name type version) @@ -1929,7 +1970,7 @@ #+allegro (excl::current-directory) #+clisp (ext:default-directory) #+clozure (ccl:current-directory) - #+(or cmu scl) (#+cmu parse-unix-namestring* #+scl lisp::parse-unix-namestring + #+(or cmucl scl) (#+cmucl parse-unix-namestring* #+scl lisp::parse-unix-namestring (strcat (nth-value 1 (unix:unix-current-directory)) "/")) #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return? #+(or clasp ecl) (ext:getcwd) @@ -1947,7 +1988,7 @@ #+allegro (excl:chdir x) #+clisp (ext:cd x) #+clozure (setf (ccl:current-directory) x) - #+(or cmu scl) (unix:unix-chdir (ext:unix-namestring x)) + #+(or cmucl scl) (unix:unix-chdir (ext:unix-namestring x)) #+cormanlisp (unless (zerop (win32::_chdir (namestring x))) (error "Could not set current directory to ~A" x)) #+(or clasp ecl) (ext:chdir x) @@ -1955,7 +1996,7 @@ #+lispworks (hcl:change-directory x) #+mkcl (mk-ext:chdir x) #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (sb-ext:native-namestring x))) - #-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl genera lispworks mkcl sbcl scl xcl) + #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mkcl sbcl scl xcl) (error "chdir not supported on your implementation")))) @@ -2076,7 +2117,8 @@ ;; Checking constraints #:ensure-pathname ;; implemented in filesystem.lisp to accommodate for existence constraints ;; Wildcard pathnames - #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* #:*wild-path* #:wilden + #:*wild* #:*wild-file* #:*wild-file-for-directory* #:*wild-directory* + #:*wild-inferiors* #:*wild-path* #:wilden ;; Translate a pathname #:relativize-directory-component #:relativize-pathname-directory #:directory-separator-for-host #:directorize-pathname-host-device @@ -2092,7 +2134,7 @@ implementation's MAKE-PATHNAME and other primitives to a CLHS-standard format that is a list and not a string." (cond - #-(or cmu sbcl scl) ;; these implementations already normalize directory components. + #-(or cmucl sbcl scl) ;; these implementations already normalize directory components. ((stringp directory) `(:absolute ,directory)) ((or (null directory) (and (consp directory) (member (first directory) '(:absolute :relative)))) @@ -2135,22 +2177,17 @@ ;; See CLHS make-pathname and 19.2.2.2.3. ;; This will be :unspecific if supported, or NIL if not. (defparameter *unspecific-pathname-type* - #+(or abcl allegro clozure cmu genera lispworks sbcl scl) :unspecific + #+(or abcl allegro clozure cmucl genera lispworks sbcl scl) :unspecific #+(or clasp clisp ecl mkcl gcl xcl #|These haven't been tested:|# cormanlisp mcl) nil "Unspecific type component to use with the underlying implementation's MAKE-PATHNAME") - (defun make-pathname* (&rest keys &key (directory nil) - host (device () #+allegro devicep) name type version defaults + (defun make-pathname* (&rest keys &key directory host device name type version defaults #+scl &allow-other-keys) "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and tries hard to make a pathname that will actually behave as documented, - despite the peculiarities of each implementation" - ;; TODO: reimplement defaulting for MCL, whereby an explicit NIL should override the defaults. - (declare (ignorable host device directory name type version defaults)) - (apply 'make-pathname - (append - #+allegro (when (and devicep (null device)) `(:device :unspecific)) - keys))) + despite the peculiarities of each implementation. DEPRECATED: just use MAKE-PATHNAME." + (declare (ignore host device directory name type version defaults)) + (apply 'make-pathname keys)) (defun make-pathname-component-logical (x) "Make a pathname component suitable for use in a logical-pathname" @@ -2163,7 +2200,7 @@ (defun make-pathname-logical (pathname host) "Take a PATHNAME's directory, name, type and version components, and make a new pathname with corresponding components and specified logical HOST" - (make-pathname* + (make-pathname :host host :directory (make-pathname-component-logical (pathname-directory pathname)) :name (make-pathname-component-logical (pathname-name pathname)) @@ -2206,10 +2243,10 @@ (pathname-device defaults) (merge-pathname-directory-components directory (pathname-directory defaults)) (unspecific-handler defaults)))) - (make-pathname* :host host :device device :directory directory - :name (funcall unspecific-handler name) - :type (funcall unspecific-handler type) - :version (funcall unspecific-handler version)))))) + (make-pathname :host host :device device :directory directory + :name (funcall unspecific-handler name) + :type (funcall unspecific-handler type) + :version (funcall unspecific-handler version)))))) (defun logical-pathname-p (x) "is X a logical-pathname?" @@ -2234,13 +2271,13 @@ ;; But CMUCL decides to die on NIL. ;; MCL has issues with make-pathname, nil and defaulting (declare (ignorable defaults)) - #.`(make-pathname* :directory nil :name nil :type nil :version nil - :device (or #+(and mkcl unix) :unspecific) - :host (or #+cmu lisp::*unix-host* #+(and mkcl unix) "localhost") - #+scl ,@'(:scheme nil :scheme-specific-part nil - :username nil :password nil :parameters nil :query nil :fragment nil) - ;; the default shouldn't matter, but we really want something physical - #-mcl ,@'(:defaults defaults))) + #.`(make-pathname :directory nil :name nil :type nil :version nil + :device (or #+(and mkcl unix) :unspecific) + :host (or #+cmucl lisp::*unix-host* #+(and mkcl unix) "localhost") + #+scl ,@'(:scheme nil :scheme-specific-part nil + :username nil :password nil :parameters nil :query nil :fragment nil) + ;; the default shouldn't matter, but we really want something physical + #-mcl ,@'(:defaults defaults))) (defvar *nil-pathname* (nil-pathname (physicalize-pathname (user-homedir-pathname))) "A pathname that is as neutral as possible for use as defaults @@ -2318,9 +2355,9 @@ Returns the (parsed) PATHNAME when true" (when pathname - (let* ((pathname (pathname pathname)) - (name (pathname-name pathname))) - (when (not (member name '(nil :unspecific "") :test 'equal)) + (let ((pathname (pathname pathname))) + (unless (and (member (pathname-name pathname) '(nil :unspecific "") :test 'equal) + (member (pathname-type pathname) '(nil :unspecific "") :test 'equal)) pathname))))) @@ -2337,10 +2374,10 @@ i.e. removing one level of depth in the DIRECTORY component. e.g. if pathname is Unix pathname /foo/bar/baz/file.type then return /foo/bar/" (when pathname - (make-pathname* :name nil :type nil :version nil - :directory (merge-pathname-directory-components - '(:relative :back) (pathname-directory pathname)) - :defaults pathname))) + (make-pathname :name nil :type nil :version nil + :directory (merge-pathname-directory-components + '(:relative :back) (pathname-directory pathname)) + :defaults pathname))) (defun directory-pathname-p (pathname) "Does PATHNAME represent a directory? @@ -2375,11 +2412,13 @@ ((directory-pathname-p pathspec) pathspec) (t - (make-pathname* :directory (append (or (normalize-pathname-directory-component - (pathname-directory pathspec)) - (list :relative)) - (list (file-namestring pathspec))) - :name nil :type nil :version nil :defaults pathspec))))) + (handler-case + (make-pathname :directory (append (or (normalize-pathname-directory-component + (pathname-directory pathspec)) + (list :relative)) + (list (file-namestring pathspec))) + :name nil :type nil :version nil :defaults pathspec) + (error (c) (call-function on-error (compatfmt "~@") pathspec c))))))) ;;; Parsing filenames @@ -2512,7 +2551,7 @@ (t (split-name-type filename))) (apply 'ensure-pathname - (make-pathname* + (make-pathname :directory (unless file-only (cons relative path)) :name name :type type :defaults (or #-mcl defaults *nil-pathname*)) @@ -2581,19 +2620,19 @@ (defun pathname-root (pathname) "return the root directory for the host and device of given PATHNAME" - (make-pathname* :directory '(:absolute) - :name nil :type nil :version nil - :defaults pathname ;; host device, and on scl, *some* - ;; scheme-specific parts: port username password, not others: - . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) + (make-pathname :directory '(:absolute) + :name nil :type nil :version nil + :defaults pathname ;; host device, and on scl, *some* + ;; scheme-specific parts: port username password, not others: + . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) (defun pathname-host-pathname (pathname) "return a pathname with the same host as given PATHNAME, and all other fields NIL" - (make-pathname* :directory nil - :name nil :type nil :version nil :device nil - :defaults pathname ;; host device, and on scl, *some* - ;; scheme-specific parts: port username password, not others: - . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) + (make-pathname :directory nil + :name nil :type nil :version nil :device nil + :defaults pathname ;; host device, and on scl, *some* + ;; scheme-specific parts: port username password, not others: + . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) (defun ensure-absolute-pathname (path &optional defaults (on-error 'error)) "Given a pathname designator PATH, return an absolute pathname as specified by PATH @@ -2658,14 +2697,18 @@ (defparameter *wild-file* (make-pathname :directory nil :name *wild* :type *wild* :version (or #-(or allegro abcl xcl) *wild*)) - "A pathname object with wildcards for matching any file in a given directory") + "A pathname object with wildcards for matching any file with TRANSLATE-PATHNAME") + (defparameter *wild-file-for-directory* + (make-pathname :directory nil :name *wild* :type (or #-(or clisp gcl) *wild*) + :version (or #-(or allegro abcl clisp gcl xcl) *wild*)) + "A pathname object with wildcards for matching any file with DIRECTORY") (defparameter *wild-directory* - (make-pathname* :directory `(:relative ,*wild-directory-component*) - :name nil :type nil :version nil) + (make-pathname :directory `(:relative ,*wild-directory-component*) + :name nil :type nil :version nil) "A pathname object with wildcards for matching any subdirectory") (defparameter *wild-inferiors* - (make-pathname* :directory `(:relative ,*wild-inferiors-component*) - :name nil :type nil :version nil) + (make-pathname :directory `(:relative ,*wild-inferiors-component*) + :name nil :type nil :version nil) "A pathname object with wildcards for matching any recursive subdirectory") (defparameter *wild-path* (merge-pathnames* *wild-file* *wild-inferiors*) @@ -2692,13 +2735,13 @@ (defun relativize-pathname-directory (pathspec) "Given a PATHNAME, return a relative pathname with otherwise the same components" (let ((p (pathname pathspec))) - (make-pathname* + (make-pathname :directory (relativize-directory-component (pathname-directory p)) :defaults p))) (defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*)) "Given a PATHNAME, return the character used to delimit directory names on this host and device." - (let ((foo (make-pathname* :directory '(:absolute "FOO") :defaults pathname))) + (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname))) (last-char (namestring foo)))) #-scl @@ -2722,8 +2765,7 @@ (multiple-value-bind (relative path filename) (split-unix-namestring-directory-components root-string :ensure-directory t) (declare (ignore relative filename)) - (let ((new-base - (make-pathname* :defaults root :directory `(:absolute ,@path)))) + (let ((new-base (make-pathname :defaults root :directory `(:absolute ,@path)))) (translate-pathname absolute-pathname wild-root (wilden new-base)))))) #+scl @@ -2745,8 +2787,8 @@ (when (specificp scheme) (setf prefix (strcat scheme prefix))) (assert (and directory (eq (first directory) :absolute))) - (make-pathname* :directory `(:absolute ,prefix ,@(rest directory)) - :defaults pathname))) + (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) + :defaults pathname))) pathname))) (defun* (translate-pathname*) (path absolute-source destination &optional root source) @@ -2817,9 +2859,9 @@ (when x (let ((p (pathname x))) #+clozure (with-pathname-defaults () (ccl:native-translated-namestring p)) ; see ccl bug 978 - #+(or cmu scl) (ext:unix-namestring p nil) + #+(or cmucl scl) (ext:unix-namestring p nil) #+sbcl (sb-ext:native-namestring p) - #-(or clozure cmu sbcl scl) + #-(or clozure cmucl sbcl scl) (os-cond ((os-unix-p) (unix-namestring p)) (t (namestring p)))))) @@ -2832,8 +2874,10 @@ (when string (with-pathname-defaults () #+clozure (ccl:native-to-pathname string) + #+cmucl (uiop/os::parse-unix-namestring* string) #+sbcl (sb-ext:parse-native-namestring string) - #-(or clozure sbcl) + #+scl (lisp::parse-unix-namestring string) + #-(or clozure cmucl sbcl scl) (os-cond ((os-unix-p) (parse-unix-namestring string :ensure-directory ensure-directory)) (t (parse-namestring string)))))) @@ -2854,7 +2898,7 @@ (or (ignore-errors (truename p)) ;; this is here because trying to find the truename of a directory pathname WITHOUT supplying ;; a trailing directory separator, causes an error on some lisps. - #+(or clisp gcl) (if-let (d (ensure-directory-pathname p)) (ignore-errors (truename d))))))) + #+(or clisp gcl) (if-let (d (ensure-directory-pathname p nil)) (ignore-errors (truename d))))))) (defun safe-file-write-date (pathname) "Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error." @@ -2918,10 +2962,10 @@ (if truename (probe-file p) (and - #+(or cmu scl) (unix:unix-stat (ext:unix-namestring p)) + #+(or cmucl scl) (unix:unix-stat (ext:unix-namestring p)) #+(and lispworks unix) (system:get-file-stat p) #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring p)) - #-(or cmu (and lispworks unix) sbcl scl) (file-write-date p) + #-(or cmucl (and lispworks unix) sbcl scl) (file-write-date p) p)))))) (defun directory-exists-p (x) @@ -2948,17 +2992,20 @@ (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil) #+(or clozure digitool) '(:follow-links nil) #+clisp '(:circle t :if-does-not-exist :ignore) - #+(or cmu scl) '(:follow-links nil :truenamep nil) + #+(or cmucl scl) '(:follow-links nil :truenamep nil) #+lispworks '(:link-transparency nil) #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil) '(:resolve-symlinks nil)))))) (defun filter-logical-directory-results (directory entries merger) - "Given ENTRIES in a DIRECTORY, remove if the directory is logical -the entries which are physical yet when transformed by MERGER have a different TRUENAME. -This function is used as a helper to DIRECTORY-FILES to avoid invalid entries when using logical-pathnames." - (remove-duplicates ;; on CLISP, querying ~/ will return duplicates - (if (logical-pathname-p directory) + "If DIRECTORY isn't a logical pathname, return ENTRIES. If it is, +given ENTRIES in the DIRECTORY, remove the entries which are physical yet +when transformed by MERGER have a different TRUENAME. +Also remove duplicates as may appear with some translation rules. +This function is used as a helper to DIRECTORY-FILES to avoid invalid entries +when using logical-pathnames." + (if (logical-pathname-p directory) + (remove-duplicates ;; on CLISP, querying ~/ will return duplicates ;; Try hard to not resolve logical-pathname into physical pathnames; ;; otherwise logical-pathname users/lovers will be disappointed. ;; If directory* could use some implementation-dependent magic, @@ -2972,12 +3019,11 @@ ;; At this point f should already be a truename, ;; but isn't quite in CLISP, for it doesn't have :version :newest (and u (equal (truename* u) (truename* f)) u))) - :when p :collect p) - entries) - :test 'pathname-equal)) + :when p :collect p) + :test 'pathname-equal) + entries)) - - (defun directory-files (directory &optional (pattern *wild-file*)) + (defun directory-files (directory &optional (pattern *wild-file-for-directory*)) "Return a list of the files in a directory according to the PATTERN. Subdirectories should NOT be returned. PATTERN defaults to a pattern carefully chosen based on the implementation; @@ -2995,10 +3041,7 @@ (error "Invalid file pattern ~S for logical directory ~S" pattern directory)) (setf pattern (make-pathname-logical pattern (pathname-host dir)))) (let* ((pat (merge-pathnames* pattern dir)) - (entries (append (ignore-errors (directory* pat)) - #+(or clisp gcl) - (when (equal :wild (pathname-type pattern)) - (ignore-errors (directory* (make-pathname :type nil :defaults pat))))))) + (entries (ignore-errors (directory* pat)))) (remove-if 'directory-pathname-p (filter-logical-directory-results directory entries @@ -3014,9 +3057,9 @@ (let* ((directory (ensure-directory-pathname directory)) #-(or abcl cormanlisp genera xcl) (wild (merge-pathnames* - #-(or abcl allegro cmu lispworks sbcl scl xcl) + #-(or abcl allegro cmucl lispworks sbcl scl xcl) *wild-directory* - #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*" + #+(or abcl allegro cmucl lispworks sbcl scl xcl) "*.*" directory)) (dirs #-(or abcl cormanlisp genera xcl) @@ -3025,17 +3068,17 @@ #+mcl '(:directories t)))) #+(or abcl xcl) (system:list-directory directory) #+cormanlisp (cl::directory-subdirs directory) - #+genera (fs:directory-list directory)) - #+(or abcl allegro cmu genera lispworks sbcl scl xcl) + #+genera (handler-case (fs:directory-list directory) (fs:directory-not-found () nil))) + #+(or abcl allegro cmucl genera lispworks sbcl scl xcl) (dirs (loop :for x :in dirs :for d = #+(or abcl xcl) (extensions:probe-directory x) #+allegro (excl:probe-directory x) - #+(or cmu sbcl scl) (directory-pathname-p x) + #+(or cmucl sbcl scl) (directory-pathname-p x) #+genera (getf (cdr x) :directory) #+lispworks (lw:file-directory-p x) - :when d :collect #+(or abcl allegro xcl) d + :when d :collect #+(or abcl allegro xcl) (ensure-directory-pathname d) #+genera (ensure-directory-pathname (first x)) - #+(or cmu lispworks sbcl scl) x))) + #+(or cmucl lispworks sbcl scl) x))) (filter-logical-directory-results directory dirs (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory)) @@ -3080,13 +3123,13 @@ (loop :while up-components :do (if-let (parent (ignore-errors - (probe-file* (make-pathname* :directory `(:absolute ,@(reverse up-components)) - :name nil :type nil :version nil :defaults p)))) + (probe-file* (make-pathname :directory `(:absolute ,@(reverse up-components)) + :name nil :type nil :version nil :defaults p)))) (if-let (simplified (ignore-errors (merge-pathnames* - (make-pathname* :directory `(:relative ,@down-components) - :defaults p) + (make-pathname :directory `(:relative ,@down-components) + :defaults p) (ensure-directory-pathname parent)))) (return simplified))) (push (pop up-components) down-components) @@ -3327,15 +3370,19 @@ (defun lisp-implementation-directory (&key truename) "Where are the system files of the current installation of the CL implementation?" (declare (ignorable truename)) - #+(or clasp clozure ecl gcl mkcl sbcl) (let ((dir - (ignore-errors - #+clozure #p"ccl:" - #+(or clasp ecl mkcl) #p"SYS:" - #+gcl system::*system-directory* - #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil)) - (funcall it) - (getenv-pathname "SBCL_HOME" :ensure-directory t))))) + #+abcl extensions:*lisp-home* + #+(or allegro clasp ecl mkcl) #p"SYS:" + #+clisp custom:*lib-directory* + #+clozure #p"ccl:" + #+cmucl (ignore-errors (pathname-parent-directory-pathname (truename #p"modules:"))) + #+gcl system::*system-directory* + #+lispworks lispworks:*lispworks-directory* + #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil)) + (funcall it) + (getenv-pathname "SBCL_HOME" :ensure-directory t)) + #+scl (ignore-errors (pathname-parent-directory-pathname (truename #p"file://modules/"))) + #+xcl ext:*xcl-home*)) (if (and dir truename) (truename* dir) dir))) @@ -3368,13 +3415,16 @@ (defun rename-file-overwriting-target (source target) "Rename a file, overwriting any previous file with the TARGET name, in an atomic way if the implementation allows." - #+clisp ;; in recent enough versions of CLISP, :if-exists :overwrite would make it atomic - (progn (funcall 'require "syscalls") - (symbol-call :posix :copy-file source target :method :rename)) - #+(and sbcl os-windows) (delete-file-if-exists target) ;; not atomic - #-clisp - (rename-file source target - #+(or clasp clozure ecl) :if-exists #+clozure :rename-and-delete #+(or clasp ecl) t)) + (let ((source (ensure-pathname source :namestring :lisp :ensure-physical t :want-file t)) + (target (ensure-pathname target :namestring :lisp :ensure-physical t :want-file t))) + #+clisp ;; in recent enough versions of CLISP, :if-exists :overwrite would make it atomic + (progn (funcall 'require "syscalls") + (symbol-call :posix :copy-file source target :method :rename)) + #+(and sbcl os-windows) (delete-file-if-exists target) ;; not atomic + #-clisp + (rename-file source target + #+(or clasp clozure ecl) :if-exists + #+clozure :rename-and-delete #+(or clasp ecl) t))) (defun delete-empty-directory (directory-pathname) "Delete an empty directory" @@ -3382,10 +3432,10 @@ #+allegro (excl:delete-directory directory-pathname) #+clisp (ext:delete-directory directory-pathname) #+clozure (ccl::delete-empty-directory directory-pathname) - #+(or cmu scl) (multiple-value-bind (ok errno) + #+(or cmucl scl) (multiple-value-bind (ok errno) (unix:unix-rmdir (native-namestring directory-pathname)) (unless ok - #+cmu (error "Error number ~A when trying to delete directory ~A" + #+cmucl (error "Error number ~A when trying to delete directory ~A" errno directory-pathname) #+scl (error "~@" directory-pathname (unix:get-unix-error-msg errno)))) @@ -3398,8 +3448,8 @@ `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname))) #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname))) - #-(or abcl allegro clasp clisp clozure cmu cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl) - (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera + #-(or abcl allegro clasp clisp clozure cmucl cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl) + (not-implemented-error 'delete-empty-directory "(on your platform)")) ; genera (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error)) "Delete a directory including all its recursive contents, aka rm -rf. @@ -3432,7 +3482,7 @@ (error "~S was asked to delete ~S but the directory does not exist" 'delete-directory-tree directory-pathname)) (:ignore nil))) - #-(or allegro cmu clozure genera sbcl scl) + #-(or allegro cmucl clozure genera sbcl scl) ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp, ;; except on implementations where we can prevent DIRECTORY from following symlinks; ;; instead spawn a standard external program to do the dirty work. @@ -3481,6 +3531,7 @@ #:read-file-forms #:read-file-form #:safe-read-file-form #:eval-input #:eval-thunk #:standard-eval-thunk #:println #:writeln + #:file-stream-p #:file-or-synonym-stream-p ;; Temporary files #:*temporary-directory* #:temporary-directory #:default-temporary-directory #:setup-temporary-directory @@ -3491,7 +3542,7 @@ (with-upgradability () (defvar *default-stream-element-type* - (or #+(or abcl cmu cormanlisp scl xcl) 'character + (or #+(or abcl cmucl cormanlisp scl xcl) 'character #+lispworks 'lw:simple-char :default) "default element-type for open (depends on the current CL implementation)") @@ -3502,7 +3553,7 @@ (defun setup-stdin () (setf *stdin* #.(or #+clozure 'ccl::*stdin* - #+(or cmu scl) 'system:*stdin* + #+(or cmucl scl) 'system:*stdin* #+(or clasp ecl) 'ext::+process-standard-input+ #+sbcl 'sb-sys:*stdin* '*standard-input*))) @@ -3513,7 +3564,7 @@ (defun setup-stdout () (setf *stdout* #.(or #+clozure 'ccl::*stdout* - #+(or cmu scl) 'system:*stdout* + #+(or cmucl scl) 'system:*stdout* #+(or clasp ecl) 'ext::+process-standard-output+ #+sbcl 'sb-sys:*stdout* '*standard-output*))) @@ -3525,7 +3576,7 @@ (setf *stderr* #.(or #+allegro 'excl::*stderr* #+clozure 'ccl::*stderr* - #+(or cmu scl) 'system:*stderr* + #+(or cmucl scl) 'system:*stderr* #+(or clasp ecl) 'ext::+process-error-output+ #+sbcl 'sb-sys:*stderr* '*error-output*))) @@ -3810,7 +3861,7 @@ (when eof (return))) (loop :with buffer-size = (or buffer-size 8192) - :for buffer = (make-array (list buffer-size) :element-type (or element-type 'character)) + :with buffer = (make-array (list buffer-size) :element-type (or element-type 'character)) :for end = (read-sequence buffer input) :until (zerop end) :do (write-sequence buffer output :end end) @@ -3828,6 +3879,11 @@ (defun copy-file (input output) "Copy contents of the INPUT file to the OUTPUT file" ;; Not available on LW personal edition or LW 6.0 on Mac: (lispworks:copy-file i f) + #+allegro + (excl.osi:copy-file input output) + #+ecl + (ext:copy-file input output) + #-(or allegro ecl) (concatenate-files (list input) output)) (defun slurp-stream-string (input &key (element-type 'character) stripped) @@ -4013,7 +4069,7 @@ "Call a THUNK with stream and/or pathname arguments identifying a temporary file. The temporary file's pathname will be based on concatenating -PREFIX (defaults to \"uiop\"), a random alphanumeric string, +PREFIX (or \"tmp\" if it's NIL), a random alphanumeric string, and optional SUFFIX (defaults to \"-tmp\" if a type was provided) and TYPE (defaults to \"tmp\", using a dot as separator if not NIL), within DIRECTORY (defaulting to the TEMPORARY-DIRECTORY) if the PREFIX isn't absolute. @@ -4023,7 +4079,7 @@ EXTERNAL-FORMAT (defaults to *UTF-8-EXTERNAL-FORMAT*). If WANT-STREAM-P is true (the defaults to T), then THUNK will then be CALL-FUNCTION'ed with the stream and the pathname (if WANT-PATHNAME-P is true, defaults to T), -and stream with be closed after the THUNK exits (either normally or abnormally). +and stream will be closed after the THUNK exits (either normally or abnormally). If WANT-STREAM-P is false, then WANT-PATHAME-P must be true, and then THUNK is only CALL-FUNCTION'ed after the stream is closed, with the pathname as argument. Upon exit of THUNK, the AFTER thunk if defined is CALL-FUNCTION'ed with the pathname as argument. @@ -4033,16 +4089,21 @@ (check-type direction (member :output :io)) (assert (or want-stream-p want-pathname-p)) (loop - :with prefix = (native-namestring - (ensure-absolute-pathname - (or prefix "tmp") - (or (ensure-pathname directory :namestring :native :ensure-directory t) - #'temporary-directory))) - :with results = () + :with prefix-pn = (ensure-absolute-pathname + (or prefix "tmp") + (or (ensure-pathname + directory + :namestring :native + :ensure-directory t + :ensure-physical t) + #'temporary-directory)) + :with prefix-nns = (native-namestring prefix-pn) + :with results = (progn (ensure-directories-exist prefix-pn) + ()) :for counter :from (random (expt 36 #-gcl 8 #+gcl 5)) :for pathname = (parse-native-namestring (format nil "~A~36R~@[~A~]~@[.~A~]" - prefix counter suffix (unless (eq type :unspecific) type))) + prefix-nns counter suffix (unless (eq type :unspecific) type))) :for okp = nil :do ;; TODO: on Unix, do something about umask ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL @@ -4051,6 +4112,7 @@ ;; Can we at least design some hook? (unwind-protect (progn + (ensure-directories-exist pathname) (with-open-file (stream pathname :direction direction :element-type element-type @@ -4133,10 +4195,10 @@ "Return a new pathname modified from X by adding a trivial random suffix. A new empty file with said temporary pathname is created, to ensure there is no clash with any concurrent process attempting the same thing." - (let* ((px (ensure-pathname x)) - (prefix (if-let (n (pathname-name px)) (strcat n "-tmp") "tmp"))) - (get-temporary-file - :directory (pathname-directory-pathname px) :prefix prefix :type (pathname-type px)))) + (let* ((px (ensure-pathname x :ensure-physical t)) + (prefix (if-let (n (pathname-name px)) (strcat n "-tmp") "tmp")) + (directory (pathname-directory-pathname px))) + (get-temporary-file :directory directory :prefix prefix :type (pathname-type px)))) (defun call-with-staging-pathname (pathname fun) "Calls FUN with a staging pathname, and atomically @@ -4154,6 +4216,15 @@ (defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body) "Trivial syntax wrapper for CALL-WITH-STAGING-PATHNAME" `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body)))) + +(with-upgradability () + (defun file-stream-p (stream) + (typep stream 'file-stream)) + (defun file-or-synonym-stream-p (stream) + (or (file-stream-p stream) + (and (typep stream 'synonym-stream) + (file-or-synonym-stream-p + (symbol-value (synonym-stream-symbol stream))))))) ;;;; ------------------------------------------------------------------------- ;;;; Starting, Stopping, Dumping a Lisp image @@ -4165,7 +4236,8 @@ #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments* #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments #:argv0 #:*lisp-interaction* - #:*fatal-conditions* #:fatal-condition-p #:handle-fatal-condition + #:fatal-condition #:fatal-condition-p + #:handle-fatal-condition #:call-with-fatal-condition-handler #:with-fatal-condition-handler #:*image-restore-hook* #:*image-prelude* #:*image-entry-point* #:*image-postlude* #:*image-dump-hook* @@ -4207,10 +4279,8 @@ (defvar *image-dump-hook* nil "Functions to call (in order) when before an image is dumped") - (defvar *fatal-conditions* '(error) - "conditions that cause the Lisp image to enter the debugger if interactive, -or to die if not interactive")) - + (deftype fatal-condition () + `(and serious-condition #+clozure (not ccl:process-reset)))) ;;; Exiting properly or im- (with-upgradability () @@ -4225,7 +4295,7 @@ #+clisp (ext:quit code) #+clozure (ccl:quit code) #+cormanlisp (win32:exitprocess code) - #+(or cmu scl) (unix:unix-exit code) + #+(or cmucl scl) (unix:unix-exit code) #+gcl (system:quit code) #+genera (error "~S: You probably don't want to Halt Genera. (code: ~S)" 'quit code) #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t) @@ -4236,7 +4306,7 @@ (cond (exit `(,exit :code code :abort (not finish-output))) (quit `(,quit :unix-status code :recklessly-p (not finish-output))))) - #-(or abcl allegro clasp clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl) + #-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code)) (defun die (code format &rest arguments) @@ -4279,7 +4349,7 @@ #+clozure (ccl:print-call-history :count count :start-frame-number 1) #+mcl (ccl:print-call-history :detailed-p nil) (finish-output stream)) - #+(or cmu scl) + #+(or cmucl scl) (let ((debug:*debug-print-level* *print-level*) (debug:*debug-print-length* *print-length*)) (debug:backtrace (or count most-positive-fixnum) stream)) @@ -4298,9 +4368,7 @@ (dbg:*debug-print-length* *print-length*)) (dbg:bug-backtrace nil)) #+sbcl - (sb-debug:backtrace - #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream '(or count most-positive-fixnum)) - stream) + (sb-debug:print-backtrace :stream stream :count (or count most-positive-fixnum)) #+xcl (loop :for i :from 0 :below (or count most-positive-fixnum) :for frame :in (extensions:backtrace-as-list) :do @@ -4329,8 +4397,8 @@ condition))) (defun fatal-condition-p (condition) - "Is the CONDITION fatal? It is if it matches any in *FATAL-CONDITIONS*" - (match-any-condition-p condition *fatal-conditions*)) + "Is the CONDITION fatal?" + (typep condition 'fatal-condition)) (defun handle-fatal-condition (condition) "Handle a fatal CONDITION: @@ -4345,7 +4413,7 @@ (defun call-with-fatal-condition-handler (thunk) "Call THUNK in a context where fatal conditions are appropriately handled" - (handler-bind (((satisfies fatal-condition-p) #'handle-fatal-condition)) + (handler-bind ((fatal-condition #'handle-fatal-condition)) (funcall thunk))) (defmacro with-fatal-condition-handler ((&optional) &body body) @@ -4385,15 +4453,15 @@ #+(or clasp ecl) (loop :for i :from 0 :below (si:argc) :collect (si:argv i)) #+clisp (coerce (ext:argv) 'list) #+clozure ccl:*command-line-argument-list* - #+(or cmu scl) extensions:*command-line-strings* + #+(or cmucl scl) extensions:*command-line-strings* #+gcl si:*command-args* #+(or genera mcl) nil #+lispworks sys:*line-arguments-list* #+mkcl (loop :for i :from 0 :below (mkcl:argc) :collect (mkcl:argv i)) #+sbcl sb-ext:*posix-argv* #+xcl system:*argv* - #-(or abcl allegro clasp clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl) - (error "raw-command-line-arguments not implemented yet")) + #-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mkcl sbcl scl xcl) + (not-implemented-error 'raw-command-line-arguments)) (defun command-line-arguments (&optional (arguments (raw-command-line-arguments))) "Extract user arguments from command-line invocation of current process. @@ -4421,7 +4489,7 @@ (cond ((eq *image-dumped-p* :executable) ; yes, this ARGV0 is our argv0 ! ;; NB: not currently available on ABCL, Corman, Genera, MCL - (or #+(or allegro clisp clozure cmu gcl lispworks sbcl scl xcl) + (or #+(or allegro clisp clozure cmucl gcl lispworks sbcl scl xcl) (first (raw-command-line-arguments)) #+(or clasp ecl) (si:argv 0) #+mkcl (mkcl:argv 0))) (t ;; argv[0] is the name of the interpreter. @@ -4511,7 +4579,7 @@ (setf *image-dump-hook* dump-hook) (call-image-dump-hook) (setf *image-restored-p* nil) - #-(or clisp clozure cmu lispworks sbcl scl) + #-(or clisp clozure cmucl lispworks sbcl scl) (when executable (error "Dumping an executable is not supported on this implementation! Aborting.")) #+allegro @@ -4539,13 +4607,13 @@ (funcall (fdefinition 'ccl::write-elf-symbols-to-file) path) (dump path)) (dump t))) - #+(or cmu scl) + #+(or cmucl scl) (progn (ext:gc :full t) (setf ext:*batch-mode* nil) (setf ext::*gc-run-time* 0) (apply 'ext:save-lisp filename - #+cmu :executable #+cmu t + #+cmucl :executable #+cmucl t (when executable '(:init-function restore-image :process-command-line nil)))) #+gcl (progn @@ -4568,7 +4636,7 @@ #+(and sbcl os-windows) ;; passing :application-type :gui will disable the console window. ;; the default is :console - only works with SBCL 1.1.15 or later. (when application-type (list :application-type application-type))))) - #-(or allegro clisp clozure cmu gcl lispworks sbcl scl) + #-(or allegro clisp clozure cmucl gcl lispworks sbcl scl) (error "Can't ~S ~S: UIOP doesn't support image dumping with ~A.~%" 'dump-image filename (nth-value 1 (implementation-type)))) @@ -4583,7 +4651,7 @@ ;; Is it meaningful to run these in the current environment? ;; only if we also track the object files that constitute the "current" image, ;; and otherwise simulate dump-image, including quitting at the end. - #-(or clasp ecl mkcl) (error "~S not implemented for your implementation (yet)" 'create-image) + #-(or clasp ecl mkcl) (not-implemented-error 'create-image) #+(or clasp ecl mkcl) (let ((epilogue-code (if no-uiop @@ -4644,7 +4712,10 @@ ;;; run-program #:slurp-input-stream #:vomit-output-stream - #:run-program + #:close-streams #:launch-program #:process-alive-p #:run-program + #:terminate-process #:wait-process + #:process-info-error-output #:process-info-input #:process-info-output + #:process-info-pid #:subprocess-error #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process )) @@ -4984,13 +5055,13 @@ #+os-unix (list command) #+os-windows (string - #+mkcl (list "cmd" "/c" command) ;; NB: We do NOT add cmd /c here. You might want to. #+(or allegro clisp) command ;; On ClozureCL for Windows, we assume you are using ;; r15398 or later in 1.9 or later, ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858 #+clozure (cons "cmd" (strcat "/c " command)) + #+mkcl (list "cmd" "/c" command) #+sbcl (list (%cmd-shell-pathname) "/c" command) ;; NB: On other Windows implementations, this is utterly bogus ;; except in the most trivial cases where no quoting is needed. @@ -5006,8 +5077,8 @@ via SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM (return T), or whether it's already taken care of by the implementation's underlying run-program." (not (typep specifier '(or null string pathname (member :interactive :output) - #+(or cmu (and sbcl os-unix) scl) (or stream (eql t)) - #+lispworks file-stream)))) ;; not a type!? comm:socket-stream + #+(or cmucl (and sbcl os-unix) scl) (or stream (eql t)) + #+lispworks file-stream)))) (defun %normalize-io-specifier (specifier &optional role) "Normalizes a portable I/O specifier for %RUN-PROGRAM into an implementation-dependent @@ -5022,28 +5093,48 @@ ((eql :interactive) #+allegro nil #+clisp :terminal - #+(or clasp clozure cmu ecl mkcl sbcl scl) t) - #+(or allegro clasp clozure cmu ecl lispworks mkcl sbcl scl) + #+(or clozure cmucl ecl mkcl sbcl scl) t) + #+(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl) ((eql :output) (if (eq role :error-output) :output (error "Wrong specifier ~S for role ~S" specifier role))))) + (defun %normalize-if-exists (action) + (ecase action + (:supersede #+clisp :overwrite #-clisp action) + ((:append :error) action))) + (defun %interactivep (input output error-output) (member :interactive (list input output error-output))) - #+clisp - (defun clisp-exit-code (raw-exit-code) - (typecase raw-exit-code - (null 0) ; no error - (integer raw-exit-code) ; negative: signal - (t -1))) + (defun %signal-to-exit-code (signum) + (+ 128 signum)) + + #+mkcl + (defun %mkcl-signal-to-number (signal) + (require :mk-unix) + (symbol-value (find-symbol signal :mk-unix))) + + (defclass process-info () + ((process :initform nil) + (input-stream :initform nil) + (output-stream :initform nil) + (bidir-stream :initform nil) + (error-output-stream :initform nil) + ;; For backward-compatibility, to maintain the property (zerop + ;; exit-code) <-> success, an exit in response to a signal is + ;; encoded as 128+signum. + (exit-code :initform nil) + ;; If the platform allows it, distinguish exiting with a code + ;; >128 from exiting in response to a signal by setting this code + (signal-code :initform nil))) (defun %run-program (command &rest keys &key input (if-input-does-not-exist :error) - output (if-output-exists :overwrite) - error-output (if-error-output-exists :overwrite) + output (if-output-exists :supersede) + error-output (if-error-output-exists :supersede) directory wait #+allegro separate-streams &allow-other-keys) @@ -5051,180 +5142,328 @@ It spawns a subprocess that runs the specified COMMAND (a list of program and arguments). INPUT, OUTPUT and ERROR-OUTPUT specify a portable IO specifer, to be normalized by %NORMALIZE-IO-SPECIFIER. -It returns a process-info plist with possible keys: - PROCESS, EXIT-CODE, INPUT-STREAM, OUTPUT-STREAM, BIDIR-STREAM, ERROR-STREAM." - ;; NB: these implementations have unix vs windows set at compile-time. +It returns a process-info object." + ;; NB: these implementations have Unix vs Windows set at compile-time. (declare (ignorable directory if-input-does-not-exist if-output-exists if-error-output-exists)) - (assert (not (and wait (member :stream (list input output error-output))))) - #-(or allegro clasp clisp clozure cmu ecl (and lispworks os-unix) mkcl sbcl scl) - (progn command keys directory - (error "run-program not available")) - #+(or allegro clisp clozure cmu ecl (and lispworks os-unix) mkcl sbcl scl) + #-(or abcl allegro clisp clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl) + (progn command keys input output error-output directory wait ;; ignore + (not-implemented-error '%run-program)) + #-(or abcl cmucl ecl mkcl sbcl) + (when (and wait (member :stream (list input output error-output))) + (parameter-error "~S: I/O parameters cannot be ~S when ~S is ~S on this lisp" + '%run-program :stream :wait t)) + #+allegro + (when (some #'(lambda (stream) + (and (streamp stream) + (not (file-stream-p stream)))) + (list input output error-output)) + (parameter-error "~S: Streams passed as I/O parameters need to be file streams on this lisp" + '%run-program)) + #+(or abcl clisp lispworks) + (when (some #'streamp (list input output error-output)) + (parameter-error "~S: I/O parameters cannot be foreign streams on this lisp" + '%run-program)) + #+clisp + (unless (eq error-output :interactive) + (parameter-error "~S: The only admissible value for ~S is ~S on this lisp" + '%run-program :error-output :interactive)) + #+clisp + (when (or (stringp input) (pathnamep input)) + (unless (file-exists-p input) + (parameter-error "~S: Files passed as arguments to ~S need to exist on this lisp" + '%run-program :input))) + #+ecl + (when (some #'(lambda (stream) + (and (streamp stream) + (not (file-or-synonym-stream-p stream)))) + (list input output error-output)) + (parameter-error "~S: Streams passed as I/O parameters need to be (synonymous with) file streams on this lisp" + '%run-program)) + #+(or abcl allegro clisp clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl) (let* ((%command (%normalize-command command)) + (%if-output-exists (%normalize-if-exists if-output-exists)) (%input (%normalize-io-specifier input :input)) (%output (%normalize-io-specifier output :output)) (%error-output (%normalize-io-specifier error-output :error-output)) - #+(and allegro os-windows) (interactive (%interactivep input output error-output)) + #+(and allegro os-windows) + (interactive (%interactivep input output error-output)) (process* - #+allegro - (multiple-value-list + (nest + #-(or allegro mkcl sbcl) (with-current-directory (directory)) + #+(or allegro clisp ecl lispworks mkcl) (multiple-value-list) (apply - 'excl:run-shell-command - #+os-unix (coerce (cons (first %command) %command) 'vector) - #+os-windows %command - :input %input - :output %output - :error-output %error-output - :directory directory :wait wait - #+os-windows :show-window #+os-windows (if interactive nil :hide) - :allow-other-keys t keys)) - #-allegro - (with-current-directory (#-(or sbcl mkcl) directory) + #+abcl #'sys:run-program + #+allegro 'excl:run-shell-command + #+(and allegro os-unix) (coerce (cons (first %command) %command) 'vector) + #+(and allegro os-windows) %command #+clisp - (flet ((run (f x &rest args) - (multiple-value-list - (apply f x :input %input :output %output - :allow-other-keys t `(,@args ,@keys))))) - (assert (eq %error-output :terminal)) - ;;; since we now always return a code, we can't use this code path, anyway! - (etypecase %command - #+os-windows (string (run 'ext:run-shell-command %command)) - (list (run 'ext:run-program (car %command) - :arguments (cdr %command))))) - #+(or clasp clozure cmu ecl mkcl sbcl scl) - (#-(or clasp ecl mkcl) progn #+(or clasp ecl mkcl) multiple-value-list - (apply - '#+(or cmu ecl scl) ext:run-program - #+clozure ccl:run-program #+sbcl sb-ext:run-program #+mkcl mk-ext:run-program - (car %command) (cdr %command) - :input %input - :output %output - :error %error-output - :wait wait - :allow-other-keys t - (append - #+(or clozure cmu mkcl sbcl scl) - `(:if-input-does-not-exist ,if-input-does-not-exist - :if-output-exists ,if-output-exists - :if-error-exists ,if-error-output-exists) - #+sbcl `(:search t - :if-output-does-not-exist :create - :if-error-does-not-exist :create) - #-sbcl keys #+sbcl (if directory keys (remove-plist-key :directory keys))))) - #+(and lispworks os-unix) ;; note: only used on Unix in non-interactive case - (multiple-value-list - (apply - 'system:run-shell-command - (cons "/usr/bin/env" %command) ; lispworks wants a full path. - :input %input :if-input-does-not-exist if-input-does-not-exist - :output %output :if-output-exists if-output-exists - :error-output %error-output :if-error-output-exists if-error-output-exists - :wait wait :save-exit-status t :allow-other-keys t keys)))) - (process-info-r ())) - (flet ((prop (key value) (push key process-info-r) (push value process-info-r))) + (etypecase %command + #+os-windows + (string (lambda (&rest keys) (apply 'ext:run-shell-command %command keys))) + (list (lambda (&rest keys) + (apply 'ext:run-program (car %command) :arguments (cdr %command) keys)))) + #+clozure 'ccl:run-program + #+(or cmucl ecl scl) 'ext:run-program + #+lispworks 'system:run-shell-command + #+lispworks (cons "/usr/bin/env" %command) ; LW wants a full path + #+mkcl 'mk-ext:run-program + #+sbcl 'sb-ext:run-program + (append + #+(or abcl clozure cmucl ecl mkcl sbcl scl) `(,(car %command) ,(cdr %command)) + `(:input ,%input :output ,%output :wait ,wait :allow-other-keys t) + #-clisp `(#+(or allegro lispworks) :error-output #-(or allegro lispworks) :error + ,%error-output) + #+(and allegro os-windows) `(:show-window ,(if interactive nil :hide)) + #+clisp `(:if-output-exists ,%if-output-exists) + #+(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl) + `(:if-input-does-not-exist ,if-input-does-not-exist + :if-output-exists ,%if-output-exists + #-(or allegro lispworks) :if-error-exists + #+(or allegro lispworks) :if-error-output-exists + ,if-error-output-exists) + #+lispworks `(:save-exit-status t) + #+mkcl `(:directory ,(native-namestring directory)) + #+sbcl `(:search t) + #-sbcl keys + #+sbcl (if directory keys (remove-plist-key :directory keys)))))) + (process-info (make-instance 'process-info))) + #+clisp (declare (ignore %error-output)) + (labels ((prop (key value) (setf (slot-value process-info key) value)) + #+(or allegro clisp ecl lispworks mkcl) + (store-codes (exit-code &optional signal-code) + (if signal-code + (progn (prop 'exit-code (%signal-to-exit-code signal-code)) + (prop 'signal-code signal-code)) + (prop 'exit-code exit-code)))) #+allegro (cond - (wait (prop :exit-code (first process*))) + (wait (store-codes (first process*))) (separate-streams (destructuring-bind (in out err pid) process* - (prop :process pid) - (when (eq input :stream) (prop :input-stream in)) - (when (eq output :stream) (prop :output-stream out)) - (when (eq error-output :stream) (prop :error-stream err)))) + (prop 'process pid) + (when (eq input :stream) (prop 'input-stream in)) + (when (eq output :stream) (prop 'output-stream out)) + (when (eq error-output :stream) (prop 'error-stream err)))) (t - (prop :process (third process*)) + (prop 'process (third process*)) (let ((x (first process*))) (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)) (0) - (1 (prop :input-stream x)) - (2 (prop :output-stream x)) - (3 (prop :bidir-stream x)))) + (1 (prop 'input-stream x)) + (2 (prop 'output-stream x)) + (3 (prop 'bidir-stream x)))) (when (eq error-output :stream) - (prop :error-stream (second process*))))) + (prop 'error-stream (second process*))))) #+clisp - (cond - (wait (prop :exit-code (clisp-exit-code (first process*)))) - (t - (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)) - (0) - (1 (prop :input-stream (first process*))) - (2 (prop :output-stream (first process*))) - (3 (prop :bidir-stream (pop process*)) - (prop :input-stream (pop process*)) - (prop :output-stream (pop process*)))))) - #+(or clozure cmu sbcl scl) + (if wait + (let ((raw-exit-code (or (first process*) 0))) + (if (minusp raw-exit-code) + (store-codes 0 (- raw-exit-code)) + (store-codes raw-exit-code))) + (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)) + (0) + (1 (prop 'input-stream (first process*))) + (2 (prop 'output-stream (first process*))) + (3 (prop 'bidir-stream (pop process*)) + (prop 'input-stream (pop process*)) + (prop 'output-stream (pop process*))))) + #+(or abcl clozure cmucl sbcl scl) (progn - (prop :process process*) + (prop 'process process*) (when (eq input :stream) - (prop :input-stream + (prop 'input-stream + #+abcl (symbol-call :sys :process-input process*) #+clozure (ccl:external-process-input-stream process*) - #+(or cmu scl) (ext:process-input process*) + #+(or cmucl scl) (ext:process-input process*) #+sbcl (sb-ext:process-input process*))) (when (eq output :stream) - (prop :output-stream + (prop 'output-stream + #+abcl (symbol-call :sys :process-output process*) #+clozure (ccl:external-process-output-stream process*) - #+(or cmu scl) (ext:process-output process*) + #+(or cmucl scl) (ext:process-output process*) #+sbcl (sb-ext:process-output process*))) (when (eq error-output :stream) - (prop :error-output-stream + (prop 'error-output-stream + #+abcl (symbol-call :sys :process-error process*) #+clozure (ccl:external-process-error-stream process*) - #+(or cmu scl) (ext:process-error process*) + #+(or cmucl scl) (ext:process-error process*) #+sbcl (sb-ext:process-error process*)))) - #+(or clasp ecl mkcl) - (destructuring-bind #+(or clasp ecl) (stream code process) #+mkcl (stream process code) process* + #+(or ecl mkcl) + (destructuring-bind #+ecl (stream code process) #+mkcl (stream process code) process* (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)))) (cond ((zerop mode)) - ((null process*) (prop :exit-code -1)) - (t (prop (case mode (1 :input-stream) (2 :output-stream) (3 :bidir-stream)) stream)))) - (when code (prop :exit-code code)) - (when process (prop :process process))) + ((null process*) (store-codes -1)) + (t (prop (case mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream)) stream)))) + (when code + (let ((signum #+mkcl (and (stringp code) (%mkcl-signal-to-number code)) + #-mkcl (and (eq (ext:external-process-wait process) + :signaled) + code))) + (store-codes code signum))) + (when process (prop 'process process))) #+lispworks (if wait - (prop :exit-code (first process*)) + (store-codes (first process*) (second process*)) (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)))) - (if (zerop mode) - (prop :process (first process*)) - (destructuring-bind (x err pid) process* - (prop :process pid) - (prop (ecase mode (1 :input-stream) (2 :output-stream) (3 :bidir-stream)) x) - (when (eq error-output :stream) (prop :error-stream err)))))) - (nreverse process-info-r)))) + (if (or (plusp mode) (eq error-output :stream)) + (destructuring-bind (io err pid) process* + #+lispworks7+ (declare (ignore pid)) + (prop 'process #+lispworks7+ io #-lispworks7+ pid) + (when (plusp mode) + (prop (ecase mode + (1 'input-stream) + (2 'output-stream) + (3 'bidir-stream)) io)) + (when (eq error-output :stream) + (prop 'error-stream err))) + ;; lispworks6 returns (pid), lispworks7 returns (io,err,pid). + (prop 'process (first process*))))) + process-info))) + + (defun process-info-error-output (process-info) + (slot-value process-info 'error-output-stream)) + (defun process-info-input (process-info) + (or (slot-value process-info 'bidir-stream) + (slot-value process-info 'input-stream))) + (defun process-info-output (process-info) + (or (slot-value process-info 'bidir-stream) + (slot-value process-info 'output-stream))) - (defun %process-info-pid (process-info) - (let ((process (getf process-info :process))) + (defun process-info-pid (process-info) + (let ((process (slot-value process-info 'process))) (declare (ignorable process)) - #+(or allegro lispworks) process - #+clozure (ccl::external-process-pid process) - #+(or clasp ecl) (si:external-process-pid process) - #+(or cmu scl) (ext:process-pid process) + #+abcl (symbol-call :sys :process-pid process) + #+allegro process + #+clozure (ccl:external-process-id process) + #+ecl (ext:external-process-pid process) + #+(or cmucl scl) (ext:process-pid process) + #+lispworks7+ (sys:pipe-pid process) + #+(and lispworks (not lispworks7+)) process #+mkcl (mkcl:process-id process) #+sbcl (sb-ext:process-pid process) - #-(or allegro cmu mkcl sbcl scl) (error "~S not implemented" '%process-info-pid))) + #-(or abcl allegro clozure cmucl ecl mkcl lispworks sbcl scl) + (not-implemented-error 'process-info-pid))) - (defun %wait-process-result (process-info) - (or (getf process-info :exit-code) - (let ((process (getf process-info :process))) - (when process - ;; 1- wait - #+clozure (ccl::external-process-wait process) - #+(or cmu scl) (ext:process-wait process) - #+sbcl (sb-ext:process-wait process) - ;; 2- extract result - #+allegro (sys:reap-os-subprocess :pid process :wait t) - #+clozure (nth-value 1 (ccl:external-process-status process)) - #+(or cmu scl) (ext:process-exit-code process) - #+(or clasp ecl) (nth-value 1 (ext:external-process-wait process t)) + (defun %process-status (process-info) + (if-let (exit-code (slot-value process-info 'exit-code)) + (return-from %process-status + (if-let (signal-code (slot-value process-info 'signal-code)) + (values :signaled signal-code) + (values :exited exit-code)))) + #-(or allegro clozure cmucl ecl lispworks mkcl sbcl scl) + (not-implemented-error '%process-status) + (if-let (process (slot-value process-info 'process)) + (multiple-value-bind (status code) + (progn + #+allegro (multiple-value-bind (exit-code pid signal) + (sys:reap-os-subprocess :pid process :wait nil) + (assert pid) + (cond ((null exit-code) :running) + ((null signal) (values :exited exit-code)) + (t (values :signaled signal)))) + #+clozure (ccl:external-process-status process) + #+(or cmucl scl) (let ((status (ext:process-status process))) + (values status (if (member status '(:exited :signaled)) + (ext:process-exit-code process)))) + #+ecl (ext:external-process-status process) #+lispworks - (if-let ((stream (or (getf process-info :input-stream) - (getf process-info :output-stream) - (getf process-info :bidir-stream) - (getf process-info :error-stream)))) - (system:pipe-exit-status stream :wait t) - (if-let ((f (find-symbol* :pid-exit-status :system nil))) - (funcall f process :wait t))) - #+sbcl (sb-ext:process-exit-code process) - #+mkcl (mkcl:join-process process))))) + ;; a signal is only returned on LispWorks 7+ + (multiple-value-bind (exit-code signal) + (funcall #+lispworks7+ #'sys:pipe-exit-status + #-lispworks7+ #'sys:pid-exit-status + process :wait nil) + (cond ((null exit-code) :running) + ((null signal) (values :exited exit-code)) + (t (values :signaled signal)))) + #+mkcl (let ((status (mk-ext:process-status process)) + (code (mk-ext:process-exit-code process))) + (if (stringp code) + (values :signaled (%mkcl-signal-to-number code)) + (values status code))) + #+sbcl (let ((status (sb-ext:process-status process))) + (values status (if (member status '(:exited :signaled)) + (sb-ext:process-exit-code process))))) + (case status + (:exited (setf (slot-value process-info 'exit-code) code)) + (:signaled (let ((%code (%signal-to-exit-code code))) + (setf (slot-value process-info 'exit-code) %code + (slot-value process-info 'signal-code) code)))) + (values status code)))) + + (defun process-alive-p (process-info) + "Check if a process has yet to exit." + (unless (slot-value process-info 'exit-code) + #+abcl (sys:process-alive-p (slot-value process-info 'process)) + #+(or cmucl scl) (ext:process-alive-p (slot-value process-info 'process)) + #+sbcl (sb-ext:process-alive-p (slot-value process-info 'process)) + #-(or abcl cmucl sbcl scl) (member (%process-status process-info) + '(:running :sleeping)))) + + (defun wait-process (process-info) + "Wait for the process to terminate, if it is still running. +Otherwise, return immediately. An exit code (a number) will be +returned, with 0 indicating success, and anything else indicating +failure. If the process exits after receiving a signal, the exit code +will be the sum of 128 and the (positive) numeric signal code. A second +value may be returned in this case: the numeric signal code itself. +Any asynchronously spawned process requires this function to be run +before it is garbage-collected in order to free up resources that +might otherwise be irrevocably lost." + (if-let (exit-code (slot-value process-info 'exit-code)) + (if-let (signal-code (slot-value process-info 'signal-code)) + (values exit-code signal-code) + exit-code) + (let ((process (slot-value process-info 'process))) + #-(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl) + (not-implemented-error 'wait-process) + (when process + ;; 1- wait + #+clozure (ccl::external-process-wait process) + #+(or cmucl scl) (ext:process-wait process) + #+sbcl (sb-ext:process-wait process) + ;; 2- extract result + (multiple-value-bind (exit-code signal-code) + (progn + #+abcl (sys:process-wait process) + #+allegro (multiple-value-bind (exit-code pid signal) + (sys:reap-os-subprocess :pid process :wait t) + (assert pid) + (values exit-code signal)) + #+clozure (multiple-value-bind (status code) + (ccl:external-process-status process) + (if (eq status :signaled) + (values nil code) + code)) + #+(or cmucl scl) (let ((status (ext:process-status process)) + (code (ext:process-exit-code process))) + (if (eq status :signaled) + (values nil code) + code)) + #+ecl (multiple-value-bind (status code) + (ext:external-process-wait process t) + (if (eq status :signaled) + (values nil code) + code)) + #+lispworks (funcall #+lispworks7+ #'sys:pipe-exit-status + #-lispworks7+ #'sys:pid-exit-status + process :wait t) + #+mkcl (let ((code (mkcl:join-process process))) + (if (stringp code) + (values nil (%mkcl-signal-to-number code)) + code)) + #+sbcl (let ((status (sb-ext:process-status process)) + (code (sb-ext:process-exit-code process))) + (if (eq status :signaled) + (values nil code) + code))) + (if signal-code + (let ((%exit-code (%signal-to-exit-code signal-code))) + (setf (slot-value process-info 'exit-code) %exit-code + (slot-value process-info 'signal-code) signal-code) + (values %exit-code signal-code)) + (progn (setf (slot-value process-info 'exit-code) exit-code) + exit-code))))))) (defun %check-result (exit-code &key command process ignore-error-status) (unless ignore-error-status @@ -5233,6 +5472,61 @@ 'subprocess-error :command command :code exit-code :process process))) exit-code) + (defun close-streams (process-info) + "Close any stream that the process might own. Needs to be run +whenever streams were requested by passing :stream to :input, :output, +or :error-output." + (dolist (stream + (cons (slot-value process-info 'error-output-stream) + (if-let (bidir-stream (slot-value process-info 'bidir-stream)) + (list bidir-stream) + (list (slot-value process-info 'input-stream) + (slot-value process-info 'output-stream))))) + (when stream (close stream)))) + + ;; WARNING: For signals other than SIGTERM and SIGKILL this may not + ;; do what you expect it to. Sending SIGSTOP to a process spawned + ;; via %run-program, e.g., will stop the shell /bin/sh that is used + ;; to run the command (via `sh -c command`) but not the actual + ;; command. + #+os-unix + (defun %posix-send-signal (process-info signal) + #+allegro (excl.osi:kill (slot-value process-info 'process) signal) + #+clozure (ccl:signal-external-process (slot-value process-info 'process) + signal :error-if-exited nil) + #+(or cmucl scl) (ext:process-kill (slot-value process-info 'process) signal) + #+sbcl (sb-ext:process-kill (slot-value process-info 'process) signal) + #-(or allegro clozure cmucl sbcl scl) + (if-let (pid (process-info-pid process-info)) + (%run-program (format nil "kill -~a ~a" signal pid) :wait t))) + + ;;; this function never gets called on Windows, but the compiler cannot tell + ;;; that. [2016/09/25:rpg] + #+os-windows + (defun %posix-send-signal (process-info signal) + (declare (ignore process-info signal)) + (values)) + + (defun terminate-process (process-info &key urgent) + "Cause the process to exit. To that end, the process may or may +not be sent a signal, which it will find harder (or even impossible) +to ignore if URGENT is T. On some platforms, it may also be subject to +race conditions." + (declare (ignorable urgent)) + #+abcl (sys:process-kill (slot-value process-info 'process)) + #+ecl (symbol-call :ext :terminate-process + (slot-value process-info 'process) urgent) + #+lispworks7+ (sys:pipe-kill-process (slot-value process-info 'process)) + #+mkcl (mk-ext:terminate-process (slot-value process-info 'process) + :force urgent) + #-(or abcl ecl lispworks7+ mkcl) + (os-cond + ((os-unix-p) (%posix-send-signal process-info (if urgent 9 15))) + ((os-windows-p) (if-let (pid (process-info-pid process-info)) + (%run-program (format nil "taskkill ~a /pid ~a" + (if urgent "/f" "") pid)))) + (t (not-implemented-error 'terminate-process)))) + (defun %call-with-program-io (gf tval stream-easy-p fun direction spec activep returner &key element-type external-format &allow-other-keys) ;; handle redirection for run-program and system @@ -5282,7 +5576,7 @@ (typecase activity-spec ((or null string pathname (eql :interactive)) (easy-case)) - #+(or cmu (and sbcl os-unix) scl) ;; streams are only easy on implementations that try very hard + #+(or cmucl (and sbcl os-unix) scl) ;; streams are only easy on implementations that try very hard (stream (if stream-easy-p (easy-case) (hard-case))) (t @@ -5324,10 +5618,10 @@ (defun %use-run-program (command &rest keys &key input output error-output ignore-error-status &allow-other-keys) ;; helper for RUN-PROGRAM when using %run-program - #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl xcl) + #+(or cormanlisp gcl (and lispworks os-windows) mcl xcl) (progn command keys input output error-output ignore-error-status ;; ignore - (error "Not implemented on this platform")) + (not-implemented-error '%use-run-program)) (assert (not (member :stream (list input output error-output)))) (let* ((active-input-p (%active-io-specifier-p input)) (active-output-p (%active-io-specifier-p output)) @@ -5339,7 +5633,7 @@ (active-error-output-p :error-output) (t nil))) (wait (not activity)) - output-result error-output-result exit-code) + output-result error-output-result exit-code process-info) (with-program-output ((reduced-output output-activity) output :keys keys :setf output-result :stream-easy-p t :active (eq activity :output)) @@ -5349,33 +5643,32 @@ (with-program-input ((reduced-input input-activity) input :keys keys :stream-easy-p t :active (eq activity :input)) - (let ((process-info - (apply '%run-program command - :wait wait :input reduced-input :output reduced-output - :error-output (if (eq error-output :output) :output reduced-error-output) - keys))) - (labels ((get-stream (stream-name &optional fallbackp) - (or (getf process-info stream-name) - (when fallbackp - (getf process-info :bidir-stream)))) - (run-activity (activity stream-name &optional fallbackp) - (if-let (stream (get-stream stream-name fallbackp)) - (funcall activity stream) - (error 'subprocess-error - :code `(:missing ,stream-name) - :command command :process process-info)))) - (unwind-protect - (ecase activity - ((nil)) - (:input (run-activity input-activity :input-stream t)) - (:output (run-activity output-activity :output-stream t)) - (:error-output (run-activity error-output-activity :error-output-stream))) - (loop :for (() val) :on process-info :by #'cddr - :when (streamp val) :do (ignore-errors (close val))) - (setf exit-code - (%check-result (%wait-process-result process-info) - :command command :process process-info - :ignore-error-status ignore-error-status)))))))) + (setf process-info + (apply '%run-program command + :wait wait :input reduced-input :output reduced-output + :error-output (if (eq error-output :output) :output reduced-error-output) + keys)) + (labels ((get-stream (stream-name &optional fallbackp) + (or (slot-value process-info stream-name) + (when fallbackp + (slot-value process-info 'bidir-stream)))) + (run-activity (activity stream-name &optional fallbackp) + (if-let (stream (get-stream stream-name fallbackp)) + (funcall activity stream) + (error 'subprocess-error + :code `(:missing ,stream-name) + :command command :process process-info)))) + (unwind-protect + (ecase activity + ((nil)) + (:input (run-activity input-activity 'input-stream t)) + (:output (run-activity output-activity 'output-stream t)) + (:error-output (run-activity error-output-activity 'error-output-stream))) + (close-streams process-info) + (setf exit-code (wait-process process-info))))))) + (%check-result exit-code + :command command :process process-info + :ignore-error-status ignore-error-status) (values output-result error-output-result exit-code))) (defun %normalize-system-command (command) ;; helper for %USE-SYSTEM @@ -5426,28 +5719,27 @@ &key input output error-output directory &allow-other-keys) "A portable abstraction of a low-level call to libc's system()." (declare (ignorable input output error-output directory keys)) - #+(or allegro clozure cmu (and lispworks os-unix) sbcl scl) - (%wait-process-result + #+(or allegro clozure cmucl (and lispworks os-unix) sbcl scl) + (wait-process (apply '%run-program (%normalize-system-command command) :wait t keys)) #+(or abcl clasp clisp cormanlisp ecl gcl genera (and lispworks os-windows) mkcl xcl) (let ((%command (%redirected-system-command command input output error-output directory))) #+(and lispworks os-windows) (system:call-system %command :current-directory directory :wait t) #+clisp - (%wait-process-result + (wait-process (apply '%run-program %command :wait t :input :interactive :output :interactive :error-output :interactive keys)) #-(or clisp (and lispworks os-windows)) (with-current-directory ((os-cond ((not (os-unix-p)) directory))) - #+abcl (ext:run-shell-command %command) + #+abcl (ext:run-shell-command %command) ;; FIXME: deprecated #+cormanlisp (win32:system %command) #+(or clasp ecl) (let ((*standard-input* *stdin*) (*standard-output* *stdout*) (*error-output* *stderr*)) (ext:system %command)) #+gcl (system:system %command) - #+genera (error "~S not supported on Genera, cannot run ~S" - '%system %command) + #+genera (not-implemented-error '%system) #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command)) #+mkcl (mkcl:system %command) #+xcl (system:%run-shell-command %command)))) @@ -5461,25 +5753,71 @@ (with-program-error-output ((reduced-error-output) error-output :keys keys :setf error-output-result) (with-program-input ((reduced-input) input :keys keys) - (setf exit-code - (%check-result (apply '%system command - :input reduced-input :output reduced-output - :error-output reduced-error-output keys) - :command command - :ignore-error-status ignore-error-status))))) + (setf exit-code (apply '%system command + :input reduced-input :output reduced-output + :error-output reduced-error-output keys))))) + (%check-result exit-code + :command command + :ignore-error-status ignore-error-status) (values output-result error-output-result exit-code))) + (defun launch-program (command &rest keys &key + input (if-input-does-not-exist :error) + output (if-output-exists :supersede) + error-output (if-error-output-exists :supersede) + (element-type #-clozure *default-stream-element-type* + #+clozure 'character) + (external-format *utf-8-external-format*) + &allow-other-keys) + "Launch program specified by COMMAND, +either a list of strings specifying a program and list of arguments, +or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on +Windows) _asynchronously_. + +If OUTPUT is a pathname, a string designating a pathname, or NIL +designating the null device, the file at that path is used as output. +If it's :INTERACTIVE, output is inherited from the current process; +beware that this may be different from your *STANDARD-OUTPUT*, and +under SLIME will be on your *inferior-lisp* buffer. If it's T, output +goes to your current *STANDARD-OUTPUT* stream. If it's :STREAM, a new +stream will be made available that can be accessed via +PROCESS-INFO-OUTPUT and read from. Otherwise, OUTPUT should be a value +that the underlying lisp implementation knows how to handle. + +ERROR-OUTPUT is similar to OUTPUT. T designates the *ERROR-OUTPUT*, +:OUTPUT means redirecting the error output to the output stream, +and :STREAM causes a stream to be made available via +PROCESS-INFO-ERROR-OUTPUT. + +INPUT is similar to OUTPUT, except that T designates the +*STANDARD-INPUT* and a stream requested through the :STREAM keyword +would be available through PROCESS-INFO-INPUT. + +ELEMENT-TYPE and EXTERNAL-FORMAT are passed on to your Lisp +implementation, when applicable, for creation of the output stream. + +LAUNCH-PROGRAM returns a process-info object." + (apply '%run-program command + :wait nil + :input input :if-input-does-not-exist if-input-does-not-exist + :output output :if-output-exists if-output-exists + :error-output error-output :if-error-output-exists if-error-output-exists + :element-type element-type :external-format external-format + keys)) + (defun run-program (command &rest keys &key ignore-error-status (force-shell nil force-shell-suppliedp) (input nil inputp) (if-input-does-not-exist :error) - output (if-output-exists :overwrite) - (error-output nil error-output-p) (if-error-output-exists :overwrite) + output (if-output-exists :supersede) + (error-output nil error-output-p) (if-error-output-exists :supersede) (element-type #-clozure *default-stream-element-type* #+clozure 'character) (external-format *utf-8-external-format*) &allow-other-keys) "Run program specified by COMMAND, either a list of strings specifying a program and list of arguments, -or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows). +or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows); +_synchronously_ process its output as specified and return the processing results +when the program and its output processing are complete. Always call a shell (rather than directly execute the command when possible) if FORCE-SHELL is specified. Similarly, never call a shell if FORCE-SHELL is @@ -5513,7 +5851,7 @@ INPUT is similar to OUTPUT, except that VOMIT-OUTPUT-STREAM is used, no value is returned, and T designates the *STANDARD-INPUT*. -Use ELEMENT-TYPE and EXTERNAL-FORMAT are passed on +ELEMENT-TYPE and EXTERNAL-FORMAT are passed on to your Lisp implementation, when applicable, for creation of the output stream. One and only one of the stream slurping or vomiting may or may not happen @@ -5529,22 +5867,22 @@ 2- either 0 if the subprocess exited with success status, or an indication of failure via the EXIT-CODE of the process" (declare (ignorable ignore-error-status)) - #-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl) - (error "RUN-PROGRAM not implemented for this Lisp") + #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl) + (not-implemented-error 'run-program) ;; per doc string, set FORCE-SHELL to T if we get command as a string. But ;; don't override user's specified preference. [2015/06/29:rpg] (when (stringp command) (unless force-shell-suppliedp + #-(and sbcl os-windows) ;; force-shell t isn't working properly on windows as of sbcl 1.2.16 (setf force-shell t))) (flet ((default (x xp output) (cond (xp x) ((eq output :interactive) :interactive)))) (apply (if (or force-shell - #+(or clasp clisp) (or (not ignore-error-status) t) - #+clisp (member error-output '(:interactive :output)) - ;; old versions of ecl <= 15.3.7 don't support non-trivial :error - #+ecl (and (nth-value 1 (ignore-errors (slot-value (ext:make-external-process) 'ext::error-stream))) - (not (member error-output '(:interactive :output nil)))) + #+(or clasp clisp) t + ;; A race condition in ECL <= 16.0.0 prevents using ext:run-program + #+ecl #.(if-let (ver (parse-version (lisp-implementation-version))) + (lexicographic<= '< ver '(16 0 1))) #+(and lispworks os-unix) (%interactivep input output error-output) - #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl xcl) t) + #+(or cormanlisp gcl (and lispworks os-windows) mcl xcl) t) '%use-system '%use-run-program) command :input (default input inputp output) @@ -5622,7 +5960,7 @@ #+clisp '() ;; system::*optimize* is a constant hash-table! (with non-constant contents) #+clozure '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety* ccl::*nx-debug* ccl::*nx-cspeed*) - #+(or cmu scl) '(c::*default-cookie*) + #+(or cmucl scl) '(c::*default-cookie*) #+(and ecl (not clasp)) (unless (use-ecl-byte-compiler-p) '(c::*speed* c::*space* c::*safety* c::*debug*)) #+clasp '() #+gcl '(compiler::*speed* compiler::*space* compiler::*compiler-new-safety* compiler::*debug*) @@ -5631,11 +5969,11 @@ #+sbcl '(sb-c::*policy*))) (defun get-optimization-settings () "Get current compiler optimization settings, ready to PROCLAIM again" - #-(or abcl allegro clasp clisp clozure cmu ecl lispworks mkcl sbcl scl xcl) + #-(or abcl allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl scl xcl) (warn "~S does not support ~S. Please help me fix that." 'get-optimization-settings (implementation-type)) - #+(or abcl allegro clasp clisp clozure cmu ecl lispworks mkcl sbcl scl xcl) - (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity))) + #+(or abcl allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl scl xcl) + (let ((settings '(speed space safety debug compilation-speed #+(or cmucl scl) c::brevity))) #.`(loop #+(or allegro clozure) ,@'(:with info = #+allegro (sys:declaration-information 'optimize) #+clozure (ccl:declaration-information 'optimize nil)) @@ -5644,7 +5982,7 @@ :for y = (or #+(or allegro clozure) (second (assoc x info)) ; normalize order #+clisp (gethash x system::*optimize* 1) #+(or abcl clasp ecl mkcl xcl) (symbol-value v) - #+(or cmu scl) (slot-value c::*default-cookie* + #+(or cmucl scl) (slot-value c::*default-cookie* (case x (compilation-speed 'c::cspeed) (otherwise x))) #+lispworks (slot-value compiler::*optimization-level* x) @@ -5686,7 +6024,7 @@ (defvar *usual-uninteresting-conditions* (append ;;#+clozure '(ccl:compiler-warning) - #+cmu '("Deleting unreachable code.") + #+cmucl '("Deleting unreachable code.") #+lispworks '("~S being redefined in ~A (previously in ~A)." "~S defined more than once in ~A.") ;; lispworks gets confused by eval-when. #+sbcl @@ -5871,7 +6209,7 @@ :warning-type warning-type :args (destructuring-bind (fun . more) args (cons (symbolify-function-name fun) more)))))) - #+(or cmu scl) + #+(or cmucl scl) (defun reify-undefined-warning (warning) ;; Extracting undefined-warnings from the compilation-unit ;; To be passed through the above reify/unreify link, it must be a "simple-sexp" @@ -5923,7 +6261,7 @@ (if-let (dw ccl::*outstanding-deferred-warnings*) (let ((mdw (ccl::ensure-merged-deferred-warnings dw))) (ccl::deferred-warnings.warnings mdw)))) - #+(or cmu scl) + #+(or cmucl scl) (when lisp::*in-compilation-unit* ;; Try to send nothing through the pipe if nothing needs to be accumulated `(,@(when c::*undefined-warnings* @@ -5969,7 +6307,7 @@ (setf ccl::*outstanding-deferred-warnings* (ccl::%defer-warnings t))))) (appendf (ccl::deferred-warnings.warnings dw) (mapcar 'unreify-deferred-warning reified-deferred-warnings))) - #+(or cmu scl) + #+(or cmucl scl) (dolist (item reified-deferred-warnings) ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol. ;; For *undefined-warnings*, the adjustment is a list of initargs. @@ -6032,7 +6370,7 @@ (if-let (dw ccl::*outstanding-deferred-warnings*) (let ((mdw (ccl::ensure-merged-deferred-warnings dw))) (setf (ccl::deferred-warnings.warnings mdw) nil))) - #+(or cmu scl) + #+(or cmucl scl) (when lisp::*in-compilation-unit* (setf c::*undefined-warnings* nil c::*compiler-error-count* 0 @@ -6198,46 +6536,48 @@ "This function provides a portable wrapper around COMPILE-FILE. It ensures that the OUTPUT-FILE value is only returned and the file only actually created if the compilation was successful, -even though your implementation may not do that, and including -an optional call to an user-provided consistency check function COMPILE-CHECK; +even though your implementation may not do that. It also checks an optional +user-provided consistency function COMPILE-CHECK to determine success; it will call this function if not NIL at the end of the compilation with the arguments sent to COMPILE-FILE*, except with :OUTPUT-FILE TMP-FILE where TMP-FILE is the name of a temporary output-file. It also checks two flags (with legacy british spelling from ASDF1), *COMPILE-FILE-FAILURE-BEHAVIOUR* and *COMPILE-FILE-WARNINGS-BEHAVIOUR* with appropriate implementation-dependent defaults, -and if a failure (respectively warnings) are reported by COMPILE-FILE -with consider it an error unless the respective behaviour flag +and if a failure (respectively warnings) are reported by COMPILE-FILE, +it will consider that an error unless the respective behaviour flag is one of :SUCCESS :WARN :IGNORE. If WARNINGS-FILE is defined, deferred warnings are saved to that file. On ECL or MKCL, it creates both the linkable object and loadable fasl files. On implementations that erroneously do not recognize standard keyword arguments, it will filter them appropriately." - #+(or clasp ecl) (when (and object-file (equal (compile-file-type) (pathname object-file))) - (format t "Whoa, some funky ASDF upgrade switched ~S calling convention for ~S and ~S~%" - 'compile-file* output-file object-file) - (rotatef output-file object-file)) + #+(or clasp ecl) + (when (and object-file (equal (compile-file-type) (pathname object-file))) + (format t "Whoa, some funky ASDF upgrade switched ~S calling convention for ~S and ~S~%" + 'compile-file* output-file object-file) + (rotatef output-file object-file)) (let* ((keywords (remove-plist-keys `(:output-file :compile-check :warnings-file #+clisp :lib-file #+(or clasp ecl mkcl) :object-file) keys)) (output-file (or output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords))) + (physical-output-file (physicalize-pathname output-file)) #+(or clasp ecl) (object-file (unless (use-ecl-byte-compiler-p) (or object-file - #+ecl(compile-file-pathname output-file :type :object) + #+ecl (compile-file-pathname output-file :type :object) #+clasp (compile-file-pathname output-file :output-type :object)))) #+mkcl (object-file (or object-file (compile-file-pathname output-file :fasl-p nil))) - (tmp-file (tmpize-pathname output-file)) + (tmp-file (tmpize-pathname physical-output-file)) #+sbcl (cfasl-file (etypecase emit-cfasl (null nil) - ((eql t) (make-pathname :type "cfasl" :defaults output-file)) + ((eql t) (make-pathname :type "cfasl" :defaults physical-output-file)) (string (parse-namestring emit-cfasl)) (pathname emit-cfasl))) #+sbcl @@ -6276,17 +6616,23 @@ #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files (list object-file)))) (or (not compile-check) (apply compile-check input-file - :output-file #-(or clasp ecl) output-file #+(or clasp ecl) tmp-file + :output-file output-truename keywords)))) - (delete-file-if-exists output-file) + (delete-file-if-exists physical-output-file) (when output-truename #+clasp (when output-truename (rename-file-overwriting-target tmp-file output-truename)) - #+clisp (when lib-file (rename-file-overwriting-target tmp-lib lib-file)) + ;; see CLISP bug 677 + #+clisp + (progn + (setf tmp-lib (make-pathname :type "lib" :defaults output-truename)) + (unless lib-file (setf lib-file (make-pathname :type "lib" :defaults physical-output-file))) + (rename-file-overwriting-target tmp-lib lib-file)) #+sbcl (when cfasl-file (rename-file-overwriting-target tmp-cfasl cfasl-file)) - (rename-file-overwriting-target output-truename output-file) - (setf output-truename (truename output-file))) + (rename-file-overwriting-target output-truename physical-output-file) + (setf output-truename (truename physical-output-file))) #+clasp (delete-file-if-exists tmp-file) - #+clisp (delete-file-if-exists tmp-lib)) + #+clisp (progn (delete-file-if-exists tmp-file) ;; this one works around clisp BUG 677 + (delete-file-if-exists tmp-lib))) ;; this one is "normal" defensive cleanup (t ;; error or failed check (delete-file-if-exists output-truename) #+clisp (delete-file-if-exists tmp-lib) @@ -6319,11 +6665,11 @@ (with-upgradability () (defun combine-fasls (inputs output) "Combine a list of FASLs INPUTS into a single FASL OUTPUT" - #-(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl) + #-(or abcl allegro clisp clozure cmucl lispworks sbcl scl xcl) (error "~A does not support ~S~%inputs ~S~%output ~S" (implementation-type) 'combine-fasls inputs output) #+abcl (funcall 'sys::concatenate-fasls inputs output) ; requires ABCL 1.2.0 - #+(or allegro clisp cmu sbcl scl xcl) (concatenate-files inputs output) + #+(or allegro clisp cmucl sbcl scl xcl) (concatenate-files inputs output) #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede) #+lispworks (let (fasls) @@ -6341,7 +6687,7 @@ :members ,(loop :for f :in (reverse fasls) :collect `(,(namestring f) :load-only t)))) - (scm:concatenate-system output :fasls-to-concatenate)) + (scm:concatenate-system output :fasls-to-concatenate :force t)) (loop :for f :in fasls :do (ignore-errors (delete-file f))) (ignore-errors (lispworks:delete-system :fasls-to-concatenate)))))) ;;;; --------------------------------------------------------------------------- @@ -6545,7 +6891,7 @@ ;; but what it means to the output-translations is ;; "relative to the root of the source pathname's host and device". (return-from resolve-absolute-location - (let ((p (make-pathname* :directory '(:relative)))) + (let ((p (make-pathname :directory '(:relative)))) (if wilden (wilden p) p)))) ((eql :home) (user-homedir-pathname)) ((eql :here) (resolve-absolute-location @@ -6691,7 +7037,7 @@ (resolve-absolute-location `(,(or (getenv-absolute-directory "XDG_CACHE_HOME") (os-cond - ((os-windows-p) (xdg-data-home "cache")) + ((os-windows-p) (xdg-data-home "cache/")) (t (subpathname* (user-homedir-pathname) ".cache/")))) ,more))) @@ -6768,8 +7114,7 @@ :uiop/pathname :uiop/stream :uiop/os :uiop/image :uiop/run-program :uiop/lisp-build :uiop/configuration) (:export - #:coerce-pathname #:component-name-to-pathname-components - #+(or clasp ecl mkcl) #:compile-file-keeping-object + #:coerce-pathname #:user-configuration-directories #:system-configuration-directories #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory )) @@ -6780,27 +7125,11 @@ (with-upgradability () (defun coerce-pathname (name &key type defaults) ;; For backward-compatibility only, for people using internals - ;; Reported users in quicklisp: hu.dwim.asdf, asdf-utils, xcvb - ;; Will be removed after 2014-01-16. + ;; Reported users in quicklisp 2015-11: hu.dwim.asdf (removed in next release) + ;; Will be removed after 2015-12. ;;(warn "Please don't use ASDF::COERCE-PATHNAME. Use ASDF/PATHNAME:PARSE-UNIX-NAMESTRING.") (parse-unix-namestring name :type type :defaults defaults)) - (defun component-name-to-pathname-components (unix-style-namestring - &key force-directory force-relative) - ;; Will be removed after 2014-01-16. - ;; (warn "Please don't use ASDF::COMPONENT-NAME-TO-PATHNAME-COMPONENTS, use SPLIT-UNIX-NAMESTRING-DIRECTORY-COMPONENTS") - (multiple-value-bind (relabs path filename file-only) - (split-unix-namestring-directory-components - unix-style-namestring :ensure-directory force-directory) - (declare (ignore file-only)) - (when (and force-relative (not (eq relabs :relative))) - (error (compatfmt "~@") - unix-style-namestring)) - (values relabs path filename))) - - #+(or clasp ecl mkcl) - (defun compile-file-keeping-object (&rest args) (apply #'compile-file* args)) - ;; Backward compatibility for ASDF 2.27 to 3.1.4 (defun user-configuration-directories () "Return the current user's list of user configuration directories @@ -6857,7 +7186,7 @@ (:export #:asdf-version #:*previous-asdf-versions* #:*asdf-version* #:asdf-message #:*verbose-out* - #:upgrading-p #:when-upgrading #:upgrade-asdf #:asdf-upgrade-error #:defparameter* + #:upgrading-p #:when-upgrading #:upgrade-asdf #:defparameter* #:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* #:cleanup-upgraded-asdf ;; There will be no symbol left behind! #:intern*) @@ -6878,19 +7207,43 @@ (string rev) (cons (format nil "~{~D~^.~}" rev)) (null "1.0")))))) - ;; Important: define *p-a-v* /before/ *a-v* so that it initializes correctly. - (defvar *previous-asdf-versions* (if-let (previous (asdf-version)) (list previous))) + ;; This (private) variable contains a list of versions of previously loaded variants of ASDF, + ;; from which ASDF was upgraded. + ;; Important: define *p-a-v* /before/ *a-v* so that they initialize correctly. + (defvar *previous-asdf-versions* + (let ((previous (asdf-version))) + (when previous + ;; Punt on hard package upgrade: from ASDF1 or ASDF2 + (when (version< previous "2.27") ;; 2.27 is the first to have the :asdf3 feature. + (let ((away (format nil "~A-~A" :asdf previous))) + (rename-package :asdf away) + (when *load-verbose* + (format t "~&; Renamed old ~A package away to ~A~%" :asdf away))))) + (list previous))) + ;; This public variable will be bound shortly to the currently loaded version of ASDF. (defvar *asdf-version* nil) - ;; We need to clear systems from versions yet older than the below: + ;; We need to clear systems from versions older than the one in this (private) parameter: (defparameter *oldest-forward-compatible-asdf-version* "2.33") ;; 2.32.13 renames a slot in component. + ;; Semi-private variable: a designator for a stream on which to output ASDF progress messages (defvar *verbose-out* nil) + ;; Private function by which ASDF outputs progress messages and warning messages: (defun asdf-message (format-string &rest format-args) (when *verbose-out* (apply 'format *verbose-out* format-string format-args))) + ;; Private hook for functions to run after ASDF has upgraded itself from an older variant: (defvar *post-upgrade-cleanup-hook* ()) + ;; Private hook for functions to run after ASDF is restarted, whether by starting a process + ;; from a dumped image or after upgrading from an older variant: + ;; TODO: understand what happened with that hook, why functions are registered on it but it is + ;; never called anymore. This is a bug that should be fixed before next release (3.1.8)! (defvar *post-upgrade-restart-hook* ()) + ;; Private function to detect whether the current upgrade counts as an incompatible + ;; data schema upgrade implying the need to drop data. (defun upgrading-p (&optional (oldest-compatible-version *oldest-forward-compatible-asdf-version*)) (and *previous-asdf-versions* (version< (first *previous-asdf-versions*) oldest-compatible-version))) + ;; Private variant of defparameter that works in presence of incompatible upgrades: + ;; behaves like defvar in a compatible upgrade (e.g. reloading system after simple code change), + ;; but behaves like defparameter if in presence of an incompatible upgrade. (defmacro defparameter* (var value &optional docstring (version *oldest-forward-compatible-asdf-version*)) (let* ((name (string-trim "*" var)) (valfun (intern (format nil "%~A-~A-~A" :compute name :value)))) @@ -6899,6 +7252,9 @@ (defvar ,var (,valfun) ,@(ensure-list docstring)) (when (upgrading-p ,version) (setf ,var (,valfun)))))) + ;; Private macro to declare sections of code that are only compiled and run when upgrading. + ;; The use of eval portably ensures that the code will not have adverse compile-time side-effects, + ;; whereas the use of handler-bind portably ensures that it will not issue warnings when it runs. (defmacro when-upgrading ((&key (version *oldest-forward-compatible-asdf-version*) (upgrading-p `(upgrading-p ,version)) when) &body body) "A wrapper macro for code that should only be run when upgrading a @@ -6907,6 +7263,7 @@ (when (and ,upgrading-p ,@(when when `(,when))) (handler-bind ((style-warning #'muffle-warning)) (eval '(progn ,@body)))))) + ;; Only now can we safely update the version. (let* (;; For bug reporting sanity, please always bump this version when you modify this file. ;; Please also modify asdf.asd to reflect this change. make bump-version v=3.4.5.67.8 ;; can help you do these changes in synch (look at the source for documentation). @@ -6916,7 +7273,7 @@ ;; "3.4.5.67" would be a development version in the official branch, on top of 3.4.5. ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5 ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67 - (asdf-version "3.1.5.4") + (asdf-version "3.1.8.2") (existing-version (asdf-version))) (setf *asdf-version* asdf-version) (when (and existing-version (not (equal asdf-version existing-version))) @@ -6926,25 +7283,12 @@ (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%") existing-version asdf-version))))) +;;; Upon upgrade, specially frob some functions and classes that are being incompatibly redefined (when-upgrading () (let ((redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops. ;; NB: it's too late to do anything about functions in UIOP! ;; If you introduce some critically incompatibility there, you must change name. - '(#:component-relative-pathname #:component-parent-pathname ;; component - #:source-file-type - #:find-system #:system-source-file #:system-relative-pathname ;; system - #:find-component ;; find-component - #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action - #:component-depends-on #:operation-done-p #:component-depends-on - #:traverse ;; backward-interface - #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies ;; plan - #:operate ;; operate - #:parse-component-form ;; defsystem - #:apply-output-translations ;; output-translations - #:process-output-translations-directive - #:inherit-source-registry #:process-source-registry ;; source-registry - #:process-source-registry-directive - #:trivial-system-p)) ;; bundle + '()) ;; empty now that we don't unintern, but wholly punt on ASDF 2.26 or earlier. (redefined-classes ;; redefining the classes causes interim circularities ;; with the old ASDF during upgrade, and many implementations bork @@ -6952,7 +7296,7 @@ (loop :for name :in redefined-functions :for sym = (find-symbol* name :asdf nil) :do (when sym - ;; On CLISP we seem to be unable to fmakunbound and define a function in the same fasl. Sigh. + ;; CLISP seemingly can't fmakunbound and define a function in the same fasl. Sigh. #-clisp (fmakunbound sym))) (labels ((asym (x) (multiple-value-bind (s p) (if (consp x) (values (car x) (cadr x)) (values x :asdf)) (find-symbol* s p nil))) @@ -6964,14 +7308,9 @@ ;;; Self-upgrade functions - (with-upgradability () - (defun asdf-upgrade-error () - ;; Important notice for whom it concerns. The crux of the matter is that - ;; TRAVERSE can be completely refactored, and so after the find-system returns, it's too late. - (error "When a system transitively depends on ASDF, it must :defsystem-depends-on (:asdf)~%~ - Otherwise, when you upgrade from ASDF 2, you must do it before you operate on any system.~%")) - + ;; This private function is called at the end of asdf/footer and ensures that, + ;; *if* this loading of ASDF was an upgrade, then all registered cleanup functions will be called. (defun cleanup-upgraded-asdf (&optional (old-version (first *previous-asdf-versions*))) (let ((new-version (asdf-version))) (unless (equal old-version new-version) @@ -6998,6 +7337,8 @@ (handler-bind (((or style-warning) #'muffle-warning)) (symbol-call :asdf :load-system :asdf :verbose nil)))) + ;; Register the upgrade-configuration function from UIOP, + ;; to ensure configuration is upgraded as needed. (register-hook-function '*post-upgrade-cleanup-hook* 'upgrade-configuration)) ;;;; ------------------------------------------------------------------------- @@ -7048,26 +7389,40 @@ (defgeneric component-name (component) (:documentation "Name of the COMPONENT, unique relative to its parent")) (defgeneric component-system (component) - (:documentation "Find the top-level system containing COMPONENT")) + (:documentation "Top-level system containing the COMPONENT")) (defgeneric component-pathname (component) - (:documentation "Extracts the pathname applicable for a particular component.")) + (:documentation "Pathname of the COMPONENT if any, or NIL.")) (defgeneric (component-relative-pathname) (component) - (:documentation "Returns a pathname for the component argument intended to be -interpreted relative to the pathname of that component's parent. -Despite the function's name, the return value may be an absolute -pathname, because an absolute pathname may be interpreted relative to -another pathname in a degenerate way.")) - (defgeneric component-external-format (component)) - (defgeneric component-encoding (component)) - (defgeneric version-satisfies (component version)) - (defgeneric component-version (component)) - (defgeneric (setf component-version) (new-version component)) - (defgeneric component-parent (component)) + ;; in ASDF4, rename that to component-specified-pathname ? + (:documentation "Specified pathname of the COMPONENT, +intended to be merged with the pathname of that component's parent if any, using merged-pathnames*. +Despite the function's name, the return value can be an absolute pathname, in which case the merge +will leave it unmodified.")) + (defgeneric component-external-format (component) + (:documentation "The external-format of the COMPONENT. +By default, deduced from the COMPONENT-ENCODING.")) + (defgeneric component-encoding (component) + (:documentation "The encoding of the COMPONENT. By default, only :utf-8 is supported. +Use asdf-encodings to support more encodings.")) + (defgeneric version-satisfies (component version) + (:documentation "Check whether a COMPONENT satisfies the constraint of being at least as recent +as the specified VERSION, which must be a string of dot-separated natural numbers, or NIL.")) + (defgeneric component-version (component) + (:documentation "Return the version of a COMPONENT, which must be a string of dot-separated +natural numbers, or NIL.")) + (defgeneric (setf component-version) (new-version component) + (:documentation "Updates the version of a COMPONENT, which must be a string of dot-separated +natural numbers, or NIL.")) + (defgeneric component-parent (component) + (:documentation "The parent of a child COMPONENT, +or NIL for top-level components (a.k.a. systems)")) + ;; NIL is a designator for the absence of a component, in which case the parent is also absent. (defmethod component-parent ((component null)) nil) - ;; Backward compatible way of computing the FILE-TYPE of a component. + ;; Deprecated: Backward compatible way of computing the FILE-TYPE of a component. ;; TODO: find users, have them stop using that, remove it for ASDF4. - (defgeneric (source-file-type) (component system)) + (defgeneric (source-file-type) (component system) + (:documentation "DEPRECATED. Use the FILE-TYPE of a COMPONENT instead.")) (define-condition system-definition-error (error) () ;; [this use of :report should be redundant, but unfortunately it's not. @@ -7076,7 +7431,7 @@ ;; condition objects, which in turn does inheritance of :report options at ;; run-time. fortunately, inheritance means we only need this kludge here in ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] - #+cmu (:report print-object)) + #+cmucl (:report print-object)) (define-condition duplicate-names (system-definition-error) ((name :initarg :name :reader duplicate-names-name)) @@ -7114,10 +7469,9 @@ ;; See our ASDF 2 paper for more complete explanations. (in-order-to :initform nil :initarg :in-order-to :accessor component-in-order-to) - ;; methods defined using the "inline" style inside a defsystem form: - ;; need to store them somewhere so we can delete them when the system - ;; is re-evaluated. - (inline-methods :accessor component-inline-methods :initform nil) ;; OBSOLETE! DELETE THIS IF NO ONE USES. + ;; Methods defined using the "inline" style inside a defsystem form: + ;; we store them here so we can delete them when the system is re-evaluated. + (inline-methods :accessor component-inline-methods :initform nil) ;; ASDF4: rename it from relative-pathname to specified-pathname. It need not be relative. ;; There is no initform and no direct accessor for this specified pathname, ;; so we only access the information through appropriate methods, after it has been processed. @@ -7136,7 +7490,8 @@ ;; For backward-compatibility, this slot is part of component rather than of child-component. ASDF4: stop it. (parent :initarg :parent :initform nil :reader component-parent) (build-operation - :initarg :build-operation :initform nil :reader component-build-operation))) + :initarg :build-operation :initform nil :reader component-build-operation)) + (:documentation "Base class for all components of a build")) (defun component-find-path (component) "Return a path from a root system to the COMPONENT. @@ -7160,11 +7515,12 @@ ;; The tree typically but not necessarily follows the filesystem hierarchy. (with-upgradability () (defclass child-component (component) () - (:documentation "A CHILD-COMPONENT is a component that may be part of + (:documentation "A CHILD-COMPONENT is a COMPONENT that may be part of a PARENT-COMPONENT.")) (defclass file-component (child-component) - ((type :accessor file-type :initarg :type))) ; no default + ((type :accessor file-type :initarg :type)) ; no default + (:documentation "a COMPONENT that represents a file")) (defclass source-file (file-component) ((type :accessor source-file-explicit-type ;; backward-compatibility :initform nil))) ;; NB: many systems have come to rely on this default. @@ -7173,7 +7529,8 @@ (defclass java-source-file (source-file) ((type :initform "java"))) (defclass static-file (source-file) - ((type :initform nil))) + ((type :initform nil)) + (:documentation "Component for a file to be included as is in the build output")) (defclass doc-file (static-file) ()) (defclass html-file (doc-file) ((type :initform "html"))) @@ -7191,10 +7548,13 @@ :initform nil :initarg :default-component-class :accessor module-default-component-class)) - (:documentation "A PARENT-COMPONENT is a component that may have -children."))) + (:documentation "A PARENT-COMPONENT is a component that may have children."))) (with-upgradability () + ;; (Private) Function that given a PARENT component, + ;; the list of children of which has been initialized, + ;; compute the hash-table in slot children-by-name that allows to retrieve its children by name. + ;; If ONLY-IF-NEEDED-P is defined, skip any (re)computation if the slot is already populated. (defun compute-children-by-name (parent &key only-if-needed-p) (unless (and only-if-needed-p (slot-boundp parent 'children-by-name)) (let ((hash (make-hash-table :test 'equal))) @@ -7208,15 +7568,22 @@ (with-upgradability () (defclass module (child-component parent-component) - (#+clisp (components)))) ;; backward compatibility during upgrade only + (#+clisp (components)) ;; backward compatibility during upgrade only + (:documentation "A module is a intermediate component with both a parent and children, +typically but not necessarily representing the files in a subdirectory of the build source."))) ;;;; component pathnames (with-upgradability () - (defgeneric* (component-parent-pathname) (component)) + (defgeneric* (component-parent-pathname) (component) + (:documentation "The pathname of the COMPONENT's parent, if any, or NIL")) (defmethod component-parent-pathname (component) (component-pathname (component-parent component))) + ;; The default method for component-pathname tries to extract a cached precomputed + ;; absolute-pathname from the relevant slot, and if not, computes it by merging the + ;; component-relative-pathname (which should be component-specified-pathname, it can be absolute) + ;; with the directory of the component-parent-pathname. (defmethod component-pathname ((component component)) (if (slot-boundp component 'absolute-pathname) (slot-value component 'absolute-pathname) @@ -7230,6 +7597,9 @@ (setf (slot-value component 'absolute-pathname) pathname) pathname))) + ;; Default method for component-relative-pathname: + ;; combine the contents of slot relative-pathname (from specified initarg :pathname) + ;; with the appropriate source-file-type, which defaults to the file-type of the component. (defmethod component-relative-pathname ((component component)) ;; SOURCE-FILE-TYPE below is strictly for backward-compatibility with ASDF1. ;; We ought to be able to extract this from the component alone with FILE-TYPE. @@ -7263,7 +7633,11 @@ ;;;; around-compile-hook (with-upgradability () - (defgeneric around-compile-hook (component)) + (defgeneric around-compile-hook (component) + (:documentation "An optional hook function that will be called with one argument, a thunk. +The hook function must call the thunk, that will compile code from the component, and may or may not +also evaluate the compiled results. The hook function may establish dynamic variable bindings around +this compilation, or check its results, etc.")) (defmethod around-compile-hook ((c component)) (cond ((slot-boundp c 'around-compile) @@ -7292,6 +7666,7 @@ ;;; all sub-components (of a given type) (with-upgradability () (defun sub-components (component &key (type t)) + "Compute the transitive sub-components of given COMPONENT that are of given TYPE" (while-collecting (c) (labels ((recurse (x) (when (if-let (it (component-if-feature x)) (featurep it) t) @@ -7325,12 +7700,33 @@ (in-package :asdf/system) (with-upgradability () - (defgeneric* (find-system) (system &optional error-p)) + ;; The method is actually defined in asdf/find-system, + ;; but we declare the function here to avoid a forward reference. + (defgeneric* (find-system) (system &optional error-p) + (:documentation "Given a system designator, find the actual corresponding system object. +If no system is found, then signal an error if ERROR-P is true (the default), or else return NIL. +A system designator is usually a string (conventionally all lowercase) or a symbol, designating +the same system as its downcased name; it can also be a system object (designating itself).")) (defgeneric* (system-source-file :supersede #-clisp t #+clisp nil) (system) (:documentation "Return the source file in which system is defined.")) - (defgeneric component-build-pathname (component)) + ;; This is bad design, but was the easiest kluge I found to let the user specify that + ;; some special actions create outputs at locations controled by the user that are not affected + ;; by the usual output-translations. + ;; TODO: Fix operate to stop passing flags to operation (which in the current design shouldn't + ;; have any flags, since the stamp cache, etc., can't distinguish them), and instead insert + ;; *there* the ability of specifying special output paths, not in the system definition. + (defgeneric component-build-pathname (component) + (:documentation "The COMPONENT-BUILD-PATHNAME, when defined and not null, specifies the +output pathname for the action using the COMPONENT-BUILD-OPERATION. + +NB: This interface is subject to change. Please contact ASDF maintainers if you use it.")) + + ;; TODO: Should this have been made a SYSTEM-ENTRY-POINT instead? + (defgeneric component-entry-point (component) + (:documentation "The COMPONENT-ENTRY-POINT, when defined, specifies what function to call +(with no argument) when running an image dumped from the COMPONENT. - (defgeneric component-entry-point (component)) +NB: This interface is subject to change. Please contact ASDF maintainers if you use it.")) (defmethod component-entry-point ((c component)) nil)) @@ -7341,7 +7737,9 @@ (defclass proto-system () ; slots to keep when resetting a system ;; To preserve identity for all objects, we'd need keep the components slots ;; but also to modify parse-component-form to reset the recycled objects. - ((name) (source-file) #|(children) (children-by-names)|#)) + ((name) (source-file) #|(children) (children-by-names)|#) + (:documentation "PROTO-SYSTEM defines the elements of identity that are preserved when +a SYSTEM is redefined and its class is modified.")) (defclass system (module proto-system) ;; Backward-compatibility: inherit from module. ASDF4: only inherit from parent-component. @@ -7369,9 +7767,14 @@ :initform nil) ;; these two are specially set in parse-component-form, so have no :INITARGs. (depends-on :reader system-depends-on :initform nil) - (weakly-depends-on :reader system-weakly-depends-on :initform nil))) + (weakly-depends-on :reader system-weakly-depends-on :initform nil)) + (:documentation "SYSTEM is the base class for top-level components that users may request +ASDF to build.")) + (defun reset-system (system &rest keys &key &allow-other-keys) + "Erase any data from a SYSTEM except its basic identity, then reinitialize it +based on supplied KEYS." (change-class (change-class system 'proto-system) 'system) (apply 'reinitialize-instance system keys))) @@ -7379,6 +7782,7 @@ ;;;; Pathnames (with-upgradability () + ;; Resolve a system designator to a system before extracting its system-source-file (defmethod system-source-file ((system-name string)) (system-source-file (find-system system-name))) (defmethod system-source-file ((system-name symbol)) @@ -7390,15 +7794,24 @@ (pathname-directory-pathname (system-source-file system-designator))) (defun (system-relative-pathname) (system name &key type) + "Given a SYSTEM, and a (Unix-style relative path) NAME of a file (or directory) of given TYPE, +return the absolute pathname of a corresponding file under that system's source code pathname." (subpathname (system-source-directory system) name :type type)) (defmethod component-pathname ((system system)) + "Given a SYSTEM, and a (Unix-style relative path) NAME of a file (or directory) of given TYPE, +return the absolute pathname of a corresponding file under that system's source code pathname." (let ((pathname (or (call-next-method) (system-source-directory system)))) (unless (and (slot-boundp system 'relative-pathname) ;; backward-compatibility with ASDF1-age (slot-value system 'relative-pathname)) ;; systems that directly access this slot. (setf (slot-value system 'relative-pathname) pathname)) pathname)) + ;; The default method of component-relative-pathname for a system: + ;; if a pathname was specified in the .asd file, it must be relative to the .asd file + ;; (actually, to its truename* if *resolve-symlinks* it true, the default). + ;; The method will return an *absolute* pathname, once again showing that the historical name + ;; component-relative-pathname is misleading and should have been component-specified-pathname. (defmethod component-relative-pathname ((system system)) (parse-unix-namestring (and (slot-boundp system 'relative-pathname) @@ -7408,14 +7821,18 @@ :ensure-absolute t :defaults (system-source-directory system))) + ;; A system has no parent; if some method wants to make a path "relative to its parent", + ;; it will instead be relative to the system itself. (defmethod component-parent-pathname ((system system)) (system-source-directory system)) + ;; Most components don't have a specified component-build-pathname, and therefore + ;; no magic redirection of their output that disregards the output-translations. (defmethod component-build-pathname ((c component)) nil)) ;;;; ------------------------------------------------------------------------- -;;;; Stamp cache +;;;; Session cache (uiop/package:define-package :asdf/cache (:use :uiop/common-lisp :uiop :asdf/upgrade) @@ -7426,35 +7843,53 @@ #:clear-configuration-and-retry #:retry)) (in-package :asdf/cache) -;;; This stamp cache is useful for: -;; * consistency of stamps used within a single run -;; * fewer accesses to the filesystem -;; * the ability to test with fake timestamps, without touching files +;;; The ASDF session cache is used to memoize some computations. It is instrumental in achieving: +;; * Consistency in the view of the world relied on by ASDF within a given session. +;; Inconsistencies in file stamps, system definitions, etc., could cause infinite loops +;; (a.k.a. stack overflows) and other erratic behavior. +;; * Speed and reliability of ASDF, with fewer side-effects from access to the filesystem, and +;; no expensive recomputations of transitive dependencies for some input-files or output-files. +;; * Testability of ASDF with the ability to fake timestamps without actually touching files. (with-upgradability () + ;; The session cache variable. + ;; NIL when outside a session, an equal hash-table when inside a session. (defvar *asdf-cache* nil) + ;; Set a session cache entry for KEY to a list of values VALUE-LIST, when inside a session. + ;; Return those values. (defun set-asdf-cache-entry (key value-list) - (apply 'values - (if *asdf-cache* - (setf (gethash key *asdf-cache*) value-list) - value-list))) + (values-list (if *asdf-cache* + (setf (gethash key *asdf-cache*) value-list) + value-list))) + ;; Unset the session cache entry for KEY, when inside a session. (defun unset-asdf-cache-entry (key) (when *asdf-cache* (remhash key *asdf-cache*))) + ;; Consult the session cache entry for KEY if present and in a session; + ;; if not present, compute it by calling the THUNK, + ;; and set the session cache entry accordingly, if in a session. + ;; Return the values from the cache and/or the thunk computation. (defun consult-asdf-cache (key &optional thunk) (if *asdf-cache* (multiple-value-bind (results foundp) (gethash key *asdf-cache*) (if foundp - (apply 'values results) + (values-list results) (set-asdf-cache-entry key (multiple-value-list (call-function thunk))))) (call-function thunk))) + ;; Syntactic sugar for consult-asdf-cache (defmacro do-asdf-cache (key &body body) `(consult-asdf-cache ,key #'(lambda () ,@body))) + ;; Compute inside a ASDF session with a cache. + ;; First, make sure an ASDF session is underway, by binding the session cache variable + ;; to a new hash-table if it's currently null (or even if it isn't, if OVERRIDE is true). + ;; Second, if a new session was started, establish restarts for retrying the overall computation. + ;; Finally, consult the cache if a KEY was specified with the THUNK as a fallback when the cache + ;; entry isn't found, or just call the THUNK if no KEY was specified. (defun call-with-asdf-cache (thunk &key override key) (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk))) (if (and *asdf-cache* (not override)) @@ -7471,9 +7906,14 @@ (format s (compatfmt "~@"))) (clear-configuration))))))) + ;; Syntactic sugar for call-with-asdf-cache (defmacro with-asdf-cache ((&key key override) &body body) `(call-with-asdf-cache #'(lambda () ,@body) :override ,override :key ,key)) + + ;;; Define specific accessor for file (date) stamp. + + ;; Normalize a namestring for use as a key in the session cache. (defun normalize-namestring (pathname) (let ((resolved (resolve-symlinks* (ensure-absolute-pathname @@ -7481,15 +7921,19 @@ 'get-pathname-defaults)))) (with-pathname-defaults () (namestring resolved)))) + ;; Compute the file stamp for a normalized namestring (defun compute-file-stamp (normalized-namestring) (with-pathname-defaults () (safe-file-write-date normalized-namestring))) + ;; Override the time STAMP associated to a given FILE in the session cache. + ;; If no STAMP is specified, recompute a new one from the filesystem. (defun register-file-stamp (file &optional (stamp nil stampp)) (let* ((namestring (normalize-namestring file)) (stamp (if stampp stamp (compute-file-stamp namestring)))) (set-asdf-cache-entry `(get-file-stamp ,namestring) (list stamp)))) + ;; Get or compute a memoized stamp for given FILE from the session cache. (defun get-file-stamp (file) (when file (let ((namestring (normalize-namestring file))) @@ -7506,7 +7950,9 @@ #:remove-entry-from-registry #:coerce-entry-to-directory #:coerce-name #:primary-system-name #:coerce-filename #:find-system #:locate-system #:load-asd - #:system-registered-p #:register-system #:registered-systems #:clear-system #:map-systems + #:system-registered-p #:registered-system #:register-system + #:registered-systems* #:registered-systems + #:clear-system #:map-systems #:missing-component #:missing-requires #:missing-parent #:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error #:load-system-definition-error #:error-name #:error-pathname #:error-condition @@ -7515,6 +7961,7 @@ #:find-system-if-being-defined #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems* + #:mark-component-preloaded ;; forward reference to asdf/operate #:sysdef-immutable-system-search #:register-immutable-system #:*immutable-systems* #:*defined-systems* #:clear-defined-systems ;; defined in source-registry, but specially mentioned here: @@ -7546,119 +7993,183 @@ (error 'formatted-system-definition-error :format-control format :format-arguments arguments)) + + ;;; Canonicalizing system names + (defun coerce-name (name) + "Given a designator for a component NAME, return the name as a string. +The designator can be a COMPONENT (designing its name; note that a SYSTEM is a component), +a SYMBOL (designing its name, downcased), or a STRING (designing itself)." (typecase name (component (component-name name)) - (symbol (string-downcase (symbol-name name))) + (symbol (string-downcase name)) (string name) (t (sysdef-error (compatfmt "~@") name)))) (defun primary-system-name (name) - ;; When a system name has slashes, the file with defsystem is named by - ;; the first of the slash-separated components. + "Given a system designator NAME, return the name of the corresponding primary system, +after which the .asd file is named. That's the first component when dividing the name +as a string by / slashes." (first (split-string (coerce-name name) :separator "/"))) (defun coerce-filename (name) + "Coerce a system designator NAME into a string suitable as a filename component. +The (current) transformation is to replace characters /:\\ each by --, +the former being forbidden in a filename component. +NB: The onus is unhappily on the user to avoid clashes." (frob-substrings (coerce-name name) '("/" ":" "\\") "--")) + + ;;; Registry of Defined Systems + (defvar *defined-systems* (make-hash-table :test 'equal) - "This is a hash table whose keys are strings, being the -names of the systems, and whose values are pairs, the first + "This is a hash table whose keys are strings -- the +names of systems -- and whose values are pairs, the first element of which is a universal-time indicating when the system definition was last updated, and the second element -of which is a system object.") +of which is a system object. + A system is referred to as \"registered\" if it is present +in this table.") (defun system-registered-p (name) + "Return a generalized boolean that is true if a system of given NAME was registered already. +NAME is a system designator, to be normalized by COERCE-NAME. +The value returned if true is a pair of a timestamp and a system object." (gethash (coerce-name name) *defined-systems*)) - (defun registered-systems () + (defun registered-system (name) + "Return a system of given NAME that was registered already, +if such a system exists. NAME is a system designator, to be +normalized by COERCE-NAME. The value returned is a system object, +or NIL if not found." + (cdr (system-registered-p name))) + + (defun registered-systems* () + "Return a list containing every registered system (as a system object)." (loop :for registered :being :the :hash-values :of *defined-systems* - :collect (coerce-name (cdr registered)))) + :collect (cdr registered))) + + (defun registered-systems () + "Return a list of the names of every registered system." + (mapcar 'coerce-name (registered-systems*))) (defun register-system (system) + "Given a SYSTEM object, register it." (check-type system system) (let ((name (component-name system))) (check-type name string) (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system) - (unless (eq system (cdr (gethash name *defined-systems*))) + (unless (eq system (registered-system name)) (setf (gethash name *defined-systems*) - (cons (if-let (file (ignore-errors (system-source-file system))) - (get-file-stamp file)) + (cons (ignore-errors (get-file-stamp (system-source-file system))) system))))) - (defvar *preloaded-systems* (make-hash-table :test 'equal)) + + ;;; Preloaded systems: in the image even if you can't find source files backing them. + + (defvar *preloaded-systems* (make-hash-table :test 'equal) + "Registration table for preloaded systems.") + + (declaim (ftype (function (t) t) mark-component-preloaded)) ; defined in asdf/operate (defun make-preloaded-system (name keys) - (apply 'make-instance (getf keys :class 'system) - :name name :source-file (getf keys :source-file) - (remove-plist-keys '(:class :name :source-file) keys))) + "Make a preloaded system of given NAME with build information from KEYS" + (let ((system (apply 'make-instance (getf keys :class 'system) + :name name :source-file (getf keys :source-file) + (remove-plist-keys '(:class :name :source-file) keys)))) + (mark-component-preloaded system) + system)) (defun sysdef-preloaded-system-search (requested) + "If REQUESTED names a system registered as preloaded, return a new system +with its registration information." (let ((name (coerce-name requested))) (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*) (when foundp (make-preloaded-system name keys))))) - (defun register-preloaded-system (system-name &rest keys) - (setf (gethash (coerce-name system-name) *preloaded-systems*) keys)) + (defun ensure-preloaded-system-registered (name) + "If there isn't a registered _defined_ system of given NAME, +and a there is a registered _preloaded_ system of given NAME, +then define and register said preloaded system." + (if-let (system (and (not (registered-system name)) (sysdef-preloaded-system-search name))) + (register-system system))) + + (defun ensure-all-preloaded-systems-registered () + "Make sure all registered preloaded systems are defined. +This function is run whenever ASDF is upgraded." + (loop :for name :being :the :hash-keys :of *preloaded-systems* + :do (ensure-preloaded-system-registered name))) + (register-hook-function '*post-upgrade-restart-hook* 'ensure-all-preloaded-systems-registered) + + (defun register-preloaded-system (system-name &rest keys &key (version t) &allow-other-keys) + "Register a system as being preloaded. If the system has not been loaded from the filesystem +yet, or if its build information is later cleared with CLEAR-SYSTEM, a dummy system will be +registered without backing filesystem information, based on KEYS (e.g. to provide a VERSION). +If VERSION is the default T, and a system was already loaded, then its version will be preserved." + (let ((name (coerce-name system-name))) + (when (eql version t) + (if-let (system (registered-system name)) + (setf (getf keys :version) (component-version system)))) + (setf (gethash name *preloaded-systems*) keys) + (ensure-preloaded-system-registered system-name))) - (dolist (s '("asdf" "uiop" "asdf-driver" "asdf-defsystem" "asdf-package-system")) - ;; don't bother with these, no one relies on them: "asdf-utils" "asdf-bundle" - (register-preloaded-system s :version *asdf-version*)) + + ;;; Immutable systems: in the image and can't be reloaded from source. (defvar *immutable-systems* nil - "An hash-set (equal hash-table mapping keys to T) of systems that are immutable, + "A hash-set (equal hash-table mapping keys to T) of systems that are immutable, i.e. already loaded in memory and not to be refreshed from the filesystem. They will be treated specially by find-system, and passed as :force-not argument to make-plan. -If you deliver an image with many systems precompiled, *and* do not want to check the filesystem -for them every time a user loads an extension, what more risk a problematic upgrade or catastrophic -downgrade, before you dump an image, use: - (setf asdf::*immutable-systems* (uiop:list-to-hash-set (asdf:already-loaded-systems)))") +For instance, to can deliver an image with many systems precompiled, that *will not* check the +filesystem for them every time a user loads an extension, what more risk a problematic upgrade + or catastrophic downgrade, before you dump an image, you may use: + (map () 'asdf:register-immutable-system (asdf:already-loaded-systems)) + +Note that direct access to this variable from outside ASDF is not supported. +Please call REGISTER-IMMUTABLE-SYSTEM to add new immutable systems, and +contact maintainers if you need a stable API to do more than that.") (defun sysdef-immutable-system-search (requested) (let ((name (coerce-name requested))) (when (and *immutable-systems* (gethash name *immutable-systems*)) - (or (cdr (system-registered-p requested)) - (sysdef-preloaded-system-search name) + (or (registered-system requested) (error 'formatted-system-definition-error - :format-control "Requested system ~A is in the *immutable-systems* set, ~ -but not loaded in memory" + :format-control "Requested system ~A registered as an immutable-system, ~ +but not even registered as defined" :format-arguments (list name)))))) - (defun register-immutable-system (system-name &key (version t)) - (let* ((system-name (coerce-name system-name)) - (registered-system (cdr (system-registered-p system-name))) - (default-version? (eql version t)) - (version (cond ((and default-version? registered-system) - (component-version registered-system)) - (default-version? nil) - (t version)))) - (unless registered-system - (register-system (make-preloaded-system system-name (list :version version)))) - (register-preloaded-system system-name :version version) + (defun register-immutable-system (system-name &rest keys) + "Register SYSTEM-NAME as preloaded and immutable. +It will automatically be considered as passed to FORCE-NOT in a plan." + (let ((system-name (coerce-name system-name))) + (apply 'register-preloaded-system system-name keys) (unless *immutable-systems* (setf *immutable-systems* (list-to-hash-set nil))) - (setf (gethash (coerce-name system-name) *immutable-systems*) t))) + (setf (gethash system-name *immutable-systems*) t))) + + + ;;; Making systems undefined. (defun clear-system (system) - "Clear the entry for a SYSTEM in the database of systems previously loaded, -unless the system appears in the table of *IMMUTABLE-SYSTEMS*. -Note that this does NOT in any way cause the code of the system to be unloaded. -Returns T if cleared or already cleared, -NIL if not cleared because the system was found to be immutable." + "Clear the entry for a SYSTEM in the database of systems previously defined. +However if the system was registered as PRELOADED (which it is if it is IMMUTABLE), +then a new system with the same name will be defined and registered in its place +from which build details will have been cleared. +Note that this does NOT in any way cause any of the code of the system to be unloaded. +Returns T if system was or is now undefined, NIL if a new preloaded system was redefined." ;; There is no "unload" operation in Common Lisp, and ;; a general such operation cannot be portably written, ;; considering how much CL relies on side-effects to global data structures. (let ((name (coerce-name system))) - (unless (and *immutable-systems* (gethash name *immutable-systems*)) - (remhash (coerce-name name) *defined-systems*) - (unset-asdf-cache-entry `(locate-system ,name)) - (unset-asdf-cache-entry `(find-system ,name)) - t))) + (remhash name *defined-systems*) + (unset-asdf-cache-entry `(find-system ,name)) + (not (ensure-preloaded-system-registered name)))) (defun clear-defined-systems () - ;; Invalidate all systems but ASDF itself, if registered. + "Clear all currently registered defined systems. +Preloaded systems (including immutable ones) will be reset, other systems will be de-registered." (loop :for name :being :the :hash-keys :of *defined-systems* :unless (equal name "asdf") :do (clear-system name))) @@ -7670,36 +8181,60 @@ FN should be a function of one argument. It will be called with an object of type asdf:system." (loop :for registered :being :the :hash-values :of *defined-systems* - :do (funcall fn (cdr registered))))) + :do (funcall fn (cdr registered)))) -;;; for the sake of keeping things reasonably neat, we adopt a -;;; convention that functions in this list are prefixed SYSDEF- -(with-upgradability () - (defvar *system-definition-search-functions* '()) + ;;; Searching for system definitions + + ;; For the sake of keeping things reasonably neat, we adopt a convention that + ;; only symbols are to be pushed to this list (rather than e.g. function objects), + ;; which makes upgrade easier. Also, the name of these symbols shall start with SYSDEF- + (defvar *system-definition-search-functions* '() + "A list that controls the ways that ASDF looks for system definitions. +It contains symbols to be funcalled in order, with a requested system name as argument, +until one returns a non-NIL result (if any), which must then be a fully initialized system object +with that name.") + + ;; Initialize and/or upgrade the *system-definition-search-functions* + ;; so it doesn't contain obsolete symbols, and does contain the current ones. (defun cleanup-system-definition-search-functions () (setf *system-definition-search-functions* (append ;; Remove known-incompatible sysdef functions from old versions of asdf. - (remove-if #'(lambda (x) (member x '(contrib-sysdef-search sysdef-find-asdf sysdef-preloaded-system-search))) - *system-definition-search-functions*) + ;; Order matters, so we can't just use set-difference. + (let ((obsolete + '(contrib-sysdef-search sysdef-find-asdf sysdef-preloaded-system-search))) + (remove-if #'(lambda (x) (member x obsolete)) *system-definition-search-functions*)) ;; Tuck our defaults at the end of the list if they were absent. ;; This is imperfect, in case they were removed on purpose, - ;; but then it will be the responsibility of whoever does that + ;; but then it will be the responsibility of whoever removes these symmbols ;; to upgrade asdf before he does such a thing rather than after. (remove-if #'(lambda (x) (member x *system-definition-search-functions*)) '(sysdef-central-registry-search sysdef-source-registry-search))))) (cleanup-system-definition-search-functions) + ;; This (private) function does the search for a system definition using *s-d-s-f*; + ;; it is to be called by locate-system. (defun search-for-system-definition (system) + ;; Search for valid definitions of the system available in the current session. + ;; Previous definitions as registered in *defined-systems* MUST NOT be considered; + ;; they will be reconciled by locate-system then find-system. + ;; There are two special treatments: first, specially search for objects being defined + ;; in the current session, to avoid definition races between several files; + ;; second, specially search for immutable systems, so they cannot be redefined. + ;; Finally, use the search functions specified in *system-definition-search-functions*. (let ((name (coerce-name system))) (flet ((try (f) (if-let ((x (funcall f name))) (return-from search-for-system-definition x)))) (try 'find-system-if-being-defined) (try 'sysdef-immutable-system-search) - (map () #'try *system-definition-search-functions*) - (try 'sysdef-preloaded-system-search)))) + (map () #'try *system-definition-search-functions*)))) + + ;;; The legacy way of finding a system: the *central-registry* + + ;; This variable contains a list of directories to be lazily searched for the requested asd + ;; by sysdef-central-registry-search. (defvar *central-registry* nil "A list of 'system directory designators' ASDF uses to find systems. @@ -7711,10 +8246,13 @@ #p\"/home/me/cl/systems/\" #p\"/usr/share/common-lisp/systems/\")) -This is for backward compatibility. -Going forward, we recommend new users should be using the source-registry. -") +This variable is for backward compatibility. +Going forward, we recommend new users should be using the source-registry.") + ;; Function to look for an asd file of given NAME under a directory provided by DEFAULTS. + ;; Return the truename of that file if it is found and TRUENAME is true. + ;; Return NIL if the file is not found. + ;; On Windows, follow shortcuts to .asd files. (defun probe-asd (name defaults &key truename) (block nil (when (directory-pathname-p defaults) @@ -7737,6 +8275,7 @@ (when (probe-file* shortcut) (ensure-pathname (parse-windows-shortcut shortcut) :namestring :native))))))))) + ;; Function to push onto *s-d-s-f* to use the *central-registry* (defun sysdef-central-registry-search (system) (let ((name (primary-system-name system)) (to-remove nil) @@ -7784,21 +8323,35 @@ (list new) (subseq *central-registry* (1+ position)))))))))) + + ;;; Methods for find-system + + ;; Reject NIL as a system designator. (defmethod find-system ((name null) &optional (error-p t)) (when error-p (sysdef-error (compatfmt "~@")))) + ;; Default method for find-system: resolve the argument using COERCE-NAME. (defmethod find-system (name &optional (error-p t)) (find-system (coerce-name name) error-p)) (defun find-system-if-being-defined (name) - ;; notable side effect: mark the system as being defined, to avoid infinite loops + ;; This function finds systems being defined *in the current ASDF session*, as embodied by + ;; its session cache, even before they are fully defined and registered in *defined-systems*. + ;; The purpose of this function is to prevent races between two files that might otherwise + ;; try overwrite each other's system objects, resulting in infinite loops and stack overflow. + ;; This function explicitly MUST NOT find definitions merely registered in previous sessions. + ;; NB: this function depends on a corresponding side-effect in parse-defsystem; + ;; the precise protocol between the two functions may change in the future (or not). (first (gethash `(find-system ,(coerce-name name)) *asdf-cache*))) (defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname))) &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*)) - ;; Tries to load system definition with canonical NAME from PATHNAME. + "Load system definitions from PATHNAME. +NAME if supplied is the name of a system expected to be defined in that file. + +Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD." (with-asdf-cache () (with-standard-io-syntax (let ((*package* (find-package :asdf-user)) @@ -7813,16 +8366,19 @@ ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings. (pathname-directory-pathname (physicalize-pathname pathname)))) (handler-bind - ((error #'(lambda (condition) - (error 'load-system-definition-error - :name name :pathname pathname - :condition condition)))) + (((and error (not missing-component)) + #'(lambda (condition) + (error 'load-system-definition-error + :name name :pathname pathname :condition condition)))) (asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%") name pathname) (load* pathname :external-format external-format)))))) (defvar *old-asdf-systems* (make-hash-table :test 'equal)) + ;; (Private) function to check that a system that was found isn't an asdf downgrade. + ;; Returns T if everything went right, NIL if the system was an ASDF of the same or older version, + ;; that shall not be loaded. Also issue a warning if it was a strictly older version of ASDF. (defun check-not-old-asdf-system (name pathname) (or (not (equal name "asdf")) (null pathname) @@ -7875,37 +8431,39 @@ either associated with FOUND-SYSTEM, or with the PREVIOUS system. PREVIOUS when not null is a previously loaded SYSTEM object of same name. PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded." - (let* ((name (coerce-name name)) - (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk - (previous (cdr in-memory)) - (previous (and (typep previous 'system) previous)) - (previous-time (car in-memory)) - (found (search-for-system-definition name)) - (found-system (and (typep found 'system) found)) - (pathname (ensure-pathname - (or (and (typep found '(or pathname string)) (pathname found)) - (and found-system (system-source-file found-system)) - (and previous (system-source-file previous))) - :want-absolute t :resolve-symlinks *resolve-symlinks*)) - (foundp (and (or found-system pathname previous) t))) - (check-type found (or null pathname system)) - (unless (check-not-old-asdf-system name pathname) - (cond - (previous (setf found nil pathname nil)) - (t - (setf found (sysdef-preloaded-system-search "asdf")) - (assert (typep found 'system)) - (setf found-system found pathname nil)))) - (values foundp found-system pathname previous previous-time))) - + (with-asdf-cache () ;; NB: We don't cache the results. We once used to, but it wasn't useful, + ;; and keeping a negative cache was a bug (see lp#1335323), which required + ;; explicit invalidation in clear-system and find-system (when unsucccessful). + (let* ((name (coerce-name name)) + (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk + (previous (cdr in-memory)) + (previous (and (typep previous 'system) previous)) + (previous-time (car in-memory)) + (found (search-for-system-definition name)) + (found-system (and (typep found 'system) found)) + (pathname (ensure-pathname + (or (and (typep found '(or pathname string)) (pathname found)) + (and found-system (system-source-file found-system)) + (and previous (system-source-file previous))) + :want-absolute t :resolve-symlinks *resolve-symlinks*)) + (foundp (and (or found-system pathname previous) t))) + (check-type found (or null pathname system)) + (unless (check-not-old-asdf-system name pathname) + (check-type previous system) ;; asdf is preloaded, so there should be a previous one. + (setf found-system nil pathname nil)) + (values foundp found-system pathname previous previous-time)))) + + ;; Main method for find-system: first, make sure the computation is memoized in a session cache. + ;; unless the system is immutable, use locate-system to find the primary system; + ;; reconcile the finding (if any) with any previous definition (in a previous session, + ;; preloaded, with a previous configuration, or before filesystem changes), and + ;; load a found .asd if appropriate. Finally, update registration table and return results. (defmethod find-system ((name string) &optional (error-p t)) (with-asdf-cache (:key `(find-system ,name)) (let ((primary-name (primary-system-name name))) (unless (equal name primary-name) (find-system primary-name nil))) - (or (and *immutable-systems* (gethash name *immutable-systems*) - (or (cdr (system-registered-p name)) - (sysdef-preloaded-system-search name))) + (or (and *immutable-systems* (gethash name *immutable-systems*) (registered-system name)) (multiple-value-bind (foundp found-system pathname previous previous-time) (locate-system name) (assert (eq foundp (and (or found-system pathname previous) t))) @@ -7925,9 +8483,10 @@ (physicalize-pathname pathname) (physicalize-pathname previous-pathname)))) (stamp<= stamp previous-time)))))) - ;; only load when it's a pathname that is different or has newer content, and not an old asdf + ;; Only load when it's a pathname that is different or has newer content. (load-asd pathname :name name))) - (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed + ;; Try again after having loaded from disk if needed + (let ((in-memory (system-registered-p name))) (cond (in-memory (when pathname @@ -7935,8 +8494,7 @@ (cdr in-memory)) (error-p (error 'missing-component :requires name)) - (t ;; not found: don't keep negative cache, see lp#1335323 - (unset-asdf-cache-entry `(locate-system ,name)) + (t (return-from find-system nil))))))))) ;;;; ------------------------------------------------------------------------- ;;;; Finding components @@ -7990,38 +8548,58 @@ ;;;; Finding components (with-upgradability () - (defgeneric* (find-component) (base path) - (:documentation "Find a component by resolving the PATH starting from BASE parent")) - (defgeneric resolve-dependency-combination (component combinator arguments)) - - (defmethod find-component ((base string) path) - (let ((s (find-system base nil))) - (and s (find-component s path)))) - - (defmethod find-component ((base symbol) path) + (defgeneric* (find-component) (base path &key registered) + (:documentation "Find a component by resolving the PATH starting from BASE parent. +If REGISTERED is true, only search currently registered systems.")) + (defgeneric resolve-dependency-combination (component combinator arguments) + (:documentation "Return a component satisfying the dependency specification (COMBINATOR . ARGUMENTS) +in the context of COMPONENT")) + + ;; Methods for find-component + + ;; If the base component is a string, resolve it as a system, then if not nil follow the path. + (defmethod find-component ((base string) path &key registered) + (if-let ((s (if registered + (registered-system base) + (find-system base nil)))) + (find-component s path :registered registered))) + + ;; If the base component is a symbol, coerce it to a name if not nil, and resolve that. + ;; If nil, use the path as base if not nil, or else return nil. + (defmethod find-component ((base symbol) path &key registered) (cond - (base (find-component (coerce-name base) path)) - (path (find-component path nil)) + (base (find-component (coerce-name base) path :registered registered)) + (path (find-component path nil :registered registered)) (t nil))) - (defmethod find-component ((base cons) path) - (find-component (car base) (cons (cdr base) path))) - - (defmethod find-component ((parent parent-component) (name string)) - (compute-children-by-name parent :only-if-needed-p t) ;; SBCL may miss the u-i-f-r-c method!!! + ;; If the base component is a cons cell, resolve its car, and add its cdr to the path. + (defmethod find-component ((base cons) path &key registered) + (find-component (car base) (cons (cdr base) path) :registered registered)) + + ;; If the base component is a parent-component and the path a string, find the named child. + (defmethod find-component ((parent parent-component) (name string) &key registered) + (declare (ignorable registered)) + (compute-children-by-name parent :only-if-needed-p t) (values (gethash name (component-children-by-name parent)))) - (defmethod find-component (base (name symbol)) + ;; If the path is a symbol, coerce it to a name if non-nil, or else just return the base. + (defmethod find-component (base (name symbol) &key registered) (if name - (find-component base (coerce-name name)) + (find-component base (coerce-name name) :registered registered) base)) - (defmethod find-component ((c component) (name cons)) - (find-component (find-component c (car name)) (cdr name))) - - (defmethod find-component ((base t) (actual component)) + ;; If the path is a cons, first resolve its car as path, then its cdr. + (defmethod find-component ((c component) (name cons) &key registered) + (find-component (find-component c (car name) :registered registered) + (cdr name) :registered registered)) + + ;; If the path is a component, return it, disregarding the base. + (defmethod find-component ((base t) (actual component) &key registered) + (declare (ignorable registered)) actual) + ;; Resolve dependency NAME in the context of a COMPONENT, with given optional VERSION constraint. + ;; This (private) function is used below by RESOLVE-DEPENDENCY-SPEC and by the :VERSION spec. (defun resolve-dependency-name (component name &optional version) (loop (restart-case @@ -8052,16 +8630,19 @@ (unset-asdf-cache-entry `(find-system ,name)) (unset-asdf-cache-entry `(locate-system ,name)))))))) - + ;; Resolve dependency specification DEP-SPEC in the context of COMPONENT. + ;; This is notably used by MAP-DIRECT-DEPENDENCIES to process the results of COMPONENT-DEPENDS-ON + ;; and by PARSE-DEFSYSTEM to process DEFSYSTEM-DEPENDS-ON. (defun resolve-dependency-spec (component dep-spec) (let ((component (find-component () component))) (if (atom dep-spec) (resolve-dependency-name component dep-spec) (resolve-dependency-combination component (car dep-spec) (cdr dep-spec))))) + ;; Methods for RESOLVE-DEPENDENCY-COMBINATION to parse lists as dependency specifications. (defmethod resolve-dependency-combination (component combinator arguments) - (error (compatfmt "~@") - (cons combinator arguments) component)) + (parameter-error (compatfmt "~@") + 'resolve-dependency-combination (cons combinator arguments) component)) (defmethod resolve-dependency-combination (component (combinator (eql :feature)) arguments) (when (featurep (first arguments)) @@ -8092,11 +8673,20 @@ (with-upgradability () (defclass operation () - ((original-initargs ;; for backward-compat -- used by GBBopen and swank (via operation-forced) - :initform nil :initarg :original-initargs :accessor operation-original-initargs))) - - ;; Cache a copy of the INITARGS in the ORIGINAL-INITARGS slot, if that slot is not - ;; already bound. + ((original-initargs ;; for backward-compat -- used by GBBopen, and swank (via operation-forced) + :initform nil :initarg :original-initargs :accessor operation-original-initargs)) + (:documentation "The base class for all ASDF operations. + +ASDF does NOT, never did and never will distinguish between multiple operations of the same class. +Therefore, all slots of all operations must have (:allocation class) and no initargs. + +Any exceptions currently maintained for backward-compatibility are deprecated, +and support for them may be discontinued at any moment. +")) + + ;; Cache a copy of the INITARGS in the ORIGINAL-INITARGS slot, if that slot is not already bound. + ;; This is a deprecated feature temporarily maintained for backward compatibility. + ;; It will be removed at some point in the future. (defmethod initialize-instance :after ((o operation) &rest initargs &key force force-not system verbose &allow-other-keys) (declare (ignore force force-not system verbose)) @@ -8111,14 +8701,23 @@ ;;; make-operation, find-operation (with-upgradability () + ;; A table to memoize instances of a given operation. There shall be only one. (defparameter* *operations* (make-hash-table :test 'equal)) + ;; A memoizing way of creating instances of operation. (defun make-operation (operation-class &rest initargs) + "This function creates and memoizes an instance of OPERATION-CLASS. +All operation instances MUST be created through this function. + +Use of INITARGS is for backward compatibility and may be discontinued at any time." (let ((class (coerce-class operation-class :package :asdf/interface :super 'operation :error 'sysdef-error))) (ensure-gethash (cons class initargs) *operations* (list* 'make-instance class initargs)))) + ;; We preserve the operation-original-initargs of the context, + ;; but only as an unsupported feature. + ;; This is all done purely for the temporary sake of backwards compatibility. (defgeneric find-operation (context spec) (:documentation "Find an operation by resolving the SPEC in the CONTEXT")) (defmethod find-operation ((context t) (spec operation)) @@ -8156,29 +8755,49 @@ (in-package :asdf/action) (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) ;; LispWorks issues spurious warning - (deftype action () '(cons operation component)) ;; a step to be performed while building + + (deftype action () + "A pair of operation and component uniquely identifies a node in the dependency graph +of steps to be performed while building a system." + '(cons operation component)) (deftype operation-designator () - ;; an operation designates itself, - ;; nil designates a context-dependent current operation, and - ;; class-name or class designates an instance of the designated class. + "An operation designates itself. NIL designates a context-dependent current operation, +and a class-name or class designates the canonical instance of the designated class." '(or operation null symbol class))) + +;;; TODO: These should be moved to asdf/plan and be made simple defuns. (with-upgradability () (defgeneric traverse-actions (actions &key &allow-other-keys)) (defgeneric traverse-sub-actions (operation component &key &allow-other-keys)) (defgeneric required-components (component &key &allow-other-keys))) -;;;; Reified representation for storage or debugging. Note: dropping original-initargs + +;;;; Reified representation for storage or debugging. Note: it drops the operation-original-initargs (with-upgradability () (defun action-path (action) + "A readable data structure that identifies the action." (destructuring-bind (o . c) action (cons (type-of o) (component-find-path c)))) (defun find-action (path) + "Reconstitute an action from its action-path" (destructuring-bind (o . c) path (cons (make-operation o) (find-component () c))))) ;;;; Convenience methods (with-upgradability () + ;; A macro that defines convenience methods for a generic function (gf) that + ;; dispatches on operation and component. The convenience methods allow users + ;; to call the gf with operation and/or component designators, that the + ;; methods will resolve into actual operation and component objects, so that + ;; the users can interact using readable designators, but developers only have + ;; to write methods that handle operation and component objects. + ;; FUNCTION is the generic function name + ;; FORMALS is its list of arguments, which must include OPERATION and COMPONENT. + ;; IF-NO-OPERATION is a form (defaults to NIL) describing what to do if no operation is found. + ;; IF-NO-COMPONENT is a form (defaults to NIL) describing what to do if no component is found. + ;; If OPERATION-INITARGS is true, then for backward compatibility the function has + ;; a &rest argument that is passed into the operation's initargs if and when it is created. (defmacro define-convenience-action-methods (function formals &key if-no-operation if-no-component operation-initargs) (let* ((rest (gensym "REST")) @@ -8228,12 +8847,18 @@ (defmethod action-description (operation component) (format nil (compatfmt "~@<~A on ~A~@:>") (type-of operation) component)) - (defgeneric* (explain) (operation component)) + + ;; This is for compatibility with ASDF 1, and is deprecated. + ;; TODO: move it to backward-interface + (defgeneric* (explain) (operation component) + (:documentation "Display a message describing an action")) (defmethod explain ((o operation) (c component)) (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c))) (define-convenience-action-methods explain (operation component)) (defun format-action (stream action &optional colon-p at-sign-p) + "FORMAT helper to display an action's action-description. +Use it in FORMAT control strings as ~/asdf-action:format-action/" (assert (null colon-p)) (assert (null at-sign-p)) (destructuring-bind (operation . component) action (princ (action-description operation component) stream)))) @@ -8394,10 +9019,22 @@ ;;;; Inputs, Outputs, and invisible dependencies (with-upgradability () - (defgeneric* (output-files) (operation component)) - (defgeneric* (input-files) (operation component)) + (defgeneric* (output-files) (operation component) + (:documentation "Methods for this function return two values: a list of output files +corresponding to this action, and a boolean indicating if they have already been subjected +to relevant output translations and should not be further translated. + +Methods on PERFORM *must* call this function to determine where their outputs are to be located. +They may rely on the order of the files to discriminate between outputs. +")) + (defgeneric* (input-files) (operation component) + (:documentation "A list of input files corresponding to this action. + +Methods on PERFORM *must* call this function to determine where their inputs are located. +They may rely on the order of the files to discriminate between inputs. +")) (defgeneric* (operation-done-p) (operation component) - (:documentation "Returns a boolean, which is NIL if the action is forced to be performed again")) + (:documentation "Returns a boolean which is NIL if the action must be performed (again).")) (define-convenience-action-methods output-files (operation component)) (define-convenience-action-methods input-files (operation component)) (define-convenience-action-methods operation-done-p (operation component)) @@ -8405,8 +9042,8 @@ (defmethod operation-done-p ((o operation) (c component)) t) + ;; Translate output files, unless asked not to. Memoize the result. (defmethod output-files :around (operation component) - "Translate output files, unless asked not to. Memoize the result." operation component ;; hush genera, not convinced by declare ignorable(!) (do-asdf-cache `(output-files ,operation ,component) (values @@ -8431,14 +9068,19 @@ (assert (length=n-p files 1)) (first files))) + ;; Memoize input files. (defmethod input-files :around (operation component) - "memoize input files." (do-asdf-cache `(input-files ,operation ,component) (call-next-method))) + ;; By default an action has no input-files. (defmethod input-files ((o operation) (c component)) nil) + ;; An action with a selfward-operation by default gets its input-files from the output-files of + ;; the actions using selfward-operations it depends on (and the same component), + ;; or if there are none, on the component-pathname of the component if it's a file + ;; -- and then on the results of the next-method. (defmethod input-files ((o selfward-operation) (c component)) `(,@(or (loop :for dep-o :in (ensure-list (selfward-operation o)) :append (or (output-files dep-o c) (input-files dep-o c))) @@ -8449,22 +9091,32 @@ ;;;; Done performing (with-upgradability () - (defgeneric component-operation-time (operation component)) ;; ASDF4: hide it behind plan-action-stamp + ;; ASDF4: hide it behind plan-action-stamp + (defgeneric component-operation-time (operation component) + (:documentation "Return the timestamp for when an action was last performed")) + (defgeneric (setf component-operation-time) (time operation component) + (:documentation "Update the timestamp for when an action was last performed")) (define-convenience-action-methods component-operation-time (operation component)) - (defgeneric mark-operation-done (operation component)) ;; ASDF4: hide it behind (setf plan-action-stamp) + ;; ASDF4: hide it behind (setf plan-action-stamp) + (defgeneric mark-operation-done (operation component) + (:documentation "Mark a action as having been just done. + +Updates the action's COMPONENT-OPERATION-TIME to match the COMPUTE-ACTION-STAMP +using the JUST-DONE flag.")) (defgeneric compute-action-stamp (plan operation component &key just-done) (:documentation "Has this action been successfully done already, and at what known timestamp has it been done at or will it be done at? -Takes two keywords JUST-DONE and PLAN: -JUST-DONE is a boolean that is true if the action was just successfully performed, -at which point we want compute the actual stamp and warn if files are missing; -otherwise we are making plans, anticipating the effects of the action. -PLAN is a plan object modelling future effects of actions, -or NIL to denote what actually happened. +* PLAN is a plan object modelling future effects of actions, + or NIL to denote what actually happened. +* OPERATION and COMPONENT denote the action. +Takes keyword JUST-DONE: +* JUST-DONE is a boolean that is true if the action was just successfully performed, + at which point we want compute the actual stamp and warn if files are missing; + otherwise we are making plans, anticipating the effects of the action. Returns two values: * a STAMP saying when it was done or will be done, - or T if the action has involves files that need to be recomputed. + or T if the action involves files that need to be recomputed. * a boolean DONE-P that indicates whether the action has actually been done, and both its output-files and its in-image side-effects are up to date.")) @@ -8486,15 +9138,17 @@ (defmethod component-operation-time ((o operation) (c component)) (gethash (type-of o) (component-operation-times c))) + (defmethod (setf component-operation-time) (stamp (o operation) (c component)) + (setf (gethash (type-of o) (component-operation-times c)) stamp)) + (defmethod mark-operation-done ((o operation) (c component)) - (setf (gethash (type-of o) (component-operation-times c)) - (compute-action-stamp nil o c :just-done t)))) + (setf (component-operation-time o c) (compute-action-stamp nil o c :just-done t)))) ;;;; Perform (with-upgradability () - (defgeneric* (perform-with-restarts) (operation component)) - (defgeneric* (perform) (operation component)) + (defgeneric* (perform) (operation component) + (:documentation "PERFORM an action, consuming its input-files and building its output-files")) (define-convenience-action-methods perform (operation component)) (defmethod perform :before ((o operation) (c component)) @@ -8511,10 +9165,12 @@ (compatfmt "~@") 'perform (cons o c)))) + ;; The restarts of the perform-with-restarts variant matter in an interactive context. + ;; The retry strategies of p-w-r itself, and/or the background workers of a multiprocess build + ;; may call perform directly rather than call p-w-r. + (defgeneric* (perform-with-restarts) (operation component) + (:documentation "PERFORM an action in a context where suitable restarts are in place.")) (defmethod perform-with-restarts (operation component) - ;; TOO verbose, especially as the default. Add your own :before method - ;; to perform-with-restart or perform if you want that: - #|(explain operation component)|# (perform operation component)) (defmethod perform-with-restarts :around (operation component) (loop @@ -8555,42 +9211,57 @@ ;;;; Component classes (with-upgradability () (defclass cl-source-file (source-file) - ((type :initform "lisp"))) + ((type :initform "lisp")) + (:documentation "Component class for a Common Lisp source file (using type \"lisp\")")) (defclass cl-source-file.cl (cl-source-file) - ((type :initform "cl"))) + ((type :initform "cl")) + (:documentation "Component class for a Common Lisp source file using type \"cl\"")) (defclass cl-source-file.lsp (cl-source-file) - ((type :initform "lsp")))) + ((type :initform "lsp")) + (:documentation "Component class for a Common Lisp source file using type \"lsp\""))) ;;;; Operation classes (with-upgradability () - (defclass basic-load-op (operation) ()) + (defclass basic-load-op (operation) () + (:documentation "Base class for operations that apply the load-time effects of a file")) (defclass basic-compile-op (operation) + ;; NB: These slots are deprecated. They are for backward compatibility only, + ;; and will be removed at some point in the future. ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil) - (flags :initarg :flags :accessor compile-op-flags :initform nil)))) + (flags :initarg :flags :accessor compile-op-flags :initform nil)) + (:documentation "Base class for operations that apply the compile-time effects of a file"))) + ;;; Our default operations: loading into the current lisp image (with-upgradability () (defclass prepare-op (upward-operation sideway-operation) ((sideway-operation :initform 'load-op :allocation :class)) - (:documentation "Load dependencies necessary for COMPILE-OP or LOAD-OP of a given COMPONENT.")) + (:documentation "Load the dependencies for the COMPILE-OP or LOAD-OP of a given COMPONENT.")) (defclass load-op (basic-load-op downward-operation selfward-operation) ;; NB: even though compile-op depends on prepare-op it is not needed-in-image-p, ;; so we need to directly depend on prepare-op for its side-effects in the current image. - ((selfward-operation :initform '(prepare-op compile-op) :allocation :class))) + ((selfward-operation :initform '(prepare-op compile-op) :allocation :class)) + (:documentation "Operation for loading the compiled FASL for a Lisp file")) (defclass compile-op (basic-compile-op downward-operation selfward-operation) - ((selfward-operation :initform 'prepare-op :allocation :class))) + ((selfward-operation :initform 'prepare-op :allocation :class)) + (:documentation "Operation for compiling a Lisp file to a FASL")) + (defclass prepare-source-op (upward-operation sideway-operation) - ((sideway-operation :initform 'load-source-op :allocation :class))) + ((sideway-operation :initform 'load-source-op :allocation :class)) + (:documentation "Operation for loading the dependencies of a Lisp file as source.")) (defclass load-source-op (basic-load-op downward-operation selfward-operation) - ((selfward-operation :initform 'prepare-source-op :allocation :class))) + ((selfward-operation :initform 'prepare-source-op :allocation :class)) + (:documentation "Operation for loading a Lisp file as source.")) (defclass test-op (selfward-operation) - ((selfward-operation :initform 'load-op :allocation :class)))) + ((selfward-operation :initform 'load-op :allocation :class)) + (:documentation "Operation for running the tests for system. +If the tests fail, an error will be signaled."))) -;;;; prepare-op, compile-op and load-op +;;;; Methods for prepare-op, compile-op and load-op ;;; prepare-op (with-upgradability () @@ -8607,14 +9278,19 @@ (format nil (compatfmt "~@") c)) (defmethod action-description ((o compile-op) (c parent-component)) (format nil (compatfmt "~@") c)) - (defgeneric call-with-around-compile-hook (component thunk)) + (defgeneric call-with-around-compile-hook (component thunk) + (:documentation "A method to be called around the PERFORM'ing of actions that apply the +compile-time side-effects of file (i.e., COMPILE-OP or LOAD-SOURCE-OP). This method can be used +to setup readtables and other variables that control reading, macroexpanding, and compiling, etc. +Note that it will NOT be called around the performing of LOAD-OP.")) (defmethod call-with-around-compile-hook ((c component) function) (call-around-hook (around-compile-hook c) function)) (defun perform-lisp-compilation (o c) + "Perform the compilation of the Lisp file associated to the specified action (O . C)." (let (;; Before 2.26.53, that was unfortunately component-pathname. Now, ;; we consult input-files, the first of which should be the one to compile-file (input-file (first (input-files o c))) - ;; on some implementations, there are more than one output-file, + ;; On some implementations, there are more than one output-file, ;; but the first one should always be the primary fasl that gets loaded. (outputs (output-files o c))) (multiple-value-bind (output warnings-p failure-p) @@ -8623,7 +9299,13 @@ &optional #+(or clasp ecl mkcl) object-file #+clisp lib-file - warnings-file) outputs + warnings-file &rest rest) outputs + ;; Allow for extra outputs that are not of type warnings-file + ;; The way we do it is kludgy. In ASDF4, output-files shall not be positional. + (declare (ignore rest)) + (when warnings-file + (unless (equal (pathname-type warnings-file) (warnings-file-type)) + (setf warnings-file nil))) (call-with-around-compile-hook c #'(lambda (&rest flags) (apply 'compile-file* input-file @@ -8636,10 +9318,11 @@ flags (compile-op-flags o)))))) (check-lisp-compile-results output warnings-p failure-p "~/asdf-action::format-action/" (list (cons o c)))))) - (defun report-file-p (f) + "Is F a build report file containing, e.g., warnings to check?" (equalp (pathname-type f) "build-report")) (defun perform-lisp-warnings-check (o c) + "Check the warnings associated with the dependencies of an action." (let* ((expected-warnings-files (remove-if-not #'warnings-file-p (input-files o c))) (actual-warnings-files (loop :for w :in expected-warnings-files :when (get-file-stamp w) @@ -8655,6 +9338,8 @@ (defmethod perform ((o compile-op) (c cl-source-file)) (perform-lisp-compilation o c)) (defun lisp-compilation-output-files (o c) + "Compute the output-files for compiling the Lisp file for the specified action (O . C), +an OPERATION and a COMPONENT." (let* ((i (first (input-files o c))) (f (compile-file-pathname i #+clasp :output-type #+ecl :type #+(or clasp ecl) :fasl @@ -8676,6 +9361,8 @@ (lisp-compilation-output-files o c)) (defmethod perform ((o compile-op) (c static-file)) nil) + + ;; Performing compile-op on a system will check the deferred warnings for the system (defmethod perform ((o compile-op) (c system)) (when (and *warnings-file-type* (not (builtin-system-p c))) (perform-lisp-warnings-check o c))) @@ -8709,6 +9396,8 @@ (component-name c))) (perform (find-operation o 'compile-op) c))))) (defun perform-lisp-load-fasl (o c) + "Perform the loading of a FASL associated to specified action (O . C), +an OPERATION and a COMPONENT." (if-let (fasl (first (input-files o c))) (load* fasl))) (defmethod perform ((o load-op) (c cl-source-file)) @@ -8735,6 +9424,7 @@ (defmethod action-description ((o load-source-op) (c parent-component)) (format nil (compatfmt "~@") c)) (defun perform-lisp-load-source (o c) + "Perform the loading of a Lisp file as associated to specified action (O . C)" (call-with-around-compile-hook c #'(lambda () (load* (first (input-files o c)) @@ -8753,7 +9443,6 @@ (defmethod operation-done-p ((o test-op) (c system)) "Testing a system is _never_ done." nil)) - ;;;; ------------------------------------------------------------------------- ;;;; Plan @@ -8764,7 +9453,7 @@ :asdf/cache :asdf/find-system :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-action) (:export - #:component-operation-time #:mark-operation-done + #:component-operation-time #:plan #:plan-traversal #:sequential-plan #:*default-plan-class* #:planned-action-status #:plan-action-status #:action-already-done-p #:circular-dependency #:circular-dependency-actions @@ -8788,17 +9477,28 @@ ;;;; Generic plan traversal class (with-upgradability () - (defclass plan () ()) + (defclass plan () () + (:documentation "Base class for a plan based on which ASDF can build a system")) (defclass plan-traversal (plan) - ((system :initform nil :initarg :system :accessor plan-system) + (;; The system for which the plan is computed + (system :initform nil :initarg :system :accessor plan-system) + ;; Table of systems specified via :force arguments (forced :initform nil :initarg :force :accessor plan-forced) + ;; Table of systems specified via :force-not argument (and/or immutable) (forced-not :initform nil :initarg :force-not :accessor plan-forced-not) + ;; Counts of total actions in plan (total-action-count :initform 0 :accessor plan-total-action-count) + ;; Count of actions that need to be performed (planned-action-count :initform 0 :accessor plan-planned-action-count) + ;; Count of actions that need to be performed that have a non-empty list of output-files. (planned-output-action-count :initform 0 :accessor plan-planned-output-action-count) + ;; Table that to actions already visited while walking the dependencies associates status (visited-actions :initform (make-hash-table :test 'equal) :accessor plan-visited-actions) - (visiting-action-set :initform (make-hash-table :test 'equal) :accessor plan-visiting-action-set) - (visiting-action-list :initform () :accessor plan-visiting-action-list)))) + ;; Actions that depend on those being currently walked through, to detect circularities + (visiting-action-set ;; as a set + :initform (make-hash-table :test 'equal) :accessor plan-visiting-action-set) + (visiting-action-list :initform () :accessor plan-visiting-action-list)) ;; as a list + (:documentation "Base class for plans that simply traverse dependencies"))) ;;;; Planned action status @@ -8828,12 +9528,15 @@ (defmethod action-planned-p ((action-status t)) t) ; default method for non planned-action-status objects - ;; TODO: eliminate NODE-FOR, use CONS. - ;; Supposes cleaner protocol for operation initargs passed to MAKE-OPERATION. + ;; TODO: either confirm there are no operation-original-initargs, eliminate NODE-FOR, + ;; and use (CONS O C); or keep the operation initargs, and here use MAKE-OPERATION. ;; However, see also component-operation-time and mark-operation-done - (defun node-for (o c) (cons (type-of o) c)) + (defun node-for (o c) + "Given operation O and component C, return an object to use as key in action-indexed tables." + (cons (type-of o) c)) (defun action-already-done-p (plan operation component) + "According to this plan, is this action already done and up to date?" (action-done-p (plan-action-status plan operation component))) (defmethod plan-action-status ((plan null) (o operation) (c component)) @@ -8851,28 +9554,41 @@ ;;;; forcing (with-upgradability () - (defgeneric action-forced-p (plan operation component)) - (defgeneric action-forced-not-p (plan operation component)) - - (defun normalize-forced-systems (x system) - (etypecase x - ((or (member nil :all) hash-table function) x) - (cons (list-to-hash-set (mapcar #'coerce-name x))) + (defgeneric action-forced-p (plan operation component) + (:documentation "Is this action forced to happen in this plan?")) + (defgeneric action-forced-not-p (plan operation component) + (:documentation "Is this action forced to not happen in this plan? +Takes precedence over action-forced-p.")) + + (defun normalize-forced-systems (force system) + "Given a SYSTEM on which operate is called and the specified FORCE argument, +extract a hash-set of systems that are forced, or a predicate on system names, +or NIL if none are forced, or :ALL if all are." + (etypecase force + ((or (member nil :all) hash-table function) force) + (cons (list-to-hash-set (mapcar #'coerce-name force))) ((eql t) (when system (list-to-hash-set (list (coerce-name system))))))) - (defun normalize-forced-not-systems (x system) + (defun normalize-forced-not-systems (force-not system) + "Given a SYSTEM on which operate is called, the specified FORCE-NOT argument, +and the set of IMMUTABLE systems, extract a hash-set of systems that are effectively forced-not, +or predicate on system names, or NIL if none are forced, or :ALL if all are." (let ((requested - (etypecase x - ((or (member nil :all) hash-table function) x) - (cons (list-to-hash-set (mapcar #'coerce-name x))) + (etypecase force-not + ((or (member nil :all) hash-table function) force-not) + (cons (list-to-hash-set (mapcar #'coerce-name force-not))) ((eql t) (if system (let ((name (coerce-name system))) #'(lambda (x) (not (equal x name)))) - t))))) + :all))))) (if (and *immutable-systems* requested) - #'(lambda (x) (or (call-function requested x) (call-function *immutable-systems* x))) + #'(lambda (x) (or (call-function requested x) + (call-function *immutable-systems* x))) (or *immutable-systems* requested)))) + ;; TODO: shouldn't we be looking up the primary system name, rather than the system name? (defun action-override-p (plan operation component override-accessor) + "Given a plan, an action, and a function that given the plan accesses a set of overrides +(i.e. force or force-not), see if the override applies to the current action." (declare (ignore operation)) (call-function (funcall override-accessor plan) (coerce-name (component-system (find-component () component))))) @@ -8882,7 +9598,7 @@ ;; Did the user ask us to re-perform the action? (action-override-p plan operation component 'plan-forced) ;; You really can't force a builtin system and :all doesn't apply to it, - ;; except it it's the specifically the system currently being built. + ;; except if it's the specifically the system currently being built. (not (let ((system (component-system component))) (and (builtin-system-p system) (not (eq system (plan-system plan)))))))) @@ -8903,17 +9619,21 @@ (with-upgradability () (defgeneric action-valid-p (plan operation component) (:documentation "Is this action valid to include amongst dependencies?")) + ;; :if-feature will invalidate actions on components for which the features don't apply. (defmethod action-valid-p ((plan t) (o operation) (c component)) (if-let (it (component-if-feature c)) (featurep it) t)) + ;; If either the operation or component was resolved to nil, the action is invalid. (defmethod action-valid-p ((plan t) (o null) (c t)) nil) (defmethod action-valid-p ((plan t) (o t) (c null)) nil) + ;; If the plan is null, i.e., we're looking at reality, + ;; then any action with actual operation and component objects is valid. (defmethod action-valid-p ((plan null) (o operation) (c component)) t)) ;;;; Is the action needed in this image? (with-upgradability () (defgeneric needed-in-image-p (operation component) - (:documentation "Is the action of OPERATION on COMPONENT needed in the current image to be meaningful, - or could it just as well have been done in another Lisp image?")) + (:documentation "Is the action of OPERATION on COMPONENT needed in the current image +to be meaningful, or could it just as well have been done in another Lisp image?")) (defmethod needed-in-image-p ((o operation) (c component)) ;; We presume that actions that modify the filesystem don't need be run @@ -8926,6 +9646,7 @@ ;;;; Visiting dependencies of an action and computing action stamps (with-upgradability () (defun (map-direct-dependencies) (plan operation component fun) + "Call FUN on all the valid dependencies of the given action in the given plan" (loop* :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component) :for dep-o = (find-operation operation dep-o-spec) :when dep-o @@ -8935,6 +9656,9 @@ :do (funcall fun dep-o dep-c)))) (defun (reduce-direct-dependencies) (plan operation component combinator seed) + "Reduce the direct dependencies to a value computed by iteratively calling COMBINATOR +for each dependency action on the dependency's operation and component and an accumulator +initialized with SEED." (map-direct-dependencies plan operation component #'(lambda (dep-o dep-c) @@ -8942,6 +9666,7 @@ seed) (defun (direct-dependencies) (plan operation component) + "Compute a list of the direct dependencies of the action within the plan" (reduce-direct-dependencies plan operation component #'acons nil)) ;; In a distant future, get-file-stamp, component-operation-time and latest-stamp @@ -8960,7 +9685,8 @@ ;; in the current image, or NIL if it hasn't. ;; Note that if e.g. LOAD-OP only depends on up-to-date files, but ;; hasn't been done in the current image yet, then it can have a non-T timestamp, - ;; yet a NIL done-in-image-p flag. + ;; yet a NIL done-in-image-p flag: we can predict what timestamp it will have once loaded, + ;; i.e. that of the input-files. (nest (block ()) (let ((dep-stamp ; collect timestamp from dependencies (or T if forced or out-of-date) @@ -8980,7 +9706,7 @@ (latest-in (stamps-latest (cons dep-stamp in-stamps)))) (when (and missing-in (not just-done)) (return (values t nil)))) ;; collect timestamps from outputs, and exit early if any is missing - (let* ((out-files (output-files o c)) + (let* ((out-files (remove-if 'null (output-files o c))) (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files)) (missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f)) (earliest-out (stamps-earliest out-stamps))) @@ -9021,11 +9747,6 @@ ;;;; Generic support for plan-traversal (with-upgradability () - (defgeneric plan-record-dependency (plan operation component)) - - (defgeneric call-while-visiting-action (plan operation component function) - (:documentation "Detect circular dependencies")) - (defmethod initialize-instance :after ((plan plan-traversal) &key force force-not system &allow-other-keys) @@ -9033,15 +9754,35 @@ (setf forced (normalize-forced-systems force system)) (setf forced-not (normalize-forced-not-systems force-not system)))) - (defmethod (setf plan-action-status) (new-status (plan plan-traversal) (o operation) (c component)) - (setf (gethash (node-for o c) (plan-visited-actions plan)) new-status)) + (defgeneric plan-actions (plan) + (:documentation "Extract from a plan a list of actions to perform in sequence")) + (defmethod plan-actions ((plan list)) + plan) + + (defmethod (setf plan-action-status) (new-status (p plan-traversal) (o operation) (c component)) + (setf (gethash (node-for o c) (plan-visited-actions p)) new-status)) + + (defmethod plan-action-status ((p plan-traversal) (o operation) (c component)) + (or (and (action-forced-not-p p o c) (plan-action-status nil o c)) + (values (gethash (node-for o c) (plan-visited-actions p))))) + + (defmethod action-valid-p ((p plan-traversal) (o operation) (s system)) + (and (not (action-forced-not-p p o s)) (call-next-method))) + + (defgeneric plan-record-dependency (plan operation component) + (:documentation "Record an action as a dependency in the current plan"))) - (defmethod plan-action-status ((plan plan-traversal) (o operation) (c component)) - (or (and (action-forced-not-p plan o c) (plan-action-status nil o c)) - (values (gethash (node-for o c) (plan-visited-actions plan))))) - (defmethod action-valid-p ((plan plan-traversal) (o operation) (s system)) - (and (not (action-forced-not-p plan o s)) (call-next-method))) +;;;; Detection of circular dependencies +(with-upgradability () + (define-condition circular-dependency (system-definition-error) + ((actions :initarg :actions :reader circular-dependency-actions)) + (:report (lambda (c s) + (format s (compatfmt "~@") + (circular-dependency-actions c))))) + + (defgeneric call-while-visiting-action (plan operation component function) + (:documentation "Detect circular dependencies")) (defmethod call-while-visiting-action ((plan plan-traversal) operation component fun) (with-accessors ((action-set plan-visiting-action-set) @@ -9055,20 +9796,15 @@ (unwind-protect (funcall fun) (pop action-list) - (setf (gethash action action-set) nil)))))) + (setf (gethash action action-set) nil))))) + + ;; Syntactic sugar for call-while-visiting-action + (defmacro while-visiting-action ((p o c) &body body) + `(call-while-visiting-action ,p ,o ,c #'(lambda () ,@body)))) ;;;; Actual traversal: traverse-action (with-upgradability () - (define-condition circular-dependency (system-definition-error) - ((actions :initarg :actions :reader circular-dependency-actions)) - (:report (lambda (c s) - (format s (compatfmt "~@") - (circular-dependency-actions c))))) - - (defmacro while-visiting-action ((p o c) &body body) - `(call-while-visiting-action ,p ,o ,c #'(lambda () ,@body))) - (defgeneric traverse-action (plan operation component needed-in-image-p)) ;; TRAVERSE-ACTION, in the context of a given PLAN object that accumulates dependency data, @@ -9121,6 +9857,8 @@ :index (if status ; index of action amongst all nodes in traversal (action-index status) ;; if already visited, keep index (incf (plan-total-action-count plan))))) ; else new index + (when (and done-p (not add-to-plan-p)) + (setf (component-operation-time operation component) stamp)) (when add-to-plan-p ; if it needs to be added to the plan, (incf (plan-planned-action-count plan)) ; count it (unless aniip ; if it's output-producing, @@ -9133,14 +9871,13 @@ ;;;; Sequential plans (the default) (with-upgradability () (defclass sequential-plan (plan-traversal) - ((actions-r :initform nil :accessor plan-actions-r))) + ((actions-r :initform nil :accessor plan-actions-r)) + (:documentation "Simplest, default plan class, accumulating a sequence of actions")) - (defgeneric plan-actions (plan)) - (defmethod plan-actions ((plan list)) - plan) (defmethod plan-actions ((plan sequential-plan)) (reverse (plan-actions-r plan))) + ;; No need to record a dependency to build a full graph, just accumulate nodes in order. (defmethod plan-record-dependency ((plan sequential-plan) (o operation) (c component)) (values)) @@ -9149,17 +9886,20 @@ (when (action-planned-p new-status) (push (cons o c) (plan-actions-r p))))) + ;;;; High-level interface: traverse, perform-plan, plan-operates-on-p (with-upgradability () (defgeneric make-plan (plan-class operation component &key &allow-other-keys) - (:documentation - "Generate and return a plan for performing OPERATION on COMPONENT.")) + (:documentation "Generate and return a plan for performing OPERATION on COMPONENT.")) (define-convenience-action-methods make-plan (plan-class operation component &key)) - (defgeneric perform-plan (plan &key)) - (defgeneric plan-operates-on-p (plan component)) + (defgeneric perform-plan (plan &key) + (:documentation "Actually perform a plan and build the requested actions")) + (defgeneric plan-operates-on-p (plan component) + (:documentation "Does this PLAN include any operation on given COMPONENT?")) - (defvar *default-plan-class* 'sequential-plan) + (defvar *default-plan-class* 'sequential-plan + "The default plan class to use when building with ASDF") (defmethod make-plan (plan-class (o operation) (c component) &rest keys &key &allow-other-keys) (let ((plan (apply 'make-instance (or plan-class *default-plan-class*) @@ -9199,12 +9939,16 @@ ((action-filter :initform t :initarg :action-filter :reader plan-action-filter) (component-type :initform t :initarg :component-type :reader plan-component-type) (keep-operation :initform t :initarg :keep-operation :reader plan-keep-operation) - (keep-component :initform t :initarg :keep-component :reader plan-keep-component))) + (keep-component :initform t :initarg :keep-component :reader plan-keep-component)) + (:documentation "A variant of SEQUENTIAL-PLAN that only records a subset of actions.")) (defmethod initialize-instance :after ((plan filtered-sequential-plan) &key force force-not - other-systems) + other-systems) (declare (ignore force force-not)) + ;; Ignore force and force-not, rely on other-systems: + ;; force traversal of what we're interested in, i.e. current system or also others; + ;; force-not traversal of what we're not interested in, i.e. other systems unless other-systems. (with-slots (forced forced-not action-filter system) plan (setf forced (normalize-forced-systems (if other-systems :all t) system)) (setf forced-not (normalize-forced-not-systems (if other-systems nil t) system)) @@ -9216,6 +9960,7 @@ (call-next-method))) (defmethod traverse-actions (actions &rest keys &key plan-class &allow-other-keys) + "Given a list of actions, build a plan with these actions as roots." (let ((plan (apply 'make-instance (or plan-class 'filtered-sequential-plan) keys))) (loop* :for (o . c) :in actions :do (traverse-action plan o c t)) plan)) @@ -9233,6 +9978,8 @@ :collect (cons o c)))) (defmethod required-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys) + "Given a SYSTEM and a GOAL-OPERATION (default LOAD-OP), traverse the dependencies and +return a list of the components involved in building the desired action." (remove-duplicates (mapcar 'cdr (plan-actions (apply 'traverse-sub-actions goal-operation system @@ -9260,36 +10007,45 @@ (with-upgradability () (defgeneric* (operate) (operation component &key &allow-other-keys) (:documentation - "Operate does three things: + "Operate does mainly four things for the user: -1. It creates an instance of OPERATION-CLASS using any keyword parameters as initargs. -2. It finds the asdf-system specified by SYSTEM (possibly loading it from disk). -3. It then calls MAKE-PLAN with the operation and system as arguments - -The operation of making a plan is wrapped in WITH-COMPILATION-UNIT and error -handling code. If a VERSION argument is supplied, then operate also ensures -that the system found satisfies it using the VERSION-SATISFIES method. - -Note that dependencies may cause the operation to invoke other operations on the system -or its components: the new operations will be created with the same initargs as the original one. +1. Resolves the OPERATION designator into an operation object. + OPERATION is typically a symbol denoting an operation class, instantiated with MAKE-OPERATION. +2. Resolves the COMPONENT designator into a component object. + COMPONENT is typically a string or symbol naming a system, loaded from disk using FIND-SYSTEM. +3. It then calls MAKE-PLAN with the operation and system as arguments. +4. Finally calls PERFORM-PLAN on the resulting plan to actually build the system. + +The entire computation is wrapped in WITH-COMPILATION-UNIT and error handling code. +If a VERSION argument is supplied, then operate also ensures that the system found satisfies it +using the VERSION-SATISFIES method. +If a PLAN-CLASS argument is supplied, that class is used for the plan. The :FORCE or :FORCE-NOT argument to OPERATE can be: T to force the inside of the specified system to be rebuilt (resp. not), without recursively forcing the other systems we depend on. :ALL to force all systems including other systems we depend on to be rebuilt (resp. not). (SYSTEM1 SYSTEM2 ... SYSTEMN) to force systems named in a given list -:FORCE has precedence over :FORCE-NOT; builtin systems cannot be forced.")) +:FORCE-NOT has precedence over :FORCE; builtin systems cannot be forced. - (define-convenience-action-methods - operate (operation component &key) - ;; I'd like to at least remove-plist-keys :force :force-not :verbose, - ;; but swank.asd relies on :force (!). - :operation-initargs t ;; backward-compatibility with ASDF1. Yuck. - :if-no-component (error 'missing-component :requires component)) +For backward compatibility, all keyword arguments are passed to MAKE-OPERATION +when instantiating a new operation, that will in turn be inherited by new operations. +But do NOT depend on it, for this is deprecated behavior.")) + + (define-convenience-action-methods operate (operation component &key) + ;; I'd like to at least remove-plist-keys :force :force-not :verbose, + ;; but swank.asd relies on :force (!). + :operation-initargs t ;; backward-compatibility with ASDF1. Deprecated. + :if-no-component (error 'missing-component :requires component)) + ;; TODO: actually, the use as a hash-set is write-only, so it can be reduced to a boolean, + ;; and then possibly replaced by checking for say *asdf-cache*. (defvar *systems-being-operated* nil - "A boolean indicating that some systems are being operated on") + "A hash-set of names of systems being operated on, or NIL") + ;; This method ensures that an ASDF upgrade is attempted as the very first thing, + ;; with suitable state preservation in case in case it actually happens, + ;; and that a few suitable dynamic bindings are established. (defmethod operate :around (operation component &rest keys &key verbose (on-warnings *compile-file-warnings-behaviour*) @@ -9345,15 +10101,16 @@ (with-upgradability () (defvar *load-system-operation* 'load-op "Operation used by ASDF:LOAD-SYSTEM. By default, ASDF:LOAD-OP. -You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle +You may override it with e.g. ASDF:LOAD-BUNDLE-OP from asdf/bundle or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken. The default operation may change in the future if we implement a component-directed strategy for how to load or compile systems.") + ;; In prepare-op for a system, propagate *load-system-operation* rather than load-op (defmethod component-depends-on ((o prepare-op) (s system)) - (loop :for (o . cs) :in (call-next-method) - :collect (cons (if (eq o 'load-op) *load-system-operation* o) cs))) + (loop :for (do . dc) :in (call-next-method) + :collect (cons (if (eq do 'load-op) *load-system-operation* do) dc))) (defclass build-op (non-propagating-operation) () (:documentation "Since ASDF3, BUILD-OP is the recommended 'master' operation, @@ -9406,21 +10163,26 @@ ;; only tries to load its specified target if it's not loaded yet. (with-upgradability () (defun component-loaded-p (component) - "has given COMPONENT been successfully loaded in the current image (yet)?" - (action-already-done-p nil (make-instance 'load-op) (find-component component ()))) + "Has the given COMPONENT been successfully loaded in the current image (yet)? +Note that this returns true even if the component is not up to date." + (if-let ((component (find-component component () :registered t))) + (action-already-done-p nil (make-instance 'load-op) component))) (defun already-loaded-systems () "return a list of the names of the systems that have been successfully loaded so far" - (remove-if-not 'component-loaded-p (registered-systems))) + (mapcar 'coerce-name (remove-if-not 'component-loaded-p (registered-systems*)))) (defun require-system (system &rest keys &key &allow-other-keys) - "Ensure the specified SYSTEM is loaded, passing the KEYS to OPERATE, but skip any update to the + "Ensure the specified SYSTEM is loaded, passing the KEYS to OPERATE, but do not update the system or its dependencies if they have already been loaded." - (apply 'load-system system :force-not (already-loaded-systems) keys))) + (unless (component-loaded-p system) + (apply 'load-system system :force-not (already-loaded-systems) keys)))) ;;;; Define the class REQUIRE-SYSTEM, to be hooked into CL:REQUIRE when possible, ;; i.e. for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL +;; Note that despite the two being homonyms, the _function_ require-system +;; and the _class_ require-system are quite distinct entities, fulfilling independent purposes. (with-upgradability () (defvar *modules-being-required* nil) @@ -9436,24 +10198,36 @@ (let* ((module (or (required-module s) (coerce-name s))) (*modules-being-required* (cons module *modules-being-required*))) (assert (null (component-children s))) - (require module))) + ;; CMUCL likes its module names to be all upcase. + (require #-cmucl module #+cmucl (string-upcase module)))) (defmethod resolve-dependency-combination (component (combinator (eql :require)) arguments) - (unless (length=n-p arguments 1) - (error (compatfmt "~@") - (cons combinator arguments) component combinator)) - (let* ((module (car arguments)) + (unless (and (length=n-p arguments 1) + (typep (car arguments) '(or string (and symbol (not null))))) + (parameter-error (compatfmt "~@") + 'resolve-dependency-combination + (cons combinator arguments) component combinator)) + ;; :require must be prepared for some implementations providing modules using ASDF, + ;; as SBCL used to do, and others may might do. Thus, the system provided in the end + ;; would be a downcased name as per module-provide-asdf above. For the same reason, + ;; we cannot assume that the system in the end will be of type require-system, + ;; but must check whether we can use find-system and short-circuit cl:require. + ;; Otherwise, calling cl:require could result in nasty reentrant calls between + ;; cl:require and asdf:operate that could potentially blow up the stack, + ;; all the while defeating the consistency of the dependency graph. + (let* ((module (car arguments)) ;; NB: we already checked that it was not null (name (string-downcase module)) (system (find-system name nil))) - (assert module) - ;;(unless (typep system '(or null require-system)) - ;; (warn "~S depends on ~S but ~S is registered as a ~S" - ;; component (cons combinator arguments) module (type-of system))) (or system (let ((system (make-instance 'require-system :name name))) (register-system system) system)))) (defun module-provide-asdf (name) + ;; We must use string-downcase, because modules are traditionally specified as symbols, + ;; that implementations traditionally normalize as uppercase, for which we seek a system + ;; with a name that is traditionally in lowercase. Case is lost along the way. That's fine. + ;; We could make complex, non-portable rules to try to preserve case, and just documenting + ;; them would be a hell that it would be a disservice to inflict on users. (let ((module (string-downcase name))) (unless (member module *modules-being-required* :test 'equal) (let ((*modules-being-required* (cons module *modules-being-required*)) @@ -9461,9 +10235,10 @@ (handler-bind ((style-warning #'muffle-warning) (missing-component (constantly nil)) - (error #'(lambda (e) - (format *error-output* (compatfmt "~@~%") - name e)))) + (fatal-condition + #'(lambda (e) + (format *error-output* (compatfmt "~@~%") + name e)))) (let ((*verbose-out* (make-broadcast-stream))) (let ((system (find-system module nil))) (when system @@ -9480,8 +10255,19 @@ :when (eq (first k) 'find-system) :collect (second k)))) (clrhash *asdf-cache*) (dolist (s l) (find-system s nil))))) - (register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf)) + (register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf) + ;; The following function's symbol is from asdf/find-system. + ;; It is defined here to resolve what would otherwise be forward package references. + (defun mark-component-preloaded (component) + "Mark a component as preloaded." + (let ((component (find-component component nil :registered t))) + ;; Recurse to children, so asdf/plan will hopefully be happy. + (map () 'mark-component-preloaded (component-children component)) + ;; Mark the timestamps of the common lisp-action operations as 0. + (let ((times (component-operation-times component))) + (dolist (o '(load-op compile-op prepare-op)) + (setf (gethash o times) 0)))))) ;;;; --------------------------------------------------------------------------- ;;;; asdf-output-translations @@ -9507,6 +10293,8 @@ )) (in-package :asdf/output-translations) +;; (setf output-translations) at some point used to be a macro for the sake of +;; obsolete versions of GCL. Make sure that macro doesn't come to haunt us. (when-upgrading () (undefine-function '(setf output-translations))) (with-upgradability () @@ -9520,8 +10308,10 @@ and the order is by decreasing length of namestring of the source pathname.") (defun output-translations () + "Return the configured output-translations, if any" (car *output-translations*)) + ;; Set the output-translations, by sorting the provided new-value. (defun set-output-translations (new-value) (setf *output-translations* (list @@ -9536,6 +10326,7 @@ (defun* ((setf output-translations)) (new-value) (set-output-translations new-value)) (defun output-translations-initialized-p () + "Have the output-translations been initialized yet?" (and *output-translations* t)) (defun clear-output-translations () @@ -9544,6 +10335,9 @@ (values)) (register-clear-configuration-hook 'clear-output-translations) + + ;;; Validation of the configuration directives... + (defun validate-output-translations-directive (directive) (or (member directive '(:enable-user-cache :disable-cache nil)) (and (consp directive) @@ -9572,6 +10366,8 @@ directory :output-translations 'validate-output-translations-directive :invalid-form-reporter 'invalid-output-translation)) + + ;;; Parse the ASDF_OUTPUT_TRANSLATIONS environment variable and/or some file contents (defun parse-output-translations-string (string &key location) (cond ((or (null string) (equal string "")) @@ -9613,6 +10409,8 @@ (push :ignore-inherited-configuration directives)) (return `(:output-translations ,@(nreverse directives))))))))) + + ;; The default sources of configuration for output-translations (defparameter* *default-output-translations* '(environment-output-translations user-output-translations-pathname @@ -9620,6 +10418,8 @@ system-output-translations-pathname system-output-translations-directory-pathname)) + ;; Compulsory implementation-dependent wrapping for the translations: + ;; handle implementation-provided systems. (defun wrapping-output-translations () `(:output-translations ;; Some implementations have precompiled ASDF systems, @@ -9636,9 +10436,11 @@ ;; We enable the user cache by default, and here is the place we do: :enable-user-cache)) + ;; Relative pathnames of output-translations configuration to XDG configuration directory (defparameter *output-translations-file* (parse-unix-namestring "common-lisp/asdf-output-translations.conf")) (defparameter *output-translations-directory* (parse-unix-namestring "common-lisp/asdf-output-translations.conf.d/")) + ;; Locating various configuration pathnames, depending on input or output intent. (defun user-output-translations-pathname (&key (direction :input)) (xdg-config-pathname *output-translations-file* direction)) (defun system-output-translations-pathname (&key (direction :input)) @@ -9652,6 +10454,9 @@ (defun environment-output-translations () (getenv "ASDF_OUTPUT_TRANSLATIONS")) + + ;;; Processing the configuration. + (defgeneric process-output-translations (spec &key inherit collect)) (defun inherit-output-translations (inherit &key collect) @@ -9712,6 +10517,9 @@ (dolist (directive (cdr (validate-output-translations-form form))) (process-output-translations-directive directive :inherit inherit :collect collect))) + + ;;; Top-level entry-points to configure output-translations + (defun compute-output-translations (&optional parameter) "read the configuration, return it" (remove-duplicates @@ -9720,8 +10528,11 @@ `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c)) :test 'equal :from-end t)) + ;; Saving the user-provided parameter to output-translations, if any, + ;; so we can recompute the translations after code upgrade. (defvar *output-translations-parameter* nil) + ;; Main entry-point for users. (defun initialize-output-translations (&optional (parameter *output-translations-parameter*)) "read the configuration, initialize the internal configuration variable, return the configuration" @@ -9743,6 +10554,8 @@ (output-translations) (initialize-output-translations))) + + ;; Top-level entry-point to _use_ output-translations (defun* (apply-output-translations) (path) (etypecase path (logical-pathname @@ -9763,11 +10576,14 @@ :return (translate-pathname* p absolute-source destination root source) :finally (return p))))) + ;; Hook into uiop's output-translation mechanism #-cormanlisp (setf *output-translation-function* 'apply-output-translations) - #+abcl + + ;;; Implementation-dependent hacks + #+abcl ;; ABCL: make it possible to use systems provided in the ABCL jar. (defun translate-jar-pathname (source wildcard) (declare (ignore wildcard)) (flet ((normalize-device (pathname) @@ -9816,7 +10632,7 @@ #:default-user-source-registry #:default-system-source-registry #:user-source-registry #:system-source-registry #:user-source-registry-directory #:system-source-registry-directory - #:environment-source-registry #:process-source-registry + #:environment-source-registry #:process-source-registry #:inherit-source-registry #:compute-source-registry #:flatten-source-registry #:sysdef-source-registry-search)) (in-package :asdf/source-registry) @@ -9825,20 +10641,28 @@ (define-condition invalid-source-registry (invalid-configuration warning) ((format :initform (compatfmt "~@")))) - ;; Using ack 1.2 exclusions + ;; Default list of directories under which the source-registry tree search won't recurse (defvar *default-source-registry-exclusions* - '(".bzr" ".cdv" + '(;;-- Using ack 1.2 exclusions + ".bzr" ".cdv" ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs" "_sgbak" "autom4te.cache" "cover_db" "_build" - "debian")) ;; debian often builds stuff under the debian directory... BAD. + ;;-- debian often builds stuff under the debian directory... BAD. + "debian")) + ;; Actual list of directories under which the source-registry tree search won't recurse (defvar *source-registry-exclusions* *default-source-registry-exclusions*) + ;; The state of the source-registry after search in configured locations (defvar *source-registry* nil "Either NIL (for uninitialized), or an equal hash-table, mapping system names to pathnames of .asd files") + ;; Saving the user-provided parameter to the source-registry, if any, + ;; so we can recompute the source-registry after code upgrade. + (defvar *source-registry-parameter* nil) + (defun source-registry-initialized-p () (typep *source-registry* 'hash-table)) @@ -9849,7 +10673,7 @@ (register-clear-configuration-hook 'clear-source-registry) (defparameter *wild-asd* - (make-pathname* :directory nil :name *wild* :type "asd" :version :newest)) + (make-pathname :directory nil :name *wild* :type "asd" :version :newest)) (defun directory-asd-files (directory) (directory-files directory *wild-asd*)) @@ -9863,6 +10687,8 @@ "Should :tree entries of the source-registry recurse in subdirectories after having found a .asd file? True by default.") + ;; When walking down a filesystem tree, if in a directory there is a .cl-source-registry.cache, + ;; read its contents instead of further recursively querying the filesystem. (defun process-source-registry-cache (directory collect) (let ((cache (ignore-errors (safe-read-file-form (subpathname directory ".cl-source-registry.cache"))))) @@ -9873,15 +10699,23 @@ (defun collect-sub*directories-asd-files (directory &key (exclude *default-source-registry-exclusions*) collect (recurse-beyond-asds *recurse-beyond-asds*) ignore-cache) - (collect-sub*directories - directory - #'(lambda (dir) - (unless (and (not ignore-cache) (process-source-registry-cache directory collect)) - (let ((asds (collect-asds-in-directory dir collect))) - (or recurse-beyond-asds (not asds))))) - #'(lambda (x) - (not (member (car (last (pathname-directory x))) exclude :test #'equal))) - (constantly nil))) + (let ((visited (make-hash-table :test 'equalp))) + (flet ((collectp (dir) + (unless (and (not ignore-cache) (process-source-registry-cache directory collect)) + (let ((asds (collect-asds-in-directory dir collect))) + (or recurse-beyond-asds (not asds))))) + (recursep (x) ; x will be a directory pathname + (and + (not (member (car (last (pathname-directory x))) exclude :test #'equal)) + (flet ((pathname-key (x) + (namestring (truename* x)))) + (let ((visitedp (gethash (pathname-key x) visited))) + (if visitedp nil + (setf (gethash (pathname-key x) visited) t))))))) + (collect-sub*directories directory #'collectp #'recursep (constantly nil))))) + + + ;;; Validate the configuration forms (defun validate-source-registry-directive (directive) (or (member directive '(:default-registry)) @@ -9910,6 +10744,9 @@ directory :source-registry 'validate-source-registry-directive :invalid-form-reporter 'invalid-source-registry)) + + ;;; Parse the configuration string + (defun parse-source-registry-string (string &key location) (cond ((or (null string) (equal string "")) @@ -9973,8 +10810,8 @@ `(:source-registry #+(or clasp ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory))) :inherit-configuration - #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:")) - #+cmu (:tree #p"modules:") + #+mkcl (:tree ,(translate-logical-pathname "SYS:")) + #+cmucl (:tree #p"modules:") #+scl (:tree #p"file://modules/"))) (defun default-user-source-registry () `(:source-registry @@ -10002,6 +10839,9 @@ (defun environment-source-registry () (getenv "CL_SOURCE_REGISTRY")) + + ;;; Process the source-registry configuration + (defgeneric* (process-source-registry) (spec &key inherit register)) (defun* (inherit-source-registry) (inherit &key register) @@ -10060,7 +10900,9 @@ (dolist (directive (cdr (validate-source-registry-form form))) (process-source-registry-directive directive :inherit inherit :register register)))) - (defun flatten-source-registry (&optional parameter) + + ;; Flatten the user-provided configuration into an ordered list of directories and trees + (defun flatten-source-registry (&optional (parameter *source-registry-parameter*)) (remove-duplicates (while-collecting (collect) (with-pathname-defaults () ;; be location-independent @@ -10073,7 +10915,8 @@ :test 'equal :from-end t)) ;; Will read the configuration and initialize all internal variables. - (defun compute-source-registry (&optional parameter (registry *source-registry*)) + (defun compute-source-registry (&optional (parameter *source-registry-parameter*) + (registry *source-registry*)) (dolist (entry (flatten-source-registry parameter)) (destructuring-bind (directory &key recurse exclude) entry (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates @@ -10103,8 +10946,6 @@ h))) (values)) - (defvar *source-registry-parameter* nil) - (defun initialize-source-registry (&optional (parameter *source-registry-parameter*)) ;; Record the parameter used to configure the registry (setf *source-registry-parameter* parameter) @@ -10152,18 +10993,17 @@ ;;; Pathname (with-upgradability () (defun determine-system-directory (pathname) - ;; The defsystem macro calls this function to determine - ;; the pathname of a system as follows: - ;; 1. if the pathname argument is an pathname object (NOT a namestring), + ;; The defsystem macro calls this function to determine the pathname of a system as follows: + ;; 1. If the pathname argument is an pathname object (NOT a namestring), ;; that is already an absolute pathname, return it. - ;; 2. otherwise, the directory containing the LOAD-PATHNAME + ;; 2. Otherwise, the directory containing the LOAD-PATHNAME ;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and ;; if it is indeed available and an absolute pathname, then ;; the PATHNAME argument is normalized to a relative pathname ;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T) ;; and merged into that DIRECTORY as per SUBPATHNAME. - ;; Note: avoid *COMPILE-FILE-PATHNAME* because .asd is loaded, - ;; and may be from within the EVAL-WHEN of a file compilation. + ;; Note: avoid *COMPILE-FILE-PATHNAME* because the .asd is loaded as source, + ;; but may be from within the EVAL-WHEN of a file compilation. ;; If no absolute pathname was found, we return NIL. (check-type pathname (or null string pathname)) (pathname-directory-pathname @@ -10177,6 +11017,7 @@ ;;; Component class (with-upgradability () + ;; What :file gets interpreted as, unless overridden by a :default-component-class (defvar *default-component-class* 'cl-source-file) (defun class-for-type (parent type) @@ -10184,7 +11025,7 @@ (and (eq type :file) (coerce-class (or (loop :for p = parent :then (component-parent p) :while p - :thereis (module-default-component-class p)) + :thereis (module-default-component-class p)) *default-component-class*) :package :asdf/interface :super 'component :error nil)) (sysdef-error "don't recognize component type ~S" type)))) @@ -10223,6 +11064,9 @@ (sysdef-error-component ":components must be NIL or a list of components." type name components))) + ;; Given a form used as :version specification, in the context of a system definition + ;; in a file at PATHNAME, for given COMPONENT with given PARENT, normalize the form + ;; to an acceptable ASDF-format version. (defun* (normalize-version) (form &key pathname component parent) (labels ((invalid (&optional (continuation "using NIL instead")) (warn (compatfmt "~@") @@ -10293,7 +11137,7 @@ ;;; Main parsing function (with-upgradability () - (defun* parse-dependency-def (dd) + (defun parse-dependency-def (dd) (if (listp dd) (case (first dd) (:feature @@ -10314,12 +11158,12 @@ (otherwise (sysdef-error "Ill-formed dependency: ~s" dd))) (coerce-name dd))) - (defun* parse-dependency-defs (dd-list) + (defun parse-dependency-defs (dd-list) "Parse the dependency defs in DD-LIST into canonical form by translating all system names contained using COERCE-NAME. Return the result." (mapcar 'parse-dependency-def dd-list)) - (defun* (parse-component-form) (parent options &key previous-serial-component) + (defun (parse-component-form) (parent options &key previous-serial-component) (destructuring-bind (type name &rest rest &key (builtin-system-p () bspp) @@ -10409,6 +11253,15 @@ (with-asdf-cache () (let* ((name (coerce-name name)) (source-file (if sfp source-file (resolve-symlinks* (load-pathname)))) + ;; NB: handle defsystem-depends-on BEFORE to create the system object, + ;; so that in case it fails, there is no incomplete object polluting the build. + (checked-defsystem-depends-on + (let* ((dep-forms (parse-dependency-defs defsystem-depends-on)) + (deps (loop :for spec :in dep-forms + :when (resolve-dependency-spec nil spec) + :collect :it))) + (load-systems* deps) + dep-forms)) (registered (system-registered-p name)) (registered! (if registered (rplaca registered (get-file-stamp source-file)) @@ -10417,17 +11270,13 @@ (system (reset-system (cdr registered!) :name name :source-file source-file)) (component-options - (remove-plist-keys '(:defsystem-depends-on :class) options)) - (defsystem-dependencies (loop :for spec :in defsystem-depends-on - :when (resolve-dependency-spec nil spec) - :collect :it))) - ;; cache defsystem-depends-on in canonical form - (when defsystem-depends-on - (setf component-options - (append `(:defsystem-depends-on ,(parse-dependency-defs defsystem-depends-on)) - component-options))) + (append + (remove-plist-keys '(:defsystem-depends-on :class) options) + ;; cache defsystem-depends-on in canonical form + (when checked-defsystem-depends-on + `(:defsystem-depends-on ,checked-defsystem-depends-on))))) + ;; This works hand in hand with asdf/find-system:find-system-if-being-defined: (set-asdf-cache-entry `(find-system ,name) (list system)) - (load-systems* defsystem-dependencies) ;; We change-class AFTER we loaded the defsystem-depends-on ;; since the class might be defined as part of those. (let ((class (class-for-type nil class))) @@ -10453,7 +11302,7 @@ :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/defsystem) (:export #:bundle-op #:bundle-type #:program-system - #:bundle-system #:bundle-pathname-type #:bundlable-file-p #:direct-dependency-files + #:bundle-system #:bundle-pathname-type #:direct-dependency-files #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p #:basic-compile-bundle-op #:prepare-bundle-op #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op @@ -10468,22 +11317,28 @@ (with-upgradability () (defclass bundle-op (basic-compile-op) + ;; NB: use of instance-allocated slots for operations is DEPRECATED + ;; and only supported in a temporary fashion for backward compatibility. + ;; Supported replacement: Define slots on program-system instead. ((build-args :initarg :args :initform nil :accessor extra-build-args) (name-suffix :initarg :name-suffix :initform nil) (bundle-type :initform :no-output-file :reader bundle-type) - #+(or clasp ecl) (lisp-files :initform nil :accessor extra-object-files))) + #+(or clasp ecl) (lisp-files :initform nil :accessor extra-object-files)) + (:documentation "base class for operations that bundle outputs from multiple components")) (defclass monolithic-op (operation) () (:documentation "A MONOLITHIC operation operates on a system *and all of its dependencies*. So, for example, a monolithic concatenate operation will concatenate together a system's components and all of its dependencies, but a simple concatenate operation will concatenate only the components of the system -itself.")) ;; operation on a system and its dependencies +itself.")) (defclass monolithic-bundle-op (monolithic-op bundle-op) - ;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation + ;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation. + ;; DEPRECATED. Supported replacement: Define slots on program-system instead. ((prologue-code :initform nil :accessor prologue-code) - (epilogue-code :initform nil :accessor epilogue-code))) + (epilogue-code :initform nil :accessor epilogue-code)) + (:documentation "operations that are both monolithic-op and bundle-op")) (defclass program-system (system) ;; New style (ASDF3.1) way of specifying prologue and epilogue on ECL: in the system @@ -10511,44 +11366,79 @@ (:documentation "Abstract operation for linking files together")) (defclass gather-op (bundle-op) - ((gather-op :initform nil :allocation :class :reader gather-op)) + ;; TODO: rename the slot and reader gather-op to gather-operation + ((gather-op :initform nil :allocation :class :reader gather-op) + (gather-type :initform :no-output-file :allocation :class :reader gather-type)) (:documentation "Abstract operation for gathering many input files from a system")) (defun operation-monolithic-p (op) (typep op 'monolithic-op)) + ;; Dependencies of a gather-op are the actions of the dependent + ;; operation for all the (sorted) required components for loading + ;; the system. Monolithic operations typically use lib-op as the + ;; dependent operation, and all system-level dependencies as + ;; required components. Non-monolithic operations typically use + ;; basic-compile-op as the dependent operation, and all transitive + ;; sub-components as required components (excluding other systems). (defmethod component-depends-on ((o gather-op) (s system)) (let* ((mono (operation-monolithic-p o)) + (go (make-operation (or (gather-op o) 'compile-op))) + (bundle-p (typep go 'bundle-op)) + ;; In a non-mono operation, don't recurse to other systems. + ;; In a mono operation gathering bundles, don't recurse inside systems. + (component-type (if mono (if bundle-p 'system t) '(not system))) + ;; In the end, only keep system bundles or non-system bundles, depending. + (keep-component (if bundle-p 'system '(not system))) (deps (required-components - s :other-systems mono :component-type (if mono 'system '(not system)) + s :other-systems mono :component-type component-type :keep-component keep-component :goal-operation (find-operation o 'load-op) - :keep-operation 'compile-op))) - ;; NB: the explicit make-operation on ECL and MKCL - ;; ensures that we drop the original-initargs and its magic flags when recursing. - `((,(make-operation (or (gather-op o) (if mono 'lib-op 'compile-op))) ,@deps) - ,@(call-next-method)))) + :keep-operation 'basic-compile-op))) + `((,go ,@deps) ,@(call-next-method)))) - ;; create a single fasl for the entire library + ;; Create a single fasl for the entire library (defclass basic-compile-bundle-op (bundle-op) - ((bundle-type :initform :fasl))) + ((gather-type :initform #-(or clasp ecl mkcl) :fasl #+(or clasp ecl mkcl) :object + :allocation :class) + (bundle-type :initform :fasl :allocation :class)) + (:documentation "Base class for compiling into a bundle")) + ;; Analog to prepare-op, for load-bundle-op and compile-bundle-op (defclass prepare-bundle-op (sideway-operation) ((sideway-operation :initform #+(or clasp ecl mkcl) 'load-bundle-op #-(or clasp ecl mkcl) 'load-op - :allocation :class))) + :allocation :class)) + (:documentation "Operation class for loading the bundles of a system's dependencies")) (defclass lib-op (link-op gather-op non-propagating-operation) - ((bundle-type :initform :lib)) - (:documentation "compile the system and produce linkable (.a) library for it.")) - - (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation - #+(or clasp ecl mkcl) link-op #-(or clasp ecl) gather-op) - ((selfward-operation :initform '(prepare-bundle-op #+(or clasp ecl) lib-op) - :allocation :class))) + ((gather-type :initform :object :allocation :class) + (bundle-type :initform :lib :allocation :class)) + (:documentation "Compile the system and produce a linkable static library (.a/.lib) +for all the linkable object files associated with the system. Compare with DLL-OP. + +On most implementations, these object files only include extensions to the runtime +written in C or another language with a compiler producing linkable object files. +On CLASP, ECL, MKCL, these object files _also_ include the contents of Lisp files +themselves. In any case, this operation will produce what you need to further build +a static runtime for your system, or a dynamic library to load in an existing runtime.")) + + ;; What works: on ECL, CLASP(?), MKCL, we link many .o files from the system into the .so; + ;; on other implementations, we combine the .fasl files into one. + (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation gather-op + #+(or clasp ecl mkcl) link-op) + ((selfward-operation :initform '(prepare-bundle-op) :allocation :class)) + (:documentation "This operator is an alternative to COMPILE-OP. Build a system +and all of its dependencies, but build only a single (\"monolithic\") FASL, instead +of one per source file, which may be more resource efficient. That monolithic +FASL should be loaded with LOAD-BUNDLE-OP, rather than LOAD-OP.")) (defclass load-bundle-op (basic-load-op selfward-operation) - ((selfward-operation :initform '(prepare-bundle-op compile-bundle-op) :allocation :class))) + ((selfward-operation :initform '(prepare-bundle-op compile-bundle-op) :allocation :class)) + (:documentation "This operator is an alternative to LOAD-OP. Build a system +and all of its dependencies, using COMPILE-BUNDLE-OP. The difference with +respect to LOAD-OP is that it builds only a single FASL, which may be +faster and more resource efficient.")) ;; NB: since the monolithic-op's can't be sideway-operation's, ;; if we wanted lib-op, dll-op, deliver-asd-op to be sideway-operation's, @@ -10556,39 +11446,53 @@ ;; but instead inherit from a basic-FOO-op as with basic-compile-bundle-op above. (defclass dll-op (link-op gather-op non-propagating-operation) - ((bundle-type :initform :dll)) - (:documentation "compile the system and produce dynamic (.so/.dll) library for it.")) + ((gather-type :initform :object :allocation :class) + (bundle-type :initform :dll :allocation :class)) + (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll) +for all the linkable object files associated with the system. Compare with LIB-OP.")) (defclass deliver-asd-op (basic-compile-op selfward-operation) - ((selfward-operation :initform '(compile-bundle-op #+(or clasp ecl mkcl) lib-op) :allocation :class)) + ((selfward-operation + ;; TODO: implement link-op on all implementations, and make that + ;; '(compile-bundle-op lib-op #-(or clasp ecl mkcl) dll-op) + :initform '(compile-bundle-op #+(or clasp ecl mkcl) lib-op) + :allocation :class)) (:documentation "produce an asd file for delivering the system as a single fasl")) (defclass monolithic-deliver-asd-op (monolithic-bundle-op deliver-asd-op) ((selfward-operation + ;; TODO: implement link-op on all implementations, and make that + ;; '(monolithic-compile-bundle-op monolithic-lib-op #-(or clasp ecl mkcl) monolithic-dll-op) :initform '(monolithic-compile-bundle-op #+(or clasp ecl mkcl) monolithic-lib-op) :allocation :class)) (:documentation "produce fasl and asd files for combined system and dependencies.")) - (defclass monolithic-compile-bundle-op (monolithic-bundle-op basic-compile-bundle-op - #+(or clasp ecl mkcl) link-op gather-op non-propagating-operation) - ((gather-op :initform #+(or clasp ecl mkcl) 'lib-op #-(or clasp ecl mkcl) 'compile-bundle-op :allocation :class)) + (defclass monolithic-compile-bundle-op + (monolithic-bundle-op basic-compile-bundle-op + #+(or clasp ecl mkcl) link-op gather-op non-propagating-operation) + () (:documentation "Create a single fasl for the system and its dependencies.")) (defclass monolithic-load-bundle-op (monolithic-bundle-op load-bundle-op) ((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class)) (:documentation "Load a single fasl for the system and its dependencies.")) - (defclass monolithic-lib-op (monolithic-bundle-op lib-op non-propagating-operation) () - (:documentation "Create a single linkable library for the system and its dependencies.")) + (defclass monolithic-lib-op (monolithic-bundle-op lib-op non-propagating-operation) + ((gather-type :initform :object :allocation :class)) + (:documentation "Compile the system and produce a linkable static library (.a/.lib) +for all the linkable object files associated with the system or its dependencies. See LIB-OP.")) (defclass monolithic-dll-op (monolithic-bundle-op dll-op non-propagating-operation) - ((bundle-type :initform :dll)) - (:documentation "Create a single dynamic (.so/.dll) library for the system and its dependencies.")) + ((gather-type :initform :object :allocation :class)) + (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll) +for all the linkable object files associated with the system or its dependencies. See LIB-OP")) (defclass image-op (monolithic-bundle-op selfward-operation #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-op) ((bundle-type :initform :image) + (gather-op :initform 'lib-op :allocation :class) + #+(or clasp ecl mkcl) (gather-type :initform :static-library :allocation :class) (selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class)) (:documentation "create an image file from the system and its dependencies")) @@ -10596,20 +11500,34 @@ ((bundle-type :initform :program)) (:documentation "create an executable file from the system and its dependencies")) + ;; From the ASDF-internal bundle-type identifier, get a filesystem-usable pathname type. (defun bundle-pathname-type (bundle-type) (etypecase bundle-type - ((eql :no-output-file) nil) ;; should we error out instead? - ((or null string) bundle-type) - ((eql :fasl) #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb") - #+(or clasp ecl) - ((member :dll :lib :shared-library :static-library :program :object :program) - (compile-file-type :type bundle-type)) - ((member :image) #+allegro "dxl" #+(and clisp os-windows) "exe" #-(or allegro (and clisp os-windows)) "image") - ((member :dll :shared-library) (os-cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll"))) - ((member :lib :static-library) (os-cond ((os-unix-p) "a") - ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib")))) - ((eql :program) (os-cond ((os-unix-p) nil) ((os-windows-p) "exe"))))) + ((or null string) ;; pass through nil or string literal + bundle-type) + ((eql :no-output-file) ;; marker for a bundle-type that has NO output file + (error "No output file, therefore no pathname type")) + ((eql :fasl) ;; the type of a fasl + #-(or clasp ecl mkcl) (compile-file-type) ; on image-based platforms, used as input and output + #+(or clasp ecl mkcl) "fasb") ; on C-linking platforms, only used as output for system bundles + ((member :image) + #+allegro "dxl" + #+(and clisp os-windows) "exe" + #-(or allegro (and clisp os-windows)) "image") + ;; NB: on CLASP and ECL these implementations, we better agree with + ;; (compile-file-type :type bundle-type)) + ((eql :object) ;; the type of a linkable object file + (os-cond ((os-unix-p) "o") + ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "o" "obj")))) + ((member :lib :static-library) ;; the type of a linkable library + (os-cond ((os-unix-p) "a") + ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib")))) + ((member :dll :shared-library) ;; the type of a shared library + (os-cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll"))) + ((eql :program) ;; the type of an executable program + (os-cond ((os-unix-p) nil) ((os-windows-p) "exe"))))) + ;; Compute the output-files for a given bundle action (defun bundle-output-files (o c) (let ((bundle-type (bundle-type o))) (unless (or (eq bundle-type :no-output-file) ;; NIL already means something regarding type. @@ -10618,7 +11536,10 @@ (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix)))) (type (bundle-pathname-type bundle-type))) (values (list (subpathname (component-pathname c) name :type type)) - (eq (type-of o) (component-build-operation c))))))) + (eq (class-of o) (coerce-class (component-build-operation c) + :package :asdf/interface + :super 'operation + :error nil))))))) (defmethod output-files ((o bundle-op) (c system)) (bundle-output-files o c)) @@ -10631,14 +11552,19 @@ (setf *image-entry-point* (ensure-function (component-entry-point c))))) (defclass compiled-file (file-component) - ((type :initform #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb"))) + ((type :initform #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb")) + (:documentation "Class for a file that is already compiled, +e.g. as part of the implementation, of an outer build system that calls into ASDF, +or of opaque libraries shipped along the source code.")) (defclass precompiled-system (system) - ((build-pathname :initarg :fasl))) + ((build-pathname :initarg :fasl)) + (:documentation "Class For a system that is delivered as a precompiled fasl")) (defclass prebuilt-system (system) ((build-pathname :initarg :static-library :initarg :lib - :accessor prebuilt-system-static-library)))) + :accessor prebuilt-system-static-library)) + (:documentation "Class for a system delivered with a linkable static library (.a/.lib)"))) ;;; @@ -10654,6 +11580,7 @@ &key (name-suffix nil name-suffix-p) &allow-other-keys) (declare (ignore initargs name-suffix)) + ;; TODO: make that class slots or methods, not instance slots (unless name-suffix-p (setf (slot-value instance 'name-suffix) (unless (typep instance 'program-op) @@ -10673,16 +11600,6 @@ :force :force-not :plan-class) ;; TODO: refactor so we don't mix plan and operation arguments (operation-original-initargs instance)))) - (defun bundlable-file-p (pathname) - (let ((type (pathname-type pathname))) - (declare (ignorable type)) - (or #+(or clasp ecl) (or (equalp type (compile-file-type :type :object)) - (equalp type (compile-file-type :type :static-library))) - #+mkcl (or (equalp type (compile-file-type :fasl-p nil)) - #+(or unix mingw32 mingw64) (equalp type "a") ;; valid on Unix and MinGW - #+(and windows (not (or mingw32 mingw64))) (equalp type "lib")) - #+(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type))))) - (defgeneric* (trivial-system-p) (component)) (defun user-system-p (s) @@ -10703,18 +11620,24 @@ ;;; (with-upgradability () (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys) - ;; This file selects output files from direct dependencies; - ;; your component-depends-on method better gathered the correct dependencies in the correct order. + ;; This function selects output files from direct dependencies; + ;; your component-depends-on method must gather the correct dependencies in the correct order. (while-collecting (collect) (map-direct-dependencies t o c #'(lambda (sub-o sub-c) (loop :for f :in (funcall key sub-o sub-c) :when (funcall test f) :do (collect f)))))) + (defun pathname-type-equal-function (type) + #'(lambda (p) (equalp (pathname-type p) type))) + (defmethod input-files ((o gather-op) (c system)) (unless (eq (bundle-type o) :no-output-file) - (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files))) + (direct-dependency-files + o c :key 'output-files + :test (pathname-type-equal-function (bundle-pathname-type (gather-type o)))))) + ;; Find the operation that produces a given bundle-type (defun select-bundle-operation (type &optional monolithic) (ecase type ((:dll :shared-library) @@ -10728,7 +11651,7 @@ ((:program) 'program-op))) - ;; DEPRECATED. This is originally from asdf-ecl.lisp. Does anyone use it? + ;; SUPPORTED ALTERNATIVE: Use program-op and program-system (defun make-build (system &rest args &key (monolithic nil) (type :fasl) (move-here nil move-here-p) &allow-other-keys) @@ -10737,7 +11660,7 @@ (typep move-here '(or pathname string))) (ensure-pathname move-here :namestring :lisp :ensure-directory t) (system-relative-pathname system "asdf-output/"))) - (operation (apply #'operate operation-name + (operation (apply 'operate operation-name system (remove-plist-keys '(:monolithic :type :move-here) args))) (system (find-system system)) @@ -10749,14 +11672,21 @@ :for new-f = (make-pathname :name (pathname-name f) :type (pathname-type f) :defaults dest-path) - :do (rename-file-overwriting-target f new-f) + :do (handler-case (rename-file-overwriting-target f new-f) + (file-error (c) + (declare (ignore c)) + (copy-file f new-f) + (delete-file-if-exists f))) :collect new-f) files))) - ;; DEPRECATED. Does anyone use this? + ;; Apparently, some users of ECL, MKCL and ABCL may still be using it; + ;; but at the very least, this function should be renamed, and/or + ;; some way of specifying the output directory should be provided. + ;; As is, it is not such a useful interface. (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys) (declare (ignore force verbose version)) - (apply #'operate 'deliver-asd-op system args))) + (apply 'operate 'deliver-asd-op system args))) ;;; ;;; LOAD-BUNDLE-OP @@ -10842,9 +11772,13 @@ (version (component-version s)) (dependencies (if (operation-monolithic-p o) + ;; We want only dependencies, and we use + ;; basic-load-op rather than load-op so that this + ;; will keep working on systems when + ;; *load-system-operation* is load-bundle-op (remove-if-not 'builtin-system-p (required-components s :component-type 'system - :keep-operation 'load-op)) + :keep-operation 'basic-load-op)) (while-collecting (x) ;; resolve the sideway-dependencies of s (map-direct-dependencies t 'load-op s @@ -10912,48 +11846,46 @@ #+(or clasp ecl mkcl) (with-upgradability () - ;; I think that Juanjo intended for this to be, - ;; but beware the weird bug in test-xach-update-bug.script, - ;; and also it makes mkcl fail test-logical-pathname.script, - ;; and ecl fail test-bundle.script. - ;;(unless (or #+(or clasp ecl) (use-ecl-byte-compiler-p)) - ;; (setf *load-system-operation* 'load-bundle-op)) - - (defun uiop-library-pathname () - #+clasp (probe-file* (compile-file-pathname "sys:uiop" :output-type :object)) - #+ecl (or (probe-file* (compile-file-pathname "sys:uiop" :type :lib)) ;; new style - (probe-file* (compile-file-pathname "sys:uiop" :type :object))) ;; old style - #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;uiop")) - - (defun asdf-library-pathname () - #+clasp (probe-file* (compile-file-pathname "sys:asdf" :output-type :object)) - #+ecl (or (probe-file* (compile-file-pathname "sys:asdf" :type :lib)) ;; new style - (probe-file* (compile-file-pathname "sys:asdf" :type :object))) ;; old style - #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;asdf")) - - (defun compiler-library-pathname () - #+clasp (compile-file-pathname "sys:cmp" :output-type :lib) - #+ecl (compile-file-pathname "sys:cmp" :type :lib) - #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:cmp")) - - (defun make-library-system (name pathname) - (make-instance 'prebuilt-system - :name (coerce-name name) :static-library (resolve-symlinks* pathname))) + + ;; *load-system-operation* can't be determined at load time, because + ;; bytecodes compiler may be installed after loading asdf. + ;; + ;; (unless (use-ecl-byte-compiler-p) + ;; (setf *load-system-operation* 'load-bundle-op)) + + (defun system-module-pathname (module) + (let ((name (coerce-name module))) + (some + 'file-exists-p + (list + #+clasp (compile-file-pathname (make-pathname :name name :defaults "sys:") :output-type :object) + #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :lib) + #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :object) + #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:") + #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;"))))) + + (defun make-prebuilt-system (name &optional (pathname (system-module-pathname name))) + "Creates a prebuilt-system if PATHNAME isn't NIL." + (when pathname + (make-instance 'prebuilt-system + :name (coerce-name name) + :static-library (resolve-symlinks* pathname)))) (defmethod component-depends-on :around ((o image-op) (c system)) (destructuring-bind ((lib-op . deps)) (call-next-method) - (flet ((has-it-p (x) (find x deps :test 'equal :key 'coerce-name))) + (labels ((has-it-p (x) (find x deps :test 'equal :key 'coerce-name)) + (ensure-linkable-system (x) + (unless (has-it-p x) + (or (if-let (s (find-system x)) + (and (system-source-directory x) + (list s))) + (if-let (p (system-module-pathname x)) + (list (make-prebuilt-system x p))))))) `((,lib-op - ,@(unless (or (no-uiop c) (has-it-p "cmp")) - `(,(make-library-system - "cmp" (compiler-library-pathname)))) - ,@(unless (or (no-uiop c) (has-it-p "uiop") (has-it-p "asdf")) - (cond - ((system-source-directory :uiop) `(,(find-system :uiop))) - ((system-source-directory :asdf) `(,(find-system :asdf))) - (t `(,@(if-let (uiop (uiop-library-pathname)) - `(,(make-library-system "uiop" uiop))) - ,(make-library-system "asdf" (asdf-library-pathname)))))) + ,@(unless (no-uiop c) + (append (ensure-linkable-system "cmp") + (or (ensure-linkable-system "uiop") + (ensure-linkable-system "asdf")))) ,@deps))))) (defmethod perform ((o link-op) (c system)) @@ -10975,16 +11907,6 @@ :extra-object-files (or (extra-object-files o) (when programp (extra-object-files c))) :no-uiop (no-uiop c) (when programp `(:entry-point ,(component-entry-point c)))))))) - -#+(and (not asdf-use-unsafe-mac-bundle-op) - (or (and clasp ecl darwin) - (and abcl darwin (not abcl-bundle-op-supported)))) -(defmethod perform :before ((o basic-compile-bundle-op) (c component)) - (unless (featurep :asdf-use-unsafe-mac-bundle-op) - (cerror "Continue after modifying *FEATURES*." - "BASIC-COMPILE-BUNDLE-OP operations are not supported on Mac OS X for this lisp.~%~T~ -To continue, push :asdf-use-unsafe-mac-bundle-op onto *FEATURES*.~%~T~ -Please report to ASDF-DEVEL if this works for you."))) ;;;; ------------------------------------------------------------------------- ;;;; Concatenate-source @@ -11009,27 +11931,40 @@ ;;; Concatenate sources ;;; (with-upgradability () + ;; Base classes for both regular and monolithic concatenate-source operations (defclass basic-concatenate-source-op (bundle-op) ((bundle-type :initform "lisp"))) (defclass basic-load-concatenated-source-op (basic-load-op selfward-operation) ()) (defclass basic-compile-concatenated-source-op (basic-compile-op selfward-operation) ()) (defclass basic-load-compiled-concatenated-source-op (basic-load-op selfward-operation) ()) - (defclass concatenate-source-op (basic-concatenate-source-op non-propagating-operation) ()) + ;; Regular concatenate-source operations + (defclass concatenate-source-op (basic-concatenate-source-op non-propagating-operation) () + (:documentation "Operation to concatenate all sources in a system into a single file")) (defclass load-concatenated-source-op (basic-load-concatenated-source-op) - ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class))) + ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class)) + (:documentation "Operation to load the result of concatenate-source-op as source")) (defclass compile-concatenated-source-op (basic-compile-concatenated-source-op) - ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class))) + ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class)) + (:documentation "Operation to compile the result of concatenate-source-op")) (defclass load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op) - ((selfward-operation :initform '(prepare-op compile-concatenated-source-op) :allocation :class))) + ((selfward-operation :initform '(prepare-op compile-concatenated-source-op) :allocation :class)) + (:documentation "Operation to load the result of compile-concatenated-source-op")) - (defclass monolithic-concatenate-source-op (basic-concatenate-source-op monolithic-bundle-op non-propagating-operation) ()) + (defclass monolithic-concatenate-source-op + (basic-concatenate-source-op monolithic-bundle-op non-propagating-operation) () + (:documentation "Operation to concatenate all sources in a system and its dependencies +into a single file")) (defclass monolithic-load-concatenated-source-op (basic-load-concatenated-source-op) - ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class))) + ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class)) + (:documentation "Operation to load the result of monolithic-concatenate-source-op as source")) (defclass monolithic-compile-concatenated-source-op (basic-compile-concatenated-source-op) - ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class))) - (defclass monolithic-load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op) - ((selfward-operation :initform 'monolithic-compile-concatenated-source-op :allocation :class))) + ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class)) + (:documentation "Operation to compile the result of monolithic-concatenate-source-op")) + (defclass monolithic-load-compiled-concatenated-source-op + (basic-load-compiled-concatenated-source-op) + ((selfward-operation :initform 'monolithic-compile-concatenated-source-op :allocation :class)) + (:documentation "Operation to load the result of monolithic-compile-concatenated-source-op")) (defmethod input-files ((operation basic-concatenate-source-op) (s system)) (loop :with encoding = (or (component-encoding s) *default-encoding*) @@ -11038,7 +11973,7 @@ :with other-around-compile = '() :for c :in (required-components s :goal-operation 'compile-op - :keep-operation 'compile-op + :keep-operation 'basic-compile-op :other-systems (operation-monolithic-p operation)) :append (when (typep c 'cl-source-file) @@ -11092,27 +12027,36 @@ (in-package :asdf/package-inferred-system) (with-upgradability () + ;; The names of the recognized defpackage forms. (defparameter *defpackage-forms* '(defpackage define-package)) (defun initial-package-inferred-systems-table () + ;; Mark all existing packages are preloaded. (let ((h (make-hash-table :test 'equal))) (dolist (p (list-all-packages)) (dolist (n (package-names p)) (setf (gethash n h) t))) h)) + ;; Mapping from package names to systems that provide them. (defvar *package-inferred-systems* (initial-package-inferred-systems-table)) (defclass package-inferred-system (system) - ()) + () + (:documentation "Class for primary systems for which secondary systems are automatically +in the one-file, one-file, one-system style: system names are mapped to files under the primary +system's system-source-directory, dependencies are inferred from the first defpackage form in +every such file")) - ;; For backward compatibility only. To be removed in an upcoming release: + ;; DEPRECATED. For backward compatibility only. To be removed in an upcoming release: (defclass package-system (package-inferred-system) ()) + ;; Is a given form recognizable as a defpackage form? (defun defpackage-form-p (form) (and (consp form) (member (car form) *defpackage-forms*))) + ;; Find the first defpackage form in a stream, if any (defun stream-defpackage-form (stream) (loop :for form = (read stream nil nil) :while form :when (defpackage-form-p form) :return form)) @@ -11147,6 +12091,7 @@ :from-end t :test 'equal)) (defun package-designator-name (package) + "Normalize a package designator to a string" (etypecase package (package (package-name package)) (string package) @@ -11166,16 +12111,20 @@ system-name (string-downcase package-name))) + ;; Given a file in package-inferred-system style, find its dependencies (defun package-inferred-system-file-dependencies (file &optional system) (if-let (defpackage-form (file-defpackage-form file)) (remove t (mapcar 'package-name-system (package-dependencies defpackage-form))) (error 'package-inferred-system-missing-package-error :system system :pathname file))) - (defun same-package-inferred-system-p (system name directory subpath dependencies) + ;; Given package-inferred-system object, check whether its specification matches + ;; the provided parameters + (defun same-package-inferred-system-p (system name directory subpath around-compile dependencies) (and (eq (type-of system) 'package-inferred-system) (equal (component-name system) name) (pathname-equal directory (component-pathname system)) (equal dependencies (component-sideway-dependencies system)) + (equal around-compile (around-compile-hook system)) (let ((children (component-children system))) (and (length=n-p children 1) (let ((child (first children))) @@ -11184,25 +12133,28 @@ (and (slot-boundp child 'relative-pathname) (equal (slot-value child 'relative-pathname) subpath)))))))) + ;; sysdef search function to push into *system-definition-search-functions* (defun sysdef-package-inferred-system-search (system) (let ((primary (primary-system-name system))) (unless (equal primary system) (let ((top (find-system primary nil))) (when (typep top 'package-inferred-system) - (if-let (dir (system-source-directory top)) + (if-let (dir (component-pathname top)) (let* ((sub (subseq system (1+ (length primary)))) (f (probe-file* (subpathname dir sub :type "lisp") :truename *resolve-symlinks*))) (when (file-pathname-p f) (let ((dependencies (package-inferred-system-file-dependencies f system)) - (previous (cdr (system-registered-p system)))) - (if (same-package-inferred-system-p previous system dir sub dependencies) + (previous (registered-system system)) + (around-compile (around-compile-hook top))) + (if (same-package-inferred-system-p previous system dir sub around-compile dependencies) previous (eval `(defsystem ,system :class package-inferred-system :source-file nil :pathname ,dir :depends-on ,dependencies + :around-compile ,around-compile :components ((cl-source-file "lisp" :pathname ,sub))))))))))))))) (with-upgradability () @@ -11216,27 +12168,14 @@ (uiop/package:define-package :asdf/backward-internals (:recycle :asdf/backward-internals :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system) - (:export ;; for internal use - #:make-sub-operation - #:load-sysdef #:make-temporary-package)) + (:export #:load-sysdef)) (in-package :asdf/backward-internals) -(when-upgrading (:when (fboundp 'make-sub-operation)) - (defun make-sub-operation (c o dep-c dep-o) - (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error))) - -;;;; load-sysdef (with-upgradability () (defun load-sysdef (name pathname) - (load-asd pathname :name name)) - - (defun make-temporary-package () - ;; For loading a .asd file, we don't make a temporary package anymore, - ;; but use ASDF-USER. I'd like to have this function do this, - ;; but since whoever uses it is likely to delete-package the result afterwards, - ;; this would be a bad idea, so preserve the old behavior. - (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf)))) - + (declare (ignore name pathname)) + ;; Needed for backward compatibility with swank-asdf from SLIME 2015-12-01 or older. + (error "Use asdf:load-asd instead of asdf::load-sysdef"))) ;;;; ------------------------------------------------------------------------- ;;; Backward-compatible interfaces @@ -11259,6 +12198,10 @@ (in-package :asdf/backward-interface) (with-upgradability () + ;; These conditions from ASDF 1 and 2 are used by many packages in Quicklisp; + ;; but ASDF3 replaced them with somewhat different variants of uiop:compile-condition + ;; that do not involve ASDF actions. + ;; TODO: find the offenders and stop them. (define-condition operation-error (error) ;; Bad, backward-compatible name ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel ((component :reader error-component :initarg :component) @@ -11271,16 +12214,37 @@ (define-condition compile-warned (compile-error) ()) (defun component-load-dependencies (component) + "DEPRECATED. Please use COMPONENT-SIDEWAY-DEPENDENCIES instead." ;; Old deprecated name for the same thing. Please update your software. (component-sideway-dependencies component)) - (defgeneric operation-forced (operation)) ;; Used by swank.asd for swank-loader. + (defgeneric operation-forced (operation) + (:documentation "DEPRECATED. Assume it's (constantly t) instead.")) + ;; This method exists for backward compatibility with swank.asd, its only user, + ;; that still uses it as of 2016-09-21. + ;; + ;; The magic PERFORM method in swank.asd only actually loads swank if it sees that + ;; the operation was forced. But except for the first time, the only reason the action + ;; would be performed to begin with is because it was forced; and the first time over, + ;; it doesn't hurt that :reload t :delete t should be used. So the check is redundant. + ;; More generally, if you have to do something when the operation was forced, + ;; you should also do it when not, and vice-versa, because it really shouldn't matter. + ;; Thus, the backward-compatible thing to do is to always return T. + ;; + ;; TODO: change this function to a defun that always returns T. (defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force)) - (defgeneric operation-on-warnings (operation)) - (defgeneric operation-on-failure (operation)) - (defgeneric (setf operation-on-warnings) (x operation)) - (defgeneric (setf operation-on-failure) (x operation)) + + ;; These old interfaces from ASDF1 have never been very meaningful + ;; but are still used in obscure places. + (defgeneric operation-on-warnings (operation) + (:documentation "DEPRECATED. Please use UIOP:*COMPILE-FILE-WARNINGS-BEHAVIOUR* instead.")) + (defgeneric operation-on-failure (operation) + (:documentation "DEPRECATED. Please use UIOP:*COMPILE-FILE-FAILURE-BEHAVIOUR* instead.")) + (defgeneric (setf operation-on-warnings) (x operation) + (:documentation "DEPRECATED. Please SETF UIOP:*COMPILE-FILE-WARNINGS-BEHAVIOUR* instead.")) + (defgeneric (setf operation-on-failure) (x operation) + (:documentation "DEPRECATED. Please SETF UIOP:*COMPILE-FILE-FAILURE-BEHAVIOUR* instead.")) (defmethod operation-on-warnings ((o operation)) *compile-file-warnings-behaviour*) (defmethod operation-on-failure ((o operation)) @@ -11294,15 +12258,17 @@ ;; As of 2.014.8, we mean to make this function obsolete, ;; but that won't happen until all clients have been updated. ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead" - "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete. -It used to expose ASDF internals with subtle differences with respect to -user expectations, that have been refactored away since. -We recommend you use ASDF:SYSTEM-SOURCE-FILE instead -for a mostly compatible replacement that we're supporting, -or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME + "DEPRECATED. This function used to expose ASDF internals with subtle +differences with respect to user expectations, that have been refactored +away since. We recommend you use ASDF:SYSTEM-SOURCE-FILE instead for a +mostly compatible replacement that we're supporting, or even +ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME if that's whay you mean." ;;) (system-source-file x)) + + ;; TRAVERSE is the function used to compute a plan in ASDF 1 and 2. + ;; It was never officially exposed but some people still used it. (defgeneric* (traverse) (operation component &key &allow-other-keys) (:documentation "Generate and return a plan for performing OPERATION on COMPONENT. @@ -11318,6 +12284,7 @@ ;;;; ASDF-Binary-Locations compatibility ;; This remains supported for legacy user, but not recommended for new users. +;; We suspect there are no more legacy users in 2016. (with-upgradability () (defun enable-asdf-binary-locations-compatibility (&key @@ -11329,7 +12296,8 @@ (source-to-target-mappings nil) (file-types `(,(compile-file-type) "build-report" - #+(or clasp ecl) (compile-file-type :type :object) + #+clasp (compile-file-type :output-type :object) + #+ecl (compile-file-type :type :object) #+mkcl (compile-file-type :fasl-p nil) #+clisp "lib" #+sbcl "cfasl" #+sbcl "sbcl-warnings" #+clozure "ccl-warnings"))) @@ -11602,57 +12570,75 @@ (uiop/package:define-package :asdf/footer (:recycle :asdf/footer :asdf) (:use :uiop/common-lisp :uiop - :asdf/upgrade :asdf/find-system :asdf/operate :asdf/bundle)) + :asdf/upgrade :asdf/find-system :asdf/operate :asdf/bundle) + ;; Happily, all those implementations all have the same module-provider hook interface. + #+(or abcl clasp cmucl clozure ecl mkcl sbcl) + (:import-from #+abcl :sys #+(or clasp cmucl ecl) :ext #+clozure :ccl #+mkcl :mk-ext #+sbcl sb-ext + #:*module-provider-functions* + #+ecl #:*load-hooks*) + #+(or clasp mkcl) (:import-from :si #:*load-hooks*)) + (in-package :asdf/footer) +;;;; Register ASDF itself and all its subsystems as preloaded. +(with-upgradability () + (dolist (s '("asdf" "uiop" "asdf-defsystem" "asdf-package-system")) + ;; Don't bother with these system names, no one relies on them anymore: + ;; "asdf-utils" "asdf-bundle" "asdf-driver" + (register-preloaded-system s :version *asdf-version*))) + + ;;;; Hook ASDF into the implementation's REQUIRE and other entry points. -#+(or abcl clasp clisp clozure cmu ecl mkcl sbcl) +#+(or abcl clasp clisp clozure cmucl ecl mkcl sbcl) (with-upgradability () - (if-let (x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom nil))) - (eval `(pushnew 'module-provide-asdf - #+abcl sys::*module-provider-functions* - #+(or clasp cmu ecl) ext:*module-provider-functions* - #+clisp ,x - #+clozure ccl:*module-provider-functions* - #+mkcl mk-ext:*module-provider-functions* - #+sbcl sb-ext:*module-provider-functions*))) + ;; Hook into CL:REQUIRE. + #-clisp (pushnew 'module-provide-asdf *module-provider-functions*) + #+clisp (if-let (x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom nil))) + (eval `(pushnew 'module-provide-asdf ,x))) #+(or clasp ecl mkcl) (progn - (pushnew '("fasb" . si::load-binary) si::*load-hooks* :test 'equal :key 'car) + (pushnew '("fasb" . si::load-binary) *load-hooks* :test 'equal :key 'car) - #+(or (and clasp windows) (and ecl win32) (and mkcl windows)) - (unless (assoc "asd" #+(or clasp ecl) ext:*load-hooks* #+mkcl si::*load-hooks* :test 'equal) - (appendf #+(or clasp ecl) ext:*load-hooks* #+mkcl si::*load-hooks* '(("asd" . si::load-source)))) - - (setf #+(or clasp ecl) ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions* - (loop :for f :in #+(or clasp ecl) ext:*module-provider-functions* - #+mkcl mk-ext::*module-provider-functions* - :collect - (if (eq f 'module-provide-asdf) f - #'(lambda (name) - (let ((l (multiple-value-list (funcall f name)))) - (and (first l) (register-preloaded-system (coerce-name name))) - (values-list l)))))))) + #+os-windows + (unless (assoc "asd" *load-hooks* :test 'equal) + (appendf *load-hooks* '(("asd" . si::load-source)))) + + ;; Wrap module provider functions in an idempotent, upgrade friendly way + (defvar *wrapped-module-provider* (make-hash-table)) + (setf (gethash 'module-provide-asdf *wrapped-module-provider*) 'module-provide-asdf) + (defun wrap-module-provider (provider name) + (let ((results (multiple-value-list (funcall provider name)))) + (when (first results) (register-preloaded-system (coerce-name name))) + (values-list results))) + (defun wrap-module-provider-function (provider) + (ensure-gethash provider *wrapped-module-provider* + (constantly + #'(lambda (module-name) + (wrap-module-provider provider module-name))))) + (setf *module-provider-functions* + (mapcar #'wrap-module-provider-function *module-provider-functions*)))) -#+cmu ;; Hook into the CMUCL herald. +#+cmucl ;; Hook into the CMUCL herald. (with-upgradability () (defun herald-asdf (stream) (format stream " ASDF ~A" (asdf-version))) - (setf (getf ext:*herald-items* :asdf) `(herald-asdf))) + (setf (getf ext:*herald-items* :asdf) '(herald-asdf))) ;;;; Done! (with-upgradability () - #+allegro + #+allegro ;; restore *w-o-n-r-c* setting as saved in uiop/common-lisp (when (boundp 'excl:*warn-on-nested-reader-conditionals*) - (setf excl:*warn-on-nested-reader-conditionals* asdf/common-lisp::*acl-warn-save*)) + (setf excl:*warn-on-nested-reader-conditionals* uiop/common-lisp::*acl-warn-save*)) + ;; Advertise the features we provide. (dolist (f '(:asdf :asdf2 :asdf3 :asdf3.1 :asdf-package-system)) (pushnew f *features*)) ;; Provide both lowercase and uppercase, to satisfy more people, especially LispWorks users. (provide "asdf") (provide "ASDF") + ;; Finally, call a function that will cleanup in case this is an upgrade of an older ASDF. (cleanup-upgraded-asdf)) (when *load-verbose* diff -Nru ecl-16.1.2/contrib/asdf/asdf.texinfo ecl-16.1.3+ds/contrib/asdf/asdf.texinfo --- ecl-16.1.2/contrib/asdf/asdf.texinfo 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/contrib/asdf/asdf.texinfo 1970-01-01 00:00:00.000000000 +0000 @@ -1,5824 +0,0 @@ -\input texinfo @c -*- texinfo -*- -@c %**start of header -@setfilename asdf.info -@settitle ASDF Manual -@syncodeindex tp fn -@c %**end of header - -@c We use @&key, etc to escape & from TeX in lambda lists -- -@c so we need to define them for info as well. -@macro AallowOtherKeys -&allow-other-keys -@end macro -@macro Aoptional -&optional -@end macro -@macro Arest -&rest -@end macro -@macro Akey -&key -@end macro -@macro Abody -&body -@end macro - -@c for install-info -@dircategory Software development -@direntry -* asdf: (asdf). Another System Definition Facility (for Common Lisp) -@end direntry - -@copying -This manual describes ASDF, a system definition facility -for Common Lisp programs and libraries. - -You can find the latest version of this manual at -@url{http://common-lisp.net/project/asdf/asdf.html}. - -ASDF Copyright @copyright{} 2001-2014 Daniel Barlow and contributors. - -This manual Copyright @copyright{} 2001-2014 Daniel Barlow and contributors. - -This manual revised @copyright{} 2009-2014 Robert P. Goldman and Francois-Rene Rideau. - -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 AUTHORS OR COPYRIGHT HOLDERS BE -LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION -OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION -WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - -@end copying - - - -@titlepage -@title ASDF: Another System Definition Facility - -@c The following two commands start the copyright page. -@page -@vskip 0pt plus 1filll -@insertcopying -@end titlepage - -@c Output the table of contents at the beginning. -@contents - -@c ------------------- - -@ifnottex - -@node Top, Introduction, (dir), (dir) -@top ASDF: Another System Definition Facility - -@insertcopying - -@menu -* Introduction:: -* Quick start summary:: -* Loading ASDF:: -* Configuring ASDF:: -* Using ASDF:: -* Defining systems with defsystem:: -* The object model of ASDF:: -* Controlling where ASDF searches for systems:: -* Controlling where ASDF saves compiled files:: -* Error handling:: -* Miscellaneous additional functionality:: -* Getting the latest version:: -* FAQ:: -* Ongoing Work:: -* Bibliography:: -* Concept Index:: -* Function and Class Index:: -* Variable Index:: @c @detailmenu -@c - -@detailmenu - --- The Detailed Node Listing --- - -Loading ASDF - -* Loading a pre-installed ASDF:: -* Checking whether ASDF is loaded:: -* Upgrading ASDF:: -* Loading ASDF from source:: - -Upgrading ASDF - -* Upgrading your implementation's ASDF:: -* Issues with upgrading ASDF:: - -Configuring ASDF - -* Configuring ASDF to find your systems:: -* Configuring ASDF to find your systems --- old style:: -* Configuring where ASDF stores object files:: -* Resetting the ASDF configuration:: - -Using ASDF - -* Loading a system:: -* Other Operations:: -* Moving on:: - -Defining systems with defsystem - -* The defsystem form:: -* A more involved example:: -* The defsystem grammar:: -* Other code in .asd files:: -* The package-inferred-system extension:: - -The Object model of ASDF - -* Operations:: -* Components:: -* Dependencies:: -* Functions:: - -Operations - -* Predefined operations of ASDF:: -* Creating new operations:: - -Components - -* Common attributes of components:: -* Pre-defined subclasses of component:: -* Creating new component types:: - -properties - -* Pre-defined subclasses of component:: -* Creating new component types:: - -Controlling where ASDF searches for systems - -* Configurations:: -* Truenames and other dangers:: -* XDG base directory:: -* Backward Compatibility:: -* Configuration DSL:: -* Configuration Directories:: -* Shell-friendly syntax for configuration:: -* Search Algorithm:: -* Caching Results:: -* Configuration API:: -* Introspection:: -* Status:: -* Rejected ideas:: -* TODO:: -* Credits for the source-registry:: - -Configuration Directories - -* The here directive:: - -Introspection - -* *source-registry-parameter* variable:: -* Information about system dependencies:: - -Controlling where ASDF saves compiled files - -* Output Configurations:: -* Output Backward Compatibility:: -* Output Configuration DSL:: -* Output Configuration Directories:: -* Output Shell-friendly syntax for configuration:: -* Semantics of Output Translations:: -* Output Caching Results:: -* Output location API:: -* Credits for output translations:: - -Miscellaneous additional functionality - -* Controlling file compilation:: -* Controlling source file character encoding:: -* Some Utility Functions:: - -FAQ - -* Where do I report a bug?:: -* What has changed between ASDF 1 ASDF 2 and ASDF 3?:: -* Issues with installing the proper version of ASDF:: -* Issues with configuring ASDF:: -* Issues with using and extending ASDF to define systems:: -* ASDF development FAQs:: - -``What has changed between ASDF 1, ASDF 2, and ASDF 3?'' - -* What are ASDF 1 2 3?:: -* How do I detect the ASDF version?:: -* ASDF can portably name files in subdirectories:: -* Output translations:: -* Source Registry Configuration:: -* Usual operations are made easier to the user:: -* Many bugs have been fixed:: -* ASDF itself is versioned:: -* ASDF can be upgraded:: -* Decoupled release cycle:: -* Pitfalls of the transition to ASDF 2:: -* What happened to the bundle operations:: - -Issues with installing the proper version of ASDF - -* My Common Lisp implementation comes with an outdated version of ASDF. What to do?:: -* I'm a Common Lisp implementation vendor. When and how should I upgrade ASDF?:: - -Issues with configuring ASDF - -* How can I customize where fasl files are stored?:: -* How can I wholly disable the compiler output cache?:: - -Issues with using and extending ASDF to define systems - -* How can I cater for unit-testing in my system?:: -* How can I cater for documentation generation in my system?:: -* How can I maintain non-Lisp (e.g. C) source files?:: -* I want to put my module's files at the top level. How do I do this?:: -* How do I create a system definition where all the source files have a .cl extension?:: -* How do I mark a source file to be loaded only and not compiled?:: -* How do I work with readtables?:: - -ASDF development FAQs - -* How do run the tests interactively in a REPL?:: - -@end detailmenu -@end menu - -@end ifnottex - -@c ------------------- - -@node Introduction, Quick start summary, Top, Top -@comment node-name, next, previous, up -@chapter Introduction -@cindex ASDF-related features -@vindex *features* -@cindex Testing for ASDF -@cindex ASDF versions -@cindex :asdf -@cindex :asdf2 -@cindex :asdf3 - -ASDF is Another System Definition Facility: -a tool for specifying how systems of Common Lisp software -are made up of components (sub-systems and files), -and how to operate on these components in the right order -so that they can be compiled, loaded, tested, etc. -If you are new to ASDF, @pxref{Quick start summary,,the quick start -guide}. - -ASDF presents three faces: -one for users of Common Lisp software who want to reuse other people's code, -one for writers of Common Lisp software who want to specify how to build their systems, -and one for implementers of Common Lisp extensions who want to extend -the build system. -For more specifics, -@pxref{Using ASDF,,Loading a system}, -to learn how to use ASDF to load a system. -@xref{Defining systems with defsystem}, -to learn how to define a system of your own. -@xref{The object model of ASDF}, for a description of -the ASDF internals and how to extend ASDF. - -Note that -ASDF is @emph{not} a tool for library and system @emph{installation}; it -plays a role like @t{make} or @t{ant}, not like a package manager. -In particular, ASDF should not to be confused with ASDF-Install, which attempts to find and -download ASDF systems for you. -Despite the name, ASDF-Install is not part of ASDF, but a separate piece of software. -ASDF-Install is also unmaintained and obsolete. -We recommend you use Quicklisp -(@uref{http://www.quicklisp.org}) instead, -a Common Lisp package manager which works well and is being actively maintained. -If you want to download software from version control instead of tarballs, -so you may more easily modify it, we recommend clbuild (@uref{http://common-lisp.net/project/clbuild/}). -We recommend @file{~/common-lisp/} -as a place into which to install Common Lisp software; -starting with ASDF 3.1.2, it is included in the default source-registry configuration. - -@node Quick start summary, Loading ASDF, Introduction, Top -@chapter Quick start summary - -@itemize - -@item To load an ASDF system: - -@itemize -@item -Load ASDF itself into your Lisp image, either through -@code{(require "asdf")} (if it's supplied by your lisp implementation) -or else through -@code{(load "/path/to/asdf.lisp")}. For more details, @ref{Loading ASDF}. - -@item -Make sure ASDF can find system definitions -through proper source-registry configuration. -For more details, @xref{Configuring ASDF to find your systems}. -The simplest way is simply to put all your lisp code in subdirectories of -@file{~/common-lisp/} (starting with ASDF 3.1.2), -or @file{~/.local/share/common-lisp/source/} -(for ASDF 2 and later, or if you want to keep source in a hidden directory). -Such code will automatically be found. - -@item -Load a system with @code{(asdf:load-system :system)}. @xref{Using ASDF}. - -@end itemize - -@item To make your own ASDF system: - -@itemize -@item -As above, load and configure ASDF. - -@item -Make a new directory for your system, @code{my-system/} in a location -where ASDF can find it (@pxref{Configuring ASDF to find your systems}). -All else being equal, the easiest location is probably -@file{~/common-lisp/my-system/}. - - -@item -Create an ASDF system definition listing the dependencies of -your system, its components, and their interdependencies, -and put it in @file{my-system.asd}. -This file must have the same name as your system. -@xref{Defining systems with defsystem}. - -@item -Use @code{(asdf:load-system :my-system)} -to make sure it's all working properly. @xref{Using ASDF}. - -@end itemize -@end itemize - -@c FIXME: (1) add a sample project that the user can cut and paste to -@c get started. (2) discuss the option of starting with Quicklisp. - - - - - -@node Loading ASDF, Configuring ASDF, Quick start summary, Top -@comment node-name, next, previous, up -@chapter Loading ASDF - -@menu -* Loading a pre-installed ASDF:: -* Checking whether ASDF is loaded:: -* Upgrading ASDF:: -* Loading ASDF from source:: -@end menu - -@node Loading a pre-installed ASDF, Checking whether ASDF is loaded, Loading ASDF, Loading ASDF -@section Loading a pre-installed ASDF - -Most recent Lisp implementations include a copy of ASDF 3, -or at least ASDF 2. -You can usually load this copy using Common Lisp's @code{require} function.@footnote{ -NB: all implementations except GNU CLISP also accept -@code{(require "ASDF")}, @code{(require 'asdf)} and @code{(require :asdf)}. -For portability's sake, you should use @code{(require "asdf")}. -} - -@lisp -(require "asdf") -@end lisp - -As of the writing of this manual, -the following implementations provide ASDF 3 this way: -ABCL, Allegro CL, Clozure CL, CMUCL, ECL, GNU CLISP, MKCL, SBCL. -The following implementations only provide ASDF 2: -LispWorks, mocl, XCL. -The following implementations don't provide ASDF: -Corman CL, GCL, Genera, MCL, SCL. -The latter implementations are not actively maintained; -if some of them are ever released again, they probably will include ASDF 3. - -If the implementation you are using doesn't provide ASDF 2 or ASDF 3, -see @pxref{Loading ASDF,,Loading ASDF from source} below. -If that implementation is still actively maintained, -you may also send a bug report to your Lisp vendor and complain -about their failing to provide ASDF. - -@node Checking whether ASDF is loaded, Upgrading ASDF, Loading a pre-installed ASDF, Loading ASDF -@section Checking whether ASDF is loaded - -To check whether ASDF is properly loaded in your current Lisp image, -you can run this form: - -@lisp -(asdf:asdf-version) -@end lisp - -If it returns a string, -that is the version of ASDF that is currently installed. - -If it raises an error, -then either ASDF is not loaded, or -you are using a very old version of ASDF, -and need to install ASDF 3. - -You can check whether an old version is loaded -by checking if the ASDF package is present. -The form below will allow you to programmatically determine -whether a recent version is loaded, an old version is loaded, -or none at all: - -@lisp -(when (find-package :asdf) - (let ((ver (symbol-value - (or (find-symbol (string :*asdf-version*) :asdf) - (find-symbol (string :*asdf-revision*) :asdf))))) - (etypecase ver - (string ver) - (cons (with-output-to-string (s) - (loop for (n . m) on ver - do (princ n s) - (when m (princ "." s))))) - (null "1.0")))) -@end lisp - -If it returns @code{nil} then ASDF is not installed. -Otherwise it should return a string. -If it returns @code{"1.0"}, then it can actually be -any version before 1.77 or so, or some buggy variant of 1.x. - -If you are experiencing problems with ASDF, -please try upgrading to the latest released version, -using the method below, -before you contact us and raise an issue. - -@node Upgrading ASDF, Loading ASDF from source, Checking whether ASDF is loaded, Loading ASDF -@section Upgrading ASDF -@c FIXME: tighten this up a bit -- there's a lot of stuff here that -@c doesn't matter to almost anyone. Move discussion of updating antique -@c versions of ASDF down, or encapsulate it. - -If you want to upgrade to a more recent ASDF version, -you need to install and configure your ASDF just like any other system -(@pxref{Configuring ASDF to find your systems}). - -If your implementation provides ASDF 3 or later, -you only need to @code{(require "asdf")}: -ASDF will automatically look whether an updated version of itself is available -amongst the regularly configured systems, before it compiles anything else. - -@menu -* Upgrading your implementation's ASDF:: -* Issues with upgrading ASDF:: -@end menu - -@node Upgrading your implementation's ASDF, Issues with upgrading ASDF, Upgrading ASDF, Upgrading ASDF -@subsection Upgrading your implementation's ASDF - -Most implementations provide a recent ASDF 3 in their latest release. -If yours doesn't, we recommend upgrading your implementation. -If the latest version of your implementation still doesn't provide ASDF, -or provides an old version, we recommend installing a recent ASDF so your implementation provides it, -as explained below. -If all fails, we recommend you load ASDF from source -@pxref{Loading ASDF,,Loading ASDF from source}. - -The ASDF source repository contains a tool to help you upgrade your implementation's ASDF. -You can invoke it from the shell command-line as -@code{tools/asdf-tools install-asdf lispworks} -(where you can replace @code{lispworks} by the name of the relevant implementation), -or you can @code{(load "tools/install-asdf.lisp")} from your Lisp REPL. - -It works on -Allegro CL, Clozure CL, CMU CL, ECL, GCL, GNU CLISP, LispWorks, MKCL, SBCL, SCL, XCL. -It doesn't work on ABCL, Corman CL, Genera, MCL, MOCL. -Happily, ABCL is usually pretty up to date and shouldn't need that script. -GCL requires a very recent version, and hasn't been tested for lack of success compiling it. -Corman CL, Genera, MCL are obsolete anyway. -MOCL is under development. - -Finally, if your implementation only provides ASDF 2, -and you can't or won't upgrade it or override its ASDF module, -you may simply configure ASDF to find a proper upgrade; -however, to avoid issues with a self-upgrade in mid-build, -you @emph{must} make sure to upgrade ASDF immediately -after requiring the builtin ASDF 2: - -@lisp -(require "asdf") -;; <--- insert programmatic configuration here if needed -(asdf:load-system :asdf) -@end lisp - -@node Issues with upgrading ASDF, , Upgrading your implementation's ASDF, Upgrading ASDF -@subsection Issues with upgrading ASDF - -Note that there are some limitations to upgrading ASDF: -@itemize -@item -Previously loaded ASDF extensions become invalid, and will need to be reloaded. -Examples include CFFI-Grovel, hacks used by ironclad, etc. -Since it isn't possible to automatically detect what extensions -need to be invalidated, -ASDF will invalidate @emph{all} previously loaded systems -when it is loaded on top of a forward-incompatible ASDF version. -@footnote{ -@vindex *oldest-forward-compatible-asdf-version* -Forward incompatibility can be determined using the variable -@code{asdf/upgrade::*oldest-forward-compatible-asdf-version*}, -which is 2.33 at the time of this writing.} - -Starting with ASDF 3 (2.27 or later), -this self-upgrade will be automatically attempted as the first step -to any system operation, to avoid any possibility of -a catastrophic attempt to self-upgrade in mid-build. - -@c FIXME: Fix grammar below. -@item -For this and many other reasons, -you should load, configure and upgrade ASDF -as one of the very first things done by your build and startup scripts. -It is safer if you upgrade ASDF and its extensions as a special step -at the very beginning of whatever script you are running, -before you start using ASDF to load anything else. - -@item -Until all implementations provide ASDF 3 or later, -it is unsafe to upgrade ASDF as part of loading a system -that depends on a more recent version of ASDF, -since the new one might shadow the old one while the old one is running, -and the running old one will be confused -when extensions are loaded into the new one. -In the meantime, we recommend that your systems should @emph{not} specify -@code{:depends-on (:asdf)}, or @code{:depends-on ((:version :asdf "3.0.1"))}, -but instead that they check that a recent enough ASDF is installed, -with such code as: -@example -(unless (or #+asdf2 (asdf:version-satisfies - (asdf:asdf-version) *required-asdf-version*)) - (error "FOO requires ASDF ~A or later." *required-asdf-version*)) -@end example -@item -Until all implementations provide ASDF 3 or later, -it is unsafe for a system to transitively depend on ASDF -and not directly depend on ASDF; -if any of the system you use either depends-on asdf, -system-depends-on asdf, or transitively does, -you should also do as well. -@end itemize - -@node Loading ASDF from source, , Upgrading ASDF, Loading ASDF -@section Loading ASDF from source - -If your implementation doesn't include ASDF, -if for some reason the upgrade somehow fails, -does not or cannot apply to your case, -you will have to install the file @file{asdf.lisp} -somewhere and load it with: - -@lisp -(load "/path/to/your/installed/asdf.lisp") -@end lisp - -The single file @file{asdf.lisp} is all you normally need to use ASDF. - -You can extract this file from latest release tarball on the -@url{http://common-lisp.net/project/asdf/,ASDF website}. -If you are daring and willing to report bugs, you can get -the latest and greatest version of ASDF from its git repository. -@xref{Getting the latest version}. - -For maximum convenience you might want to have ASDF loaded -whenever you start your Lisp implementation, -for example by loading it from the startup script or dumping a custom core ---- check your Lisp implementation's manual for details. - - -@node Configuring ASDF, Using ASDF, Loading ASDF, Top -@comment node-name, next, previous, up -@chapter Configuring ASDF - -For standard use cases, ASDF should work pretty much out of the box. -We recommend you skim the sections on configuring ASDF to find your systems -and choose the method of installing Lisp software that works best for you. -Then skip directly to @xref{Using ASDF}. That will probably be enough. -You are unlikely to have to worry about the way ASDF stores object files, -and resetting the ASDF configuration is usually only needed in corner cases. - - -@menu -* Configuring ASDF to find your systems:: -* Configuring ASDF to find your systems --- old style:: -* Configuring where ASDF stores object files:: -* Resetting the ASDF configuration:: -@end menu - -@node Configuring ASDF to find your systems, Configuring ASDF to find your systems --- old style, Configuring ASDF, Configuring ASDF -@section Configuring ASDF to find your systems - -In order to compile and load your systems, ASDF must be configured to find -the @file{.asd} files that contain system definitions. - -There are a number of different techniques for setting yourself up with -ASDF, starting from easiest to the most complex: - -@itemize @bullet - -@item -Put all of your systems in one of the standard locations, subdirectories -of -@itemize -@item -@file{~/common-lisp/} or -@item -@file{~/.local/share/common-lisp/source/}. -@end itemize -If you install software there, you don't need further -configuration.@footnote{@file{~/common-lisp/} is only included in -the default configuration -starting with ASDF 3.1.2 or later.} - -@item -If you're using some tool to install software (e.g. Quicklisp), -the authors of that tool should already have configured ASDF. - -@item -If you have more specific desires about how to lay out your software on -disk, the preferred way to configure where ASDF finds your systems is -the @code{source-registry} facility, -fully described in its own chapter of this manual. -@xref{Controlling where ASDF searches for systems}. Here is a quick -recipe for getting started: - -The simplest way to add a path to your search path, -say @file{/home/luser/.asd-link-farm/} -is to create the directory -@file{~/.config/common-lisp/source-registry.conf.d/} -and there create a file with any name of your choice, -and with the type @file{conf}@footnote{By requiring the @file{.conf} -extension, and ignoring other files, ASDF allows you to have disabled files, -editor backups, etc. in the same directory with your active -configuration files. - -ASDF will also ignore files whose names start with a @file{.} character. - -It is customary to start the filename with two digits, to control the -sorting of the @code{conf} files in the source registry directory, and -thus the order in which the directories will be scanned.}, -for instance @file{42-asd-link-farm.conf}, -containing the line: - -@kbd{(:directory "/home/luser/.asd-link-farm/")} - -If you want all the subdirectories under @file{/home/luser/lisp/} -to be recursively scanned for @file{.asd} files, instead use: - -@kbd{(:tree "/home/luser/lisp/")} - -ASDF will automatically read your configuration -the first time you try to find a system. -If necessary, you can reset the source-registry configuration with: - -@lisp -(asdf:clear-source-registry) -@end lisp - -@item -In earlier versions of ASDF, the system source registry was configured -using a global variable, @code{asdf:*central-registry*}. -For more details about this, see the following section, -@ref{Configuring ASDF to find your systems --- old style}. -Unless you need to understand this, -skip directly to @ref{Configuring where ASDF stores object files}. - -@end itemize - -Note that your Operating System distribution or your system administrator -may already have configured system-managed libraries for you. - - - -@node Configuring ASDF to find your systems --- old style, Configuring where ASDF stores object files, Configuring ASDF to find your systems, Configuring ASDF -@section Configuring ASDF to find your systems --- old style - - -@c FIXME: this section should be moved elsewhere. The novice user -@c should not be burdened with it. [2014/02/27:rpg] - - -The old way to configure ASDF to find your systems is by -@code{push}ing directory pathnames onto the variable -@code{asdf:*central-registry*}. - -You must configure this variable between the time you load ASDF -and the time you first try to use it. -Loading and configuring ASDF presumably happen -as part of some initialization script that builds or starts -your Common Lisp software system. -(For instance, some SBCL users used to put it in their @file{~/.sbclrc}.) - -The @code{asdf:*central-registry*} is empty by default in ASDF 2 or ASDF 3, -but is still supported for compatibility with ASDF 1. -When used, it takes precedence over the above source-registry.@footnote{ -It is possible to further customize -the system definition file search. -That's considered advanced use, and covered later: -search forward for -@code{*system-definition-search-functions*}. -@xref{Defining systems with defsystem}.} - -For example, let's say you want ASDF to find the @file{.asd} file -@file{/home/me/src/foo/foo.asd}. -In your lisp initialization file, you could have the following: - -@lisp -(require "asdf") -(push "/home/me/src/foo/" asdf:*central-registry*) -@end lisp - -Note the trailing slash: when searching for a system, -ASDF will evaluate each entry of the central registry -and coerce the result to a pathname.@footnote{ -ASDF will indeed call @code{eval} on each entry. -It will skip entries that evaluate to @code{nil}. - -Strings and pathname objects are self-evaluating, -in which case the @code{eval} step does nothing; -but you may push arbitrary s-expressions onto the central registry. -These s-expressions may be evaluated to compute context-dependent -entries, e.g. things that depend -on the value of shell variables or the identity of the user. - -The variable @code{asdf:*central-registry*} is thus a list of -``system directory designators''. -A @dfn{system directory designator} is a form -which will be evaluated whenever a system is to be found, -and must evaluate to a directory to look in (or @code{NIL}). -By ``directory'', we mean -``designator for a pathname with a non-empty DIRECTORY component''. -} -The trailing directory name separator -is necessary to tell Lisp that you're discussing a directory -rather than a file. If you leave it out, ASDF is likely to look in -@code{/home/me/src/} instead of @code{/home/me/src/foo/} as you -intended, and fail to find your system definition. - -Typically there are a lot of @file{.asd} files, and -a common idiom was to put -@emph{symbolic links} to all of one's @file{.asd} files -in a common directory -and push @emph{that} directory (the ``link farm'') -onto -@code{asdf:*central-registry*}, -instead of pushing each individual system directory. - -ASDF knows to follow @emph{symlinks} -to the actual location of the systems.@footnote{ -On Windows, you can use Windows shortcuts instead of POSIX symlinks. -if you try aliases under MacOS, we are curious to hear about your experience.} - -For example, if @code{#p"/home/me/cl/systems/"} -is an element of @code{*central-registry*}, you could set up the -system @var{foo} as follows: - -@example -$ cd /home/me/cl/systems/ -$ ln -s ~/src/foo/foo.asd . -@end example - -This old style for configuring ASDF is not recommended for new users, -but it is supported for old users, and for users who want to programmatically -control what directories are added to the ASDF search path. - - -@node Configuring where ASDF stores object files, Resetting the ASDF configuration, Configuring ASDF to find your systems --- old style, Configuring ASDF -@section Configuring where ASDF stores object files -@findex clear-output-translations - -ASDF lets you configure where object files will be stored. -Sensible defaults are provided and -you shouldn't normally have to worry about it. - -This allows the same source code repository to be shared -between several versions of several Common Lisp implementations, -between several users using different compilation options, -with users who lack write privileges on shared source directories, etc. -This also keeps source directories from being cluttered -with object/fasl files. - -Starting with ASDF 2, the @code{asdf-output-translations} facility -was added to ASDF itself. This facility controls where object files will be stored. -This facility is fully described in a chapter of this manual, -@ref{Controlling where ASDF saves compiled files}. - -@c FIXME: possibly this should be moved elsewhere. It's redundant here, -@c and makes this section of the manual too long and daunting for the -@c new user. [2014/02/27:rpg] -@c The simplest way to add a translation to your search path, -@c say from @file{/foo/bar/baz/quux/} -@c to @file{/where/i/want/my/fasls/} -@c is to create the directory -@c @file{~/.config/common-lisp/asdf-output-translations.conf.d/} -@c and there create a file with any name of your choice and the type @file{conf}, -@c for instance @file{42-bazquux.conf} -@c containing the line: - -@c @kbd{("/foo/bar/baz/quux/" "/where/i/want/my/fasls/")} - -@c To disable output translations for source under a given directory, -@c say @file{/toto/tata/} -@c you can create a file @file{40-disable-toto.conf} -@c with the line: - -@c @kbd{("/toto/tata/")} - -@c To wholly disable output translations for all directories, -@c you can create a file @file{00-disable.conf} -@c with the line: - -@c @kbd{(t t)} - -@c Note that your Operating System distribution or your system administrator -@c may already have configured translations for you. -@c In absence of any configuration, the default is to redirect everything -@c under an implementation-dependent subdirectory of @file{~/.cache/common-lisp/}. -@c @xref{Controlling where ASDF searches for systems}, for full details. - -@c The required @file{.conf} extension allows you to have disabled files -@c or editor backups (ending in @file{~}), and works portably -@c (for instance, it is a pain to allow both empty and non-empty extension on CLISP). -@c Excluded are files the name of which start with a @file{.} character. -@c It is customary to start the filename with two digits -@c that specify the order in which the directories will be scanned. - -@c ASDF will automatically read your configuration -@c the first time you try to find a system. -@c You can reset the source-registry configuration with: - -@c @lisp -@c (asdf:clear-output-translations) -@c @end lisp - -@c And you probably should do so before you dump your Lisp image, -@c if the configuration may change -@c between the machine where you save it at the time you save it -@c and the machine you resume it at the time you resume it. -@c (Once again, you should use @code{(asdf:clear-configuration)} -@c before you dump your Lisp image, which includes the above.) - -Note that before ASDF 2, -other ASDF add-ons offered the same functionality, -each in subtly different and incompatible ways: -ASDF-Binary-Locations, cl-launch, common-lisp-controller. -ASDF-Binary-Locations is now not needed anymore and should not be used. -cl-launch 3.000 and common-lisp-controller 7.2 have been updated -to delegate object file placement to ASDF. - -@node Resetting the ASDF configuration, , Configuring where ASDF stores object files, Configuring ASDF -@section Resetting the ASDF configuration - -@c FIXME: this should probably be moved out of the "quickstart" part of -@c the manual. [2014/02/27:rpg] - - -When you dump and restore an image, or when you tweak your configuration, -you may want to reset the ASDF configuration. -For that you may use the following function: - -@defun clear-configuration - Undoes any ASDF configuration - regarding source-registry or output-translations. -@end defun - -@vindex *image-dump-hook* -This function is pushed onto the @code{uiop:*image-dump-hook*} by default, -which means that if you save an image using @code{uiop:dump-image}, -or via @code{asdf:image-op} and @code{asdf:program-op}, -it will be automatically called to clear your configuration. -If for some reason you prefer to call your implementation's underlying functionality, -be sure to call @code{clear-configuration} manually, -or push it into your implementation's equivalent of @code{uiop:*image-dump-hook*}, -e.g. @code{sb-ext:*save-hooks*} on SBCL, or @code{ext:*before-save-initializations*} -on CMUCL and SCL, etc. - -@node Using ASDF, Defining systems with defsystem, Configuring ASDF, Top -@chapter Using ASDF - -@menu -* Loading a system:: -* Other Operations:: -* Moving on:: -@end menu - -@node Loading a system, Other Operations, Using ASDF, Using ASDF -@section Loading a system - -The system @var{foo} is loaded (and compiled, if necessary) -by evaluating the following Lisp form: - -@example -(asdf:load-system :@var{foo}) -@end example - -On some implementations (namely recent versions of -ABCL, Clozure CL, CMUCL, ECL, GNU CLISP, MKCL and SBCL), -ASDF hooks into the @code{CL:REQUIRE} facility -and you can just use: - -@example -(require :@var{foo}) -@end example - -In older versions of ASDF, you needed to use -@code{(asdf:oos 'asdf:load-op :@var{foo})}. -If your ASDF is too old to provide @code{asdf:load-system} though -we recommend that you upgrade to ASDF 3. -@xref{Loading ASDF,,Loading ASDF from source}. - -Note the name of a system is specified as a string or a symbol. -If a symbol (including a keyword), its name is taken and lowercased. -The name must be a suitable value for the @code{:name} initarg -to @code{make-pathname} in whatever filesystem the system is to be -found. - -The lower-casing-symbols behaviour is unconventional, -but was selected after some consideration. -The type of systems we want to support -either have lowercase as customary case (Unix, Mac, Windows) -or silently convert lowercase to uppercase (lpns). -@c so this makes more sense than attempting to use @code{:case :common}, -@c which is reported not to work on some implementations - -@node Other Operations, Moving on, Loading a system, Using ASDF -@section Other Operations - -@findex load-system -@findex compile-system -@findex test-system -@findex requrie-system - -ASDF provides three commands for the most common system operations: -@code{load-system}, @code{compile-system}, and @code{test-system}. -It also provides @code{require-system}, a version of @code{load-system} -that skips trying to update systems that are already loaded. - -@c FIXME: We seem to export @findex bundle-system also. - -@findex operate -@findex oos - -Because ASDF is an extensible system -for defining @emph{operations} on @emph{components}, -it also provides a generic function @code{operate} -(which is usually abbreviated by @code{oos}, -which stands for operate-on-system). -You'll use @code{oos} whenever you want to do something beyond -compiling, loading and testing. - -Output from ASDF and ASDF extensions are sent -to the CL stream @code{*standard-output*}, -so rebinding that stream around calls to @code{asdf:operate} -should redirect all output from ASDF operations. - -@c Reminder: before ASDF can operate on a system, however, -@c it must be able to find and load that system's definition. -@c @xref{Configuring ASDF,,Configuring ASDF to find your systems}. - -@c FIXME: the following is too complicated for here, especially since -@c :force hasn't been defined yet. Move it. [2014/02/27:rpg] - -@findex already-loaded-systems -@findex require-system -@findex load-system -@vindex *load-system-operation* -For advanced users, note that -@code{require-system} calls @code{load-system} -with keyword arguments @code{:force-not (already-loaded-systems)}. -@code{already-loaded-systems} returns a list of the names of loaded systems. -@code{load-system} applies @code{operate} with the operation from -@code{*load-system-operation*} (which by default is @code{load-op}), -the system, and any provided keyword arguments. - - -@node Moving on, , Other Operations, Using ASDF -@section Moving on - -That's all you need to know to use ASDF to load systems written by others. -The rest of this manual deals with writing system definitions -for Common Lisp software you write yourself, -including how to extend ASDF to define new operation and component types. - - -@node Defining systems with defsystem, The object model of ASDF, Using ASDF, Top -@comment node-name, next, previous, up -@chapter Defining systems with defsystem - -This chapter describes how to use ASDF to define systems and develop -software. - - -@menu -* The defsystem form:: -* A more involved example:: -* The defsystem grammar:: -* Other code in .asd files:: -* The package-inferred-system extension:: -@end menu - -@node The defsystem form, A more involved example, Defining systems with defsystem, Defining systems with defsystem -@comment node-name, next, previous, up -@section The defsystem form -@findex defsystem -@cindex asdf-user -@findex load-asd - -This section begins with an example of a system definition, -then gives the full grammar of @code{defsystem}. - -Let's look at a simple system. -This is a complete file that should be saved as @file{hello-lisp.asd} -(in order that ASDF can find it -when ordered to operate on the system named @code{"hello-lisp"}). - -@c FIXME: the first example should have an outside dependency, e.g., -@c CL-PPCRE. - -@lisp -(in-package :asdf-user) - -(defsystem "hello-lisp" - :description "hello-lisp: a sample Lisp system." - :version "0.0.1" - :author "Joe User " - :licence "Public Domain" - :components ((:file "packages") - (:file "macros" :depends-on ("packages")) - (:file "hello" :depends-on ("macros")))) -@end lisp - -Some notes about this example: - -@itemize - -@item -The file starts with an @code{in-package} form -for package @code{asdf-user}. Quick summary: just do this, because it -helps make interactive development of @code{defsystem} forms behave in -the same was as when these forms are loaded by ASDF. If that's enough -for you, skip the rest of this item. Otherwise read on for the gory details. - -If your file is loaded by ASDF 3, it will be loaded into the -@code{asdf-user} package. The @code{in-package} form -will ensure that the system definition is read the -same as within ASDF when you load it interactively with @code{cl:load}. -However, we recommend that you load @file{.asd} files -through function @code{asdf::load-asd} rather than through @code{cl:load}, -in which case this form is unnecessary. -Recent versions of SLIME (2013-02 and later) know to do that. - -@item -You can always rely on symbols -from both package @code{asdf} and @code{common-lisp} being available in -@code{.asd} files -- -most importantly including @code{defsystem}. - -@c FIXME: the following should be inserted in a more advanced -@c bit of the manual. For now, it is simply elided. -@c Starting with ASDF 3.1, -@c @file{.asd} files are read in the package @code{asdf-user} -@c that uses @code{asdf}, @code{uiop} and @code{uiop/common-lisp} -@c (a variant of @code{common-lisp} -@c that has some portability fixes on old implementations). -@c ASDF 3 releases before 3.1 also read in package @code{asdf-user} -@c but that package don't use the full @code{uiop}, only @code{uiop/package}. -@c ASDF 1 and ASDF 2 releases (up until 2.26) instead read @file{.asd} files -@c in a temporary package @code{asdf@emph{N}} -@c that uses @code{asdf} and @code{common-lisp}. -@c You may thus have to package-qualify some symbols with @code{uiop:} -@c to support older variants of ASDF 3, -@c and/or package-qualify them with @code{asdf::} -@c to be compatible with even older variants of ASDF 2 -@c (and then only use the few already available in ASDF 2). - - -@item -The @code{defsystem} form defines a system named @code{hello-lisp} -that contains three source files: -@file{packages}, @file{macros} and @file{hello}. - -@c FIXME: The first example system should probably use just :serial T. -@item -The file @file{macros} depends on @file{packages} -(presumably because the package it's in is defined in @file{packages}), -and the file @file{hello} depends on @file{macros} -(and hence, transitively on @file{packages}). -This means that ASDF will compile and load @file{packages} and @file{macros} -before starting the compilation of file @file{hello}. - -@item -System source files should be located in the same directory -as the @code{.asd} file with the system definition. -@c FIXME: the following should live somewhere, but not in the quickstart -@c page. [2014/05/03:rpg] -@c ASDF resolves symbolic links (or Windows shortcuts) -@c before loading the system definition file and -@c stores its location in the resulting system@footnote{ -@c It is possible, though almost never necessary, to override this behaviour.}. -@c This is a good thing because the user can move the system sources -@c without having to edit the system definition. - -@c FIXME: Should have cross-reference to "Version specifiers" in the -@c defsystem grammar, but the cross-referencing is so broken by -@c insufficient node breakdown that I have not put one in. -@c FIXME: this is way too detailed for the first example! -@c move it! -@item -Make sure you know how the @code{:version} numbers will be parsed! -Only period-separated non-negative integers are accepted. -See below Version specifiers in @ref{The defsystem grammar}. -@cindex :version - -@end itemize - -@node A more involved example, The defsystem grammar, The defsystem form, Defining systems with defsystem -@comment node-name, next, previous, up -@section A more involved example -@findex defsystem - -Let's illustrate some more involved uses of @code{defsystem} via a -slightly convoluted example: - -@lisp -(in-package :asdf-user) - -(defsystem "foo" - :version "1.0.0" - :components ((:module "mod" - :components ((:file "bar") - (:file"baz") - (:file "quux")) - :perform (compile-op :after (op c) - (do-something c)) - :explain (compile-op :after (op c) - (explain-something c))) - (:file "blah"))) -@end lisp - -The @code{:module} component named @code{"mod"} is a collection of three files, -which will be located in a subdirectory of the main code directory named -@file{mod} (this location can be overridden; see the discussion of the -@code{:pathname} option in @ref{The defsystem grammar}). - -The method-form tokens provide a shorthand for defining methods on -particular components. This part - -@lisp - :perform (compile-op :after (op c) - (do-something c)) - :explain (compile-op :after (op c) - (explain-something c)) -@end lisp - -has the effect of - -@lisp -(defmethod perform :after ((op compile-op) (c (eql ...))) - (do-something c)) -(defmethod explain :after ((op compile-op) (c (eql ...))) - (explain-something c)) -@end lisp - -where @code{...} is the component in question. -In this case @code{...} would expand to something like - -@lisp -(find-component "foo" "mod") -@end lisp - -For more details on the syntax of such forms, see @ref{The defsystem -grammar}. -For more details on what these methods do, @pxref{Operations} in -@ref{The object model of ASDF}. - -@c FIXME: The following plunge into detail weeds is not appropriate in this -@c location. [2010/10/03:rpg] -@c note that although this also supports @code{:before} methods, -@c they may not do what you want them to --- -@c a @code{:before} method on perform @code{((op compile-op) (c (eql ...)))} -@c will run after all the dependencies and sub-components have been processed, -@c but before the component in question has been compiled. - - -@c FIXME: There should be YA example that shows definitions of functions -@c and classes. The following material should go there. -@c @item -@c If in addition to simply using @code{defsystem}, -@c you are going to define functions, -@c create ASDF extension, globally bind symbols, etc., -@c it is recommended that to avoid namespace pollution between systems, -@c you should create your own package for that purpose, with: - -@c @lisp -@c (defpackage :hello-lisp-system -@c (:use :cl :asdf)) - -@c (in-package :hello-lisp-system) -@c @end lisp - - -@node The defsystem grammar, Other code in .asd files, A more involved example, Defining systems with defsystem -@comment node-name, next, previous, up -@section The defsystem grammar -@findex defsystem -@cindex DEFSYSTEM grammar - -@c FIXME: @var typesetting not consistently used here. We should either expand -@c its use to everywhere, or we should kill it everywhere. - - -@example -system-definition := ( defsystem system-designator @var{system-option}* ) - -system-option := :defsystem-depends-on system-list - | :weakly-depends-on @var{system-list} - | :class class-name (see discussion below) - | module-option - | option - -module-option := :components component-list - | :serial [ t | nil ] - -option := - | :pathname pathname-specifier - | :default-component-class class-name - | :perform method-form - | :explain method-form - | :output-files method-form - | :operation-done-p method-form - | :if-feature feature-expression - | :depends-on ( @var{dependency-def}* ) - | :in-order-to ( @var{dependency}+ ) - - -system-list := ( @var{simple-component-name}* ) - -component-list := ( @var{component-def}* ) - -component-def := ( component-type simple-component-name @var{option}* ) - -component-type := :module | :file | :static-file | other-component-type - -other-component-type := symbol-by-name - (@pxref{The defsystem grammar,,Component types}) - -# This is used in :depends-on, as opposed to ``dependency,'' -# which is used in :in-order-to -dependency-def := simple-component-name - | ( :feature @var{feature-expression} dependency-def ) - | ( :version simple-component-name version-specifier ) - | ( :require module-name ) - -# ``dependency'' is used in :in-order-to, as opposed to -# ``dependency-def'' -dependency := (dependent-op @var{requirement}+) -requirement := (required-op @var{required-component}+) -dependent-op := operation-name -required-op := operation-name - -simple-component-name := string - | symbol - -pathname-specifier := pathname | string | symbol - -method-form := (operation-name qual lambda-list @Arest{} body) -qual := method qualifier - -component-dep-fail-option := :fail | :try-next | :ignore - -feature-expression := keyword - | (:and @var{feature-expression}*) - | (:or @var{feature-expression}*) - | (:not @var{feature-expression}) -@end example - - -@subsection Component names - -Component names (@code{simple-component-name}) -may be either strings or symbols. - -@subsection Component types - -Component type names, even if expressed as keywords, will be looked up -by name in the current package and in the asdf package, if not found in -the current package. So a component type @code{my-component-type}, in -the current package @code{my-system-asd} can be specified as -@code{:my-component-type}, or @code{my-component-type}. - -@code{system} and its subclasses are @emph{not} -allowed as component types for such children components. - -@subsection System class names - -A system class name will be looked up -in the same way as a Component type (see above), -except that only @code{system} and its subclasses are allowed. -Typically, one will not need to specify a system -class name, unless using a non-standard system class defined in some -ASDF extension, typically loaded through @code{DEFSYSTEM-DEPENDS-ON}, -see below. For such class names in the ASDF package, we recommend that -the @code{:class} option be specified using a keyword symbol, such as - -@example -:class :MY-NEW-SYSTEM-SUBCLASS -@end example - -This practice will ensure that package name conflicts are avoided. -Otherwise, the symbol @code{MY-NEW-SYSTEM-SUBCLASS} will be read into -the current package @emph{before} it has been exported from the ASDF -extension loaded by @code{:defsystem-depends-on}, causing a name -conflict in the current package. - -@subsection Defsystem depends on -@cindex :defsystem-depends-on - -The @code{:defsystem-depends-on} option to @code{defsystem} allows the -programmer to specify another ASDF-defined system or set of systems that -must be loaded @emph{before} the system definition is processed. -Typically this is used to load an ASDF extension that is used in the -system definition. - -@subsection Weakly depends on -@cindex :weakly-depends-on - -We do @emph{NOT} recommend you use this feature. -If you are tempted to write a system @var{foo} -that weakly-depends-on a system @var{bar}, -we recommend that you should instead -write system @var{foo} in a parametric way, -and offer some special variable and/or some hook to specialize its behavior; -then you should write a system @var{foo+bar} -that does the hooking of things together. - -The (deprecated) @code{:weakly-depends-on} option to @code{defsystem} -allows the programmer to specify another ASDF-defined system or set of systems -that ASDF should @emph{try} to load, -but need not load in order to be successful. -Typically this is used if there are a number of systems -that, if present, could provide additional functionality, -but which are not necessary for basic function. - -Currently, although it is specified to be an option only to @code{defsystem}, -this option is accepted at any component, but it probably -only makes sense at the @code{defsystem} level. -Programmers are cautioned not -to use this component option except at the @code{defsystem} level, as -this anomalous behavior may be removed without warning. - -@c Finally, you might look into the @code{asdf-system-connections} extension, -@c that will let you define additional code to be loaded -@c when two systems are simultaneously loaded. -@c It may or may not be considered good style, but at least it can be used -@c in a way that has deterministic behavior independent of load order, -@c unlike @code{weakly-depends-on}. - - -@subsection Pathname specifiers -@cindex pathname specifiers - -A pathname specifier (@code{pathname-specifier}) -may be a pathname, a string or a symbol. -When no pathname specifier is given for a component, -which is the usual case, the component name itself is used. - -If a string is given, which is the usual case, -the string will be interpreted as a Unix-style pathname -where @code{/} characters will be interpreted as directory separators. -Usually, Unix-style relative pathnames are used -(i.e. not starting with @code{/}, as opposed to absolute pathnames); -they are relative to the path of the parent component. -Finally, depending on the @code{component-type}, -the pathname may be interpreted as either a file or a directory, -and if it's a file, -a file type may be added corresponding to the @code{component-type}, -or else it will be extracted from the string itself (if applicable). - -For instance, the @code{component-type} @code{:module} -wants a directory pathname, and so a string @code{"foo/bar"} -will be interpreted as the pathname @file{#p"foo/bar/"}. -On the other hand, the @code{component-type} @code{:file} -wants a file of type @code{lisp}, and so a string @code{"foo/bar"} -will be interpreted as the pathname @file{#p"foo/bar.lisp"}, -and a string @code{"foo/bar.quux"} -will be interpreted as the pathname @file{#p"foo/bar.quux.lisp"}. -Finally, the @code{component-type} @code{:static-file} -wants a file without specifying a type, and so a string @code{"foo/bar"} -will be interpreted as the pathname @file{#p"foo/bar"}, -and a string @code{"foo/bar.quux"} -will be interpreted as the pathname @file{#p"foo/bar.quux"}. - -ASDF interprets the string @code{".."} -as the pathname directory component word @code{:back}, -which when merged, goes back one level in the directory hierarchy. - -If a symbol is given, it will be translated into a string, -and downcased in the process. -The downcasing of symbols is unconventional, -but was selected after some consideration. -Observations suggest that the type of systems we want to support -either have lowercase as customary case (Unix, Mac, windows) -or silently convert lowercase to uppercase (lpns), -so this makes more sense than attempting to use @code{:case :common} -as argument to @code{make-pathname}, -which is reported not to work on some implementations. - -Pathname objects may be given to override the path for a component. -Such objects are typically specified using reader macros such as @code{#p} -or @code{#.(make-pathname ...)}. -Note however, that @code{#p...} is -a shorthand for @code{#.(parse-namestring ...)} -and that the behavior of @code{parse-namestring} is completely non-portable, -unless you are using Common Lisp @code{logical-pathname}s, -which themselves involve other non-portable behavior -(@pxref{The defsystem grammar,,Using logical pathnames}, below). -Pathnames made with @code{#.(make-pathname ...)} -can usually be done more easily with the string syntax above. -The only case that you really need a pathname object is to override -the component-type default file type for a given component. -Therefore, pathname objects should only rarely be used. -Unhappily, ASDF 1 used not to properly support -parsing component names as strings specifying paths with directories, -and the cumbersome @code{#.(make-pathname ...)} syntax had to be used. -An alternative to @code{#.} read-time evaluation is to use -@code{(eval `(defsystem ... ,pathname ...))}. - -Note that when specifying pathname objects, -ASDF does not do any special interpretation of the pathname -influenced by the component type, unlike the procedure for -pathname-specifying strings. -On the one hand, you have to be careful to provide a pathname that correctly -fulfills whatever constraints are required from that component type -(e.g. naming a directory or a file with appropriate type); -on the other hand, you can circumvent the file type that would otherwise -be forced upon you if you were specifying a string. - -@subsection Version specifiers -@cindex version specifiers -@cindex :version - -Version specifiers are strings to be parsed as period-separated lists of integers. -I.e., in the example, @code{"0.2.1"} is to be interpreted, -roughly speaking, as @code{(0 2 1)}. -In particular, version @code{"0.2.1"} is interpreted the same as @code{"0.0002.1"}, -though the latter is not canonical and may lead to a warning being issued. -Also, @code{"1.3"} and @code{"1.4"} are both strictly @code{uiop:version<} to @code{"1.30"}, -quite unlike what would have happened -had the version strings been interpreted as decimal fractions. - -Instead of a string representing the version, -the @code{:version} argument can be an expression that is resolved to -such a string using the following trivial domain-specific language: -in addition to being a literal string, it can be an expression of the form -@code{(:read-file-form :at )}, -which will be resolved by reading a form in the specified pathname -(read as a subpathname of the current system if relative or a unix-namestring). -You may use a @code{uiop:access-at} specifier -with the (optional) @code{:at} keyword, -by default the specifier is @code{0}, meaning the first form is returned; -subforms can also be specified, with e.g. @code{(1 2 2)} specifying -``the third subform (index 2) of the third subform (index 2) of the second form (index 1)'' -in the file (mind the off-by-one error in the English language). - -System definers are encouraged to use version identifiers of the form -@var{x}.@var{y}.@var{z} for -major version, minor version and patch level, -where significant API incompatibilities are signaled by an increased major number. - -@xref{Common attributes of components}. - -@subsection Require -@cindex :require dependencies - -Use the implementation's own @code{require} to load the @var{module-name}. - - -@subsection Using logical pathnames -@cindex logical pathnames - -We do not generally recommend the use of logical pathnames, -especially not so to newcomers to Common Lisp. -However, we do support the use of logical pathnames by old timers, -when such is their preference. - -To use logical pathnames, -you will have to provide a pathname object as a @code{:pathname} specifier -to components that use it, using such syntax as -@code{#p"LOGICAL-HOST:absolute;path;to;component.lisp"}. - -You only have to specify such logical pathname -for your system or some top-level component. -Sub-components' relative pathnames, -specified using the string syntax for names, -will be properly merged with the pathnames of their parents. -The specification of a logical pathname host however is @emph{not} -otherwise directly supported in the ASDF syntax -for pathname specifiers as strings. - -The @code{asdf-output-translation} layer will -avoid trying to resolve and translate logical pathnames. -The advantage of this is that -you can define yourself what translations you want to use -with the logical pathname facility. -The disadvantage is that if you do not define such translations, -any system that uses logical pathnames will behave differently under -asdf-output-translations than other systems you use. - -If you wish to use logical pathnames you will have to configure the -translations yourself before they may be used. -ASDF currently provides no specific support -for defining logical pathname translations. - -Note that the reasons we do not recommend logical pathnames are that -(1) there is no portable way to set up logical pathnames before they are used, -(2) logical pathnames are limited to only portably use -a single character case, digits and hyphens. -While you can solve the first issue on your own, -describing how to do it on each of fifteen implementations supported by ASDF -is more than we can document. -As for the second issue, mind that the limitation is notably enforced on SBCL, -and that you therefore can't portably violate the limitations -but must instead define some encoding of your own and add individual mappings -to name physical pathnames that do not fit the restrictions. -This can notably be a problem when your Lisp files are part of a larger project -in which it is common to name files or directories in a way that -includes the version numbers of supported protocols, -or in which files are shared with software written -in different programming languages where conventions include the use of -underscores, dots or CamelCase in pathnames. - - -@subsection Serial dependencies -@cindex serial dependencies - -If the @code{:serial t} option is specified for a module, -ASDF will add dependencies for each child component, -on all the children textually preceding it. -This is done as if by @code{:depends-on}. - -@lisp -:serial t -:components ((:file "a") (:file "b") (:file "c")) -@end lisp - -is equivalent to - -@lisp -:components ((:file "a") - (:file "b" :depends-on ("a")) - (:file "c" :depends-on ("a" "b"))) -@end lisp - - -@subsection Source location (@code{:pathname}) - -The @code{:pathname} option is optional in all cases for systems -defined via @code{defsystem}, and generally is unnecessary. In the -simple case, source files will be found in the same directory as the -system or, in the case of modules, in a subdirectory with the same name -as the module. - -@c FIXME: This should be moved elsewhere -- it's too much detail for the -@c grammar section. - -More specifically, ASDF follows a hairy set of rules that are designed so that -@enumerate -@item -@code{find-system} -will load a system from disk -and have its pathname default to the right place. - -@item -This pathname information will not be overwritten with -@code{*default-pathname-defaults*} -(which could be somewhere else altogether) -if the user loads up the @file{.asd} file into his editor -and interactively re-evaluates that form. -@end enumerate - -If a system is being loaded for the first time, -its top-level pathname will be set to: - -@itemize -@item -The host/device/directory parts of @code{*load-truename*}, -if it is bound. -@item -@code{*default-pathname-defaults*}, otherwise. -@end itemize - -If a system is being redefined, the top-level pathname will be - -@itemize -@item -changed, if explicitly supplied or obtained from @code{*load-truename*} -(so that an updated source location is reflected in the system definition) - -@item -changed if it had previously been set from @code{*default-pathname-defaults*} - -@item -left as before, if it had previously been set from @code{*load-truename*} -and @code{*load-truename*} is currently unbound -(so that a developer can evaluate a @code{defsystem} form -from within an editor without clobbering its source location) -@end itemize - -@subsection if-feature option -@cindex :if-feature component option -@anchor{if-feature-option} @c redo if this ever becomes a node in -@c its own right... - -This option allows you to specify a feature expression to be evaluated -as if by @code{#+} to conditionally include a component in your build. -If the expression is false, the component is dropped -as well as any dependency pointing to it. -As compared to using @code{#+} which is expanded at read-time, -this allows you to have an object in your component hierarchy -that can be used for manipulations beside building your project, and -that is accessible to outside code that wishes to reason about system -structure. - -Programmers should be careful to consider @strong{when} the -@code{:if-feature} is evaluated. Recall that ASDF first computes a -build plan, and then executes that plan. ASDF will check to see whether -or not a feature is present @strong{at planning time}, not during the -build. It follows that one cannot use @code{:if-feature} to check -features that are set during the course of the build. It can only be -used to check the state of features before any build operations have -been performed. - -This option was added in ASDF 3. For more information, -@xref{required-features, Required features}. - -@subsection if-component-dep-fails option -@cindex :if-component-dep-fails component option -This option was removed in ASDF 3. -Its semantics was limited in purpose and dubious to explain, -and its implementation was breaking a hole into the ASDF object model. -Please use the @code{if-feature} option instead. - -@subsection feature requirement -This requirement was removed in ASDF 3.1. Please do not use it. In -most cases, @code{:if-feature} (@pxref{if-feature-option}) will provide -an adequate substitute. - -The @code{feature} requirement used to ensure that a chain of component -dependencies would fail when a key feature was absent. -Used in conjunction with @code{:if-component-dep-fails} -this provided -a roundabout way to express conditional compilation. - - -@node Other code in .asd files, The package-inferred-system extension, The defsystem grammar, Defining systems with defsystem -@section Other code in .asd files - -Files containing @code{defsystem} forms -are regular Lisp files that are executed by @code{load}. -Consequently, you can put whatever Lisp code you like into these files. -However, it is recommended to keep such forms to a minimal, -and to instead define @code{defsystem} extensions -that you use with @code{:defsystem-depends-on}. - -If however, you might insist on including code in the @file{.asd} file itself, -e.g., to examine and adjust the compile-time environment, -possibly adding appropriate features to @code{*features*}. -If so, here are some conventions we recommend you follow, -so that users can control certain details of execution -of the Lisp in @file{.asd} files: - -@itemize -@item -Any informative output -(other than warnings and errors, -which are the condition system's to dispose of) -should be sent to the standard CL stream @code{*standard-output*}, -so that users can easily control the disposition -of output from ASDF operations. -@end itemize - - -@node The package-inferred-system extension, , Other code in .asd files, Defining systems with defsystem -@section The package-inferred-system extension - -Starting with release 3.1.2, -ASDF supports a one-package-per-file style of programming, -whereby each file is its own system, -and dependencies are deduced from the @code{defpackage} form -(or its variant @code{uiop:define-package}). - - -In this style, packages refer to a system with the same name (downcased); -and if a system is defined with @code{:class package-inferred-system}, -then system names that start with that name -(using the slash @code{/} separator) -refer to files under the filesystem hierarchy where the system is defined. -For instance, if system @code{my-lib} is defined in -@file{/foo/bar/my-lib/my-lib.asd}, then system @code{my-lib/src/utility} -will be found in file @file{/foo/bar/my-lib/src/utility.lisp}. - -This style was made popular by @code{faslpath} and @code{quick-build} before, -and at the cost of a stricter package discipline, -seems to make for more maintainable code. -It is used by ASDF itself (starting with ASDF 3) and by @code{lisp-interface-library}. - -To use this style, choose a toplevel system name, e.g. @code{my-lib}, -and create a file @file{my-lib.asd} -with the @code{:class :package-inferred-system} option in its @code{defsystem}. -For instance: -@example -#-asdf3 (error "my-lib requires ASDF 3") -(defsystem my-lib - :class :package-inferred-system - :defsystem-depends-on (:asdf-package-system) - :depends-on (:my-lib/interface/all - :my-lib/src/all - :my-lib/extras/all) - :in-order-to ((test-op (load-op :my-lib/test/all))) - :perform (test-op (o c) (symbol-call :my-lib/test/all :test-suite))) - -(defsystem :my-lib/test :depends-on (:my-lib/test/all)) - -(register-system-packages :my-lib/interface/all '(:my-lib-interface)) -(register-system-packages :my-lib/src/all '(:my-lib-implementation)) -(register-system-packages :my-lib/test/all '(:my-lib-test)) - -(register-system-packages - :closer-mop - '(:c2mop :closer-common-lisp :c2cl :closer-common-lisp-user :c2cl-user)) -@end example - -In the code above, the -@code{:defsystem-depends-on (:asdf-package-system)} is -for compatibility with older versions of ASDF 3 (ASDF 2 is not supported), -and requires the @code{asdf-package-system} library to be present -(it is implicitly provided by ASDF starting with release 3.1.2, -which can be detected with the feature @code{:asdf3.1}). - -The function @code{register-system-packages} has to be called to register -packages used or provided by your system and its components -where the name of the system that provides the package -is not the downcase of the package name. - -Then, file @file{interface/order.lisp} under the @code{lil} hierarchy, -that defines abstract interfaces for order comparisons, -starts with the following form, -dependencies being trivially computed from the @code{:use} and @code{:mix} clauses: - -@example -(uiop:define-package :lil/interface/order - (:use :closer-common-lisp - :lil/interface/definition - :lil/interface/base - :lil/interface/eq :lil/interface/group) - (:mix :fare-utils :uiop :alexandria) - (:export ...)) -@end example - -ASDF can tell that this file depends on system @code{closer-mop} (registered above), -@code{lil/interface/definition}, @code{lil/interface/base}, -@code{lil/interface/eq}, and @code{lil/interface/group} -(package and system names match, and they will be looked up hierarchically). - -ASDF also detects dependencies from @code{:import-from} clauses. -You may thus import a well-defined set of symbols from an existing package -as loaded from suitably named system; -or if you prefer to use any such symbol fully qualified by a package prefix, -you may declare a dependency on such a package and its corresponding system -via an @code{:import-from} clause with an empty list of symbols, as in: - -@example -(defpackage :foo/bar - (:use :cl) - (:import-from :foo/baz #:sym1 #:sym2) - (:import-from :foo/quux) - (:export ...)) -@end example - -The form @code{uiop:define-package} is supported as well as @code{defpackage}, -and has many options that prove useful in this context, -such as @code{:use-reexport} and @code{:mix-reexport} -that allow for ``inheritance'' of symbols being exported. - -@node The object model of ASDF, Controlling where ASDF searches for systems, Defining systems with defsystem, Top -@comment node-name, next, previous, up -@chapter The Object model of ASDF -@tindex component -@tindex operation - -ASDF is designed in an object-oriented way from the ground up. -Both a system's structure and the operations that can be performed on systems -follow a extensible protocol, allowing programmers to add new behaviors to ASDF. -For example, @code{cffi} adds support for special FFI description files -that interface with C libraries and for wrapper files that embed C code in Lisp. -@code{abcl-jar} supports creating Java JAR archives in ABCL. -@code{poiu} supports compiling code in parallel using background processes. - -The key classes in ASDF are @code{component} and @code{operation}. -A @code{component} represents an individual source file or a group of source files, -and the products (e.g., fasl files) produced from it. -An @code{operation} represents a transformation that can be performed on a component, -turning them from source files to intermediate results to final outputs. -Components are related by @emph{dependencies}, specified in system -definitions. - -When ordered to @code{operate} with some operation on a component (usually a system), -ASDF will first compute a @emph{plan} -by traversing the dependency graph using function @code{make-plan}.@footnote{ - Historically, the function that built a plan was - called @code{traverse}, and returned a list of actions; - it was deprecated in favor of @code{make-plan} (that returns a plan object) - when the @code{plan} objects were introduced; - the old function is kept for backward compatibility and debugging purposes only. -} -The resulting plan object contains an ordered list of @emph{actions}. -An action is a pair of an @code{operation} and a @code{component}, -representing a particular build step to be @code{perform}ed. -The ordering of the plan ensures that no action is performed before -all its dependencies have been fulfilled.@footnote{ - The term @emph{action} - was used by Kent Pitman in his article, ``The Description of Large Systems,'' - (@pxref{Bibliography}). - Although the term was only used by ASDF hackers starting with ASDF 2, - the concept was there since the very beginning of ASDF 1, - just not clearly articulated. -} - -In this chapter, we describe ASDF's object-oriented protocol, -the classes that make it up, and the generic functions on those classes. -These generic functions often take -both an operation and a component as arguments: -much of the power and configurability of ASDF is provided by -this use of CLOS's multiple dispatch. -We will describe the built-in component and operation classes, and -explain how to extend the ASDF protocol by defining new classes and -methods for ASDF's generic functions. -We will also describe the many @emph{hooks} that can be configured to -customize the behavior of existing @emph{functions}. - -@c FIXME: Swap operations and components. -@c FIXME: Possibly add a description of the PLAN object. -@c Not critical, since the user isn't expected to interact with it. -@menu -* Operations:: -* Components:: -* Dependencies:: -* Functions:: -@end menu - -@node Operations, Components, The object model of ASDF, The object model of ASDF -@comment node-name, next, previous, up -@section Operations -@cindex operation - -An @dfn{operation} object of the appropriate type is instantiated -whenever the user wants to do something with a system like - -@itemize -@item compile all its files -@item load the files into a running lisp environment -@item copy its source files somewhere else -@end itemize - -Operations can be invoked directly, or examined -to see what their effects would be without performing them. -There are a bunch of methods specialised on operation and component type -that actually do the grunt work. -Operations are invoked on systems via @code{operate} (@pxref{operate}). - -ASDF contains a number of pre-defined @t{operation} classes for common, -and even fairly uncommon tasks that you might want to do with it. -In addition, ASDF contains ``abstract'' @t{operation} classes that -programmers can use as building blocks to define ASDF extensions. We -discuss these in turn below. - -@c The operation object contains whatever state is relevant for this purpose -@c (perhaps a list of visited nodes, for example) -@c but primarily is a nice thing to specialise operation methods on -@c and easier than having them all be @code{EQL} methods. - -@menu -* Predefined operations of ASDF:: -* Creating new operations:: -@end menu - -Operations are invoked on systems via @code{operate}. -@anchor{operate} -@deffn {Generic function} @code{operate} @var{operation} @var{component} @Arest{} @var{initargs} @Akey{} @code{force} @code{force-not} @code{verbose} @AallowOtherKeys -@deffnx {Generic function} @code{oos} @var{operation} @var{component} @Arest{} @var{initargs} @Akey{} @AallowOtherKeys{} -@code{operate} invokes @var{operation} on @var{system}. -@code{oos} is a synonym for @code{operate} (it stands for operate-on-system). - -@var{operation} is a symbol that is passed, -along with the supplied @var{initargs}, -to @code{make-operation} (which will call @code{make-instance}) -to create the operation object. -@var{component} is a component designator, -usually a string or symbol that designates a system, -sometimes a list of strings or symbols that designate a subcomponent of a system. - -The @var{initargs} are passed to the @code{make-instance} call -when creating the operation object. -@c We probably want to deprecate that, because -@c (1) there is a mix of flags for operate, for the operation-class, for the plan-class, etc. -@c (2) flags to operations have never been well-supported, anyway. -@c The future solution probably involves having an explicit :operation-options keyword or some such -@c (if operation options are not wholly eliminated), a separate :plan-options, etc. -Note that dependencies may cause the operation -to invoke other operations on the system or its components: -the new operations will be created -with the same @var{initargs} as the original one. - -If @var{force} is @code{:all}, then all systems -are forced to be recompiled even if not modified since last compilation. -If @var{force} is @code{t}, then only the system being loaded -is forced to be recompiled even if not modified since last compilation, -but other systems are not affected. -If @var{force} is a list, then it specifies a list of systems that -are forced to be recompiled even if not modified since last compilation. -If @var{force-not} is @code{:all}, then all systems -are forced not to be recompiled even if modified since last compilation. -If @var{force-not} is @code{t}, then all systems but the system being loaded -are forced not to be recompiled even if modified since last compilation -(note: this was changed in ASDF 3.1.2). -If @var{force-not} is a list, then it specifies a list of systems that -are forced not to be recompiled even if modified since last compilation. - -Both @var{force} and @var{force-not} apply to systems that are dependencies and were already compiled. -@var{force-not} takes precedences over @var{force}, -as it should, really, but unhappily only since ASDF 3.1.2. -Moreover, systems the name of which is member of the set @var{*immutable-systems*} -(represented as an equal hash-table) are always considered @var{forced-not}, and -even their @file{.asd} is not refreshed from the filesystem. - -To see what @code{operate} would do, you can use: -@example -(asdf:traverse operation-class system-name) -@end example - -@end deffn - - - -@node Predefined operations of ASDF, Creating new operations, Operations, Operations -@comment node-name, next, previous, up -@subsection Predefined operations of ASDF -@c FIXME: All these deffn's should be replaced with deftyp. Also, we -@c should set up an appropriate index. - -All the operations described in this section are in the @code{asdf} package. -They are invoked via the @code{operate} generic function. - -@lisp -(asdf:operate 'asdf:@var{operation-name} :@var{system-name} @{@var{operation-options ...}@}) -@end lisp - -@deffn Operation @code{compile-op} - -This operation compiles the specified component. -A @code{cl-source-file} will be @code{compile-file}'d. -All the children and dependencies of a system or module -will be recursively compiled by @code{compile-op}. - -@code{compile-op} depends on @code{prepare-op} which -itself depends on a @code{load-op} of all of a component's dependencies, -as well as of its parent's dependencies. -When @code{operate} is called on @code{compile-op}, -all these dependencies will be loaded as well as compiled; -yet, some parts of the system main remain unloaded, -because nothing depends on them. -Use @code{load-op} to load a system. -@end deffn - -@deffn Operation @code{load-op} - -This operation loads the compiled code for a specified component. -A @code{cl-source-file} will have its compiled fasl @code{load}ed, -which fasl is the output of @code{compile-op} that @code{load-op} depends on. - -@code{load-op} will recursively load all the children of a system or module. - -@code{load-op} also depends on @code{prepare-op} which -itself depends on a @code{load-op} of all of a component's dependencies, -as well as of its parent's dependencies. -@end deffn - -@deffn Operation @code{prepare-op} - -This operation ensures that the dependencies of a component -and its recursive parents are loaded (as per @code{load-op}), -as a prerequisite before @code{compile-op} and @code{load-op} operations -may be performed on a given component. -@end deffn - -@deffn Operation @code{load-source-op}, @code{prepare-source-op} - -@code{load-source-op} will load the source for the files in a module -rather than the compiled fasl output. -It has a @code{prepare-source-op} analog to @code{prepare-op}, -that ensures the dependencies are themselves loaded via @code{load-source-op}. - -@end deffn - -@anchor{test-op} -@deffn Operation @code{test-op} - -This operation will perform some tests on the module. -The default method will do nothing. -The default dependency is to require -@code{load-op} to be performed on the module first. -Its @code{operation-done-p} method returns @code{nil}, -which means that the operation is @emph{never} done --- -we assume that if you invoke the @code{test-op}, -you want to test the system, even if you have already done so. - -The results of this operation are not defined by ASDF. -It has proven difficult to define how the test operation -should signal its results to the user -in a way that is compatible with all of the various test libraries -and test techniques in use in the community, and -given the fact that ASDF operations do not return a value indicating -success or failure. -For those willing to go to the effort, we suggest defining conditions to -signal when a @code{test-op} fails, and storing in those conditions -information that describes which tests fail. - -People typically define a separate test @emph{system} to hold the tests. -Doing this avoids unnecessarily adding a test framework as a dependency -on a library. For example, one might have -@lisp -(defsystem foo - :in-order-to ((test-op (test-op "foo/test"))) - ...) - -(defsystem foo/test - :depends-on (foo fiveam) ; fiveam is a test framework library - ...) -@end lisp - -Then one defines @code{perform} methods on -@code{test-op} such as the following: -@lisp -(defsystem foo/test - :depends-on (foo fiveam) ; fiveam is a test framework library - :perform (test-op (o s) - (uiop:symbol-call :fiveam '#:run! - (uiop:find-symbol* '#:foo-test-suite - :foo-tests))) - ...) -@end lisp - -@end deffn - - - -@deffn Operation @code{compile-bundle-op}, @code{monolithic-compile-bundle-op}, @code{load-bundle-op}, @code{monolithic-load-bundle-op}, @code{deliver-asd-op}, @code{monolithic-deliver-asd-op}, @code{lib-op}, @code{monolithic-lib-op}, @code{dll-op}, @code{monolithic-dll-op}, @code{image-op}, @code{program-op} - -These are ``bundle'' operations, that can create a single-file ``bundle'' -for all the contents of each system in an application, -or for the entire application. - -@code{compile-bundle-op} will create a single fasl file for each of the systems needed, -grouping all its many fasls in one, -so you can deliver each system as a single fasl -@code{monolithic-compile-bundle-op} will create a single fasl file for the target system -and all its dependencies, -so you can deliver your entire application as a single fasl. -@code{load-bundle-op} will load the output of @code{compile-bundle-op}. -Note that if it the output is not up-to-date, -@code{compile-bundle-op} may load the intermediate fasls as a side-effect. -Bundling fasls together matters a lot on ECL, -where the dynamic linking involved in loading tens of individual fasls -can be noticeably more expensive than loading a single one. - -NB: @code{compile-bundle-op}, @code{monolithic-compile-bundle-op}, @code{load-bundle-op}, @code{monolithic-load-bundle-op}, @code{deliver-asd-op}, @code{monolithic-deliver-asd-op} were respectively called -@code{fasl-op}, @code{monolithic-fasl-op}, @code{load-fasl-op}, @code{monolithic-load-fasl-op}, @code{binary-op}, @code{monolithic-binary-op} before ASDF 3.1. -The old names still exist for backward compatibility, -though they poorly label what is going on. - -Once you have created a fasl with @code{compile-bundle-op}, -you can use @code{precompiled-system} to deliver it in a way -that is compatible with clients having dependencies on your system, -whether it is distributed as source or as a single binary; -the @file{.asd} file to be delivered with the fasl will look like this: -@example -(defsystem :mysystem :class :precompiled-system - :fasl (some expression that will evaluate to a pathname)) -@end example -Or you can use @code{deliver-asd-op} to let ASDF create such a system for you -as well as the @code{compile-bundle-op} output, -or @code{monolithic-deliver-asd-op}. -This allows you to deliver code for your systems or applications -as a single file. -Of course, if you want to test the result in the current image, -@emph{before} you try to use any newly created @file{.asd} files, -you should not forget to @code{(asdf:clear-configuration)} -or at least @code{(asdf:clear-source-registry)}, -so it re-populates the source-registry from the filesystem. - -The @code{program-op} operation will create an executable program -from the specified system and its dependencies. -You can use UIOP for its pre-image-dump hooks, its post-image-restore hooks, -and its access to command-line arguments. -And you can specify an entry point @code{my-app:main} -by specifying in your @code{defsystem} -the option @code{:entry-point "my-app:main"}. -Depending on your implementation, -running @code{(asdf:operate 'asdf:program-op :my-app)} -may quit the current Lisp image upon completion. -See the example in -@file{test/hello-world-example.asd} and @file{test/hello.lisp}, -as built and tested by -@file{test/test-program.script} and @file{test/make-hello-world.lisp}. -@code{image-op} will dump an image that may not be standalone -and does not start its own function, -but follows the usual execution convention of the underlying Lisp, -just with more code pre-loaded, -for use as an intermediate build result or with a wrapper invocation script. - -There is also @code{lib-op} -for building a linkable @file{.a} file (Windows: @file{.lib}) -from all linkable object dependencies (FFI files, and on ECL, Lisp files too), -and its monolithic equivalent @code{monolithic-lib-op}. -And there is also @code{dll-op} -(respectively its monolithic equivalent @code{monolithic-lib-op}) -for building a linkable @file{.so} file -(Windows: @file{.dll}, MacOS X: @file{.dynlib}) -to create a single dynamic library -for all the extra FFI code to be linked into each of your systems -(respectively your entire application). - -All these ``bundle'' operations are available since ASDF 3 -on all actively supported Lisp implementations, -but may be unavailable on unmaintained legacy implementations. -This functionality was previously available for select implementations, -as part of a separate system @code{asdf-bundle}, -itself descended from the ECL-only @code{asdf-ecl}. - -The pathname of the output of bundle operations -is subject to output-translation as usual, -unless the operation is equal to -the @code{:build-operation} argument to @code{defsystem}. -This behavior is not very satisfactory and may change in the future. -Maybe you have suggestions on how to better configure it? -@end deffn - -@deffn Operation @code{concatenate-source-op}, @code{monolithic-concatenate-source-op}, @code{load-concatenated-source-op}, @code{compile-concatenated-source-op}, @code{load-compiled-concatenated-source-op}, @code{monolithic-load-concatenated-source-op}, @code{monolithic-compile-concatenated-source-op}, @code{monolithic-load-compiled-concatenated-source-op} - -These operations, as their respective names indicate, -will concatenate all the @code{cl-source-file} source files in a system -(or in a system and all its dependencies, if monolithic), -in the order defined by dependencies, -then load the result, or compile and then load the result. - -These operations are useful to deliver a system or application -as a single source file, -and for testing that said file loads properly, or compiles and then loads properly. - -ASDF itself is delivered as a single source file this way, -using @code{monolithic-concatenate-source-op}, -prepending a prelude and the @code{uiop} library -before the @code{asdf/defsystem} system itself. -@end deffn - - -@node Creating new operations, , Predefined operations of ASDF, Operations -@comment node-name, next, previous, up -@subsection Creating new operations - -ASDF was designed to be extensible in an object-oriented fashion. -To teach ASDF new tricks, a programmer can implement the behaviour he wants -by creating a subclass of @code{operation}. - -ASDF's pre-defined operations are in no way ``privileged'', -but it is requested that developers never use the @code{asdf} package -for operations they develop themselves. -The rationale for this rule is that we don't want to establish a -``global asdf operation name registry'', -but also want to avoid name clashes. - -Your operation @emph{must} usually provide methods -for one or more of the following generic functions: - -@itemize - -@findex perform -@item @code{perform} -Unless your operation, like @code{prepare-op}, -is for dependency propagation only, -the most important function for which to define a method -is usually @code{perform}, -which will be called to perform the operation on a specified component, -after all dependencies have been performed. - -The @code{perform} method must call @code{input-files} and @code{output-files} (see below) -to locate its inputs and outputs, -because the user is allowed to override the method -or tweak the output-translation mechanism. -Perform should only use the primary value returned by @code{output-files}. -If one and only one output file is expected, -it can call @code{output-file} that checks that this is the case -and returns the first and only list element. - -@findex output-files -@item @code{output-files} -If your perform method has any output, -you must define a method for this function. -for ASDF to determine where the outputs of performing operation lie. - -Your method may return two values, a list of pathnames, and a boolean. -If the boolean is @code{nil} (or you fail to return multiple values), -then enclosing @code{:around} methods may translate these pathnames, -e.g. to ensure object files are somehow stored -in some implementation-dependent cache. -If the boolean is @code{t} then the pathnames are marked -not be translated by the enclosing @code{:around} method. - -@findex component-depends-on -@item @code{component-depends-on} -If the action of performing the operation on a component has dependencies, -you must define a method on @code{component-depends-on}. - -Your method will take as specialized arguments -an operation and a component which together identify an action, -and return a list of entries describing actions that this action depends on. -The format of entries is described below. - -It is @emph{strongly} advised that -you should always append the results of @code{(call-next-method)} -to the results of your method, -or ``interesting'' failures will likely occur, -unless you're a true specialist of ASDF internals. -It is unhappily too late to compatibly use the @code{append} method combination, -but conceptually that's the protocol that is being manually implemented. - -Each entry returned by @code{component-depends-on} is itself a list. - -The first element of an entry is an operation designator: -either an operation object designating itself, or -a symbol that names an operation class -(that ASDF will instantiate using @code{make-operation}). -For instance, @code{load-op}, @code{compile-op} and @code{prepare-op} -are common such names, denoting the respective operations. - -@c FIXME COERCE-NAME is referenced, but not defined. -@findex coerce-name -@findex find-component -The rest of each entry is a list of component designators: -either a component object designating itself, -or an identifier to be used with @code{find-component}. -@code{find-component} will be called with the current component's parent as parent, -and the identifier as second argument. -The identifier is typically a string, -a symbol (to be downcased as per @code{coerce-name}), -or a list of strings or symbols. -In particular, the empty list @code{nil} denotes the parent itself. - -@end itemize - -An operation @emph{may} provide methods for the following generic functions: - -@itemize - -@item @code{input-files} -@findex input-files -A method for this function is often not needed, -since ASDF has a pretty clever default @code{input-files} mechanism. -You only need create a method if there are multiple ultimate input files, -and/or the bottom one doesn't depend -on the @code{component-pathname} of the component. - -@item @code{operation-done-p} -@findex operation-done-p -You only need to define a method on that function -if you can detect conditions that invalidate previous runs of the operation, -even though no filesystem timestamp has changed, -in which case you return @code{nil} (the default is @code{t}). - -For instance, the method for @code{test-op} always returns @code{nil}, -so that tests are always run afresh. -Of course, the @code{test-op} for your system could depend -on a deterministically repeatable @code{test-report-op}, -and just read the results from the report files, -in which case you could have this method return @code{t}. - -@end itemize - -Operations that print output should send that output to the standard -CL stream @code{*standard-output*}, as the Lisp compiler and loader do. - -@node Components, Dependencies, Operations, The object model of ASDF -@comment node-name, next, previous, up -@section Components -@cindex component -@cindex system -@cindex system designator -@cindex component designator -@vindex *system-definition-search-functions* - -A @code{component} represents an individual source file or a group of source files, -and the things that get transformed into. -A @code{system} is a component at the top level of the component hierarchy, -that can be found via @code{find-system}. -A @code{source-file} is a component representing a single source-file -and the successive output files into which it is transformed. -A @code{module} is an intermediate component itself grouping several other components, -themselves source-files or further modules. - -A @dfn{system designator} is a system itself, -or a string or symbol that behaves just like any other component name -(including with regard to the case conversion rules for component names). - -A @dfn{component designator}, relative to a base component, -is either a component itself, -or a string or symbol, -or a list of designators. - -@defun find-system system-designator @Aoptional{} (error-p t) - -Given a system designator, @code{find-system} finds and returns a system. -If no system is found, an error of type -@code{missing-component} is thrown, -or @code{nil} is returned if @code{error-p} is false. - -To find and update systems, @code{find-system} funcalls each element -in the @code{*system-definition-search-functions*} list, -expecting a pathname to be returned, or a system object, -from which a pathname may be extracted, and that will be registered. -The resulting pathname (if any) is loaded -if one of the following conditions is true: - -@itemize -@item -there is no system of that name in memory -@item -the pathname is different from that which was previously loaded -@item -the file's @code{last-modified} time exceeds the @code{last-modified} time -of the system in memory -@end itemize - -@cindex ASDF-USER package -When system definitions are loaded from @file{.asd} files, -they are implicitly loaded into the @code{ASDF-USER} package, -which uses @code{ASDF}, @code{UIOP} and @code{UIOP/COMMON-LISP}@footnote{ -Note that between releases 2.27 and 3.0.3, only @code{UIOP/PACKAGE}, -not all of @code{UIOP}, was used; if you want your code to work -with releases earlier than 3.1.2, you may have to explicitly define a package -that uses @code{UIOP}, or use proper package prefix to your symbols, as in -@code{uiop:version<}.} -Programmers who do anything non-trivial in a @file{.asd} file, -such as defining new variables, functions or classes, -should include @code{defpackage} and @code{in-package} forms in this file, -so they will not overwrite each others' extensions. -Such forms might also help the files behave identically -if loaded manually with @code{cl:load} for development or debugging, -though we recommend you use the function @code{asdf::load-asd} instead, -which the @code{slime-asdf} contrib knows about. - -The default value of @code{*system-definition-search-functions*} -is a list of three functions. -The first function looks in each of the directories given -by evaluating members of @code{*central-registry*} -for a file whose name is the name of the system and whose type is @file{asd}; -the first such file is returned, -whether or not it turns out to actually define the appropriate system. -The second function does something similar, -for the directories specified in the @code{source-registry}, -but searches the filesystem only once and caches its results. -The third function makes the @code{package-inferred-system} extension work, -@pxref{The package-inferred-system extension}. - -Because of the way these search functions are defined, -you should put the definition for a system -@var{foo} in a file named @file{foo.asd}, -in a directory that is -in the central registry or -which can be found using the -source registry configuration. - -@c FIXME: Move this discussion to the system definition grammar, or somewhere else. -@anchor{System names} -@cindex System names -@cindex Primary system name -@findex primary-system-name -It is often useful to define multiple systems in a same file, -but ASDF can only locate a system's definition file based on the system -name. -For this reason, -ASDF 3's system search algorithm has been extended to -allow a file @file{foo.asd} to contain -secondary systems named @var{foo/bar}, @var{foo/baz}, @var{foo/quux}, etc., -in addition to the primary system named @var{foo}. -The first component of a system name, -separated by the slash character, @code{/}, -is called the primary name of a system. -The primary name may be -extracted by function @code{asdf::primary-system-name}; -when ASDF 3 is told to find a system whose name has a slash, -it will first attempt to load the corresponding primary system, -and will thus see any such definitions, and/or any -definition of a @code{package-inferred-system}.@footnote{ -ASDF 2.26 and earlier versions -do not support this primary system name convention. -With these versions of ASDF -you must explicitly load @file{foo.asd} -before you can use system @var{foo/bar} defined therein, -e.g. using @code{(asdf:find-system "foo")}. -We do not support ASDF 2, and recommend that you should upgrade to ASDF 3. -} -If your file @file{foo.asd} also defines systems -that do not follow this convention, e.g., a system named @var{foo-test}, -ASDF will not be able to automatically locate a definition for these systems, -and will only see their definition -if you explicitly find or load the primary system -using e.g. @code{(asdf:find-system "foo")} before you try to use them. -We strongly recommend against this practice, -though it is currently supported for backward compatibility. - -@end defun - -@defun primary-system-name name - -Internal (not exported) function, @code{asdf::primary-system-name}. -Returns the primary system name (the portion before -the slash, @code{/}, in a secondary system name) from @var{name}. - -@end defun - -@defun locate-system name - -This function should typically @emph{not} be invoked directly. It is -exported as part of the API only for programmers who wish to provide -their own @code{*system-definition-search-functions*}. - -Given a system @var{name} designator, -try to locate where to load the system definition from. -@c (This does not include the loading of the system definition, -@c which is done by @code{find-system}, -@c or the loading of the system itself, which is done by @code{load-system}; -@c however, for systems the definition of which has already been loaded, -@c @code{locate-system} may return an object of class @code{system}.) -Returns five values: @var{foundp}, @var{found-system}, @var{pathname}, -@var{previous}, and @var{previous-time}. -@var{foundp} is true when a system was found, -either a new as yet unregistered one, or a previously registered one. -The @var{found-system} return value -will be a @code{system} object, if a system definition is found in your -source registry. -@c This system may be registered (by @code{register-system}) or may not, if -@c it's preloaded code. Fare writes: -@c In the case of preloaded code, as for "asdf", "uiop", etc., -@c themselves, the system objects are not registered until after they are -@c initially located by sysdef-preloaded-system-search as a fallback when -@c no source code was found. -The system definition will @emph{not} be -loaded if it hasn't been loaded already. -@var{pathname} when not null is a path from which to load the system, -either associated with @var{found-system}, or with the @var{previous} system. -If @var{previous} is not null, it will be a @emph{previously loaded} -@code{system} object of the same name (note that the system -@emph{definition} is previously-loaded: the system itself may or may not be). -@var{previous-time} when not null is -the timestamp of the previous system definition file, at the -time when the @var{previous} system definition was loaded. - -For example, if your current registry has @file{foo.asd} in -@file{/current/path/to/foo.asd}, -but system @code{foo} was previously loaded from @file{/previous/path/to/foo.asd} -then @var{locate-system} will return the following values: -@enumerate -@item -@var{foundp} will be @code{T}, -@item -@var{found-system} will be @code{NIL}, -@item -@var{pathname} will be @code{#p"/current/path/to/foo.asd"}, -@item -@var{previous} will be an object of type @code{SYSTEM} with -@code{system-source-file} slot value of -@code{#p"/previous/path/to/foo.asd"} -@item -@var{previous-time} will be the timestamp of -@code{#p"/previous/path/to/foo.asd"} at the time it was loaded. -@end enumerate -@end defun - -@defun find-component base path - -Given a @var{base} component (or designator for such), -and a @var{path}, find the component designated by the @var{path} -starting from the @var{base}. - -If @var{path} is a component object, it designates itself, -independently from the base. - -@findex coerce-name -If @var{path} is a string, or symbol denoting a string via @code{coerce-name}, -then @var{base} is resolved to a component object, -which must be a system or module, -and the designated component is the child named by the @var{path}. - -If @var{path} is a @code{cons} cell, -@code{find-component} with the base and the @code{car} of the @var{path}, -and the resulting object is used as the base for a tail call -to @code{find-component} with the @code{car} of the @var{path}. - -If @var{base} is a component object, it designates itself. - -If @var{base} is null, then @var{path} is used as the base, with @code{nil} as the path. - -If @var{base} is a string, or symbol denoting a string via @code{coerce-name}, -it designates a system as per @code{find-system}. - -If @var{base} is a @code{cons} cell, it designates the component found by -@code{find-component} with its @code{car} as base and @code{cdr} as path. -@end defun - - -@menu -* Common attributes of components:: -* Pre-defined subclasses of component:: -* Creating new component types:: -@end menu - -@node Common attributes of components, Pre-defined subclasses of component, Components, Components -@comment node-name, next, previous, up -@subsection Common attributes of components - -All components, regardless of type, have the following attributes. -All attributes except @code{name} are optional. - -@subsubsection Name -@findex coerce-name -A component name is a string or a symbol. -If a symbol, its name is taken and lowercased. This translation is -performed by the exported function @code{coerce-name}. - -Unless overridden by a @code{:pathname} attribute, -the name will be interpreted as a pathname specifier according -to a Unix-style syntax. -@xref{The defsystem grammar,,Pathname specifiers}. - -@subsubsection Version identifier -@findex version-satisfies -@cindex :version - -This optional attribute specifies a version for the current component. -The version should typically be a string of integers separated by dots, -for example @samp{1.0.11}. -For more information on version specifiers, see @ref{The defsystem grammar}. - -A version may then be queried by the generic function @code{version-satisfies}, -to see if @code{:version} dependencies are satisfied, -and when specifying dependencies, a constraint of minimal version to satisfy -can be specified using e.g. @code{(:version "mydepname" "1.0.11")}. - -Note that in the wild, we typically see version numbering -only on components of type @code{system}. -Presumably it is much less useful within a given system, -wherein the library author is responsible to keep the various files in synch. - -@subsubsection Required features -@anchor{required-features} - -Traditionally defsystem users have used @code{#+} reader conditionals -to include or exclude specific per-implementation files. -For example, CFFI, the portable C foreign function interface contained -lines like: -@lisp - #+sbcl (:file "cffi-sbcl") -@end lisp -An unfortunate side effect of this approach is that no single -implementation can read the entire system. -This causes problems if, for example, one wished to design an @code{archive-op} -that would create an archive file containing all the sources, since -for example the file @code{cffi-sbcl.lisp} above would be invisible when -running the @code{archive-op} on any implementation other than SBCL. - -Starting with ASDF 3, -components may therefore have an @code{:if-feature} option. -The value of this option should be -a feature expression using the same syntax as @code{#+} does. -If that feature expression evaluates to false, any reference to the component will be ignored -during compilation, loading and/or linking. -Since the expression is read by the normal reader, -you must explicitly prefix your symbols with @code{:} so they be read as keywords; -this is as contrasted with the @code{#+} syntax -that implicitly reads symbols in the keyword package by default. - -For instance, @code{:if-feature (:and :x86 (:or :sbcl :cmu :scl))} specifies that -the given component is only to be compiled and loaded -when the implementation is SBCL, CMUCL or Scieneer CL on an x86 machine. -You cannot write it as @code{:if-feature (and x86 (or sbcl cmu scl))} -since the symbols would not be read as keywords. - -@xref{if-feature-option}. - -@subsubsection Dependencies - -This attribute specifies dependencies of the component on its siblings. -It is optional but often necessary. - -There is an excitingly complicated relationship between the initarg -and the method that you use to ask about dependencies - -Dependencies are between (operation component) pairs. -In your initargs for the component, you can say - -@lisp -:in-order-to ((compile-op (load-op "a" "b") (compile-op "c")) - (load-op (load-op "foo"))) -@end lisp - -This means the following things: -@itemize -@item -before performing compile-op on this component, we must perform -load-op on @var{a} and @var{b}, and compile-op on @var{c}, -@item -before performing @code{load-op}, we have to load @var{foo} -@end itemize - -The syntax is approximately - -@verbatim -(this-op @{(other-op required-components)@}+) - -simple-component-name := string - | symbol - -required-components := simple-component-name - | (required-components required-components) - -component-name := simple-component-name - | (:version simple-component-name minimum-version-object) -@end verbatim - -Side note: - -This is on a par with what ACL defsystem does. -mk-defsystem is less general: it has an implied dependency - -@verbatim - for all source file x, (load x) depends on (compile x) -@end verbatim - -and using a @code{:depends-on} argument to say that @var{b} depends on -@var{a} @emph{actually} means that - -@verbatim - (compile b) depends on (load a) -@end verbatim - -This is insufficient for e.g. the McCLIM system, which requires that -all the files are loaded before any of them can be compiled ] - -End side note - -In ASDF, the dependency information for a given component and operation -can be queried using @code{(component-depends-on operation component)}, -which returns a list - -@lisp -((load-op "a") (load-op "b") (compile-op "c") ...) -@end lisp - -@code{component-depends-on} can be subclassed for more specific -component/operation types: these need to @code{(call-next-method)} -and append the answer to their dependency, unless -they have a good reason for completely overriding the default dependencies. - -If it weren't for CLISP, we'd be using @code{LIST} method -combination to do this transparently. -But, we need to support CLISP. -If you have the time for some CLISP hacking, -I'm sure they'd welcome your fixes. -@c Doesn't CLISP now support LIST method combination? - -A minimal version can be specified for a component you depend on -(typically another system), by specifying @code{(:version "other-system" "1.2.3")} -instead of simply @code{"other-system"} as the dependency. -See the discussion of the semantics of @code{:version} -in the defsystem grammar. - -@c FIXME: Should have cross-reference to "Version specifiers" in the -@c defsystem grammar, but the cross-referencing is so broken by -@c insufficient node breakdown that I have not put one in. - - -@subsubsection pathname - -This attribute is optional and if absent (which is the usual case), -the component name will be used. - -@xref{The defsystem grammar,,Pathname specifiers}, -for an explanation of how this attribute is interpreted. - -Note that the @code{defsystem} macro (used to create a ``top-level'' system) -does additional processing to set the filesystem location of -the top component in that system. -This is detailed elsewhere. @xref{Defining systems with defsystem}. - - -@subsubsection properties - -This attribute is optional. - -Packaging systems often require information about files or systems -in addition to that specified by ASDF's pre-defined component attributes. -Programs that create vendor packages out of ASDF systems therefore -have to create ``placeholder'' information to satisfy these systems. -Sometimes the creator of an ASDF system may know the additional -information and wish to provide it directly. - -@code{(component-property component property-name)} and -associated @code{setf} method will allow -the programmatic update of this information. -Property names are compared as if by @code{EQL}, -so use symbols or keywords or something. - -@menu -* Pre-defined subclasses of component:: -* Creating new component types:: -@end menu - -@node Pre-defined subclasses of component, Creating new component types, Common attributes of components, Components -@comment node-name, next, previous, up -@subsection Pre-defined subclasses of component - -@deffn Component source-file - -A source file is any file that the system does not know how to -generate from other components of the system. - -Note that this is not necessarily the same thing as -``a file containing data that is typically fed to a compiler''. -If a file is generated by some pre-processor stage -(e.g. a @file{.h} file from @file{.h.in} by autoconf) -then it is not, by this definition, a source file. -Conversely, we might have a graphic file -that cannot be automatically regenerated, -or a proprietary shared library that we received as a binary: -these do count as source files for our purposes. - -Subclasses of source-file exist for various languages. -@emph{FIXME: describe these.} -@end deffn - -@deffn Component module - -A module is a collection of sub-components. - -A module component has the following extra initargs: - -@itemize -@item -@code{:components} the components contained in this module - -@item -@code{:default-component-class} -All children components which don't specify their class explicitly -are inferred to be of this type. - -@item -@code{:if-component-dep-fails} -This attribute was removed in ASDF 3. Do not use it. -Use @code{:if-feature} instead (@pxref{required-features}, and @pxref{if-feature-option}). - -@item -@code{:serial} When this attribute is set, -each subcomponent of this component is assumed to depend on all subcomponents -before it in the list given to @code{:components}, i.e. -all of them are loaded before a compile or load operation is performed on it. - -@end itemize - -The default operation knows how to traverse a module, so -most operations will not need to provide methods specialised on modules. - -@code{module} may be subclassed to represent components such as -foreign-language linked libraries or archive files. -@end deffn - -@deffn Component system - -@code{system} is a subclass of @code{module}. - -A system is a module with a few extra attributes for documentation -purposes; these are given elsewhere. -@xref{The defsystem grammar}. - -Users can create new classes for their systems: -the default @code{defsystem} macro takes a @code{:class} keyword argument. -@end deffn - -@node Creating new component types, , Pre-defined subclasses of component, Components -@comment node-name, next, previous, up -@subsection Creating new component types - -New component types are defined by subclassing one of the existing -component classes and specializing methods on the new component class. - -@c FIXME: this should perhaps be explained more throughly, -@c not only by example ... - -As an example, suppose we have some implementation-dependent -functionality that we want to isolate -in one subdirectory per Lisp implementation our system supports. -We create a subclass of -@code{cl-source-file}: - -@lisp -(defclass unportable-cl-source-file (cl-source-file) - ()) -@end lisp - -Function @code{asdf:implementation-type} (exported since 2.014.14) -gives us the name of the subdirectory. -All that's left is to define how to calculate the pathname -of an @code{unportable-cl-source-file}. - -@lisp -(defmethod component-pathname ((component unportable-cl-source-file)) - (merge-pathnames* - (parse-unix-namestring (format nil "~(~A~)/" (asdf:implementation-type))) - (call-next-method))) -@end lisp - -The new component type is used in a @code{defsystem} form in this way: - -@lisp -(defsystem :foo - :components - ((:file "packages") - ... - (:unportable-cl-source-file "threads" - :depends-on ("packages" ...)) - ... - ) -@end lisp - -@node Dependencies, Functions, Components, The object model of ASDF -@section Dependencies -@c FIXME: Moved this material here, but it isn't very comfortable -@c here.... Also needs to be revised to be coherent. - -To be successfully build-able, this graph of actions must be acyclic. -If, as a user, extender or implementer of ASDF, you introduce -a cycle into the dependency graph, -ASDF will fail loudly. -To clearly distinguish the direction of dependencies, -ASDF 3 uses the words @emph{requiring} and @emph{required} -as applied to an action depending on the other: -the requiring action @code{depends-on} the completion of all required actions -before it may itself be @code{perform}ed. - -Using the @code{defsystem} syntax, users may easily express -direct dependencies along the graph of the object hierarchy: -between a component and its parent, its children, and its siblings. -By defining custom CLOS methods, you can express more elaborate dependencies as you wish. -Most common operations, such as @code{load-op}, @code{compile-op} or @code{load-source-op} -are automatically propagate ``downward'' the component hierarchy and are ``covariant'' with it: -to act the operation on the parent module, you must first act it on all the children components, -with the action on the parent being parent of the action on each child. -Other operations, such as @code{prepare-op} and @code{prepare-source-op} -(introduced in ASDF 3) are automatically propagated ``upward'' the component hierarchy -and are ``contravariant'' with it: -to perform the operation of preparing for compilation of a child component, -you must perform the operation of preparing for compilation of its parent component, and so on, -ensuring that all the parent's dependencies are (compiled and) loaded -before the child component may be compiled and loaded. -Yet other operations, such as @code{test-op} or @code{load-bundle-op} -remain at the system level, and are not propagated along the hierarchy, -but instead do something global on the system. - - -@node Functions, , Dependencies, The object model of ASDF -@comment node-name, next, previous, up -@section Functions - -@c FIXME: this does not belong here.... -@defun version-satisfies @var{version} @var{version-spec} -Does @var{version} satisfy the @var{version-spec}. A generic function. -ASDF provides built-in methods for @var{version} being a @code{component} or @code{string}. -@var{version-spec} should be a string. -If it's a component, its version is extracted as a string before further processing. - -A version string satisfies the version-spec if after parsing, -the former is no older than the latter. -Therefore @code{"1.9.1"}, @code{"1.9.2"} and @code{"1.10"} all satisfy @code{"1.9.1"}, -but @code{"1.8.4"} or @code{"1.9"} do not. -For more information about how @code{version-satisfies} parses and interprets -version strings and specifications, -@pxref{The defsystem grammar} (version specifiers) and -@ref{Common attributes of components}. - -Note that in versions of ASDF prior to 3.0.1, -including the entire ASDF 1 and ASDF 2 series, -@code{version-satisfies} would also require that the version and the version-spec -have the same major version number (the first integer in the list); -if the major version differed, the version would be considered as not matching the spec. -But that feature was not documented, therefore presumably not relied upon, -whereas it was a nuisance to several users. -Starting with ASDF 3.0.1, -@code{version-satisfies} does not treat the major version number specially, -and returns T simply if the first argument designates a version that isn't older -than the one specified as a second argument. -If needs be, the @code{(:version ...)} syntax for specifying dependencies -could be in the future extended to specify an exclusive upper bound for compatible versions -as well as an inclusive lower bound. -@end defun - -@node Controlling where ASDF searches for systems, Controlling where ASDF saves compiled files, The object model of ASDF, Top -@comment node-name, next, previous, up -@chapter Controlling where ASDF searches for systems - - - -@menu -* Configurations:: -* Truenames and other dangers:: -* XDG base directory:: -* Backward Compatibility:: -* Configuration DSL:: -* Configuration Directories:: -* Shell-friendly syntax for configuration:: -* Search Algorithm:: -* Caching Results:: -* Configuration API:: -* Introspection:: -* Status:: -* Rejected ideas:: -* TODO:: -* Credits for the source-registry:: -@end menu - -@node Configurations, Truenames and other dangers, Controlling where ASDF searches for systems, Controlling where ASDF searches for systems -@section Configurations - -Configurations specify paths where to find system files. - -@enumerate - -@item -The search registry may use some hardcoded wrapping registry specification. -This allows some implementations (notably SBCL) to specify where to find -some special implementation-provided systems that -need to precisely match the version of the implementation itself. - -@item -An application may explicitly initialize the source-registry configuration -using the configuration API -(@pxref{Controlling where ASDF searches for systems,Configuration API,Configuration API}, below) -in which case this takes precedence. -It may itself compute this configuration from the command-line, -from a script, from its own configuration file, etc. - -@item -The source registry will be configured from -the environment variable @code{CL_SOURCE_REGISTRY} if it exists. - -@item -The source registry will be configured from -user configuration file -@file{$XDG_CONFIG_DIRS/common-lisp/source-registry.conf} -(which defaults to -@file{~/.config/common-lisp/source-registry.conf}) -if it exists. - -@item -The source registry will be configured from -user configuration directory -@file{$XDG_CONFIG_DIRS/common-lisp/source-registry.conf.d/} -(which defaults to -@file{~/.config/common-lisp/source-registry.conf.d/}) -if it exists. - -@item -The source registry will be configured from -default user configuration trees -@file{~/common-lisp/} (since ASDF 3.1.2 only), -@file{~/.sbcl/systems/} (on SBCL only), -@file{$XDG_DATA_HOME/common-lisp/systems/} (no recursion, link farm) -@file{$XDG_DATA_HOME/common-lisp/source/}. -The @code{XDG_DATA_HOME} directory defaults to @file{~/.local/share/}. -On Windows, the @code{local-appdata} and @code{appdata} directories are used instead. - -@item -The source registry will be configured from -system configuration file -@file{/etc/common-lisp/source-registry.conf} -if it exists. - -@item -The source registry will be configured from -system configuration directory -@file{/etc/common-lisp/source-registry.conf.d/} -if it exists. - -@item -The source registry will be configured from a default configuration. -This configuration may allow for implementation-specific systems -to be found, for systems to be found the current directory -(at the time that the configuration is initialized) as well as -@code{:directory} entries for @file{$XDG_DATA_DIRS/common-lisp/systems/} and -@code{:tree} entries for @file{$XDG_DATA_DIRS/common-lisp/source/}, -where @code{XDG_DATA_DIRS} defaults to @file{/usr/local/share} and @file{/usr/share} on Unix, -and the @code{common-appdata} directory on Windows. - -@item -The source registry may include implementation-dependent directories -that correspond to implementation-provided extensions. - -@end enumerate - -Each of these configurations is specified as an s-expression -in a trivial domain-specific language (defined below). -Additionally, a more shell-friendly syntax is available -for the environment variable (defined yet below). - -Each of these configurations is only used if the previous -configuration explicitly or implicitly specifies that it -includes its inherited configuration. - -Additionally, some implementation-specific directories -may be automatically prepended to whatever directories are specified -in configuration files, no matter if the last one inherits or not. - -@node Truenames and other dangers, XDG base directory, Configurations, Controlling where ASDF searches for systems -@section Truenames and other dangers - -One great innovation of the original ASDF was its ability to leverage -@code{CL:TRUENAME} to locate where your source code was and where to build it, -allowing for symlink farms as a simple but effective configuration mechanism -that is easy to control programmatically. -ASDF 3 still supports this configuration style, and it is enabled by default; -however we recommend you instead use -our source-registry configuration mechanism described below, -because it is easier to setup in a portable way across users and implementations. - -Additionally, some people dislike truename, -either because it is very slow on their system, or -because they are using content-addressed storage where the truename of a file -is related to a digest of its individual contents, -and not to other files in the same intended project. -For these people, ASDF 3 allows to eschew the @code{TRUENAME} mechanism, -by setting the variable @var{asdf:*resolve-symlinks*} to @code{nil}. - -PS: Yes, if you haven't read Vernor Vinge's short but great classic -``True Names... and Other Dangers'' then you're in for a treat. - -@node XDG base directory, Backward Compatibility, Truenames and other dangers, Controlling where ASDF searches for systems -@section XDG base directory - -Note that we purport to respect the XDG base directory specification -as to where configuration files are located, -where data files are located, -where output file caches are located. -Mentions of XDG variables refer to that document. - -@url{http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html} - -This specification allows the user to specify some environment variables -to customize how applications behave to his preferences. - -On Windows platforms, when not using Cygwin, -instead of the XDG base directory specification, -we try to use folder configuration from the registry regarding -@code{Common AppData} and similar directories. -Since support for querying the Windows registry -is not possible to do in reasonable amounts of portable Common Lisp code, -ASDF 3 relies on the environment variables that Windows usually exports. - -@node Backward Compatibility, Configuration DSL, XDG base directory, Controlling where ASDF searches for systems -@section Backward Compatibility - -For backward compatibility as well as to provide a practical backdoor for hackers, -ASDF will first search for @file{.asd} files in the directories specified in -@code{asdf:*central-registry*} -before it searches in the source registry above. - -@xref{Configuring ASDF,,Configuring ASDF to find your systems --- old style}. - -By default, @code{asdf:*central-registry*} will be empty. - -This old mechanism will therefore not affect you if you don't use it, -but will take precedence over the new mechanism if you do use it. - -@node Configuration DSL, Configuration Directories, Backward Compatibility, Controlling where ASDF searches for systems -@section Configuration DSL -@cindex :inherit-configuration source config directive -@cindex inherit-configuration source config directive -@cindex :ignore-invalid-entries source config directive -@cindex ignore-invalid-entries source config directive -@cindex :directory source config directive -@cindex directory source config directive -@cindex :tree source config directive -@cindex tree source config directive -@cindex :exclude source config directive -@cindex exclude source config directive -@cindex :also-exclude source config directive -@cindex also-exclude source config directive -@cindex :include source config directive -@cindex include source config directive -@cindex :default-registry source config directive -@cindex default-registry source config directive - -Here is the grammar of the s-expression (SEXP) DSL for source-registry -configuration: - -@c FIXME: This is too wide for happy compilation into pdf. - -@example -;; A configuration is a single SEXP starting with the keyword -;; :source-registry followed by a list of directives. -CONFIGURATION := (:source-registry DIRECTIVE ...) - -;; A directive is one of the following: -DIRECTIVE := - ;; INHERITANCE DIRECTIVE: - ;; Your configuration expression MUST contain - ;; exactly one of the following: - :inherit-configuration | - ;; splices inherited configuration (often specified last) or - :ignore-inherited-configuration | - ;; drop inherited configuration (specified anywhere) - - ;; forward compatibility directive (since ASDF 2.011.4), useful when - ;; you want to use new configuration features but have to bootstrap - ;; the newer required ASDF from an older release that doesn't - ;; support said features: - :ignore-invalid-entries | - - ;; add a single directory to be scanned (no recursion) - (:directory DIRECTORY-PATHNAME-DESIGNATOR) | - - ;; add a directory hierarchy, recursing but - ;; excluding specified patterns - (:tree DIRECTORY-PATHNAME-DESIGNATOR) | - - ;; override the defaults for exclusion patterns - (:exclude EXCLUSION-PATTERN ...) | - ;; augment the defaults for exclusion patterns - (:also-exclude EXCLUSION-PATTERN ...) | - ;; Note that the scope of a an exclude pattern specification is - ;; the rest of the current configuration expression or file. - - ;; splice the parsed contents of another config file - (:include REGULAR-FILE-PATHNAME-DESIGNATOR) | - - ;; This directive specifies that some default must be spliced. - :default-registry - -REGULAR-FILE-PATHNAME-DESIGNATOR - := PATHNAME-DESIGNATOR ; interpreted as a file -DIRECTORY-PATHNAME-DESIGNATOR - := PATHNAME-DESIGNATOR ; interpreted as a directory - -PATHNAME-DESIGNATOR := - NIL | ;; Special: skip this entry. - ABSOLUTE-COMPONENT-DESIGNATOR ;; see pathname DSL - -EXCLUSION-PATTERN := a string without wildcards, that will be matched - exactly against the name of a any subdirectory in the directory - component of a path. e.g. @code{"_darcs"} will match - @file{#p"/foo/bar/_darcs/src/bar.asd"} -@end example - -Pathnames are designated using another DSL, -shared with the output-translations configuration DSL below. -The DSL is resolved by the function @code{asdf::resolve-location}, -to be documented and exported at some point in the future. - -@example -ABSOLUTE-COMPONENT-DESIGNATOR := - (ABSOLUTE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...) | - STRING | - ;; namestring (better be absolute or bust, directory assumed where - ;; applicable). In output-translations, directory is assumed and - ;; **/*.*.* added if it's last. On MCL, a MacOSX-style POSIX - ;; namestring (for MacOS9 style, use #p"..."); Note that none of the - ;; above applies to strings used in *central-registry*, which - ;; doesn't use this DSL: they are processed as normal namestrings. - ;; however, you can compute what you put in the *central-registry* - ;; based on the results of say - ;; (asdf::resolve-location "/Users/fare/cl/cl-foo/") - PATHNAME | - ;; pathname (better be an absolute path, or bust) - ;; In output-translations, unless followed by relative components, - ;; it better have appropriate wildcards, as in **/*.*.* - :HOME | ; designates the user-homedir-pathname ~/ - :USER-CACHE | ; designates the default location for the user cache - :HERE | - ;; designates the location of the configuration file - ;; (or *default-pathname-defaults*, if invoked interactively) - :ROOT - ;; magic, for output-translations source only: paths that are relative - ;; to the root of the source host and device - -They keyword :SYSTEM-CACHE is not accepted in ASDF 3.1 and beyond: it -was a security hazard. - -RELATIVE-COMPONENT-DESIGNATOR := - (RELATIVE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...) | - STRING | - ;; relative directory pathname as interpreted by - ;; parse-unix-namestring. - ;; In output translations, if last component, **/*.*.* is added - PATHNAME | ; pathname; unless last component, directory is assumed. - :IMPLEMENTATION | - ;; directory based on implementation, e.g. sbcl-1.0.45-linux-x64 - :IMPLEMENTATION-TYPE | - ;; a directory based on lisp-implementation-type only, e.g. sbcl - :DEFAULT-DIRECTORY | - ;; a relativized version of the default directory - :*/ | ;; any direct subdirectory (since ASDF 2.011.4) - :**/ | ;; any recursively inferior subdirectory (since ASDF 2.011.4) - :*.*.* | ;; any file (since ASDF 2.011.4) - -The keywords :UID and :USERNAME are no longer supported. -@end example - -For instance, as a simple case, my @file{~/.config/common-lisp/source-registry.conf}, -which is the default place ASDF looks for this configuration, once contained: -@example -(:source-registry - (:tree (:home "cl")) ;; will expand to e.g. "/home/joeluser/cl/" - :inherit-configuration) -@end example - -@node Configuration Directories, Shell-friendly syntax for configuration, Configuration DSL, Controlling where ASDF searches for systems -@section Configuration Directories - -Configuration directories consist in files each containing -a list of directives without any enclosing @code{(:source-registry ...)} form. -The files will be sorted by namestring as if by @code{string<} and -the lists of directives of these files with be concatenated in order. -An implicit @code{:inherit-configuration} will be included -at the @emph{end} of the list. - -System-wide or per-user Common Lisp software distributions -such as Debian packages or some future version of @code{clbuild} -may then include files such as -@file{/etc/common-lisp/source-registry.conf.d/10-foo.conf} or -@file{~/.config/common-lisp/source-registry.conf.d/10-foo.conf} -to easily and modularly register configuration information -about software being distributed. - -The convention is that, for sorting purposes, -the names of files in such a directory begin with two digits -that determine the order in which these entries will be read. -Also, the type of these files must be @file{.conf}, -which not only simplifies the implementation by allowing -for more portable techniques in finding those files, -but also makes it trivial to disable a file, by renaming it to a different file type. - -Directories may be included by specifying a directory pathname -or namestring in an @code{:include} directive, e.g.: - -@example - (:include "/foo/bar/") -@end example - -Hence, to achieve the same effect as -my example @file{~/.config/common-lisp/source-registry.conf} above, -I could simply create a file -@file{~/.config/common-lisp/source-registry.conf.d/33-home-fare-cl.conf} -alone in its directory with the following contents: -@example -(:tree "/home/fare/cl/") -@end example - -@menu -* The here directive:: -@end menu - -@node The here directive, , Configuration Directories, Configuration Directories -@subsection The :here directive - -The @code{:here} directive is an absolute pathname designator that -refers to the directory containing the configuration file currently -being processed. - -The @code{:here} directive is intended to simplify the delivery of -complex CL systems, and for easy configuration of projects shared through -revision control systems, in accordance with our design principle that -each participant should be able to provide all and only the information -available to him or her. - -Consider a person X who has set up the source code repository for a -complex project with a master directory @file{dir/}. Ordinarily, one -might simply have the user add a directive that would look something -like this: -@example - (:tree "path/to/dir") -@end example -But what if X knows that there are very large subtrees -under dir that are filled with, e.g., Java source code, image files for -icons, etc.? All of the asdf system definitions are contained in the -subdirectories @file{dir/src/lisp/} and @file{dir/extlib/lisp/}, and -these are the only directories that should be searched. - -In this case, X can put into @file{dir/} a file @file{asdf.conf} that -contains the following: -@example -(:source-registry - (:tree (:here "src/lisp/")) - (:tree (:here "extlib/lisp")) - (:directory (:here "outlier/"))) -@end example - -Then when someone else (call her Y) checks out a copy of this -repository, she need only add -@example -(:include "/path/to/my/checkout/directory/asdf.conf") -@end example -to one of her previously-existing asdf source location configuration -files, or invoke @code{initialize-source-registry} with a configuration -form containing that s-expression. ASDF will find the .conf file that X -has provided, and then set up source locations within the working -directory according to X's (relative) instructions. - -@node Shell-friendly syntax for configuration, Search Algorithm, Configuration Directories, Controlling where ASDF searches for systems -@section Shell-friendly syntax for configuration - -When considering environment variable @code{CL_SOURCE_REGISTRY} -ASDF will skip to next configuration if it's an empty string. -It will @code{READ} the string as a SEXP in the DSL -if it begins with a paren @code{(}, -otherwise it will be interpreted much like @code{TEXINPUTS}, -as a list of paths, where - - * paths are separated - by a @code{:} (colon) on Unix platforms (including cygwin), - by a @code{;} (semicolon) on other platforms (mainly, Windows). - - * each entry is a directory to add to the search path. - - * if the entry ends with a double slash @code{//} - then it instead indicates a tree in the subdirectories - of which to recurse. - - * if the entry is the empty string (which may only appear once), - then it indicates that the inherited configuration should be - spliced there. - -@node Search Algorithm, Caching Results, Shell-friendly syntax for configuration, Controlling where ASDF searches for systems -@section Search Algorithm -@vindex *default-source-registry-exclusions* - -In case that isn't clear, the semantics of the configuration is that -when searching for a system of a given name, -directives are processed in order. - -When looking in a directory, if the system is found, the search succeeds, -otherwise it continues. - -When looking in a tree, if one system is found, the search succeeds. -If multiple systems are found, the consequences are unspecified: -the search may succeed with any of the found systems, -or an error may be raised. -ASDF currently returns the first system found, -XCVB currently raised an error. -If none is found, the search continues. - -Exclude statements specify patterns of subdirectories -the systems from which to ignore. -Typically you don't want to use copies of files kept by such -version control systems as Darcs. -Exclude statements are not propagated to further included or inherited -configuration files or expressions; -instead the defaults are reset around every configuration statement -to the default defaults from @code{asdf::*default-source-registry-exclusions*}. - -Include statements cause the search to recurse with the path specifications -from the file specified. - -An inherit-configuration statement cause the search to recurse with the path -specifications from the next configuration -(@pxref{Controlling where ASDF searches for systems,,Configurations} above). - - -@node Caching Results, Configuration API, Search Algorithm, Controlling where ASDF searches for systems -@section Caching Results - -The implementation is allowed to either eagerly compute the information -from the configurations and file system, or to lazily re-compute it -every time, or to cache any part of it as it goes. -In practice, the recommended @code{source-registry} eagerly collects and caches results -and you need to explicitly flush the cache for change to be taken into account, -whereas the old-style @code{*central-registry*} mechanism queries the filesystem every time. - -To explicitly flush any information cached by the system -after a change was made in the filesystem, @xref{Configuration API}, -and e.g. call @code{asdf:clear-source-registry}. - -Starting with ASDF 3.1.4, you can also explicitly build a persistent cache -of the @file{.asd} files found under a tree: -when recursing into a directory declared by @code{:tree} and its transitive subdirectories, -if a file @file{.cl-source-registry.cache} exists containing a form -that is a list starting with @code{:source-registry-cache} followed by a list of strings, -as in @code{(:source-registry-cache @emph{"foo/bar.asd" "path/to/more.asd" ...})}, -then the strings are assumed to be @code{unix-namestring}s designating -the available asd files under that tree, and the recursion otherwise stops. -The list can also be empty, allowing to stop a costly recursion in a huge directory tree. - -To update such a cache after you install, update or remove source repositories, -you can run a script distributed with ASDF: -@code{tools/cl-source-registry-cache.lisp @emph{/path/to/directory}}. -To wholly invalidate the cache, you can -delete the file @file{.cl-source-registry.cache} in that directory. -In either case, for an existing Lisp process to see this change, -it needs to clear its own cache with e.g. @code{(asdf:clear-source-registry)}. - -Developers may safely create a cache in their development tree, -and we recommend they do it at the top of their source tree if -it contains more than a small number of files and directories; -they only need update it when they create, remove or move @file{.asd} files. -Software distribution managers may also safely create such a cache, -but they must be careful to update it every time they install, update or remove -a software source repository or installation package. -Finally, advanced developers who juggle with a lot of code -in their @code{source-registry} may manually manage such a cache, -to allow for faster startup of Lisp programs. - -This persistence cache can help you reduce startup latency. -For instance, on one machine with hundreds of source repositories, -such a cache shaves half a second at the startup -of every @code{#!/usr/bin/cl} script using SBCL, more on other implementations; -this makes a notable difference as to -their subjective interactivity and usability. -The speedup will only happen if the implementation-provided ASDF is recent enough -(3.1.3.7 or later); it is not enough for a recent ASDF upgrade to be present, -since the upgrade will itself be found but -after the old version has scanned the directories without heeding such a cache. -To upgrade the implementation-provided ASDF, -use our script @code{tools/install-asdf.lisp}. - - -@node Configuration API, Introspection, Caching Results, Controlling where ASDF searches for systems -@section Configuration API - -The specified functions are exported from your build system's package. -Thus for ASDF the corresponding functions are in package ASDF, -and for XCVB the corresponding functions are in package XCVB. - -@defun initialize-source-registry @Aoptional{} PARAMETER - will read the configuration and initialize all internal variables. - You may extend or override configuration - from the environment and configuration files - with the given @var{PARAMETER}, which can be - @code{nil} (no configuration override), - or a SEXP (in the SEXP DSL), - a string (as in the string DSL), - a pathname (of a file or directory with configuration), - or a symbol (fbound to function that when called returns one of the above). -@end defun - -@defun clear-source-registry - undoes any source registry configuration - and clears any cache for the search algorithm. - You might want to call this function - (or better, @code{clear-configuration}) - before you dump an image that would be resumed - with a different configuration, - and return an empty configuration. - Note that this does not include clearing information about - systems defined in the current image, only about - where to look for systems not yet defined. -@end defun - -@defun ensure-source-registry @Aoptional{} PARAMETER - checks whether a source registry has been initialized. - If not, initialize it with the given @var{PARAMETER}. -@end defun - -Every time you use ASDF's @code{find-system}, or -anything that uses it (such as @code{operate}, @code{load-system}, etc.), -@code{ensure-source-registry} is called with parameter @code{nil}, -which the first time around causes your configuration to be read. -If you change a configuration file, -you need to explicitly @code{initialize-source-registry} again, -or maybe simply to @code{clear-source-registry} (or @code{clear-configuration}) -which will cause the initialization to happen next time around. - -@node Introspection, Status, Configuration API, Controlling where ASDF searches for systems -@section Introspection - -@menu -* *source-registry-parameter* variable:: -* Information about system dependencies:: -@end menu - -@node *source-registry-parameter* variable, Information about system dependencies, Introspection, Introspection -@subsection *source-registry-parameter* variable -@vindex *source-registry-parameter* - -We have made available the variable @code{*source-registry-parameter*} -that can be used by code that wishes to introspect about the (past) -configuration of ASDF's source registry. @strong{This variable should -never be set!} It will be set as a side-effect of calling -@code{initialize-source-registry}; user code should treat it as -read-only. - -@node Information about system dependencies, , *source-registry-parameter* variable, Introspection -@subsection Information about system dependencies - -ASDF makes available three functions to read system interdependencies. -These are intended to aid programmers who wish to perform dependency -analyses. - -@defun system-defsystem-depends-on system -@end defun - -@defun system-depends-on system -@end defun - -@defun system-weakly-depends-on system -Returns a list of names of systems that are weakly depended on by -@var{system}. Weakly depended on systems are optionally loaded only if -ASDF can find them; failure to find such systems does @emph{not} cause an -error in loading. - -Note that the return value for @code{system-weakly-depends-on} is simpler -than the return values of the other two system dependency introspection -functions. -@end defun - -@node Status, Rejected ideas, Introspection, Controlling where ASDF searches for systems -@section Status - -This mechanism is vastly successful, and we have declared -that @code{asdf:*central-registry*} is not recommended anymore, -though we will continue to support it. -All hooks into implementation-specific search mechanisms -have been integrated in the @code{wrapping-source-registry} -that everyone uses implicitly. - -@node Rejected ideas, TODO, Status, Controlling where ASDF searches for systems -@section Rejected ideas - -Alternatives I (FRR) considered and rejected while developing ASDF 2 included: - -@enumerate -@item Keep @code{asdf:*central-registry*} as the master with its current semantics, - and somehow the configuration parser expands the new configuration - language into a expanded series of directories of subdirectories to - lookup, pre-recursing through specified hierarchies. This is kludgy, - and leaves little space of future cleanups and extensions. - -@item Keep @code{asdf:*central-registry*} as the master but extend its semantics - in completely new ways, so that new kinds of entries may be implemented - as a recursive search, etc. This seems somewhat backwards. - -@item Completely remove @code{asdf:*central-registry*} - and break backwards compatibility. - Hopefully this will happen in a few years after everyone migrate to - a better ASDF and/or to XCVB, but it would be very bad to do it now. - -@item Replace @code{asdf:*central-registry*} by a symbol-macro with appropriate magic - when you dereference it or setf it. Only the new variable with new - semantics is handled by the new search procedure. - Complex and still introduces subtle semantic issues. -@end enumerate - - -I've been suggested the below features, but have rejected them, -for the sake of keeping ASDF no more complex than strictly necessary. - -@itemize -@item - More syntactic sugar: synonyms for the configuration directives, such as - @code{(:add-directory X)} for @code{(:directory X)}, or @code{(:add-directory-hierarchy X)} - or @code{(:add-directory X :recurse t)} for @code{(:tree X)}. - -@item - The possibility to register individual files instead of directories. - -@item - Integrate Xach Beane's tilde expander into the parser, - or something similar that is shell-friendly or shell-compatible. - I'd rather keep ASDF minimal. But maybe this precisely keeps it - minimal by removing the need for evaluated entries that ASDF has? - i.e. uses of @code{USER-HOMEDIR-PATHNAME} and @code{$SBCL_HOME} - Hopefully, these are already superseded by the @code{:default-registry} - -@item - Using the shell-unfriendly syntax @code{/**} instead of @code{//} to specify recursion - down a filesystem tree in the environment variable. - It isn't that Lisp friendly either. -@end itemize - -@node TODO, Credits for the source-registry, Rejected ideas, Controlling where ASDF searches for systems -@section TODO - -@itemize -@item Add examples -@end itemize - -@node Credits for the source-registry, , TODO, Controlling where ASDF searches for systems -@section Credits for the source-registry - -Thanks a lot to Stelian Ionescu for the initial idea. - -Thanks to Rommel Martinez for the initial implementation attempt. - -All bad design ideas and implementation bugs are mine, not theirs. -But so are good design ideas and elegant implementation tricks. - - --- Francois-Rene Rideau @email{fare@@tunes.org}, Mon, 22 Feb 2010 00:07:33 -0500 - - - -@node Controlling where ASDF saves compiled files, Error handling, Controlling where ASDF searches for systems, Top -@comment node-name, next, previous, up -@chapter Controlling where ASDF saves compiled files -@cindex asdf-output-translations -@vindex ASDF_OUTPUT_TRANSLATIONS - -Each Common Lisp implementation has its own format -for compiled files or fasls.@footnote{``FASL'' is short for ``FASt Loading.''} -If you use multiple implementations -(or multiple versions of the same implementation), -you'll soon find your source directories -littered with various @file{fasl}s, @file{dfsl}s, @file{cfsl}s and so -on. -Worse yet, multiple implementations use the same file extension and -some implementations maintain the same file extension -while changing formats from version to version (or platform to -platform). -This can lead to many errors and much confusion -as you switch from one implementation to the next. - -Since ASDF 2, ASDF includes the @code{asdf-output-translations} facility -to mitigate the problem. - -@menu -* Output Configurations:: -* Output Backward Compatibility:: -* Output Configuration DSL:: -* Output Configuration Directories:: -* Output Shell-friendly syntax for configuration:: -* Semantics of Output Translations:: -* Output Caching Results:: -* Output location API:: -* Credits for output translations:: -@end menu - -@node Output Configurations, Output Backward Compatibility, Controlling where ASDF saves compiled files, Controlling where ASDF saves compiled files -@section Configurations - -@c FIXME: Explain how configurations work: can't expect reader will have -@c looked at previous chapter. Probably cut and paste will do. - - -Configurations specify mappings from input locations to output locations. -Once again we rely on the XDG base directory specification for configuration. -@xref{Controlling where ASDF searches for systems,,XDG base directory}. - -@enumerate - -@item -Some hardcoded wrapping output translations configuration may be used. -This allows special output translations (or usually, invariant directories) -to be specified corresponding to the similar special entries in the source registry. - -@item -An application may explicitly initialize the output-translations -configuration using the Configuration API -in which case this takes precedence. -(@pxref{Controlling where ASDF saves compiled files,,Configuration API}.) -It may itself compute this configuration from the command-line, -from a script, from its own configuration file, etc. - -@item -The source registry will be configured from -the environment variable @code{ASDF_OUTPUT_TRANSLATIONS} if it exists. - -@item -The source registry will be configured from -user configuration file -@file{$XDG_CONFIG_DIRS/common-lisp/asdf-output-translations.conf} -(which defaults to -@file{~/.config/common-lisp/asdf-output-translations.conf}) -if it exists. - -@item -The source registry will be configured from -user configuration directory -@file{$XDG_CONFIG_DIRS/common-lisp/asdf-output-translations.conf.d/} -(which defaults to -@file{~/.config/common-lisp/asdf-output-translations.conf.d/}) -if it exists. - -@item -The source registry will be configured from -system configuration file -@file{/etc/common-lisp/asdf-output-translations.conf} -if it exists. - -@item -The source registry will be configured from -system configuration directory -@file{/etc/common-lisp/asdf-output-translations.conf.d/} -if it exists. - -@end enumerate - -Each of these configurations is specified as a SEXP -in a trivial domain-specific language (@pxref{Configuration DSL}). -Additionally, a more shell-friendly syntax is available -for the environment variable (@pxref{Shell-friendly syntax for configuration}). - -When processing an entry in the above list of configuration methods, -ASDF will stop unless that entry -explicitly or implicitly specifies that it -includes its inherited configuration. - -Note that by default, a per-user cache is used for output files. -This allows the seamless use of shared installations of software -between several users, and takes files out of the way of the developers -when they browse source code, -at the expense of taking a small toll when developers have to clean up -output files and find they need to get familiar with output-translations -first.@footnote{A @code{CLEAN-OP} would be a partial solution to this problem.} - - -@node Output Backward Compatibility, Output Configuration DSL, Output Configurations, Controlling where ASDF saves compiled files -@section Backward Compatibility -@cindex ASDF-BINARY-LOCATIONS compatibility -@c FIXME: Demote this section -- the typical reader doesn't care about -@c backwards compatibility. - - -We purposely do @emph{not} provide backward compatibility with earlier versions of -@code{ASDF-Binary-Locations} (8 Sept 2009), -@code{common-lisp-controller} (7.0) or -@code{cl-launch} (2.35), -each of which had similar general capabilities. -The APIs of these programs were not designed -for easy user configuration -through configuration files. -Recent versions of @code{common-lisp-controller} (7.2) and @code{cl-launch} (3.000) -use the new @code{asdf-output-translations} API as defined below. -@code{ASDF-Binary-Locations} is fully superseded and not to be used anymore. - -This incompatibility shouldn't inconvenience many people. -Indeed, few people use and customize these packages; -these few people are experts who can trivially adapt to the new configuration. -Most people are not experts, could not properly configure these features -(except inasmuch as the default configuration of -@code{common-lisp-controller} and/or @code{cl-launch} -might have been doing the right thing for some users), -and yet will experience software that ``just works'', -as configured by the system distributor, or by default. - -Nevertheless, if you are a fan of @code{ASDF-Binary-Locations}, -we provide a limited emulation mode: - -@defun enable-asdf-binary-locations-compatibility @Akey{} centralize-lisp-binaries default-toplevel-directory include-per-user-information map-all-source-files source-to-target-mappings -This function will initialize the new @code{asdf-output-translations} facility in a way -that emulates the behavior of the old @code{ASDF-Binary-Locations} facility. -Where you would previously set global variables -@var{*centralize-lisp-binaries*}, -@var{*default-toplevel-directory*}, -@var{*include-per-user-information*}, -@var{*map-all-source-files*} or @var{*source-to-target-mappings*} -you will now have to pass the same values as keyword arguments to this function. -Note however that as an extension the @code{:source-to-target-mappings} keyword argument -will accept any valid pathname designator for @code{asdf-output-translations} -instead of just strings and pathnames. -@end defun - -If you insist, you can also keep using the old @code{ASDF-Binary-Locations} -(the one available as an extension to load of top of ASDF, -not the one built into a few old versions of ASDF), -but first you must disable @code{asdf-output-translations} -with @code{(asdf:disable-output-translations)}, -or you might experience ``interesting'' issues. - -Also, note that output translation is enabled by default. -To disable it, use @code{(asdf:disable-output-translations)}. - -@node Output Configuration DSL, Output Configuration Directories, Output Backward Compatibility, Controlling where ASDF saves compiled files -@section Configuration DSL - -Here is the grammar of the SEXP DSL -for @code{asdf-output-translations} configuration: - -@verbatim -;; A configuration is single SEXP starting with keyword :source-registry -;; followed by a list of directives. -CONFIGURATION := (:output-translations DIRECTIVE ...) - -;; A directive is one of the following: -DIRECTIVE := - ;; INHERITANCE DIRECTIVE: - ;; Your configuration expression MUST contain - ;; exactly one of either of these: - :inherit-configuration | - ;; splices inherited configuration (often specified last) - :ignore-inherited-configuration | - ;; drop inherited configuration (specified anywhere) - - ;; forward compatibility directive (since ASDF 2.011.4), useful when - ;; you want to use new configuration features but have to bootstrap a - ;; the newer required ASDF from an older release that doesn't have - ;; said features: - :ignore-invalid-entries | - - ;; include a configuration file or directory - (:include PATHNAME-DESIGNATOR) | - - ;; enable global cache in ~/.common-lisp/cache/sbcl-1.0.45-linux-amd64/ - ;; or something. - :enable-user-cache | - ;; Disable global cache. Map / to / - :disable-cache | - - ;; add a single directory to be scanned (no recursion) - (DIRECTORY-DESIGNATOR DIRECTORY-DESIGNATOR) - - ;; use a function to return the translation of a directory designator - (DIRECTORY-DESIGNATOR (:function TRANSLATION-FUNCTION)) - -DIRECTORY-DESIGNATOR := - NIL | ; As source: skip this entry. As destination: same as source - T | ; as source matches anything, as destination - ; maps pathname to itself. - ABSOLUTE-COMPONENT-DESIGNATOR ; same as in the source-registry language - -TRANSLATION-FUNCTION := - SYMBOL | ;; symbol naming a function that takes two arguments: - ;; the pathname to be translated and the matching - ;; DIRECTORY-DESIGNATOR - LAMBDA ;; A form which evaluates to a function taking two arguments: - ;; the pathname to be translated and the matching - ;; DIRECTORY-DESIGNATOR - -@end verbatim - -Relative components better be either relative -or subdirectories of the path before them, or bust. - -@c FIXME: the following assumes that the reader is familiar with the use -@c of this pattern in logical pathnames, which may not be a reasonable -@c assumption. Expand. -The last component, if not a pathname, is notionally completed by @file{/**/*.*}. -You can specify more fine-grained patterns -by using a pathname object as the last component -e.g. @file{#p"some/path/**/foo*/bar-*.fasl"} - -You may use @code{#+features} to customize the configuration file. - -The second designator of a mapping may be @code{nil}, indicating that files are not mapped -to anything but themselves (same as if the second designator was the same as the first). - -When the first designator is @code{t}, -the mapping always matches. -When the first designator starts with @code{:root}, -the mapping matches any host and device. -In either of these cases, if the second designator -isn't @code{t} and doesn't start with @code{:root}, -then strings indicating the host and pathname are somehow copied -in the beginning of the directory component of the source pathname -before it is translated. - -When the second designator is @code{t}, the mapping is the identity. -When the second designator starts with @code{:root}, -the mapping preserves the host and device of the original pathname. -Notably, this allows you to map files -to a subdirectory of the whichever directory the file is in. -Though the syntax is not quite as easy to use as we'd like, -you can have an (source destination) mapping entry such as follows -in your configuration file, -or you may use @code{enable-asdf-binary-locations-compatibility} -with @code{:centralize-lisp-binaries nil} -which will do the same thing internally for you: -@lisp -#.(let ((wild-subdir - (make-pathname :directory '(:relative :wild-inferiors))) - (wild-file - (make-pathname :name :wild :version :wild :type :wild))) - `((:root ,wild-subdir ,wild-file) - (:root ,wild-subdir :implementation ,wild-file))) -@end lisp -Starting with ASDF 2.011.4, you can use the simpler: - @code{`(:root (:root :**/ :implementation :*.*.*))} - - - -@code{:include} statements cause the search to recurse with the path specifications -from the file specified. - -If the @code{translate-pathname} mechanism cannot achieve a desired -translation, the user may provide a function which provides the -required algorithm. Such a translation function is specified by -supplying a list as the second @code{directory-designator} -the first element of which is the keyword @code{:function}, -and the second element of which is -either a symbol which designates a function or a lambda expression. -The function designated by the second argument must take two arguments, -the first being the pathname of the source file, -the second being the wildcard that was matched. -When invoked, the function should return the translated pathname. - -An @code{:inherit-configuration} statement causes the search to recurse with the path -specifications from the next configuration in the bulleted list. -@xref{Controlling where ASDF saves compiled files,,Configurations}, above. - -@vindex @code{asdf::*user-cache*} -@itemize -@item -@code{:enable-user-cache} is the same as @code{(t :user-cache)}. -@item -@code{:disable-cache} is the same as @code{(t t)}. -@item -@code{:user-cache} uses the contents of variable @code{asdf::*user-cache*} -which by default is the same as using -@code{(:home ".cache" "common-lisp" :implementation)}. -@end itemize - - -@node Output Configuration Directories, Output Shell-friendly syntax for configuration, Output Configuration DSL, Controlling where ASDF saves compiled files -@section Configuration Directories - -Configuration directories consist of files, each of which contains -a list of directives without any enclosing -@code{(:output-translations ...)} form. -The files will be sorted by namestring as if by @code{string<} and -the lists of directives of these files with be concatenated in order. -An implicit @code{:inherit-configuration} will be included -at the @emph{end} of the list. - -System-wide or per-user Common Lisp software distributions -such as Debian packages or some future version of @code{clbuild} -may then include files such as -@file{/etc/common-lisp/asdf-output-translations.conf.d/10-foo.conf} or -@file{~/.config/common-lisp/asdf-output-translations.conf.d/10-foo.conf} -to easily and modularly register configuration information -about software being distributed. - -The convention is that, for sorting purposes, -the names of files in such a directory begin with two digits -that determine the order in which these entries will be read. -Also, the type of these files must be @file{.conf}, -which not only simplifies the implementation by allowing -for more portable techniques in finding those files, -but also makes it trivial to disable a file, by renaming it to a different file type. - -Directories may be included by specifying a directory pathname -or namestring in an @code{:include} directive, e.g.: - -@verbatim - (:include "/foo/bar/") -@end verbatim - -@node Output Shell-friendly syntax for configuration, Semantics of Output Translations, Output Configuration Directories, Controlling where ASDF saves compiled files -@section Shell-friendly syntax for configuration - -When considering environment variable @code{ASDF_OUTPUT_TRANSLATIONS} -ASDF will skip to the next configuration if it's an empty string. -It will @code{READ} the string as an SEXP in the DSL -if it begins with a paren @code{(} -and it will be interpreted as a list of directories. -Directories should come by pairs, indicating a mapping directive. -Entries are separated -by a @code{:} (colon) on Unix platforms (including cygwin), -by a @code{;} (semicolon) on other platforms (mainly, Windows). - -The magic empty entry, -if it comes in what would otherwise be the first entry in a pair, -indicates the splicing of inherited configuration. -If it comes as the second entry in a pair, -it indicates that the directory specified first is to be left untranslated -(which has the same effect as if the directory had been repeated). -Thus @code{"/foo:/bar::/baz:"} means that -things under directory @file{/foo/} -are translated to be under @file{/bar/}, -then include the inherited configuration, -then specify that things under directory @file{/baz/} are not translated. - -@node Semantics of Output Translations, Output Caching Results, Output Shell-friendly syntax for configuration, Controlling where ASDF saves compiled files -@section Semantics of Output Translations - -From the specified configuration, -a list of mappings is extracted in a straightforward way: -mappings are collected in order, recursing through -included or inherited configuration as specified. -To this list is prepended some implementation-specific mappings, -and is appended a global default. - -The list is then compiled to a mapping table as follows: -for each entry, in order, resolve the first designated directory -into an actual directory pathname for source locations. -If no mapping was specified yet for that location, -resolve the second designated directory to an output location directory -add a mapping to the table mapping the source location to the output location, -and add another mapping from the output location to itself -(unless a mapping already exists for the output location). - -Based on the table, a mapping function is defined, -mapping source pathnames to output pathnames: -given a source pathname, locate the longest matching prefix -in the source column of the mapping table. -Replace that prefix by the corresponding output column -in the same row of the table, and return the result. -If no match is found, return the source pathname. -(A global default mapping the filesystem root to itself -may ensure that there will always be a match, -with same fall-through semantics). - -@node Output Caching Results, Output location API, Semantics of Output Translations, Controlling where ASDF saves compiled files -@section Caching Results - -The implementation is allowed to either eagerly compute the information -from the configurations and file system, or to lazily re-compute it -every time, or to cache any part of it as it goes. -To explicitly flush any information cached by the system, use the API below. - - -@node Output location API, Credits for output translations, Output Caching Results, Controlling where ASDF saves compiled files -@section Output location API - -The specified functions are exported from package ASDF. - -@defun initialize-output-translations @Aoptional{} PARAMETER - will read the configuration and initialize all internal variables. - You may extend or override configuration - from the environment and configuration files - with the given @var{PARAMETER}, which can be - @code{nil} (no configuration override), - or a SEXP (in the SEXP DSL), - a string (as in the string DSL), - a pathname (of a file or directory with configuration), - or a symbol (fbound to function that when called returns one of the above). -@end defun - -@defun disable-output-translations - will initialize output translations in a way - that maps every pathname to itself, - effectively disabling the output translation facility. -@end defun - -@defun clear-output-translations - undoes any output translation configuration - and clears any cache for the mapping algorithm. - You might want to call this function - (or better, @code{clear-configuration}) - before you dump an image that would be resumed - with a different configuration, - and return an empty configuration. - Note that this does not include clearing information about - systems defined in the current image, only about - where to look for systems not yet defined. -@end defun - -@defun ensure-output-translations @Aoptional{} PARAMETER - checks whether output translations have been initialized. - If not, initialize them with the given @var{PARAMETER}. - This function will be called before any attempt to operate on a system. -@end defun - -@defun apply-output-translations PATHNAME - Applies the configured output location translations to @var{PATHNAME} - (calls @code{ensure-output-translations} for the translations). -@end defun - -Every time you use ASDF's @code{output-files}, or -anything that uses it (that may compile, such as @code{operate}, @code{perform}, etc.), -@code{ensure-output-translations} is called with parameter @code{nil}, -which the first time around causes your configuration to be read. -If you change a configuration file, -you need to explicitly @code{initialize-output-translations} again, -or maybe @code{clear-output-translations} (or @code{clear-configuration}), -which will cause the initialization to happen next time around. - - -@node Credits for output translations, , Output location API, Controlling where ASDF saves compiled files -@section Credits for output translations - -Thanks a lot to Peter van Eynde for @code{Common Lisp Controller} -and to Bjorn Lindberg and Gary King for @code{ASDF-Binary-Locations}. - -All bad design ideas and implementation bugs are to mine, not theirs. -But so are good design ideas and elegant implementation tricks. - - --- Francois-Rene Rideau @email{fare@@tunes.org} - -@c @section Default locations -@c @findex output-files-for-system-and-operation - -@c The default binary location for each Lisp implementation -@c is a subdirectory of each source directory. -@c To account for different Lisps, Operating Systems, Implementation versions, -@c and so on, ASDF borrows code from SLIME -@c to create reasonable custom directory names. -@c Here are some examples: - -@c @itemize -@c @item -@c SBCL, version 1.0.45 on Mac OS X for Intel: @code{sbcl-1.0.45-darwin-x86} - -@c @item -@c Franz Allegro, version 8.0, ANSI Common Lisp: @code{allegro-8.0a-macosx-x86} - -@c @item -@c Franz Allegro, version 8.1, Modern (case sensitive) Common Lisp: @code{allegro-8.1m-macosx-x86} -@c @end itemize - -@c By default, all output file pathnames will be relocated -@c to some thus-named subdirectory of @file{~/.cache/common-lisp/}. - -@c See the document @file{README.asdf-output-translations} -@c for a full specification on how to configure @code{asdf-output-translations}. - -@node Error handling, Miscellaneous additional functionality, Controlling where ASDF saves compiled files, Top -@comment node-name, next, previous, up -@chapter Error handling -@findex SYSTEM-DEFINITION-ERROR -@findex OPERATION-ERROR - -@section ASDF errors - -If ASDF detects an incorrect system definition, it will signal a generalised instance of -@code{SYSTEM-DEFINITION-ERROR}. - -Operations may go wrong (for example when source files contain errors). -These are signalled using generalised instances of -@code{OPERATION-ERROR}. - -@section Compilation error and warning handling -@vindex *compile-file-warnings-behaviour* -@vindex *compile-file-errors-behavior* - -ASDF checks for warnings and errors when a file is compiled. -The variables @var{*compile-file-warnings-behaviour*} and -@var{*compile-file-errors-behavior*} -control the handling of any such events. -The valid values for these variables are -@code{:error}, @code{:warn}, and @code{:ignore}. - -@node Miscellaneous additional functionality, Getting the latest version, Error handling, Top -@comment node-name, next, previous, up -@chapter Miscellaneous additional functionality - -ASDF includes several additional features that are generally -useful for system definition and development. - -@menu -* Controlling file compilation:: -* Controlling source file character encoding:: -* Some Utility Functions:: -@end menu - -@node Controlling file compilation, Controlling source file character encoding, Miscellaneous additional functionality, Miscellaneous additional functionality -@section Controlling file compilation -@cindex :around-compile -@cindex around-compile keyword -@cindex compile-check keyword -@cindex :compile-check -@findex compile-file* - -@c FIXME: Needs rewrite. Start with motivation -- why are we doing -@c this? (there is some, but it's buried). Also, all of a sudden in -@c the middle of the discussion we start talking about a "hook," which -@c is confusing. - -When declaring a component (system, module, file), -you can specify a keyword argument @code{:around-compile function}. -If left unspecified (and therefore unbound), -the value will be inherited from the parent component if any, -or with a default of @code{nil} -if no value is specified in any transitive parent. - -The argument must be either @code{nil}, an fbound symbol, -a lambda-expression (e.g. @code{(lambda (thunk) ...(funcall thunk ...) ...)}) -a function object (e.g. using @code{#.#'} but that's discouraged -because it prevents the introspection done by e.g. asdf-dependency-grovel), -or a string that when @code{read} yields a symbol or a lambda-expression. -@code{nil} means the normal compile-file function will be called. -A non-nil value designates a function of one argument -that will be called with a function that will -invoke @code{compile-file*} with various arguments; -the around-compile hook may supply additional keyword arguments -to pass to that call to @code{compile-file*}. - -One notable argument that is heeded by @code{compile-file*} is -@code{:compile-check}, -a function called when the compilation was otherwise a success, -with the same arguments as @code{compile-file}; -the function shall return true if the compilation -and its resulting compiled file respected all system-specific invariants, -and false (@code{nil}) if it broke any of those invariants; -it may issue warnings or errors before it returns @code{nil}. -(NB: The ability to pass such extra flags -is only available starting with ASDF 2.22.3.) -This feature is notably exercised by asdf-finalizers. - -By using a string, you may reference -a function, symbol and/or package -that will only be created later during the build, but -isn't yet present at the time the defsystem form is evaluated. -However, if your entire system is using such a hook, you may have to -explicitly override the hook with @code{nil} for all the modules and files -that are compiled before the hook is defined. - -Using this hook, you may achieve such effects as: -locally renaming packages, -binding @var{*readtables*} and other syntax-controlling variables, -handling warnings and other conditions, -proclaiming consistent optimization settings, -saving code coverage information, -maintaining meta-data about compilation timings, -setting gensym counters and PRNG seeds and other sources of non-determinism, -overriding the source-location and/or timestamping systems, -checking that some compile-time side-effects were properly balanced, -etc. - -Note that there is no around-load hook. This is on purpose. -Some implementations such as ECL, GCL or MKCL link object files, -which allows for no such hook. -Other implementations allow for concatenating FASL files, -which doesn't allow for such a hook either. -We aim to discourage something that's not portable, -and has some dubious impact on performance and semantics -even when it is possible. -Things you might want to do with an around-load hook -are better done around-compile, -though it may at times require some creativity -(see e.g. the @code{package-renaming} system). - - -@node Controlling source file character encoding, Some Utility Functions, Controlling file compilation, Miscellaneous additional functionality -@section Controlling source file character encoding - -Starting with ASDF 2.21, components accept a @code{:encoding} option -so authors may specify which character encoding should be used -to read and evaluate their source code. -When left unspecified, the encoding is inherited -from the parent module or system; -if no encoding is specified at any point, -or if @code{nil} is explicitly specified, -an extensible protocol described below is followed, -that ultimately defaults to @code{:utf-8} since ASDF 3. - -The protocol to determine the encoding is -to call the function @code{detect-encoding}, -which itself, if provided a valid file, -calls the function specified by @var{*encoding-detection-hook*}, -or else defaults to the @var{*default-encoding*}. -The @var{*encoding-detection-hook*} is by default bound -to function @code{always-default-encoding}, -that always returns the contents of @var{*default-encoding*}. -@var{*default-encoding*} is bound to @code{:utf-8} by default -(before ASDF 3, the default was @code{:default}). - -Whichever encoding is returned must be a portable keyword, -that will be translated to an implementation-specific external-format designator -by function @code{encoding-external-format}, -which itself simply calls the function specified @var{*encoding-external-format-hook*}; -that function by default is @code{default-encoding-external-format}, -that only recognizes @code{:utf-8} and @code{:default}, -and translates the former to the implementation-dependent @var{*utf-8-external-format*}, -and the latter to itself (that itself is portable but has an implementation-dependent meaning). - -In other words, there now are plenty of extension hooks, but -by default ASDF enforces the previous @emph{de facto} standard behavior -of using @code{:utf-8}, independently from -whatever configuration the user may be using. -Thus, system authors can now rely on @code{:utf-8} -being used while compiling their files, -even if the user is currently using @code{:koi8-r} or @code{:euc-jp} -as their interactive encoding. -(Before ASDF 3, there was no such guarantee, @code{:default} was used, -and only plain ASCII was safe to include in source code.) - -Some legacy implementations only support 8-bit characters, -and some implementations provide 8-bit only variants. -On these implementations, the @var{*utf-8-external-format*} -gracefully falls back to @code{:default}, -and Unicode characters will be read as multi-character mojibake. -To detect such situations, UIOP will push the @code{:asdf-unicode} feature -on implementations that support Unicode, and you can use reader-conditionalization -to protect any @code{:encoding @emph{encoding}} statement, as in -@code{#+asdf-unicode :encoding #+asdf-unicode :utf-8}. -We recommend that you avoid using unprotected @code{:encoding} specifications -until after ASDF 2.21 or later becomes widespread -(in April 2014, only LispWorks lags with ASDF 2.019, -and is scheduled to be updated later this year). - -While it offers plenty of hooks for extension, -and one such extension is available (see @code{asdf-encodings} below), -ASDF itself only recognizes one encoding beside @code{:default}, -and that is @code{:utf-8}, which is the @emph{de facto} standard, -already used by the vast majority of libraries that use more than ASCII. -On implementations that do not support unicode, -the feature @code{:asdf-unicode} is absent, and -the @code{:default} external-format is used -to read even source files declared as @code{:utf-8}. -On these implementations, non-ASCII characters -intended to be read as one CL character -may thus end up being read as multiple CL characters. -In most cases, this shouldn't affect the software's semantics: -comments will be skipped just the same, strings with be read and printed -with slightly different lengths, symbol names will be accordingly longer, -but none of it should matter. -But a few systems that actually depend on unicode characters -may fail to work properly, or may work in a subtly different way. -See for instance @code{lambda-reader}. - -We invite you to embrace UTF-8 -as the encoding for non-ASCII characters starting today, -even without any explicit specification in your @file{.asd} files. -Indeed, on some implementations and configurations, -UTF-8 is already the @code{:default}, -and loading your code may cause errors if it is encoded in anything but UTF-8. -Therefore, even with the legacy behavior, -non-UTF-8 is guaranteed to break for some users, -whereas UTF-8 is pretty much guaranteed not to break anywhere -(provided you do @emph{not} use a BOM), -although it might be read incorrectly on some implementations. -@code{:utf-8} has been the default value of @code{*default-encoding*} since ASDF 3. - -If you need non-standard character encodings for your source code, -use the extension system @code{asdf-encodings}, by specifying -@code{:defsystem-depends-on (:asdf-encodings)} in your @code{defsystem}. -This extension system will register support for more encodings using the -@code{*encoding-external-format-hook*} facility, -so you can explicitly specify @code{:encoding :latin1} -in your @file{.asd} file. -Using the @code{*encoding-detection-hook*} it will also -eventually implement some autodetection of a file's encoding -from an emacs-style @code{-*- mode: lisp ; coding: latin1 -*-} declaration, -or otherwise based on an analysis of octet patterns in the file. -At this point, @code{asdf-encoding} only supports the encodings -that are supported as part of your implementation. -Since the list varies depending on implementations, -we still recommend you use @code{:utf-8} everywhere, -which is the most portable (next to it is @code{:latin1}). - -Recent versions of Quicklisp include @code{asdf-encodings}; -if you're not using it, you may get this extension using git: -@kbd{git clone git://common-lisp.net/projects/asdf/asdf-encodings.git} -or -@kbd{git clone ssh://common-lisp.net/project/asdf/git/asdf-encodings.git}. -You can also browse the repository on -@url{http://common-lisp.net/gitweb?p=projects/asdf/asdf-encodings.git}. - -When you use @code{asdf-encodings}, -any @file{.asd} file loaded -will use the autodetection algorithm to determine its encoding. -If you depend on this detection happening, -you should explicitly load @code{asdf-encodings} early in your build. -Note that @code{:defsystem-depends-on} cannot be used here: by the time -the @code{:defsystem-depends-on} is loaded, the enclosing -@code{defsystem} form has already been read. - -In practice, this means that the @code{*default-encoding*} -is usually used for @file{.asd} files. -Currently, this defaults to @code{:utf-8}, and -you should be safe using Unicode characters in those files. -This might matter, for instance, in meta-data about author's names. -Otherwise, the main data in these files is component (path)names, -and we don't recommend using non-ASCII characters for these, -for the result probably isn't very portable. - -@section Miscellaneous Functions - -These functions are exported by ASDF for your convenience. - -@anchor{system-relative-pathname} -@defun system-relative-pathname system name @Akey{} type - -It's often handy to locate a file relative to some system. -The @code{system-relative-pathname} function meets this need. - -It takes two mandatory arguments @var{system} and @var{name} -and a keyword argument @var{type}: -@var{system} is name of a system, whereas @var{name} and optionally @var{type} -specify a relative pathname, interpreted like a component pathname specifier -by @code{coerce-pathname}. @xref{The defsystem grammar,,Pathname specifiers}. - -It returns a pathname built from the location of the system's -source directory and the relative pathname. For example: - -@lisp -> (asdf:system-relative-pathname 'cl-ppcre "regex.data") -#P"/repository/other/cl-ppcre/regex.data" -@end lisp - -@end defun - -@defun system-source-directory system-designator - -ASDF does not provide a turnkey solution for locating -data (or other miscellaneous) files -that are distributed together with the source code of a system. -Programmers can use @code{system-source-directory} to find such files. -Returns a pathname object. -The @var{system-designator} may be a string, symbol, or ASDF system object. -@end defun - -@defun clear-system system-designator - -It is sometimes useful to force recompilation of a previously loaded system. -For these cases, @code{(asdf:clear-system :foo)} -will remove the system from the table of currently loaded systems: -the next time the system @code{foo} or one that depends on it is re-loaded, -@code{foo} will be loaded again.@footnote{Alternatively, you could touch @code{foo.asd} or -remove the corresponding fasls from the output file cache.} - -Note that this does not and cannot undo -the previous loading of the system. -Common Lisp has no provision for such an operation, -and its reliance on irreversible side-effects to global data structures -makes such a thing impossible in the general case. -If the software being re-loaded is not conceived with hot upgrade in mind, -re-loading may cause many errors, warnings or subtle silent problems, -as packages, generic function signatures, structures, types, macros, constants, etc. -are being redefined incompatibly. -It is up to the user to make sure that reloading is possible and has the desired effect. -In some cases, extreme measures such as recursively deleting packages, -unregistering symbols, defining methods on @code{update-instance-for-redefined-class} -and much more are necessary for reloading to happen smoothly. -ASDF itself goes to extensive effort to make a hot upgrade possible -with respect to its own code. -If you want, you can reuse some of its utilities such as -@code{uiop:define-package} and @code{uiop:with-upgradability}, -and get inspiration (or disinspiration) -from what it does in @file{header.lisp} and @file{upgrade.lisp}. -@end defun - -@defun register-preloaded-system name @Arest{} keys -A system with name @var{name}, -created by @code{make-instance} with extra keys @var{keys} -(e.g. @code{:version}), -is registered as @emph{preloaded}. -That is, its code has already been loaded into the current image, -and if at some point some other system @code{:depends-on} it yet no source code is found, -it is considered as already provided, -and ASDF will not raise a @code{missing-component} error. - -This function is particularly useful if you distribute your code -as fasls with either @code{compile-bundle-op} or @code{monolithic-compile-bundle-op}, -and want to register systems so that dependencies will work uniformly -whether you're using your software from source or from fasl. -@end defun - -@defun run-shell-command control-string @Arest{} args - -This function is obsolete and present only for the sake of backwards-compatibility: -``If it's not backwards, it's not compatible''. We @emph{strongly} discourage its use. -Its current behavior is only well-defined on Unix platforms -(which include MacOS X and cygwin). On Windows, anything goes. -The following documentation is only for the purpose of your migrating away from it -in a way that preserves semantics. - -Instead we recommend the use @code{run-program}, described in the next section, and -available as part of ASDF since ASDF 3. - -@code{run-shell-command} takes as arguments a format @code{control-string} -and arguments to be passed to @code{format} after this control-string -to produce a string. -This string is a command that will be evaluated with a POSIX shell if possible; -yet, on Windows, some implementations will use CMD.EXE, -while others (like SBCL) will make an attempt at invoking a POSIX shell -(and fail if it is not present). -@end defun - -@node Some Utility Functions, , Controlling source file character encoding, Miscellaneous additional functionality -@section Some Utility Functions - -The below functions are not exported by ASDF itself, but by UIOP, available since ASDF 3. -Some of them have precursors in ASDF 2, but we recommend -you rely on ASDF 3 for active developments. -UIOP provides many, many more utility functions, and we recommend -you read its README and sources for more information. - - -@defun parse-unix-namestring name @Akey{} type defaults dot-dot ensure-directory @AallowOtherKeys -Coerce NAME into a PATHNAME using standard Unix syntax. - -Unix syntax is used whether or not the underlying system is Unix; -on non-Unix systems it is only usable for relative pathnames. -In order to manipulate relative pathnames portably, it is crucial -to possess a portable pathname syntax independent of the underlying OS. -This is what @code{parse-unix-namestring} provides, and why we use it in ASDF. - -When given a @code{pathname} object, just return it untouched. -When given @code{nil}, just return @code{nil}. -When given a non-null @code{symbol}, first downcase its name and treat it as a string. -When given a @code{string}, portably decompose it into a pathname as below. - -@code{#\/} separates directory components. - -The last @code{#\/}-separated substring is interpreted as follows: -1- If @var{type} is @code{:directory} or @var{ensure-directory} is true, - the string is made the last directory component, and its @code{name} and @code{type} are @code{nil}. - if the string is empty, it's the empty pathname with all slots @code{nil}. -2- If @var{type} is @code{nil}, the substring is a file-namestring, - and its @code{name} and @code{type} are separated by @code{split-name-type}. -3- If @var{type} is a string, it is the given @code{type}, and the whole string is the @code{name}. - -Directory components with an empty name the name @code{.} are removed. -Any directory named @code{..} is read as @var{dot-dot}, -which must be one of @code{:back} or @code{:up} and defaults to @code{:back}. - -@vindex *nil-pathname* -@code{host}, @code{device} and @code{version} components are taken from @var{defaults}, -which itself defaults to @code{*nil-pathname*}. -@code{*nil-pathname*} is also used if @var{defaults} is @code{nil}. -No host or device can be specified in the string itself, -which makes it unsuitable for absolute pathnames outside Unix. - -For relative pathnames, these components (and hence the defaults) won't matter -if you use @code{merge-pathnames*} but will matter if you use @code{merge-pathnames}, -which is an important reason to always use @code{merge-pathnames*}. - -Arbitrary keys are accepted, and the parse result is passed to @code{ensure-pathname} -with those keys, removing @var{type}, @var{defaults} and @var{dot-dot}. -When you're manipulating pathnames that are supposed to make sense portably -even though the OS may not be Unixish, we recommend you use @code{:want-relative t} -so that @code{parse-unix-namestring} will throw an error if the pathname is absolute. -@end defun - -@defun merge-pathnames* specified @Aoptional{} defaults - -This function is a replacement for @code{merge-pathnames} that uses the host and device -from the @var{defaults} rather than the @var{specified} pathname when the latter -is a relative pathname. This allows ASDF and its users to create and use relative pathnames -without having to know beforehand what are the host and device -of the absolute pathnames they are relative to. - -@end defun - -@defun subpathname pathname subpath @Akey{} type - -This function takes a @var{pathname} and a @var{subpath} and a @var{type}. -If @var{subpath} is already a @code{pathname} object (not namestring), -and is an absolute pathname at that, it is returned unchanged; -otherwise, @var{subpath} is turned into a relative pathname with given @var{type} -as per @code{parse-unix-namestring} with @code{:want-relative t :type }@var{type}, -then it is merged with the @code{pathname-directory-pathname} of @var{pathname}, -as per @code{merge-pathnames*}. - -We strongly encourage the use of this function -for portably resolving relative pathnames in your code base. -@end defun - -@defun subpathname* pathname subpath @Akey{} type - -This function returns @code{nil} if the base @var{pathname} is @code{nil}, -otherwise acts like @code{subpathname}. -@end defun - -@defun run-program command @Akey{} ignore-error-status force-shell input output @ -error-output if-input-does-not-exist if-output-exists if-error-output-exists @ -element-type external-format @AallowOtherKeys - -@code{run-program} takes a @var{command} argument that is either -a list of a program name or path and its arguments, -or a string to be executed by a shell. -It spawns the command, waits for it to return, -verifies that it exited cleanly (unless told not too below), -and optionally captures and processes its output. -It accepts many keyword arguments to configure its behavior. - -@code{run-program} returns three values: the first for the output, -the second for the error-output, and the third for the return value. -(Beware that before ASDF 3.0.2.11, it didn't handle input or error-output, -and returned only one value, -the one for the output if any handler was specified, or else the exit code; -please upgrade ASDF, or at least UIOP, to rely on the new enhanced behavior.) - -@var{output} is its most important argument; -it specifies how the output is captured and processed. -If it is @code{nil}, then the output is redirected to the null device, -that will discard it. -If it is @code{:interactive}, then it is inherited from the current process -(beware: this may be different from your @var{*standard-output*}, -and under SLIME will be on your @code{*inferior-lisp*} buffer). -If it is @code{t}, output goes to your current @var{*standard-output*} stream. -Otherwise, @var{output} should be a value that is a suitable first argument to -@code{slurp-input-stream} (see below), or -a list of such a value and keyword arguments. -In this case, @code{run-program} will -create a temporary stream for the program output; -the program output, in that stream, -will be processed by a call to @code{slurp-input-stream}, -using @var{output} as the first argument -(or if it's a list the first element of @var{output} and the rest as keywords). -The primary value resulting from that call -(or @code{nil} if no call was needed) -will be the first value returned by @code{run-program}. -E.g., using @code{:output :string} -will have it return the entire output stream as a string. -And using @code{:output '(:string :stripped t)} -will have it return the same string stripped of any ending newline. - -@var{error-output} is similar to @var{output}, except that -the resulting value is returned as the second value of @code{run-program}. -@code{t} designates the @var{*error-output*}. -Also @code{:output} means redirecting the error output to the output stream, -in which case @code{nil} is returned. - -@var{input} is similar to @var{output}, except that -@code{vomit-output-stream} is used, no value is returned, -and @code{t} designates the @var{*standard-input*}. - -@code{element-type} and @code{external-format} are passed on -to your Lisp implementation, when applicable, for creation of the output stream. - -One and only one of the stream slurping or vomiting may or may not happen -in parallel in parallel with the subprocess, -depending on options and implementation, -and with priority being given to output processing. -Other streams are completely produced or consumed -before or after the subprocess is spawned, using temporary files. - -@code{force-shell} forces evaluation of the command through a shell, -even if it was passed as a list rather than a string. -If a shell is used, it is @file{/bin/sh} on Unix or @file{CMD.EXE} on Windows, -except on implementations that (erroneously, IMNSHO) -insist on consulting @code{$SHELL} like clisp. - -@code{ignore-error-status} causes @code{run-program} -to not raise an error if the spawned program exits in error. -Following POSIX convention, an error is anything but -a normal exit with status code zero. -By default, an error of type @code{subprocess-error} is raised in this case. - -@code{run-program} works on all platforms supported by ASDF, except Genera. -See the source code for more documentation. - -@end defun - -@defun slurp-input-stream processor input-stream @Akey{} - -@code{slurp-input-stream} is a generic function of two arguments, a target object and an input stream, -and accepting keyword arguments. -Predefined methods based on the target object are as follows: - -@itemize -@item -If the object is a function, the function is called with the stream as argument. - -@item If the object is a cons, its first element is applied to its rest appended by -a list of the input stream. - -@item If the object is an output stream, the contents of the input stream are copied to it. -If the @var{linewise} keyword argument is provided, copying happens line by line, -and an optional @var{prefix} is printed before each line. -Otherwise, copying happen based on a buffer of size @var{buffer-size}, -using the specified @var{element-type}. - -@item If the object is @code{'string} or @code{:string}, the content is captured into a string. -Accepted keywords include the @var{element-type} and a flag @var{stripped}, -which when true causes any single line ending to be removed as per @code{uiop:stripln}. - -@item If the object is @code{:lines}, the content is captured as a list of strings, -one per line, without line ending. If the @var{count} keyword argument is provided, -it is a maximum count of lines to be read. - -@item If the object is @code{:line}, the content is captured as with @code{:lines} above, -and then its sub-object is extracted with the @var{at} argument, -which defaults to @code{0}, extracting the first line. -A number will extract the corresponding line. -See the documentation for @code{uiop:access-at}. - -@item If the object is @code{:forms}, the content is captured as a list of S-expressions, -as read by the Lisp reader. -If the @var{count} argument is provided, -it is a maximum count of lines to be read. -We recommend you control the syntax with such macro as -@code{uiop:with-safe-io-syntax}. - -@item If the object is @code{:form}, the content is captured as with @code{:forms} above, -and then its sub-object is extracted with the @var{at} argument, -which defaults to @code{0}, extracting the first form. -A number will extract the corresponding form. -See the documentation for @code{uiop:access-at}. -We recommend you control the syntax with such macro as -@code{uiop:with-safe-io-syntax}. -@end itemize -@end defun - - -@node Getting the latest version, FAQ, Miscellaneous additional functionality, Top -@comment node-name, next, previous, up -@chapter Getting the latest version - -Decide which version you want. -The @code{master} branch is where development happens; -its @code{HEAD} is usually OK, including the latest fixes and portability tweaks, -but an occasional regression may happen despite our (limited) test suite. - -The @code{release} branch is what cautious people should be using; -it has usually been tested more, and releases are cut at a point -where there isn't any known unresolved issue. - -You may get the ASDF source repository using git: -@kbd{git clone git://common-lisp.net/projects/asdf/asdf.git} - -You will find the above referenced tags in this repository. -You can also browse the repository on -@url{http://common-lisp.net/gitweb?p=projects/asdf/asdf.git}. - -Discussion of ASDF development is conducted on the -mailing list -@kbd{asdf-devel@@common-lisp.net}. -@url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel} - - -@node FAQ, Ongoing Work, Getting the latest version, Top -@comment node-name, next, previous, up -@chapter FAQ - -@menu -* Where do I report a bug?:: -* What has changed between ASDF 1 ASDF 2 and ASDF 3?:: -* Issues with installing the proper version of ASDF:: -* Issues with configuring ASDF:: -* Issues with using and extending ASDF to define systems:: -* ASDF development FAQs:: -@end menu - -@node Where do I report a bug?, What has changed between ASDF 1 ASDF 2 and ASDF 3?, FAQ, FAQ -@section ``Where do I report a bug?'' - -ASDF bugs are tracked on launchpad: @url{https://launchpad.net/asdf}. - -If you're unsure about whether something is a bug, or for general discussion, -use the @url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list} - - -@node What has changed between ASDF 1 ASDF 2 and ASDF 3?, Issues with installing the proper version of ASDF, Where do I report a bug?, FAQ -@section ``What has changed between ASDF 1, ASDF 2, and ASDF 3?'' - -We released ASDF 2.000 on May 31st 2010, -and ASDF 3.0.0 on May 15th 2013. -Releases of ASDF 2 and later have since then been included -in all actively maintained CL implementations that used to bundle ASDF 1, -plus some implementations that previously did not. -ASDF has been made to work with all actively maintained CL -implementations and even a few implementations that are @emph{not} -actively maintained. -@xref{FAQ,,``What has changed between ASDF 1 and ASDF 2?''}. -Furthermore, it is possible to upgrade from ASDF 1 to ASDF 2 or ASDF 3 on the fly -(though we recommend instead upgrading your implementation or its ASDF module). -For this reason, we have stopped supporting ASDF 1 and ASDF 2. -If you are using ASDF 1 or ASDF 2 and are experiencing any kind of issues or limitations, -we recommend you upgrade to ASDF 3 ---- and we explain how to do that. @xref{Loading ASDF}. -(In the context of compatibility requirements, -ASDF 2.27, released on Feb 1st 2013, and further 2.x releases up to 2.33, -count as pre-releases of ASDF 3, and define the @code{:asdf3} feature; -still, please use the latest release). -Release ASDF 3.1.2 and later also define the @code{:asdf3.1} feature. - - -@menu -* What are ASDF 1 2 3?:: -* How do I detect the ASDF version?:: -* ASDF can portably name files in subdirectories:: -* Output translations:: -* Source Registry Configuration:: -* Usual operations are made easier to the user:: -* Many bugs have been fixed:: -* ASDF itself is versioned:: -* ASDF can be upgraded:: -* Decoupled release cycle:: -* Pitfalls of the transition to ASDF 2:: -* What happened to the bundle operations:: -@end menu - -@node What are ASDF 1 2 3?, How do I detect the ASDF version?, What has changed between ASDF 1 ASDF 2 and ASDF 3?, What has changed between ASDF 1 ASDF 2 and ASDF 3? -@subsection What are ASDF 1, ASDF 2, and ASDF 3? - -ASDF 1 refers to any release earlier than 1.369 or so (from August 2001 to October 2009), -and to any development revision earlier than 2.000 (May 2010). -If your copy of ASDF doesn't even contain version information, it's an old ASDF 1. -Revisions between 1.656 and 1.728 may count as development releases for ASDF 2. - -ASDF 2 refers to releases from 2.000 (May 31st 2010) to 2.26 (Oct 30 2012), -and any development revision newer than ASDF 1 and older than 2.27 (Feb 1 2013). - -ASDF 3 refers to releases from 2.27 (Feb 1 2013) to 2.33 and 3.0.0 onward (May 15 2013). -2.27 to 2.33 count as pre-releases to ASDF 3. - -@node How do I detect the ASDF version?, ASDF can portably name files in subdirectories, What are ASDF 1 2 3?, What has changed between ASDF 1 ASDF 2 and ASDF 3? -@subsection How do I detect the ASDF version? -@findex asdf-version -@cindex *features* - -All releases of ASDF -push @code{:asdf} onto @code{*features*}. -Releases starting with ASDF 2 -push @code{:asdf2} onto @code{*features*}. -Releases starting with ASDF 3 (including 2.27 and later pre-releases) -push @code{:asdf3} onto @code{*features*}. -Furthermore, releases starting with ASDF 3.1.2 (May 2014), -though they count as ASDF 3, include enough progress that they -push @code{:asdf3.1} onto @code{*features*}. -You may depend on the presence or absence of these features -to write code that takes advantage of recent ASDF functionality -but still works on older versions, or at least detects the old version and signals an error. - -Additionally, all releases starting with ASDF 2 -define a function @code{(asdf:asdf-version)} you may use to query the version. -All releases starting with 2.013 display the version number prominently -on the second line of the @file{asdf.lisp} source file. - -If you are experiencing problems or limitations of any sort with ASDF 1 or ASDF 2, -we recommend that you should upgrade to the latest release, be it ASDF 3 or other. - - -@node ASDF can portably name files in subdirectories, Output translations, How do I detect the ASDF version?, What has changed between ASDF 1 ASDF 2 and ASDF 3? -@subsection ASDF can portably name files in subdirectories - -Common Lisp namestrings are not portable, -except maybe for logical pathname namestrings, -that themselves have various limitations and require a lot of setup -that is itself ultimately non-portable. - -In ASDF 1, the only portable ways to refer to pathnames inside systems and components -were very awkward, using @code{#.(make-pathname ...)} and -@code{#.(merge-pathnames ...)}. -Even the above were themselves were inadequate in the general case -due to host and device issues, unless horribly complex patterns were used. -Plenty of simple cases that looked portable actually weren't, -leading to much confusion and greavance. - -ASDF 2 implements its own portable syntax for strings as pathname specifiers. -Naming files within a system definition becomes easy and portable again. -@xref{Miscellaneous additional functionality,system-relative-pathname}, -@code{merge-pathnames*}, -@code{coerce-pathname}. - -On the other hand, there are places where systems used to accept namestrings -where you must now use an explicit pathname object: -@code{(defsystem ... :pathname "LOGICAL-HOST:PATH;TO;SYSTEM;" ...)} -must now be written with the @code{#p} syntax: -@code{(defsystem ... :pathname #p"LOGICAL-HOST:PATH;TO;SYSTEM;" ...)} - -@xref{The defsystem grammar,,Pathname specifiers}. - - -@node Output translations, Source Registry Configuration, ASDF can portably name files in subdirectories, What has changed between ASDF 1 ASDF 2 and ASDF 3? -@subsection Output translations - -A popular feature added to ASDF was output pathname translation: -@code{asdf-binary-locations}, @code{common-lisp-controller}, -@code{cl-launch} and other hacks were all implementing it in ways -both mutually incompatible and difficult to configure. - -Output pathname translation is essential to share -source directories of portable systems across multiple implementations -or variants thereof, -or source directories of shared installations of systems across multiple users, -or combinations of the above. - -In ASDF 2, a standard mechanism is provided for that, -@code{asdf-output-translations}, -with sensible defaults, adequate configuration languages, -a coherent set of configuration files and hooks, -and support for non-Unix platforms. - -@xref{Controlling where ASDF saves compiled files}. - -@node Source Registry Configuration, Usual operations are made easier to the user, Output translations, What has changed between ASDF 1 ASDF 2 and ASDF 3? -@subsection Source Registry Configuration - -Configuring ASDF used to require special magic -to be applied just at the right moment, -between the moment ASDF is loaded and the moment it is used, -in a way that is specific to the user, -the implementation he is using and the application he is building. - -This made for awkward configuration files and startup scripts -that could not be shared between users, managed by administrators -or packaged by distributions. - -ASDF 2 provides a well-documented way to configure ASDF, -with sensible defaults, adequate configuration languages, -and a coherent set of configuration files and hooks. - -We believe it's a vast improvement because it decouples -application distribution from library distribution. -The application writer can avoid thinking where the libraries are, -and the library distributor (dpkg, clbuild, advanced user, etc.) -can configure them once and for every application. -Yet settings can be easily overridden where needed, -so whoever needs control has exactly as much as required. - -At the same time, ASDF 2 remains compatible -with the old magic you may have in your build scripts -(using @code{*central-registry*} and -@code{*system-definition-search-functions*}) -to tailor the ASDF configuration to your build automation needs, -and also allows for new magic, simpler and more powerful magic. - -@xref{Controlling where ASDF searches for systems}. - - -@node Usual operations are made easier to the user, Many bugs have been fixed, Source Registry Configuration, What has changed between ASDF 1 ASDF 2 and ASDF 3? -@subsection Usual operations are made easier to the user - -In ASDF 1, you had to use the awkward syntax -@code{(asdf:oos 'asdf:load-op :foo)} -to load a system, -and similarly for @code{compile-op}, @code{test-op}. - -In ASDF 2, you can use shortcuts for the usual operations: -@code{(asdf:load-system :foo)}, and -similarly for @code{compile-system}, @code{test-system}. - - -@node Many bugs have been fixed, ASDF itself is versioned, Usual operations are made easier to the user, What has changed between ASDF 1 ASDF 2 and ASDF 3? -@subsection Many bugs have been fixed - -The following issues and many others have been fixed: - -@itemize -@item -The infamous TRAVERSE function has been revamped completely -between ASDF 1 and ASDF 2, with many bugs squashed. -In particular, dependencies were not correctly propagated -across modules but now are. -It has been completely rewritten many times over -between ASDF 2.000 and ASDF 3, -with fundamental issues in the original model being fixed. -Timestamps were not propagated at all, and now are. -The internal model of how actions depend on each other -is now both consistent and complete. -The @code{:version} and -the @code{:force (system1 .. systemN)} feature have been fixed. - -@item -Performance has been notably improved for large systems -(say with thousands of components) by using -hash-tables instead of linear search, -and linear-time list accumulation instead of cubic time recursive append, -for an overall @emph{O(n)} complexity vs @emph{O(n^4)}. - -@item -Many features used to not be portable, -especially where pathnames were involved. -Windows support was notably quirky because of such non-portability. - -@item -The internal test suite used to massively fail on many implementations. -While still incomplete, it now fully passes -on all implementations supported by the test suite, -though some tests are commented out on a few implementations. - -@item -Support was lacking for some implementations. -ABCL and GCL were notably wholly broken. -ECL extensions were not integrated with ASDF release. - -@item -The documentation was grossly out of date. - -@end itemize - - -@node ASDF itself is versioned, ASDF can be upgraded, Many bugs have been fixed, What has changed between ASDF 1 ASDF 2 and ASDF 3? -@subsection ASDF itself is versioned - -Between new features, old bugs fixed, and new bugs introduced, -there were various releases of ASDF in the wild, -and no simple way to check which release had which feature set. -People using or writing systems had to either make worst-case assumptions -as to what features were available and worked, -or take great pains to have the correct version of ASDF installed. - -With ASDF 2, we provide a new stable set of working features -that everyone can rely on from now on. -Use @code{#+asdf2} to detect presence of ASDF 2, -@code{(asdf:version-satisfies (asdf:asdf-version) "2.345.67")} -to check the availability of a version no earlier than required. - - -@node ASDF can be upgraded, Decoupled release cycle, ASDF itself is versioned, What has changed between ASDF 1 ASDF 2 and ASDF 3? -@subsection ASDF can be upgraded - -When an old version of ASDF was loaded, -it was very hard to upgrade ASDF in your current image -without breaking everything. -Instead you had to exit the Lisp process and -somehow arrange to start a new one from a simpler image. -Something that can't be done from within Lisp, -making automation of it difficult, -which compounded with difficulty in configuration, -made the task quite hard. -Yet as we saw before, the task would have been required -to not have to live with the worst case or non-portable -subset of ASDF features. - -With ASDF 2, it is easy to upgrade -from ASDF 2 to later versions from within Lisp, -and not too hard to upgrade from ASDF 1 to ASDF 2 from within Lisp. -We support hot upgrade of ASDF and any breakage is a bug -that we will do our best to fix. -There are still limitations on upgrade, though, -most notably the fact that after you upgrade ASDF, -you must also reload or upgrade all ASDF extensions. - -@node Decoupled release cycle, Pitfalls of the transition to ASDF 2, ASDF can be upgraded, What has changed between ASDF 1 ASDF 2 and ASDF 3? -@subsection Decoupled release cycle - -When vendors were releasing their Lisp implementations with ASDF, -they had to basically never change version -because neither upgrade nor downgrade was possible -without breaking something for someone, -and no obvious upgrade path was visible and recommendable. - -With ASDF 2, upgrade is possible, easy and can be recommended. -This means that vendors can safely ship a recent version of ASDF, -confident that if a user isn't fully satisfied, -he can easily upgrade ASDF and deal -with a supported recent version of it. -This means that release cycles will be causally decoupled, -the practical consequence of which will mean faster convergence -towards the latest version for everyone. - - -@node Pitfalls of the transition to ASDF 2, What happened to the bundle operations, Decoupled release cycle, What has changed between ASDF 1 ASDF 2 and ASDF 3? -@subsection Pitfalls of the transition to ASDF 2 - -The main pitfalls in upgrading to ASDF 2 seem to be related -to the output translation mechanism. - -@itemize - -@item -Output translations is enabled by default. This may surprise some users, -most of them in pleasant way (we hope), a few of them in an unpleasant way. -It is trivial to disable output translations. -@xref{FAQ,,``How can I wholly disable the compiler output cache?''}. - -@item -Some systems in the large have been known -not to play well with output translations. -They were relatively easy to fix. -Once again, it is also easy to disable output translations, -or to override its configuration. - -@item -The new ASDF output translations are incompatible with ASDF-Binary-Locations. -They replace A-B-L, and there is compatibility mode to emulate -your previous A-B-L configuration. -See @code{enable-asdf-binary-locations-compatibility} in -@pxref{Controlling where ASDF saves compiled files,,Backward Compatibility}. -But thou shalt not load ABL on top of ASDF 2. - -@end itemize - -Other issues include the following: - -@itemize - -@item -ASDF pathname designators are now specified -in places where they were unspecified, -and a few small adjustments have to be made to some non-portable defsystems. -Notably, in the @code{:pathname} argument -to a @code{defsystem} and its components, -a logical pathname (or implementation-dependent hierarchical pathname) -must now be specified with @code{#p} syntax -where the namestring might have previously sufficed; -moreover when evaluation is desired @code{#.} must be used, -where it wasn't necessary in the toplevel @code{:pathname} argument -(but necessary in other @code{:pathname} arguments). - -@item -There is a slight performance bug, notably on SBCL, -when initially searching for @file{asd} files, -the implicit @code{(directory "/configured/path/**/*.asd")} -for every configured path @code{(:tree "/configured/path/")} -in your @code{source-registry} configuration can cause a slight pause. -Try to @code{(time (asdf:initialize-source-registry))} -to see how bad it is or isn't on your system. -If you insist on not having this pause, -you can avoid the pause by overriding the default source-registry configuration -and not use any deep @code{:tree} entry but only @code{:directory} entries -or shallow @code{:tree} entries. -Or you can fix your implementation to not be quite that slow -when recursing through directories. -@emph{Update}: This performance bug fixed the hard way in 2.010. - -@item -On Windows, only LispWorks supports proper default configuration pathnames -based on the Windows registry. -Other implementations make do with environment variables, -that you may have to define yourself -if you're using an older version of Windows. -Windows support is somewhat less tested than Unix support. -Please help report and fix bugs. -@emph{Update}: As of ASDF 2.21, all implementations -should now use the same proper default configuration pathnames -and they should actually work, though they haven't all been tested. - -@item -The mechanism by which one customizes a system so that Lisp files -may use a different extension from the default @file{.lisp} has changed. -Previously, the pathname for a component -was lazily computed when operating on a system, -and you would -@code{(defmethod source-file-type ((component cl-source-file) (system (eql (find-system 'foo)))) - (declare (ignorable component system)) "lis")}. -Now, the pathname for a component is eagerly computed when defining the system, -and instead you will @code{(defclass cl-source-file.lis (cl-source-file) ((type :initform "lis")))} -and use @code{:default-component-class cl-source-file.lis} -as argument to @code{defsystem}, -as detailed in a @pxref{FAQ,How do I create a system definition where all the source files have a .cl extension?} below. - -@findex source-file-type - - -@end itemize - -@node What happened to the bundle operations, , Pitfalls of the transition to ASDF 2, What has changed between ASDF 1 ASDF 2 and ASDF 3? -@subsection What happened to the bundle operations? - -@tindex fasl-op (obsolete) -@tindex load-fasl-op (obsolete) -@tindex binary-op (obsolete) -@tindex monolithic-fasl-op (obsolete) -@tindex monolithic-load-fasl-op (obsolete) -@tindex monolithic-binary-op (obsolete) -@tindex compile-bundle-op -@tindex load-bundle-op -@tindex deliver-asd-op -@tindex monolithic-compile-bundle-op -@tindex monolithic-load-bundle-op -@tindex monolithic-deliver-asd-op - -Some of the bundle operations were renamed after ASDF 3.1.3, and the old -names have been removed. Old bundle operations, and their modern -equivalents are: - -@itemize -@item -@code{fasl-op} is now @code{compile-bundle-op} -@item -@code{load-fasl-op} is now @code{load-bundle-op} -@item -@code{binary-op} is now @code{deliver-asd-op} -@item -@code{monolithic-fasl-op} is now @code{monolithic-compile-bundle-op} -@item -@code{monolithic-load-fasl-op} is now @code{monolithic-load-bundle-op} -@item -@code{monolithic-binary-op} is now @code{monolithic-deliver-asd-op} -@end itemize - - - -@node Issues with installing the proper version of ASDF, Issues with configuring ASDF, What has changed between ASDF 1 ASDF 2 and ASDF 3?, FAQ -@section Issues with installing the proper version of ASDF - -@menu -* My Common Lisp implementation comes with an outdated version of ASDF. What to do?:: -* I'm a Common Lisp implementation vendor. When and how should I upgrade ASDF?:: -@end menu - -@node My Common Lisp implementation comes with an outdated version of ASDF. What to do?, I'm a Common Lisp implementation vendor. When and how should I upgrade ASDF?, Issues with installing the proper version of ASDF, Issues with installing the proper version of ASDF -@subsection ``My Common Lisp implementation comes with an outdated version of ASDF. What to do?'' - -We recommend you upgrade ASDF. -@xref{Loading ASDF,,Upgrading ASDF}. - -If this does not work, it is a bug, and you should report it. -@xref{FAQ, report-bugs, Where do I report a bug}. -In the meantime, you can load @file{asdf.lisp} directly. -@xref{Loading ASDF,Loading an otherwise installed ASDF}. - - -@node I'm a Common Lisp implementation vendor. When and how should I upgrade ASDF?, , My Common Lisp implementation comes with an outdated version of ASDF. What to do?, Issues with installing the proper version of ASDF -@subsection ``I'm a Common Lisp implementation vendor. When and how should I upgrade ASDF?'' - -Since ASDF 2, -it should always be a good time to upgrade to a recent version of ASDF. -You may consult with the maintainer for which specific version they recommend, -but the latest @code{release} should be correct. -Though we do try to test ASDF releases against all implementations that we can, -we may not be testing against all variants of your implementation, -and we may not be running enough tests; -we trust you to thoroughly test it with your own implementation -before you release it. -If there are any issues with the current release, -it's a bug that you should report upstream and that we will fix ASAP. - -As to how to include ASDF, we recommend the following: - -@itemize -@item -If ASDF isn't loaded yet, then @code{(require "asdf")} -should load the version of ASDF that is bundled with your system. -If possible so should @code{(require "ASDF")}. -You may have it load some other version configured by the user, -if you allow such configuration. - -@item -If your system provides a mechanism to hook into @code{CL:REQUIRE}, -then it would be nice to add ASDF to this hook the same way that -ABCL, CCL, CLISP, CMUCL, ECL, SBCL and SCL do it. -Please send us appropriate code to this end. - -@item -You may, like SBCL since 1.1.13 or MKCL since 1.1.9, -have ASDF create bundle FASLs -that are provided as modules by your Lisp distribution. -You may also, but we don't recommend that anymore, -have ASDF like SBCL up until 1.1.12 be implicitly used -when requiring modules that are provided by your Lisp distribution; -if you do, you should add them in the beginning of both -@code{wrapping-source-registry} and @code{wrapping-output-translations}. - -@item -If you have magic systems as above, like SBCL used to do, -then we explicitly ask you to @emph{NOT} distribute -@file{asdf.asd} as part of those magic systems. -You should still include the file @file{asdf.lisp} in your source distribution -and precompile it in your binary distribution, -but @file{asdf.asd} if included at all, -should be secluded from the magic systems, -in a separate file hierarchy. -Alternatively, you may provide the system -after renaming it and its @file{.asd} file to e.g. -@code{asdf-ecl} and @file{asdf-ecl.asd}, or -@code{sb-asdf} and @file{sb-asdf.asd}. -Indeed, if you made @file{asdf.asd} a magic system, -then users would no longer be able to upgrade ASDF using ASDF itself -to some version of their preference that -they maintain independently from your Lisp distribution. - -@item -If you do not have any such magic systems, or have other non-magic systems -that you want to bundle with your implementation, -then you may add them to the @code{wrapping-source-registry}, -and you are welcome to include @file{asdf.asd} amongst them. -Non-magic systems should be at the back of the @code{wrapping-source-registry} -while magic systems are at the front. -If they are precompiled, -they should also be in the @code{wrapping-output-translations}. - -@item -Since ASDF 3, the library UIOP comes transcluded in ASDF. -But if you want to be nice to users who care for UIOP but not for ASDF, -you may package UIOP separately, -so that one may @code{(require "uiop")} and not load ASDF, -or one may @code{(require "asdf")} -which would implicitly require and load the former. - -@item -Please send us upstream any patches you make to ASDF itself, -so we can merge them back in for the benefit of your users -when they upgrade to the upstream version. - -@end itemize - - - -@node Issues with configuring ASDF, Issues with using and extending ASDF to define systems, Issues with installing the proper version of ASDF, FAQ -@section Issues with configuring ASDF - -@menu -* How can I customize where fasl files are stored?:: -* How can I wholly disable the compiler output cache?:: -@end menu - -@node How can I customize where fasl files are stored?, How can I wholly disable the compiler output cache?, Issues with configuring ASDF, Issues with configuring ASDF -@subsection ``How can I customize where fasl files are stored?'' - -@xref{Controlling where ASDF saves compiled files}. - -Note that in the past there was an add-on to ASDF called -@code{ASDF-binary-locations}, developed by Gary King. -That add-on has been merged into ASDF proper, -then superseded by the @code{asdf-output-translations} facility. - -Note that use of @code{asdf-output-translations} -can interfere with one aspect of your systems ---- if your system uses @code{*load-truename*} to find files -(e.g., if you have some data files stored with your program), -then the relocation that this ASDF customization performs -is likely to interfere. -Use @code{asdf:system-relative-pathname} to locate a file -in the source directory of some system, and -use @code{asdf:apply-output-translations} to locate a file -whose pathname has been translated by the facility. - -@node How can I wholly disable the compiler output cache?, , How can I customize where fasl files are stored?, Issues with configuring ASDF -@subsection ``How can I wholly disable the compiler output cache?'' - -To permanently disable the compiler output cache -for all future runs of ASDF, you can: - -@example -mkdir -p ~/.config/common-lisp/asdf-output-translations.conf.d/ -echo ':disable-cache' > ~/.config/common-lisp/asdf-output-translations.conf.d/99-disable-cache.conf -@end example - -This assumes that you didn't otherwise configure the ASDF files -(if you did, edit them again), -and don't somehow override the configuration at runtime -with a shell variable (see below) or some other runtime command -(e.g. some call to @code{asdf:initialize-output-translations}). - -To disable the compiler output cache in Lisp processes -run by your current shell, try (assuming @code{bash} or @code{zsh}) -(on Unix and cygwin only): - -@example -export ASDF_OUTPUT_TRANSLATIONS=/: -@end example - -To disable the compiler output cache just in the current Lisp process, -use (after loading ASDF but before using it): - -@example -(asdf:disable-output-translations) -@end example - -Note that this does @emph{NOT} belong in a @file{.asd} file. -Please do not tamper with ASDF configuration from a @file{.asd} file, -and only do this from your personal configuration or build scripts. - -@node Issues with using and extending ASDF to define systems, ASDF development FAQs, Issues with configuring ASDF, FAQ -@section Issues with using and extending ASDF to define systems - -@menu -* How can I cater for unit-testing in my system?:: -* How can I cater for documentation generation in my system?:: -* How can I maintain non-Lisp (e.g. C) source files?:: -* I want to put my module's files at the top level. How do I do this?:: -* How do I create a system definition where all the source files have a .cl extension?:: -* How do I mark a source file to be loaded only and not compiled?:: -* How do I work with readtables?:: -@end menu - -@node How can I cater for unit-testing in my system?, How can I cater for documentation generation in my system?, Issues with using and extending ASDF to define systems, Issues with using and extending ASDF to define systems -@subsection ``How can I cater for unit-testing in my system?'' - -ASDF provides a predefined test operation, @code{test-op}. -@xref{Predefined operations of ASDF, test-op}. -The test operation, however, is largely left to the system definer to specify. -@code{test-op} has been -a topic of considerable discussion on the -@url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}, -and on the -@url{https://launchpad.net/asdf,launchpad bug-tracker}. -We provide some guidelines in the discussion of @code{test-op}. - -@c cut the following because it's discussed in the discussion of test-op. -@c Here are some guidelines: - -@c @itemize -@c @item -@c For a given system, @var{foo}, you will want to define a corresponding -@c test system, such as @var{foo-test}. The reason that you will want this -@c separate system is that ASDF does not out of the box supply components -@c that are conditionally loaded. So if you want to have source files -@c (with the test definitions) that will not be loaded except when testing, -@c they should be put elsewhere. - -@c @item -@c The @var{foo-test} system can be defined in an asd file of its own or -@c together with @var{foo}. An aesthetic preference against cluttering up -@c the filesystem with extra asd files should be balanced against the -@c question of whether one might want to directly load @var{foo-test}. -@c Typically one would not want to do this except in early stages of -@c debugging. - -@c @item -@c Record that testing is implemented by @var{foo-test}. For example: -@c @example -@c (defsystem @var{foo} -@c :in-order-to ((test-op (test-op @var{foo-test}))) -@c ....) - -@c (defsystem @var{foo-test} -@c :depends-on (@var{foo} @var{my-test-library} ...) -@c ....) -@c @end example -@c @end itemize - -@c This procedure will allow you to support users who do not wish to -@c install your test framework. - -@c One oddity of ASDF is that @code{operate} (@pxref{Operations,operate}) -@c does not return a value. So in current versions of ASDF there is no -@c reliable programmatic means of determining whether or not a set of tests -@c has passed, or which tests have failed. The user must simply read the -@c console output. This limitation has been the subject of much -@c discussion. - -@node How can I cater for documentation generation in my system?, How can I maintain non-Lisp (e.g. C) source files?, How can I cater for unit-testing in my system?, Issues with using and extending ASDF to define systems -@subsection ``How can I cater for documentation generation in my system?'' - -Various ASDF extensions provide some kind of @code{doc-op} operation. -See also @url{https://bugs.launchpad.net/asdf/+bug/479470}. - - -@node How can I maintain non-Lisp (e.g. C) source files?, I want to put my module's files at the top level. How do I do this?, How can I cater for documentation generation in my system?, Issues with using and extending ASDF to define systems -@subsection ``How can I maintain non-Lisp (e.g. C) source files?'' - -See @code{cffi}'s @code{cffi-grovel}. - -@anchor{report-bugs} - - -@node I want to put my module's files at the top level. How do I do this?, How do I create a system definition where all the source files have a .cl extension?, How can I maintain non-Lisp (e.g. C) source files?, Issues with using and extending ASDF to define systems -@subsection ``I want to put my module's files at the top level. How do I do this?'' - -By default, the files contained in an asdf module go -in a subdirectory with the same name as the module. -However, this can be overridden by adding a @code{:pathname ""} argument -to the module description. -For example, here is how it could be done -in the spatial-trees ASDF system definition for ASDF 2: - -@example -(asdf:defsystem :spatial-trees - :components - ((:module base - :pathname "" - :components - ((:file "package") - (:file "basedefs" :depends-on ("package")) - (:file "rectangles" :depends-on ("package")))) - (:module tree-impls - :depends-on (base) - :pathname "" - :components - ((:file "r-trees") - (:file "greene-trees" :depends-on ("r-trees")) - (:file "rstar-trees" :depends-on ("r-trees")) - (:file "rplus-trees" :depends-on ("r-trees")) - (:file "x-trees" :depends-on ("r-trees" "rstar-trees")))) - (:module viz - :depends-on (base) - :pathname "" - :components - ((:static-file "spatial-tree-viz.lisp"))) - (:module tests - :depends-on (base) - :pathname "" - :components - ((:static-file "spatial-tree-test.lisp"))) - (:static-file "LICENCE") - (:static-file "TODO"))) -@end example - -All of the files in the @code{tree-impls} module are at the top level, -instead of in a @file{tree-impls/} subdirectory. - -Note that the argument to @code{:pathname} can be either a pathname object or a string. -A pathname object can be constructed with the @file{#p"foo/bar/"} syntax, -but this is discouraged because the results of parsing a namestring are not portable. -A pathname can only be portably constructed with such syntax as -@code{#.(make-pathname :directory '(:relative "foo" "bar"))}, -and similarly the current directory can only be portably specified as -@code{#.(make-pathname :directory '(:relative))}. -However, as of ASDF 2, you can portably use a string to denote a pathname. -The string will be parsed as a @code{/}-separated path from the current directory, -such that the empty string @code{""} denotes the current directory, and -@code{"foo/bar"} (no trailing @code{/} required in the case of modules) -portably denotes the same subdirectory as above. -When files are specified, the last @code{/}-separated component is interpreted -either as the name component of a pathname -(if the component class specifies a pathname type), -or as a name component plus optional dot-separated type component -(if the component class doesn't specifies a pathname type). - -@node How do I create a system definition where all the source files have a .cl extension?, How do I mark a source file to be loaded only and not compiled?, I want to put my module's files at the top level. How do I do this?, Issues with using and extending ASDF to define systems -@subsection How do I create a system definition where all the source files have a .cl extension? - -Starting with ASDF 2.014.14, you may just pass -the builtin class @code{cl-source-file.cl} as -the @code{:default-component-class} argument to @code{defsystem}: - -@lisp -(defsystem my-cl-system - :default-component-class cl-source-file.cl - ...) -@end lisp - -Another builtin class @code{cl-source-file.lsp} is offered -for files ending in @file{.lsp}. - -If you want to use a different extension -for which ASDF doesn't provide builtin support, -or want to support versions of ASDF -earlier than 2.014.14 (but later than 2.000), -you can define a class as follows: - -@lisp -;; Prologue: make sure we're using a sane package. -(defpackage :my-asdf-extension - (:use :asdf :common-lisp) - (:export #:cl-source-file.lis)) -(in-package :my-asdf-extension) - -(defclass cl-source-file.lis (cl-source-file) - ((type :initform "lis"))) -@end lisp - -Then you can use it as follows: -@lisp -(defsystem my-cl-system - :default-component-class my-asdf-extension:cl-source-file.lis - ...) -@end lisp - -Of course, if you're in the same package, e.g. in the same file, -you won't need to use the package qualifier before @code{cl-source-file.lis}. -Actually, if all you're doing is defining this class -and using it in the same file without other fancy definitions, -you might skip package complications: - -@lisp -(in-package :asdf) -(defclass cl-source-file.lis (cl-source-file) - ((type :initform "lis"))) -(defsystem my-cl-system - :default-component-class cl-source-file.lis - ...) -@end lisp - -It is possible to achieve the same effect -in a way that supports both ASDF 1 and ASDF 2, -but really, friends don't let friends use ASDF 1. -Please upgrade to ASDF 3. -In short, though: do same as above, but -@emph{before} you use the class in a @code{defsystem}, -you also define the following method: - -@lisp -(defmethod source-file-type ((f cl-source-file.lis) (s system)) - (declare (ignorable f s)) - "lis") -@end lisp - -@node How do I mark a source file to be loaded only and not compiled?, How do I work with readtables?, How do I create a system definition where all the source files have a .cl extension?, Issues with using and extending ASDF to define systems -@subsection How do I mark a source file to be loaded only and not compiled? - -There is no provision in ASDF for ensuring that -some components are always loaded as source, while others are always -compiled. -There is @code{load-source-op} (@pxref{Predefined operations of -ASDF,load-source-op}), but that is an operation to be applied to a -system as a whole, not to one or another specific source files. -While this idea often comes up in discussions, -it doesn't play well with either the linking model of ECL -or with various bundle operations. -In addition, the dependency model of ASDF would have to be modified incompatibly -to allow for such a trick. -@c If your code doesn't compile cleanly, fix it. -@c If compilation makes it slow, use @code{declaim} or @code{eval-when} -@c to adjust your compiler settings, -@c or eschew compilation by @code{eval}uating a quoted source form at load-time. - -@node How do I work with readtables?, , How do I mark a source file to be loaded only and not compiled?, Issues with using and extending ASDF to define systems -@subsection How do I work with readtables? - -@cindex readtables - -It is possible to configure the lisp syntax by modifying the currently-active readtable. -However, this same readtable is shared globally by all software being compiled by ASDF, -especially since @code{load} and @code{compile-file} both bind @var{*readtable*}, -so that its value is the same across the build at the start of every file -(unless overridden by some @code{perform :around} method), -even if a file locally binds it to a different readtable during the build. - -Therefore, the following hygiene restrictions apply. If you don't abide by these restrictions, -there will be situations where your output files will be corrupted during an incremental build. -We are not trying to prescribe new restrictions for the sake of good style: -these restrictions have always applied implicitly, and -we are simply describing what they have always been. - -@itemize -@item It is forbidden to modifying any standard character or standard macro dispatch defined in the CLHS. -@item No two dependencies may assign different meanings to the same non-standard character. -@item Using any non-standard character while expecting the implementation to treat some way - counts as such an assignment of meaning. -@item libraries need to document these assignments of meaning to non-standard characters. -@item free software libraries will register these changes on: - @url{http://www.cliki.net/Macro%20Characters} -@end itemize - -If you want to use readtable modifications that cannot abide by those restrictions, -you @emph{must} create a different readtable object and set @var{*readtable*} -to temporarily bind it to your new readtable (which will be undone after processing the file). - -For that, we recommend you use system @code{named-readtables} -to define or combine such readtables using @code{named-readtables:defreadtable} -and use them using @code{named-readtables:in-readtable}. -Equivalently, you can use system @code{cl-syntax}, -that itself uses @code{named-readtables}, -but may someday do more with, e.g. @var{*print-pprint-dispatch*}. - -For even more advanced syntax modification beyond what a readtable can express, -you may consider either: -@itemize -@item a @code{perform} method that compiles a constant file that contains a single form - @code{#.*code-read-with-alternate-reader*} in an environment where this special variable - was bound to the code read by your alternate reader, or -@item using the system @code{reader-interception}. -@end itemize - -Beware that @c unless and until the @code{syntax-control} branch is merged, -it is unsafe to use ASDF from the REPL to compile or load systems -while the readtable isn't the shared readtable previously used to build software. -You @emph{must} manually undo any binding of @var{*readtable*} at the REPL -and restore its initial value whenever you call @code{operate} -(via e.g. @code{load-system}, @code{test-system} or @code{require}) -from a REPL that is using a different readtable. - -@subsubsection How should my system use a readtable exported by another system? - -Use from the @code{named-readtables} system the macro @code{named-readtables:in-readtable}. - -If the other system fails to use @code{named-readtables}, fix it and send a patch upstream. -In the day and age of Quicklisp and clbuild, there is little reason -to eschew using such an important library anymore. - -@subsubsection How should my library make a readtable available to other systems? - -Use from the @code{named-readtables} system the macro @code{named-readtables:defreadtable}. - -@node ASDF development FAQs, , Issues with using and extending ASDF to define systems, FAQ -@section ASDF development FAQs - -@menu -* How do run the tests interactively in a REPL?:: -@end menu - -@node How do run the tests interactively in a REPL?, , ASDF development FAQs, ASDF development FAQs -@subsection How do run the tests interactively in a REPL? - -This not-so-frequently asked question is primarily for ASDF developers, -but those who encounter an unexpected error in some test may be -interested, too. - -Here's the procedure for experimenting with tests in a REPL: -@example -;; BEWARE! Some tests expect you to be in the .../asdf/test directory -;; If your REPL is not there yet, change your current directory: -;; under SLIME, you may: ,change-directory ~/common-lisp/asdf/test/ -;; otherwise you may evaluate something like: -(require "asdf") (asdf:upgrade-asdf) ;load UIOP & update asdf.lisp -(uiop:chdir (asdf:system-relative-pathname :asdf "test/")) -(setf *default-pathname-defaults* (uiop:getcwd)) - -;; Load the test script support. -(load "script-support.lisp") - -;; Initialize the script support. -;; This will also change your *package* to asdf-test. -;; NB: this function is also available from package cl-user, -;; and also available with the shorter name da in both packages. -(asdf-test::debug-asdf) - -;; In case you modified ASDF since you last tested it, -;; you need to update asdf.lisp itself by evaluating 'make' in a shell, -;; or (require "asdf") (asdf:load-system :asdf) in another CL REPL, -;; if not done in this REPL above. -;; *Then*, in this REPL, you need to evaluate: -;(asdf-test::compile-load-asdf) - -;; Now, you may experiment with test code from a .script file. -;; See the instructions given at the end of your failing test -;; to identify which form is needed, e.g. -(frob-packages) -(asdf::with-asdf-cache () (load "test-utilities.script")) -@end example - - -@comment FIXME: Add a FAQ about how to use a new system class... - -@comment node-name, next, previous, up -@node Ongoing Work, Bibliography, FAQ, Top -@unnumbered Ongoing Work -For an active list of things to be done, -see the @file{TODO} file in the source repository. - -Also, bugs are now tracked on launchpad: -@url{https://launchpad.net/asdf}. - -@node Bibliography, Concept Index, Ongoing Work, Top -@unnumbered Bibliography - -@itemize -@item Francois-Rene Rideau: - ``ASDF 3, or Why Lisp is Now an Acceptable Scripting Language'', 2014. - This article describes the innovations in ASDF 3 and 3.1, - as well as historical information on previous versions. - @url{http://github.com/fare/asdf3-2013} -@item Alastair Bridgewater: - ``Quick-build'' (private communication), 2012. - @code{quick-build} is a simple and robust one file, one package build system, - similar to @code{faslpath}, in 182 lines of code - (117 of which are not blank, not comments, not docstrings). - Unhappily, it remains unpublished and its IP status is unclear as of April 2014. - @code{asdf/package-system} is mostly compatible with it, - modulo a different setup for toplevel hierarchies. -@item Zach Beane: - ``Quicklisp'', 2011. - The Quicklisp blog and Xach's livejournal contain information on Quicklisp. - @url{http://blog.quicklisp.org/} - @url{http://xach.livejournal.com/} -@item Francois-Rene Rideau and Robert Goldman: - ``Evolving ASDF: More Cooperation, Less Coordination'', 2010. - This article describes the main issues solved by ASDF 2. - @url{http://common-lisp.net/project/asdf/doc/ilc2010draft.pdf} - @url{http://www.common-lisp.org/gitweb?p=projects/asdf/ilc2010.git} -@item Francois-Rene Rideau and Spencer Brody: - ``XCVB: an eXtensible Component Verifier and Builder for Common Lisp'', 2009. - This article describes XCVB, a proposed competitor for ASDF, - many ideas of which have been incorporated into ASDF 2 and 3, - though many other of which still haven't. - @url{http://common-lisp.net/projects/xcvb/} -@item Peter von Etter: - ``faslpath'', 2009. - @code{faslpath} is similar to the latter @code{quick-build} - and our letter @code{asdf/package-system} extension, - except that it uses the dot @code{.} rather than the slash @code{/} as a separator. - @url{https://code.google.com/p/faslpath/} -@item Drew McDermott: - ``A Framework for Maintaining the Coherence of a Running Lisp,'' - International Lisp Conference, 2005, available in pre-print form at - @url{http://www.cs.yale.edu/homes/dvm/papers/lisp05.pdf} -@item Dan Barlow: ``ASDF Manual'', 2004. - Older versions of this document from the days of ASDF 1; - they include ideas laid down by Dan Barlow, - and comparisons with older defsystems (@code{mk-defsystem}) - and defsystem (@code{defsystem-4}, kmp's Memo 801). -@item Marco Antoniotti and Peter Van Eynde: - ``@code{DEFSYSTEM}: A @code{make} for Common Lisp, A Thoughtful Re-Implementation of an Old Idea'', 2002. - The @file{defsystem-4} proposal available in the CLOCC repository. -@item Mark Kantrovitz: ``Defsystem: A Portable Make Facility for Common Lisp'', 1990. - The classic @file{mk-defsystem}, later variants of which - are available in the CLOCC repository as @code{defsystem-3.x}. -@item Richard Elliot Robbins: - ``BUILD: A Tool for Maintaining Consistency in Modular Systems'', MIT AI TR 874, 1985. - @url{ftp://publications.ai.mit.edu/ai-publications/pdf/AITR-874.pdf} -@item Kent M. Pitman (kmp): ``The Description of Large Systems'', MIT AI Memo 801, 1984. - Available in updated-for-CL form on the web at - @url{http://nhplace.com/kent/Papers/Large-Systems.html} -@item Dan Weinreb and David Moon: - ``Lisp Machine Manual'', MIT, 1981. - The famous CHINE NUAL describes one of the earliest variants of DEFSYSTEM. - @url{https://bitsavers.trailing-edge.com/pdf/mit/cadr/chinual_4thEd_Jul81.pdf} -@end itemize - - -@node Concept Index, Function and Class Index, Bibliography, Top -@unnumbered Concept Index - -@printindex cp - -@node Function and Class Index, Variable Index, Concept Index, Top -@unnumbered Function and Class Index - -@printindex fn - -@node Variable Index, , Function and Class Index, Top -@unnumbered Variable Index - -@printindex vr - -@bye - -@c LocalWords: clbuild tarballs defsystem Quicklisp initarg uiop fasl -@c LocalWords: namestring initargs fasls diff -Nru ecl-16.1.2/contrib/asdf/README.ECL ecl-16.1.3+ds/contrib/asdf/README.ECL --- ecl-16.1.2/contrib/asdf/README.ECL 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/contrib/asdf/README.ECL 2016-12-19 10:25:00.000000000 +0000 @@ -1,2 +1,6 @@ -The copies of asdf.lisp and README in this directory are complete and -unchanged from the canonical common-lisp.net repository. +See: https://gitlab.common-lisp.net/ecl/asdf + +Before upgrading to upstream ASDF version keep in mind that it removes +vital interface for ECL `make-build' and changes in the canonical +repository are unpredictible (both wrt release schedule, +deprecation/removal time and feature bloat). diff -Nru ecl-16.1.2/contrib/asdf/README.md ecl-16.1.3+ds/contrib/asdf/README.md --- ecl-16.1.2/contrib/asdf/README.md 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/contrib/asdf/README.md 1970-01-01 00:00:00.000000000 +0000 @@ -1,190 +0,0 @@ -ASDF: Another System Definition Facility -======================================== - -What is ASDF? -------------- - -ASDF is the de facto standard build facility for Common Lisp. -Your Lisp implementation probably contains a copy of ASDF, -which you can load using `(require "asdf")`. - -If you come from the C/C++ world, the function ASDF covers a bit of what -each of make, autoconf, dlopen and libc do for C programs: -it orchestrates the compilation and dependency management, -handles some of the portability issues, dynamically finds and loads code, -and offers some portable system access. -Except everything is different in Common Lisp, and ultimately much simpler, -though it requires acquiring some basic concepts. -Importantly, ASDF builds all software in the current Lisp image. - -To use ASDF, read our manual: - - http://common-lisp.net/project/asdf/asdf.html - -The first few sections, Loading ASDF, Configuring ASDF and Using ASDF, -will get you started as a simple user. -If you want to define your own systems, further read the section -Defining systems with defsystem. - -The manual is also in the doc/ subdirectory, and can be prepared with: - - make doc - - -ASDF 3 now includes an extensive runtime support library: -UIOP, the Utilities for Implementation- and OS- Portability. -Its documentation unhappily lies mainly in the source code and docstrings. -See [`uiop/README.md`](uiop/README.md) for an introduction. - -More information and additional links can be found on ASDF's home page at: - - http://common-lisp.net/project/asdf/ - - -Quick Start ------------ - -Just use `(require "asdf")` to load your implementation-provided ASDF. - -If it is recent enough (3.0 or later, check its `(asdf:asdf-version)`), -then it will automatically upgrade to the ASDF provided as source code, -assuming the source code in under a path registered by the source-registry. - - -Building and testing it ------------------------ - -First, make sure ASDF is checked out under a path registered by the source-registry, -if that isn't the case yet (see the manual). One place would be: - - ~/.local/share/common-lisp/source/asdf/ - -or, assuming your implementation provides ASDF 3.1 or later: - - ~/common-lisp/asdf/ - - -If you cloned our git repository, bootstrap a copy of build/asdf.lisp with: - - make - -Before you may run tests, you need a few CL libraries. -The simplest way to get them is as follows, but read below: - - make ext - -The above make target uses `git submodule update --init` to download -all these libraries using git. If you don't otherwise maintain your -own set of carefully controlled CL libraries, that's what you want to use. -However, if you do maintain your own set of carefully controlled CL libraries -then you will want to use whichever tools you use (e.g. quicklisp, clbuild, -or your own scripts around git) to download these libraries: -alexandria, closer-mop, cl-ppcre, fare-mop, fare-quasiquote, fare-utils, -inferior-shell, lisp-invocation, named-readtables, optima. - -If you are a CL developer, you may already have them, or may want -to use your own tools to download a version of them you control. -If you use Quicklisp, you may let Quicklisp download those you don't have. -In these cases, you do NOT want to use -However, if you want to let ASDF download known-working versions -of its dependencies, you can do it with: - - make ext - -To run all the tests on your favorite Lisp implementation $L, -choose your most elaborate installed system $S, and try: - - make t u l=$L s=$S - - -Debugging tip -------------- - -To load ASDF in such a way that M-. will work, install the source code, and run: - - (asdf:load-system :uiop) ;; loading uiop is simple - (map () 'load ;; loading asdf/defsystem is tricky - (mapcar 'asdf:component-pathname - (asdf::required-components :asdf/defsystem :keep-component 'asdf:cl-source-file))) - - -What has changed? ------------------ - -You can consult the `debian/changelog` for an overview of the -significant changes in each release, and -the `git log` for a detailed description of each commit. - - -How do I navigate this source directory? ----------------------------------------- - -* `asdf.asd` - * The system definition for building ASDF with ASDF. - -* `*.lisp` - * The source code files for asdf/defsystem. - See asdf.asd for the order in which they are loaded. - -* `uiop/` - * Utilities of Implementation- and OS- Portability, - the portability layer of ASDF. It has its own `README`, - and functions all have docstrings. - -* `Makefile` - * a minimal Makefile for bootstrapping purposes. - Most of the logic is in the asdf-tools system - -* `tools/` - * Some scripts to help ASDF users - * `load-asdf.lisp` -- a build script to load, configure and use ASDF - * `install-asdf.lisp` -- replace and update an implementation's ASDF - * `cl-source-registry-cache.lisp` -- update a cache for the source-registry - -* `build.xcvb` - * The system definition for building ASDF with XCVB. - It hasn't been tested or maintained for years and has bitrotten. - -* `version.lisp-expr` - * The current version. Bumped up every time the code changes, using: - - ./tools/asdf-builder bump - -* `doc/` - * documentation for ASDF, including: - * `index.html` -- the web page for http://common-lisp.net/project/asdf/ - * `asdf.texinfo` -- our manual - * `Makefile` -- how to build the manual - * `cclan.png` `lisp-logo120x80.png` `style.css` `favicon.ico` - -- auxiliaries of `index.html` - -* `test/` - * regression test scripts (and ancillary files) for developers to check - that they don't unintentionally break any of the functionality of ASDF. - Far from covering all of ASDF. - -* `contrib/` - * a few contributed files that show case how to use ASDF. - -* `debian/` - files for packaging on debian, ubuntu, etc. - -* `build/` - * where the Makefile and asdf-tools store their output files, including - * `asdf.lisp` -- the current one-file deliverable of ASDF - * `asdf-XXX.lisp` -- for upgrade test purposes, old versions - * `results/` -- logs of tests that have been run - * `fasls/` -- output files while running tests. - -* `ext/` - * external dependencies, that can be populated with `make ext` - or equivalently with `git submodule update --init`. - -* `README` - * this file - -* `TODO` - * plenty of ideas for how to further improve ASDF. - - -Last updated Thursday, September 11th, 2014. diff -Nru ecl-16.1.2/contrib/package-locks/package-locks.lisp ecl-16.1.3+ds/contrib/package-locks/package-locks.lisp --- ecl-16.1.2/contrib/package-locks/package-locks.lisp 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/contrib/package-locks/package-locks.lisp 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,58 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 2016 Daniel Kochmańskin +;;;; +;;;; See file 'LICENSE' for the copyright details. + +;;;; PACKAGE-LOCKS Convenient interface for package-locks mechanism. + +(in-package "EXT") + + +;;; Package locks +(pushnew :package-locks *features*) + +(defun lock-package (package &aux (package (si:coerce-to-package package))) + (ffi:c-inline (package) (:object) :void + "(#0)->pack.locked = 1" + :side-effects t + :one-liner t) + T) + +(defun unlock-package (package &aux (package (si:coerce-to-package package))) + (ffi:c-inline (package) (:object) :void + "(#0)->pack.locked = 0" + :side-effects t + :one-liner t) + T) + +(defun package-locked-p (package &aux (package (si:coerce-to-package package))) + "Returns T when PACKAGE is locked, NIL otherwise. Signals an error +if PACKAGE doesn't designate a valid package." + (ffi:c-inline (package) (:object) :object + "(#0)->pack.locked ? ECL_T : ECL_NIL" + :side-effects nil + :one-liner t)) + +(defmacro without-package-locks (&body body) + "Ignores all runtime package lock violations during the execution of +body. Body can begin with declarations." + `(let ((si::*ignore-package-locks* t)) ,@body)) + +(defmacro with-unlocked-packages ((&rest packages) &body forms) + "Unlocks PACKAGES for the dynamic scope of the body. Signals an +error if any of PACKAGES is not a valid package designator." + (with-unique-names (unlocked-packages) + `(let (,unlocked-packages) + (unwind-protect + (progn + (dolist (p ',packages) + (when (package-locked-p p) + (push p ,unlocked-packages) + (unlock-package p))) + ,@forms) + (dolist (p ,unlocked-packages) + (when (find-package p) + (lock-package p))))))) + +(provide '#:package-locks) diff -Nru ecl-16.1.2/contrib/profile/profile.lisp ecl-16.1.3+ds/contrib/profile/profile.lisp --- ecl-16.1.2/contrib/profile/profile.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/contrib/profile/profile.lisp 2016-12-19 10:25:00.000000000 +0000 @@ -246,10 +246,6 @@ (dolist (name names) (etypecase name (symbol (funcall function name)) - (list - (legal-fun-name-or-type-error name) - ;; Then we map onto it. - (funcall function name)) (string (let ((package (si:coerce-to-package name))) (do-symbols (symbol package) (when (eq (symbol-package symbol) package) @@ -259,7 +255,8 @@ (funcall function symbol)) (let ((setf-name `(setf ,symbol))) (when (fboundp setf-name) - (funcall function setf-name))))))))) + (funcall function setf-name))))))) + (t (warn "ignoring invalid argument: ~S" name)))) (values)) ;;; Profile the named function, which should exist and not be profiled diff -Nru ecl-16.1.2/contrib/sockets/sockets.lisp ecl-16.1.3+ds/contrib/sockets/sockets.lisp --- ecl-16.1.2/contrib/sockets/sockets.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/contrib/sockets/sockets.lisp 2016-12-19 10:25:00.000000000 +0000 @@ -107,7 +107,7 @@ (define-c-constants +af-inet+ "AF_INET" - +af-local+ #-sun4sol2 "AF_LOCAL" #+sun4sol2 "AF_UNIX" + +af-local+ #-(or sun4sol2 aix) "AF_LOCAL" #+(or sun4sol2 aix) "AF_UNIX" +eagain+ "EAGAIN" +eintr+ "EINTR") @@ -1429,6 +1429,19 @@ "#define NETDB_INTERNAL WSAEAFNOSUPPORT" "#define NETDB_SUCCESS 0" ) + +#+:haiku +(clines + "#define ESOCKTNOSUPPORT ENOTSUP") + +(Clines + "#ifndef NETDB_INTERNAL" + "#define NETDB_INTERNAL 0" + "#endif" + "#ifndef NETDB_SUCCESS" + "#define NETDB_SUCCESS 0" + "#endif") + (define-socket-condition EADDRINUSE address-in-use-error) (define-socket-condition EAGAIN interrupted-error) (define-socket-condition EBADF bad-file-descriptor-error) diff -Nru ecl-16.1.2/COPYING ecl-16.1.3+ds/COPYING --- ecl-16.1.2/COPYING 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/COPYING 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,481 @@ + GNU LIBRARY GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1991 Free Software Foundation, Inc. + 675 Mass Ave, Cambridge, MA 02139, USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the library GPL. It is + numbered 2 because it goes with version 2 of the ordinary GPL.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Library General Public License, applies to some +specially designated Free Software Foundation software, and to any +other libraries whose authors decide to use it. You can use it for +your libraries, 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 library, or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link a program with the library, you must provide +complete object files to the recipients so that they can relink them +with the library, after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + Our method of protecting your rights has two steps: (1) copyright +the library, and (2) offer you this license which gives you legal +permission to copy, distribute and/or modify the library. + + Also, for each distributor's protection, we want to make certain +that everyone understands that there is no warranty for this free +library. If the library is modified by someone else and passed on, we +want its recipients to know that what they have is not the original +version, 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 companies distributing free +software will individually obtain patent licenses, thus in effect +transforming the program into proprietary software. To prevent this, +we have made it clear that any patent must be licensed for everyone's +free use or not licensed at all. + + Most GNU software, including some libraries, is covered by the ordinary +GNU General Public License, which was designed for utility programs. This +license, the GNU Library General Public License, applies to certain +designated libraries. This license is quite different from the ordinary +one; be sure to read it in full, and don't assume that anything in it is +the same as in the ordinary license. + + The reason we have a separate public license for some libraries is that +they blur the distinction we usually make between modifying or adding to a +program and simply using it. Linking a program with a library, without +changing the library, is in some sense simply using the library, and is +analogous to running a utility program or application program. However, in +a textual and legal sense, the linked executable is a combined work, a +derivative of the original library, and the ordinary General Public License +treats it as such. + + Because of this blurred distinction, using the ordinary General +Public License for libraries did not effectively promote software +sharing, because most developers did not use the libraries. We +concluded that weaker conditions might promote sharing better. + + However, unrestricted linking of non-free programs would deprive the +users of those programs of all benefit from the free status of the +libraries themselves. This Library General Public License is intended to +permit developers of non-free programs to use free libraries, while +preserving your freedom as a user of such programs to change the free +libraries that are incorporated in them. (We have not seen how to achieve +this as regards changes in header files, but we have achieved it as regards +changes in the actual functions of the Library.) The hope is that this +will lead to faster development of free libraries. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, while the latter only +works together with the library. + + Note that it is possible for a library to be covered by the ordinary +General Public License rather than by this special one. + + GNU LIBRARY GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library which +contains a notice placed by the copyright holder or other authorized +party saying it may be distributed under the terms of this Library +General Public License (also called "this License"). Each licensee is +addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, 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 library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete 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 distribute a copy of this License along with the +Library. + + 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 Library or any portion +of it, thus forming a work based on the Library, 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) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +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 Library, 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 Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you 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. + + If distribution of 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 satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also compile or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + c) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + d) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. 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. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library 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. + + 9. 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 Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +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. + + 11. 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 Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library 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 Library. + +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. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library 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. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Library 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 Library +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 Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +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 + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "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 +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. 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 LIBRARY 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 +LIBRARY (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 LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + Appendix: How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. 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) + + This 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. + + This 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 this library; if not, write to the Free + Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! diff -Nru ecl-16.1.2/debian/changelog ecl-16.1.3+ds/debian/changelog --- ecl-16.1.2/debian/changelog 2018-10-28 13:18:20.000000000 +0000 +++ ecl-16.1.3+ds/debian/changelog 2019-01-16 16:50:23.000000000 +0000 @@ -1,3 +1,23 @@ +ecl (16.1.3+ds-2) unstable; urgency=medium + + * Upload to unstable. + + -- Tobias Hansen Wed, 16 Jan 2019 17:50:23 +0100 + +ecl (16.1.3+ds-1) experimental; urgency=medium + + * Team upload + * New upstream release. + Strip off embedded code copies of GMP, libffi and boehm GC, to make sure + that we use the system versions, and to simplify copyright/license + tracking. + * no-embedded-copies.patch: new patch, fixes minor issues related to the + removal of embedded copies. + * Rewrite d/copyright using machine-readable format 1.0 + * Tarball is now automatically repackaged by uscan + + -- Sébastien Villemot Tue, 30 Oct 2018 12:05:59 +0100 + ecl (16.1.2-5) unstable; urgency=medium * Team upload diff -Nru ecl-16.1.2/debian/copyright ecl-16.1.3+ds/debian/copyright --- ecl-16.1.2/debian/copyright 2018-04-10 12:06:28.000000000 +0000 +++ ecl-16.1.3+ds/debian/copyright 2019-01-16 11:19:19.000000000 +0000 @@ -1,65 +1,329 @@ -This package was debianized by Peter Van Eynde on -Mon, 12 Dec 2005 21:54:01 +0100. +Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ +Upstream-Name: ECL +Upstream-Contact: ecl-devel@common-lisp.net +Source: https://common-lisp.net/project/ecl/ +Files-Excluded: src/gmp src/libffi src/bdwgc + +Files: * +Copyright: 1984 Taiichi Yuasa and Masami Hagiya + 1990, 1991, 1993 Giuseppe Attardi + 2000-2012, Juan Jose Garcia Ripoll + 2015-2016, Daniel Kochmański +License: GPL-2+ + +Files: contrib/asdf/* +Copyright: 2001-2016, Daniel Barlow and contributors +License: Expat + +Files: contrib/cl-simd/* +Copyright: 2010, Alexander Gavrilov (angavrilov@gmail.com) +License: Expat + +Files: contrib/deflate/* +Copyright: 2000-2010, PMSF IT Consulting Pierre R. Mai. +License: Expat + +Files: contrib/defsystem/* +Copyright: 1989 - 1999 Mark Kantrowitz + 1999 - 2005 Mark Kantrowitz and Marco Antoniotti +License: permissive-defsystem + Use, copying, modification, merging, publishing, distribution + and/or sale of this software, source and/or binary files and + associated documentation files (the "Software") and of derivative + works based upon this Software are permitted, as long as the + following conditions are met: + . + o this copyright notice is included intact and is prominently + visible in the Software + o if modifications have been made to the source code of the + this package that have not been adopted for inclusion in the + official version of the Software as maintained by the Copyright + holders, then the modified package MUST CLEARLY identify that + such package is a non-standard and non-official version of + the Software. Furthermore, it is strongly encouraged that any + modifications made to the Software be sent via e-mail to the + MK-DEFSYSTEM maintainers for consideration of inclusion in the + official MK-DEFSYSTEM package. + . + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NON-INFRINGEMENT. + IN NO EVENT SHALL M. KANTROWITZ AND M. ANTONIOTTI BE LIABLE FOR ANY + CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, + TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE + SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + . + Except as contained in this notice, the names of M. Kantrowitz and + M. Antoniotti shall not be used in advertising or otherwise to promote + the sale, use or other dealings in this Software without prior written + authorization from M. Kantrowitz and M. Antoniotti. + +Files: contrib/ecl-curl/* +Copyright: 2011, Juan Jose Garcia-Ripoll +License: BSD-2-clause + +Files: contrib/encodings/* +Copyright: 2005, 2009, 2011, Juan Jose Garcia-Ripoll +License: LGPL-2+ + +Files: contrib/profile/* +Copyright: none +License: public-domain + +Files: contrib/quicklisp/* +Copyright: 2011 Zachary Beane +License: Expat + +Files: contrib/rt/* +Copyright: 1990, the Massachusetts Institute of Technology, Cambridge MA. | +License: NTP~disclaimer + Permission to use, copy, modify, and distribute this software and its + documentation for any purpose and without fee is hereby granted, provided + that this copyright and permission notice appear in all copies and + supporting documentation, and that the name of M.I.T. not be used in + advertising or publicity pertaining to distribution of the software + without specific, written prior permission. M.I.T. makes no + representations about the suitability of this software for any purpose. + It is provided "as is" without express or implied warranty. + . + M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING + ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL + M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR + ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, + WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, + ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS + SOFTWARE. + +Files: contrib/sockets/* +Copyright: none +License: public-domain + +Files: contrib/win32/txtedit.lisp + contrib/win32/win32.lisp +Copyright: 2005, Michael Goffioul (michael dot goffioul at swing dot be) +License: LGPL-2+ + +Files: examples/* +Copyright: 2001, 2005, 2006, 2010, 2011, Juan Jose Garcia Ripoll. +License: BSD-2-clause + +Files: examples/build/* +Copyright: 2001, 2005, 2006, 2010, 2011, Juan Jose Garcia Ripoll. +License: LGPL-2+ + +Files: examples/threads/* +Copyright: 2001, 2005, 2006, 2010, 2011, Juan Jose Garcia Ripoll. +License: LGPL-2+ + +Files: msvc/gmp/* +Copyright: 1989-2005, Free Software Foundation, Inc. +License: LGPL-2.1+ + +Files: msvc/gmp/build.vc8/unistd.h +Copyright: 1984 Taiichi Yuasa and Masami Hagiya + 1990, 1991, 1993 Giuseppe Attardi + 2000, Juan Jose Garcia Ripoll + 2015, Daniel Kochmański +License: GPL-2+ + +Files: src/c/arch/* + src/c/printer/integer_to_string.d + src/c/unixint.d + src/cmp/cmplet.lsp + src/h/cache.h + src/h/config.h.in + src/h/cons.h + src/h/internal.h + src/h/legacy.h + src/h/cs.h + src/h/number.h + src/h/page.h + src/h/ecl-cmp.h + src/h/ecl.h + src/h/impl/* + src/h/object.h + src/h/stacks.h +Copyright: 1984, Taiichi Yuasa and Masami Hagiya. + 1990, 1995, Giuseppe Attardi. + 2001-2011, Juan Jose Garcia Ripoll. + 2016, Daniel Kochmański. +License: LGPL-2+ + +Files: src/clos/walk.lsp +Copyright: 1985-1990, Xerox Corporation. +License: GPL-2+ + +Files: src/configure +Copyright: 1992-1996, 1998-2012, Free Software Foundation, Inc. +License: FSFUL + +Files: src/doc/new-doc/* +Copyright: 2002-2003 Kevin M. Rosenberg + 2006 Juan José García-Ripoll + 2016 Daniel Kochmański +License: GFDL-NIV-1.3+ +Comment: + See src/doc/new-doc/introduction/copyrights.txi + +Files: src/lsp/defpackage.lsp +Copyright: 1990, 1991, The Boeing Company +License: NTP-defpackage + Permission is granted to any individual or institution to use, + copy, modify, and distribute this software, provided that this + complete copyright and permission notice is maintained, intact, in + all copies and supporting documentation and that modifications are + appropriately documented with date, author and description of the + change. + . + Stephen L. Nicoud (snicoud@boeing.com) provides this software "as + is" without express or implied warranty by him or The Boeing + Company. + . + This software is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY. No author or distributor accepts + responsibility to anyone for the consequences of using it or for + whether it serves any particular purpose or works at all. + +Files: src/lsp/format.lsp + src/lsp/pprint.lsp +Copyright: none +License: public-domain + +Files: src/lsp/loop.lsp +Copyright: 1986 by the Massachusetts Institute of Technology + 1989, 1990, 1991, 1992 by Symbolics +License: NTP-loop + Permission to use, copy, modify and distribute this software and its + documentation for any purpose and without fee is hereby granted, + provided that the M.I.T. copyright notice appear in all copies and that + both that copyright notice and this permission notice appear in + supporting documentation. The names "M.I.T." and "Massachusetts + Institute of Technology" may not be used in advertising or publicity + pertaining to distribution of the software without specific, written + prior permission. Notice must be given in supporting documentation that + copying distribution is by permission of M.I.T. M.I.T. makes no + representations about the suitability of this software for any purpose. + It is provided "as is" without express or implied warranty. + . + Permission to use, copy, modify and distribute this software and its + documentation for any purpose and without fee is hereby granted, + provided that the Symbolics copyright notice appear in all copies and + that both that copyright notice and this permission notice appear in + supporting documentation. The name "Symbolics" may not be used in + advertising or publicity pertaining to distribution of the software + without specific, written prior permission. Notice must be given in + supporting documentation that copying distribution is by permission of + Symbolics. Symbolics makes no representations about the suitability of + this software for any purpose. It is provided "as is" without express + or implied warranty. + . + Symbolics, CLOE Runtime, and Minima are trademarks, and CLOE, Genera, + and Zetalisp are registered trademarks of Symbolics, Inc. + +Files: src/tests/1am.lisp + src/tests/2am.lisp +Copyright: 2014-2016, James M. Lawrence +License: Expat + +Files: debian/* +Copyright: 2005-2011 Peter Van Eynde + 2008 Luca Capello + 2011-2015 Christoph Egger + 2015-2017 Tobias Hansen + 2018 Sébastien Villemot +License: LGPL-2+ + +License: BSD-2-clause + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are + met: + . + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + . + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials + provided with the distribution. + . + THIS SOFTWARE IS PROVIDED BY THE AUTHORS 'AS IS' AND ANY EXPRESSED OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, + INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING + IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + +License: Expat + 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 AUTHORS OR COPYRIGHT HOLDERS BE + LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, + TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN + CONNECTION WITH THE SOFTWARE OR THE USE OR + OTHER DEALINGS IN THE SOFTWARE. + +License: FSFUL + This configure script is free software; the Free Software Foundation + gives unlimited permission to copy, distribute and modify it. + +License: GFDL-NIV-1.3+ + Permission is granted to copy, distribute and/or modify this document + under the terms of the GNU Free Documentation License, Version 1.3 or + any later version published by the Free Software Foundation; with no + Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. + . + On Debian systems, the complete text of the GNU Free Documentation + License, version 1.3, can be found in the file + `/usr/share/common-licenses/GFDL-1.3'. + +License: GPL-2+ + 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; version 2 dated June, 1991, or (at + your option) any later version. + . + On Debian systems, the complete text of version 2 of the GNU General + Public License can be found in '/usr/share/common-licenses/GPL-2'. + +License: LGPL-2+ + This program 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; version 2 of the License, or (at + your option) any later version. + . + On Debian systems, the complete text of version 2 of the GNU Library + General Public License can be found in '/usr/share/common-licenses/LGPL-2'. + +License: LGPL-2.1+ + This program is free software; you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published by the + Free Software Foundation; version 2.1 of the License, or (at + your option) any later version. + . + On Debian systems, the complete text of version 2.1 of the GNU Lesser + General Public License can be found in '/usr/share/common-licenses/LGPL-2.1'. -It was downloaded from https://common-lisp.net/project/ecl/ - -Upstream Author: Juan Jose Garcia Ripoll ecls-list@lists.sourceforge.net - -Copyright: - - Copyright (c) 2000, Juan Jose Garcia Ripoll - Copyright (c) 1990, 1991, 1993 Giuseppe Attardi - Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya - All Rights Reserved - - Distributed under the terms of the GNU Library General Public Licence. - See /usr/share/common-licenses/LGPL-2 - -Some files are not under the LGPL: - -- src/lsp/loop2.lsp -- src/clx -- contrib/asdf -- contrib/rt: MIT-like licenses - -- src/lsp/pprint.lsp -- src/lsp/format.lsp -- contrib/sockets: in the public domain - -- contrib/defsystem: a special case, mostly MIT-like: -;;; MK:DEFSYSTEM 3.6 Interim -;;; -;;; Copyright (c) 1989 - 1999 Mark Kantrowitz. All rights reserved. -;;; 1999 - 2005 Mark Kantrowitz and Marco Antoniotti. All -;;; rights reserved. - -;;; Use, copying, modification, merging, publishing, distribution -;;; and/or sale of this software, source and/or binary files and -;;; associated documentation files (the "Software") and of derivative -;;; works based upon this Software are permitted, as long as the -;;; following conditions are met: - -;;; o this copyright notice is included intact and is prominently -;;; visible in the Software -;;; o if modifications have been made to the source code of the -;;; this package that have not been adopted for inclusion in the -;;; official version of the Software as maintained by the Copyright -;;; holders, then the modified package MUST CLEARLY identify that -;;; such package is a non-standard and non-official version of -;;; the Software. Furthermore, it is strongly encouraged that any -;;; modifications made to the Software be sent via e-mail to the -;;; MK-DEFSYSTEM maintainers for consideration of inclusion in the -;;; official MK-DEFSYSTEM package. - -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;;; EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NON-INFRINGEMENT. -;;; IN NO EVENT SHALL M. KANTROWITZ AND M. ANTONIOTTI BE LIABLE FOR ANY -;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, -;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE -;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - -;;; Except as contained in this notice, the names of M. Kantrowitz and -;;; M. Antoniotti shall not be used in advertising or otherwise to promote -;;; the sale, use or other dealings in this Software without prior written -;;; authorization from M. Kantrowitz and M. Antoniotti. +License: public-domain + This program is placed in the public domain. diff -Nru ecl-16.1.2/debian/ecl.lintian-overrides ecl-16.1.3+ds/debian/ecl.lintian-overrides --- ecl-16.1.2/debian/ecl.lintian-overrides 2018-10-28 13:18:16.000000000 +0000 +++ ecl-16.1.3+ds/debian/ecl.lintian-overrides 2019-01-16 11:19:19.000000000 +0000 @@ -1,2 +1,2 @@ -ecl: package-name-doesnt-match-sonames libecl16.1 -ecl: non-dev-pkg-with-shlib-symlink usr/lib/*/libecl.so.16.1.2 usr/lib/*/libecl.so +ecl: package-name-doesnt-match-sonames libecl* +ecl: non-dev-pkg-with-shlib-symlink usr/lib/*/libecl.so.* usr/lib/*/libecl.so diff -Nru ecl-16.1.2/debian/patches/format-security.patch ecl-16.1.3+ds/debian/patches/format-security.patch --- ecl-16.1.2/debian/patches/format-security.patch 2018-10-28 13:18:13.000000000 +0000 +++ ecl-16.1.3+ds/debian/patches/format-security.patch 2019-01-16 11:19:19.000000000 +0000 @@ -5,12 +5,13 @@ Author: Sébastien Villemot Bug-Debian: https://bugs.debian.org/714308 Forwarded: https://gitlab.com/embeddable-common-lisp/ecl/merge_requests/124 +Applied-Upstream: 16.2.0 Last-Update: 2018-10-28 --- This patch header follows DEP-3: http://dep.debian.net/deps/dep3/ --- a/src/aclocal.m4 +++ b/src/aclocal.m4 -@@ -762,7 +762,7 @@ int main() { +@@ -782,7 +782,7 @@ int main() { fclose(f); f = fopen("conftestval","w"); if (f == NULL) exit(1); diff -Nru ecl-16.1.2/debian/patches/no-embedded-copies.patch ecl-16.1.3+ds/debian/patches/no-embedded-copies.patch --- ecl-16.1.2/debian/patches/no-embedded-copies.patch 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/debian/patches/no-embedded-copies.patch 2019-01-16 11:19:19.000000000 +0000 @@ -0,0 +1,29 @@ +Description: Do not rely on embedded code copies + GMP, libffi and boehm GC are stripped off the Debian source package. Ensure + that everything goes smoothly in that context. +Author: Sébastien Villemot +Forwarded: not-needed +Last-Update: 2018-10-29 +--- +This patch header follows DEP-3: http://dep.debian.net/deps/dep3/ +--- a/src/configure.ac ++++ b/src/configure.ac +@@ -11,7 +11,6 @@ dnl + AC_INIT([ecl],[16.1.3],[]) + AC_REVISION([$Revision$]) + AC_CONFIG_SRCDIR([bare.lsp.in]) +-AC_CONFIG_AUX_DIR([gmp]) + AC_PREREQ(2.69) + + dnl ----------------------------------------------------------------------- +--- a/src/Makefile.in ++++ b/src/Makefile.in +@@ -67,7 +67,7 @@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ + INSTALL_SCRIPT = @INSTALL_SCRIPT@ + INSTALL_LIBRARY = $(INSTALL_SCRIPT) + INSTALL_DATA = @INSTALL_DATA@ +-mkinstalldirs = $(top_srcdir)/bdwgc/install-sh -d ++mkinstalldirs = $(top_srcdir)/install.sh -d + + # Files + diff -Nru ecl-16.1.2/debian/patches/patch-hurd.patch ecl-16.1.3+ds/debian/patches/patch-hurd.patch --- ecl-16.1.2/debian/patches/patch-hurd.patch 2018-04-10 11:50:41.000000000 +0000 +++ ecl-16.1.3+ds/debian/patches/patch-hurd.patch 2019-01-16 11:19:19.000000000 +0000 @@ -1,6 +1,6 @@ --- a/src/c/unixint.d +++ b/src/c/unixint.d -@@ -1333,6 +1333,8 @@ +@@ -1329,6 +1329,8 @@ install_synchronous_signal_handlers() */ #ifdef SIGRTMIN # define DEFAULT_THREAD_INTERRUPT_SIGNAL SIGRTMIN + 2 diff -Nru ecl-16.1.2/debian/patches/series ecl-16.1.3+ds/debian/patches/series --- ecl-16.1.2/debian/patches/series 2018-10-28 13:17:54.000000000 +0000 +++ ecl-16.1.3+ds/debian/patches/series 2019-01-16 11:19:19.000000000 +0000 @@ -1,3 +1,4 @@ harden-configure.patch patch-hurd.patch format-security.patch +no-embedded-copies.patch diff -Nru ecl-16.1.2/debian/rules ecl-16.1.3+ds/debian/rules --- ecl-16.1.2/debian/rules 2018-10-28 13:18:16.000000000 +0000 +++ ecl-16.1.3+ds/debian/rules 2019-01-16 11:19:19.000000000 +0000 @@ -12,9 +12,8 @@ touch src/configure configure dh_auto_configure -- \ - --with-system-gmp=yes \ + --enable-gmp=system \ --with-tcp \ - --with-clx \ --enable-threads=yes \ --enable-boehm=system \ --enable-libatomic=system \ diff -Nru ecl-16.1.2/debian/watch ecl-16.1.3+ds/debian/watch --- ecl-16.1.2/debian/watch 2018-04-10 12:06:25.000000000 +0000 +++ ecl-16.1.3+ds/debian/watch 2019-01-16 11:19:19.000000000 +0000 @@ -1,3 +1,3 @@ version=4 -opts="filenamemangle=s%ecl@ANY_VERSION@\.tgz%ecl-$1.tar.gz%" \ +opts="filenamemangle=s%ecl@ANY_VERSION@\.tgz%ecl-$1.tar.gz%,dversionmangle=s/\+ds\d*$// ,repacksuffix=+ds" \ https://common-lisp.net/project/ecl/static/files/release/ecl@ANY_VERSION@(?:@ARCHIVE_EXT@|\.tgz) diff -Nru ecl-16.1.2/doc/ansi_packages.xml ecl-16.1.3+ds/doc/ansi_packages.xml --- ecl-16.1.2/doc/ansi_packages.xml 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/doc/ansi_packages.xml 2016-12-19 10:25:00.000000000 +0000 @@ -56,12 +56,6 @@ The compiler - XLIB - CLX - XLIB - CLX library for X-Windows - - SB-BSD-SOCKETS SOCKETS @@ -86,12 +80,11 @@ In we list all packages available in &ECL;. The nicknames are aliases for a package. Thus, system:symbol may be written as - sys:symbol or si:symbol. The module field - explains which library provides what package. For instance, the + sys:symbol or si:symbol. The module + field explains which library provides what package. For instance, the ASDF is obtained when loading the - ASDF library with (require 'asdf); and the - XLIB package when configuring and loading the - CLX library. + ASDF library with (require + 'asdf). diff -Nru ecl-16.1.2/doc/copyright.xmlf ecl-16.1.3+ds/doc/copyright.xmlf --- ecl-16.1.2/doc/copyright.xmlf 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/doc/copyright.xmlf 2016-12-19 10:25:00.000000000 +0000 @@ -26,12 +26,11 @@ PLEASE NOTE THAT: This license covers all of the ECL program except for the files - src/lsp/loop2.lsp ; Symbolic's LOOP macro + src/lsp/loop.lsp ; Symbolic's LOOP macro src/lsp/pprint.lsp ; CMUCL's pretty printer src/lsp/format.lsp ; CMUCL's format and the directories contrib/ ; User contributed extensions - src/clx/ ; portable CLX library from Telent Look the precise copyright of these extensions in the corresponding files. diff -Nru ecl-16.1.2/doc/ffi.xmlf ecl-16.1.3+ds/doc/ffi.xmlf --- ecl-16.1.2/doc/ffi.xmlf 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/doc/ffi.xmlf 2016-12-19 10:25:00.000000000 +0000 @@ -80,8 +80,13 @@ a little piece of assembly code does the job of translating the lisp data into foreign objects, storing the arguments in the stack and in CPU registers, calling the function and converting back the output of the - function to lisp. + function to lisp. + + &ECL; for this purpose utilizes the library "A Portable Foreign + Function Interface Library" commonly known as libffi. + @@ -103,46 +108,19 @@ On the other hand, the dynamic approach allows us to choose the libraries we load at any time, look for the functions and invoke them even - from the toplevel, but it relies on unportable techniques and requires from - us, the developers of &ECL;, to know very well both the assembly code of the - machine &ECL; runs on and the calling conventions of that particular - operating system. + from the toplevel, but it relies on unportable techniques and requires the + developers to know very well both the assembly code of the machine the code + runs on and the calling conventions of that particular operating system. For + these reasons &ECL; doesn't maintain it's own implementation of the DFFI but + rather relies on the third party library. &ECL; currently supports the static method on all platforms, and the - dynamical one a few of the most popular ones, shown in . You can test if your copy of &ECL; was built with - DFFI by inspecting whether the symbol :DFFI is present in - the list from variable *FEATURES*. - - - DFFI support - - - - Architecture - Support - Operating systems - - - - - Intel x86 32 bits - Complete - Any with SysV ABI (Linux, BSD), Windows, OS X - - - Intel x86 64 bits - In progress - SysV ABI - - - PowerPC 32 bits - In progress - OS X - - - -
+ dynamical one a wide range of the most popular ones, shown in libffi. You can test if your + copy of &ECL; was built with DFFI by inspecting whether the symbol + :DFFI is present in the list from variable + *FEATURES*. +
@@ -170,7 +148,7 @@ The most important component of the object is the memory region where data is stored. By default &ECL; assumes that the user will perform automatic - managment of this memory, deleting the object when it is no longer + management of this memory, deleting the object when it is no longer needed. The first reason is that this block may have been allocated by a foreign routine using malloc(), or mmap(), or statically, by referring to a C constant. The @@ -219,7 +197,7 @@ &ECL;'s own low level interface. Only to be used if &ECL; is your deployment platform. It features some powerful constructs that allow you to - merge arbitrary C code with lisp ( and and ). @@ -305,7 +283,7 @@ ;; (let ((c-cos (cffi:foreign-funcall "cos" :double 1.0d0 :double))) (format t "~%Lisp cos:~t~d~%C cos:~t~d~%Difference:~t~d" - (sin 1.0d0) c-sin (- (sin 1.0d0) c-sin))) + (cos 1.0d0) c-cos (- (cos 1.0d0) c-cos)))
diff -Nru ecl-16.1.2/doc/intro.xmlf ecl-16.1.3+ds/doc/intro.xmlf --- ecl-16.1.2/doc/intro.xmlf 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/doc/intro.xmlf 2016-12-19 10:25:00.000000000 +0000 @@ -219,7 +219,7 @@ Prepare a directory (hereafter called ECL directory) for ECL. In the following examples, we suppose that the ECL - directory is /usr/local/ecl. + directory is /usr/local/bin/ecl. Extract the content from the compressed tar file. @@ -232,7 +232,7 @@ $ ./configure This example will prepare to install executable files, manual pages and info files in standard directories like /usr/local/bin, - /usr/local/man/man1, /usr/local/info. + /usr/local/share/man/man1. If you don't have access rights to these directories, you should diff -Nru ecl-16.1.2/doc/Makefile ecl-16.1.3+ds/doc/Makefile --- ecl-16.1.2/doc/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/doc/Makefile 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,64 @@ +XMLTO = xmlto +XSLTPROC = xsltproc + +GEN_XMLFILES= tmp/COPYING.GFDL.xml +XMLFILES= ecl.xml bibliography.xmlf clos.xmlf compiler.xmlf \ + declarations.xmlf ecldev.xmlf \ + internals.xmlf interpreter.xmlf preface.xmlf \ + io.xmlf mp.xmlf asdf.xmlf os.xmlf pde.xmlf \ + copyright.xmlf ffi.xmlf ref_os.xmlf \ + uffi/ref_primitive.xml uffi/ref_aggregate.xml uffi/ref_object.xml \ + uffi/ref_string.xml uffi/ref_func_libr.xml \ + mp.xmlf ref_mp.xmlf memory.xmlf ref_memory.xmlf \ + mop.xmlf embed.xmlf ref_embed.xmlf signals.xmlf \ + ansi_arrays.xml ansi_overview.xml \ + ansi_characters.xml ansi_packages.xml ansi_conses.xml \ + ansi_printer.xml ansi_data_flow.xml ansi_reader.xml \ + ansi_environment.xml ansi_sequences.xml ansi_evaluation.xml \ + ansi_streams.xml ansi_filenames.xml ansi_strings.xml \ + ansi_files.xml ansi_structures.xml ansi_hash_tables.xml \ + ansi_symbols.xml ansi_numbers.xml ansi_system_construction.xml \ + ansi_objects.xml ansi_types.xml \ + ref_c_evaluation.xml ref_c_data_flow.xml ref_c_symbols.xml \ + ref_c_numbers.xml ref_c_characters.xml ref_c_strings.xml \ + ref_c_conses.xml ref_c_hash_tables.xml ref_c_sequences.xml \ + ref_c_filenames.xml ref_c_packages.xml ref_c_printer.xml \ + ref_c_system_construction.xml ref_c_environment.xml \ + ref_c_objects.xml ref_c_conditions.xml ref_c_structures.xml \ + ref_signals.xmlf ref_c_arrays.xml $(GEN_XMLFILES) + +HTML_XSLFILES= xsl/customization.xml xsl/lispfunc.xml xsl/refentryintoc.xml +PDF_XSLFILES= xsl/customization.xml xsl/lispfunc-po.xml + +all: html/ecl.css + +ecl2.xml: $(XMLFILES) xsl/add_indexterm.xml + @test -d html || mkdir html + $(XSLTPROC) --xinclude xsl/add_indexterm.xml ecl.xml | \ + sed 's, xmlns="",,g;s,—,,g;' > ecl2.xml +html/index.html: ecl2.xml $(HTML_XSLFILES) + $(XMLTO) -vv --skip-validation $(subst xsl, -m xsl,$(HTML_XSLFILES)) -o html html ecl2.xml + cp ecl.css html/ +html/ecl.css: ecl.css html/index.html + cp ecl.css html/ + @test -d html/figures || mkdir html/figures + cp figures/*.png html/figures/ +ecl.pdf: ecl2.xml $(PDF_XSLFILES) + -mkdir tex + dblatex -V -d --tmpdir=tex -P latex.encoding=utf8 ecl2.xml + mv ecl2.pdf $@ + +tmp/ecl.ent: ecl.ent + cp $< $@ + +tmp/COPYING.GFDL.xml: COPYING.GFDL Makefile + echo ' $@ + cat $< >> $@ + echo ']]>' >> $@ + +jing: + jing -t -i /usr/local/Cellar/docbook/5.0/docbook/xml/5.0/rng/docbookxi.rnc ecl.xml + +clean: + rm -f tmp/ecl.ent ecl2.xml $(GEN_XMLFILES) html/*.html ecl.pdf + rm -rf tex diff -Nru ecl-16.1.2/doc/preface.xmlf ecl-16.1.3+ds/doc/preface.xmlf --- ecl-16.1.2/doc/preface.xmlf 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/doc/preface.xmlf 2016-12-19 10:25:00.000000000 +0000 @@ -186,12 +186,11 @@ PLEASE NOTE THAT: This license covers all of the ECL program except for the files - src/lsp/loop2.lsp ; Symbolic's LOOP macro + src/lsp/loop.lsp ; Symbolic's LOOP macro src/lsp/pprint.lsp ; CMUCL's pretty printer src/lsp/format.lsp ; CMUCL's format and the directories contrib/ ; User contributed extensions - src/clx/ ; portable CLX library from Telent Look the precise copyright of these extensions in the corresponding files. @@ -400,7 +399,7 @@ Make sure the program is installed and ready to run - $ /usr/local/ecl + $ /usr/local/bin/ecl ECL (Embeddable Common-Lisp) 16.0.0 Copyright (C) 1984 Taiichi Yuasa and Masami Hagiya Copyright (C) 1993 Giuseppe Attardi diff -Nru ecl-16.1.2/doc/ref_c_conditions.xml ecl-16.1.3+ds/doc/ref_c_conditions.xml --- ecl-16.1.2/doc/ref_c_conditions.xml 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/doc/ref_c_conditions.xml 2016-12-19 10:25:00.000000000 +0000 @@ -30,14 +30,14 @@ The following example shows how to establish a handler for ERROR conditions. Note how the first value to ECL_HANDLER_CASE matches the position of the restart name in the list: cl_object error = ecl_make_symbol("ERROR","CL"); -ECL_RESTART_BEGIN(the_env, ecl_list1(error)) { +ECL_HANDLER_CASE_BEGIN(the_env, ecl_list1(error)) { /* This form is evaluated with bound handlers */ output = cl_eval(1, form); } ECL_HANDLER_CASE(1, condition) { /* This code is executed when an error happens */ /* We just return the error that took place */ output = condition; -} ECL_RESTART_END; +} ECL_HANDLER_CASE_END; @@ -65,7 +65,7 @@ cl_object abort = ecl_make_symbol("ABORT","CL"); cl_object use_value = ecl_make_symbol("USE-VALUE","CL"); -ECL_RESTART_BEGIN(the_env, cl_list(2, abort, use_value)) { +ECL_RESTART_CASE_BEGIN(the_env, cl_list(2, abort, use_value)) { /* This form is evaluated with bound restarts */ output = cl_eval(1, form); } ECL_RESTART_CASE(1, args) { @@ -74,7 +74,7 @@ } ECL_RESTART_CASE(2, args) { /* This code is executed when the 2nd restart (ABORT) is invoked */ output = ECL_CAR(args); -} ECL_RESTART_END; +} ECL_RESTART_CASE_END; @@ -171,4 +171,4 @@ - \ No newline at end of file + diff -Nru ecl-16.1.2/doc/ref_mp.xmlf ecl-16.1.3+ds/doc/ref_mp.xmlf --- ecl-16.1.2/doc/ref_mp.xmlf 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/doc/ref_mp.xmlf 2016-12-19 10:25:00.000000000 +0000 @@ -73,6 +73,39 @@ + + + + + + mp:holding-lock-p + Determine whether current process holds the lock. + + + + Function + + + mp:holding-lock-p + lock + + + + + lock + An object of type mp:lock. + + + + + + Description + Returns true if the current process holds the lock. + + + + + @@ -453,7 +486,7 @@ Function - mp:process-active-p + mp:process-name process @@ -589,6 +622,39 @@ + + + + + + mp:recursive-lock-p + Determine whether lock is recursive or not. + + + + Function + + + mp:recursive-lock-p + lock + + + + + lock + An object of type mp:lock. + + + + + + Description + Returns true if the lock is recursive. + + + + + @@ -652,4 +718,4 @@ nxml-outline-child-indent: 1 fill-column: 79 End: - --> \ No newline at end of file + --> diff -Nru ecl-16.1.2/examples/ecl_qt/build_fasl.lisp ecl-16.1.3+ds/examples/ecl_qt/build_fasl.lisp --- ecl-16.1.2/examples/ecl_qt/build_fasl.lisp 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/examples/ecl_qt/build_fasl.lisp 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,8 @@ +;;(require 'asdf) +(push "./" asdf:*central-registry*) + +(asdf:make-build :hello-lisp-system + :type :fasl + :monolithic t + :move-here "qt/") +(quit) diff -Nru ecl-16.1.2/examples/ecl_qt/build_static.lisp ecl-16.1.3+ds/examples/ecl_qt/build_static.lisp --- ecl-16.1.2/examples/ecl_qt/build_static.lisp 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/examples/ecl_qt/build_static.lisp 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,8 @@ +;;(require 'asdf) +(push "./" asdf:*central-registry*) + +(asdf:make-build :lisp-envi + :type :static-library + :move-here "qt/") +(quit) + diff -Nru ecl-16.1.2/examples/ecl_qt/hello-lisp.lisp ecl-16.1.3+ds/examples/ecl_qt/hello-lisp.lisp --- ecl-16.1.2/examples/ecl_qt/hello-lisp.lisp 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/examples/ecl_qt/hello-lisp.lisp 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,33 @@ + +(defpackage :hello-lisp + (:use :cl :lparallel)) + +(in-package :hello-lisp) ;;package name hello-lisp + + +(setf lparallel:*kernel* (lparallel:make-kernel 4)) + +(lparallel:defpun pfib (n) + (if (< n 2) + n + (plet ((a (pfib (- n 1))) + (b (pfib (- n 2)))) + (+ a b)))) + + +(defun qsort (seq pred) + (if (null seq) nil + (let* ((pivot (first seq)) + (left (remove-if-not (lambda (x) + (funcall pred x pivot)) + (cdr seq))) + (right (remove-if (lambda (x) + (funcall pred x pivot)) + (cdr seq)))) + (append (qsort left pred) + (list pivot) + (qsort right pred))))) + + +(defun say-hello () + "Bonjour, lisp!") diff -Nru ecl-16.1.2/examples/ecl_qt/hello-lisp-system.asd ecl-16.1.3+ds/examples/ecl_qt/hello-lisp-system.asd --- ecl-16.1.2/examples/ecl_qt/hello-lisp-system.asd 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/examples/ecl_qt/hello-lisp-system.asd 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,4 @@ +(defsystem :hello-lisp-system + :depends-on (:lparallel) + :components ((:file "hello-lisp"))) + diff -Nru ecl-16.1.2/examples/ecl_qt/lisp-envi.asd ecl-16.1.3+ds/examples/ecl_qt/lisp-envi.asd --- ecl-16.1.2/examples/ecl_qt/lisp-envi.asd 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/examples/ecl_qt/lisp-envi.asd 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,3 @@ +(defsystem :lisp-envi + :depends-on () + :components ((:file "lisp-envi"))) diff -Nru ecl-16.1.2/examples/ecl_qt/lisp-envi.lisp ecl-16.1.3+ds/examples/ecl_qt/lisp-envi.lisp --- ecl-16.1.2/examples/ecl_qt/lisp-envi.lisp 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/examples/ecl_qt/lisp-envi.lisp 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,3 @@ +(princ "Lisp Environment Booted.") + + diff -Nru ecl-16.1.2/examples/ecl_qt/Makefile ecl-16.1.3+ds/examples/ecl_qt/Makefile --- ecl-16.1.2/examples/ecl_qt/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/examples/ecl_qt/Makefile 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,13 @@ +all: qt/lisp-envi.a qt/hello-lisp-system--all-systems.fasb + +#lisp environment. +qt/lisp-envi.a: lisp-envi.asd lisp-envi.lisp build_static.lisp + ecl -load build_static.lisp + +#your lisp system. +qt/hello-lisp-system--all-systems.fasb: hello-lisp-system.asd hello-lisp.lisp \ +build_fasl.lisp + ecl -load build_fasl.lisp + +clean: + -rm -f qt/hello-lisp-system--all-systems.fasb qt/lisp-envi.a diff -Nru ecl-16.1.2/examples/ecl_qt/qt/cl_bridge_utils.cpp ecl-16.1.3+ds/examples/ecl_qt/qt/cl_bridge_utils.cpp --- ecl-16.1.2/examples/ecl_qt/qt/cl_bridge_utils.cpp 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/examples/ecl_qt/qt/cl_bridge_utils.cpp 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,11 @@ +#include "cl_bridge_utils.hpp" + + +cl_object lispfy(string str){ + return c_string_to_object(str.data()); +} + +string __spc_expr(string first){ + return first; +} + diff -Nru ecl-16.1.2/examples/ecl_qt/qt/cl_bridge_utils.hpp ecl-16.1.3+ds/examples/ecl_qt/qt/cl_bridge_utils.hpp --- ecl-16.1.2/examples/ecl_qt/qt/cl_bridge_utils.hpp 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/examples/ecl_qt/qt/cl_bridge_utils.hpp 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,103 @@ +#ifndef CL_BRIDGE_UTILS_HPP +#define CL_BRIDGE_UTILS_HPP +#include +#include +#ifdef slots +#undef slots +#endif +#include + +using std::string; +using lisp_expr = std::string; +using std::cout; +using std::endl; +//extern string CL_MAIN_FASB ; +//extern string CL_MAIN_PACKAGE_NAME ; + +cl_object lispfy(string str); /* convert a std::string to cl_object */ + + + +/* add spaces among several strings. */ +string __spc_expr(string first); +template +string __spc_expr (string first, str ... next){ + return first+" "+__spc_expr(next...); +} + +/* encapsule expressions in parenthesis. */ +/* to create lisp expr. */ +template +lisp_expr par_expr(str... all){ + return "("+__spc_expr(all...)+")"; +} + +/* turn the sequence into a lisp list expr. */ +/* ex: par_list("hello", "lisp", "world"); + * -> '("hello" "lisp" "world") */ +template +lisp_expr par_list(str... all){ + return "'"+par_expr(all...); +} + +/* an enhanced version of cl_eval */ +template +cl_object cl_eval(str... all){ + std::cout<__obj=obj;} + cl_obj(const cl_object &obj){this->__obj=obj;} + + /* list index */ + inline cl_obj car(){return cl_obj(cl_car(this->__obj));} + inline cl_obj cdr(){return cl_obj(cl_cdr(this->__obj));} + inline cl_obj cadr(){return this->cdr().car();} + inline cl_obj caar(){return this->car().car();} + inline cl_obj cddr(){return this->cdr().cdr();} + + /* predicates */ + inline bool nullp(){return Null(this->__obj);} + inline bool atomp(){return ECL_ATOM(this->__obj);} + inline bool listp(){return ECL_LISTP(this->__obj);} + inline bool symbolp(){return ECL_SYMBOLP(this->__obj);} + + inline int to_int(){return ecl_to_int(this->__obj);} + inline char to_char(){return ecl_to_char(this->__obj);} + + /* turn the cl_object into string. */ + inline std::string to_std_string(){ + std::string val; + auto & str=this->__obj->string; + for(unsigned long i=0;i + inline void list_traverse(function fn){cl_list_traverse(this->__obj, fn);} + + inline cl_obj operator=(cl_object &&obj){return cl_obj(obj);} + +}; + + + +#endif // CL_BRIDGE_UTILS_HPP diff -Nru ecl-16.1.2/examples/ecl_qt/qt/ecl_qtdemo.pro ecl-16.1.3+ds/examples/ecl_qt/qt/ecl_qtdemo.pro --- ecl-16.1.2/examples/ecl_qt/qt/ecl_qtdemo.pro 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/examples/ecl_qt/qt/ecl_qtdemo.pro 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,38 @@ +#------------------------------------------------- +# +# Project created by QtCreator 2016-08-10T18:00:40 +# +#------------------------------------------------- + +QT += core gui + +CONFIG+=c++14 +greaterThan(QT_MAJOR_VERSION, 4): QT += widgets + +TARGET = ecl_qtdemo +TEMPLATE = app + + +SOURCES += main.cpp\ + hybrid_main.cpp \ + cl_bridge_utils.cpp + +HEADERS += hybrid_main.h \ + cl_bridge_utils.hpp + +FORMS += hybrid_main.ui + +# The include path that contains ecl/ecl.h +QMAKE_CFLAGS += `ecl-config --cflags` +QMAKE_CXXFLAGS += `ecl-config --cflags` + +# The ECL shared library directory. +QMAKE_LFLAGS += `ecl-config --ldflags` + +# Lisp library written by a user +LIBS += $$_PRO_FILE_PWD_/lisp-envi.a +LIBS += -lecl + +RESOURCES += \ + resource.qrc + diff -Nru ecl-16.1.2/examples/ecl_qt/qt/hybrid_main.cpp ecl-16.1.3+ds/examples/ecl_qt/qt/hybrid_main.cpp --- ecl-16.1.2/examples/ecl_qt/qt/hybrid_main.cpp 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/examples/ecl_qt/qt/hybrid_main.cpp 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,76 @@ +#include "hybrid_main.h" +#include "ui_hybrid_main.h" +#include +#include +#include "cl_bridge_utils.hpp" +using ss=std::stringstream; +using std::cout; +using std::endl; +hybrid_main::hybrid_main(QWidget *parent) : + QMainWindow(parent), + ui(new Ui::hybrid_main) +{ + ui->setupUi(this); +} + + +hybrid_main::~hybrid_main() +{ + delete ui; +} + +/* int -> string */ +auto itos=[](auto in){ + ss s;s<>res; + return res; +}; + +/* when called, an alert dialog shows up */ +auto jump_out_alert_window=[](std::string str){ + QMessageBox::critical(0 , + "critical message" , QString::fromStdString(str), + QMessageBox::Ok | QMessageBox::Default , + QMessageBox::Cancel | QMessageBox::Escape , 0 ); + +}; + +/* concurrent fibonacci */ +void hybrid_main::on_pushButton_clicked() +{ + auto str=ui->edit->text().toStdString(); + if(str==""){ + jump_out_alert_window("You haven't input anything!"); + } else { + cl_obj rtv=cl_eval("pfib", str); + string strt=itos(rtv.to_int()); + ui->ans->setText(QString::fromStdString(strt)); + } +} + +/* quick sort. */ +void hybrid_main::on_pushButton_2_clicked() +{ + auto str=ui->input->text().toStdString(); + if(str=="") + { + jump_out_alert_window("You haven't input anything!"); + } else { + cout<output->setText(QString::fromStdString(lab)); + } +} + + + + +/* hello lisp */ +void hybrid_main::on_pushButton_3_clicked() +{ + string s=cl_obj(cl_eval("say-hello")).to_std_string(); + jump_out_alert_window(s); +} diff -Nru ecl-16.1.2/examples/ecl_qt/qt/hybrid_main.h ecl-16.1.3+ds/examples/ecl_qt/qt/hybrid_main.h --- ecl-16.1.2/examples/ecl_qt/qt/hybrid_main.h 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/examples/ecl_qt/qt/hybrid_main.h 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,32 @@ +#ifndef HYBRID_MAIN_H +#define HYBRID_MAIN_H + +#include + +namespace Ui { +class hybrid_main; +} + +class hybrid_main : public QMainWindow +{ + Q_OBJECT + +public: + explicit hybrid_main(QWidget *parent = 0); + ~hybrid_main(); + +private slots: + void on_pushButton_clicked(); + + void on_pushButton_2_clicked(); + + void on_pushButton_3_clicked(); + +private: + Ui::hybrid_main *ui; +}; + + + + +#endif // HYBRID_MAIN_H diff -Nru ecl-16.1.2/examples/ecl_qt/qt/hybrid_main.ui ecl-16.1.3+ds/examples/ecl_qt/qt/hybrid_main.ui --- ecl-16.1.2/examples/ecl_qt/qt/hybrid_main.ui 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/examples/ecl_qt/qt/hybrid_main.ui 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,248 @@ + + + hybrid_main + + + + 0 + 0 + 641 + 430 + + + + hybrid_main + + + + + + 112 + 60 + 121 + 21 + + + + + + + + + + Input N here. + + + + + + 240 + 55 + 113 + 32 + + + + calculate! + + + + + + 30 + 60 + 71 + 16 + + + + Fibonacci: + + + + + + 160 + 100 + 241 + 16 + + + + Quick Sort List Processing Test + + + + + + 30 + 130 + 59 + 16 + + + + Input + + + + + + 30 + 170 + 59 + 16 + + + + Output + + + + + + 20 + 200 + 113 + 32 + + + + sort! + + + + + + 110 + 130 + 491 + 21 + + + + Input a sequence of number, seperate by space. + + + + + + 110 + 170 + 491 + 21 + + + + true + + + Sorted sequence output + + + + + + 30 + 80 + 601 + 16 + + + + Qt::Horizontal + + + + + + 270 + 240 + 61 + 91 + + + + border-image:url(:/pic/madeinlisp.png) + + + + + + + + + 370 + 300 + 191 + 41 + + + + (Core made in Lisp.) + + + + + + 160 + 10 + 301 + 16 + + + + Concurrent Compution Test (lparallel) + + + + + + 350 + 270 + 181 + 32 + + + + Hello, Lisp! + + + + + + 360 + 60 + 113 + 21 + + + + + + + true + + + Answer output + + + + + + 400 + 240 + 111 + 16 + + + + String Test + + + + + + + + Binary files /tmp/tmpfunQtY/cpZiCsfjgs/ecl-16.1.2/examples/ecl_qt/qt/madeinlisp.png and /tmp/tmpfunQtY/Q2gw5PRUPc/ecl-16.1.3+ds/examples/ecl_qt/qt/madeinlisp.png differ diff -Nru ecl-16.1.2/examples/ecl_qt/qt/main.cpp ecl-16.1.3+ds/examples/ecl_qt/qt/main.cpp --- ecl-16.1.2/examples/ecl_qt/qt/main.cpp 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/examples/ecl_qt/qt/main.cpp 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,43 @@ +#include "hybrid_main.h" +#include +#include "cl_bridge_utils.hpp" + +string CL_MAIN_FASB = "\"hello-lisp-system--all-systems.fasb\""; +string CL_MAIN_PACKAGE_NAME = "hello-lisp"; + +/* Initialization. + * This time we load the fasb file after + * the Lisp Environment is booted. + * */ +#define __cl_init_name init_lib_LISP_ENVI + +extern "C"{ + + extern void __cl_init_name(cl_object); + +} + +void init_cl_env(int argc, char * argv[]){ + /* Initialize CL environment */ + cl_boot(argc, argv); + ecl_init_module(NULL, __cl_init_name); + /* load fasb */ + cl_eval("load", CL_MAIN_FASB); + /* set context to current package */ + cl_eval("in-package", CL_MAIN_PACKAGE_NAME); + /* hook for shutting down cl env */ + atexit(cl_shutdown); +} + +#undef __cl_init_name + + + + +int main(int argc, char *argv[]){ + QApplication a(argc, argv); + hybrid_main w; + w.show(); + init_cl_env(argc, argv); /* init env */ + return a.exec(); +} diff -Nru ecl-16.1.2/examples/ecl_qt/qt/resource.qrc ecl-16.1.3+ds/examples/ecl_qt/qt/resource.qrc --- ecl-16.1.2/examples/ecl_qt/qt/resource.qrc 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/examples/ecl_qt/qt/resource.qrc 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,5 @@ + + + madeinlisp.png + + diff -Nru ecl-16.1.2/examples/ecl_qt/README.md ecl-16.1.3+ds/examples/ecl_qt/README.md --- ecl-16.1.2/examples/ecl_qt/README.md 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/examples/ecl_qt/README.md 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,52 @@ +This demo shows how to embed ECL into Qt5 and serve as kernel. This +also discuss how to compile ECL with C++(14). You can extend on this +demo to form a more complicate and productive project. + +# Preparation +Before you build the demo, make sure you have those dependencies installed: +1. ECL, of course. We recommend version 16.1.2. +2. g++/clang compiler with at least C++14 support. +3. make +4. Qt5.x with Qt Creator. +5. Quicklisp installed on your ECL. + +We use the external Lisp package :lparallel so you better download +that package in advance using `(ql:quickload :lparallel)`. + +# Build + +## Build CL Library and FASB + +Run `make` in current directory and you get two files in the directory +`qt/` (if successful). `lisp-envi.a` and +`hello-lisp-system--all-systems.fasb`. + +## Configure and build your Qt Project + +To build the example it is enough to change to the `qt/` directory, +generate a Makefile with `qmake` and to call `make`. + +```shell +cd qt/ +qmake +make +``` + +If you want to change your Qt project, open it with the `Qt +Creator`. It can build the executable for you (instead of manually +working with make). + +# Run + +After you go through the steps above, go for the executable file and +try that demo. + +Notice: For OSX users, you should manually move the .fasb file into +the directory where your executable file is in. So run the command: +``` +mv hello-lisp-system--all-systems.fasb ecl_qtdemo.app/Contents/MacOS/ +``` + +Happy hacking with ECL! + +ntr(Lexicall) diff -Nru ecl-16.1.2/examples/threads/import/import.c ecl-16.1.3+ds/examples/threads/import/import.c --- ecl-16.1.2/examples/threads/import/import.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/examples/threads/import/import.c 2016-12-19 10:25:00.000000000 +0000 @@ -38,15 +38,15 @@ * or CreateThread (in unix and Windows respectively) with the * GC_pthread_create and GC_CreateThread functions. */ + /* Unfortunately, the Bohem-Weiser garbage collector does not keep track * of its configuration. We have to add the following flags by hand in * order to force pthread_create being redefined. */ #define GC_THREADS #define _REENTRANT -#include -#include +#include static void * thread_entry_point(void *data) @@ -59,7 +59,7 @@ * routine initializes the lisp and makes it ready for working * in this thread. */ - ecl_import_current_thread(Cnil, Cnil); + ecl_import_current_thread(ECL_NIL, ECL_NIL); /* * Here we execute some lisp code code. diff -Nru ecl-16.1.2/examples/threads/import_win32/import.c ecl-16.1.3+ds/examples/threads/import_win32/import.c --- ecl-16.1.2/examples/threads/import_win32/import.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/examples/threads/import_win32/import.c 2016-12-19 10:25:00.000000000 +0000 @@ -59,7 +59,7 @@ * in this thread. */ - ecl_import_current_thread(Cnil, Cnil); + ecl_import_current_thread(ECL_NIL, ECL_NIL); /* * Here we execute some lisp code code. diff -Nru ecl-16.1.2/.gitignore ecl-16.1.3+ds/.gitignore --- ecl-16.1.2/.gitignore 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/.gitignore 2016-12-19 10:25:00.000000000 +0000 @@ -39,10 +39,60 @@ BUILD-STAMP MODULES -Makefile +/Makefile src/autom4te.cache src/config.log regressions/*.lsp regressions/eformat-tests/*.txt +*.aux +*.cp* +*.fn* +*.log +/src/doc/new-doc/*.lsp* +*.toc +*.tp* +*.vr* +/src/doc/new-doc/new-doc.pdf +/src/doc/new-doc/ecldoc.info +/src/doc/new-doc/new-doc.ex +/src/doc/new-doc/new-doc.exs +/src/doc/new-doc/new-doc.ft +/src/doc/new-doc/new-doc.fts +/src/doc/new-doc/new-doc.cf +/src/doc/new-doc/new-doc.cfs +/examples/ecl_qt/qt/ecl_qtdemo +/examples/ecl_qt/hello-lisp-system--all-systems.fasb +/examples/ecl_qt/lisp-envi.a +/examples/ecl_qt/qt/.qmake.stash +/examples/ecl_qt/qt/Makefile +*fasc +*.orig + +# msvc +/msvc/encodings/ +/msvc/ecl/atomic_ops/ +/msvc/ecl/impl/ +/msvc/ecl/*.h +/msvc/clos/ +/msvc/cmp.asd +/msvc/cmp/ +/msvc/deflate.asd +/msvc/defsystem.asd +/msvc/ecl-cdb.asd +/msvc/ecl-curl.asd +/msvc/ecl-help.asd +/msvc/ecl-quicklisp.asd +/msvc/ecl.ico +/msvc/ecl.rc +/msvc/ecl.res +/msvc/ext/ +/msvc/lsp/ +/msvc/package/ +/msvc/prebuilt-asdf.asd +/msvc/profile.asd +/msvc/ql-minitar.asd +/msvc/rt.asd +/msvc/sb-bsd-sockets.asd +/msvc/sockets.asd diff -Nru ecl-16.1.2/INSTALL ecl-16.1.3+ds/INSTALL --- ecl-16.1.2/INSTALL 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/INSTALL 2016-12-19 10:25:00.000000000 +0000 @@ -3,60 +3,63 @@ If you do not have access to the online version, follow the following recipies. * Unix and similar platforms. - 1. Type - ./configure --help - to get a list of the flags with which ECL can be configured. - 2. Enter - ./configure ... - where "..." is the set of flags you have chosen. - 3. Use "make" followed by "make install" to build and install ECL. +1. Type + ./configure --help + to get a list of the flags with which ECL can be configured. +2. Enter + ./configure ... + where "..." is the set of flags you have chosen. +3. Use "make" followed by "make install" to build and install ECL. * Windows with Visual Studio C++ 2008 - 1. Enter the msvc directory - 2. Read the file Makefile to find the configuration options. They typically have the - form ECL_UNICODE=1, ECL_THREADS=1, etc - 3. Enter - nmake ... - followed by zero or more of those options +1. Enter the msvc directory +2. Read the file Makefile to find the configuration options. They + typically have the form ECL_UNICODE=1, ECL_THREADS=1, etc +3. Enter + nmake ... + followed by zero or more of those options 4. Use "nmake install" to create a directory called "package" with ECL in it. 5. Move that directory wherever you need. * Cross-compile for the android platform (from the UNIX machine) - 1. Build the host ECL - #+BEGIN_SRC shell-script - ./configure ABI=32 CFLAGS="-m32 -g -O2" LDFLAGS="-m32 -g -O2" \ - --prefix=`pwd`/ecl-android-host \ - --disable-longdouble \ - --enable-libatomic=included +1. Build the host ECL + #+BEGIN_SRC shell-script + ./configure ABI=32 CFLAGS="-m32 -g -O2" LDFLAGS="-m32 -g -O2"\ + --prefix=`pwd`/ecl-android-host --disable-longdouble make -j9 make install rm -r build export ECL_TO_RUN=`pwd`/ecl-android-host/bin/ecl - #+END_SRC - 2. Build the toolchain (requires android-ndk) and export the - necessary paths - if you have a toolchain for the android just - export it's bin/ directory - #+BEGIN_SRC shell-script - export PLATFORM_PREFIX=/opt/toolchains/android-ndk/ - export NDK_PATH=/opt/android-ndk/ - export NDK_PLATFORM=android-4 - - mkdir ${PLATFORM_PREFIX} - ${NDK_PATH}/build/tools/make-standalone-toolchain.sh \ - --platform=${NDK_PLATFORM} \ - --install-dir=${PLATFORM_PREFIX} \ - --arch=arm + #+END_SRC +2. Configure the toolchain (requires android-ndk) and export the + necessary paths: + #+BEGIN_SRC shell-script + # android-ndk r13b is known to be broken, tested with r9b available at: + # http://dl.google.com/android/ndk/android-ndk-r9b-linux-x86_64.tar.bz2 + # http://dl.google.com/android/ndk/android-ndk-r9b-darwin-x86_64.tar.bz2 + export NDK_PATH=/opt/android-ndk + export SYSROOT=${NDK_PATH}/platforms/android-9/arch-arm + export PATH=${NDK_PATH}/toolchains/arm-linux-androideabi-4.6/prebuilt/linux-x86_64/bin:$PATH + #+END_SRC +3. Build and install the target library + #+BEGIN_SRC shell-script + export LDFLAGS="--sysroot=${SYSROOT}" + export CPPFLAGS="--sysroot=${SYSROOT}" + ./configure --host=arm-linux-androideabi \ + --prefix=`pwd`/ecl-android \ + --with-cross-config=`pwd`/src/util/android.cross_config + make -j9 + make install + #+END_SRC +4. Library and assets in the ecl-android directory are ready to run on + the Android system. - export PATH=${PLATFORM_PREFIX}/bin:${PATH} - #+END_SRC - 3. Build and install the target library - #+BEGIN_SRC shell-script - ./configure --host=arm-linux-androideabi \ - --prefix=`pwd`/ecl-android \ - --with-cross-config=`pwd`src/util/android.cross_config \ - --disable-soname - make -j9 - make install - #+END_SRC - 4. Library and assets in the ecl-android directory are ready to run - on the Android system. +** Building ecl-android on Darwin (OSX) +If your host platform is darwin, then the host compiler should be +built with the Apple's GCC (not the GCC from Macports). Using the +MacPort command: +#+BEGIN_SRC shell-script + sudo port select --set gcc none +#+END_SRC + +Hint provided by Pascal J. Bourguignon. diff -Nru ecl-16.1.2/LGPL ecl-16.1.3+ds/LGPL --- ecl-16.1.2/LGPL 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/LGPL 1970-01-01 00:00:00.000000000 +0000 @@ -1,481 +0,0 @@ - GNU LIBRARY GENERAL PUBLIC LICENSE - Version 2, June 1991 - - Copyright (C) 1991 Free Software Foundation, Inc. - 675 Mass Ave, Cambridge, MA 02139, USA - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - -[This is the first released version of the library GPL. It is - numbered 2 because it goes with version 2 of the ordinary GPL.] - - Preamble - - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -Licenses are intended to guarantee your freedom to share and change -free software--to make sure the software is free for all its users. - - This license, the Library General Public License, applies to some -specially designated Free Software Foundation software, and to any -other libraries whose authors decide to use it. You can use it for -your libraries, 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 library, or if you modify it. - - For example, if you distribute copies of the library, whether gratis -or for a fee, you must give the recipients all the rights that we gave -you. You must make sure that they, too, receive or can get the source -code. If you link a program with the library, you must provide -complete object files to the recipients so that they can relink them -with the library, after making changes to the library and recompiling -it. And you must show them these terms so they know their rights. - - Our method of protecting your rights has two steps: (1) copyright -the library, and (2) offer you this license which gives you legal -permission to copy, distribute and/or modify the library. - - Also, for each distributor's protection, we want to make certain -that everyone understands that there is no warranty for this free -library. If the library is modified by someone else and passed on, we -want its recipients to know that what they have is not the original -version, 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 companies distributing free -software will individually obtain patent licenses, thus in effect -transforming the program into proprietary software. To prevent this, -we have made it clear that any patent must be licensed for everyone's -free use or not licensed at all. - - Most GNU software, including some libraries, is covered by the ordinary -GNU General Public License, which was designed for utility programs. This -license, the GNU Library General Public License, applies to certain -designated libraries. This license is quite different from the ordinary -one; be sure to read it in full, and don't assume that anything in it is -the same as in the ordinary license. - - The reason we have a separate public license for some libraries is that -they blur the distinction we usually make between modifying or adding to a -program and simply using it. Linking a program with a library, without -changing the library, is in some sense simply using the library, and is -analogous to running a utility program or application program. However, in -a textual and legal sense, the linked executable is a combined work, a -derivative of the original library, and the ordinary General Public License -treats it as such. - - Because of this blurred distinction, using the ordinary General -Public License for libraries did not effectively promote software -sharing, because most developers did not use the libraries. We -concluded that weaker conditions might promote sharing better. - - However, unrestricted linking of non-free programs would deprive the -users of those programs of all benefit from the free status of the -libraries themselves. This Library General Public License is intended to -permit developers of non-free programs to use free libraries, while -preserving your freedom as a user of such programs to change the free -libraries that are incorporated in them. (We have not seen how to achieve -this as regards changes in header files, but we have achieved it as regards -changes in the actual functions of the Library.) The hope is that this -will lead to faster development of free libraries. - - The precise terms and conditions for copying, distribution and -modification follow. Pay close attention to the difference between a -"work based on the library" and a "work that uses the library". The -former contains code derived from the library, while the latter only -works together with the library. - - Note that it is possible for a library to be covered by the ordinary -General Public License rather than by this special one. - - GNU LIBRARY GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - - 0. This License Agreement applies to any software library which -contains a notice placed by the copyright holder or other authorized -party saying it may be distributed under the terms of this Library -General Public License (also called "this License"). Each licensee is -addressed as "you". - - A "library" means a collection of software functions and/or data -prepared so as to be conveniently linked with application programs -(which use some of those functions and data) to form executables. - - The "Library", below, refers to any such software library or work -which has been distributed under these terms. A "work based on the -Library" means either the Library or any derivative work under -copyright law: that is to say, a work containing the Library or a -portion of it, either verbatim or with modifications and/or translated -straightforwardly into another language. (Hereinafter, translation is -included without limitation in the term "modification".) - - "Source code" for a work means the preferred form of the work for -making modifications to it. For a library, 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 library. - - Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running a program using the Library is not restricted, and output from -such a program is covered only if its contents constitute a work based -on the Library (independent of the use of the Library in a tool for -writing it). Whether that is true depends on what the Library does -and what the program that uses the Library does. - - 1. You may copy and distribute verbatim copies of the Library's -complete 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 distribute a copy of this License along with the -Library. - - 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 Library or any portion -of it, thus forming a work based on the Library, 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) The modified work must itself be a software library. - - b) You must cause the files modified to carry prominent notices - stating that you changed the files and the date of any change. - - c) You must cause the whole of the work to be licensed at no - charge to all third parties under the terms of this License. - - d) If a facility in the modified Library refers to a function or a - table of data to be supplied by an application program that uses - the facility, other than as an argument passed when the facility - is invoked, then you must make a good faith effort to ensure that, - in the event an application does not supply such function or - table, the facility still operates, and performs whatever part of - its purpose remains meaningful. - - (For example, a function in a library to compute square roots has - a purpose that is entirely well-defined independent of the - application. Therefore, Subsection 2d requires that any - application-supplied function or table used by this function must - be optional: if the application does not supply it, the square - root function must still compute square roots.) - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Library, -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 Library, 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 Library. - -In addition, mere aggregation of another work not based on the Library -with the Library (or with a work based on the Library) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - - 3. You may opt to apply the terms of the ordinary GNU General Public -License instead of this License to a given copy of the Library. To do -this, you must alter all the notices that refer to this License, so -that they refer to the ordinary GNU General Public License, version 2, -instead of to this License. (If a newer version than version 2 of the -ordinary GNU General Public License has appeared, then you can specify -that version instead if you wish.) Do not make any other change in -these notices. - - Once this change is made in a given copy, it is irreversible for -that copy, so the ordinary GNU General Public License applies to all -subsequent copies and derivative works made from that copy. - - This option is useful when you wish to copy part of the code of -the Library into a program that is not a library. - - 4. You may copy and distribute the Library (or a portion or -derivative of it, under Section 2) in object code or executable form -under the terms of Sections 1 and 2 above provided that you 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. - - If distribution of 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 satisfies the requirement to -distribute the source code, even though third parties are not -compelled to copy the source along with the object code. - - 5. A program that contains no derivative of any portion of the -Library, but is designed to work with the Library by being compiled or -linked with it, is called a "work that uses the Library". Such a -work, in isolation, is not a derivative work of the Library, and -therefore falls outside the scope of this License. - - However, linking a "work that uses the Library" with the Library -creates an executable that is a derivative of the Library (because it -contains portions of the Library), rather than a "work that uses the -library". The executable is therefore covered by this License. -Section 6 states terms for distribution of such executables. - - When a "work that uses the Library" uses material from a header file -that is part of the Library, the object code for the work may be a -derivative work of the Library even though the source code is not. -Whether this is true is especially significant if the work can be -linked without the Library, or if the work is itself a library. The -threshold for this to be true is not precisely defined by law. - - If such an object file uses only numerical parameters, data -structure layouts and accessors, and small macros and small inline -functions (ten lines or less in length), then the use of the object -file is unrestricted, regardless of whether it is legally a derivative -work. (Executables containing this object code plus portions of the -Library will still fall under Section 6.) - - Otherwise, if the work is a derivative of the Library, you may -distribute the object code for the work under the terms of Section 6. -Any executables containing that work also fall under Section 6, -whether or not they are linked directly with the Library itself. - - 6. As an exception to the Sections above, you may also compile or -link a "work that uses the Library" with the Library to produce a -work containing portions of the Library, and distribute that work -under terms of your choice, provided that the terms permit -modification of the work for the customer's own use and reverse -engineering for debugging such modifications. - - You must give prominent notice with each copy of the work that the -Library is used in it and that the Library and its use are covered by -this License. You must supply a copy of this License. If the work -during execution displays copyright notices, you must include the -copyright notice for the Library among them, as well as a reference -directing the user to the copy of this License. Also, you must do one -of these things: - - a) Accompany the work with the complete corresponding - machine-readable source code for the Library including whatever - changes were used in the work (which must be distributed under - Sections 1 and 2 above); and, if the work is an executable linked - with the Library, with the complete machine-readable "work that - uses the Library", as object code and/or source code, so that the - user can modify the Library and then relink to produce a modified - executable containing the modified Library. (It is understood - that the user who changes the contents of definitions files in the - Library will not necessarily be able to recompile the application - to use the modified definitions.) - - b) Accompany the work with a written offer, valid for at - least three years, to give the same user the materials - specified in Subsection 6a, above, for a charge no more - than the cost of performing this distribution. - - c) If distribution of the work is made by offering access to copy - from a designated place, offer equivalent access to copy the above - specified materials from the same place. - - d) Verify that the user has already received a copy of these - materials or that you have already sent this user a copy. - - For an executable, the required form of the "work that uses the -Library" must include any data and utility programs needed for -reproducing the executable from it. 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. - - It may happen that this requirement contradicts the license -restrictions of other proprietary libraries that do not normally -accompany the operating system. Such a contradiction means you cannot -use both them and the Library together in an executable that you -distribute. - - 7. You may place library facilities that are a work based on the -Library side-by-side in a single library together with other library -facilities not covered by this License, and distribute such a combined -library, provided that the separate distribution of the work based on -the Library and of the other library facilities is otherwise -permitted, and provided that you do these two things: - - a) Accompany the combined library with a copy of the same work - based on the Library, uncombined with any other library - facilities. This must be distributed under the terms of the - Sections above. - - b) Give prominent notice with the combined library of the fact - that part of it is a work based on the Library, and explaining - where to find the accompanying uncombined form of the same work. - - 8. You may not copy, modify, sublicense, link with, or distribute -the Library except as expressly provided under this License. Any -attempt otherwise to copy, modify, sublicense, link with, or -distribute the Library 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. - - 9. 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 Library or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Library (or any work based on the -Library), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Library or works based on it. - - 10. Each time you redistribute the Library (or any work based on the -Library), the recipient automatically receives a license from the -original licensor to copy, distribute, link with or modify the Library -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. - - 11. 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 Library at all. For example, if a patent -license would not permit royalty-free redistribution of the Library 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 Library. - -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. - - 12. If the distribution and/or use of the Library is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Library 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. - - 13. The Free Software Foundation may publish revised and/or new -versions of the Library 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 Library -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 Library does not specify a -license version number, you may choose any version ever published by -the Free Software Foundation. - - 14. If you wish to incorporate parts of the Library into other free -programs whose distribution conditions are incompatible with these, -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 - - 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO -WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. -EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR -OTHER PARTIES PROVIDE THE LIBRARY "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 -LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME -THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. - - 16. 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 LIBRARY 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 -LIBRARY (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 LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF -SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH -DAMAGES. - - END OF TERMS AND CONDITIONS - - Appendix: How to Apply These Terms to Your New Libraries - - If you develop a new library, and you want it to be of the greatest -possible use to the public, we recommend making it free software that -everyone can redistribute and change. You can do so by permitting -redistribution under these terms (or, alternatively, under the terms of the -ordinary General Public License). - - To apply these terms, attach the following notices to the library. 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) - - This 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. - - This 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 this library; if not, write to the Free - Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -Also add information on how to contact you by electronic and paper mail. - -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a "copyright disclaimer" for the library, if -necessary. Here is a sample; alter the names: - - Yoyodyne, Inc., hereby disclaims all copyright interest in the - library `Frob' (a library for tweaking knobs) written by James Random Hacker. - - , 1 April 1990 - Ty Coon, President of Vice - -That's all there is to it! diff -Nru ecl-16.1.2/LICENSE ecl-16.1.3+ds/LICENSE --- ecl-16.1.2/LICENSE 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/LICENSE 2016-12-19 10:25:00.000000000 +0000 @@ -23,13 +23,12 @@ PLEASE NOTE THAT: This license covers all of the ECL program except for the files - src/lsp/loop2.lsp ; Symbolic's LOOP macro + src/lsp/loop.lsp ; Symbolic's LOOP macro src/lsp/pprint.lsp ; CMUCL's pretty printer src/lsp/format.lsp ; CMUCL's format and the directories contrib/ ; User contributed extensions examples/ ; Examples for the ECL usage - src/clx/ ; portable CLX library from Telent Look the precise copyright of these extensions in the corresponding files. diff -Nru ecl-16.1.2/Makefile.in ecl-16.1.3+ds/Makefile.in --- ecl-16.1.2/Makefile.in 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/Makefile.in 2016-12-19 10:25:00.000000000 +0000 @@ -44,16 +44,18 @@ prefix=@prefix@ exec_prefix=@exec_prefix@ +datarootdir=@datarootdir@ +datadir=@datadir@ bindir=@bindir@ infodir=@infodir@ mandir=@mandir@ libdir=@libdir@ # What to release -TAR_CONTENTS=Makefile.in README.1st LGPL ANNOUNCEMENT Copyright doc \ +TAR_CONTENTS=Makefile.in README.md LGPL ANNOUNCEMENT LICENSE doc \ configure src/c src/cmp src/clos src/CHANGELOG src/lsp src/doc \ src/h src/gmp src/config* src/install.sh src/Makefile.in \ - src/util contrib/ src/clx src/gc src/*.in src/*.m4 src/gabriel \ + src/util contrib/ src/gc src/*.in src/*.m4 src/gabriel \ src/tests/Makefile.in msvc examples # ==================== Utility Programs for the Build ==================== @@ -73,6 +75,9 @@ Makefile: Makefile.in build/config.status (cd build; ./config.status) +ecl_min: build/Makefile + cd build; $(MAKE) ecl_min + # ==================== Installation ==================== INSTALL_TARGET = @INSTALL_TARGET@ @@ -115,9 +120,7 @@ realclean: distclean check: - cd build && $(MAKE) check -recheck: - cd build && $(MAKE) recheck + cd build && $(MAKE) check TESTS="$(TESTS)" # ==================== Various means of distribution ==================== @@ -131,9 +134,6 @@ source-dist: $(TAR_DIR).tgz -rpmdir=$(shell rpm --showrc | grep '^-[0-9]*:.*[^{]_topdir' | sed 's,^.*topdir[ ]*\(.*\)[ ]*,\1,') -rpmbuild=$(shell if [ -z `which rpmbuild` ]; then echo "rpm"; else echo "rpmbuild"; fi) - $(TAR_DIR).tgz: git archive --format=tar.gz --prefix=$(TAR_DIR)/ HEAD > $@ @@ -157,12 +157,3 @@ `pwd`/src/util/ecl_nsi.sh `pwd`/src/util/ecl.nsi build/$(TAR_DIR) makensis.exe build/$(TAR_DIR)/ecl.nsi mv build/$(TAR_DIR)/Setup.exe ecl-$(VERSION).exe - -upload-frs: - ecldir=`echo $(VERSION) | sed -e 's,\([0-9]*\.[0-9]*\)\.[0-9]*,\1,'` && \ - destdir=jjgarcia,ecls@frs.sourceforge.net:/home/frs/project/e/ec/ecls/ecls/ && \ - test -d frs || mkdir frs && \ - test -d frs/$$ecldir || mkdir frs/$$ecldir && \ - cp $(TAR_DIR).tgz src/CHANGELOG frs/$$ecldir && \ - cd frs && scp -rC $$ecldir $$destdir - rm -rf frs diff -Nru ecl-16.1.2/msvc/c/Makefile ecl-16.1.3+ds/msvc/c/Makefile --- ecl-16.1.2/msvc/c/Makefile 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/msvc/c/Makefile 2016-12-19 10:25:00.000000000 +0000 @@ -5,10 +5,8 @@ srcdir = ..\..\src\c !if "$(ECL_WIN64)" != "" -ECL_FFI_OBJ= ECL_FPE_CODE=fpe_none.c !else -ECL_FFI_OBJ=ffi_x86.obj ECL_FPE_CODE=fpe_x86.c !endif @@ -42,7 +40,7 @@ # TRUE_CC = cl CC = cl -CFLAGS = -c $(ECL_CFLAGS) -DECL_API="__declspec(dllexport)" -I./ -I../ -I$(srcdir) -I$(top_srcdir)/bdwgc/include -I$(top_srcdir)/bdwgc/include/private +CFLAGS = -c $(ECL_CFLAGS) -DECL_BUILD -DECL_API="__declspec(dllexport)" -I./ -I../ -I$(srcdir) -I$(top_srcdir)/bdwgc/include -I$(top_srcdir)/bdwgc/include/private SHELL = /bin/sh RM = del @@ -66,7 +64,7 @@ HFILES = ..\ecl\config.h ..\ecl\atomic_ops.h $(HDIR)\ecl.h $(HDIR)\ecl-cmp.h\ $(HDIR)\object.h $(HDIR)\cs.h $(HDIR)\stacks.h\ $(HDIR)\external.h $(HDIR)\cons.h $(HDIR)\legacy.h\ - $(HDIR)\number.h $(HDIR)\page.h $(HDIR)\unify.h\ + $(HDIR)\number.h $(HDIR)\page.h \ $(HDIR)\internal.h $(HDIR)\ecl-inl.h $(HDIR)\bytecodes.h \ $(HDIR)\impl\math_dispatch.h @@ -103,7 +101,7 @@ mapfun.obj multival.obj hash.obj format.obj pathname.obj\ structure.obj load.obj unixfsys.obj unixsys.obj \ ffi.obj alloc_2.obj tcp.obj $(THREADS_OBJ) serialize.obj \ - $(ECL_FFI_OBJ) $(ECL_UCD_OBJ) $(ECL_SSE_OBJ) + $(ECL_UCD_OBJ) $(ECL_SSE_OBJ) all: $(DPP) ..\eclmin.lib ..\cinit.obj @@ -151,7 +149,8 @@ do $(RM) %f -for %f in (..\ecl\*.h) do $(RM) %f -for %f in (cut.exe cut.obj dpp.exe dpp.obj) do $(RM) %f - -del /S /Q ..\ecl\atomic* + -del /S /Q ..\ecl\atomic_ops + -del /S /Q ..\ecl\impl # Build rules @@ -164,8 +163,14 @@ "@ECL_THREADS@" "$(ECL_THREADS_FLAG)" \ "@ECL_UNICODE@" "$(ECL_UNICODE_FLAG)" \ "@ECL_SSE2@" "$(ECL_SSE_FLAG)" \ - < ..\ecl\config.h.msvc6 > $@ - xcopy /SYI $(top_srcdir)\h\* ..\ecl + < ..\ecl\config.h.msvc6 > ..\ecl\config.h + cut.exe "@ECL_FPE_CODE@" "$(srcdir:\=/)/arch/$(ECL_FPE_CODE)" \ + "@ECL_VERSION_NUMBER@" "$(ECL_VERSION_NUMBER)" \ + "@ECL_THREADS@" "$(ECL_THREADS_FLAG)" \ + "@ECL_UNICODE@" "$(ECL_UNICODE_FLAG)" \ + "@ECL_SSE2@" "$(ECL_SSE_FLAG)" \ + < ..\ecl\config-internal.h.msvc6 > ..\ecl\config-internal.h + xcopy /SYI $(top_srcdir)\h\*.h ..\ecl -mkdir ..\ecl\atomic_ops -mkdir ..\ecl\atomic_ops\sysdeps xcopy /SYI $(top_srcdir)\bdwgc\libatomic_ops\src\atomic_ops.h ..\ecl diff -Nru ecl-16.1.2/msvc/doc/Makefile ecl-16.1.3+ds/msvc/doc/Makefile --- ecl-16.1.2/msvc/doc/Makefile 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/msvc/doc/Makefile 2016-12-19 10:25:00.000000000 +0000 @@ -30,42 +30,34 @@ ECL = ../ecl -all: $(INFO_FILES) $(HTML_FILES) developers_manual user_manual clx_manual +all: $(INFO_FILES) $(HTML_FILES) developers_manual user_manual_manual ecl.dvi: $(srcdir)/user.txi $(srcdir)/macros.txi clisp.sty ecl.sty tex $(srcdir)/user.txi ecldev.dvi: $(srcdir)/devel.txi $(srcdir)/macros.txi clisp.sty ecl.sty tex $(srcdir)/devel.txi -clx.dvi: clx.texinfo - tex clx.texinfo ecl.ps: ecl.dvi $(srcdir)/macros.txi dvips -o $@ ecl.dvi ecldev.ps: ecldev.dvi $(srcdir)/macros.txi dvips -o $@ ecldev.dvi -clx.ps: clx.dvi - dvips -o $@ clx.dvi install: all IF NOT EXIST $(docdir) $(MKDIR) $(docdir) - for %i in (Copyright LGPL) do $(CP) $(top_srcdir)\..\%i $(docdir) + for %i in (LICENSE LGPL) do $(CP) $(top_srcdir)\..\%i $(docdir) for %i in ($(HTML_FILES)) do $(CP) %i $(docdir) IF NOT EXIST $(docdir)\ecldev $(MKDIR) $(docdir)\ecldev for %i in (ecldev\*) do $(CP) %i $(docdir)\ecldev IF NOT EXIST $(docdir)\ecl $(MKDIR) $(docdir)\ecl for %i in (ecl\*) do $(CP) %i $(docdir)\ecl - IF NOT EXIST $(docdir)\clx $(MKDIR) $(docdir)\clx - for %i in (clx\*) do $(CP) %i $(docdir)\clx flatinstall: all IF NOT EXIST $(docdir) $(MKDIR) $(docdir) - for %i in (Copyright LGPL) do $(CP) $(top_srcdir)\..\%i $(docdir) + for %i in (LICENSE LGPL) do $(CP) $(top_srcdir)\..\%i $(docdir) for %i in ($(HTML_FILES)) do $(CP) %i $(docdir) IF NOT EXIST $(docdir)\ecldev $(MKDIR) $(docdir)\ecldev for %i in (ecldev\*) do $(CP) %i $(docdir)\ecldev IF NOT EXIST $(docdir)\ecl $(MKDIR) $(docdir)\ecl for %i in (ecl\*) do $(CP) %i $(docdir)\ecl - IF NOT EXIST $(docdir)\clx $(MKDIR) $(docdir)\clx - for %i in (clx\*) do $(CP) %i $(docdir)\clx uninstall: for k in $(INFO_FILES); do \ @@ -77,7 +69,7 @@ rm -r $(infodir)/ecl.$(INFOEXT) $(infodir)/ecldev.$(INFOEXT); \ rm $(mandir)/man$(manext)/ecl.$(manext) -head2: developers_manual user_manual clx_manual $(srcdir)/head Makefile +head2: developers_manual user_manual manual $(srcdir)/head Makefile IF EXIST ecl\index.html ( \ ..\c\cut.exe "ecl/user.html" "ecl/index.html" \ "ecldev/devel.html" "ecldev/index.html" \ @@ -89,16 +81,10 @@ gzip < ecl.info > ecl.info.gz ecldev.info.gz: ecldev.info gzip < ecldev.info > ecldev.info.gz -clx.info.gz: clx.info - gzip < clx.info > clx.info.gz ecl.info: $(srcdir)/user.txi $(srcdir)/macros.txi makeinfo -I $(srcdir) --no-split $(srcdir)/user.txi ecldev.info: $(srcdir)/devel.txi $(srcdir)/macros.txi makeinfo -I $(srcdir) --no-split $(srcdir)/devel.txi -clx.info: clx.texinfo - makeinfo --no-split clx.texinfo -clx.texinfo: $(top_srcdir)/clx/manual/clx.texinfo - cp $(top_srcdir)/clx/manual/clx.texinfo . download.html: $(srcdir)/download.in.html head2 ( type head2 $(srcdir)\download.in.html $(srcdir)\end ) | $(FILTER) > $@ @@ -126,10 +112,10 @@ ../gabriel/BENCHMARK: if not exist ..\gabriel $(MKDIR) ..\gabriel echo No benchmarks available > ..\gabriel\BENCHMARK -license.html: $(top_srcdir)/../Copyright head2 +license.html: $(top_srcdir)/../LICENSE head2 type head2 > html_tmp echo "
" >> html_tmp
-	type $(top_srcdir)\..\Copyright >> html_tmp
+	type $(top_srcdir)\..\LICENSE >> html_tmp
 	echo "
" >> html_tmp type $(srcdir)\end >> html_tmp $(FILTER) < html_tmp > $@ @@ -152,11 +138,6 @@ IF NOT EXIST ecldev MKDIR ecldev makeinfo -v -I $(srcdir) --html $(srcdir)/devel.txi echo > developers_manual -clx_manual: $(srcdir)/../clx/manual/clx.texinfo - echo "Producing clx.html; ignore error messages." - IF NOT EXIST clx MKDIR clx - makeinfo -v --html $(srcdir)\..\clx\manual\clx.texinfo - echo > clx_manual clean: - -for %i in (ecl ecldev clx ..\gabriel) do $(RMDIR) %i - -for %i in (ecl.info* ecldev.info* $(HTML_FILES) head2 user_manual developers_manual clx_manual ..\gabriel\BENCHMARK) do $(RM) %i + -for %i in (ecl ecldev ..\gabriel) do $(RMDIR) %i + -for %i in (ecl.info* ecldev.info* $(HTML_FILES) head2 user_manual developers_manual_manual ..\gabriel\BENCHMARK) do $(RM) %i diff -Nru ecl-16.1.2/msvc/ecl/config.h.msvc6 ecl-16.1.3+ds/msvc/ecl/config.h.msvc6 --- ecl-16.1.2/msvc/ecl/config.h.msvc6 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/msvc/ecl/config.h.msvc6 2016-12-19 10:25:00.000000000 +0000 @@ -218,12 +218,16 @@ /* #undef HAVE_FLOAT_COMPLEX */ /* Missing integer types */ +#if _MSC_VER < 1900 typedef char int8_t; typedef short int16_t; typedef int int32_t; typedef unsigned char uint8_t; typedef unsigned short uint16_t; typedef unsigned int uint32_t; +#else +#include +#endif /* We can use small, two-words conses, without type information */ /* #undef ECL_SMALL_CONS */ @@ -239,224 +243,3 @@ #undef ECL_SSE2 #endif #endif - - -/* -CUT-: Everything below this mark will not be installed */ -/* -------------------------------------------------------------------- * - * BUILD OPTIONS WHICH NEED NOT BE EXPORTED * - * -------------------------------------------------------------------- */ -/* - * FEATURES LINKED IN: - */ - -/* CLX */ -#define CLX 1 -/* Locatives */ -/* #undef LOCATIVE */ -/* Use old MIT LOOP macro system */ -/* #undef ECL_OLD_LOOP */ - -/* Define this if you want a runtime version only without compiler */ -/* #undef RUNTIME */ -/* Profile tool */ -/* #undef PROFILE */ -/* Program Development Environment */ -/* #undef PDE */ - -/* Allow loading dynamically linked code */ -#define ENABLE_DLOPEN 1 - -/* Undefine this if you do not want ECL to check for circular lists */ -#define ECL_SAFE - -/* Use CMU Common-Lisp's FORMAT routine */ -#define ECL_CMU_FORMAT 1 - -/* Bytecodes and arguments are 8 and 16 bits large, respectively */ -/* #undef ECL_SMALL_BYTECODES */ - -/* Assembler implementation of APPLY and friends */ -/* #undef ECL_ASM_APPLY */ - -/* Activate Boehm-Weiser incremental garbage collector */ -/* #undef GBC_BOEHM_GENGC */ - -#define ECL_WEAK_HASH - -/* - * SYSTEM FEATURES: - */ - -/* Arguments cannot be accessed as array */ -/* #undef NO_ARGS_ARRAY */ -/* Most significant byte first */ -/* #undef WORDS_BIGENDIAN */ -/* Has */ -/* #undef HAVE_SYS_RESOURCE_H */ -/* #undef HAVE_ULIMIT_H */ -/* High precision timer */ -/* #undef HAVE_NANOSLEEP */ -/* Float version if isnan() */ -/* #undef HAVE_ISNANF */ -/* float.h for epsilons, maximum real numbers, etc */ -#define HAVE_FLOAT_H 1 -/* select() */ -/* #undef HAVE_SELECT */ -/* #undef HAVE_SYS_SELECT_H */ -/* #undef HAVE_SYS_IOCTL_H */ -/* putenv() or setenv() */ -#undef HAVE_SETENV -#define HAVE_PUTENV 1 -/* times() and sys/times.h */ -/* #undef HAVE_TIMES */ -/* gettimeofday() and sys/time.h */ -/* #undef HAVE_GETTIMEOFDAY */ -/* getrusage() and sys/resource.h */ -/* #undef HAVE_GETRUSAGE */ -/* user home directory, user name, etc... */ -/* #undef HAVE_PW_H */ -/* symbolic links and checking their existence */ -/* #undef HAVE_LSTAT */ -/* safe creation of temporary files */ -/* #undef HAVE_MKSTEMP */ -/* timer for userland threads */ -/* #undef HAVE_ALARM */ -/* filesytem */ -/* #undef HAVE_DIRENT_H */ -/* dynamic linking of libraries */ -/* #undef HAVE_DLFCN_H */ -/* #undef HAVE_LINK_H */ -/* #undef HAVE_MACH_O_DYLD_H */ -/* POSIX signals */ -/* #undef HAVE_SIGPROCMASK */ -/* isatty() checks whether a file is connected to a */ -#define HAVE_ISATTY 1 -/* can manipulate floating point environment */ -/* #undef HAVE_FENV_H */ -/* can activate individual traps in floating point environment */ -/* #undef HAVE_FEENABLEEXCEPT */ -/* do we want to deactivate all support for floating point exceptions */ -/* #undef ECL_AVOID_FPE_H */ -/* do we want to have signed zeros */ -#define ECL_SIGNED_ZERO 1 -/* do we want NaNs and Infs */ -#define ECL_IEEE_FP 1 -/* has support for large files */ -/* #undef HAVE_FSEEKO */ -/* compiler understands long long */ -#define HAVE_LONG_LONG 1 -/* the tzset() function gets the current time zone */ -#define HAVE_TZSET 1 -/* several floating point functions (ISO C99) */ -#if 0 -#undef HAVE_EXPF -#undef HAVE_LOGF -#undef HAVE_SQRTF -#undef HAVE_COSF -#undef HAVE_SINF -#undef HAVE_TANF -#undef HAVE_SINHF -#undef HAVE_COSHF -#undef HAVE_TANHF -#endif -#define HAVE_FLOORF -#define HAVE_CEILF -#define HAVE_FABSF -#define HAVE_FREXPF -#define HAVE_LDEXPF -#define HAVE_LOG1PL -/* whether we have sched_yield() that gives priority to other threads */ -/* #undef HAVE_SCHED_YIELD */ -/* uname() for system identification */ -/* #undef HAVE_UNAME */ -/* #undef HAVE_UNISTD_H */ -/* #undef HAVE_SYS_WAIT_H */ -/* size of long long */ -#define ECL_LONG_LONG_BITS 64 - -/* - * we do not manage to get proper signal handling of floating point - * arithmetics in the Alpha chips. - */ -#if defined(__alpha__) -# ifdef HAVE_FENV_H -# undef HAVE_FENV_H -# endif -# ifdef HAVE_FEENABLEEXCEPT -# undef HAVE_FEENABLEEXCEPT -# endif -#endif - -/* what characters are used to mark beginning of new line */ -#define ECL_NEWLINE_IS_CRLF 1 -/* #undef ECL_NEWLINE_IS_LFCR */ - -/* - * PARAMETERS: - */ - -/* - * Memory limits for the old garbage collector. - */ -#define LISP_PAGESIZE 2048 /* Page size in bytes */ -#define MAXPAGE 16384 /* Maximum Memory Size */ - -/* We reserve these many bytes for computation with bignums registers */ -#define BIGNUM_REGISTER_SIZE 16 - -/* We allocate a number of strings in a pool which is used to speed up reading */ -#define ECL_MAX_STRING_POOL_SIZE 10 -#define ECL_BUFFER_STRING_SIZE 128 - -/* - * Macros that depend on these system features. - */ -#if defined(sparc) || defined(i386) || defined(mips) -# define stack_align(n) (((n) + 0x7) & ~0x7) -#else -# define stack_align(n) (((n) + 03) & ~03) -#endif - -/* #undef FILE_CNT */ -#if 0 == 1 -# define FILE_CNT(fp) ((fp)->_IO_read_end - (fp)->_IO_read_ptr) -#endif -#if 0 == 2 -# define FILE_CNT(fp) ((fp)->_r) -#endif -#if 3 == 3 -# define FILE_CNT(fp) ((fp)->_cnt) -#endif - -#if defined(cygwin) || defined(mingw32) || defined(_MSC_VER) -# define IS_DIR_SEPARATOR(x) ((x=='/')||(x=='\\')) -# define DIR_SEPARATOR '/' -# define PATH_SEPARATOR ';' -#else -# define IS_DIR_SEPARATOR(x) (x=='/') -# define DIR_SEPARATOR '/' -# define PATH_SEPARATOR ':' -#endif - -#define ECL_ARCHITECTURE "PENTIUM4" - -#ifdef ECL_AVOID_FPE_H -# define ecl_detect_fpe() -#else -# include "@ECL_FPE_CODE@" -#endif - -#define strcasecmp _stricmp -#define isnan _isnan -#define finite _finite -#define sleep _sleep - -#include "@ECL_FPE_CODE@" - -#include -#ifndef isfinite -# define isfinite(x) (finite(x)) -# define signbit(x) (_copysign(1.0,(x)) < 0) -# define ECL_MATHERR_CLEAR -# define ECL_MATHERR_TEST -#endif diff -Nru ecl-16.1.2/msvc/ecl/config-internal.h.msvc6 ecl-16.1.3+ds/msvc/ecl/config-internal.h.msvc6 --- ecl-16.1.2/msvc/ecl/config-internal.h.msvc6 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/msvc/ecl/config-internal.h.msvc6 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,215 @@ +/* + * FEATURES LINKED IN: + */ + +/* Locatives */ +/* #undef LOCATIVE */ +/* Use old MIT LOOP macro system */ +/* #undef ECL_OLD_LOOP */ + +/* Define this if you want a runtime version only without compiler */ +/* #undef RUNTIME */ +/* Profile tool */ +/* #undef PROFILE */ +/* Program Development Environment */ +/* #undef PDE */ + +/* Allow loading dynamically linked code */ +#define ENABLE_DLOPEN 1 + +/* Undefine this if you do not want ECL to check for circular lists */ +#define ECL_SAFE + +/* Use CMU Common-Lisp's FORMAT routine */ +#define ECL_CMU_FORMAT 1 + +/* Bytecodes and arguments are 8 and 16 bits large, respectively */ +/* #undef ECL_SMALL_BYTECODES */ + +/* Assembler implementation of APPLY and friends */ +/* #undef ECL_ASM_APPLY */ + +/* Activate Boehm-Weiser incremental garbage collector */ +/* #undef GBC_BOEHM_GENGC */ + +#define ECL_WEAK_HASH + +/* + * SYSTEM FEATURES: + */ + +/* Arguments cannot be accessed as array */ +/* #undef NO_ARGS_ARRAY */ +/* Most significant byte first */ +/* #undef WORDS_BIGENDIAN */ +/* Has */ +/* #undef HAVE_SYS_RESOURCE_H */ +/* #undef HAVE_ULIMIT_H */ +/* High precision timer */ +/* #undef HAVE_NANOSLEEP */ +/* Float version if isnan() */ +/* #undef HAVE_ISNANF */ +/* float.h for epsilons, maximum real numbers, etc */ +#define HAVE_FLOAT_H 1 +/* select() */ +/* #undef HAVE_SELECT */ +/* #undef HAVE_SYS_SELECT_H */ +/* #undef HAVE_SYS_IOCTL_H */ +/* putenv() or setenv() */ +#undef HAVE_SETENV +#define HAVE_PUTENV 1 +/* times() and sys/times.h */ +/* #undef HAVE_TIMES */ +/* gettimeofday() and sys/time.h */ +/* #undef HAVE_GETTIMEOFDAY */ +/* getrusage() and sys/resource.h */ +/* #undef HAVE_GETRUSAGE */ +/* user home directory, user name, etc... */ +/* #undef HAVE_PW_H */ +/* symbolic links and checking their existence */ +/* #undef HAVE_LSTAT */ +/* safe creation of temporary files */ +/* #undef HAVE_MKSTEMP */ +/* timer for userland threads */ +/* #undef HAVE_ALARM */ +/* filesytem */ +/* #undef HAVE_DIRENT_H */ +/* dynamic linking of libraries */ +/* #undef HAVE_DLFCN_H */ +/* #undef HAVE_LINK_H */ +/* #undef HAVE_MACH_O_DYLD_H */ +/* POSIX signals */ +/* #undef HAVE_SIGPROCMASK */ +/* isatty() checks whether a file is connected to a */ +#define HAVE_ISATTY 1 +/* can manipulate floating point environment */ +/* #undef HAVE_FENV_H */ +/* can activate individual traps in floating point environment */ +/* #undef HAVE_FEENABLEEXCEPT */ +/* do we want to deactivate all support for floating point exceptions */ +/* #undef ECL_AVOID_FPE_H */ +/* do we want to have signed zeros */ +#define ECL_SIGNED_ZERO 1 +/* do we want NaNs and Infs */ +#define ECL_IEEE_FP 1 +/* has support for large files */ +/* #undef HAVE_FSEEKO */ +/* compiler understands long long */ +#define HAVE_LONG_LONG 1 +/* the tzset() function gets the current time zone */ +#define HAVE_TZSET 1 +/* several floating point functions (ISO C99) */ +#if 0 +#undef HAVE_EXPF +#undef HAVE_LOGF +#undef HAVE_SQRTF +#undef HAVE_COSF +#undef HAVE_SINF +#undef HAVE_TANF +#undef HAVE_SINHF +#undef HAVE_COSHF +#undef HAVE_TANHF +#endif +#define HAVE_FLOORF +#define HAVE_CEILF +#define HAVE_FABSF +#define HAVE_FREXPF +#define HAVE_LDEXPF +#define HAVE_LOG1PL +/* whether we have sched_yield() that gives priority to other threads */ +/* #undef HAVE_SCHED_YIELD */ +/* uname() for system identification */ +/* #undef HAVE_UNAME */ +/* #undef HAVE_UNISTD_H */ +/* #undef HAVE_SYS_WAIT_H */ +/* size of long long */ +#define ECL_LONG_LONG_BITS 64 + +/* + * we do not manage to get proper signal handling of floating point + * arithmetics in the Alpha chips. + */ +#if defined(__alpha__) +# ifdef HAVE_FENV_H +# undef HAVE_FENV_H +# endif +# ifdef HAVE_FEENABLEEXCEPT +# undef HAVE_FEENABLEEXCEPT +# endif +#endif + +/* what characters are used to mark beginning of new line */ +#define ECL_NEWLINE_IS_CRLF 1 +/* #undef ECL_NEWLINE_IS_LFCR */ + +/* + * PARAMETERS: + */ + +/* + * Memory limits for the old garbage collector. + */ +#define LISP_PAGESIZE 2048 /* Page size in bytes */ +#define MAXPAGE 16384 /* Maximum Memory Size */ + +/* We reserve these many bytes for computation with bignums registers */ +#define BIGNUM_REGISTER_SIZE 16 + +/* We allocate a number of strings in a pool which is used to speed up reading */ +#define ECL_MAX_STRING_POOL_SIZE 10 +#define ECL_BUFFER_STRING_SIZE 128 + +/* + * Macros that depend on these system features. + */ +#if defined(sparc) || defined(i386) || defined(mips) +# define stack_align(n) (((n) + 0x7) & ~0x7) +#else +# define stack_align(n) (((n) + 03) & ~03) +#endif + +#undef FILE_CNT +#if 0 == 1 +# define FILE_CNT(fp) ((fp)->_IO_read_end - (fp)->_IO_read_ptr) +#endif +#if 0 == 2 +# define FILE_CNT(fp) ((fp)->_r) +#endif +#if ( defined(_MSC_VER) && (_MSC_VER < 1900) ) && 3 == 3 +# define FILE_CNT(fp) ((fp)->_cnt) +#endif + +#if defined(cygwin) || defined(mingw32) || defined(_MSC_VER) +# define IS_DIR_SEPARATOR(x) ((x=='/')||(x=='\\')) +# define DIR_SEPARATOR '/' +# define PATH_SEPARATOR ';' +#else +# define IS_DIR_SEPARATOR(x) (x=='/') +# define DIR_SEPARATOR '/' +# define PATH_SEPARATOR ':' +#endif + +#define ECL_ARCHITECTURE "PENTIUM4" + +#ifdef ECL_AVOID_FPE_H +# define ecl_detect_fpe() +#else +# include "@ECL_FPE_CODE@" +#endif + +#define strcasecmp _stricmp +#if defined(_MSC_VER) && (_MSC_VER < 1900) +#define isnan _isnan +#endif +#define finite _finite +#define sleep _sleep + +#include "@ECL_FPE_CODE@" + +#include +#ifndef isfinite +# define isfinite(x) (finite(x)) +# define signbit(x) (_copysign(1.0,(x)) < 0) +# define ECL_MATHERR_CLEAR +# define ECL_MATHERR_TEST +#endif diff -Nru ecl-16.1.2/msvc/Makefile ecl-16.1.3+ds/msvc/Makefile --- ecl-16.1.2/msvc/Makefile 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/msvc/Makefile 2016-12-19 10:25:00.000000000 +0000 @@ -10,8 +10,8 @@ SHORT_SITE_NAME = LONG_SITE_NAME = -ECL_VERSION = 16.1.2 -ECL_VERSION_NUMBER= 161002 +ECL_VERSION = 16.1.3 +ECL_VERSION_NUMBER= 160103 ARCHITECTURE = PENTIUM4 SOFTWARE_TYPE = NT SOFTWARE_VERSION = 5.0 @@ -53,8 +53,6 @@ ECL_ASDF = # TCP support ECL_SOCKETS = -# X Windows support -# ECL_CLX = 1 # Regression Tests support ECL_RT = # Defsystem support @@ -181,10 +179,6 @@ ECL_MODULES = $(ECL_MODULES) sockets ECL_FEATURES = (cons :wants-sockets $(ECL_FEATURES)) !endif -!ifdef ECL_CLX -ECL_MODULES = $(ECL_MODULES) clx -ECL_FEATURES = (cons :wants-clx $(ECL_FEATURES)) -!endif !ifdef ECL_RT ECL_MODULES = $(ECL_MODULES) rt ECL_FEATURES = (cons :wants-rt $(ECL_FEATURES)) @@ -297,7 +291,6 @@ $(CP) $(srcdir)\cmp\load.lsp.in cmp\load.lsp cmp/cmpdefs.lsp: $(srcdir)/cmp/cmpdefs.lsp Makefile c\cut "@ECL_CC@" "$(CC)" \ - "@CC_IS_CXX@" "nil" \ "@CFLAGS@" "$(CFLAGS)" \ "@CFLAGS_OPTIMIZE@" "$(CFLAGS_OPTIMIZE)" \ "@ECL_CFLAGS@" "" \ @@ -363,12 +356,10 @@ $(CP) gmp.lib ..\eclgmp.lib $(CP) gmp.h ..\ecl\gmp.h cd .. + sysfun.lsp: $(CP) $(srcdir)\cmp\sysfun.lsp .\ -rt.lisp: - $(CP) $(srcdir)\..\contrib\rt\rt.lisp .\ - install: IF NOT EXIST "$(prefix)" $(MKDIR) "$(prefix)" IF NOT EXIST "$(bindir)" $(MKDIR) "$(bindir)" @@ -394,7 +385,7 @@ for /f %i in ('type MODULES') do $(CP) %i "$(libdir)" for %i in (ecl-static.lib) do IF EXIST %i $(CP) %i "$(libdir)" IF NOT EXIST "$(docdir)" $(MKDIR) "$(docdir)" - for %i in (..\Copyright ..\LGPL ..\README.1st ..\CHANGELOG) do $(CP) %i "$(docdir)" + for %i in (..\LICENSE ..\LGPL ..\README.md ..\CHANGELOG) do $(CP) %i "$(docdir)" !if "$(ECL_UNICODE)" != "" IF NOT EXIST "$(libdir)\encodings" $(MKDIR) "$(libdir)\encodings" $(CP) encodings\*.* "$(libdir)\encodings" @@ -473,10 +464,10 @@ test3: -mkdir stage2 cp -rf lsp clos cmp stage2 - -for i in lsp cmp clos clx tk; do test -f lib$$i.a && mv lib$$i.a stage2; done + -for i in lsp cmp clos tk; do test -f lib$$i.a && mv lib$$i.a stage2; done $(MAKE) clean_lisp ./ecl < compile.lsp - -for i in lsp clos cmp clx tk; do test -d $$i && diff --exclude=\*.o $$i stage2/$$i; done | less + -for i in lsp clos cmp tk; do test -d $$i && diff --exclude=\*.o $$i stage2/$$i; done | less test: $(MAKE) -C tests $(MAKE) -C ansi-tests > ansi-tests/log diff -Nru ecl-16.1.2/src/aclocal.m4 ecl-16.1.3+ds/src/aclocal.m4 --- ecl-16.1.2/src/aclocal.m4 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/aclocal.m4 2016-12-19 10:25:00.000000000 +0000 @@ -6,7 +6,7 @@ if test "$enable_longdouble" != "no" ; then AC_CHECK_TYPES([long double],[enable_longdouble=yes],[enable_longdouble=no]) if test "$enable_longdouble" != "no" ; then -AC_CHECK_FUNCS([sinl cosl tanl logl expl],[],[enable_longdouble=no; break]) +AC_CHECK_FUNCS([sinl cosl tanl logl expl ldexpl frexpl],[],[enable_longdouble=no; break]) if test "$enable_longdouble" != "no" ; then AC_DEFINE([ECL_LONG_FLOAT], [], [ECL_LONG_FLOAT]) fi @@ -55,8 +55,7 @@ AC_MSG_RESULT([$ECL_LONG_LONG_BITS]) AC_DEFINE([ecl_long_long_t], [long long], [compiler understands long long]) AC_DEFINE([ecl_ulong_long_t], [unsigned long long], [compiler understands long long]) - AC_DEFINE_UNQUOTED([ECL_LONG_LONG_BITS],[$ECL_LONG_LONG_BITS], - [ECL_LOING_LONG_BITS])dnl last param needs to be on a new line. -evrim. + AC_DEFINE_UNQUOTED([ECL_LONG_LONG_BITS],[$ECL_LONG_LONG_BITS], [ECL_LONG_LONG_BITS]) fi ]) @@ -248,8 +247,8 @@ THREAD_LIBS='' THREAD_GC_FLAGS='--enable-threads=posix' INSTALL_TARGET='install' -THREAD_OBJ="$THREAD_OBJ threads/process threads/queue threads/mutex threads/condition_variable threads/semaphore threads/barrier threads/mailbox" -clibs='' +THREAD_OBJ="$THREAD_OBJ c/threads/process c/threads/queue c/threads/mutex c/threads/condition_variable c/threads/semaphore c/threads/barrier c/threads/mailbox" +clibs='-lm' SONAME='' SONAME_LDFLAGS='' case "${host_os}" in @@ -260,11 +259,9 @@ SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH='-Wl,--rpath,~A' - clibs="-ldl" + clibs="-ldl ${clibs}" # Maybe CFLAGS="-D_ISOC99_SOURCE ${CFLAGS}" ??? - CFLAGS="-D_GNU_SOURCE -D_FILE_OFFSET_BITS=64 -DANDROID -DPLATFORM_ANDROID -DUSE_GET_STACKBASE_FOR_MAIN -DIGNORE_DYNAMIC_LOADING -DAO_REQUIRE_CAS ${CFLAGS}" - SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION" - SONAME_LDFLAGS="-Wl,-soname,SONAME" + CFLAGS="-D_GNU_SOURCE -D_FILE_OFFSET_BITS=64 -DPLATFORM_ANDROID -DUSE_GET_STACKBASE_FOR_MAIN -DIGNORE_DYNAMIC_LOADING ${CFLAGS}" ECL_ADD_FEATURE([android]) ;; @@ -276,7 +273,7 @@ SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH='-Wl,--rpath,~A' - clibs="-ldl" + clibs="-ldl ${clibs}" # Maybe CFLAGS="-D_ISOC99_SOURCE ${CFLAGS}" ??? CFLAGS="-D_GNU_SOURCE -D_FILE_OFFSET_BITS=64 ${CFLAGS}" SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION" @@ -289,7 +286,7 @@ SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH='-Wl,--rpath,~A' - clibs="-ldl" + clibs="-ldl ${clibs}" CFLAGS="-D_GNU_SOURCE ${CFLAGS}" SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION" SONAME_LDFLAGS="-Wl,-soname,SONAME" @@ -301,7 +298,7 @@ SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH='-Wl,--rpath,~A' - clibs="-ldl" + clibs="-ldl ${clibs}" CFLAGS="-D_GNU_SOURCE ${CFLAGS}" SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION" SONAME_LDFLAGS="-Wl,-soname,SONAME" @@ -312,7 +309,7 @@ SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH="-Wl,--rpath,~A" - clibs="" + clibs="${clibs}" SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION" SONAME_LDFLAGS="-Wl,-soname,SONAME" ;; @@ -322,7 +319,7 @@ SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH="-Wl,--rpath,~A" - clibs="" + clibs="${clibs}" SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION" SONAME_LDFLAGS="-Wl,-soname,SONAME" ;; @@ -332,7 +329,7 @@ SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH="-Wl,--rpath,~A" - clibs="" + clibs="${clibs}" SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION" SONAME_LDFLAGS="-Wl,-soname,SONAME" ;; @@ -343,7 +340,7 @@ SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH="-Wl,--rpath,~A" - clibs="-lpthread -lm" + clibs="-lpthread ${clibs}" SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION" SONAME_LDFLAGS="-Wl,-soname,SONAME" ;; @@ -354,9 +351,9 @@ BUNDLE_LDFLAGS="-dy -G ${LDFLAGS}" ECL_LDRPATH='-Wl,-R,~A' TCPLIBS='-lsocket -lnsl -lintl' - clibs='-ldl' - SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION" - SONAME_LDFLAGS="-Wl,-soname,SONAME" + clibs='${clibs} -ldl' + SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION" + SONAME_LDFLAGS="-Wl,-soname,SONAME" if test "x$GCC" = "xyes"; then CFLAGS="${CFLAGS} -std=gnu99 -D_XOPEN_SOURCE=600 -D__EXTENSIONS__" SHARED_LDFLAGS="-shared $SHARED_LDFLAGS" @@ -364,8 +361,8 @@ fi ;; cygwin*) - enable_threads='no' thehost='cygwin' + #enable_threads='no' shared='yes' THREAD_CFLAGS='-D_THREAD_SAFE' THREAD_LIBS='-lpthread' @@ -382,6 +379,9 @@ ;; mingw*) thehost='mingw32' + dnl We disable fpe because ECL/MinGW has problems with FE_INEXACT + with_ieee_fp='no' + with_fpe='no' clibs='' shared='yes' enable_threads='yes' @@ -440,8 +440,28 @@ SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH='-Wld=\"-rld_l ~A\"' - clibs="-Wld=-lrld" + clibs="-Wld=-lrld ${clibs}" + ;; + haiku*) + thehost='haiku' + THREAD_LIBS='' + SHARED_LDFLAGS="-shared ${LDFLAGS}" + BUNDLE_LDFLAGS="-shared ${LDFLAGS}" + ECL_LDRPATH="-Wl,--rpath,~A" + clibs="-lnetwork" + SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION" + SONAME_LDFLAGS="-Wl,-soname,SONAME" ;; + aix*) + PICFLAG='-DPIC' + thehost="aix" + THREAD_LIBS='-lpthread' + SHARED_LDFLAGS="-G -bsvr4 -brtl ${LDFLAGS}" + BUNDLE_LDFLAGS="-G -bsvr4 -brtl ${LDFLAGS}" + ECL_LDRPATH="-Wl,-R~A" + SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION" + SONAME_LDFLAGS="-bsvr4 -brtl" + ;; *) thehost="$host_os" shared="no" @@ -898,10 +918,12 @@ dnl Check whether we have POSIX read/write locks are available AC_DEFUN([ECL_POSIX_RWLOCK],[ AC_CHECK_FUNC( [pthread_rwlock_init], [ - AC_DEFINE([ECL_RWLOCK], [], [ECL_RWLOCK]) - AC_DEFINE([HAVE_POSIX_RWLOCK], [], [HAVE_POSIX_RWLOCK]) + AC_CHECK_TYPES([pthread_rwlock_t], [ + AC_DEFINE([ECL_RWLOCK], [], [ECL_RWLOCK]) + AC_DEFINE([HAVE_POSIX_RWLOCK], [], [HAVE_POSIX_RWLOCK]) + ], []) ], []) -THREAD_OBJ="$THREAD_OBJ threads/rwlock" +THREAD_OBJ="$THREAD_OBJ c/threads/rwlock" ]) @@ -1018,7 +1040,7 @@ fi else FASL_LIBS="${FASL_LIBS} -lgc" - EXTRA_OBJS="${EXTRA_OBJS} alloc_2.${OBJEXT}" + EXTRA_OBJS="${EXTRA_OBJS} c/alloc_2.${OBJEXT}" AC_DEFINE(GBC_BOEHM, [1], [Use Boehm's garbage collector]) fi fi @@ -1049,7 +1071,7 @@ ECL_BOEHM_GC_HEADER='ecl/gc/gc.h' SUBDIRS="${SUBDIRS} gc" CORE_LIBS="-leclgc ${CORE_LIBS}" - EXTRA_OBJS="${EXTRA_OBJS} alloc_2.${OBJEXT}" + EXTRA_OBJS="${EXTRA_OBJS} c/alloc_2.${OBJEXT}" if test "${enable_shared}" = "no"; then LIBRARIES="${LIBRARIES} ${LIBPREFIX}eclgc.${LIBEXT}" fi @@ -1122,7 +1144,7 @@ ECL_LIBFFI_HEADER='ecl/ffi.h' SUBDIRS="${SUBDIRS} libffi" CORE_LIBS="-leclffi ${CORE_LIBS}" - EXTRA_OBJS="${EXTRA_OBJS} alloc_2.${OBJEXT}" + EXTRA_OBJS="${EXTRA_OBJS} c/alloc_2.${OBJEXT}" if test "${enable_shared}" = "no"; then LIBRARIES="${LIBRARIES} ${LIBPREFIX}eclffi.${LIBEXT}" fi diff -Nru ecl-16.1.2/src/bdwgc/aclocal.m4 ecl-16.1.3+ds/src/bdwgc/aclocal.m4 --- ecl-16.1.2/src/bdwgc/aclocal.m4 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/aclocal.m4 1970-01-01 00:00:00.000000000 +0000 @@ -1,1428 +0,0 @@ -# generated automatically by aclocal 1.15 -*- Autoconf -*- - -# Copyright (C) 1996-2014 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. - -m4_ifndef([AC_CONFIG_MACRO_DIRS], [m4_defun([_AM_CONFIG_MACRO_DIRS], [])m4_defun([AC_CONFIG_MACRO_DIRS], [_AM_CONFIG_MACRO_DIRS($@)])]) -m4_ifndef([AC_AUTOCONF_VERSION], - [m4_copy([m4_PACKAGE_VERSION], [AC_AUTOCONF_VERSION])])dnl -m4_if(m4_defn([AC_AUTOCONF_VERSION]), [2.69],, -[m4_warning([this file was generated for autoconf 2.69. -You have another version of autoconf. It may work, but is not guaranteed to. -If you have problems, you may need to regenerate the build system entirely. -To do so, use the procedure documented by the package, typically 'autoreconf'.])]) - -# pkg.m4 - Macros to locate and utilise pkg-config. -*- Autoconf -*- -# serial 1 (pkg-config-0.24) -# -# 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|LIBDIR|SYSROOT_DIR|ALLOW_SYSTEM_(CFLAGS|LIBS)))?$]) -m4_pattern_allow([^PKG_CONFIG_(DISABLE_UNINSTALLED|TOP_BUILD_DIR|DEBUG_SPEW)$]) -AC_ARG_VAR([PKG_CONFIG], [path to pkg-config utility]) -AC_ARG_VAR([PKG_CONFIG_PATH], [directories to add to pkg-config's search path]) -AC_ARG_VAR([PKG_CONFIG_LIBDIR], [path overriding pkg-config's built-in search path]) - -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. -# -# Please remember that m4 expands AC_REQUIRE([PKG_PROG_PKG_CONFIG]) -# only at the first occurence in configure.ac, so if the first place -# it's called might be skipped (such as if it is within an "if", you -# have 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_default([$2], [:]) -m4_ifvaln([$3], [else - $3])dnl -fi]) - -# _PKG_CONFIG([VARIABLE], [COMMAND], [MODULES]) -# --------------------------------------------- -m4_define([_PKG_CONFIG], -[if test -n "$$1"; then - pkg_cv_[]$1="$$1" - elif test -n "$PKG_CONFIG"; then - PKG_CHECK_EXISTS([$3], - [pkg_cv_[]$1=`$PKG_CONFIG --[]$2 "$3" 2>/dev/null` - test "x$?" != "x0" && pkg_failed=yes ], - [pkg_failed=yes]) - 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 - AC_MSG_RESULT([no]) - _PKG_SHORT_ERRORS_SUPPORTED - if test $_pkg_short_errors_supported = yes; then - $1[]_PKG_ERRORS=`$PKG_CONFIG --short-errors --print-errors --cflags --libs "$2" 2>&1` - else - $1[]_PKG_ERRORS=`$PKG_CONFIG --print-errors --cflags --libs "$2" 2>&1` - fi - # Put the nasty error message in config.log where it belongs - echo "$$1[]_PKG_ERRORS" >&AS_MESSAGE_LOG_FD - - m4_default([$4], [AC_MSG_ERROR( -[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])[]dnl - ]) -elif test $pkg_failed = untried; then - AC_MSG_RESULT([no]) - m4_default([$4], [AC_MSG_FAILURE( -[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 .])[]dnl - ]) -else - $1[]_CFLAGS=$pkg_cv_[]$1[]_CFLAGS - $1[]_LIBS=$pkg_cv_[]$1[]_LIBS - AC_MSG_RESULT([yes]) - $3 -fi[]dnl -])# PKG_CHECK_MODULES - - -# PKG_INSTALLDIR(DIRECTORY) -# ------------------------- -# Substitutes the variable pkgconfigdir as the location where a module -# should install pkg-config .pc files. By default the directory is -# $libdir/pkgconfig, but the default can be changed by passing -# DIRECTORY. The user can override through the --with-pkgconfigdir -# parameter. -AC_DEFUN([PKG_INSTALLDIR], -[m4_pushdef([pkg_default], [m4_default([$1], ['${libdir}/pkgconfig'])]) -m4_pushdef([pkg_description], - [pkg-config installation directory @<:@]pkg_default[@:>@]) -AC_ARG_WITH([pkgconfigdir], - [AS_HELP_STRING([--with-pkgconfigdir], pkg_description)],, - [with_pkgconfigdir=]pkg_default) -AC_SUBST([pkgconfigdir], [$with_pkgconfigdir]) -m4_popdef([pkg_default]) -m4_popdef([pkg_description]) -]) dnl PKG_INSTALLDIR - - -# PKG_NOARCH_INSTALLDIR(DIRECTORY) -# ------------------------- -# Substitutes the variable noarch_pkgconfigdir as the location where a -# module should install arch-independent pkg-config .pc files. By -# default the directory is $datadir/pkgconfig, but the default can be -# changed by passing DIRECTORY. The user can override through the -# --with-noarch-pkgconfigdir parameter. -AC_DEFUN([PKG_NOARCH_INSTALLDIR], -[m4_pushdef([pkg_default], [m4_default([$1], ['${datadir}/pkgconfig'])]) -m4_pushdef([pkg_description], - [pkg-config arch-independent installation directory @<:@]pkg_default[@:>@]) -AC_ARG_WITH([noarch-pkgconfigdir], - [AS_HELP_STRING([--with-noarch-pkgconfigdir], pkg_description)],, - [with_noarch_pkgconfigdir=]pkg_default) -AC_SUBST([noarch_pkgconfigdir], [$with_noarch_pkgconfigdir]) -m4_popdef([pkg_default]) -m4_popdef([pkg_description]) -]) dnl PKG_NOARCH_INSTALLDIR - - -# PKG_CHECK_VAR(VARIABLE, MODULE, CONFIG-VARIABLE, -# [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND]) -# ------------------------------------------- -# Retrieves the value of the pkg-config variable for the given module. -AC_DEFUN([PKG_CHECK_VAR], -[AC_REQUIRE([PKG_PROG_PKG_CONFIG])dnl -AC_ARG_VAR([$1], [value of $3 for $2, overriding pkg-config])dnl - -_PKG_CONFIG([$1], [variable="][$3]["], [$2]) -AS_VAR_COPY([$1], [pkg_cv_][$1]) - -AS_VAR_IF([$1], [""], [$5], [$4])dnl -])# PKG_CHECK_VAR - -# Copyright (C) 2002-2014 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. - -# AM_AUTOMAKE_VERSION(VERSION) -# ---------------------------- -# Automake X.Y traces this macro to ensure aclocal.m4 has been -# generated from the m4 files accompanying Automake X.Y. -# (This private macro should not be called outside this file.) -AC_DEFUN([AM_AUTOMAKE_VERSION], -[am__api_version='1.15' -dnl Some users find AM_AUTOMAKE_VERSION and mistake it for a way to -dnl require some minimum version. Point them to the right macro. -m4_if([$1], [1.15], [], - [AC_FATAL([Do not call $0, use AM_INIT_AUTOMAKE([$1]).])])dnl -]) - -# _AM_AUTOCONF_VERSION(VERSION) -# ----------------------------- -# aclocal traces this macro to find the Autoconf version. -# This is a private macro too. Using m4_define simplifies -# the logic in aclocal, which can simply ignore this definition. -m4_define([_AM_AUTOCONF_VERSION], []) - -# AM_SET_CURRENT_AUTOMAKE_VERSION -# ------------------------------- -# Call AM_AUTOMAKE_VERSION and AM_AUTOMAKE_VERSION so they can be traced. -# This function is AC_REQUIREd by AM_INIT_AUTOMAKE. -AC_DEFUN([AM_SET_CURRENT_AUTOMAKE_VERSION], -[AM_AUTOMAKE_VERSION([1.15])dnl -m4_ifndef([AC_AUTOCONF_VERSION], - [m4_copy([m4_PACKAGE_VERSION], [AC_AUTOCONF_VERSION])])dnl -_AM_AUTOCONF_VERSION(m4_defn([AC_AUTOCONF_VERSION]))]) - -# Figure out how to run the assembler. -*- Autoconf -*- - -# Copyright (C) 2001-2014 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. - -# AM_PROG_AS -# ---------- -AC_DEFUN([AM_PROG_AS], -[# By default we simply use the C compiler to build assembly code. -AC_REQUIRE([AC_PROG_CC]) -test "${CCAS+set}" = set || CCAS=$CC -test "${CCASFLAGS+set}" = set || CCASFLAGS=$CFLAGS -AC_ARG_VAR([CCAS], [assembler compiler command (defaults to CC)]) -AC_ARG_VAR([CCASFLAGS], [assembler compiler flags (defaults to CFLAGS)]) -_AM_IF_OPTION([no-dependencies],, [_AM_DEPENDENCIES([CCAS])])dnl -]) - -# AM_AUX_DIR_EXPAND -*- Autoconf -*- - -# Copyright (C) 2001-2014 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. - -# For projects using AC_CONFIG_AUX_DIR([foo]), Autoconf sets -# $ac_aux_dir to '$srcdir/foo'. In other projects, it is set to -# '$srcdir', '$srcdir/..', or '$srcdir/../..'. -# -# Of course, Automake must honor this variable whenever it calls a -# tool from the auxiliary directory. The problem is that $srcdir (and -# therefore $ac_aux_dir as well) can be either absolute or relative, -# depending on how configure is run. This is pretty annoying, since -# it makes $ac_aux_dir quite unusable in subdirectories: in the top -# source directory, any form will work fine, but in subdirectories a -# relative path needs to be adjusted first. -# -# $ac_aux_dir/missing -# fails when called from a subdirectory if $ac_aux_dir is relative -# $top_srcdir/$ac_aux_dir/missing -# fails if $ac_aux_dir is absolute, -# fails when called from a subdirectory in a VPATH build with -# a relative $ac_aux_dir -# -# The reason of the latter failure is that $top_srcdir and $ac_aux_dir -# are both prefixed by $srcdir. In an in-source build this is usually -# harmless because $srcdir is '.', but things will broke when you -# start a VPATH build or use an absolute $srcdir. -# -# So we could use something similar to $top_srcdir/$ac_aux_dir/missing, -# iff we strip the leading $srcdir from $ac_aux_dir. That would be: -# am_aux_dir='\$(top_srcdir)/'`expr "$ac_aux_dir" : "$srcdir//*\(.*\)"` -# and then we would define $MISSING as -# MISSING="\${SHELL} $am_aux_dir/missing" -# This will work as long as MISSING is not called from configure, because -# unfortunately $(top_srcdir) has no meaning in configure. -# However there are other variables, like CC, which are often used in -# configure, and could therefore not use this "fixed" $ac_aux_dir. -# -# Another solution, used here, is to always expand $ac_aux_dir to an -# absolute PATH. The drawback is that using absolute paths prevent a -# configured tree to be moved without reconfiguration. - -AC_DEFUN([AM_AUX_DIR_EXPAND], -[AC_REQUIRE([AC_CONFIG_AUX_DIR_DEFAULT])dnl -# Expand $ac_aux_dir to an absolute path. -am_aux_dir=`cd "$ac_aux_dir" && pwd` -]) - -# AM_CONDITIONAL -*- Autoconf -*- - -# Copyright (C) 1997-2014 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. - -# AM_CONDITIONAL(NAME, SHELL-CONDITION) -# ------------------------------------- -# Define a conditional. -AC_DEFUN([AM_CONDITIONAL], -[AC_PREREQ([2.52])dnl - m4_if([$1], [TRUE], [AC_FATAL([$0: invalid condition: $1])], - [$1], [FALSE], [AC_FATAL([$0: invalid condition: $1])])dnl -AC_SUBST([$1_TRUE])dnl -AC_SUBST([$1_FALSE])dnl -_AM_SUBST_NOTMAKE([$1_TRUE])dnl -_AM_SUBST_NOTMAKE([$1_FALSE])dnl -m4_define([_AM_COND_VALUE_$1], [$2])dnl -if $2; then - $1_TRUE= - $1_FALSE='#' -else - $1_TRUE='#' - $1_FALSE= -fi -AC_CONFIG_COMMANDS_PRE( -[if test -z "${$1_TRUE}" && test -z "${$1_FALSE}"; then - AC_MSG_ERROR([[conditional "$1" was never defined. -Usually this means the macro was only invoked conditionally.]]) -fi])]) - -# Copyright (C) 1999-2014 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. - - -# There are a few dirty hacks below to avoid letting 'AC_PROG_CC' be -# written in clear, in which case automake, when reading aclocal.m4, -# will think it sees a *use*, and therefore will trigger all it's -# C support machinery. Also note that it means that autoscan, seeing -# CC etc. in the Makefile, will ask for an AC_PROG_CC use... - - -# _AM_DEPENDENCIES(NAME) -# ---------------------- -# See how the compiler implements dependency checking. -# NAME is "CC", "CXX", "OBJC", "OBJCXX", "UPC", or "GJC". -# We try a few techniques and use that to set a single cache variable. -# -# We don't AC_REQUIRE the corresponding AC_PROG_CC since the latter was -# modified to invoke _AM_DEPENDENCIES(CC); we would have a circular -# dependency, and given that the user is not expected to run this macro, -# just rely on AC_PROG_CC. -AC_DEFUN([_AM_DEPENDENCIES], -[AC_REQUIRE([AM_SET_DEPDIR])dnl -AC_REQUIRE([AM_OUTPUT_DEPENDENCY_COMMANDS])dnl -AC_REQUIRE([AM_MAKE_INCLUDE])dnl -AC_REQUIRE([AM_DEP_TRACK])dnl - -m4_if([$1], [CC], [depcc="$CC" am_compiler_list=], - [$1], [CXX], [depcc="$CXX" am_compiler_list=], - [$1], [OBJC], [depcc="$OBJC" am_compiler_list='gcc3 gcc'], - [$1], [OBJCXX], [depcc="$OBJCXX" am_compiler_list='gcc3 gcc'], - [$1], [UPC], [depcc="$UPC" am_compiler_list=], - [$1], [GCJ], [depcc="$GCJ" am_compiler_list='gcc3 gcc'], - [depcc="$$1" am_compiler_list=]) - -AC_CACHE_CHECK([dependency style of $depcc], - [am_cv_$1_dependencies_compiler_type], -[if test -z "$AMDEP_TRUE" && test -f "$am_depcomp"; then - # We make a subdir and do the tests there. Otherwise we can end up - # making bogus files that we don't know about and never remove. For - # instance it was reported that on HP-UX the gcc test will end up - # making a dummy file named 'D' -- because '-MD' means "put the output - # in D". - rm -rf conftest.dir - mkdir conftest.dir - # Copy depcomp to subdir because otherwise we won't find it if we're - # using a relative directory. - cp "$am_depcomp" conftest.dir - cd conftest.dir - # We will build objects and dependencies in a subdirectory because - # it helps to detect inapplicable dependency modes. For instance - # both Tru64's cc and ICC support -MD to output dependencies as a - # side effect of compilation, but ICC will put the dependencies in - # the current directory while Tru64 will put them in the object - # directory. - mkdir sub - - am_cv_$1_dependencies_compiler_type=none - if test "$am_compiler_list" = ""; then - am_compiler_list=`sed -n ['s/^#*\([a-zA-Z0-9]*\))$/\1/p'] < ./depcomp` - fi - am__universal=false - m4_case([$1], [CC], - [case " $depcc " in #( - *\ -arch\ *\ -arch\ *) am__universal=true ;; - esac], - [CXX], - [case " $depcc " in #( - *\ -arch\ *\ -arch\ *) am__universal=true ;; - esac]) - - for depmode in $am_compiler_list; do - # Setup a source with many dependencies, because some compilers - # like to wrap large dependency lists on column 80 (with \), and - # we should not choose a depcomp mode which is confused by this. - # - # We need to recreate these files for each test, as the compiler may - # overwrite some of them when testing with obscure command lines. - # This happens at least with the AIX C compiler. - : > sub/conftest.c - for i in 1 2 3 4 5 6; do - echo '#include "conftst'$i'.h"' >> sub/conftest.c - # Using ": > sub/conftst$i.h" creates only sub/conftst1.h with - # Solaris 10 /bin/sh. - echo '/* dummy */' > sub/conftst$i.h - done - echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf - - # We check with '-c' and '-o' for the sake of the "dashmstdout" - # mode. It turns out that the SunPro C++ compiler does not properly - # handle '-M -o', and we need to detect this. Also, some Intel - # versions had trouble with output in subdirs. - am__obj=sub/conftest.${OBJEXT-o} - am__minus_obj="-o $am__obj" - case $depmode in - gcc) - # This depmode causes a compiler race in universal mode. - test "$am__universal" = false || continue - ;; - nosideeffect) - # After this tag, mechanisms are not by side-effect, so they'll - # only be used when explicitly requested. - if test "x$enable_dependency_tracking" = xyes; then - continue - else - break - fi - ;; - msvc7 | msvc7msys | msvisualcpp | msvcmsys) - # This compiler won't grok '-c -o', but also, the minuso test has - # not run yet. These depmodes are late enough in the game, and - # so weak that their functioning should not be impacted. - am__obj=conftest.${OBJEXT-o} - am__minus_obj= - ;; - none) break ;; - esac - if depmode=$depmode \ - source=sub/conftest.c object=$am__obj \ - depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \ - $SHELL ./depcomp $depcc -c $am__minus_obj sub/conftest.c \ - >/dev/null 2>conftest.err && - grep sub/conftst1.h sub/conftest.Po > /dev/null 2>&1 && - grep sub/conftst6.h sub/conftest.Po > /dev/null 2>&1 && - grep $am__obj sub/conftest.Po > /dev/null 2>&1 && - ${MAKE-make} -s -f confmf > /dev/null 2>&1; then - # icc doesn't choke on unknown options, it will just issue warnings - # or remarks (even with -Werror). So we grep stderr for any message - # that says an option was ignored or not supported. - # When given -MP, icc 7.0 and 7.1 complain thusly: - # icc: Command line warning: ignoring option '-M'; no argument required - # The diagnosis changed in icc 8.0: - # icc: Command line remark: option '-MP' not supported - if (grep 'ignoring option' conftest.err || - grep 'not supported' conftest.err) >/dev/null 2>&1; then :; else - am_cv_$1_dependencies_compiler_type=$depmode - break - fi - fi - done - - cd .. - rm -rf conftest.dir -else - am_cv_$1_dependencies_compiler_type=none -fi -]) -AC_SUBST([$1DEPMODE], [depmode=$am_cv_$1_dependencies_compiler_type]) -AM_CONDITIONAL([am__fastdep$1], [ - test "x$enable_dependency_tracking" != xno \ - && test "$am_cv_$1_dependencies_compiler_type" = gcc3]) -]) - - -# AM_SET_DEPDIR -# ------------- -# Choose a directory name for dependency files. -# This macro is AC_REQUIREd in _AM_DEPENDENCIES. -AC_DEFUN([AM_SET_DEPDIR], -[AC_REQUIRE([AM_SET_LEADING_DOT])dnl -AC_SUBST([DEPDIR], ["${am__leading_dot}deps"])dnl -]) - - -# AM_DEP_TRACK -# ------------ -AC_DEFUN([AM_DEP_TRACK], -[AC_ARG_ENABLE([dependency-tracking], [dnl -AS_HELP_STRING( - [--enable-dependency-tracking], - [do not reject slow dependency extractors]) -AS_HELP_STRING( - [--disable-dependency-tracking], - [speeds up one-time build])]) -if test "x$enable_dependency_tracking" != xno; then - am_depcomp="$ac_aux_dir/depcomp" - AMDEPBACKSLASH='\' - am__nodep='_no' -fi -AM_CONDITIONAL([AMDEP], [test "x$enable_dependency_tracking" != xno]) -AC_SUBST([AMDEPBACKSLASH])dnl -_AM_SUBST_NOTMAKE([AMDEPBACKSLASH])dnl -AC_SUBST([am__nodep])dnl -_AM_SUBST_NOTMAKE([am__nodep])dnl -]) - -# Generate code to set up dependency tracking. -*- Autoconf -*- - -# Copyright (C) 1999-2014 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. - - -# _AM_OUTPUT_DEPENDENCY_COMMANDS -# ------------------------------ -AC_DEFUN([_AM_OUTPUT_DEPENDENCY_COMMANDS], -[{ - # Older Autoconf quotes --file arguments for eval, but not when files - # are listed without --file. Let's play safe and only enable the eval - # if we detect the quoting. - case $CONFIG_FILES in - *\'*) eval set x "$CONFIG_FILES" ;; - *) set x $CONFIG_FILES ;; - esac - shift - for mf - do - # Strip MF so we end up with the name of the file. - mf=`echo "$mf" | sed -e 's/:.*$//'` - # Check whether this is an Automake generated Makefile or not. - # We used to match only the files named 'Makefile.in', but - # some people rename them; so instead we look at the file content. - # Grep'ing the first line is not enough: some people post-process - # each Makefile.in and add a new line on top of each file to say so. - # Grep'ing the whole file is not good either: AIX grep has a line - # limit of 2048, but all sed's we know have understand at least 4000. - if sed -n 's,^#.*generated by automake.*,X,p' "$mf" | grep X >/dev/null 2>&1; then - dirpart=`AS_DIRNAME("$mf")` - else - continue - fi - # Extract the definition of DEPDIR, am__include, and am__quote - # from the Makefile without running 'make'. - DEPDIR=`sed -n 's/^DEPDIR = //p' < "$mf"` - test -z "$DEPDIR" && continue - am__include=`sed -n 's/^am__include = //p' < "$mf"` - test -z "$am__include" && continue - am__quote=`sed -n 's/^am__quote = //p' < "$mf"` - # Find all dependency output files, they are included files with - # $(DEPDIR) in their names. We invoke sed twice because it is the - # simplest approach to changing $(DEPDIR) to its actual value in the - # expansion. - for file in `sed -n " - s/^$am__include $am__quote\(.*(DEPDIR).*\)$am__quote"'$/\1/p' <"$mf" | \ - sed -e 's/\$(DEPDIR)/'"$DEPDIR"'/g'`; do - # Make sure the directory exists. - test -f "$dirpart/$file" && continue - fdir=`AS_DIRNAME(["$file"])` - AS_MKDIR_P([$dirpart/$fdir]) - # echo "creating $dirpart/$file" - echo '# dummy' > "$dirpart/$file" - done - done -} -])# _AM_OUTPUT_DEPENDENCY_COMMANDS - - -# AM_OUTPUT_DEPENDENCY_COMMANDS -# ----------------------------- -# This macro should only be invoked once -- use via AC_REQUIRE. -# -# This code is only required when automatic dependency tracking -# is enabled. FIXME. This creates each '.P' file that we will -# need in order to bootstrap the dependency handling code. -AC_DEFUN([AM_OUTPUT_DEPENDENCY_COMMANDS], -[AC_CONFIG_COMMANDS([depfiles], - [test x"$AMDEP_TRUE" != x"" || _AM_OUTPUT_DEPENDENCY_COMMANDS], - [AMDEP_TRUE="$AMDEP_TRUE" ac_aux_dir="$ac_aux_dir"]) -]) - -# Do all the work for Automake. -*- Autoconf -*- - -# Copyright (C) 1996-2014 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 macro actually does too much. Some checks are only needed if -# your package does certain things. But this isn't really a big deal. - -dnl Redefine AC_PROG_CC to automatically invoke _AM_PROG_CC_C_O. -m4_define([AC_PROG_CC], -m4_defn([AC_PROG_CC]) -[_AM_PROG_CC_C_O -]) - -# AM_INIT_AUTOMAKE(PACKAGE, VERSION, [NO-DEFINE]) -# AM_INIT_AUTOMAKE([OPTIONS]) -# ----------------------------------------------- -# The call with PACKAGE and VERSION arguments is the old style -# call (pre autoconf-2.50), which is being phased out. PACKAGE -# and VERSION should now be passed to AC_INIT and removed from -# the call to AM_INIT_AUTOMAKE. -# We support both call styles for the transition. After -# the next Automake release, Autoconf can make the AC_INIT -# arguments mandatory, and then we can depend on a new Autoconf -# release and drop the old call support. -AC_DEFUN([AM_INIT_AUTOMAKE], -[AC_PREREQ([2.65])dnl -dnl Autoconf wants to disallow AM_ names. We explicitly allow -dnl the ones we care about. -m4_pattern_allow([^AM_[A-Z]+FLAGS$])dnl -AC_REQUIRE([AM_SET_CURRENT_AUTOMAKE_VERSION])dnl -AC_REQUIRE([AC_PROG_INSTALL])dnl -if test "`cd $srcdir && pwd`" != "`pwd`"; then - # Use -I$(srcdir) only when $(srcdir) != ., so that make's output - # is not polluted with repeated "-I." - AC_SUBST([am__isrc], [' -I$(srcdir)'])_AM_SUBST_NOTMAKE([am__isrc])dnl - # test to see if srcdir already configured - if test -f $srcdir/config.status; then - AC_MSG_ERROR([source directory already configured; run "make distclean" there first]) - fi -fi - -# test whether we have cygpath -if test -z "$CYGPATH_W"; then - if (cygpath --version) >/dev/null 2>/dev/null; then - CYGPATH_W='cygpath -w' - else - CYGPATH_W=echo - fi -fi -AC_SUBST([CYGPATH_W]) - -# Define the identity of the package. -dnl Distinguish between old-style and new-style calls. -m4_ifval([$2], -[AC_DIAGNOSE([obsolete], - [$0: two- and three-arguments forms are deprecated.]) -m4_ifval([$3], [_AM_SET_OPTION([no-define])])dnl - AC_SUBST([PACKAGE], [$1])dnl - AC_SUBST([VERSION], [$2])], -[_AM_SET_OPTIONS([$1])dnl -dnl Diagnose old-style AC_INIT with new-style AM_AUTOMAKE_INIT. -m4_if( - m4_ifdef([AC_PACKAGE_NAME], [ok]):m4_ifdef([AC_PACKAGE_VERSION], [ok]), - [ok:ok],, - [m4_fatal([AC_INIT should be called with package and version arguments])])dnl - AC_SUBST([PACKAGE], ['AC_PACKAGE_TARNAME'])dnl - AC_SUBST([VERSION], ['AC_PACKAGE_VERSION'])])dnl - -_AM_IF_OPTION([no-define],, -[AC_DEFINE_UNQUOTED([PACKAGE], ["$PACKAGE"], [Name of package]) - AC_DEFINE_UNQUOTED([VERSION], ["$VERSION"], [Version number of package])])dnl - -# Some tools Automake needs. -AC_REQUIRE([AM_SANITY_CHECK])dnl -AC_REQUIRE([AC_ARG_PROGRAM])dnl -AM_MISSING_PROG([ACLOCAL], [aclocal-${am__api_version}]) -AM_MISSING_PROG([AUTOCONF], [autoconf]) -AM_MISSING_PROG([AUTOMAKE], [automake-${am__api_version}]) -AM_MISSING_PROG([AUTOHEADER], [autoheader]) -AM_MISSING_PROG([MAKEINFO], [makeinfo]) -AC_REQUIRE([AM_PROG_INSTALL_SH])dnl -AC_REQUIRE([AM_PROG_INSTALL_STRIP])dnl -AC_REQUIRE([AC_PROG_MKDIR_P])dnl -# For better backward compatibility. To be removed once Automake 1.9.x -# dies out for good. For more background, see: -# -# -AC_SUBST([mkdir_p], ['$(MKDIR_P)']) -# We need awk for the "check" target (and possibly the TAP driver). The -# system "awk" is bad on some platforms. -AC_REQUIRE([AC_PROG_AWK])dnl -AC_REQUIRE([AC_PROG_MAKE_SET])dnl -AC_REQUIRE([AM_SET_LEADING_DOT])dnl -_AM_IF_OPTION([tar-ustar], [_AM_PROG_TAR([ustar])], - [_AM_IF_OPTION([tar-pax], [_AM_PROG_TAR([pax])], - [_AM_PROG_TAR([v7])])]) -_AM_IF_OPTION([no-dependencies],, -[AC_PROVIDE_IFELSE([AC_PROG_CC], - [_AM_DEPENDENCIES([CC])], - [m4_define([AC_PROG_CC], - m4_defn([AC_PROG_CC])[_AM_DEPENDENCIES([CC])])])dnl -AC_PROVIDE_IFELSE([AC_PROG_CXX], - [_AM_DEPENDENCIES([CXX])], - [m4_define([AC_PROG_CXX], - m4_defn([AC_PROG_CXX])[_AM_DEPENDENCIES([CXX])])])dnl -AC_PROVIDE_IFELSE([AC_PROG_OBJC], - [_AM_DEPENDENCIES([OBJC])], - [m4_define([AC_PROG_OBJC], - m4_defn([AC_PROG_OBJC])[_AM_DEPENDENCIES([OBJC])])])dnl -AC_PROVIDE_IFELSE([AC_PROG_OBJCXX], - [_AM_DEPENDENCIES([OBJCXX])], - [m4_define([AC_PROG_OBJCXX], - m4_defn([AC_PROG_OBJCXX])[_AM_DEPENDENCIES([OBJCXX])])])dnl -]) -AC_REQUIRE([AM_SILENT_RULES])dnl -dnl The testsuite driver may need to know about EXEEXT, so add the -dnl 'am__EXEEXT' conditional if _AM_COMPILER_EXEEXT was seen. This -dnl macro is hooked onto _AC_COMPILER_EXEEXT early, see below. -AC_CONFIG_COMMANDS_PRE(dnl -[m4_provide_if([_AM_COMPILER_EXEEXT], - [AM_CONDITIONAL([am__EXEEXT], [test -n "$EXEEXT"])])])dnl - -# POSIX will say in a future version that running "rm -f" with no argument -# is OK; and we want to be able to make that assumption in our Makefile -# recipes. So use an aggressive probe to check that the usage we want is -# actually supported "in the wild" to an acceptable degree. -# See automake bug#10828. -# To make any issue more visible, cause the running configure to be aborted -# by default if the 'rm' program in use doesn't match our expectations; the -# user can still override this though. -if rm -f && rm -fr && rm -rf; then : OK; else - cat >&2 <<'END' -Oops! - -Your 'rm' program seems unable to run without file operands specified -on the command line, even when the '-f' option is present. This is contrary -to the behaviour of most rm programs out there, and not conforming with -the upcoming POSIX standard: - -Please tell bug-automake@gnu.org about your system, including the value -of your $PATH and any error possibly output before this message. This -can help us improve future automake versions. - -END - if test x"$ACCEPT_INFERIOR_RM_PROGRAM" = x"yes"; then - echo 'Configuration will proceed anyway, since you have set the' >&2 - echo 'ACCEPT_INFERIOR_RM_PROGRAM variable to "yes"' >&2 - echo >&2 - else - cat >&2 <<'END' -Aborting the configuration process, to ensure you take notice of the issue. - -You can download and install GNU coreutils to get an 'rm' implementation -that behaves properly: . - -If you want to complete the configuration process using your problematic -'rm' anyway, export the environment variable ACCEPT_INFERIOR_RM_PROGRAM -to "yes", and re-run configure. - -END - AC_MSG_ERROR([Your 'rm' program is bad, sorry.]) - fi -fi -dnl The trailing newline in this macro's definition is deliberate, for -dnl backward compatibility and to allow trailing 'dnl'-style comments -dnl after the AM_INIT_AUTOMAKE invocation. See automake bug#16841. -]) - -dnl Hook into '_AC_COMPILER_EXEEXT' early to learn its expansion. Do not -dnl add the conditional right here, as _AC_COMPILER_EXEEXT may be further -dnl mangled by Autoconf and run in a shell conditional statement. -m4_define([_AC_COMPILER_EXEEXT], -m4_defn([_AC_COMPILER_EXEEXT])[m4_provide([_AM_COMPILER_EXEEXT])]) - -# When config.status generates a header, we must update the stamp-h file. -# This file resides in the same directory as the config header -# that is generated. The stamp files are numbered to have different names. - -# Autoconf calls _AC_AM_CONFIG_HEADER_HOOK (when defined) in the -# loop where config.status creates the headers, so we can generate -# our stamp files there. -AC_DEFUN([_AC_AM_CONFIG_HEADER_HOOK], -[# Compute $1's index in $config_headers. -_am_arg=$1 -_am_stamp_count=1 -for _am_header in $config_headers :; do - case $_am_header in - $_am_arg | $_am_arg:* ) - break ;; - * ) - _am_stamp_count=`expr $_am_stamp_count + 1` ;; - esac -done -echo "timestamp for $_am_arg" >`AS_DIRNAME(["$_am_arg"])`/stamp-h[]$_am_stamp_count]) - -# Copyright (C) 2001-2014 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. - -# AM_PROG_INSTALL_SH -# ------------------ -# Define $install_sh. -AC_DEFUN([AM_PROG_INSTALL_SH], -[AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl -if test x"${install_sh+set}" != xset; then - case $am_aux_dir in - *\ * | *\ *) - install_sh="\${SHELL} '$am_aux_dir/install-sh'" ;; - *) - install_sh="\${SHELL} $am_aux_dir/install-sh" - esac -fi -AC_SUBST([install_sh])]) - -# Copyright (C) 2003-2014 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. - -# Check whether the underlying file-system supports filenames -# with a leading dot. For instance MS-DOS doesn't. -AC_DEFUN([AM_SET_LEADING_DOT], -[rm -rf .tst 2>/dev/null -mkdir .tst 2>/dev/null -if test -d .tst; then - am__leading_dot=. -else - am__leading_dot=_ -fi -rmdir .tst 2>/dev/null -AC_SUBST([am__leading_dot])]) - -# Add --enable-maintainer-mode option to configure. -*- Autoconf -*- -# From Jim Meyering - -# Copyright (C) 1996-2014 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. - -# AM_MAINTAINER_MODE([DEFAULT-MODE]) -# ---------------------------------- -# Control maintainer-specific portions of Makefiles. -# Default is to disable them, unless 'enable' is passed literally. -# For symmetry, 'disable' may be passed as well. Anyway, the user -# can override the default with the --enable/--disable switch. -AC_DEFUN([AM_MAINTAINER_MODE], -[m4_case(m4_default([$1], [disable]), - [enable], [m4_define([am_maintainer_other], [disable])], - [disable], [m4_define([am_maintainer_other], [enable])], - [m4_define([am_maintainer_other], [enable]) - m4_warn([syntax], [unexpected argument to AM@&t@_MAINTAINER_MODE: $1])]) -AC_MSG_CHECKING([whether to enable maintainer-specific portions of Makefiles]) - dnl maintainer-mode's default is 'disable' unless 'enable' is passed - AC_ARG_ENABLE([maintainer-mode], - [AS_HELP_STRING([--]am_maintainer_other[-maintainer-mode], - am_maintainer_other[ make rules and dependencies not useful - (and sometimes confusing) to the casual installer])], - [USE_MAINTAINER_MODE=$enableval], - [USE_MAINTAINER_MODE=]m4_if(am_maintainer_other, [enable], [no], [yes])) - AC_MSG_RESULT([$USE_MAINTAINER_MODE]) - AM_CONDITIONAL([MAINTAINER_MODE], [test $USE_MAINTAINER_MODE = yes]) - MAINT=$MAINTAINER_MODE_TRUE - AC_SUBST([MAINT])dnl -] -) - -# Check to see how 'make' treats includes. -*- Autoconf -*- - -# Copyright (C) 2001-2014 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. - -# AM_MAKE_INCLUDE() -# ----------------- -# Check to see how make treats includes. -AC_DEFUN([AM_MAKE_INCLUDE], -[am_make=${MAKE-make} -cat > confinc << 'END' -am__doit: - @echo this is the am__doit target -.PHONY: am__doit -END -# If we don't find an include directive, just comment out the code. -AC_MSG_CHECKING([for style of include used by $am_make]) -am__include="#" -am__quote= -_am_result=none -# First try GNU make style include. -echo "include confinc" > confmf -# Ignore all kinds of additional output from 'make'. -case `$am_make -s -f confmf 2> /dev/null` in #( -*the\ am__doit\ target*) - am__include=include - am__quote= - _am_result=GNU - ;; -esac -# Now try BSD make style include. -if test "$am__include" = "#"; then - echo '.include "confinc"' > confmf - case `$am_make -s -f confmf 2> /dev/null` in #( - *the\ am__doit\ target*) - am__include=.include - am__quote="\"" - _am_result=BSD - ;; - esac -fi -AC_SUBST([am__include]) -AC_SUBST([am__quote]) -AC_MSG_RESULT([$_am_result]) -rm -f confinc confmf -]) - -# Fake the existence of programs that GNU maintainers use. -*- Autoconf -*- - -# Copyright (C) 1997-2014 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. - -# AM_MISSING_PROG(NAME, PROGRAM) -# ------------------------------ -AC_DEFUN([AM_MISSING_PROG], -[AC_REQUIRE([AM_MISSING_HAS_RUN]) -$1=${$1-"${am_missing_run}$2"} -AC_SUBST($1)]) - -# AM_MISSING_HAS_RUN -# ------------------ -# Define MISSING if not defined so far and test if it is modern enough. -# If it is, set am_missing_run to use it, otherwise, to nothing. -AC_DEFUN([AM_MISSING_HAS_RUN], -[AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl -AC_REQUIRE_AUX_FILE([missing])dnl -if test x"${MISSING+set}" != xset; then - case $am_aux_dir in - *\ * | *\ *) - MISSING="\${SHELL} \"$am_aux_dir/missing\"" ;; - *) - MISSING="\${SHELL} $am_aux_dir/missing" ;; - esac -fi -# Use eval to expand $SHELL -if eval "$MISSING --is-lightweight"; then - am_missing_run="$MISSING " -else - am_missing_run= - AC_MSG_WARN(['missing' script is too old or missing]) -fi -]) - -# Helper functions for option handling. -*- Autoconf -*- - -# Copyright (C) 2001-2014 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. - -# _AM_MANGLE_OPTION(NAME) -# ----------------------- -AC_DEFUN([_AM_MANGLE_OPTION], -[[_AM_OPTION_]m4_bpatsubst($1, [[^a-zA-Z0-9_]], [_])]) - -# _AM_SET_OPTION(NAME) -# -------------------- -# Set option NAME. Presently that only means defining a flag for this option. -AC_DEFUN([_AM_SET_OPTION], -[m4_define(_AM_MANGLE_OPTION([$1]), [1])]) - -# _AM_SET_OPTIONS(OPTIONS) -# ------------------------ -# OPTIONS is a space-separated list of Automake options. -AC_DEFUN([_AM_SET_OPTIONS], -[m4_foreach_w([_AM_Option], [$1], [_AM_SET_OPTION(_AM_Option)])]) - -# _AM_IF_OPTION(OPTION, IF-SET, [IF-NOT-SET]) -# ------------------------------------------- -# Execute IF-SET if OPTION is set, IF-NOT-SET otherwise. -AC_DEFUN([_AM_IF_OPTION], -[m4_ifset(_AM_MANGLE_OPTION([$1]), [$2], [$3])]) - -# Copyright (C) 1999-2014 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. - -# _AM_PROG_CC_C_O -# --------------- -# Like AC_PROG_CC_C_O, but changed for automake. We rewrite AC_PROG_CC -# to automatically call this. -AC_DEFUN([_AM_PROG_CC_C_O], -[AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl -AC_REQUIRE_AUX_FILE([compile])dnl -AC_LANG_PUSH([C])dnl -AC_CACHE_CHECK( - [whether $CC understands -c and -o together], - [am_cv_prog_cc_c_o], - [AC_LANG_CONFTEST([AC_LANG_PROGRAM([])]) - # Make sure it works both with $CC and with simple cc. - # Following AC_PROG_CC_C_O, we do the test twice because some - # compilers refuse to overwrite an existing .o file with -o, - # though they will create one. - am_cv_prog_cc_c_o=yes - for am_i in 1 2; do - if AM_RUN_LOG([$CC -c conftest.$ac_ext -o conftest2.$ac_objext]) \ - && test -f conftest2.$ac_objext; then - : OK - else - am_cv_prog_cc_c_o=no - break - fi - done - rm -f core conftest* - unset am_i]) -if test "$am_cv_prog_cc_c_o" != yes; then - # Losing compiler, so override with the script. - # FIXME: It is wrong to rewrite CC. - # But if we don't then we get into trouble of one sort or another. - # A longer-term fix would be to have automake use am__CC in this case, - # and then we could set am__CC="\$(top_srcdir)/compile \$(CC)" - CC="$am_aux_dir/compile $CC" -fi -AC_LANG_POP([C])]) - -# For backward compatibility. -AC_DEFUN_ONCE([AM_PROG_CC_C_O], [AC_REQUIRE([AC_PROG_CC])]) - -# Copyright (C) 2001-2014 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. - -# AM_RUN_LOG(COMMAND) -# ------------------- -# Run COMMAND, save the exit status in ac_status, and log it. -# (This has been adapted from Autoconf's _AC_RUN_LOG macro.) -AC_DEFUN([AM_RUN_LOG], -[{ echo "$as_me:$LINENO: $1" >&AS_MESSAGE_LOG_FD - ($1) >&AS_MESSAGE_LOG_FD 2>&AS_MESSAGE_LOG_FD - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&AS_MESSAGE_LOG_FD - (exit $ac_status); }]) - -# Check to make sure that the build environment is sane. -*- Autoconf -*- - -# Copyright (C) 1996-2014 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. - -# AM_SANITY_CHECK -# --------------- -AC_DEFUN([AM_SANITY_CHECK], -[AC_MSG_CHECKING([whether build environment is sane]) -# Reject unsafe characters in $srcdir or the absolute working directory -# name. Accept space and tab only in the latter. -am_lf=' -' -case `pwd` in - *[[\\\"\#\$\&\'\`$am_lf]]*) - AC_MSG_ERROR([unsafe absolute working directory name]);; -esac -case $srcdir in - *[[\\\"\#\$\&\'\`$am_lf\ \ ]]*) - AC_MSG_ERROR([unsafe srcdir value: '$srcdir']);; -esac - -# Do 'set' in a subshell so we don't clobber the current shell's -# arguments. Must try -L first in case configure is actually a -# symlink; some systems play weird games with the mod time of symlinks -# (eg FreeBSD returns the mod time of the symlink's containing -# directory). -if ( - am_has_slept=no - for am_try in 1 2; do - echo "timestamp, slept: $am_has_slept" > conftest.file - set X `ls -Lt "$srcdir/configure" conftest.file 2> /dev/null` - if test "$[*]" = "X"; then - # -L didn't work. - set X `ls -t "$srcdir/configure" conftest.file` - fi - if test "$[*]" != "X $srcdir/configure conftest.file" \ - && test "$[*]" != "X conftest.file $srcdir/configure"; then - - # If neither matched, then we have a broken ls. This can happen - # if, for instance, CONFIG_SHELL is bash and it inherits a - # broken ls alias from the environment. This has actually - # happened. Such a system could not be considered "sane". - AC_MSG_ERROR([ls -t appears to fail. Make sure there is not a broken - alias in your environment]) - fi - if test "$[2]" = conftest.file || test $am_try -eq 2; then - break - fi - # Just in case. - sleep 1 - am_has_slept=yes - done - test "$[2]" = conftest.file - ) -then - # Ok. - : -else - AC_MSG_ERROR([newly created file is older than distributed files! -Check your system clock]) -fi -AC_MSG_RESULT([yes]) -# If we didn't sleep, we still need to ensure time stamps of config.status and -# generated files are strictly newer. -am_sleep_pid= -if grep 'slept: no' conftest.file >/dev/null 2>&1; then - ( sleep 1 ) & - am_sleep_pid=$! -fi -AC_CONFIG_COMMANDS_PRE( - [AC_MSG_CHECKING([that generated files are newer than configure]) - if test -n "$am_sleep_pid"; then - # Hide warnings about reused PIDs. - wait $am_sleep_pid 2>/dev/null - fi - AC_MSG_RESULT([done])]) -rm -f conftest.file -]) - -# Copyright (C) 2009-2014 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. - -# AM_SILENT_RULES([DEFAULT]) -# -------------------------- -# Enable less verbose build rules; with the default set to DEFAULT -# ("yes" being less verbose, "no" or empty being verbose). -AC_DEFUN([AM_SILENT_RULES], -[AC_ARG_ENABLE([silent-rules], [dnl -AS_HELP_STRING( - [--enable-silent-rules], - [less verbose build output (undo: "make V=1")]) -AS_HELP_STRING( - [--disable-silent-rules], - [verbose build output (undo: "make V=0")])dnl -]) -case $enable_silent_rules in @%:@ ((( - yes) AM_DEFAULT_VERBOSITY=0;; - no) AM_DEFAULT_VERBOSITY=1;; - *) AM_DEFAULT_VERBOSITY=m4_if([$1], [yes], [0], [1]);; -esac -dnl -dnl A few 'make' implementations (e.g., NonStop OS and NextStep) -dnl do not support nested variable expansions. -dnl See automake bug#9928 and bug#10237. -am_make=${MAKE-make} -AC_CACHE_CHECK([whether $am_make supports nested variables], - [am_cv_make_support_nested_variables], - [if AS_ECHO([['TRUE=$(BAR$(V)) -BAR0=false -BAR1=true -V=1 -am__doit: - @$(TRUE) -.PHONY: am__doit']]) | $am_make -f - >/dev/null 2>&1; then - am_cv_make_support_nested_variables=yes -else - am_cv_make_support_nested_variables=no -fi]) -if test $am_cv_make_support_nested_variables = yes; then - dnl Using '$V' instead of '$(V)' breaks IRIX make. - AM_V='$(V)' - AM_DEFAULT_V='$(AM_DEFAULT_VERBOSITY)' -else - AM_V=$AM_DEFAULT_VERBOSITY - AM_DEFAULT_V=$AM_DEFAULT_VERBOSITY -fi -AC_SUBST([AM_V])dnl -AM_SUBST_NOTMAKE([AM_V])dnl -AC_SUBST([AM_DEFAULT_V])dnl -AM_SUBST_NOTMAKE([AM_DEFAULT_V])dnl -AC_SUBST([AM_DEFAULT_VERBOSITY])dnl -AM_BACKSLASH='\' -AC_SUBST([AM_BACKSLASH])dnl -_AM_SUBST_NOTMAKE([AM_BACKSLASH])dnl -]) - -# Copyright (C) 2001-2014 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. - -# AM_PROG_INSTALL_STRIP -# --------------------- -# One issue with vendor 'install' (even GNU) is that you can't -# specify the program used to strip binaries. This is especially -# annoying in cross-compiling environments, where the build's strip -# is unlikely to handle the host's binaries. -# Fortunately install-sh will honor a STRIPPROG variable, so we -# always use install-sh in "make install-strip", and initialize -# STRIPPROG with the value of the STRIP variable (set by the user). -AC_DEFUN([AM_PROG_INSTALL_STRIP], -[AC_REQUIRE([AM_PROG_INSTALL_SH])dnl -# Installed binaries are usually stripped using 'strip' when the user -# run "make install-strip". However 'strip' might not be the right -# tool to use in cross-compilation environments, therefore Automake -# will honor the 'STRIP' environment variable to overrule this program. -dnl Don't test for $cross_compiling = yes, because it might be 'maybe'. -if test "$cross_compiling" != no; then - AC_CHECK_TOOL([STRIP], [strip], :) -fi -INSTALL_STRIP_PROGRAM="\$(install_sh) -c -s" -AC_SUBST([INSTALL_STRIP_PROGRAM])]) - -# Copyright (C) 2006-2014 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. - -# _AM_SUBST_NOTMAKE(VARIABLE) -# --------------------------- -# Prevent Automake from outputting VARIABLE = @VARIABLE@ in Makefile.in. -# This macro is traced by Automake. -AC_DEFUN([_AM_SUBST_NOTMAKE]) - -# AM_SUBST_NOTMAKE(VARIABLE) -# -------------------------- -# Public sister of _AM_SUBST_NOTMAKE. -AC_DEFUN([AM_SUBST_NOTMAKE], [_AM_SUBST_NOTMAKE($@)]) - -# Check how to create a tarball. -*- Autoconf -*- - -# Copyright (C) 2004-2014 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. - -# _AM_PROG_TAR(FORMAT) -# -------------------- -# Check how to create a tarball in format FORMAT. -# FORMAT should be one of 'v7', 'ustar', or 'pax'. -# -# Substitute a variable $(am__tar) that is a command -# writing to stdout a FORMAT-tarball containing the directory -# $tardir. -# tardir=directory && $(am__tar) > result.tar -# -# Substitute a variable $(am__untar) that extract such -# a tarball read from stdin. -# $(am__untar) < result.tar -# -AC_DEFUN([_AM_PROG_TAR], -[# Always define AMTAR for backward compatibility. Yes, it's still used -# in the wild :-( We should find a proper way to deprecate it ... -AC_SUBST([AMTAR], ['$${TAR-tar}']) - -# We'll loop over all known methods to create a tar archive until one works. -_am_tools='gnutar m4_if([$1], [ustar], [plaintar]) pax cpio none' - -m4_if([$1], [v7], - [am__tar='$${TAR-tar} chof - "$$tardir"' am__untar='$${TAR-tar} xf -'], - - [m4_case([$1], - [ustar], - [# The POSIX 1988 'ustar' format is defined with fixed-size fields. - # There is notably a 21 bits limit for the UID and the GID. In fact, - # the 'pax' utility can hang on bigger UID/GID (see automake bug#8343 - # and bug#13588). - am_max_uid=2097151 # 2^21 - 1 - am_max_gid=$am_max_uid - # The $UID and $GID variables are not portable, so we need to resort - # to the POSIX-mandated id(1) utility. Errors in the 'id' calls - # below are definitely unexpected, so allow the users to see them - # (that is, avoid stderr redirection). - am_uid=`id -u || echo unknown` - am_gid=`id -g || echo unknown` - AC_MSG_CHECKING([whether UID '$am_uid' is supported by ustar format]) - if test $am_uid -le $am_max_uid; then - AC_MSG_RESULT([yes]) - else - AC_MSG_RESULT([no]) - _am_tools=none - fi - AC_MSG_CHECKING([whether GID '$am_gid' is supported by ustar format]) - if test $am_gid -le $am_max_gid; then - AC_MSG_RESULT([yes]) - else - AC_MSG_RESULT([no]) - _am_tools=none - fi], - - [pax], - [], - - [m4_fatal([Unknown tar format])]) - - AC_MSG_CHECKING([how to create a $1 tar archive]) - - # Go ahead even if we have the value already cached. We do so because we - # need to set the values for the 'am__tar' and 'am__untar' variables. - _am_tools=${am_cv_prog_tar_$1-$_am_tools} - - for _am_tool in $_am_tools; do - case $_am_tool in - gnutar) - for _am_tar in tar gnutar gtar; do - AM_RUN_LOG([$_am_tar --version]) && break - done - am__tar="$_am_tar --format=m4_if([$1], [pax], [posix], [$1]) -chf - "'"$$tardir"' - am__tar_="$_am_tar --format=m4_if([$1], [pax], [posix], [$1]) -chf - "'"$tardir"' - am__untar="$_am_tar -xf -" - ;; - plaintar) - # Must skip GNU tar: if it does not support --format= it doesn't create - # ustar tarball either. - (tar --version) >/dev/null 2>&1 && continue - am__tar='tar chf - "$$tardir"' - am__tar_='tar chf - "$tardir"' - am__untar='tar xf -' - ;; - pax) - am__tar='pax -L -x $1 -w "$$tardir"' - am__tar_='pax -L -x $1 -w "$tardir"' - am__untar='pax -r' - ;; - cpio) - am__tar='find "$$tardir" -print | cpio -o -H $1 -L' - am__tar_='find "$tardir" -print | cpio -o -H $1 -L' - am__untar='cpio -i -H $1 -d' - ;; - none) - am__tar=false - am__tar_=false - am__untar=false - ;; - esac - - # If the value was cached, stop now. We just wanted to have am__tar - # and am__untar set. - test -n "${am_cv_prog_tar_$1}" && break - - # tar/untar a dummy directory, and stop if the command works. - rm -rf conftest.dir - mkdir conftest.dir - echo GrepMe > conftest.dir/file - AM_RUN_LOG([tardir=conftest.dir && eval $am__tar_ >conftest.tar]) - rm -rf conftest.dir - if test -s conftest.tar; then - AM_RUN_LOG([$am__untar /dev/null 2>&1 && break - fi - done - rm -rf conftest.dir - - AC_CACHE_VAL([am_cv_prog_tar_$1], [am_cv_prog_tar_$1=$_am_tool]) - AC_MSG_RESULT([$am_cv_prog_tar_$1])]) - -AC_SUBST([am__tar]) -AC_SUBST([am__untar]) -]) # _AM_PROG_TAR - -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]) diff -Nru ecl-16.1.2/src/bdwgc/allchblk.c ecl-16.1.3+ds/src/bdwgc/allchblk.c --- ecl-16.1.2/src/bdwgc/allchblk.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/allchblk.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,884 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1998-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 1999 by Hewlett-Packard Company. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#include "private/gc_priv.h" - -#include - -#ifdef GC_USE_ENTIRE_HEAP - int GC_use_entire_heap = TRUE; -#else - int GC_use_entire_heap = FALSE; -#endif - -/* - * Free heap blocks are kept on one of several free lists, - * depending on the size of the block. Each free list is doubly linked. - * Adjacent free blocks are coalesced. - */ - - -# define MAX_BLACK_LIST_ALLOC (2*HBLKSIZE) - /* largest block we will allocate starting on a black */ - /* listed block. Must be >= HBLKSIZE. */ - - -# define UNIQUE_THRESHOLD 32 - /* Sizes up to this many HBLKs each have their own free list */ -# define HUGE_THRESHOLD 256 - /* Sizes of at least this many heap blocks are mapped to a */ - /* single free list. */ -# define FL_COMPRESSION 8 - /* In between sizes map this many distinct sizes to a single */ - /* bin. */ - -# define N_HBLK_FLS ((HUGE_THRESHOLD - UNIQUE_THRESHOLD) / FL_COMPRESSION \ - + UNIQUE_THRESHOLD) - -#ifndef GC_GCJ_SUPPORT - STATIC -#endif - struct hblk * GC_hblkfreelist[N_HBLK_FLS+1] = { 0 }; - /* List of completely empty heap blocks */ - /* Linked through hb_next field of */ - /* header structure associated with */ - /* block. Remains externally visible */ - /* as used by GNU GCJ currently. */ - -#ifndef GC_GCJ_SUPPORT - STATIC -#endif - word GC_free_bytes[N_HBLK_FLS+1] = { 0 }; - /* Number of free bytes on each list. Remains visible to GCJ. */ - -/* Return the largest n such that the number of free bytes on lists */ -/* n .. N_HBLK_FLS is greater or equal to GC_max_large_allocd_bytes */ -/* minus GC_large_allocd_bytes. If there is no such n, return 0. */ -GC_INLINE int GC_enough_large_bytes_left(void) -{ - int n; - word bytes = GC_large_allocd_bytes; - - GC_ASSERT(GC_max_large_allocd_bytes <= GC_heapsize); - for (n = N_HBLK_FLS; n >= 0; --n) { - bytes += GC_free_bytes[n]; - if (bytes >= GC_max_large_allocd_bytes) return n; - } - return 0; -} - -/* Map a number of blocks to the appropriate large block free list index. */ -STATIC int GC_hblk_fl_from_blocks(word blocks_needed) -{ - if (blocks_needed <= UNIQUE_THRESHOLD) return (int)blocks_needed; - if (blocks_needed >= HUGE_THRESHOLD) return N_HBLK_FLS; - return (int)(blocks_needed - UNIQUE_THRESHOLD)/FL_COMPRESSION - + UNIQUE_THRESHOLD; - -} - -# define PHDR(hhdr) HDR((hhdr) -> hb_prev) -# define NHDR(hhdr) HDR((hhdr) -> hb_next) - -# ifdef USE_MUNMAP -# define IS_MAPPED(hhdr) (((hhdr) -> hb_flags & WAS_UNMAPPED) == 0) -# else -# define IS_MAPPED(hhdr) TRUE -# endif /* !USE_MUNMAP */ - -#if !defined(NO_DEBUGGING) || defined(GC_ASSERTIONS) - /* Should return the same value as GC_large_free_bytes. */ - GC_INNER word GC_compute_large_free_bytes(void) - { - struct hblk * h; - hdr * hhdr; - word total_free = 0; - unsigned i; - - for (i = 0; i <= N_HBLK_FLS; ++i) { - for (h = GC_hblkfreelist[i]; h != 0; h = hhdr->hb_next) { - hhdr = HDR(h); - total_free += hhdr->hb_sz; - } - } - return total_free; - } -#endif /* !NO_DEBUGGING || GC_ASSERTIONS */ - -# if !defined(NO_DEBUGGING) -void GC_print_hblkfreelist(void) -{ - struct hblk * h; - hdr * hhdr; - unsigned i; - word total; - - for (i = 0; i <= N_HBLK_FLS; ++i) { - h = GC_hblkfreelist[i]; - if (0 != h) GC_printf("Free list %u (total size %lu):\n", - i, (unsigned long)GC_free_bytes[i]); - while (h != 0) { - hhdr = HDR(h); - GC_printf("\t%p size %lu %s black listed\n", - (void *)h, (unsigned long) hhdr -> hb_sz, - GC_is_black_listed(h, HBLKSIZE) != 0 ? "start" : - GC_is_black_listed(h, hhdr -> hb_sz) != 0 ? "partially" : - "not"); - h = hhdr -> hb_next; - } - } - GC_printf("GC_large_free_bytes: %lu\n", - (unsigned long)GC_large_free_bytes); - - if ((total = GC_compute_large_free_bytes()) != GC_large_free_bytes) - GC_err_printf("GC_large_free_bytes INCONSISTENT!! Should be: %lu\n", - (unsigned long)total); -} - -/* Return the free list index on which the block described by the header */ -/* appears, or -1 if it appears nowhere. */ -static int free_list_index_of(hdr *wanted) -{ - struct hblk * h; - hdr * hhdr; - int i; - - for (i = 0; i <= N_HBLK_FLS; ++i) { - h = GC_hblkfreelist[i]; - while (h != 0) { - hhdr = HDR(h); - if (hhdr == wanted) return i; - h = hhdr -> hb_next; - } - } - return -1; -} - -void GC_dump_regions(void) -{ - unsigned i; - ptr_t start, end; - ptr_t p; - size_t bytes; - hdr *hhdr; - for (i = 0; i < GC_n_heap_sects; ++i) { - start = GC_heap_sects[i].hs_start; - bytes = GC_heap_sects[i].hs_bytes; - end = start + bytes; - /* Merge in contiguous sections. */ - while (i+1 < GC_n_heap_sects && GC_heap_sects[i+1].hs_start == end) { - ++i; - end = GC_heap_sects[i].hs_start + GC_heap_sects[i].hs_bytes; - } - GC_printf("***Section from %p to %p\n", start, end); - for (p = start; (word)p < (word)end; ) { - hhdr = HDR(p); - if (IS_FORWARDING_ADDR_OR_NIL(hhdr)) { - GC_printf("\t%p Missing header!!(%p)\n", p, (void *)hhdr); - p += HBLKSIZE; - continue; - } - if (HBLK_IS_FREE(hhdr)) { - int correct_index = GC_hblk_fl_from_blocks( - divHBLKSZ(hhdr -> hb_sz)); - int actual_index; - - GC_printf("\t%p\tfree block of size 0x%lx bytes%s\n", p, - (unsigned long)(hhdr -> hb_sz), - IS_MAPPED(hhdr) ? "" : " (unmapped)"); - actual_index = free_list_index_of(hhdr); - if (-1 == actual_index) { - GC_printf("\t\tBlock not on free list %d!!\n", - correct_index); - } else if (correct_index != actual_index) { - GC_printf("\t\tBlock on list %d, should be on %d!!\n", - actual_index, correct_index); - } - p += hhdr -> hb_sz; - } else { - GC_printf("\t%p\tused for blocks of size 0x%lx bytes\n", p, - (unsigned long)(hhdr -> hb_sz)); - p += HBLKSIZE * OBJ_SZ_TO_BLOCKS(hhdr -> hb_sz); - } - } - } -} - -# endif /* NO_DEBUGGING */ - -/* Initialize hdr for a block containing the indicated size and */ -/* kind of objects. */ -/* Return FALSE on failure. */ -static GC_bool setup_header(hdr * hhdr, struct hblk *block, size_t byte_sz, - int kind, unsigned flags) -{ - word descr; -# ifdef MARK_BIT_PER_GRANULE - size_t granules; - - if (byte_sz > MAXOBJBYTES) - flags |= LARGE_BLOCK; -# endif -# ifdef ENABLE_DISCLAIM - if (GC_obj_kinds[kind].ok_disclaim_proc) - flags |= HAS_DISCLAIM; - if (GC_obj_kinds[kind].ok_mark_unconditionally) - flags |= MARK_UNCONDITIONALLY; -# endif - - /* Set size, kind and mark proc fields */ - hhdr -> hb_sz = byte_sz; - hhdr -> hb_obj_kind = (unsigned char)kind; - hhdr -> hb_flags = (unsigned char)flags; - hhdr -> hb_block = block; - descr = GC_obj_kinds[kind].ok_descriptor; - if (GC_obj_kinds[kind].ok_relocate_descr) descr += byte_sz; - hhdr -> hb_descr = descr; - -# ifdef MARK_BIT_PER_OBJ - /* Set hb_inv_sz as portably as possible. */ - /* We set it to the smallest value such that sz * inv_sz > 2**32 */ - /* This may be more precision than necessary. */ - if (byte_sz > MAXOBJBYTES) { - hhdr -> hb_inv_sz = LARGE_INV_SZ; - } else { - word inv_sz; - -# if CPP_WORDSZ == 64 - inv_sz = ((word)1 << 32)/byte_sz; - if (((inv_sz*byte_sz) >> 32) == 0) ++inv_sz; -# else /* 32 bit words */ - GC_ASSERT(byte_sz >= 4); - inv_sz = ((unsigned)1 << 31)/byte_sz; - inv_sz *= 2; - while (inv_sz*byte_sz > byte_sz) ++inv_sz; -# endif - hhdr -> hb_inv_sz = inv_sz; - } -# else /* MARK_BIT_PER_GRANULE */ - granules = BYTES_TO_GRANULES(byte_sz); - if (EXPECT(!GC_add_map_entry(granules), FALSE)) { - /* Make it look like a valid block. */ - hhdr -> hb_sz = HBLKSIZE; - hhdr -> hb_descr = 0; - hhdr -> hb_flags |= LARGE_BLOCK; - hhdr -> hb_map = 0; - return FALSE; - } - hhdr -> hb_map = GC_obj_map[(hhdr -> hb_flags & LARGE_BLOCK) != 0 ? - 0 : granules]; -# endif /* MARK_BIT_PER_GRANULE */ - - /* Clear mark bits */ - GC_clear_hdr_marks(hhdr); - - hhdr -> hb_last_reclaimed = (unsigned short)GC_gc_no; - return(TRUE); -} - -/* Remove hhdr from the free list (it is assumed to specified by index). */ -STATIC void GC_remove_from_fl_at(hdr *hhdr, int index) -{ - GC_ASSERT(((hhdr -> hb_sz) & (HBLKSIZE-1)) == 0); - if (hhdr -> hb_prev == 0) { - GC_ASSERT(HDR(GC_hblkfreelist[index]) == hhdr); - GC_hblkfreelist[index] = hhdr -> hb_next; - } else { - hdr *phdr; - GET_HDR(hhdr -> hb_prev, phdr); - phdr -> hb_next = hhdr -> hb_next; - } - /* We always need index to maintain free counts. */ - GC_ASSERT(GC_free_bytes[index] >= hhdr -> hb_sz); - GC_free_bytes[index] -= hhdr -> hb_sz; - if (0 != hhdr -> hb_next) { - hdr * nhdr; - GC_ASSERT(!IS_FORWARDING_ADDR_OR_NIL(NHDR(hhdr))); - GET_HDR(hhdr -> hb_next, nhdr); - nhdr -> hb_prev = hhdr -> hb_prev; - } -} - -/* Remove hhdr from the appropriate free list (we assume it is on the */ -/* size-appropriate free list). */ -GC_INLINE void GC_remove_from_fl(hdr *hhdr) -{ - GC_remove_from_fl_at(hhdr, GC_hblk_fl_from_blocks(divHBLKSZ(hhdr->hb_sz))); -} - -/* Return a pointer to the free block ending just before h, if any. */ -STATIC struct hblk * GC_free_block_ending_at(struct hblk *h) -{ - struct hblk * p = h - 1; - hdr * phdr; - - GET_HDR(p, phdr); - while (0 != phdr && IS_FORWARDING_ADDR_OR_NIL(phdr)) { - p = FORWARDED_ADDR(p,phdr); - phdr = HDR(p); - } - if (0 != phdr) { - if(HBLK_IS_FREE(phdr)) { - return p; - } else { - return 0; - } - } - p = GC_prev_block(h - 1); - if (0 != p) { - phdr = HDR(p); - if (HBLK_IS_FREE(phdr) && (ptr_t)p + phdr -> hb_sz == (ptr_t)h) { - return p; - } - } - return 0; -} - -/* Add hhdr to the appropriate free list. */ -/* We maintain individual free lists sorted by address. */ -STATIC void GC_add_to_fl(struct hblk *h, hdr *hhdr) -{ - int index = GC_hblk_fl_from_blocks(divHBLKSZ(hhdr -> hb_sz)); - struct hblk *second = GC_hblkfreelist[index]; - hdr * second_hdr; -# if defined(GC_ASSERTIONS) && !defined(USE_MUNMAP) - struct hblk *next = (struct hblk *)((word)h + hhdr -> hb_sz); - hdr * nexthdr = HDR(next); - struct hblk *prev = GC_free_block_ending_at(h); - hdr * prevhdr = HDR(prev); - GC_ASSERT(nexthdr == 0 || !HBLK_IS_FREE(nexthdr) - || (signed_word)GC_heapsize < 0); - /* In the last case, blocks may be too large to merge. */ - GC_ASSERT(prev == 0 || !HBLK_IS_FREE(prevhdr) - || (signed_word)GC_heapsize < 0); -# endif - - GC_ASSERT(((hhdr -> hb_sz) & (HBLKSIZE-1)) == 0); - GC_hblkfreelist[index] = h; - GC_free_bytes[index] += hhdr -> hb_sz; - GC_ASSERT(GC_free_bytes[index] <= GC_large_free_bytes); - hhdr -> hb_next = second; - hhdr -> hb_prev = 0; - if (0 != second) { - GET_HDR(second, second_hdr); - second_hdr -> hb_prev = h; - } - hhdr -> hb_flags |= FREE_BLK; -} - -#ifdef USE_MUNMAP - -# ifndef MUNMAP_THRESHOLD -# define MUNMAP_THRESHOLD 6 -# endif - -GC_INNER int GC_unmap_threshold = MUNMAP_THRESHOLD; - -/* Unmap blocks that haven't been recently touched. This is the only way */ -/* way blocks are ever unmapped. */ -GC_INNER void GC_unmap_old(void) -{ - struct hblk * h; - hdr * hhdr; - int i; - - if (GC_unmap_threshold == 0) - return; /* unmapping disabled */ - - for (i = 0; i <= N_HBLK_FLS; ++i) { - for (h = GC_hblkfreelist[i]; 0 != h; h = hhdr -> hb_next) { - hhdr = HDR(h); - if (!IS_MAPPED(hhdr)) continue; - - if ((unsigned short)GC_gc_no - hhdr -> hb_last_reclaimed > - (unsigned short)GC_unmap_threshold) { - GC_unmap((ptr_t)h, hhdr -> hb_sz); - hhdr -> hb_flags |= WAS_UNMAPPED; - } - } - } -} - -/* Merge all unmapped blocks that are adjacent to other free */ -/* blocks. This may involve remapping, since all blocks are either */ -/* fully mapped or fully unmapped. */ -GC_INNER void GC_merge_unmapped(void) -{ - struct hblk * h, *next; - hdr * hhdr, *nexthdr; - word size, nextsize; - int i; - - for (i = 0; i <= N_HBLK_FLS; ++i) { - h = GC_hblkfreelist[i]; - while (h != 0) { - GET_HDR(h, hhdr); - size = hhdr->hb_sz; - next = (struct hblk *)((word)h + size); - GET_HDR(next, nexthdr); - /* Coalesce with successor, if possible */ - if (0 != nexthdr && HBLK_IS_FREE(nexthdr) - && (signed_word) (size + (nextsize = nexthdr->hb_sz)) > 0 - /* no pot. overflow */) { - /* Note that we usually try to avoid adjacent free blocks */ - /* that are either both mapped or both unmapped. But that */ - /* isn't guaranteed to hold since we remap blocks when we */ - /* split them, and don't merge at that point. It may also */ - /* not hold if the merged block would be too big. */ - if (IS_MAPPED(hhdr) && !IS_MAPPED(nexthdr)) { - /* make both consistent, so that we can merge */ - if (size > nextsize) { - GC_remap((ptr_t)next, nextsize); - } else { - GC_unmap((ptr_t)h, size); - GC_unmap_gap((ptr_t)h, size, (ptr_t)next, nextsize); - hhdr -> hb_flags |= WAS_UNMAPPED; - } - } else if (IS_MAPPED(nexthdr) && !IS_MAPPED(hhdr)) { - if (size > nextsize) { - GC_unmap((ptr_t)next, nextsize); - GC_unmap_gap((ptr_t)h, size, (ptr_t)next, nextsize); - } else { - GC_remap((ptr_t)h, size); - hhdr -> hb_flags &= ~WAS_UNMAPPED; - hhdr -> hb_last_reclaimed = nexthdr -> hb_last_reclaimed; - } - } else if (!IS_MAPPED(hhdr) && !IS_MAPPED(nexthdr)) { - /* Unmap any gap in the middle */ - GC_unmap_gap((ptr_t)h, size, (ptr_t)next, nextsize); - } - /* If they are both unmapped, we merge, but leave unmapped. */ - GC_remove_from_fl_at(hhdr, i); - GC_remove_from_fl(nexthdr); - hhdr -> hb_sz += nexthdr -> hb_sz; - GC_remove_header(next); - GC_add_to_fl(h, hhdr); - /* Start over at beginning of list */ - h = GC_hblkfreelist[i]; - } else /* not mergable with successor */ { - h = hhdr -> hb_next; - } - } /* while (h != 0) ... */ - } /* for ... */ -} - -#endif /* USE_MUNMAP */ - -/* - * Return a pointer to a block starting at h of length bytes. - * Memory for the block is mapped. - * Remove the block from its free list, and return the remainder (if any) - * to its appropriate free list. - * May fail by returning 0. - * The header for the returned block must be set up by the caller. - * If the return value is not 0, then hhdr is the header for it. - */ -STATIC struct hblk * GC_get_first_part(struct hblk *h, hdr *hhdr, - size_t bytes, int index) -{ - word total_size = hhdr -> hb_sz; - struct hblk * rest; - hdr * rest_hdr; - - GC_ASSERT((total_size & (HBLKSIZE-1)) == 0); - GC_remove_from_fl_at(hhdr, index); - if (total_size == bytes) return h; - rest = (struct hblk *)((word)h + bytes); - rest_hdr = GC_install_header(rest); - if (0 == rest_hdr) { - /* FIXME: This is likely to be very bad news ... */ - WARN("Header allocation failed: Dropping block.\n", 0); - return(0); - } - rest_hdr -> hb_sz = total_size - bytes; - rest_hdr -> hb_flags = 0; -# ifdef GC_ASSERTIONS - /* Mark h not free, to avoid assertion about adjacent free blocks. */ - hhdr -> hb_flags &= ~FREE_BLK; -# endif - GC_add_to_fl(rest, rest_hdr); - return h; -} - -/* - * H is a free block. N points at an address inside it. - * A new header for n has already been set up. Fix up h's header - * to reflect the fact that it is being split, move it to the - * appropriate free list. - * N replaces h in the original free list. - * - * Nhdr is not completely filled in, since it is about to allocated. - * It may in fact end up on the wrong free list for its size. - * That's not a disaster, since n is about to be allocated - * by our caller. - * (Hence adding it to a free list is silly. But this path is hopefully - * rare enough that it doesn't matter. The code is cleaner this way.) - */ -STATIC void GC_split_block(struct hblk *h, hdr *hhdr, struct hblk *n, - hdr *nhdr, int index /* Index of free list */) -{ - word total_size = hhdr -> hb_sz; - word h_size = (word)n - (word)h; - struct hblk *prev = hhdr -> hb_prev; - struct hblk *next = hhdr -> hb_next; - - /* Replace h with n on its freelist */ - nhdr -> hb_prev = prev; - nhdr -> hb_next = next; - nhdr -> hb_sz = total_size - h_size; - nhdr -> hb_flags = 0; - if (0 != prev) { - HDR(prev) -> hb_next = n; - } else { - GC_hblkfreelist[index] = n; - } - if (0 != next) { - HDR(next) -> hb_prev = n; - } - GC_ASSERT(GC_free_bytes[index] > h_size); - GC_free_bytes[index] -= h_size; -# ifdef USE_MUNMAP - hhdr -> hb_last_reclaimed = (unsigned short)GC_gc_no; -# endif - hhdr -> hb_sz = h_size; - GC_add_to_fl(h, hhdr); - nhdr -> hb_flags |= FREE_BLK; -} - -STATIC struct hblk * -GC_allochblk_nth(size_t sz /* bytes */, int kind, unsigned flags, int n, - int may_split); -#define AVOID_SPLIT_REMAPPED 2 - -/* - * Allocate (and return pointer to) a heap block - * for objects of size sz bytes, searching the nth free list. - * - * NOTE: We set obj_map field in header correctly. - * Caller is responsible for building an object freelist in block. - * - * The client is responsible for clearing the block, if necessary. - */ -GC_INNER struct hblk * -GC_allochblk(size_t sz, int kind, unsigned flags/* IGNORE_OFF_PAGE or 0 */) -{ - word blocks; - int start_list; - struct hblk *result; - int may_split; - int split_limit; /* Highest index of free list whose blocks we */ - /* split. */ - - GC_ASSERT((sz & (GRANULE_BYTES - 1)) == 0); - blocks = OBJ_SZ_TO_BLOCKS(sz); - if ((signed_word)(blocks * HBLKSIZE) < 0) { - return 0; - } - start_list = GC_hblk_fl_from_blocks(blocks); - /* Try for an exact match first. */ - result = GC_allochblk_nth(sz, kind, flags, start_list, FALSE); - if (0 != result) return result; - - may_split = TRUE; - if (GC_use_entire_heap || GC_dont_gc - || USED_HEAP_SIZE < GC_requested_heapsize - || GC_incremental || !GC_should_collect()) { - /* Should use more of the heap, even if it requires splitting. */ - split_limit = N_HBLK_FLS; - } else if (GC_finalizer_bytes_freed > (GC_heapsize >> 4)) { - /* If we are deallocating lots of memory from */ - /* finalizers, fail and collect sooner rather */ - /* than later. */ - split_limit = 0; - } else { - /* If we have enough large blocks left to cover any */ - /* previous request for large blocks, we go ahead */ - /* and split. Assuming a steady state, that should */ - /* be safe. It means that we can use the full */ - /* heap if we allocate only small objects. */ - split_limit = GC_enough_large_bytes_left(); -# ifdef USE_MUNMAP - if (split_limit > 0) - may_split = AVOID_SPLIT_REMAPPED; -# endif - } - if (start_list < UNIQUE_THRESHOLD) { - /* No reason to try start_list again, since all blocks are exact */ - /* matches. */ - ++start_list; - } - for (; start_list <= split_limit; ++start_list) { - result = GC_allochblk_nth(sz, kind, flags, start_list, may_split); - if (0 != result) - break; - } - return result; -} - -STATIC long GC_large_alloc_warn_suppressed = 0; - /* Number of warnings suppressed so far. */ - -/* The same, but with search restricted to nth free list. Flags is */ -/* IGNORE_OFF_PAGE or zero. sz is in bytes. The may_split flag */ -/* indicates whether it is OK to split larger blocks (if set to */ -/* AVOID_SPLIT_REMAPPED then memory remapping followed by splitting */ -/* should be generally avoided). */ -STATIC struct hblk * -GC_allochblk_nth(size_t sz, int kind, unsigned flags, int n, int may_split) -{ - struct hblk *hbp; - hdr * hhdr; /* Header corr. to hbp */ - struct hblk *thishbp; - hdr * thishdr; /* Header corr. to thishbp */ - signed_word size_needed; /* number of bytes in requested objects */ - signed_word size_avail; /* bytes available in this block */ - - size_needed = HBLKSIZE * OBJ_SZ_TO_BLOCKS(sz); - - /* search for a big enough block in free list */ - for (hbp = GC_hblkfreelist[n];; hbp = hhdr -> hb_next) { - if (NULL == hbp) return NULL; - GET_HDR(hbp, hhdr); /* set hhdr value */ - size_avail = hhdr->hb_sz; - if (size_avail < size_needed) continue; - if (size_avail != size_needed) { - signed_word next_size; - - if (!may_split) continue; - /* If the next heap block is obviously better, go on. */ - /* This prevents us from disassembling a single large */ - /* block to get tiny blocks. */ - thishbp = hhdr -> hb_next; - if (thishbp != 0) { - GET_HDR(thishbp, thishdr); - next_size = (signed_word)(thishdr -> hb_sz); - if (next_size < size_avail - && next_size >= size_needed - && !GC_is_black_listed(thishbp, (word)size_needed)) { - continue; - } - } - } - if (!IS_UNCOLLECTABLE(kind) && (kind != PTRFREE - || size_needed > (signed_word)MAX_BLACK_LIST_ALLOC)) { - struct hblk * lasthbp = hbp; - ptr_t search_end = (ptr_t)hbp + size_avail - size_needed; - signed_word orig_avail = size_avail; - signed_word eff_size_needed = (flags & IGNORE_OFF_PAGE) != 0 ? - (signed_word)HBLKSIZE - : size_needed; - - while ((word)lasthbp <= (word)search_end - && (thishbp = GC_is_black_listed(lasthbp, - (word)eff_size_needed)) != 0) { - lasthbp = thishbp; - } - size_avail -= (ptr_t)lasthbp - (ptr_t)hbp; - thishbp = lasthbp; - if (size_avail >= size_needed) { - if (thishbp != hbp) { -# ifdef USE_MUNMAP - /* Avoid remapping followed by splitting. */ - if (may_split == AVOID_SPLIT_REMAPPED && !IS_MAPPED(hhdr)) - continue; -# endif - thishdr = GC_install_header(thishbp); - if (0 != thishdr) { - /* Make sure it's mapped before we mangle it. */ -# ifdef USE_MUNMAP - if (!IS_MAPPED(hhdr)) { - GC_remap((ptr_t)hbp, hhdr -> hb_sz); - hhdr -> hb_flags &= ~WAS_UNMAPPED; - } -# endif - /* Split the block at thishbp */ - GC_split_block(hbp, hhdr, thishbp, thishdr, n); - /* Advance to thishbp */ - hbp = thishbp; - hhdr = thishdr; - /* We must now allocate thishbp, since it may */ - /* be on the wrong free list. */ - } - } - } else if (size_needed > (signed_word)BL_LIMIT - && orig_avail - size_needed - > (signed_word)BL_LIMIT) { - /* Punt, since anything else risks unreasonable heap growth. */ - if (++GC_large_alloc_warn_suppressed - >= GC_large_alloc_warn_interval) { - WARN("Repeated allocation of very large block " - "(appr. size %" WARN_PRIdPTR "):\n" - "\tMay lead to memory leak and poor performance.\n", - size_needed); - GC_large_alloc_warn_suppressed = 0; - } - size_avail = orig_avail; - } else if (size_avail == 0 && size_needed == HBLKSIZE - && IS_MAPPED(hhdr)) { - if (!GC_find_leak) { - static unsigned count = 0; - - /* The block is completely blacklisted. We need */ - /* to drop some such blocks, since otherwise we spend */ - /* all our time traversing them if pointer-free */ - /* blocks are unpopular. */ - /* A dropped block will be reconsidered at next GC. */ - if ((++count & 3) == 0) { - /* Allocate and drop the block in small chunks, to */ - /* maximize the chance that we will recover some */ - /* later. */ - word total_size = hhdr -> hb_sz; - struct hblk * limit = hbp + divHBLKSZ(total_size); - struct hblk * h; - struct hblk * prev = hhdr -> hb_prev; - - GC_large_free_bytes -= total_size; - GC_bytes_dropped += total_size; - GC_remove_from_fl_at(hhdr, n); - for (h = hbp; (word)h < (word)limit; h++) { - if (h != hbp) { - hhdr = GC_install_header(h); - } - if (NULL != hhdr) { - (void)setup_header(hhdr, h, HBLKSIZE, PTRFREE, 0); - /* Can't fail. */ - if (GC_debugging_started) { - BZERO(h, HBLKSIZE); - } - } - } - /* Restore hbp to point at free block */ - hbp = prev; - if (0 == hbp) { - return GC_allochblk_nth(sz, kind, flags, n, may_split); - } - hhdr = HDR(hbp); - } - } - } - } - if( size_avail >= size_needed ) { -# ifdef USE_MUNMAP - if (!IS_MAPPED(hhdr)) { - GC_remap((ptr_t)hbp, hhdr -> hb_sz); - hhdr -> hb_flags &= ~WAS_UNMAPPED; - /* Note: This may leave adjacent, mapped free blocks. */ - } -# endif - /* hbp may be on the wrong freelist; the parameter n */ - /* is important. */ - hbp = GC_get_first_part(hbp, hhdr, size_needed, n); - break; - } - } - - if (0 == hbp) return 0; - - /* Add it to map of valid blocks */ - if (!GC_install_counts(hbp, (word)size_needed)) return(0); - /* This leaks memory under very rare conditions. */ - - /* Set up header */ - if (!setup_header(hhdr, hbp, sz, kind, flags)) { - GC_remove_counts(hbp, (word)size_needed); - return(0); /* ditto */ - } -# ifndef GC_DISABLE_INCREMENTAL - /* Notify virtual dirty bit implementation that we are about to */ - /* write. Ensure that pointer-free objects are not protected */ - /* if it is avoidable. This also ensures that newly allocated */ - /* blocks are treated as dirty. Necessary since we don't */ - /* protect free blocks. */ - GC_ASSERT((size_needed & (HBLKSIZE-1)) == 0); - GC_remove_protection(hbp, divHBLKSZ(size_needed), - (hhdr -> hb_descr == 0) /* pointer-free */); -# endif - /* We just successfully allocated a block. Restart count of */ - /* consecutive failures. */ - GC_fail_count = 0; - - GC_large_free_bytes -= size_needed; - GC_ASSERT(IS_MAPPED(hhdr)); - return( hbp ); -} - -/* - * Free a heap block. - * - * Coalesce the block with its neighbors if possible. - * - * All mark words are assumed to be cleared. - */ -GC_INNER void GC_freehblk(struct hblk *hbp) -{ - struct hblk *next, *prev; - hdr *hhdr, *prevhdr, *nexthdr; - word size; - - GET_HDR(hbp, hhdr); - size = HBLKSIZE * OBJ_SZ_TO_BLOCKS(hhdr->hb_sz); - if ((signed_word)size <= 0) - ABORT("Deallocating excessively large block. Too large an allocation?"); - /* Probably possible if we try to allocate more than half the address */ - /* space at once. If we don't catch it here, strange things happen */ - /* later. */ - GC_remove_counts(hbp, size); - hhdr->hb_sz = size; -# ifdef USE_MUNMAP - hhdr -> hb_last_reclaimed = (unsigned short)GC_gc_no; -# endif - - /* Check for duplicate deallocation in the easy case */ - if (HBLK_IS_FREE(hhdr)) { - ABORT_ARG1("Duplicate large block deallocation", - " of %p", (void *)hbp); - } - - GC_ASSERT(IS_MAPPED(hhdr)); - hhdr -> hb_flags |= FREE_BLK; - next = (struct hblk *)((ptr_t)hbp + size); - GET_HDR(next, nexthdr); - prev = GC_free_block_ending_at(hbp); - /* Coalesce with successor, if possible */ - if(0 != nexthdr && HBLK_IS_FREE(nexthdr) && IS_MAPPED(nexthdr) - && (signed_word)(hhdr -> hb_sz + nexthdr -> hb_sz) > 0 - /* no overflow */) { - GC_remove_from_fl(nexthdr); - hhdr -> hb_sz += nexthdr -> hb_sz; - GC_remove_header(next); - } - /* Coalesce with predecessor, if possible. */ - if (0 != prev) { - prevhdr = HDR(prev); - if (IS_MAPPED(prevhdr) - && (signed_word)(hhdr -> hb_sz + prevhdr -> hb_sz) > 0) { - GC_remove_from_fl(prevhdr); - prevhdr -> hb_sz += hhdr -> hb_sz; -# ifdef USE_MUNMAP - prevhdr -> hb_last_reclaimed = (unsigned short)GC_gc_no; -# endif - GC_remove_header(hbp); - hbp = prev; - hhdr = prevhdr; - } - } - /* FIXME: It is not clear we really always want to do these merges */ - /* with USE_MUNMAP, since it updates ages and hence prevents */ - /* unmapping. */ - - GC_large_free_bytes += size; - GC_add_to_fl(hbp, hhdr); -} diff -Nru ecl-16.1.2/src/bdwgc/alloc.c ecl-16.1.3+ds/src/bdwgc/alloc.c --- ecl-16.1.2/src/bdwgc/alloc.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/alloc.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,1374 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1996 by Xerox Corporation. All rights reserved. - * Copyright (c) 1998 by Silicon Graphics. All rights reserved. - * Copyright (c) 1999-2004 Hewlett-Packard Development Company, L.P. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -#include "private/gc_priv.h" - -#include -#if !defined(MACOS) && !defined(MSWINCE) -# include -# if !defined(__CC_ARM) -# include -# endif -#endif - -/* - * Separate free lists are maintained for different sized objects - * up to MAXOBJBYTES. - * The call GC_allocobj(i,k) ensures that the freelist for - * kind k objects of size i points to a non-empty - * free list. It returns a pointer to the first entry on the free list. - * In a single-threaded world, GC_allocobj may be called to allocate - * an object of (small) size lb as follows: - * - * lg = GC_size_map[lb]; - * op = GC_objfreelist[lg]; - * if (NULL == op) { - * op = GENERAL_MALLOC(lb, NORMAL); - * } else { - * GC_objfreelist[lg] = obj_link(op); - * } - * - * Note that this is very fast if the free list is non-empty; it should - * only involve the execution of 4 or 5 simple instructions. - * All composite objects on freelists are cleared, except for - * their first word. - */ - -/* - * The allocator uses GC_allochblk to allocate large chunks of objects. - * These chunks all start on addresses which are multiples of - * HBLKSZ. Each allocated chunk has an associated header, - * which can be located quickly based on the address of the chunk. - * (See headers.c for details.) - * This makes it possible to check quickly whether an - * arbitrary address corresponds to an object administered by the - * allocator. - */ - -word GC_non_gc_bytes = 0; /* Number of bytes not intended to be collected */ - -word GC_gc_no = 0; - -#ifndef GC_DISABLE_INCREMENTAL - GC_INNER int GC_incremental = 0; /* By default, stop the world. */ -#endif - -#ifdef THREADS - int GC_parallel = FALSE; /* By default, parallel GC is off. */ -#endif - -#ifndef GC_FULL_FREQ -# define GC_FULL_FREQ 19 /* Every 20th collection is a full */ - /* collection, whether we need it */ - /* or not. */ -#endif - -int GC_full_freq = GC_FULL_FREQ; - -STATIC GC_bool GC_need_full_gc = FALSE; - /* Need full GC do to heap growth. */ - -#ifdef THREAD_LOCAL_ALLOC - GC_INNER GC_bool GC_world_stopped = FALSE; -#endif - -STATIC word GC_used_heap_size_after_full = 0; - -/* GC_copyright symbol is externally visible. */ -char * const GC_copyright[] = -{"Copyright 1988,1989 Hans-J. Boehm and Alan J. Demers ", -"Copyright (c) 1991-1995 by Xerox Corporation. All rights reserved. ", -"Copyright (c) 1996-1998 by Silicon Graphics. All rights reserved. ", -"Copyright (c) 1999-2009 by Hewlett-Packard Company. All rights reserved. ", -"THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY", -" EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK.", -"See source code for details." }; - -/* Version macros are now defined in gc_version.h, which is included by */ -/* gc.h, which is included by gc_priv.h. */ -#ifndef GC_NO_VERSION_VAR - const unsigned GC_version = ((GC_VERSION_MAJOR << 16) | - (GC_VERSION_MINOR << 8) | GC_VERSION_MICRO); -#endif - -GC_API unsigned GC_CALL GC_get_version(void) -{ - return (GC_VERSION_MAJOR << 16) | (GC_VERSION_MINOR << 8) | - GC_VERSION_MICRO; -} - -/* some more variables */ - -#ifdef GC_DONT_EXPAND - int GC_dont_expand = TRUE; -#else - int GC_dont_expand = FALSE; -#endif - -#ifndef GC_FREE_SPACE_DIVISOR -# define GC_FREE_SPACE_DIVISOR 3 /* must be > 0 */ -#endif - -word GC_free_space_divisor = GC_FREE_SPACE_DIVISOR; - -GC_INNER int GC_CALLBACK GC_never_stop_func(void) -{ - return(0); -} - -#ifndef GC_TIME_LIMIT -# define GC_TIME_LIMIT 50 /* We try to keep pause times from exceeding */ - /* this by much. In milliseconds. */ -#endif - -unsigned long GC_time_limit = GC_TIME_LIMIT; - -#ifndef NO_CLOCK - STATIC CLOCK_TYPE GC_start_time = 0; - /* Time at which we stopped world. */ - /* used only in GC_timeout_stop_func. */ -#endif - -STATIC int GC_n_attempts = 0; /* Number of attempts at finishing */ - /* collection within GC_time_limit. */ - -STATIC GC_stop_func GC_default_stop_func = GC_never_stop_func; - /* accessed holding the lock. */ - -GC_API void GC_CALL GC_set_stop_func(GC_stop_func stop_func) -{ - DCL_LOCK_STATE; - GC_ASSERT(stop_func != 0); - LOCK(); - GC_default_stop_func = stop_func; - UNLOCK(); -} - -GC_API GC_stop_func GC_CALL GC_get_stop_func(void) -{ - GC_stop_func stop_func; - DCL_LOCK_STATE; - LOCK(); - stop_func = GC_default_stop_func; - UNLOCK(); - return stop_func; -} - -#if defined(GC_DISABLE_INCREMENTAL) || defined(NO_CLOCK) -# define GC_timeout_stop_func GC_default_stop_func -#else - STATIC int GC_CALLBACK GC_timeout_stop_func (void) - { - CLOCK_TYPE current_time; - static unsigned count = 0; - unsigned long time_diff; - - if ((*GC_default_stop_func)()) - return(1); - - if ((count++ & 3) != 0) return(0); - GET_TIME(current_time); - time_diff = MS_TIME_DIFF(current_time,GC_start_time); - if (time_diff >= GC_time_limit) { - GC_COND_LOG_PRINTF( - "Abandoning stopped marking after %lu msecs (attempt %d)\n", - time_diff, GC_n_attempts); - return(1); - } - return(0); - } -#endif /* !GC_DISABLE_INCREMENTAL */ - -#ifdef THREADS - GC_INNER word GC_total_stacksize = 0; /* updated on every push_all_stacks */ -#endif - -/* Return the minimum number of bytes that must be allocated between */ -/* collections to amortize the collection cost. Should be non-zero. */ -static word min_bytes_allocd(void) -{ - word result; -# ifdef STACK_NOT_SCANNED - word stack_size = 0; -# elif defined(STACK_GROWS_UP) - word stack_size = GC_approx_sp() - GC_stackbottom; - /* GC_stackbottom is used only for a single-threaded case. */ -# else - word stack_size = GC_stackbottom - GC_approx_sp(); -# endif - - word total_root_size; /* includes double stack size, */ - /* since the stack is expensive */ - /* to scan. */ - word scan_size; /* Estimate of memory to be scanned */ - /* during normal GC. */ - -# ifdef THREADS - if (GC_need_to_lock) { - /* We are multi-threaded... */ - stack_size = GC_total_stacksize; - /* For now, we just use the value computed during the latest GC. */ -# ifdef DEBUG_THREADS - GC_log_printf("Total stacks size: %lu\n", - (unsigned long)stack_size); -# endif - } -# endif - - total_root_size = 2 * stack_size + GC_root_size; - scan_size = 2 * GC_composite_in_use + GC_atomic_in_use / 4 - + total_root_size; - result = scan_size / GC_free_space_divisor; - if (GC_incremental) { - result /= 2; - } - return result > 0 ? result : 1; -} - -STATIC word GC_non_gc_bytes_at_gc = 0; - /* Number of explicitly managed bytes of storage */ - /* at last collection. */ - -/* Return the number of bytes allocated, adjusted for explicit storage */ -/* management, etc.. This number is used in deciding when to trigger */ -/* collections. */ -STATIC word GC_adj_bytes_allocd(void) -{ - signed_word result; - signed_word expl_managed = (signed_word)GC_non_gc_bytes - - (signed_word)GC_non_gc_bytes_at_gc; - - /* Don't count what was explicitly freed, or newly allocated for */ - /* explicit management. Note that deallocating an explicitly */ - /* managed object should not alter result, assuming the client */ - /* is playing by the rules. */ - result = (signed_word)GC_bytes_allocd - + (signed_word)GC_bytes_dropped - - (signed_word)GC_bytes_freed - + (signed_word)GC_finalizer_bytes_freed - - expl_managed; - if (result > (signed_word)GC_bytes_allocd) { - result = GC_bytes_allocd; - /* probably client bug or unfortunate scheduling */ - } - result += GC_bytes_finalized; - /* We count objects enqueued for finalization as though they */ - /* had been reallocated this round. Finalization is user */ - /* visible progress. And if we don't count this, we have */ - /* stability problems for programs that finalize all objects. */ - if (result < (signed_word)(GC_bytes_allocd >> 3)) { - /* Always count at least 1/8 of the allocations. We don't want */ - /* to collect too infrequently, since that would inhibit */ - /* coalescing of free storage blocks. */ - /* This also makes us partially robust against client bugs. */ - return(GC_bytes_allocd >> 3); - } else { - return(result); - } -} - - -/* Clear up a few frames worth of garbage left at the top of the stack. */ -/* This is used to prevent us from accidentally treating garbage left */ -/* on the stack by other parts of the collector as roots. This */ -/* differs from the code in misc.c, which actually tries to keep the */ -/* stack clear of long-lived, client-generated garbage. */ -STATIC void GC_clear_a_few_frames(void) -{ -# ifndef CLEAR_NWORDS -# define CLEAR_NWORDS 64 -# endif - volatile word frames[CLEAR_NWORDS]; - BZERO((word *)frames, CLEAR_NWORDS * sizeof(word)); -} - -/* Heap size at which we need a collection to avoid expanding past */ -/* limits used by blacklisting. */ -STATIC word GC_collect_at_heapsize = (word)(-1); - -/* Have we allocated enough to amortize a collection? */ -GC_INNER GC_bool GC_should_collect(void) -{ - static word last_min_bytes_allocd; - static word last_gc_no; - if (last_gc_no != GC_gc_no) { - last_gc_no = GC_gc_no; - last_min_bytes_allocd = min_bytes_allocd(); - } - return(GC_adj_bytes_allocd() >= last_min_bytes_allocd - || GC_heapsize >= GC_collect_at_heapsize); -} - -/* STATIC */ GC_start_callback_proc GC_start_call_back = 0; - /* Called at start of full collections. */ - /* Not called if 0. Called with the allocation */ - /* lock held. Not used by GC itself. */ - -GC_API void GC_CALL GC_set_start_callback(GC_start_callback_proc fn) -{ - DCL_LOCK_STATE; - LOCK(); - GC_start_call_back = fn; - UNLOCK(); -} - -GC_API GC_start_callback_proc GC_CALL GC_get_start_callback(void) -{ - GC_start_callback_proc fn; - DCL_LOCK_STATE; - LOCK(); - fn = GC_start_call_back; - UNLOCK(); - return fn; -} - -GC_INLINE void GC_notify_full_gc(void) -{ - if (GC_start_call_back != 0) { - (*GC_start_call_back)(); - } -} - -STATIC GC_bool GC_is_full_gc = FALSE; - -STATIC GC_bool GC_stopped_mark(GC_stop_func stop_func); -STATIC void GC_finish_collection(void); - -/* - * Initiate a garbage collection if appropriate. - * Choose judiciously - * between partial, full, and stop-world collections. - */ -STATIC void GC_maybe_gc(void) -{ - static int n_partial_gcs = 0; - - GC_ASSERT(I_HOLD_LOCK()); - ASSERT_CANCEL_DISABLED(); - if (GC_should_collect()) { - if (!GC_incremental) { - /* FIXME: If possible, GC_default_stop_func should be used here */ - GC_try_to_collect_inner(GC_never_stop_func); - n_partial_gcs = 0; - return; - } else { -# ifdef PARALLEL_MARK - if (GC_parallel) - GC_wait_for_reclaim(); -# endif - if (GC_need_full_gc || n_partial_gcs >= GC_full_freq) { - GC_COND_LOG_PRINTF( - "***>Full mark for collection #%lu after %lu allocd bytes\n", - (unsigned long)GC_gc_no + 1, (unsigned long)GC_bytes_allocd); - GC_promote_black_lists(); - (void)GC_reclaim_all((GC_stop_func)0, TRUE); - GC_notify_full_gc(); - GC_clear_marks(); - n_partial_gcs = 0; - GC_is_full_gc = TRUE; - } else { - n_partial_gcs++; - } - } - /* We try to mark with the world stopped. */ - /* If we run out of time, this turns into */ - /* incremental marking. */ -# ifndef NO_CLOCK - if (GC_time_limit != GC_TIME_UNLIMITED) { GET_TIME(GC_start_time); } -# endif - /* FIXME: If possible, GC_default_stop_func should be */ - /* used instead of GC_never_stop_func here. */ - if (GC_stopped_mark(GC_time_limit == GC_TIME_UNLIMITED? - GC_never_stop_func : GC_timeout_stop_func)) { -# ifdef SAVE_CALL_CHAIN - GC_save_callers(GC_last_stack); -# endif - GC_finish_collection(); - } else { - if (!GC_is_full_gc) { - /* Count this as the first attempt */ - GC_n_attempts++; - } - } - } -} - - -/* - * Stop the world garbage collection. Assumes lock held. If stop_func is - * not GC_never_stop_func then abort if stop_func returns TRUE. - * Return TRUE if we successfully completed the collection. - */ -GC_INNER GC_bool GC_try_to_collect_inner(GC_stop_func stop_func) -{ -# ifndef SMALL_CONFIG - CLOCK_TYPE start_time = 0; /* initialized to prevent warning. */ - CLOCK_TYPE current_time; -# endif - ASSERT_CANCEL_DISABLED(); - if (GC_dont_gc || (*stop_func)()) return FALSE; - if (GC_incremental && GC_collection_in_progress()) { - GC_COND_LOG_PRINTF( - "GC_try_to_collect_inner: finishing collection in progress\n"); - /* Just finish collection already in progress. */ - while(GC_collection_in_progress()) { - if ((*stop_func)()) return(FALSE); - GC_collect_a_little_inner(1); - } - } - GC_notify_full_gc(); -# ifndef SMALL_CONFIG - if (GC_print_stats) { - GET_TIME(start_time); - GC_log_printf("Initiating full world-stop collection!\n"); - } -# endif - GC_promote_black_lists(); - /* Make sure all blocks have been reclaimed, so sweep routines */ - /* don't see cleared mark bits. */ - /* If we're guaranteed to finish, then this is unnecessary. */ - /* In the find_leak case, we have to finish to guarantee that */ - /* previously unmarked objects are not reported as leaks. */ -# ifdef PARALLEL_MARK - if (GC_parallel) - GC_wait_for_reclaim(); -# endif - if ((GC_find_leak || stop_func != GC_never_stop_func) - && !GC_reclaim_all(stop_func, FALSE)) { - /* Aborted. So far everything is still consistent. */ - return(FALSE); - } - GC_invalidate_mark_state(); /* Flush mark stack. */ - GC_clear_marks(); -# ifdef SAVE_CALL_CHAIN - GC_save_callers(GC_last_stack); -# endif - GC_is_full_gc = TRUE; - if (!GC_stopped_mark(stop_func)) { - if (!GC_incremental) { - /* We're partially done and have no way to complete or use */ - /* current work. Reestablish invariants as cheaply as */ - /* possible. */ - GC_invalidate_mark_state(); - GC_unpromote_black_lists(); - } /* else we claim the world is already still consistent. We'll */ - /* finish incrementally. */ - return(FALSE); - } - GC_finish_collection(); -# ifndef SMALL_CONFIG - if (GC_print_stats) { - GET_TIME(current_time); - GC_log_printf("Complete collection took %lu msecs\n", - MS_TIME_DIFF(current_time,start_time)); - } -# endif - return(TRUE); -} - -/* - * Perform n units of garbage collection work. A unit is intended to touch - * roughly GC_RATE pages. Every once in a while, we do more than that. - * This needs to be a fairly large number with our current incremental - * GC strategy, since otherwise we allocate too much during GC, and the - * cleanup gets expensive. - */ -#ifndef GC_RATE -# define GC_RATE 10 -#endif -#ifndef MAX_PRIOR_ATTEMPTS -# define MAX_PRIOR_ATTEMPTS 1 -#endif - /* Maximum number of prior attempts at world stop marking */ - /* A value of 1 means that we finish the second time, no matter */ - /* how long it takes. Doesn't count the initial root scan */ - /* for a full GC. */ - -STATIC int GC_deficit = 0;/* The number of extra calls to GC_mark_some */ - /* that we have made. */ - -GC_INNER void GC_collect_a_little_inner(int n) -{ - int i; - IF_CANCEL(int cancel_state;) - - if (GC_dont_gc) return; - DISABLE_CANCEL(cancel_state); - if (GC_incremental && GC_collection_in_progress()) { - for (i = GC_deficit; i < GC_RATE*n; i++) { - if (GC_mark_some((ptr_t)0)) { - /* Need to finish a collection */ -# ifdef SAVE_CALL_CHAIN - GC_save_callers(GC_last_stack); -# endif -# ifdef PARALLEL_MARK - if (GC_parallel) - GC_wait_for_reclaim(); -# endif - if (GC_n_attempts < MAX_PRIOR_ATTEMPTS - && GC_time_limit != GC_TIME_UNLIMITED) { -# ifndef NO_CLOCK - GET_TIME(GC_start_time); -# endif - if (!GC_stopped_mark(GC_timeout_stop_func)) { - GC_n_attempts++; - break; - } - } else { - /* FIXME: If possible, GC_default_stop_func should be */ - /* used here. */ - (void)GC_stopped_mark(GC_never_stop_func); - } - GC_finish_collection(); - break; - } - } - if (GC_deficit > 0) GC_deficit -= GC_RATE*n; - if (GC_deficit < 0) GC_deficit = 0; - } else { - GC_maybe_gc(); - } - RESTORE_CANCEL(cancel_state); -} - -GC_INNER void (*GC_check_heap)(void) = 0; -GC_INNER void (*GC_print_all_smashed)(void) = 0; - -GC_API int GC_CALL GC_collect_a_little(void) -{ - int result; - DCL_LOCK_STATE; - - LOCK(); - GC_collect_a_little_inner(1); - result = (int)GC_collection_in_progress(); - UNLOCK(); - if (!result && GC_debugging_started) GC_print_all_smashed(); - return(result); -} - -#ifndef SMALL_CONFIG - /* Variables for world-stop average delay time statistic computation. */ - /* "divisor" is incremented every world-stop and halved when reached */ - /* its maximum (or upon "total_time" overflow). */ - static unsigned world_stopped_total_time = 0; - static unsigned world_stopped_total_divisor = 0; -# ifndef MAX_TOTAL_TIME_DIVISOR - /* We shall not use big values here (so "outdated" delay time */ - /* values would have less impact on "average" delay time value than */ - /* newer ones). */ -# define MAX_TOTAL_TIME_DIVISOR 1000 -# endif -#endif - -#ifdef USE_MUNMAP -# define IF_USE_MUNMAP(x) x -# define COMMA_IF_USE_MUNMAP(x) /* comma */, x -#else -# define IF_USE_MUNMAP(x) /* empty */ -# define COMMA_IF_USE_MUNMAP(x) /* empty */ -#endif - -/* - * Assumes lock is held. We stop the world and mark from all roots. - * If stop_func() ever returns TRUE, we may fail and return FALSE. - * Increment GC_gc_no if we succeed. - */ -STATIC GC_bool GC_stopped_mark(GC_stop_func stop_func) -{ - unsigned i; -# ifndef SMALL_CONFIG - CLOCK_TYPE start_time = 0; /* initialized to prevent warning. */ - CLOCK_TYPE current_time; -# endif - -# if !defined(REDIRECT_MALLOC) && defined(USE_WINALLOC) - GC_add_current_malloc_heap(); -# endif -# if defined(REGISTER_LIBRARIES_EARLY) - GC_cond_register_dynamic_libraries(); -# endif - -# ifndef SMALL_CONFIG - if (GC_PRINT_STATS_FLAG) - GET_TIME(start_time); -# endif - - STOP_WORLD(); -# ifdef THREAD_LOCAL_ALLOC - GC_world_stopped = TRUE; -# endif - /* Output blank line for convenience here */ - GC_COND_LOG_PRINTF( - "\n--> Marking for collection #%lu after %lu allocated bytes\n", - (unsigned long)GC_gc_no + 1, (unsigned long) GC_bytes_allocd); -# ifdef MAKE_BACK_GRAPH - if (GC_print_back_height) { - GC_build_back_graph(); - } -# endif - - /* Mark from all roots. */ - /* Minimize junk left in my registers and on the stack */ - GC_clear_a_few_frames(); - GC_noop6(0,0,0,0,0,0); - - GC_initiate_gc(); - for (i = 0;;i++) { - if ((*stop_func)()) { - GC_COND_LOG_PRINTF("Abandoned stopped marking after" - " %u iterations\n", i); - GC_deficit = i; /* Give the mutator a chance. */ -# ifdef THREAD_LOCAL_ALLOC - GC_world_stopped = FALSE; -# endif - START_WORLD(); - return(FALSE); - } - if (GC_mark_some(GC_approx_sp())) break; - } - - GC_gc_no++; - GC_DBGLOG_PRINTF("GC #%lu freed %ld bytes, heap %lu KiB" - IF_USE_MUNMAP(" (+ %lu KiB unmapped)") "\n", - (unsigned long)GC_gc_no, (long)GC_bytes_found, - TO_KiB_UL(GC_heapsize - GC_unmapped_bytes) /*, */ - COMMA_IF_USE_MUNMAP(TO_KiB_UL(GC_unmapped_bytes))); - - /* Check all debugged objects for consistency */ - if (GC_debugging_started) { - (*GC_check_heap)(); - } - -# ifdef THREAD_LOCAL_ALLOC - GC_world_stopped = FALSE; -# endif - START_WORLD(); -# ifndef SMALL_CONFIG - if (GC_PRINT_STATS_FLAG) { - unsigned long time_diff; - unsigned total_time, divisor; - GET_TIME(current_time); - time_diff = MS_TIME_DIFF(current_time,start_time); - - /* Compute new world-stop delay total time */ - total_time = world_stopped_total_time; - divisor = world_stopped_total_divisor; - if ((int)total_time < 0 || divisor >= MAX_TOTAL_TIME_DIVISOR) { - /* Halve values if overflow occurs */ - total_time >>= 1; - divisor >>= 1; - } - total_time += time_diff < (((unsigned)-1) >> 1) ? - (unsigned)time_diff : ((unsigned)-1) >> 1; - /* Update old world_stopped_total_time and its divisor */ - world_stopped_total_time = total_time; - world_stopped_total_divisor = ++divisor; - - GC_ASSERT(divisor != 0); - GC_log_printf( - "World-stopped marking took %lu msecs (%u in average)\n", - time_diff, total_time / divisor); - } -# endif - return(TRUE); -} - -/* Set all mark bits for the free list whose first entry is q */ -GC_INNER void GC_set_fl_marks(ptr_t q) -{ - struct hblk *h, *last_h; - hdr *hhdr; - IF_PER_OBJ(size_t sz;) - unsigned bit_no; - - if (q != NULL) { - h = HBLKPTR(q); - last_h = h; - hhdr = HDR(h); - IF_PER_OBJ(sz = hhdr->hb_sz;) - - for (;;) { - bit_no = MARK_BIT_NO((ptr_t)q - (ptr_t)h, sz); - if (!mark_bit_from_hdr(hhdr, bit_no)) { - set_mark_bit_from_hdr(hhdr, bit_no); - ++hhdr -> hb_n_marks; - } - - q = obj_link(q); - if (q == NULL) - break; - - h = HBLKPTR(q); - if (h != last_h) { - last_h = h; - hhdr = HDR(h); - IF_PER_OBJ(sz = hhdr->hb_sz;) - } - } - } -} - -#if defined(GC_ASSERTIONS) && defined(THREADS) && defined(THREAD_LOCAL_ALLOC) - /* Check that all mark bits for the free list whose first entry is */ - /* (*pfreelist) are set. Check skipped if points to a special value. */ - void GC_check_fl_marks(void **pfreelist) - { -# ifdef AO_HAVE_load_acquire_read - AO_t *list = (AO_t *)AO_load_acquire_read((AO_t *)pfreelist); - /* Atomic operations are used because the world is running. */ - AO_t *prev; - AO_t *p; - - if ((word)list <= HBLKSIZE) return; - - prev = (AO_t *)pfreelist; - for (p = list; p != NULL;) { - AO_t *next; - - if (!GC_is_marked(p)) { - ABORT_ARG2("Unmarked local free list entry", - ": object %p on list %p", (void *)p, (void *)list); - } - - /* While traversing the free-list, it re-reads the pointer to */ - /* the current node before accepting its next pointer and */ - /* bails out if the latter has changed. That way, it won't */ - /* try to follow the pointer which might be been modified */ - /* after the object was returned to the client. It might */ - /* perform the mark-check on the just allocated object but */ - /* that should be harmless. */ - next = (AO_t *)AO_load_acquire_read(p); - if (AO_load(prev) != (AO_t)p) - break; - prev = p; - p = next; - } -# else - /* FIXME: Not implemented (just skipped). */ - (void)pfreelist; -# endif - } -#endif /* GC_ASSERTIONS && THREAD_LOCAL_ALLOC */ - -/* Clear all mark bits for the free list whose first entry is q */ -/* Decrement GC_bytes_found by number of bytes on free list. */ -STATIC void GC_clear_fl_marks(ptr_t q) -{ - struct hblk *h, *last_h; - hdr *hhdr; - size_t sz; - unsigned bit_no; - - if (q != NULL) { - h = HBLKPTR(q); - last_h = h; - hhdr = HDR(h); - sz = hhdr->hb_sz; /* Normally set only once. */ - - for (;;) { - bit_no = MARK_BIT_NO((ptr_t)q - (ptr_t)h, sz); - if (mark_bit_from_hdr(hhdr, bit_no)) { - size_t n_marks = hhdr -> hb_n_marks - 1; - clear_mark_bit_from_hdr(hhdr, bit_no); -# ifdef PARALLEL_MARK - /* Appr. count, don't decrement to zero! */ - if (0 != n_marks || !GC_parallel) { - hhdr -> hb_n_marks = n_marks; - } -# else - hhdr -> hb_n_marks = n_marks; -# endif - } - GC_bytes_found -= sz; - - q = obj_link(q); - if (q == NULL) - break; - - h = HBLKPTR(q); - if (h != last_h) { - last_h = h; - hhdr = HDR(h); - sz = hhdr->hb_sz; - } - } - } -} - -#if defined(GC_ASSERTIONS) && defined(THREADS) && defined(THREAD_LOCAL_ALLOC) - void GC_check_tls(void); -#endif - -GC_on_heap_resize_proc GC_on_heap_resize = 0; - -/* Used for logging only. */ -GC_INLINE int GC_compute_heap_usage_percent(void) -{ - word used = GC_composite_in_use + GC_atomic_in_use; - word heap_sz = GC_heapsize - GC_unmapped_bytes; - return used >= heap_sz ? 0 : used < ((word)-1) / 100 ? - (int)((used * 100) / heap_sz) : (int)(used / (heap_sz / 100)); -} - -/* Finish up a collection. Assumes mark bits are consistent, lock is */ -/* held, but the world is otherwise running. */ -STATIC void GC_finish_collection(void) -{ -# ifndef SMALL_CONFIG - CLOCK_TYPE start_time = 0; /* initialized to prevent warning. */ - CLOCK_TYPE finalize_time = 0; - CLOCK_TYPE done_time; -# endif - -# if defined(GC_ASSERTIONS) && defined(THREADS) \ - && defined(THREAD_LOCAL_ALLOC) && !defined(DBG_HDRS_ALL) - /* Check that we marked some of our own data. */ - /* FIXME: Add more checks. */ - GC_check_tls(); -# endif - -# ifndef SMALL_CONFIG - if (GC_print_stats) - GET_TIME(start_time); -# endif - -# ifndef GC_GET_HEAP_USAGE_NOT_NEEDED - if (GC_bytes_found > 0) - GC_reclaimed_bytes_before_gc += (word)GC_bytes_found; -# endif - GC_bytes_found = 0; -# if defined(LINUX) && defined(__ELF__) && !defined(SMALL_CONFIG) - if (GETENV("GC_PRINT_ADDRESS_MAP") != 0) { - GC_print_address_map(); - } -# endif - COND_DUMP; - if (GC_find_leak) { - /* Mark all objects on the free list. All objects should be */ - /* marked when we're done. */ - word size; /* current object size */ - unsigned kind; - ptr_t q; - - for (kind = 0; kind < GC_n_kinds; kind++) { - for (size = 1; size <= MAXOBJGRANULES; size++) { - q = GC_obj_kinds[kind].ok_freelist[size]; - if (q != 0) GC_set_fl_marks(q); - } - } - GC_start_reclaim(TRUE); - /* The above just checks; it doesn't really reclaim anything. */ - } - -# ifndef GC_NO_FINALIZATION - GC_finalize(); -# endif -# ifdef STUBBORN_ALLOC - GC_clean_changing_list(); -# endif - -# ifndef SMALL_CONFIG - if (GC_print_stats) - GET_TIME(finalize_time); -# endif - - if (GC_print_back_height) { -# ifdef MAKE_BACK_GRAPH - GC_traverse_back_graph(); -# elif !defined(SMALL_CONFIG) - GC_err_printf("Back height not available: " - "Rebuild collector with -DMAKE_BACK_GRAPH\n"); -# endif - } - - /* Clear free list mark bits, in case they got accidentally marked */ - /* (or GC_find_leak is set and they were intentionally marked). */ - /* Also subtract memory remaining from GC_bytes_found count. */ - /* Note that composite objects on free list are cleared. */ - /* Thus accidentally marking a free list is not a problem; only */ - /* objects on the list itself will be marked, and that's fixed here. */ - { - word size; /* current object size */ - ptr_t q; /* pointer to current object */ - unsigned kind; - - for (kind = 0; kind < GC_n_kinds; kind++) { - for (size = 1; size <= MAXOBJGRANULES; size++) { - q = GC_obj_kinds[kind].ok_freelist[size]; - if (q != 0) GC_clear_fl_marks(q); - } - } - } - - GC_VERBOSE_LOG_PRINTF("Bytes recovered before sweep - f.l. count = %ld\n", - (long)GC_bytes_found); - - /* Reconstruct free lists to contain everything not marked */ - GC_start_reclaim(FALSE); - GC_DBGLOG_PRINTF("In-use heap: %d%% (%lu KiB pointers + %lu KiB other)\n", - GC_compute_heap_usage_percent(), - TO_KiB_UL(GC_composite_in_use), - TO_KiB_UL(GC_atomic_in_use)); - if (GC_is_full_gc) { - GC_used_heap_size_after_full = USED_HEAP_SIZE; - GC_need_full_gc = FALSE; - } else { - GC_need_full_gc = USED_HEAP_SIZE - GC_used_heap_size_after_full - > min_bytes_allocd(); - } - - GC_VERBOSE_LOG_PRINTF("Immediately reclaimed %ld bytes, heapsize:" - " %lu bytes" IF_USE_MUNMAP(" (%lu unmapped)") "\n", - (long)GC_bytes_found, - (unsigned long)GC_heapsize /*, */ - COMMA_IF_USE_MUNMAP((unsigned long) - GC_unmapped_bytes)); - - /* Reset or increment counters for next cycle */ - GC_n_attempts = 0; - GC_is_full_gc = FALSE; - GC_bytes_allocd_before_gc += GC_bytes_allocd; - GC_non_gc_bytes_at_gc = GC_non_gc_bytes; - GC_bytes_allocd = 0; - GC_bytes_dropped = 0; - GC_bytes_freed = 0; - GC_finalizer_bytes_freed = 0; - - IF_USE_MUNMAP(GC_unmap_old()); - -# ifndef SMALL_CONFIG - if (GC_print_stats) { - GET_TIME(done_time); -# ifndef GC_NO_FINALIZATION - /* A convenient place to output finalization statistics. */ - GC_print_finalization_stats(); -# endif - GC_log_printf("Finalize plus initiate sweep took %lu + %lu msecs\n", - MS_TIME_DIFF(finalize_time,start_time), - MS_TIME_DIFF(done_time,finalize_time)); - } -# endif -} - -/* If stop_func == 0 then GC_default_stop_func is used instead. */ -STATIC GC_bool GC_try_to_collect_general(GC_stop_func stop_func, - GC_bool force_unmap GC_ATTR_UNUSED) -{ - GC_bool result; - IF_USE_MUNMAP(int old_unmap_threshold;) - IF_CANCEL(int cancel_state;) - DCL_LOCK_STATE; - - if (!EXPECT(GC_is_initialized, TRUE)) GC_init(); - if (GC_debugging_started) GC_print_all_smashed(); - GC_INVOKE_FINALIZERS(); - LOCK(); - DISABLE_CANCEL(cancel_state); -# ifdef USE_MUNMAP - old_unmap_threshold = GC_unmap_threshold; - if (force_unmap || - (GC_force_unmap_on_gcollect && old_unmap_threshold > 0)) - GC_unmap_threshold = 1; /* unmap as much as possible */ -# endif - ENTER_GC(); - /* Minimize junk left in my registers */ - GC_noop6(0,0,0,0,0,0); - result = GC_try_to_collect_inner(stop_func != 0 ? stop_func : - GC_default_stop_func); - EXIT_GC(); - IF_USE_MUNMAP(GC_unmap_threshold = old_unmap_threshold); /* restore */ - RESTORE_CANCEL(cancel_state); - UNLOCK(); - if (result) { - if (GC_debugging_started) GC_print_all_smashed(); - GC_INVOKE_FINALIZERS(); - } - return(result); -} - -/* Externally callable routines to invoke full, stop-the-world collection. */ -GC_API int GC_CALL GC_try_to_collect(GC_stop_func stop_func) -{ - GC_ASSERT(stop_func != 0); - return (int)GC_try_to_collect_general(stop_func, FALSE); -} - -GC_API void GC_CALL GC_gcollect(void) -{ - /* 0 is passed as stop_func to get GC_default_stop_func value */ - /* while holding the allocation lock (to prevent data races). */ - (void)GC_try_to_collect_general(0, FALSE); - if (GC_have_errors) GC_print_all_errors(); -} - -STATIC word GC_heapsize_at_forced_unmap = 0; - -GC_API void GC_CALL GC_gcollect_and_unmap(void) -{ - /* Record current heap size to make heap growth more conservative */ - /* afterwards (as if the heap is growing from zero size again). */ - GC_heapsize_at_forced_unmap = GC_heapsize; - /* Collect and force memory unmapping to OS. */ - (void)GC_try_to_collect_general(GC_never_stop_func, TRUE); -} - -GC_INNER word GC_n_heap_sects = 0; - /* Number of sections currently in heap. */ - -#ifdef USE_PROC_FOR_LIBRARIES - GC_INNER word GC_n_memory = 0; - /* Number of GET_MEM allocated memory sections. */ -#endif - -#ifdef USE_PROC_FOR_LIBRARIES - /* Add HBLKSIZE aligned, GET_MEM-generated block to GC_our_memory. */ - /* Defined to do nothing if USE_PROC_FOR_LIBRARIES not set. */ - GC_INNER void GC_add_to_our_memory(ptr_t p, size_t bytes) - { - if (0 == p) return; - if (GC_n_memory >= MAX_HEAP_SECTS) - ABORT("Too many GC-allocated memory sections: Increase MAX_HEAP_SECTS"); - GC_our_memory[GC_n_memory].hs_start = p; - GC_our_memory[GC_n_memory].hs_bytes = bytes; - GC_n_memory++; - } -#endif - -/* - * Use the chunk of memory starting at p of size bytes as part of the heap. - * Assumes p is HBLKSIZE aligned, and bytes is a multiple of HBLKSIZE. - */ -GC_INNER void GC_add_to_heap(struct hblk *p, size_t bytes) -{ - hdr * phdr; - word endp; - - if (GC_n_heap_sects >= MAX_HEAP_SECTS) { - ABORT("Too many heap sections: Increase MAXHINCR or MAX_HEAP_SECTS"); - } - while ((word)p <= HBLKSIZE) { - /* Can't handle memory near address zero. */ - ++p; - bytes -= HBLKSIZE; - if (0 == bytes) return; - } - endp = (word)p + bytes; - if (endp <= (word)p) { - /* Address wrapped. */ - bytes -= HBLKSIZE; - if (0 == bytes) return; - endp -= HBLKSIZE; - } - phdr = GC_install_header(p); - if (0 == phdr) { - /* This is extremely unlikely. Can't add it. This will */ - /* almost certainly result in a 0 return from the allocator, */ - /* which is entirely appropriate. */ - return; - } - GC_ASSERT(endp > (word)p && endp == (word)p + bytes); - GC_heap_sects[GC_n_heap_sects].hs_start = (ptr_t)p; - GC_heap_sects[GC_n_heap_sects].hs_bytes = bytes; - GC_n_heap_sects++; - phdr -> hb_sz = bytes; - phdr -> hb_flags = 0; - GC_freehblk(p); - GC_heapsize += bytes; - - /* Normally the caller calculates a new GC_collect_at_heapsize, - * but this is also called directly from alloc_mark_stack, so - * adjust here. It will be recalculated when called from - * GC_expand_hp_inner. - */ - GC_collect_at_heapsize += bytes; - if (GC_collect_at_heapsize < GC_heapsize /* wrapped */) - GC_collect_at_heapsize = (word)(-1); - - if ((word)p <= (word)GC_least_plausible_heap_addr - || GC_least_plausible_heap_addr == 0) { - GC_least_plausible_heap_addr = (void *)((ptr_t)p - sizeof(word)); - /* Making it a little smaller than necessary prevents */ - /* us from getting a false hit from the variable */ - /* itself. There's some unintentional reflection */ - /* here. */ - } - if ((word)p + bytes >= (word)GC_greatest_plausible_heap_addr) { - GC_greatest_plausible_heap_addr = (void *)endp; - } -} - -#if !defined(NO_DEBUGGING) - void GC_print_heap_sects(void) - { - unsigned i; - - GC_printf("Total heap size: %lu" IF_USE_MUNMAP(" (%lu unmapped)") "\n", - (unsigned long)GC_heapsize /*, */ - COMMA_IF_USE_MUNMAP((unsigned long)GC_unmapped_bytes)); - - for (i = 0; i < GC_n_heap_sects; i++) { - ptr_t start = GC_heap_sects[i].hs_start; - size_t len = GC_heap_sects[i].hs_bytes; - struct hblk *h; - unsigned nbl = 0; - - for (h = (struct hblk *)start; (word)h < (word)(start + len); h++) { - if (GC_is_black_listed(h, HBLKSIZE)) nbl++; - } - GC_printf("Section %d from %p to %p %lu/%lu blacklisted\n", - i, start, start + len, - (unsigned long)nbl, (unsigned long)(len/HBLKSIZE)); - } - } -#endif - -void * GC_least_plausible_heap_addr = (void *)ONES; -void * GC_greatest_plausible_heap_addr = 0; - -GC_INLINE word GC_max(word x, word y) -{ - return(x > y? x : y); -} - -GC_INLINE word GC_min(word x, word y) -{ - return(x < y? x : y); -} - -STATIC word GC_max_heapsize = 0; - -GC_API void GC_CALL GC_set_max_heap_size(GC_word n) -{ - GC_max_heapsize = n; -} - -GC_word GC_max_retries = 0; - -/* This explicitly increases the size of the heap. It is used */ -/* internally, but may also be invoked from GC_expand_hp by the user. */ -/* The argument is in units of HBLKSIZE (tiny values are rounded up). */ -/* Returns FALSE on failure. */ -GC_INNER GC_bool GC_expand_hp_inner(word n) -{ - word bytes; - struct hblk * space; - word expansion_slop; /* Number of bytes by which we expect the */ - /* heap to expand soon. */ - - if (n < MINHINCR) n = MINHINCR; - bytes = ROUNDUP_PAGESIZE(n * HBLKSIZE); - if (GC_max_heapsize != 0 && GC_heapsize + bytes > GC_max_heapsize) { - /* Exceeded self-imposed limit */ - return(FALSE); - } - space = GET_MEM(bytes); - GC_add_to_our_memory((ptr_t)space, bytes); - if (space == 0) { - WARN("Failed to expand heap by %" WARN_PRIdPTR " bytes\n", bytes); - return(FALSE); - } - GC_INFOLOG_PRINTF("Grow heap to %lu KiB after %lu bytes allocated\n", - TO_KiB_UL(GC_heapsize + bytes), - (unsigned long)GC_bytes_allocd); - /* Adjust heap limits generously for blacklisting to work better. */ - /* GC_add_to_heap performs minimal adjustment needed for */ - /* correctness. */ - expansion_slop = min_bytes_allocd() + 4*MAXHINCR*HBLKSIZE; - if ((GC_last_heap_addr == 0 && !((word)space & SIGNB)) - || (GC_last_heap_addr != 0 - && (word)GC_last_heap_addr < (word)space)) { - /* Assume the heap is growing up */ - word new_limit = (word)space + bytes + expansion_slop; - if (new_limit > (word)space) { - GC_greatest_plausible_heap_addr = - (void *)GC_max((word)GC_greatest_plausible_heap_addr, - (word)new_limit); - } - } else { - /* Heap is growing down */ - word new_limit = (word)space - expansion_slop; - if (new_limit < (word)space) { - GC_least_plausible_heap_addr = - (void *)GC_min((word)GC_least_plausible_heap_addr, - (word)space - expansion_slop); - } - } - GC_prev_heap_addr = GC_last_heap_addr; - GC_last_heap_addr = (ptr_t)space; - GC_add_to_heap(space, bytes); - /* Force GC before we are likely to allocate past expansion_slop */ - GC_collect_at_heapsize = - GC_heapsize + expansion_slop - 2*MAXHINCR*HBLKSIZE; - if (GC_collect_at_heapsize < GC_heapsize /* wrapped */) - GC_collect_at_heapsize = (word)(-1); - if (GC_on_heap_resize) - (*GC_on_heap_resize)(GC_heapsize); - - return(TRUE); -} - -/* Really returns a bool, but it's externally visible, so that's clumsy. */ -/* Arguments is in bytes. Includes GC_init() call. */ -GC_API int GC_CALL GC_expand_hp(size_t bytes) -{ - int result; - DCL_LOCK_STATE; - - LOCK(); - if (!EXPECT(GC_is_initialized, TRUE)) GC_init(); - result = (int)GC_expand_hp_inner(divHBLKSZ((word)bytes)); - if (result) GC_requested_heapsize += bytes; - UNLOCK(); - return(result); -} - -word GC_fo_entries = 0; /* used also in extra/MacOS.c */ - -GC_INNER unsigned GC_fail_count = 0; - /* How many consecutive GC/expansion failures? */ - /* Reset by GC_allochblk. */ - -static word last_fo_entries = 0; -static word last_bytes_finalized = 0; - -/* Collect or expand heap in an attempt make the indicated number of */ -/* free blocks available. Should be called until the blocks are */ -/* available (setting retry value to TRUE unless this is the first call */ -/* in a loop) or until it fails by returning FALSE. */ -GC_INNER GC_bool GC_collect_or_expand(word needed_blocks, - GC_bool ignore_off_page, - GC_bool retry) -{ - GC_bool gc_not_stopped = TRUE; - word blocks_to_get; - IF_CANCEL(int cancel_state;) - - DISABLE_CANCEL(cancel_state); - if (!GC_incremental && !GC_dont_gc && - ((GC_dont_expand && GC_bytes_allocd > 0) - || (GC_fo_entries > (last_fo_entries + 500) - && (last_bytes_finalized | GC_bytes_finalized) != 0) - || GC_should_collect())) { - /* Try to do a full collection using 'default' stop_func (unless */ - /* nothing has been allocated since the latest collection or heap */ - /* expansion is disabled). */ - gc_not_stopped = GC_try_to_collect_inner( - GC_bytes_allocd > 0 && (!GC_dont_expand || !retry) ? - GC_default_stop_func : GC_never_stop_func); - if (gc_not_stopped == TRUE || !retry) { - /* Either the collection hasn't been aborted or this is the */ - /* first attempt (in a loop). */ - last_fo_entries = GC_fo_entries; - last_bytes_finalized = GC_bytes_finalized; - RESTORE_CANCEL(cancel_state); - return(TRUE); - } - } - - blocks_to_get = (GC_heapsize - GC_heapsize_at_forced_unmap) - / (HBLKSIZE * GC_free_space_divisor) - + needed_blocks; - if (blocks_to_get > MAXHINCR) { - word slop; - - /* Get the minimum required to make it likely that we can satisfy */ - /* the current request in the presence of black-listing. */ - /* This will probably be more than MAXHINCR. */ - if (ignore_off_page) { - slop = 4; - } else { - slop = 2 * divHBLKSZ(BL_LIMIT); - if (slop > needed_blocks) slop = needed_blocks; - } - if (needed_blocks + slop > MAXHINCR) { - blocks_to_get = needed_blocks + slop; - } else { - blocks_to_get = MAXHINCR; - } - } - - if (!GC_expand_hp_inner(blocks_to_get) - && (blocks_to_get == needed_blocks - || !GC_expand_hp_inner(needed_blocks))) { - if (gc_not_stopped == FALSE) { - /* Don't increment GC_fail_count here (and no warning). */ - GC_gcollect_inner(); - GC_ASSERT(GC_bytes_allocd == 0); - } else if (GC_fail_count++ < GC_max_retries) { - WARN("Out of Memory! Trying to continue ...\n", 0); - GC_gcollect_inner(); - } else { -# if !defined(AMIGA) || !defined(GC_AMIGA_FASTALLOC) - WARN("Out of Memory! Heap size: %" WARN_PRIdPTR " MiB." - " Returning NULL!\n", (GC_heapsize - GC_unmapped_bytes) >> 20); -# endif - RESTORE_CANCEL(cancel_state); - return(FALSE); - } - } else if (GC_fail_count) { - GC_COND_LOG_PRINTF("Memory available again...\n"); - } - RESTORE_CANCEL(cancel_state); - return(TRUE); -} - -/* - * Make sure the object free list for size gran (in granules) is not empty. - * Return a pointer to the first object on the free list. - * The object MUST BE REMOVED FROM THE FREE LIST BY THE CALLER. - * Assumes we hold the allocator lock. - */ -GC_INNER ptr_t GC_allocobj(size_t gran, int kind) -{ - void ** flh = &(GC_obj_kinds[kind].ok_freelist[gran]); - GC_bool tried_minor = FALSE; - GC_bool retry = FALSE; - - if (gran == 0) return(0); - - while (*flh == 0) { - ENTER_GC(); - /* Do our share of marking work */ - if(TRUE_INCREMENTAL) GC_collect_a_little_inner(1); - /* Sweep blocks for objects of this size */ - GC_continue_reclaim(gran, kind); - EXIT_GC(); - if (*flh == 0) { - GC_new_hblk(gran, kind); - if (*flh == 0) { - ENTER_GC(); - if (GC_incremental && GC_time_limit == GC_TIME_UNLIMITED - && !tried_minor) { - GC_collect_a_little_inner(1); - tried_minor = TRUE; - } else { - if (!GC_collect_or_expand(1, FALSE, retry)) { - EXIT_GC(); - return(0); - } - retry = TRUE; - } - EXIT_GC(); - } - } - } - /* Successful allocation; reset failure count. */ - GC_fail_count = 0; - - return(*flh); -} diff -Nru ecl-16.1.2/src/bdwgc/AUTHORS ecl-16.1.3+ds/src/bdwgc/AUTHORS --- ecl-16.1.2/src/bdwgc/AUTHORS 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/AUTHORS 1970-01-01 00:00:00.000000000 +0000 @@ -1,362 +0,0 @@ -This is an attempt to acknowledge contributions to the garbage collector. -Early contributions also mentioned (duplicated) in ChangeLog file; details of -later ones should be in "git log". - -HISTORY - - - Early versions of this collector were developed as a part of research -projects supported in part by the National Science Foundation -and the Defense Advance Research Projects Agency. - -The garbage collector originated as part of the run-time system for -the Russell programming language implementation. The first version of the -garbage collector was written primarily by Alan Demers. It was then refined -and mostly rewritten, primarily by Hans-J. Boehm, at Cornell U., -the University of Washington, Rice University (where it was first used for -C and assembly code), Xerox PARC, SGI, and HP Labs. However, significant -contributions have also been made by many others. - -Other contributors (my apologies for any omissions): - -Adam Megacz -Adnan Ali -Adrian Bunk -Akira Tagoh -Alain Novak -Alan Dosser -Alan J. Demers -Aleksey Demakov -Alexander Belchenko -Alexander Gavrilov -Alexander Herz -Alexandr Petrosian -Alexandr Shadchin -Alexandre Oliva -Alistair G. Crooks -Allan Hsu -Andre Leiradella -Andreas Jaeger -Andreas Tobler -Andrei Polushin -Andrej Cedilnik -Andrew Begel -Andrew Gray -Andrew Haley -Andrew Horton -Andrew McKinlay -Andrew Pinski -Andrew Stitcher -Andrew Stone -Andy Wingo -Anselm Baird-Smith -Anthony Green -Antoine de Maricourt -Ari Huttunen -Arrigo Triulzi -Ashley Bone -Assar Westerlund -Barry DeFreese -Baruch Siach -Ben A. Mesander -Ben Cottrell -Ben Hutchings -Ben Maurer -Benjamin Lerman -Bernd Edlinger -Bernie Solomon -Bill Janssen -Bo Thorsen -Bradley D. LaRonde -Bradley Smith -Brent Benson -Brian Alliet -Brian Beuning -Brian Burton -Brian D. Carlstrom -Brian F. Dennis -Brian Lewis -Bruce Hoult -Bruce Mitchener -Bruno Haible -Bryce McKinlay -Burkhard Linke -Cesar Eduardo Barros -Charles Fiterman -Charles Mills -Chris Dodd -Chris Lingard -Christian Joensson -Christian Limpach -Christian Thalinger -Christoffe Raffali -Clay Spence -Colin LeMahieu -Craig McDaniel -Dai Sato -Dan Bonachea -Dan Fandrich -Dan Sullivan -Daniel R. Grayson -Danny Smith -Darrell Schiebel -Dave Barrett -Dave Detlefs -Dave Korn -Dave Love -David Ayers -David Brownlee -David Butenhof -David Chase -David Daney -David Grove -David Leonard -David Miller -David Mossberger -David Peroutka -David Pickens -David Stes -Davide Angelocola -Dick Porter -Dietmar Planitzer -Dimitris Vyzovitis -Dimitry Andric -Djamel Magri -Doug Kaufman -Doug Moen -Douglas Steel -Elijah Taylor -Elvenlord Elrond -Emmanual Stumpf -Eric Benson -Eric Holk -Fabian Thylman -Fergus Henderson -Franklin Chen -Fred Gilham -Fred Stearns -Friedrich Dominicus -Gary Leavens -Geoff Norton -George Talbot -Gerard A Allan -Glauco Masotti -Grzegorz Jakacki -Gustavo Rodriguez-Rivera -H.J. Lu -Hannes Mehnert -Hanno Boeck -Hans Boehm -Hans-Peter Nilsson -Henning Makholm -Henrik Theiling -Hironori Sakamoto -Hiroshi Kawashima -Hubert Garavel -Iain Sandoe -Ian Piumarta -Ian Searle -Igor Khavkine -Ivan Demakov -Ivan Maidanski -Jaap Boender -Jack Andrews -Jacob Navia -Jakub Jelinek -James Clark -James Dominy -Jan Alexander Steffens -Jan Wielemaker -Jani Kajala -Jean-Baptiste Nivois -Jean-Claude Beaudoin -Jean-Daniel Fekete -Jeff Sturm -Jeffrey Hsu -Jeffrey Mark Siskind -Jeremy Fitzhardinge -Jesper Peterson -Jesse Hull -Jesse Jones -Jesse Rosenstock -Ji-Yong Chung -Jie Liu -Jim Marshall -Jim Meyering -Joerg Sonnenberger -Johannes Schmidt -Johannes Totz -John Bowman -John Clements -John Ellis -John Merryweather Cooper -Jon Moore -Jonathan Bachrach -Jonathan Chambers -Jonathan Clark -Jonathan Pryor -Juan Jose Garcia-Ripoll -Kai Tietz -Kaz Kojima -Kazu Hirata -Kazuhiro Inaoka -Kenjiro Taura -Kenneth Schalk -Kevin Kenny -Kevin Tew -Kevin Warne -Kjetil S. Matheussen -Klaus Treichel -Knut Tvedten -Krister Walfridsson -Kristian Kristensen -Kumar Srikantan -Kurt Miller -Lars Farm -Laurent Morichetti -Linas Vepstas -Loren J. Rittle -Louis Zhuang -Ludovic Courtes -Maarten Thibaut -Manuel A. Fernandez Montecelo -Manuel Serrano -Marc Recht -Marco Maggi -Marcos Dione -Marcus Herbert -Margaret Fleck -Mark Boulter -Mark Mitchell -Mark Reichert -Mark Sibly -Mark Weiser -Martin Hirzel -Martin Tauchmann -Matt Austern -Matthew Flatt -Matthias Andree -Matthias Drochner -Maurizio Vairani -Melissa O'Neill -Michael Arnoldus -Michael Smith -Michael Spertus -Michel Schinz -Miguel de Icaza -Mike Gran -Mike McGaughey -Mike Stump -Mitch Harris -Mohan Embar -Nathanael Nerode -Neale Ferguson -Neil Sharman -Nicolas Cannasse -Niibe Yutaka -Niklas Therning -Noah Lavine -Nobuyuki Hikichi -Oliver Kurth -Ondrej Bilka -Paolo Molaro -Parag Patel -Patrick Bridges -Patrick C. Beard -Patrick Doyle -Paul Brook -Paul Graham -Paul Nash -Per Bothner -Peter Bigot -Peter Chubb -Peter Colson -Peter Housel -Peter Monks -Peter Ross -Peter Seebach -Peter Wang -Petr Krajca -Petr Salinger -Petter Urkedal -Philip Brown -Philipp Tomsich -Philippe Queinnec -Phillip Musumeci -Phong Vo -Pierre de Rop -Pontus Rydin -Radek Polak -Rainer Orth -Ranjit Mathew -Rauli Ruohonen -Regis Cridlig -Reimer Behrends -Renaud Blanch -Rene Girard -Rex Dieter -Reza Shahidi -Richard Earnshaw -Richard Henderson -Richard Sandiford -Rob Haack -Robert Brazile -Roger Sayle -Roland McGrath -Roman Hodek -Romano Paolo Tenca -Rutger Ovidius -Ryan Murray -Salvador Eduardo Tropea -Samuel Thibault -Scott Ananian -Scott Schwartz -Shawn Wagner -Shiro Kawai -Simon Gornall -Simon Posnjak -Slava Sysoltsev -Stefan Ring -Stefano Rivera -Sugioka Toshinobu -Suzuki Toshiya -Sven Hartrumpf -Sven Verdoolaege -Takis Psarogiannakopoulos -Tatsuya Bizenn -Thiemo Seufer -Thomas Funke -Thomas Klausner -Thomas Maier -Thorsten Glaser -Tilman Vogel -Tim Bingham -Timothy N. Newsham -Tom Tromey -Tommaso Tagliapietra -Toralf Foerster -Toshio Endo -Tsugutomo Enami -Tum Nguyen -Tyson Dowd -Uchiyama Yasushi -Ulrich Drepper -Ulrich Weigand -Uros Bizjak -Vernon Lee -Victor Ivrii -Vitaly Magerya -Vladimir Tsichevski -Walter Bright -Walter Underwood -Wilson Ho -Wink Saville -Xi Wang -Xiaokun Zhu -Yann Dirson -Yannis Bres -Yusuke Suzuki -Yvan Roux -Zach Saw -Zhiying Chen -Zhong Shao -Zoltan Varga diff -Nru ecl-16.1.2/src/bdwgc/autogen.sh ecl-16.1.3+ds/src/bdwgc/autogen.sh --- ecl-16.1.2/src/bdwgc/autogen.sh 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/autogen.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,18 +0,0 @@ -#!/bin/sh -set -e - -# This script creates (or regenerates) configure (as well as aclocal.m4, -# config.h.in, Makefile.in, etc.) missing in the source repository. -# -# If you compile from a distribution tarball, you can skip this. Otherwise, -# make sure that you have Autoconf, Automake, Libtool, and pkg-config -# installed on your system, and that the corresponding *.m4 files are visible -# to the aclocal. The latter can be achieved by using packages shipped by -# your OS, or by installing custom versions of all four packages to the same -# prefix. Otherwise, you may need to invoke autoreconf with the appropriate -# -I options to locate the required *.m4 files. - -autoreconf -i - -echo -echo "Ready to run './configure'." diff -Nru ecl-16.1.2/src/bdwgc/backgraph.c ecl-16.1.3+ds/src/bdwgc/backgraph.c --- ecl-16.1.2/src/bdwgc/backgraph.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/backgraph.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,481 +0,0 @@ -/* - * Copyright (c) 2001 by Hewlett-Packard Company. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -#include "private/dbg_mlc.h" - -/* - * This implements a full, though not well-tuned, representation of the - * backwards points-to graph. This is used to test for non-GC-robust - * data structures; the code is not used during normal garbage collection. - * - * One restriction is that we drop all back-edges from nodes with very - * high in-degree, and simply add them add them to a list of such - * nodes. They are then treated as permanent roots. Id this by itself - * doesn't introduce a space leak, then such nodes can't contribute to - * a growing space leak. - */ - -#ifdef MAKE_BACK_GRAPH - -#define MAX_IN 10 /* Maximum in-degree we handle directly */ - -/* #include */ - -#if !defined(DBG_HDRS_ALL) || (ALIGNMENT != CPP_WORDSZ/8) /* || !defined(UNIX_LIKE) */ -# error The configuration does not support MAKE_BACK_GRAPH -#endif - -/* We store single back pointers directly in the object's oh_bg_ptr field. */ -/* If there is more than one ptr to an object, we store q | FLAG_MANY, */ -/* where q is a pointer to a back_edges object. */ -/* Every once in a while we use a back_edges object even for a single */ -/* pointer, since we need the other fields in the back_edges structure to */ -/* be present in some fraction of the objects. Otherwise we get serious */ -/* performance issues. */ -#define FLAG_MANY 2 - -typedef struct back_edges_struct { - word n_edges; /* Number of edges, including those in continuation */ - /* structures. */ - unsigned short flags; -# define RETAIN 1 /* Directly points to a reachable object; */ - /* retain for next GC. */ - unsigned short height_gc_no; - /* If height > 0, then the GC_gc_no value when it */ - /* was computed. If it was computed this cycle, then */ - /* it is current. If it was computed during the */ - /* last cycle, then it represents the old height, */ - /* which is only saved for live objects referenced by */ - /* dead ones. This may grow due to refs from newly */ - /* dead objects. */ - signed_word height; - /* Longest path through unreachable nodes to this node */ - /* that we found using depth first search. */ - -# define HEIGHT_UNKNOWN ((signed_word)(-2)) -# define HEIGHT_IN_PROGRESS ((signed_word)(-1)) - ptr_t edges[MAX_IN]; - struct back_edges_struct *cont; - /* Pointer to continuation structure; we use only the */ - /* edges field in the continuation. */ - /* also used as free list link. */ -} back_edges; - -/* Allocate a new back edge structure. Should be more sophisticated */ -/* if this were production code. */ -#define MAX_BACK_EDGE_STRUCTS 100000 -static back_edges *back_edge_space = 0; -STATIC int GC_n_back_edge_structs = 0; - /* Serves as pointer to never used */ - /* back_edges space. */ -static back_edges *avail_back_edges = 0; - /* Pointer to free list of deallocated */ - /* back_edges structures. */ - -static back_edges * new_back_edges(void) -{ - if (0 == back_edge_space) { - back_edge_space = (back_edges *)GET_MEM( - ROUNDUP_PAGESIZE_IF_MMAP(MAX_BACK_EDGE_STRUCTS - * sizeof(back_edges))); - if (NULL == back_edge_space) - ABORT("Insufficient memory for back edges"); - GC_add_to_our_memory((ptr_t)back_edge_space, - MAX_BACK_EDGE_STRUCTS*sizeof(back_edges)); - } - if (0 != avail_back_edges) { - back_edges * result = avail_back_edges; - avail_back_edges = result -> cont; - result -> cont = 0; - return result; - } - if (GC_n_back_edge_structs >= MAX_BACK_EDGE_STRUCTS - 1) { - ABORT("Needed too much space for back edges: adjust " - "MAX_BACK_EDGE_STRUCTS"); - } - return back_edge_space + (GC_n_back_edge_structs++); -} - -/* Deallocate p and its associated continuation structures. */ -static void deallocate_back_edges(back_edges *p) -{ - back_edges *last = p; - - while (0 != last -> cont) last = last -> cont; - last -> cont = avail_back_edges; - avail_back_edges = p; -} - -/* Table of objects that are currently on the depth-first search */ -/* stack. Only objects with in-degree one are in this table. */ -/* Other objects are identified using HEIGHT_IN_PROGRESS. */ -/* FIXME: This data structure NEEDS IMPROVEMENT. */ -#define INITIAL_IN_PROGRESS 10000 -static ptr_t * in_progress_space = 0; -static size_t in_progress_size = 0; -static size_t n_in_progress = 0; - -static void push_in_progress(ptr_t p) -{ - if (n_in_progress >= in_progress_size) { - if (in_progress_size == 0) { - in_progress_size = ROUNDUP_PAGESIZE_IF_MMAP(INITIAL_IN_PROGRESS - * sizeof(ptr_t)) - / sizeof(ptr_t); - in_progress_space = (ptr_t *)GET_MEM(in_progress_size * sizeof(ptr_t)); - GC_add_to_our_memory((ptr_t)in_progress_space, - in_progress_size * sizeof(ptr_t)); - } else { - ptr_t * new_in_progress_space; - in_progress_size *= 2; - new_in_progress_space = (ptr_t *) - GET_MEM(in_progress_size * sizeof(ptr_t)); - GC_add_to_our_memory((ptr_t)new_in_progress_space, - in_progress_size * sizeof(ptr_t)); - if (new_in_progress_space != NULL) - BCOPY(in_progress_space, new_in_progress_space, - n_in_progress * sizeof(ptr_t)); - in_progress_space = new_in_progress_space; - /* FIXME: This just drops the old space. */ - } - } - if (in_progress_space == 0) - ABORT("MAKE_BACK_GRAPH: Out of in-progress space: " - "Huge linear data structure?"); - in_progress_space[n_in_progress++] = p; -} - -static GC_bool is_in_progress(ptr_t p) -{ - size_t i; - for (i = 0; i < n_in_progress; ++i) { - if (in_progress_space[i] == p) return TRUE; - } - return FALSE; -} - -GC_INLINE void pop_in_progress(ptr_t p GC_ATTR_UNUSED) -{ - --n_in_progress; - GC_ASSERT(in_progress_space[n_in_progress] == p); -} - -#define GET_OH_BG_PTR(p) \ - (ptr_t)GC_REVEAL_POINTER(((oh *)(p)) -> oh_bg_ptr) -#define SET_OH_BG_PTR(p,q) (((oh *)(p)) -> oh_bg_ptr = GC_HIDE_POINTER(q)) - -/* Execute s once for each predecessor q of p in the points-to graph. */ -/* s should be a bracketed statement. We declare q. */ -#define FOR_EACH_PRED(q, p, s) \ - do { \ - ptr_t q = GET_OH_BG_PTR(p); \ - if (!((word)q & FLAG_MANY)) { \ - if (q && !((word)q & 1)) s \ - /* !((word)q & 1) checks for a misinterpreted freelist link */ \ - } else { \ - back_edges *orig_be_ = (back_edges *)((word)q & ~FLAG_MANY); \ - back_edges *be_ = orig_be_; \ - int local_; \ - word total_; \ - word n_edges_ = be_ -> n_edges; \ - for (total_ = 0, local_ = 0; total_ < n_edges_; ++local_, ++total_) { \ - if (local_ == MAX_IN) { \ - be_ = be_ -> cont; \ - local_ = 0; \ - } \ - q = be_ -> edges[local_]; s \ - } \ - } \ - } while (0) - -/* Ensure that p has a back_edges structure associated with it. */ -static void ensure_struct(ptr_t p) -{ - ptr_t old_back_ptr = GET_OH_BG_PTR(p); - - if (!((word)old_back_ptr & FLAG_MANY)) { - back_edges *be = new_back_edges(); - be -> flags = 0; - if (0 == old_back_ptr) { - be -> n_edges = 0; - } else { - be -> n_edges = 1; - be -> edges[0] = old_back_ptr; - } - be -> height = HEIGHT_UNKNOWN; - be -> height_gc_no = (unsigned short)(GC_gc_no - 1); - GC_ASSERT((word)be >= (word)back_edge_space); - SET_OH_BG_PTR(p, (word)be | FLAG_MANY); - } -} - -/* Add the (forward) edge from p to q to the backward graph. Both p */ -/* q are pointers to the object base, i.e. pointers to an oh. */ -static void add_edge(ptr_t p, ptr_t q) -{ - ptr_t old_back_ptr = GET_OH_BG_PTR(q); - back_edges * be, *be_cont; - word i; - static unsigned random_number = 13; -# define GOT_LUCKY_NUMBER (((++random_number) & 0x7f) == 0) - /* A not very random number we use to occasionally allocate a */ - /* back_edges structure even for a single backward edge. This */ - /* prevents us from repeatedly tracing back through very long */ - /* chains, since we will have some place to store height and */ - /* in_progress flags along the way. */ - - GC_ASSERT(p == GC_base(p) && q == GC_base(q)); - if (!GC_HAS_DEBUG_INFO(q) || !GC_HAS_DEBUG_INFO(p)) { - /* This is really a misinterpreted free list link, since we saw */ - /* a pointer to a free list. Don't overwrite it! */ - return; - } - if (0 == old_back_ptr) { - SET_OH_BG_PTR(q, p); - if (GOT_LUCKY_NUMBER) ensure_struct(q); - return; - } - /* Check whether it was already in the list of predecessors. */ - FOR_EACH_PRED(pred, q, { if (p == pred) return; }); - ensure_struct(q); - old_back_ptr = GET_OH_BG_PTR(q); - be = (back_edges *)((word)old_back_ptr & ~FLAG_MANY); - for (i = be -> n_edges, be_cont = be; i > MAX_IN; i -= MAX_IN) - be_cont = be_cont -> cont; - if (i == MAX_IN) { - be_cont -> cont = new_back_edges(); - be_cont = be_cont -> cont; - i = 0; - } - be_cont -> edges[i] = p; - be -> n_edges++; -# ifdef DEBUG_PRINT_BIG_N_EDGES - if (GC_print_stats == VERBOSE && be -> n_edges == 100) { - GC_err_printf("The following object has big in-degree:\n"); - GC_print_heap_obj(q); - } -# endif -} - -typedef void (*per_object_func)(ptr_t p, size_t n_bytes, word gc_descr); - -static void per_object_helper(struct hblk *h, word fn) -{ - hdr * hhdr = HDR(h); - size_t sz = hhdr -> hb_sz; - word descr = hhdr -> hb_descr; - per_object_func f = (per_object_func)fn; - int i = 0; - - do { - f((ptr_t)(h -> hb_body + i), sz, descr); - i += (int)sz; - } while ((word)i + sz <= BYTES_TO_WORDS(HBLKSIZE)); -} - -GC_INLINE void GC_apply_to_each_object(per_object_func f) -{ - GC_apply_to_all_blocks(per_object_helper, (word)f); -} - -static void reset_back_edge(ptr_t p, size_t n_bytes GC_ATTR_UNUSED, - word gc_descr GC_ATTR_UNUSED) -{ - /* Skip any free list links, or dropped blocks */ - if (GC_HAS_DEBUG_INFO(p)) { - ptr_t old_back_ptr = GET_OH_BG_PTR(p); - if ((word)old_back_ptr & FLAG_MANY) { - back_edges *be = (back_edges *)((word)old_back_ptr & ~FLAG_MANY); - if (!(be -> flags & RETAIN)) { - deallocate_back_edges(be); - SET_OH_BG_PTR(p, 0); - } else { - - GC_ASSERT(GC_is_marked(p)); - - /* Back edges may point to objects that will not be retained. */ - /* Delete them for now, but remember the height. */ - /* Some will be added back at next GC. */ - be -> n_edges = 0; - if (0 != be -> cont) { - deallocate_back_edges(be -> cont); - be -> cont = 0; - } - - GC_ASSERT(GC_is_marked(p)); - - /* We only retain things for one GC cycle at a time. */ - be -> flags &= ~RETAIN; - } - } else /* Simple back pointer */ { - /* Clear to avoid dangling pointer. */ - SET_OH_BG_PTR(p, 0); - } - } -} - -static void add_back_edges(ptr_t p, size_t n_bytes, word gc_descr) -{ - word *currentp = (word *)(p + sizeof(oh)); - - /* For now, fix up non-length descriptors conservatively. */ - if((gc_descr & GC_DS_TAGS) != GC_DS_LENGTH) { - gc_descr = n_bytes; - } - while ((word)currentp < (word)(p + gc_descr)) { - word current = *currentp++; - FIXUP_POINTER(current); - if (current >= (word)GC_least_plausible_heap_addr && - current <= (word)GC_greatest_plausible_heap_addr) { - ptr_t target = GC_base((void *)current); - if (0 != target) { - add_edge(p, target); - } - } - } -} - -/* Rebuild the representation of the backward reachability graph. */ -/* Does not examine mark bits. Can be called before GC. */ -GC_INNER void GC_build_back_graph(void) -{ - GC_apply_to_each_object(add_back_edges); -} - -/* Return an approximation to the length of the longest simple path */ -/* through unreachable objects to p. We refer to this as the height */ -/* of p. */ -static word backwards_height(ptr_t p) -{ - word result; - ptr_t back_ptr = GET_OH_BG_PTR(p); - back_edges *be; - - if (0 == back_ptr) return 1; - if (!((word)back_ptr & FLAG_MANY)) { - if (is_in_progress(p)) return 0; /* DFS back edge, i.e. we followed */ - /* an edge to an object already */ - /* on our stack: ignore */ - push_in_progress(p); - result = backwards_height(back_ptr)+1; - pop_in_progress(p); - return result; - } - be = (back_edges *)((word)back_ptr & ~FLAG_MANY); - if (be -> height >= 0 && be -> height_gc_no == (unsigned short)GC_gc_no) - return be -> height; - /* Ignore back edges in DFS */ - if (be -> height == HEIGHT_IN_PROGRESS) return 0; - result = (be -> height > 0? be -> height : 1); - be -> height = HEIGHT_IN_PROGRESS; - FOR_EACH_PRED(q, p, { - word this_height; - if (GC_is_marked(q) && !(FLAG_MANY & (word)GET_OH_BG_PTR(p))) { - GC_COND_LOG_PRINTF("Found bogus pointer from %p to %p\n", q, p); - /* Reachable object "points to" unreachable one. */ - /* Could be caused by our lax treatment of GC descriptors. */ - this_height = 1; - } else { - this_height = backwards_height(q); - } - if (this_height >= result) result = this_height + 1; - }); - be -> height = result; - be -> height_gc_no = (unsigned short)GC_gc_no; - return result; -} - -STATIC word GC_max_height = 0; -STATIC ptr_t GC_deepest_obj = NULL; - -/* Compute the maximum height of every unreachable predecessor p of a */ -/* reachable object. Arrange to save the heights of all such objects p */ -/* so that they can be used in calculating the height of objects in the */ -/* next GC. */ -/* Set GC_max_height to be the maximum height we encounter, and */ -/* GC_deepest_obj to be the corresponding object. */ -static void update_max_height(ptr_t p, size_t n_bytes GC_ATTR_UNUSED, - word gc_descr GC_ATTR_UNUSED) -{ - if (GC_is_marked(p) && GC_HAS_DEBUG_INFO(p)) { - word p_height = 0; - ptr_t p_deepest_obj = 0; - ptr_t back_ptr; - back_edges *be = 0; - - /* If we remembered a height last time, use it as a minimum. */ - /* It may have increased due to newly unreachable chains pointing */ - /* to p, but it can't have decreased. */ - back_ptr = GET_OH_BG_PTR(p); - if (0 != back_ptr && ((word)back_ptr & FLAG_MANY)) { - be = (back_edges *)((word)back_ptr & ~FLAG_MANY); - if (be -> height != HEIGHT_UNKNOWN) p_height = be -> height; - } - FOR_EACH_PRED(q, p, { - if (!GC_is_marked(q) && GC_HAS_DEBUG_INFO(q)) { - word q_height; - - q_height = backwards_height(q); - if (q_height > p_height) { - p_height = q_height; - p_deepest_obj = q; - } - } - }); - if (p_height > 0) { - /* Remember the height for next time. */ - if (be == 0) { - ensure_struct(p); - back_ptr = GET_OH_BG_PTR(p); - be = (back_edges *)((word)back_ptr & ~FLAG_MANY); - } - be -> flags |= RETAIN; - be -> height = p_height; - be -> height_gc_no = (unsigned short)GC_gc_no; - } - if (p_height > GC_max_height) { - GC_max_height = p_height; - GC_deepest_obj = p_deepest_obj; - } - } -} - -STATIC word GC_max_max_height = 0; - -GC_INNER void GC_traverse_back_graph(void) -{ - GC_max_height = 0; - GC_apply_to_each_object(update_max_height); - if (0 != GC_deepest_obj) - GC_set_mark_bit(GC_deepest_obj); /* Keep it until we can print it. */ -} - -void GC_print_back_graph_stats(void) -{ - GC_printf("Maximum backwards height of reachable objects at GC %lu is %lu\n", - (unsigned long) GC_gc_no, (unsigned long)GC_max_height); - if (GC_max_height > GC_max_max_height) { - GC_max_max_height = GC_max_height; - GC_err_printf( - "The following unreachable object is last in a longest chain " - "of unreachable objects:\n"); - GC_print_heap_obj(GC_deepest_obj); - } - GC_COND_LOG_PRINTF("Needed max total of %d back-edge structs\n", - GC_n_back_edge_structs); - GC_apply_to_each_object(reset_back_edge); - GC_deepest_obj = 0; -} - -#endif /* MAKE_BACK_GRAPH */ diff -Nru ecl-16.1.2/src/bdwgc/BCC_MAKEFILE ecl-16.1.3+ds/src/bdwgc/BCC_MAKEFILE --- ecl-16.1.2/src/bdwgc/BCC_MAKEFILE 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/BCC_MAKEFILE 1970-01-01 00:00:00.000000000 +0000 @@ -1,87 +0,0 @@ -# Makefile for Borland C++ 5.5 on NT -# If you have the Borland assembler, remove "-DUSE_GENERIC" -# -bc= c:\Borland\BCC55 -bcbin= $(bc)\bin -bclib= $(bc)\lib -bcinclude= $(bc)\include - -gcinclude1 = $(bc)\gc6.2\include -gcinclude2 = $(bc)\gc6.2\cord - -cc= $(bcbin)\bcc32 -rc= $(bcbin)\brc32 -lib= $(bcbin)\tlib -link= $(bcbin)\ilink32 -cflags= -O2 -R -v- -vi -H -H=gc.csm -I$(bcinclude);$(gcinclude1);$(gcinclude2) -L$(bclib) \ - -w-pro -w-aus -w-par -w-ccc -w-rch -a4 -defines= -DALL_INTERIOR_POINTERS -DUSE_GENERIC -DNO_GETENV -DJAVA_FINALIZATION -DGC_OPERATOR_NEW_ARRAY - -.c.obj: - $(cc) @&&| - $(cdebug) $(cflags) $(cvars) $(defines) -o$* -c $*.c -| - -.cpp.obj: - $(cc) @&&| - $(cdebug) $(cflags) $(cvars) $(defines) -o$* -c $*.cpp -| - -.rc.res: - $(rc) -i$(bcinclude) -r -fo$* $*.rc - -XXXOBJS= XXXalloc.obj XXXreclaim.obj XXXallchblk.obj XXXmisc.obj \ - XXXmach_dep.obj XXXos_dep.obj XXXmark_rts.obj XXXheaders.obj XXXmark.obj \ - XXXobj_map.obj XXXblacklst.obj XXXfinalize.obj XXXnew_hblk.obj \ - XXXdbg_mlc.obj XXXmalloc.obj XXXstubborn.obj XXXdyn_load.obj \ - XXXtypd_mlc.obj XXXptr_chck.obj XXXgc_cpp.obj XXXmallocx.obj \ - XXXfnlz_mlc.obj - -OBJS= $(XXXOBJS:XXX=) - -all: gctest.exe cord\de.exe test_cpp.exe - -$(OBJS) test.obj: include\private\gc_priv.h include\private\gc_hdrs.h include\gc.h include\private\gcconfig.h MAKEFILE - -gc.lib: $(OBJS) - del gc.lib - $(lib) $* @&&| - $(XXXOBJS:XXX=+) -| - -gctest.exe: tests\test.obj gc.lib - $(cc) @&&| - $(cflags) -W -e$* tests\test.obj gc.lib -| - -cord\tests\de.obj cord\tests\de_win.obj: include\cord.h \ - include\cord_pos.h cord\tests\de_win.h cord\tests\de_cmds.h - -cord\de.exe: cord\cordbscs.obj cord\cordxtra.obj cord\tests\de.obj \ - cord\tests\de_win.obj cord\tests\de_win.res gc.lib - $(cc) @&&| - $(cflags) -W -e$* cord\cordbscs.obj cord\cordxtra.obj \ - cord\tests\de.obj cord\tests\de_win.obj gc.lib -| - $(rc) cord\tests\de_win.res cord\de.exe - -gc_cpp.obj: include\gc_cpp.h include\gc.h - -gc_cpp.cpp: gc_cpp.cc - copy gc_cpp.cc gc_cpp.cpp - -test_cpp.cpp: tests\test_cpp.cc - copy tests\test_cpp.cc test_cpp.cpp - -test_cpp.exe: test_cpp.obj include\gc_cpp.h include\gc.h gc.lib - $(cc) @&&| - $(cflags) -W -e$* test_cpp.obj gc.lib -| - -scratch: - -del *.obj *.res *.exe *.csm cord\*.obj cord\*.res cord\*.exe cord\*.csm - -clean: - del gc.lib - del *.obj - del tests\test.obj diff -Nru ecl-16.1.2/src/bdwgc/bdw-gc.pc.in ecl-16.1.3+ds/src/bdwgc/bdw-gc.pc.in --- ecl-16.1.2/src/bdwgc/bdw-gc.pc.in 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/bdw-gc.pc.in 1970-01-01 00:00:00.000000000 +0000 @@ -1,10 +0,0 @@ -prefix=@prefix@ -exec_prefix=@exec_prefix@ -libdir=@libdir@ -includedir=@includedir@ - -Name: Boehm-Demers-Weiser Conservative Garbage Collector -Description: A garbage collector for C and C++ -Version: @PACKAGE_VERSION@ -Libs: -L${libdir} -lgc -Cflags: -I${includedir} diff -Nru ecl-16.1.2/src/bdwgc/blacklst.c ecl-16.1.3+ds/src/bdwgc/blacklst.c --- ecl-16.1.2/src/bdwgc/blacklst.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/blacklst.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,289 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#include "private/gc_priv.h" - -/* - * We maintain several hash tables of hblks that have had false hits. - * Each contains one bit per hash bucket; If any page in the bucket - * has had a false hit, we assume that all of them have. - * See the definition of page_hash_table in gc_private.h. - * False hits from the stack(s) are much more dangerous than false hits - * from elsewhere, since the former can pin a large object that spans the - * block, even though it does not start on the dangerous block. - */ - -/* - * Externally callable routines are: - - * GC_add_to_black_list_normal - * GC_add_to_black_list_stack - * GC_promote_black_lists - * GC_is_black_listed - * - * All require that the allocator lock is held. - */ - -/* Pointers to individual tables. We replace one table by another by */ -/* switching these pointers. */ -STATIC word * GC_old_normal_bl = NULL; - /* Nonstack false references seen at last full */ - /* collection. */ -STATIC word * GC_incomplete_normal_bl = NULL; - /* Nonstack false references seen since last */ - /* full collection. */ -STATIC word * GC_old_stack_bl = NULL; -STATIC word * GC_incomplete_stack_bl = NULL; - -STATIC word GC_total_stack_black_listed = 0; - /* Number of bytes on stack blacklist. */ - -GC_INNER word GC_black_list_spacing = MINHINCR * HBLKSIZE; - /* Initial rough guess. */ - -STATIC void GC_clear_bl(word *); - -GC_INNER void GC_default_print_heap_obj_proc(ptr_t p) -{ - ptr_t base = GC_base(p); - int kind = HDR(base)->hb_obj_kind; - - GC_err_printf("object at %p of appr. %lu bytes (%s)\n", - base, (unsigned long)GC_size(base), - kind == PTRFREE ? "atomic" : - IS_UNCOLLECTABLE(kind) ? "uncollectable" : "composite"); -} - -GC_INNER void (*GC_print_heap_obj)(ptr_t p) = GC_default_print_heap_obj_proc; - -#ifdef PRINT_BLACK_LIST - STATIC void GC_print_blacklisted_ptr(word p, ptr_t source, - const char *kind_str) - { - ptr_t base = GC_base(source); - - if (0 == base) { - GC_err_printf("Black listing (%s) %p referenced from %p in %s\n", - kind_str, (ptr_t)p, source, - NULL != source ? "root set" : "register"); - } else { - /* FIXME: We can't call the debug version of GC_print_heap_obj */ - /* (with PRINT_CALL_CHAIN) here because the lock is held and */ - /* the world is stopped. */ - GC_err_printf("Black listing (%s) %p referenced from %p in" - " object at %p of appr. %lu bytes\n", - kind_str, (ptr_t)p, source, - base, (unsigned long)GC_size(base)); - } - } -#endif /* PRINT_BLACK_LIST */ - -GC_INNER void GC_bl_init_no_interiors(void) -{ - if (GC_incomplete_normal_bl == 0) { - GC_old_normal_bl = (word *)GC_scratch_alloc(sizeof(page_hash_table)); - GC_incomplete_normal_bl = (word *)GC_scratch_alloc( - sizeof(page_hash_table)); - if (GC_old_normal_bl == 0 || GC_incomplete_normal_bl == 0) { - GC_err_printf("Insufficient memory for black list\n"); - EXIT(); - } - GC_clear_bl(GC_old_normal_bl); - GC_clear_bl(GC_incomplete_normal_bl); - } -} - -GC_INNER void GC_bl_init(void) -{ - if (!GC_all_interior_pointers) { - GC_bl_init_no_interiors(); - } - GC_old_stack_bl = (word *)GC_scratch_alloc(sizeof(page_hash_table)); - GC_incomplete_stack_bl = (word *)GC_scratch_alloc(sizeof(page_hash_table)); - if (GC_old_stack_bl == 0 || GC_incomplete_stack_bl == 0) { - GC_err_printf("Insufficient memory for black list\n"); - EXIT(); - } - GC_clear_bl(GC_old_stack_bl); - GC_clear_bl(GC_incomplete_stack_bl); -} - -STATIC void GC_clear_bl(word *doomed) -{ - BZERO(doomed, sizeof(page_hash_table)); -} - -STATIC void GC_copy_bl(word *old, word *new) -{ - BCOPY(old, new, sizeof(page_hash_table)); -} - -static word total_stack_black_listed(void); - -/* Signal the completion of a collection. Turn the incomplete black */ -/* lists into new black lists, etc. */ -GC_INNER void GC_promote_black_lists(void) -{ - word * very_old_normal_bl = GC_old_normal_bl; - word * very_old_stack_bl = GC_old_stack_bl; - - GC_old_normal_bl = GC_incomplete_normal_bl; - GC_old_stack_bl = GC_incomplete_stack_bl; - if (!GC_all_interior_pointers) { - GC_clear_bl(very_old_normal_bl); - } - GC_clear_bl(very_old_stack_bl); - GC_incomplete_normal_bl = very_old_normal_bl; - GC_incomplete_stack_bl = very_old_stack_bl; - GC_total_stack_black_listed = total_stack_black_listed(); - GC_VERBOSE_LOG_PRINTF( - "%lu bytes in heap blacklisted for interior pointers\n", - (unsigned long)GC_total_stack_black_listed); - if (GC_total_stack_black_listed != 0) { - GC_black_list_spacing = - HBLKSIZE*(GC_heapsize/GC_total_stack_black_listed); - } - if (GC_black_list_spacing < 3 * HBLKSIZE) { - GC_black_list_spacing = 3 * HBLKSIZE; - } - if (GC_black_list_spacing > MAXHINCR * HBLKSIZE) { - GC_black_list_spacing = MAXHINCR * HBLKSIZE; - /* Makes it easier to allocate really huge blocks, which otherwise */ - /* may have problems with nonuniform blacklist distributions. */ - /* This way we should always succeed immediately after growing the */ - /* heap. */ - } -} - -GC_INNER void GC_unpromote_black_lists(void) -{ - if (!GC_all_interior_pointers) { - GC_copy_bl(GC_old_normal_bl, GC_incomplete_normal_bl); - } - GC_copy_bl(GC_old_stack_bl, GC_incomplete_stack_bl); -} - -/* P is not a valid pointer reference, but it falls inside */ -/* the plausible heap bounds. */ -/* Add it to the normal incomplete black list if appropriate. */ -#ifdef PRINT_BLACK_LIST - GC_INNER void GC_add_to_black_list_normal(word p, ptr_t source) -#else - GC_INNER void GC_add_to_black_list_normal(word p) -#endif -{ - if (GC_modws_valid_offsets[p & (sizeof(word)-1)]) { - word index = PHT_HASH((word)p); - - if (HDR(p) == 0 || get_pht_entry_from_index(GC_old_normal_bl, index)) { -# ifdef PRINT_BLACK_LIST - if (!get_pht_entry_from_index(GC_incomplete_normal_bl, index)) { - GC_print_blacklisted_ptr(p, source, "normal"); - } -# endif - set_pht_entry_from_index(GC_incomplete_normal_bl, index); - } /* else this is probably just an interior pointer to an allocated */ - /* object, and isn't worth black listing. */ - } -} - -/* And the same for false pointers from the stack. */ -#ifdef PRINT_BLACK_LIST - GC_INNER void GC_add_to_black_list_stack(word p, ptr_t source) -#else - GC_INNER void GC_add_to_black_list_stack(word p) -#endif -{ - word index = PHT_HASH((word)p); - - if (HDR(p) == 0 || get_pht_entry_from_index(GC_old_stack_bl, index)) { -# ifdef PRINT_BLACK_LIST - if (!get_pht_entry_from_index(GC_incomplete_stack_bl, index)) { - GC_print_blacklisted_ptr(p, source, "stack"); - } -# endif - set_pht_entry_from_index(GC_incomplete_stack_bl, index); - } -} - -/* - * Is the block starting at h of size len bytes black listed? If so, - * return the address of the next plausible r such that (r, len) might not - * be black listed. (R may not actually be in the heap. We guarantee only - * that every smaller value of r after h is also black listed.) - * If (h,len) is not black listed, return 0. - * Knows about the structure of the black list hash tables. - */ -struct hblk * GC_is_black_listed(struct hblk *h, word len) -{ - word index = PHT_HASH((word)h); - word i; - word nblocks; - - if (!GC_all_interior_pointers - && (get_pht_entry_from_index(GC_old_normal_bl, index) - || get_pht_entry_from_index(GC_incomplete_normal_bl, index))) { - return (h+1); - } - - nblocks = divHBLKSZ(len); - for (i = 0;;) { - if (GC_old_stack_bl[divWORDSZ(index)] == 0 - && GC_incomplete_stack_bl[divWORDSZ(index)] == 0) { - /* An easy case */ - i += WORDSZ - modWORDSZ(index); - } else { - if (get_pht_entry_from_index(GC_old_stack_bl, index) - || get_pht_entry_from_index(GC_incomplete_stack_bl, index)) { - return(h+i+1); - } - i++; - } - if (i >= nblocks) break; - index = PHT_HASH((word)(h+i)); - } - return(0); -} - -/* Return the number of blacklisted blocks in a given range. */ -/* Used only for statistical purposes. */ -/* Looks only at the GC_incomplete_stack_bl. */ -STATIC word GC_number_stack_black_listed(struct hblk *start, - struct hblk *endp1) -{ - register struct hblk * h; - word result = 0; - - for (h = start; (word)h < (word)endp1; h++) { - word index = PHT_HASH((word)h); - - if (get_pht_entry_from_index(GC_old_stack_bl, index)) result++; - } - return(result); -} - -/* Return the total number of (stack) black-listed bytes. */ -static word total_stack_black_listed(void) -{ - register unsigned i; - word total = 0; - - for (i = 0; i < GC_n_heap_sects; i++) { - struct hblk * start = (struct hblk *) GC_heap_sects[i].hs_start; - struct hblk * endp1 = start + GC_heap_sects[i].hs_bytes/HBLKSIZE; - - total += GC_number_stack_black_listed(start, endp1); - } - return(total * HBLKSIZE); -} diff -Nru ecl-16.1.2/src/bdwgc/ChangeLog ecl-16.1.3+ds/src/bdwgc/ChangeLog --- ecl-16.1.2/src/bdwgc/ChangeLog 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/ChangeLog 1970-01-01 00:00:00.000000000 +0000 @@ -1,8689 +0,0 @@ - -== [7.5.0] (development) == - -* Add API function to set/modify GC log file descriptor (Unix). -* Add alloc_size attribute to GC_generic_malloc. -* Added instructions to README.md for building from git. -* Allow to force GC_dump_regularly set on at compilation. -* Change 'cord' no-argument functions declaration style to ANSI C. -* Define ROUNDUP_PAGESIZE, ROUNDUP_GRANULE_SIZE macros (code refactoring). -* Define public GC_GENERIC_OR_SPECIAL_MALLOC and GC_get_kind_and_size. -* Eliminate redundant *flh check for null in GC_allocobj. -* GC_scratch_alloc code refactoring (and WARN message improvement). -* Group all compact fields of GC_arrays to fit in single page. -* Improve documentation for disappearing links in gc.h. -* Make heap growth more conservative after GC_gcollect_and_unmap call. -* New macro (GC_ALWAYS_MULTITHREADED) to set multi-threaded mode implicitly. -* Refine description in README how to build from source repository. -* Remove 'opp' local variable in GC_malloc_X. -* Remove hb_large_block field (use 1 extra bit of hb_flags instead). -* Remove obsolete BACKING_STORE_ALIGNMENT/DISPLACEMENT macros for Linux/IA64. -* Remove redundant casts in GC_generic_or_special_malloc and similar. -* Use magic header on objects to improve disclaim_test. -Also, includes 7.4.2 changes. - - -== [7.4.2] 2014-06-03 == - -* Add config option to use STGRTMIN-based signals for thread suspend/resume. -* Allow parallel mark to be enabled on powerpc-linux systems. -* Check for Fujitsu compiler in builtin_unwind logic (enable FX10/K-Computer). -* Fix 'Array subscript is above array bounds' GCC warning in GC_new_kind/proc. -* Fix 'attribute declaration must precede definition' warning (clang-3.1). -* Fix (enable) Cygwin-64 build. -* Fix GC_finalized_malloc failure on disclaim_test. -* Fix GC_sig_suspend initialization when non-constant SIGRTMIN used. -* Fix MS VC redefinition warning for functions declared with GC_ATTR_MALLOC. -* Fix TEXT() usage for concatenated strings in GC_CreateLogFile (Win32). -* Fix data roots registration for Android/x86 and NDK ARM 'gold' linker. -* Fix find stackbottom on BlueGene P/Q systems. -* Fix machdep .lo files path in configure (SPARC, IA-64). -* Fix ok_init assignment (missing cast) in GC_new_kind_inner. -* Fix typos in names in AUTHORS and ChangeLog files. -* Remove barrett_diagram file duplicated by tree.html. -* Remove non-existing DISCARD_WORDS from GC data structure ASCII diagram. -* Restore contribution information for ancient releases in ChangeLog. -Also, includes 7.2f changes. - - -== [7.4.0] 2013-11-17 == - -* Add 'bytes reclaimed' counters to public GC_prof_stats_s. -* Add AArch64 (64-bit ARM) target support. -* Add GC_LONG_REFS_NOT_NEEDED ifdefs to exclude long link functionality. -* Add GC_get_prof_stats[_unsafe]() to GC public API. -* Add GC_push_all/conditional() to GC public API. -* Add assertion on number_of_objs to GC_extend_size_map. -* Add assertion to GC_enable() ensuring no counter underflow. -* Add assertion to LOCK definition that lock is not already held. -* Add assertion to LONG_MULT and remove useless assert in PUSH_CONTENTS_HDR. -* Add double-lock assertion to GC_acquire_mark_lock. -* Add manual POSIX fork handling support (Android). -* Add note about 'pkg-config' solving problem with autoconf 2.68 or older. -* Add public GC_set/get_abort_func to replace default GC_on_abort. -* Add public GC_start_mark_threads() to allow parallel marker in fork child. -* Add public setter and getter for GC_push_other_roots. -* Add support of Android logger. -* Add tests for GC_register/move/unregister_long_link. -* Add thread suspend/resume signals public setters (POSIX threads). -* Added long weakref support. -* Adjust GC_dont_expand/gc/precollect and GC_print_stats type to match gc.h. -* Adjust README.md title and references to doc .html files in it. -* Adjust build scripts to enable additional test library in staticrootstest. -* Adjust logged messages in start_mark_threads and GC_thr_init. -* Adjust printf format specifiers in GC_print_trace. -* Allow not to rely on __data_start value (Linux). -* Allow pthread_kill error code logging in GC_suspend/resume (debugging). -* Allow to compile GC_inner_start_routine aside from extra/gc.c. -* Allow to omit libc atexit() call. -* Avoid LOCK/UNLOCK hard-coding in gc_locks.h for PS3 target. -* Better document GC_warn_proc in gc.h. -* Call GC_on_abort (with NULL argument) on exit(1). -* Call GC_stats/verbose_log_printf instead of GC_log_printf if print_stats. -* Change policy regarding version numbers ("micro" part instead of "alpha"). -* Changed C99-style designated init of GC_dl_hashtbl struct to use C89-style. -* Check GC_base result in GC_print_all_smashed_proc. -* Check that SIG_SUSPEND and SIG_THR_RESTART are different (Pthreads). -* Check traceable_allocator.allocate result before dereference in test_cpp. -* Code refactoring of GC_x_printf (move shared code to macro). -* Convert readme to markdown. -* Default to use libc_stack_end in single-threaded GC on glibc targets. -* Define GC_VSNPRINTF internal macro in misc.c (code refactoring). -* Define functions in darwin_semaphore.h as inline instead of static. -* Define old_bus_handler static variable only if used (Unix). -* Detect dladdr() presence by configure. -* Disable find-leak GC_gcollect on GC abnormal EXIT. -* Do not define _setjmp/_longjmp macros in mach_dep.c. -* Do not duplicate android_log_write output to GC log file (Android). -* Do not include sigcontext.h if NO_SIGCONTEXT_H (Linux). -* Do not set GC_lock_holder by call_with_alloc_lock if assertions disabled. -* Do not use pthread_getattr_np if NO_PTHREAD_GETATTR_NP specified. -* Elaborate comment on dependencies in autogen.sh. -* Eliminate 'cast from int to pointer' warning in GC_exclude_static_roots. -* Eliminate 'missing exception specification' warning in gc_cpp.cc (Clang). -* Eliminate 'uninitialized variable use' warning in test_printf (cord). -* Eliminate 'unused result' compiler warning in main() of test_cpp. -* Eliminate 'unused value' compiler warning in GC_stop_world (Pthreads). -* Eliminate 'unused variable' compiler warning in start_mark_threads (HP/UX). -* Eliminate Clang warning for GC_pthread_exit attribute. -* Eliminate GCC warning about uninitialized 'hhdr' in GC_allochblk_nth. -* Eliminate GCC warning in GC_get_main_stack_base (OpenBSD). -* Eliminate GCC warnings in setjmp_t.c, test_cpp and cord 'de' app. -* Eliminate GC_first_nonempty atomic value reload in GC_mark_local assertion. -* Eliminate SIGBUS-related dead code in GC_write_fault_handler (Linux). -* Eliminate warning and simplify expression in GC_init_explicit_typing. -* Enable 'force GC at every GC_malloc' debug-related functionality. -* Enable on-demand debug logging in GC_FindTopOfStack (Darwin). -* Enable prefetch operations by default (GCC 3.0+). -* Enable staticrootstest for the case of GC shared library build. -* Enable thread-local allocation support for Clang on Cygwin. -* Explicitly specify that Darwin, Linux and Solaris platforms have dladdr. -* Fix ABORT definition for mingw32ce (WinCE). -* Fix AM_CONFIG_HEADER in configure for autoconf-2.69-1. -* Fix GC_CreateThread and GC_beginthreadex definition for Cygwin. -* Fix GC_INIT_CONF_ROOTS in gc.h for Android. -* Fix GC_INLINE definition to comply with ISO C90 standard (GCC). -* Fix GC_remove_all_threads_but_me for Android (fork support). -* Fix debug_register_displacement calls from GC_debug_generic_malloc_inner. -* Fix dyn_load.c compilation for Android 4.3. -* Fix make disclaim_test to link with new GNU ld linking rules. -* Improve GC error printing atomicity in GC_debug_X and GC_print_obj. -* Improve GC output atomicity in GC_print_obj, GC_print_all_errors. -* Improve debug-only messages of add/remove_roots and init_linux_data_start. -* Improve fork test logging in gctest. -* Improve logged messages about heap size and usage. -* Improve logging for Android differentiating messages by log level. -* Improve staticrootstest (add global data to library, add lib w/o GC_INIT). -* Improve staticrootstest checks (tests). -* Include "config.h" instead of "private/config.h" on HAVE_CONFIG_H. -* Include proper header file in 'tools' for configuration macros. -* Include pthread_np.h from pthread_stop_world.c on OpenBSD. -* Log error messages to stderr instead of stdout in tests. -* Make GC_generic_malloc_ignore_off_page() public. -* Make GC_mark_lock_holder variable static. -* Make GC_print_trace always thread-safe and remove 'lock' argument. -* Mark GC_started_thread_while_stopped() as GC_INNER. -* Minimize code duplication in GC_mark_and_push. -* Move 'include setjmp.h' from mach_dep.c to gc_priv.h. -* Move GC_OPENBSD_UTHREADS definition to private/gcconfig.h (OpenBSD). -* Move GC_get_suspend/thr_restart_signal to misc.c for NaCl and OpenBSD. -* Move LOCK/UNLOCK from GC_unregister_disappearing_link_inner outer. -* Port BDWGC to Android/x86. -* Postpone the suspend signal in GC_dirty_init only if used to stop world. -* Prepend '#' symbol to GC number in logged messages. -* Prevent POSIX fork if mprotect_thread is started (Darwin). -* Prevent abort on GC_err/warn_printf write failure. -* Prevent misleading AC_MSG_ERROR/AS_IF errors reported in configure.ac. -* Put gc_cpp symbols into 'boehmgc' namespace if GC_NAMESPACE defined. -* Recognize GC_DONT_GC macro in gc.h (causes GC_INIT to turn off GC). -* Recognize GC_SIG_SUSPEND and GC_SIG_THR_RESTART tuning macros in gc.h. -* Redirect WRITE to __android_log_write if GC_ANDROID_LOG (Android). -* Refine comment of GC_is_heap_ptr and GC_thread_is_registered in gc.h. -* Register dynamic libraries via dl_iterate_phdr on Android and OpenBSD. -* Remove DebugBreak on WriteFile failure (Win32). -* Remove GC_BUILD definition from build scripts. -* Remove abort on open log failure from GC_write (Win32). -* Remove configure.ac outdated revision number. -* Remove nested EXPECT in GC_core_finalized_malloc. -* Remove nested always-false ifdef for HPUX and FREEBSD. -* Remove redundant GC_err_printf before abort. -* Remove unused UTHREAD_SP_OFFSET macro (OpenBSD). -* Rename subthread_create to subthreadcreate_test (Makefile). -* Replace GC_COND_LOG_PRINTF calls with WARN for allocation failure messages. -* Replace GC_log/err_printf() followed by ABORT with ABORT_ARGn(). -* Replace GC_stats_log_printf with GC_DBG/INFOLOG_PRINTF. -* Replace SIG_SUSPEND/THR_RESTART macros to variables in pthread_stop_world. -* Replace Win32 GC_delete_gc_thread with GC_delete_gc_thread_no_free. -* Replace conditional GC_log_printf calls with GC_COND/VERBOSE_LOG_PRINTF. -* Replace sprintf with defensive snprintf. -* Replace var-args GC_noop with GC_noop6 (to eliminate Clang warning). -* Simplify LOCK/UNLOCK macro definition for static code analysis tools. -* Specify GC_malloc result is unused in some tests. -* Specify GC_pthread_join result is unused in threadkey_test. -* Specify LT_INIT in configure.ac. -* Start of port to QNX. -* Support rthreads introduced in OpenBSD 5.2+. -* Suppress 'GC_dont_gc deprecated' warning in gc.h if GC_DONT_GC. -* Tag GC malloc routines with alloc_size attribute for Clang 3.2+. -* Test NO_WRAP_MARK_SOME macro to suppress WRAP_MARK_SOME-specific code. -* Turn off GC_LOOP_ON_ABORT functionality if GC compiled with NO_DEBUGGING. -* Turn on world-stop delay logging at debug level by default for Android. -* Use EXPECT in GC_COND/VERBOSE_LOG_PRINTF. -* Use GC_log_printf for logging instead of GC_[err_]printf. -* Use compiler TLS for Android NDK gcc/arm. -* Use memcpy (BCOPY) instead of strcpy (to suppress GCC warning). -* Use pthread API to operate thread-local data on Linux if no compiler TLS. -* Workaround 'ELF_DATA/EM_ALPHA redefined' warning in Android linker.h. -* Workaround 'unresolved __tls_get_addr' error for Android NDK Clang. -Also, includes 7.2e, 7.2d, 7.2c, 7.2b changes. - - -== [7.3alpha2] 2012-05-11 == - -* Add 'const' qualifier to pointer argument of some API functions. -* Add GC_UNDERSCORE_STDCALL, UNICODE macro templates to configure (Win32). -* Add GC_get_thr_restart_signal, GC_thread_is_registered to GC API. -* Add GC_is_heap_ptr, GC_move_disappearing_link to GC API. -* Add SHORT_DBG_HDRS macro template to configure. -* Add Symbian port to mainline (porting done by Djamel Magri). -* Add TODO file. -* Add assertion ensuring proper alignment of 'pushed' GC symbols. -* Add assertion in GC_getspecific on qtid. -* Add assertion to GC_incremental_protection_needs, refine documentation. -* Add assertion to check GC_large_free_bytes by GC_finish_collection. -* Add configure option to compile all library .c files into single gc.o. -* Add cordtest to make check. -* Add disclaim callbacks for efficient finalization (ENABLE_DISCLAIM). -* Add finalization.html to 'doc' folder. -* Add javaxfc.h to the installation set of GC header files (configure). -* Add on-heap-resize event notification to API. -* Adjust GC_log_printf format specifiers (regarding signed/unsigned long). -* Adjust GC_requested_heapsize on GC_init if GC_INITIAL_HEAP_SIZE given. -* Allow GC_exclude_static_roots() region start to be unaligned. -* Allow Win32 DllMain chaining on the client side. -* Allow to exclude finalization support by GC_NO_FINALIZATION macro. -* Allow to get memory via Win32 VirtualAlloc (USE_WINALLOC) on Cygwin. -* Avoid unnecessary GC_find_limit invocation if GC_no_dls. -* Avoid use of deprecated GC_dont_gc and GC_stackbottom in gctest. -* Cast pointers to word (instead of unsigned long) in specific.h. -* Changed the order in autogen.sh so ltmain exists in time for automake. -* Declare privately and use handy GC_base_C() for constant object pointers. -* Define GC_DLL if DLL_EXPORT at GC build (for Cygwin/MinGW). -* Define GC_READ_ENV_FILE in configure for WinCE unless gc-debug is off. -* Do not compile backgraph.c unless configure '--enable-gc-debug'. -* Do not compile pthread_stop_world.c for Cygwin/Darwin (configure). -* Do not install ancient new_gc_alloc.h broken for modern STL (configure). -* Enable GC_MIN_MARKERS to set minimal number of pthread-based markers. -* Enable PARALLEL_MARK and THREAD_LOCAL_ALLOC for FreeBSD in configure. -* Enable parallel mark by default in configure (Darwin/Linux/Solaris/Win32). -* Export GC_is_marked, GC_clear/set_mark_bit (for mark-bit manipulation). -* Extend thread-related debug messages. -* Fix 'configure --enable-cplusplus' for Cygwin/MinGW. -* Fix DATASTART (and other minor improvements) for NaCl target. -* Fix GC_setspecific to prevent garbage collection inside. -* Fix compiler warning in cordtest. -* Fix minor warnings reported by GCC with '-pedantic' option. -* Fix static data roots registration on Android (if GC is shared). -* Implement GC_get_stack_base for Darwin for single-threaded mode. -* Improve GC_allochblk algorithm of block splitting when unmapping enabled. -* Improve GC_collect_or_expand algorithm for many finalizers registered case. -* In tests, print a message in case a test is a no-op. -* Instruct configure to hide internal libgc.so symbols if supported by GCC. -* Log amount of unmapped memory (if enabled) on marking-for-collection. -* Make __data_start a weak symbol to allow loading modules on mips. -* Move "cord" library tests to "cord/tests" folder. -* Move asm machine-dependent files to "src" folder. -* Move build tools sources to "tools" folder. -* Move cord_pos.h to public headers folder. -* Open log file in APPEND mode on Win32 (similar that on Unix/Cygwin). -* Optimize some functions by moving pthread_self calls out of LOCK section. -* Place only major per-release changes description to ChangeLog (this file). -* Prevent compiler warnings in GC_FindTopOfStack and GC_ports (Darwin). -* Recognize GC_LOG_TO_FILE_ALWAYS macro to log to 'gc.log' by default. -* Remove all auto-generated files from the repo. -* Remove binary icon file for de_win. -* Remove cordtest from "cord" library. -* Remove duplicate MacOS_Test_config.h file. -* Remove gc_amiga_redirects.h (included internally) from public headers. -* Remove obsolete Makefile.DLL (superseded by Cygwin/MinGW configure). -* Remove obsolete unused asm files for ALPHA, HPUX, SGI, RS6000, ULTRIX. -* Remove unsupported MMAP_STACKS (specific to Solaris threads). -* Remove unused ancient SILENT, __STDC__, NO_SIGNALS macros. -* Replace ARGSUSED comment-based annotation with GCC 'unused' attribute. -* Replace GC_ms_entry declaration with opaque definition for public API. -* Replace long GC_markers global variable with int GC_markers_m1. -* Replace pointer relational comparisons with non-pointer ones. -* Replace printf PRIxMAX specifier with '%p' for thread id debug output. -* Require autoconf 2.61 instead of v2.64. -* Simplify autogen.sh (use autoreconf). -* Split GC_abort with GC_on_abort and abort() invoked from ABORT. -* Support GC_ATTR_MALLOC for MS VisualStudio. -* Tag auxiliary malloc-like API functions with 'malloc' attribute. -* Tag deprecated variables in GC API. -* Tag must-be-non-null arguments of GC API functions. -* Turn on "extra" GCC warnings. -* Turn on unused-parameter checking for GCC. -* Update AUTHORS file. -* Use EXPECT for checking various 'initialized' boolean variables. -* Use USE_COMPILER_TLS on Cygwin. -* Use pthread_key for thread-local storage on FreeBSD. -* Use union of AO_t and word to favor strict-aliasing compiler optimization. -Also, includes 7.2 changes. - - -== [7.2f] 2014-06-03 == - -* Fix 'Bad signal in suspend_handler' abort on FreeBSD-9.2. -* Fix 'source file in a subdirectory' Automake warnings. -* Fix ABORT message in GC_restart_handler. -* Fix ADD_DEFINITION in CMakeLists.txt for kFreeBSD. -* Fix CMakeLists.txt: do not override CMAKE_OSX_ARCHITECTURES. -* Fix GC_alloc_large by bumping GC_collect_at_heapsize in GC_add_to_heap. -* Fix GC_scratch_last_end_ptr update on GC_scratch_alloc failure. -* Fix GET_MEM argument rounding in GC_scratch_alloc and similar. -* Fix PARALLEL_MARK for Windows 7+. -* Fix build (broken by fenv.h inclusion) on Linux/x86_64 under uClibc. -* Fix crash when using GC_malloc_many() as first allocation call. -* Fix mark stack excessive growth during parallel mark. -* Fix or remove broken URLs in documentation. -* Fix out-of-memory case in new_back_edges, push_in_progress (backgraph). -* Fix typo in GC_collect_or_expand comment. -* Fix typos in GC overview file, gc_config_macros.h, gc_cpp.h, README.changes. -* Regenerate configure files by automake 1.14.1, libtool 2.4.2.418. -* Update emails/links due to project site and ML transition. - - -== [7.2e] 2013-11-10 == - -* Add weak attribute to avoid __data_start undefined messages (s390x). -* Add weak stubs for pthread_cancel API. -* Adjust 'pthread_[un]register_cancel undefined ref' workaround (Pthreads). -* Append _test suffix to 'initsecondarythread' binary file names. -* Enable PARALLEL_MARK and THREAD_LOCAL_ALLOC for FreeBSD in configure. -* Fix 'stack section' pointer passed to push_all_stack_sections (Pthreads). -* Fix GC_CreateThread 'dwStackSize' argument type for Win64. -* Fix GC_PTHREAD_PTRVAL definition for GC_PTHREADS_PARAMARK (Win32). -* Fix GC_clear_stack by declaring 'dummy' local array as volatile. -* Fix GC_get_stack_base assembly code (Cygwin/Clang). -* Fix GC_malloc_explicitly_typed_ignore_off_page for large allocations. -* Fix GC_marker_Id elements initialization (WinCE). -* Fix GC_print_trace missing unlock. -* Fix GC_unix_mmap_get_mem for open of /dev/zero failure. -* Fix GC_win32_free_heap compilation error for Cygwin. -* Fix GC_win32_free_heap to prevent memory leak if USE_GLOBAL_ALLOC. -* Fix Win32 GC_write preventing potential infinite recursion at abort. -* Fix assertion violation in GC_mark_from prefetch loop. -* Fix collection of objects referenced only from GC_mark_stack_X variables. -* Fix dwSize argument of VirtualFree call in detect_GetWriteWatch (Win32). -* Fix heap sections overflow for Win32/Cygwin with enabled parallel marker. -* Fix min_bytes_allocd preventing potential infinite loop in GC_allocobj. -* Fix missing tabs in SMakefile.amiga file. -* Fix null-pointer dereference in CORD_substr_closure. -* Fix old_segv/bus_act variables initialization for FreeBSD. -* Fix potential double fclose in test_extras (cordtest). -* Fix pthread_attr_t resource leak in pthread_create. -* Fix race in GC_print_all_errors regarding GC_leaked. -* Fix sizeof in GC_push_thread_structures. -* Fix stackbottom/stack_end assignment in GC_call_with_gc_active. -* Fix tests makefile to link with new GNU ld linking rules. -* Fix typos in comments and documentation. -* Fix unportable '==' test operators in configure. -* Fix vsprintf_args cleanup in CORD_vsprintf. -* Merge FreeBSD New ports collection for boehm-gc v7.2d. -* Replace GC_DBG_RA with GC_DBG_EXTRAS macro. -* Replace deprecated [CXX]INCLUDES to AM_C[PP]FLAGS in configure.ac file. -* Use __builtin_extract_return_addr in GC_RETURN_ADDR_PARENT (gcc/x86). - - -== [7.2d] 2012-08-09 == - -* Fix GC_call_with_stack_base to prevent its tail-call optimization. -* Fix all address-of-dummy operations by using GC_approx_sp() instead. -* Fix stop_info.stack_ptr assignment in GC_suspend_all for OpenBSD. -* Fix test_cpp (ensure the collector recognizes pointers to interiors). -* Fix thread-related tests for pthreads-w32. -* test_cpp: Fix WinMain to prevent SEGV if zero arguments passed (MinGW). - - -== [7.2c] 2012-06-11 == - -* Fix CORD_cat_char_star to prevent SEGV in case of out-of-memory. -* Fix GC_FirstDLOpenedLinkMap() for NetBSD 6 release. -* Fix GC_scratch_alloc and GC_get_maps invocations to prevent SEGV. -* Fix visibility of GC_clear/set_mark_bit (unhide symbols). -* Fix visibility of GC_push_all/conditional, GC_push_other_roots symbols. - - -== [7.2b] 2012-05-23 == - -* Fix assertion in GC_malloc_[atomic_]uncollectable (THREADS case only). - - -== [7.2] 2012-05-11 == - -* Abort in GC_thr_init on pthread_atfork failure (POSIX threads). -* Add GC_WIN32_PTHREADS target in configure. -* Add GC_is_disabled new function to GC API. -* Add info that getcontext() resets FPE mask no longer on Linux/x86_64. -* Add public GC_set_handle_fork to control forked child handling support. -* Add realloc_test.c test. -* Add support for Hexagon target. -* Add thread-safe GC_get_heap_usage_safe to GC API. -* Change GC_check_fl_marks prototype and implementation. -* Check pthread_create/join result in test. -* Define GC_DLL (in configure) if building only dynamic libraries. -* Define NO_DEBUGGING (in configure) if "--disable-gc-debug" is set. -* Disable incremental mode on Darwin if fork handling requested. -* Enable parallel marker in configure for Solaris. -* Fix "comparison of signed and unsigned values" compiler warnings. -* Fix 'volatile' keyword placement in GC_SysVGetDataStart. -* Fix ALIGNMENT, CPP_WORDSZ, GC_GRANULE_BYTES/WORDS for x32 target. -* Fix GC_READ_ENV_FILE code for Cygwin. -* Fix GC_add_roots_inner for Mac OS X (align segment start). -* Fix GC_check_fl_marks regarding concurrent access. -* Fix GC_finalizer_nested size to workaround alignment problem in Watcom. -* Fix GC_find_limit_with_bound to always reset fault handler on return. -* Fix GC_init static assertion for clang/x64 (Darwin). -* Fix GC_init[_lib_bounds] and GC_get_main_stack_base for malloc redirection. -* Fix GC_push_all/selected boundaries check. -* Fix GC_register_my_thread marking thread as detached (Cygwin/pthreads-w32). -* Fix GC_remove_all_threads_but_me to cleanup thread-specific data storage. -* Fix GC_restart_handler to preserve errno if needed. -* Fix GC_root_size update in GC_add_roots_inner (Win32). -* Fix GC_unregister_my_thread to ensure no ongoing incremental GC (Win32). -* Fix GC_with_callee_saves_pushed for clang (disable __builtin_unwind_init). -* Fix calloc, GC_generic_malloc to check for allocation size overflows. -* Fix compiler warning in GC_dyld_image_add/remove (Darwin). -* Fix configure --enable-cplusplus make install. -* Fix configure to disable GCC aliasing optimization unless forced to. -* Fix duplicate definitions in gcconfig.h for NetBSD. -* Fix fork() support on Cygwin and Darwin targets. -* Fix gc.h compatibility regression regarding GC_PTR, GC_I_HIDE_POINTERS. -* Fix gc_cpp.cc for Cygwin (remove duplicate function definition). -* Fix gcconfig.h to define USE_GET_STACKBASE_FOR_MAIN for Android. -* Fix gcconfig.h to handle mips64-linux target. -* Fix gctest (for Win32) to avoid GC_print_stats internal variable usage. -* Fix mach_dep.c to include sys/ucontext.h on Mac OS X 10.6. -* Fix tests to check GC_malloc result for NULL (out-of-memory). -* Fix thread model in configure for MinGW ("win32" instead of "posix"). -* Fix various warnings reported by LINT-like tools. -* Fix visibility of some GC internal symbols used by GNU GCJ currently. -* Port some thread tests to Win32. -* Refine API GC setters and getter comments regarding locking. -* Refine GC_stackbottom description in gc.h. -* Remove duplicate calls in GC_register_dynamic_libraries. -* Remove locking in API GC_get_bytes_since_gc and friends. -* Remove newly-added GC_get_heap_size/free_bytes_inner from API. -* Remove some local variables that are unused. -* Support multi-threading for RTEMS target. -* Use global GC_noop_sink variable in GC_noop1 to suppress compiler warning. -* Use pkg-config to pick up libatomic_ops, etc. -* Workaround some Linux/arm kernels bug to get correct GC_nprocs value. - - -== [7.2alpha6] 2011-06-14 == - -* configure_atomic_ops.sh: Remove. -* Makefile.direct (dist gc.tar): Remove configure_atomic_ops.sh. -* Makefile.am (EXTRA_DIST): Add autogen.sh. - -* NT_STATIC_THREADS_MAKEFILE (.cpp.obj): Remove duplicate .cpp -filename passed. -* NT_X64_THREADS_MAKEFILE (.cpp.obj): Use lowercase file -extension. -* NT_X64_STATIC_THREADS_MAKEFILE (.cpp.obj): Likewise. -* NT_MAKEFILE (.cpp.obj): Likewise. - -* alloc.c (GC_add_current_malloc_heap, GC_build_back_graph, -GC_traverse_back_graph): Move prototype to gc_priv.h. -* checksums.c (GC_page_was_ever_dirty): Likewise. -* dbg_mlc.c (GC_default_print_heap_obj_proc): Likewise. -* dyn_load.c (GC_parse_map_entry, GC_get_maps, -GC_segment_is_thread_stack, GC_roots_present, GC_is_heap_base, -GC_get_next_stack): Likewise. -* finalize.c (GC_reset_finalizer_nested, -GC_check_finalizer_nested): Likewise. -* gcj_mlc.c (GC_start_debugging, GC_store_debug_info): Likewise. -* malloc.c (GC_extend_size_map, GC_text_mapping): Likewise. -* mark_rts.c (GC_mark_thread_local_free_lists): Likewise. -* misc.c (GC_register_main_static_data, GC_init_win32, -GC_setpagesize, GC_init_linux_data_start, -GC_set_and_save_fault_handler, GC_init_dyld, GC_init_netbsd_elf, -GC_initialize_offsets, GC_bl_init, GC_do_blocking_inner, -GC_bl_init_no_interiors): Likewise. -* os_dep.c (GC_greatest_stack_base_below, GC_push_all_stacks): -Likewise. -* reclaim.c (GC_check_leaked): Likewise. -* win32_threads.c (GC_gww_dirty_init): Likewise. -* darwin_stop_world.c (GC_is_mach_marker, GC_mprotect_stop, -GC_mprotect_resume): Move prototype to darwin_stop_world.h. -* pthread_support.c (GC_FindTopOfStack): Likewise. -* dyn_load.c (GC_cond_add_roots): Merge adjacent definitions. -* mark.c (GC_page_was_ever_dirty): Remove (as already declared). -* mark_rts.c (GC_roots_present): Change return type to void -pointer (to match the prototype); return NULL instead of FALSE. -* mark_rts.c (GC_add_roots_inner): Cast GC_roots_present() result. -* os_dep.c (NEED_PROC_MAPS): Move definition to gcconfig.h. -* os_dep.c (GC_write_fault_handler): Make STATIC. -* os_dep.c (GC_set_write_fault_handler): New function (only if -GC_WIN32_THREADS). -* pthread_start.c (GC_start_rtn_prepare_thread, -GC_thread_exit_proc): Move prototype to pthread_support.h. -* pthread_support.c (GC_nacl_initialize_gc_thread, -GC_nacl_shutdown_gc_thread, GC_unblock_gc_signals): -Likewise. -* pthread_support.c (GC_stop_init): Move prototype to -pthread_stop_world.h. -* win32_threads.c (GC_write_fault_handler): Remove prototype. -* win32_threads.c (GC_register_my_thread_inner): Call -GC_set_write_fault_handler instead of SetUnhandledExceptionFilter -(only if MPROTECT_VDB). -* doc/README.win32: Add information about DMC. -* include/private/gc_priv.h (GC_set_write_fault_handler): New -prototype (only if GC_WIN32_THREADS and MPROTECT_VDB). - -* misc.c (vsnprintf): Redirect to vsprintf() if NO_VSNPRINTF. - -* win32_threads.c (GC_unregister_my_thread): Use KNOWN_FINISHED() -instead of FINISHED macro. -* tests/test.c (check_heap_stats): Round up max_heap_sz value for -Win32 (same as for USE_MMAP). - -* tests/test.c (check_heap_stats): Adjust printf format specifier -for max_heap_sz; cast max_heap_sz accordingly. - -* doc/README.solaris2: Add note. - -* configure.ac (SOLARIS25_PROC_VDB_BUG_FIXED): Don't define for -Solaris/x86 2.10+. - -* tests/threadkey_test.c (SKIP_THREADKEY_TEST): Skip the test if -defined; explicitly define for some targets. - -* mark.c (GC_dirty): Add prototype (only if MANUAL_VDB). -* stubborn.c (GC_dirty): Likewise. -* include/private/gcconfig.h (GWW_VDB, MPROTECT_VDB, PCR_VDB, -PROC_VDB): Undefine if MANUAL_VDB. -* include/private/gcconfig.h (DEFAULT_VDB): Don't define if -MANUAL_VDB. -* os_dep.c (async_set_pht_entry_from_index): Define for -MANUAL_VDB. -* os_dep.c (GC_read_dirty): Set GC_dirty_maintained only if -success; if ioctl() failed then just print warning instead of -aborting. - -* include/private/gc_priv.h (GC_ASSERT): Use "%d" (instead of %ld) -for line number printing. - -* os_dep.c (GC_read_dirty): Add debug logging if DEBUG_DIRTY_BITS -(for PROC_VDB only); print errors via GC_err_printf; rename "ps" -and "np" local variables to npages and pagesize, respectively; -remove "current_addr" local variable. - -* os_dep.c (GC_get_main_stack_base): Convert to GC_get_stack_base -for BeOS and OS/2; define HAVE_GET_STACK_BASE. -* os_dep.c (GET_MAIN_STACKBASE_SPECIAL): Define when a specific -GC_get_main_stack_base implementation is defined. -* os_dep.c (GC_get_main_stack_base): Define that based on -GC_get_stack_base() in a single place (only if -GET_MAIN_STACKBASE_SPECIAL is unset); check GC_get_stack_base() -result. - -* mark.c (GC_push_selected): Remove "push_fn" argument (use -GC_push_all directly); update the documentation. -* mark.c (GC_push_conditional): Simplify the code (for better -readability). - -* mark.c (alloc_mark_stack): Use FALSE/TRUE (instead of 0/1) for -boolean local variables. -* doc/README.macros (GC_PREFER_MPROTECT_VDB): Update. -* os_dep.c (GC_page_was_dirty, GC_page_was_ever_dirty, -GC_remove_protection): Define for GWW_VDB and PROC_VDB in a single -place. -* os_dep.c (GC_page_was_dirty, GC_page_was_ever_dirty): Compute -PHT_HASH(h) only once (store result to a local variable). - -* doc/README.solaris2: Update. - -* include/private/gcconfig.h (end, InitStackBottom): Declare -extern variable for RTEMS. -* include/private/gcconfig.h (DATASTART, DATAEND, STACKBOTTOM): -Update (for RTEMS). -* include/private/gcconfig.h (DATAEND): Fix a typo in the macro -name (for RTEMS). -* tests/test.c (CONFIGURE_APPLICATION_DOES_NOT_NEED_CLOCK_DRIVER): -Replace with CONFIGURE_APPLICATION_NEEDS_CLOCK_DRIVER (for RTEMS). - -* include/private/gcconfig.h (MPROTECT_VDB): Enable for Solaris in -single-threaded environment. - -* include/private/gcconfig.h (MPROTECT_VDB): Undefine if PROC_VDB. -* tests/test.c (NUMBER_ROUND_UP): New macro. -* tests/test.c (check_heap_stats): Round up total expected heap -size to the nearest 4 MiB bound. -* tests/test.c (check_heap_stats): Print the current and expected -heap sizes in case of failure. - -* checksums.c (GC_check_blocks, GC_check_dirty): Do log printing -only if GC_print_stats; print errors using GC_err_printf. -* checksums.c (GC_check_blocks): Join adjacent printf() calls into -a single one. - -* pthread_support.c (pthread_join): Add assertion (check thread is -finished). -* pthread_support.c (GC_register_my_thread): Don't detach the -thread if invoked from the thread destructor. -* win32_threads.c (GC_register_my_thread): Likewise. -* win32_threads.c (GC_unregister_my_thread): Don't delete the -thread (just set FINISHED) if the thread is not detached (only if -GC_PTHREADS); add assertion (check the thread is not finished). -* tests/threadkey_test.c (main): Join some created threads. - -* pthread_support.c (GC_delete_gc_thread): Rename "gc_id" local -variable to "t". -* win32_threads.c (GC_delete_gc_thread): Likewise. -* pthread_support.c (pthread_join, pthread_detach, -pthread_cancel): Rename "thread_gc_id" local variable to "t". -* win32_threads.c (GC_pthread_detach): Likewise. -* win32_threads.c (GC_delete_gc_thread): Remove "gc_nvid" local -variable. -* win32_threads.c (GC_pthread_join): Rename "joinee" local -variable to "t". - -* pthread_stop_world.c (pthread_sigmask): Undefine even if not -DEBUG_THREADS. -* pthread_stop_world.c (GC_unblock_gc_signals): New function (only -if GC_EXPLICIT_SIGNALS_UNBLOCK). -* pthread_support.c (GC_unblock_gc_signals): New prototype. -* pthread_support.c (GC_register_my_thread_inner, -GC_register_my_thread): Call GC_unblock_gc_signals (only if -GC_EXPLICIT_SIGNALS_UNBLOCK); add comment. -* include/private/gcconfig.h (GC_EXPLICIT_SIGNALS_UNBLOCK): New -macro. - -* pthread_stop_world.c (GC_suspend_handler_inner): Remove "dummy", -"sig" local variables; rename my_thread local variable to "self". - -* tests/threadkey_test.c (LIMIT): Use smaller value (don't create -more than 30 in parallel by default). - -* tests/threadkey_test.c (key_once, main): Work around for Solaris -PTHREAD_ONCE_INIT. -* tests/threadkey_test.c (LIMIT): Use smaller value for Solaris. - -* dyn_load.c (GC_FirstDLOpenedLinkMap): Remove unused "r" local -variable. -* pthread_support.c (GC_unregister_my_thread_inner): Revert back -GC_remove_specific invocation; add a comment. -* include/private/thread_local_alloc.h (GC_remove_specific): -Revert back. -* specific.c (slow_getspecific): Cast qtid to AO_t. -* include/private/specific.h (key_create, setspecific, -remove_specific): Remove "extern" keyword. -* include/private/specific.h (getspecific): Change type of "qtid" -local variable to unsigned long. - -* pthread_support.c (GC_check_tls): Fix "#endif" comment. -* include/gc.h (GC_REDIRECT_TO_LOCAL): Remove deprecated comment. -* include/private/thread_local_alloc.h (THREAD_LOCAL_ALLOC): -Remove redundant test of the macro. - -* backgraph.c (add_edge): Recognize DEBUG_PRINT_BIG_N_EDGES macro. -* os_dep.c (GC_set_and_save_fault_handler): Recognize -SIGACTION_FLAGS_NODEFER_HACK macro. -* pthread_support.c (mark_mutex): Recognize GLIBC_2_1_MUTEX_HACK -macro. -* pthread_support.c (GC_acquire_mark_lock): Remove commented out -code. -* include/private/gc_priv.h (SUNOS5SIGS): Don't include -sys/siginfo.h on Linux. -* include/private/gcconfig.h (FORCE_WRITE_PREFETCH): New macro -recognized, force PREFETCH_FOR_WRITE to be defined on x86. -* include/private/gcconfig.h (USE_HPUX_FIXED_STACKBOTTOM): New -macro recognized (for HP/UX). - -* os_dep.c (GC_gww_page_was_ever_dirty): Fix comment (for -GWW_VDB). -* os_dep.c (GC_dirty_init): Use memset() for GC_written_pages -resetting (for PROC_VDB). - -* tests/threadkey_test.c: New file. -* tests/tests.am (TESTS, check_PROGRAMS): Add 'threadkey_test'. -* tests/tests.am (threadkey_test_SOURCES, threadkey_test_LDADD): -New variable. - -* pthread_support.c (GC_unregister_my_thread_inner): Don't call -GC_remove_specific. -* include/private/thread_local_alloc.h (GC_remove_specific): -Remove (since it is empty for all targets). -* pthread_support.c (GC_record_stack_base): New inline function. -* win32_threads.c (GC_record_stack_base): Likewise. -* pthread_support.c (GC_register_my_thread_inner): Invoke -GC_record_stack_base. -* win32_threads.c (GC_register_my_thread_inner): Likewise. -* pthread_support.c (GC_register_my_thread): If thread is FINISHED -then call GC_record_stack_base, clear FINISHED, initialize -thread-local list and return success. -* win32_threads.c (GC_register_my_thread): Likewise. -* include/gc.h (GC_register_my_thread): Update documentation. -* include/private/thread_local_alloc.h (GC_thread_key): Likewise. - -* thread_local_alloc.c (GC_malloc, GC_malloc_atomic): Join -adjacent "#ifdef". -* thread_local_alloc.c (GC_malloc_atomic): Call -GC_core_malloc_atomic (instead of GC_core_malloc). - -* pthread_start.c (GC_start_rtn_prepare_thread): Change return -type to GC_thread. -* pthread_start.c (GC_inner_start_routine): Pass the current -thread descriptor to pthread_cleanup_push (same as in -win32_threads.c). -* pthread_stop_world.c (GC_push_all_stacks): Rename "me" local -variable to "self". -* win32_threads.c (GC_push_all_stacks): Likewise. -* pthread_stop_world.c (GC_suspend_all, GC_start_world): Rename -"my_thread" local variable to "self". -* pthread_support.c (GC_unregister_my_thread_inner): New static -function. -* pthread_support.c (GC_unregister_my_thread, -GC_thread_exit_proc): Use GC_unregister_my_thread_inner. -* win32_threads.c (GC_register_my_thread, GC_unregister_my_thread, -GC_do_blocking_inner): Rename "t" local variable to "thread_id". -* win32_threads.c (GC_wait_marker, GC_notify_all_marker): Rename -"id" local variable to "thread_id". - -* pthread_support.c (GC_unregister_my_thread): Call pthread_self -only once. -* win32_threads.c (GC_pthread_start_inner): Likewise. -* pthread_support.c (GC_unregister_my_thread): Add debug output. -* win32_threads.c (GC_unregister_my_thread): Likewise. -* pthread_support.c (GC_register_my_thread, -GC_start_rtn_prepare_thread): Rename "my_pthread" local variable -to "self". - -* include/gc.h (GC_HIDE_POINTER, GC_REVEAL_POINTER): Define -unconditionally (do not test GC_I_HIDE_POINTERS); update the -comment. -* include/gc.h (HIDE_POINTER, REVEAL_POINTER): Define as alias to -GC_HIDE/REVEAL_POINTER, respectively. -* include/private/gc_pmark.h (GC_I_HIDE_POINTERS): Do not define. -* include/private/gc_priv.h (GC_I_HIDE_POINTERS): Likewise. - -* include/gc.h (GC_register_my_thread): Refine the comment. - -* include/gc_inline.h (GC_MALLOC_WORDS, GC_CONS): Add missing -parentheses. -* include/gc_typed.h (GC_get_bit, GC_set_bit, -GC_CALLOC_EXPLICITLY_TYPED): Likewise. - -* include/private/gcconfig.h (NO_GETCONTEXT): Add missing ')'. - -* include/private/gcconfig.h (NO_GETCONTEXT): Do not use -getcontext(2) on m68k because it is not implemented there. - -* alloc.c (GC_clear_a_few_frames): Use BZERO(). -* mark_rts.c (GC_clear_roots, GC_rebuild_root_index): Likewise. -* reclaim.c (GC_start_reclaim): Likewise. -* blacklst.c (total_stack_black_listed): Remove "len" local -variable. -* dbg_mlc.c (GC_generate_random_valid_address): Replace "for" -statement with "do-while" one. -* dyn_load.c (GC_register_dynamic_libraries, -GC_register_dynlib_callback): Remove redundant parentheses. - -* cord/cordxtra.c (CORD_from_file_lazy_inner): Suppress -"unused result" compiler warning for fread(). - -* os_dep.c (GC_write_fault_handler): Break when in_allocd_block -is set to true. - -* dbg_mlc.c (GC_has_other_debug_info): Change return type to int; -return -1 if the object has (or had) debugging info but was -marked deallocated. -* include/private/dbg_mlc.h (GC_has_other_debug_info): Likewise. -* dbg_mlc.c (GC_has_other_debug_info): Update documentation; -remove "ohdr" local variable. -* dbg_mlc.c (GC_debug_free): Don't call GC_free if the object has -probably been deallocated. -* dbg_mlc.c (GC_debug_free): Don't actually free the object even -in the leak-finding mode if GC_findleak_delay_free. -* dbg_mlc.c (GC_check_leaked): New function (only unless -SHORT_DBG_HDRS). -* doc/README.environment (GC_FINDLEAK_DELAY_FREE): Document. -* doc/README.macros (GC_FINDLEAK_DELAY_FREE): Likewise. -* include/private/dbg_mlc.h (START_FLAG, END_FLAG): Use GC_WORD_C -on 64-bit architectures. -* include/private/dbg_mlc.h (NOT_MARKED): Remove redundant -parentheses. -* include/private/dbg_mlc.h (GC_HAS_DEBUG_INFO): Update (due to -GC_has_other_debug_info change). -* include/private/gc_priv.h (GC_findleak_delay_free): New global -variable declaration (unless SHORT_DBG_HDRS). -* misc.c (GC_findleak_delay_free): New global variable; recognize -GC_FINDLEAK_DELAY_FREE. -* misc.c (GC_init): Recognize GC_FINDLEAK_DELAY_FREE environment -variable (unless SHORT_DBG_HDRS). -* reclaim.c (GC_check_leaked): Declare (unless SHORT_DBG_HDRS). -* reclaim.c (GC_add_leaked): Don't add the object to leaked list -if marked as deallocated. - -* dbg_mlc.c (GC_has_other_debug_info): Fix punctuation in the -comment. -* dbg_mlc.c (GC_FREED_MEM_MARKER): New macro. -* dbg_mlc.c (GC_debug_free): Use GC_FREED_MEM_MARKER. -* dbg_mlc.c (GC_smashed): Refine documentation. -* mark.c (GC_push_selected): Change dirty_fn return type to -GC_bool. -* os_dep.c (GC_page_was_ever_dirty): Make GC_INNER. -* reclaim.c (GC_reclaim_small_nonempty_block): Remove "kind" -local variable. -* reclaim.c (GC_reclaim_block): Pass true constant to -GC_reclaim_small_nonempty_block (instead of report_if_found). -* doc/README.autoconf: Update; fix a typo. -* include/private/gcconfig.h (GC_WORD_C): New macro. - -* dbg_mlc.c (GC_store_debug_info_inner): Cast "linenum". -* dbg_mlc.c (GC_check_annotated_obj): Fix punctuation in the -comment. -* dbg_mlc.c (GC_print_smashed_obj): Add (and print) "msg" -argument. -* dbg_mlc.c (GC_debug_free, GC_print_all_smashed_proc): Pass -message to GC_print_smashed_obj. -* dbg_mlc.c (GC_debug_free): Call GC_size once. -* dbg_mlc.c (GC_debug_realloc): Calculate old_sz only if -allocation succeeded; remove unnecessary check for object is -smashed (since this is done in GC_debug_free); remove "clobbered" -local variable. - -* dbg_mlc.c (GC_store_debug_info_inner, GC_store_debug_info): -Rename "integer" argument to "linenum"; change the type of the -argument to int. -* gcj_mlc.c (GC_store_debug_info): Likewise. -* dbg_mlc.c (GET_OH_LINENUM): New macro. -* dbg_mlc.c (GC_print_obj, GC_print_smashed_obj): Use -GET_OH_LINENUM; adjust print format specifier. -* dbg_mlc.c (GC_debug_malloc, GC_debug_malloc_ignore_off_page, -GC_debug_malloc_atomic_ignore_off_page, -GC_debug_generic_malloc_inner, -GC_debug_generic_malloc_inner_ignore_off_page, -GC_debug_malloc_stubborn, GC_debug_malloc_atomic, -GC_debug_malloc_uncollectable, -GC_debug_malloc_atomic_uncollectable): Remove unnecessary cast of -"i". -* gcj_mlc.c (GC_debug_gcj_malloc): Likewise. - -* os_dep.c (GC_linux_stack_base): Rename to -GC_linux_main_stack_base. -* os_dep.c (GC_freebsd_stack_base): Rename to -GC_freebsd_main_stack_base; adjust error message. -* pthread_stop_world.c (GC_stop_init): Use GC_SEM_INIT_PSHARED -as an argument for sem_init(). -* pthread_support.c (pthread_create): Likewise. -* pthread_support.c (pthread_create): Abort in case sem_init() -fails. -* include/private/gc_priv.h (GC_SEM_INIT_PSHARED): Define. -* tests/initsecondarythread.c: Include gcconfig.h; call GC_INIT -from main() if it should be done from the primordial thread only. - -* alloc.c: Don't include sys/types.h for ArmCC. -* dyn_load.c: Likewise. -* os_dep.c: Likewise. -* mach_dep.c (_setjmp, _longjmp): Redirect to setjmp/longjmp for -ArmCC. -* mark.c (GC_noop): Define specially for ArmCC. -* include/private/gc_priv.h (GC_noop): Likewise. -* misc.c (GC_init): Don't test pointers comparison for ArmCC. -* misc.c: Don't include unistd.h for ArmCC. -* os_dep.c (pages_executable): Rename to GC_pages_executable; -make STATIC. -* os_dep.c (GC_unix_mmap_get_mem): Don't define for ArmCC. -* ptr_chck.c (GC_is_visible): Explicitly cast -(GC_DS_PER_OBJECT-GC_INDIR_PER_OBJ_BIAS) to word (to suppress -a compiler warning). -* include/private/gcconfig.h: Recognize __arm. -* include/private/gcconfig.h (HBLKPTR): Define for ArmCC. -* include/private/gcconfig.h (HBLKPTR): Add parentheses for -"bytes" argument. - -* pthread_support.c (GC_get_nprocs): Don't define for Android. -* pthread_support.c (GC_dummy_thread_local): Don't test -GC_LINUX_THREADS. -* include/gc_config_macros.h (GC_ADD_CALLER, GC_RETURN_ADDR): -Define for Android. - -* mach_dep.c (NO_GETCONTEXT): Move to gcconfig.h. -* os_dep.c (GC_write_fault_handler): Don't include ucontext.h if -NO_GETCONTEXT. -* include/private/gcconfig.h (GETPAGESIZE): Define as a sysconf -call for Android. - -* include/private/gc_locks.h (WIN32_LEAN_AND_MEAN, NOSERVICE): -Define before including windows.h. -* include/private/gc_priv.h (WIN32_LEAN_AND_MEAN, NOSERVICE): -Likewise. -* include/private/thread_local_alloc.h (WIN32_LEAN_AND_MEAN, -NOSERVICE): Likewise. -* include/private/gc_priv.h (MS_TIME_DIFF): Avoid floating-point -arithmetics; add a comment. - -* mark.c (GC_clear_hdr_marks): Don't test USE_MARK_BYTES. -* extra/setjmp_t.c (main): Don't test USE_MARK_BITS. -* include/private/gc_pmark.h (SET_MARK_BIT_EXIT_IF_SET): Likewise. -* include/private/gc_pmark.h (SET_MARK_BIT_EXIT_IF_SET): Remove -"mark_byte" local variable. -* include/private/gc_pmark.h (OR_WORD_EXIT_IF_SET): Add a comment -about that AO_or() is not used by GC unless USE_MARK_BITS -explicitly set. -* include/private/gc_priv.h (OR_WORD): Likewise. -* include/private/gc_pmark.h (INCR_MARKS): Remove trailing ';', -add parentheses. -* include/private/gc_priv.h (ONES): Define before use by -MAKE_COOLER. -* include/private/gc_priv.h (MARK_BITS_SZ): Define where used. -* include/private/gc_priv.h (OR_WORD): Don't define if -USE_MARK_BYTES. -* include/private/gcconfig.h (USE_MARK_BYTES); Remove duplicate -definition; simplify expression. - -* os_dep.c (GC_get_maps): Always close the file. -* pthread_support.c (GC_get_nprocs): Likewise. -* os_dep.c (READ): Define similarly across the file (without -parameters). -* pthread_support.c (GC_get_nprocs): Use signed int type for "i" -and "len" local variables (since read() may return -1). -* include/private/gc_pmark.h (LONG_MULT): Add prefix/suffix -double underscore; add "volatile" for asm. -* include/private/gc_pmark.h (LONG_MULT): Add missing -parentheses. -* include/private/gc_priv.h (OR_WORD): Likewise. -* include/private/gc_priv.h (OR_WORD): Remove unnecessary brackets -and ';' symbol. - -* os_dep.c (GC_get_stack_base): Implement for Android (same as -for Linux). -* pthread_support.c (GC_get_nprocs): Return 1 (instead of -1) if -failed to open "stat" file (not to issue a warning twice); update -the comment. -* pthread_support.c (GC_thr_init): Call sysconf() on Android to -get the number of CPUs. - -* include/private/gc_priv.h (_GNU_SOURCE): Revert one of the -recent patches regarding this macro as the macro should be set -(to 1) before including any other system header. - -* doc/README.environment (GC_INITIAL_HEAP_SIZE, -GC_MAXIMUM_HEAP_SIZE): Update. - -* misc.c (GC_parse_mem_size_arg): Allow 'k', 'M', 'G' suffixes in -heap size specifier; return 0 if not a valid one. -* include/gc_cpp.h: Explicitly define inline one-argument delete -operator for Cygwin (as a workaround). -* tests/test_cpp.cc (main): Suppress compiler warnings about -"assigned value is unused". - -* misc.c (GC_parse_mem_size_arg): New function. -* misc.c (GC_init): Use GC_parse_mem_size_arg(). -* pthread_stop_world.c (tkill): Declare for Android. - -* include/private/gc_priv.h (_GNU_SOURCE): Include features.h -first (except for NaCl) and then define the macro to 1 if not yet. - -* tests/tests.am (TESTS, check_PROGRAMS): Add -'initsecondarythread'. -* tests/tests.am (initsecondarythread_SOURCES, -initsecondarythread_LDADD): New variable. - -* dbg_mlc.c (GC_store_debug_info_inner): Always define; add -"const" to its string argument. -* dbg_mlc.c (GC_store_debug_info): Call GC_store_debug_info_inner. -* dbg_mlc.c (GC_debug_free): Set GC_have_errors in case of -smashed or previously deallocated found. -* dbg_mlc.c (GC_check_heap_block): Replace while loop with a for -one. -* reclaim.c (GC_reclaim_check): Likewise. -* dbg_mlc.c (GC_check_heap_proc): Remove redundant cast to word. -* os_dep.c (GC_get_stack_base): Don't initialize -stackbase_main_self/ss_sp on Solaris if thr_main() is zero (thus -calling GC_INIT() from a non-primordial thread is possible now). -* reclaim.c (GC_add_leaked): Turn into an inline one. -* reclaim.c (GC_reclaim_small_nonempty_block): -Change report_if_found type from int/word to boolean. -* include/private/gc_priv.h (GC_start_reclaim): Likewise. -* include/private/gc_priv.h (set_mark_bit_from_hdr, -clear_mark_bit_from_hdr): Place closing parenthesis properly. - -* os_dep.c (GC_get_main_stack_base): Try to use -pthread_attr_getstack first for Linux if THREADS. -* doc/README.macros (USE_GET_STACKBASE_FOR_MAIN): Adjust text -alignment. - -* dbg_mlc.c (GC_generate_random_backtrace_no_gc): Fix a message -typo. -* dbg_mlc.c (GC_debug_malloc): Add a comment (about zero size). -* dbg_mlc.c (GC_strdup): Call GC_err_printf instead of WARN (in -case of NULL argument). -* dbg_mlc.c (GC_free): In case of NULL argument, just return -(without any warning printed); eliminate "uncollectable" local -variable. - -* configure.ac (THREADDLLIBS): Use alternate thread library on -Solaris 8. -* configure.ac (need_atomic_ops_asm): Set to true only for SPARC -Solaris. -* configure.ac: Don't use libdl on mips-sgi-irix6. - -* mach_dep.c (NO_GETCONTEXT); Define for RTEMS. -* mach_dep.c (GC_with_callee_saves_pushed): Don't call -__builtin_unwind_init() for RTEMS; use setjmp() without the -leading underscore (for RTEMS). -* tests/test.c (BIG): Use smaller value for RTEMS. -* tests/test.c (main): Customize for RTEMS. - -* configure.host: Remove doubled words in comments. -* os_dep.c: Likewise. -* doc/README: Likewise. -* extra/setjmp_t.c: Likewise. -* tests/huge_test.c: Likewise. -* extra/setjmp_t.c (getpagesize, nested_sp, main, g): Replace the -K&R-style function definition with the ANSI C one. -* extra/setjmp_t.c (nested_sp): Implement in the same way as -GC_approx_sp. - -* dyn_load.c (GC_dyld_sections): Add more sctions. -* dyn_load.c (GC_dyld_add_sect_fmts): New static varaible. -* dyn_load.c (L2_MAX_OFILE_ALIGNMENT): New macro. -* dyn_load.c (GC_dyld_image_add, GC_dyld_image_remove): Improve -logging; add support for on-demand sections. - -* gcj_mlc.c (GC_gcj_malloc_initialized): Use STATIC unless -GC_ASSERTIONS. -* include/private/gc_priv.h (GC_gcj_malloc_initialized): Don't -declare (as external) unless GC_ASSERTIONS. -* os_dep.c (GC_win32_free_heap): Clear GC_heap_bases[] also for -Cygwin; add FIXME. -* include/private/gcconfig.h: Include for RTEMS. -* include/private/gcconfig.h: Add "#error" for every "-->" mark. -* include/private/gcconfig.h (CLEAR_DOUBLE): Turn the code into -an expression. -* include/private/pthread_support.h (SUSPENDED_EXT): Add new flag -(which existed previously as SUSPENDED and still exists in GCJ). -* include/private/pthread_support.h (DISABLED_GC): Change the -value (as it is already used by SUSPENDED_EXT). - -* tests/test.c (reverse_test): Modify count (BIG) for -ppc64-darwin. - -* reclaim.c (GC_print_all_errors): Recognize new GC_ABORT_ON_LEAK -macro and environment variable; abort if any error has been -printed provided the environment variable (or macro) is set. -* doc/README.environment (GC_ABORT_ON_LEAK): Document. -* doc/README.macros (GC_ABORT_ON_LEAK): Likewise. - -* os_dep.c (GC_unix_sbrk_get_mem, GC_unix_get_mem): Don't define -for RTEMS. -* include/private/gcconfig.h (RTEMS): Add support for. -* include/private/gcconfig.h (GET_MEM): Use calloc() for RTEMS. - -* mallocx.c (GC_malloc_uncollectable): Move to malloc.c (since -it is used internally in some places). - -* dbg_mlc.c (GC_register_finalizer_no_order): Remove redundant -declaration. -* dbg_mlc.c (GC_debug_malloc_replacement, -GC_debug_realloc_replacement): Rename RA to GC_DBG_RA. -* malloc.c (GC_debug_malloc_replacement): Likewise. -* mallocx.c (GC_debug_realloc_replacement): Likewise. -* dbg_mlc.c (GC_store_debug_info): Move proto from dbg_mlc.h. -* malloc.c (GC_strdup, GC_strndup, GC_wcsdup): Move to mallocx.c. -* malloc.c: Include errno.h only REDIRECT_MALLOC; remove redundant -includes of string.h. -* mallocx.c: Include string.h (for GC_strdup). -* include/private/dbg_mlc.h (GC_store_debug_info): Move declaration -to dbg_mlc.c. -* include/private/gc_locks.h (UNCOND_LOCK, UNCOND_UNLOCK): Remove -redundant trailing ';'. -* include/private/gc_priv.h (START_WORLD, COND_DUMP): Likewise. -* include/private/gc_locks.h (LOCK, UNLOCK): Place opening '{' -properly. -* include/private/gc_priv.h (GC_DBG_RA): Move from dbg_mlc.c, -malloc.c, mallocx.c. - -* alloc.c (GC_check_heap, GC_print_all_smashed): Move the -definition from misc.c. -* dbg_mlc.c (GC_debug_malloc_atomic_uncollectable): Define as -public. -* include/gc.h (GC_debug_malloc_atomic_uncollectable): Declare. -* include/gc.h (GC_MALLOC_ATOMIC_UNCOLLECTABLE): Define new public -macro. -* dbg_mlc.c (MAX_SMASHED): Don't define if already set. -* reclaim.c (MAX_LEAKED): Likewise. -* dbg_mlc.c (GC_add_smashed): Add FIXME about the concurrent -access to the global array. -* reclaim.c (GC_add_leaked): Likewise. -* misc.c (GC_print_back_height): Set on if GC_PRINT_BACK_HEIGHT -(new macro) is defined. -* doc/README.macros (GC_PRINT_BACK_HEIGHT): Document. -* misc.c (GC_dump_regularly, GC_init): Replace 0/1 for -GC_dump_regularly and GC_print_back_height variables with -FALSE/TRUE. -* reclaim.c (GC_print_all_errors): Refine the comment. - -* tests/test.c (reverse_test_inner): Undo one of the previous -patches which shifts "c" and "d" pointers only if -ALL_INTERIOR_POINTERS (since interior pointers are always -recognized in stacks). - -* misc.c (GC_stdout, GC_stderr): Move the definition to the place -where GC_log is defined (Unix only). -* misc.c (GC_init): Recognize "GC_ONLY_LOG_TO_FILE" environment -variable and the similar macro; redirect GC_stdout and GC_stderr -to GC_log if "GC_LOG_FILE" environment variable is set unless -prohibited by GC_ONLY_LOG_TO_FILE (Unix only). -* doc/README.environment (GC_ONLY_LOG_TO_FILE): Document. -* doc/README.macros (GC_ONLY_LOG_TO_FILE): Likewise. - -* misc.c (GC_stdout, GC_write): Rename GC_stdout to GC_log (Win32 -only). -* misc.c (GC_write): Add for MacOS (and OS/2); change WRITE() -accordingly. -* misc.c (GC_printf): Check GC_quiet before va_start(). - -* allchblk.c (GC_freehblk): Use GC_log_printf instead of GC_printf -inside "if (GC_print_stats)" branch. -* alloc.c (GC_collect_or_expand): Likewise. -* dyn_load.c (GC_register_dynamic_libraries): Likewise. -* headers.c (GC_scratch_alloc): Likewise. -* os_dep.c (GC_get_maps, GC_remap, PROTECT, -GC_write_fault_handler, GC_dirty_init, GC_mprotect_thread): Likewise. -* alloc.c (min_bytes_allocd): Use GC_log_printf instead of -GC_printf for DEBUG_THREADS output. -* darwin_stop_world.c (GC_stack_range_for, GC_suspend_thread_list, -GC_stop_world, GC_thread_resume, GC_start_world): Likewise. -* pthread_start.c (GC_inner_start_routine): Likewise. -* pthread_stop_world.c (GC_suspend_handler, GC_restart_handler, -GC_push_all_stacks, GC_suspend_all, GC_stop_world, -GC_start_world): Likewise. -* pthread_support.c (GC_mark_thread, GC_get_nprocs, -GC_start_rtn_prepare_thread, pthread_create): Likewise. -* checksums.c (GC_update_check_page): Use GC_printf() instead of -GC_err_printf() for error printing. -* checksums.c (GC_check_blocks, GC_check_dirty): Use GC_log_printf -instead of GC_printf for logging purposes. -* dyn_load.c (sys_errlist, sys_nerr, errno): Move declaration of -external variable outside from GC_register_dynamic_libraries. -* dyn_load.c (GC_register_dynamic_libraries): Don't use -sys_errlist value if errno equals to sys_nerr. -* dyn_load.c (GC_register_dynamic_libraries): Use GC_log_printf -instead of GC_printf for DL_VERBOSE output. -* dyn_load.c (GC_dyld_image_add, GC_dyld_image_remove, -GC_init_dyld): Use GC_log_printf instead of GC_printf for -DARWIN_DEBUG output. -* os_dep.c (catch_exception_raise): Use GC_log_printf -instead of GC_printf for DEBUG_EXCEPTION_HANDLING output. -* reclaim.c (GC_print_free_list): Move "n" increment out of -GC_printf() call. - -* win32_threads.c (DEBUG_CYGWIN_THREADS, DEBUG_WIN32_PTHREADS, -DEBUG_WIN32_THREADS): Remove. -* win32_threads.c (GC_register_my_thread_inner, -GC_win32_start_inner): Use GC_log_printf instead of GC_printf -inside "if (GC_print_stats)" branch. -* win32_threads.c (GC_PTHREAD_PTRVAL): New macro (defined only if -GC_PTHREADS). -* win32_threads.c (GC_delete_gc_thread, NUMERIC_THREAD_ID, -GC_pthread_join, GC_pthread_create): Use GC_PTHREAD_PTRVAL -macro. -* win32_threads.c (GC_push_stack_for, GC_mark_thread, -GC_CreateThread, GC_beginthreadex, GC_pthread_join, -GC_pthread_create, GC_pthread_start_inner, GC_thread_exit_proc, -GC_mark_thread_local_free_lists): Use GC_log_printf instead of -GC_printf for DEBUG_THREADS output. -* win32_threads.c (GC_win32_start_inner, GC_CreateThread, -GC_beginthreadex, GC_pthread_join, GC_pthread_create, -GC_pthread_start_inner, GC_thread_exit_proc): Cast -GetCurrentThreadId result to long; don't cast value of pthread_t -type to int; adjust printf format specifiers. -* doc/README.win32 (DEBUG_WIN32_PTHREADS): Remove obsolete -information. - -* tests/test.c (cons, small_cons, gcj_cons, check_ints, -check_uncollectable_ints, print_int_list, check_marks_int_list, -fork_a_thread, finalizer, mktree, chktree, alloc8bytes, -alloc_small, tree_test, typed_test, check_heap_stats, WinMain, -test, main): Remove unnecessary casts of GC_printf calls to void. - -* allchblk.c (GC_print_hblkfreelist): Adjust (make uniform across -BDWGC) printed message (adjust letters case, terminating dot and -new line symbols). -* alloc.c (GC_check_fl_marks): Likewise. -* backgraph.c (new_back_edges): Likewise. -* checksums.c (GC_check_dirty): Likewise. -* darwin_stop_world.c (GC_push_all_stacks, -GC_suspend_thread_list): Likewise. -* dbg_mlc.c (GC_print_type, GC_debug_free, GC_debug_realloc, -store_old): Likewise. -* dyn_load.c (GC_register_dynamic_libraries): Likewise. -* mark.c (GC_initiate_gc, GC_mark_some, GC_mark_from, GC_push_all, -GC_push_selected, GC_push_next_marked_dirty): Likewise. -* mark_rts.c (GC_exclude_static_roots_inner): Likewise. -* os_dep.c (GC_remap, GC_default_push_other_roots, -GC_push_thread_structures, GC_dirty_init, GC_read_dirty, -catch_exception_raise_state, catch_exception_raise_state_identity, -GC_mprotect_thread_notify, GC_mprotect_thread, -catch_exception_raise): Likewise. -* pthread_stop_world.c (GC_print_sig_mask, GC_push_all_stacks, -GC_stop_world, GC_stop_init): Likewise. -* pthread_support.c (GC_thr_init, GC_register_my_thread_inner, -GC_start_routine): Likewise. -* win32_threads.c (GC_register_my_thread_inner, -GC_push_all_stacks, GC_win32_start_inner, GC_pthread_join, -GC_pthread_start_inner): Likewise. -* alloc.c (GC_expand_hp_inner): Realign the code. -* mark.c (GC_mark_from, GC_mark_local, GC_do_parallel_mark): -Likewise. -* misc.c (GC_init): Likewise. -* os_dep.c (GC_dirty_init, GC_read_dirty): Likewise. -* include/private/gc_pmark.h (PUSH_CONTENTS_HDR): Likewise. -* tests/test.c (run_one_test): Likewise. -* misc.c (GC_err_puts): Document. -* misc.c (GC_err_write): Remove. -* os_dep.c (dump_maps): Likewise. -* include/private/gc_priv.h (GC_err_write): Likewise. -* os_dep.c (GC_print_address_map): Call GC_err_puts() instead of -dump_maps() and GC_err_write(). -* os_dep.c (GC_read_dirty): Remove redundant brackets. - -* tests/test.c (reverse_test_inner): Test interior pointer -recognition only if ALL_INTERIOR_POINTERS. -* tests/test.c (run_one_test): Replace GC_all_interior_pointers -with GC_get_all_interior_pointers(); simplify the expression. -* tests/test.c (check_heap_stats): Replace GC_bytes_allocd and -GC_bytes_allocd_before_gc with GC_get_total_bytes(). -* tests/test.c (main): Replace GC_gc_no with GC_get_gc_no(). - -* dbg_mlc.c (GC_debug_strdup, GC_debug_free): Output a portability -warning if the argument is NULL and GC is in leaks detection mode. -* dbg_mlc.c (GC_debug_strndup, GC_debug_wcsdup): New public -function definition. -* malloc.c (GC_strndup, GC_wcsdup, strndup): Likewise. -* mallocx.c (GC_posix_memalign): Likewise. -* malloc.c (strdup): Fix string size value; rename "len" to "lb". -* mallocx.c: Include errno.h unless WinCE (otherwise include -windows.h for Win32 error constants). -* win32_threads.c: Define WIN32_LEAN_AND_MEAN and NOSERVICE before -windows.h inclusion. -* misc.c (GC_init): Register at-exit callback if GC_find_leak -(even if GC_FIND_LEAK macro is unset). -* pthread_stop_world.c (NACL_STORE_REGS, -__nacl_suspend_thread_if_needed, GC_nacl_initialize_gc_thread): -Use BCOPY() instead of memcpy(). -* pthread_support.c (GC_init_real_syms): Likewise. -* doc/README.macros (GC_DEBUG_REPLACEMENT, GC_REQUIRE_WCSDUP): -Document new macro. -* doc/README.macros (REDIRECT_MALLOC): Update documentation. -* include/gc.h (GC_strndup, GC_posix_memalign, GC_debug_strndup): -New API function prototype. -* include/gc.h (GC_MALLOC, GC_REALLOC): Redirect to -GC_debug_malloc/realloc_replacement() if GC_DEBUG_REPLACEMENT. -* include/gc.h (GC_STRDUP): Remove redundant parentheses. -* include/leak_detector.h (realloc, strdup): Likewise. -* include/gc.h (GC_STRNDUP): New API macro. -* include/gc.h (GC_NEW, GC_NEW_ATOMIC, GC_NEW_STUBBORN, -GC_NEW_UNCOLLECTABLE): Add missing parentheses. -* include/gc.h (GC_wcsdup, GC_debug_wcsdup): New API function -prototype (only if GC_REQUIRE_WCSDUP). -* include/gc.h (GC_WCSDUP): New API macro (only if -GC_REQUIRE_WCSDUP). -* include/leak_detector.h: Include stdlib.h and string.h after gc.h (unless -GC_DONT_INCLUDE_STDLIB). -* include/leak_detector.h (malloc, calloc, free, realloc): -Undefine symbol before its redefinition. -* include/leak_detector.h (strndup, memalign, posix_memalign): -Redefine to the corresponding GC function. -* include/leak_detector.h (wcsdup): Redefine to GC_WCSDUP (only -if GC_REQUIRE_WCSDUP). -* include/leak_detector.h (CHECK_LEAKS): Add comment; don't define -the macro if already defined. - -* misc.c (GC_abort): Use _exit() (instead of DebugBreak) on Win32 -when doing code static analysis (to inform the tool that the -function is a no-return one). -* os_dep.c (GC_linux_stack_base): Remove a duplicate validation -of the length of "stat" file; use signed int type for "i", -"buf_offset" and "len" local variables (since read() may -return -1). - -* blacklst.c (GC_bl_init_no_interiors): New function (the code -moved from GC_bl_init). -* blacklst.c (GC_bl_init): Invoke GC_bl_init_no_interiors unless -GC_all_interior_pointers mode; remove unnecessarily parameter cast -for GC_scratch_alloc call. -* include/private/gc_priv.h (GC_bl_init): Move the function -declaration to misc.c file. -* misc.c (GC_bl_init_no_interiors): Add a prototype. -* misc.c (GC_set_all_interior_pointers): Allow values other than 0 -and 1; allow altering GC_set_all_interior_pointers value even -after GC initialization. -* obj_map.c (GC_initialize_offsets): Clear GC_valid_offsets and -GC_modws_valid_offsets if GC_all_interior_pointers is off. -* misc.c (GC_init): Don't call GC_initialize_offsets() unless -GC_all_interior_pointers mode. - -* alloc.c (GC_finish_collection): Remove redundant brackets; -adjust code indentation. -* blacklst.c (GC_add_to_black_list_normal): Simplify expression -(to improve code readability). -* blacklst.c (GC_is_black_listed): Join nested "if" (into a single -conditional expression); initialize "nblocks" just before the loop -beginning. -* misc.c (GC_init): Don't compute initial_heap_sz if GC is already -initialized. -* include/private/gc_priv.h (GC_initialize_offsets): Move the -function declaration to misc.c file. -* obj_map.c (GC_initialize_offsets): Remove offsets_initialized -static variable since the function is called only once. -* tests/middle.c (main): Use setter for GC_all_interior_pointers; -adjust printf format specifier (and cast the value passed to). - -* doc/README.macros (SMALL_CONFIG, LARGE_CONFIG): Refine the -documentation. -* include/private/gc_hdrs.h (LOG_BOTTOM_SZ): Ignore SMALL_CONFIG -if LARGE_CONFIG is defined. -* include/private/gc_priv.h (CPP_LOG_HBLKSIZE): Likewise. - -* alloc.c (GC_finish_collection): Replace "#else #ifdef" with -"#elif". -* include/private/gc_priv.h (CPP_LOG_HBLKSIZE, LOG_PHT_ENTRIES, -MAX_ROOT_SETS, MAX_HEAP_SECTS): Likewise. -* alloc.c (GC_expand_hp_inner): Check for GC_collect_at_heapsize -overflow even if not LARGE_CONFIG. -* dbg_mlc.c (GC_check_heap_proc): Check "oh" size even if -SMALL_CONFIG. -* finalize.c (GC_print_finalization_stats): Fix "#endif" comment. -* doc/README.environment (GC_LOG_FILE, GC_PRINT_VERBOSE_STATS, -GC_FULL_FREQUENCY): Refine the documentation. - -* extra/msvc_dbg.c: Test _MSC_VER macro; include "gc.h" (for -GC_word). -* extra/msvc_dbg.c (ULONG_PTR): Replace with GC_ULONG_PTR; define -as word. - -* dbg_mlc.c (GC_get_back_ptr_info, GC_print_obj, -GC_print_smashed_obj, GC_debug_free_inner): Add a code for a -LINT-like tool to instruct it that the function is invoked only -with valid parameters (otherwise a SEGV is ok); recognize LINT2 -new macro. -* misc.c (GC_abort): Instruct a LINT-like tool that the function -never returns in fact. -* os_dep.c (GC_linux_stack_base): Check for read buffer overflow; -close the file immediately after read; use STRTOULL() instead of -decoding the address number manually. -* include/private/gc_priv.h (EXPECT): Don't specify outcome for a -LINT-like tool. -* include/private/gc_priv.h (GC_all_interior_pointers): Instruct a -LINT-like tool that the value is restricted to zero and one only -(required since the variable is global and its value is used as a -part of array index expression is some places). - -* dbg_mlc.c (GC_make_closure): Fix SEGV in case GC_malloc returns -NULL. -* dbg_mlc.c (GC_debug_register_finalizer, -GC_debug_register_finalizer_no_order, -GC_debug_register_finalizer_unreachable, -GC_debug_register_finalizer_ignore_self): Handle out of memory -case properly (similar to GC_register_finalizer_inner). -* headers.c (GC_install_header): Handle the case when alloc_hdr() -returns NULL. -* os_dep.c (GC_get_maps_len): Defend against missing "maps" file. -* pthread_support.c (GC_mark_thread): Place a dummy return -statement (which uses "id" argument) before the actual use of "id" -as an array index (to suppress a warning produced by some static -code analysis tools). -* win32_threads.c (GC_mark_thread): Likewise. -* pthread_support.c (GC_thr_init): Abort (with the appropriate -message) if out of memory. - -* finalize.c (GC_register_finalizer_inner): Fix a typo in a -comment. -*include/private/gcconfig.h (STACKBOTTOM): Likewise. -* gcj_mlc.c (GC_core_gcj_malloc): Replace 0/1 with TRUE/FALSE in -EXPECT (the 2nd argument). -* malloc.c (GC_core_malloc_atomic, GC_core_malloc, GC_free): -Likewise. -* mark.c (GC_mark_and_push, GC_mark_and_push_stack): Likewise. -* thread_local_alloc.c (GC_malloc, GC_malloc_atomic): Likewise. -* include/private/gc_hdrs.h (HC_GET_HDR): Likewise. -* include/private/gc_priv.h (SMALL_OBJ): Likewise. -* include/private/specific.h (getspecific): Likewise. -* pthread_support.c (LOCK_STATS): Add a comment. - -* include/gc_pthread_redirects.h (GC_NO_DLOPEN, -GC_NO_PTHREAD_SIGMASK, GC_PTHREAD_CREATE_CONST, -GC_PTHREAD_EXIT_ATTRIBUTE, GC_NO_PTHREAD_CANCEL): Move the -definition to gc_config_macros. - -* pthread_support.c (pthread_cancel, GC_pthread_cancel_t, -GC_pthread_cancel): Test GC_NO_PTHREAD_CANCEL (instead of NACL and -GC_PTHREAD_EXIT_ATTRIBUTE). -* include/gc_pthread_redirects.h (GC_pthread_cancel, -pthread_cancel): Likewise. -* pthread_support.c (GC_pthread_create, GC_pthread_sigmask, -GC_pthread_join, GC_pthread_detach, GC_pthread_cancel): Realign -code. -* include/gc_pthread_redirects.h (GC_PTHREAD_EXIT_ATTRIBUTE): -Define as empty for NaCl. -* include/gc_pthread_redirects.h (GC_NO_PTHREAD_CANCEL): New macro -defined. - -* dyn_load.c (GC_init_dyld): Do not invoke -_dyld_bind_fully_image_containing_address() if GC_no_dls (as it is -not required to register the main data segment in that case). -* include/gc.h (GC_no_dls): Adjust the comment. - -* dyn_load.c (GC_MUST_RESTORE_REDEFINED_DLOPEN): Test -GC_NO_DLOPEN. -* gc_dlopen.c: Likewise. -* include/gc_pthread_redirects.h (GC_dlopen, dlopen): Likewise. -* gc_dlopen.c: Don't include dlfcn.h (as it is included in -gc_pthread_redirects.h). -* pthread_support.c (pthread_sigmask, GC_pthread_sigmask_t, -GC_pthread_sigmask): Test GC_NO_PTHREAD_SIGMASK (instead of -GC_DARWIN_THREADS, GC_OPENBSD_THREADS and NACL). -* include/gc_pthread_redirects.h (GC_pthread_sigmask, -pthread_sigmask): Likewise. -* win32_threads.c (pthread_sigmask, GC_pthread_sigmask): Test -GC_NO_PTHREAD_SIGMASK (instead of GC_WIN32_PTHREADS). -* pthread_support.c (pthread_create, GC_pthread_create_t, -GC_pthread_create): Rename GC_PTHREAD_CONST to -GC_PTHREAD_CREATE_CONST. -* win32_threads.c (GC_pthread_create): Likewise. -* include/gc_pthread_redirects.h: Likewise. -* include/gc_pthread_redirects.h (GC_NO_DLOPEN, -GC_NO_PTHREAD_SIGMASK): New macro defined. -* include/gc_pthread_redirects.h (GC_PTHREAD_CREATE_CONST): Set to -empty for NaCl. -* include/gc_pthread_redirects.h (GC_PTHREAD_EXIT_ATTRIBUTE): Do -not define for Android (as CANCEL_SAFE is not defined). - -* include/gc.h (GC_ADD_CALLER, GC_RETURN_ADDR, -GC_HAVE_BUILTIN_BACKTRACE, GC_CAN_SAVE_CALL_STACKS): Move -definition to gc_config_macros.h file. -* include/gc_config_macros.h: Check the file is included from gc.h -file. -* include/gc_version.h: Likewise. - -* gc_dlopen.c: Empty unit for NaCl. -* os_dep.c: Include fcntl.h for NaCl. -* os_dep.c (GC_get_main_stack_base): Ignore -USE_GET_STACKBASE_FOR_MAIN macro for NaCl. -* os_dep.c (GC_get_stack_base): Return GC_UNIMPLEMENTED for NaCl. -* os_dep.c (GC_remap): Use mmap (instead of mprotect) for NaCl. -* pthread_start.c (GC_inner_start_routine): Don't invoke -pthread_cleanup_push/pop for NaCl. -* pthread_stop_world.c (GC_nacl_num_gc_threads, -GC_nacl_thread_idx, GC_nacl_park_threads_now, -GC_nacl_thread_parker, GC_nacl_gc_thread_self, -GC_nacl_thread_parked, GC_nacl_thread_used, -GC_nacl_thread_parking_inited, GC_nacl_thread_alloc_lock): New -variable (fo NaCl only). -* pthread_stop_world.c (GC_remove_allowed_signals, -suspend_handler_mask, GC_stop_count, GC_world_is_stopped, -GC_retry_signals, SIG_THR_RESTART, GC_suspend_ack_sem, -GC_restart_ack_sem, GC_suspend_handler_inner, GC_suspend_handler, -GC_restart_handler): Don't define for NaCl. -* pthread_support.c (GC_get_nprocs): Likewise. -* include/private/gc_priv.h (SIG_SUSPEND): Likewise. -* include/private/gcconfig.h (LINUX): Likewise. -* pthread_stop_world.c (GC_push_all_stacks): Push register storage -for NaCl. -* pthread_stop_world.c (GC_suspend_all, GC_stop_world, -GC_start_world): Implement for NaCl. -* pthread_stop_world.c (GC_stop_world): Don't define unused "i" -local variable for OpenBSD (and NaCl). -* pthread_stop_world.c (NACL_STORE_REGS): New macro definition for -NaCl. -* pthread_stop_world.c (nacl_pre_syscall_hook, -__nacl_suspend_thread_if_needed, nacl_post_syscall_hook, -GC_nacl_initialize_gc_thread, GC_nacl_shutdown_gc_thread): New -function (for NaCl only). -* pthread_stop_world.c (GC_stop_init): Empty for NaCl. -* pthread_support.c (pthread_cancel, pthread_sigmask): Don't -redirect for NaCl. -* include/gc_pthread_redirects.h (pthread_cancel, -pthread_sigmask): Likewise. -* pthread_support.c (GC_nacl_initialize_gc_thread, -GC_nacl_shutdown_gc_thread): New internal prototype (NaCl only). -* pthread_support.c (GC_new_thread, GC_delete_thread): Initialize -and shutdown thread for NaCl. -* pthread_support.c (GC_thr_init): Call sysconf for NaCl. -* pthread_support.c (GC_pthread_exit): Call GC_thread_exit_proc -for NaCl. -* include/gc.h: Don't include features.h for NaCl. -* include/gc_pthread_redirects.h (GC_PTHREAD_CONST): New macro. -* include/gc_pthread_redirects.h (GC_pthread_create): Use -GC_PTHREAD_CONST instead of const. -* win32_threads.c (GC_pthread_create): Likewise. -* pthread_support.c (GC_pthread_create_t, GC_pthread_create, -pthread_create): Likewise. -* include/private/gcconfig.h (NACL): Recognize NaCl. -* include/private/gcconfig.h (GC_LINUX_THREADS): Valid for NaCl. -* include/private/pthread_stop_world.h (thread_stop_info): Add -reg_storage member; define NACL_GC_REG_STORAGE_SIZE macro (for -NaCl only). -* include/private/pthread_support.h (GC_nacl_gc_thread_self): -Declare internal variable (for NaCl only). - -* mach_dep.c (GC_with_callee_saves_pushed): Fix FE_ALL_EXCEPT -macro. - -* mark.c (GC_mark_some): Prefix and suffix "asm" and "volatile" -keywords with double underscore. -* os_dep.c (catch_exception_raise, catch_exception_raise_state, -catch_exception_raise_state_identity): Add GC_API_OSCALL to -function definition. -* os_dep.c (catch_exception_raise_state, -catch_exception_raise_state_identity): Move definition to be -before GC_ports. -* os_dep.c (catch_exception_raise): Declare to have the symbol -defined before GC_ports. -* os_dep.c (GC_ports): Store references to catch_exception_raise, -catch_exception_raise_state, catch_exception_raise_state_identity -(to prevent stripping these symbols as dead). -* os_dep.c (catch_exception_raise, catch_exception_raise_state, -catch_exception_raise_state_identity): Mark these symbols as -"referenced dynamically" via an assembler directive (unless -NO_DESC_CATCH_EXCEPTION_RAISE). -* include/private/gc_priv.h (GC_API_OSCALL): New macro (defined -similar to GC_API but as if GC_DLL is always defined). - -* os_dep.c: Don't include signal.h for GC_write_fault_handler on -Win32. -* os_dep.c (SIG_OK): Don't return true unless SIGSEGV or SIGBUS on -FreeBSD. -* os_dep.c (CODE_OK): Use SEGV_ACCERR on FreeBSD (define -SEGV_ACCERR for older FreeBSD releases). - -* dyn_load.c (GC_register_map_entries, -GC_register_dynamic_libraries_dl_iterate_phdr): Calculate -DATASTART only once if DATASTART_IS_FUNC. -* dyn_load.c (GC_register_dynamic_libraries_dl_iterate_phdr): -Calculate DATAEND only once if DATAEND_IS_FUNC. -* dyn_load.c: Add comment to some endif; realign some code. -* dyn_load.c (GC_init_dyld): Don't use -_dyld_bind_fully_image_containing_address if -NO_DYLD_BIND_FULLY_IMAGE defined; add FIXME. -* include/private/gcconfig.h (GC_data_start, GC_find_limit): -Declare if used by DATASTART/DATAEND, respectively. -* include/private/gcconfig.h (DATASTART_IS_FUNC, DATAEND_IS_FUNC): -Define if DATASTART/DATAEND is a function, respectively. -* include/private/gcconfig.h (GETPAGESIZE, NO_PTHREAD_TRYLOCK, -NO_DYLD_BIND_FULLY_IMAGE): Define for Darwin/arm as well; include -unistd.h. - -* os_dep.c (GC_setpagesize, GC_task_self, PROTECT, UNPROTECT): -Reorder to remove redundant ifdef for Win32. -* os_dep.c: Add comment to some endif. -* os_dep.c: Include pthread.h (for Linux even if single-threaded) -if USE_GET_STACKBASE_FOR_MAIN; also include it for Darwin. -* os_dep.c (STACKBOTTOM): Redefine for Darwin (unless prohibited -for some reason). -* os_dep.c (GC_get_main_stack_base): Allow -USE_GET_STACKBASE_FOR_MAIN for Linux even if single-threaded; add -assertion for the returned result. -* os_dep.c (GC_get_stack_base): Define for Darwin if -multi-threaded. -* os_dep.c (SIG_OK, CODE_OK): Add comment (for FreeBSD). -* os_dep.c (ID_STOP, ID_RESUME): Define only if threads. -* os_dep.c (catch_exception_raise): Remove redundant parentheses; -refine the documentation. - -* NT_MAKEFILE: Define _CRT_SECURE_NO_DEPRECATE for C++ files as -well. -* NT_STATIC_THREADS_MAKEFILE: Likewise. -* doc/README.macros (USE_GET_STACKBASE_FOR_MAIN): Refine. -* include/gc.h (GC_INIT): Document. -* include/private/gc_priv.h (GC_MACH_HEADER, GC_MACH_SECTION, -GC_GETSECTBYNAME): Define depending only on the word size (i.e., -define these macros also for ARM). -* tests/test.c (check_heap_stats): Print main thread stack bottom -as well (only if verbose mode is on). - -* mach_dep.c (GC_with_callee_saves_pushed): Fix and improve code -introduced by the previous patch (if GETCONTEXT_FPU_EXCMASK_BUG -and X86_64). - -* darwin_stop_world.c (GC_FindTopOfStack): Prefix and suffix -"volatile" keyword with double underscore. -* mach_dep.c (GETCONTEXT_FPU_EXCMASK_BUG): Recognize new macro and -include fenv.h if defined (unless NO_GETCONTEXT or HAVE_PUSH_REGS). -* mach_dep.c (GC_with_callee_saves_pushed): Restore FPU exception -mask corrupted by getcontext if GETCONTEXT_FPU_EXCMASK_BUG. -* include/private/gcconfig.h (GETCONTEXT_FPU_EXCMASK_BUG): Define -for Linux/amd64 (since its GLibc getcontext currently has the bug). - -* allchblk.c (GC_use_entire_heap): Change type to int (as declared -in gc.h); set the default value depending on new GC_USE_ENTIRE_HEAP -macro. -* misc.c (GC_init): Test GC_USE_ENTIRE_HEAP environment variable to -alter the default value of GC_use_entire_heap. -* doc/README.environment (GC_USE_ENTIRE_HEAP): Document. -* doc/README.macros (GC_USE_ENTIRE_HEAP): Likewise. - -* include/private/gcconfig.h (PARALLEL_MARK): Do not make it cause -MPROTECT_VDB undefining. - -* include/private/gcconfig.h (DYNAMIC_LOADING): Fix filename in -the comment. - -* include/private/gc_priv.h (_GC_arrays): Move the conditional -macro definitions (shortcuts for GC_arrays members) into the -structure body. - -* darwin_stop_world.c (GC_mach_handler_thread, -GC_use_mach_handler_thread, -GC_darwin_register_mach_handler_thread): Define only if -MPROTECT_VDB. -* darwin_stop_world.c (GC_suspend_thread_list): Use -GC_mach_handler_thread and GC_use_mach_handler_thread only if -MPROTECT_VDB. -* darwin_stop_world.c (GC_stop_world): Reset GC_mach_threads_count -only if defined (i.e. unless GC_NO_THREADS_DISCOVERY). -* misc.c (GC_init): Fix comment for GWW_VDB. -* os_dep.c (DARWIN_EXC_STATE, DARWIN_EXC_STATE_COUNT, -DARWIN_EXC_STATE_T, DARWIN_EXC_STATE_DAR): New macros. -* os_dep.c (catch_exception_raise): Use DARWIN_EXC_STATE, -DARWIN_EXC_STATE_COUNT, DARWIN_EXC_STATE_T, DARWIN_EXC_STATE_DAR. -* pthread_support.c (GC_thr_init): Define "dummy" local variable -only unless GC_DARWIN_THREADS. -* include/private/gcconfig.h (MPROTECT_VDB): Define for Darwin -even in the single-threaded mode; define for iPhone/iPad. -* include/private/gcconfig.h (IA64): Remove unnecessary "ifdef" -around "undef". -* include/private/gcconfig.h (HEURISTIC1): Remove unused for -Cygwin. -* include/private/gcconfig.h (STACKBOTTOM): Use fixed address for -Darwin/arm (instead of HEURISTIC1). - -* misc.c (GC_write): Replace multiple "ifdef/endif" with "elif" -(for ECOS and NOSYS). -* os_dep.c (GC_get_main_stack_base): Likewise. -* os_dep.c (GC_get_main_stack_base): Check -USE_GET_STACKBASE_FOR_MAIN macro before checking STACKBOTTOM one; -remove "dummy" variable (use result one instead). -* doc/README.macros (SN_TARGET_PS3): Document. -* extra/threadlibs.c (main): Don't output "-lpthread" (and "-ldl") -for Android. -* include/private/pthread_support.h: Fix comment for "endif". - -* misc.c (GC_allocate_ml): Define global variable if SN_TARGET_PS3. -* misc.c (GC_init): Initialize GC_allocate_ml if SN_TARGET_PS3. -* os_dep.c (SIGSEGV): Define to dummy zero if SN_TARGET_PS3. -* os_dep.c (GC_unix_mmap_get_mem): Don't define if SN_TARGET_PS3. -* os_dep.c (GC_default_push_other_roots, -GC_push_thread_structures): Define for SN_TARGET_PS3. -* include/private/gc_locks.h (GC_allocate_ml, LOCK, UNLOCK): Define -for SN_TARGET_PS3. -* include/private/gcconfig.h (SN_TARGET_PS3): Recognize new macro -(Sony PS/3 target). -* include/private/gcconfig.h (THREADS): Define unconditionally if -SN_TARGET_PS3. -* include/private/gcconfig.h (GET_MEM): Define for SN_TARGET_PS3. - -* alloc.c (GC_collect_or_expand): Replace NIL with NULL in message. -* dbg_mlc.c (GC_debug_malloc, GC_debug_malloc_ignore_off_page, -GC_debug_malloc_atomic_ignore_off_page, -GC_debug_generic_malloc_inner, -GC_generic_malloc_inner_ignore_off_page, GC_debug_malloc_stubborn, -GC_debug_malloc_atomic, GC_debug_malloc_uncollectable, -GC_debug_malloc_atomic_uncollectable): Likewise. -* gcj_mlc.c (GC_debug_gcj_malloc): Likewise. -* dbg_mlc.c (GC_check_annotated_obj): Replace NIL with NULL in a -comment. -* dyn_load.c (GC_FirstDLOpenedLinkMap): Likewise. -* mark_rts.c (GC_roots_present): Likewise. -* doc/README: Likewise. -* include/private/gc_hdrs.h (IS_FORWARDING_ADDR_OR_NIL): Likewise. -* include/private/gc_priv.h (_GC_arrays): Likewise. - -* configure.ac: Use AC_CHECK_LIB() to check for pthread instead of -just blindly linking to -lpthread, as Android includes pthread -support within libc and does not provide a separate libpthread. -* dyn_load.c (GC_register_dynamic_libraries): Skip current link map -entry if l_addr is NULL (Android/bionic only). -* pthread_stop_world.c (android_thread_kill): New internal function -(Android only). -* pthread_stop_world.c (GC_suspend_all, GC_start_world): Call -android_thread_kill (based on tkill) instead of pthread_kill on -Android (since pthread_kill cannot be used safely on the platform). -* pthread_support.c (GC_new_thread): Store thread Id (obtained from -gettid) for use by android_thread_kill (Android only). -* include/private/pthread_support.h (GC_Thread_Rep): Add kernel_id -structure member (Android only). -* include/private/gcconfig.h: Recognize __x86_64 macro as a synonym -of __x86_64__ (Darwin); define __environ macro (Android on M68K). - -* allchblk.c (GC_freehblk): Print extended error message (done via -GC_printf() before aborting with a short message) only if -GC_print_stats. -* dyn_load.c (GC_register_dynamic_libraries): Likewise. -* os_dep.c (GC_get_maps, GC_register_data_segments, GC_remap, -PROTECT, GC_write_fault_handler, GC_mprotect_thread): Likewise. -* pthread_stop_world.c (GC_start_world): Likewise. -* win32_threads.c (GC_register_my_thread_inner): Likewise. -* os_dep.c (GC_get_main_stack_base, GC_register_data_segments, -GC_dirty_init): Remove redundant print of an error message before -aborting with the same message. -* os_dep.c (GC_register_data_segments): Remove format specifier -from the string passed to GC_err_puts(); use ABORT instead of EXIT -(if invalid executable type). -* os_dep.c (GC_remap): Adjust printf format specifier (for long -type). -* os_dep.c (GC_dirty_init): Print a message about SIG_IGN detected -(for SIGSEGV/BUS) only if GC_print_stats. -* os_dep.c (catch_exception_raise): Join 2 adjacent GC_err_printf -calls. - -* tests/test.c (main): Print the relevant message if GWW_VDB. -* include/private/gcconfig.h: Don't define MPROTECT_VDB for Win32 -on x64 if compiled by GCC. - -* tests/staticrootstest.c: Include string.h for memset() prototype. -* tests/thread_leak_test.c (main): Fix printf() format specifiers. - -* CMakeLists.txt: Check enable_parallel_mark on Darwin. -* configure.ac: Likewise. -* darwin_stop_world.c (DARWIN_SUSPEND_GC_THREADS, -DARWIN_QUERY_TASK_THREADS): Rename to GC_NO_THREADS_DISCOVERY and -GC_DISCOVER_TASK_THREADS, respectively. -* os_dep.c (DARWIN_SUSPEND_GC_THREADS): Likewise. -* pthread_support.c (DARWIN_SUSPEND_GC_THREADS): Likewise. -* darwin_stop_world.c (DARWIN_QUERY_TASK_THREADS): Don't define -(and remove FIXME). -* darwin_stop_world.c (GC_use_threads_discovery): Add GC_API; -comment; remove FIXME. -* win32_threads.c (GC_NO_DLLMAIN): Rename to -GC_NO_THREADS_DISCOVERY. -* tests/test.c (GC_NO_DLLMAIN): Likewise. -* doc/README.macros (GC_NO_DLLMAIN): Likewise. -* doc/README.win32 (GC_NO_DLLMAIN): Likewise. -* doc/README.macros (GC_NO_THREADS_DISCOVERY): Update the comment. -* win32_threads.c (GC_win32_dll_threads): Define as macro to true -if GC_DISCOVER_TASK_THREADS (and not GC_NO_THREADS_DISCOVERY); -update the comment. -* win32_threads.c (GC_use_DllMain): Rename to -GC_use_threads_discovery; do not set GC_win32_dll_threads if -GC_DISCOVER_TASK_THREADS. -* win32_threads.c (GC_started_thread_while_stopped, -GC_lookup_thread_inner, UNPROTECT_THREAD, GC_lookup_pthread, -GC_thr_init, GC_pthread_create, DllMain): Rewrite some expressions -which use GC_win32_dll_threads to minimize the possibility of -an "unreachable code" compiler warning when GC_win32_dll_threads -is defined as a macro. -* win32_threads.c (GC_unregister_my_thread): Don't call -GC_delete_thread() if GC_win32_dll_threads and THREAD_LOCAL_ALLOC -(since can't happen); use "t" local variable only if not -GC_win32_dll_threads. -* doc/README.macros (GC_DISCOVER_TASK_THREADS): Document. -* include/gc.h (GC_use_DllMain): Rename to -GC_use_threads_discovery but keep old name as a macro definition. -* include/gc.h (GC_use_threads_discovery): Declare also for -Darwin; update the comment. -* tests/test.c (main): Call GC_use_threads_discovery for Darwin -(to test the mode if possible). - -* darwin_stop_world.c (DARWIN_SUSPEND_GC_THREADS, -DARWIN_QUERY_TASK_THREADS): New macro recognized. -* darwin_stop_world.c (GC_query_task_threads): add STATIC; -initialize to false; define as macro if DARWIN_SUSPEND_GC_THREADS -or DARWIN_QUERY_TASK_THREADS; remove FIXME. -* darwin_stop_world.c (GC_use_threads_discovery): New function -(for setting GC_query_task_threads value). -* darwin_stop_world.c (GC_mach_handler_thread, -GC_use_mach_handler_thread, GC_mach_thread, GC_MAX_MACH_THREADS, -GC_mach_threads, GC_mach_threads_count, GC_suspend_thread_list, -GC_darwin_register_mach_handler_thread): Define only if not -DARWIN_SUSPEND_GC_THREADS. -* darwin_stop_world.c (GC_stop_world, GC_start_world): Exclude -the code for GC_query_task_threads case from compilation unless -DARWIN_SUSPEND_GC_THREADS. -* os_dep.c (GC_darwin_register_mach_handler_thread): Declared only -if Darwin threads and not DARWIN_SUSPEND_GC_THREADS. -* os_dep.c (GC_mprotect_thread): Call -GC_darwin_register_mach_handler_thread only if THREADS and not -DARWIN_SUSPEND_GC_THREADS. -* pthread_support.c (marker_mach_threads): Don't define if -DARWIN_SUSPEND_GC_THREADS. -* pthread_support.c (GC_mark_thread): Don't fill in -marker_mach_threads if DARWIN_SUSPEND_GC_THREADS. -* include/private/gc_locks.h (GC_need_to_lock): Always declare for -THREADS case. - -* darwin_stop_world.c (GC_query_task_threads): Don't define to -false for DARWIN_DONT_PARSE_STACK case; unconditionally initialize -the variable to false (for now). -* darwin_stop_world.c (GC_push_all_stacks): Call task_threads() -only if not DARWIN_DONT_PARSE_STACK. -* darwin_stop_world.c (GC_stop_world, GC_start_world): Use the -approach based on task_threads() only if GC_query_task_threads -else use GC_threads table. - -* darwin_stop_world.c (GC_mach_threads): Remove static qualifier. -* darwin_stop_world.c (GC_stop_init): Remove (as we do not need to -really clear GC_mach_threads[]). -* darwin_stop_world.c (GC_stop_world): Reset GC_mach_threads_count -(instead of calling GC_stop_init). -* include/private/pthread_support.h (GC_stop_init): Remove proto. -* pthread_support.c (GC_stop_init): Add proto (unless Darwin). -* pthread_support.c (GC_thr_init): Don't call GC_stop_init() if -GC_DARWIN_THREADS. - -* darwin_stop_world.c (GC_stack_range_for): New static function -(move the code from GC_push_all_stacks). -* darwin_stop_world.c (GC_push_all_stacks): Call -GC_stack_range_for(); rename kern_return local variable to -kern_result. -* darwin_stop_world.c (GC_is_mach_marker): Change argument type -from mach_port_t to thread_act_t. -* pthread_support.c (GC_is_mach_marker): Likewise. - -* darwin_stop_world.c (GC_push_all_stacks): Fix "my_task" local -variable initialization (always call current_task()). -* pthread_support.c (GC_thr_init, GC_register_my_thread_inner): -Don't set thread's stop_info.stack_ptr value for Darwin. -* include/private/darwin_stop_world.h (thread_stop_info): Update -the comment for stack_ptr. - -* darwin_stop_world.c (GC_push_all_stacks): Rename "r", "me" local -variables to "kern_return" and "my_thread" ones, respectively; -call mach_port_deallocate() unconditionally. -* darwin_stop_world.c (GC_stop_world): Don't call mach_thread_self -if DEBUG_THREADS. - -* darwin_stop_world.c (GC_mach_thread): Move from -darwin_stop_world.h. -* include/private/darwin_stop_world.h (GC_mach_thread): Remove. -* win32_threads.c (GC_start_world): Define "thread_id" local -variable only if GC_ASSERTIONS; decide whether to resume a thread -based on its "suspended" field value; assert that suspended thread -stack_base is non-zero and the thread is not our one. - -* darwin_stop_world.c (GC_thread_resume): New inline function -(move code from GC_thread_resume). -* darwin_stop_world.c (GC_start_world): Check result of -task_threads(); call GC_thread_resume(). -* os_dep.c (GC_malloc_heap_l, GC_is_malloc_heap_base): Define -only if not CYGWIN32. -* os_dep.c (GC_is_heap_base): Call GC_is_malloc_heap_base() only -if not CYGWIN32. - -* darwin_stop_world.c (FindTopOfStack): Change return type to -ptr_t (from long); make GC_INNER; add GC_ prefix. -* darwin_stop_world.c (GC_push_all_stacks): Add thread_blocked -local variable (initialized from the corresponding GC_thread -field unless GC_query_task_threads); add assertion that our -thread is not blocked; prefix FindTopOfStack with GC_ and remove -no longer needed cast to ptr_t of the result; handle thread -blocked case (and remove FIXME); use GC_push_all_stack_sections -unless GC_query_task_threads (and remove FIXME). -* pthread_support.c (GC_FindTopOfStack): Declare (if needed). -* pthread_support.c (GC_do_blocking_inner): Call -GC_save_regs_in_stack (if needed) before acquiring the lock. -* win32_threads.c (GC_do_blocking_inner): Likewise. -* pthread_support.c (GC_do_blocking_inner): Set/clear topOfStack -field of GC_thread (Darwin only). -* include/private/pthread_support.h (GC_thread): Add topOfStack -field for Darwin (unless DARWIN_DONT_PARSE_STACK). - -* finalize.c (GC_check_finalizer_nested): Change return type to -char pointer (instead of int pointer); use explicit cast for -GC_finalizer_nested assignment. -* pthread_support.c (GC_check_finalizer_nested): Likewise. -* win32_threads.c (GC_check_finalizer_nested): Likewise. -* finalize.c (GC_finalizer_nested): Change type to unsigned char. -* finalize.c (GC_notify_or_invoke_finalizers): Change type of -"pnested" local variable to char pointer. -* pthread_support.c (GC_do_blocking_inner, -GC_call_with_gc_active): Use explicit cast for "thread_blocked" -field assignment. -* win32_threads.c (GC_lookup_pthread): Use explicit cast for -"suspended" field assignment. -* win32_threads.c (GC_Thread_Rep): Use short type for -finalizer_skipped; use char type for finalizer_nested and flags -fields and reorder some fields (to minimize GC_Thread_Rep -structure size). -* include/private/pthread_support.h (GC_Thread_Rep): Likewise. -* win32_threads.c (GC_Thread_Rep): Use char type for suspended -field (instead of GC_bool). -* include/private/pthread_support.h (GC_Thread_Rep): Use char type -for thread_blocked field (instead of short). - -* darwin_stop_world.c (GC_query_task_threads): New variable (or -macro). -* darwin_stop_world.c (GC_push_all_stacks): Use -GC_query_task_threads (to choose between algorithms based on -kernel task_threads and based on GC_threads table); update FIXME; -remove commented out GC_push_one statements. -* pthread_support.c (GC_thr_init, GC_do_blocking_inner, -GC_call_with_gc_active, GC_register_my_thread_inner): Initialize -stack_ptr field for all platforms. -* pthread_support.c (GC_call_with_gc_active): Initialize -saved_stack_ptr field for all platforms. -* include/private/darwin_stop_world.h (thread_stop_info): Add -stack_ptr field; change type of already_suspended from int to -GC_bool. - -* darwin_stop_world.c (GC_MAX_MACH_THREADS): New macro. -* darwin_stop_world.c (GC_mach_threads, GC_stop_init): Use -GC_MAX_MACH_THREADS instead of THREAD_TABLE_SZ. -* darwin_stop_world.c (GC_mach_threads): Add FIXME. -* darwin_stop_world.c (GC_stop_init, GC_suspend_thread_list, -GC_stop_world): Use FALSE and TRUE for already_suspended field and -"changed", "found" variables. -* darwin_stop_world.c (GC_is_mach_marker): New prototype (only if -PARALLEL_MARK). -* darwin_stop_world.c (GC_suspend_thread_list): Change return type -to GC_bool; change type of "changed", "found" to GC_bool; make -"my_thread" as an argument (instead of acquiring/deallocating it -locally); do not add my_thread, GC_mach_handler_thread and marker -threads to GC_mach_threads table; check for overflow of -GC_mach_threads table; increase GC_mach_threads_count if "found" -is true and info.suspend_count is non-zero. -* darwin_stop_world.c (GC_suspend_thread_list, GC_start_world): -Adjust "thread" format specifiers for GC_printf(); search thread -in "old_list" starting from the previous found one. -* darwin_stop_world.c (GC_stop_world): Rename "changes" to -"changed" local variable; remove "result" variable; adjust -GC_printf debugging message. -* darwin_stop_world.c (GC_start_world): Do not check for -my_thread and GC_use_mach_handler_thread (since they are not added -to GC_mach_threads table); call thread_info() only if -DEBUG_THREADS or GC_ASSERTIONS. -* pthread_support.c (marker_mach_threads): New static variable (if -Darwin). -* pthread_support.c (GC_is_mach_marker): New function (if Darwin). -* pthread_support.c (GC_mark_thread): Fill in marker_mach_threads -table (if Darwin). - -* alloc.c (GC_parallel): Define only if THREADS. -* misc.c (GC_get_parallel): Likewise. -* include/gc.h (GC_parallel, GC_get_parallel, -GC_get_suspend_signal, GC_allow_register_threads, -GC_register_my_thread, GC_unregister_my_thread): Define only if -GC_THREADS. -* include/gc.h (GC_get_heap_size): Fix a typo in a comment. - -* configure.ac: Use `AC_C_INLINE'. -* include/private/gc_priv.h (GC_INLINE): Use "inline" keyword -(determined by configure AC_C_INLINE) if HAVE_CONFIG_H is defined. - -* dyn_load.c (DL_ITERATE_PHDR_STRONG): New macro (define for -FreeBSD). -* dyn_load.c (GC_register_main_static_data): Move the definition -above GC_register_dynamic_libraries_dl_iterate_phdr one (FreeBSD -case); unconditionally return FALSE if DL_ITERATE_PHDR_STRONG. -* dyn_load.c (GC_register_dynamic_libraries_dl_iterate_phdr): Test -GC_register_main_static_data() result (instead of direct testing -of dl_iterate_phdr (to prevent a compiler warning). -* os_dep.c (CODE_OK): Test si_code also for the value of 2 -(FreeBSD case; required for FreeBSD v7+). -* os_dep.c (CODE_OK): Properly use parentheses (HPUX case). -* include/private/gcconfig.h (DATASTART): Cast etext argument in -GC_FreeBSDGetDataStart() call; remove unnecessary "&" (FreeBSD -case). - -* include/private/specific.h (quick_thread_id): Define thru -GC_approx_sp(); define as a macro. -* include/private/specific.h (getspecific): Use GC_INLINE instead -of __inline__ (to work around Sun CC which does not recognize -inline keyword surrounded with underscores). - -* darwin_stop_world.c (FindTopOfStack): Simplify condition -expressions. -* darwin_stop_world.c (GC_push_all_stacks): Merge two variants -of this function (DARWIN_DONT_PARSE_STACK). -* darwin_stop_world.c (GC_push_all_stacks): Add a check for our -thread is found (same as in pthread_stop_world.c). -* darwin_stop_world.c (GC_push_all_stacks): Print the number of -scanned threads if verbose (same as in pthread_stop_world.c). - -* darwin_stop_world.c (GC_push_all_stacks): Reset -thread_state_count value before every thread_get_state call; -refine the comment for thread_state_count. -* darwin_stop_world.c (GC_push_all_stacks): Ignore rsp, rip/eip, -rflags, cs, fs, gs, ss, ds, es, __pc registers; uncomment ebp -register pushing. -* darwin_stop_world.c (GC_push_all_stacks): Set outCount to -GC_MACH_THREAD_STATE_COUNT (instead of THREAD_STATE_MAX). -* darwin_stop_world.c (GC_push_all_stacks): Remove FIXME and WARN -for i386. - -* doc/README.macros (DARWIN_DONT_PARSE_STACK): Fix a typo. -* darwin_stop_world.c (GC_use_mach_handler_thread): Change type -to GC_bool. -* darwin_stop_world.c (GC_suspend_thread_list, GC_start_world): -Simplify the expressions involving GC_use_mach_handler_thread. -* darwin_stop_world.c (GC_darwin_register_mach_handler_thread): -Initialize GC_use_mach_handler_thread to TRUE (instead of 1). - -* include/gc_pthread_redirects.h (GC_pthread_sigmask, GC_dlopen, -pthread_sigmask, dlopen): Don't define for Win32 pthreads (and -don't include signal.h and dlfcn.h). - -* dyn_load.c (GC_register_dynlib_callback): Add FIXME. - -* include/private/gcconfig.h: Add support for FreeBSD on ppc64. - -* os_dep.c (PROTECT, UNPROTECT): Correct VM_PROT_EXEC to -VM_PROT_EXECUTE. - -* os_dep.c (os2_alloc): Don't set PAG_EXECUTE unless -pages_executable is on. -* os_dep.c (os2_alloc): Add FIXME (for recursion). -* os_dep.c (UNPROTECT): Abort with a more informative message if -pages_executable is on ("mprotect" case). -* os_dep.c (PROTECT, UNPROTECT): Set VM_PROT_EXEC if -pages_executable is on (Darwin case). -* pthread_support.c (GC_init_real_syms): Abort with an informative -message if libgc is linked after libpthread. - -* dyn_load.c (GC_register_dynlib_callback): Adjust "start" pointer -for 64-bit targets. -* pthread_support.c (start_mark_threads): Expand PTHREAD_CREATE -macro. -* pthread_support.c (start_mark_threads): Call INIT_REAL_SYMS() -since REAL(pthread_create) is used. -* pthread_support.c (PTHREAD_CREATE): Remove unused. - -* extra/threadlibs.c (main): Remove --wrap for "read" (since not -wrapped anymore). -* doc/README.linux (GC_USE_LD_WRAP): Likewise. -* os_dep.c (__wrap_read): Likewise. - -* include/gc_pthread_redirects.h: Test GC_PTHREADS and GC_H at the -beginning of the file. -* include/gc_pthread_redirects.h (GC_PTHREAD_EXIT_ATTRIBUTE): New -macro (defined only for Linux and Solaris). -* include/gc_pthread_redirects.h (GC_pthread_cancel, -GC_pthread_exit): Declare new API function (only if -GC_PTHREAD_EXIT_ATTRIBUTE). -* include/gc_pthread_redirects.h (pthread_cancel, pthread_exit): -Redirect (if GC_PTHREAD_EXIT_ATTRIBUTE). -* include/private/pthread_support.h (DISABLED_GC): New macro. -* pthread_support.c (pthread_cancel, pthread_exit): Restore -original definition or declare "real" function (if needed and -GC_PTHREAD_EXIT_ATTRIBUTE). -* pthread_support.c (GC_pthread_cancel_t, GC_pthread_exit_t): -Declare new types if needed. -* pthread_support.c (GC_pthread_cancel, GC_pthread_exit): New -function definition (only if GC_PTHREAD_EXIT_ATTRIBUTE). -* pthread_support.c (GC_init_real_syms): Initialize pointers to -the "real" pthread_cancel and pthread_exit (only if -GC_PTHREAD_EXIT_ATTRIBUTE). -* pthread_support.c (GC_unregister_my_thread): Enable collections -if DISABLED_GC was set (only if GC_PTHREAD_EXIT_ATTRIBUTE). -* pthread_support.c (pthread_cancel, pthread_exit): New wrapped -function definition (only if GC_PTHREAD_EXIT_ATTRIBUTE defined). -* pthread_support.c (GC_start_routine): Refine the comment. -* extra/threadlibs.c (main): Adjust --wrap (add "read", -"pthread_exit", "pthread_cancel" but remove "sleep"). -* doc/README.linux (GC_USE_LD_WRAP): Likewise. - -* include/gc.h (GC_MALLOC_STUBBORN): Remove trailing ';' in the -macro definition. -* include/gc.h (GC_reachable_here): Likewise. -* include/gc.h (GC_reachable_here): Prefix and postfix "volatile" -with double '_'. - -* pthread_start.c: New file. -* CMakeLists.txt (SRC): Add pthread_start.c. -* Makefile.am (libgc_la_SOURCES): Likewise. -* Makefile.direct (CSRCS): Likewise. -* Makefile.direct (OBJS): Add pthread_start.obj. -* extra/gc.c: Add a comment; include pthread_start.c. -* pthread_support.c (start_info): Move the struct definition down -closer to its usage. -* pthread_support.c (GC_thread_exit_proc): Replace STATIC with -GC_INNER. -* pthread_support.c (GC_inner_start_routine): Move to the -definition to pthread_start.c; leave only the prototype; remove -STATIC. -* pthread_support.c (GC_start_rtn_prepare_thread): New function -(contains parts of the original GC_inner_start_routine). - -* configure.ac (NO_EXECUTE_PERMISSION): Add comment. -* doc/README.macros (NO_EXECUTE_PERMISSION): Update the -documentation. -* include/gc.h (GC_set_pages_executable, GC_get_pages_executable): -New API function declaration. -* os_dep.c (OPT_PROT_EXEC): Remove (superseded by -pages_executable). -* os_dep.c (pages_executable): New static variable. -* os_dep.c (IGNORE_PAGES_EXECUTABLE): New macro (used by -GC_get_pages_executable only). -* os_dep.c (GC_unix_mmap_get_mem, GC_remap, PROTECT, UNPROTECT): -Replace OPT_PROT_EXEC with pages_executable. -* os_dep.c (GC_unix_mmap_get_mem, GC_remap, GC_win32_get_mem, -GC_wince_get_mem, UNPROTECT): Undefine IGNORE_PAGES_EXECUTABLE. -* os_dep.c (GC_win32_get_mem, GC_wince_get_mem, GC_remap, PROTECT, -UNPROTECT): Use PAGE_EXECUTE_... only if pages_executable is on. -* os_dep.c (GC_set_pages_executable, GC_get_pages_executable): New -API function definition. - -* tests/test.c (check_heap_stats): Increase max_heap_sz by 20% for -64-bit CPUs (to prevent "Unexpected heap growth" failure on Win64, -at least). - -* tests/test.c (check_heap_stats): Increase max_heap_sz by 25% for -32-bit CPUs (to prevent "Unexpected heap growth" failure). - -* gc_dlopen.c (dlopen): Prototype REAL_DLFUNC if GC_USE_LD_WRAP. -* pthread_support.c (pthread_create, pthread_join, pthread_detach, -pthread_sigmask): Likewise. -* gc_dlopen.c (dlopen): Remove cast (redundant since the prototype -is added). -* gc_dlopen.c (GC_dlopen): Fix return type. -* pthread_support.c (GC_init_real_syms): Don't define -LIBPTHREAD_NAME, LIBPTHREAD_NAME_LEN, len, namebuf and -libpthread_name if RTLD_NEXT. - -* gc_dlopen.c (disable_gc_for_dlopen): Update the comment. -* gc_dlopen.c (dlopen): Likewise. -* include/gc.h (GC_enable_incremental): Refine the comment. -* include/gc.h (DECLSPEC_NORETURN): Define macro as empty if -missing (only for Win32). -* include/gc.h (GC_ExitThread): Use DECLSPEC_NORETURN. -* win32_threads.c (GC_ExitThread): Likewise. -* include/gc.h (GC_endthreadex): Add a comment. - -* include/cord.h: Fix typos. - -* Makefile.am (EXTRA_DIST): Add "CMakeLists.txt" and -"tests/CMakeLists.txt". -* doc/doc.am (dist_pkgdata_DATA): Add "doc/README.cmake". - -* mach_dep.c (NO_GETCONTEXT): Also define if AVR32. -* include/private/gcconfig.h (AVR32): New macro (also define the -supplementary macros for the target). -* include/private/thread_local_alloc (USE_COMPILER_TLS): Don't -define for AVR32. - -* tests/leak_test.c (main): Explicitly define as returning int -(to prevent a spurious test failure on some Linux/alpha targets). -* tests/thread_leak_test.c (main): Likewise. -* tests/thread_leak_test.c: Initialize GC_find_leak in the main -thread (before GC_INIT) only. -* tests/leak_test.c (main): Use GC_set_find_leak() instead of -accessing GC_find_leak directly. -* tests/thread_leak_test.c (main): Likewise. - -* include/gc.h (GC_find_leak, GC_finalize_on_demand, -GC_java_finalization, GC_dont_expand, GC_no_dls, -GC_dont_precollect): Simplify the comment (remove the information -about data races since the value is boolean). - -* os_dep.c (GC_get_stack_base, GC_get_main_stack_base): New -Solaris-specific implementation (based on thr_stksegment). -* os_dep.c (stackbase_main_self, stackbase_main_ss_sp): New static -variable used by the Solaris-specific GC_get_stack_base(). - -* pthread_support.c (GC_mark_thread_local_free_lists, -GC_check_tls): Mark (and check) only for live threads (in case of -GC_destroy_thread_local() is called already but GC_delete_thread() -is not yet). -* win32_threads.c (GC_mark_thread_local_free_lists, GC_check_tls): -Likewise. - -* NT_MAKEFILE: Remove the comment about DLL and Win32S. -* NT_STATIC_THREADS_MAKEFILE: Likewise. -* NT_X64_STATIC_THREADS_MAKEFILE: Likewise. -* NT_MAKEFILE: Add ".SUFFIXES" directive (to handle gc_cpp.cc -properly on VS 2005+). -* NT_MAKEFILE: Update GC log file name in comments. -* NT_STATIC_THREADS_MAKEFILE: Likewise. -* NT_X64_STATIC_THREADS_MAKEFILE: Likewise. -* NT_X64_THREADS_MAKEFILE: Likewise. -* doc/README.win32: Likewise. -* NT_MAKEFILE: Remove ":full" for "-debug" option (since no -longer supported by VS). -* NT_STATIC_THREADS_MAKEFILE: Likewise. -* NT_MAKEFILE: Commented out copying of gc_cpp.cc to gc_cpp.cpp. -* NT_STATIC_THREADS_MAKEFILE: Likewise. -* NT_X64_STATIC_THREADS_MAKEFILE: Likewise. -* NT_X64_THREADS_MAKEFILE: Likewise. -* NT_STATIC_THREADS_MAKEFILE: Add -D PARALLEL_MARK option. -* NT_STATIC_THREADS_MAKEFILE: Increase stack size for gctest.exe. -* NT_X64_STATIC_THREADS_MAKEFILE: Remove "-stack" option (use the -default stack size limit). -* NT_X64_THREADS_MAKEFILE: Rename "gc64_dll.dll" to "gc64.dll". -* win32_threads.c (GC_get_next_stack): Always define (since it is -also used for Cygwin now). - -* alloc.c (GC_maybe_gc): Move GC_notify_full_gc() call upper to -be just before GC_clear_marks() call. -* include/gc_mark.h (GC_start_callback_proc): Refine the comment. - -* Makefile.am (check_LTLIBRARIES): Initialize to empty. -* tests/tests.am (TESTS, check_PROGRAMS): Add staticrootstest. -* tests/tests.am (staticrootstest_SOURCES, staticrootstest_LDADD, -libstaticrootslib_la_SOURCES, libstaticrootslib_la_LIBADD, -libstaticrootslib_la_LDFLAGS, libstaticrootslib_la_DEPENDENCIES): -Define. -* tests/tests.am (check_LTLIBRARIES): Add libstaticrootslib.la. - -* tests/staticrootstest.c: New file. -* tests/staticrootslib.c: Likewise. - -* dyn_load.c (GC_get_next_stack, GC_cond_add_roots): Define for -Cygwin as well as other win32 targets. -* dyn_load.c (GC_wnt): Define to constant true. -* dyn_load.c (GC_register_dynamic_libraries): Define for Cygwin as -well as other win32 targets. -* mark_rts.c (rt_hash, GC_roots_present, add_roots_to_index): -Don't define for Cygwin, as on other win32. -* mark_rts.c (GC_add_roots_inner, GC_clear_roots): Handle on -Cygwin as for other win32 targets. -* mark_rts.c (GC_rebuild_root_index): Don't declare on Cygwin, as -other win32. -* mark_rts.c (GC_remove_tmp_roots): Do declare on Cygwin as on -other win32. -* mark_rts.c (GC_remove_roots, GC_remove_roots_inner): Don't -declare on Cygwin as on other win32. -* mark_rts.c (GC_is_tmp_root): Do declare on Cygwin when -!NO_DEBUGGING, as on other win32 targets. -* mark_rts.c (GC_cond_register_dynamic_libraries): Handle on -Cygwin as for other win32 targets. -* os_dep.c (GC_setpagesize): Handle on Cygwin as on other win32. -* os_dep.c (GC_get_main_stack_base): Don't declare on Cygwin, as -other win32. -* os_dep.c (GC_sysinfo): Declare on Cygwin, as other win32. -* os_dep.c (GC_win32_get_mem): Declare on Cygwin, as on other -Win32, but call GC_unix_get_mem instead of GlobalAlloc. -* os_dep.c (GC_win32_free_heap): Declare on Cygwin (as empty). -* ptr_chck.c (GC_is_visible): Register dynamic libraries on Cygwin -as on other win32 platforms. -* win32_threads.c (GC_get_next_stack): Define on Cygwin as well as -for dynamic loading targets. -* include/private/gc_priv.h (GC_INNER): Don't try to use -visibility on Cygwin which does not support it. -* include/private/gc_priv.h (struct roots): Don't declare r_next -member on Cygwin as on other windows hosts. -* include/private/gc_priv.h (LOG_RT_SIZE, RT_SIZE): Don't define -likewise. -* include/private/gc_priv.h (struct _GC_arrays): Do declare -_heap_bases[] member and don't declare _root_index likewise. -* include/private/gc_priv.h (GC_heap_bases): Do define likewise. -* include/private/gc_priv.h (_SYSTEM_INFO): Do forward-declare -likewise. -* include/private/gc_priv.h (GC_sysinfo): Do declare extern -likewise. -* include/private/gcconfig.h (GC_win32_get_mem, GET_MEM): Do -prototype on Cygwin as other win32 platforms. - -* os_dep.c (GC_get_main_stack_base): Use pthread_getattr_np() and -pthread_attr_getstack() instead of GC_get_stack_base() (and check -returned stackaddr for NULL); output a warning on failure. - -* alloc.c (GC_start_call_back): Replace the definition type to -GC_start_callback_proc. -* alloc.c (GC_set_start_callback, GC_get_start_callback): New -setter/getter function. -* alloc.c (GC_try_to_collect_inner): Call GC_notify_full_gc() -unconditionally (because GC_try_to_collect_inner always does full -GC). -* include/gc_mark.h (GC_start_callback_proc): New type. -* include/gc_mark.h (GC_set_start_callback, -GC_get_start_callback): New API function declaration. - -* doc/README.macros (USE_GET_STACKBASE_FOR_MAIN): Document. -* os_dep.c (GC_get_main_stack_base): Recognize -USE_GET_STACKBASE_FOR_MAIN (only if THREADS and LINUX_STACKBOTTOM) -and use GC_get_stack_base() in this case. - -* os_dep.c (GC_get_stack_base): Add LOCK/UNLOCK() (since -GC_find_limit_with_bound() should be called with the lock held). -* backgraph.c (FOR_EACH_PRED): Fix a typo. - -* alloc.c (GC_set_stop_func, GC_get_stop_func): Add -DCL_LOCK_STATE. -* finalize.c (GC_notify_or_invoke_finalizers): Likewise. -* gc_dlopen.c (disable_gc_for_dlopen): Likewise. -* gcj_mlc.c (maybe_finalize, GC_debug_gcj_malloc): Likewise. -* mark.c (GC_print_trace): Likewise. -* misc.c (GC_set_warn_proc, GC_get_warn_proc, GC_enable, -GC_disable, GC_new_free_list, GC_new_kind, GC_new_proc, -GC_set_oom_fn, GC_get_oom_fn, GC_set_finalizer_notifier, -GC_get_finalizer_notifier): Likewise. -* os_dep.c (GC_get_stack_base, GC_print_callers): Likewise. -* pthread_support.c (GC_is_thread_tsd_valid, -GC_wait_for_gc_completion, GC_init_parallel, GC_do_blocking_inner, -GC_call_with_gc_active, GC_unregister_my_thread, pthread_join, -pthread_detach, GC_register_my_thread, GC_inner_start_routine, -pthread_create): Likewise. -* reclaim.c (GC_print_all_errors): Likewise. -* win32_threads.c (GC_is_thread_tsd_valid, GC_register_my_thread, -GC_unregister_my_thread, GC_do_blocking_inner, -GC_call_with_gc_active, GC_lookup_pthread, GC_pthread_join, -GC_pthread_start_inner, GC_thread_exit_proc, GC_pthread_detach, -GC_init_parallel): Likewise. - -* doc/README.darwin: Update. - -* CMakeLists.txt: Adjust INCLUDE_DIRECTORIES and SRC (to make it -usable on Mac OS X). -* doc/README.cmake: Update. - -* CMakeLists.txt: New file (adding CMake support). -* tests/CMakeLists.txt: Likewise. -* doc/README.cmake: Likewise. - -* configure.ac (darwin): Don't define HAS_PPC_THREAD_STATE... -macros. -* include/private/gc_priv.h (THREAD_FLD): Recognize -__DARWIN_UNIX03 instead of HAS_PPC_THREAD_STATE... macros. - -* pthread_support.c: Include and for -OpenBSD. -* pthread_support.c (get_ncpu): Define also for Darwin, NetBSD and -OpenBSD. -* pthread_support.c (GC_thr_init): Use get_ncpu() for Darwin, -NetBSD and OpenBSD. - -* mallocx.c (GC_generic_malloc_many, GC_malloc_many): Define even -if THREADS is undefined. -* include/gc.h (GC_malloc_many): Update the comment. - -* include/gc_cpp.h (GC_PLACEMENT_DELETE): Define for Embarcadero -(formerly known as Borland) C++ compiler v6.21+. -* include/gc_cpp.h (GC_NO_OPERATOR_NEW_ARRAY): Define for ancient -VC++ compilers. - -* win32_threads.c (GC_register_my_thread_inner, -GC_pthread_start_inner): Undo the previous commit changes for -the thread flags and DETACHED state (since the state is only -tested in GC_thread_exit_proc). - -* include/gc.h (GC_unregister_my_thread): Fix a typo; update the -comment. -* pthread_support.c (GC_delete_thread): Allow to delete the main -thread (don't call GC_INTERNAL_FREE for it); update the comment. -* win32_threads.c (GC_delete_thread): Likewise. -* pthread_support.c (GC_unregister_my_thread): Add an assertion -for FINISHED flag is unset. -* tests/test.c (check_heap_stats): Test the main thread -unregistering (only if THREADS). -* win32_threads.c (GC_register_my_thread_inner): Set flags to -DETACHED (only if GC_PTHREADS). -* win32_threads.c (GC_unregister_my_thread): Add FIXME (for -GC_wait_for_gc_completion). -* win32_threads.c (GC_pthread_start_inner): Clear flags detached -state if needed; set pthread_id and flags while holding the lock. - -* include/private/gc_priv.h (SIG_SUSPEND): Don't define for -OpenBSD and Darwin. - -* include/gc.h: Recognize _M_X64 (as an alias for _AMD64_). - -* test.c (main, WinMain): Consistently don't invoke -GC_enable_incremental() if MAKE_BACKGRAPH is defined, but -do invoke it even if parallel marking is enabled. - -* tests/test.c (reverse_test): Comment out a check for MSWIN32 -(when determing BIG value) assuming outdated win32S. -* tests/test.c (reverse_test): Rename to reverse_test_inner; -change the declaration (to be of GC_fn_type); call itself thru -GC_call_with_gc_active() if the argument is zero. -* tests/test.c (reverse_test): New function added calling -reverse_test_inner thru GC_do_blocking (to test GC_do_blocking and -GC_call_with_gc_active). - -* doc/README.macros (IGNORE_DYNAMIC_LOADING, PLATFORM_ANDROID): -Document. -* dyn_load.c: Don't include if PLATFORM_ANDROID. -* dyn_load.c: Include bionic (instead of ) if -PLATFORM_ANDROID. -* include/private/gcconfig.h (LINUX): Define also if -PLATFORM_ANDROID (for the windows-based toolkit). -* include/private/gcconfig.h (SEARCH_FOR_DATA_START): Explicitly -define for Android/x86 platform. -* include/private/gcconfig.h (IGNORE_DYNAMIC_LOADING): Recognize -new macro (undefine DYNAMIC_LOADING in this case). -* include/private/gcconfig.h (CANCEL_SAFE): Don't define if -PLATFORM_ANDROID. -* include/private/gcconfig.h (IF_CANCEL): Fix definition for the -explicitly defined CANCEL_SAFE. - -* allchblk.c (GC_allochblk_nth): Don't call GC_remove_protection() -if GC_DISABLE_INCREMENTAL. -* reclaim.c (GC_reclaim_generic): Likewise. -* checksums.c (GC_page_was_ever_dirty): Add prototype. -* include/private/gc_locks.h (GC_mark_lock_holder): Don't declare -unless PARALLEL_MARK. -* include/private/gc_priv.h (GC_dirty_maintained, -GC_page_was_dirty, GC_remove_protection, GC_dirty_init): Don't -declare if GC_DISABLE_INCREMENTAL. -* include/private/gc_priv.h (GC_print_finalization_stats): Don't -declare if SMALL_CONFIG. -* include/private/gcconfig.h (CHECKSUMS): Explicitly undefine if -GC_DISABLE_INCREMENTAL (since nothing to check). -* include/private/gcconfig.h (DEFAULT_VDB): Don't define if -GC_DISABLE_INCREMENTAL. -* os_dep.c (GC_dirty_maintained): Likewise. -* mark.c (GC_initiate_gc): Don't call GC_read_dirty() if -GC_DISABLE_INCREMENTAL. -* os_dep.c (GC_gww_page_was_ever_dirty, GC_page_was_ever_dirty): -Uncomment; define only if CHECKSUMS. - -* darwin_stop_world.c (GC_push_all_stacks): Fix a bug (call -GC_push_all_stack() instead of GC_push_all_stack_frames()). -* include/private/gc_priv.h (GC_push_all_stack_frames, -GC_push_all_register_frames): Rename to -GC_push_all_stack_sections and GC_push_all_register_sections, -respectively. -* mark_rts.c (GC_push_all_stack_frames, -GC_push_all_register_frames, GC_push_all_stack_part_eager_frames, -GC_push_current_stack): Likewise. -* pthread_stop_world.c (GC_push_all_stacks): Likewise. -* win32_threads.c (GC_push_stack_for): Likewise. -* misc.c (GC_call_with_gc_active): Rename "frame" local variable -to "stacksect". -* pthread_support.c (GC_call_with_gc_active): Likewise. -* win32_threads.c (GC_call_with_gc_active): Likewise. -* pthread_support.c (GC_call_with_gc_active): Update FIXME for -Darwin. -* win32_threads.c (GC_Thread_Rep): Update the comment for -traced_stack_sect. - -* darwin_stop_world.c (GC_push_all_stacks): Rename -activation_frame to traced_stack_sect. -* include/private/gc_priv.h (GC_push_all_stack_frames, -GC_push_all_register_frames): Likewise. -* include/private/pthread_support.h (GC_Thread_Rep): Likewise. -* mark_rts.c (GC_push_all_register_frames, -GC_push_all_stack_frames, GC_push_all_stack_part_eager_frames, -GC_push_current_stack): Likewise. -* pthread_stop_world.c (GC_push_all_stacks): Likewise. -* pthread_support.c (GC_call_with_gc_active): Likewise. -* win32_threads.c (GC_Thread_Rep, GC_call_with_gc_active, -GC_push_stack_for): Likewise. -* include/private/gc_priv.h (GC_activation_frame_s): Rename to -GC_traced_stack_sect_s. -* include/private/gc_priv.h (GC_activation_frame): Rename to -GC_traced_stack_sect. -* misc.c (GC_activation_frame, GC_call_with_gc_active): Likewise. -* doc/README.macros (UNICODE): Document. - -* doc/README.macros (GC_READ_ENV_FILE): Document (new macro). -* include/private/gc_priv.h (GETENV): Recognize GC_READ_ENV_FILE; -declare and use GC_envfile_getenv(). -* misc.c (GC_envfile_content, GC_envfile_length): New static -variable (only if GC_READ_ENV_FILE). -* misc.c (GC_ENVFILE_MAXLEN): New macro (used in GC_envfile_init). -* misc.c (GC_envfile_init, GC_envfile_getenv): New function (only -if GC_READ_ENV_FILE). -* misc.c (GC_init): Call GC_envfile_init() (before using GETENV) -if GC_READ_ENV_FILE. -* misc.c (GC_init): Move GC_setpagesize() and GC_init_win32() -calls to be just before GC_envfile_init() one (since the latter -uses GET_MEM). -* misc.c (GC_abort): use ExitProcess() (instead of DebugBreak) for -WinCE if NO_DEBUGGING; add a comment for DebugBreak() (for WinCE). -* mark_rts.c (GC_add_roots_inner): Remove redundant trailing '\n' -from the ABORT message. -* misc.c (GC_init): Likewise. -* os_dep.c (GC_get_main_stack_base, GC_register_data_segments): -Likewise. -* pthread_stop_world.c (GC_push_all_stacks): Likewise. -* pthread_support.c (GC_init_real_syms, start_mark_threads): -Likewise. - -* win32_threads.c (GC_get_next_stack): Don't define for Cygwin -(since unused for now). - -* dyn_load.c (HAVE_REGISTER_MAIN_STATIC_DATA): Don't define unless -GC_register_main_static_data() is defined. -* dyn_load.c (GC_register_dynamic_libraries): Define only if used -(if DYNAMIC_LOADING or PCR or Win32/CE). -* dyn_load.c (GC_register_main_static_data): Define the default -one only if DYNAMIC_LOADING. -* include/private/gc_priv.h (GC_register_dynamic_libraries): -Declare only if used (to prevent compiler warning). - -* mark_rts.c (GC_approx_sp): Add a comment (for GCC). - - -== [7.2alpha4] 2009-12-01 == - -* configure.ac (AC_CONFIG_COMMANDS): Quote srcdir value. - -* include/gc.h (GC_get_suspend_signal): New function declaration. -* misc.c (GC_get_suspend_signal): New API function (only if -THREADS). - -* alloc.c (min_bytes_allocd): Multiply GC_free_space_divisor by -two if GC_incremental (instead of TRUE_INCREMENTAL). - -* sparc_mach_dep.S (GC_push_regs): Remove the reference. - -* os_dep.c (SIZE_T, PULONG_PTR): Remove. -* os_dep.c (ULONG_PTR): Replace with GC_ULONG_PTR (defined as GC -"word"); add the comment. -* os_dep.c (GetWriteWatch_type, detect_GetWriteWatch, -GC_gww_read_dirty): Prefix ULONG_PTR with "GC_". - -* win32_threads.c (THREAD_TABLE_SZ): Change back to a power-of-two -const value (for speed). -* win32_threads.c (THREAD_TABLE_INDEX): New macro. -* win32_threads.c (GC_new_thread, GC_lookup_thread_inner, -GC_delete_gc_thread, GC_delete_thread, GC_lookup_pthread): Use -THREAD_TABLE_INDEX instead of THREAD_TABLE_SZ. -* win32_threads.c (PTHREAD_MAP_HASH): Rename to PTHREAD_MAP_INDEX. - -* win32_threads.c (THREAD_TABLE_SZ): Make the const value prime. - -* backgraph.c: Remove apostrophe char from "#error". - -* doc/README.macros (GC_DISABLE_INCREMENTAL): Document. -* include/private/gcconfig.h (GC_DISABLE_INCREMENTAL): Recognize -new macro; implicitly define it if SMALL_CONFIG. -* alloc.c (GC_incremental, GC_timeout_stop_func): Check for -GC_DISABLE_INCREMENTAL instead of SMALL_CONFIG. -* include/private/gc_priv.h (GC_incremental, TRUE_INCREMENTAL, -GC_push_conditional): Likewise. -* mark.c (GC_push_next_marked_dirty, GC_push_selected, -GC_push_conditional, GC_block_was_dirty): Likewise. -* misc.c (GC_enable_incremental): Likewise. -* misc.c (GC_init): Likewise. - -* dyn_load.c (WIN32_LEAN_AND_MEAN): Guard with ifndef. -* misc.c (WIN32_LEAN_AND_MEAN): Likewise. -* os_dep.c (WIN32_LEAN_AND_MEAN): Likewise. -* allchblk.c (GC_allochblk_nth): Fix a minor typo (don't/doesn't) -in a comment. -* backgraph.c: Likewise. -* dyn_load.c (GC_register_dynamic_libraries): Likewise. -* extra/threadlibs.c (main): Likewise. -* pthread_support.c (pthread_join): Likewise. -* tests/test.c (main): Likewise. - -* mach_dep.c (GC_push_regs): Remove STATIC (just to catch -a duplicate symbol definition linker error). -* misc.c (GC_clear_stack_inner): Likewise. -* sparc_mach_dep.S (GC_push_regs): Comment out the reference. - -* include/private/gc_priv.h (GC_write_disabled): New variable -declaration (only if GC_ASSERTIONS and Win32 threads). -* misc.c (GC_write): Add assertion for GC_write_disabled value is -not on (only if THREADS). -* win32_threads.c (GC_write_disabled): New variable (only if -GC_ASSERTIONS and not Cygwin). -* win32_threads.c (GC_stop_world): Set and clear GC_write_disabled -(while holding GC_write_cs). - -* win32_threads.c (GC_please_stop): If DllMain-based thread -registration is not compiled in then define GC_please_stop as -a non-volatile variable for assertion only. -* win32_threads.c (GC_stop_world): Set and clear only if defined. -* win32_threads.c (GC_stop_world): Add the comment for GC_printf() -usage (while holding GC_write_cs). -* win32_threads.c (GC_delete_gc_thread): Likewise. -* os_dep.c (GC_remove_protection): Likewise. - -* pthread_support.c (GC_inner_start_routine): Join 3 sequential -GC_printf() calls into a single one (for DEBUG_THREADS). - -* include/private/gc_priv.h (GC_total_stacksize): New variable -declaration (only if THREADS). -* alloc.c (GC_total_stacksize): New variable (only if THREADS). -* alloc.c (min_bytes_allocd): Calculate stack_size using -GC_stackbottom only in the single-threaded case; otherwise use -GC_total_stacksize; print GC_total_stacksize value if -DEBUG_THREADS. -* darwin_stop_world.c (GC_push_all_stacks): Use "%p" printf type -specifier for lo/hi values (instead of "%lx"). -* darwin_stop_world.c (GC_push_all_stacks): Use -GC_push_all_stack_frames() instead of GC_push_all_stack(). -* darwin_stop_world.c (GC_push_all_stacks): Recalculate -GC_total_stacksize value. -* pthread_stop_world.c (GC_push_all_stacks): Likewise. -* win32_threads.c (GC_push_all_stacks): Likewise. -* win32_threads.c (GC_push_stack_for): Pass "me" argument; return -stack size; don't check for non-zero value of thread->stack_base. -* win32_threads.c (GC_push_all_stacks): Don't call -GC_push_stack_for() and don't check for "t->id == me" if -thread->stack_base is zero. - -* dyn_load.c (GC_dump_meminfo): Prefix "%lx" printf type specifier -with "0x". -* os_dep.c (PROTECT): Likewise. -* win32_threads.c (GC_mark_thread_local_free_lists): Cast p->id to -int (to match printf type specifier). - -* tests/test.c (check_heap_stats): Take into account the unmapped -memory size when checking for "Unexpected heap growth"; remove -FIXME. - -* alloc.c: Revert last change. - -* include/private/gcconfig.h (STACKBOTTOM): Add a presence check -for eCos/NOSYS. -* misc.c (GC_write): Comment out _Jv_diag_write() call (since no -longer defined in GCJ). - -* os_dep.c (brk): Rename to ecos_gc_brk. - -* alloc.c (min_bytes_allocd): Use GC_stackbottom value to compute -stack_size even if THREADS. -* doc/README.macros (DEBUG_THREADS): Document. -* pthread_support.c (DEBUG_THREADS): Remove the commented out -definition. -* win32_threads.c (DEBUG_WIN32_THREADS): Remove duplicate -definition. -* win32_threads.c: Include errno.h (except for WinCE). -* win32_threads.c (GC_win32_start_inner): Copy "start" and "param" -to local variables, and free "arg" parameter before "start" -invocation. -* win32_threads.c (GC_beginthreadex): Set errno to EAGAIN on error -(instead of calling SetLastError(ERROR_NOT_ENOUGH_MEMORY)). -* win32_threads.c (GC_beginthreadex): Return 0 on error (instead -of -1). - -* darwin_stop_world.c (GC_darwin_register_mach_handler_thread): -Use GC_INNER for the function definition. -* include/private/darwin_stop_world.h -(GC_darwin_register_mach_handler_thread): Remove the prototype. -* os_dep.c (GC_darwin_register_mach_handler_thread): Use GC_INNER -for the function prototype. -* include/private/gc_priv.h (NDEBUG): Explicitly define if -NO_DEBUGGING and not GC_ASSERTIONS (before the standard headers -inclusion). - -* include/private/gcconfig.h: Move DebugBreak() workaround (for -x86mingw32ce toolchain) to gc_priv.h (after windows.h inclusion). - -* allchblk.c (GC_unmap_old, GC_merge_unmapped, GC_allochblk, -GC_freehblk): Use GC_INNER for the function definition. -* alloc.c (GC_never_stop_func, GC_should_collect, -GC_try_to_collect_inner, GC_collect_a_little_inner, -GC_set_fl_marks, GC_add_to_our_memory, GC_add_to_heap, -GC_expand_hp_inner, GC_collect_or_expand, GC_allocobj): Likewise. -* backgraph.c (GC_build_back_graph, GC_traverse_back_graph): -Likewise. -* blacklst.c (GC_default_print_heap_obj_proc, GC_bl_init, -GC_promote_black_lists, GC_unpromote_black_lists, -GC_add_to_black_list_normal, GC_add_to_black_list_stack, -GC_is_black_listed): Likewise. -* darwin_stop_world.c (GC_push_all_stacks, GC_push_all_stacks, -GC_stop_init, GC_stop_world, GC_start_world): Likewise. -* dbg_mlc.c (GC_has_other_debug_info, GC_store_back_pointer, -GC_marked_for_finalization, GC_generate_random_backtrace_no_gc, -GC_store_debug_info, GC_start_debugging, -GC_debug_generic_malloc_inner, -GC_debug_generic_malloc_inner_ignore_off_page, -GC_debug_malloc_uncollectable, GC_debug_free_inner): Likewise. -* dyn_load.c (GC_register_dynamic_libraries, -GC_register_main_static_data, GC_init_dyld): Likewise. -* finalize.c (GC_push_finalizer_structures, GC_finalize, -GC_notify_or_invoke_finalizers, GC_print_finalization_stats): -Likewise. -* gcj_mlc.c (GC_core_gcj_malloc): Likewise. -* headers.c (GC_find_header, GC_header_cache_miss, -GC_scratch_alloc, GC_init_headers, GC_install_header, -GC_install_counts, GC_remove_header, GC_remove_counts, -GC_next_used_block, GC_prev_block): Likewise. -* mach_dep.c (GC_with_callee_saves_pushed): Likewise. -* malloc.c (GC_collect_or_expand, GC_alloc_large, -GC_generic_malloc_inner, GC_generic_malloc_inner_ignore_off_page, -GC_core_malloc_atomic, GC_core_malloc, GC_free_inner): Likewise. -* mallocx.c (GC_generic_malloc_ignore_off_page): Likewise. -* mark.c (GC_collection_in_progress, GC_clear_hdr_marks, -GC_set_hdr_marks, GC_set_mark_bit, GC_clear_mark_bit, -GC_clear_marks, GC_initiate_gc, GC_mark_some, -GC_mark_stack_empty, GC_invalidate_mark_state, -GC_signal_mark_stack_overflow, GC_mark_from, GC_help_marker, -GC_mark_init, GC_push_all, GC_push_conditional, -GC_mark_and_push_stack, GC_push_all_eager, GC_push_all_stack): -Likewise. -* mark_rts.c (GC_is_static_root, GC_roots_present, GC_approx_sp, -GC_exclude_static_roots_inner, GC_push_all_register_frames, -GC_push_all_stack_frames, GC_cond_register_dynamic_libraries, -GC_push_roots): Likewise. -* misc.c (GC_extend_size_map, GC_clear_stack, GC_err_write): -Likewise. -* new_hblk.c (GC_build_fl, GC_new_hblk): Likewise. -* obj_map.c (GC_register_displacement_inner, GC_add_map_entry, -GC_initialize_offsets): Likewise. -* os_dep.c (GC_get_maps, GC_parse_map_entry, GC_text_mapping, -GC_init_linux_data_start, GC_init_netbsd_elf, GC_setpagesize, -GC_set_and_save_fault_handler, GC_setup_temporary_fault_handler, -GC_reset_fault_handler, GC_get_register_stack_base, GC_init_win32, -GC_add_current_malloc_heap, GC_is_heap_base, GC_unmap, GC_remap, -GC_unmap_gap, GC_push_all_stacks, GC_gww_dirty_init, -GC_dirty_init, GC_read_dirty, GC_page_was_dirty, -GC_page_was_ever_dirty, GC_remove_protection, -GC_write_fault_handler, GC_mprotect_stop, GC_mprotect_resume, -GC_save_callers, GC_print_callers): Likewise. -* pthread_stop_world.c (GC_push_all_stacks, GC_stop_world, -GC_start_world, GC_stop_init): Likewise. -* pthread_support.c (GC_mark_thread_local_free_lists, -GC_lookup_thread, GC_reset_finalizer_nested, -GC_check_finalizer_nested, GC_segment_is_thread_stack, -GC_greatest_stack_base_below, GC_thr_init, GC_init_parallel, -GC_do_blocking_inner, GC_lock, GC_acquire_mark_lock, -GC_release_mark_lock, GC_wait_for_reclaim, GC_notify_all_builder, -GC_wait_marker, GC_notify_all_marker): Likewise. -* reclaim.c (GC_print_all_errors, GC_block_empty, -GC_reclaim_generic, GC_start_reclaim, GC_continue_reclaim, -GC_reclaim_all): Likewise. -* thread_local_alloc.c (GC_init_thread_local, -GC_destroy_thread_local, GC_mark_thread_local_fls_for): Likewise. -* win32_threads.c (GC_reset_finalizer_nested, -GC_check_finalizer_nested, GC_do_blocking_inner, GC_stop_world, -GC_start_world, GC_push_all_stacks, GC_get_next_stack, -GC_acquire_mark_lock, GC_release_mark_lock, GC_wait_for_reclaim, -GC_notify_all_builder, GC_wait_marker, GC_notify_all_marker, -GC_thr_init, GC_init_parallel, GC_lock, -GC_mark_thread_local_free_lists): Likewise. -* alloc.c (GC_add_current_malloc_heap, GC_build_back_graph, -GC_traverse_back_graph): Use GC_INNER for the function prototype. -* darwin_stop_world.c (GC_mprotect_stop, GC_mprotect_resume): -Likewise. -* dbg_mlc.c (GC_default_print_heap_obj_proc): Likewise. -* dyn_load.c (GC_parse_map_entry, GC_get_maps, -GC_segment_is_thread_stack, GC_roots_present, GC_is_heap_base, -GC_get_next_stack): Likewise. -* finalize.c (GC_reset_finalizer_nested, -GC_check_finalizer_nested): Likewise. -* gcj_mlc.c (GC_start_debugging): Likewise. -* include/private/dbg_mlc.h (GC_save_callers, GC_print_callers, -GC_has_other_debug_info, GC_store_debug_info): Likewise. -* include/private/gc_hdrs.h (GC_header_cache_miss): Likewise. -* include/private/gc_locks.h (GC_lock): Likewise. -* include/private/gc_pmark.h (GC_signal_mark_stack_overflow, -GC_mark_from): Likewise. -* include/private/pthread_support.h (GC_lookup_thread, -GC_stop_init): Likewise. -* include/private/thread_local_alloc.h (GC_init_thread_local, -GC_destroy_thread_local, GC_mark_thread_local_fls_for): Likewise. -* malloc.c (GC_extend_size_map, GC_text_mapping): Likewise. -* mark.c (GC_page_was_ever_dirty): Likewise. -* mark_rts.c (GC_mark_thread_local_free_lists): Likewise. -* misc.c (GC_register_main_static_data, GC_init_win32, -GC_setpagesize, GC_init_linux_data_start, -GC_set_and_save_fault_handler, GC_init_dyld, GC_init_netbsd_elf, -GC_do_blocking_inner): Likewise. -* os_dep.c (GC_greatest_stack_base_below): Likewise. -* win32_threads.c (GC_write_fault_handler, GC_gww_dirty_init): -Likewise. -* include/private/gc_priv.h: Likewise. -* include/private/gc_priv.h (GC_INNER): Update the comment. -* doc/README.macros (GC_DLL): Update. - -* alloc.c (GC_collection_in_progress): Move the prototype to -gc_priv.h. -* gc_dlopen.c (GC_collection_in_progress): Likewise. -* pthread_support.c (GC_collection_in_progress): Likewise. -* misc.c (GC_init_parallel): Likewise. -* pthread_support.c (GC_init_parallel): Likewise. -* win32_threads.c (GC_init_parallel): Likewise. -* darwin_stop_world.c (GC_thr_init): Likewise. -* misc.c (GC_thr_init): Likewise. -* pthread_stop_world.c (GC_thr_init): Likewise. -* pthread_support.c (GC_thr_init): Likewise. -* blacklst.c (GC_clear_bl, GC_copy_bl, -GC_number_stack_black_listed): Make STATIC. -* dbg_mlc.c (GC_print_obj, GC_make_closure, -GC_debug_invoke_finalizer): Likewise. -* malloc.c (GC_alloc_large_and_clear): Likewise. -* mark.c (GC_push_selected, GC_push_marked1, GC_push_marked2, -GC_push_marked4, GC_push_marked, GC_push_next_marked, -GC_push_next_marked_dirty, GC_push_next_marked_uncollectable): -Likewise. -* misc.c (GC_clear_stack_inner): Likewise. -* os_dep.c (GC_repeat_read, GC_default_push_other_roots): Likewise. -* darwin_stop_world.c (FindTopOfStack): Make static; define only -if not DARWIN_DONT_PARSE_STACK. -* dbg_mlc.c (GC_debug_free_inner): Define only if DBG_HDRS_ALL. -* dyn_load.c (GC_repeat_read): Remove unused prototype. -* include/private/gc_pmark.h (GC_find_start): Likewise. -* misc.c (GC_read, GC_register_finalizer_no_order): Likewise. -* dyn_load.c (GC_segment_is_thread_stack): Add prototype (only if -THREADS). -* dyn_load.c (GC_register_main_static_data): Define only if -DYNAMIC_LOADING. -* finalize.c (GC_enqueue_all_finalizers): Remove unnecessary tail -"return" statement. -* gc_dlopen.c (GC_SOLARIS_THREADS): Don't recognize (since implies -GC_PTHREADS). -* include/gc.h: Fix a typo. -* include/gc_inline.h (GC_ASSERT): Define (if not defined) since -the header is public. -* include/gc_inline.h (GC_generic_malloc_many): New public -function declaration. -* mallocx.c (GC_generic_malloc_many): Make public. -* include/private/gc_priv.h (GC_INNER): Use visibility attribute -(if available). -* include/private/gc_priv.h (GC_EXTERN): Define using GC_INNER. -* include/private/gc_priv.h: Include atomic_ops.h if THREADS and -MPROTECT_VDB. -* os_dep.c: Don't include atomic_ops.h -* win32_threads.c: Likewise. -* include/private/gc_priv.h (GC_push_selected, GC_push_regs, -GC_push_marked, GC_number_stack_black_listed, -GC_alloc_large_and_clear, GC_reclaim_or_delete_all, -GC_generic_malloc_many, GC_make_closure, -GC_debug_invoke_finalizer, GC_print_obj, GC_page_was_ever_dirty): -Remove the prototype. -* mark.c (GC_page_was_ever_dirty): Add prototype (only if -PROC_VDB). -* include/private/gc_priv.h (GC_push_next_marked_dirty, -GC_push_next_marked, GC_push_next_marked_uncollectable): Move -the prototype to mark.c. -* include/private/gc_priv.h (GC_is_static_root): Declare only if -not THREADS. -* include/private/gc_priv.h (GC_free_inner): Declare only if -THREADS. -* include/private/gc_priv.h (GC_debug_free_inner): Declare only if -THREADS and DBG_HDRS_ALL. -* include/private/gc_priv.h (GC_markers): Declare GC_markers only -if PARALLEL_MARK. -* include/private/gc_priv.h (GC_register_main_static_data): Move -the prototype to misc.c. -* mach_dep.c (GC_push_regs): Make STATIC; define only along with -HAVE_PUSH_REGS definition. -* mach_dep.c (GC_clear_stack_inner): Replace K&R-style function -definition with the ANSI C one. -* mark.c (GC_started_thread_while_stopped): Declared only if not -GNU C. -* win32_threads.c (GC_started_thread_while_stopped): Don't define -if GNU C. -* mark.c (GC_mark_from): Avoid unbalanced brackets in -#if-#else-#endif blocks. -* mark_rts.c (GC_is_static_root): Define only if not THREADS. -* os_dep.c (GC_get_stack_base): Make public (for OpenBSD). -* os_dep.c (GC_page_was_ever_dirty): Comment out the function -except for PROC_VDB. -* tests/test.c (main): Don't reference GC_print_obj, -GC_make_closure, GC_debug_invoke_finalizer, -GC_page_was_ever_dirty, GC_is_fresh (in GC_noop). -* thread_local_alloc.c: Don't include "gc_inline.h". -* win32_threads.c (GC_write_fault_handler): Declare only if -MPROTECT_VDB. - -* allchblk.c (DEBUG): Remove macro (since unused). -* allchblk.c: Include private/gc_priv.h before other includes and -definitions. -* alloc.c: Likewise. -* gc_dlopen.c: Likewise. -* headers.c: Likewise. -* mallocx.c: Likewise. -* mark_rts.c: Likewise. -* new_hblk.c: Likewise. -* reclaim.c: Likewise. -* mark.c: Include private/gc_pmark.h before other includes. -* misc.c: Likewise. -* dyn_load.c (_GNU_SOURCE): Move the definition to gc_priv.h. -* pthread_support.c (_USING_POSIX4A_DRAFT10): Likewise. -* pthread_support.c (_POSIX4A_DRAFT10_SOURCE): Remove (since -already defined in gc_config_macros.h). -* dyn_load.c (GC_init_dyld): Remove parameter cast for -_dyld_register_func_for_add_image() and -_dyld_register_func_for_remove_image(); add the comment about -possible warnings; add FIXME for the deprecated -_dyld_bind_fully_image_containing_address(). -* include/private/gc_priv.h: Include gc.h before the standard -headers inclusion. -* tests/test.c: Likewise. -* include/private/gcconfig.h (DebugBreak): Update the comment. -* typd_mlc.c (ED_INITIAL_SIZE): Remove ';'. - -* configure.ac (openbsd): Define GC_OPENBSD_THREADS. -* configure.ac: Add AM_CONDITIONAL(OPENBSD_THREADS). -* configure.ac: Add sparc-openbsd case. -* doc/README.macros (GC_NETBSD_THREADS, GC_OPENBSD_THREADS): -Document. -* tests/test.c (main): Handle OpenBSD case. -* include/private/pthread_stop_world.h: Likewise. -* extra/threadlibs.c (main): Replace K&R-style function definition -with the ANSI C one. -* extra/threadlibs.c (main): Handle GC_OPENBSD_THREADS case. -* dyn_load.c (OPENBSD): Recognize (similar to NETBSD). -* include/gc_config_macros.h (GC_SOLARIS_THREADS): Recognize; -define it for OpenBSD. -* include/gc_pthread_redirects.h (GC_pthread_sigmask, -pthread_sigmask): Don't declare and redefine for OpenBSD. -* include/private/gcconfig.h: Handle OpenBSD (on arm, sh, i386, -amd64, powerpc). -* mach_dep.c (NO_GETCONTEXT): Likewise. -* include/private/pthread_stop_world.h (thread_stop_info): Don't -define last_stop_count field if OpenBSD. -* misc.c (GC_init_dyld): Add declaration (if NetBSD). -* misc.c (GC_init): Don't call GC_init_netbsd_elf() for OpenBSD. -* os_dep.c (GC_init_netbsd_elf): Don't define for OpenBSD. -* os_dep.c (old_segv_act, GC_jmp_buf_openbsd): New static variable -(only if OpenBSD). -* os_dep.c (GC_fault_handler_openbsd, GC_find_limit_openbsd, -GC_skip_hole_openbsd): New static function (only if OpenBSD). -* os_dep.c (GC_get_stack_base, GC_get_main_stack_base, -GC_register_data_segments): Define specially for OpenBSD case. -* os_dep.c (GC_fault_handler_lock): Initialize to -AO_TS_INITIALIZER (instead of 0). -* pthread_support.c (GC_allocate_lock): Likewise. -* pthread_stop_world.c (NSIG, GC_print_sig_mask, -GC_remove_allowed_signals, suspend_handler_mask, GC_stop_count, -GC_world_is_stopped, GC_retry_signals, SIG_THR_RESTART, -GC_suspend_ack_sem, GC_suspend_handler_inner, GC_suspend_handler, -GC_restart_handler): Don't define and use if OpenBSD. -* pthread_stop_world.c (GC_suspend_all, GC_stop_world, -GC_start_world): Handle OpenBSD case. -* pthread_stop_world.c (GC_stop_init): Define as empty if OpenBSD. -* pthread_support.c (pthread_sigmask): Don't undefine the macro and -don't define the wrapper function if OpenBSD. -* pthread_support.c (GC_thr_init): Handle OpenBSD case. - -* dyn_load.c: Move the inclusion of private/gc_priv.h below -definition of a feature macro (_GNU_SOURCE). - -* include/gc.h (REVEAL_POINTER): Remove redundant parentheses. -* include/gc.h (GC_HIDE_POINTER, GC_REVEAL_POINTER): New macros -(only if GC_I_HIDE_POINTERS). -* backgraph.c (GET_OH_BG_PTR): Prefix REVEAL_POINTER() with "GC_". -* dbg_mlc.c (GC_get_back_ptr_info): Likewise. -* finalize.c (GC_grow_table, GC_dump_finalization, GC_finalize, -GC_enqueue_all_finalizers): Likewise. -* backgraph.c (SET_OH_BG_PTR): Prefix HIDE_POINTER() with "GC_". -* finalize.c (GC_general_register_disappearing_link, -GC_unregister_disappearing_link, GC_register_finalizer_inner, -GC_finalize): Likewise. -* include/private/dbg_mlc.h (HIDE_BACK_PTR): Likewise. -* include/private/dbg_mlc.h (GC_I_HIDE_POINTERS): Define instead -of I_HIDE_POINTERS. -* include/private/gc_priv.h (GC_I_HIDE_POINTERS): Likewise. -* include/gc.h (_GC_H): Strip leading underscore. -* include/gc_backptr.h (_GC_H): Likewise. -* include/gc_gcj.h (_GC_H): Likewise. -* include/gc_mark.h (_GC_H): Likewise. -* include/gc_typed.h (_GC_TYPED_H, _GC_H): Likewise. -* include/javaxfc.h (_GC_H): Likewise. -* include/new_gc_alloc.h (__GC_SPECIALIZE): Likewise. -* include/private/dbg_mlc.h (_GC_H): Likewise. -* include/private/gc_priv.h (_GC_H): Likewise. - -* gc_cpp.cc: Include "gc_cpp.h" instead of . - -* include/private/gc_priv.h (GC_INNER): New macro (for GC-scope -variable definitions). -* include/private/gc_priv.h (GC_EXTERN): Update the comment. -* allchblk.c (GC_unmap_threshold): Define as GC_INNER. -* alloc.c (GC_incremental, GC_world_stopped, GC_n_heap_sects, -GC_n_memory, GC_fail_count): Likewise. -* blacklst.c (GC_black_list_spacing, GC_print_heap_obj): Likewise. -* gcj_mlc.c (GC_gcj_malloc_initialized, GC_gcjobjfreelist): Likewise. -* mach_dep.c (GC_save_regs_ret_val): Likewise. -* mark.c (GC_n_mark_procs, GC_obj_kinds, GC_n_kinds, -GC_mark_stack, GC_mark_stack_limit, GC_mark_stack_size, -GC_mark_stack_top, GC_mark_state, GC_mark_stack_too_small, -GC_mark_no, GC_markers): Likewise. -* mark_rts.c (GC_root_size, GC_push_typed_structures): Likewise. -* misc.c (GC_allocate_ml, GC_debugging_started, GC_check_heap, -GC_print_all_smashed, GC_print_back_height, GC_dump_regularly, -GC_backtraces, GC_force_unmap_on_gcollect, -GC_large_alloc_warn_interval, GC_is_initialized, GC_write_cs, -GC_current_warn_proc, GC_blocked_sp, GC_activation_frame): Likewise. -* os_dep.c (GC_page_size, GC_dont_query_stack_min, -GC_no_win32_dlls, GC_wnt, GC_sysinfo, GC_push_other_roots, -GC_dirty_maintained, GC_fault_handler_lock): Likewise. -* pthread_support.c (GC_allocate_ml, GC_lock_holder, -GC_need_to_lock, GC_thr_initialized, GC_threads, -GC_in_thread_creation, GC_collecting, GC_allocate_lock, -GC_mark_lock_holder): Likewise. -* reclaim.c (GC_bytes_found, GC_fl_builder_count, GC_have_errors): -Likewise. -* win32_threads.c (GC_allocate_ml, GC_lock_holder, -GC_need_to_lock, GC_mark_lock_holder, GC_collecting): Likewise. -* extra/gc.c (GC_INNER, GC_EXTERN): Define as STATIC. -* mach_dep.c (GC_with_callee_saves_pushed): Remove redundant {}. - -* include/private/gc_priv.h (GC_bytes_allocd, GC_objfreelist, -GC_aobjfreelist): Replace GC_EXTERN to extern for SEPARATE_GLOBALS -case (since they are not defined inside GC at present). -* include/private/gc_priv.h (GC_objects_are_marked): Remove the -declaration (since made static). -* mark.c (GC_objects_are_marked): Define as STATIC. -* win32_threads.c (GC_thr_initialized, GC_in_thread_creation): -Likewise. -* mark.c (GC_N_KINDS_INITIAL_VALUE): New macro (defined and used -to initialize GC_n_kinds). -* win32_threads.c (start_mark_threads): Adjust the comment. - -* alloc.c (GC_notify_full_gc): Use GC_INLINE for a tiny static -function. -* backgraph.c (pop_in_progress, GC_apply_to_each_object): Likewise. -* mark_rts.c (add_roots_to_index): Likewise. - -* extra/gc.c: New file. -* Makefile.am (EXTRA_DIST): Add "extra/gc.c". - -* misc.c (GC_log): Remove the declaration; move the definition (to -the place where it is used); make STATIC. -* misc.c (GC_init): Use GC_err_printf() instead of GC_log_printf() -to print open log failure. -* misc.c (GC_write): Don't abort on open log failure if the GC is -compiled with GC_PRINT_VERBOSE_STATS (useful for WinCE). - -* include/private/gcconfig.h (USE_MMAP): Guard with ifndef. - -* allchblk.c (GC_fail_count, GC_large_alloc_warn_interval): Move -the variable declaration to gc_priv.h. -* alloc.c (GC_bytes_found, GC_unmap_threshold, -GC_force_unmap_on_gcollect): Likewise. -* dyn_load.c (GC_no_win32_dlls, GC_wnt): Likewise. -* finalize.c (GC_fail_count): Likewise. -* include/private/gc_locks.h (GC_allocate_ml, GC_lock_holder, -GC_collecting, GC_mark_lock_holder, GC_need_to_lock): Likewise. -* include/private/gc_pmark.h (GC_n_mark_procs, GC_mark_stack_size, -GC_mark_stack_limit, GC_mark_stack_top, GC_mark_stack, -GC_mark_stack_too_small, GC_mark_state): Likewise. -* include/private/pthread_support.h (GC_threads, -GC_thr_initialized, GC_in_thread_creation): Likewise. -* mallocx.c (GC_bytes_found): Likewise. -* mark_rts.c (GC_save_regs_ret_val, GC_world_stopped): Likewise. -* misc.c (GC_unmap_threshold): Likewise. -* os_dep.c (GC_unmap_threshold): Likewise. -* pthread_support.c (GC_markers): Likewise. -* thread_local_alloc.c (GC_gcjobjfreelist, -GC_gcj_malloc_initialized, GC_gcj_kind): Likewise. -* win32_threads.c (GC_fault_handler_lock, GC_write_cs, -GC_dont_query_stack_min, GC_markers, GC_wnt): Likewise. -* include/private/gc_priv.h (GC_EXTERN): New macro (used mostly as -a tag for now); defined after "gcconfig.h" inclusion. -* include/private/gc_priv.h: Use GC_EXTERN instead of "extern" -keyword for most global variables. -* alloc.c (GC_copyright): Add the comment about the symbol -visibility. -* finalize.c (GC_fo_entries): Likewise. -* include/private/gc_priv.h (GC_print_stats): Likewise. -* misc.c (GC_quiet): Likewise. -* mallocx.c (GC_bytes_allocd_tmp): Make the volatile variable -STATIC. -* pthread_support.c (GC_threads): Add explicit zero initializer -(to make the variable definition differ from the declaration). - -* backgraph.c (GC_quiet): Remove the declaration (not needed -anymore since gc_priv.h is always included). -* checksums.c (GC_quiet): Likewise. -* gcj_mlc.c (GC_quiet): Likewise. -* headers.c (GC_hdr_cache_hits, GC_hdr_cache_misses): Add the -comment. -* include/private/gc_hdrs.h (GC_hdr_cache_hits, -GC_hdr_cache_misses): Likewise. -* mark.c (GC_first_nonempty): Make the volatile variable STATIC. -* pthread_stop_world.c (GC_stop_count, GC_world_is_stopped): -Likewise. -* win32_threads.c (GC_please_stop, GC_max_thread_index, -GC_mark_mutex_waitcnt): Likewise. - -* pthread_support.c (GC_USE_LD_WRAP): Fix a typo (swapped 'L' and -'D') in the name. - -* gc_dlopen.c (GC_MUST_RESTORE_REDEFINED_DLOPEN): Define if dlopen -redirection is turned off; turn it on later when dlopen real -symbol is no longer needed (according to the comment and the same -as in dyn_load.c). -* gc_dlopen.c (WRAP_FUNC, REAL_FUNC): Rename to WRAP_DLFUNC and -REAL_DLFUNC, respectively (to have unique names since the -definitions may differ from that of the similar ones in -pthread_support.c). -* mark.c (source): Undefine the macro when no longer needed. -* os_dep.c (handler): Rename the type to GC_fault_handler_t (to -have the unique name across the project). -* os_dep.c (STAT_BUF_SIZE, STAT_READ); Guard with ifndef; add the -comment. -* pthread_support.c (STAT_BUF_SIZE, STAT_READ): Likewise. -* os_dep.c (sbrk): Undo sbrk() redirection (for ECOS) when no -longer needed. - -* pthread_stop_world.c (pthread_sigmask): Undefine before using -in GC_print_sig_mask() (only if DEBUG_THREADS); add the comment. -* win32_threads.c (dlopen, _beginthread): Don't undefine (since -neither redirected nor used here). -* win32_threads.c (GC_Thread_Rep): Rename "table_management" to -"tm" for short; remove "tm_" prefix. -* win32_threads.c (in_use, next): Don't define the macros; use -tm.in_use and tm.next fields, respectively (to ease debugging). -* win32_threads.c (HASH): Rename to PTHREAD_MAP_HASH (to have -unique name across the project). - -* include/private/gc_priv.h (I_HIDE_POINTERS): Define before gc.h -inclusion. -* include/private/gc_pmark.h (I_HIDE_POINTERS): Define if gc.h is -not included yet. -* finalize.c (I_HIDE_POINTERS): Don't define. -* include/private/dbg_mlc.h (I_HIDE_POINTERS): Likewise. -* misc.c (I_HIDE_POINTERS): Likewise. -* include/private/dbg_mlc.h (HIDE_POINTER, REVEAL_POINTER, -GC_hidden_pointer): Don't define if HIDE_POINTER is undefined. -* include/private/gc_pmark.h: Remove the comment about gc_priv.h -inclusion order. - -* dyn_load.c: Include gc_priv.h before using configuration -information (MACOS). -* dyn_load.c (GC_must_restore_redefined_dlopen): Rename to -GC_MUST_RESTORE_REDEFINED_DLOPEN. - -* backgraph.c (SET_OH_BG_PTR): Place outermost parenthesis -properly. -* darwin_stop_world.c: Replace "if DEBUG_THREADS" with -"ifdef DEBUG_THREADS". -* pthread_stop_world.c: Likewise. -* pthread_support.c: Likewise. -* include/gc_inline.h: Guard with GC_INLINE_H. - -* alloc.c (GC_copyright): Define as const. -* alloc.c (GC_collect_at_heapsize): Replace "static" with "STATIC" -(since the name starts with "GC_" prefix). -* dbg_mlc.c (GC_describe_type_fns): Likewise. -* dyn_load.c (GC_FirstDLOpenedLinkMap, -GC_register_dynlib_callback, GC_dyld_sections, -GC_dyld_name_for_hdr, GC_dyld_image_add, GC_dyld_image_remove): -Likewise. -* malloc.c (GC_libpthread_start, GC_libpthread_end, -GC_libld_start, GC_libld_end): Likewise. -* mark_rts.c (GC_remove_root_at_pos, GC_rebuild_root_index): -Likewise. -* os_dep.c (GC_gww_read_dirty, GC_gww_page_was_dirty, -GC_gww_page_was_ever_dirty, GC_mprotect_thread_notify, -GC_mprotect_thread_reply, GC_mprotect_thread, GC_darwin_sigbus, -GC_forward_exception): Likewise. -* pthread_support.c (GC_syms_initialized): Likewise. -* typd_mlc.c (GC_push_typed_structures_proc): Likewise. -* win32_threads.c (GC_win32_dll_threads, -GC_register_my_thread_inner, GC_lookup_pthread, GC_get_stack_min, -GC_waitForSingleObjectInfinite): Likewise. -* darwin_stop_world.c (GC_use_mach_handler_thread, -GC_use_mach_handler_thread, GC_mach_threads_count): Replace -"static" with "STATIC" and add zero initializer. -* os_dep.c (GC_task_self, GC_ports, GC_mprotect_state, -GC_sigbus_count): Likewise. -* headers.c (free_hdr): Replace "static" with GC_INLINE. -* misc.c (GC_tmp): Rename static variable to fwrite_gc_res. -* os_dep.c (memory): Rename static variable to ecos_gc_memory. -* os_dep.c (async_set_pht_entry_from_index): Make static (for -MPROTECT_VDB case). -* pthread_support.c (GC_real_pthread_create, -GC_real_pthread_sigmask, GC_real_pthread_join, -GC_real_pthread_detach, GC_init_real_syms): Use REAL_FUNC() macro -for static GC_real_XXX symbols. -* win32_threads.c (GC_may_be_in_stack): Remove "GC_" prefix. - -* alloc.c (GC_finish_collection): Replace getenv() with GETENV(). -* dyn_load.c (GC_init_dyld): Likewise. -* os_dep.c (GC_print_callers): Likewise. -* dyn_load.c (GC_dyld_name_for_hdr): Cast _dyld_get_image_name() -result (since it's always of "struct mach_header" type). -* dyn_load.c (GC_init_dyld): Cast GC_dyld_image_add and -GC_dyld_image_remove (to always have the first argument of -"struct mach_header" pointer type). - -* configure.ac: Add threads support for OpenBSD case (threads may -not work correctly for it). - -* acinclude.m4: Rename to m4/gc_set_version.m4. -* m4/libtool.m4: Delete the file. -* m4/lt~obsolete.m4: Likewise. -* m4/ltoptions.m4: Likewise. -* m4/ltsugar.m4: Likewise. -* m4/ltversion.m4: Likewise. - -* include/private/gcconfig.h: Define DebugBreak() as _exit(-1) for -x86mingw32ce toolchain to workaround the incorrect DebugBreak() -declaration in winbase.h (the workaround would turn into a no-op -when DebugBreak() will be defined as a macro in the toolchain). - -* include/private/gcconfig.h: Recognize __i386__ if WinCE (for -x86mingw32ce toolchain). -* include/private/gcconfig.h (NO_GETENV): Don't define for CeGCC -toolchain (or if already defined). -* include/private/gcconfig.h (NO_GETENV_WIN32): New macro (always -defined for WinCE or if NO_GETENV is defined). -* misc.c (GC_CreateLogFile): Use NO_GETENV_WIN32 macro instead of -NO_GETENV one. - -* configure.ac: Add AC_CONFIG_MACRO_DIR([m4]). -* Makefile.am: Add "ACLOCAL_AMFLAGS = -I m4". -* libtool.m4: Remove. -* m4/libtool.m4: New file (generated). -* m4/lt~obsolete.m4: Likewise. -* m4/ltoptions.m4: Likewise. -* m4/ltsugar.m4: Likewise. -* m4/ltversion.m4: Likewise. - -* include/gc.h (GC_UNDERSCORE_STDCALL): Recognize new macro; -prefix GC_CreateThread and GC_ExitThread with '_' if defined. -* doc/README.macros (GC_UNDERSCORE_STDCALL): Document. - -* alloc.c (GC_collect_or_expand): Add "retry" argument; add the -comments; don't use "default" stop_func on a retry if -GC_dont_expand. -* alloc.c (GC_allocobj): Pass "retry" argument to -GC_collect_or_expand(). -* malloc.c (GC_alloc_large): Likewise. -* include/private/gc_priv.h (GC_collect_or_expand): Move the -declaration to malloc.c; add "retry" argument. - -* alloc.c (GC_start_call_back): Move the variable definition from -misc.c. -* include/private/gc_priv.h (GC_start_call_back): Remove the -declaration. -* alloc.c (GC_notify_full_gc): Remove unnecessary cast of 0. -* alloc.c (GC_try_to_collect_inner): Also call stop_func at the -beginning of the function. -* include/gc.h (GC_try_to_collect): Refine the comment about -stop_func. - -* alloc.c (GC_default_stop_func, GC_try_to_collect_general, -GC_gcollect): Add the comment. -* alloc.c (GC_try_to_collect_general): Move the assertion on -stop_func != 0 to GC_try_to_collect(). -* alloc.c (GC_try_to_collect_general): If stop_func == 0 then use -GC_default_stop_func instead (holding the lock). -* alloc.c (GC_gcollect): Pass 0 as stop_func instead of -GC_default_stop_func (to prevent data races). - -* Makefile.direct: Move "define arguments" documentation to -doc/README.macros; add reference to doc/README.macros. -* Makefile.dj: Change the documentation reference to -doc/README.macros. -* README.QUICK: Likewise. -* configure.ac: Likewise. -* allchblk.c: Remove unnecessary "-D" from the comment. -* doc/README.macros: Likewise. -* README.environment: Likewise. -* include/gc.h: Likewise. -* include/gc_inline.h: Likewise. -* include/private/gcconfig.h: Likewise. -* README.QUICK: Fix a typo. - -* misc.c (GC_CreateLogFile): Use FILE_ATTRIBUTE_NORMAL for -CreateFile(); don't immediately flush every write if very verbose. - -* doc/README.win32: Replace ".exe.log" to ".gc.log". -* doc/README.win64: Likewise. -* doc/README.win64: Fix a typo. -* misc.c (GC_CreateLogFile): Strip executable file extension for -the log file; use ".gc.log" extension (instead of ".log"). - -* include/gc_config_macros.h: Avoid the redefinition of -GC_xxx_THREADS macros. - -* alloc.c (GC_try_to_collect_general): Change the type of "result" -local variable to GC_bool. - -* include/gc_config_macros.h: Use old behavior for FreeBSD and -NetBSD platform detection code (check that other GC_xxx_THREADS -are undefined); add FIXME. - -* include/gc_config_macros.h: Rearrange the platform detection -code (GC_WIN32_PTHREADS implies GC_WIN32_THREADS; define -GC_THREADS first if GC_XXX_THREADS already set; define proper -GC_XXX_THREADS if GC_THREADS; define GC_PTHREADS in a single -place; define _REENTRANT if posix threads except for Win32). - -* alloc.c (GC_try_to_collect_general): New function (move the code -from GC_try_to_collect, pass force_unmap argument). -* alloc.c (GC_try_to_collect, GC_gcollect): Call -GC_try_to_collect_general(). -* alloc.c (GC_gcollect_and_unmap): New public function. -* include/gc.h (GC_gcollect_and_unmap): New function declaration. -* tests/test.c (window_proc): Call GC_gcollect_and_unmap() on -WM_HIBERNATE event (instead of GC_set_force_unmap_on_gcollect() -and GC_gcollect()). - -* include/gc.h (GC_allow_register_threads, GC_register_my_thread, -GC_unregister_my_thread, GC_malloc_many): Refine the comment. -* include/gc.h (GC_malloc_many, GC_NEXT): Declare unconditionally -(that is, don't depend on GC_THREADS macro). -* include/gc.h: Don't check for __CYGWIN32__ and __CYGWIN__ along -with a check for GC_PTHREADS (since the former implies the -latter). - -* include/gc.h (GC_SOLARIS_THREADS): Don't check for. -* include/gc.h (GC_MIN, GC_MAX): Don't define. -* mallocx.c (GC_malloc_many): Add comment to #endif. - -* configure.ac: Drop the subdir-objects Automake option, since -it's incompatible with picking source files from libatomic_ops. - -* allchblk.c (GC_fail_count, GC_large_alloc_warn_interval): Add -"extern" keyword to a global variable declaration (some compilers -require it). -* alloc.c (GC_bytes_found, GC_unmap_threshold, -GC_force_unmap_on_gcollect): Likewise. -* dyn_load.c (GC_no_win32_dlls, GC_wnt): Likewise. -* finalize.c (GC_fail_count): Likewise. -* include/private/gc_hdrs.h (GC_hdr_cache_hits, -GC_hdr_cache_misses): Likewise. -* mallocx.c (GC_bytes_found): Likewise. -* mark_rts.c (GC_save_regs_ret_val, GC_world_stopped): Likewise. -* misc.c (GC_unmap_threshold): Likewise. -* os_dep.c (GC_unmap_threshold, GC_old_allocator): Likewise. -* pthread_support.c (GC_markers): Likewise. -* thread_local_alloc.c (GC_gcjobjfreelist, -GC_gcj_malloc_initialized, GC_gcj_kind): Likewise. -* win32_threads.c (GC_fault_handler_lock, GC_write_cs, -GC_dont_query_stack_min, GC_markers, GC_wnt): Likewise. - -* tests/huge_test.c: Define GC_IGNORE_WARN (if not defined) to -suppress misleading GC "Out of Memory!" warning printed on every -GC_MALLOC(LONG_MAX) call. -* tests/huge_test.c: Include "gc.h" instead of . -* tests/huge_test.c (main): Replace K&R-style function definition -with the ANSI C one. - -* dyn_load.c (GC_register_dynamic_libraries): Always use -lpMaximumApplicationAddress value for WinCE (even for old -versions). -* os_dep.c (VER_PLATFORM_WIN32_CE): Define if not in winbase.h. -* os_dep.c (GC_dont_query_stack_min): New global variable (only if -WinCE and THREADS). -* os_dep.c (GC_setpagesize): Adjust lpMaximumApplicationAddress -for WinCE (prior to version 6) if not _WIN32_WCE_EMULATION; set -GC_dont_query_stack_min for older WinCE (prior to version 5). -* win32_threads.c (GC_dont_query_stack_min): Declare. -* win32_threads.c (GC_get_stack_min): Rename the macro to -GC_wince_evaluate_stack_min for WinCE; update the comment. -* win32_threads.c (GC_push_stack_for, GC_get_next_stack): Use -GC_wince_evaluate_stack_min() instead of GC_get_stack_min() for -WinCE and don't update thread's last_stack_min value (only if -GC_dont_query_stack_min). -* win32_threads.c (GC_push_stack_for): Skip assertion for WinCE if -GC_dont_query_stack_min (since the evaluated stack_min value may -be incorrect if the stack is bigger than 64 KiB). - -* gc_dlopen.c (GC_dlopen): Add function redirector (only if -GC_USE_LD_WRAP). -* include/gc.h: Include "gc_pthread_redirects.h" even if -GC_USE_LD_WRAP or GC_NO_THREAD_REDIRECTS. -* include/gc_pthread_redirects.h (GC_PTHREAD_REDIRECTS_H): Don't -define and check for (since included only from gc.h). -* include/gc_pthread_redirects.h: Declare "GC_" symbols even if -GC_USE_LD_WRAP or GC_NO_THREAD_REDIRECTS. -* include/gc_pthread_redirects.h: Include signal.h only to get -sigset_t definition. - -* Makefile.direct: Document GC_REGISTER_MEM_PRIVATE. -* mark_rts.c (GC_is_tmp_root): Define also for WinCE unless -NO_DEBUGGING (that is, replace _WIN32_WCE_EMULATION with MSWINCE). -* os_dep.c (GC_sysinfo): Remove explicit global variable -initialization to "{0}" (revert back the previous change) since it -might produce a warning. - -* allchblk.c (GC_large_alloc_warn_interval): Move declaration from -gc_priv.h. -* allchblk.c (GC_large_alloc_warn_suppressed): Move definition -from misc.c; define as STATIC. -* include/private/gc_priv.h (GC_large_alloc_warn_interval, -GC_large_alloc_warn_suppressed): Remove declaration. -* alloc.c (GC_bytes_found): Add "defined in" comment. -* mallocx.c (GC_bytes_found): Likewise. -* misc.c (GC_unmap_threshold): Likewise. -* os_dep.c (GC_old_allocator): Likewise. -* pthread_support.c (GC_markers): Likewise. -* thread_local_alloc.c (GC_gcjobjfreelist, -GC_gcj_malloc_initialized, GC_gcj_kind): Likewise. -* win32_threads.c (GC_markers): Likewise. -* alloc.c (GC_start_time): Explicitly initialize to 0 or NULL (to -be distinctive from a variable declaration). -* backgraph.c (GC_max_height, GC_deepest_obj): Likewise. -* blacklst.c (GC_old_normal_bl, GC_incomplete_normal_bl, -GC_old_stack_bl, GC_incomplete_stack_bl): Likewise. -* checksums.c (GC_faulted, GC_n_dirty_errors, -GC_n_faulted_dirty_errors, GC_n_changed_errors, GC_n_clean, -GC_n_dirty, GC_bytes_in_used_blocks): Likewise. -* dbg_mlc.c (GC_smashed): Likewise. -* finalize.c (GC_old_dl_entries): Likewise. -* gcj_mlc.c (GC_gcj_kind, GC_gcj_debug_kind, GC_gcjobjfreelist, -GC_gcjdebugobjfreelist): Likewise. -* mach_dep.c (GC_save_regs_ret_val): Likewise. -* mark.c (GC_n_rescuing_pages, GC_mark_stack, GC_mark_stack_limit, -GC_mark_stack_top): Likewise. -* misc.c (GC_min_sp, GC_high_water, GC_bytes_allocd_at_reset): -Likewise. -* os_dep.c (GC_data_start, GC_page_size, GC_sysinfo, -GC_old_segv_handler, GC_old_bus_handler, -GC_old_bus_handler_used_si, GC_old_segv_handler_used_si, -GC_proc_buf, GC_proc_fd, GC_vd_base): Likewise. -* pthread_stop_world.c (GC_stop_count, GC_stopping_pid): Likewise. -* reclaim.c (GC_leaked): Likewise. -* typd_mlc.c (GC_explicit_kind, GC_array_kind, GC_ext_descriptors, -GC_typed_mark_proc_index, GC_array_mark_proc_index, -GC_eobjfreelist, GC_arobjfreelist): Likewise. -* win32_threads.c (GC_pthread_map_cache, GC_marker_cv, -GC_marker_Id): Likewise. -* dbg_mlc.c (GC_smashed, GC_n_smashed): Define as STATIC. -* gcj_mlc.c (GC_gcjdebugobjfreelist): Likewise. -* os_dep.c (GC_vd_base): Likewise. -* pthread_support.c (GC_mark_threads): Likewise. -* reclaim.c (GC_leaked): Likewise. -* typd_mlc.c (GC_bm_table): Likewise. -* mark_rts.c (GC_save_regs_ret_val): Change declaration type to -that of definition; add "defined in" comment. -* mark_rts.c (GC_push_current_stack): Remove unnecessary cast for -GC_save_regs_ret_val. -* misc.c (GC_check_heap, GC_print_all_smashed, -GC_start_call_back): Remove unnecessary cast (of 0). -* misc.c (GC_LARGE_ALLOC_WARN_INTERVAL): New tuning macro. -* misc.c (GC_large_alloc_warn_interval): Initialize to -GC_LARGE_ALLOC_WARN_INTERVAL value. -* misc.c (GC_tmp): Change to "static". -* os_dep.c (GC_mprotect_state): Define as static. -* pthread_support.c (dummy_thread_local): Prefix with "GC_". -* win32_threads.c (WinMain): Remove FIXME for WinCE. - -* os_dep.c (PROTECT, UNPROTECT): Use distinct ABORT messages. - -* configure.ac: Rewrite the tests for external or internal -libatomic_ops. -* configure.ac: In particular, drop the symbolic links. Add option ---with-libatomic-ops for forced selection. -* Makefile.am: Adjust the path of source files from libatomic_ops -to not use the links. -* Makefile.am (libgc_la_LIBADD): Add $(ATOMIC_OPS_LIBS). This will -be empty if we use the bundled AO sources. - -* Makefile.am: Strip version suffix for libatomic_ops directory. -* build_atomic_ops.sh: Likewise. -* build_atomic_ops.sh.cygwin: Likewise. -* configure_atomic_ops.sh: Likewise. -* Makefile.direct: Remove AO_VERSION definition; strip version -suffix for libatomic_ops directory. -* NT_STATIC_THREADS_MAKEFILE: Likewise. -* NT_X64_STATIC_THREADS_MAKEFILE: Likewise. -* NT_X64_THREADS_MAKEFILE: Likewise. -* gc.mak: Likewise. - -* libatomic_ops: Rename from "libatomic_ops-1.2". - -* alloc.c (GC_version): Add "const" keyword. -* alloc.c (GC_get_version): New public function. -* include/gc.h (GC_get_version): New function declaration; update -the comment for the GC version. - -* include/private/gc_locks.h (GC_allocate_ml, GC_lock_holder, -GC_collecting, GC_mark_lock_holder, GC_need_to_lock): Use "extern" -(for the global variable declaration) again. -* include/private/gc_pmark.h (GC_n_mark_procs, GC_mark_stack_size, -GC_mark_stack_limit, GC_mark_stack_top, GC_mark_stack, -GC_mark_stack_too_small, GC_mark_state): Likewise. -* include/private/gcconfig.h (GC_register_stackbottom): Likewise. -* include/private/pthread_support.h (GC_threads, -GC_thr_initialized, GC_in_thread_creation): Likewise. -* include/private/gc_priv.h: Likewise. - -* real_malloc.c: Include private/config.h if HAVE_CONFIG_H. - -* allchblk.c (GC_hblkfreelist): Define as STATIC. -* blacklst.c (GC_total_stack_black_listed): Likewise. -* include/private/gc_priv.h (GC_hblkfreelist, GC_stopped_mark, -GC_total_stack_black_listed, GC_push_stubborn_structures): Remove -declaration. -* mark_rts.c (GC_stopped_mark): Add declaration (only if -THREAD_LOCAL_ALLOC). -* allchblk.c (GC_fail_count): Move the declaration out of -GC_allochblk_nth(); remove "extern". -* alloc.c (IF_THREADS): Remove unused macro. -* alloc.c (GC_world_stopped): Define only if THREAD_LOCAL_ALLOC. -* alloc.c (GC_stopped_mark): Set GC_world_stopped value only if -THREAD_LOCAL_ALLOC. -* alloc.c (GC_bytes_found, GC_collection_in_progress, -GC_check_tls, GC_unmap_threshold, GC_force_unmap_on_gcollect): -Remove K&R-style "extern" for the declaration. -* dbg_mlc.c (GC_free_inner): Likewise. -* dyn_load.c (GC_repeat_read, GC_roots_present, GC_is_heap_base, -GC_get_next_stack, GC_no_win32_dlls, GC_wnt): Likewise. -* finalize.c (GC_fail_count): Likewise. -* include/private/gc_hdrs.h (GC_hdr_cache_hits, -GC_hdr_cache_misses): Likewise. -* include/private/gc_locks.h (GC_allocate_ml, GC_lock_holder, -GC_lock, GC_collecting, GC_mark_lock_holder, GC_need_to_lock): -Likewise. -* include/private/gc_pmark.h (GC_mark_procs, GC_n_mark_procs, -GC_mark_stack_size, GC_mark_stack_limit, GC_mark_stack_top, -GC_mark_stack, GC_mark_stack_too_small, GC_mark_state): Likewise. -* include/private/gc_priv.h (GC_current_warn_proc, GC_obj_kinds, -GC_n_kinds, GC_fo_entries, GC_n_heap_sects, GC_n_memory, -GC_page_size, GC_sysinfo, GC_black_list_spacing, -GC_objects_are_marked, GC_incremental, GC_dirty_maintained, -GC_root_size, GC_debugging_started, GC_large_alloc_warn_interval, -GC_large_alloc_warn_suppressed, GC_blocked_sp, -GC_activation_frame, GC_push_other_roots, -GC_push_finalizer_structures, GC_push_thread_structures, -GC_push_typed_structures, GC_start_call_back, GC_is_initialized, -GC_check_heap, GC_print_all_smashed, GC_print_all_errors, -GC_print_heap_obj, GC_have_errors, GC_print_stats, -GC_dump_regularly, GC_backtraces, GC_print_back_height, -GC_debug_generic_malloc_inner, -GC_debug_generic_malloc_inner_ignore_off_page, -GC_fl_builder_count, GC_mark_no, GC_help_marker, -GC_setup_temporary_fault_handler, GC_reset_fault_handler): Likewise. -* include/private/gcconfig.h (GC_SysVGetDataStart, -GC_FreeBSDGetDataStart, GC_register_stackbottom, -GC_MacTemporaryNewPtr, GC_amiga_get_mem): Likewise. -* include/private/pthread_support.h (GC_threads, -GC_thr_initialized, GC_in_thread_creation): Likewise. -* malloc.c (GC_text_mapping): Likewise. -* mallocx.c (GC_bytes_found): Likewise. -* mark.c (GC_check_dirty, GC_started_thread_while_stopped): Likewise. -* mark_rts.c (GC_save_regs_ret_val): Likewise. -* misc.c (GC_clear_stack_inner, GC_init_parallel, GC_init_win32, -GC_setpagesize, GC_init_linux_data_start, -GC_set_and_save_fault_handler, GC_unmap_threshold): Likewise. -* os_dep.c (GC_unmap_threshold, GC_push_all_stacks, -GC_darwin_register_mach_handler_thread): Likewise. -* pthread_support.c (GC_markers, GC_collection_in_progress): -Likewise. -* tests/test.c (GC_amiga_free_all_mem): Likewise. -* thread_local_alloc.c (GC_gcjobjfreelist, -GC_gcj_malloc_initialized, GC_gcj_kind): Likewise. -* win32_threads.c (GC_write_fault_handler, GC_gww_dirty_init, -GC_fault_handler_lock, GC_write_cs, GC_markers): Likewise. -* misc.c (GC_read, GC_register_finalizer_no_order, GC_init_dyld): -Move the declaration out of GC_init(); remove "extern". -* os_dep.c (GC_abort): Add the comment; add workaround to suppress -compiler "unreachable code" warnings for ABORT callers (where -ABORT is followed by a dummy return statement). -* os_dep.c (GC_old_allocator): Move the declaration out of -GC_default_push_other_roots(); remove "extern". -* darwin_stop_world.c (GC_mprotect_stop, GC_mprotect_resume): -Move the declaration out of GC_stop_world() and GC_start_world() -(only if MPROTECT_VDB); remove "extern". - -* win32_threads.c (GC_get_stack_min, GC_push_stack_for, -GC_get_next_stack): Recognize _WIN32_WCE_EMULATION macro (used for -WinCE emulation and for custom WinCE 6 devices); add the comment. -* win32_threads.c (GC_get_stack_min): Cast pointer to word instead -of DWORD. -* win32_threads.c (GC_get_next_stack): Don't use and maintain the -latest known stack_min value for WinCE (if GC_get_stack_min is -defined as a macro); update the comments. -* win32_threads.c (GC_wnt): Don't declare for WinCE. - -* Makefile.direct: Document EMPTY_GETENV_RESULTS. -* gcj_mlc.c (GC_clear_stack): Remove declaration. -* malloc.c (GC_clear_stack): Likewise. -* mallocx.c (GC_clear_stack): Likewise. -* typd_mlc.c (GC_clear_stack): Likewise. -* gcj_mlc.c (GENERAL_MALLOC, GENERAL_MALLOC_IOP): Rename to -GENERAL_MALLOC_INNER and GENERAL_MALLOC_INNER_IOP, respectively; -remove "lb" unnecessary cast to word. -* include/private/gc_priv.h (GC_clear_stack): Add declaration. -* include/private/gc_priv.h (GENERAL_MALLOC, GENERAL_MALLOC_IOP): -Move common declaration from typd_mlc.c and malloc.c; remove -unnecessary result and "lb" parameter casts. -* include/private/thread_local_alloc.h: Guard against duplicate -header file inclusion. -* os_dep.c (USE_MUNMAP): Replace "-->" with an error directive for -the case when USE_MMAP is not defined. -* pthread_support.c (GC_is_thread_tsd_valid): New internal -function (only if GC_ASSERTIONS and THREAD_LOCAL_ALLOC); move the -code from thread-local GC_malloc(); add FIXME for the condition. -* win32_threads.c (GC_is_thread_tsd_valid): Likewise. -* thread_local_alloc.c (GC_gcjobjfreelist): Change the type (to -match that of its definition). -* thread_local_alloc.c (GC_destroy_thread_local): Add a cast for -GC_gcjobjfreelist. -* thread_local_alloc.c (GC_lookup_thread, GC_lookup_thread_inner): -Remove unused declaration; don't include pthread.h. -* thread_local_alloc.c (GC_is_thread_tsd_valid): New declaration -(only if GC_ASSERTIONS). -* thread_local_alloc.c (GC_malloc): Use GC_is_thread_tsd_valid() -instead of GC_lookup_thread(). -* win32_threads.c (GC_lookup_thread_inner): Define as STATIC. -* win32_threads.c (UNPROTECT): Rename to UNPROTECT_THREAD (to have -id different from that in os_dep.c). - -* allchblk.c (GC_enough_large_bytes_left): Replace "inline static" -with GC_INLINE. -* include/private/gc_priv.h (fixed_getenv): Likewise. -* alloc.c (GC_max, GC_min): Replace "static INLINE" with -GC_INLINE. -* mark_rts.c (rt_hash): Likewise. -* win32_threads.c (GC_get_max_thread_index): Likewise. -* include/private/gc_priv.h (INLINE): Prefix with "GC_"; include -"static"; define for Sun CC; define for VC++ (and other -compilers). -* pthread_support.c: Don't define __inline__ for non-GNU compilers -(not needed anymore). - -* NT_THREADS_MAKEFILE: Remove file (since it duplicates gc.mak). -* Makefile.in: Remove reference to NT_THREADS_MAKEFILE. -* Makefile.am: Likewise. -* Makefile.dj: Likewise. -* Makefile.direct: Likewise. -* doc/README.win32: Add reference to gc.mak. -* NT_X64_THREADS_MAKEFILE: Likewise. - -* Makefile.direct: Remove references to acinclude.m4, libtool.m4. - -* autogen.sh: Update. - -* Makefile.am: Don't add libtool.m4 to EXTRA_DIST. -* acinclude.m4: Fix underquoting of GC_SET_VERSION. -* README.QUICK: Update information for Makefile. -* Makefile.am: Do not distribute the substituted bdw-gc.pc. -* configure.ac: Add AM conditional analog to KEEP_BACK_PTRS. -* tests/tests.am: Use it here to conditionally enable tracetest -when possible. - -* dyn_load.c (GC_wnt): Update the comment. -* dyn_load.c (GC_register_dynamic_libraries): Add the comment for -_WIN32_WCE_EMULATION; recognize GC_REGISTER_MEM_PRIVATE (new -macro); call GC_is_heap_base() only if check for Type succeeded. - -* mark_rts.c (GC_is_tmp_root): Don't define unless NO_DEBUGGING; -update the comment. -* include/private/gc_priv.h (GC_is_tmp_root): Remove declaration. - -* include/private/gcconfig.h (CANCEL_SAFE, IF_CANCEL): new macros. -* include/private/gc_priv.h (DISABLE_CANCEL, RESTORE_CANCEL, -ASSERT_CANCEL_DISABLED): New macros. -* alloc.c (GC_maybe_gc): Assert cancellation disabled. -(GC_collect_a_little_inner,GC_try_to_collect, GC_collect_or_expand): -Disable cancellation. -(GC_add_to_our_memory): Check for overflow. -* misc.c (GC_cancel_disable_count): declare. -(GC_init, GC_write): Disable cancellation. -(GC_init): Remove redundant GC_is_initialized test. -* os_dep.c (GC_repeat_read): Assert cancellation disabled. -(GC_get_stack_base): Disable cancellation. -* pthread_stop_world.c (GC_suspend_handler_inner): Disable -cancellation. -* pthread_support.c (GC_mark_thread): Permanently disable -cancellation. -(GC_wait_for_gc_completion, GC_wait_builder, GC_wait_marker): -Assert cancellation disabled. -(fork handling): Disable cancellation, fix comment. -(GC_pthread_create): Disable cancellation. -(GC_unregister_my_thread): Disable cancellation. -* Makefile.direct: Document NO_CANCEL_SAFE. - -* Makefile: Remove outdated file (Makefile.direct should be used -instead). - -* include/gc.h (GC_use_DllMain): Refine the comment. - -* configure.ac: Add documentation to AC_DEFINE for GC_THREADS and -EMPTY_GETENV_RESULTS. -* configure.ac: Fix a typo. -* Makefile.am: Likewise. - -* checksums.c (GC_checksum, GC_update_check_page): Remove -"register" keyword in local variable declarations (for the code -used only for debugging or which is not time-critical). -* dbg_mlc.c (GC_has_other_debug_info, GC_store_debug_info, -GC_store_debug_info_inner, GC_check_annotated_obj, GC_print_obj, -GC_print_smashed_obj, GC_debug_end_stubborn_change, -GC_debug_invoke_finalizer): Likewise. -* dyn_load.c (GC_register_dynamic_libraries): Likewise. -* mallocx.c (GC_realloc): Likewise. -* mark_rts.c (GC_print_static_roots, GC_is_static_root, -GC_clear_roots): Likewise. -* misc.c (GC_write): Likewise. -* os_dep.c (GC_print_callers): Likewise. -* dyn_load.c (GC_register_dynamic_libraries): Rename "i" local -variable to "j" for the nested loop (just not to hide the similar -variable in the outer one). -* mark_rts.c (GC_print_static_roots): Output an error message -using GC_err_printf() (instead of GC_printf()). - -* configure.ac: Move include flag from ${INCLUDE} ... -* Makefile.am: ... to AM_CPPFLAGS and also add the build directory. -* configure.ac: Call AM_CONFIG_HEADER([include/private/config.h]). -* configure.ac: Add documentation to all AC_DEFINE either directly -or using AH_TEMPLATE. - -* win32_threads.c (GC_waitForSingleObjectInfinite): New static -function (only if GC_WINMAIN_REDIRECT). -* win32_threads.c (WinMain): Call GC_waitForSingleObjectInfinite() -thru GC_do_blocking() instead of calling WaitForSingleObject() -directly. - -* pthread_support.c (start_mark_threads): Refine printed message. -* win32_threads.c (GC_thr_init): Likewise. - -* Makefile.direct (GC_WINMAIN_REDIRECT): Add the comment for. -* Makefile.direct (NO_GETENV): Update the comment. -* include/gc.h (GC_WINMAIN_WINCE_LPTSTR): Remove macro. -* include/gc.h (GC_WinMain): Remove declaration. -* include/gc.h (WinMain): Define (as GC_WinMain) if and only if -GC_WINMAIN_REDIRECT. -* tests/test.c (GC_COND_INIT): Define as GC_INIT() also in case of -WinCE target unless GC_WINMAIN_REDIRECT is defined. -* tests/test.c (WINMAIN_LPTSTR): New macro. -* tests/test.c (WinMain): Use WINMAIN_LPTSTR instead of LP[W]STR -and GC_WINMAIN_WINCE_LPTSTR. -* win32_threads.c (start_mark_threads): Add the comment for -MARK_THREAD_STACK_SIZE. -* win32_threads.c: Recognize new GC_WINMAIN_REDIRECT macro. -* win32_threads.c (WINMAIN_LPTSTR, WINMAIN_THREAD_STACK_SIZE): New -macro (only if GC_WINMAIN_REDIRECT). -* win32_threads.c: Undefine WinMain macro if GC_WINMAIN_REDIRECT. -* win32_threads.c (GC_WinMain): Add prototype (only if -GC_WINMAIN_REDIRECT). -* win32_threads.c (main_thread_args, WinMain): Rename -GC_WINMAIN_WINCE_LPTSTR to WINMAIN_LPTSTR. -* win32_threads.c (WinMain): Call GC_INIT() instead of GC_init(); -use WINMAIN_THREAD_STACK_SIZE. -* win32_threads.c (WinMain): Call GC_deinit() and -DeleteCriticalSection() only if WinCE; add FIXME. - -* os_dep.c (GC_get_main_stack_base): add assertion for mem_base -value returned by GC_get_stack_base(). - -* Makefile.direct (MUNMAP_THRESHOLD, GC_FORCE_UNMAP_ON_GCOLLECT): -Add the comment for. -* alloc.c (GC_unmap_threshold, GC_force_unmap_on_gcollect): -Declare external variable (only if USE_MUNMAP). -* alloc.c (GC_try_to_collect): Temporarily set GC_unmap_threshold -value to 1 if GC_force_unmap_on_gcollect and restore it before -unlocking (only if USE_MUNMAP). -* doc/README.environment (GC_FORCE_UNMAP_ON_GCOLLECT): Add -information for. -* include/gc.h (GC_set_force_unmap_on_gcollect, -GC_get_force_unmap_on_gcollect): New public function prototype. -* include/gc.h (GC_FORCE_UNMAP_ON_GCOLLECT): New macro is -recognized. -* misc.c (GC_FORCE_UNMAP_ON_GCOLLECT): Likewise. -* include/gc.h (GC_INIT_CONF_FORCE_UNMAP_ON_GCOLLECT): New -internal macro (used by GC_INIT only). -* misc.c (GC_force_unmap_on_gcollect): New global variable. -* misc.c (GC_init): Recognize new "GC_FORCE_UNMAP_ON_GCOLLECT" -environment variable (and set GC_force_unmap_on_gcollect). -* misc.c (GC_set_force_unmap_on_gcollect, -GC_get_force_unmap_on_gcollect): New public function. -* tests/test.c (window_proc): Call GC_set_force_unmap_on_gcollect -to force the mode on if WM_HIBERNATE; restore the mode after -GC_gcollect(). - -* Makefile.direct (LARGE_CONFIG): Update information. -* include/gc.h (GC_stop_func): Refine the comment. - -* configure.ac: Use EMPTY_GETENV_RESULTS instead of NO_GETENV for -Win32 (workaround for Wine bug). - -* allchblk.c (GC_freehblk): Adjust local variables indentation. -* mallocx.c (GC_generic_malloc_many): Likewise. -* typd_mlc.c (GC_malloc_explicitly_typed_ignore_off_page, -GC_calloc_explicitly_typed): Likewise. -* typd_mlc.c (GC_make_array_descriptor): Remove unnecessary -brackets. - -* configure.ac: Replace GC_WIN32_THREADS with GC_THREADS. -* configure.ac: Process enable_parallel_mark option for Cygwin and -Win32; define THREAD_LOCAL_ALLOC for Win32. - -* include/private/gc_priv.h: Define AO_ASSUME_WINDOWS98 if -PARALLEL_MARK (required for VC++ x86). - -* dbg_mlc.c (GC_generate_random_backtrace): Call -GC_try_to_collect(GC_never_stop_func) instead of GC_gcollect(); -if GC is disabled then print error message and return. -* include/gc.h (GC_try_to_collect): Refine the comment. -* include/private/gc_priv.h (GC_never_stop_func): Fix return type; -refine the comment. - -* add_gc_prefix.c: Move the file to the new "extra" directory. -* AmigaOS.c: Likewise. -* gcname.c: Likewise. -* if_mach.c: Likewise. -* if_not_there.c: Likewise. -* MacOS.c: Likewise. -* msvc_dbg.c: Likewise. -* setjmp_t.c: Likewise. -* threadlibs.c: Likewise. -* EMX_MAKEFILE: Prepend setjmp_t.c with "extra" directory. -* Makefile: Prepend AmigaOS.c, MacOS.c, add_gc_prefix.c, gcname.c, -if_mach.c, if_not_there.c, msvc_dbg.c, setjmp_t.c, threadlibs.c -with "extra" directory. -* Makefile.am: Likewise. -* Makefile.direct: Likewise. -* Makefile.dj: Likewise. -* Makefile.in: Likewise. -* NT_MAKEFILE: Prepend msvc_dbg.obj with "extra" directory. -* NT_STATIC_THREADS_MAKEFILE: Likewise. -* NT_X64_STATIC_THREADS_MAKEFILE: Likewise. -* NT_X64_THREADS_MAKEFILE: Likewise. -* NT_THREADS_MAKEFILE: Prepend msvc_dbg.c with "extra" directory. -* gc.mak: Likewise. -* PCR-Makefile: Prepend if_mach.c, if_not_there.c with "extra" -directory. -* SMakefile.amiga: Prepend AmigaOS.c, setjmp_t.c with "extra" -directory. -* doc/simple_example.html: Update for threadlibs.c. -* os_dep.c: Prepend included AmigaOS.c with "extra" directory. - -* include/gc.h (GC_do_blocking, GC_call_with_gc_active): New -function prototype. -* include/private/gc_priv.h (STOP_WORLD): Replace a no-op (for the -single-threaded case) with an assertion check for the state to be -not a "do-blocking" one. -* include/private/gc_priv.h (blocking_data): Move the structure -definition from pthread_support.c; change "fn" return type to void -pointer. -* include/private/gc_priv.h (GC_activation_frame_s): New structure -type. -* include/private/gc_priv.h (GC_push_all_stack_frames): New -function declaration (only if THREADS). -* include/private/gc_priv.h (GC_world_stopped): Don't declare -unless THREADS. -* include/private/gc_priv.h (GC_blocked_sp, -GC_activation_frame_s): New declaration (only if not THREADS). -* include/private/gc_priv.h (GC_push_all_register_frames): New -function declaration (only for IA-64). -* include/private/gc_priv.h (NURSERY, GC_push_proc): Remove -obsolete (unused) symbols. -* include/private/gc_priv.h (GC_push_all_stack_partially_eager): -Remove declaration (since it is static now). -* mark_rts.c (GC_push_all_stack_partially_eager): Move from mark.c -(for code locality) and make STATIC. -* mark_rts.c (GC_push_all_register_frames): New function (only for -IA-64). -* mark_rts.c (GC_push_all_stack_frames): New function (only if -THREADS). -* mark_rts.c (GC_add_trace_entry): New function prototype (used by -GC_push_all_stack_partially_eager(), only if TRACE_BUF). -* mark_rts.c (GC_push_all_stack_part_eager_frames): New function. -* mar_rts.c (GC_save_regs_ret_val): Move the declaration out of a -function body (only for IA-64). -* mark_rts.c (GC_push_current_stack): Call -GC_push_all_stack_part_eager_frames() instead of -GC_push_all_stack_partially_eager(). -* mark_rts.c (GC_push_current_stack): Call -GC_push_all_register_frames() instead of GC_push_all_eager() for -IA-64 backing store. -* misc.c (GC_do_blocking_inner): Declare function (if THREADS -only). -* misc.c (GC_blocked_sp, GC_blocked_register_sp, -GC_activation_frame): New global variables (only if not THREADS). -* misc.c (GC_call_with_gc_active, GC_do_blocking_inner): New API -function (only if not THREADS). -* misc.c (GC_do_blocking): Move the function from -pthread_support.c. -* include/private/pthread_support.h (GC_Thread_Rep): Add -"activation_frame" field. -* pthread_stop_world.c (GC_push_all_stacks): Call -GC_push_all_stack_frames() and GC_push_all_register_frames instead -of GC_push_all_stack() and/or GC_push_all_eager(); don't check for -STACK_GROWS_UP here. -* pthread_support.c (GC_do_blocking_inner): Remove "static"; store -"fn" result back to "client_data" field. -* pthread_support.c (GC_call_with_gc_active): New API function. -* win32_threads.c (GC_call_with_gc_active): Likewise. -* win32_threads.c (GC_Thread_Rep): Add "thread_blocked_sp" and -"activation_frame" fields. -* win32_threads.c (GC_new_thread): Add assertion checking for -thread_blocked_sp is NULL. -* win32_threads.c (GC_do_blocking_inner): New function. -* win32_threads.c (GC_stop_world): Don't suspend a thread if its -thread_blocked_sp is non-NULL. -* win32_threads.c (GC_push_stack_for): Use thread -"activation_frame" (if non-NULL); use "thread_blocked_sp" if -non-NULL (instead of calling GetThreadContext()); "UNPROTECT" the -thread before modifying its last_stack_min; call -GC_push_all_stack_frames() instead of GC_push_all_stack(); update -the comments. - -* alloc.c (GC_default_stop_func): New static variable (initialized -to GC_never_stop_func). -* alloc.c (GC_set_stop_func, GC_get_stop_func): New function. -* alloc.c (GC_timeout_stop_func): Define as GC_default_stop_func -(instead of GC_never_stop_func) if SMALL_CONFIG (or NO_CLOCK), -else call GC_default_stop_func() before getting "current_time". -* alloc.c (GC_maybe_gc): Expand GC_gcollect_inner() macro (for -FIXME comment). -* alloc.c (GC_maybe_gc, GC_collect_a_little_inner): add FIXME for -replacing GC_never_stop_func with GC_default_stop_func (if -possible). -* alloc.c (GC_gcollect): Use GC_default_stop_func. -* alloc.c (GC_collect_or_expand): Use GC_default_stop_func -(instead of GC_never_stop_func) unless it is trigged due to out of -memory; don't increment GC_fail_count and don't output warning -(before trying to collect again) in case the collection has been -interrupted (by GC_default_stop_func) and the heap expansion has -failed too. -* include/gc.h (GC_set_stop_func, GC_get_stop_func): New function -prototypes. - -* os_dep.c (GC_get_stack_base): Add FIXME; add assertion for -GC_get_writable_length() result. - -* configure.ac: Don't use -lpthread -ldl for Cygwin. - -* NT_THREADS_MAKEFILE: Make it back equal to gc.mak. - -* include/private/gcconfig.h (GWW_VDB): Undefine if -USE_GLOBAL_ALLOC (since incompatible). -* os_dep.c (GetWriteWatch_alloc_flag): Define as 0 unless GWW_VDB -is defined. -* os_dep.c (GC_unmap_threshold): Declare (for use in -GC_init_win32) if USE_MUNMAP. -* os_dep.c (GC_init_win32): Turn off memory unmapping if -GlobalAlloc() is used. -* os_dep.c (GC_win32_get_mem): Define and use new -VIRTUAL_ALLOC_PAD macro; don't waste a extra memory page unless -MPROTECT_VDB is in use. - -* Makefile: Replace "version.h" with "include/gc_version.h". -* include/gc_version.h: Likewise. - -* alloc.c (GC_collect_or_expand): Output heap size in WARN() -(before returning FALSE) for convenience. - -* allchblk.c (GC_allochblk_nth): Use GC_PRIdPTR in WARN() format -string. -* pthread_support.c (start_mark_threads, GC_thr_init): Likewise. -* win32_threads.c (GC_delete_thread): Likewise. -* include/private/gc_priv.h (GC_PRIdPTR): New macro. -* pthread_stop_world.c (GC_suspend_handler_inner): Remove -unnecessary cast for WARN argument. -* pthread_support.c (start_mark_threads): if pthread_create() -failed then don't try to create other marker threads and (after -printing a warning) adjust GC_markers and GC_parallel values; log -GC_markers value (possibly adjusted) after that. - -* win32_threads.c (start_mark_threads): if pthread_create() is -failed then don't try to create other marker threads and (after -printing a warning) adjust GC_markers and GC_parallel values. -* win32_threads.c (mark_mutex_event, builder_cv, mark_cv): Move -the definition upper (to be visible in start_mark_threads()). -* win32_threads.c (start_mark_threads): if CreateThread() or -_beginthreadex() is failed then don't try to create other marker -threads and (after printing a warning) adjust GC_markers, -GC_parallel values, and destroy the event objects (either only -some for the uncreated threads if DONT_USE_SIGNALANDWAIT or all if -not a single thread is created). -* win32_threads.c (GC_thr_init): Log GC_markers value (possibly -adjusted) after start_mark_threads() call. - -* Makefile.am: Back remove "GC_" prefix for PTHREADS, -DARWIN_THREADS, WIN32_THREADS (for configure.ac). - -* include/private/gc_priv.h: Change include of config.h to -private/config.h. -* include/private/gc_pmark.h: Likewise. -* gc_cpp.cc: Likewise. -* tests/test.c: Likewise. -* tests/test_cpp.cc: Include private/config.h (if HAVE_CONFIG_H); -undefine GC_BUILD. - -* finalize.c (GC_general_register_disappearing_link): Return -GC_SUCCESS, GC_DUPLICATE, GC_NO_MEMORY (instead of 0, 1 and 2, -respectively). -* include/gc.h (GC_NO_MEMORY): New macro (defined as 2). -* include/gc.h (GC_register_disappearing_link, -GC_general_register_disappearing_link): Update the comment. -* typd_mlc.c (GC_calloc_explicitly_typed): Use GC_NO_MEMORY macro. -* finalize.c (GC_general_register_disappearing_link, -GC_register_finalizer_inner): Recalculate the hash table index -after GC_oom_fn succeeded (since the table may grow while not -holding the lock) and check again that the entry is still not in -the table (free the unused entry otherwise unless DBG_HDRS_ALL). -* finalize.c (GC_register_finalizer_inner): Initialize "hhdr" -local variable (to prevent a compiler warning). -* finalize.c (GC_register_finalizer_inner): Don't modify the data -pointed by "ocd" and "ofn" in GC_register_finalizer_inner() failed -(due to out of memory). - -* alloc.c (GC_set_fl_marks, GC_clear_fl_marks): Transform loop to -suppress compiler "variable might be uninitialized" warnings. - -* Makefile.direct (DONT_USE_SIGNALANDWAIT): Add the comment for. -* win32_threads.c (DONT_USE_SIGNALANDWAIT): Always define for -WinCE. -* win32_threads.c (THREAD_HANDLE): Cast Id (of DWORD type) to -HANDLE thru word type (to avoid a compiler warning) for WinCE. -* win32_threads.c (GC_marker_cv, GC_marker_Id): New static array -(only if DONT_USE_SIGNALANDWAIT). -* win32_threads.c (start_mark_threads): Initialize GC_marker_Id -and GC_marker_cv for each helper thread (only if -DONT_USE_SIGNALANDWAIT). -* win32_threads.c (GC_mark_mutex_state): New static variable (only -if DONT_USE_SIGNALANDWAIT). -* win32_threads.c (GC_mark_mutex_waitcnt, -signalObjectAndWait_func): Don't define if DONT_USE_SIGNALANDWAIT. -* win32_threads.c (GC_acquire_mark_lock, GC_release_mark_lock): -Use InterlockedExchange() over GC_mark_mutex_state (instead of -AO_fetch_and_add()) if DONT_USE_SIGNALANDWAIT. -* win32_threads.c (GC_wait_marker, GC_notify_all_marker): -Implement wait/broadcast primitives using Win32 multiple events -(one for each marker thread) if DONT_USE_SIGNALANDWAIT (instead of -using Win32 SignalObjectAndWait). -* win32_threads.c (GC_thr_init): Don't declare hK32 local -variable, don't check for GC_wnt, and don't initialize -signalObjectAndWait_func if DONT_USE_SIGNALANDWAIT. - -* alloc.c (GC_finish_collection): Call GC_print_finalization_stats -if GC_print_stats (after getting "done_time"). -* finalize.c (GC_old_dl_entries): New static variable (only if not -SMALL_CONFIG). -* finalize.c (GC_finalize): Save current GC_dl_entries value (only -if not SMALL_CONFIG). -* finalize.c (GC_print_finalization_stats): Define if and only if -not SMALL_CONFIG; use GC_old_dl_entries value; use GC_log_printf() -instead of GC_printf(); use "%lu" (instead of "%u") print format -specifier; use unsigned long type for "ready" counter (for LP64 -targets). -* misc.c (GC_dump): No longer call GC_print_finalization_stats() -here (since it is called from GC_finish_collection()). -* misc.c (STACKBASE): Remove unused macro undef (for NOSYS and -ECOS). - -* alloc.c (GC_expand_hp): Replace GC_init_inner() call with -GC_init() one. -* malloc.c (GC_alloc_large, GC_generic_malloc_inner): Likewise. -* mallocx.c (GC_generic_malloc_many): Likewise. -* misc.c (GC_enable_incremental): Likewise. -* alloc.c (GC_expand_hp): Update the comment. -* mark.c (GC_obj_kinds): Likewise. -* win32_threads.c (GC_allow_register_threads): Likewise. -* private/gc_priv.h (GC_init_inner): Remove function declaration. -* misc.c (GC_init_inner): Replace with public GC_init(). - -* gcj_mlc.c (GC_gcj_fake_mark_proc): New static function. -* gcj_mlc.c (GC_init_gcj_malloc): If mp is 0 then supply -GC_gcj_fake_mark_proc (aborting with the appropriate message) -instead. - -* os_dep.c (GC_wince_get_mem): If VirtualAlloc() returns NULL (due -to out of memory) then don't increment GC_n_heap_bases and don't -call VirtualAlloc() again (with MEM_COMMIT). -* os_dep.c (GC_remap): Abort with a more informatory message if -VirtualAlloc() fails due to out of memory; update FIXME. - -* Makefile: Fix typo for msvc_dbg.c. -* Makefile.direct: Likewise. -* Makefile.am: Prefix PTHREADS, DARWIN_THREADS, WIN32_THREADS with -"GC_". -* Makefile.dj: Don't reference remove files (nursery.c, -gc_nursery.h, gc_copy_descr.h). -* NT_MAKEFILE: Don't define __STDC__ macro (no longer used). -* NT_STATIC_THREADS_MAKEFILE: Likewise. -* NT_THREADS_MAKEFILE: Likewise. -* NT_X64_STATIC_THREADS_MAKEFILE: Likewise. -* NT_X64_THREADS_MAKEFILE: Likewise. -* gc.mak: Likewise. -* NT_MAKEFILE: Remove unnecessary -DGC_BUILD (since it is always -defined in the source files). -* NT_THREADS_MAKEFILE: Likewise. -* NT_X64_THREADS_MAKEFILE: Likewise. -* gc.mak: Likewise. -* NT_X64_THREADS_MAKEFILE: Fix typo for -DGC_NOT_DLL. -* NT_STATIC_THREADS_MAKEFILE: Replace GC_WIN32_THREADS with -GC_THREADS. -* NT_THREADS_MAKEFILE: Likewise. -* NT_X64_STATIC_THREADS_MAKEFILE: Likewise. -* NT_X64_THREADS_MAKEFILE: Likewise. -* gc.mak: Likewise. -* NT_MAKEFILE: Define _CRT_SECURE_NO_DEPRECATE to suppress the -compiler warnings. -* NT_STATIC_THREADS_MAKEFILE: Likewise. -* NT_X64_STATIC_THREADS_MAKEFILE: Place -D_CRT_SECURE_NO_DEPRECATE -before "$*.C" (and "$*.CPP"). -* NT_X64_THREADS_MAKEFILE: Likewise. - -* doc/README.solaris2: Replace GC_SOLARIS_THREADS with GC_THREADS. -* doc/README.win32: Replace GC_WIN32_THREADS with GC_THREADS. -* doc/README.win64: Add info about mingw-w64; add note for VC++ -warnings suppression. - -* os_dep.c (GC_forward_exception): Fix logic in several places. -(OSX-specific) - -* include/private/gc_priv.h (MAX_HEAP_SECTS): Guard with ifndef. - -* Makefile.direct: Copy missing information for -DSHORT_DBG_HDRS -from Makefile. -* Makefile: Remove the information about "define arguments" (which -is incomplete and outdated compared to that in Makefile.direct); -add help reference to Makefile.direct. -* Makefile.dj: Likewise. - -* alloc.c (world_stopped_total_time, world_stopped_total_divisor): -Replace "STATIC" with "static" in the definition (since the -symbols aren't prefixed with "GC_"). -* win32_threads.c (marker_sp, marker_bsp, marker_last_stack_min, -start_mark_threads, mark_mutex, builder_cv, mark_cv, -mark_mutex_event, signalObjectAndWait_func, main_thread_start): -Likewise. -* pthread_support.c (GC_wait_builder): Define as STATIC. -* win32_threads.c (GC_wait_builder): Likewise. - -* misc.c (GC_get_heap_size_inner, GC_get_free_bytes_inner): New -API function. -* include/gc_pmark.h (GC_get_heap_size_inner, -GC_get_free_bytes_inner): New function declaration. - -* include/gc.h: Recognize __CEGCC__ (as a synonym for _WIN32_WCE). -* include/gc_config_macros.h: Likewise. -* include/gc.h (GC_MAXIMUM_HEAP_SIZE): Recognize new macro. -* include/gc.h (GC_INIT_CONF_MAXIMUM_HEAP_SIZE): New macro (for -internal use). -* include/gc_config_macros.h: Always include stddef.h if GCC. -* include/gc_config_macros.h (GC_API): Define for CeGCC in the -same way as for MinGW. -* include/gc_config_macros.h (GC_API): Group the definition for -all cases together (check for GC_DLL only once). -* include/gc_pthread_redirects.h: Group non-Darwin code together. -* tests/test.c: Recognize GC_PRINT_VERBOSE_STATS (only if GC_DLL). - -* Makefile.direct (GC_PTHREADS_PARAMARK, GC_IGNORE_GCJ_INFO, -GC_PRINT_VERBOSE_STATS, GC_DONT_EXPAND, GC_INITIAL_HEAP_SIZE, -GC_FREE_SPACE_DIVISOR, GC_TIME_LIMIT, GC_FULL_FREQ): Add the -comment for. -* misc.c (GC_init_inner): Recognize GC_PRINT_VERBOSE_STATS (new -macro). -* dyn_load.c (GC_wnt): Change definition to TRUE for WinCE; add -FIXME and the comment for WinCE. -* gcj_mlc.c (GC_init_gcj_malloc): Recognize GC_IGNORE_GCJ_INFO -(new macro). -* include/gc.h (GC_HAVE_BUILTIN_BACKTRACE): Don't define for VC++ -WinCE (since backtrace() is unimplemented). -* include/private/gc_priv.h (GC_n_heap_bases): Remove declaration -(since static). -* os_dep.c (GC_n_heap_bases): Define as STATIC; move the -definition to be above GC_is_heap_base(). -* include/private/gcconfig.h: Don't define NOSYS for WinCE on ARM -(both for MinGW and CeGCC toolchains). -* include/private/gcconfig.h: Recognize __CEGCC__ and -__MINGW32CE__ (as synonyms for __WIN32_WCE). -* include/private/gcconfig.h: If SH4 then don't set config -parameters for SH. -* include/private/thread_local_alloc.h (GC_key_create): Don't -abort on failures, just return -1 in these cases (this also -prevents compilation error for targets where ABORT is defined -indirectly as an inline assembler sequence). -* mark.c (WRAP_MARK_SOME): Also define for WinCE; add FIXME for -the GCC-based cross-compiler. -* mark.c (ext_ex_regn, mark_ex_handler): Don't define unless -WRAP_MARK_SOME is defined; define also for WinCE case; don't -check for _WIN64 (since WRAP_MARK_SOME is undefined for it). -* mark.c (GC_mark_some): Use __try/__except also for WinCE; update -the comment. -* misc.c: Include signal.h after gc_pmark.h included; check for -MSWINCE instead of _WIN32_WCE. -* misc.c (GC_init_inner): Remove duplicate GC_setpagesize() call. -* misc.c: Don't include for WinCE targets. -* misc.c (GC_write): Define _MAX_PATH if undefined (workaround for -CeGCC toolchain). -* misc.c (GC_write): Use OutputDebugStringW() instead of -_CrtDbgReport() for WinCE targets. -* os_dep.c (GC_least_described_address): Define as STATIC. -* os_dep.c (GC_register_data_segments): Fix code indentation. -* os_dep.c (GC_wince_get_mem): Initialize "result" local variable -(to prevent a compiler warning). -* os_dep.c (GC_dirty_init): Add comment for WinCE target. -* tests/test.c: Don't include winbase.h directly if GCC for WinCE, -include assert.h instead. -* tests/test.c (tiny_reverse_test): Define and use -TINY_REVERSE_UPPER_VALUE macro (4 if VERY_SMALL_CONFIG else 10); -useful for WinCE. -* win32_threads.c (GC_Thread_Rep): Don't declare "handle" field -for WinCE (since thread Id is used as a "real" thread handle). -* win32_threads.c (THREAD_HANDLE): New macro. -* win32_threads.c (GC_register_my_thread_inner): Don't recognize -DONT_IMPORT_GETCURTHREAD anymore; don't record thread handle on -WinCE. -* Makefile.direct (DONT_IMPORT_GETCURTHREAD): Remove comment for. -* win32_threads.c (UNPROTECT, GC_fault_handler_lock): Don't check -for MSWINCE. -* win32_threads.c (GC_delete_gc_thread, GC_delete_thread): Don't -close thread handle on WinCE (since it's a thread Id). -* win32_threads.c (GC_suspend): Don't check for MSWINCE in the -MPROTECT-related code (for the case if MPROTECT_VDB would be -implemented for WinCE). -* win32_threads.c (GC_suspend, GC_start_world, GC_push_stack_for): -Use THREAD_HANDLE(t) to obtain thread handle. -* win32_threads.c (GC_PTHREADS_PARAMARK): New macro recognized; -implicitly define GC_PTHREADS_PARAMARK if GC_PTHREADS; include -pthread.h; define NUMERIC_THREAD_ID(id) if undefined yet; replace -GC_PTHREADS with GC_PTHREADS_PARAMARK where appropriate (for the -parallel mark support). -* win32_threads.c (start_mark_threads): Use int type for "i" local -variable (instead of "unsigned") to prevent a compiler warning. -* win32_threads.c (start_mark_threads): Don't check CreateThread() -result for -1; call CloseHandle() for the handle created by -CreateThread() (on WinCE); don't use errno (since errno.h is -missing on some targets like WinCE) when printing warning on a -marker thread creation failure. -* win32_threads.c (signalObjectAndWait_func): Define for WinCE. -* win32_threads.c (GC_wait_marker): Remove unnecessary assertion -for non-zero signalObjectAndWait_func (to make the code compilable -for WinCE). -* win32_threads.c (GC_thr_init): Allow PARALLEL_MARK for WinCE; -use GC_sysinfo to get processors count if WinCE; don't check for -SignalObjectAndWait() if WinCE; replace GC_PTHREADS with -GC_PTHREADS_PARAMARK. -* win32_threads.c (GC_thr_init): Recognize GC_MIN_MARKERS new -macro (useful for testing parallel marking on WinCE). -* win32_threads.c (GC_win32_start, main_thread_start): Define as -STATIC. -* win32_threads.c: Don't define main_thread_args, -main_thread_start(), WinMain() for WinCE if GC_DLL. -* win32_threads.c (WINCE_MAIN_STACK_SIZE): Remove useless macro -(since the stack size parameter is ignored on WinCE). -* win32_threads.c (main_thread_start): Remove forward declaration; -place its definition before WinMain() one. -* win32_threads.c (WinMain): Abort if GC_CreateThread() or -WaitForSingleObject() failed (for the main thread). - -* allchblk.c (MUNMAP_THRESHOLD): Move macro definition out of -a function. -* allchblk.c (GC_unmap_threshold): New global variable definition -(initialized to MUNMAP_THRESHOLD). -* allchblk.c (GC_unmap_old): Use GC_unmap_threshold instead of -MUNMAP_THRESHOLD; skip unmapping if GC_unmap_threshold is 0. -* doc/README.environment (GC_UNMAP_THRESHOLD): Add information. -* misc.c (GC_unmap_threshold): New variable declaration. -* misc.c (GC_init_inner): Recognize "GC_UNMAP_THRESHOLD" -environment variable to set GC_unmap_threshold value (only if -USE_MUNMAP). - -* dbg_mlc.c (OFN_UNSET): New macro (to detect -GC_register_finalizer() failures). -* dbg_mlc.c (store_old): Add a check for register_finalizer() -failure caused by an out-of-memory event (leave *ofn and *ocd -unmodified in that case). -* dbg_mlc.c (GC_debug_register_finalizer, -GC_debug_register_finalizer_no_order, -GC_debug_register_finalizer_unreachable, -GC_debug_register_finalizer_ignore_self): Initialize my_old_fn -to OFN_UNSET; clear *ocd and *ofn for non-heap objects (the same -as in GC_register_finalizer_inner()). - -* Makefile.direct (GC_DLL): Add the comment for. -* doc/README.macros: Fix a typo. -* doc/README.macros (_DLL, GC_DLL, GC_NOT_DLL): Update info. -* doc/README.macros (__STDC__): Remove info. -* dbg_mlc.c (GC_get_back_ptr_info, GC_generate_random_heap_address, -GC_generate_random_valid_address, GC_print_backtrace, -GC_generate_random_backtrace, GC_register_describe_type_fn): Add -GC_API and GC_CALL to function definition. -* malloc.c (GC_generic_malloc): Likewise. -* mallocx.c (GC_incr_bytes_allocd, GC_incr_bytes_freed): Likewise. -* mark.c (GC_mark_and_push): Likewise. -* misc.c (GC_new_free_list_inner, GC_new_free_list, -GC_new_kind_inner, GC_new_kind, GC_new_proc_inner, GC_new_proc): -Likewise. -* include/gc_backptr.h (GC_get_back_ptr_info, -GC_generate_random_heap_address, GC_generate_random_valid_address, -GC_generate_random_backtrace, GC_print_backtrace): Add GC_API and -GC_CALL to function prototype. -* include/gc_mark.h (GC_mark_and_push, GC_new_free_list, -GC_new_free_list_inner, GC_new_kind, GC_new_kind_inner, -GC_new_proc, GC_new_proc_inner, GC_generic_malloc, -GC_register_describe_type_fn): Likewise. -* include/new_gc_alloc.h (GC_incr_bytes_allocd, GC_incr_mem_freed, -GC_generic_malloc_words_small): Likewise. -* gc_cpp.cc: Include "config.h" (if HAVE_CONFIG_H defined). -* include/private/gc_pmark.h: Likewise. -* include/private/gc_priv.h: Likewise. -* tests/test.c: Likewise. -* gc_cpp.cc: Define GC_BUILD. -* include/private/gc_pmark.h: Likewise. -* include/private/gc_priv.h: Likewise. -* gc_dlopen.c (WRAP_FUNC, REAL_FUNC): New macro. -* gc_dlopen.c (dlopen): Add GC_API to the wrapper function -definition. -* pthread_support.c (GC_pthread_create, GC_pthread_sigmask, -GC_pthread_join, GC_pthread_detach, pthread_sigmask, pthread_join, -pthread_detach, pthread_create): Likewise. -* win32_threads.c (GC_pthread_join, GC_pthread_create, -GC_pthread_sigmask, GC_pthread_detach): Likewise. -* gc_dlopen.c (dlopen): Use WRAP_FUNC and REAL_FUNC macros. -* include/gc_backptr.h: Include "gc.h". -* include/gc_backptr.h: Use extern "C" for the exported functions. -* include/gc_mark.h: Likewise. -* include/gc_config_macros.h (GC_THREADS): Define the macro if any -GC_XXX_THREADS is defined. -* include/gc_config_macros.h (_PTHREADS, _POSIX4A_DRAFT10_SOURCE): -Move the definitions below the place where GC_NETBSD_THREADS and -GC_DGUX386_THREADS are defined. -* include/gc_config_macros.h (GC_DLL): Don't define (even if _DLL -is defined) for GCC. -* include/gc_config_macros.h (GC_API): Define for Cygwin (in the -same way as for VC++); define for GCC v4+ (other than already -recognized MinGW/Cygwin) as a "default" visibility attribute if -GC_DLL is defined. -* include/gc_config_macros.h (GC_ATTR_MALLOC, GC_ATTR_ALLOC_SIZE): -New macro. -* include/gc.h (GC_malloc, GC_malloc_atomic, GC_strdup, -GC_malloc_uncollectable, GC_malloc_stubborn, GC_memalign, -GC_malloc_atomic_uncollectable, GC_malloc_ignore_off_page, -GC_malloc_atomic_ignore_off_page, GC_debug_malloc, -GC_debug_malloc_atomic, GC_debug_strdup, -GC_debug_malloc_uncollectable, GC_debug_malloc_stubborn, -GC_debug_malloc_ignore_off_page, -GC_debug_malloc_atomic_ignore_off_page, -GC_debug_malloc_replacement): Add GC_ATTR_MALLOC attribute. -* include/gc_gcj.h (GC_gcj_malloc, GC_debug_gcj_malloc, -GC_gcj_malloc_ignore_off_page): Likewise. -* include/gc.h (GC_malloc, GC_malloc_atomic, -GC_malloc_uncollectable, GC_malloc_stubborn, -GC_malloc_atomic_uncollectable, GC_malloc_ignore_off_page, -GC_malloc_atomic_ignore_off_page, GC_debug_malloc, -GC_debug_malloc_atomic, GC_debug_malloc_uncollectable, -GC_debug_malloc_stubborn, GC_debug_malloc_ignore_off_page, -GC_debug_malloc_atomic_ignore_off_page, -GC_debug_malloc_replacement: Add GC_ATTR_ALLOC_SIZE attribute -(for the first argument). -* include/gc_gcj.h (GC_gcj_malloc, GC_debug_gcj_malloc, -GC_gcj_malloc_ignore_off_page): Likewise. -* include/gc.h (GC_memalign, GC_realloc, GC_debug_realloc, -GC_debug_realloc_replacement): Add GC_ATTR_ALLOC_SIZE attribute -(for the second argument). -* include/gc.h (GC_malloc, GC_malloc_atomic, GC_strdup, -GC_malloc_uncollectable, GC_malloc_stubborn, GC_memalign, -GC_malloc_atomic_uncollectable, GC_free, GC_base, GC_size, -GC_realloc, GC_expand_hp, GC_set_max_heap_size, -GC_exclude_static_roots, GC_add_roots, GC_remove_roots, -GC_register_displacement, GC_debug_register_displacement, -GC_try_to_collect, GC_malloc_ignore_off_page, -GC_malloc_atomic_ignore_off_page, GC_debug_malloc, -GC_debug_malloc_atomic, GC_debug_strdup, -GC_debug_malloc_uncollectable, GC_debug_malloc_stubborn, -GC_debug_malloc_ignore_off_page, -GC_debug_malloc_atomic_ignore_off_page, GC_debug_free, -GC_debug_realloc, GC_debug_malloc_replacement, -GC_debug_realloc_replacement, GC_finalization_proc, -GC_register_finalizer, GC_debug_register_finalizer, -GC_register_finalizer_ignore_self, -GC_debug_register_finalizer_ignore_self, -GC_register_finalizer_no_order, -GC_debug_register_finalizer_no_order, -GC_register_finalizer_unreachable, -GC_debug_register_finalizer_unreachable, -GC_register_disappearing_link, -GC_general_register_disappearing_link, -GC_unregister_disappearing_link, GC_noop1, GC_warn_proc, -GC_set_warn_proc, GC_ignore_warn_proc, GC_fn_type, -GC_call_with_alloc_lock, GC_stack_base_func, -GC_call_with_stack_base, GC_same_obj, GC_pre_incr, GC_post_incr, -GC_is_visible, GC_is_valid_displacement, GC_same_obj_print_proc, -GC_is_valid_displacement_print_proc, GC_is_visible_print_proc, -GC_malloc_many, GC_CreateThread, GC_beginthreadex, -GC_endthreadex): Comment out (or remove if single and meaningless) -function argument names (to avoid identifiers out of the name -space). -* include/gc_gcj.h (GC_init_gcj_malloc, GC_gcj_malloc, -GC_debug_gcj_malloc, GC_gcj_malloc_ignore_off_page): Likewise. -* include/gc.h (GC_try_to_collect): Update the comment. -* include/gc.h (GC_size, GC_register_my_thread): Add const -qualifier for the argument referent. -* misc.c (GC_size): Likewise. -* pthread_support.c (GC_register_my_thread_inner, -GC_register_my_thread): Likewise. -* win32_threads.c (GC_register_my_thread_inner, -GC_register_my_thread): Likewise. -* include/gc.h (GC_INIT_CONF_ROOTS): New macro for internal use -(define instead of GC_INIT() for Cygwin and AIX). -* include/gc.h (GC_DONT_EXPAND, GC_MAX_RETRIES, -GC_FREE_SPACE_DIVISOR, GC_FULL_FREQ, GC_TIME_LIMIT, GC_IGNORE_WARN, -GC_INITIAL_HEAP_SIZE): Recognize new macro. -* include/gc.h (GC_INIT_CONF_DONT_EXPAND, GC_INIT_CONF_MAX_RETRIES, -GC_INIT_CONF_FREE_SPACE_DIVISOR, GC_INIT_CONF_FULL_FREQ, -GC_INIT_CONF_TIME_LIMIT, GC_INIT_CONF_IGNORE_WARN, -GC_INIT_CONF_INITIAL_HEAP_SIZE): New macro for internal use. -* include/gc.h (GC_INIT): Use GC_INIT_CONF_XXX macros. -* include/gc_mark.h: Prefix GC_H with '_'. -* include/gc_mark.h (GC_least_plausible_heap_addr, -GC_greatest_plausible_heap_addr, GC_debug_header_size): Use GC_API -for the public variable declaration. -* include/new_gc_alloc.h (GC_objfreelist_ptr, GC_aobjfreelist_ptr, -GC_uobjfreelist_ptr, GC_auobjfreelist_ptr): Likewise. -* include/gc_pthread_redirects.h (GC_pthread_create, -GC_pthread_sigmask, GC_dlopen, GC_pthread_join, GC_pthread_detach): -Use GC_API for the wrapper prototype. -* include/gc_pthread_redirects.h (pthread_create, pthread_join, -pthread_detach, pthread_sigmask, dlopen): Undefine unconditionally -before redirecting. -* include/new_gc_alloc.h: Replace GC_incr_mem_freed() with -GC_incr_bytes_freed(); remove FIXME. -* include/private/gc_priv.h (GC_make_closure, -GC_debug_invoke_finalizer, GC_noop): Remove GC_API for the private -function. -* tests/test.c (GC_print_stats): Handle GC_DLL case regardless of -the target. - -* finalize.c (GC_general_register_disappearing_link, -GC_register_finalizer_inner): Remove unnecessary "ifdef THREADS" -guard for LOCK/UNLOCK(). -* finalize.c (GC_general_register_disappearing_link, -GC_register_finalizer_inner): Get GC_oom_fn value before releasing -the lock (to prevent data races). -* gcj_mlc.c (GC_gcj_malloc, GC_debug_gcj_malloc, -GC_gcj_malloc_ignore_off_page): Likewise. -* mallocx.c (GC_generic_malloc_ignore_off_page): Likewise. -* include/gc_inline.h (GC_FAST_MALLOC_GRANS): Use GC_get_oom_fn() -instead of GC_oom_fn (to prevent data races). -* malloc.c (GC_generic_malloc): Likewise. -* mallocx.c (GC_memalign): Likewise. -* pthread_support.c (pthread_create): Likewise. -* gcj_mlc.c (maybe_finalize): Acquire the lock before setting -last_finalized_no value to prevent data races. -* include/gc.h (GC_gc_no, GC_get_gc_no, GC_oom_fn, GC_set_oom_fn, -GC_set_find_leak, GC_set_finalize_on_demand, -GC_set_java_finalization, GC_set_finalizer_notifier, -GC_set_dont_expand, GC_set_full_freq, GC_set_non_gc_bytes, -GC_set_no_dls, GC_set_free_space_divisor, GC_set_max_retries, -GC_set_dont_precollect, GC_set_time_limit, GC_warn_proc): Refine -the comment. -* misc.c (GC_set_oom_fn): Likewise. -* include/gc.h (GC_general_register_disappearing_link): Refine the -comment (replace "soft" word with "weak"). -* misc.c (GC_oom_fn, GC_get_gc_no, GC_get_parallel, -GC_set_finalizer_notifier, GC_set_find_leak): Add the comment. -* misc.c (GC_set_oom_fn, GC_get_oom_fn, GC_set_finalizer_notifier, -GC_get_finalizer_notifier): Use LOCK/UNLOCK to prevent data races. - -* dbg_mlc.c: Guard include with ifndef MSWINCE; include -"private/dbg_mlc.h" before it. -* malloc.c: Likewise. -* dbg_mlc.c (GC_debug_strdup): Use memcpy() instead of strcpy() -for WinCE (since deprecated); evaluate strlen() only once; don't -set errno for WinCE. -* malloc.c (GC_strdup): Likewise. -* dyn_load.c (GC_wnt): Define as macro (FALSE) for WinCE. -* include/gc.h (GC_unregister_my_thread): Refine the comment. -* include/gc.h (GC_uintptr_t, GC_beginthreadex, GC_endthreadex): -Don't declare for WinCE. -* include/gc.h (GC_WINMAIN_WINCE_LPTSTR): New macro (WinCE only). -* include/gc.h (GC_WinMain): Remove GC_API. -* include/gc.h (GC_WinMain): Use GC_WINMAIN_WINCE_LPTSTR for -lpCmdLine. -* tests/test.c (GC_WinMain): Likewise. -* win32_threads.c (main_thread_args, GC_WinMain): Likewise. -* include/gc_config_macros.h (ptrdiff_t): Guard with -ifndef _PTRDIFF_T_DEFINED; define _PTRDIFF_T_DEFINED macro. -* include/private/gc_locks.h: Guard include "atomic_ops.h" with -ifdef GC_PTHREADS (and not GC_WIN32_THREADS). -* mark.c: Include "atomic_ops.h" if PARALLEL_MARK. -* thread_local_alloc.c: Include "atomic_ops.h" if GC_GCJ_SUPPORT. -* win32_threads.c: Include "atomic_ops.h" if MPROTECT_VDB. -* include/private/gc_locks.h: Use include "atomic_ops.h" instead -of include . -* include/private/gc_priv.h: Likewise. -* include/private/gc_locks.h (GC_allocate_ml, GC_need_to_lock): -Don't export (replace GC_API to "extern"). -* win32_threads.c (GC_allocate_ml): Don't export. -* include/private/gc_priv.h (DebugBreak): Define as macro for -WinCE (if not UNDER_CE and DebugBreak is not defined yet). -* include/private/gc_priv.h (UNALIGNED): Rename to UNALIGNED_PTRS -(since "UNALIGNED" is defined in winnt.h of WinCE). -* mark.c (UNALIGNED): Likewise. -* include/private/gcconfig.h (ARM32): Recognize _M_ARM and _ARM_. -* include/private/gcconfig.h (ALIGNMENT): Check always defined. -* include/private/gcconfig.h: Allow GC_WIN32_THREADS for WinCE. -* include/private/thread_local_alloc.h: Define USE_WIN32_SPECIFIC -for WinCE (since __declspec(thread) is unsupported). -* include/private/thread_local_alloc.h (TLS_OUT_OF_INDEXES): -Define for WinCE (if undefined). -* malloc.c (GC_malloc): Remove outdated comment about disabling -signals. -* misc.c: Don't include (since not used anymore and may -break TEXT() macro defined in winnt.h). -* misc.c (GC_init_inner): Don't use GetModuleHandle() and -InitializeCriticalSectionAndSpinCount() for WinCE. -* misc.c (GC_init_inner): Replace GetModuleHandleA() with -GetModuleHandle() (and use TEXT() macro controlled by UNICODE). -* misc.c (LOG_FILE): Remove unused macro; don't use _T() macro. -* misc.c (GC_CreateLogFile): New static function (Win32/WinCE -only); move the code from GC_write(); replace GETENV() with -GetEnvironmentVariable(); replace CreateFileA() with -CreateFile(); use TEXT() macro (for Unicode support); replace -strcat() with memcpy() (since deprecated in WinCE). -* misc.c (GC_write): Define as STATIC. -* win32_threads.c (GC_attached_thread): Likewise. -* misc.c (GC_write): Use GC_CreateLogFile(). -* misc.c: Define vsnprintf macro as StringCchVPrintfA for WinCE. -* misc.c (GC_abort): Try to invoke MessageBoxA() dynamically -(Win32 only) if DONT_USE_USER32_DLL is defined. -* misc.c (GC_abort): Duplicate msg to GC log file (for Win32 and -WinCE). -* misc.c (GC_abort): Use a more user-friendly abort if -NO_DEBUGGING (Win32 only). -* os_dep.c: Include "atomic_ops.h" only if MPROTECT_VDB (and -THREADS). -* os_dep.c (detect_GetWriteWatch): Use TEXT() for GetModuleHandle -(for Unicode support); check GetModuleHandle() result. -* tests/test.c: Don't define assert for WinCE (since may be -redefined by "assert.h" included from libatomic_ops). -* tests/test.c (FAIL): Define as ABORT for all targets (except -for PCR). -* tests/test.c (n_tests): Don't use AO_t. -* tests/test.c (check_heap_stats): Don't cast n_tests. -* tests/test.c (inc_int_counter): New function (for n_tests atomic -incrementation). -* tests/test.c (run_one_test): Test GC_memalign() for all targets. -* tests/test.c (run_one_test): Avoid unbalanced brackets in -#if-#else-#endif blocks. -* tests/test.c (run_one_test): Replace AO_fetch_and_add1() and -private LOCK/UNLOCK with GC_call_with_alloc_lock(inc_int_counter). -* tests/test.c (check_heap_stats): Replace -"if (sizeof(char *) > 4)" with "#if CPP_WORDSZ == 64" to suppress -"unreachable code" compiler warning. -* tests/test.c (WinMain): Set cmd type to LPWSTR (for WinCE -"UNDER_CE" mode); else use LPSTR type (for Win32 and WinCE). -* tests/test.c (thr_window): Replace "L" string prefix with -TEXT(). -* thread_local_alloc.c: Check THREADS is defined (to prevent other -compiler errors and warnings otherwise). -* tests/test.c (WinMain): Recognize GC_NO_DLLMAIN macro (for -GC_use_DllMain()). -* Makefile.direct (GC_NO_DLLMAIN, DONT_IMPORT_GETCURTHREAD): Add -the comments for. -* win32_threads.c (GC_register_my_thread_inner): Recognize -DONT_IMPORT_GETCURTHREAD macro. -* win32_threads.c: Recognize GC_NO_DLLMAIN macro (to exclude -DllMain support if needed). -* win32_threads.c (GC_NO_DLLMAIN): Define implicitly if DllMain -thread registration is unsupported for a given configuration. -* win32_threads.c (GC_use_DllMain): Update the comment; refine -ABORT message. -* win32_threads.c (GC_use_DllMain, -GC_started_thread_while_stopped, GC_register_my_thread_inner, -GC_lookup_thread_inner, GC_delete_gc_thread, -GC_allow_register_threads, GC_lookup_pthread, -GC_push_thread_structures, GC_stop_world, GC_push_all_stacks): -Check for GC_NO_DLLMAIN. -* win32_threads.c (GC_Thread_Rep.tm_in_use, GC_attached_thread, -DllMain): Don't define if GC_NO_DLLMAIN. -* win32_threads.c (GC_stop_world): Declare "i" and "max" local -variables only if not GC_NO_DLLMAIN (to suppress compiler -warning). -* win32_threads.c (GC_mark_thread, start_mark_threads): Use -CreateThread() instead of _beginthreadex() for WinCE. -* win32_threads.c (MARK_THREAD_STACK_SIZE, WINCE_MAIN_STACK_SIZE): -New macros defined (used by start_mark_threads(), WinMain()). -* win32_threads.c (GC_thr_init): Exclude parallel-specific code on -WinCE for now (since getenv(), GetProcessAffinityMask() and -SignalObjectAndWait() are missing on WinCE). -* win32_threads.c (GC_thr_init): replace GetModuleHandleA() with -GetModuleHandle(); replace CreateEventA() with CreateEvent(); use -TEXT() macro (for Unicode support). - -* include/gc.h (GC_has_static_roots_func): New typedef (user filter -callback). -* include/gc.h (GC_register_has_static_roots_callback): Use -GC_has_static_roots_func type. -* dyn_load.c (GC_has_static_roots, -GC_register_has_static_roots_callback): Likewise. -* dyn_load.c (GC_has_static_roots, -GC_register_has_static_roots_callback): Define on all platforms. -* dyn_load.c (GC_register_dynlib_callback, -GC_register_dynamic_libraries, GC_init_dyld): Replace K&R-style -functions definition with the ANSI C one. -* dyn_load.c (GC_register_dynlib_callback): Use new local variable -"callback" (initialized from GC_has_static_roots) to minimize data -races. -* dyn_load.c (GC_register_dynamic_libraries_dl_iterate_phdr, -GC_cond_add_roots): Define as STATIC. -* mark_rts.c (GC_remove_roots_inner): Likewise. -* dyn_load.c (GC_dyld_image_add): Don't call GC_add_roots() for -sections smaller than pointer size (just to avoid acquiring the -lock unnecessarily). -* dyn_load.c (GC_dyld_name_for_hdr): Define unconditionally (not -only for DARWIN_DEBUG). -* dyn_load.c (GC_dyld_image_add): Replace GC_add_roots() call with -LOCK + GC_add_roots_inner() + UNLOCK. -* dyn_load.c (GC_dyld_image_add): Call GC_has_static_roots() user -callback (if set) holding the lock; if it returns 0 then don't call -GC_add_roots_inner() for that region. -* dyn_load.c (GC_register_has_static_roots_callback): Put -"callback" value to GC_has_static_roots on all platforms. -* dyn_load.c (GC_has_static_roots): Update the comments. -* include/gc.h (GC_exclude_static_roots, GC_add_roots, -GC_remove_roots, GC_register_has_static_roots_callback): Likewise. -* include/private/gc_priv.h (struct roots): Likewise. -* include/private/gc_priv.h (GC_remove_roots_inner): Move prototype -to mark_rts.c and declare it as STATIC. -* include/private/gc_priv.h (GC_exclude_static_roots_inner): New -prototype. -* dyn_load.c (GC_register_dynamic_libraries_dl_iterate_phdr): Use -GC_exclude_static_roots_inner() instead of GC_exclude_static_roots. -* misc.c (GC_init_inner): Likewise. -* mark_rts.c (GC_exclude_static_roots_inner): New function (move -all the code from GC_exclude_static_roots(); add the comment. -* mark_rts.c (GC_add_roots_inner, GC_exclude_static_roots_inner): -add alignment assertion for the lower bound; add assertion for the -lower bound to be less than the upper one. -* mark_rts.c (GC_add_roots_inner, GC_exclude_static_roots): Adjust -the upper bound (round down to be of a pointer-aligned value); -return in case of an empty range. -* mark_rts.c (GC_exclude_static_roots): Acquire the lock and call -GC_exclude_static_roots_inner(). -* mark_rts.c (GC_remove_roots): Quickly check the bounds and return -in case of a do-nothing case (before acquiring the lock). - -* finalize.c (GC_fail_count): New external variable declaration. -* finalize.c (GC_reset_finalizer_nested, -GC_check_finalizer_nested): New function declarations (if THREADS -only). -* finalize.c (GC_finalizer_nested, GC_finalizer_skipped): New -static global variables (used internally by GC_finalize() and -GC_check_finalizer_nested()). -* finalize.c (GC_check_finalizer_nested): New static function -definition (only if not THREADS, used internally by -GC_notify_or_invoke_finalizers() to minimize the probability of -a deep recursion when a client finalizer tries to allocate GC -memory). -* finalize.c (GC_finalize): Reset GC_finalizer_nested value (or -call GC_reset_finalizer_nested()) if last heap expansion failed. -* finalize.c (GC_notify_or_invoke_finalizers): Access GC_gc_no, -GC_finalizer_now, GC_finalize_on_demand, GC_finalizer_notifier, -last_finalizer_notification variables holding the lock (to avoid -data races). -* finalize.c (GC_finalizer_notifier): Add comment. -* finalize.c (GC_notify_or_invoke_finalizers): Add "quick" check -for an empty finalization queue (only if THREADS and not -KEEP_BACK_PTRS/MAKE_BACK_GRAPH). -* finalize.c (GC_notify_or_invoke_finalizers): Call -GC_check_finalizer_nested() and skip GC_invoke_finalizers() call -if appropriate. -* include/private/pthread_support.h (GC_Thread_Rep): Add unsigned -finalizer_nested and finalizer_skipped fields (for internal use -by the multi-threaded GC_check_finalizer_nested()). -* win32_threads.c (GC_Thread_Rep): Likewise. -* pthread_support.c (GC_reset_finalizer_nested, -GC_check_finalizer_nested): New function definitions (the -multi-threaded variants of that in finalize.c). -* win32_threads.c (GC_reset_finalizer_nested, -GC_check_finalizer_nested): Likewise. - -* alloc.c (GC_stopped_mark): Remove GC_log_printf("") (not needed -anymore and GCC produces a warning for it). -* alloc.c (GC_stopped_mark): Adjust printf argument type -specifier. -* backgraph.c: Include dbg_mlc.h before ifdef MAKE_BACK_GRAPH (for -the case when the configuration information comes from aconfig -file). -* checksums.c: Likewise. -* include/gc_allocator.h (GC_ATTR_UNUSED): Use "__unused__" -keyword instead of "unused". -* include/gc_allocator.h: Fix typos in comments. -* thread_local_alloc.c: Likewise. -* include/javaxfc.h (GC_finalize_all): Update comment. -* include/private/gc_priv.h (GC_API_PRIV): New macro (defined as -GC_API and serves only as a marker for the private but exported -symbols used by test.c only). -* include/private/gc_priv.h (GC_abort, GC_arrays, GC_is_marked, -GC_printf, GC_err_printf, GC_log_printf): Replace GC_API decl with -GC_API_PRIV one. -* include/private/gc_priv.h (GC_fo_entries): Don't export it -outside a DLL. -* include/private/gc_priv.h (GC_ATTR_FORMAT_PRINTF): New macro -designated to check the arguments correctness of printf-like -functions (currently works only for GCC v3+). -* include/private/gc_priv.h (GC_printf, GC_err_printf, -GC_log_printf): Use GC_ATTR_FORMAT_PRINTF attribute. - -* dyn_load.c (HAVE_DL_ITERATE_PHDR): Break definition from use. -Define for FreeBSD 7.0+. - -* mach_dep.c: Don't include ucontext.h with NO_GETCONTEXT. - -* include/gc_gcj.h (GC_init_gcj_malloc): Improve descriptive -comment. - -* allchblk.c (GC_merge_unmapped): Don't assume that adjacent -free blocks have different mapping status. Correctly handle gap -between blocks. -(GC_split_block): Remove dead code setting hb_flags. Add comment. -(GC_allochblk): Split blocks also in generational-only mode. -* os_dep.c (GC_unmap_gap): Don't really use munmap. - -* include/private/gc_priv.h (GC_unmapped_bytes): Define as 0 for -not USE_MUNMAP case. - -* Makefile.direct (MARK_BIT_PER_OBJ, PRINT_BLACK_LIST, -USE_PROC_FOR_LIBRARIES): Fix typo in the comments. -* Makefile.direct (USE_MMAP, USE_MUNMAP, THREAD_LOCAL_ALLOC, -PARALLEL_MARK, STATIC): Update the comments. -* include/private/gcconfig.h (GC_PREFER_MPROTECT_VDB): New macro -recognized (only if MPROTECT_VDB). -* Makefile.direct (DONT_USE_USER32_DLL, GC_PREFER_MPROTECT_VDB): -Add the comments for. -* os_dep.c (detect_GetWriteWatch): Recognize "GC_USE_GETWRITEWATCH" -environment variable (only if MPROTECT_VDB, if the variable is -unset when GC_PREFER_MPROTECT_VDB macro controls the strategy). -* doc/README.environment (GC_USE_GETWRITEWATCH): New variable. -* include/private/gcconfig.h (MPROTECT_VDB): Add FIXME for -USE_MUNMAP and PARALLEL_MARK cases (to relax the conditions in -the future). -* misc.c (GC_get_heap_size, GC_get_free_bytes): Ignore the memory -space returned to OS (GC_unmapped_bytes). -* include/gc.h (GC_get_heap_size, GC_get_free_bytes): Update the -comments. -* misc.c (GC_get_unmapped_bytes): New API function. -* include/gc.h (GC_get_unmapped_bytes): New API prototype. -* os_dep.c (GC_dirty_init): Move "ifdef GWW_VDB" block out of -"ifdef MSWIN32" one (for Cygwin). - -* pthread_support.c (GC_allow_register_threads): New API function. -* win32_threads.c (GC_allow_register_threads): Likewise. -* include/gc.h (GC_allow_register_threads): New API prototype. -* include/gc.h (GC_register_my_thread, GC_unregister_my_thread): -Update the comments. -* pthread_support.c (GC_register_my_thread): Check the collector -is in the multi-threaded mode. -* win32_threads.c (GC_register_my_thread): Likewise. - -* finalize.c (GC_finalize_all): Always call GC_invoke_finalizers -instead, following Ivan's original patch. - -* allchblk.c (GC_allochblk_nth): Add assertion. -* checksums.c: Add GC_record_fault, GC_was_faulted, -CC_n_faulted_dirty_errors. -(GC_check_dirty): Remove register declarations, print -dirty bit errors on faulted pages. -* os_dep.c (GC_write_fault_handler): Call GC_record_fault(). -* os_dep.c (GC_remove_protection): Compute index correctly. - - -== [7.2alpha2] 2009-06-12 == - -* dbg_mlc.c (GC_print_smashed_obj): Convert a group of printf() -calls into a single one (for output atomicity). -* typd_mlc.c (GC_calloc_explicitly_typed): Don't declare and use -GC_finalization_failures variable; check the result of -GC_general_register_disappearing_link() (for lack of memory) -instead. -* finalize.c (GC_finalization_failures): Remove unused global -variable. -* finalize.c (GC_general_register_disappearing_link, -GC_general_register_disappearing_link): Don't update the value of -GC_finalization_failures (since unused). -* include/private/gc_pmark.h (PUSH_ONE_CHECKED_STACK, -GC_PUSH_ONE_STACK, GC_PUSH_ONE_HEAP): The first parameter is of -word type now (as FIXUP_POINTER requires numeric argument). -* finalize.c (GC_ignore_self_finalize_mark_proc): GC_PUSH_ONE_HEAP -requires the first parameter of word type. -* mark.c (PUSH_GRANULE): Likewise. -* mark.c (GC_push_one, GC_push_all_eager): Likewise. -* finalize.c (GC_finalize_all): Call GC_invoke_finalizers() or -GC_finalizer_notifier directly, instead -of GC_INVOKE_FINALIZERS() to prevent infinite looping. -* include/javaxfc.h: Clarify GC_finalize_all comment. -* gcj_mlc.c: Include gc_pmark.h before "ifdef GC_GCJ_SUPPORT" (not -after) for configuration information. -* gcj_mlc.c (GC_gcj_malloc_ignore_off_page): Add comment. -* gcj_mlc.c (GC_gcj_malloc_ignore_off_page): Check "op" local -variable for NULL before dereferencing it, return GC_oom_fn() in -this case. -* typd_mlc.c (GC_malloc_explicitly_typed, -GC_malloc_explicitly_typed_ignore_off_page): Transform the code to -suppress compiler warning (for uninitialized "lg" variable). - -* win32_threads.c (GC_unregister_my_thread): add false assertion -in unreachable code. - -* pthread_support.c (GC_inner_start_routine): Don't release the -GC lock between GC_register_my_thread_inner() and -GC_init_thread_local() calls (post the "registered" even after -calling GC_init_thread_local()). -* win32_threads.c (GC_register_my_thread, GC_unregister_my_thread): -Use GC_lookup_thread_inner() instead of GC_lookup_thread() and -acquire the GC lock only once. -* win32_threads.c (GC_thr_init): Call GC_register_my_thread_inner() -directly instead of GC_register_my_thread() since I_HOLD_LOCK -and our (main) thread is not registered yet (add assertion for it). -* win32_threads.c (GC_init_parallel): Call GC_lookup_thread_inner() -directly instead of GC_lookup_thread() (since I_HOLD_LOCK). -* win32_threads.c (GC_lookup_thread): Remove unused function. -* win32_threads.c: Remove "#error GC_DLL untested with Cygwin". -* win32_threads.c (GC_win32_dll_threads): Define as FALSE macro -also if THREAD_LOCAL_ALLOC or GC_PTHREADS. -* win32_threads.c (GC_use_DllMain): Call ABORT also if GC_PTHREADS -(for Cygwin). -* win32_threads.c (GC_push_stack_for): Add parentheses around "&&" -(inside GC_ASSERT) to prevent compiler warning. -* win32_threads.c (GC_push_all_stacks): Remove FIXME for -PARALLEL_MARK. -* win32_threads.c (MAX_MARKERS, GC_markers): Move the definitions -to a place before GC_get_next_stack(). -* win32_threads.c (marker_sp, marker_bsp): New static arrays (same -as in pthread_support.c). -* win32_threads.c (marker_last_stack_min): New static arrays (the -same semantics as for last_stack_min of GC_Thread_Rep). -* win32_threads.c (GC_get_next_stack): Handle marker threads. -* win32_threads.c (GC_mark_thread): Save the current stack pointer -to marker_[b]sp. -* win32_threads.c (start_mark_threads): Initialize -marker_last_stack_min elements (to "unset" value). - -* misc.c (GC_set_oom_fn, GC_set_all_interior_pointers, -GC_set_finalize_on_demand, GC_set_java_finalization, -GC_set_finalizer_notifier, GC_set_dont_expand, GC_set_full_freq, -GC_set_no_dls, GC_set_free_space_divisor, GC_set_max_retries, -GC_set_dont_precollect, GC_set_time_limit, GC_set_warn_proc): -Change return type to void (these API functions no longer return -the old value). -* include/gc.h: Likewise. -* tests/test.c (main, WinMain, test): Remove explicit cast to void -for GC_set_warn_proc(). -* misc.c (GC_get_oom_fn, GC_get_all_interior_pointers, -GC_get_finalize_on_demand, GC_get_java_finalization, -GC_get_finalizer_notifier, GC_get_dont_expand, GC_get_full_freq, -GC_get_no_dls, GC_get_free_space_divisor, GC_get_max_retries, -GC_get_dont_precollect, GC_get_time_limit, GC_get_warn_proc): New -API functions (to get the current value of the corresponding R/W -public variables). -* include/gc.h: Likewise. -* include/gc.h (GC_set_warn_proc, GC_set_free_space_divisor): -Update the comment. -* misc.c (GC_ignore_warn_proc): New API call-back function. -* include/gc.h (GC_ignore_warn_proc): Likewise. -* misc.c (GC_set_find_leak, GC_get_find_leak, GC_set_non_gc_bytes, -GC_get_non_gc_bytes): New API setter and getter functions (for the -public GC_find_leak and GC_non_gc_bytes variables, respectively). -* include/gc.h: Likewise. -* include/gc.h (GC_memalign): Add proto to GC API. -* mallocx.c (GC_memalign): Use GC_API, GC_CALL for the definition. -* tests/test.c (run_one_test): Test GC_memalign() on Win32 too, -remove GC_memalign() proto. -* misc.c (GC_write): Use multi-byte (A) variants of Win32 -GetModuleFileName() and CreateFile(). -* tests/test.c (main): Replace K&R-style function definition with the -ANSI C one. - -* include/private/gcconfig.h (PLATFORM_ANDROID): New macro -recognized (for Linux on ARM32 without glibc). -* include/private/gcconfig.h (STRTOULL): Define for all targets -(define as "strtoul" for most targets except for LLP64/Win64). -* misc.c (GC_init_inner): Use STRTOULL instead of atoi/atol() -(cast the result to word type) to decode values of "GC_TRACE", -"GC_INITIAL_HEAP_SIZE", "GC_MAXIMUM_HEAP_SIZE" environment -variables. - -* include/gc_allocator.h: Add gc_allocator_ignore_off_page. -* tests/test_cpp.cc: Add call to gc_allocator_ignore_off_page. - -* win32_threads.c (GC_release_mark_lock): Correct misspelling of -AO_load in assertion. - -* win32_threads.c (MAX_THREADS): Define as 1 if GC_win32_dll_threads -is defined as FALSE (otherwise the size of dll_thread_table is near -200 KiB for 32-bit). -* win32_threads.c (GC_use_DllMain): Optimize for THREAD_LOCAL_ALLOC. -* win32_threads.c (GC_Thread_Rep): Add backing_store_end and -backing_store_ptr fields for IA64 support. -* win32_threads.c (GC_register_my_thread_inner): Set -backing_store_end field to reg_base value for IA64 (same as in -pthread_support.c). -* win32_threads.c (SET_PTHREAD_MAP_CACHE): Put parentheses in the -"right" places, remove ';'. -* win32_threads.c (GC_fault_handler_lock): Declare only -if MPROTECT_VDB (and not WinCE). -* win32_threads.c (GC_suspend): Acquire and release -GC_fault_handler_lock only if MPROTECT_VDB (and not WinCE). -* win32_threads.c (GC_suspend): Define as STATIC. -* win32_threads.c (GC_push_stack_for): Fix WARN() format specifier -(should be word-compliant, "%p" is used w/o "0x"), don't cast sp. -* win32_threads.c (GC_push_all_stacks): Convert a group of printf() -calls into a single one (for output atomicity). -* win32_threads.c (GC_get_next_stack): Unprotect thread descriptor -before altering its last_stack_min ("thread" variable is added). -* win32_threads.c (GC_get_next_stack): Remove unnecessary checks for -"s" is non-NULL. -* win32_threads.c (GC_get_next_stack): Don't call GC_may_be_in_stack -if WinCE. -* win32_threads.c (GC_get_next_stack): Pass current_min value to -GC_get_stack_min as-is (without -1). -* win32_threads.c (GC_wait_marker): Remove FIXME and use "release" -version of AO_fetch_and_sub1(). -* win32_threads.c (GC_win32_start_inner, GC_win32_start): convert int -to pointer (and vice versa) thru word type to suppress warnings. -* win32_threads.c (GC_mark_mutex_waitcnt): Fix comment, always -access atomically. -* misc.c: Change GC_THREADS tests back to THREADS. - -* allchblk.c (GC_print_hblkfreelist, GC_dump_regions): Convert -a group of printf() calls into a single one (for output atomicity). -* include/gc.h (GC_set_all_interior_pointers, GC_set_full_freq, -GC_set_time_limit): New prototypes. -* misc.c (GC_set_all_interior_pointers, GC_set_full_freq, -GC_set_time_limit): New public setter/getter functions. -* include/gc.h: Fix (and remove outdated) comments for thread-local -allocation. -* include/gc.h: Fix typos in comments. -* misc.c (GC_init_inner, GC_printf): Likewise. -* include/gc.h (GC_unregister_disappearing_link): Refine comment. -* include/gc.h (GC_stack_base): Recognize _M_IA64 macro. -* misc.c (GC_stack_last_cleared, GC_min_sp, GC_high_water, -GC_bytes_allocd_at_reset, DEGRADE_RATE): Define only if THREADS. -* misc.c (GC_stack_last_cleared, GC_min_sp, GC_high_water, -GC_bytes_allocd_at_reset): Define as STATIC. -* misc.c (GC_get_heap_size, GC_get_free_bytes, -GC_get_bytes_since_gc, GC_get_total_bytes): Acquire the GC lock to -avoid data races. -* misc.c (GC_write_cs): Define only if THREADS (Win32/WinCE only). -* misc.c (GC_init_inner): Initialize GC_write_cs only if THREADS. -* misc.c (GC_init_inner): Use GC_INITIAL_HEAP_SIZE (if available) to -set the default initial value of initial_heap_sz. -* misc.c (GC_deinit): Destroy GC_write_cs only if THREADS. -* misc.c (GC_init_inner): Fix WARN() format specifier (should be -word-compliant, "%p" is used w/o "0x"). -* misc.c (GC_init_inner): Don't recognize "GC_PAUSE_TIME_TARGET" -environment variable if SMALL_CONFIG. -* misc.c (GC_init_inner): Recognize "GC_FULL_FREQUENCY" environment -variable to set initial GC_full_freq value (if not SMALL_CONFIG). -* doc/README.environment (GC_FULL_FREQUENCY): Add information. -* doc/README.environment (GC_MARKERS): Refine information. -* misc.c (GC_init_inner): Change GC_ASSERT to GC_STATIC_ASSERT where -possible. -* misc.c (IF_NEED_TO_LOCK): New macro (instead of GC_need_to_lock). -* misc.c (GC_write): Use IF_NEED_TO_LOCK for handling GC_write_cs. -* misc.c (GC_abort): Don't define if SMALL_CONFIG. -* misc.c (GC_abort): Directly use WRITE() instead of GC_err_printf() -(to prevent possible infinite recursion). - -* finalize.c (finalization_mark_proc): Replace K&R-style declaration -with ANSI C one. -* finalize.c (GC_grow_table, GC_register_finalizer_inner, -GC_enqueue_all_finalizers): Remove outdated comments about disabling -signals. -* finalize.c (GC_general_register_disappearing_link): Fix assertion -to catch NULL "obj" value. -* finalize.c (GC_unregister_disappearing_link): Check "link" -alignment before gaining the lock. -* finalize.c (GC_finalize): Refine comment. -* finalize.c (GC_finalize): Fix WARN() format specifier (should be -word-compliant, "%p" is used w/o "0x"). -* finalize.c (GC_invoke_finalizers): Initialize "bytes_freed_before" -variable (to 0) to suppress compiler warning. -* include/gc_gcj.h (MARK_DESCR_OFFSET): Move to private/gc_pmark.h. -* include/gc_gcj.h: add "extern C" header and tail. -* include/private/gc_pmark.h: Remove GC_do_parallel_mark(), -GC_help_wanted, GC_helper_count, GC_active_count declarations (move -the comments to the place where these symbols are defined in mark.c). -* mark.c: Add STATIC GC_do_parallel_mark() declaration (for use by -GC_mark_some_inner, if PARALLEL_MARK only). -* mark.c (GC_mark_some_inner, GC_help_wanted, GC_helper_count, -GC_active_count, GC_do_parallel_mark): Define as STATIC. -* pthread_support.c (GC_mark_thread): Likewise. -* typd_mlc.c (GC_explicit_typing_initialized, GC_explicit_kind, -GC_array_kind, GC_ext_descriptors, GC_ed_size, GC_avail_descr, -GC_typed_mark_proc_index, GC_array_mark_proc_index, GC_eobjfreelist, -GC_arobjfreelist): Likewise. -* include/private/gc_pmark.h (PUSH_CONTENTS_HDR): Change GC_ASSERT -for HBLKSIZE to GC_STATIC_ASSERT. -* mark.c (GC_noop): Define for Borland C the same as for Watcom. -* mark.c (GC_noop, GC_mark_and_push): Add ARGSUSED tag. -* pthread_support.c (GC_do_blocking_inner): Likewise. -* mark.c (GC_mark_from): Initialize "limit" (to 0) in the default -switch branch to suppress compiler warning. -* mark.c (GC_return_mark_stack): Append new-line to printf message. -* mark.c: Remove unused GC_true_func(), GC_PUSH_ALL(). -* pthread_support.c (GC_mark_thread): Add dummy "return 0" to -suppress compiler warning. -* pthread_support.c (start_mark_threads): Move the code limiting -"GC_markers" value (and printing a warning) to GC_thr_init(). -* pthread_support.c (GC_thr_init): Silently limit "GC_markers" value -if based on the number of CPUs. -* pthread_support.c (GC_thr_init): Treat incorrect "GC_markers" -values as one. -* pthread_support.c (GC_register_my_thread_inner): Add a check for -"stack_end" is non-NULL (the same as in win32_threads.c). -* pthread_support.c (pthread_create): Call GC_oom_fn before giving up -with ENOMEM. -* thread_local_alloc.c (return_single_freelist): Convert "for" loop -to "while" one to suppress "possible extraneous ';'" warning. - -* darwin_stop_world.c (GC_push_all_stacks): Recognize ARM32. -* include/private/gc_priv.h (GC_THREAD_STATE_T): Define for ARM32 -(Darwin only). -* include/private/gcconfig.h: Add machine-specific part for DARWIN. -* include/private/gcconfig.h (ARM32): Define config parameters for -DARWIN (iPhone). - -* alloc.c (GC_FULL_FREQ, GC_DONT_EXPAND, GC_FREE_SPACE_DIVISOR, -GC_TIME_LIMIT): New macros (used to control the default initial -values of GC_full_freq variable, GC_dont_expand, -GC_free_space_divisor, GC_time_limit respectively). -* include/private/gc_priv.h (TIME_LIMIT): Remove macro (replaced -with GC_TIME_LIMIT in alloc.c). -* alloc.c (GC_need_full_gc, GC_stopped_mark, GC_finish_collection): -Define as STATIC. -* mark_rts.c (GC_push_current_stack, GC_push_gc_structures): Likewise. -* include/private/gc_priv.h (GC_stopped_mark, GC_finish_collection): -Move the prototypes to alloc.c, make STATIC. -* include/private/gc_priv.h (GC_push_current_stack, -GC_push_gc_structures, GC_push_regs_and_stack): Remove prototypes -(move the comments to the places where these functions are defined). -* mach_dep.c (GC_push_regs_and_stack): Move to mark_rts.c and define -as STATIC. -* alloc.c (GC_timeout_stop_func, GC_stopped_mark, -GC_print_heap_sects): Convert a group of printf() calls into -a single one (for output atomicity). -* mark_rts.c (GC_print_static_roots): Likewise. -* alloc.c (GC_stopped_mark): Output blank line (when logging) for -convenience to delimit collections. -* alloc.c (GC_clear_a_few_frames): Rename NWORDS to CLEAR_NWORDS; -make "frames" local variable volatile (to prevent optimization). -* alloc.c (GC_try_to_collect_inner, GC_stopped_mark, -GC_finish_collection, GC_allocobj): Remove outdated comments about -disabling signals. -* include/private/gc_priv.h (GC_register_displacement_inner, -GC_gcollect_inner): Likewise. -* alloc.c (GC_try_to_collect_inner, GC_stopped_mark, -GC_finish_collection): Initialize "start_time" local variable (to 0) -to suppress compiler warning. -* mark_rts.c (GC_add_roots_inner): Likewise. -* alloc.c (GC_RATE, MAX_PRIOR_ATTEMPTS): Guard with "ifndef". -* include/private/gc_priv.h (clock, GC_stop_world, GC_start_world, -GC_acquire_mark_lock, GC_release_mark_lock, GC_notify_all_builder, -GC_wait_for_reclaim, GC_notify_all_marker, GC_wait_marker): Replace -K&R-style function prototypes with ANSI C one. -* include/private/gc_priv.h (ABORT): Define as DebugBreak() for -Win32/WinCE if SMALL_CONFIG (the same as in GC_abort()). -* include/private/gc_priv.h (ROUNDED_UP_WORDS, abs): Remove unused -macros. -* include/private/gc_priv.h (GC_noop): Declare for Borland C the -same as for Watcom. -* mark_rts.c (GC_push_conditional_with_exclusions): Add ARGSUSED tag. - -* dbg_mlc.c (GC_store_debug_info, GC_store_debug_info_inner): Remove -outdated comment about disabling signals. -* mallocx.c (GC_malloc_uncollectable, -GC_malloc_atomic_uncollectable): Likewise. -* os_dep.c: Likewise. -* dbg_mlc.c (GC_debug_change_stubborn, GC_debug_end_stubborn_change): -Add ARGSUSED tag. -* pthread_stop_world.c (GC_suspend_handler, -GC_suspend_handler_inner): Likewise. -* dbg_mlc.c (GC_debug_free, GC_debug_realloc): Fix printf message. -* dbg_mlc.c (GC_debug_realloc): Set "result" to NULL in the default -switch branch to suppress compiler warning. -* dyn_load.c (GC_init_dyld): Use ABORT() instead of GC_abort(). -* include/private/darwin_semaphore.h (sem_init): Likewise. -* include/javaxfc.h: Replace "GC_H" with "_GC_H". -* include/private/dbg_mlc.h (GC_has_other_debug_info, -GC_store_debug_info): Replace K&R-style function prototypes with ANSI -C one. -* include/private/gcconfig.h (GC_FreeBSDGetDataStart, real_malloc, -GC_win32_get_mem, GC_wince_get_mem, GC_unix_get_mem): Likewise. -* include/private/pthread_support.h (GC_stop_init): Likewise. -* include/private/gcconfig.h: Refine comment about setting -GC_stackbottom. -* include/private/gcconfig.h (FIXUP_POINTER): Put parentheses in the -"right" places. -* include/private/pthread_support.h (GC_Thread_Rep): Refine comment -for "stack_end" field. -* mallocx.c (GC_malloc_uncollectable, -GC_malloc_atomic_uncollectable): Remove cast to undefined "hbklk". -* os_dep.c (GC_USE_MEM_TOP_DOWN): New macro (for setting -GC_mem_top_down to MEM_TOP_DOWN for debug purposes). -* os_dep.c (GC_gww_read_dirty, catch_exception_raise): Fix WARN() -format specifier (should be word-compliant, "%p" is used w/o "0x"). -* pthread_stop_world.c (GC_suspend_handler_inner): Likewise. -* os_dep.c (GC_dirty_init): Append new-line to printf messages. -* os_dep.c (GC_mprotect_thread): Fix GC_err_printf message. -* os_dep.c (GC_save_callers): Change GC_ASSERT to GC_STATIC_ASSERT. -* pthread_stop_world.c (GC_retry_signals, GC_suspend_ack_sem): Define -as STATIC. -* pthread_stop_world.c (GC_push_all_stacks): Add assertion for that -"thread_blocked" is not set for the current thread. -* real_malloc.c: Add "extern GC_quiet" to suppress compiler warning. -* reclaim.c (GC_reclaim_all): Initialize "start_time" (to 0) to -suppress compiler warning. - -* tests/test.c (check_heap_stats): Avoid unbalanced brackets in ifdef. - -* win32_threads.c: restructure parallel marking mutex initialization. -* win32_threads.c, alloc.c, darwin_stop_world.c, mallocx.c, mark.c, -pthread_stop_world.c, pthread_support.c: Add runtime conditions -on GC_parallel were appropriate. -* pthread_support.c: Condition marker_bsp on ia64. -(GC_segment_is_thread_stack): Fix loop upper bound. -* reclaim.c: Limit some assertions to PARALLEL_MARK. -* pthread_support.c: Don't acquire mark lock for thread-local -allocation. -* include/private/gc_priv.h: Don't define parallel mark sync -support just for THREAD_LOCAL_ALLOC. - -* include/private/gcconfig.h: refine MINGW32 test. -* mark.c: Add win64/gcc tests. - -* test.c (fork_a_thread, reverse_test, alloc8bytes, tree_test, -typed_test, run_one_test, check_heap_stats, main, test): Replace -all K&R-style function definitions with ANSI C ones. -* trace_test.c (main): Likewise. -* test.c (GC_COND_INIT): Define as GC_INIT() also in case of -THREAD_LOCAL_ALLOC. -* test.c (reverse_test): Call fork_a_thread() only if GC_PTHREADS -or GC_WIN32_THREADS; remove fork_a_thread() macros definition. -* test.c (reverse_test): Use "volatile" when clearing "b" and "c" -local variables (to suppress "assigned value is never used" -compiler warning). -* test.c (tree_test): Use public GC_noop1() instead of private -GC_noop(). -* test.c (typed_test): Likewise. -* test.c (check_heap_stats): Define and assign value to -"late_finalize_count" local variable only if its value is used -(if FINALIZE_ON_DEMAND defined). -* test.c (main): Remove DJGPP-specific initialization of -GC_stackbottom (not needed anymore, handled in gcconfig.h). -* trace_test.c: Guard #define GC_DEBUG with #ifndef. -* trace_test.c: Include "gc_backptr.h". -* trace_test.c (main): Call GC_INIT(). -* trace_test.c (main): Add "return 0" statement. - -* dyn_load.c (GC_register_dynlib_callback): Use new index j -instead of i in the inner loop. - -* tests/test.c: Increment n_tests with fetch_and_add when possible, -avoiding need to export lock. - -* include/gc_pthread_redirects.h: -- dlfcn.h is included for dlopen() proto before undefining -"dlopen" (so, it's possible now to include dlfcn.h after -gc.h from user code); -- GC_dlopen() proto is added (except for Darwin as -it's missing there); -- "dlopen" is explicitly undefined (before its redefinition). -* include/gc.h: -- "process.h" is included besides "windows.h" -(for _beginthreadex/_endthreadex); win32 only. -- GC_NO_THREAD_DECLS is moved to the right place -(before closing "extern C"). -* pthread_support.c: Fix out of memory handling for Thread_Reps. -* win32_threads.c: Don't include process.h on winCE, -improve out of memory handling for thread structures, don't -define GC_beginthreadex and GC_endthreadex for winCE. - -* tests/test.c: Change gcj vtable decriptor type from size_t to -GC_word. - -* gcj_mlc.c: Add comment. -* tests/test.c: Change NTEST to NTHREADS. Fork 5 threads by default. -Run reverse_test a second time in each thread.Add comments. -Don't rely on AO_fetch_and_add. - -* dyn_load.c (GC_register_dynlib_callback, -GC_register_dynamic_libraries_dl_iterate_phdr): Add support -for GNU_PT_RELRO relocations. - -* Makefile, Makefile.direct: GC_SOLARIS_PTHREADS was replaced -by GC_SOLARIS_THREADS. -* include/gc.h: Improve finalizer documentation. -* mips_sgi_mach_dep.s: Replace _MIPS_SIM_ABI32 with _ABIO32. -* pthread_stop_world.c, Makefile.dj: Fix typos. - -* win32_threads.c (GC_new_thread): Make first_thread -visible to the whole file. -(UNPROTECT): New macro. -(GC_push_stack_for, GC_suspend, GC_start_world): unprotect -thread structures before writing. -(GC_suspend): Acquire GC_fault_handler_lock before suspending -thread. -* os_dep.c: export GC_fault_handler_lock. -(GC_remove_protection): Check if already unprotected. - -* doc/README.win32: Add OpenWatcom warning. -* include/private/gcconfig.h: Really check it in. - -* os_dep.c (GC_get_stack_base, windows): Replace with Dave Korn's -code from gcc version. -* os_dep.c: make gc compilable (optionally) for Cygwin with -GetWriteWatch-based virtual dirty bit implementation ("os_dep.c" file). -* os_dep.c: Make non-win32 GC_write_fault_handler STATIC. -* mark.c (GC_noop): fix declaration definition mismatch for DMC. -* include/private/gcconfig.h: Enable MPROTECT_VDB and GWW_VDB for -Watcom (Win32 only). It works. - -* mach_dep.c: Don't use __builtin_unwind_init for register -state on PowerPC/Darwin. - -* doc/gcdescr.html: Improve description of object freelist -structure. -* include/private/gc_priv.h: Fix comment for _size_map. - -* os_dep.c (GC_linux_stack_base): Relax sanity test. - -* include/private/gc_pmark.h (PUSH_CONTENTS_HDR for -MARK_BIT_PER_OBJ): Add missing backslash before eoln. - -* misc.c (GC_set_warn_proc): Implicitly intialize GC on -non-Cygwin win32. - -* configure.ac: Enable thread-local allocation for sparc-linux. - -* alloc.c (GC_try_to_collect): Remove duplicate initialization -check. -* malloc.c (GC_generic_malloc): Remove lw to eliminate single- -threaded warnings. -* mallocx.c (GC_generic_malloc_ignore_off_page): Likewise. - -* allchblk.c, backgraph.c, dbg_mlc.c, dyn_load.c, -finalize.c, include/private/gc_pmark.h, malloc.c, mark.c, -os_dep.c, pthread_stop_world.c, pthread_support.c, reclaim.c, -thread_local_alloc.c. -* misc.c: Refine comment. - -* os_dep.c: Define GC_GWW_BUF_LEN more intelligently. Add FIXME -comment. - -* win32_threads.c (GC_push_stack_for): Yet another attempt -at the stack_min finding logic. Try to clean up the existing code -while minimizing VirtualQuery calls. -(GC_win32_start_inner): Register thread before GC_printf. -Produce more output with DEBUG_THREADS. -*include/gc.h: Update obsolete comments. - -* tests/test.c: -(gcj_class_struct2): Use cast instead of l suffix. -Cast GetLastError to int in various places. -Avoid unused result warning from incr/decr macros. -Add cast for fake_gcj_mark_proc. -Cast GC_gc_no to unsigned in printf. - -* include/gc.h: Fix two typos in comments. - -* finalize.c: Fix typo in comment. - -* blacklst.c (GC_print_source_pointer): Don't call GC_print_heap_obj -with lock. - -* reclaim.c: (GC_reclaim_block): Scan even nearly full blocks -if we are checking for leaks. - -* win32_threads.c: Remove mark lock spinning. -* win32_threads.c, pthread_support.c: Update GC_unlocked_count, -GC_spin_count, and GC_block_count using atomic operations. -* tests/test.c: Declare n_tests as AO_t only if we have threads. - -* win32_threads.c: Support PARALLEL_MARK. Make printf arg -types agree with format specifiers. -Add STATIC for GC_threads. -* include/private/gcconfig.h: Add FIXME comment. -* tests/test.c (run_ine_test): Replace LOCK/UNLOCK use with -AO_fetch_and_add1_full. Declare n_tests as AO_t. -(WinMain): Don't call GC_use_DllMain. -with PARALLEL_MARK or THREAD_LOCAL_ALLOC. - -* alloc.c (GC_try_to_collect_inner): Don't print redundant -GC_bytes_allocd and GC_gc_no. -(GC_stopped_mark): Print average world stop time. -* include/private/gc_priv.h (MS_TIME_DIFF): Add cast. - -* misc.c, doc/README.environment: Add support for -GC_FREE_SPACE_DIVISOR and GC-disable-incremental. -* include/gc.h: Make GC_set_free_space_divisor correspond to -(somewhat unfortunate) reality. - -(Mostly improves LLP64 support.) -* backgraph.c, checksums.c, dbg_mlc.c, finalize.c, mark.c, -misc.c, reclaim.c: Changed some int and long type to word or size_t -(and vice versa where appropriate) -* gcj_mlc.c, include/private/dbg_mlc.h, include/private/gcconfig.h, -include/private/thread_local_alloc.h, mark.c, -misc.c, thread_local_alloc.c, win32_threads.c: Added intermediate -casts to word type when casting from int to pointer (or pointer -to int, or data pointer to code pointer) - just to remove the -corresponding compiler warning. -* ptr_chck.c (GC_is_visible): cast int const to word type to -prevent left shift overflow. -* os_dep.c: change the type of GC_mem_top_down global variable -(containing a flag) to DWORD. -* include/gc_config_macros.h: define GC_SOLARIS_THREADS if GC_THREADS -is defined on SunOS x86_64. -* misc.c (GC_init_size_map): Ifdef out GC_ASSERT as a workaround -for VC++ 2008 amd64 (v15.00.21022.08 for x64) compiler bug -(the compiler gets hung if invoked with -Ox -D -ALL_INTERIOR_POINTERS -D GC_ASSERTIONS) -* backgraph.c: cast GC_gc_no value to unsigned short when -assigned/compared to height_gc_no field of back_edges. -* os_dep.c (GC_remove_protection): Add ARGSUSED. -* win32_threads.c (GC_thread_exit_proc): Remove unused local -variable. -* mark.c (GC_check_dirty): Move declaration out of func body. - -* doc/gcinterface.html: Improve REDIRECT_MALLOC documentation. -* include/gc.h (GC_register_my_thread): Improve comment. - -* Makefile.direct: Add comment for -DCHECKSUMS. - -* thread_local_alloc.c, include/private/thread_local_alloc.h: -Fix typos in comments. -* finalize.c: Declare mark_procs and GC_register_finalizer_inner -STATIC. -* malloc.c (GC_free): Move size calculation below assertion. - -* win32_threads.c (GC_get_stack_min, GC_may_be_in_stack): -Add one entry VirtualQuery cache, I_HOLD_LOCK assertions. -(GC_push_stack_for, GC_get_next_stack) : Hopefully fix WINCE support. - -* finalize.c (GC_general_register_disappearing_link): Add -assertion. -* malloc.c (GC_generic_malloc): Round lb to granules, not words. -* mallocx.c (GC_generic_malloc_ignore_off_page): Round lb to -granules, not words. - -* mach_dep.c (NO_GETCONTEXT): Define for sparc linux. -* configure.ac: Define mach_dep for sparc-linux. - -* mark_rts.c (GC_approx_sp): Use volatile to avoid common -warning. - -* dyn_load.c (GC_cond_add_roots): Fix GC_get_next_stack argument -order. - -* alloc.c, dbg_mlc.c, dyn_load.c, finalize.c, gcj_mlc.c, -include/gc.h, include/gc_config_macros.h, include/gc_cpp.h, -include/gc_gcj.h, include/gc_mark.h, include/gc_typed.h, -include/javaxfc.h, include/private/gc_locks.h, -include/private/gc_priv.h, malloc.c, mallocx.c, mark.c, mark_rts.c, -misc.c, obj_map.c, os_dep.c, pthread_support.c, ptr_chck.c, -stubborn.c, tests/test.c, thread_local_alloc.c, typd_mlc.c -win32_threads.c: Add GC_CALL and GC_CALLBACK macro invocations. -* test.c: Remove some old K&R code. - -* win32_threads.c (GC_may_be_in_stack): New. (GC_Thread_Rep): -Add last_stack_min. (GC_push_stack_for): Use last_stack_min. -(GC_get_next_stack): Add limit argument, use_last_stack_min. -(GC_suspend): make stack_base assignment conditional. -* dyn_load.c (win32 GC_cod_add_roots): Pass limit to -GC_get_next_stack. -* configure_atomic_ops.sh: Remove. -* build_atomic_ops.sh, build_atomic_ops.sh.cygwin, doc/README.win32, -Makefile.direct: Partially support build directories whose path -name contains blanks. -* Makefile.am: Support new files (build_atomic_ops.sh, -build_atomic_ops.sh.cygwin) - -* include/private/gc_locks.h, include/private/gc_pmark.h, -include/private/gc_priv.h, include/private/gcconfig.h, -mach_dep.c, mark_rts.c, misc.c, os_dep.c, pthread_stop_world.c, -pthread_support.c, thread_local_alloc.c, typd_mlc.c, win32_threads.c: -Fix comments. - -* pthread_support.c: Comment out LOCK_STATS. -* include/gc.h: Fix comments. - -* misc.c (GC_init_inner): Enable GC_LOG_FILE on Cygwin. -* include/private/gcconfig.h: Consider USE_MMAP for Cygwin. -* os_dep.c (GC_get_main_stack_base): Use alternate definition -with USE_MMAP. -* include/private/gc_priv.h: Sometimes define SETJMP on Cygwin. - -* doc/README: Make it clearer when Makefile.direct is assumed. -* cord/cord.am: install include/cord.h. - -* win32_threads.c (GC_pthread_join, GC_pthread_start_inner): -Remove unused variables. -* darwin_stop_world.c: Always declare GC_thr_init(). -* dbg_mlc.c (GC_debug_free_inner): Don't touch oh_sz if -SHORT_DBG_HDRS is defined. -* include/private/gc_pmark.h (OR_WORD_EXIT_IF_SET, parallel -mark, USE_MARK_BITS version): Refer to correct parameter name. - -* finalize.c (GC_general_register_disappearing_link): Remove -redundant code. -* gcj_mlc.c (GC_init_gcj_malloc): Add cast to signed. -* os_dep.c: (GC_write_fault_handler): Remove remaining -references to deleted variable "code". Remove redundant -FREEBSD definitions. -* include/private/gcconfig.h (GWW_VDB): Define for X86_64 when -defined for X86. (STATIC): Define as "static" with NO_DEBUGGING. - -* include/private/gc_priv.h: Update MAX_HEAP_SECTS. - -* dbg_mlc.c (GC_print_smashed_obj): Increase robustness with -smashed string, (GC_debug_free_inner): Mark as free. -* mallocx.c (GC_malloc_many): Always clear new block if -GC_debugging_started. -* reclaim.c: Move GC_debugging_started from -GC_reclaim_small_nonempty_block() to GC_reclaim_generic(), -which is also called directly. -* doc/README: Fix spelling error. Update license summary. -* include/gc.h (GC_PRE_INCR3, GC_POST_INCR3): add (void **) casts. -* tests/test.c: Don't define GC_DEBUG if already defined. - -* doc/simple_example.html: update --enable-full-debug reference, -Make HTML formatting standards compliant. -* doc/debugging.html, doc/leak.html: Fix HTML formatting bugs. -* doc/gcinterface.html: specify encoding. - -* doc/simple_example.html: Update thread-local allocation -description. - -* configure.ac: Check for gc-debug earlier; replace remaining -full-debug tests. -* include/gc.h, ptr_chck.c (GC_pre_incr, GC_post_incr): -Use signed offset type. Use ptr_t internally. -* doc/gcinterface.html: Update LOCAL_MALLOC description. -* doc/README.autoconf, doc/leak.html, doc/README.DGUX386: -Fix full-debug reference. -* include/gc.h: Rewrite GC_..._INCR and friends. -* tests/test.c: Minimally test GC_..._INCR and friends. - -* mark.c: (GC_push_next_marked, GC_push_next_marked_dirty, -GC_push_next_marked_uncollectable): Never invoke GC_push_marked -on free hblk. -* headers.c: Test COUNT_HDR_CACHE_HITS not USE_HDR_CACHE. -(GC_header_cache_miss): Always blacklist pointers for free -hblks. Add assertion and comment. -* pthread_support.c (GC_register_my_thread): Fix #if indentation. -* include/private/gc_hdrs.h: USE_HDR_CACHE is no longer tested. -Delete it. -* include/private/gc_pmark.h: (PUSH_OBJ): Add assertion. - -* alloc.c, include/gc_mark.h, Makefile.direct: Improve comments. - -* configure.ac: Set win32_threads on MinGW. - -Ivan's description of the patch follows. Note that a few pieces like -the GC_malloc(0) patch, were not applied since an alternate had been -previously applied. A few differed stylistically from the rest of -the code (mostly casts to void * instead of target type), -or were classified as too minor to bother. Note that -all of Ivan's static declarations which did not correct outright -naming bugs (as a few did), where replaced by STATIC, which is -ignored by default. - -- minor bug fixing (for FreeBSD, for THREAD_LOCAL_ALLOC and for -GC_malloc(0)); -- addition of missing getter/setter functions for public variables -(may be useful if compiled as Win32 DLL); -- addition of missing GC_API for some exported functions; -- addition of missing "static" declarator for internal functions -and variables (where possible); -- replacement of all remaining K&R-style definitions with ANSI -C ones (__STDC__ macro is not used anymore); -- addition of some Win32 macro definitions (that may be missing in -the standard headers supplied with a compiler) for GWW_VDB mode; -- elimination of most compiler warnings (except for -"uninitialized data" warning); -- several typos correction; -- missing parenthesis addition in macros in some header files of -"libatomic_ops" module. - -My highlights based on reading the patch: - -* allchblk.c: Remove GC_freehblk_ptr decl. -Make free_list_index_of() static. -* include/gc.h: Use __int64 on win64, define GC_oom_func, -GC_finalizer_notifier_proc, GC_finalizer_notifier_proc, -add getter and setters: GC_get_gc_no, GC_get_parallel, -GC_set_oom_fn, GC_set_finalize_on_demand, -GC_set_java_finalization, GC_set_dont_expand, -GC_set_no_dls, GC_set_max_retries, GC_set_dont_precollect, -GC_set_finalizer_notifier. Always define GC_win32_free_heap. -gc_config_macros.h: Define _REENTRANT after processing -GC_THREADS. -* include/gc_cpp.h: Improve GC_PLACEMENT_DELETE test, -handling of operator new[] for old Windows compilers. -* include/gc_inline.h (GC_MALLOC_FAST_GRANS): Add parentheses -around arguments. -* dbg_mlc.c, malloc.c, misc.c: Add many GC_API specs. -* mark.c (GC_mark_and_push_stack): Fix source argument for -blacklist printing. -* misc.c: Fix log file naming based on environment variable -for Windows. Make GC_set_warn_proc and GC_set_free_space_divisor -just return current value with 0 argument. Add DONT_USE_USER32_DLL. -Add various getters and setters as in gc.h. -* os_dep.c: Remove no longer used GC_disable/enable_signals -implementations. (GC_get_stack_base): Add pthread_attr_destroy -call. No longer set GC_old_bus_handler in DARWIN workaround. -* pthread_support.c: GC_register_my_thread must also -call GC_init_thread_local. - -* Makefile.direct, mach_dep.c: Add support for NO_GETCONTEXT. -* mach_dep.c: Include signal.h. -* gc_priv.h: Factor out INLINE declaration. - -* include/private/gcconfig.h: Update MIPS/LINUX config. -* doc/gcdescr.html: Fix typo. -* mach_dep.c (GC_with_callee_saves_pushed): Don't rely on getcontext -for MIPS/LINUX. - -* configure.ac: SPARC fixes. -* thread_local_alloc.c(GC_mark_thread_local_fls_for): Include -size 0, except for gcj. -* doc/gc.man: Expand C++ cautions. -* include/gc_inline.h: Fix comments. - - -== [7.1] 2008-05-03 == - -* doc/gcinterface.html: Improve C++ interface documentation. - -* allchblk.c (GC_allochblk): Check for overflow during size -rounding. -* tests/huge_test.c: New. -* Makefile.direct, tests/tests.am: Add huge_test.c - -* pthread_support.c: Fix typo in comment. -* os_dep.c (GC_win32_get_mem): Add heap section only if -allocation succeeded. - -* malloc.c: (free replacement) Fix caller address space check. - -* finalize.c (GC_grow_table): Dereference table in null-check. - -* win32_threads.c (GC_delete_gc_thread, GC_delete_thread): -Consistently call CloseHandle. (GC_suspend): Call -GC_delete_gc_thread. -* tests/test.c: Don't reference GC_print_stats if not exported. - -* tests/test.c (run_one_test): Don't mention pthread_self(). -* misc.c: Declare GC_thr_init(). - -* allchblk.c (add_to_fl): disable assertions with USE_MUNMAP, -and refine assertions to handle huge unmergable blocks. -(GC_allochblk_nth): Add comment. - -* include/private/gcconfig.h: Add missing FREEBSD macro -consistency test. - -* allchblk.c (GC_enough_large_bytes_left): No longer take -parameters; return free list index bound. -(GC_merge_unmapped): Don't access nexthdr until after null test. -(Fixes bug in 1/29/08 check-in.) (GC_allochblk): Calculate -when splitting is allowable only once here, not when considering each -block. (GC_allchblk_nth): Accept new may_split parameter. -Avoid some redundant tests for exact size matches. -* alloc.c (GC_should_collect): Cache min_bytes_allocd. -(GC_maybe_gc): Make locking assertion testable. -* mark_rts.c: Fix indentation. -* pthread_stop_world.c: Replace old GC_err_printf1 reference. -* tests/test.c: Remove (void) casts. Optionally print some -timing information. - -* windows-untested/gc.def: Remove CreateThread line. -* windows-untested/README: New file. -* win32_threads.c (GC_use_DllMain): Force collector initialization. -* include/gc.h (GC_use_DllMain): Clarify usage rules in comment. -* mark.c (GC_mark_from): Slightly simplify GC_DS_PER_OBJECT code. -* include/gc_cpp.h: Add matching placement delete overloads -everywhere. -* include/private/gc_locks.h (NO_THREAD): Add cast. -* include/private/gcconfig.h: Add test for __HP_aCC. -* configure.ac, tests/tests.am: Avoid libgccpp on HP/UX. - -* doc/README.win32: Fix typo. -* configure.ac: Fix printing of enable-shared result. - -* misc.c (GC_init_inner): Assert !GC_need_to_lock only when -defined. (GC_call_with_stack_base): Add GC_API. -* os_dep.c (GC_get_stack_base): Add GC_API. -* win32_threads.c: (GC_register_my_thread, GC_unregister_my_thread): -Add GC_API. -* include/gc.h: Add GC_API annotations. -* include/private/gc_locks.h: Define UNCOND_LOCK etc. also for -PCR. -* include/private/gc_pmark.h: Fix comments. - -* include/private/gc_priv.h, mark_rts.c, typd_mlc.c: -Add GC_push_typed_structures() to push GC_ext_descriptors. - -* tests/test.c: Call GC_INIT for DARWIN; test system type using -gcconfig.h-defined macros. - -* allchblk.c (GC_merge_unmapped, GC_freehblk): Refuse to create -blocks large enough that their size, when interpreted as a signed -value, would be negative. -* include/private/gc_priv.h: Comment hb_sz range limit. - -* mark.c (GC_push_next_marked): correct comment. -* Makefile.direct: document NO_PROC_STAT. -* include/private/gcconfig.h: Accomodate NO_PROC_STAT. - - -== [7.1alpha2] 2008-01-10 == - -* Makefile.am: Mention atomic_ops.c and atomic_ops_sysdeps.S -again. Refer to build directory as ".". - -* configure.ac: Ignore --enable-parallel-mark on Darwin for now. -* darwin_stop_world.c: Add FIXME comment for parallel marker. - -* include/private/gc_priv.h: Update MAX_ROOT_SETS -and LOG_PHT_ENTRIES to handle larger heaps. - -* include/gc.h (GC_INIT,GC_init): Update comments. - -* allchblk.c, alloc.c, include/private/gc_priv.h: -Track GC_bytes_dropped and use in GC triggering decisions. -* alloc.c (min_bytes_allocd): Weight atomic blocks less. - -* alloc.c (GC_add_to_heap): Call GC_install_header(p) AFTER -adjusting p. - -* Makefile.am: Add NT_X64_THREADS_MAKEFILE. - -* NT_X64_STATIC_THREADS_MAKEFILE: Clean up obsolete comment. -* alloc.c: Add declaration for GC_add_current_malloc_heap. -* win32_threads.c (GC_beginthreadex): Clean up error -return code. -* doc/README.win64, NT_X64_THREADS_MAKEFILE, Makefile.direct: -Add NT_X64_THREADS_MAKEFILE. - -* alloc.c: Define GC_version instead of in version.h. -* version.h: Remove. -* include/gc_version.h: Move most of version.h here. -* include/gc.h: Include gc_version.h. -* gcname.c, add_gc_prefix.c: include gc.h instead of version.h. -* Makefile.direct, Makefile.dj, Makefile.am, include/include.am: -Adjust for version.h rename. - -* configure.ac: Put libatomic_ops links in build directory. -* Makefile.am: Don't mention atomic_ops.c and atomic_ops_sysdeps.S -as nodist sources. - -* include/gc.h, doc/README.macros: Add GC_NO_THREAD_REDIRECTS, -GC_NO_THREAD_DECLS, don't test explicitly for GC_SOLARIS_THREADS. - -* alloc.c: Deal correctly with address wrapping for -GC_greatest_plausible_heap_addr and GC_least_plausible_heap_addr. -* finalize.c, include/gc.h (GC_register_disappearing_link, -GC_register_finalizer_inner): Improve out-of-memory handling. -* include/private/gc_pmark.h: Fix comment spelling. - -* include/gc_inline.h, include/gc_tiny_fl.h: cleanups to make usable -in other contexts. - -* include/gc.h: Don't define GC_HAVE_BUILTIN_BACKTRACE for uclibc. - -* gc_cpp.cc: Don't include gc_cpp.h from local directory. - -* allchblk.c, configure.ac (add --enable-munmap) - -* dyn_load.c (GC_dyld_image_add): Remove ifdef clause and use the macro -GC_GETSECTBYNAME instead. -* include/private/gc_priv.h: Define GC_GETSECTBYNAME according to the -architecture (Darwin). - -* reclaim.c (GC_bytes_found): Expand comment. -* thread_local_alloc.c (GC_malloc_atomic, GC_gcj_malloc): Pass -granules, not bytes, to GC_FAST_MALLOC_GRANS. -* include/gc.h: Never include gc_local_alloc.h. -* tests/test.c: Add size zero allocation tests. - -* malloc.c: Update GC_large_allocd_bytes on explicit deallocation. -* allchblk.c: Sanity check GC_max_large_allocd_bytes. - -* Makefile.direct: Invoke $(MAKE) instead of make. - -* doc/scale.html: Reflect gc7 thread local allocation behavior. - -* include/extra/gc.h, include/extra/gc_cpp.h: New. -* include/include.am: Install gc.h and gc_cpp.h in $(prefix)/include -again. - -* pthread_support.c (GC_thr_init): Use sysconf(_SC_NPROCESSORS_ONLN) -for HURD. - -* include/private/gcconfig.h: Add Linux/mips-64 support. - -* dbg_mlc.c: Use random() on all glibc systems. -* mach_dep.c (GC_with_callee_saves_pushed): Don't use getcontext() on -HURD. Add comment. -* pthread_stop_world.c (GC_suspend_handler, GC_stop_init): Accomodate -systems without SA_SIGINFO. - -* include/gc.h (GC_PTR_STORE): Fix non-DEBUG parentheses. -* tests/test.c (run_one_test): Add GC_PTR_STORE test. -No longer test for RS6000. - -* alloc.c, backgraph.c, headers.c, include/private/gc_priv.h: -Maintain GC_our_memory and GC_n_memory. -* dbg_mlc.c (GC_print_smashed_obj): Improve message. -(GC_print_all_smashed_proc): Pass client object address instead of -base. -* dyn_load.c (sort_heap_sects): New. (GC_register_map_entries): -Register sections that are contiguous and merged with our heap. -* malloc.c, os_dep.c (GC_text_mapping): Check for just base name -of libraries. -* malloc.c (calloc): Check for special callers even with -USE_PROC_FOR_LIBRARIES. Move assertion. Add rudimentary -malloc/free tracing. -* misc.c: No longer call GC_init_lib_bounds explicitly. -* thread_local_alloc.c (GC_malloc, GC_malloc_atomic): Always -initialize on demand. -* tests/test.c: Call GC_INIT only when required. - -* Makefile.direct: Remove comment fragment. -* tests/tests.am: Add smashtest. -* configure.ac: Define GC_USE_DLOPEN_WRAP with redirect-malloc. -* pthread_support.c: Fix comment spelling. -* include/private/gcconfig.h: Define USE_PROC_FOR_LIBRARIES with -GC_LINUX_THREADS and REDIRECT_MALLOC. -* tests/smash_test.c: Initial check-in. -* obj_map.c: Print log entry to correct file. -* include/private/thread_local_alloc.h: Add TlsAlloc error check. - -* alloc.c (GC_stopped_mark): Call GC_add_current_malloc_heap() -while world is still running. -* os_dep.c (GC_is_heap_base): Don't call GC_add_current_malloc_heap() -with world stopped. -* include/gc.h (GC_INIT for cygwin): Always call GC_add_roots. -* misc.c (GC_init/GC_init_inner): Perform all work in -GC_init_inner. -* Makefile.direct: Expand -DUSE_MUNMAP comment. - -* include/gc.h: Define uintptr_t explicitly for VC++6. -* msvc_dbg.c (GetModuleBase): Revert to strcat if strcat_s doesn't -exist. - - -== [7.0] 2007-07-02 == - -* include/gc_config_macros.h: Also check for IA64 when setting -GC_HPUX_THREADS. -* mallocx.c: Change my_bytes_allocd to signed_word. -* include/gc_pthread_redirects.h: Remove obsolete Solaris threads -(as opposed to pthreads) support. - -* mach_dep.c (GC_with_callee_saves_pushed): Don't use getcontext() -on ARM/Linux. Check getcontext() return value. - -* backgraph.c (per_object_func): Make argument types consistent. -(GC_traverse_back_graph): Mark GC_deepest_obj. - -* finalize.c (GC_finalize): Change dl_size and fo_size to size_t. -* os_dep.c (GC_win32_get_mem): Add GC_mem_top_down option. - -* doc/README.win32, doc/README, README.QUICK: Fix some of the worst -anachronisms. -* dyn_load.c: Partially support cygwin, but don't enable it yet. - -* Makefile.am: Use -no-undefined for libgc. -* Makefile.direct: Document USE_PROC_FOR_LIBRARIES. -* dyn_load.c (GC_register_map_entries): Rename prot_buf to prot -consistently. -* misc.c: Fix some WARN calls. Move GC_is_initialized setting and -GC_thr_init() call. -* os_dep.c: Consistently use WARN where appropriate. -* thread_local_alloc.c: Revert change to GC_WIN32_THREADS test. Instead -remove inappropriate pthread.h include. -* doc/README.linux: Remove some anachronisms. - -* alloc.c: Also use GC_check_tls on non-Linux systems. -* mallocx.c (GC_reclaim_generic): Remove bogus declaration. -* include/private/gc_priv.h (GC_reclaim_generic): Declare correctly -with prototype. - -* alloc.c (GC_adj_bytes_allocd): Avoid (long) casts, fix comment. -(GC_print_heap_sects): Use size_t instead of unsigned long. -* thread_local_alloc.c (GC_lookup_thread): Define in the correct -context. -* win32_threads.c, include/gc_config_macros.h: The last of Romano -Paolo Tenca's patch. Move stdint.h include to gc_config_macros.h. -* include/gc_inline.h: Avoid gc_priv.h dependencies. -* tests/test.c (check_heap_stats): Replace unsigned long with size_t. - -* NT_X64_STATIC_THREADS_MAKEFILE: Replace obsolete -debugtype:cv. -* mark_rts.c (GC_push_roots): Fix kind type. - -* doc/README.win64: New file. -* doc/doc.am, Makefile.direct: Add README.win64. - -* Makefile.am, Makefile.direct: Add NT_X64_STATIC_THREADS_MAKEFILE. -* NT_X64_STATIC_THREADS_MAKEFILE: Fix warning flags. -* allochblk.c, alloc.c, blacklst.c, dbg_mlc.c, dyn_load.c, -finalize.c, headers.c, mach_dep.c, malloc.c, mark.c, misc.c, -obj_map.c, os_dep.c, ptr_chck.c, reclaim.c, typd_mlc.c, -win32_threads.c, cord/de_win.c, include/gc_mark.h, -include/private/gc_hdrs.h, include/private/gc_pmark.h, -include/private/gc_priv.h, tests/test_cpp.cc: -Replace old style function declarations. Clean up integral types. -Remove register declarations. The change in malloc.c and the -"int descr" declaration in mark.c are the most likely to have -been real bugs outside of win64. -* msvc_dbg.c: Disable on win64. -* win32_threads.c: Add AMD64 support. -* include/gc.h: no backtrace on AMD64 for now. - -* msvc_dbg.c(GetModuleBase): Replace strcat with strcat_s. - -* include/gc.h: (GC_word, GC_signed_word): Fix win64 definitions. -Don't include windows.h in an extern "C" context. -* include/private/gcconfig.h: Fix win64/X86_64 configuration. -* tests/test.c: Eliminate more old style function definitions. -Cleanup pointer and integer casts for win64. -* tests/test_cpp.cc: Don't include gc_priv.h. -* NT_STATIC_THREADS_MAKEFILE: Restrict suffixes for VC++ 2005. -* NT_X64_STATIC_THREADS_MAKEFILE: New. - -* win32_threads.c: Separate out DEBUG_WIN32_PTHREADS_STACK. Ignore -FINISHED threads for suspension. (GC_pthread_join): Add -pthread_self() cast. (GC_pthread_start_inner): Execute cleanup -handler when popping it. -* include/private/gc_locks.h: Inline THREAD_EQUAL for -GC_WIN32_PTHREADS. Define USE_PTHREAD_LOCKS only if we have -pthreads. - -* gc_dlopen.c, thread_local_alloc.c, threadlibs.c, win32_threads.c, -tests/test.c: Accomodate GC_WIN32_PTHREADS. -* include/gc.h: Don't include windows.h for GC_WIN32_PTHREADS. -* include/gc_config_macros.h: Define both PTHREADS and -GC_WIN32_THREADS. -* include/private/gc_locks.h: Nonstandard definitions of -NUMERIC_THREAD_ID for GC_WIN32_PTHREADS. -* doc/README.win32, Makefile.direct: Include documentation -for GC_WIN32_PTHREADS. -* Makefile.direct: Remove some anachronisms in the documentation. - -* Makefile.am: Move includes to bottom. Add better library -dependencies. Increment library version. Remove "SUBDIRS += .". -* cord/cord.am, tests/tests.am: Add better library dependencies. -Remove now unnecessary dependencies. -* include/gc.h (GC_beginthreadex, GC_endthreadex, GC_ExitThread): -Move to define on all Windows platforms. (_beginthread): define -to generate error if used. - -* include/private/gc_locks.h: Format to 80 columns. - -* malloc.c(GC_free): Ignore bad frees on MSWIN32 with REDIRECT_MALLOC. -* NT_MAKEFILE: msvc_dbg.h is in include/private. Don't use cvars -rc. -* misc.c (WIN32 GC_write): Define GC_need_to_lock in single-threaded -case. -* win32_threads.c: Test for __MINGW32__ in addition to _MINGW_VER. -(GC_CreateThread, GC_beginthreadex): Deallocate args even if we fail. -* include/gc.h: Add GC_reachable_here(). (GC_WinMain): Add GC_API. -(GC_beginthreadex, GC_endthreadex, GC_ExitThread): Declare. -* tests/test.c: Add GC_reachable_here() call. - -* alloc.c (GC_try_to_collect): Call GC_init if necessary. -* tests/thread_leak_test.c: Don't unconditionally define -GC_LINUX_THREADS. - -* Makefile.am: Remove extra_ldflags_libgc definition. - -* include/private/gc_priv.h: Define AO_REQUIRE_CAS. - -* finalize.c (GC_unreachable_finalize_mark_proc): Don't return void -value. - - -== [7.0alpha9] 2007-05-15 == - -* Some gc6.9 changes. -* Change FindTopOfStack decl in darwin_stop_world.c. -* Move some static tests from misc.c to gcconfig.h. Use #error. -* Add GC_print_free_list() function (thanks to Bruce Hoult). -* Add GC_GNU_THREADS support on HURD (thanks to Aleksey Demakov, -Barry DeFreese, and possibly other Debian maintainers). -* __GNUC__ was misspelled as __GNUC in thread_local_alloc.h (thanks to -Peter Wang). -* Integrated various MacOSX patches and tried to reconcile them (thanks to -Allan Hsu, several contributors at Apple, and probably others). -* Added some casts to powerpc.h in libatomic_ops to silence warnings. - -* Makefile.am: Include NT_STSTIC_THREADS_MAKEFILE in dist. -* include/private/gc_locks.h: GC_compare_and_exchange, GC_atomic_add: -remove. NUMERIC_THREAD_ID, THREAD_EQUAL: New. GC_lock_holder: now -unsigned long. I_DONT_HOLD_LOCK, I_HOLD_LOCK: Update. -* pthread_stop_world.c, pthread_support.c, win32_threads.c: Use -NUMERIC_THREAD_ID, THREAD_EQUAL. -* include/private/gcconfig.h: GENERIC_COMPARE_AND_SWAP: Remove. -* include/private/thread_local_alloc.h: Don't USE_COMPILER_TLS on -ARM. - -* dbg_mlc.c, include/gc.h, finalize.c: Merge Alexandre Oliva's -GC_debug_register_finalizer_unreachable() patch from gcc tree. -* thread_local_alloc.c (GC_malloc, GC_malloc_atomic): Add assertions -to check GC has been initialized. - -* include/gc_cpp.h: Documentation updates. -* include/gc_config_macros.h: Don't check for __ppc__ to set -DARWIN_THREADS. -* Makefile.am: Include configure_atomic_ops.sh in dist. - -* Makefile.am: Don't distribute copied atomic_ops files. Include -libatomic_ops with "make dist". -* configure.ac: Enable THREAD_LOCAL_ALLOC for Cygwin with threads. -* win32_threads.c: Report error for Cygwin + GC_DLL. - -* Makefile.direct: Update THREAD_LOCAL_ALLOC documentation. -* cord/de_win.c: Rename and move AboutBox. Call GC_INIT. Remove -MakeProcInstance anachronism. -* doc/README.macros: Officially remove elif prohibition. -Remove documentation for defunct SRC_M3 support. -* include/gc.h: Remove more SRC_M3 references. -* include/private/gcconfig.h: Remove still more SRC_M3 references. -GC_SOLARIS_THREADS no longer needs to be checked separately. - -* thread_local_alloc.c, include/private/thread_local_alloc.h: -Spell __declspec correctly. -* NT_STATIC_THREADS_MAKEFILE: Enable thread-local allocation. - -* doc/README.win32: Adjust GC_win32_dll_threads rules again. - -* mark.c (GC_mark_some wrapper): Restructure for readability, handle -GC_started_thread_while_stopped. -* misc.c (Win32 GC_write): Lock GC_write_cs only if needed. -* win32_threads.c: (client_has_run): remove, -GC_started_thread_while_stopped, GC_attached_thread: add. -(GC_push_all_stacks): Add verbose output. -(DllMain): Avoid initializing collector or the like. -Never update both thread tables. -* doc/README.win32: Adjust GC_win32_dll_threads rules. - -* pthread_stop_world.c (GC_push_all_stacks): Print thread count with -GC_PRINT_VERBOSE_STATS. - -* configure.ac: Comment out redundant -AC_DEFINE(NO_EXECUTE_PERMISSION). -* sparc_mach_dep.S: Remove single quote in comment. -* include/private/gcconfig.h: Fix DATAEND for NONSTOP. -* win32_threads.c: Include stdint.h for Mingw. Add GC_API for DllMain. -(GC_use_DllMain): Fix assertion. - -* configure.ac: Introduce extra_ldflags_libgc. Use it for Darwin. -* Makefile.am (libgc_la_LDFLAGS): Use extra_ldflags_libgc. -* include/private/gcconfig.h: Enable MPROTECT_VDB for all Darwin -targets. Remove comments. -Prepare ppc64 support for Darwin. - -* darwin_stop_world.c (GC_push_all_stacks): Fix compiler warnings. -Make i unsigned. -(GC_stop_world): Likewise. Remove unused GC_thread p. -(GC_start_world): Likewise. - -* os_dep.c: Define GC_darwin_register_mach_handler_thread extern. -Remove double SIG_HNDLR_PTR definition. -(GC_forward_exception): Fix compiler warnings, make i unsigned. -Initialize thread_state to NULL. -(catch_exception_raise): Fix compiler warnings, make i unsigned. - -* include/private/gc_priv.h (NEED_FIND_LIMIT, FREEBSD variant): -also define for X86_64. -* configure.ac: Move generic gnu (Hurd) case to below kfreebsd case. -* README.changes: Point to ChangeLog. - -* darwin_stop_world.c: Move THREAD_FLD defines to ... -* include/private/gc_priv.h: ... here. -Fix THREAD_STATE definitions for ppc64. -* os_dep.c (catch_exception_raise): Use THREAD_FLD for exc_state member -access. - -* configure.ac (i586-darwin): Replaced HAS_I386_THREAD_STATE_* with -HAS_X86_THREAD_STATE32_*. -(x86_64-*-darwin*): Extended the above check for x86_64-*-darwin* with -HAS_X86_THREAD_STATE64_*. -Added value 1 in the above AC_DEFINE's. Important for the upcoming -Leopard. -* include/private/gcconfig.h: Modified X86_64 define for Darwin. -Removed __x86_64__ check in POWERPC section. Added base definitions -for the X86_64 Darwin port. -* include/private/gc_priv.h: Added GC_MACH_HEADER and GC_MACH_SECTION -to distinguish between 32 and 64-bit applications. Added definitions -for X86_64 Darwin. -* darwin_stop_world.c: Added HAS_X86_THREAD_STATE64___RAX. And -replaced HAS_I386_THREAD_STATE___EAX with HAS_X86_THREAD_STATE32___EAX. -(GC_push_all_stacks): Added code for X86_64 Darwin. Even for the -!DARWIN_DONT_PARSE_STACK. Maybe obsolete. -* dyn_load.c (GC_dyld_name_for_hdr): Use GC_MACH_HEADER. -(GC_dyld_image_add): Use GC_MACH_HEADER and GC_MACH_SECTION. -Distinguish between getsectbynamefromheader_64 and -getsectbynamefromheader. -* os_dep.c (catch_exception_raise): Introduce exception definition for -X86_64 Darwin. Replaced old i386_EXCEPTION_STATE_* definition with -x86_EXCEPTION_STATE32_*. Add X86_64 for exc_state.faultvaddr. - - -== [7.0alpha7] 2006-09-19 == - -* More 6.7 changes. -* Declare GC_dump() in gc.h. -* Add --enable-large-config, which just defines the LARGE_CONFIG macro. -* Make GlobalAlloc address alignment a bit more intuitive (thanks to -Charles Mills). -* Use #elif in the definitions of GET_MEM. -* Overhaul porting.html. Remove corresponding text from README. -* Fix typo in DARWIN section of gcconfig.h. -* Fix Darwin thread memory leak (thanks to Bruce Mitchener). -* Update x86 AO_test_and_set implementation to use "=q". -* Add $(EXEEXT) to many tests in tests/tests.am. (Corresponds to a -6.7 fix, which no longer applied.) -* Fix Darwin/PPC port. -* Fix Cygwin/threads port. -* Fix gcj malloc support. -* For GNU-style make, don't build libatomic_ops unless threads are requested. -This should allow single-threaded builds on platforms which do not -currently support libatomic_ops. -* Clean up and hopefully fix the CFLAGS calculation for GNU build. -(Substantially improves things on HP/UX.) -* Integrated Andrei Polushin's Visual C++ patches. These provide for -stack traces, better C++ debug support, and better log file handling. -Note that these change the location of the log file to a the path of the -executable with a .log extension. To get the old behavior back, define -OLD_WIN32_LOG_FILE. For the time being, I'm checking his project -files and the like into a windows-untested subdirectory. They -are almost certainly already out of date, but better than what we had -before. -* Fixed some win32 threads bugs, and added support for _beginthreadex. -* Fix zero size thread local allocation so that explicit deallocation -works correctly. -* Removed serious bug in GC_malloc_uncollectable(large size). -* Do not try to do thread-local gcj allocation in incremental mode. There -are races in setting up the descriptor. -* Add GC_INIT() to middle.c, fix some more GC_printfn calls. -* Some assertions erroneously used I_HOLD_LOCK() negatively, even though -it can now spuriously return TRUE. -* Rename SUNOS5 macro and OS name to SOLARIS and SUNOS5DL to SOLARISDL. -* On Linux and some Un*x variants, allocate memory by first trying sbrk, -and then switching to mmap if that fails. -* Fixed /proc/x/maps reading to deal with asynchronous deletions. -* Fix REDIRECT_MALLOC with threads on Linux. It now usually seems to work -with ugly hacks that include having calloc behave differently when it is -called from ld.so or the pthreads library. A reasonable amount of -infrastructure was added to support some of this. (Thanks to Roland McGrath -for ideas and information.) -* Import various updated build scripts. -* Add GC_register_has_static_roots_callback (thanks to Andrew Haley). -* Fix serious bugs in GC_malloc_atomic_uncollectable(). -* Return GC_SUCCESS form GC_get_stack_base(). -* Fix several atomic_ops problems on IA64 with HP Compiler. -* Update to atomic_ops-1.2. -* Fix hb_n_marks description and reclaim.c assertion. -* Various additional win32 threads fixes. -* Enable GC_ASSERTIONS for Debug build with NT_THREADS_MAKEFILE. - - -== [7.0alpha5] 2005-09-29 == - -* More 6.6, 6.7 changes. -* Some Solaris fixes, including some more general changes in how -the assembly pieces of mach_dep.c are handled. -* Removed a lot of SOLARIS_THREADS-specific code that was only -needed with the old implementation. This included many (mostly no-op) -versions of GC_is_fresh. -* Don't use atomic_ops in gc_locks.h unless we need threads. -* Fixed USE_MARK_BITS, which is once again the default without PARALLEL_MARK. -* Removed Solaris GC_INIT hack. It's a workaround for a long dead bug, -and it seemed to be wrong anyway. -* Changed win32_threads.c to require preprocessor-based interception -of thread routines by default. A client call to GC_use_DllMain is -now required to get the old behavior in which DllMain is used to implicitly -register threads. This was done for uniformity with other platforms, and -because the DllMain solution seemed to require very tricky code which, -at least in the past, imposed hard bounds on the number of threads. -* Many small changes to make thread support work again on Cygwin. -* Moved definition of allocator lock etc. to pthread_support.c and -win32_threads.c for those two cases. -* Got rid of the FASTLOCK() machinery. It doesn't seem useful on modern -platforms. -* Cleaned up the uncollectible allocation routines, speeding up the -slower paths. The code did enough unnecessary work off the critical path -that the underlying logic was getting hard to extract. -* No longer turn off THREAD_LOCAL_ALLOC with DBG_HDRS_ALL. Indications -are it just works, and I think the reasons for it not working disappeared -a while ago. -* Fixed bugs in hb_n_marks calculation and assertion. -* Don't use __builtin_expect for pre-3.0 gcc. -* Define GWW_VDB only for recent Microsoft tool chains. -* Add overview.html to doc directory. -* Fix NT_STATIC_THREADS_MAKEFILE, various compiler warnings. -* Made thread local allocation sort of work with Cygwin. The code should -be there to deal with other Windows variants, But non-Cygwin Windows -threads need more bug fixes. - - -== [7.0alpha4] 2005-08-02 == - -* Various 6.5, 6.6 changes. -* Removed GC_brief_async_signal_safe_sleep and used atomic_ops instead -(thanks to Ben Maurer). -* Integrated build patches from Davide Angelocola and Petter Urkedal. -* Fix dynamic-linker-based pthread call redirection. -* Renamed RS6000 to POWERPC/AIX. -* Allow recovery from SIGSEGV in marker on Linux. This works around -a race in thread stack marking if /proc is used to find roots. We do -that by default with malloc redirection and threads. This involved -moving some GC_find_limit and SETJMP related declarations to gc_priv.h. -* Added doc/porting.html file. -* Added ADD_HEAP_GUARD_PAGES for sbrk/*nix platforms to debug extreme -memory overwrite errors. -* Added trivial NO_INCREMENTAL flag to facilitate debugging. -* Added GC_getattr_np-based GC_get_stack_base (untested). -* Separated thread local allocation into a separate file and added the -beginning of win32 support for that. - - -== [7.0alpha3] 2005-04-28 == - -* Added support for dlopen-based interception of pthread functions. -This is only half done. The gc.h redefinitions currently interfere. -* Integrated major automake overhaul from Petter Urkedal. - - -== [7.0alpha2] 2005-04-07 == - -* GC_bytes_allocd was incremented by a possibly uninitialized variable -in GC_generic_malloc_inner. (Bug introduced in gc7.0alpha1. Thanks -to Ben Hutchings for tracking it down.) -* Win32 fixes (thanks to Ben Hutchings and Maurizio Vairani). -* Integrated Ben Hutchings' GetWriteWatch-based virtual dirty bit -implementation for win32. -* Removed pc_gc.tar and floppy targets in Makefile.direct. Removed -pc_excludes file. -* No longer include GC_bytes_wasted when evaluating allocation progress. -Since we are now counting live memory, it no longer makes sense. -* Applied Davide Angelocola's configure patch. There are now separate -Makefile.am's in the cord and tests subdirectory, more tests, etc. -* Renamed configure.in to configure.ac. -* Merged a very small number of Nathanael Nerode's configure.ac -cleanups from the gcc tree. Unfortunately, that file is a bit -different from ours. -* Changed EINTR handling in sem_wait slightly. -* Restructure the root marking code. Remove all traces of -USE_GENERIC_PUSH_REGS, and effectively make it the default. -Make it easier to pass a context pointer to the mark routine, in -case we ever want to do precise stack marking. -* Replace GC_start_blocking() and GC_end_blocking() with GC_do_blocking(). -This remains undocumented, and only implemented for pthreads. But it -removes an otherwise unavoidable race with stores of callee-save -registers. -* Fix GC_n_mark_bits for the default MARK_BIT_PER_GRANULE case. This -resulted in bogus complaints in heap dumps. -* Upgrade to libatomic_ops-1.0, and update build structure to match. -* Remove SRC_M3 support. Clean up lock initialization code in misc.c. -* Removed gc_local_alloc.h. If THREAD_LOCAL_ALLOC is defined, the -thread local allocation routines are now called automatically. -* Renamed gc_inl.h back to gc_inline.h. Changed the interface appreciably -since locking has turned into a dominant issue, and in-line allocation -only makes sense if it's no worse than thread-local allocation. -Gc_inline.h is now also used to implement thread-local allocation. -* Finished replacing stubborn allocation with manual write barrier. -Untested. -* Use thread-local allocation code by default. -* Added GC_register_my_thread and friends for Posix and win32. -* Patch for GWW_VDB from Ben Hutchings. -* Removed explicit THREAD_LOCAL_ALLOC tests, since that now always -redefines GC_malloc. -* Removed now unused AIX memory allocation code. -* Various minor fixes for bugs introduced in 7.0alpha1. - - -== [7.0alpha1] 2004-11-09 == - -* Remove GC_PROTO, VOLATILE, GC_PTR, and GC_CONST. Assume ANSI C compiler -and use ANSI constructs unconditionally. -* Introduce #elif and #error in some of the appropriate places. -* Remove GC_printf cruft. Use stdargs. -* Remove separate Solaris threads support. Use the more generic Posix -implementation. -* Use atomic_ops for atomic operations and memory barriers. -* Clean up MPROTECT_VDB implementation. Use SA_SIGINFO wherever -possible. -* Remove broken SIGNALS stuff. -* Use size_t instead of word, where appropriate. -* Add .S.o rule to Makefile.am. -* Officially discontinue SunOS4, several old flavors of M68K (SunOS4, -A/UX, HP), IBM PC/RTs and RISCOS/Irix4. (I doubt the old code worked. -If anyone cares, these should be easy to resurrect.) -* Add EXPECT() in some critical places. -* Redefined hb_sz and hb_body to deal with bytes rather than words. -This affected a great deal of code. I would like to consistently use -byte offsets and sizes where there's not a convincing reason to do -otherwise. -* Redefined several other variables (GC_mem_found, GC_words_allocd) -etc. to use units of bytes. Most of these were also renamed to -reflect that fact. -* Killed as many "register" declarations as possible. -* Partially replaced stubborn allocation with manual write barrier. -It's currently broken. -* Restructured mark code, to allow mark bits to be kept either on -a per allocation granule or per object basis. The emphasis is -now on the -DUSE_MARK_BYTES option, since individual bits perform -quite badly on hyper-threaded P4s, and are probably suboptimal on -other architectures. -DUSE_MARK_BITS is currently broken, and may -be resurrected only for the single-threaded case. This significantly -reduced the cache footprint required by auxiliary GC data structures. -It also reduces space overhead for small heaps. It probably slows -things down slightly if interior pointers are very common. -* As part of the above, we now maintain an approximate count of set -mark bits in each heap block. -* As part of the above, the semantics of hb_map changed drastically. -For MARK_BIT_PER_OBJ, it doesn't exist. For MARK_BIT_PER_GRANULE, -it is purely a way to replace a mod instruction with a table lookup. -(Somewhat to my surprise, this still wins on modern hardware.) -* Removed PRINTSTATS, GATHERSTATS, and SILENT macros. Everything is -now controlled by GC_print_stats variable and GC_PRINT_STATS -and new GC_PRINT_VERBOSE_STATS environment variables. -* Add GC_log_printf and use it consistently for logging output. -* Unconditionally count the objects we reclaim in the sweep phase. -For thread local allocation, we need that anyway, and we expect -that's increasingly the only case that matters. And it simplifies -the code. In general expect minor performance hacks that benefit -only the single-threaded case to disappear. -* Remove GC_quiet from gc.h and elsewhere. -* Changed the heap expansion heuristic, and the definition of -GC_free_space_divisor, to refer to live data size, instead of total -heap size. I believe this is much more robust. It wasn't previously -possible, because we didn't have access to live data size. -* Thread local allocation added the extra byte in twice: Once in -thread_local_alloc, and once in malloc_many. -* Removed GC_malloc_words_small and GC_gcj_fast_malloc. A new -mechanism based on the thread local allocation data structures -is expected to be added instead. This should allow inlined code -that is both fast and doesn't rely on collector internals. -* Changed both free lists and reclaim lists to be indexed by granules -instead of words, norming halving their size. -* MERGE_SIZE is now the only option, and the macro was removed. -(Without it, we need a memory reference to GC_all_interior_pointers -anyway. Thus it costs us nothing.) -* Change GC_size_map to map to granules instead of words. Make sure -that every possible size up to TINY_FREELISTS is present. -* Split of macros need for fast inline allocation into gc_tiny_fl.h -in anticipation of a new inline allocator that doesn't rely on GC -internals. -* Changed thread local allocation to use GRANULE_BYTES and TINY_FREELISTS -in anticipation of a merge with the inline allocation code. -* Removed ALIGN_DOUBLE. This is mostly handled by GRANULE_BYTES. -* Make locking on most platforms conditional on GC_need_to_lock. - - -== [6.9] == - -* Fix typo in PREFETCH implementation for X86_64 (thanks to Peter Wang). -* Fix M68K LINUX port (thanks to Debian packagers). -* __GNUC__ was misspelled as __GNUC in new_gc_alloc.h (thanks to Peter Wang). -* Integrated Allan Hsu's patch for OS X VM deallocation problems. -* Applied FreeBSD/X86_64 patch. - - -== [6.8] 2006-07-08 == - -* Added some support for Dragonfly BSD (thanks to Joerg Sonnenberger and -Thomas Klausner). -* Improvements to the HP/UX section of configure.in/configure.ac (thanks -to Andreas Tobler). -* GC_unix_get_mem could neglect to release the malloc lock on Irix, under -extremely unlikely circumstances. (Thanks to Jean-Baptiste Nivois for -some careful code inspection.) -* Added support for kFreeBSD + glibc (thanks to Petr Salinger). -* Fix more MacOS threads memory leaks (thanks to Allan Hsu). -* Added initial Solaris/X86-64 support (thanks to Rainer Orth). - - -== [6.7] 2006-03-03 == - -* Add "int" to Solaris "end" and "etext" declaration in gc.h. Declared -the symbols with underscores and as arrays, since that's what's actually -used. Perhaps this could all just be removed. (Thanks to John Bowman.) -* Fixed ARM GC_test_and_set code (thanks to Kazu Hirata and Paul Brook). -* Added casts for assignments to hb_last_reclaimed, which truncate the -value. Added a cast to GC_adj_words_allocd. Use GetModuleHandleA -when retrieving a handle to kernel32.dll under win32. -* Added Tandem S-Series support. (Thanks to Craig McDaniel. A modified -version of his patch was applied, and hence breakage is probably not -his fault.) -* Remove spurious gc:: qualifier for operator delete[] in gc_cpp.h (thanks -to Hanno Boeck). -* Changed a test for LINUX in config_macros.h to one for __linux__. -* Add prototypes for GC_finalizer_notifier and GC_thr_init (thanks to -David Ayers). -* Use ld instead of nonexistent ldz instruction in Darwin FindTopOfStack -(thanks to Andreas Tobler). -* Add support for Darwin/X86 (thanks to Geoff Norton and the Mono -developers). -* Merge in some recent gcc fixes. Add ppc64 asm code. (Thanks to -Bryce McKinlay and other GCJ developers.) -* Scan MEM_PRIVATE sections under Windows ME and predecessors. -* Interior pointers with some largish offsets into large objects could -be ignored, if GC_all_interior_pointers was set. (Oddly this worked -correctly for stack references if it was not set. Otherwise it failed -for both stack and heap references. Thanks to Andrew McKinlay for the -critical test case.) -* Integrated Tatsuya Bizenn's NETBSD threads support, with some -untested changes. -* Added GC_strdup and friends to make leak detection work correctly -for strdup clients (thanks to Jon Moore). Fixed the existing strdup -with malloc redirection to handle a null malloc return correctly. - - -== [6.6] 2005-09-09 == - -* Fix CPU count detection for Irix and FreeBSD (thanks to Dan Bonachea). -* Integrate Dan Bonachea's patch for the IBM XLC compiler on Darwin. -* Integrated Andreas Tobler's FreeBSD/PowerPC patch. -* Don't access the GC thread structure from the restart handler. It's -unsafe, since the handler may run too late. (Thanks to Ben Maurer for -tracking this down.) -* Applied Christian Thalinger's patch to change comment syntax in -alpha_mach_dep.S. -* Added test for GC_no_dls in GC_dyld_image_add for DARWIN (thanks to -Juan Jose Garcia-Ripoll). -* Use LINUX_STACKBOTTOM for Linux/SH and LINUX/ARM (thanks to -Sugioka Toshinobu and Christian Thalinger). -* Rewrote GC_parse_map_entry. This assumed a fixed column layout of -/proc/self/maps on Linux. This ceased to be true about 2 years ago. -The old code is probably quite problematic with -DREDIRECT_MALLOC. It -is also used by default for IA64, though I haven't seen actual failures -there. -* More consistently define HBLKSIZE to 4096 on 64 bit architectures with -4K pages (thanks to Andrew Haley). -* With win32 threads, GC_stop_world needs to acquire GC_write_cs (thanks -to Ben Hutchings for the observation and patch). -* Move up struct callinfo declaration to make gcc 4.0.2 happy. - - -== [6.5] 2005-05-22 == - -* Integrated Paolo Molaro's patch to deal with EINTR in sem_wait. -* Make GC_approx_sp() write to dummy location to ensure that stack -is grown here, when sp looks reasonable, rather than later, when -it might look like a bad memory reference. (Problem was never -observed that I know of. But on rereading the code it seemed -dubious.) -* Separate out GC_with_callee_saves_pushed and sometimes call -it from GC_suspend_handler in pthread_stop_world.c. Callee-save -register values sometimes failed to get traced under HP/UX on -PA-RISC. Linux/IA64 had the same problem, though non-stacked -callee-save registers seem to be so rarely used there that nobody -ever noticed. -* Integrated an ancient Darwin powerpc_darwin_machine_dep.s patch -from Andreas Tobler, which I had lost. -* Fix compare_and_exchange implementation for gcc/IA64 to deal with -pickier compiler versions. -* Fixed Itanium 32-bit ABI support (HP/UX). In particular, the -compare_and_exchange implementation didn't consider that possibility. -* Undefine GC_pthread_detach in win32_threads.c (thanks to -Tommaso Tagliapietra). -* Fixed inclusion of frame.h for NETBSD in os_dep.c. -* Applied Dan Bonachea's patch to use mmap on AIX. -* Several fixes to resurrect the Irix port on recent OS versions. -* Change ALPHA to use LINUX_STACKBOTTOM. -* Change SPARC64/LINUX to also use LINUX_STACKBOTTOM. Deal with potential -bad values of __libc_stack_end on that platform (thanks to David Miller). -* Relax gctest to allow larger heap if ALIGN_DOUBLE isn't set. -(Unnecessary in 7.0) -* Force a define of __STDC__=0 for the IBM compiler on AIX, so that -we get prototypes. (Unnecessary in 7.0) -* GC_INIT definition for AIX and CYGWIN referred to DATASTART and DATAEND -which are only defined in private include files. -* Integrated some small gcconfig.h patches from Dan Bonachea. Also -relaxed assertion about FreeBSD stack size in pthread_support.c. -* Integrated Andrew Begel's darwin_stop_world.c patch for 64-bit -support. This may need additional work. -* Avoided potentially infinite recursion in GC_save_callers if -the system backtrace calls malloc. The workaround currently requires -__thread support if this code is used with threads. -* Avoided another similar infinite recursion by conditionally -invoking GC_save_callers in alloc.c (thanks to Matthias Andree -for helping to track down both of these). -* Removed all traces of aix_irix_threads.c. AIX and Irix now use -pthread_support.c and pthread_stop_world.c. The old code appeared -to be unreliable for AIX, and was not regularly maintained. -* On Irix, ignore segments with MA_FETCHOP or MA_NOTCACHED attributed; -they're not always safe to read. -* Fixed a previously vacuous assertion (diagnosed by the SGI compiler) -in GC_remove_from_fl. -* Fix stack_size assertion in GC_pthread_create. -* Fix assertion in GC_steal_mark_stack. - - -== [6.4] 2004-12-21 == - -* Merge gcconfig.h changes from gcc tree. -* Unconditionally include gc_priv.h in solaris_pthreads.c, win32_threads.h, -aix_irix_threads.c, and solaris_threads.c to get thread definitions. -* Start marker threads in GC_thr_init, so that they get started even -if no other threads are ever started. (Oddly enough, the parallel -collector worked correctly, though not well, with no helper threads.) -* Go ahead and split large blocks in GC_allochblk_nth if GC_dont_gc -is set (thanks to Alexander Petrossian). -* GC_PRINT_BACK_HEIGHT would deadlock with thread support. -* Let in_progress_space in backgraph.s grow dynamically. -* Fix README.solaris2. The GC_thr_init() hack doesn't work anymore. -* Convert GC_finalizer_mem_freed to bytes in allchblk.c. -* Add missing declaration for GC_generic_malloc_words_small_inner. -Without it, s390x breaks. (Thanks to Ulrich Weigand.) -* Applied several MacOSX patches to support older tool chains (thanks -to Stefan Ring). -* Bug fix for NetBSD/amd64 (thanks to Marc Recht). -* Add NetBSD/sh3 support (thanks to Uchiyama Yasushi). -* Fixed an uninitialized variable in cordprnt.c. -* Eliminated some, but not all, gcc -Wall warnings. -* Changed some old style casts to reinterpret_cast in new_gc_alloc.h -(thanks to Dan Grayson). -* GC_extend_size_map shouldn't adjust for GC_all_interior_pointers if -GC_DONT_ADD_BYTE_AT_END is set. -* Changed some (long) casts to (word) in preparation for win64 (thanks -to Peter Colson). -* Changed "int stack_size" declaration in pthread_support.c to use -size_t. (Only mattered with GC_ASSERTIONS enabled.) -* Added CRIS (etrax) support (thanks to Simon Posnjak and Hans-Peter Nilsson). -* Removed GC_IGNORE_FB frame buffer recognition, and replaced -it with a check that the mapping type is MEM_IMAGE. -In theory, this should work much better, but it is a high -risk change for win32. (Thanks to Ashley Bone for the crucial -experimental data behind this, and to Rutger Ovidius for -some further experiments.) -* GC_allochblk_nth incremented GC_words_wasted by bytes rather than -words. -* Consider GC_words_wasted in GC_adj_words_allocd only if it is within -reason. (A hack to avoid some extremely unlikely scenarios in which -we manage to allocate only "wasted" space. 7.0 has a better fix.) -* Changed PowerPC GC_clear implementation to use lwsync instead of -eieio, since the documentation recommends against eieio, and -it seems to be incorrect if the preceding memory op is a load. -* Fixed print_block_list to print the correct kind number for -STUBBORN (thanks to Rutger Ovidius). -* Have configure.in generate an error if it is asked to support -pthreads, but doesn't know how to. -* Added Kazuhiro Inaoka's patch for Renesas M32R support. -* Have the GNU build mechanism link with -ldl. Rename THREADLIBS -to THREADDLLIBS to reflect this. (Thanks to Sven Verdoolaege.) -* Added Hannes Mehnert's patch for FreeBSD/SPARC support. -* Merged some FreeBSD specific patches to threadlibs.c and dyn_load.c. -(Thanks to John Merryweather Cooper.) -* Define MPROTECT_VDB on MACOSX only if threads are being used, since the -dirty page tracking mechanism uses threads. (This avoids an undefined -reference to _GC_darwin_register_mach_handler_thread.) -* By popular demand, use __libc symbols only if we are built with -USE_LIBC_PRIVATES, which is off by default, and not otherwise documented. -* Ignore GC_enable_incremental() requests when KEEP_BACK_PTRS is set. -The GC itself will dirty lots of pages in this cases, probably making -it counterproductive on all platforms. And the DARWIN port crashes. - - -== [6.3] 2004-07-08 == - -* Compile test_cpp.cc with CXXCOMPILE instead of COMPILE. -* Very large allocations could cause a collector hang. Correct -calculation of GC_collect_at_heapsize. -* GC_print_hblkfreelist printed some bogus results if USE_MUNMAP -was defined. -* Include gc_config_macros.h in threadlibs.c. -* Correct MacOSX thread stop code (thanks to Dick Porter). -* SMALL_OBJ definition was off by one. This could cause crashes -at startup. (Thanks to Zoltan Varga for narrowing this down to -a trivial test case.) -* Integrate Paolo Molaro's patch to deal with a race in the Darwin -thread stopping code. -* Changed X86_64 implementation to use SA_SIGINFO in the MPROTECT_VDB -implementation. The old approach appears to have been broken by -recent kernels. -* Added GC_ATTR_UNUSED to eliminate a warning in gc_allocator.h (thanks -to Andrew Begel). -* Fix GC_task_self declaration in os_dep.c (thanks to Andrew Pinski). -* Increase INITIAL_BUF_SZ in os_dep.c for Solaris /proc reads. - - -== [6.3alpha6] 2004-05-06 == - -* Define USE_GENERIC_PUSH_REGS for NetBSD/M68K. -* Fixed the X86_64 PREFETCH macros to correctly handle ia32e (which uses -different prefetch instructions from AMD64). (Thanks to H.J. Lu.) -* GC_config_macros.h did not correctly define GC_WIN32_THREADS from -GC_THREADS. -* Added simple_example.html. -* Merged Andrew Gray's patch to correctly restore signal handlers on -FreeBSD. -* Merged a patch from Andreas Jaeger to deal with prefetch-related warnings -on x86-64. Added some other casts so that the PREFETCH macros -always get a ptr_t argument. Removed some casts in the PREFETCH -implementations. -* Added a header guard for gc_allocator.h and changed GC_debug_free to -clobber contents of deallocated object (suggested by Jesse Jones). -* The signal masking code in pthread_stop_world.c contained some errors. -In particular SIGSEGV was masked in the handler, in spite of the fact that -it wrote to the heap. This could lead to an uncaught SIGSEGV, which -apparently became much more likely in Linux 2.6. Also fixed some -typos, and reduced code duplication in the same area. -* Remove ltconfig, clean up configure messages for DG/UX (thanks to -Adrian Bunk for the patches). -* Integrated NetBSD/OpenBSD patches from Marc Recht and Matthias Drochner. - - -== [6.3alpha5] 2004-03-30 == - -* Fix & vs && typo in GC_generic_malloc and -GC_generic_malloc_ignore_off_page. (Propagated from the gcc tree.) -* Removed SA_NODEFER hack from NetBSD and Solaris write-protect handler. -(According to Christian Limpach, the NetBSD problem is fixed. -Presumably so is the Solaris 2.3 problem.) -* Removed placement delete from gc_cpp.h for the SGI compiler (thanks -to Simon Gornall for the patch). -* Changed semantics of the GC_IGNORE_FB environment variable, based -on experimentation by Nicolas Cannasse pointing out that the old -interpretation was useless. We still need help in identifying win32 -graphics memory mappings. The current "solution" is a hack. -* Removed "MAKEOVERRIDES =" from Makefile.am and thus Makefile.in. -It probably made more sense in the gcc context. -* Explicitly ensure that NEED_FIND_LIMIT is defined for {Open,Net}BSD/ELF. -* Replaced USE_HPUX_TLS macro by USE_COMPILER_TLS, since gcc often -supports the same extension on various platforms. -* Added some basic (completely untested) defines for win64, in support -of future work. -* Declared GC_jmp_buf in os_dep.s as JMP_BUF instead of jmp_buf, fixing -a memory overwrite bug on Solaris and perhaps other platforms. -* Added 0 != __libc_stack_end test to GC_linux_stack_base (thanks to -Jakub Jelinek for the patch and explaining the problem). -Otherwise pre-linking could cause the collector to fail. -* Changed default thread local storage implementation to USE_PTHREAD_SPECIFIC -for HP/UX with gcc. The compiler-based implementation appears to work -only with the vendor compiler. -* Export GC_debug_header_size and GC_USR_PTR_FROM_BASE from gc_mark.h, -making client mark code cleaner and less dependent on GC version. -* Export several new procedures and GC_generic_malloc from gc_mark.h -to support user-defined kinds. Use the new procedures to replace existing -code in gcj_mlc.c and typd_mlc.c. -* Added support for GC_BACKTRACES. -* Fixed a remaining problem in CORD_str with signed characters (thanks -to Alexandr Petrosian for the patch). -* Removed supposedly redundant, but very buggy, definitions of finalizer -macros from javaxfc.h. Fortunately this file probably has no users. -The correct declarations were already in gc.h. -* Also need to set GC_in_thread_creation while waiting for GC during -thread termination, since it is also possible to collect from an -unregistered thread in that case. -* Define NO_GETENV for Windows CE, since getenv doesn't appear to exist. -Plus some other minor WinCE fixes (thanks to Alain Novak). -* Added GC_register_describe_type_fn. -* Arrange for debugging finalizer registration to ignore non-heap -registrations, since the regular version of the routine also behaves -that way. -* GC_gcj_malloc and friends need to check for finalizers waiting to be run. -One of the more obscure allocation routines with missing a LOCK() call. -* Fixed cvtres invocations in NT_MAKEFILE and NT_STATIC_THREADS_MAKEFILE -to work with VS.NET. -* Cleaned up GC_INIT calls in test. Updated gc.man to encourage GC_INIT -use in portable code. -* Taught the GC to use libunwind if --enable-full-debug is specified on -IA64 and libunwind is present. -* The USE_MUNMAP code could get confused about the age of a block and -prematurely unmap it. GC_unmap_old had a bug related to wrapping of -GC_gc_no. GC_freehblk and GC_merge_unmapped didn't maintain -hb_last_reclaimed reasonably when blocks were merged. The code was -fixed to reflect original intent, but that may not always be an -improvement. - - -== [6.3alpha4] 2004-01-01 == - -* USE_MMAP was broken by confusion in the code dealing with USE_MMAP_ANON. -* Darwin support was broken in alpha3 as a result of my mis-integration of -Andrew Begel's patches. Fixed with another patch from Andrew Begel. -* A new sanity check in pthread_stop_world.c:GC_push_all_stacks() was -overly aggressive. We may collect from an unregistered thread during -thread creation. Fixed by explicitly checking for that case. (Added -GC_in_thread_creation.) - - -== [6.3alpha3] 2003-12-20 == - -* Removed -DSMALL_CONFIG from BCC_MAKEFILE. -* Changed macros to test for an ARM processor (Patch from Richard Earnshaw.) -* Mostly applied a DJGPP patch from Doug Kaufman. Especially Makefile.dj -had suffered from serious bit rot. -* Rewrote GC_apply_to_maps, eliminating an off-by-one subscript error, -and a call to alloca (for lcc compatibility). -* Changed USE_MUNMAP behavior on POSIX platforms to immediately remap -the memory with PROT_NONE instead of unmapping it. The latter risks -an intervening mmap grabbing the address space out from underneath us. -Updated this code to reflect a cleaner patch from Ulrich Drepper. -* Replaced _T with _Tp in new_gc_alloc.h to avoid a MACOS X conflict. -(Patch from Andrew Begel.) -* Dynamically choose whether or not lock should spin on win32 (thanks -to Maurizio Vairani for the patch). This may be a significant performance -improvement for win32. -* Fix Makefile.direct to actually include NT_STATIC_THREADS_MAKEFILE -in the distribution (thanks to Maurizio Vairani). -* Maybe_install_looping_handler() was accidentally exported, violating -our name space convention. -* Made os_dep.c use sigsetjmp and SA_NODEFER for NetBSD. (Thanks to -Christian Limpach. I generalized the patch to use sigsetjmp on all -UNIX_LIKE platforms, admittedly a slightly risky move. But it may avoid -similar problems on some other platforms. I also cleaned up the definition -of UNIX_LIKE a bit.) -* Integrated Andrew Begel's Darwin threads patch, adjusted according to -some of Fergus Hendersons's comments. (Patch didn't apply cleanly, -errors are possible.) -* Added another test or two for the Intel 8.0 compiler to avoid -confusing it with gcc. The single-threaded collector should now build -with icc, at least on ia64. - - -== [6.3alpha2] 2003-11-04 == - -* Re-enabled I_HOLD_LOCK assertion in aix_irix_threads.h. -* Put back the WINABI qualifier for GC_CreateThread. (Thanks to -Danny Smith for the patch. 6.3alpha1 had the qualifier in one place -but not elsewhere, which was clearly wrong.) -* Sometimes explicitly define __private_extern__ before DARWIN dyld.h -include. (Thanks to Andreas Tobler for posting the patch.) -* Included signal.h from pthread_support.c. Removed GC_looping_handler, -which was dead code. -* GC_find_start was misdeclared by gc_pmark.h if PRINT_BLACK_LIST was -defined (thanks to Glauco Masotti for testing and reporting this). -Changed GC_find_start to never just return 0. According to its -comment it doesn't, and it's unclear that's correct. -* GC_alloc_large had several largely compensating bugs in the -computation of GC_words_wasted. (It was confused about bytes vs. -words in two places.) -* Integrated Slava Sysoltsev's patch to support more recent versions of -the Intel compiler on IA64/Linux. -* Changed win32 spinlock initialization to conditionally set a spin count. -(Emmanual Stumpf pointed out that enabling this makes a large performance -difference on win32 multiprocessors.) Also cleaned up the win32 spinlock -initialization code a bit. -* Fixed thread support for HP/UX/IA64. The register backing store base for -the main thread was sometimes not set correctly. (Thanks to -Laurent Morichetti.) -* Added -DEMPTY_GETENV_RESULTS flag to work around Wine problem. -* Declare GC_stack_alloc and GC_stack_free in solaris_threads.h to -avoid 64-bit size mismatches (thanks to Bernie Solomon). -* Fixed GC_generic_push_regs to avoid a potential and very unfortunate -tail call optimization. This could lead to prematurely reclaimed -objects on configurations that used the generic routine and the new -build infrastructure (which potentially optimizes mach_dep.c). -This was a serious bug, but it's unclear whether it has resulted in -any real failures. -* Fixed CORD_str to deal with signed characters (thanks to Alexandr Petrosian -for noticing the problem and supplying the patch). -* Merged a couple of NOSYS/ECOS tests into os_dep.c from gcj (thanks -to Anthony Green). -* Partially merged a win32 patch from Ben Hutchings, and substantially -revised other parts of win32_threads.c. It had several problems. -Under MinGW with a statically linked library, the main thread was -not registered. Cygwin detached threads leaked thread descriptors. -There were several race conditions. For now, unfortunately the -static threads limit remains, though we increased it, and made table -traversal cost depend on the actual thread count. -There is also still some code duplication with pthread_support.c. -(Thread descriptors did become much smaller, since Ben Hutchings -removed the thread context from them.) -* Integrated a Solaris configure.in patch from Rainer Orth. -* Added GC_IGNORE_FB and associated warning to very partially address -the issue of the collector treating a mapped frame buffer as part -of the root set. (Thanks to David Peroutka for providing some -insight. More would be helpful. Is there anything that can be used -to at least partially identify such memory segments?) - - -== [6.3alpha1] 2003-07-26 == - -* Integrated some NetBSD patches by Marc Recht. These -were already in the NetBSD package. -* GC_pthread_create waited for the semaphore even if pthread_create failed. -(Thanks to Dick Porter for the pthread_support.c patch.) Applied the -analogous fix for aix_irix_threads.c. -* Added Rainer Orth's Tru64 fixes. -* The check for exceeding the thread table size in win32 threadDetach -was incorrect (thanks to Alexandr Petrosian for the patch). -* Applied Andrew Begel's patch to correct some reentrancy issues -with dynamic loading on Darwin. -* GC_CreateThread() was neglecting to duplicate the thread handle in -the table (thanks to Tum Nguyen for the patch). -* Pass +ESdbgasm only on PA-RISC machines with vendor compiler (thanks to -Roger Sayle for the patch). -* Applied more AIX threads patches from Scott Ananian. - - -== [6.2] 2003-06-21 == - -* Integrated a second round of Irix/AIX patches from Dan Bonachea. -Renamed mips_sgi_mach_dep.S back to mips_sgi_mach_dep.s, since it requires -the Irix assembler to do the C preprocessing; gcc -E doesn't work. -* Fixed Makefile.direct for DARWIN (thanks to Manuel Serrano). -* There was a race between GC_pthread_detach and thread exit that could -result in a thread structure being deallocated by GC_pthread_detach -even though it was still needed by the thread exit code (thanks to -Dick Porter for the small test case that allowed this to be debugged). -* Fixed version parsing for non-alpha versions in acinclude.m4 and -version checking in version.h. -* Issues identified (not yet fixed): -- A dynamic libgc.so references dlopen unconditionally, but doesn't link -against libdl. -- GC_proc_fd for Solaris is not correctly updated in response to a -fork() call. Thus incremental collection in the child won't work -correctly. (Thanks to Ben Cottrell for pointing this out.) -- --enable-redirect-malloc is mostly untested and known not to work -on some platforms. -- There seem to be outstanding issues on Solaris/X86, possibly with -finding the data segment starting address. -- Very large root set sizes (> 16 MB or so) could cause the collector -to abort with an unexpected mark stack overflow. (Thanks to -Peter Chubb.) NOT YET FIXED. Workaround is to increase the initial -size. -- The SGI version of the collector marks from mmapped pages, even -if they are not part of dynamic library static data areas. This -causes performance problems with some SGI libraries that use mmap -as a bitmap allocator. NOT YET FIXED. It may be possible to turn -off DYNAMIC_LOADING in the collector as a workaround. It may also -be possible to conditionally intercept mmap and use GC_exclude_static_roots. -The real fix is to walk rld data structures, which looks possible. -- Incremental collector should handle large objects better. Currently, -it looks like the whole object is treated as dirty if any part of it is. - - -== [6.2alpha6] 2003-06-05 == - -* There was an extra underscore in the name of GC_save_registers_in_stack -for NetBSD/SPARC (thanks to Jaap Boender for the patch). -* Integrated Brian Alliet's patch for Darwin. This restructured the -linuxthreads/pthreads support to separate generic pthreads support -from more the system-dependent thread-stopping code. I believe this -should make it easier to eliminate the code duplication between -pthreads platforms in the future. The patch included some other -code cleanups. -* Integrated Dan Bonachea's patch to support AIX threads. This required -substantial manual integration, mostly due to conflicts with other -recent threads changes. It may take another iteration to -get it to work. -* Removed HPUX/PA-RISC support from aix_irix_threads.c. It wasn't used -anyway and it cluttered up the code. And anything we can do to migrate -towards generic pthreads support is a good thing. -* Added a more explicit test for tracing of function arguments to test.c. -* Added Akira Tagoh's PowerPC64 patch. -* Fixed some bit rot in the Cygwin port (thanks to Dan Bonachea for -pointing it out). gc.h now includes just windows.h, not winbase.h. -* Declared GC_save_regs_in_stack() in gc_priv.h. Remove other declarations. -* Changed --enable-cplusplus to use automake consistently. The old way -confused libtool. "Make install" didn't work correctly for the old version. -Previously --enable-cplusplus was broken on cygwin. -* Changed the C version of GC_push_regs to fail at compile time if it is -generated with an empty body. This seems to have been the cause of one -or two subtle failures on unusual platforms. Those failures should -now occur at build time and be easily fixable. - - -== [6.2alpha5] 2003-05-14 == - -* GC_invoke_finalizers could, under rare conditions, set -GC_finalizer_mem_freed to an essentially random value. This could -possibly cause unbounded heap growth for long-running applications -under some conditions. (The bug was introduced in 6.1alpha5, and -is not in gcc3.3.) -* Attempted to sanitize the various DLL macros. GC_USE_DLL disappeared. -GC_DLL is used instead. All internal tests are now on GC_DLL. -README.macros is now more precise about the intended meaning. -* Include DllMain in the multi-threaded win32 version only if the -collector is actually built as a dll (thanks to Mohan Embar for -a version of the patch). -* Hide the cygwin threadAttach/Detach functions. They were violating our -namespace rules. -* Fixed an assertion in GC_check_heap_proc. Added GC_STATIC_ASSERT -(thanks again to Ben Hutchings). -* Removed some obsolete definitions for Linux/PowerPC in gcconfig.h. -* CORD_cat was not rebalancing unbalanced trees in some cases, violating -a CORD invariant. Also tweaked the re-balancing rule for -CORD_cat_char_star. (Thanks to Alexandr Petrosian for the bug report -and patch.) -* Added hand-coded structured exception handling support to mark.c. -This should enable support of dynamic libraries under win32 with -gcc-compiled code. (Thanks to Ranjit Mathew for the patch.) -Turned on dynamic library scanning for win32/gcc. -* Removed some remnants of read wrapping (thanks to Kenneth Schalk). -GC_USE_LD_WRAP ws probably broken in recent versions. -* The build could fail on some platforms since gcconfig.h could include -declarations mentioning ptr_t, which was not defined, e.g. when if_mach -was built (thanks to Yann Dirson for pointing this out). Also -cleaned up tests for GC_PRIVATE_H in gcconfig.h a bit. -* The GC_LOOP_ON_ABORT environment variable interfered with incremental -collection, since the write fault handler was erroneously overridden. -Handlers are now set up in the correct order. -* It used to be possible to call GC_mark_thread_local_free_lists() while -the world was not stopped during an incremental GC. This was not safe. -Fortunately, it was also unnecessary. Added GC_world_stopped flag -to avoid it. (This caused occasional crashes in GC_set_fl_marks -with thread local allocation and incremental GC. This probably happened -primarily on old, slow multiprocessors.) -* Allowed overriding of MAX_THREADS in win32_threads.c from the build -command line (thanks to Yannis Bres for the patch). -* Taught the IA64/linux code to determine the register backing store base from -/proc/self/maps after checking the __libc symbol, but before guessing. -(__libc symbols are on the endangered list, and the guess is likely to not -always be right for 2.6 kernels.) Restructured the code to read and parse -/proc/self/maps so it only exists in one place (all platforms). -* The -DUSE_PROC_FOR_LIBRARIES code was broken on Linux. It claimed that it -also registered the main data segment, but didn't actually do so. (I don't -think anyone actually uses this configuration, but ...) -* Made another attempt to get --enablecplusplus to do the right thing. -Since there are unavoidable problems with C programs linking against a -dynamic library that includes C++ code, I separated out the c++ code into -libgccpp. - - -== [6.2alpha4] 2003-03-10 == - -* Use LINUX_STACKBOTTOM for >= glibc2.2 on Linux/MIPS. (See Debian bug -# 177204) -* Integrated Jeff Sturm and Jesse Rosenstock's MACOSX threads patches. -* Integrated Grzegorz Jakacki's substantial GNU build patch. "Make dist" -should now work for the GNU build process. Documentation files -are installed under share/gc. -* Tweaked gc_cpp.h to again support the Borland compiler (thanks to -Rene Girard for pointing out the problems). -* Updated BCC_MAKEFILE (thanks to Rene Girard). -* Added GC_ASSERT check for minimum thread stack size. -* Added --enable-gc-assertions. -* Added some web documentation to the distribution. Updated it in the -process. -* Separate gc_conf_macros.h from gc.h. -* Added generic GC_THREADS client-defined macro to set the appropriate -GC_XXX_THREADS internal macro. (gc_config_macros.h.) -* Add debugging versions of _ignore_off_page allocation primitves. -* Moved declarations of GC_make_closure and GC_debug_invoke_finalizer -from gc.h to gc_priv.h. -* Reset GC_fail_count even if only a small allocation succeeds. -* Integrated Brian Alliet's patch for dynamic library support on Darwin. -* gc_cpp.h's gc_cleanup destructor called GC_REGISTER_FINALIZER_IGNORE_SELF -when it should have called the lower case version, since it was -explicitly computing a base pointer. - - -== [6.2alpha3] 2003-01-30 == - -* Don't include execinfo.h in os_dep.c when it's not needed, and may not -exist. - - -== [6.2alpha2] == - -* Fixed the completely broken FreeBSD code in 6.2alpha1 (thanks to -Hironori Sakamoto for the patch). -* Changed IRIX reference in dbg_mlc.c to IRIX5 (thanks to Marcus Herbert). -* Attempted to work around the problems with .S filenames and the SGI -compiler. (Untested.) -* Worked around an HP/UX make issue with the GNU-style build process. -* Fixed the --enable-cplusplus build machinery to allow builds without -a C++ compiler. (That was always the intent ...) -* Changed the debugging allocation macros to explicitly pass the return -address for Linux and XXXBSD on hardware for which we can't get stack -traces. Use __builtin_return_address(0) to generate it when possible. -Some of the configuration work was cleaned up (good) and moved to gc.h -(bad, but necessary). This should make leak detection more useful -on a number of platforms. (Thanks to Fabian Thylman for the suggestion.) -* Fixed compilation problems in dbg_mlc.c with GC_ADD_CALLER. -* Bumped revision number for dynamic library. - - -== [6.2alpha1] 2003-01-23 == - -* Guard the test for GC_DUMP_REGULARLY in misc.c with -"#ifndef NO_DEBUGGING". Otherwise it fails to build with NO_DEBUGGING -defined. (Thanks to Manuel Serrano.) -* Message about retrying suspend signals was incorrectly generated even when -flag was not set. -* Cleaned up MACOSX/NEXT root registration code. There was apparently a -separate ifdef case in GC_register_data_segments() for no reason. -* Removed MPROTECT_VDB for MACOSX port, based on one negative report. -* Arrange for gc.h and friends to be correctly installed with GNU-style -"make install". -* Enable the GNU-style build facility include C++ support in the library -with --enable-cplusplus (thanks to Thomas Maier for some of the patch). -* Mark from GC_thread_key in linux_threads.c, in case that's allocated -from the garbage collected heap, as it is with our own thread-specific -storage implementation (thanks to Jeff Sturm). -* Mark all free list header blocks if they are heap allocated. This avoids -some unnecessary tracing. And it remains correct if we clear the -root set. (Thanks to Jeff Sturm for identifying the bug.) -* Improved S390/Linux support. Add S390/Linux 64-bit support (thanks to -Ulrich Weigand). -* Corrected the spelling of GC_{M,C}ALLOC_EXPLICTLY_TYPED to -GC_{M,C}ALLOC_EXPLICITLY_TYPED in gc_typed.h. This is technically -an interface change. Based on the fact that nobody reported this, -I suspect/hope there were no clients. -* Cleaned up gc_typed.h so that (1) it adds an extern "C" declaration -when appropriate, (2) doesn't generate references to undefined internal -macros, and (3) allows easier manual construction of descriptors. -* Close the file descriptor used by GC_print_address_map(). -* Set the "close-on-exec" bit for various file descriptors maintained -for the collector's internal use. -* Added a hack to find memory segments owned by the system allocator -under win32. Based on my tests, this tends to eventually find all -segments, though it may take a while. There appear to be cleaner, -but slower solutions under NT/XP. But they rely on an API that's -unsupported under 9X. -* Changed Linux PowerPC stack finding to LINUX_STACKBOTTOM. (Thanks -to Akira Tagoh for pointing out that HEURISTIC1 does not work on -64-bit kernels.) -* Added GC_set_free_space_divisor to avoid some Windows dll issues. -* Added FIXUP_POINTER, POINTER_SHIFT, POINTER_MASK to allow preprocessing -of candidate pointers for tagging, etc. -* Always lock around GC_notify_full_gc(). Simplified code for -invoking GC_notify_full_gc(). -* Changed the way DATASTART is defined on FreeBSD to be robust against -an unmapped page after etext. (Thanks to Hironori Sakamoto for -tracking down the intermittent failure.) -* Made GC_enable() and GC_disable() official. Deprecated direct update -of GC_dont_gc. Changed GC_gcollect to be a noop when garbage collection -is disabled. -* Call GC_register_dynamic_libraries before stopping the world on Linux, -in order to avoid a potential deadlock due to the dl_iterate_phdr lock. -* Introduced a more general mechanism for platform-dependent code to -decide whether the main data segment should be handled separately -from dynamic libraries, or registered by GC_register_dynamic_libraries. -The latter is more reliable and easier on Linux with dl_iterate_phdr. - - -== [6.1] == - -* Added GC_MAXIMUM_HEAP_SIZE environment variable. -* Fix configure.in for MIPS/LINUX (thanks to H.J. Lu). -* Double page hash table size for -DLARGE_CONFIG. -* Integrated Bo Thorsen's X86-64 support. -* STACKBOTTOM definition for LINUX/MIPS was partially changed back -(thanks to H.J. Lu and Hiroshi Kawashima for resolving this). -* Replaced all occurrences of LINUX_DATA_START in gcconfig.h with -SEARCH_FOR_DATA_START. It doesn't hurt to fall back to a search. -And __data_start doesn't seem to get defined correctly of the GC -library is loaded with LD_PRELOAD, e.g. for leak detection. -* If the GC_find_leak environment variable is set, do a -atexit(GC_gcollect) to give us at least one chance to detect leaks. -This may report some very benign leaks, but ... -* Addeded REDIRECT_FREE. It's necessary if we want leak detection with -LD_PRELOAD. -* Defer printing of leaked objects, as for smashed objects. -* Fixed process and descriptor leak in GC_print_callers. Try for -line number even if we got function name.) -* Ported parallel GC support and thread local allocation to Alpha. -Not yet well-tested. -* Added GC_DUMP_REGULARLY and added finalization statistics to GC_dump(). -* Fixed Makefile.am to mention alpha_mach_dep.S instead of the defunct -alpha_mach_dep.s. -* Incorporated a change to new_gc_alloc.h, -which should make it work with gcc3.1. -* Use alpha_mach_dep.S only on Linux. (It's not clear that this is -optimal, but it otherwise didn't build on Tru64. Thanks to Fergus Henderson.) -* Added ifdef to guard free() in os_dep.c. Otherwise we get a -compilation error on Irix (thanks to Dai Sato). -* Added an experimental version of GC_memalign to mallocx.c. This can't -always work, since we don't handle alignment requests in the hblk-level -allocator, and we can't handle arbitrary pointer displacements unless -GC_all_interior_pointers is enabled. But it should work for alignment -requests up to HBLKSIZE. This is not yet documented in the standard -places. -* Finally debugged the OSF1/Tru64 thread support. This needs more testing, -since I needed to add a somewhat unconvincing workaround for signal -delivery issues that I don't yet completely understand. But it does -pass my tests, even in parallel GC mode. Incremental GC support is -disabled if thread support is enabled, due to the signal issues. -* Eliminated name-space-incorrect definition of _cdecl from gc_cpp.h. -* Added GC_debug_malloc_replacement and GC_debug_realloc_replacement -declarations to gc.h. On IA64, this is required for REDIRECT_MALLOC -to work correctly with these. -* Fixed Linux USE_PROC_FOR_LIBRARIES to work with a 64-bit /proc format. - - -== [6.1alpha5] 2002-06-19 == - -* Added GC_finalizer_mem_freed, and changed some of the code that -decided on heap expansion to look at it. Memory explicitly -deallocated by finalizers essentially needs to be counted as reclaimed -by the GC. Otherwise there are cases in which the heap can grow -infinitely. (Thanks to Mark Reichert for the test case.) -* Integrated Adam Megacz patches to not scan dynamic libraries if -we are compiling with gcc on win32. Otherwise we need structured -exception handling to deal with asynchronously unmapped root -segments, and gcc doesn't directly support that. -* Integrated Anthony Green's patch to support Wine. -* GC_OPERATOR_NEW_ARRAY was misspelled OPERATOR_NEW_ARRAY in several -places, including gc_cpp.cc (thanks to Wink Saville for pointing this out). -* Integrated Loren J. Rittle's Alpha FreeBSD patches. These also -changed the declarations of symbols like _end on many platforms to -that they wouldn't mistakenly be declared as short data symbols (suggested by -Richard Henderson). -* Integrated changes from the Debian distribution (thanks to Ryan Murray -for pointing these out). -Fix C++ comments in POWERPC port. Add ARM32 -incremental GC support. Get rid of USE_GENERIC_PUSH_REGS for alpha/Linux, -this time for real. Use va_copy to get rid of cord printf problems -(finally). -* Close file descriptor used to count CPUs (thanks to Jeff Sturm for -pointing out the omission). -* Don't just drop gcj free lists in GC_start_reclaim, since that can -eventually cause the marker to see a bogus mark descriptor in the -dropped objects. The usual symptom was a very intermittent segmentation -fault in the marker. This mattered only if one of the GC_gcj_malloc -variants was used (thanks to Michael Smith, Jeff Sturm, Bryce McKinlay and -Tom Tromey for helping to track this down). -* Fixed Linux and Solaris/64 SPARC configuration (thanks to David Miller, -Jeff Sturm, Tom Tromey, and Christian Joensson). -* Fixed a typo in strdup definition (thanks to Gerard A Allan). -* Changed Makefile.direct to invoke $(CC) to assemble alpha_mach_dep.S. -This is needed on Linux. I'm not sure whether it's better or worse -on Tru64. -* Changed gc_cpp.h once more to declare operator new and friends only in -a Microsoft environment. This may need further fine tuning (thanks to -Johannes Schmidt for pointing out that the older code breaks on gcc3.0.4). -* Don't ever override strdup if it's already macro defined (thanks to -Adnan Ali for pointing out the problem). -* Changed gc_cpp.h yet again to also overload placement new. Due to the -C++ overloading rules, the other overloaded new operations otherwise hide -placement new, which causes many STL uses to break (thanks to Reza Shahidi -for reporting this, and to Matt Austern for proposing a fix). -* Integrated cygwin pthreads support from Dan Bonachea. -* Turn on DYNAMIC_LOADING for NetBSD (thanks to Krister Walfridsson). -* Changed printing code to print more complete GC times. -* Applied Mark Mitchell's Irix patch to correct some bit rot. -* Clarified which object-printing routines in dbg_mlc.c should hold -the allocation lock. Restructured the code to allow reasonable object -printing with -DREDIRECT_MALLOC. -* Fix the Linux mmap code to always start with 0x1000 as the initial hint. -Minor patches for 64-bit AIX, particularly to STACKBOTTOM (thanks to -Jeffrey Mark Siskind). -* Renamed "SUSPENDED" flag for Solaris threads support to avoid a conflict -with a system header (thanks to Philip Brown). -* Cause win32_threads.c to handle an out of range stack pointer correctly, -though currently with a warning. (Thanks to Jonathan Clark for -observing that win32 applications may temporarily use the stack -pointer for other purposes, and suggesting a fix. Unfortunately, it's -not clear that there is a complete solution to this problem.) - - -== [6.1alpha4] 2002-06-16 == - -* Fixed typo in sparc_mach_dep.S, preventing the 64-bit version from -building. Increased 64-bit heap size limit in test.c slightly, since -a functional SPARC collector seems to slightly exceed the old limits. -* Use NPRGREG in solaris_threads.c, thus printing all registers if things -go wrong. -* Added GC_MARKERS environment variable to allow use of a single marker -thread on an MP without confusing the lock implementation. -* Collect much less aggressively in incremental mode with GC_TIME_UNLIMITED. -This is really a purely generational mode, and we can afford to -postpone the collection until the heap is (nearly) full. -* Remove read() wrapper for MPROTECT_VDB. It was causing more harm than -good. It is often no longer needed if system calls avoid writing to -pointerfull heap objects. -* Fix MACOSX test in gcconfig.h (thanks to John Clements). -* Change GC_test_and_set so that it consistently has one argument. -Add spaces to ::: in powerpc assembly code in gc_locks.h (thanks to -Ryan Murray). -* Fixed a formatting error in dbg_mlc.c. Added prototype to GC_abort() -declaration (thanks to Michael Smith). -* Removed "source" argument to GC_find_start(). Eliminate GC_FIND_START(). -* Added win32 recognition code in configure.in. Changed some of the -dllimport/export defines in gc.h (thanks to Adam Megacz). -* GC_malloc_many didn't set hb_last_reclaimed when it called -GC_reclaim_generic. (I'm not sure this matters much, but ...) -* Allocating uncollectible objects with debug information sometimes -allocated objects that were one byte too small, since uncollectible -objects don't have the extra byte added at the end (thanks to -Wink Saville for pointing this out). -* Added a bit more assertion checking to make sure that gcj objects -on free lists never have a nonzero second word. -* Replaced BCC_MAKEFILE with an up-to-date one (thanks to Andre Leiradella). -* Upgraded libtool, cinfigure.in and some related files to hopefully -support NetBSD/SPARC (thanks to Adrian Bunk). Unfortunately, -libtool 1.4.2 seemed to be buggy due to missing quotes in several -"test" invocations. Fixed those in the ltmain.sh script. -* Some win32-specific patches, including the introduction of -GC_CreateThread (thanks to Adam Megacz). -* Merged in gcj changes from Anthony Green to support embedded systems. -* Tried to consistently rename preprocessed assembly files with a capital -.S extension. -* Use alpha_mach_dep.S on ALPHA again. It doesn't really matter, but this -makes our distribution consistent with the gcc one, avoiding future merge -problems. -* Move GET_MEM definition into gcconfig.h. Include gcconfig.h slightly -later in gc_priv.h to avoid forward references to ptr_t. -* Add some testing of local allocation to test.c. -* Change definition of INVALID_QTID in specific.h. The -1 value was used -inconsistently, and too likely to collide with a valid stack address. -Some general clean-up of specific.[ch]. Added assertions. (Thanks -to Michael Smith for tracking down an intermittent bug to this -general area. I'm not sure it has been squashed yet, however.) -* On Pthread systems it was not safe to call GC_malloc() between fork() -and exec(). According to the applicable standards, it doesn't appear -to be safe to call malloc() or many other libc functions either, thus -it's not clear this is fixable. Added experimental support for --DHANDLE_FORK in linux_threads.c which tries to support it. It may -succeed if libc does the right thing. I'm not sure whether it does. -(Thanks to Kenneth Schalk for pointing out this issue.) -* Documented thread local allocation primitives to require an -explicit GC_init call. GC_init_parallel is no longer declared to -be a constructor function, since that isn't portable and often -seems to lead to initialization order problems. -* Changed gc_cpp.cc and gc_cpp.h in one more attempt to make them -compatible with Visual C++ 6 (thanks to Wink Saville for the patch). -* Some more patches for Linux on HP PA-RISC. -* Added include/gc_allocator.h. It implements (hopefully) standard -conforming (as opposed to SGI-style) allocators that allocate -collectible (gc_allocator) or GC-traceable, but not collectible -(traceable_allocator) objects. This borrows heavily from libstc++, -which borrows heavily from the SGI implementation, this part of -which was written by Matt Austern. Changed test_cpp.cc to very -minimally test this. -* On Linux/X86, retry mmap with a different start argument. That should -allow the collector to use more (closer to 3GB) of the address space. -* Force 64 bit alignment with GCJ support (reflects Bryce McKinlay's -patch to the gcc tree). -* Refined the choice of sa_handler vs. sa_sigaction in GC_dirty_init -to accommodate some glibc5 systems (thanks to Dan Fandrich for the patch). -* Compensated for the fact that current versions of glibc set -__libc_stack_end incorrectly on Linux/IA64 while initialization code -is running. This could cause the collector to miss 16 bytes of -the memory stack if GC_malloc or friends where called before main(). -* Mostly integrated Takis Psarogiannakopoulos' port to DG/UX Inix 86. -This will probably take another iteration to work, since his -patch conflicted with the libtool upgrade. -* Added README.arm.cross containing some information about cross- -compiling to an ARM processor from Margaret Fleck (original code provided by -Bradley D. LaRonde; edited by Andrej Cedilnik using some of solutions by -Tilman Vogel; also ported for iPAQ by Oliver Kurth). - - -== [6.1alpha3] 2002-02-07 == - -* Minor cleanup on the gcconfig.h section for SPARC. -* Minor fix to support Intel compiler for I386/Linux (thanks to -Sven Hartrumpf). -* Added SPARC V9 (64-bit) support (thanks to Jeff Sturm). -* Restructured the way in which we determine whether or not to keep -call stacks for debug allocation. By default SAVE_CALL_COUNT is -now zero on all platforms. Added SAVE_CALL_NARGS parameters. -If possible, use execinfo.h to capture call stack. (This should -add support for a number of new platforms, though often at -considerable runtime expense.) -* Try to print symbolic information for call stacks. On Linux, we -do this with a combination of execinfo.h and running addr2line in -a separate process. This is both much more expensive and much more -useful. Amazingly, it seems to be fast enough for most purposes. -* Redefined strdup if -DREDIRECT_MALLOC is given. -* Changed incremental collector and MPROTECT_VDB implementation so that, -under favorable conditions, pointer-free objects are not protected. -Added GC_incremental_protection_needs() to determine ahead of time whether -pointer-free objects may be protected. Replaced GC_write_hint() with -GC_remove_protection(). -* Added test for GC_ENABLE_INCREMENTAL environment variable. -* Made GC_time_limit runtime configurable. Added GC_PAUSE_TIME_TARGET -environment variable. -* Eliminated GC_page_sz, a duplicate of GC_page_size. -* Caused the Solaris and Irix thread creation primitives to call -GC_init_inner(). - - -== [6.1alpha2] 2001-12-20 == - -* No longer wrap read by default in multi-threaded applications. It was -pointed out on the libgcj list that this holds the allocation lock for -way too long if the read blocks. For now, reads into the heap are -broken with incremental collection. It's possible to turn this back on -if you make sure that read calls don't block (e.g. by calling select -first). -* Fix ifdef in Solaris_threads.h to refer to GC_SOLARIS_THREADS. -* Added check for environment variable GC_IGNORE_GCJ_INFO. -* Added printing of stop-the-world GC times if GC_PRINT_STATS environment -variable is set. -* The calloc definition in leak_detector.h was missing parentheses, and -realloc was missing a second argument to GC_REALLOC (thanks to -Elvenlord Elrond). -* Added GC_PRINT_BACK_HEIGHT environment variable and associated -code, mostly in the new file backgraph.c. See doc/README.environment. -* Added -DUSE_GLOBAL_ALLOC to work around a Windows NT issue (thanks to -Jonathan Clark). -* Integrated port to NEC EWS4800 (MIPS-based workstation, with somewhat -different address-space layout). This may help for other machines with -holes in the data segment. (Thanks to Hironori Sakamoto.) -* Changed the order in which GC_push_roots and friends push things onto -the mark stack. GC_push_all calls need to come first, since we can't -necessarily recover if those overflow the mark stack. (Thanks to -Matthew Flatt for tracking down the problem.) -* Some minor cleanups to mostly support the Intel compiler on Linux/IA64. - - -== [6.1alpha1] 2001-09-22 == - -* Non-debug, atomic allocations could result in bogus smashed object -reports with debugging on (thanks to Patrick Doyle for the small test case). -* Fixed GC_get_register_stack_base (Itanium only) to work around a glibc -2.2.4 bug. -* Initial port to HP/UX on Itanium. Thread support and both 32 and 64 -bit ABIs appear to work. Parallel mark support doesn't yet, due to -some inline assembly code issues. Thread local allocation does appear -to work. -* ifdef'ed out glibc2.1/Itanium workaround. I suspect nobody is using -that combination anymore. -* Added a patch to make new_gc_alloc.h usable with gcc3.0 (thanks to -Dimitris Vyzovitis for the patch). -* Debugged 64-bit support on HP/UX PA-RISC. -* Turned on dynamic loading support for FreeBSD/ELF (thanks to Peter Housel). -* Unregistering of finalizers with debugging allocation was broken (thanks -to Jani Kajala for the test case). -* Old finalizers were not returned correctly from GC_debug_register_finalizer. -* Disabled MPROTECT_VDB for Linux/M68K based on a report that it doesn't work. -* Cleaned up some statistics gathering code in reclaim.c (thanks to -Walter Bright). -* Added some support for OpenBSD/ELF/Linux (thanks to Suzuki Toshiya). -* Added Jakub Jelinek's patch to use dl_iterate_phdr for dynamic library -traversal to dyn_load.c. Changed it to weakly reference dl_iterate_phdr, -so that the old code is still used with old versions of glibc. -* Cleaned up feature test macros for various threads packages and -integrated (partially functional) FreeBSD threads code from Loren J. Rittle. -It's likely that the cleanup broke something, since it touched lots of -code. It's also likely that it fixed some unreported bugs in the -less common thread implementations, since some of the original code -didn't stand up to close scrutiny. Support for the next pthreads -implementation should be easier to add. - - -== [6.0] 2001-07-26 == - -* Two more bug fixes for KEEP_BACK_PTRS and DBG_HDRS_ALL. -* Fixed a stack clearing problem that resulted in SIGILL with a -misaligned stack pointer for multi-threaded SPARC builds. -* Integrated another HURD patch (thanks to Igor Khavkine). - - -== [6.0alpha9] == - -* added README.macros. -* Made gc.mak a symbolic link to work around winzip's tendency to ignore -hard links. -* Simplified the setting of NEED_FIND_LIMIT in os_dep.c, possibly breaking -it on untested platforms. -* Integrated initial GNU HURD port (thanks to Chris Lingard and -Igor Khavkine). -* A few more fixes for Digital Mars compiler (by Walter Bright). -* Fixed gcc version recognition. Renamed OPERATOR_NEW_ARRAY to -GC_OPERATOR_NEW_ARRAY. Changed GC_OPERATOR_NEW_ARRAY to be the default. -It can be overridden with -DGC_NO_OPERATOR_NEW_ARRAY (thanks to -Cesar Eduardo Barros). -* Changed the byte size to free-list mapping in thread local allocation -so that size 0 allocations are handled correctly. -* Fixed Linux/MIPS stackbottom for new toolchain (thanks to Ryan Murray). -* Changed finalization registration to invoke GC_oom_fn when it runs out -of memory. -* Removed lvalue cast in finalize.c. This caused some debug configurations -not to build with some non-gcc compilers. - - -== [6.0alpha8] 2001-06-15 == - -* Changed GC_debug_malloc_replacement and GC_debug_realloc_replacement -so that they compile under Irix (thanks to Dave Love). -* Updated powerpc_macosx_mach_dep.s so that it works if the collector -is in a dynamic library (thanks to Andrew Begel). -* Transformed README.debugging into debugging.html, updating and -expanding it in the process. Added gcdescr.html and tree.html -from the web site to the GC distribution. -* Fixed several problems related to PRINT_BLACK_LIST. This involved -restructuring some of the marker macros. -* Fixed some problems with the sizing of objects with debug information. -Finalization was broken KEEP_BACK_PTRS or PRINT_BLACK_LIST. Reduced the -object size with SHORT_DEBUG_HDRS by another word. -* The "Needed to allocate blacklisted ..." warning had inadvertently -been turned off by default, due to a buggy test in allchblk.c. Turned -it back on. -* Removed the marker macros to deal with 2 pointers in interleaved fashion. -They were messy and the performance improvement seemed minimal. We'll -leave such scheduling issues to the compiler. -* Changed Linux/PowerPC test to also check for __powerpc__ in response -to a discussion on the gcc mailing list. -* Removed the "static" from the jmp_buf declaration in GC_generic_push_regs -(suggested by Matthew Flatt). This was causing problems in -systems that register all of their own roots. It looks far more correct -to me without the "static" anyway. -* Fixed several problems with thread local allocation of pointer-free or -typed objects. The collector was reclaiming thread-local free lists, since -it wasn't following the link fields. -* There was apparently a long-standing race condition related to -multi-threaded incremental collection. A collection could be started and -a thread stopped between the memory unprotect system call and the setting of -the corresponding dirt bit. I believe this did not affect Solaris or PCR, -which use a different dirty-bit implementation. Fixed this by installing -signal handlers with sigaction instead of signal, and disabling the thread -suspend signal while in the write-protect handler. (It is unclear -whether this scenario ever actually occurred.) -* Incremental collection did not cooperate correctly with the PARALLEL_MARK -implementation of GC_malloc_many or the local_malloc primitives. It still -doesn't work well, but it shouldn't lose memory anymore. -* Integrated some changes from the gcc source tree that I had previously -missed (thanks to Bryce McKinlay for the reminder and patch). -* Added Makefile.direct as a copy of the default Makefile, which would -normally be overwritten if configure is run. -* Changed the gc.tar target in Makefile.direct to embed the version number -in the gc directory name. This will affect future tar file distributions. -* Changed the Irix dynamic library finding code to no longer try to -eliminate writable text segments under Irix6.x, since that is probably no -longer necessary, and can apparently be unsafe on occasion (thanks to -Shiro Kawai for pointing this out). -* GC_cleanup with GC_DEBUG enabled passed a real object base address to -GC_debug_register_finalizer_ignore_self, which expected a pointer past the -debug header. Call GC_register_finalizer_ignore_self instead, even with -debugging enabled (thanks to Jean-Daniel Fekete for catching this). -* The collector didn't build with call chain saving enabled but NARGS=0. -* Fixed up the GNU-style build files enough so that they work in some -obvious cases (thanks to Maarten Thibaut). -* Added initial port to Digital Mars compiler for win32 (thanks to Walter -Bright). - - -== [6.0alpha7] 2001-04-19 == - -* Added GC_finalizer_notifier. Fixed GC_finalize_on_demand. (The variable -actually wasn't being tested at the right points. The build-time flag -was.) -* Added Tom Tromey's S390 Linux patch. -* Added code to push GC_finalize_now in GC_push_finalizer_structures -(thanks to Matthew Flatt). -* Added GC_push_gc_structures() to push all GC internal roots. -* Integrated some FreeBSD changes from Matthew Flatt. -* It looks like USRSTACK is not always correctly defined under Solaris. -Hacked gcconfig.h to attempt to work around the problem. The result -is not well tested. (Thanks again to Matthew Flatt for pointing this out.) -* Added Ji-Yong Chung's win32 threads and C++ fixes. -* Arranged for hpux_test_and_clear.s to no longer be needed or built. -It was causing build problems with gas, and it's not clear this is -better than the pthreads alternative on this platform. -* Some MINGW32 fixes from Hubert Garavel. -* Added initial Hitachi SH4 port from Kaz Kojima. -* Ported thread-local allocation and parallel mark code to HP/UX on PA_RISC. -* Made include/gc_mark.h more public and separated out the really private -pieces. This is probably still not quite sufficient for clients that -want to supply their own kind of type information. But it's a start. -This involved lots of identifier renaming to make it namespace clean. -* Added GC_dont_precollect for clients that need complete control over -the root set. -* GC_is_visible didn't do the right thing with gcj objects. (Not that -many people are likely to care, but ...) -* Don't redefine read with GC_USE_LD_WRAP. -* Initial port to LINUX/HP_PA. Incremental collection and threads are not -yet supported. (Incremental collection should work if you have the -right kernel. Threads may work with a sufficiently patched pthread -library.) -* Changed gcconfig.h to recognize __i386__ as an alternative to i386 in -many places (thanks to Benjamin Lerman). -* Made win32_threads.c more tolerant of detaching a thread that it didn't -know about (thanks to Paul Nash). -* Added Makefile.am and configure.in from gcc to the distribution, with -minimal changes. For the moment, those are just placeholders. In the -future, we're planning to switch to a GNU-style build environment for -Un*x-like systems, though the old Makefile will remain as a backup. -* Turned off STUBBORN_ALLOC by default, and added it back as a Makefile -option. -* Redistributed some functions between malloc.c and mallocx.c, so that -simple statically linked apps no longer pull in mallocx.o. -* Changed large object allocation to clear the first and last few words -of each block before releasing the lock. Otherwise the marker could see -objects with nonsensical type descriptors. -* Fixed a couple of subtle problems that could result in not recognizing -interior pointers from the stack. (I believe these were introduced -in 6.0alpha6.) -* GC_debug_free_inner called GC_free, which tried to reacquire the -allocator lock, and hence deadlocked. (DBG_HDRS_ALL probably never worked -with threads.) -* Fixed several problems with back traces. Accidental references to a free -list could cause the free list pointer to be overwritten by a back pointer. -There seemed to be some problems with the encoding of root and finalizer -references. - - -== [6.0alpha6] == - -* Changed the definition of DATASTART on ALPHA and IA64, where data_start -and __data_start are not defined by earlier versions of glibc. This might -need to be fixed on other platforms as well. -* Changed the way the stack base and backing store base are found on IA64. -This should now remain reliable on future kernels. But since it relies -on /proc, it will no longer work in the simulated NUE environment. -* Made the call to random() in dbg_mlc.c with -DKEEP_BACK_PTRS dependent -on the OS. On non-Unix systems, rand() should be used instead. Handled -small RAND_MAX (thanks to Peter Ross for pointing this out). -* Fixed the cord make rules to create the cord subdirectory, if necessary -(thanks to Doug Moen). -* Changed fo_object_size calculation in finalize.c. Turned finalization -of non-heap object into a no-op. Removed anachronism from GC_size() -implementation. -* Changed GC_push_dirty call in solaris_threads.c to GC_push_selected. -It was missed in a previous renaming (thanks to Vladimir Tsichevski -for pointing this out). -* Arranged to not mask SIGABRT in linux_threads.c (thanks to Bryce McKinlay). -* Added GC_no_dls hook for applications that want to register their own -roots. -* Integrated Kjetil Matheussen's Amiga changes. -* Added FREEBSD_STACKBOTTOM. Changed the X86/FreeBSD port to use it -(thanks to Matthew Flatt). -* Added pthread_detach interception for platforms supported by linux_threads.c -and irix_threads.c. -* Changed the USE_MMAP code to check for the case in which we got the -high end of the address space, i.e. mem_ptr + mem_sz == 0. It appears -that this can happen under Solaris 7. It seems to be allowed by what -I would claim is an oversight in the mmap specification. (Thanks to -Toshio Endo for pointing out the problem.) -* Cleanup of linux_threads.c. Some code was originally cloned from -irix_threads.c and now unnecessary. Some comments were obviously wrong. -* (Mostly) fixed a longstanding problem with setting of dirty bits from -a signal handler. In the presence of threads, dirty bits could get lost, -since the etting of a bit in the bit vector was not atomic with respect -to other updates. The fix is 100% correct only for platforms for which -GC_test_and_set is defined. The goal is to make that all platforms with -thread support. Matters only if incremental GC and threads are both -enabled. -* made GC_all_interior_pointers (a.k.a. ALL_INTERIOR_POINTERS) an -initialization time, instead of build-time option. This is a -nontrivial, high risk change. It should slow down the code measurably -only if MERGE_SIZES is not defined, which is a very nonstandard -configuration. -* Added doc/README.environment, and implemented what it describes. This -allows a number of additional configuration options to be set through -the environment. It documents a few previously undocumented options. -* Integrated Eric Benson's leak testing improvements. -* Removed the option to throw away the beginning of each page (DISCARD_WORDS). -This became less and less useful as processors enforce stricter alignment. -And it hadn't been tested in ages, and was thus probably broken anyway. - - -== [6.0alpha5] == - -* Changed the definition of GC_pause in linux_threads.c to use a volatile -asm. Some versions of gcc apparently optimize away writes to local volatile -variables. This caused poor locking behavior starting at about -4 processors. -* Added GC_start_blocking(), GC_end_blocking() calls and wrapper for sleep -to linux_threads.c. -The first two calls could be used to generally avoid sending GC signals to -blocked threads, avoiding both premature wakeups and unnecessary overhead. -* Fixed a serious bug in thread-local allocation. At thread termination, -GC_free could get called on small integers. Changed the code for thread -termination to more efficiently return left-over free-lists. -* Integrated Kjetil Matheussen's BeOS support. -* Rearranged the directory structure to create the doc and tests -subdirectories. -* Sort of integrated Eric Benson's patch for OSF1. This provided basic -OSF1 thread support by suitably extending hpux_irix_threads.c. Based -on earlier email conversations with David Butenhof, I suspect that it -will be more reliable in the long run to base this on linux_threads.c -instead. Thus I attempted to patch up linux_threads.c based on Eric's code. -The result is almost certainly broken, but hopefully close enough that -someone with access to a machine can pick it up. -* Integrated lots of minor changes from the NetBSD distribution. (These -were supplied by David Brownlee. I'm not sure about the original -authors.) -* Hacked a bit more on the HP/UX thread-support in linux_threads.c. It -now appears to work in the absence of incremental collection. Renamed -hpux_irix_threads.c back to irix_threads.c, and removed the attempt to -support HPUX there. -* Changed gc.h to define _REENTRANT in cases in which it should already -have been defined. It is still safer to also define it on the command -line. - - -== [6.0alpha4] == - -* Moved up the detection of mostly full blocks to the initiation of the -sweep phase. This eliminates some lock contention in the PARALLEL_MARK case, -as multiple threads try to look at mostly full blocks concurrently. -* Restored the code in GC_malloc_many that grabs a prefix of the global -free list. This avoids the case in which every GC_malloc_many call -tries and fails to allocate a new heap block, and the returns a single -object from the global free list. -* Some minor fixes in new_hblk.c. (Attempted to build free lists in order -of increasing addresses instead of decreasing addresses for cache performance -reasons. But this seems to be only a very minor gain with -DEAGER_SWEEP, -and a loss in other cases. So the change was backed out.) -* Fixed some of the documentation (thanks in large part to Fergus Henderson). -* Fixed the Linux USE_PROC_FOR_LIBRARIES code to deal with apps that perform -large numbers of mmaps (thanks to Eric Benson). Also fixed that code to -deal with short reads. -* Added GC_get_total_bytes(). -* Fixed leak detection mode to avoid spurious messages under linuxthreads. -(This should also now be easy for the other supported threads packages. -But the code is tricky enough that I'm hesitant to do it without being able -to test. Everything allocated in the GC thread support itself should be -explicitly deallocated.) -* Made it possible (with luck) to redirect malloc to GC_local_malloc. - - -== [6.0alpha3] 2000-09-26 == - -* Fixed the /proc/self/maps code to not seek, since that apparently is not -reliable across all interesting kernels. -* Fixed some compilation problems in the absence of PARALLEL_MARK -(introduced in alpha2). -* Fixed an algorithmic problem with PARALLEL_MARK. If work needs to -be given back to the main mark "stack", the BOTTOM entries of the local -stack should be given away, not the top ones. This has substantial -performance impact, especially for > 2 processors, from what I can tell. -* Extracted gc_lock.h from gc_priv.h. This should eventually make it a -bit easier to avoid including gc_priv.h in clients. -* Moved all include files to include/ and removed duplicate links to the -same file. The old scheme was a bad idea because it was too easy to get the -copies out of sync, and many systems don't support hard links. -Unfortunately, it's likely that I broke some of the non-Unix Makefiles in -the process, although I tried to update them appropriately. -* Removed the partial support for a copied nursery. It's not clear that -this would be a tremendous win, since we don't consistently lose to -generational copying collectors. And it would significantly complicate -many things. May be reintroduced if/when it really turns out to win. -* Removed references to IRIX_JDK_THREADS, since I believe there never -were and never will be any clients. -* Added some code to linux_threads.c to possibly support HPUX threads -using the Linux code. Unfortunately, it doesn't work yet, and is -currently disabled. -* Added support under Linux/X86 for saving the call chain, both in (debug) -objects for client debugging, and in GC_arrays._last_stack for GC -debugging. This was previously supported only under Solaris. It is -not enabled by default under X86, since it requires that code be compiled -to explicitly gave frame pointers on the call stack. (With gcc this -currently happens by default, but is often turned off explicitly.) -To turn it on, define SAVE_CALL_CHAIN. - - -== [6.0alpha2] == - -* Added USE_MARK_BYTES to reduce the need for compare-and-swap on platforms -for which that's expensive. -* Fixed a locking bug ib GC_gcj_malloc and some locking assertion problems. -* Added a missing volatile to OR_WORD and renamed the parameter to -GC_compare_and_swap so it's not a C++ reserved word (thanks to -Toshio Endo for pointing out both of those). -* Changed Linux dynamic library registration code to look at /proc/self/maps -instead of the rld data structures when REDIRECT_MALLOC is defined. -Otherwise some of the rld data data structures may be prematurely garbage -collected. -* Fixed USE_LD_WRAP a bit more, so it should now work without threads. -* Renamed XXX_THREADS macros to GC_XXX_THREADS for namespace correctness. -Temporarily added some backward compatibility definitions. Renamed -USE_LD_WRAP to GC_USE_LD_WRAP. -* Many MACOSX POWERPC changes, some additions to the gctest output, and -a few minor generic bug fixes (thanks to Dietmar Planitzer). - - -== [6.0alpha1] == - -* Added HP/PA prefetch support. -* Added -DDBG_HDRS_ALL and -DSHORT_DBG_HDRS to reduce the cost and improve -the reliability of generating pointer backtrace information, e.g. in -the Bigloo environment. -* Added parallel marking support (-DPARALLEL_MARK). This currently -works only under IA32 and IA64 Linux, but it shouldn't be hard to adapt -to other platforms. This is intended to be a lighter-weight (less -new code, probably not as scalable) solution than the work by Toshio Endo -et al, at the University of Tokyo. A number of their ideas were -reused, though the code wasn't, and the underlying data structure -is significantly different. In particular, we keep the global mark -stack as a single shared data structure, but most of the work is done -on smaller thread-local mark stacks. -* Changed GC_malloc_many to be cheaper, and to require less mutual exclusion -with -DPARALLEL_MARK. -* Added full support for thread local allocation under Linux -(-DTHREAD_LOCAL_ALLOC). This is a thin veneer on GC_malloc_many, and -should be easily portable to other platforms, especially those that -support pthreads. -* CLEAR_DOUBLE was not always getting invoked when it should have been. -* GC_gcj_malloc and friends used different out of memory handling than -everything else, probably because I forgot about one when I implemented -the other. They now both call GC_oom_fn(), not GC_oom_action(). -* Integrated Jakub Jelinek's fixes for Linux/SPARC. -* Moved GC_objfreelist, GC_aobjfreelist, and GC_words_allocd out of -GC_arrays, and separately registered the first two as excluded roots. -This makes code compiled with gc_inl.h less dependent on the -collector version. (It would be nice to remove the inclusion of -gc_priv.h by gc_inl.h completely, but we're not there yet. The -locking definitions in gc_priv.h are still referenced.) -This change was later conditioned on SEPARATE_GLOBALS, which -is not defined by default, since it involves a performance hit. -* Register GC_obj_kinds separately as an excluded root region. The -attempt to register it with GC_arrays was usually failing. (This wasn't -serious, but seemed to generate some confusion.) -* Moved backptr.h to gc_backptr.h. - - -== [5.4] == - -* Fixed a typo that prevented compilation with -DUSE_3DNOW_PREFETCH (thanks to -Shawn Wagner for actually testing this). -* Fixed GC_is_thread_stack in solaris_threads.c. It forgot to return a value -in the common case. -* Fixed another silly syntax problem in GC_double_descr (thanks to -Fergus Henderson for finding it). -* Fixed a GC_gcj_malloc bug: It tended to release the allocator lock twice. - - -== [5.3] 2000-09-24 == - -* Fixed _end declaration for OSF1. -* There were lots of spurious leak reports in leak detection mode, caused -by the fact that some pages were not being swept, and hence unmarked -objects weren't making it onto free lists. (This bug dated back to 5.0.) -* Fixed a typo in the liblinuxgc.so Makefile rule. -* Added the GetExitCodeThread to Win32 GC_stop_world to (mostly) work -around a Windows 95 GetOpenFileName problem (thanks to Jacob Navia). - - -== [5.2] == - -* dyn_load.c declared GC_scratch_last_end_ptr as an extern even if it -was defined as a macro. This prevented the collector from building on -Irix. -* We quietly assumed that indirect mark descriptors were never 0. -Our own typed allocation interface violated that. This could result -in segmentation faults in the marker with typed allocation. -* Fixed a _DUSE_MUNMAP bug in the heap block allocation code (thanks to -Ben Hutchings for the patch). -* Taught the collector about VC++ handling array operator new (thanks to -Ben Hutchings for the patch). -* The two copies of gc_hdrs.h had diverged. Made one a link to the other -again. - - -== [5.1] == - -* Fixed a gc.h header bug which showed up under Irix (thanks to Dan Sullivan). -* Fixed a typo in GC_double_descr in typd_mlc.c. -This probably could result in objects described by array descriptors not -getting traced correctly (thanks to Ben Hutchings for pointing this out). -* The block nearly full tests in reclaim.c were not correct for 64 bit -environments. This could result in unnecessary heap growth under unlikely -conditions. - - -== [5.0] == - -* Fixed threadlibs.c for linux threads. -DUSE_LD_WRAP was broken and --ldl was omitted. Fixed Linux stack finding code to handle --DUSE_LD_WRAP correctly. -* Added MSWIN32 exception handler around marker, so that the collector -can recover from root segments that are unmapped during the collection. -This caused occasional failures under Windows 98, and may also be -an issue under Windows NT/2000. - - -== [5.0alpha7] == - -* -DREDIRECT_MALLOC was broken in alpha6. Fixed. -* Cleaned up gc_ccp.h slightly, thus also causing the HP C++ compiler to -accept it. -* Removed accidental reference to dbg_mlc.c, which caused dbg_mlc.o to be -linked into every executable. -* Added PREFETCH to bitmap marker. Changed it to use the header cache. -* GC_push_marked sometimes pushed one object too many, resulting in a -segmentation fault in GC_mark_from_mark_stack. This was probably an old -bug. It finally showed up in gctest on win32. -* Gc_priv.h erroneously #defined GC_incremental to be TRUE instead of FALSE -when SMALL_CONFIG was defined. This was no doubt a major performance bug for -the default win32 configuration. -* Removed -DSMALL_CONFIG from NT_MAKEFILE. It seemed like an anachronism now -that the average PC has 64MB or so. -* Integrated Bryce McKinlay's patches for linux threads and dynamic loading -from the libgcj tree. Turned on dynamic loading support for Linux/PPC. -* Changed the stack finding code to use environ on HP/UX (thanks -to Gustavo Rodriguez-Rivera for the suggestion). This should -probably be done on other platforms, too. Since I can't test those, that'll -wait until after 5.0. - - -== [5.0alpha6] == - -* GC_malloc_explicitly_typed and friends sometimes failed to -initialize first word. -* Added allocation routines and support in the marker for mark descriptors -in a type structure referenced by the first word of an object. This was -introduced to support gcj, but hopefully in a way that makes it -generically useful. -* Added GC_requested_heapsize, and inhibited collections in non-incremental -mode if the actual used heap size is less than what was explicitly -requested. -* The Solaris pthreads version of GC_pthread_create didn't handle a NULL -attribute pointer. Solaris thread support used the wrong default thread -stack size (thanks to Melissa O'Neill for the patch). -* Changed PUSH_CONTENTS macro to no longer modify first parameter. -This usually doesn't matter, but it was certainly an accident waiting -to happen ... -* Added GC_register_finalizer_no_order and friends to gc.h. They're -needed by Java implementations. -* Integrated a fix for a win32 deadlock resulting from clock() calling -malloc (thanks to Chris Dodd). -* Integrated Hiroshi Kawashima's port to Linux/MIPS. This was designed -for a handheld platform, and may or may not be sufficient for other -machines. -* Fixed a va_arg problem with the %c specifier in cordprnt.c. It appears -that this was always broken, but recent versions of gcc are the first to -report the (statically detectable) bug. -* Added an attempt at a more general solution to dlopen races/deadlocks. -GC_dlopen now temporarily disables collection. Still not ideal, but ... -* Added -DUSE_I686_PREFETCH, -DUSE_3DNOW_PREFETCH, and support for IA64 -prefetch instructions. May improve performance measurably, but I'm not -sure the code will run correctly on processors that don't support the -instruction. Won't build except with very recent gcc. -* Added caching for header lookups in the marker. This seems to result -in a barely measurable performance gain. Added support for interleaved -lookups of two pointers, but unconfigured that since the performance -gain is currently near zero, and it adds to code size. -* Changed Linux DATA_START definition to check both data_start and -__data_start, since nothing else seems to be portable. -* Added -DUSE_LD_WRAP to optionally take advantage of the GNU ld function -wrapping mechanism. Probably currently useful only on Linux. -* Moved some variables for the scratch allocator into GC_arrays (suggested -by Martin Hirzel). -* Fixed a win32 threads bug that caused the collector to not look for -interior pointers from one of the thread stacks without -ALL_INTERIOR_POINTERS (thanks to Jeff Sturm). -* Added Mingw32 support (thanks to Jeff Sturm for the patch). -* Changed the alpha port to use the generic register scanning code instead -of alpha_mach_dep.s. Alpha_mach_dep.s doesn't look for pointers in fp -registers, but gcc sometimes spills pointers there (thanks to Manuel Serrano -for helping debug this). Changed the IA64 code to -do something similar for similar reasons. - - -== [5.0alpha4] 1999-10-30 == - -* Added protection fault handling patch for Linux/M68K from Fergus -Henderson and Roman Hodek. -* Removed the tests for SGI_SOURCE in new_gc_alloc.h. This was causing that -interface to fail on non-SGI platforms. -* Changed the Linux stack finding code to use /proc, after changing it -to use HEURISTIC1 (thanks to David Mossberger for pointing out /proc hook). -* Added HP/UX incremental GC support and HP/UX 11 thread support. -Thread support is currently still flaky. -* Added basic Linux/IA64 support. -* Integrated Anthony Green's PicoJava support. -* Integrated Scott Ananian's StrongARM/NetBSD support. -* Fixed some fairly serious performance bugs in the incremental -collector. These have probably been there essentially forever. -(Mark bits were sometimes set before scanning dirty pages. -The reclaim phase unnecessarily dirtied full small object pages.) -* Changed the reclaim phase to ignore nearly full pages to avoid -touching them. -* Limited GC_black_list_spacing to roughly the heap growth increment. -* Changed full collection triggering heuristic to decrease full GC -frequency by default, but to explicitly trigger full GCs during -heap growth. This doesn't always improve things, but on average it's -probably a win. -* GC_debug_free(0, ...) failed (thanks to Fergus Henderson for the -bug report and fix). - - -== [5.0alpha3] 1999-09-15 == - -(Also known as 4.15alpha3.) -* Added some highly incomplete code to support a copied young generation. -Comments on nursery.h are appreciated. -* Changed -DFIND_LEAK, -DJAVA_FINALIZATION, and -DFINALIZE_ON_DEMAND, -so the same effect could be obtained with a runtime switch. This is -a step towards standardizing on a single dynamic GC library. -* Significantly changed the way leak detection is handled, as a consequence -of the above. - - -== [5.0alpha2] 1999-07-23 == - -* Fixed bugs introduced in alpha1 (OpenBSD & large block initialization). -* Added -DKEEP_BACK_PTRS and backptr.h interface. (The implementation -idea came from Alan Demers.) - - -== [5.0alpha1] 1999-06-30 == - -(Also known as 4.15alpha1.) -* Reworked large block allocator. Now uses multiple doubly linked free -lists to approximate best fit. -* Changed heap expansion heuristic. Entirely free blocks are no longer -counted towards the heap size. This seems to have a major impact on -heap size stability; the old version could expand the heap way too -much in the presence of large block fragmentation. -* added -DGC_ASSERTIONS and some simple assertions inside the collector. -This is mainlyt for collector debugging. -* added -DUSE_MUNMAP to allow the heap to shrink. Supported on only -a few UNIX-like platforms for now. -* added GC_dump_regions() for debugging of fragmentation issues. -* Changed PowerPC pointer alignment under Linux to 4. -* Changed the Linux/Alpha port to walk the data segment backwards until -it encounters a SIGSEGV. The old way to find the start of the data -segment broke with a recent release. -* cordxtra.c needed to call GC_REGISTER_FINALIZER instead of -GC_register_finalizer, so that it would continue to work with GC_DEBUG. -* allochblk sometimes cleared the wrong block for debugging purposes -when it dropped blacklisted blocks. This could result in spurious -error reports with GC_DEBUG. -* added MACOS X Server support (thanks to Andrew Stone). -* Changed the Solaris threads code to ignore stack limits > 8 MB with -a warning. Empirically, it is not safe to access arbitrary pages -in such large stacks. And the dirty bit implementation does not -guarantee that none of them will be accessed. -* Integrated Martin Tauchmann's Amiga changes. -* Integrated James Dominy's OpenBSD/SPARC port. - - -== [4.14] 1999-04-16 == - -* changed STACKBOTTOM for DJGPP (thanks to Salvador Eduardo Tropea). - - -== [4.14alpha2] 1999-03-26 == - -* -DSMALL_CONFIG did not work reliably with large (> 4K) pages. -Recycling the mark stack during expansion could result in a size -zero heap segment, which confused things. (This was probably also an -issue with the normal config and huge pages.) -* Did more work to make sure that callee-save registers were scanned -completely, even with the setjmp-based code. Added USE_GENERIC_PUSH_REGS -macro to facilitate testing on machines I have access to. -* Added code to explicitly push register contents for win32 threads. -This seems to be necessary. (Thanks to Pierre de Rop.) - - -== [4.14alpha1] 1999-03-10 == - -* Fixed GC_print_source_ptr to not use a prototype. -* generalized CYGWIN test. -* gc::new did the wrong thing with PointerFreeGC placement (thanks to -Rauli Ruohonen). -* In the ALL_INTERIOR_POINTERS (default) case, some callee-save register -values could fail to be scanned if the register was saved and -reused in a GC frame. This showed up in verbose mode with gctest -compiled with an unreleased SGI compiler. I vaguely recall an old -bug report that may have been related. The bug was probably quite old. -(The problem was that the stack scanning could be deferred until -after the relevant frame was overwritten, and the new save location -might be outside the scanned area. Fixed by more eager stack scanning.) -* PRINT_BLACK_LIST had some problems. A few source addresses were garbage. -* Replaced Makefile.dj and added -I flags to cord make targets (thanks to -Gary Leavens). -* GC_try_to_collect was broken with the non-incremental collector. -* gc_cleanup destructors could pass the wrong address to -GC_register_finalizer_ignore_self in the presence of multiple -inheritance (thanks to Darrell Schiebel). -* Changed PowerPC Linux stack finding code. - - -== [4.13] 1999-02-19 == - -* Fixed a crucial bug in the Watcom port. There was a redundant declaration -of GC_push_one in gc_priv.h. -* Added FINALIZE_ON_DEMAND. -* Fixed some pre-ANSI cc problems in test.c. -* Removed getpagesize() use for Solaris. It seems to be missing in one -or two versions. -* Fixed bool handling for SPARCCompiler version 4.2. -* Fixed some files in include that had gotten unlinked from the main -copy. -* Some RS/6000 fixes (missing casts). (Thanks to Toralf Foerster.) -* Fixed several problems in GC_debug_realloc, affecting mostly the -FIND_LEAK case. -* GC_exclude_static_roots contained a buggy unsigned comparison to -terminate a loop (thanks to Wilson Ho). -* CORD_str failed if the substring occurred at the last possible position. -(Only affects cord users.) -* Fixed Linux code to deal with RedHat 5.0 and integrated Peter Bigot's -os_dep.c code for dealing with various Linux versions. -* Added workaround for Irix pthreads sigaction bug and possible signal -misdirection problems. - - -== [4.13alpha3] 1998-12-08 == - -* Fixed MSWIN32 recognition test, which interfered with cygwin. -* Removed unnecessary gc_watcom.asm from distribution. Removed -some obsolete README.win32 text. -* Added Alpha Linux incremental GC support (thanks to Philipp Tomsich -for code for retrieving the fault address in a signal handler). -Changed Linux signal handler context argument to be a pointer. -* Took care of some new warnings generated by the 7.3 SGI compiler. -* Integrated Phillip Musumeci's FreeBSD/ELF fixes. -* -DIRIX_THREADS was broken with the -o32 ABI (typo in gc_priv.h). - - -== [4.13alpha2] 1998-08-08 == - -* Fixed more Linux threads problems. -* Changed default GC_free_space_divisor to 3 with new large block allocation -(thanks to Matthew Flatt for some measurements that suggest the old -value sometimes favors space too much over time). -* More CYGWIN32 fixes. -* Integrated Tyson Dowd's Linux-M68K port. -* Minor HP PA and DEC UNIX fixes from Fergus Henderson. -* Integrated Christoffe Raffali's Linux-SPARC changes. -* Allowed for one more GC fixup iteration after a full GC in incremental -mode. Some quick measurements suggested that this significantly -reduces pause times even with smaller GC_RATE values. -* Moved some more GC data structures into GC_arrays. This decreases -pause times and GC overhead, but makes debugging slightly less convenient. -* Fixed namespace pollution problem ("excl_table"). -* Made GC_incremental a constant for -DSMALL_CONFIG, hopefully shrinking -that slightly. -* Added some win32 threads fixes. -* Integrated Ivan Demakov and David Stes' Watcom fixes. -* Various other minor fixes contributed by many people. -* Renamed config.h to gcconfig.h, since config.h tends to be used for -many other things. -* Integrated Matthew Flatt's support for 68K MacOS "far globals". -* Fixed up some of the dynamic library Makefile targets for consistency -across platforms. -* Fixed a USE_MMAP typo that caused out-of-memory handling to fail -on Solaris. -* Added code to test.c to test thread creation a bit more. -* Integrated GC_win32_free_heap (as suggested by Ivan Demakov). -* Fixed Solaris 2.7 stack base finding problem. (This may actually -have been done in an earlier alpha release.) - - -== [4.13alpha1] 1998-02-17 == - -* Changed RS6000 STACKBOTTOM. -* Integrated Patrick Beard's Mac changes. -* Alpha1 didn't compile on Irix m.n, m < 6. -* Replaced Makefile.dj with a new one from Gary Leavens. -* Added Andrew Stitcher's changes to support SCO OpenServer. -* Added PRINT_BLACK_LIST, to allow debugging of high densities of false -pointers. -* Added code to debug allocator to keep track of return address -in GC_malloc caller, thus giving a bit more context. -* Changed default behavior of large block allocator to more -aggressively avoid fragmentation. This is likely to slow down the -collector when it succeeds at reducing space cost. -* Integrated Fergus Henderson's CYGWIN32 changes. They are untested, -but needed for newer versions. -* USE_MMAP had some serious bugs. This caused the collector to fail -consistently on Solaris with -DSMALL_CONFIG. -* Added Linux threads support (thanks to Fergus Henderson). - - -== [4.12] 1997-08-26 == - -* Fixed ElfW definition in dyn_load.c. -This prevented the dynamic library support from compiling on some -older ELF Linux systems. -* Fixed UTS4 port (which I apparently mangled during the integration). -(Thanks to Alistair Crooks.) -* "Make C++" failed on Suns with SC4.0, due to a problem with "bool". -Fixed in gc_priv.h. -* Added more pieces for GNU win32 (thanks to Timothy N. Newsham). -The current state of things should suffice for at least some -applications. -* Changed the out of memory retry count handling. (This matters only -if GC_max_retries > 0, which is no longer the default.) -* If a /proc read failed repeatedly, GC_written_pages was not updated -correctly (thanks to Peter Chubb for diagnosing this). -* Under unlikely circumstances, the allocator could infinite loop in -an out of memory situation (thanks to Kenjiro Taura for -identifying the problem and supplying a fix). -* Fixed a syntactic error in the DJGPP code. Also fixed a test program -problem with DJGPP (thanks to Fergus Henderson and Peter Monks). -* Atomic uncollectible objects were not treated correctly by the -incremental collector. This resulted in weird log statistics and -occasional performance problems (thanks to Peter Chubb for pointing this out). -* Fixed some problems resulting from compilers that don't define -__STDC__. In this case void * and char * were used inconsistently -in some cases. (Void * should not have been used at all. If -you have an ANSI superset compiler that does not define __STDC__, -please compile with -D__STDC__=0. Thanks to Manuel Serrano and others -for pointing out the problem.) -* Fixed a compilation problem on Irix with -n32 and -DIRIX_THREADS. -Also fixed some other IRIX_THREADS problems which may or may not have -had observable symptoms. -* Fixed an HP PA compilation problem in dyn_load.c (thanks to -Philippe Queinnec). -* SEGV fault handlers sometimes did not get reset correctly (thanks -to David Pickens). -* Added a fix for SOLARIS_THREADS on Intel (thanks to David Pickens). -This probably needs more work to become functional. -* Fixed struct sigcontext_struct in os_dep.c for compilation under -Linux 2.1.X (thanks to Fergus Henderson). -* Changed the DJGPP STACKBOTTOM and DATASTART values to those ones suggested -(by Kristian Kristensen). These may still not be right, but it is -it is likely to work more often than what was there before. They may -even be exactly right. -* Added a #include to test_cpp.cc. This appears to help -with HP/UX and gcc (thanks to Assar Westerlund). -* Version 4.11 failed to run in incremental mode on recent 64-bit Irix -kernels. This was a problem related to page unaligned heap segments. -Changed the code to page align heap sections on all platforms. -(I had mistakenly identified this as a kernel problem earlier. -It was not.) -* Version 4.11 did not make allocated storage executable, except on -one or two platforms, due to a bug in a #if test (thanks to David Grove -for pointing this out). -* Added sparc_sunos4_mach_dep.s to support Sun's compilers under SunOS4. -* Added GC_exclude_static_roots. -* Fixed the object size mapping algorithm. This shouldn't matter, -but the old code was ugly. -* Heap checking code could die if one of the allocated objects was -larger than its base address. (Unsigned underflow problem. Thanks -to Clay Spence for isolating the problem.) -* Added RS6000 (AIX) dynamic library support and fixed STACK_BOTTOM (thanks -to Fred Stearns). -* Added Fergus Henderson's patches for improved robustness with large -heaps and lots of blacklisting. -* Added Peter Chubb's changes to support Solaris Pthreads, to support -MMAP allocation in Solaris, to allow Solaris to find dynamic libraries -through /proc, to add malloc_typed_ignore_off_page, and a few other -minor features and bug fixes. -* The Solaris 2 port should not use sbrk. I received confirmation from -Sun that the use of sbrk and malloc in the same program is not -supported. The collector now defines USE_MMAP by default on Solaris. -* Replaced the djgpp makefile with Gary Leavens' version. -* Fixed MSWIN32 detection test. -* Added Fergus Henderson's patches to allow putting the collector into -a DLL under GNU win32. -* Added Ivan V. Demakov's port to Watcom C on X86. -* Added Ian Piumarta's Linux/PowerPC port. -* Added PointerFreeGC to the placement options in gc_cpp.h (suggested by -Brian Burton). This is of course unsafe, and may be controversial. -On the other hand, it seems to be needed often enough that it's worth -adding as a standard facility. -* Add Lars Farm's suggestions on building the collector for MacOS. - - -== [4.12alpha2] == - -(Changes not specified.) - - -== [4.11] 1996-12-03 == - -* Rationalized (hopefully) GC_try_to_collect in an incremental collection -environment. It appeared to not handle a call while a collection was in -progress, and was otherwise too conservative. -* Merged GC_reclaim_or_delete_all into GC_reclaim_all to get rid of some -code. -* Added Patrick Beard's Mac fixes, with substantial completely untested -modifications. -* Fixed the MPROTECT_VDB code to deal with large pages and imprecise -fault addresses (as on an UltraSPARC running Solaris 2.5). Note that this -was not a problem in the default configuration, which uses PROC_VDB. -* The DEC Alpha assembly code needed to restore $gp between calls (thanks to -Fergus Henderson for tracking this down and supplying a patch). -* The write command for "de" was completely broken for large files. -I used the easiest portable fix, which involved changing the semantics -so that f.new is written instead of overwriting f. That's safer anyway. -* Added README.solaris2 with a discussion of the possible problems of -mixing the collector's sbrk allocation with malloc/realloc. -* Changed the data segment starting address for SGI machines. The -old code failed under IRIX6. -* Required double word alignment for MIPS. -* Various minor fixes to remove warnings. -* Attempted to fix some Solaris threads problems (reported by Zhiying Chen). -In particular, the collector could try to fork a thread with the -world stopped as part of GC_thr_init. It also failed to deal with -the case in which the original thread terminated before the whole -process did. -* Added -DNO_EXECUTE_PERMISSION. This has a major performance impact -on the incremental collector under Irix, and perhaps under other -operating systems. -* Added some code to support allocating the heap with mmap. This may -be preferable under some circumstances. -* Integrated dynamic library support for HP (thanks to Knut Tvedten). -* Integrated James Clark's win32 threads support, and made a number -of changes to it (many of which suggested by Pontus Rydin). This is still -not 100% solid. -* Integrated Alistair G. Crooks' support for UTS4 running on an Amdahl -370-class machine. -* Fixed a serious bug in explicitly typed allocation. Objects requiring -large descriptors where handled in a way that usually resulted in -a segmentation fault in the marker (thanks to Jeremy Fitzhardinge -for helping to track this down). -* Added partial support for GNU win32 development (thanks to -Fergus Henderson). -* Added optional support for Java-style finalization semantics (thanks to -Patrick Bridges). This is recommended only for Java implementations. -* GC_malloc_uncollectable faulted instead of returning 0 when out of -memory (thanks to Daniel R. Grayson for noticing). -* Calls to GC_base before the collector was initialized failed on a -DEC Alpha (thanks to Matthew Flatt). -* Added base pointer checking to GC_REGISTER_FINALIZER in debugging mode -(thanks to Jeremy Fitzhardinge). -* GC_debug_realloc failed for uncollectible objects (thanks to -Jeremy Fitzhardinge). -* Explicitly typed allocation could crash if it ran out of memory (thanks to -Jeremy Fitzhardinge). -* Added minimal support for a DEC Alpha running Linux. -* Fixed a problem with allocation of objects whose size overflowed -ptrdiff_t. (This now fails unconditionally, as it should.) -* Added the beginning of Irix pthread support. -* Integrated Xiaokun Zhu's fixes for djgpp 2.01. -* Added SGI-style STL allocator support (gc_alloc.h). -* Fixed a serious bug in README.solaris2. -Multi-threaded programs must include -gc.h with SOLARIS_THREADS defined. -* Changed GC_free so it actually deallocates uncollectible objects (thanks -to Peter Chubb for pointing out the problem). -* Added Linux ELF support for dynamic libraries (thanks to Patrick Bridges). -* Changed the Borland cc configuration so that the assembler is not -required. -* Fixed a bug in the C++ test that caused it to fail in 64-bit -environments. - - -== [4.10t3] 1996-11-18 == - -Some changes related to threads support. - - -== [4.10] 1996-02-19 == - -* Fixed a typo around a call to GC_collect_or_expand in alloc.c. It broke -handling of out of memory. (Thanks to Patrick C. Beard for noticing.) - - -== [4.9] 1996-02-12 == - -* More README.debugging fixes. -* Objects ready for finalization, but not finalized in the same GC -cycle, could be prematurely collected. This occasionally happened -in test_cpp. -* Too little memory was obtained from the system for very large -objects. That could cause a heap explosion if these objects were -not contiguous (e.g. under PCR), and too much of them was blacklisted. -* Due to an improper initialization, the collector was too hesitant to -allocate blacklisted objects immediately after system startup. -* Moved GC_arrays from the data into the bss segment by not explicitly -initializing it to zero. This significantly -reduces the size of executables, and probably avoids some disk accesses -on program startup. It's conceivable that it might break a port that I -didn't test. -* Fixed EMX_MAKEFILE to reflect the gc_c++.h to gc_cpp.h renaming which -occurred a while ago. - - -== [4.8] 1995-11-20 == - -* Changed a "comment" in a MacOS specific part of mach_dep.c that caused -gcc to fail on other platforms. - - -== [4.7] 1995-11-18 == - -* Fixed some compilation problems with -DCHECKSUMS (thanks to Ian Searle). -* Updated some Mac specific files (to synchronize with Patrick C. Beard). -* Fixed a serious bug for machines with non-word-aligned pointers. -(Thanks to Patrick C. Beard for pointing out the problem. The collector -should fail almost any conceivable test immediately on such machines.) - - -== [4.6] 1995-11-09 == - -* Added Linux ELF support (thanks to Arrigo Triulzi). -* GC_base crashed if it was called before any other GC_ routines. -This could happen if a gc_cleanup object was allocated outside the heap -before any heap allocation. -* The heap expansion heuristic was not stable if all objects had finalization -enabled. Fixed finalize.c to count memory in finalization queue and -avoid explicit deallocation. Changed alloc.c to also consider this count. -(This is still not recommended. It's expensive if nothing else. Thanks -to John Ellis for pointing this out.) -* GC_malloc_uncollectable(0) was broken (thanks to Phong Vo for pointing -this out). -* The collector didn't compile under Linux 1.3.X (thanks to Fred Gilham for -pointing this out). The current workaround is ugly, but expected to be -temporary. -* Fixed a formatting problem for SPARC stack traces. -* Fixed some '=='s in os_dep.c that should have been assignments. -Fortunately these were in code that should never be executed anyway (thanks -to Fergus Henderson). -* Fixed the heap block allocator to only drop blacklisted blocks in small -chunks. Made BL_LIMIT self adjusting. (Both of these were in response -to heap growth observed by Paul Graham.) -* Fixed the Metrowerks/68K Mac code to also mark from a6 (thanks to -Patrick C. Beard). -* Significantly updated README.debugging. -* Fixed some problems with longjmps out of signal handlers, especially under -Solaris. Added a workaround for the fact that siglongjmp doesn't appear to -do the right thing with -lthread under Solaris. -* Added MSDOS/djgpp port (thanks to Mitch Harris). -* Added "make reserved_namespace" and "make user_namespace". The -first renames ALL "GC_xxx" identifiers as "_GC_xxx". The second is the -inverse transformation. Note that doing this is guaranteed to break all -clients written for the other names. -* descriptor field for kind NORMAL in GC_obj_kinds with ADD_BYTE_AT_END -defined should be -ALIGNMENT not WORDS_TO_BYTES(-1). This is -a serious bug on machines with pointer alignment of less than a word. -* GC_ignore_self_finalize_mark_proc didn't handle pointers to very near the -end of the object correctly. Caused failures of the C++ test on a DEC Alpha -with g++. -* gc_inl.h still had problems. Partially fixed. Added warnings at the -beginning to hopefully specify the remaining dangers. -* Added DATAEND definition to config.h. -* Fixed some of the .h file organization. Fixed "make floppy". - - -== [4.5] 1995-06-14 == - -* Fixed many minor and one major README bugs (thanks to Franklin Chen -for pointing out many of them). -* Fixed ALPHA/OSF/1 dynamic library support (thanks to Jonathan Bachrach). -* Added incremental GC support (MPROTECT_VDB) for Linux (with some -help from Bruno Haible). -* Altered SPARC recognition tests in gc.h and config.h (mostly as -suggested by Fergus Henderson). -* Added basic incremental GC support for win32, as implemented by -Windows NT and Windows 95. GC_enable_incremental is a no-op -under win32s, which doesn't implement enough of the VM interface. -* Added -DLARGE_CONFIG. -* Fixed GC_..._ignore_off_page to also function without --DALL_INTERIOR_POINTERS. -* (Hopefully) fixed RS/6000 port. (Only the test was broken.) -* Fixed a performance bug in the non-incremental collector running -on machines supporting incremental collection with MPROTECT_VDB -(e.g. SunOS 4, DEC AXP). This turned into a correctness bug under -win32s with win32 incremental collection. (Not all memory protection -was disabled.) -* Fixed some ppcr related bit rot. -* Caused dynamic libraries to be unregistered before re-registering. -The old way turned out to be a performance bug on some machines. -* GC_root_size was not properly maintained under MSWIN32. -* Added -DNO_DEBUGGING and GC_dump. -* Fixed a couple of bugs arising with SOLARIS_THREADS + -REDIRECT_MALLOC. -* Added NetBSD/M68K port (thanks to Peter Seebach). -* Fixed a serious realloc bug. For certain object sizes, the collector -wouldn't scan the expanded part of the object. (Thanks to Clay Spence -for noticing the problem, and helping me to track it down.) - - -== [4.4] 1995-02-18 == - -* ASM_CLEAR_CODE was erroneously defined for HP -PA machines, resulting in a compile error. -* Fixed OS/2 Makefile to create a library (thanks to Mark Boulter). -* Gc_cleanup objects didn't work if they were created on -the stack. Fixed. -* One copy of Gc_cpp.h in the distribution was out of -synch, and failed to document some known compiler -problems with explicit destructor invocation. Partially -fixed. There are probably other compilers on which -gc_cleanup is miscompiled. -* Fixed Makefile to pass C compiler flags to C++ compiler. -* Added Mac fixes. -* Fixed os_dep.c to work around what appears to be -a new and different VirtualQuery bug under newer -versions of win32S. -* GC_non_gc_bytes was not correctly maintained by -GC_free. Fixed (thanks to James Clark). -* Added GC_set_max_heap_size. -* Changed allocation code to ignore blacklisting if it is preventing -use of a very large block of memory. This has the advantage -that naive code allocating very large objects is much more -likely to work. The downside is you might no -longer find out that such code should really use -GC_malloc_ignore_off_page. -* Changed GC_printf under win32 to close and reopen the file -between calls. FAT file systems otherwise make the log file -useless for debugging. -* Added GC_try_to_collect and GC_get_bytes_since_gc. These -allow starting an abortable collection during idle times. -This facility does not require special OS support. (Thanks to -Michael Spertus of Geodesic Systems for suggesting this. It was -actually an easy addition. Kumar Srikantan previously added a similar -facility to a now ancient version of the collector. At the time -this was much harder, and the result was less convincing.) -* Added some support for the Borland development environment (thanks -to John Ellis and Michael Spertus). -* Removed a misfeature from checksums.c that caused unexpected -heap growth (thanks to Scott Schwartz). -* Changed finalize.c to call WARN if it encounters a finalization cycle. -WARN is defined in gc_priv.h to write a message, usually to stdout. -In many environments, this may be inappropriate. -* Renamed NO_PARAMS in gc.h to GC_NO_PARAMS, thus adhering to my own -naming convention. -* Added GC_set_warn_proc to intercept warnings. -* Fixed Amiga port (thanks to Michel Schinz). -* Fixed a bug in mark.c that could result in an access to unmapped -memory from GC_mark_from_mark_stack on machines with unaligned -pointers. -* Fixed a win32 specific performance bug that could result in scanning of -objects allocated with the system malloc. -* Added REDIRECT_MALLOC. - - -== [4.3] 1994-12-23 == - -* Fixed SPARC alignment problem with GC_DEBUG. -* Fixed Solaris threads /proc workaround. The real -problem was an interaction with mprotect. -* Incorporated fix from Patrick Beard for gc_c++.h (now gc_cpp.h). -* Slightly improved allocator space utilization by -fixing the GC_size_map mechanism. -* Integrated some Sony News and MIPS RISCos 4.51 -patches (thanks to Nobuyuki Hikichi at Software Research Associates, -Inc., Japan). -* Fixed HP_PA alignment problem (thanks to Brian F. Dennis). -* Added GC_same_obj and friends. Changed GC_base -to return 0 for pointers past the end of large objects. -Improved GC_base performance with ALL_INTERIOR_POINTERS -on machines with a slow integer mod operation. -Added GC_PTR_ADD, GC_PTR_STORE, etc. to prepare -for preprocessor. -* changed the default on most UNIX machines to be that -signals are not disabled during critical GC operations. -This is still ANSI-conforming, though somewhat dangerous -in the presence of signal handlers. But the performance -cost of the alternative is sometimes problematic. -Can be changed back with a minor Makefile edit. -* renamed IS_STRING in gc.h, to CORD_IS_STRING, thus -following my own naming convention. Added the function -CORD_to_const_char_star. -* Fixed a gross bug in GC_finalize. Symptom: occasional -address faults in that function (thanks to Anselm Baird-Smith). -* Added port to ICL DRS6000 running DRS/NX. Restructured -things a bit to factor out common code, and remove obsolete -code. Collector should now run under SUNOS5 with either -mprotect or /proc dirty bits. (Thanks to Douglas Steel.) -* More bug fixes and workarounds for Solaris 2.X. (These were -mostly related to putting the collector in a dynamic library, -which didn't really work before. Also SOLARIS_THREADS -didn't interact well with dl_open.) (Thanks to Brian Lewis.) -* Fixed a serious performance bug on the DEC Alpha. The text -segment was getting registered as part of the root set. -(Amazingly, the result was still fast enough that the bug -was not conspicuous.) The fix works on OSF/1, version 1.3. -Hopefully it also works on other versions of OSF/1 ... -* Fixed a bug in GC_clear_roots. -* Fixed a bug in GC_generic_malloc_words_small that broke -gc_inl.h (reported by Antoine de Maricourt). -* Fixed some problems with cord/de under Linux. -* Fixed some cord problems, notably with CORD_riter4. -* Added DG/UX port (thanks to Ben A. Mesander). -* Added finalization registration routines with weaker ordering -constraints. (This is necessary for C++ finalization with -multiple inheritance, since the compiler often adds self-cycles.) -* Filled the holes in the SCO port (thanks to Michael Arnoldus). -* Completely rewritten the documentation in the interface gc_c++.h -(later renamed gc_cpp.h) making it both clearer and more precise (done by -John Ellis). -* The definition of accessibility now ignores pointers from a finalizable -object (an object with a clean-up function) to itself (done by John Ellis). -This allows objects with virtual base classes to be finalizable by the -collector. Compilers typically implement virtual base classes using -pointers from an object to itself, which under the old definition of -accessibility prevented objects with virtual base classes from ever -being collected or finalized. -* gc_cleanup now includes gc as a virtual base. This was enabled by -the change in the definition of accessibility (by John Ellis). -* Added support for operator new[] (by John Ellis). Since most compilers -don't yet support operator new[], it is conditionalized on --DOPERATOR_NEW_ARRAY. The code is untested, but its trivial and looks -correct. -* The test program test_gc_c++ (later renamed test_cpp.cc) -tries to test for the C++-specific functionality not tested by the -other programs. -* Added unistd.h include to misc.c. (Needed for ppcr.) -* Added PowerMac port (thanks to Patrick C. Beard). -* Fixed "srcdir"-related Makefile problems. Changed things so -that all externally visible include files always appear in the -include subdirectory of the source. Made gc.h directly -includable from C++ code (thanks to Per Bothner). -* Changed Intel code to also mark from ebp (thanks to Kevin Warne). -* Renamed C++ related files so they could live in a FAT -file system (thanks to Charles Fiterman). -* Changed Windows NT Makefile to include C++ support in -gc.lib. Added C++ test as Makefile target. - - -== [4.2] 1994-08-03 == - -* Multiple bug fixes/workarounds in the Solaris threads version. -(It occasionally failed to locate some register contents for -marking. It also turns out that thr_suspend and friends are -unreliable in Solaris 2.3. Dirty bit reads appear -to be unreliable under some weird -circumstances. My stack marking code -contained a serious performance bug. The new code is -extremely defensive, and has not failed in several CPU -hours of testing. But no guarantees ...) -* Added MacOS support. (Thanks to Patrick C. Beard. -David Chase suggested several improvements.) -* Fixed several syntactic bugs in gc_c++.h and friends. (These -didn't bother g++, but did bother most other compilers.) -Fixed gc_c++.h finalization interface. -* 64 bit alignment for allocated objects was not guaranteed in a -few cases in which it should have been. -* Added GC_malloc_atomic_ignore_off_page. -* Added GC_collect_a_little. -* Added some prototypes to gc.h. -* Some other minor bug fixes (notably in Makefile). -* Fixed OS/2 / EMX port (thanks to Ari Huttunen). -* Fixed AmigaDOS port (thanks to Michel Schinz). -* Fixed the DATASTART definition under Solaris. There -was a 1 in 16K chance of the collector missing the first -64K of static data (and thus crashing). -* Fixed some blatant anachronisms in the README file. -* Fixed PCR-Makefile for upcoming PPCR release. - - -== [4.1] 1994-05-20 == - -* Changed finalization implementation to guarantee that -finalization procedures are called outside of the allocation -lock, making direct use of the interface a little less dangerous. -MAY BREAK EXISTING CLIENTS that assume finalizers -are protected by a lock. Since there seem to be few multi-threaded -clients that use finalization, this is hopefully not much of -a problem. -* Fixed a gross bug in CORD_prev. -* Fixed a bug in blacklst.c that could result in unbounded -heap growth during startup on machines that do not clear -memory obtained from the OS (e.g. win32S). -* Ported de editor to win32/win32S. (This is now the only -version with a mouse-sensitive UI. Thanks to Rob Haack for the -implementation based on the generic Windows application template.) -* Added GC_malloc_ignore_off_page to allocate large arrays -in the presence of ALL_INTERIOR_POINTERS. -* Changed GC_call_with_alloc_lock to not disable signals in -the single-threaded case. -* Reduced retry count in GC_collect_or_expand for garbage -collecting when out of memory. -* Made uncollectible allocations bypass black-listing, as they -should. -* Fixed a bug in typed_test in test.c that could cause (legitimate) -GC crashes. -* Fixed some potential synchronization problems in finalize.c -* Fixed a real locking problem in typd_mlc.c. -* Worked around an AIX 3.2 compiler feature that results in -out of bounds memory references. -* Partially worked around an IRIX5.2 beta problem (which may -or may not persist to the final release). -* Fixed a bug in the heap integrity checking code that could -result in explicitly deallocated objects being identified as -smashed. Fixed a bug in the dbg_mlc stack saving code -that caused old argument pointers to be considered live. -* Fixed a bug in CORD_ncmp (and hence CORD_str). -* Repaired the OS2 port, which had suffered from bit rot -in 4.0. Worked around what appears to be CSet/2 V1.0 -optimizer bug. -* Fixed a Makefile bug for target "c++". - - -== [4.0] 1994-04-07 == - -* Added support for Solaris threads (which was possible -only by reimplementing some fraction of Solaris threads, -since Sun doesn't currently make the thread debugging -interface available). -* Added non-threads win32 and win32S support. -* (Grudgingly, with suitable muttering of obscenities) renamed -files so that the collector distribution could live on a FAT -file system. Files that are guaranteed to be useless on -a PC still have long names. Gc_inline.h and gc_private.h -still exist, but now just include gc_inl.h and gc_priv.h. -* Fixed a really obscure bug in finalization that could cause -undetected mark stack overflows. (I would be surprised if -any real code ever tickled this one.) -* Changed finalization code to dynamically resize the hash -tables it maintains. (This probably does not matter for well- --written code. It no doubt does for C++ code that overuses -destructors.) -* Added typed allocation primitives. Rewrote the marker to -accommodate them with more reasonable efficiency. This -change should also speed up marking for GC_malloc allocated -objects a little. See gc_typed.h for new primitives. (Thanks to -Zhong Shao performed much of the experimentation that led to the -current typed allocation facility.) -* Improved debugging facilities slightly. Allocation time -stack traces are now kept by default on SPARC/SUNOS4. (Thanks to -Scott Schwartz.) -* Added better support for small heap applications. -* Significantly extended cord package. Fixed a bug in the -implementation of lazily read files. Printf and friends now -have cord variants. Cord traversals are a bit faster. -* Made ALL_INTERIOR_POINTERS recognition the default. -* Fixed de so that it can run in constant space, independent -of file size. Added simple string searching to cords and de. -* Added the Hull-Ellis C++ interface (supplied by Jesse Hull and John Ellis). -* Added dynamic library support for OSF/1 (thanks to Alan Dosser and -Tim Bingham at DEC). -* Changed argument to GC_expand_hp to be expressed -in units of bytes instead of heap blocks. (Necessary -since the heap block size now varies depending on -configuration. The old version was never very clean.) -* Added GC_get_heap_size(). The previous "equivalent" -was broken. -* Restructured the Makefile a bit. -* Added FreeBSD port (provided by Jeffrey Hsu). - - -== [3.7] 1994-03-15 == - -* Added a workaround for an HP/UX compiler bug. -* Fixed another stack clearing performance bug. Reworked -that code once more. - - -== [3.6] 1994-01-14 == - -* fixed a bug in the mark stack growth code that was introduced -in 3.4. -* fixed Makefile to work around DEC AXP compiler tail recursion -bug. - - -== [3.5] == - -* Minor collections now mark from roots only once, if that -doesn't cause an excessive pause. -* The stack clearing heuristic was refined to prevent anomalies -with very heavily recursive programs and sparse stacks. -* Fixed a bug that prevented mark stack growth in some cases. -GC_objects_are_marked should be set to TRUE after a call -to GC_push_roots and as part of GC_push_marked, since -both can now set mark bits. I think this is only a performance -bug, but I wouldn't bet on it. It's certainly very hard to argue -that the old version was correct. -* Fixed an incremental collection bug that prevented it from -working at all when HBLKSIZE != getpagesize() -* Changed dynamic_loading.c to include gc_priv.h before testing -DYNAMIC_LOADING. SunOS dynamic library scanning -must have been broken in 3.4. -* Object size rounding now adapts to program behavior. -* Added a workaround (provided by Manuel Serrano and -colleagues) to a long-standing SunOS 4.X (and 3.X) ld bug -that I had incorrectly assumed to have been squished. -The collector was broken if the text segment size was within -32 bytes of a multiple of 8K bytes, and if the beginning of -the data segment contained interesting roots. The workaround -assumes a demand-loadable executable. The original may have -have "worked" in some other cases. -* Added dynamic library support under IRIX5. -* Added support for EMX under OS/2 (thanks to Ari Huttunen). -* Added support of Motorola 88K processor running CX/UX (by Brent Benson). - - -== [3.4] == - -* Fixed a performance bug in GC_realloc. -* Updated the amiga port. -* Added NetBSD and 386BSD ports (supplied by Alistair G. Crooks). -* Added cord library. -* Added trivial performance enhancement for -ALL_INTERIOR_POINTERS (do not scan last word). - - -== [3.3] 1993-10-02 == - -* PCR-specific bugs (thanks to Neil Sharman). -* Missing locking in GC_free, redundant FASTUNLOCK -in GC_malloc_stubborn, and 2 bugs in -GC_unregister_disappearing_link (pointed out by Neil Sharman). -* Common symbols allocated by the SunOS4.X dynamic loader -were not included in the root set. -* Bug in GC_finalize (reported by Brian Beuning and Alan Dosser). -* Merged Amiga port from Jesper Peterson (untested). -* Merged NeXT port from Thomas Funke (significantly -modified and untested). (Also thanks to Brian D. Carlstrom for -the supplied the NeXT ports.) - - -== [3.2] == - -Fixed a serious and not entirely repeatable bug in -the incremental collector. It appeared only when dirty bit info -on the roots was available, which is normally only under Solaris. -It also added GC_general_register_disappearing_link, and some -testing code. Interface.c disappeared. - - -== [3.1] == - -* A workaround for a SunOS 4.X SPARC C compiler -misfeature that caused problems when the collector was turned into -a dynamic library. -* A fix for a bug in GC_base that could result in a memory fault. -* A fix for a performance bug (and several other misfeatures) pointed -out by Dave Detlefs and Alan Dosser. -* Use of dirty bit information for static data under Solaris 2.X. -* DEC Alpha/OSF1 support (thanks to Alan Dosser). -* Incremental collection on more platforms. -* A more refined heap expansion policy. Less space usage by default. -* Various minor enhancements to reduce space usage, and to reduce -the amount of memory scanned by the collector. -* Uncollectible allocation without per object overhead. -* More conscientious handling of out-of-memory conditions. -* Fixed a bug in debugging stubborn allocation. -* Fixed a bug that resulted in occasional erroneous reporting of smashed -objects with debugging allocation. -* Fixed bogus leak reports of size 4096 blocks with FIND_LEAK. - - -== [3.0] == - -Added generational/incremental collection and stubborn objects. - - -== [2.6] 1993-04-27 == - -(Changes not specified.) - - -== [2.5] == - -* Removed an explicit call to exit(1) -* Fixed calls to GC_printf and GC_err_printf, so the correct number of -arguments are always supplied. The OS/2 C compiler gets confused if -the number of actuals and the number of formals differ. (ANSI C -doesn't require this to work. The ANSI sanctioned way of doing things -causes too many compatibility problems.) - - -== [2.4] 1993-01-26 == - -Added GC_free_space_divisor as a tuning knob, added -support for OS/2 and linux, and fixed the following bugs: -* On machines with unaligned pointers (e.g. Sun 3), every 128th word could -fail to be considered for marking. -* Dynamic_load.c erroneously added 4 bytes to the length of the data and -bss sections of the dynamic library. This could result in a bad memory -reference if the actual length was a multiple of a page. (Observed on -Sun 3. Can probably also happen on a Sun 4.) -(Thanks to Robert Brazile for pointing out that the Sun 3 version -was broken. Dynamic library handling is still broken on Sun 3s -under 4.1.1U1, but apparently not 4.1.1. If you have such a machine, -use -Bstatic.) - - -== [2.3] == - -* Added ALL_INTERIOR_POINTERS. -* Missing declaration of etext in the A/UX version. -* Some PCR root-finding problems. -* Blacklisting was not 100% effective, because the plausible future -heap bounds were being miscalculated. -* GC_realloc didn't handle out-of-memory correctly. -* GC_base could return a nonzero value for addresses inside free blocks. -* test.c wasn't really thread safe, and could erroneously report failure -in a multi-threaded environment. (The locking primitives need to be -replaced for other threads packages.) -* GC_CONS was thoroughly broken. -* On a SPARC with dynamic linking, signals stayed disabled while the -client code was running (thanks to Manuel Serrano). - - -== [2.2] == - -* GC_realloc could fail to extend the size of the object for certain large -object sizes. -* A blatant subscript range error in GC_printf, which unfortunately -wasn't exercised on machines with sufficient stack alignment constraints. -* GC_register_displacement did the wrong thing if it was called after -any allocation had taken place. -* The leak finding code would eventually break after 2048 byte -byte objects leaked. -* interface.c didn't compile. -* The heap size remained much too small for large stacks. -* The stack clearing code behaved badly for large stacks, and perhaps -on HP/PA machines. - - -== [2.1] == - -* The first stable version since 1.9. -* Added support for PPCR. - - -== [2.0] == - -* Introduced a consistent naming convention for collector -routines and added support for registering dynamic library data segments -in the standard mark_roots.c (original code supporting the SunOS dynamic -loader provided by Bill Janssen). Most of the data structures were revamped. -The treatment of interior pointers was completely changed. Finalization -was added. Support for locking was added. Object kinds were added. -We added a black listing facility to avoid allocating at addresses known -to occur as integers somewhere in the address space. Much of this -was accomplished by adapting ideas and code from the PCR collector. -The test program was changed and expanded. - - -== [1.9] 1992-01-29 == - -* fixed a major bug in gc_realloc. - - -== [1.8] == - -* added ULTRIX support in gc_private.h. (Robert Brazile originally supplied -the ULTRIX code. Alan Dosser and Regis Cridlig subsequently provided updates -and information on variation between ULTRIX systems.) - - -== [1.5] == - -* ensure 8 byte alignment for objects allocated on a sparc based machine. - - -== [1.4] == - -* Does not use compile time determined values -for the stack base. This no longer works on Sun 3s, since Sun 3/80s use -a different stack base. We now use a straightforward heuristic on all -machines on which it is known to work (incl. Sun 3s) and compile-time -determined values for the rest. There should really be library calls -to determine such values. - - -== [1.3] == - -* Fixed spurious -assembly language assignments to TMP_SP. Only the assignment in the PC/RT -code is necessary. On other machines, with certain compiler options, -the assignments can lead to an unsaved register being overwritten. -Known to cause problems under SunOS 3.5 WITHOUT the -O option. (With --O the compiler recognizes it as dead code. It probably shouldn't, -but that's another story.) -The SPARC-specific code was originally contributed by Mark Weiser. -The Encore Multimax modifications were supplied by Kevin Kenny. -The adaptation to the IBM PC/RT is largely -due to Vernon Lee, on machines made available to Rice by IBM. -Much of the HP specific code and a number of good suggestions for improving -the generic code are due to Walter Underwood. -Parag Patel supplied the A/UX code. -Manuel Serrano supplied linux and Sony News specific code. diff -Nru ecl-16.1.2/src/bdwgc/checksums.c ecl-16.1.3+ds/src/bdwgc/checksums.c --- ecl-16.1.2/src/bdwgc/checksums.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/checksums.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,220 +0,0 @@ -/* - * Copyright (c) 1992-1994 by Xerox Corporation. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#include "private/gc_priv.h" - -#ifdef CHECKSUMS - -/* This is debugging code intended to verify the results of dirty bit */ -/* computations. Works only in a single threaded environment. */ -/* We assume that stubborn objects are changed only when they are */ -/* enabled for writing. (Certain kinds of writing are actually */ -/* safe under other conditions.) */ -#define NSUMS 10000 - -#define OFFSET 0x10000 - -typedef struct { - GC_bool new_valid; - word old_sum; - word new_sum; - struct hblk * block; /* Block to which this refers + OFFSET */ - /* to hide it from collector. */ -} page_entry; - -page_entry GC_sums[NSUMS]; - -STATIC word GC_faulted[NSUMS] = { 0 }; - /* Record of pages on which we saw a write fault. */ - -STATIC size_t GC_n_faulted = 0; - -void GC_record_fault(struct hblk * h) -{ - word page = ROUNDUP_PAGESIZE((word)h); - - if (GC_n_faulted >= NSUMS) ABORT("write fault log overflowed"); - GC_faulted[GC_n_faulted++] = page; -} - -STATIC GC_bool GC_was_faulted(struct hblk *h) -{ - size_t i; - word page = ROUNDUP_PAGESIZE((word)h); - - for (i = 0; i < GC_n_faulted; ++i) { - if (GC_faulted[i] == page) return TRUE; - } - return FALSE; -} - -STATIC word GC_checksum(struct hblk *h) -{ - word *p = (word *)h; - word *lim = (word *)(h+1); - word result = 0; - - while ((word)p < (word)lim) { - result += *p++; - } - return(result | 0x80000000 /* doesn't look like pointer */); -} - -#ifdef STUBBORN_ALLOC - /* Check whether a stubborn object from the given block appears on */ - /* the appropriate free list. */ - STATIC GC_bool GC_on_free_list(struct hblk *h) - { - hdr * hhdr = HDR(h); - size_t sz = BYTES_TO_WORDS(hhdr -> hb_sz); - ptr_t p; - - if (sz > MAXOBJWORDS) return(FALSE); - for (p = GC_sobjfreelist[sz]; p != 0; p = obj_link(p)) { - if (HBLKPTR(p) == h) return(TRUE); - } - return(FALSE); - } -#endif - -int GC_n_dirty_errors = 0; -int GC_n_faulted_dirty_errors = 0; -int GC_n_changed_errors = 0; -int GC_n_clean = 0; -int GC_n_dirty = 0; - -STATIC void GC_update_check_page(struct hblk *h, int index) -{ - page_entry *pe = GC_sums + index; - hdr * hhdr = HDR(h); - struct hblk *b; - - if (pe -> block != 0 && pe -> block != h + OFFSET) ABORT("goofed"); - pe -> old_sum = pe -> new_sum; - pe -> new_sum = GC_checksum(h); -# if !defined(MSWIN32) && !defined(MSWINCE) - if (pe -> new_sum != 0x80000000 && !GC_page_was_ever_dirty(h)) { - GC_err_printf("GC_page_was_ever_dirty(%p) is wrong\n", (void *)h); - } -# endif - if (GC_page_was_dirty(h)) { - GC_n_dirty++; - } else { - GC_n_clean++; - } - b = h; - while (IS_FORWARDING_ADDR_OR_NIL(hhdr) && hhdr != 0) { - b -= (word)hhdr; - hhdr = HDR(b); - } - if (pe -> new_valid - && hhdr != 0 && hhdr -> hb_descr != 0 /* may contain pointers */ - && pe -> old_sum != pe -> new_sum) { - if (!GC_page_was_dirty(h) || !GC_page_was_ever_dirty(h)) { - GC_bool was_faulted = GC_was_faulted(h); - /* Set breakpoint here */GC_n_dirty_errors++; - if (was_faulted) GC_n_faulted_dirty_errors++; - } -# ifdef STUBBORN_ALLOC - if (!HBLK_IS_FREE(hhdr) - && hhdr -> hb_obj_kind == STUBBORN - && !GC_page_was_changed(h) - && !GC_on_free_list(h)) { - /* if GC_on_free_list(h) then reclaim may have touched it */ - /* without any allocations taking place. */ - /* Set breakpoint here */GC_n_changed_errors++; - } -# endif - } - pe -> new_valid = TRUE; - pe -> block = h + OFFSET; -} - -word GC_bytes_in_used_blocks = 0; - -STATIC void GC_add_block(struct hblk *h, word dummy GC_ATTR_UNUSED) -{ - hdr * hhdr = HDR(h); - size_t bytes = hhdr -> hb_sz; - - bytes += HBLKSIZE-1; - bytes &= ~(HBLKSIZE-1); - GC_bytes_in_used_blocks += bytes; -} - -STATIC void GC_check_blocks(void) -{ - word bytes_in_free_blocks = GC_large_free_bytes; - - GC_bytes_in_used_blocks = 0; - GC_apply_to_all_blocks(GC_add_block, (word)0); - GC_COND_LOG_PRINTF("GC_bytes_in_used_blocks = %lu," - " bytes_in_free_blocks = %lu, heapsize = %lu\n", - (unsigned long)GC_bytes_in_used_blocks, - (unsigned long)bytes_in_free_blocks, - (unsigned long)GC_heapsize); - if (GC_bytes_in_used_blocks + bytes_in_free_blocks != GC_heapsize) { - GC_err_printf("LOST SOME BLOCKS!!\n"); - } -} - -/* Should be called immediately after GC_read_dirty and GC_read_changed. */ -void GC_check_dirty(void) -{ - int index; - unsigned i; - struct hblk *h; - ptr_t start; - - GC_check_blocks(); - - GC_n_dirty_errors = 0; - GC_n_faulted_dirty_errors = 0; - GC_n_changed_errors = 0; - GC_n_clean = 0; - GC_n_dirty = 0; - - index = 0; - for (i = 0; i < GC_n_heap_sects; i++) { - start = GC_heap_sects[i].hs_start; - for (h = (struct hblk *)start; - (word)h < (word)(start + GC_heap_sects[i].hs_bytes); h++) { - GC_update_check_page(h, index); - index++; - if (index >= NSUMS) goto out; - } - } -out: - GC_COND_LOG_PRINTF("Checked %lu clean and %lu dirty pages\n", - (unsigned long)GC_n_clean, (unsigned long)GC_n_dirty); - if (GC_n_dirty_errors > 0) { - GC_err_printf("Found %d dirty bit errors (%d were faulted)\n", - GC_n_dirty_errors, GC_n_faulted_dirty_errors); - } - if (GC_n_changed_errors > 0) { - GC_err_printf("Found %lu changed bit errors\n", - (unsigned long)GC_n_changed_errors); - GC_err_printf( - "These may be benign (provoked by nonpointer changes)\n"); -# ifdef THREADS - GC_err_printf( - "Also expect 1 per thread currently allocating a stubborn obj\n"); -# endif - } - for (i = 0; i < GC_n_faulted; ++i) { - GC_faulted[i] = 0; /* Don't expose block pointers to GC */ - } - GC_n_faulted = 0; -} - -#endif /* CHECKSUMS */ diff -Nru ecl-16.1.2/src/bdwgc/CMakeLists.txt ecl-16.1.3+ds/src/bdwgc/CMakeLists.txt --- ecl-16.1.2/src/bdwgc/CMakeLists.txt 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/CMakeLists.txt 1970-01-01 00:00:00.000000000 +0000 @@ -1,230 +0,0 @@ -# -# Copyright (c) 1994 by Xerox Corporation. All rights reserved. -# Copyright (c) 1996 by Silicon Graphics. All rights reserved. -# Copyright (c) 1998 by Fergus Henderson. All rights reserved. -# Copyright (c) 2000-2010 by Hewlett-Packard Company. All rights reserved. -## -# THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED -# OR IMPLIED. ANY USE IS AT YOUR OWN RISK. -## -# Permission is hereby granted to use or copy this program -# for any purpose, provided the above notices are retained on all copies. -# Permission to modify the code and to distribute modified code is granted, -# provided the above notices are retained, and a notice that the code was -# modified is included with the above copyright notice. -## - -# -# get cmake and run: -# cmake -G "Visual Studio 8 2005" -# in the same dir as this file -# this will generate gc.sln -# - -SET(CMAKE_LEGACY_CYGWIN_WIN32 0) # Remove when CMake >= 2.8.4 is required - -PROJECT(gc) - -CMAKE_MINIMUM_REQUIRED(VERSION 2.6) - -ADD_DEFINITIONS("-D_CRT_SECURE_NO_DEPRECATE - -DALL_INTERIOR_POINTERS") - -IF(APPLE) - IF("${CMAKE_OSX_ARCHITECTURES}" STREQUAL "") - SET(CMAKE_OSX_ARCHITECTURES "ppc;i386;x86_64" CACHE STRING "Build architectures for Mac OS X" FORCE) - ENDIF() -ENDIF(APPLE) - -#LIBATOMIC #TODO -#ADD_LIBRARY(atomic_ops STATIC ) -#SET_TARGET_PROPERTIES(atomic_ops PROPERTIES COMPILE_FLAGS -DNO_DEBUGGING) - - -#LIBGC - -INCLUDE_DIRECTORIES(include) -INCLUDE_DIRECTORIES(libatomic_ops/src) - -SET(SRC alloc.c reclaim.c allchblk.c misc.c mach_dep.c os_dep.c - mark_rts.c headers.c mark.c obj_map.c blacklst.c finalize.c - new_hblk.c dbg_mlc.c malloc.c stubborn.c dyn_load.c - typd_mlc.c ptr_chck.c gc_cpp.cc mallocx.c checksums.c - thread_local_alloc.c) -SET(LIBS) -OPTION(enable_threads "TODO" NO) -IF(enable_threads) - FIND_PACKAGE(Threads REQUIRED) - MESSAGE("Thread Model: ${CMAKE_THREAD_LIBS_INIT}" ) - INCLUDE_DIRECTORIES(${Threads_INCLUDE_DIR}) - SET(LIBS ${LIBS} ${Threads_LIBRARIES}) -ENDIF(enable_threads) - -OPTION(enable_parallel_mark "Parallelize marking and free list construction" NO) - -#IF(Threads_FOUND) -# ADD_DEFINITIONS("") -#ELSE -# MESSAGE("Parallel mark requires enable_threads ON" ) -#ENDIF(Threads_FOUND) - -IF(enable_parallel_mark) -ENDIF(enable_parallel_mark) - -OPTION(enable_cplusplus "install C++ support" NO) - -SET(_HOST ${CMAKE_HOST_SYSTEM_PROCESSOR}--${CMAKE_SYSTEM}) #FIXME missing the vendor field.Use lowercase - -STRING(TOLOWER ${_HOST} HOST) -MESSAGE("HOST = ${HOST}") - -#Thread Detection. Relying on cmake for lib an includes. -#TODO check cmake detection -IF(CMAKE_USE_PTHREADS_INIT) - SET(SRC ${SRC} pthread_start.c pthread_support.c pthread_stop_world.c) - IF( "HOST" MATCHES x86-.*-linux.*|ia64-.*-linux.*|i586-.*-linux.*|i686-.*-linux.*|x86_64-.*-linux.*|alpha-.*-linux.*|sparc.*-.*-linux.*) - ADD_DEFINITIONS("-DGC_LINUX_THREADS") - ADD_DEFINITIONS("-D_REENTRANT") - IF (${enable_parallel_mark}) - ADD_DEFINITIONS("-DPARALLEL_MARK") - ENDIF() - ADD_DEFINITIONS("-DTHREAD_LOCAL_ALLOC") - MESSAGE("Explicit GC_INIT() calls may be required.") - ENDIF() - IF ( "HOST" MATCHES .*-.*-linux.*) - ADD_DEFINITIONS("-DGC_LINUX_THREADS") - ADD_DEFINITIONS("-D_REENTRANT") - ENDIF() - IF ( "HOST" MATCHES .*-.*-aix.*) - ADD_DEFINITIONS("-DGC_AIX_THREADS") - ADD_DEFINITIONS("-D_REENTRANT") - ENDIF() - IF ( "HOST" MATCHES .*-.*-hpux11.*) - MESSAGE("Only HP/UX 11 POSIX threads are supported.") - ADD_DEFINITIONS("-DGC_HPUX_THREADS") - ADD_DEFINITIONS("-D_POSIX_C_SOURCE=199506L") #TODO test -DVAR=value. Alternative is COMPILE_DEFINITIONS property - IF (${enable_parallel_mark}) - ADD_DEFINITIONS("-DPARALLEL_MARK") - ENDIF() - MESSAGE("Explicit GC_INIT() calls may be required.") - ADD_DEFINITIONS("-D_REENTRANT") #TODO - ENDIF() - IF ( "HOST" MATCHES .*-.*-hpux10.*) - MESSAGE("Only HP/UX 11 POSIX threads are supported.") - ENDIF() - IF ( "HOST" MATCHES .*-.*-openbsd.*) - ADD_DEFINITIONS("-DGC_OPENBSD_THREADS") - ENDIF() - IF ( "HOST" MATCHES .*-.*-freebsd.*) - MESSAGE("FreeBSD does not yet fully support threads with Boehm GC.") - ADD_DEFINITIONS("-DGC_FREEBSD_THREADS") - ENDIF() - IF ( "HOST" MATCHES .*-.*-kfreebsd.*-gnu) - ADD_DEFINITIONS("-DGC_FREEBSD_THREADS") - ADD_DEFINITIONS("-D_REENTRANT") - IF (${enable_parallel_mark}) - ADD_DEFINITIONS("-DPARALLEL_MARK") - ENDIF() - ADD_DEFINITIONS("-DTHREAD_LOCAL_ALLOC") - ADD_DEFINITIONS("-DUSE_COMPILER_TLS") - ENDIF() - IF ( "HOST" MATCHES .*-.*-gnu.*) - ADD_DEFINITIONS("-DGC_GNU_THREADS") - ADD_DEFINITIONS("-D_REENTRANT") - ADD_DEFINITIONS("-DTHREAD_LOCAL_ALLOC") - ENDIF() - IF ( "HOST" MATCHES .*-.*-netbsd.*) - MESSAGE("Only on NetBSD 2.0 or later.") - ADD_DEFINITIONS("-DGC_NETBSD_THREADS") - ADD_DEFINITIONS("-D_REENTRANT") - ADD_DEFINITIONS("-D_PTHREADS") - ENDIF() - IF ( "HOST" MATCHES .*-.*-solaris.*) - ADD_DEFINITIONS("-DGC_SOLARIS_THREADS") - ADD_DEFINITIONS("-DTHREAD_LOCAL_ALLOC") -#TODO -# if test "$GCC" != yes; then -# CFLAGS="$CFLAGS -O" -# need_atomic_ops_asm=true -# fi - - ENDIF() - IF ( "HOST" MATCHES .*-.*-irix.*) - ADD_DEFINITIONS("-DGC_IRIX_THREADS") - ENDIF() - IF ( "HOST" MATCHES .*-.*-cygwin.*) - ADD_DEFINITIONS("-DGC_THREADS") - IF (${enable_parallel_mark}) - ADD_DEFINITIONS("-DPARALLEL_MARK") - ENDIF() - ADD_DEFINITIONS("-DTHREAD_LOCAL_ALLOC") - -#TODO -# win32_threads=true - ENDIF() - IF ( "HOST" MATCHES .*-.*-darwin.*) - ADD_DEFINITIONS("-DGC_DARWIN_THREADS") - ADD_DEFINITIONS("-DTHREAD_LOCAL_ALLOC") - MESSAGE("Explicit GC_INIT() calls may be required.") - SET(SRC ${SRC} darwin_stop_world.c) - IF (${enable_parallel_mark}) - ADD_DEFINITIONS("-DPARALLEL_MARK") - ENDIF() - #TODO - #darwin_threads=true - ENDIF() - IF ( "HOST" MATCHES .*-.*-osf*) - ADD_DEFINITIONS("-DGC_OSF1_THREADS") - IF (${enable_parallel_mark}) - ADD_DEFINITIONS("-DPARALLEL_MARK") - ADD_DEFINITIONS("-DTHREAD_LOCAL_ALLOC") - MESSAGE("Explicit GC_INIT() calls may be required.") - # May want to enable it in other cases, too. - # Measurements haven't yet been done. - ENDIF() - ENDIF() - IF ( "HOST" MATCHES .*-.*-linux.*) - ADD_DEFINITIONS("-DGC_LINUX_THREADS") - ADD_DEFINITIONS("-D_REENTRANT") - ENDIF() -ENDIF(CMAKE_USE_PTHREADS_INIT) - -IF(CMAKE_USE_WIN32_THREADS_INIT) - ADD_DEFINITIONS("-DGC_THREADS") - #win32_threads=true TODO - IF (${enable_parallel_mark}) - ADD_DEFINITIONS("-DPARALLEL_MARK") - ADD_DEFINITIONS("-DTHREAD_LOCAL_ALLOC") - ENDIF() - ADD_DEFINITIONS("-DEMPTY_GETENV_RESULTS") #TODO test - SET(SRC ${SRC} win32_threads.c) -ENDIF(CMAKE_USE_WIN32_THREADS_INIT) - -OPTION(enable_gcj_support "Support for gcj" NO) -IF(enable_gcj_support) - ADD_DEFINITIONS("-DGC_GCJ_SUPPORT") -ENDIF(enable_gcj_support) - - -ADD_LIBRARY( gc-lib STATIC ${SRC}) -SET_TARGET_PROPERTIES(gc-lib PROPERTIES - COMPILE_DEFINITIONS GC_NOT_DLL) -#TODO TARGET_LINK_LIBRARIES(... ... ${LIBS}) - -ADD_LIBRARY( gcmt-lib STATIC ${SRC}) -SET_TARGET_PROPERTIES(gcmt-lib PROPERTIES - COMPILE_DEFINITIONS GC_NOT_DLL) - -ADD_LIBRARY( gcmt-dll SHARED ${SRC}) - -IF(WIN32) - ADD_EXECUTABLE(cord cord/cordbscs.c cord/cordxtra.c - cord/tests/de.c cord/tests/de_win.c) - SET_TARGET_PROPERTIES(cord PROPERTIES WIN32_EXECUTABLE TRUE) - SET_TARGET_PROPERTIES(cord PROPERTIES - COMPILE_DEFINITIONS GC_NOT_DLL) - TARGET_LINK_LIBRARIES(cord gc-lib) - TARGET_LINK_LIBRARIES(cord gdi32) -ENDIF(WIN32) - -ADD_SUBDIRECTORY(tests) diff -Nru ecl-16.1.2/src/bdwgc/compile ecl-16.1.3+ds/src/bdwgc/compile --- ecl-16.1.2/src/bdwgc/compile 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/compile 1970-01-01 00:00:00.000000000 +0000 @@ -1,347 +0,0 @@ -#! /bin/sh -# Wrapper for compilers which do not understand '-c -o'. - -scriptversion=2012-10-14.11; # UTC - -# Copyright (C) 1999-2014 Free Software Foundation, Inc. -# Written by Tom Tromey . -# -# 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, see . - -# 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. - -# This file is maintained in Automake, please report -# bugs to or send patches to -# . - -nl=' -' - -# We need space, tab and new line, in precisely that order. Quoting is -# there to prevent tools from complaining about whitespace usage. -IFS=" "" $nl" - -file_conv= - -# func_file_conv build_file lazy -# Convert a $build file to $host form and store it in $file -# Currently only supports Windows hosts. If the determined conversion -# type is listed in (the comma separated) LAZY, no conversion will -# take place. -func_file_conv () -{ - file=$1 - case $file in - / | /[!/]*) # absolute file, and not a UNC file - if test -z "$file_conv"; then - # lazily determine how to convert abs files - case `uname -s` in - MINGW*) - file_conv=mingw - ;; - CYGWIN*) - file_conv=cygwin - ;; - *) - file_conv=wine - ;; - esac - fi - case $file_conv/,$2, in - *,$file_conv,*) - ;; - mingw/*) - file=`cmd //C echo "$file " | sed -e 's/"\(.*\) " *$/\1/'` - ;; - cygwin/*) - file=`cygpath -m "$file" || echo "$file"` - ;; - wine/*) - file=`winepath -w "$file" || echo "$file"` - ;; - esac - ;; - esac -} - -# func_cl_dashL linkdir -# Make cl look for libraries in LINKDIR -func_cl_dashL () -{ - func_file_conv "$1" - if test -z "$lib_path"; then - lib_path=$file - else - lib_path="$lib_path;$file" - fi - linker_opts="$linker_opts -LIBPATH:$file" -} - -# func_cl_dashl library -# Do a library search-path lookup for cl -func_cl_dashl () -{ - lib=$1 - found=no - save_IFS=$IFS - IFS=';' - for dir in $lib_path $LIB - do - IFS=$save_IFS - if $shared && test -f "$dir/$lib.dll.lib"; then - found=yes - lib=$dir/$lib.dll.lib - break - fi - if test -f "$dir/$lib.lib"; then - found=yes - lib=$dir/$lib.lib - break - fi - if test -f "$dir/lib$lib.a"; then - found=yes - lib=$dir/lib$lib.a - break - fi - done - IFS=$save_IFS - - if test "$found" != yes; then - lib=$lib.lib - fi -} - -# func_cl_wrapper cl arg... -# Adjust compile command to suit cl -func_cl_wrapper () -{ - # Assume a capable shell - lib_path= - shared=: - linker_opts= - for arg - do - if test -n "$eat"; then - eat= - else - case $1 in - -o) - # configure might choose to run compile as 'compile cc -o foo foo.c'. - eat=1 - case $2 in - *.o | *.[oO][bB][jJ]) - func_file_conv "$2" - set x "$@" -Fo"$file" - shift - ;; - *) - func_file_conv "$2" - set x "$@" -Fe"$file" - shift - ;; - esac - ;; - -I) - eat=1 - func_file_conv "$2" mingw - set x "$@" -I"$file" - shift - ;; - -I*) - func_file_conv "${1#-I}" mingw - set x "$@" -I"$file" - shift - ;; - -l) - eat=1 - func_cl_dashl "$2" - set x "$@" "$lib" - shift - ;; - -l*) - func_cl_dashl "${1#-l}" - set x "$@" "$lib" - shift - ;; - -L) - eat=1 - func_cl_dashL "$2" - ;; - -L*) - func_cl_dashL "${1#-L}" - ;; - -static) - shared=false - ;; - -Wl,*) - arg=${1#-Wl,} - save_ifs="$IFS"; IFS=',' - for flag in $arg; do - IFS="$save_ifs" - linker_opts="$linker_opts $flag" - done - IFS="$save_ifs" - ;; - -Xlinker) - eat=1 - linker_opts="$linker_opts $2" - ;; - -*) - set x "$@" "$1" - shift - ;; - *.cc | *.CC | *.cxx | *.CXX | *.[cC]++) - func_file_conv "$1" - set x "$@" -Tp"$file" - shift - ;; - *.c | *.cpp | *.CPP | *.lib | *.LIB | *.Lib | *.OBJ | *.obj | *.[oO]) - func_file_conv "$1" mingw - set x "$@" "$file" - shift - ;; - *) - set x "$@" "$1" - shift - ;; - esac - fi - shift - done - if test -n "$linker_opts"; then - linker_opts="-link$linker_opts" - fi - exec "$@" $linker_opts - exit 1 -} - -eat= - -case $1 in - '') - echo "$0: No command. Try '$0 --help' for more information." 1>&2 - exit 1; - ;; - -h | --h*) - cat <<\EOF -Usage: compile [--help] [--version] PROGRAM [ARGS] - -Wrapper for compilers which do not understand '-c -o'. -Remove '-o dest.o' from ARGS, run PROGRAM with the remaining -arguments, and rename the output as expected. - -If you are trying to build a whole package this is not the -right script to run: please start by reading the file 'INSTALL'. - -Report bugs to . -EOF - exit $? - ;; - -v | --v*) - echo "compile $scriptversion" - exit $? - ;; - cl | *[/\\]cl | cl.exe | *[/\\]cl.exe ) - func_cl_wrapper "$@" # Doesn't return... - ;; -esac - -ofile= -cfile= - -for arg -do - if test -n "$eat"; then - eat= - else - case $1 in - -o) - # configure might choose to run compile as 'compile cc -o foo foo.c'. - # So we strip '-o arg' only if arg is an object. - eat=1 - case $2 in - *.o | *.obj) - ofile=$2 - ;; - *) - set x "$@" -o "$2" - shift - ;; - esac - ;; - *.c) - cfile=$1 - set x "$@" "$1" - shift - ;; - *) - set x "$@" "$1" - shift - ;; - esac - fi - shift -done - -if test -z "$ofile" || test -z "$cfile"; then - # If no '-o' option was seen then we might have been invoked from a - # pattern rule where we don't need one. That is ok -- this is a - # normal compilation that the losing compiler can handle. If no - # '.c' file was seen then we are probably linking. That is also - # ok. - exec "$@" -fi - -# Name of file we expect compiler to create. -cofile=`echo "$cfile" | sed 's|^.*[\\/]||; s|^[a-zA-Z]:||; s/\.c$/.o/'` - -# Create the lock directory. -# Note: use '[/\\:.-]' here to ensure that we don't use the same name -# that we are using for the .o file. Also, base the name on the expected -# object file name, since that is what matters with a parallel build. -lockdir=`echo "$cofile" | sed -e 's|[/\\:.-]|_|g'`.d -while true; do - if mkdir "$lockdir" >/dev/null 2>&1; then - break - fi - sleep 1 -done -# FIXME: race condition here if user kills between mkdir and trap. -trap "rmdir '$lockdir'; exit 1" 1 2 15 - -# Run the compile. -"$@" -ret=$? - -if test -f "$cofile"; then - test "$cofile" = "$ofile" || mv "$cofile" "$ofile" -elif test -f "${cofile}bj"; then - test "${cofile}bj" = "$ofile" || mv "${cofile}bj" "$ofile" -fi - -rmdir "$lockdir" -exit $ret - -# Local Variables: -# mode: shell-script -# sh-indentation: 2 -# eval: (add-hook 'write-file-hooks 'time-stamp) -# time-stamp-start: "scriptversion=" -# time-stamp-format: "%:y-%02m-%02d.%02H" -# time-stamp-time-zone: "UTC" -# time-stamp-end: "; # UTC" -# End: diff -Nru ecl-16.1.2/src/bdwgc/config.guess ecl-16.1.3+ds/src/bdwgc/config.guess --- ecl-16.1.2/src/bdwgc/config.guess 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/config.guess 1970-01-01 00:00:00.000000000 +0000 @@ -1,1421 +0,0 @@ -#! /bin/sh -# Attempt to guess a canonical system name. -# Copyright 1992-2014 Free Software Foundation, Inc. - -timestamp='2014-11-04' - -# 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 3 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, see . -# -# 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. This Exception is an additional permission under section 7 -# of the GNU General Public License, version 3 ("GPLv3"). -# -# Originally written by Per Bothner; maintained since 2000 by Ben Elliston. -# -# You can get the latest version of this script from: -# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD -# -# Please send patches to . - - -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 1992-2014 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 - -case "${UNAME_SYSTEM}" in -Linux|GNU|GNU/*) - # If the system lacks a compiler, then just pick glibc. - # We could probably try harder. - LIBC=gnu - - eval $set_cc_for_build - cat <<-EOF > $dummy.c - #include - #if defined(__UCLIBC__) - LIBC=uclibc - #elif defined(__dietlibc__) - LIBC=dietlibc - #else - LIBC=gnu - #endif - EOF - eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC' | sed 's, ,,g'` - ;; -esac - -# 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 tuples: *-*-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 ;; - *:Bitrig:*:*) - UNAME_MACHINE_ARCH=`arch | sed 's/Bitrig.//'` - echo ${UNAME_MACHINE_ARCH}-unknown-bitrig${UNAME_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'` - # Reset EXIT trap before exiting to avoid spurious non-zero exit code. - exitcode=$? - trap '' 0 - exit $exitcode ;; - 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:AuroraUX:5.*:* | i86xen:AuroraUX:5.*:*) - echo i386-pc-auroraux${UNAME_RELEASE} - 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:*:[4567]) - 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/lslpp ] ; then - IBM_REV=`/usr/bin/lslpp -Lqc bos.rte.libc | - awk -F: '{ print $3 }' | sed s/[0-9]*$/0/` - 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:*:*) - UNAME_PROCESSOR=`/usr/bin/uname -p` - case ${UNAME_PROCESSOR} in - amd64) - echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; - *) - echo ${UNAME_PROCESSOR}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; - esac - exit ;; - i*:CYGWIN*:*) - echo ${UNAME_MACHINE}-pc-cygwin - exit ;; - *:MINGW64*:*) - echo ${UNAME_MACHINE}-pc-mingw64 - exit ;; - *:MINGW*:*) - echo ${UNAME_MACHINE}-pc-mingw32 - exit ;; - *:MSYS*:*) - echo ${UNAME_MACHINE}-pc-msys - exit ;; - i*:windows32*:*) - # uname -m includes "-pc" on this system. - echo ${UNAME_MACHINE}-mingw32 - exit ;; - i*:PW*:*) - echo ${UNAME_MACHINE}-pc-pw32 - exit ;; - *:Interix*:*) - case ${UNAME_MACHINE} in - x86) - echo i586-pc-interix${UNAME_RELEASE} - exit ;; - authenticamd | genuineintel | EM64T) - 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-${LIBC}`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/[-(].*//'`-${LIBC} - exit ;; - i*86:Minix:*:*) - echo ${UNAME_MACHINE}-pc-minix - exit ;; - aarch64:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - aarch64_be:Linux:*:*) - UNAME_MACHINE=aarch64_be - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - 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="gnulibc1" ; fi - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - arc:Linux:*:* | arceb:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - 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-${LIBC} - else - if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \ - | grep -q __ARM_PCS_VFP - then - echo ${UNAME_MACHINE}-unknown-linux-${LIBC}eabi - else - echo ${UNAME_MACHINE}-unknown-linux-${LIBC}eabihf - fi - fi - exit ;; - avr32*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - cris:Linux:*:*) - echo ${UNAME_MACHINE}-axis-linux-${LIBC} - exit ;; - crisv32:Linux:*:*) - echo ${UNAME_MACHINE}-axis-linux-${LIBC} - exit ;; - frv:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - hexagon:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - i*86:Linux:*:*) - echo ${UNAME_MACHINE}-pc-linux-${LIBC} - exit ;; - ia64:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - m32r*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - m68*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - 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 | grep '^CPU'` - test x"${CPU}" != x && { echo "${CPU}-unknown-linux-${LIBC}"; exit; } - ;; - openrisc*:Linux:*:*) - echo or1k-unknown-linux-${LIBC} - exit ;; - or32:Linux:*:* | or1k*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - padre:Linux:*:*) - echo sparc-unknown-linux-${LIBC} - exit ;; - parisc64:Linux:*:* | hppa64:Linux:*:*) - echo hppa64-unknown-linux-${LIBC} - 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-${LIBC} ;; - PA8*) echo hppa2.0-unknown-linux-${LIBC} ;; - *) echo hppa-unknown-linux-${LIBC} ;; - esac - exit ;; - ppc64:Linux:*:*) - echo powerpc64-unknown-linux-${LIBC} - exit ;; - ppc:Linux:*:*) - echo powerpc-unknown-linux-${LIBC} - exit ;; - ppc64le:Linux:*:*) - echo powerpc64le-unknown-linux-${LIBC} - exit ;; - ppcle:Linux:*:*) - echo powerpcle-unknown-linux-${LIBC} - exit ;; - s390:Linux:*:* | s390x:Linux:*:*) - echo ${UNAME_MACHINE}-ibm-linux-${LIBC} - exit ;; - sh64*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - sh*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - sparc:Linux:*:* | sparc64:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - tile*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - vax:Linux:*:*) - echo ${UNAME_MACHINE}-dec-linux-${LIBC} - exit ;; - x86_64:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - xtensa*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - 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 ;; - x86_64:Haiku:*:*) - echo x86_64-unknown-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 - eval $set_cc_for_build - if test "$UNAME_PROCESSOR" = unknown ; then - UNAME_PROCESSOR=powerpc - fi - if test `echo "$UNAME_RELEASE" | sed -e 's/\..*//'` -le 10 ; then - if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then - if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \ - (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ - grep IS_64BIT_ARCH >/dev/null - then - case $UNAME_PROCESSOR in - i386) UNAME_PROCESSOR=x86_64 ;; - powerpc) UNAME_PROCESSOR=powerpc64 ;; - esac - fi - fi - elif test "$UNAME_PROCESSOR" = i386 ; then - # Avoid executing cc on OS X 10.9, as it ships with a stub - # that puts up a graphical alert prompting to install - # developer tools. Any system running Mac OS X 10.7 or - # later (Darwin 11 and later) is required to have a 64-bit - # processor. This is not true of the ARM version of Darwin - # that Apple uses in portable devices. - UNAME_PROCESSOR=x86_64 - fi - 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 ;; - NEO-?:NONSTOP_KERNEL:*:*) - echo neo-tandem-nsk${UNAME_RELEASE} - 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 ;; - x86_64:VMkernel:*:*) - echo ${UNAME_MACHINE}-unknown-esx - exit ;; -esac - -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: diff -Nru ecl-16.1.2/src/bdwgc/config.sub ecl-16.1.3+ds/src/bdwgc/config.sub --- ecl-16.1.2/src/bdwgc/config.sub 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/config.sub 1970-01-01 00:00:00.000000000 +0000 @@ -1,1807 +0,0 @@ -#! /bin/sh -# Configuration validation subroutine script. -# Copyright 1992-2014 Free Software Foundation, Inc. - -timestamp='2014-12-03' - -# 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 3 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, see . -# -# 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. This Exception is an additional permission under section 7 -# of the GNU General Public License, version 3 ("GPLv3"). - - -# Please send patches to . -# -# 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. - -# You can get the latest version of this script from: -# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub;hb=HEAD - -# 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 1992-2014 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-android* | linux-dietlibc | linux-newlib* | \ - linux-musl* | 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/'` - ;; - android-linux) - os=-linux-android - basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`-unknown - ;; - *) - 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 | -microblaze*) - 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*178) - os=-lynxos178 - ;; - -lynx*5) - os=-lynxos5 - ;; - -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 \ - | aarch64 | aarch64_be \ - | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ - | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ - | am33_2.0 \ - | arc | arceb \ - | arm | arm[bl]e | arme[lb] | armv[2-8] | armv[3-8][lb] | armv7[arm] \ - | avr | avr32 \ - | be32 | be64 \ - | bfin \ - | c4x | c8051 | clipper \ - | d10v | d30v | dlx | dsp16xx \ - | epiphany \ - | fido | fr30 | frv \ - | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ - | hexagon \ - | i370 | i860 | i960 | ia64 \ - | ip2k | iq2000 \ - | k1om \ - | le32 | le64 \ - | lm32 \ - | m32c | m32r | m32rle | m68000 | m68k | m88k \ - | maxq | mb | microblaze | microblazeel | 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 \ - | mipsisa32r6 | mipsisa32r6el \ - | mipsisa64 | mipsisa64el \ - | mipsisa64r2 | mipsisa64r2el \ - | mipsisa64r6 | mipsisa64r6el \ - | mipsisa64sb1 | mipsisa64sb1el \ - | mipsisa64sr71k | mipsisa64sr71kel \ - | mipsr5900 | mipsr5900el \ - | mipstx39 | mipstx39el \ - | mn10200 | mn10300 \ - | moxie \ - | mt \ - | msp430 \ - | nds32 | nds32le | nds32be \ - | nios | nios2 | nios2eb | nios2el \ - | ns16k | ns32k \ - | open8 | or1k | or1knd | or32 \ - | pdp10 | pdp11 | pj | pjl \ - | powerpc | powerpc64 | powerpc64le | powerpcle \ - | pyramid \ - | riscv32 | riscv64 \ - | rl78 | rx \ - | 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 \ - | tahoe | tic4x | tic54x | tic55x | tic6x | tic80 | tron \ - | ubicom32 \ - | v850 | v850e | v850e1 | v850e2 | v850es | v850e2v3 \ - | visium \ - | we32k \ - | x86 | xc16x | xstormy16 | xtensa \ - | z8k | z80) - basic_machine=$basic_machine-unknown - ;; - c54x) - basic_machine=tic54x-unknown - ;; - c55x) - basic_machine=tic55x-unknown - ;; - c6x) - basic_machine=tic6x-unknown - ;; - leon|leon[3-9]) - basic_machine=sparc-$basic_machine - ;; - m6811 | m68hc11 | m6812 | m68hc12 | m68hcs12x | nvptx | picochip) - basic_machine=$basic_machine-unknown - os=-none - ;; - m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k) - ;; - ms1) - basic_machine=mt-unknown - ;; - - strongarm | thumb | xscale) - basic_machine=arm-unknown - ;; - xgate) - basic_machine=$basic_machine-unknown - os=-none - ;; - xscaleeb) - basic_machine=armeb-unknown - ;; - - xscaleel) - basic_machine=armel-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-* \ - | aarch64-* | aarch64_be-* \ - | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ - | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ - | alphapca5[67]-* | alpha64pca5[67]-* | arc-* | arceb-* \ - | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ - | avr-* | avr32-* \ - | be32-* | be64-* \ - | bfin-* | bs2000-* \ - | c[123]* | c30-* | [cjt]90-* | c4x-* \ - | c8051-* | 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-* \ - | hexagon-* \ - | i*86-* | i860-* | i960-* | ia64-* \ - | ip2k-* | iq2000-* \ - | k1om-* \ - | le32-* | le64-* \ - | lm32-* \ - | m32c-* | m32r-* | m32rle-* \ - | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ - | m88110-* | m88k-* | maxq-* | mcore-* | metag-* \ - | microblaze-* | microblazeel-* \ - | 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-* \ - | mipsisa32r6-* | mipsisa32r6el-* \ - | mipsisa64-* | mipsisa64el-* \ - | mipsisa64r2-* | mipsisa64r2el-* \ - | mipsisa64r6-* | mipsisa64r6el-* \ - | mipsisa64sb1-* | mipsisa64sb1el-* \ - | mipsisa64sr71k-* | mipsisa64sr71kel-* \ - | mipsr5900-* | mipsr5900el-* \ - | mipstx39-* | mipstx39el-* \ - | mmix-* \ - | mt-* \ - | msp430-* \ - | nds32-* | nds32le-* | nds32be-* \ - | nios-* | nios2-* | nios2eb-* | nios2el-* \ - | none-* | np1-* | ns16k-* | ns32k-* \ - | open8-* \ - | or1k*-* \ - | orion-* \ - | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ - | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* \ - | pyramid-* \ - | rl78-* | romp-* | rs6000-* | rx-* \ - | 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-* | sv1-* | sx?-* \ - | tahoe-* \ - | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \ - | tile*-* \ - | tron-* \ - | ubicom32-* \ - | v850-* | v850e-* | v850e1-* | v850es-* | v850e2-* | v850e2v3-* \ - | vax-* \ - | visium-* \ - | we32k-* \ - | x86-* | x86_64-* | xc16x-* | xps100-* \ - | 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 - ;; - c54x-*) - basic_machine=tic54x-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - c55x-*) - basic_machine=tic55x-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - c6x-*) - basic_machine=tic6x-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - 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 | 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*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 - ;; - leon-*|leon[3-9]-*) - basic_machine=sparc-`echo $basic_machine | sed 's/-.*//'` - ;; - 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 - ;; - microblaze*) - basic_machine=microblaze-xilinx - ;; - mingw64) - basic_machine=x86_64-pc - os=-mingw64 - ;; - mingw32) - basic_machine=i686-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 - ;; - moxiebox) - basic_machine=moxie-unknown - os=-moxiebox - ;; - msdos) - basic_machine=i386-pc - os=-msdos - ;; - ms1-*) - basic_machine=`echo $basic_machine | sed -e 's/ms1-/mt-/'` - ;; - msys) - basic_machine=i686-pc - os=-msys - ;; - mvs) - basic_machine=i370-ibm - os=-mvs - ;; - nacl) - basic_machine=le32-unknown - os=-nacl - ;; - 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 - ;; - neo-tandem) - basic_machine=neo-tandem - ;; - nse-tandem) - basic_machine=nse-tandem - ;; - 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 | ppcbe) basic_machine=powerpc-unknown - ;; - ppc-* | ppcbe-*) - 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 | rdos64) - basic_machine=x86_64-pc - os=-rdos - ;; - rdos32) - 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 - ;; - strongarm-* | thumb-*) - basic_machine=arm-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - 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 - ;; - tile*) - basic_machine=$basic_machine-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 - ;; - xscale-* | xscalee[bl]-*) - basic_machine=`echo $basic_machine | sed 's/^xscale/arm/'` - ;; - 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. - -auroraux) - os=-auroraux - ;; - -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* | -auroraux* | -solaris* \ - | -sym* | -kopensolaris* | -plan9* \ - | -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* \ - | -bitrig* | -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* | -msys* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ - | -mingw32* | -mingw64* | -linux-gnu* | -linux-android* \ - | -linux-newlib* | -linux-musl* | -linux-uclibc* \ - | -uxpv* | -beos* | -mpeix* | -udk* | -moxiebox* \ - | -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* | -es* | -tirtos*) - # 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 - ;; - -zvmoe) - os=-zvmoe - ;; - -dicos*) - os=-dicos - ;; - -nacl*) - ;; - -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 - ;; - c8051-*) - os=-elf - ;; - hexagon-*) - os=-elf - ;; - tic54x-*) - os=-coff - ;; - tic55x-*) - os=-coff - ;; - tic6x-*) - 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 - ;; - 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: diff -Nru ecl-16.1.2/src/bdwgc/configure ecl-16.1.3+ds/src/bdwgc/configure --- ecl-16.1.2/src/bdwgc/configure 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/configure 1970-01-01 00:00:00.000000000 +0000 @@ -1,20486 +0,0 @@ -#! /bin/sh -# Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.69 for gc 7.5.0. -# -# Report bugs to . -# -# -# Copyright (C) 1992-1996, 1998-2012 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. -as_myself= -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 - -# Use a proper internal environment variable to ensure we don't fall - # into an infinite loop, continuously re-executing ourselves. - if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then - _as_can_reexec=no; export _as_can_reexec; - # 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. -# Preserve -v and -x to the replacement shell. -BASH_ENV=/dev/null -ENV=/dev/null -(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV -case $- in # (((( - *v*x* | *x*v* ) as_opts=-vx ;; - *v* ) as_opts=-v ;; - *x* ) as_opts=-x ;; - * ) as_opts= ;; -esac -exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} -# Admittedly, this is quite paranoid, since all the known shells bail -# out after a failed `exec'. -$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 -as_fn_exit 255 - fi - # We don't want this to propagate to other subprocesses. - { _as_can_reexec=; unset _as_can_reexec;} -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 -test -x / || 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 -n \"\${ZSH_VERSION+set}\${BASH_VERSION+set}\" || ( - ECHO='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' - ECHO=\$ECHO\$ECHO\$ECHO\$ECHO\$ECHO - ECHO=\$ECHO\$ECHO\$ECHO\$ECHO\$ECHO\$ECHO - PATH=/empty FPATH=/empty; export PATH FPATH - test \"X\`printf %s \$ECHO\`\" = \"X\$ECHO\" \\ - || test \"X\`print -r -- \$ECHO\`\" = \"X\$ECHO\" ) || 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 : - export CONFIG_SHELL - # 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. -# Preserve -v and -x to the replacement shell. -BASH_ENV=/dev/null -ENV=/dev/null -(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV -case $- in # (((( - *v*x* | *x*v* ) as_opts=-vx ;; - *v* ) as_opts=-v ;; - *x* ) as_opts=-x ;; - * ) as_opts= ;; -esac -exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} -# Admittedly, this is quite paranoid, since all the known shells bail -# out after a failed `exec'. -$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 -exit 255 -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 and -$0: bdwgc@lists.opendylan.org about your system, including -$0: any error possibly output before this message. Then -$0: install a modern shell, or manually run the script -$0: 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_executable_p FILE -# ----------------------- -# Test if FILE is an executable regular file. -as_fn_executable_p () -{ - test -f "$1" && test -x "$1" -} # as_fn_executable_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 STATUS 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=$1; test $as_status -eq 0 && as_status=1 - if test "$4"; then - as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 - fi - $as_echo "$as_me: error: $2" >&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; } - - # If we had to re-execute with $CONFIG_SHELL, we're ensured to have - # already done that, so ensure we don't try to do so again and fall - # in an infinite loop. This has already happened in practice. - _as_can_reexec=no; export _as_can_reexec - # 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 -pR'. - ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || - as_ln_s='cp -pR' - elif ln conf$$.file conf$$ 2>/dev/null; then - as_ln_s=ln - else - as_ln_s='cp -pR' - fi -else - as_ln_s='cp -pR' -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 - -as_test_x='test -x' -as_executable_p=as_fn_executable_p - -# 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'" - -SHELL=${CONFIG_SHELL-/bin/sh} - - -test -n "$DJDIR" || exec 7<&0 &1 - -# Name of the host. -# hostname on some systems (SVR3.2, old GNU/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='gc' -PACKAGE_TARNAME='gc' -PACKAGE_VERSION='7.5.0' -PACKAGE_STRING='gc 7.5.0' -PACKAGE_BUGREPORT='bdwgc@lists.opendylan.org' -PACKAGE_URL='' - -ac_unique_file="gcj_mlc.c" -# 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" - -enable_option_checking=no -ac_subst_vars='am__EXEEXT_FALSE -am__EXEEXT_TRUE -LTLIBOBJS -LIBOBJS -NEED_ATOMIC_OPS_ASM_FALSE -NEED_ATOMIC_OPS_ASM_TRUE -USE_INTERNAL_LIBATOMIC_OPS_FALSE -USE_INTERNAL_LIBATOMIC_OPS_TRUE -subdirs -ATOMIC_OPS_LIBS -ATOMIC_OPS_CFLAGS -PKG_CONFIG_LIBDIR -PKG_CONFIG_PATH -PKG_CONFIG -SINGLE_GC_OBJ_FALSE -SINGLE_GC_OBJ_TRUE -USE_LIBDIR_FALSE -USE_LIBDIR_TRUE -UNWINDLIBS -ENABLE_DISCLAIM_FALSE -ENABLE_DISCLAIM_TRUE -KEEP_BACK_PTRS_FALSE -KEEP_BACK_PTRS_TRUE -MAKE_BACK_GRAPH_FALSE -MAKE_BACK_GRAPH_TRUE -addlibs -addobjs -CXXLIBS -AM_CPPFLAGS -AM_CFLAGS -CPLUSPLUS_FALSE -CPLUSPLUS_TRUE -target_all -EXTRA_TEST_LIBS -extra_ldflags_libgc -AVOID_CPP_LIB_FALSE -AVOID_CPP_LIB_TRUE -ASM_WITH_CPP_UNSUPPORTED_FALSE -ASM_WITH_CPP_UNSUPPORTED_TRUE -WIN32_THREADS_FALSE -WIN32_THREADS_TRUE -DARWIN_THREADS_FALSE -DARWIN_THREADS_TRUE -PTHREADS_FALSE -PTHREADS_TRUE -THREADS_FALSE -THREADS_TRUE -THREADDLLIBS -GC_CFLAGS -CXXCPP -CPP -LT_SYS_LIBRARY_PATH -OTOOL64 -OTOOL -LIPO -NMEDIT -DSYMUTIL -MANIFEST_TOOL -RANLIB -ac_ct_AR -AR -DLLTOOL -OBJDUMP -LN_S -NM -ac_ct_DUMPBIN -DUMPBIN -LD -FGREP -EGREP -GREP -SED -LIBTOOL -am__fastdepCCAS_FALSE -am__fastdepCCAS_TRUE -CCASDEPMODE -CCASFLAGS -CCAS -am__fastdepCXX_FALSE -am__fastdepCXX_TRUE -CXXDEPMODE -ac_ct_CXX -CXXFLAGS -CXX -am__fastdepCC_FALSE -am__fastdepCC_TRUE -CCDEPMODE -am__nodep -AMDEPBACKSLASH -AMDEP_FALSE -AMDEP_TRUE -am__quote -am__include -DEPDIR -OBJEXT -EXEEXT -ac_ct_CC -CPPFLAGS -LDFLAGS -CFLAGS -CC -GC_VERSION -MAINT -MAINTAINER_MODE_FALSE -MAINTAINER_MODE_TRUE -AM_BACKSLASH -AM_DEFAULT_VERBOSITY -AM_DEFAULT_V -AM_V -am__untar -am__tar -AMTAR -am__leading_dot -SET_MAKE -AWK -mkdir_p -MKDIR_P -INSTALL_STRIP_PROGRAM -STRIP -install_sh -MAKEINFO -AUTOHEADER -AUTOMAKE -AUTOCONF -ACLOCAL -VERSION -PACKAGE -CYGPATH_W -am__isrc -INSTALL_DATA -INSTALL_SCRIPT -INSTALL_PROGRAM -target_os -target_vendor -target_cpu -target -host_os -host_vendor -host_cpu -host -build_os -build_vendor -build_cpu -build -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_silent_rules -enable_maintainer_mode -enable_dependency_tracking -enable_shared -enable_static -with_pic -enable_fast_install -with_aix_soname -with_gnu_ld -with_sysroot -enable_libtool_lock -enable_threads -enable_parallel_mark -enable_cplusplus -with_ecos -with_target_subdir -with_cross_host -enable_gcj_support -enable_sigrt_signals -enable_gc_debug -enable_java_finalization -enable_atomic_uncollectable -enable_redirect_malloc -enable_disclaim -enable_large_config -enable_handle_fork -enable_gc_assertions -enable_munmap -enable_single_obj_compilation -with_libatomic_ops -' - ac_precious_vars='build_alias -host_alias -target_alias -CC -CFLAGS -LDFLAGS -LIBS -CPPFLAGS -CXX -CXXFLAGS -CCC -CCAS -CCASFLAGS -LT_SYS_LIBRARY_PATH -CPP -CXXCPP -PKG_CONFIG -PKG_CONFIG_PATH -PKG_CONFIG_LIBDIR -ATOMIC_OPS_CFLAGS -ATOMIC_OPS_LIBS' -ac_subdirs_all='libatomic_ops' - -# 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_TARNAME}' -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= ;; - *) 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 - 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 gc 7.5.0 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/gc] - --htmldir=DIR html documentation [DOCDIR] - --dvidir=DIR dvi documentation [DOCDIR] - --pdfdir=DIR pdf documentation [DOCDIR] - --psdir=DIR ps documentation [DOCDIR] -_ACEOF - - cat <<\_ACEOF - -Program names: - --program-prefix=PREFIX prepend PREFIX to installed program names - --program-suffix=SUFFIX append SUFFIX to installed program names - --program-transform-name=PROGRAM run sed PROGRAM on installed program names - -System types: - --build=BUILD configure for building on BUILD [guessed] - --host=HOST cross-compile to build programs to run on HOST [BUILD] - --target=TARGET configure for building compilers for TARGET [HOST] -_ACEOF -fi - -if test -n "$ac_init_help"; then - case $ac_init_help in - short | recursive ) echo "Configuration of gc 7.5.0:";; - esac - 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-silent-rules less verbose build output (undo: "make V=1") - --disable-silent-rules verbose build output (undo: "make V=0") - --enable-maintainer-mode - enable make rules and dependencies not useful (and - sometimes confusing) to the casual installer - --enable-dependency-tracking - do not reject slow dependency extractors - --disable-dependency-tracking - speeds up one-time build - --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) - --enable-threads=TYPE choose threading package - --enable-parallel-mark parallelize marking and free list construction - --enable-cplusplus install C++ support - --disable-gcj-support Disable support for gcj. - --enable-sigrt-signals Force GC to use SIGRTMIN-based signals for thread - suspend/resume - --enable-gc-debug include full support for pointer backtracing etc. - --disable-java-finalization - Disable support for java finalization. - --disable-atomic-uncollectible - Disable support for atomic uncollectible allocation. - --enable-redirect-malloc - Redirect malloc and friends to GC routines - --disable-disclaim Disable alternative (more efficient) finalization - interface. - --enable-large-config Optimize for large (> 100 MB) heap or root set - --enable-handle-fork Attempt to ensure a usable collector after fork() in - multi-threaded programs. - --enable-gc-assertions collector-internal assertion checking - --enable-munmap=N return page to the os if empty for N collections - --enable-single-obj-compilation - Compile all library .c files into single .o - -Optional Packages: - --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] - --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) - --with-pic[=PKGS] try to use only PIC/non-PIC objects [default=use - both] - --with-aix-soname=aix|svr4|both - shared library versioning (aka "SONAME") variant to - provide on AIX, [default=aix]. - --with-gnu-ld assume the C compiler uses GNU ld [default=no] - --with-sysroot[=DIR] Search for dependent libraries within DIR (or the - compiler's sysroot if not specified). - --with-ecos enable runtime eCos target support - --with-target-subdir=SUBDIR - configuring with a cross compiler - --with-cross-host=HOST configuring with a cross compiler - --with-libatomic-ops=yes|no|check - Use a external libatomic_ops? (default: check) - -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 (Objective) C/C++ preprocessor flags, e.g. -I if - you have headers in a nonstandard directory - CXX C++ compiler command - CXXFLAGS C++ compiler flags - CCAS assembler compiler command (defaults to CC) - CCASFLAGS assembler compiler flags (defaults to CFLAGS) - LT_SYS_LIBRARY_PATH - User-defined run-time library search path. - CPP C preprocessor - CXXCPP C++ preprocessor - PKG_CONFIG path to pkg-config utility - PKG_CONFIG_PATH - directories to add to pkg-config's search path - PKG_CONFIG_LIBDIR - path overriding pkg-config's built-in search path - ATOMIC_OPS_CFLAGS - C compiler flags for ATOMIC_OPS, overriding pkg-config - ATOMIC_OPS_LIBS - linker flags for ATOMIC_OPS, 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 . -_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 -gc configure 7.5.0 -generated by GNU Autoconf 2.69 - -Copyright (C) 2012 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; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_c_try_compile - -# ac_fn_cxx_try_compile LINENO -# ---------------------------- -# Try to compile conftest.$ac_ext, and return whether this succeeded. -ac_fn_cxx_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_cxx_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; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_cxx_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 || - 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; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $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 eval \${$3+:} false; 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; ${as_lineno_stack:+:} 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; } > conftest.i && { - 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; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $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; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $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 eval \${$3+:} false; 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; ${as_lineno_stack:+:} unset as_lineno - -} # ac_fn_c_check_func - -# ac_fn_cxx_try_cpp LINENO -# ------------------------ -# Try to preprocess conftest.$ac_ext, and return whether this succeeded. -ac_fn_cxx_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; } > conftest.i && { - test -z "$ac_cxx_preproc_warn_flag$ac_cxx_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; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_cxx_try_cpp - -# ac_fn_cxx_try_link LINENO -# ------------------------- -# Try to link conftest.$ac_ext, and return whether this succeeded. -ac_fn_cxx_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_cxx_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - 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; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_cxx_try_link - -# 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 eval \${$3+:} false; then : - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 -$as_echo_n "checking for $2... " >&6; } -if eval \${$3+:} false; 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.i 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;} -( $as_echo "## ---------------------------------------- ## -## Report this to bdwgc@lists.opendylan.org ## -## ---------------------------------------- ##" - ) | sed "s/^/$as_me: WARNING: /" >&2 - ;; -esac - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 -$as_echo_n "checking for $2... " >&6; } -if eval \${$3+:} false; 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; ${as_lineno_stack:+:} unset as_lineno - -} # ac_fn_c_check_header_mongrel -cat >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 gc $as_me 7.5.0, which was -generated by GNU Autoconf 2.69. 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 - - $as_echo "## ---------------- ## -## Cache variables. ## -## ---------------- ##" - 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 - - $as_echo "## ----------------- ## -## Output variables. ## -## ----------------- ##" - 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 - $as_echo "## ------------------- ## -## File substitutions. ## -## ------------------- ##" - 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 - $as_echo "## ----------- ## -## confdefs.h. ## -## ----------- ##" - 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 - # We do not want a PATH search for config.site. - case $CONFIG_SITE in #(( - -*) ac_site_file1=./$CONFIG_SITE;; - */*) ac_site_file1=$CONFIG_SITE;; - *) ac_site_file1=./$CONFIG_SITE;; - esac -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 /dev/null != "$ac_site_file" && 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" \ - || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "failed to load site script $ac_site_file -See \`config.log' for more details" "$LINENO" 5; } - 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. DJGPP emulates it as a regular file. - if test /dev/null != "$cache_file" && 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 - - - ## version must conform to [0-9]+[.][0-9]+[.][0-9]+ - - -ac_aux_dir= -for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do - if test -f "$ac_dir/install-sh"; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install-sh -c" - break - elif test -f "$ac_dir/install.sh"; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install.sh -c" - break - elif test -f "$ac_dir/shtool"; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/shtool install -c" - break - fi -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 ${ac_cv_build+:} false; 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 ${ac_cv_host+:} false; 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 - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking target system type" >&5 -$as_echo_n "checking target system type... " >&6; } -if ${ac_cv_target+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test "x$target_alias" = x; then - ac_cv_target=$ac_cv_host -else - ac_cv_target=`$SHELL "$ac_aux_dir/config.sub" $target_alias` || - as_fn_error $? "$SHELL $ac_aux_dir/config.sub $target_alias failed" "$LINENO" 5 -fi - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_target" >&5 -$as_echo "$ac_cv_target" >&6; } -case $ac_cv_target in -*-*-*) ;; -*) as_fn_error $? "invalid value of canonical target" "$LINENO" 5;; -esac -target=$ac_cv_target -ac_save_IFS=$IFS; IFS='-' -set x $ac_cv_target -shift -target_cpu=$1 -target_vendor=$2 -shift; shift -# Remember, the first character of IFS is used to create $*, -# except with old shells: -target_os=$* -IFS=$ac_save_IFS -case $target_os in *\ *) target_os=`echo "$target_os" | sed 's/ /-/g'`;; esac - - -# The aliases save the names the user supplied, while $host etc. -# will get canonicalized. -test -n "$target_alias" && - test "$program_prefix$program_suffix$program_transform_name" = \ - NONENONEs,x,x, && - program_prefix=${target_alias}- - -GC_SET_VERSION -am__api_version='1.15' - -# 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 ${ac_cv_path_install+:} false; 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 as_fn_executable_p "$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 build environment is sane" >&5 -$as_echo_n "checking whether build environment is sane... " >&6; } -# Reject unsafe characters in $srcdir or the absolute working directory -# name. Accept space and tab only in the latter. -am_lf=' -' -case `pwd` in - *[\\\"\#\$\&\'\`$am_lf]*) - as_fn_error $? "unsafe absolute working directory name" "$LINENO" 5;; -esac -case $srcdir in - *[\\\"\#\$\&\'\`$am_lf\ \ ]*) - as_fn_error $? "unsafe srcdir value: '$srcdir'" "$LINENO" 5;; -esac - -# Do 'set' in a subshell so we don't clobber the current shell's -# arguments. Must try -L first in case configure is actually a -# symlink; some systems play weird games with the mod time of symlinks -# (eg FreeBSD returns the mod time of the symlink's containing -# directory). -if ( - am_has_slept=no - for am_try in 1 2; do - echo "timestamp, slept: $am_has_slept" > conftest.file - set X `ls -Lt "$srcdir/configure" conftest.file 2> /dev/null` - if test "$*" = "X"; then - # -L didn't work. - set X `ls -t "$srcdir/configure" conftest.file` - fi - if test "$*" != "X $srcdir/configure conftest.file" \ - && test "$*" != "X conftest.file $srcdir/configure"; then - - # If neither matched, then we have a broken ls. This can happen - # if, for instance, CONFIG_SHELL is bash and it inherits a - # broken ls alias from the environment. This has actually - # happened. Such a system could not be considered "sane". - as_fn_error $? "ls -t appears to fail. Make sure there is not a broken - alias in your environment" "$LINENO" 5 - fi - if test "$2" = conftest.file || test $am_try -eq 2; then - break - fi - # Just in case. - sleep 1 - am_has_slept=yes - done - test "$2" = conftest.file - ) -then - # Ok. - : -else - as_fn_error $? "newly created file is older than distributed files! -Check your system clock" "$LINENO" 5 -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } -# If we didn't sleep, we still need to ensure time stamps of config.status and -# generated files are strictly newer. -am_sleep_pid= -if grep 'slept: no' conftest.file >/dev/null 2>&1; then - ( sleep 1 ) & - am_sleep_pid=$! -fi - -rm -f conftest.file - -test "$program_prefix" != NONE && - program_transform_name="s&^&$program_prefix&;$program_transform_name" -# Use a double $ so make ignores it. -test "$program_suffix" != NONE && - program_transform_name="s&\$&$program_suffix&;$program_transform_name" -# Double any \ or $. -# By default was `s,x,x', remove it if useless. -ac_script='s/[\\$]/&&/g;s/;s,x,x,$//' -program_transform_name=`$as_echo "$program_transform_name" | sed "$ac_script"` - -# Expand $ac_aux_dir to an absolute path. -am_aux_dir=`cd "$ac_aux_dir" && pwd` - -if test x"${MISSING+set}" != xset; then - case $am_aux_dir in - *\ * | *\ *) - MISSING="\${SHELL} \"$am_aux_dir/missing\"" ;; - *) - MISSING="\${SHELL} $am_aux_dir/missing" ;; - esac -fi -# Use eval to expand $SHELL -if eval "$MISSING --is-lightweight"; then - am_missing_run="$MISSING " -else - am_missing_run= - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: 'missing' script is too old or missing" >&5 -$as_echo "$as_me: WARNING: 'missing' script is too old or missing" >&2;} -fi - -if test x"${install_sh+set}" != xset; then - case $am_aux_dir in - *\ * | *\ *) - install_sh="\${SHELL} '$am_aux_dir/install-sh'" ;; - *) - install_sh="\${SHELL} $am_aux_dir/install-sh" - esac -fi - -# Installed binaries are usually stripped using 'strip' when the user -# run "make install-strip". However 'strip' might not be the right -# tool to use in cross-compilation environments, therefore Automake -# will honor the 'STRIP' environment variable to overrule this program. -if test "$cross_compiling" != no; then - 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 ${ac_cv_prog_STRIP+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_ac_ct_STRIP+:} false; 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 as_fn_executable_p "$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 - -fi -INSTALL_STRIP_PROGRAM="\$(install_sh) -c -s" - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for a thread-safe mkdir -p" >&5 -$as_echo_n "checking for a thread-safe mkdir -p... " >&6; } -if test -z "$MKDIR_P"; then - if ${ac_cv_path_mkdir+:} false; then : - $as_echo_n "(cached) " >&6 -else - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH$PATH_SEPARATOR/opt/sfw/bin -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_prog in mkdir gmkdir; do - for ac_exec_ext in '' $ac_executable_extensions; do - as_fn_executable_p "$as_dir/$ac_prog$ac_exec_ext" || continue - case `"$as_dir/$ac_prog$ac_exec_ext" --version 2>&1` in #( - 'mkdir (GNU coreutils) '* | \ - 'mkdir (coreutils) '* | \ - 'mkdir (fileutils) '4.1*) - ac_cv_path_mkdir=$as_dir/$ac_prog$ac_exec_ext - break 3;; - esac - done - done - done -IFS=$as_save_IFS - -fi - - test -d ./--version && rmdir ./--version - if test "${ac_cv_path_mkdir+set}" = set; then - MKDIR_P="$ac_cv_path_mkdir -p" - else - # As a last resort, use the slow shell script. Don't cache a - # value for MKDIR_P 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. - MKDIR_P="$ac_install_sh -d" - fi -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $MKDIR_P" >&5 -$as_echo "$MKDIR_P" >&6; } - -for ac_prog in gawk mawk nawk awk -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 ${ac_cv_prog_AWK+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$AWK"; then - ac_cv_prog_AWK="$AWK" # 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 as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_AWK="$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 -AWK=$ac_cv_prog_AWK -if test -n "$AWK"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $AWK" >&5 -$as_echo "$AWK" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - - test -n "$AWK" && break -done - -{ $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 eval \${ac_cv_prog_make_${ac_make}_set+:} false; 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 - -rm -rf .tst 2>/dev/null -mkdir .tst 2>/dev/null -if test -d .tst; then - am__leading_dot=. -else - am__leading_dot=_ -fi -rmdir .tst 2>/dev/null - -# Check whether --enable-silent-rules was given. -if test "${enable_silent_rules+set}" = set; then : - enableval=$enable_silent_rules; -fi - -case $enable_silent_rules in # ((( - yes) AM_DEFAULT_VERBOSITY=0;; - no) AM_DEFAULT_VERBOSITY=1;; - *) AM_DEFAULT_VERBOSITY=1;; -esac -am_make=${MAKE-make} -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $am_make supports nested variables" >&5 -$as_echo_n "checking whether $am_make supports nested variables... " >&6; } -if ${am_cv_make_support_nested_variables+:} false; then : - $as_echo_n "(cached) " >&6 -else - if $as_echo 'TRUE=$(BAR$(V)) -BAR0=false -BAR1=true -V=1 -am__doit: - @$(TRUE) -.PHONY: am__doit' | $am_make -f - >/dev/null 2>&1; then - am_cv_make_support_nested_variables=yes -else - am_cv_make_support_nested_variables=no -fi -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_make_support_nested_variables" >&5 -$as_echo "$am_cv_make_support_nested_variables" >&6; } -if test $am_cv_make_support_nested_variables = yes; then - AM_V='$(V)' - AM_DEFAULT_V='$(AM_DEFAULT_VERBOSITY)' -else - AM_V=$AM_DEFAULT_VERBOSITY - AM_DEFAULT_V=$AM_DEFAULT_VERBOSITY -fi -AM_BACKSLASH='\' - -if test "`cd $srcdir && pwd`" != "`pwd`"; then - # Use -I$(srcdir) only when $(srcdir) != ., so that make's output - # is not polluted with repeated "-I." - am__isrc=' -I$(srcdir)' - # test to see if srcdir already configured - if test -f $srcdir/config.status; then - as_fn_error $? "source directory already configured; run \"make distclean\" there first" "$LINENO" 5 - fi -fi - -# test whether we have cygpath -if test -z "$CYGPATH_W"; then - if (cygpath --version) >/dev/null 2>/dev/null; then - CYGPATH_W='cygpath -w' - else - CYGPATH_W=echo - fi -fi - - -# Define the identity of the package. - PACKAGE='gc' - VERSION='7.5.0' - - -cat >>confdefs.h <<_ACEOF -#define PACKAGE "$PACKAGE" -_ACEOF - - -cat >>confdefs.h <<_ACEOF -#define VERSION "$VERSION" -_ACEOF - -# Some tools Automake needs. - -ACLOCAL=${ACLOCAL-"${am_missing_run}aclocal-${am__api_version}"} - - -AUTOCONF=${AUTOCONF-"${am_missing_run}autoconf"} - - -AUTOMAKE=${AUTOMAKE-"${am_missing_run}automake-${am__api_version}"} - - -AUTOHEADER=${AUTOHEADER-"${am_missing_run}autoheader"} - - -MAKEINFO=${MAKEINFO-"${am_missing_run}makeinfo"} - -# For better backward compatibility. To be removed once Automake 1.9.x -# dies out for good. For more background, see: -# -# -mkdir_p='$(MKDIR_P)' - -# We need awk for the "check" target (and possibly the TAP driver). The -# system "awk" is bad on some platforms. -# Always define AMTAR for backward compatibility. Yes, it's still used -# in the wild :-( We should find a proper way to deprecate it ... -AMTAR='$${TAR-tar}' - - -# We'll loop over all known methods to create a tar archive until one works. -_am_tools='gnutar pax cpio none' - -am__tar='$${TAR-tar} chof - "$$tardir"' am__untar='$${TAR-tar} xf -' - - - - - - -# POSIX will say in a future version that running "rm -f" with no argument -# is OK; and we want to be able to make that assumption in our Makefile -# recipes. So use an aggressive probe to check that the usage we want is -# actually supported "in the wild" to an acceptable degree. -# See automake bug#10828. -# To make any issue more visible, cause the running configure to be aborted -# by default if the 'rm' program in use doesn't match our expectations; the -# user can still override this though. -if rm -f && rm -fr && rm -rf; then : OK; else - cat >&2 <<'END' -Oops! - -Your 'rm' program seems unable to run without file operands specified -on the command line, even when the '-f' option is present. This is contrary -to the behaviour of most rm programs out there, and not conforming with -the upcoming POSIX standard: - -Please tell bug-automake@gnu.org about your system, including the value -of your $PATH and any error possibly output before this message. This -can help us improve future automake versions. - -END - if test x"$ACCEPT_INFERIOR_RM_PROGRAM" = x"yes"; then - echo 'Configuration will proceed anyway, since you have set the' >&2 - echo 'ACCEPT_INFERIOR_RM_PROGRAM variable to "yes"' >&2 - echo >&2 - else - cat >&2 <<'END' -Aborting the configuration process, to ensure you take notice of the issue. - -You can download and install GNU coreutils to get an 'rm' implementation -that behaves properly: . - -If you want to complete the configuration process using your problematic -'rm' anyway, export the environment variable ACCEPT_INFERIOR_RM_PROGRAM -to "yes", and re-run configure. - -END - as_fn_error $? "Your 'rm' program is bad, sorry." "$LINENO" 5 - fi -fi - -ac_config_headers="$ac_config_headers include/config.h" - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to enable maintainer-specific portions of Makefiles" >&5 -$as_echo_n "checking whether to enable maintainer-specific portions of Makefiles... " >&6; } - # Check whether --enable-maintainer-mode was given. -if test "${enable_maintainer_mode+set}" = set; then : - enableval=$enable_maintainer_mode; USE_MAINTAINER_MODE=$enableval -else - USE_MAINTAINER_MODE=no -fi - - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $USE_MAINTAINER_MODE" >&5 -$as_echo "$USE_MAINTAINER_MODE" >&6; } - if test $USE_MAINTAINER_MODE = yes; then - MAINTAINER_MODE_TRUE= - MAINTAINER_MODE_FALSE='#' -else - MAINTAINER_MODE_TRUE='#' - MAINTAINER_MODE_FALSE= -fi - - MAINT=$MAINTAINER_MODE_TRUE - - - - - - -DEPDIR="${am__leading_dot}deps" - -ac_config_commands="$ac_config_commands depfiles" - - -am_make=${MAKE-make} -cat > confinc << 'END' -am__doit: - @echo this is the am__doit target -.PHONY: am__doit -END -# If we don't find an include directive, just comment out the code. -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for style of include used by $am_make" >&5 -$as_echo_n "checking for style of include used by $am_make... " >&6; } -am__include="#" -am__quote= -_am_result=none -# First try GNU make style include. -echo "include confinc" > confmf -# Ignore all kinds of additional output from 'make'. -case `$am_make -s -f confmf 2> /dev/null` in #( -*the\ am__doit\ target*) - am__include=include - am__quote= - _am_result=GNU - ;; -esac -# Now try BSD make style include. -if test "$am__include" = "#"; then - echo '.include "confinc"' > confmf - case `$am_make -s -f confmf 2> /dev/null` in #( - *the\ am__doit\ target*) - am__include=.include - am__quote="\"" - _am_result=BSD - ;; - esac -fi - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $_am_result" >&5 -$as_echo "$_am_result" >&6; } -rm -f confinc confmf - -# Check whether --enable-dependency-tracking was given. -if test "${enable_dependency_tracking+set}" = set; then : - enableval=$enable_dependency_tracking; -fi - -if test "x$enable_dependency_tracking" != xno; then - am_depcomp="$ac_aux_dir/depcomp" - AMDEPBACKSLASH='\' - am__nodep='_no' -fi - if test "x$enable_dependency_tracking" != xno; then - AMDEP_TRUE= - AMDEP_FALSE='#' -else - AMDEP_TRUE='#' - AMDEP_FALSE= -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 -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 ${ac_cv_prog_CC+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_ac_ct_CC+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_CC+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_CC+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_CC+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_ac_ct_CC+:} false; 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 as_fn_executable_p "$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 - fi - rm -f conftest.er1 conftest.err - $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. */ - -int -main () -{ - - ; - 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" -# 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 whether the C compiler works" >&5 -$as_echo_n "checking whether the C compiler works... " >&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 -if test -z "$ac_file"; then : - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -$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 77 "C compiler cannot create executables -See \`config.log' for more details" "$LINENO" 5; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } -fi -{ $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; } -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 -$as_echo "$ac_file" >&6; } -ac_exeext=$ac_cv_exeext - -rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out -ac_clean_files=$ac_clean_files_save -{ $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 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 -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="$ac_clean_files conftest.out" -# 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; } -if test "$cross_compiling" != yes; then - { { 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; } - if { ac_try='./conftest$ac_cv_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 - 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: $cross_compiling" >&5 -$as_echo "$cross_compiling" >&6; } - -rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out -ac_clean_files=$ac_clean_files_save -{ $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 ${ac_cv_objext+:} false; 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 ${ac_cv_c_compiler_gnu+:} false; 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 ${ac_cv_prog_cc_g+:} false; 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 ${ac_cv_prog_cc_c89+:} false; 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 -struct stat; -/* 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 - -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 whether $CC understands -c and -o together" >&5 -$as_echo_n "checking whether $CC understands -c and -o together... " >&6; } -if ${am_cv_prog_cc_c_o+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF - # Make sure it works both with $CC and with simple cc. - # Following AC_PROG_CC_C_O, we do the test twice because some - # compilers refuse to overwrite an existing .o file with -o, - # though they will create one. - am_cv_prog_cc_c_o=yes - for am_i in 1 2; do - if { echo "$as_me:$LINENO: $CC -c conftest.$ac_ext -o conftest2.$ac_objext" >&5 - ($CC -c conftest.$ac_ext -o conftest2.$ac_objext) >&5 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } \ - && test -f conftest2.$ac_objext; then - : OK - else - am_cv_prog_cc_c_o=no - break - fi - done - rm -f core conftest* - unset am_i -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_prog_cc_c_o" >&5 -$as_echo "$am_cv_prog_cc_c_o" >&6; } -if test "$am_cv_prog_cc_c_o" != yes; then - # Losing compiler, so override with the script. - # FIXME: It is wrong to rewrite CC. - # But if we don't then we get into trouble of one sort or another. - # A longer-term fix would be to have automake use am__CC in this case, - # and then we could set am__CC="\$(top_srcdir)/compile \$(CC)" - CC="$am_aux_dir/compile $CC" -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 - - -depcc="$CC" am_compiler_list= - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking dependency style of $depcc" >&5 -$as_echo_n "checking dependency style of $depcc... " >&6; } -if ${am_cv_CC_dependencies_compiler_type+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -z "$AMDEP_TRUE" && test -f "$am_depcomp"; then - # We make a subdir and do the tests there. Otherwise we can end up - # making bogus files that we don't know about and never remove. For - # instance it was reported that on HP-UX the gcc test will end up - # making a dummy file named 'D' -- because '-MD' means "put the output - # in D". - rm -rf conftest.dir - mkdir conftest.dir - # Copy depcomp to subdir because otherwise we won't find it if we're - # using a relative directory. - cp "$am_depcomp" conftest.dir - cd conftest.dir - # We will build objects and dependencies in a subdirectory because - # it helps to detect inapplicable dependency modes. For instance - # both Tru64's cc and ICC support -MD to output dependencies as a - # side effect of compilation, but ICC will put the dependencies in - # the current directory while Tru64 will put them in the object - # directory. - mkdir sub - - am_cv_CC_dependencies_compiler_type=none - if test "$am_compiler_list" = ""; then - am_compiler_list=`sed -n 's/^#*\([a-zA-Z0-9]*\))$/\1/p' < ./depcomp` - fi - am__universal=false - case " $depcc " in #( - *\ -arch\ *\ -arch\ *) am__universal=true ;; - esac - - for depmode in $am_compiler_list; do - # Setup a source with many dependencies, because some compilers - # like to wrap large dependency lists on column 80 (with \), and - # we should not choose a depcomp mode which is confused by this. - # - # We need to recreate these files for each test, as the compiler may - # overwrite some of them when testing with obscure command lines. - # This happens at least with the AIX C compiler. - : > sub/conftest.c - for i in 1 2 3 4 5 6; do - echo '#include "conftst'$i'.h"' >> sub/conftest.c - # Using ": > sub/conftst$i.h" creates only sub/conftst1.h with - # Solaris 10 /bin/sh. - echo '/* dummy */' > sub/conftst$i.h - done - echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf - - # We check with '-c' and '-o' for the sake of the "dashmstdout" - # mode. It turns out that the SunPro C++ compiler does not properly - # handle '-M -o', and we need to detect this. Also, some Intel - # versions had trouble with output in subdirs. - am__obj=sub/conftest.${OBJEXT-o} - am__minus_obj="-o $am__obj" - case $depmode in - gcc) - # This depmode causes a compiler race in universal mode. - test "$am__universal" = false || continue - ;; - nosideeffect) - # After this tag, mechanisms are not by side-effect, so they'll - # only be used when explicitly requested. - if test "x$enable_dependency_tracking" = xyes; then - continue - else - break - fi - ;; - msvc7 | msvc7msys | msvisualcpp | msvcmsys) - # This compiler won't grok '-c -o', but also, the minuso test has - # not run yet. These depmodes are late enough in the game, and - # so weak that their functioning should not be impacted. - am__obj=conftest.${OBJEXT-o} - am__minus_obj= - ;; - none) break ;; - esac - if depmode=$depmode \ - source=sub/conftest.c object=$am__obj \ - depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \ - $SHELL ./depcomp $depcc -c $am__minus_obj sub/conftest.c \ - >/dev/null 2>conftest.err && - grep sub/conftst1.h sub/conftest.Po > /dev/null 2>&1 && - grep sub/conftst6.h sub/conftest.Po > /dev/null 2>&1 && - grep $am__obj sub/conftest.Po > /dev/null 2>&1 && - ${MAKE-make} -s -f confmf > /dev/null 2>&1; then - # icc doesn't choke on unknown options, it will just issue warnings - # or remarks (even with -Werror). So we grep stderr for any message - # that says an option was ignored or not supported. - # When given -MP, icc 7.0 and 7.1 complain thusly: - # icc: Command line warning: ignoring option '-M'; no argument required - # The diagnosis changed in icc 8.0: - # icc: Command line remark: option '-MP' not supported - if (grep 'ignoring option' conftest.err || - grep 'not supported' conftest.err) >/dev/null 2>&1; then :; else - am_cv_CC_dependencies_compiler_type=$depmode - break - fi - fi - done - - cd .. - rm -rf conftest.dir -else - am_cv_CC_dependencies_compiler_type=none -fi - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_CC_dependencies_compiler_type" >&5 -$as_echo "$am_cv_CC_dependencies_compiler_type" >&6; } -CCDEPMODE=depmode=$am_cv_CC_dependencies_compiler_type - - if - test "x$enable_dependency_tracking" != xno \ - && test "$am_cv_CC_dependencies_compiler_type" = gcc3; then - am__fastdepCC_TRUE= - am__fastdepCC_FALSE='#' -else - am__fastdepCC_TRUE='#' - am__fastdepCC_FALSE= -fi - - - -ac_ext=cpp -ac_cpp='$CXXCPP $CPPFLAGS' -ac_compile='$CXX -c $CXXFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CXX -o conftest$ac_exeext $CXXFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_cxx_compiler_gnu -if test -z "$CXX"; then - if test -n "$CCC"; then - CXX=$CCC - else - if test -n "$ac_tool_prefix"; then - for ac_prog in g++ c++ gpp aCC CC cxx cc++ cl.exe FCC KCC RCC xlC_r xlC - 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 ${ac_cv_prog_CXX+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$CXX"; then - ac_cv_prog_CXX="$CXX" # 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 as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_CXX="$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 -CXX=$ac_cv_prog_CXX -if test -n "$CXX"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CXX" >&5 -$as_echo "$CXX" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - - test -n "$CXX" && break - done -fi -if test -z "$CXX"; then - ac_ct_CXX=$CXX - for ac_prog in g++ c++ gpp aCC CC cxx cc++ cl.exe FCC KCC RCC xlC_r xlC -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 ${ac_cv_prog_ac_ct_CXX+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$ac_ct_CXX"; then - ac_cv_prog_ac_ct_CXX="$ac_ct_CXX" # 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 as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_ac_ct_CXX="$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_CXX=$ac_cv_prog_ac_ct_CXX -if test -n "$ac_ct_CXX"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CXX" >&5 -$as_echo "$ac_ct_CXX" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - - test -n "$ac_ct_CXX" && break -done - - if test "x$ac_ct_CXX" = x; then - CXX="g++" - 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 - CXX=$ac_ct_CXX - fi -fi - - fi -fi -# 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 - fi - rm -f conftest.er1 conftest.err - $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 ${ac_cv_cxx_compiler_gnu+:} false; 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_cxx_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_cxx_compiler_gnu=$ac_compiler_gnu - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_cxx_compiler_gnu" >&5 -$as_echo "$ac_cv_cxx_compiler_gnu" >&6; } -if test $ac_compiler_gnu = yes; then - GXX=yes -else - GXX= -fi -ac_test_CXXFLAGS=${CXXFLAGS+set} -ac_save_CXXFLAGS=$CXXFLAGS -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CXX accepts -g" >&5 -$as_echo_n "checking whether $CXX accepts -g... " >&6; } -if ${ac_cv_prog_cxx_g+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_save_cxx_werror_flag=$ac_cxx_werror_flag - ac_cxx_werror_flag=yes - ac_cv_prog_cxx_g=no - CXXFLAGS="-g" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_cxx_try_compile "$LINENO"; then : - ac_cv_prog_cxx_g=yes -else - CXXFLAGS="" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_cxx_try_compile "$LINENO"; then : - -else - ac_cxx_werror_flag=$ac_save_cxx_werror_flag - CXXFLAGS="-g" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_cxx_try_compile "$LINENO"; then : - ac_cv_prog_cxx_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_cxx_werror_flag=$ac_save_cxx_werror_flag -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cxx_g" >&5 -$as_echo "$ac_cv_prog_cxx_g" >&6; } -if test "$ac_test_CXXFLAGS" = set; then - CXXFLAGS=$ac_save_CXXFLAGS -elif test $ac_cv_prog_cxx_g = yes; then - if test "$GXX" = yes; then - CXXFLAGS="-g -O2" - else - CXXFLAGS="-g" - fi -else - if test "$GXX" = yes; then - CXXFLAGS="-O2" - else - CXXFLAGS= - fi -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 - -depcc="$CXX" am_compiler_list= - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking dependency style of $depcc" >&5 -$as_echo_n "checking dependency style of $depcc... " >&6; } -if ${am_cv_CXX_dependencies_compiler_type+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -z "$AMDEP_TRUE" && test -f "$am_depcomp"; then - # We make a subdir and do the tests there. Otherwise we can end up - # making bogus files that we don't know about and never remove. For - # instance it was reported that on HP-UX the gcc test will end up - # making a dummy file named 'D' -- because '-MD' means "put the output - # in D". - rm -rf conftest.dir - mkdir conftest.dir - # Copy depcomp to subdir because otherwise we won't find it if we're - # using a relative directory. - cp "$am_depcomp" conftest.dir - cd conftest.dir - # We will build objects and dependencies in a subdirectory because - # it helps to detect inapplicable dependency modes. For instance - # both Tru64's cc and ICC support -MD to output dependencies as a - # side effect of compilation, but ICC will put the dependencies in - # the current directory while Tru64 will put them in the object - # directory. - mkdir sub - - am_cv_CXX_dependencies_compiler_type=none - if test "$am_compiler_list" = ""; then - am_compiler_list=`sed -n 's/^#*\([a-zA-Z0-9]*\))$/\1/p' < ./depcomp` - fi - am__universal=false - case " $depcc " in #( - *\ -arch\ *\ -arch\ *) am__universal=true ;; - esac - - for depmode in $am_compiler_list; do - # Setup a source with many dependencies, because some compilers - # like to wrap large dependency lists on column 80 (with \), and - # we should not choose a depcomp mode which is confused by this. - # - # We need to recreate these files for each test, as the compiler may - # overwrite some of them when testing with obscure command lines. - # This happens at least with the AIX C compiler. - : > sub/conftest.c - for i in 1 2 3 4 5 6; do - echo '#include "conftst'$i'.h"' >> sub/conftest.c - # Using ": > sub/conftst$i.h" creates only sub/conftst1.h with - # Solaris 10 /bin/sh. - echo '/* dummy */' > sub/conftst$i.h - done - echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf - - # We check with '-c' and '-o' for the sake of the "dashmstdout" - # mode. It turns out that the SunPro C++ compiler does not properly - # handle '-M -o', and we need to detect this. Also, some Intel - # versions had trouble with output in subdirs. - am__obj=sub/conftest.${OBJEXT-o} - am__minus_obj="-o $am__obj" - case $depmode in - gcc) - # This depmode causes a compiler race in universal mode. - test "$am__universal" = false || continue - ;; - nosideeffect) - # After this tag, mechanisms are not by side-effect, so they'll - # only be used when explicitly requested. - if test "x$enable_dependency_tracking" = xyes; then - continue - else - break - fi - ;; - msvc7 | msvc7msys | msvisualcpp | msvcmsys) - # This compiler won't grok '-c -o', but also, the minuso test has - # not run yet. These depmodes are late enough in the game, and - # so weak that their functioning should not be impacted. - am__obj=conftest.${OBJEXT-o} - am__minus_obj= - ;; - none) break ;; - esac - if depmode=$depmode \ - source=sub/conftest.c object=$am__obj \ - depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \ - $SHELL ./depcomp $depcc -c $am__minus_obj sub/conftest.c \ - >/dev/null 2>conftest.err && - grep sub/conftst1.h sub/conftest.Po > /dev/null 2>&1 && - grep sub/conftst6.h sub/conftest.Po > /dev/null 2>&1 && - grep $am__obj sub/conftest.Po > /dev/null 2>&1 && - ${MAKE-make} -s -f confmf > /dev/null 2>&1; then - # icc doesn't choke on unknown options, it will just issue warnings - # or remarks (even with -Werror). So we grep stderr for any message - # that says an option was ignored or not supported. - # When given -MP, icc 7.0 and 7.1 complain thusly: - # icc: Command line warning: ignoring option '-M'; no argument required - # The diagnosis changed in icc 8.0: - # icc: Command line remark: option '-MP' not supported - if (grep 'ignoring option' conftest.err || - grep 'not supported' conftest.err) >/dev/null 2>&1; then :; else - am_cv_CXX_dependencies_compiler_type=$depmode - break - fi - fi - done - - cd .. - rm -rf conftest.dir -else - am_cv_CXX_dependencies_compiler_type=none -fi - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_CXX_dependencies_compiler_type" >&5 -$as_echo "$am_cv_CXX_dependencies_compiler_type" >&6; } -CXXDEPMODE=depmode=$am_cv_CXX_dependencies_compiler_type - - if - test "x$enable_dependency_tracking" != xno \ - && test "$am_cv_CXX_dependencies_compiler_type" = gcc3; then - am__fastdepCXX_TRUE= - am__fastdepCXX_FALSE='#' -else - am__fastdepCXX_TRUE='#' - am__fastdepCXX_FALSE= -fi - - -# By default we simply use the C compiler to build assembly code. - -test "${CCAS+set}" = set || CCAS=$CC -test "${CCASFLAGS+set}" = set || CCASFLAGS=$CFLAGS - - - -depcc="$CCAS" am_compiler_list= - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking dependency style of $depcc" >&5 -$as_echo_n "checking dependency style of $depcc... " >&6; } -if ${am_cv_CCAS_dependencies_compiler_type+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -z "$AMDEP_TRUE" && test -f "$am_depcomp"; then - # We make a subdir and do the tests there. Otherwise we can end up - # making bogus files that we don't know about and never remove. For - # instance it was reported that on HP-UX the gcc test will end up - # making a dummy file named 'D' -- because '-MD' means "put the output - # in D". - rm -rf conftest.dir - mkdir conftest.dir - # Copy depcomp to subdir because otherwise we won't find it if we're - # using a relative directory. - cp "$am_depcomp" conftest.dir - cd conftest.dir - # We will build objects and dependencies in a subdirectory because - # it helps to detect inapplicable dependency modes. For instance - # both Tru64's cc and ICC support -MD to output dependencies as a - # side effect of compilation, but ICC will put the dependencies in - # the current directory while Tru64 will put them in the object - # directory. - mkdir sub - - am_cv_CCAS_dependencies_compiler_type=none - if test "$am_compiler_list" = ""; then - am_compiler_list=`sed -n 's/^#*\([a-zA-Z0-9]*\))$/\1/p' < ./depcomp` - fi - am__universal=false - - - for depmode in $am_compiler_list; do - # Setup a source with many dependencies, because some compilers - # like to wrap large dependency lists on column 80 (with \), and - # we should not choose a depcomp mode which is confused by this. - # - # We need to recreate these files for each test, as the compiler may - # overwrite some of them when testing with obscure command lines. - # This happens at least with the AIX C compiler. - : > sub/conftest.c - for i in 1 2 3 4 5 6; do - echo '#include "conftst'$i'.h"' >> sub/conftest.c - # Using ": > sub/conftst$i.h" creates only sub/conftst1.h with - # Solaris 10 /bin/sh. - echo '/* dummy */' > sub/conftst$i.h - done - echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf - - # We check with '-c' and '-o' for the sake of the "dashmstdout" - # mode. It turns out that the SunPro C++ compiler does not properly - # handle '-M -o', and we need to detect this. Also, some Intel - # versions had trouble with output in subdirs. - am__obj=sub/conftest.${OBJEXT-o} - am__minus_obj="-o $am__obj" - case $depmode in - gcc) - # This depmode causes a compiler race in universal mode. - test "$am__universal" = false || continue - ;; - nosideeffect) - # After this tag, mechanisms are not by side-effect, so they'll - # only be used when explicitly requested. - if test "x$enable_dependency_tracking" = xyes; then - continue - else - break - fi - ;; - msvc7 | msvc7msys | msvisualcpp | msvcmsys) - # This compiler won't grok '-c -o', but also, the minuso test has - # not run yet. These depmodes are late enough in the game, and - # so weak that their functioning should not be impacted. - am__obj=conftest.${OBJEXT-o} - am__minus_obj= - ;; - none) break ;; - esac - if depmode=$depmode \ - source=sub/conftest.c object=$am__obj \ - depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \ - $SHELL ./depcomp $depcc -c $am__minus_obj sub/conftest.c \ - >/dev/null 2>conftest.err && - grep sub/conftst1.h sub/conftest.Po > /dev/null 2>&1 && - grep sub/conftst6.h sub/conftest.Po > /dev/null 2>&1 && - grep $am__obj sub/conftest.Po > /dev/null 2>&1 && - ${MAKE-make} -s -f confmf > /dev/null 2>&1; then - # icc doesn't choke on unknown options, it will just issue warnings - # or remarks (even with -Werror). So we grep stderr for any message - # that says an option was ignored or not supported. - # When given -MP, icc 7.0 and 7.1 complain thusly: - # icc: Command line warning: ignoring option '-M'; no argument required - # The diagnosis changed in icc 8.0: - # icc: Command line remark: option '-MP' not supported - if (grep 'ignoring option' conftest.err || - grep 'not supported' conftest.err) >/dev/null 2>&1; then :; else - am_cv_CCAS_dependencies_compiler_type=$depmode - break - fi - fi - done - - cd .. - rm -rf conftest.dir -else - am_cv_CCAS_dependencies_compiler_type=none -fi - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_CCAS_dependencies_compiler_type" >&5 -$as_echo "$am_cv_CCAS_dependencies_compiler_type" >&6; } -CCASDEPMODE=depmode=$am_cv_CCAS_dependencies_compiler_type - - if - test "x$enable_dependency_tracking" != xno \ - && test "$am_cv_CCAS_dependencies_compiler_type" = gcc3; then - am__fastdepCCAS_TRUE= - am__fastdepCCAS_FALSE='#' -else - am__fastdepCCAS_TRUE='#' - am__fastdepCCAS_FALSE= -fi - - - -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.4.6' -macro_revision='2.4.6' - - - - - - - - - - - - - -ltmain=$ac_aux_dir/ltmain.sh - -# Backslashify 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' - -ECHO='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' -ECHO=$ECHO$ECHO$ECHO$ECHO$ECHO -ECHO=$ECHO$ECHO$ECHO$ECHO$ECHO$ECHO - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to print strings" >&5 -$as_echo_n "checking how to print strings... " >&6; } -# Test print first, because it will be a builtin if present. -if test "X`( print -r -- -n ) 2>/dev/null`" = X-n && \ - test "X`print -r -- $ECHO 2>/dev/null`" = "X$ECHO"; then - ECHO='print -r --' -elif test "X`printf %s $ECHO 2>/dev/null`" = "X$ECHO"; then - ECHO='printf %s\n' -else - # Use this function as a fallback that always works. - func_fallback_echo () - { - eval 'cat <<_LTECHO_EOF -$1 -_LTECHO_EOF' - } - ECHO='func_fallback_echo' -fi - -# func_echo_all arg... -# Invoke $ECHO with all args, space-separated. -func_echo_all () -{ - $ECHO "" -} - -case $ECHO in - printf*) { $as_echo "$as_me:${as_lineno-$LINENO}: result: printf" >&5 -$as_echo "printf" >&6; } ;; - print*) { $as_echo "$as_me:${as_lineno-$LINENO}: result: print -r" >&5 -$as_echo "print -r" >&6; } ;; - *) { $as_echo "$as_me:${as_lineno-$LINENO}: result: cat" >&5 -$as_echo "cat" >&6; } ;; -esac - - - - - - - - - - - - - - -{ $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 ${ac_cv_path_SED+:} false; 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" - as_fn_executable_p "$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 ${ac_cv_path_GREP+:} false; 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" - as_fn_executable_p "$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 ${ac_cv_path_EGREP+:} false; 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" - as_fn_executable_p "$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 ${ac_cv_path_FGREP+:} false; 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" - as_fn_executable_p "$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 no = "$withval" || with_gnu_ld=yes -else - with_gnu_ld=no -fi - -ac_prog=ld -if test yes = "$GCC"; 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 yes = "$with_gnu_ld"; 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 ${lt_cv_path_LD+:} false; 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 ${lt_cv_prog_gnu_ld+:} false; 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 ${lt_cv_path_NM+:} false; 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 - # MSYS converts /dev/null to NUL, MinGW nm treats NUL as empty - case $build_os in - mingw*) lt_bad_file=conftest.nm/nofile ;; - *) lt_bad_file=/dev/null ;; - esac - case `"$tmp_nm" -B $lt_bad_file 2>&1 | sed '1q'` in - *$lt_bad_file* | *'Invalid file or object type'*) - lt_cv_path_NM="$tmp_nm -B" - break 2 - ;; - *) - case `"$tmp_nm" -p /dev/null 2>&1 | sed '1q'` in - */dev/null*) - lt_cv_path_NM="$tmp_nm -p" - break 2 - ;; - *) - 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 no != "$lt_cv_path_NM"; then - NM=$lt_cv_path_NM -else - # Didn't find any BSD compatible name lister, look for dumpbin. - if test -n "$DUMPBIN"; then : - # Let the user override the test. - else - if test -n "$ac_tool_prefix"; then - for ac_prog in dumpbin "link -dump" - 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 ${ac_cv_prog_DUMPBIN+:} false; 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 as_fn_executable_p "$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 "link -dump" -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 ${ac_cv_prog_ac_ct_DUMPBIN+:} false; 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 as_fn_executable_p "$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 - - case `$DUMPBIN -symbols -headers /dev/null 2>&1 | sed '1q'` in - *COFF*) - DUMPBIN="$DUMPBIN -symbols -headers" - ;; - *) - DUMPBIN=: - ;; - esac - 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 ${lt_cv_nm_interface+:} false; 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:$LINENO: $ac_compile\"" >&5) - (eval "$ac_compile" 2>conftest.err) - cat conftest.err >&5 - (eval echo "\"\$as_me:$LINENO: $NM \\\"conftest.$ac_objext\\\"\"" >&5) - (eval "$NM \"conftest.$ac_objext\"" 2>conftest.err > conftest.out) - cat conftest.err >&5 - (eval echo "\"\$as_me:$LINENO: 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 ${lt_cv_sys_max_cmd_len+:} false; 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; - ;; - - mint*) - # On MiNT this can take a long time and run out of memory. - 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; - ;; - - bitrig* | darwin* | dragonfly* | freebsd* | netbsd* | openbsd*) - # 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 - ;; - - os2*) - # The test takes a long time on OS/2. - lt_cv_sys_max_cmd_len=8192 - ;; - - 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" && \ - test undefined != "$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`env echo "$teststring$teststring" 2>/dev/null` \ - = "X$teststring$teststring"; } >/dev/null 2>&1 && - test 17 != "$i" # 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"} - -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 how to convert $build file names to $host format" >&5 -$as_echo_n "checking how to convert $build file names to $host format... " >&6; } -if ${lt_cv_to_host_file_cmd+:} false; then : - $as_echo_n "(cached) " >&6 -else - case $host in - *-*-mingw* ) - case $build in - *-*-mingw* ) # actually msys - lt_cv_to_host_file_cmd=func_convert_file_msys_to_w32 - ;; - *-*-cygwin* ) - lt_cv_to_host_file_cmd=func_convert_file_cygwin_to_w32 - ;; - * ) # otherwise, assume *nix - lt_cv_to_host_file_cmd=func_convert_file_nix_to_w32 - ;; - esac - ;; - *-*-cygwin* ) - case $build in - *-*-mingw* ) # actually msys - lt_cv_to_host_file_cmd=func_convert_file_msys_to_cygwin - ;; - *-*-cygwin* ) - lt_cv_to_host_file_cmd=func_convert_file_noop - ;; - * ) # otherwise, assume *nix - lt_cv_to_host_file_cmd=func_convert_file_nix_to_cygwin - ;; - esac - ;; - * ) # unhandled hosts (and "normal" native builds) - lt_cv_to_host_file_cmd=func_convert_file_noop - ;; -esac - -fi - -to_host_file_cmd=$lt_cv_to_host_file_cmd -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_to_host_file_cmd" >&5 -$as_echo "$lt_cv_to_host_file_cmd" >&6; } - - - - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to convert $build file names to toolchain format" >&5 -$as_echo_n "checking how to convert $build file names to toolchain format... " >&6; } -if ${lt_cv_to_tool_file_cmd+:} false; then : - $as_echo_n "(cached) " >&6 -else - #assume ordinary cross tools, or native build. -lt_cv_to_tool_file_cmd=func_convert_file_noop -case $host in - *-*-mingw* ) - case $build in - *-*-mingw* ) # actually msys - lt_cv_to_tool_file_cmd=func_convert_file_msys_to_w32 - ;; - esac - ;; -esac - -fi - -to_tool_file_cmd=$lt_cv_to_tool_file_cmd -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_to_tool_file_cmd" >&5 -$as_echo "$lt_cv_to_tool_file_cmd" >&6; } - - - - - -{ $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 ${lt_cv_ld_reload_flag+:} false; 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 - cygwin* | mingw* | pw32* | cegcc*) - if test yes != "$GCC"; then - reload_cmds=false - fi - ;; - darwin*) - if test yes = "$GCC"; 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 ${ac_cv_prog_OBJDUMP+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_ac_ct_OBJDUMP+:} false; 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 as_fn_executable_p "$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 ${lt_cv_deplibs_check_method+:} false; 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 -# that 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 - # Keep this pattern in sync with the one in func_win32_libid. - lt_cv_deplibs_check_method='file_magic file format (pei*-i386(.*architecture: i386)?|pe-arm-wince|pe-x86-64)' - 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 - ;; - -haiku*) - 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])(-bit)?( [LM]SB)? 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 glibc/ELF. -linux* | k*bsd*-gnu | kopensolaris*-gnu | gnu*) - lt_cv_deplibs_check_method=pass_all - ;; - -netbsd*) - 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* | bitrig*) - if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`"; 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 - ;; -os2*) - 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_glob= -want_nocaseglob=no -if test "$build" = "$host"; then - case $host_os in - mingw* | pw32*) - if ( shopt | grep nocaseglob ) >/dev/null 2>&1; then - want_nocaseglob=yes - else - file_magic_glob=`echo aAbBcCdDeEfFgGhHiIjJkKlLmMnNoOpPqQrRsStTuUvVwWxXyYzZ | $SED -e "s/\(..\)/s\/[\1]\/[\1]\/g;/g"` - fi - ;; - esac -fi - -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}dlltool", so it can be a program name with args. -set dummy ${ac_tool_prefix}dlltool; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_DLLTOOL+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$DLLTOOL"; then - ac_cv_prog_DLLTOOL="$DLLTOOL" # 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 as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_DLLTOOL="${ac_tool_prefix}dlltool" - $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 -DLLTOOL=$ac_cv_prog_DLLTOOL -if test -n "$DLLTOOL"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $DLLTOOL" >&5 -$as_echo "$DLLTOOL" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - -fi -if test -z "$ac_cv_prog_DLLTOOL"; then - ac_ct_DLLTOOL=$DLLTOOL - # Extract the first word of "dlltool", so it can be a program name with args. -set dummy dlltool; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_ac_ct_DLLTOOL+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$ac_ct_DLLTOOL"; then - ac_cv_prog_ac_ct_DLLTOOL="$ac_ct_DLLTOOL" # 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 as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_ac_ct_DLLTOOL="dlltool" - $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_DLLTOOL=$ac_cv_prog_ac_ct_DLLTOOL -if test -n "$ac_ct_DLLTOOL"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_DLLTOOL" >&5 -$as_echo "$ac_ct_DLLTOOL" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - if test "x$ac_ct_DLLTOOL" = x; then - DLLTOOL="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 - DLLTOOL=$ac_ct_DLLTOOL - fi -else - DLLTOOL="$ac_cv_prog_DLLTOOL" -fi - -test -z "$DLLTOOL" && DLLTOOL=dlltool - - - - - - - - - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to associate runtime and link libraries" >&5 -$as_echo_n "checking how to associate runtime and link libraries... " >&6; } -if ${lt_cv_sharedlib_from_linklib_cmd+:} false; then : - $as_echo_n "(cached) " >&6 -else - lt_cv_sharedlib_from_linklib_cmd='unknown' - -case $host_os in -cygwin* | mingw* | pw32* | cegcc*) - # two different shell functions defined in ltmain.sh; - # decide which one to use based on capabilities of $DLLTOOL - case `$DLLTOOL --help 2>&1` in - *--identify-strict*) - lt_cv_sharedlib_from_linklib_cmd=func_cygming_dll_for_implib - ;; - *) - lt_cv_sharedlib_from_linklib_cmd=func_cygming_dll_for_implib_fallback - ;; - esac - ;; -*) - # fallback: assume linklib IS sharedlib - lt_cv_sharedlib_from_linklib_cmd=$ECHO - ;; -esac - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_sharedlib_from_linklib_cmd" >&5 -$as_echo "$lt_cv_sharedlib_from_linklib_cmd" >&6; } -sharedlib_from_linklib_cmd=$lt_cv_sharedlib_from_linklib_cmd -test -z "$sharedlib_from_linklib_cmd" && sharedlib_from_linklib_cmd=$ECHO - - - - - - - - -if test -n "$ac_tool_prefix"; then - for ac_prog in ar - 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 ${ac_cv_prog_AR+:} false; 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 as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_AR="$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 -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 - - - test -n "$AR" && break - done -fi -if test -z "$AR"; then - ac_ct_AR=$AR - for ac_prog in ar -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 ${ac_cv_prog_ac_ct_AR+:} false; 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 as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_ac_ct_AR="$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_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 - - - test -n "$ac_ct_AR" && break -done - - 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 -fi - -: ${AR=ar} -: ${AR_FLAGS=cru} - - - - - - - - - - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for archiver @FILE support" >&5 -$as_echo_n "checking for archiver @FILE support... " >&6; } -if ${lt_cv_ar_at_file+:} false; then : - $as_echo_n "(cached) " >&6 -else - lt_cv_ar_at_file=no - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - echo conftest.$ac_objext > conftest.lst - lt_ar_try='$AR $AR_FLAGS libconftest.a @conftest.lst >&5' - { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$lt_ar_try\""; } >&5 - (eval $lt_ar_try) 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } - if test 0 -eq "$ac_status"; then - # Ensure the archiver fails upon bogus file names. - rm -f conftest.$ac_objext libconftest.a - { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$lt_ar_try\""; } >&5 - (eval $lt_ar_try) 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } - if test 0 -ne "$ac_status"; then - lt_cv_ar_at_file=@ - fi - fi - rm -f conftest.* libconftest.a - -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_ar_at_file" >&5 -$as_echo "$lt_cv_ar_at_file" >&6; } - -if test no = "$lt_cv_ar_at_file"; then - archiver_list_spec= -else - archiver_list_spec=$lt_cv_ar_at_file -fi - - - - - - - -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 ${ac_cv_prog_STRIP+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_ac_ct_STRIP+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_RANLIB+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_ac_ct_RANLIB+:} false; 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 as_fn_executable_p "$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 - bitrig* | openbsd*) - old_postinstall_cmds="$old_postinstall_cmds~\$RANLIB -t \$tool_oldlib" - ;; - *) - old_postinstall_cmds="$old_postinstall_cmds~\$RANLIB \$tool_oldlib" - ;; - esac - old_archive_cmds="$old_archive_cmds~\$RANLIB \$tool_oldlib" -fi - -case $host_os in - darwin*) - lock_old_archive_extraction=yes ;; - *) - lock_old_archive_extraction=no ;; -esac - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -# 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 ${lt_cv_sys_global_symbol_pipe+:} false; 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 ia64 = "$host_cpu"; 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 - -if test "$lt_cv_nm_interface" = "MS dumpbin"; then - # Gets list of data symbols to import. - lt_cv_sys_global_symbol_to_import="sed -n -e 's/^I .* \(.*\)$/\1/p'" - # Adjust the below global symbol transforms to fixup imported variables. - lt_cdecl_hook=" -e 's/^I .* \(.*\)$/extern __declspec(dllimport) char \1;/p'" - lt_c_name_hook=" -e 's/^I .* \(.*\)$/ {\"\1\", (void *) 0},/p'" - lt_c_name_lib_hook="\ - -e 's/^I .* \(lib.*\)$/ {\"\1\", (void *) 0},/p'\ - -e 's/^I .* \(.*\)$/ {\"lib\1\", (void *) 0},/p'" -else - # Disable hooks by default. - lt_cv_sys_global_symbol_to_import= - lt_cdecl_hook= - lt_c_name_hook= - lt_c_name_lib_hook= -fi - -# 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"\ -$lt_cdecl_hook\ -" -e 's/^T .* \(.*\)$/extern int \1();/p'"\ -" -e 's/^$symcode$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"\ -$lt_c_name_hook\ -" -e 's/^: \(.*\) .*$/ {\"\1\", (void *) 0},/p'"\ -" -e 's/^$symcode$symcode* .* \(.*\)$/ {\"\1\", (void *) \&\1},/p'" - -# Transform an extracted symbol line into symbol name with lib prefix and -# symbol address. -lt_cv_sys_global_symbol_to_c_name_address_lib_prefix="sed -n"\ -$lt_c_name_lib_hook\ -" -e 's/^: \(.*\) .*$/ {\"\1\", (void *) 0},/p'"\ -" -e 's/^$symcode$symcode* .* \(lib.*\)$/ {\"\1\", (void *) \&\1},/p'"\ -" -e 's/^$symcode$symcode* .* \(.*\)$/ {\"lib\1\", (void *) \&\1},/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, - # D for any global variable and I for any imported 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};"\ -" /^COFF SYMBOL TABLE/{for(i in hide) delete hide[i]};"\ -" /Section length .*#relocs.*(pick any)/{hide[last_section]=1};"\ -" /^ *Symbol name *: /{split(\$ 0,sn,\":\"); si=substr(sn[2],2)};"\ -" /^ *Type *: code/{print \"T\",si,substr(si,length(prfx))};"\ -" /^ *Type *: data/{print \"I\",si,substr(si,length(prfx))};"\ -" \$ 0!~/External *\|/{next};"\ -" / 0+ UNDEF /{next}; / UNDEF \([^|]\)*()/{next};"\ -" {if(hide[section]) next};"\ -" {f=\"D\"}; \$ 0~/\(\).*\|/{f=\"T\"};"\ -" {split(\$ 0,a,/\||\r/); split(a[2],s)};"\ -" s[1]~/^[@?]/{print f,s[1],s[1]; next};"\ -" s[1]~prfx {split(s[1],t,\"@\"); print f,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 - lt_cv_sys_global_symbol_pipe="$lt_cv_sys_global_symbol_pipe | sed '/ __gnu_lto/d'" - - # 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 -/* Keep this code in sync between libtool.m4, ltmain, lt_system.h, and tests. */ -#if defined _WIN32 || defined __CYGWIN__ || defined _WIN32_WCE -/* DATA imports from DLLs on WIN32 can't be const, because runtime - relocations are performed -- see ld's documentation on pseudo-relocs. */ -# define LT_DLSYM_CONST -#elif defined __osf__ -/* This system does not cope well with relocations in const data. */ -# define LT_DLSYM_CONST -#else -# define LT_DLSYM_CONST const -#endif - -#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. */ -LT_DLSYM_CONST struct { - const char *name; - void *address; -} -lt__PROGRAM__LTX_preloaded_symbols[] = -{ - { "@PROGRAM@", (void *) 0 }, -_LT_EOF - $SED "s/^$symcode$symcode* .* \(.*\)$/ {\"\1\", (void *) \&\1},/" < "$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_globsym_save_LIBS=$LIBS - lt_globsym_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_globsym_save_LIBS - CFLAGS=$lt_globsym_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 yes = "$pipe_works"; 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 - -# Response file support. -if test "$lt_cv_nm_interface" = "MS dumpbin"; then - nm_file_list_spec='@' -elif $NM --help 2>/dev/null | grep '[@]FILE' >/dev/null; then - nm_file_list_spec='@' -fi - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for sysroot" >&5 -$as_echo_n "checking for sysroot... " >&6; } - -# Check whether --with-sysroot was given. -if test "${with_sysroot+set}" = set; then : - withval=$with_sysroot; -else - with_sysroot=no -fi - - -lt_sysroot= -case $with_sysroot in #( - yes) - if test yes = "$GCC"; then - lt_sysroot=`$CC --print-sysroot 2>/dev/null` - fi - ;; #( - /*) - lt_sysroot=`echo "$with_sysroot" | sed -e "$sed_quote_subst"` - ;; #( - no|'') - ;; #( - *) - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $with_sysroot" >&5 -$as_echo "$with_sysroot" >&6; } - as_fn_error $? "The sysroot must be an absolute path." "$LINENO" 5 - ;; -esac - - { $as_echo "$as_me:${as_lineno-$LINENO}: result: ${lt_sysroot:-no}" >&5 -$as_echo "${lt_sysroot:-no}" >&6; } - - - - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for a working dd" >&5 -$as_echo_n "checking for a working dd... " >&6; } -if ${ac_cv_path_lt_DD+:} false; then : - $as_echo_n "(cached) " >&6 -else - printf 0123456789abcdef0123456789abcdef >conftest.i -cat conftest.i conftest.i >conftest2.i -: ${lt_DD:=$DD} -if test -z "$lt_DD"; then - ac_path_lt_DD_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 dd; do - for ac_exec_ext in '' $ac_executable_extensions; do - ac_path_lt_DD="$as_dir/$ac_prog$ac_exec_ext" - as_fn_executable_p "$ac_path_lt_DD" || continue -if "$ac_path_lt_DD" bs=32 count=1 conftest.out 2>/dev/null; then - cmp -s conftest.i conftest.out \ - && ac_cv_path_lt_DD="$ac_path_lt_DD" ac_path_lt_DD_found=: -fi - $ac_path_lt_DD_found && break 3 - done - done - done -IFS=$as_save_IFS - if test -z "$ac_cv_path_lt_DD"; then - : - fi -else - ac_cv_path_lt_DD=$lt_DD -fi - -rm -f conftest.i conftest2.i conftest.out -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_lt_DD" >&5 -$as_echo "$ac_cv_path_lt_DD" >&6; } - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to truncate binary pipes" >&5 -$as_echo_n "checking how to truncate binary pipes... " >&6; } -if ${lt_cv_truncate_bin+:} false; then : - $as_echo_n "(cached) " >&6 -else - printf 0123456789abcdef0123456789abcdef >conftest.i -cat conftest.i conftest.i >conftest2.i -lt_cv_truncate_bin= -if "$ac_cv_path_lt_DD" bs=32 count=1 conftest.out 2>/dev/null; then - cmp -s conftest.i conftest.out \ - && lt_cv_truncate_bin="$ac_cv_path_lt_DD bs=4096 count=1" -fi -rm -f conftest.i conftest2.i conftest.out -test -z "$lt_cv_truncate_bin" && lt_cv_truncate_bin="$SED -e 4q" -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_truncate_bin" >&5 -$as_echo "$lt_cv_truncate_bin" >&6; } - - - - - - - -# Calculate cc_basename. Skip known compiler wrappers and cross-prefix. -func_cc_basename () -{ - for cc_temp in $*""; do - case $cc_temp in - compile | *[\\/]compile | ccache | *[\\/]ccache ) ;; - distcc | *[\\/]distcc | purify | *[\\/]purify ) ;; - \-*) ;; - *) break;; - esac - done - func_cc_basename_result=`$ECHO "$cc_temp" | $SED "s%.*/%%; s%^$host_alias-%%"` -} - -# Check whether --enable-libtool-lock was given. -if test "${enable_libtool_lock+set}" = set; then : - enableval=$enable_libtool_lock; -fi - -test no = "$enable_libtool_lock" || 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 what ABI is being produced by ac_compile, and set mode - # options accordingly. - 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 what ABI is being produced by ac_compile, and set linker - # options accordingly. - echo '#line '$LINENO' "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 yes = "$lt_cv_prog_gnu_ld"; 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* - ;; - -mips64*-*linux*) - # Find out what ABI is being produced by ac_compile, and set linker - # options accordingly. - echo '#line '$LINENO' "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 - emul=elf - case `/usr/bin/file conftest.$ac_objext` in - *32-bit*) - emul="${emul}32" - ;; - *64-bit*) - emul="${emul}64" - ;; - esac - case `/usr/bin/file conftest.$ac_objext` in - *MSB*) - emul="${emul}btsmip" - ;; - *LSB*) - emul="${emul}ltsmip" - ;; - esac - case `/usr/bin/file conftest.$ac_objext` in - *N32*) - emul="${emul}n32" - ;; - esac - LD="${LD-ld} -m $emul" - fi - rm -rf conftest* - ;; - -x86_64-*kfreebsd*-gnu|x86_64-*linux*|powerpc*-*linux*| \ -s390*-*linux*|s390*-*tpf*|sparc*-*linux*) - # Find out what ABI is being produced by ac_compile, and set linker - # options accordingly. Note that the listed cases only cover the - # situations where additional linker options are needed (such as when - # doing 32-bit compilation for a host where ld defaults to 64-bit, or - # vice versa); the common cases where no linker options are needed do - # not appear in the list. - 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*) - case `/usr/bin/file conftest.o` in - *x86-64*) - LD="${LD-ld} -m elf32_x86_64" - ;; - *) - LD="${LD-ld} -m elf_i386" - ;; - esac - ;; - powerpc64le-*linux*) - LD="${LD-ld} -m elf32lppclinux" - ;; - 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" - ;; - powerpcle-*linux*) - LD="${LD-ld} -m elf64lppc" - ;; - 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 ${lt_cv_cc_needs_belf+:} false; 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 yes != "$lt_cv_cc_needs_belf"; then - # this is probably gcc 2.8.0, egcs 1.0 or newer; no need for -belf - CFLAGS=$SAVE_CFLAGS - fi - ;; -*-*solaris*) - # Find out what ABI is being produced by ac_compile, and set linker - # options accordingly. - 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*) - case $host in - i?86-*-solaris*|x86_64-*-solaris*) - LD="${LD-ld} -m elf_x86_64" - ;; - sparc*-*-solaris*) - LD="${LD-ld} -m elf64_sparc" - ;; - esac - # GNU ld 2.21 introduced _sol2 emulations. Use them if available. - if ${LD-ld} -V | grep _sol2 >/dev/null 2>&1; then - LD=${LD-ld}_sol2 - fi - ;; - *) - 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 - -if test -n "$ac_tool_prefix"; then - # Extract the first word of "${ac_tool_prefix}mt", so it can be a program name with args. -set dummy ${ac_tool_prefix}mt; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_MANIFEST_TOOL+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$MANIFEST_TOOL"; then - ac_cv_prog_MANIFEST_TOOL="$MANIFEST_TOOL" # 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 as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_MANIFEST_TOOL="${ac_tool_prefix}mt" - $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 -MANIFEST_TOOL=$ac_cv_prog_MANIFEST_TOOL -if test -n "$MANIFEST_TOOL"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $MANIFEST_TOOL" >&5 -$as_echo "$MANIFEST_TOOL" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - -fi -if test -z "$ac_cv_prog_MANIFEST_TOOL"; then - ac_ct_MANIFEST_TOOL=$MANIFEST_TOOL - # Extract the first word of "mt", so it can be a program name with args. -set dummy mt; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_ac_ct_MANIFEST_TOOL+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$ac_ct_MANIFEST_TOOL"; then - ac_cv_prog_ac_ct_MANIFEST_TOOL="$ac_ct_MANIFEST_TOOL" # 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 as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_ac_ct_MANIFEST_TOOL="mt" - $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_MANIFEST_TOOL=$ac_cv_prog_ac_ct_MANIFEST_TOOL -if test -n "$ac_ct_MANIFEST_TOOL"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_MANIFEST_TOOL" >&5 -$as_echo "$ac_ct_MANIFEST_TOOL" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - if test "x$ac_ct_MANIFEST_TOOL" = x; then - MANIFEST_TOOL=":" - 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 - MANIFEST_TOOL=$ac_ct_MANIFEST_TOOL - fi -else - MANIFEST_TOOL="$ac_cv_prog_MANIFEST_TOOL" -fi - -test -z "$MANIFEST_TOOL" && MANIFEST_TOOL=mt -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking if $MANIFEST_TOOL is a manifest tool" >&5 -$as_echo_n "checking if $MANIFEST_TOOL is a manifest tool... " >&6; } -if ${lt_cv_path_mainfest_tool+:} false; then : - $as_echo_n "(cached) " >&6 -else - lt_cv_path_mainfest_tool=no - echo "$as_me:$LINENO: $MANIFEST_TOOL '-?'" >&5 - $MANIFEST_TOOL '-?' 2>conftest.err > conftest.out - cat conftest.err >&5 - if $GREP 'Manifest Tool' conftest.out > /dev/null; then - lt_cv_path_mainfest_tool=yes - fi - rm -f conftest* -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_path_mainfest_tool" >&5 -$as_echo "$lt_cv_path_mainfest_tool" >&6; } -if test yes != "$lt_cv_path_mainfest_tool"; then - MANIFEST_TOOL=: -fi - - - - - - - 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 ${ac_cv_prog_DSYMUTIL+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_ac_ct_DSYMUTIL+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_NMEDIT+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_ac_ct_NMEDIT+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_LIPO+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_ac_ct_LIPO+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_OTOOL+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_ac_ct_OTOOL+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_OTOOL64+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_ac_ct_OTOOL64+:} false; 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 as_fn_executable_p "$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 ${lt_cv_apple_cc_single_mod+:} false; 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 there is a non-empty error log, and "single_module" - # appears in it, assume the flag caused a linker warning - if test -s conftest.err && $GREP single_module conftest.err; then - cat conftest.err >&5 - # Otherwise, if the output was created with a 0 exit code from - # the compiler, it worked. - elif test -f libconftest.dylib && test 0 = "$_lt_result"; 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 ${lt_cv_ld_exported_symbols_list+:} false; 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; } - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for -force_load linker flag" >&5 -$as_echo_n "checking for -force_load linker flag... " >&6; } -if ${lt_cv_ld_force_load+:} false; then : - $as_echo_n "(cached) " >&6 -else - lt_cv_ld_force_load=no - cat > conftest.c << _LT_EOF -int forced_loaded() { return 2;} -_LT_EOF - echo "$LTCC $LTCFLAGS -c -o conftest.o conftest.c" >&5 - $LTCC $LTCFLAGS -c -o conftest.o conftest.c 2>&5 - echo "$AR cru libconftest.a conftest.o" >&5 - $AR cru libconftest.a conftest.o 2>&5 - echo "$RANLIB libconftest.a" >&5 - $RANLIB libconftest.a 2>&5 - cat > conftest.c << _LT_EOF -int main() { return 0;} -_LT_EOF - echo "$LTCC $LTCFLAGS $LDFLAGS -o conftest conftest.c -Wl,-force_load,./libconftest.a" >&5 - $LTCC $LTCFLAGS $LDFLAGS -o conftest conftest.c -Wl,-force_load,./libconftest.a 2>conftest.err - _lt_result=$? - if test -s conftest.err && $GREP force_load conftest.err; then - cat conftest.err >&5 - elif test -f conftest && test 0 = "$_lt_result" && $GREP forced_load conftest >/dev/null 2>&1; then - lt_cv_ld_force_load=yes - else - cat conftest.err >&5 - fi - rm -f conftest.err libconftest.a conftest conftest.c - rm -rf conftest.dSYM - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_ld_force_load" >&5 -$as_echo "$lt_cv_ld_force_load" >&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 yes = "$lt_cv_apple_cc_single_mod"; then - _lt_dar_single_mod='$single_module' - fi - if test yes = "$lt_cv_ld_exported_symbols_list"; 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" && test no = "$lt_cv_ld_force_load"; then - _lt_dsymutil='~$DSYMUTIL $lib || :' - else - _lt_dsymutil= - fi - ;; - esac - -# func_munge_path_list VARIABLE PATH -# ----------------------------------- -# VARIABLE is name of variable containing _space_ separated list of -# directories to be munged by the contents of PATH, which is string -# having a format: -# "DIR[:DIR]:" -# string "DIR[ DIR]" will be prepended to VARIABLE -# ":DIR[:DIR]" -# string "DIR[ DIR]" will be appended to VARIABLE -# "DIRP[:DIRP]::[DIRA:]DIRA" -# string "DIRP[ DIRP]" will be prepended to VARIABLE and string -# "DIRA[ DIRA]" will be appended to VARIABLE -# "DIR[:DIR]" -# VARIABLE will be replaced by "DIR[ DIR]" -func_munge_path_list () -{ - case x$2 in - x) - ;; - *:) - eval $1=\"`$ECHO $2 | $SED 's/:/ /g'` \$$1\" - ;; - x:*) - eval $1=\"\$$1 `$ECHO $2 | $SED 's/:/ /g'`\" - ;; - *::*) - eval $1=\"\$$1\ `$ECHO $2 | $SED -e 's/.*:://' -e 's/:/ /g'`\" - eval $1=\"`$ECHO $2 | $SED -e 's/::.*//' -e 's/:/ /g'`\ \$$1\" - ;; - *) - eval $1=\"`$ECHO $2 | $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 -{ $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 ${ac_cv_prog_CPP+:} false; 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.i 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.i conftest.$ac_ext - -done -# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. -rm -f conftest.i 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.i 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.i conftest.$ac_ext - -done -# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. -rm -f conftest.i 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 ${ac_cv_header_stdc+:} false; 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 -" -if eval test \"x\$"$as_ac_Header"\" = 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" = xyes; then : - cat >>confdefs.h <<_ACEOF -#define HAVE_DLFCN_H 1 -_ACEOF - -fi - -done - - - - -func_stripname_cnf () -{ - case $2 in - .*) func_stripname_result=`$ECHO "$3" | $SED "s%^$1%%; s%\\\\$2\$%%"`;; - *) func_stripname_result=`$ECHO "$3" | $SED "s%^$1%%; s%$2\$%%"`;; - esac -} # func_stripname_cnf - - - - - -# 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; lt_p=${PACKAGE-default} - case $withval in - yes|no) pic_mode=$withval ;; - *) - pic_mode=default - # Look at the argument we got. We use all the common list separators. - lt_save_ifs=$IFS; IFS=$IFS$PATH_SEPARATOR, - for lt_pkg in $withval; do - IFS=$lt_save_ifs - if test "X$lt_pkg" = "X$lt_p"; then - pic_mode=yes - fi - done - IFS=$lt_save_ifs - ;; - esac -else - pic_mode=default -fi - - - - - - - - - # 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 - - - - - - - - - shared_archive_member_spec= -case $host,$enable_shared in -power*-*-aix[5-9]*,yes) - { $as_echo "$as_me:${as_lineno-$LINENO}: checking which variant of shared library versioning to provide" >&5 -$as_echo_n "checking which variant of shared library versioning to provide... " >&6; } - -# Check whether --with-aix-soname was given. -if test "${with_aix_soname+set}" = set; then : - withval=$with_aix_soname; case $withval in - aix|svr4|both) - ;; - *) - as_fn_error $? "Unknown argument to --with-aix-soname" "$LINENO" 5 - ;; - esac - lt_cv_with_aix_soname=$with_aix_soname -else - if ${lt_cv_with_aix_soname+:} false; then : - $as_echo_n "(cached) " >&6 -else - lt_cv_with_aix_soname=aix -fi - - with_aix_soname=$lt_cv_with_aix_soname -fi - - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $with_aix_soname" >&5 -$as_echo "$with_aix_soname" >&6; } - if test aix != "$with_aix_soname"; then - # For the AIX way of multilib, we name the shared archive member - # based on the bitwidth used, traditionally 'shr.o' or 'shr_64.o', - # and 'shr.imp' or 'shr_64.imp', respectively, for the Import File. - # Even when GNU compilers ignore OBJECT_MODE but need '-maix64' flag, - # the AIX toolchain works better with OBJECT_MODE set (default 32). - if test 64 = "${OBJECT_MODE-32}"; then - shared_archive_member_spec=shr_64 - else - shared_archive_member_spec=shr - fi - fi - ;; -*) - with_aix_soname=aix - ;; -esac - - - - - - - - - - -# 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 ${lt_cv_objdir+:} false; 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 set != "${COLLECT_NAMES+set}"; then - COLLECT_NAMES= - export COLLECT_NAMES - fi - ;; -esac - -# 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 - -func_cc_basename $compiler -cc_basename=$func_cc_basename_result - - -# 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 ${lt_cv_path_MAGIC_CMD+:} false; 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 ${lt_cv_path_MAGIC_CMD+:} false; 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 yes = "$GCC"; then - case $cc_basename in - nvcc*) - lt_prog_compiler_no_builtin_flag=' -Xcompiler -fno-builtin' ;; - *) - lt_prog_compiler_no_builtin_flag=' -fno-builtin' ;; - esac - - { $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 ${lt_cv_prog_compiler_rtti_exceptions+:} false; 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" ## exclude from sc_useless_quotes_in_assignment - # 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:$LINENO: $lt_compile\"" >&5) - (eval "$lt_compile" 2>conftest.err) - ac_status=$? - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $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 "$_lt_compiler_boilerplate" | $SED '/^$/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 yes = "$lt_cv_prog_compiler_rtti_exceptions"; 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= - - - if test yes = "$GCC"; then - lt_prog_compiler_wl='-Wl,' - lt_prog_compiler_static='-static' - - case $host_os in - aix*) - # All AIX code is PIC. - if test ia64 = "$host_cpu"; then - # AIX 5 now supports IA64 processor - lt_prog_compiler_static='-Bstatic' - fi - lt_prog_compiler_pic='-fPIC' - ;; - - 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' - case $host_os in - os2*) - lt_prog_compiler_static='$wl-static' - ;; - esac - ;; - - darwin* | rhapsody*) - # PIC is the default on this platform - # Common symbols not allowed in MH_DYLIB files - lt_prog_compiler_pic='-fno-common' - ;; - - haiku*) - # PIC is the default for Haiku. - # The "-static" flag exists, but is broken. - lt_prog_compiler_static= - ;; - - 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 - - case $cc_basename in - nvcc*) # Cuda Compiler Driver 2.2 - lt_prog_compiler_wl='-Xlinker ' - if test -n "$lt_prog_compiler_pic"; then - lt_prog_compiler_pic="-Xcompiler $lt_prog_compiler_pic" - fi - ;; - 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 ia64 = "$host_cpu"; then - # AIX 5 now supports IA64 processor - lt_prog_compiler_static='-Bstatic' - else - lt_prog_compiler_static='-bnso -bI:/lib/syscalls.exp' - fi - ;; - - darwin* | rhapsody*) - # PIC is the default on this platform - # Common symbols not allowed in MH_DYLIB files - lt_prog_compiler_pic='-fno-common' - case $cc_basename in - nagfor*) - # NAG Fortran compiler - lt_prog_compiler_wl='-Wl,-Wl,,' - lt_prog_compiler_pic='-PIC' - lt_prog_compiler_static='-Bstatic' - ;; - esac - ;; - - 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' - case $host_os in - os2*) - lt_prog_compiler_static='$wl-static' - ;; - esac - ;; - - 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 | kopensolaris*-gnu | 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' - ;; - nagfor*) - # NAG Fortran compiler - lt_prog_compiler_wl='-Wl,-Wl,,' - lt_prog_compiler_pic='-PIC' - lt_prog_compiler_static='-Bstatic' - ;; - tcc*) - # Fabrice Bellard et al's Tiny C Compiler - lt_prog_compiler_wl='-Wl,' - lt_prog_compiler_pic='-fPIC' - lt_prog_compiler_static='-static' - ;; - pgcc* | pgf77* | pgf90* | pgf95* | pgfortran*) - # 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* | bgxl* | bgf* | mpixl*) - # IBM XL C 8.0/Fortran 10.1, 11.1 on PPC and BlueGene - lt_prog_compiler_wl='-Wl,' - lt_prog_compiler_pic='-qpic' - lt_prog_compiler_static='-qstaticlink' - ;; - *) - case `$CC -V 2>&1 | sed 5q` in - *Sun\ Ceres\ Fortran* | *Sun*Fortran*\ [1-7].* | *Sun*Fortran*\ 8.[0-3]*) - # 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='' - ;; - *Sun\ F* | *Sun*Fortran*) - lt_prog_compiler_pic='-KPIC' - lt_prog_compiler_static='-Bstatic' - lt_prog_compiler_wl='-Qoption ld ' - ;; - *Sun\ C*) - # Sun C 5.9 - lt_prog_compiler_pic='-KPIC' - lt_prog_compiler_static='-Bstatic' - lt_prog_compiler_wl='-Wl,' - ;; - *Intel*\ [CF]*Compiler*) - lt_prog_compiler_wl='-Wl,' - lt_prog_compiler_pic='-fPIC' - lt_prog_compiler_static='-static' - ;; - *Portland\ Group*) - lt_prog_compiler_wl='-Wl,' - lt_prog_compiler_pic='-fpic' - lt_prog_compiler_static='-Bstatic' - ;; - 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* | sunf77* | sunf90* | sunf95*) - 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 that 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}: checking for $compiler option to produce PIC" >&5 -$as_echo_n "checking for $compiler option to produce PIC... " >&6; } -if ${lt_cv_prog_compiler_pic+:} false; then : - $as_echo_n "(cached) " >&6 -else - lt_cv_prog_compiler_pic=$lt_prog_compiler_pic -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_pic" >&5 -$as_echo "$lt_cv_prog_compiler_pic" >&6; } -lt_prog_compiler_pic=$lt_cv_prog_compiler_pic - -# -# 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 ${lt_cv_prog_compiler_pic_works+:} false; 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" ## exclude from sc_useless_quotes_in_assignment - # 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:$LINENO: $lt_compile\"" >&5) - (eval "$lt_compile" 2>conftest.err) - ac_status=$? - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $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 "$_lt_compiler_boilerplate" | $SED '/^$/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 yes = "$lt_cv_prog_compiler_pic_works"; 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 ${lt_cv_prog_compiler_static_works+:} false; 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 "$_lt_linker_boilerplate" | $SED '/^$/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 yes = "$lt_cv_prog_compiler_static_works"; 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 ${lt_cv_prog_compiler_c_o+:} false; 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:$LINENO: $lt_compile\"" >&5) - (eval "$lt_compile" 2>out/conftest.err) - ac_status=$? - cat out/conftest.err >&5 - echo "$as_me:$LINENO: \$? = $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 "$_lt_compiler_boilerplate" | $SED '/^$/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 ${lt_cv_prog_compiler_c_o+:} false; 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:$LINENO: $lt_compile\"" >&5) - (eval "$lt_compile" 2>out/conftest.err) - ac_status=$? - cat out/conftest.err >&5 - echo "$as_me:$LINENO: \$? = $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 "$_lt_compiler_boilerplate" | $SED '/^$/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 no = "$lt_cv_prog_compiler_c_o" && test no != "$need_locks"; 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 no = "$hard_links"; 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_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 yes != "$GCC"; then - with_gnu_ld=no - fi - ;; - interix*) - # we just hope/assume this is gcc and not c89 (= MSVC++) - with_gnu_ld=yes - ;; - openbsd* | bitrig*) - with_gnu_ld=no - ;; - esac - - ld_shlibs=yes - - # On some targets, GNU ld is compatible enough with the native linker - # that we're better off using the native interface for both. - lt_use_gnu_ld_interface=no - if test yes = "$with_gnu_ld"; then - case $host_os in - aix*) - # The AIX port of GNU ld has always aspired to compatibility - # with the native linker. However, as the warning in the GNU ld - # block says, versions before 2.19.5* couldn't really create working - # shared libraries, regardless of the interface used. - case `$LD -v 2>&1` in - *\ \(GNU\ Binutils\)\ 2.19.5*) ;; - *\ \(GNU\ Binutils\)\ 2.[2-9]*) ;; - *\ \(GNU\ Binutils\)\ [3-9]*) ;; - *) - lt_use_gnu_ld_interface=yes - ;; - esac - ;; - *) - lt_use_gnu_ld_interface=yes - ;; - esac - fi - - if test yes = "$lt_use_gnu_ld_interface"; 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 | $SED -e 's/(^)\+)\s\+//' 2>&1` in - *GNU\ gold*) supports_anon_versioning=yes ;; - *\ [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 ia64 != "$host_cpu"; then - ld_shlibs=no - cat <<_LT_EOF 1>&2 - -*** Warning: the GNU linker, at least up to release 2.19, 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 install binutils -*** 2.20 or above, or modify your PATH so that a non-GNU linker is found. -*** You will then need to restart the configuration process. - -_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' - export_dynamic_flag_spec='$wl--export-all-symbols' - 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/;s/^.*[ ]__nm__\([^ ]*\)[ ][^ ]*/\1 DATA/;/^I[ ]/d;/^[AITW][ ]/s/.* //'\'' | sort | uniq > $export_symbols' - exclude_expsyms='[_]+GLOBAL_OFFSET_TABLE_|[_]+GLOBAL__[FID]_.*|[_]+head_[A-Za-z0-9_]+_dll|[A-Za-z0-9_]+_dll_iname' - - 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, use it as - # is; otherwise, prepend EXPORTS... - archive_expsym_cmds='if test DEF = "`$SED -n -e '\''s/^[ ]*//'\'' -e '\''/^\(;.*\)*$/d'\'' -e '\''s/^\(EXPORTS\|LIBRARY\)\([ ].*\)*$/DEF/p'\'' -e q $export_symbols`" ; 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 - ;; - - haiku*) - archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' - link_all_deplibs=yes - ;; - - os2*) - hardcode_libdir_flag_spec='-L$libdir' - hardcode_minus_L=yes - allow_undefined_flag=unsupported - shrext_cmds=.dll - archive_cmds='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ - $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ - $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ - $ECHO EXPORTS >> $output_objdir/$libname.def~ - emxexp $libobjs | $SED /"_DLL_InitTerm"/d >> $output_objdir/$libname.def~ - $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ - emximp -o $lib $output_objdir/$libname.def' - archive_expsym_cmds='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ - $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ - $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ - $ECHO EXPORTS >> $output_objdir/$libname.def~ - prefix_cmds="$SED"~ - if test EXPORTS = "`$SED 1q $export_symbols`"; then - prefix_cmds="$prefix_cmds -e 1d"; - fi~ - prefix_cmds="$prefix_cmds -e \"s/^\(.*\)$/_\1/g\""~ - cat $export_symbols | $prefix_cmds >> $output_objdir/$libname.def~ - $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ - emximp -o $lib $output_objdir/$libname.def' - old_archive_From_new_cmds='emximp -o $output_objdir/${libname}_dll.a $output_objdir/$libname.def' - enable_shared_with_static_runtimes=yes - ;; - - 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 | kopensolaris*-gnu) - tmp_diet=no - if test linux-dietlibc = "$host_os"; 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 no = "$tmp_diet" - then - tmp_addflag=' $pic_flag' - 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; func_echo_all \"$new_convenience\"` $wl--no-whole-archive' - tmp_addflag=' $pic_flag' - ;; - pgf77* | pgf90* | pgf95* | pgfortran*) - # 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; func_echo_all \"$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' ;; - nagfor*) # NAGFOR 5.3 - tmp_sharedflag='-Wl,-shared' ;; - xl[cC]* | bgxl[cC]* | mpixl[cC]*) # IBM XL C 8.0 on PPC (deal with xlf below) - tmp_sharedflag='-qmkshrobj' - tmp_addflag= ;; - nvcc*) # Cuda Compiler Driver 2.2 - whole_archive_flag_spec='$wl--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` $wl--no-whole-archive' - compiler_needs_object=yes - ;; - 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; func_echo_all \"$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 yes = "$supports_anon_versioning"; 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 - tcc*) - export_dynamic_flag_spec='-rdynamic' - ;; - xlf* | bgf* | bgxlf* | mpixlf*) - # 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='$wl-rpath $wl$libdir' - archive_cmds='$LD -shared $libobjs $deplibs $linker_flags -soname $soname -o $lib' - if test yes = "$supports_anon_versioning"; 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 $linker_flags -soname $soname -version-script $output_objdir/$libname.ver -o $lib' - fi - ;; - esac - else - ld_shlibs=no - fi - ;; - - netbsd*) - 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 $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' - archive_expsym_cmds='$CC -shared $pic_flag $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 $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' - archive_expsym_cmds='$CC -shared $pic_flag $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 cannot -*** 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 $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' - archive_expsym_cmds='$CC -shared $pic_flag $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 no = "$ld_shlibs"; 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 yes = "$GCC" && 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 ia64 = "$host_cpu"; 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 GNU nm, but means don't demangle to AIX nm. - # Without the "-l" option, or with the "-B" option, AIX nm treats - # weak defined symbols like other global defined symbols, whereas - # GNU nm marks them as "W". - # While the 'weak' keyword is ignored in the Export File, we need - # it in the Import File for the 'aix-soname' feature, so we have - # to replace the "-B" option with "-P" for AIX 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") || (\$ 2 == "W")) && (substr(\$ 3,1,1) != ".")) { if (\$ 2 == "W") { print \$ 3 " weak" } else { print \$ 3 } } }'\'' | sort -u > $export_symbols' - else - export_symbols_cmds='`func_echo_all $NM | $SED -e '\''s/B\([^B]*\)$/P\1/'\''` -PCpgl $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B") || (\$ 2 == "W") || (\$ 2 == "V") || (\$ 2 == "Z")) && (substr(\$ 1,1,1) != ".")) { if ((\$ 2 == "W") || (\$ 2 == "V") || (\$ 2 == "Z")) { print \$ 1 " weak" } else { print \$ 1 } } }'\'' | 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 - # have runtime linking enabled, and use it for executables. - # For shared libraries, we enable/disable runtime linking - # depending on the kind of the shared library created - - # when "with_aix_soname,aix_use_runtimelinking" is: - # "aix,no" lib.a(lib.so.V) shared, rtl:no, for executables - # "aix,yes" lib.so shared, rtl:yes, for executables - # lib.a static archive - # "both,no" lib.so.V(shr.o) shared, rtl:yes - # lib.a(lib.so.V) shared, rtl:no, for executables - # "both,yes" lib.so.V(shr.o) shared, rtl:yes, for executables - # lib.a(lib.so.V) shared, rtl:no - # "svr4,*" lib.so.V(shr.o) shared, rtl:yes, for executables - # lib.a static archive - case $host_os in aix4.[23]|aix4.[23].*|aix[5-9]*) - for ld_flag in $LDFLAGS; do - if (test x-brtl = "x$ld_flag" || test x-Wl,-brtl = "x$ld_flag"); then - aix_use_runtimelinking=yes - break - fi - done - if test svr4,no = "$with_aix_soname,$aix_use_runtimelinking"; then - # With aix-soname=svr4, we create the lib.so.V shared archives only, - # so we don't have lib.a shared libs to link our executables. - # We have to force runtime linking in this case. - aix_use_runtimelinking=yes - LDFLAGS="$LDFLAGS -Wl,-brtl" - fi - ;; - 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,' - case $with_aix_soname,$aix_use_runtimelinking in - aix,*) ;; # traditional, no import file - svr4,* | *,yes) # use import file - # The Import File defines what to hardcode. - hardcode_direct=no - hardcode_direct_absolute=no - ;; - esac - - if test yes = "$GCC"; 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 yes = "$aix_use_runtimelinking"; then - shared_flag="$shared_flag "'$wl-G' - fi - # Need to ensure runtime linking is disabled for the traditional - # shared library, or the linker may eventually find shared libraries - # /with/ Import File - we do not want to mix them. - shared_flag_aix='-shared' - shared_flag_svr4='-shared $wl-G' - else - # not using gcc - if test ia64 = "$host_cpu"; 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 yes = "$aix_use_runtimelinking"; then - shared_flag='$wl-G' - else - shared_flag='$wl-bM:SRE' - fi - shared_flag_aix='$wl-bM:SRE' - shared_flag_svr4='$wl-G' - 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,yes = "$with_aix_soname,$aix_use_runtimelinking"; 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. - if test set = "${lt_cv_aix_libpath+set}"; then - aix_libpath=$lt_cv_aix_libpath -else - if ${lt_cv_aix_libpath_+:} false; then : - $as_echo_n "(cached) " >&6 -else - 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 - } - }' - lt_cv_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 "$lt_cv_aix_libpath_"; then - lt_cv_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 "$lt_cv_aix_libpath_"; then - lt_cv_aix_libpath_=/usr/lib:/lib - fi - -fi - - aix_libpath=$lt_cv_aix_libpath_ -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 -n "$allow_undefined_flag"; then func_echo_all "$wl$allow_undefined_flag"; else :; fi` $wl'$exp_sym_flag:\$export_symbols' '$shared_flag - else - if test ia64 = "$host_cpu"; 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. - if test set = "${lt_cv_aix_libpath+set}"; then - aix_libpath=$lt_cv_aix_libpath -else - if ${lt_cv_aix_libpath_+:} false; then : - $as_echo_n "(cached) " >&6 -else - 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 - } - }' - lt_cv_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 "$lt_cv_aix_libpath_"; then - lt_cv_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 "$lt_cv_aix_libpath_"; then - lt_cv_aix_libpath_=/usr/lib:/lib - fi - -fi - - aix_libpath=$lt_cv_aix_libpath_ -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' - if test yes = "$with_gnu_ld"; then - # We only use this code for GNU lds that support --whole-archive. - whole_archive_flag_spec='$wl--whole-archive$convenience $wl--no-whole-archive' - else - # Exported symbols can be pulled into shared objects from archives - whole_archive_flag_spec='$convenience' - fi - archive_cmds_need_lc=yes - archive_expsym_cmds='$RM -r $output_objdir/$realname.d~$MKDIR $output_objdir/$realname.d' - # -brtl affects multiple linker settings, -berok does not and is overridden later - compiler_flags_filtered='`func_echo_all "$compiler_flags " | $SED -e "s%-brtl\\([, ]\\)%-berok\\1%g"`' - if test svr4 != "$with_aix_soname"; then - # This is similar to how AIX traditionally builds its shared libraries. - archive_expsym_cmds="$archive_expsym_cmds"'~$CC '$shared_flag_aix' -o $output_objdir/$realname.d/$soname $libobjs $deplibs $wl-bnoentry '$compiler_flags_filtered'$wl-bE:$export_symbols$allow_undefined_flag~$AR $AR_FLAGS $output_objdir/$libname$release.a $output_objdir/$realname.d/$soname' - fi - if test aix != "$with_aix_soname"; then - archive_expsym_cmds="$archive_expsym_cmds"'~$CC '$shared_flag_svr4' -o $output_objdir/$realname.d/$shared_archive_member_spec.o $libobjs $deplibs $wl-bnoentry '$compiler_flags_filtered'$wl-bE:$export_symbols$allow_undefined_flag~$STRIP -e $output_objdir/$realname.d/$shared_archive_member_spec.o~( func_echo_all "#! $soname($shared_archive_member_spec.o)"; if test shr_64 = "$shared_archive_member_spec"; then func_echo_all "# 64"; else func_echo_all "# 32"; fi; cat $export_symbols ) > $output_objdir/$realname.d/$shared_archive_member_spec.imp~$AR $AR_FLAGS $output_objdir/$soname $output_objdir/$realname.d/$shared_archive_member_spec.o $output_objdir/$realname.d/$shared_archive_member_spec.imp' - else - # used by -dlpreopen to get the symbols - archive_expsym_cmds="$archive_expsym_cmds"'~$MV $output_objdir/$realname.d/$soname $output_objdir' - fi - archive_expsym_cmds="$archive_expsym_cmds"'~$RM -r $output_objdir/$realname.d' - 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. - case $cc_basename in - cl*) - # Native MSVC - hardcode_libdir_flag_spec=' ' - allow_undefined_flag=unsupported - always_export_symbols=yes - file_list_spec='@' - # 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 $output_objdir/$soname $libobjs $compiler_flags $deplibs -Wl,-DLL,-IMPLIB:"$tool_output_objdir$libname.dll.lib"~linknames=' - archive_expsym_cmds='if test DEF = "`$SED -n -e '\''s/^[ ]*//'\'' -e '\''/^\(;.*\)*$/d'\'' -e '\''s/^\(EXPORTS\|LIBRARY\)\([ ].*\)*$/DEF/p'\'' -e q $export_symbols`" ; then - cp "$export_symbols" "$output_objdir/$soname.def"; - echo "$tool_output_objdir$soname.def" > "$output_objdir/$soname.exp"; - else - $SED -e '\''s/^/-link -EXPORT:/'\'' < $export_symbols > $output_objdir/$soname.exp; - fi~ - $CC -o $tool_output_objdir$soname $libobjs $compiler_flags $deplibs "@$tool_output_objdir$soname.exp" -Wl,-DLL,-IMPLIB:"$tool_output_objdir$libname.dll.lib"~ - linknames=' - # The linker will not automatically build a static lib if we build a DLL. - # _LT_TAGVAR(old_archive_from_new_cmds, )='true' - enable_shared_with_static_runtimes=yes - exclude_expsyms='_NULL_IMPORT_DESCRIPTOR|_IMPORT_DESCRIPTOR_.*' - export_symbols_cmds='$NM $libobjs $convenience | $global_symbol_pipe | $SED -e '\''/^[BCDGRS][ ]/s/.*[ ]\([^ ]*\)/\1,DATA/'\'' | $SED -e '\''/^[AITW][ ]/s/.*[ ]//'\'' | sort | uniq > $export_symbols' - # Don't use ranlib - old_postinstall_cmds='chmod 644 $oldlib' - postlink_cmds='lt_outputfile="@OUTPUT@"~ - lt_tool_outputfile="@TOOL_OUTPUT@"~ - case $lt_outputfile in - *.exe|*.EXE) ;; - *) - lt_outputfile=$lt_outputfile.exe - lt_tool_outputfile=$lt_tool_outputfile.exe - ;; - esac~ - if test : != "$MANIFEST_TOOL" && test -f "$lt_outputfile.manifest"; then - $MANIFEST_TOOL -manifest "$lt_tool_outputfile.manifest" -outputresource:"$lt_tool_outputfile" || exit 1; - $RM "$lt_outputfile.manifest"; - fi' - ;; - *) - # Assume MSVC wrapper - 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 `func_echo_all "$deplibs" | $SED '\''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' - enable_shared_with_static_runtimes=yes - ;; - esac - ;; - - darwin* | rhapsody*) - - - archive_cmds_need_lc=no - hardcode_direct=no - hardcode_automatic=yes - hardcode_shlibpath_var=unsupported - if test yes = "$lt_cv_ld_force_load"; then - whole_archive_flag_spec='`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience $wl-force_load,$conv\"; done; func_echo_all \"$new_convenience\"`' - - else - whole_archive_flag_spec='' - fi - link_all_deplibs=yes - allow_undefined_flag=$_lt_dar_allow_undefined - case $cc_basename in - ifort*|nagfor*) _lt_dar_can_shared=yes ;; - *) _lt_dar_can_shared=$GCC ;; - esac - if test yes = "$_lt_dar_can_shared"; then - output_verbose_link_cmd=func_echo_all - 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 - ;; - - # 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 $pic_flag -o $lib $libobjs $deplibs $compiler_flags' - hardcode_libdir_flag_spec='-R$libdir' - hardcode_direct=yes - hardcode_shlibpath_var=no - ;; - - hpux9*) - if test yes = "$GCC"; then - archive_cmds='$RM $output_objdir/$soname~$CC -shared $pic_flag $wl+b $wl$install_libdir -o $output_objdir/$soname $libobjs $deplibs $compiler_flags~test "x$output_objdir/$soname" = "x$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 "x$output_objdir/$soname" = "x$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 yes,no = "$GCC,$with_gnu_ld"; then - archive_cmds='$CC -shared $pic_flag $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 no = "$with_gnu_ld"; then - hardcode_libdir_flag_spec='$wl+b $wl$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 yes,no = "$GCC,$with_gnu_ld"; 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 $pic_flag $wl+h $wl$soname $wl+nodefaultrpath -o $lib $libobjs $deplibs $compiler_flags' - ;; - *) - archive_cmds='$CC -shared $pic_flag $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' - ;; - *) - - # Older versions of the 11.00 compiler do not understand -b yet - # (HP92453-01 A.11.01.20 doesn't, HP92453-01 B.11.X.35175-35176.GP does) - { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $CC understands -b" >&5 -$as_echo_n "checking if $CC understands -b... " >&6; } -if ${lt_cv_prog_compiler__b+:} false; then : - $as_echo_n "(cached) " >&6 -else - lt_cv_prog_compiler__b=no - save_LDFLAGS=$LDFLAGS - LDFLAGS="$LDFLAGS -b" - 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 "$_lt_linker_boilerplate" | $SED '/^$/d' > conftest.exp - $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2 - if diff conftest.exp conftest.er2 >/dev/null; then - lt_cv_prog_compiler__b=yes - fi - else - lt_cv_prog_compiler__b=yes - fi - fi - $RM -r conftest* - LDFLAGS=$save_LDFLAGS - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler__b" >&5 -$as_echo "$lt_cv_prog_compiler__b" >&6; } - -if test yes = "$lt_cv_prog_compiler__b"; then - archive_cmds='$CC -b $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 - - ;; - esac - fi - if test no = "$with_gnu_ld"; 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 yes = "$GCC"; then - archive_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $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. - # This should be the same for all languages, so no per-tag cache variable. - { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the $host_os linker accepts -exported_symbol" >&5 -$as_echo_n "checking whether the $host_os linker accepts -exported_symbol... " >&6; } -if ${lt_cv_irix_exported_symbol+:} false; then : - $as_echo_n "(cached) " >&6 -else - 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) { return 0; } -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - lt_cv_irix_exported_symbol=yes -else - lt_cv_irix_exported_symbol=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_irix_exported_symbol" >&5 -$as_echo "$lt_cv_irix_exported_symbol" >&6; } - if test yes = "$lt_cv_irix_exported_symbol"; then - archive_expsym_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $wl-update_registry $wl$output_objdir/so_locations $wl-exports_file $wl$export_symbols -o $lib' - fi - else - archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry $output_objdir/so_locations -o $lib' - archive_expsym_cmds='$CC -shared $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -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 - ;; - - linux*) - case $cc_basename in - tcc*) - # Fabrice Bellard et al's Tiny C Compiler - ld_shlibs=yes - archive_cmds='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags' - ;; - esac - ;; - - netbsd*) - 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* | bitrig*) - 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__`"; 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 - archive_cmds='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags' - hardcode_libdir_flag_spec='$wl-rpath,$libdir' - fi - else - ld_shlibs=no - fi - ;; - - os2*) - hardcode_libdir_flag_spec='-L$libdir' - hardcode_minus_L=yes - allow_undefined_flag=unsupported - shrext_cmds=.dll - archive_cmds='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ - $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ - $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ - $ECHO EXPORTS >> $output_objdir/$libname.def~ - emxexp $libobjs | $SED /"_DLL_InitTerm"/d >> $output_objdir/$libname.def~ - $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ - emximp -o $lib $output_objdir/$libname.def' - archive_expsym_cmds='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ - $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ - $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ - $ECHO EXPORTS >> $output_objdir/$libname.def~ - prefix_cmds="$SED"~ - if test EXPORTS = "`$SED 1q $export_symbols`"; then - prefix_cmds="$prefix_cmds -e 1d"; - fi~ - prefix_cmds="$prefix_cmds -e \"s/^\(.*\)$/_\1/g\""~ - cat $export_symbols | $prefix_cmds >> $output_objdir/$libname.def~ - $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ - emximp -o $lib $output_objdir/$libname.def' - old_archive_From_new_cmds='emximp -o $output_objdir/${libname}_dll.a $output_objdir/$libname.def' - enable_shared_with_static_runtimes=yes - ;; - - osf3*) - if test yes = "$GCC"; 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" && func_echo_all "$wl-set_version $wl$verstring"` $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" && func_echo_all "-set_version $verstring"` -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 yes = "$GCC"; then - allow_undefined_flag=' $wl-expect_unresolved $wl\*' - archive_cmds='$CC -shared$allow_undefined_flag $pic_flag $libobjs $deplibs $compiler_flags $wl-msym $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $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" && func_echo_all "-set_version $verstring"` -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 "-set_version $verstring"` -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 yes = "$GCC"; then - wlarc='$wl' - archive_cmds='$CC -shared $pic_flag $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 $pic_flag $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 yes = "$GCC"; 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 sequent = "$host_vendor"; 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 yes = "$GCC"; 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 CANNOT 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 yes = "$GCC"; 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 sni = "$host_vendor"; 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 no = "$ld_shlibs" && 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 yes,yes = "$GCC,$enable_shared"; 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; } -if ${lt_cv_archive_cmds_need_lc+:} false; then : - $as_echo_n "(cached) " >&6 -else - $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 - lt_cv_archive_cmds_need_lc=no - else - lt_cv_archive_cmds_need_lc=yes - fi - allow_undefined_flag=$lt_save_allow_undefined_flag - else - cat conftest.err 1>&5 - fi - $RM conftest* - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_archive_cmds_need_lc" >&5 -$as_echo "$lt_cv_archive_cmds_need_lc" >&6; } - archive_cmds_need_lc=$lt_cv_archive_cmds_need_lc - ;; - 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 yes = "$GCC"; then - case $host_os in - darwin*) lt_awk_arg='/^libraries:/,/LR/' ;; - *) lt_awk_arg='/^libraries:/' ;; - esac - case $host_os in - mingw* | cegcc*) lt_sed_strip_eq='s|=\([A-Za-z]:\)|\1|g' ;; - *) lt_sed_strip_eq='s|=/|/|g' ;; - esac - lt_search_path_spec=`$CC -print-search-dirs | awk $lt_awk_arg | $SED -e "s/^libraries://" -e $lt_sed_strip_eq` - case $lt_search_path_spec in - *\;*) - # 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 's/;/ /g'` - ;; - *) - lt_search_path_spec=`$ECHO "$lt_search_path_spec" | $SED "s/$PATH_SEPARATOR/ /g"` - ;; - esac - # 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` - # ...but if some path component already ends with the multilib dir we assume - # that all is fine and trust -print-search-dirs as is (GCC 4.2? or newer). - case "$lt_multi_os_dir; $lt_search_path_spec " in - "/; "* | "/.; "* | "/./; "* | *"$lt_multi_os_dir "* | *"$lt_multi_os_dir/ "*) - lt_multi_os_dir= - ;; - esac - 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" - elif test -n "$lt_multi_os_dir"; then - 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; } -}'` - # AWK program above erroneously prepends '/' to C:/dos/paths - # for these hosts. - case $host_os in - mingw* | cegcc*) lt_search_path_spec=`$ECHO "$lt_search_path_spec" |\ - $SED 's|/\([A-Za-z]:\)|\1|g'` ;; - esac - sys_lib_search_path_spec=`$ECHO "$lt_search_path_spec" | $lt_NL2SP` -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 # correct to gnu/linux during the next big refactor - 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 # correct to gnu/linux during the next big refactor - need_lib_prefix=no - need_version=no - hardcode_into_libs=yes - if test ia64 = "$host_cpu"; 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 - # Using Import Files as archive members, it is possible to support - # filename-based versioning of shared library archives on AIX. While - # this would work for both with and without runtime linking, it will - # prevent static linking of such archives. So we do filename-based - # shared library versioning with .so extension only, which is used - # when both runtime linking and shared linking is enabled. - # Unfortunately, runtime linking may impact performance, so we do - # not want this to be the default eventually. Also, we use the - # versioned .so libs for executables only if there is the -brtl - # linker flag in LDFLAGS as well, or --with-aix-soname=svr4 only. - # To allow for filename-based versioning support, we need to create - # libNAME.so.V as an archive file, containing: - # *) an Import File, referring to the versioned filename of the - # archive as well as the shared archive member, telling the - # bitwidth (32 or 64) of that shared object, and providing the - # list of exported symbols of that shared object, eventually - # decorated with the 'weak' keyword - # *) the shared object with the F_LOADONLY flag set, to really avoid - # it being seen by the linker. - # At run time we better use the real file rather than another symlink, - # but for link time we create the symlink libNAME.so -> libNAME.so.V - - case $with_aix_soname,$aix_use_runtimelinking in - # AIX (on Power*) has no versioning support, so currently we cannot hardcode correct - # soname into executable. Probably we can add versioning support to - # collect2, so additional links can be useful in future. - aix,yes) # traditional libtool - dynamic_linker='AIX unversionable lib.so' - # 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' - ;; - aix,no) # traditional AIX only - dynamic_linker='AIX lib.a(lib.so.V)' - # 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' - ;; - svr4,*) # full svr4 only - dynamic_linker="AIX lib.so.V($shared_archive_member_spec.o)" - library_names_spec='$libname$release$shared_ext$major $libname$shared_ext' - # We do not specify a path in Import Files, so LIBPATH fires. - shlibpath_overrides_runpath=yes - ;; - *,yes) # both, prefer svr4 - dynamic_linker="AIX lib.so.V($shared_archive_member_spec.o), lib.a(lib.so.V)" - library_names_spec='$libname$release$shared_ext$major $libname$shared_ext' - # unpreferred sharedlib libNAME.a needs extra handling - postinstall_cmds='test -n "$linkname" || linkname="$realname"~func_stripname "" ".so" "$linkname"~$install_shared_prog "$dir/$func_stripname_result.$libext" "$destdir/$func_stripname_result.$libext"~test -z "$tstripme" || test -z "$striplib" || $striplib "$destdir/$func_stripname_result.$libext"' - postuninstall_cmds='for n in $library_names $old_library; do :; done~func_stripname "" ".so" "$n"~test "$func_stripname_result" = "$n" || func_append rmfiles " $odir/$func_stripname_result.$libext"' - # We do not specify a path in Import Files, so LIBPATH fires. - shlibpath_overrides_runpath=yes - ;; - *,no) # both, prefer aix - dynamic_linker="AIX lib.a(lib.so.V), lib.so.V($shared_archive_member_spec.o)" - library_names_spec='$libname$release.a $libname.a' - soname_spec='$libname$release$shared_ext$major' - # unpreferred sharedlib libNAME.so.V and symlink libNAME.so need extra handling - postinstall_cmds='test -z "$dlname" || $install_shared_prog $dir/$dlname $destdir/$dlname~test -z "$tstripme" || test -z "$striplib" || $striplib $destdir/$dlname~test -n "$linkname" || linkname=$realname~func_stripname "" ".a" "$linkname"~(cd "$destdir" && $LN_S -f $dlname $func_stripname_result.so)' - postuninstall_cmds='test -z "$dlname" || func_append rmfiles " $odir/$dlname"~for n in $old_library $library_names; do :; done~func_stripname "" ".a" "$n"~func_append rmfiles " $odir/$func_stripname_result.so"' - ;; - esac - 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=`func_echo_all "$lib" | $SED '\''s%^.*/\([^/]*\)\.ixlibrary$%\1%'\''`; $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 # correct to gnu/linux during the next big refactor - 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,$cc_basename in - yes,*) - # gcc - 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="$sys_lib_search_path_spec /usr/lib/w32api" - ;; - mingw* | cegcc*) - # MinGW DLLs use traditional 'lib' prefix - soname_spec='$libname`echo $release | $SED -e 's/[.]/-/g'`$versuffix$shared_ext' - ;; - 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 - dynamic_linker='Win32 ld.exe' - ;; - - *,cl*) - # Native MSVC - libname_spec='$name' - soname_spec='$libname`echo $release | $SED -e 's/[.]/-/g'`$versuffix$shared_ext' - library_names_spec='$libname.dll.lib' - - case $build_os in - mingw*) - sys_lib_search_path_spec= - lt_save_ifs=$IFS - IFS=';' - for lt_path in $LIB - do - IFS=$lt_save_ifs - # Let DOS variable expansion print the short 8.3 style file name. - lt_path=`cd "$lt_path" 2>/dev/null && cmd //C "for %i in (".") do @echo %~si"` - sys_lib_search_path_spec="$sys_lib_search_path_spec $lt_path" - done - IFS=$lt_save_ifs - # Convert to MSYS style. - sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | sed -e 's|\\\\|/|g' -e 's| \\([a-zA-Z]\\):| /\\1|g' -e 's|^ ||'` - ;; - cygwin*) - # Convert to unix form, then to dos form, then back to unix form - # but this time dos style (no spaces!) so that the unix form looks - # like /cygdrive/c/PROGRA~1:/cygdr... - sys_lib_search_path_spec=`cygpath --path --unix "$LIB"` - sys_lib_search_path_spec=`cygpath --path --dos "$sys_lib_search_path_spec" 2>/dev/null` - sys_lib_search_path_spec=`cygpath --path --unix "$sys_lib_search_path_spec" | $SED -e "s/$PATH_SEPARATOR/ /g"` - ;; - *) - sys_lib_search_path_spec=$LIB - if $ECHO "$sys_lib_search_path_spec" | $GREP ';[c-zC-Z]:/' >/dev/null; then - # It is most probably a Windows format PATH. - 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 - # FIXME: find the short name or the path components, as spaces are - # common. (e.g. "Program Files" -> "PROGRA~1") - ;; - esac - - # 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' - postuninstall_cmds='dldll=`$SHELL 2>&1 -c '\''. $file; echo \$dlname'\''`~ - dlpath=$dir/\$dldll~ - $RM \$dlpath' - shlibpath_overrides_runpath=yes - dynamic_linker='Win32 link.exe' - ;; - - *) - # Assume MSVC wrapper - library_names_spec='$libname`echo $release | $SED -e 's/[.]/-/g'`$versuffix$shared_ext $libname.lib' - dynamic_linker='Win32 ld.exe' - ;; - esac - # 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 # correct to gnu/linux during the next big refactor - 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 - ;; - -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[23].*) 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$major $libname$shared_ext' - soname_spec='$libname$release$shared_ext$major' - 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 - ;; - -haiku*) - version_type=linux # correct to gnu/linux during the next big refactor - need_lib_prefix=no - need_version=no - dynamic_linker="$host_os runtime_loader" - 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=LIBRARY_PATH - shlibpath_overrides_runpath=no - sys_lib_dlsearch_path_spec='/boot/home/config/lib /boot/common/lib /boot/system/lib' - 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 32 = "$HPUX_IA64_MODE"; then - sys_lib_search_path_spec="/usr/lib/hpux32 /usr/local/lib/hpux32 /usr/local/lib" - sys_lib_dlsearch_path_spec=/usr/lib/hpux32 - else - sys_lib_search_path_spec="/usr/lib/hpux64 /usr/local/lib/hpux64" - sys_lib_dlsearch_path_spec=/usr/lib/hpux64 - fi - ;; - 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' - # or fails outright, so override atomically: - install_override_mode=555 - ;; - -interix[3-9]*) - version_type=linux # correct to gnu/linux during the next big refactor - 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 yes = "$lt_cv_prog_gnu_ld"; then - version_type=linux # correct to gnu/linux during the next big refactor - 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 - ;; - -linux*android*) - version_type=none # Android doesn't support versioned libraries. - need_lib_prefix=no - need_version=no - library_names_spec='$libname$release$shared_ext' - soname_spec='$libname$release$shared_ext' - finish_cmds= - shlibpath_var=LD_LIBRARY_PATH - shlibpath_overrides_runpath=yes - - # 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 - - dynamic_linker='Android linker' - # Don't embed -rpath directories since the linker doesn't support them. - hardcode_libdir_flag_spec='-L$libdir' - ;; - -# This must be glibc/ELF. -linux* | k*bsd*-gnu | kopensolaris*-gnu | gnu*) - version_type=linux # correct to gnu/linux during the next big refactor - 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 - if ${lt_cv_shlibpath_overrides_runpath+:} false; then : - $as_echo_n "(cached) " >&6 -else - lt_cv_shlibpath_overrides_runpath=no - 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 : - lt_cv_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 - -fi - - shlibpath_overrides_runpath=$lt_cv_shlibpath_overrides_runpath - - # 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 - - # Ideally, we could use ldconfig to report *all* directores which are - # searched for libraries, however this is still not possible. Aside from not - # being certain /sbin/ldconfig is available, command - # 'ldconfig -N -X -v | grep ^/' on 64bit Fedora does not report /usr/lib64, - # even though it is searched at run-time. Try to do the best guess by - # appending ld.so.conf contents (and includes) 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;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' - ;; - -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 # correct to gnu/linux during the next big refactor - 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* | bitrig*) - version_type=sunos - sys_lib_dlsearch_path_spec=/usr/lib - need_lib_prefix=no - if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`"; then - need_version=no - else - need_version=yes - fi - 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 - shlibpath_overrides_runpath=yes - ;; - -os2*) - libname_spec='$name' - version_type=windows - shrext_cmds=.dll - need_version=no - need_lib_prefix=no - # OS/2 can only load a DLL with a base name of 8 characters or less. - soname_spec='`test -n "$os2dllname" && libname="$os2dllname"; - v=$($ECHO $release$versuffix | tr -d .-); - n=$($ECHO $libname | cut -b -$((8 - ${#v})) | tr . _); - $ECHO $n$v`$shared_ext' - library_names_spec='${libname}_dll.$libext' - dynamic_linker='OS/2 ld.exe' - shlibpath_var=BEGINLIBPATH - sys_lib_search_path_spec="/lib /usr/lib /usr/local/lib" - sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec - 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' - ;; - -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 # correct to gnu/linux during the next big refactor - 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 yes = "$with_gnu_ld"; then - need_lib_prefix=no - fi - need_version=yes - ;; - -sysv4 | sysv4.3*) - version_type=linux # correct to gnu/linux during the next big refactor - 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 # correct to gnu/linux during the next big refactor - 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=sco - 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 yes = "$with_gnu_ld"; 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 # correct to gnu/linux during the next big refactor - 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 # correct to gnu/linux during the next big refactor - 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 no = "$dynamic_linker" && can_build_shared=no - -variables_saved_for_relink="PATH $shlibpath_var $runpath_var" -if test yes = "$GCC"; then - variables_saved_for_relink="$variables_saved_for_relink GCC_EXEC_PREFIX COMPILER_PATH LIBRARY_PATH" -fi - -if test set = "${lt_cv_sys_lib_search_path_spec+set}"; then - sys_lib_search_path_spec=$lt_cv_sys_lib_search_path_spec -fi - -if test set = "${lt_cv_sys_lib_dlsearch_path_spec+set}"; then - sys_lib_dlsearch_path_spec=$lt_cv_sys_lib_dlsearch_path_spec -fi - -# remember unaugmented sys_lib_dlsearch_path content for libtool script decls... -configure_time_dlsearch_path=$sys_lib_dlsearch_path_spec - -# ... but it needs LT_SYS_LIBRARY_PATH munging for other configure-time code -func_munge_path_list sys_lib_dlsearch_path_spec "$LT_SYS_LIBRARY_PATH" - -# to be used as default LT_SYS_LIBRARY_PATH value in generated libtool -configure_time_lt_sys_library_path=$LT_SYS_LIBRARY_PATH - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - { $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 yes = "$hardcode_automatic"; then - - # We can hardcode non-existent directories. - if test no != "$hardcode_direct" && - # 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 no != "$_LT_TAGVAR(hardcode_shlibpath_var, )" && - test no != "$hardcode_minus_L"; 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 relink = "$hardcode_action" || - test yes = "$inherit_rpath"; then - # Fast installation is not supported - enable_fast_install=no -elif test yes = "$shlibpath_overrides_runpath" || - test no = "$enable_shared"; then - # Fast installation is not necessary - enable_fast_install=needless -fi - - - - - - - if test yes != "$enable_dlopen"; 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 ${ac_cv_lib_dl_dlopen+:} false; 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" = xyes; 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 - - ;; - - tpf*) - # Don't try to run any link tests for TPF. We know it's impossible - # because TPF is a cross-compiler, and we know how we open DSOs. - lt_cv_dlopen=dlopen - lt_cv_dlopen_libs= - lt_cv_dlopen_self=no - ;; - - *) - ac_fn_c_check_func "$LINENO" "shl_load" "ac_cv_func_shl_load" -if test "x$ac_cv_func_shl_load" = xyes; 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 ${ac_cv_lib_dld_shl_load+:} false; 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" = xyes; 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" = xyes; 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 ${ac_cv_lib_dl_dlopen+:} false; 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" = xyes; 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 ${ac_cv_lib_svld_dlopen+:} false; 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" = xyes; 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 ${ac_cv_lib_dld_dld_link+:} false; 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" = xyes; then : - lt_cv_dlopen=dld_link lt_cv_dlopen_libs=-ldld -fi - - -fi - - -fi - - -fi - - -fi - - -fi - - ;; - esac - - if test no = "$lt_cv_dlopen"; then - enable_dlopen=no - else - enable_dlopen=yes - fi - - case $lt_cv_dlopen in - dlopen) - save_CPPFLAGS=$CPPFLAGS - test yes = "$ac_cv_header_dlfcn_h" && 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 ${lt_cv_dlopen_self+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test yes = "$cross_compiling"; 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 $LINENO "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 - -/* When -fvisibility=hidden is used, assume the code has been annotated - correspondingly for the symbols needed. */ -#if defined __GNUC__ && (((__GNUC__ == 3) && (__GNUC_MINOR__ >= 3)) || (__GNUC__ > 3)) -int fnord () __attribute__((visibility("default"))); -#endif - -int fnord () { return 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; - else puts (dlerror ()); - } - /* 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 yes = "$lt_cv_dlopen_self"; 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 ${lt_cv_dlopen_self_static+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test yes = "$cross_compiling"; 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 $LINENO "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 - -/* When -fvisibility=hidden is used, assume the code has been annotated - correspondingly for the symbols needed. */ -#if defined __GNUC__ && (((__GNUC__ == 3) && (__GNUC_MINOR__ >= 3)) || (__GNUC__ > 3)) -int fnord () __attribute__((visibility("default"))); -#endif - -int fnord () { return 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; - else puts (dlerror ()); - } - /* 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 what 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 no = "$can_build_shared" && 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 yes = "$enable_shared" && enable_static=no - if test -n "$RANLIB"; then - archive_cmds="$archive_cmds~\$RANLIB \$lib" - postinstall_cmds='$RANLIB $lib' - fi - ;; - - aix[4-9]*) - if test ia64 != "$host_cpu"; then - case $enable_shared,$with_aix_soname,$aix_use_runtimelinking in - yes,aix,yes) ;; # shared object as lib.so file only - yes,svr4,*) ;; # shared object as lib.so archive member only - yes,*) enable_static=no ;; # shared object in lib.a archive as well - esac - 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 yes = "$enable_shared" || 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 - - if test -n "$CXX" && ( test no != "$CXX" && - ( (test g++ = "$CXX" && `g++ -v >/dev/null 2>&1` ) || - (test g++ != "$CXX"))); then - ac_ext=cpp -ac_cpp='$CXXCPP $CPPFLAGS' -ac_compile='$CXX -c $CXXFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CXX -o conftest$ac_exeext $CXXFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_cxx_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; } -if test -z "$CXXCPP"; then - if ${ac_cv_prog_CXXCPP+:} false; then : - $as_echo_n "(cached) " >&6 -else - # Double quotes because CXXCPP needs to be expanded - for CXXCPP in "$CXX -E" "/lib/cpp" - do - ac_preproc_ok=false -for ac_cxx_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_cxx_try_cpp "$LINENO"; then : - -else - # Broken: fails on valid input. -continue -fi -rm -f conftest.err conftest.i 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_cxx_try_cpp "$LINENO"; then : - # Broken: success on invalid input. -continue -else - # Passes both tests. -ac_preproc_ok=: -break -fi -rm -f conftest.err conftest.i conftest.$ac_ext - -done -# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. -rm -f conftest.i conftest.err conftest.$ac_ext -if $ac_preproc_ok; then : - break -fi - - done - ac_cv_prog_CXXCPP=$CXXCPP - -fi - CXXCPP=$ac_cv_prog_CXXCPP -else - ac_cv_prog_CXXCPP=$CXXCPP -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $CXXCPP" >&5 -$as_echo "$CXXCPP" >&6; } -ac_preproc_ok=false -for ac_cxx_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_cxx_try_cpp "$LINENO"; then : - -else - # Broken: fails on valid input. -continue -fi -rm -f conftest.err conftest.i 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_cxx_try_cpp "$LINENO"; then : - # Broken: success on invalid input. -continue -else - # Passes both tests. -ac_preproc_ok=: -break -fi -rm -f conftest.err conftest.i conftest.$ac_ext - -done -# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. -rm -f conftest.i 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 \"$CXXCPP\" 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 - -else - _lt_caught_CXX_error=yes -fi - -ac_ext=cpp -ac_cpp='$CXXCPP $CPPFLAGS' -ac_compile='$CXX -c $CXXFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CXX -o conftest$ac_exeext $CXXFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_cxx_compiler_gnu - -archive_cmds_need_lc_CXX=no -allow_undefined_flag_CXX= -always_export_symbols_CXX=no -archive_expsym_cmds_CXX= -compiler_needs_object_CXX=no -export_dynamic_flag_spec_CXX= -hardcode_direct_CXX=no -hardcode_direct_absolute_CXX=no -hardcode_libdir_flag_spec_CXX= -hardcode_libdir_separator_CXX= -hardcode_minus_L_CXX=no -hardcode_shlibpath_var_CXX=unsupported -hardcode_automatic_CXX=no -inherit_rpath_CXX=no -module_cmds_CXX= -module_expsym_cmds_CXX= -link_all_deplibs_CXX=unknown -old_archive_cmds_CXX=$old_archive_cmds -reload_flag_CXX=$reload_flag -reload_cmds_CXX=$reload_cmds -no_undefined_flag_CXX= -whole_archive_flag_spec_CXX= -enable_shared_with_static_runtimes_CXX=no - -# Source file extension for C++ test sources. -ac_ext=cpp - -# Object file extension for compiled C++ test sources. -objext=o -objext_CXX=$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 yes != "$_lt_caught_CXX_error"; 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. - - - - - - -# 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 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* - - - # Allow CC to be a program name with arguments. - lt_save_CC=$CC - lt_save_CFLAGS=$CFLAGS - 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++"} - CFLAGS=$CXXFLAGS - compiler=$CC - compiler_CXX=$CC - func_cc_basename $compiler -cc_basename=$func_cc_basename_result - - - if test -n "$compiler"; then - # We don't want -fno-exception when compiling C++ code, so set the - # no_builtin_flag separately - if test yes = "$GXX"; then - lt_prog_compiler_no_builtin_flag_CXX=' -fno-builtin' - else - lt_prog_compiler_no_builtin_flag_CXX= - fi - - if test yes = "$GXX"; then - # Set up default GNU C++ configuration - - - -# Check whether --with-gnu-ld was given. -if test "${with_gnu_ld+set}" = set; then : - withval=$with_gnu_ld; test no = "$withval" || with_gnu_ld=yes -else - with_gnu_ld=no -fi - -ac_prog=ld -if test yes = "$GCC"; 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 yes = "$with_gnu_ld"; 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 ${lt_cv_path_LD+:} false; 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 ${lt_cv_prog_gnu_ld+:} false; 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 - - - - - - - - # 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 yes = "$with_gnu_ld"; then - archive_cmds_CXX='$CC $pic_flag -shared -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname -o $lib' - archive_expsym_cmds_CXX='$CC $pic_flag -shared -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname $wl-retain-symbols-file $wl$export_symbols -o $lib' - - hardcode_libdir_flag_spec_CXX='$wl-rpath $wl$libdir' - export_dynamic_flag_spec_CXX='$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 - whole_archive_flag_spec_CXX=$wlarc'--whole-archive$convenience '$wlarc'--no-whole-archive' - else - whole_archive_flag_spec_CXX= - 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. - archive_cmds_CXX='$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 -v "^Configured with:" | $GREP "\-L"' - - else - GXX=no - with_gnu_ld=no - wlarc= - fi - - # PORTME: fill in a description of your system's C++ link characteristics - { $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; } - ld_shlibs_CXX=yes - case $host_os in - aix3*) - # FIXME: insert proper C++ library support - ld_shlibs_CXX=no - ;; - aix[4-9]*) - if test ia64 = "$host_cpu"; 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 - # have runtime linking enabled, and use it for executables. - # For shared libraries, we enable/disable runtime linking - # depending on the kind of the shared library created - - # when "with_aix_soname,aix_use_runtimelinking" is: - # "aix,no" lib.a(lib.so.V) shared, rtl:no, for executables - # "aix,yes" lib.so shared, rtl:yes, for executables - # lib.a static archive - # "both,no" lib.so.V(shr.o) shared, rtl:yes - # lib.a(lib.so.V) shared, rtl:no, for executables - # "both,yes" lib.so.V(shr.o) shared, rtl:yes, for executables - # lib.a(lib.so.V) shared, rtl:no - # "svr4,*" lib.so.V(shr.o) shared, rtl:yes, for executables - # lib.a static archive - 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 - if test svr4,no = "$with_aix_soname,$aix_use_runtimelinking"; then - # With aix-soname=svr4, we create the lib.so.V shared archives only, - # so we don't have lib.a shared libs to link our executables. - # We have to force runtime linking in this case. - aix_use_runtimelinking=yes - LDFLAGS="$LDFLAGS -Wl,-brtl" - fi - ;; - 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_CXX='' - hardcode_direct_CXX=yes - hardcode_direct_absolute_CXX=yes - hardcode_libdir_separator_CXX=':' - link_all_deplibs_CXX=yes - file_list_spec_CXX='$wl-f,' - case $with_aix_soname,$aix_use_runtimelinking in - aix,*) ;; # no import file - svr4,* | *,yes) # use import file - # The Import File defines what to hardcode. - hardcode_direct_CXX=no - hardcode_direct_absolute_CXX=no - ;; - esac - - if test yes = "$GXX"; 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_CXX=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_CXX=yes - hardcode_libdir_flag_spec_CXX='-L$libdir' - hardcode_libdir_separator_CXX= - fi - esac - shared_flag='-shared' - if test yes = "$aix_use_runtimelinking"; then - shared_flag=$shared_flag' $wl-G' - fi - # Need to ensure runtime linking is disabled for the traditional - # shared library, or the linker may eventually find shared libraries - # /with/ Import File - we do not want to mix them. - shared_flag_aix='-shared' - shared_flag_svr4='-shared $wl-G' - else - # not using gcc - if test ia64 = "$host_cpu"; 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 yes = "$aix_use_runtimelinking"; then - shared_flag='$wl-G' - else - shared_flag='$wl-bM:SRE' - fi - shared_flag_aix='$wl-bM:SRE' - shared_flag_svr4='$wl-G' - fi - fi - - export_dynamic_flag_spec_CXX='$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_CXX=yes - if test aix,yes = "$with_aix_soname,$aix_use_runtimelinking"; then - # Warning - without using the other runtime loading flags (-brtl), - # -berok will link without error, but may produce a broken library. - # The "-G" linker flag allows undefined symbols. - no_undefined_flag_CXX='-bernotok' - # Determine the default libpath from the value encoded in an empty - # executable. - if test set = "${lt_cv_aix_libpath+set}"; then - aix_libpath=$lt_cv_aix_libpath -else - if ${lt_cv_aix_libpath__CXX+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_cxx_try_link "$LINENO"; then : - - lt_aix_libpath_sed=' - /Import File Strings/,/^$/ { - /^0/ { - s/^0 *\([^ ]*\) *$/\1/ - p - } - }' - lt_cv_aix_libpath__CXX=`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 "$lt_cv_aix_libpath__CXX"; then - lt_cv_aix_libpath__CXX=`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 "$lt_cv_aix_libpath__CXX"; then - lt_cv_aix_libpath__CXX=/usr/lib:/lib - fi - -fi - - aix_libpath=$lt_cv_aix_libpath__CXX -fi - - hardcode_libdir_flag_spec_CXX='$wl-blibpath:$libdir:'"$aix_libpath" - - archive_expsym_cmds_CXX='$CC -o $output_objdir/$soname $libobjs $deplibs $wl'$no_entry_flag' $compiler_flags `if test -n "$allow_undefined_flag"; then func_echo_all "$wl$allow_undefined_flag"; else :; fi` $wl'$exp_sym_flag:\$export_symbols' '$shared_flag - else - if test ia64 = "$host_cpu"; then - hardcode_libdir_flag_spec_CXX='$wl-R $libdir:/usr/lib:/lib' - allow_undefined_flag_CXX="-z nodefs" - archive_expsym_cmds_CXX="\$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. - if test set = "${lt_cv_aix_libpath+set}"; then - aix_libpath=$lt_cv_aix_libpath -else - if ${lt_cv_aix_libpath__CXX+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_cxx_try_link "$LINENO"; then : - - lt_aix_libpath_sed=' - /Import File Strings/,/^$/ { - /^0/ { - s/^0 *\([^ ]*\) *$/\1/ - p - } - }' - lt_cv_aix_libpath__CXX=`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 "$lt_cv_aix_libpath__CXX"; then - lt_cv_aix_libpath__CXX=`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 "$lt_cv_aix_libpath__CXX"; then - lt_cv_aix_libpath__CXX=/usr/lib:/lib - fi - -fi - - aix_libpath=$lt_cv_aix_libpath__CXX -fi - - hardcode_libdir_flag_spec_CXX='$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_CXX=' $wl-bernotok' - allow_undefined_flag_CXX=' $wl-berok' - if test yes = "$with_gnu_ld"; then - # We only use this code for GNU lds that support --whole-archive. - whole_archive_flag_spec_CXX='$wl--whole-archive$convenience $wl--no-whole-archive' - else - # Exported symbols can be pulled into shared objects from archives - whole_archive_flag_spec_CXX='$convenience' - fi - archive_cmds_need_lc_CXX=yes - archive_expsym_cmds_CXX='$RM -r $output_objdir/$realname.d~$MKDIR $output_objdir/$realname.d' - # -brtl affects multiple linker settings, -berok does not and is overridden later - compiler_flags_filtered='`func_echo_all "$compiler_flags " | $SED -e "s%-brtl\\([, ]\\)%-berok\\1%g"`' - if test svr4 != "$with_aix_soname"; then - # This is similar to how AIX traditionally builds its shared - # libraries. Need -bnortl late, we may have -brtl in LDFLAGS. - archive_expsym_cmds_CXX="$archive_expsym_cmds_CXX"'~$CC '$shared_flag_aix' -o $output_objdir/$realname.d/$soname $libobjs $deplibs $wl-bnoentry '$compiler_flags_filtered'$wl-bE:$export_symbols$allow_undefined_flag~$AR $AR_FLAGS $output_objdir/$libname$release.a $output_objdir/$realname.d/$soname' - fi - if test aix != "$with_aix_soname"; then - archive_expsym_cmds_CXX="$archive_expsym_cmds_CXX"'~$CC '$shared_flag_svr4' -o $output_objdir/$realname.d/$shared_archive_member_spec.o $libobjs $deplibs $wl-bnoentry '$compiler_flags_filtered'$wl-bE:$export_symbols$allow_undefined_flag~$STRIP -e $output_objdir/$realname.d/$shared_archive_member_spec.o~( func_echo_all "#! $soname($shared_archive_member_spec.o)"; if test shr_64 = "$shared_archive_member_spec"; then func_echo_all "# 64"; else func_echo_all "# 32"; fi; cat $export_symbols ) > $output_objdir/$realname.d/$shared_archive_member_spec.imp~$AR $AR_FLAGS $output_objdir/$soname $output_objdir/$realname.d/$shared_archive_member_spec.o $output_objdir/$realname.d/$shared_archive_member_spec.imp' - else - # used by -dlpreopen to get the symbols - archive_expsym_cmds_CXX="$archive_expsym_cmds_CXX"'~$MV $output_objdir/$realname.d/$soname $output_objdir' - fi - archive_expsym_cmds_CXX="$archive_expsym_cmds_CXX"'~$RM -r $output_objdir/$realname.d' - fi - fi - ;; - - beos*) - if $LD --help 2>&1 | $GREP ': supported targets:.* elf' > /dev/null; then - allow_undefined_flag_CXX=unsupported - # Joseph Beckenbach says some releases of gcc - # support --undefined. This deserves some investigation. FIXME - archive_cmds_CXX='$CC -nostart $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' - else - ld_shlibs_CXX=no - fi - ;; - - chorus*) - case $cc_basename in - *) - # FIXME: insert proper C++ library support - ld_shlibs_CXX=no - ;; - esac - ;; - - cygwin* | mingw* | pw32* | cegcc*) - case $GXX,$cc_basename in - ,cl* | no,cl*) - # Native MSVC - # hardcode_libdir_flag_spec is actually meaningless, as there is - # no search path for DLLs. - hardcode_libdir_flag_spec_CXX=' ' - allow_undefined_flag_CXX=unsupported - always_export_symbols_CXX=yes - file_list_spec_CXX='@' - # 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_CXX='$CC -o $output_objdir/$soname $libobjs $compiler_flags $deplibs -Wl,-DLL,-IMPLIB:"$tool_output_objdir$libname.dll.lib"~linknames=' - archive_expsym_cmds_CXX='if test DEF = "`$SED -n -e '\''s/^[ ]*//'\'' -e '\''/^\(;.*\)*$/d'\'' -e '\''s/^\(EXPORTS\|LIBRARY\)\([ ].*\)*$/DEF/p'\'' -e q $export_symbols`" ; then - cp "$export_symbols" "$output_objdir/$soname.def"; - echo "$tool_output_objdir$soname.def" > "$output_objdir/$soname.exp"; - else - $SED -e '\''s/^/-link -EXPORT:/'\'' < $export_symbols > $output_objdir/$soname.exp; - fi~ - $CC -o $tool_output_objdir$soname $libobjs $compiler_flags $deplibs "@$tool_output_objdir$soname.exp" -Wl,-DLL,-IMPLIB:"$tool_output_objdir$libname.dll.lib"~ - linknames=' - # The linker will not automatically build a static lib if we build a DLL. - # _LT_TAGVAR(old_archive_from_new_cmds, CXX)='true' - enable_shared_with_static_runtimes_CXX=yes - # Don't use ranlib - old_postinstall_cmds_CXX='chmod 644 $oldlib' - postlink_cmds_CXX='lt_outputfile="@OUTPUT@"~ - lt_tool_outputfile="@TOOL_OUTPUT@"~ - case $lt_outputfile in - *.exe|*.EXE) ;; - *) - lt_outputfile=$lt_outputfile.exe - lt_tool_outputfile=$lt_tool_outputfile.exe - ;; - esac~ - func_to_tool_file "$lt_outputfile"~ - if test : != "$MANIFEST_TOOL" && test -f "$lt_outputfile.manifest"; then - $MANIFEST_TOOL -manifest "$lt_tool_outputfile.manifest" -outputresource:"$lt_tool_outputfile" || exit 1; - $RM "$lt_outputfile.manifest"; - fi' - ;; - *) - # g++ - # _LT_TAGVAR(hardcode_libdir_flag_spec, CXX) is actually meaningless, - # as there is no search path for DLLs. - hardcode_libdir_flag_spec_CXX='-L$libdir' - export_dynamic_flag_spec_CXX='$wl--export-all-symbols' - allow_undefined_flag_CXX=unsupported - always_export_symbols_CXX=no - enable_shared_with_static_runtimes_CXX=yes - - if $LD --help 2>&1 | $GREP 'auto-import' > /dev/null; then - archive_cmds_CXX='$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, use it as - # is; otherwise, prepend EXPORTS... - archive_expsym_cmds_CXX='if test DEF = "`$SED -n -e '\''s/^[ ]*//'\'' -e '\''/^\(;.*\)*$/d'\'' -e '\''s/^\(EXPORTS\|LIBRARY\)\([ ].*\)*$/DEF/p'\'' -e q $export_symbols`" ; 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 - ld_shlibs_CXX=no - fi - ;; - esac - ;; - darwin* | rhapsody*) - - - archive_cmds_need_lc_CXX=no - hardcode_direct_CXX=no - hardcode_automatic_CXX=yes - hardcode_shlibpath_var_CXX=unsupported - if test yes = "$lt_cv_ld_force_load"; then - whole_archive_flag_spec_CXX='`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience $wl-force_load,$conv\"; done; func_echo_all \"$new_convenience\"`' - - else - whole_archive_flag_spec_CXX='' - fi - link_all_deplibs_CXX=yes - allow_undefined_flag_CXX=$_lt_dar_allow_undefined - case $cc_basename in - ifort*|nagfor*) _lt_dar_can_shared=yes ;; - *) _lt_dar_can_shared=$GCC ;; - esac - if test yes = "$_lt_dar_can_shared"; then - output_verbose_link_cmd=func_echo_all - archive_cmds_CXX="\$CC -dynamiclib \$allow_undefined_flag -o \$lib \$libobjs \$deplibs \$compiler_flags -install_name \$rpath/\$soname \$verstring $_lt_dar_single_mod$_lt_dsymutil" - module_cmds_CXX="\$CC \$allow_undefined_flag -o \$lib -bundle \$libobjs \$deplibs \$compiler_flags$_lt_dsymutil" - archive_expsym_cmds_CXX="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_CXX="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" - if test yes != "$lt_cv_apple_cc_single_mod"; then - archive_cmds_CXX="\$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" - archive_expsym_cmds_CXX="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 - ld_shlibs_CXX=no - fi - - ;; - - os2*) - hardcode_libdir_flag_spec_CXX='-L$libdir' - hardcode_minus_L_CXX=yes - allow_undefined_flag_CXX=unsupported - shrext_cmds=.dll - archive_cmds_CXX='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ - $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ - $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ - $ECHO EXPORTS >> $output_objdir/$libname.def~ - emxexp $libobjs | $SED /"_DLL_InitTerm"/d >> $output_objdir/$libname.def~ - $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ - emximp -o $lib $output_objdir/$libname.def' - archive_expsym_cmds_CXX='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ - $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ - $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ - $ECHO EXPORTS >> $output_objdir/$libname.def~ - prefix_cmds="$SED"~ - if test EXPORTS = "`$SED 1q $export_symbols`"; then - prefix_cmds="$prefix_cmds -e 1d"; - fi~ - prefix_cmds="$prefix_cmds -e \"s/^\(.*\)$/_\1/g\""~ - cat $export_symbols | $prefix_cmds >> $output_objdir/$libname.def~ - $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ - emximp -o $lib $output_objdir/$libname.def' - old_archive_From_new_cmds_CXX='emximp -o $output_objdir/${libname}_dll.a $output_objdir/$libname.def' - enable_shared_with_static_runtimes_CXX=yes - ;; - - dgux*) - case $cc_basename in - ec++*) - # FIXME: insert proper C++ library support - ld_shlibs_CXX=no - ;; - ghcx*) - # Green Hills C++ Compiler - # FIXME: insert proper C++ library support - ld_shlibs_CXX=no - ;; - *) - # FIXME: insert proper C++ library support - ld_shlibs_CXX=no - ;; - esac - ;; - - freebsd2.*) - # C++ shared libraries reported to be fairly broken before - # switch to ELF - ld_shlibs_CXX=no - ;; - - freebsd-elf*) - archive_cmds_need_lc_CXX=no - ;; - - freebsd* | dragonfly*) - # FreeBSD 3 and later use GNU C++ and GNU ld with standard ELF - # conventions - ld_shlibs_CXX=yes - ;; - - haiku*) - archive_cmds_CXX='$CC -shared $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' - link_all_deplibs_CXX=yes - ;; - - hpux9*) - hardcode_libdir_flag_spec_CXX='$wl+b $wl$libdir' - hardcode_libdir_separator_CXX=: - export_dynamic_flag_spec_CXX='$wl-E' - hardcode_direct_CXX=yes - hardcode_minus_L_CXX=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 - ld_shlibs_CXX=no - ;; - aCC*) - archive_cmds_CXX='$RM $output_objdir/$soname~$CC -b $wl+b $wl$install_libdir -o $output_objdir/$soname $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags~test "x$output_objdir/$soname" = "x$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; func_echo_all "$list"' - ;; - *) - if test yes = "$GXX"; then - archive_cmds_CXX='$RM $output_objdir/$soname~$CC -shared -nostdlib $pic_flag $wl+b $wl$install_libdir -o $output_objdir/$soname $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags~test "x$output_objdir/$soname" = "x$lib" || mv $output_objdir/$soname $lib' - else - # FIXME: insert proper C++ library support - ld_shlibs_CXX=no - fi - ;; - esac - ;; - - hpux10*|hpux11*) - if test no = "$with_gnu_ld"; then - hardcode_libdir_flag_spec_CXX='$wl+b $wl$libdir' - hardcode_libdir_separator_CXX=: - - case $host_cpu in - hppa*64*|ia64*) - ;; - *) - export_dynamic_flag_spec_CXX='$wl-E' - ;; - esac - fi - case $host_cpu in - hppa*64*|ia64*) - hardcode_direct_CXX=no - hardcode_shlibpath_var_CXX=no - ;; - *) - hardcode_direct_CXX=yes - hardcode_direct_absolute_CXX=yes - hardcode_minus_L_CXX=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 - ld_shlibs_CXX=no - ;; - aCC*) - case $host_cpu in - hppa*64*) - archive_cmds_CXX='$CC -b $wl+h $wl$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' - ;; - ia64*) - archive_cmds_CXX='$CC -b $wl+h $wl$soname $wl+nodefaultrpath -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' - ;; - *) - archive_cmds_CXX='$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; func_echo_all "$list"' - ;; - *) - if test yes = "$GXX"; then - if test no = "$with_gnu_ld"; then - case $host_cpu in - hppa*64*) - archive_cmds_CXX='$CC -shared -nostdlib -fPIC $wl+h $wl$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' - ;; - ia64*) - archive_cmds_CXX='$CC -shared -nostdlib $pic_flag $wl+h $wl$soname $wl+nodefaultrpath -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' - ;; - *) - archive_cmds_CXX='$CC -shared -nostdlib $pic_flag $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 - ld_shlibs_CXX=no - fi - ;; - esac - ;; - - interix[3-9]*) - hardcode_direct_CXX=no - hardcode_shlibpath_var_CXX=no - hardcode_libdir_flag_spec_CXX='$wl-rpath,$libdir' - export_dynamic_flag_spec_CXX='$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_CXX='$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_CXX='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++ - archive_cmds_CXX='$CC -shared -all -multigot $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -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. - old_archive_cmds_CXX='$CC -ar -WR,-u -o $oldlib $oldobjs' - ;; - *) - if test yes = "$GXX"; then - if test no = "$with_gnu_ld"; then - archive_cmds_CXX='$CC -shared $pic_flag -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $wl-update_registry $wl$output_objdir/so_locations -o $lib' - else - archive_cmds_CXX='$CC -shared $pic_flag -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` -o $lib' - fi - fi - link_all_deplibs_CXX=yes - ;; - esac - hardcode_libdir_flag_spec_CXX='$wl-rpath $wl$libdir' - hardcode_libdir_separator_CXX=: - inherit_rpath_CXX=yes - ;; - - linux* | k*bsd*-gnu | kopensolaris*-gnu | 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. - archive_cmds_CXX='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' - archive_expsym_cmds_CXX='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; func_echo_all "$list"' - - hardcode_libdir_flag_spec_CXX='$wl-rpath,$libdir' - export_dynamic_flag_spec_CXX='$wl--export-dynamic' - - # Archives containing C++ object files must be created using - # "CC -Bstatic", where "CC" is the KAI C++ compiler. - old_archive_cmds_CXX='$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."*) - archive_cmds_CXX='$CC -shared $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname -o $lib' - archive_expsym_cmds_CXX='$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 - archive_cmds_CXX='$CC -shared'"$tmp_idyn"' $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' - archive_expsym_cmds_CXX='$CC -shared'"$tmp_idyn"' $libobjs $deplibs $compiler_flags $wl-soname $wl$soname $wl-retain-symbols-file $wl$export_symbols -o $lib' - ;; - esac - archive_cmds_need_lc_CXX=no - hardcode_libdir_flag_spec_CXX='$wl-rpath,$libdir' - export_dynamic_flag_spec_CXX='$wl--export-dynamic' - whole_archive_flag_spec_CXX='$wl--whole-archive$convenience $wl--no-whole-archive' - ;; - pgCC* | pgcpp*) - # Portland Group C++ compiler - case `$CC -V` in - *pgCC\ [1-5].* | *pgcpp\ [1-5].*) - prelink_cmds_CXX='tpldir=Template.dir~ - rm -rf $tpldir~ - $CC --prelink_objects --instantiation_dir $tpldir $objs $libobjs $compile_deplibs~ - compile_command="$compile_command `find $tpldir -name \*.o | sort | $NL2SP`"' - old_archive_cmds_CXX='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 | sort | $NL2SP`~ - $RANLIB $oldlib' - archive_cmds_CXX='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 | sort | $NL2SP` $postdep_objects $compiler_flags $wl-soname $wl$soname -o $lib' - archive_expsym_cmds_CXX='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 | sort | $NL2SP` $postdep_objects $compiler_flags $wl-soname $wl$soname $wl-retain-symbols-file $wl$export_symbols -o $lib' - ;; - *) # Version 6 and above use weak symbols - archive_cmds_CXX='$CC -shared $pic_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname -o $lib' - archive_expsym_cmds_CXX='$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 - - hardcode_libdir_flag_spec_CXX='$wl--rpath $wl$libdir' - export_dynamic_flag_spec_CXX='$wl--export-dynamic' - whole_archive_flag_spec_CXX='$wl--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` $wl--no-whole-archive' - ;; - cxx*) - # Compaq C++ - archive_cmds_CXX='$CC -shared $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname -o $lib' - archive_expsym_cmds_CXX='$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 - hardcode_libdir_flag_spec_CXX='-rpath $libdir' - hardcode_libdir_separator_CXX=: - - # 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=`func_echo_all "$templist" | $SED "s/\(^.*ld.*\)\( .*ld .*$\)/\1/"`; list= ; for z in $templist; do case $z in conftest.$objext) list="$list $z";; *.$objext);; *) list="$list $z";;esac; done; func_echo_all "X$list" | $Xsed' - ;; - xl* | mpixl* | bgxl*) - # IBM XL 8.0 on PPC, with GNU ld - hardcode_libdir_flag_spec_CXX='$wl-rpath $wl$libdir' - export_dynamic_flag_spec_CXX='$wl--export-dynamic' - archive_cmds_CXX='$CC -qmkshrobj $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' - if test yes = "$supports_anon_versioning"; then - archive_expsym_cmds_CXX='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 - no_undefined_flag_CXX=' -zdefs' - archive_cmds_CXX='$CC -G$allow_undefined_flag -h$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' - archive_expsym_cmds_CXX='$CC -G$allow_undefined_flag -h$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-retain-symbols-file $wl$export_symbols' - hardcode_libdir_flag_spec_CXX='-R$libdir' - whole_archive_flag_spec_CXX='$wl--whole-archive`new_convenience=; for conv in $convenience\"\"; do test -z \"$conv\" || new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` $wl--no-whole-archive' - compiler_needs_object_CXX=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='func_echo_all' - - # 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. - old_archive_cmds_CXX='$CC -xar -o $oldlib $oldobjs' - ;; - esac - ;; - esac - ;; - - lynxos*) - # FIXME: insert proper C++ library support - ld_shlibs_CXX=no - ;; - - m88k*) - # FIXME: insert proper C++ library support - ld_shlibs_CXX=no - ;; - - mvs*) - case $cc_basename in - cxx*) - # FIXME: insert proper C++ library support - ld_shlibs_CXX=no - ;; - *) - # FIXME: insert proper C++ library support - ld_shlibs_CXX=no - ;; - esac - ;; - - netbsd*) - if echo __ELF__ | $CC -E - | $GREP __ELF__ >/dev/null; then - archive_cmds_CXX='$LD -Bshareable -o $lib $predep_objects $libobjs $deplibs $postdep_objects $linker_flags' - wlarc= - hardcode_libdir_flag_spec_CXX='-R$libdir' - hardcode_direct_CXX=yes - hardcode_shlibpath_var_CXX=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*) - ld_shlibs_CXX=yes - ;; - - openbsd* | bitrig*) - if test -f /usr/libexec/ld.so; then - hardcode_direct_CXX=yes - hardcode_shlibpath_var_CXX=no - hardcode_direct_absolute_CXX=yes - archive_cmds_CXX='$CC -shared $pic_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -o $lib' - hardcode_libdir_flag_spec_CXX='$wl-rpath,$libdir' - if test -z "`echo __ELF__ | $CC -E - | grep __ELF__`"; then - archive_expsym_cmds_CXX='$CC -shared $pic_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-retain-symbols-file,$export_symbols -o $lib' - export_dynamic_flag_spec_CXX='$wl-E' - whole_archive_flag_spec_CXX=$wlarc'--whole-archive$convenience '$wlarc'--no-whole-archive' - fi - output_verbose_link_cmd=func_echo_all - else - ld_shlibs_CXX=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. - archive_cmds_CXX='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' - - hardcode_libdir_flag_spec_CXX='$wl-rpath,$libdir' - hardcode_libdir_separator_CXX=: - - # Archives containing C++ object files must be created using - # the KAI C++ compiler. - case $host in - osf3*) old_archive_cmds_CXX='$CC -Bstatic -o $oldlib $oldobjs' ;; - *) old_archive_cmds_CXX='$CC -o $oldlib $oldobjs' ;; - esac - ;; - RCC*) - # Rational C++ 2.4.1 - # FIXME: insert proper C++ library support - ld_shlibs_CXX=no - ;; - cxx*) - case $host in - osf3*) - allow_undefined_flag_CXX=' $wl-expect_unresolved $wl\*' - archive_cmds_CXX='$CC -shared$allow_undefined_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $soname `test -n "$verstring" && func_echo_all "$wl-set_version $verstring"` -update_registry $output_objdir/so_locations -o $lib' - hardcode_libdir_flag_spec_CXX='$wl-rpath $wl$libdir' - ;; - *) - allow_undefined_flag_CXX=' -expect_unresolved \*' - archive_cmds_CXX='$CC -shared$allow_undefined_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags -msym -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry $output_objdir/so_locations -o $lib' - archive_expsym_cmds_CXX='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 "-set_version $verstring"` -update_registry $output_objdir/so_locations -o $lib~ - $RM $lib.exp' - hardcode_libdir_flag_spec_CXX='-rpath $libdir' - ;; - esac - - hardcode_libdir_separator_CXX=: - - # 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=`func_echo_all "$templist" | $SED "s/\(^.*ld.*\)\( .*ld.*$\)/\1/"`; list= ; for z in $templist; do case $z in conftest.$objext) list="$list $z";; *.$objext);; *) list="$list $z";;esac; done; func_echo_all "$list"' - ;; - *) - if test yes,no = "$GXX,$with_gnu_ld"; then - allow_undefined_flag_CXX=' $wl-expect_unresolved $wl\*' - case $host in - osf3*) - archive_cmds_CXX='$CC -shared -nostdlib $allow_undefined_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $wl-update_registry $wl$output_objdir/so_locations -o $lib' - ;; - *) - archive_cmds_CXX='$CC -shared $pic_flag -nostdlib $allow_undefined_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-msym $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $wl-update_registry $wl$output_objdir/so_locations -o $lib' - ;; - esac - - hardcode_libdir_flag_spec_CXX='$wl-rpath $wl$libdir' - hardcode_libdir_separator_CXX=: - - # 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 -v "^Configured with:" | $GREP "\-L"' - - else - # FIXME: insert proper C++ library support - ld_shlibs_CXX=no - fi - ;; - esac - ;; - - psos*) - # FIXME: insert proper C++ library support - ld_shlibs_CXX=no - ;; - - sunos4*) - case $cc_basename in - CC*) - # Sun C++ 4.x - # FIXME: insert proper C++ library support - ld_shlibs_CXX=no - ;; - lcc*) - # Lucid - # FIXME: insert proper C++ library support - ld_shlibs_CXX=no - ;; - *) - # FIXME: insert proper C++ library support - ld_shlibs_CXX=no - ;; - esac - ;; - - solaris*) - case $cc_basename in - CC* | sunCC*) - # Sun C++ 4.2, 5.x and Centerline C++ - archive_cmds_need_lc_CXX=yes - no_undefined_flag_CXX=' -zdefs' - archive_cmds_CXX='$CC -G$allow_undefined_flag -h$soname -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' - archive_expsym_cmds_CXX='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' - - hardcode_libdir_flag_spec_CXX='-R$libdir' - hardcode_shlibpath_var_CXX=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?) - whole_archive_flag_spec_CXX='-z allextract$convenience -z defaultextract' - ;; - esac - link_all_deplibs_CXX=yes - - output_verbose_link_cmd='func_echo_all' - - # 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. - old_archive_cmds_CXX='$CC -xar -o $oldlib $oldobjs' - ;; - gcx*) - # Green Hills C++ Compiler - archive_cmds_CXX='$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. - old_archive_cmds_CXX='$CC $LDFLAGS -archive -o $oldlib $oldobjs' - ;; - *) - # GNU C++ compiler with Solaris linker - if test yes,no = "$GXX,$with_gnu_ld"; then - no_undefined_flag_CXX=' $wl-z ${wl}defs' - if $CC --version | $GREP -v '^2\.7' > /dev/null; then - archive_cmds_CXX='$CC -shared $pic_flag -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-h $wl$soname -o $lib' - archive_expsym_cmds_CXX='echo "{ global:" > $lib.exp~cat $export_symbols | $SED -e "s/\(.*\)/\1;/" >> $lib.exp~echo "local: *; };" >> $lib.exp~ - $CC -shared $pic_flag -nostdlib $wl-M $wl$lib.exp $wl-h $wl$soname -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 -v "^Configured with:" | $GREP "\-L"' - else - # g++ 2.7 appears to require '-G' NOT '-shared' on this - # platform. - archive_cmds_CXX='$CC -G -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-h $wl$soname -o $lib' - archive_expsym_cmds_CXX='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 $wl-h $wl$soname -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 -v "^Configured with:" | $GREP "\-L"' - fi - - hardcode_libdir_flag_spec_CXX='$wl-R $wl$libdir' - case $host_os in - solaris2.[0-5] | solaris2.[0-5].*) ;; - *) - whole_archive_flag_spec_CXX='$wl-z ${wl}allextract$convenience $wl-z ${wl}defaultextract' - ;; - esac - fi - ;; - esac - ;; - - sysv4*uw2* | sysv5OpenUNIX* | sysv5UnixWare7.[01].[10]* | unixware7* | sco3.2v5.0.[024]*) - no_undefined_flag_CXX='$wl-z,text' - archive_cmds_need_lc_CXX=no - hardcode_shlibpath_var_CXX=no - runpath_var='LD_RUN_PATH' - - case $cc_basename in - CC*) - archive_cmds_CXX='$CC -G $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' - archive_expsym_cmds_CXX='$CC -G $wl-Bexport:$export_symbols $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' - ;; - *) - archive_cmds_CXX='$CC -shared $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' - archive_expsym_cmds_CXX='$CC -shared $wl-Bexport:$export_symbols $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' - ;; - esac - ;; - - sysv5* | sco3.2v5* | sco5v6*) - # Note: We CANNOT 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_CXX='$wl-z,text' - allow_undefined_flag_CXX='$wl-z,nodefs' - archive_cmds_need_lc_CXX=no - hardcode_shlibpath_var_CXX=no - hardcode_libdir_flag_spec_CXX='$wl-R,$libdir' - hardcode_libdir_separator_CXX=':' - link_all_deplibs_CXX=yes - export_dynamic_flag_spec_CXX='$wl-Bexport' - runpath_var='LD_RUN_PATH' - - case $cc_basename in - CC*) - archive_cmds_CXX='$CC -G $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' - archive_expsym_cmds_CXX='$CC -G $wl-Bexport:$export_symbols $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' - old_archive_cmds_CXX='$CC -Tprelink_objects $oldobjs~ - '"$old_archive_cmds_CXX" - reload_cmds_CXX='$CC -Tprelink_objects $reload_objs~ - '"$reload_cmds_CXX" - ;; - *) - archive_cmds_CXX='$CC -shared $wl-h,$soname -o $lib $libobjs $deplibs $compiler_flags' - archive_expsym_cmds_CXX='$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 - ld_shlibs_CXX=no - ;; - *) - # FIXME: insert proper C++ library support - ld_shlibs_CXX=no - ;; - esac - ;; - - vxworks*) - # FIXME: insert proper C++ library support - ld_shlibs_CXX=no - ;; - - *) - # FIXME: insert proper C++ library support - ld_shlibs_CXX=no - ;; - esac - - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ld_shlibs_CXX" >&5 -$as_echo "$ld_shlibs_CXX" >&6; } - test no = "$ld_shlibs_CXX" && can_build_shared=no - - GCC_CXX=$GXX - LD_CXX=$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... - # Dependencies to place before and after the object being linked: -predep_objects_CXX= -postdep_objects_CXX= -predeps_CXX= -postdeps_CXX= -compiler_lib_search_path_CXX= - -cat > conftest.$ac_ext <<_LT_EOF -class Foo -{ -public: - Foo (void) { a = 0; } -private: - int a; -}; -_LT_EOF - - -_lt_libdeps_save_CFLAGS=$CFLAGS -case "$CC $CFLAGS " in #( -*\ -flto*\ *) CFLAGS="$CFLAGS -fno-lto" ;; -*\ -fwhopr*\ *) CFLAGS="$CFLAGS -fno-whopr" ;; -*\ -fuse-linker-plugin*\ *) CFLAGS="$CFLAGS -fno-use-linker-plugin" ;; -esac - -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 - # 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 $prev$p in - - -L* | -R* | -l*) - # Some compilers place space between "-{L,R}" and the path. - # Remove the space. - if test x-L = "$p" || - test x-R = "$p"; then - prev=$p - continue - fi - - # Expand the sysroot to ease extracting the directories later. - if test -z "$prev"; then - case $p in - -L*) func_stripname_cnf '-L' '' "$p"; prev=-L; p=$func_stripname_result ;; - -R*) func_stripname_cnf '-R' '' "$p"; prev=-R; p=$func_stripname_result ;; - -l*) func_stripname_cnf '-l' '' "$p"; prev=-l; p=$func_stripname_result ;; - esac - fi - case $p in - =*) func_stripname_cnf '=' '' "$p"; p=$lt_sysroot$func_stripname_result ;; - esac - if test no = "$pre_test_object_deps_done"; then - case $prev 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 "$compiler_lib_search_path_CXX"; then - compiler_lib_search_path_CXX=$prev$p - else - compiler_lib_search_path_CXX="${compiler_lib_search_path_CXX} $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 "$postdeps_CXX"; then - postdeps_CXX=$prev$p - else - postdeps_CXX="${postdeps_CXX} $prev$p" - fi - fi - prev= - ;; - - *.lto.$objext) ;; # Ignore GCC LTO objects - *.$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 no = "$pre_test_object_deps_done"; then - if test -z "$predep_objects_CXX"; then - predep_objects_CXX=$p - else - predep_objects_CXX="$predep_objects_CXX $p" - fi - else - if test -z "$postdep_objects_CXX"; then - postdep_objects_CXX=$p - else - postdep_objects_CXX="$postdep_objects_CXX $p" - fi - fi - ;; - - *) ;; # Ignore the rest. - - esac - done - - # Clean up. - rm -f a.out a.exe -else - echo "libtool.m4: error: problem compiling CXX test program" -fi - -$RM -f confest.$objext -CFLAGS=$_lt_libdeps_save_CFLAGS - -# PORTME: override above test on systems where it is broken -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. - predep_objects_CXX= - postdep_objects_CXX= - postdeps_CXX= - ;; -esac - - -case " $postdeps_CXX " in -*" -lc "*) archive_cmds_need_lc_CXX=no ;; -esac - compiler_lib_search_dirs_CXX= -if test -n "${compiler_lib_search_path_CXX}"; then - compiler_lib_search_dirs_CXX=`echo " ${compiler_lib_search_path_CXX}" | $SED -e 's! -L! !g' -e 's!^ !!'` -fi - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - lt_prog_compiler_wl_CXX= -lt_prog_compiler_pic_CXX= -lt_prog_compiler_static_CXX= - - - # C++ specific cases for pic, static, wl, etc. - if test yes = "$GXX"; then - lt_prog_compiler_wl_CXX='-Wl,' - lt_prog_compiler_static_CXX='-static' - - case $host_os in - aix*) - # All AIX code is PIC. - if test ia64 = "$host_cpu"; then - # AIX 5 now supports IA64 processor - lt_prog_compiler_static_CXX='-Bstatic' - fi - lt_prog_compiler_pic_CXX='-fPIC' - ;; - - amigaos*) - case $host_cpu in - powerpc) - # see comment about AmigaOS4 .so support - lt_prog_compiler_pic_CXX='-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_CXX='-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 - lt_prog_compiler_pic_CXX='-DDLL_EXPORT' - case $host_os in - os2*) - lt_prog_compiler_static_CXX='$wl-static' - ;; - esac - ;; - darwin* | rhapsody*) - # PIC is the default on this platform - # Common symbols not allowed in MH_DYLIB files - lt_prog_compiler_pic_CXX='-fno-common' - ;; - *djgpp*) - # DJGPP does not support shared libraries at all - lt_prog_compiler_pic_CXX= - ;; - haiku*) - # PIC is the default for Haiku. - # The "-static" flag exists, but is broken. - lt_prog_compiler_static_CXX= - ;; - 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_prog_compiler_pic_CXX=-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_prog_compiler_pic_CXX='-fPIC' - ;; - esac - ;; - *qnx* | *nto*) - # QNX uses GNU C++, but need to define -shared option too, otherwise - # it will coredump. - lt_prog_compiler_pic_CXX='-fPIC -shared' - ;; - *) - lt_prog_compiler_pic_CXX='-fPIC' - ;; - esac - else - case $host_os in - aix[4-9]*) - # All AIX code is PIC. - if test ia64 = "$host_cpu"; then - # AIX 5 now supports IA64 processor - lt_prog_compiler_static_CXX='-Bstatic' - else - lt_prog_compiler_static_CXX='-bnso -bI:/lib/syscalls.exp' - fi - ;; - chorus*) - case $cc_basename in - cxch68*) - # Green Hills C++ Compiler - # _LT_TAGVAR(lt_prog_compiler_static, CXX)="--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 - ;; - 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). - lt_prog_compiler_pic_CXX='-DDLL_EXPORT' - ;; - dgux*) - case $cc_basename in - ec++*) - lt_prog_compiler_pic_CXX='-KPIC' - ;; - ghcx*) - # Green Hills C++ Compiler - lt_prog_compiler_pic_CXX='-pic' - ;; - *) - ;; - esac - ;; - freebsd* | dragonfly*) - # FreeBSD uses GNU C++ - ;; - hpux9* | hpux10* | hpux11*) - case $cc_basename in - CC*) - lt_prog_compiler_wl_CXX='-Wl,' - lt_prog_compiler_static_CXX='$wl-a ${wl}archive' - if test ia64 != "$host_cpu"; then - lt_prog_compiler_pic_CXX='+Z' - fi - ;; - aCC*) - lt_prog_compiler_wl_CXX='-Wl,' - lt_prog_compiler_static_CXX='$wl-a ${wl}archive' - case $host_cpu in - hppa*64*|ia64*) - # +Z the default - ;; - *) - lt_prog_compiler_pic_CXX='+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_prog_compiler_wl_CXX='-Wl,' - lt_prog_compiler_static_CXX='-non_shared' - # CC pic flag -KPIC is the default. - ;; - *) - ;; - esac - ;; - linux* | k*bsd*-gnu | kopensolaris*-gnu | gnu*) - case $cc_basename in - KCC*) - # KAI C++ Compiler - lt_prog_compiler_wl_CXX='--backend -Wl,' - lt_prog_compiler_pic_CXX='-fPIC' - ;; - ecpc* ) - # old Intel C++ for x86_64, which still supported -KPIC. - lt_prog_compiler_wl_CXX='-Wl,' - lt_prog_compiler_pic_CXX='-KPIC' - lt_prog_compiler_static_CXX='-static' - ;; - icpc* ) - # Intel C++, used to be incompatible with GCC. - # ICC 10 doesn't accept -KPIC any more. - lt_prog_compiler_wl_CXX='-Wl,' - lt_prog_compiler_pic_CXX='-fPIC' - lt_prog_compiler_static_CXX='-static' - ;; - pgCC* | pgcpp*) - # Portland Group C++ compiler - lt_prog_compiler_wl_CXX='-Wl,' - lt_prog_compiler_pic_CXX='-fpic' - lt_prog_compiler_static_CXX='-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_prog_compiler_pic_CXX= - lt_prog_compiler_static_CXX='-non_shared' - ;; - xlc* | xlC* | bgxl[cC]* | mpixl[cC]*) - # IBM XL 8.0, 9.0 on PPC and BlueGene - lt_prog_compiler_wl_CXX='-Wl,' - lt_prog_compiler_pic_CXX='-qpic' - lt_prog_compiler_static_CXX='-qstaticlink' - ;; - *) - case `$CC -V 2>&1 | sed 5q` in - *Sun\ C*) - # Sun C++ 5.9 - lt_prog_compiler_pic_CXX='-KPIC' - lt_prog_compiler_static_CXX='-Bstatic' - lt_prog_compiler_wl_CXX='-Qoption ld ' - ;; - esac - ;; - esac - ;; - lynxos*) - ;; - m88k*) - ;; - mvs*) - case $cc_basename in - cxx*) - lt_prog_compiler_pic_CXX='-W c,exportall' - ;; - *) - ;; - esac - ;; - netbsd*) - ;; - *qnx* | *nto*) - # QNX uses GNU C++, but need to define -shared option too, otherwise - # it will coredump. - lt_prog_compiler_pic_CXX='-fPIC -shared' - ;; - osf3* | osf4* | osf5*) - case $cc_basename in - KCC*) - lt_prog_compiler_wl_CXX='--backend -Wl,' - ;; - RCC*) - # Rational C++ 2.4.1 - lt_prog_compiler_pic_CXX='-pic' - ;; - cxx*) - # Digital/Compaq C++ - lt_prog_compiler_wl_CXX='-Wl,' - # Make sure the PIC flag is empty. It appears that all Alpha - # Linux and Compaq Tru64 Unix objects are PIC. - lt_prog_compiler_pic_CXX= - lt_prog_compiler_static_CXX='-non_shared' - ;; - *) - ;; - esac - ;; - psos*) - ;; - solaris*) - case $cc_basename in - CC* | sunCC*) - # Sun C++ 4.2, 5.x and Centerline C++ - lt_prog_compiler_pic_CXX='-KPIC' - lt_prog_compiler_static_CXX='-Bstatic' - lt_prog_compiler_wl_CXX='-Qoption ld ' - ;; - gcx*) - # Green Hills C++ Compiler - lt_prog_compiler_pic_CXX='-PIC' - ;; - *) - ;; - esac - ;; - sunos4*) - case $cc_basename in - CC*) - # Sun C++ 4.x - lt_prog_compiler_pic_CXX='-pic' - lt_prog_compiler_static_CXX='-Bstatic' - ;; - lcc*) - # Lucid - lt_prog_compiler_pic_CXX='-pic' - ;; - *) - ;; - esac - ;; - sysv5* | unixware* | sco3.2v5* | sco5v6* | OpenUNIX*) - case $cc_basename in - CC*) - lt_prog_compiler_wl_CXX='-Wl,' - lt_prog_compiler_pic_CXX='-KPIC' - lt_prog_compiler_static_CXX='-Bstatic' - ;; - esac - ;; - tandem*) - case $cc_basename in - NCC*) - # NonStop-UX NCC 3.20 - lt_prog_compiler_pic_CXX='-KPIC' - ;; - *) - ;; - esac - ;; - vxworks*) - ;; - *) - lt_prog_compiler_can_build_shared_CXX=no - ;; - esac - fi - -case $host_os in - # For platforms that do not support PIC, -DPIC is meaningless: - *djgpp*) - lt_prog_compiler_pic_CXX= - ;; - *) - lt_prog_compiler_pic_CXX="$lt_prog_compiler_pic_CXX -DPIC" - ;; -esac - -{ $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 ${lt_cv_prog_compiler_pic_CXX+:} false; then : - $as_echo_n "(cached) " >&6 -else - lt_cv_prog_compiler_pic_CXX=$lt_prog_compiler_pic_CXX -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_pic_CXX" >&5 -$as_echo "$lt_cv_prog_compiler_pic_CXX" >&6; } -lt_prog_compiler_pic_CXX=$lt_cv_prog_compiler_pic_CXX - -# -# Check to make sure the PIC flag actually works. -# -if test -n "$lt_prog_compiler_pic_CXX"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $compiler PIC flag $lt_prog_compiler_pic_CXX works" >&5 -$as_echo_n "checking if $compiler PIC flag $lt_prog_compiler_pic_CXX works... " >&6; } -if ${lt_cv_prog_compiler_pic_works_CXX+:} false; then : - $as_echo_n "(cached) " >&6 -else - lt_cv_prog_compiler_pic_works_CXX=no - ac_outfile=conftest.$ac_objext - echo "$lt_simple_compile_test_code" > conftest.$ac_ext - lt_compiler_flag="$lt_prog_compiler_pic_CXX -DPIC" ## exclude from sc_useless_quotes_in_assignment - # 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:$LINENO: $lt_compile\"" >&5) - (eval "$lt_compile" 2>conftest.err) - ac_status=$? - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $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 "$_lt_compiler_boilerplate" | $SED '/^$/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_CXX=yes - fi - fi - $RM conftest* - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_pic_works_CXX" >&5 -$as_echo "$lt_cv_prog_compiler_pic_works_CXX" >&6; } - -if test yes = "$lt_cv_prog_compiler_pic_works_CXX"; then - case $lt_prog_compiler_pic_CXX in - "" | " "*) ;; - *) lt_prog_compiler_pic_CXX=" $lt_prog_compiler_pic_CXX" ;; - esac -else - lt_prog_compiler_pic_CXX= - lt_prog_compiler_can_build_shared_CXX=no -fi - -fi - - - - - -# -# Check to make sure the static flag actually works. -# -wl=$lt_prog_compiler_wl_CXX eval lt_tmp_static_flag=\"$lt_prog_compiler_static_CXX\" -{ $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 ${lt_cv_prog_compiler_static_works_CXX+:} false; then : - $as_echo_n "(cached) " >&6 -else - lt_cv_prog_compiler_static_works_CXX=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 "$_lt_linker_boilerplate" | $SED '/^$/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_CXX=yes - fi - else - lt_cv_prog_compiler_static_works_CXX=yes - fi - fi - $RM -r conftest* - LDFLAGS=$save_LDFLAGS - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_static_works_CXX" >&5 -$as_echo "$lt_cv_prog_compiler_static_works_CXX" >&6; } - -if test yes = "$lt_cv_prog_compiler_static_works_CXX"; then - : -else - lt_prog_compiler_static_CXX= -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 ${lt_cv_prog_compiler_c_o_CXX+:} false; then : - $as_echo_n "(cached) " >&6 -else - lt_cv_prog_compiler_c_o_CXX=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:$LINENO: $lt_compile\"" >&5) - (eval "$lt_compile" 2>out/conftest.err) - ac_status=$? - cat out/conftest.err >&5 - echo "$as_me:$LINENO: \$? = $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 "$_lt_compiler_boilerplate" | $SED '/^$/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_CXX=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_CXX" >&5 -$as_echo "$lt_cv_prog_compiler_c_o_CXX" >&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 ${lt_cv_prog_compiler_c_o_CXX+:} false; then : - $as_echo_n "(cached) " >&6 -else - lt_cv_prog_compiler_c_o_CXX=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:$LINENO: $lt_compile\"" >&5) - (eval "$lt_compile" 2>out/conftest.err) - ac_status=$? - cat out/conftest.err >&5 - echo "$as_me:$LINENO: \$? = $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 "$_lt_compiler_boilerplate" | $SED '/^$/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_CXX=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_CXX" >&5 -$as_echo "$lt_cv_prog_compiler_c_o_CXX" >&6; } - - - - -hard_links=nottested -if test no = "$lt_cv_prog_compiler_c_o_CXX" && test no != "$need_locks"; 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 no = "$hard_links"; 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; } - - export_symbols_cmds_CXX='$NM $libobjs $convenience | $global_symbol_pipe | $SED '\''s/.* //'\'' | sort | uniq > $export_symbols' - exclude_expsyms_CXX='_GLOBAL_OFFSET_TABLE_|_GLOBAL__F[ID]_.*' - 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 GNU nm, but means don't demangle to AIX nm. - # Without the "-l" option, or with the "-B" option, AIX nm treats - # weak defined symbols like other global defined symbols, whereas - # GNU nm marks them as "W". - # While the 'weak' keyword is ignored in the Export File, we need - # it in the Import File for the 'aix-soname' feature, so we have - # to replace the "-B" option with "-P" for AIX nm. - if $NM -V 2>&1 | $GREP 'GNU' > /dev/null; then - export_symbols_cmds_CXX='$NM -Bpg $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B") || (\$ 2 == "W")) && (substr(\$ 3,1,1) != ".")) { if (\$ 2 == "W") { print \$ 3 " weak" } else { print \$ 3 } } }'\'' | sort -u > $export_symbols' - else - export_symbols_cmds_CXX='`func_echo_all $NM | $SED -e '\''s/B\([^B]*\)$/P\1/'\''` -PCpgl $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B") || (\$ 2 == "W") || (\$ 2 == "V") || (\$ 2 == "Z")) && (substr(\$ 1,1,1) != ".")) { if ((\$ 2 == "W") || (\$ 2 == "V") || (\$ 2 == "Z")) { print \$ 1 " weak" } else { print \$ 1 } } }'\'' | sort -u > $export_symbols' - fi - ;; - pw32*) - export_symbols_cmds_CXX=$ltdll_cmds - ;; - cygwin* | mingw* | cegcc*) - case $cc_basename in - cl*) - exclude_expsyms_CXX='_NULL_IMPORT_DESCRIPTOR|_IMPORT_DESCRIPTOR_.*' - ;; - *) - export_symbols_cmds_CXX='$NM $libobjs $convenience | $global_symbol_pipe | $SED -e '\''/^[BCDGRS][ ]/s/.*[ ]\([^ ]*\)/\1 DATA/;s/^.*[ ]__nm__\([^ ]*\)[ ][^ ]*/\1 DATA/;/^I[ ]/d;/^[AITW][ ]/s/.* //'\'' | sort | uniq > $export_symbols' - exclude_expsyms_CXX='[_]+GLOBAL_OFFSET_TABLE_|[_]+GLOBAL__[FID]_.*|[_]+head_[A-Za-z0-9_]+_dll|[A-Za-z0-9_]+_dll_iname' - ;; - esac - ;; - *) - export_symbols_cmds_CXX='$NM $libobjs $convenience | $global_symbol_pipe | $SED '\''s/.* //'\'' | sort | uniq > $export_symbols' - ;; - esac - -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ld_shlibs_CXX" >&5 -$as_echo "$ld_shlibs_CXX" >&6; } -test no = "$ld_shlibs_CXX" && can_build_shared=no - -with_gnu_ld_CXX=$with_gnu_ld - - - - - - -# -# Do we need to explicitly link libc? -# -case "x$archive_cmds_need_lc_CXX" in -x|xyes) - # Assume -lc should be added - archive_cmds_need_lc_CXX=yes - - if test yes,yes = "$GCC,$enable_shared"; then - case $archive_cmds_CXX 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; } -if ${lt_cv_archive_cmds_need_lc_CXX+:} false; then : - $as_echo_n "(cached) " >&6 -else - $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_CXX - pic_flag=$lt_prog_compiler_pic_CXX - compiler_flags=-v - linker_flags=-v - verstring= - output_objdir=. - libname=conftest - lt_save_allow_undefined_flag=$allow_undefined_flag_CXX - allow_undefined_flag_CXX= - if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$archive_cmds_CXX 2\>\&1 \| $GREP \" -lc \" \>/dev/null 2\>\&1\""; } >&5 - (eval $archive_cmds_CXX 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 - lt_cv_archive_cmds_need_lc_CXX=no - else - lt_cv_archive_cmds_need_lc_CXX=yes - fi - allow_undefined_flag_CXX=$lt_save_allow_undefined_flag - else - cat conftest.err 1>&5 - fi - $RM conftest* - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_archive_cmds_need_lc_CXX" >&5 -$as_echo "$lt_cv_archive_cmds_need_lc_CXX" >&6; } - archive_cmds_need_lc_CXX=$lt_cv_archive_cmds_need_lc_CXX - ;; - esac - fi - ;; -esac - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking dynamic linker characteristics" >&5 -$as_echo_n "checking dynamic linker characteristics... " >&6; } - -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 # correct to gnu/linux during the next big refactor - 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 # correct to gnu/linux during the next big refactor - need_lib_prefix=no - need_version=no - hardcode_into_libs=yes - if test ia64 = "$host_cpu"; 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 - # Using Import Files as archive members, it is possible to support - # filename-based versioning of shared library archives on AIX. While - # this would work for both with and without runtime linking, it will - # prevent static linking of such archives. So we do filename-based - # shared library versioning with .so extension only, which is used - # when both runtime linking and shared linking is enabled. - # Unfortunately, runtime linking may impact performance, so we do - # not want this to be the default eventually. Also, we use the - # versioned .so libs for executables only if there is the -brtl - # linker flag in LDFLAGS as well, or --with-aix-soname=svr4 only. - # To allow for filename-based versioning support, we need to create - # libNAME.so.V as an archive file, containing: - # *) an Import File, referring to the versioned filename of the - # archive as well as the shared archive member, telling the - # bitwidth (32 or 64) of that shared object, and providing the - # list of exported symbols of that shared object, eventually - # decorated with the 'weak' keyword - # *) the shared object with the F_LOADONLY flag set, to really avoid - # it being seen by the linker. - # At run time we better use the real file rather than another symlink, - # but for link time we create the symlink libNAME.so -> libNAME.so.V - - case $with_aix_soname,$aix_use_runtimelinking in - # AIX (on Power*) has no versioning support, so currently we cannot hardcode correct - # soname into executable. Probably we can add versioning support to - # collect2, so additional links can be useful in future. - aix,yes) # traditional libtool - dynamic_linker='AIX unversionable lib.so' - # 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' - ;; - aix,no) # traditional AIX only - dynamic_linker='AIX lib.a(lib.so.V)' - # 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' - ;; - svr4,*) # full svr4 only - dynamic_linker="AIX lib.so.V($shared_archive_member_spec.o)" - library_names_spec='$libname$release$shared_ext$major $libname$shared_ext' - # We do not specify a path in Import Files, so LIBPATH fires. - shlibpath_overrides_runpath=yes - ;; - *,yes) # both, prefer svr4 - dynamic_linker="AIX lib.so.V($shared_archive_member_spec.o), lib.a(lib.so.V)" - library_names_spec='$libname$release$shared_ext$major $libname$shared_ext' - # unpreferred sharedlib libNAME.a needs extra handling - postinstall_cmds='test -n "$linkname" || linkname="$realname"~func_stripname "" ".so" "$linkname"~$install_shared_prog "$dir/$func_stripname_result.$libext" "$destdir/$func_stripname_result.$libext"~test -z "$tstripme" || test -z "$striplib" || $striplib "$destdir/$func_stripname_result.$libext"' - postuninstall_cmds='for n in $library_names $old_library; do :; done~func_stripname "" ".so" "$n"~test "$func_stripname_result" = "$n" || func_append rmfiles " $odir/$func_stripname_result.$libext"' - # We do not specify a path in Import Files, so LIBPATH fires. - shlibpath_overrides_runpath=yes - ;; - *,no) # both, prefer aix - dynamic_linker="AIX lib.a(lib.so.V), lib.so.V($shared_archive_member_spec.o)" - library_names_spec='$libname$release.a $libname.a' - soname_spec='$libname$release$shared_ext$major' - # unpreferred sharedlib libNAME.so.V and symlink libNAME.so need extra handling - postinstall_cmds='test -z "$dlname" || $install_shared_prog $dir/$dlname $destdir/$dlname~test -z "$tstripme" || test -z "$striplib" || $striplib $destdir/$dlname~test -n "$linkname" || linkname=$realname~func_stripname "" ".a" "$linkname"~(cd "$destdir" && $LN_S -f $dlname $func_stripname_result.so)' - postuninstall_cmds='test -z "$dlname" || func_append rmfiles " $odir/$dlname"~for n in $old_library $library_names; do :; done~func_stripname "" ".a" "$n"~func_append rmfiles " $odir/$func_stripname_result.so"' - ;; - esac - 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=`func_echo_all "$lib" | $SED '\''s%^.*/\([^/]*\)\.ixlibrary$%\1%'\''`; $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 # correct to gnu/linux during the next big refactor - 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,$cc_basename in - yes,*) - # gcc - 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' - - ;; - mingw* | cegcc*) - # MinGW DLLs use traditional 'lib' prefix - soname_spec='$libname`echo $release | $SED -e 's/[.]/-/g'`$versuffix$shared_ext' - ;; - 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 - dynamic_linker='Win32 ld.exe' - ;; - - *,cl*) - # Native MSVC - libname_spec='$name' - soname_spec='$libname`echo $release | $SED -e 's/[.]/-/g'`$versuffix$shared_ext' - library_names_spec='$libname.dll.lib' - - case $build_os in - mingw*) - sys_lib_search_path_spec= - lt_save_ifs=$IFS - IFS=';' - for lt_path in $LIB - do - IFS=$lt_save_ifs - # Let DOS variable expansion print the short 8.3 style file name. - lt_path=`cd "$lt_path" 2>/dev/null && cmd //C "for %i in (".") do @echo %~si"` - sys_lib_search_path_spec="$sys_lib_search_path_spec $lt_path" - done - IFS=$lt_save_ifs - # Convert to MSYS style. - sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | sed -e 's|\\\\|/|g' -e 's| \\([a-zA-Z]\\):| /\\1|g' -e 's|^ ||'` - ;; - cygwin*) - # Convert to unix form, then to dos form, then back to unix form - # but this time dos style (no spaces!) so that the unix form looks - # like /cygdrive/c/PROGRA~1:/cygdr... - sys_lib_search_path_spec=`cygpath --path --unix "$LIB"` - sys_lib_search_path_spec=`cygpath --path --dos "$sys_lib_search_path_spec" 2>/dev/null` - sys_lib_search_path_spec=`cygpath --path --unix "$sys_lib_search_path_spec" | $SED -e "s/$PATH_SEPARATOR/ /g"` - ;; - *) - sys_lib_search_path_spec=$LIB - if $ECHO "$sys_lib_search_path_spec" | $GREP ';[c-zC-Z]:/' >/dev/null; then - # It is most probably a Windows format PATH. - 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 - # FIXME: find the short name or the path components, as spaces are - # common. (e.g. "Program Files" -> "PROGRA~1") - ;; - esac - - # 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' - postuninstall_cmds='dldll=`$SHELL 2>&1 -c '\''. $file; echo \$dlname'\''`~ - dlpath=$dir/\$dldll~ - $RM \$dlpath' - shlibpath_overrides_runpath=yes - dynamic_linker='Win32 link.exe' - ;; - - *) - # Assume MSVC wrapper - library_names_spec='$libname`echo $release | $SED -e 's/[.]/-/g'`$versuffix$shared_ext $libname.lib' - dynamic_linker='Win32 ld.exe' - ;; - esac - # 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_dlsearch_path_spec='/usr/local/lib /lib /usr/lib' - ;; - -dgux*) - version_type=linux # correct to gnu/linux during the next big refactor - 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 - ;; - -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[23].*) 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$major $libname$shared_ext' - soname_spec='$libname$release$shared_ext$major' - 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 - ;; - -haiku*) - version_type=linux # correct to gnu/linux during the next big refactor - need_lib_prefix=no - need_version=no - dynamic_linker="$host_os runtime_loader" - 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=LIBRARY_PATH - shlibpath_overrides_runpath=no - sys_lib_dlsearch_path_spec='/boot/home/config/lib /boot/common/lib /boot/system/lib' - 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 32 = "$HPUX_IA64_MODE"; then - sys_lib_search_path_spec="/usr/lib/hpux32 /usr/local/lib/hpux32 /usr/local/lib" - sys_lib_dlsearch_path_spec=/usr/lib/hpux32 - else - sys_lib_search_path_spec="/usr/lib/hpux64 /usr/local/lib/hpux64" - sys_lib_dlsearch_path_spec=/usr/lib/hpux64 - fi - ;; - 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' - # or fails outright, so override atomically: - install_override_mode=555 - ;; - -interix[3-9]*) - version_type=linux # correct to gnu/linux during the next big refactor - 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 yes = "$lt_cv_prog_gnu_ld"; then - version_type=linux # correct to gnu/linux during the next big refactor - 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 - ;; - -linux*android*) - version_type=none # Android doesn't support versioned libraries. - need_lib_prefix=no - need_version=no - library_names_spec='$libname$release$shared_ext' - soname_spec='$libname$release$shared_ext' - finish_cmds= - shlibpath_var=LD_LIBRARY_PATH - shlibpath_overrides_runpath=yes - - # 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 - - dynamic_linker='Android linker' - # Don't embed -rpath directories since the linker doesn't support them. - hardcode_libdir_flag_spec_CXX='-L$libdir' - ;; - -# This must be glibc/ELF. -linux* | k*bsd*-gnu | kopensolaris*-gnu | gnu*) - version_type=linux # correct to gnu/linux during the next big refactor - 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 - if ${lt_cv_shlibpath_overrides_runpath+:} false; then : - $as_echo_n "(cached) " >&6 -else - lt_cv_shlibpath_overrides_runpath=no - save_LDFLAGS=$LDFLAGS - save_libdir=$libdir - eval "libdir=/foo; wl=\"$lt_prog_compiler_wl_CXX\"; \ - LDFLAGS=\"\$LDFLAGS $hardcode_libdir_flag_spec_CXX\"" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_cxx_try_link "$LINENO"; then : - if ($OBJDUMP -p conftest$ac_exeext) 2>/dev/null | grep "RUNPATH.*$libdir" >/dev/null; then : - lt_cv_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 - -fi - - shlibpath_overrides_runpath=$lt_cv_shlibpath_overrides_runpath - - # 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 - - # Ideally, we could use ldconfig to report *all* directores which are - # searched for libraries, however this is still not possible. Aside from not - # being certain /sbin/ldconfig is available, command - # 'ldconfig -N -X -v | grep ^/' on 64bit Fedora does not report /usr/lib64, - # even though it is searched at run-time. Try to do the best guess by - # appending ld.so.conf contents (and includes) 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;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' - ;; - -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 # correct to gnu/linux during the next big refactor - 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* | bitrig*) - version_type=sunos - sys_lib_dlsearch_path_spec=/usr/lib - need_lib_prefix=no - if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`"; then - need_version=no - else - need_version=yes - fi - 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 - shlibpath_overrides_runpath=yes - ;; - -os2*) - libname_spec='$name' - version_type=windows - shrext_cmds=.dll - need_version=no - need_lib_prefix=no - # OS/2 can only load a DLL with a base name of 8 characters or less. - soname_spec='`test -n "$os2dllname" && libname="$os2dllname"; - v=$($ECHO $release$versuffix | tr -d .-); - n=$($ECHO $libname | cut -b -$((8 - ${#v})) | tr . _); - $ECHO $n$v`$shared_ext' - library_names_spec='${libname}_dll.$libext' - dynamic_linker='OS/2 ld.exe' - shlibpath_var=BEGINLIBPATH - sys_lib_search_path_spec="/lib /usr/lib /usr/local/lib" - sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec - 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' - ;; - -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 # correct to gnu/linux during the next big refactor - 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 yes = "$with_gnu_ld"; then - need_lib_prefix=no - fi - need_version=yes - ;; - -sysv4 | sysv4.3*) - version_type=linux # correct to gnu/linux during the next big refactor - 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 # correct to gnu/linux during the next big refactor - 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=sco - 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 yes = "$with_gnu_ld"; 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 # correct to gnu/linux during the next big refactor - 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 # correct to gnu/linux during the next big refactor - 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 no = "$dynamic_linker" && can_build_shared=no - -variables_saved_for_relink="PATH $shlibpath_var $runpath_var" -if test yes = "$GCC"; then - variables_saved_for_relink="$variables_saved_for_relink GCC_EXEC_PREFIX COMPILER_PATH LIBRARY_PATH" -fi - -if test set = "${lt_cv_sys_lib_search_path_spec+set}"; then - sys_lib_search_path_spec=$lt_cv_sys_lib_search_path_spec -fi - -if test set = "${lt_cv_sys_lib_dlsearch_path_spec+set}"; then - sys_lib_dlsearch_path_spec=$lt_cv_sys_lib_dlsearch_path_spec -fi - -# remember unaugmented sys_lib_dlsearch_path content for libtool script decls... -configure_time_dlsearch_path=$sys_lib_dlsearch_path_spec - -# ... but it needs LT_SYS_LIBRARY_PATH munging for other configure-time code -func_munge_path_list sys_lib_dlsearch_path_spec "$LT_SYS_LIBRARY_PATH" - -# to be used as default LT_SYS_LIBRARY_PATH value in generated libtool -configure_time_lt_sys_library_path=$LT_SYS_LIBRARY_PATH - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - { $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_CXX= -if test -n "$hardcode_libdir_flag_spec_CXX" || - test -n "$runpath_var_CXX" || - test yes = "$hardcode_automatic_CXX"; then - - # We can hardcode non-existent directories. - if test no != "$hardcode_direct_CXX" && - # 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 no != "$_LT_TAGVAR(hardcode_shlibpath_var, CXX)" && - test no != "$hardcode_minus_L_CXX"; then - # Linking always hardcodes the temporary library directory. - hardcode_action_CXX=relink - else - # We can link without hardcoding, and we can hardcode nonexisting dirs. - hardcode_action_CXX=immediate - fi -else - # We cannot hardcode anything, or else we can only hardcode existing - # directories. - hardcode_action_CXX=unsupported -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $hardcode_action_CXX" >&5 -$as_echo "$hardcode_action_CXX" >&6; } - -if test relink = "$hardcode_action_CXX" || - test yes = "$inherit_rpath_CXX"; then - # Fast installation is not supported - enable_fast_install=no -elif test yes = "$shlibpath_overrides_runpath" || - test no = "$enable_shared"; then - # Fast installation is not necessary - enable_fast_install=needless -fi - - - - - - - - fi # test -n "$compiler" - - CC=$lt_save_CC - CFLAGS=$lt_save_CFLAGS - 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 yes != "$_lt_caught_CXX_error" - -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_commands="$ac_config_commands libtool" - - - - -# Only expand once: - - -# Note: If Autoconf reports that LIBTOOL (or AC_ENABLE_SHARED, or -# AC_PROG_LIBTOOL) is undefined, Libtool installation should be checked. - -# Special CFLAGS to use when building -gc_cflags="" - -# gc_use_mmap Set to "yes" on platforms where mmap should be used instead -# of sbrk. This will define USE_MMAP. -gc_use_mmap="" - -# We should set -fexceptions if we are using gcc and might be used -# inside something like gcj. This is the zeroth approximation: -if test :"$GCC": = :yes: ; then - gc_cflags="${gc_cflags} -fexceptions" -else - case "$host" in - hppa*-*-hpux* ) - if test :$GCC: != :"yes": ; then - gc_cflags="${gc_flags} +ESdbgasm" - fi - # :TODO: actaully we should check using Autoconf if - # the compiler supports this option. - ;; - esac -fi - -case "${host}" in - *-linux*) - # FIXME: This seems to be no longer needed as configured in gcconfig.h - #gc_use_mmap=yes - ;; -esac - -# target_optspace --enable-target-optspace ("yes", "no", "") -case "${target_optspace}:${host}" in - yes:*) - gc_cflags="${gc_cflags} -Os" - ;; - :m32r-* | :d10v-* | :d30v-*) - gc_cflags="${gc_cflags} -Os" - ;; - no:* | :*) - # Nothing. - ;; -esac - -# Set any host dependent compiler flags. -case "${host}" in - mips-tx39-*|mipstx39-unknown-*) - gc_cflags="${gc_cflags} -G 0" - ;; - *) - ;; -esac - - -GC_CFLAGS=${gc_cflags} - - -# Check whether --enable-threads was given. -if test "${enable_threads+set}" = set; then : - enableval=$enable_threads; THREADS=$enableval -else - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for thread model used by GCC" >&5 -$as_echo_n "checking for thread model used by GCC... " >&6; } - THREADS=`$CC -v 2>&1 | sed -n 's/^Thread model: //p'` - if test -z "$THREADS"; then - THREADS=no - fi - if test "$THREADS" = "posix"; then - case "$host" in - *-*-mingw*) - # Adjust thread model if cross-compiling for MinGW. - THREADS=win32 - ;; - esac - fi - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $THREADS" >&5 -$as_echo "$THREADS" >&6; } -fi - - -# Check whether --enable-parallel-mark was given. -if test "${enable_parallel_mark+set}" = set; then : - enableval=$enable_parallel_mark; case "$THREADS" in - no | none | single) - if test "${enable_parallel_mark}" != no; then - as_fn_error $? "Parallel mark requires --enable-threads=x spec" "$LINENO" 5 - fi - ;; - esac - -fi - - -# Check whether --enable-cplusplus was given. -if test "${enable_cplusplus+set}" = set; then : - enableval=$enable_cplusplus; -fi - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for inline" >&5 -$as_echo_n "checking for inline... " >&6; } -if ${ac_cv_c_inline+:} false; 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 - - -THREADDLLIBS= -need_atomic_ops_asm=false -## Libraries needed to support dynamic loading and/or threads. -case "$THREADS" in - no | none | single) - THREADS=none - ;; - posix | pthreads) - THREADS=posix - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for pthread_self in -lpthread" >&5 -$as_echo_n "checking for pthread_self in -lpthread... " >&6; } -if ${ac_cv_lib_pthread_pthread_self+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_check_lib_save_LIBS=$LIBS -LIBS="-lpthread $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 pthread_self (); -int -main () -{ -return pthread_self (); - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - ac_cv_lib_pthread_pthread_self=yes -else - ac_cv_lib_pthread_pthread_self=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_pthread_pthread_self" >&5 -$as_echo "$ac_cv_lib_pthread_pthread_self" >&6; } -if test "x$ac_cv_lib_pthread_pthread_self" = xyes; then : - THREADDLLIBS="-lpthread" -fi - - case "$host" in - x86-*-linux* | ia64-*-linux* | i586-*-linux* | i686-*-linux* \ - | x86_64-*-linux* | alpha-*-linux* | powerpc*-*-linux* | sparc*-*-linux*) - $as_echo "#define GC_LINUX_THREADS 1" >>confdefs.h - - $as_echo "#define _REENTRANT 1" >>confdefs.h - - if test "${enable_parallel_mark}" != no; then - $as_echo "#define PARALLEL_MARK 1" >>confdefs.h - - fi - $as_echo "#define THREAD_LOCAL_ALLOC 1" >>confdefs.h - - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: \"Explicit GC_INIT() calls may be required.\"" >&5 -$as_echo "$as_me: WARNING: \"Explicit GC_INIT() calls may be required.\"" >&2;}; - ;; - *-*-linux*) - $as_echo "#define GC_LINUX_THREADS 1" >>confdefs.h - - $as_echo "#define _REENTRANT 1" >>confdefs.h - - ;; - *-*-aix*) - $as_echo "#define GC_AIX_THREADS 1" >>confdefs.h - - $as_echo "#define _REENTRANT 1" >>confdefs.h - - ;; - *-*-hpux11*) - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: \"Only HP/UX 11 POSIX threads are supported.\"" >&5 -$as_echo "$as_me: WARNING: \"Only HP/UX 11 POSIX threads are supported.\"" >&2;} - $as_echo "#define GC_HPUX_THREADS 1" >>confdefs.h - - $as_echo "#define _POSIX_C_SOURCE 199506L" >>confdefs.h - - if test "${enable_parallel_mark}" = yes; then - $as_echo "#define PARALLEL_MARK 1" >>confdefs.h - - fi - $as_echo "#define THREAD_LOCAL_ALLOC 1" >>confdefs.h - - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: \"Explicit GC_INIT() calls may be required.\"" >&5 -$as_echo "$as_me: WARNING: \"Explicit GC_INIT() calls may be required.\"" >&2;}; - THREADDLLIBS="-lpthread -lrt" - # HPUX needs REENTRANT for the _r calls. - -$as_echo "#define _REENTRANT 1" >>confdefs.h - - ;; - *-*-hpux10*) - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: \"Only HP-UX 11 POSIX threads are supported.\"" >&5 -$as_echo "$as_me: WARNING: \"Only HP-UX 11 POSIX threads are supported.\"" >&2;} - ;; - *-*-openbsd*) - $as_echo "#define GC_OPENBSD_THREADS 1" >>confdefs.h - - THREADDLLIBS=-pthread - AM_CFLAGS="$AM_CFLAGS -pthread" - ;; - *-*-freebsd*) - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: \"FreeBSD does not yet fully support threads with Boehm GC.\"" >&5 -$as_echo "$as_me: WARNING: \"FreeBSD does not yet fully support threads with Boehm GC.\"" >&2;} - $as_echo "#define GC_FREEBSD_THREADS 1" >>confdefs.h - - AM_CFLAGS="$AM_CFLAGS -pthread" - if test "${enable_parallel_mark}" = yes; then - $as_echo "#define PARALLEL_MARK 1" >>confdefs.h - - fi - $as_echo "#define THREAD_LOCAL_ALLOC 1" >>confdefs.h - - ;; - *-*-kfreebsd*-gnu) - $as_echo "#define GC_FREEBSD_THREADS 1" >>confdefs.h - - AM_CFLAGS="$AM_CFLAGS -pthread" - THREADDLLIBS=-pthread - $as_echo "#define _REENTRANT 1" >>confdefs.h - - if test "${enable_parallel_mark}" = yes; then - $as_echo "#define PARALLEL_MARK 1" >>confdefs.h - - fi - $as_echo "#define THREAD_LOCAL_ALLOC 1" >>confdefs.h - - $as_echo "#define USE_COMPILER_TLS 1" >>confdefs.h - - ;; - *-*-gnu*) - $as_echo "#define GC_GNU_THREADS 1" >>confdefs.h - - $as_echo "#define _REENTRANT 1" >>confdefs.h - - $as_echo "#define THREAD_LOCAL_ALLOC 1" >>confdefs.h - - ;; - *-*-netbsd*) - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: \"Only on NetBSD 2.0 or later.\"" >&5 -$as_echo "$as_me: WARNING: \"Only on NetBSD 2.0 or later.\"" >&2;} - $as_echo "#define GC_NETBSD_THREADS 1" >>confdefs.h - - $as_echo "#define _REENTRANT 1" >>confdefs.h - - $as_echo "#define _PTHREADS 1" >>confdefs.h - - THREADDLLIBS="-lpthread -lrt" - ;; - *-*-solaris*) - $as_echo "#define GC_SOLARIS_THREADS 1" >>confdefs.h - - if test "${enable_parallel_mark}" != no; then - $as_echo "#define PARALLEL_MARK 1" >>confdefs.h - - fi - $as_echo "#define THREAD_LOCAL_ALLOC 1" >>confdefs.h - - # Need to use alternate thread library, otherwise gctest hangs - # on Solaris 8. - multi_os_directory=`$CC -print-multi-os-directory` - THREADDLLIBS="-L/usr/lib/lwp/$multi_os_directory \ - -R/usr/lib/lwp/$multi_os_directory -lpthread -lrt" - ;; - *-*-irix*) - $as_echo "#define GC_IRIX_THREADS 1" >>confdefs.h - - ;; - *-*-cygwin*) - $as_echo "#define GC_WIN32_THREADS 1" >>confdefs.h - - if test "${enable_parallel_mark}" != no; then - $as_echo "#define PARALLEL_MARK 1" >>confdefs.h - - fi - $as_echo "#define THREAD_LOCAL_ALLOC 1" >>confdefs.h - - # Cygwin doesn't have a real libpthread, so Libtool can't link - # against it. - THREADDLLIBS="" - win32_threads=true - ;; - *-*-mingw*) - $as_echo "#define GC_WIN32_PTHREADS 1" >>confdefs.h - - # Using pthreads-win32 (or other non-Cygwin pthreads) library. - if test "${enable_parallel_mark}" != no; then - $as_echo "#define PARALLEL_MARK 1" >>confdefs.h - - fi - $as_echo "#define THREAD_LOCAL_ALLOC 1" >>confdefs.h - - THREADDLLIBS="-lpthread" - win32_threads=true - ;; - *-*-darwin*) - $as_echo "#define GC_DARWIN_THREADS 1" >>confdefs.h - - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: \"Explicit GC_INIT() calls may be required.\"" >&5 -$as_echo "$as_me: WARNING: \"Explicit GC_INIT() calls may be required.\"" >&2;}; - # Parallel-mark is not well-tested on Darwin - if test "${enable_parallel_mark}" != no; then - $as_echo "#define PARALLEL_MARK 1" >>confdefs.h - - fi - $as_echo "#define THREAD_LOCAL_ALLOC 1" >>confdefs.h - - darwin_threads=true - ;; - *-*-osf*) - $as_echo "#define GC_OSF1_THREADS 1" >>confdefs.h - - if test "${enable_parallel_mark}" = yes; then - $as_echo "#define PARALLEL_MARK 1" >>confdefs.h - - $as_echo "#define THREAD_LOCAL_ALLOC 1" >>confdefs.h - - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: \"Explicit GC_INIT() calls may be required.\"" >&5 -$as_echo "$as_me: WARNING: \"Explicit GC_INIT() calls may be required.\"" >&2;}; - # May want to enable it in other cases, too. - # Measurements have not yet been done. - fi - AM_CFLAGS="$AM_CFLAGS -pthread" - THREADDLLIBS="-lpthread -lrt" - ;; - *) - as_fn_error $? "\"Pthreads not supported by the GC on this platform.\"" "$LINENO" 5 - ;; - esac - case "$host" in - sparc*-*-solaris*) - if test "$GCC" != yes; then - need_atomic_ops_asm=true - fi - ;; - esac - ;; - win32) - $as_echo "#define GC_WIN32_THREADS 1" >>confdefs.h - - if test "${enable_parallel_mark}" != no; then - $as_echo "#define PARALLEL_MARK 1" >>confdefs.h - - $as_echo "#define THREAD_LOCAL_ALLOC 1" >>confdefs.h - - else - if test "${enable_shared}" != yes || test "${enable_static}" != no; then - # Imply THREAD_LOCAL_ALLOC unless GC_DLL. - $as_echo "#define THREAD_LOCAL_ALLOC 1" >>confdefs.h - - fi - fi - if test "${enable_win32_dllmain}" = yes; then - -$as_echo "#define GC_INSIDE_DLL 1" >>confdefs.h - - fi - win32_threads=true - -$as_echo "#define EMPTY_GETENV_RESULTS 1" >>confdefs.h - - ;; - dgux386) - THREADS=dgux386 - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $THREADDLLIBS" >&5 -$as_echo "$THREADDLLIBS" >&6; } - # Use pthread GCC switch - THREADDLLIBS=-pthread - if test "${enable_parallel_mark}" = yes; then - $as_echo "#define PARALLEL_MARK 1" >>confdefs.h - - fi - $as_echo "#define THREAD_LOCAL_ALLOC 1" >>confdefs.h - - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: \"Explicit GC_INIT() calls may be required.\"" >&5 -$as_echo "$as_me: WARNING: \"Explicit GC_INIT() calls may be required.\"" >&2;}; - -$as_echo "#define GC_DGUX386_THREADS 1" >>confdefs.h - - -$as_echo "#define DGUX_THREADS 1" >>confdefs.h - - # Enable _POSIX4A_DRAFT10_SOURCE with flag -pthread - AM_CFLAGS="-pthread $AM_CFLAGS" - ;; - aix) - THREADS=posix - THREADDLLIBS=-lpthread - $as_echo "#define GC_AIX_THREADS 1" >>confdefs.h - - $as_echo "#define _REENTRANT 1" >>confdefs.h - - ;; - rtems) - THREADS=posix - $as_echo "#define GC_RTEMS_PTHREADS 1" >>confdefs.h - - $as_echo "#define THREAD_LOCAL_ALLOC 1" >>confdefs.h - - ;; - decosf1 | irix | mach | os2 | solaris | dce | vxworks) - as_fn_error $? "thread package $THREADS not yet supported" "$LINENO" 5 - ;; - *) - as_fn_error $? "$THREADS is an unknown thread package" "$LINENO" 5 - ;; -esac - - if test x$THREADS != xnone; then - THREADS_TRUE= - THREADS_FALSE='#' -else - THREADS_TRUE='#' - THREADS_FALSE= -fi - - if test x$THREADS = xposix; then - PTHREADS_TRUE= - PTHREADS_FALSE='#' -else - PTHREADS_TRUE='#' - PTHREADS_FALSE= -fi - - if test x$darwin_threads = xtrue; then - DARWIN_THREADS_TRUE= - DARWIN_THREADS_FALSE='#' -else - DARWIN_THREADS_TRUE='#' - DARWIN_THREADS_FALSE= -fi - - if test x$win32_threads = xtrue; then - WIN32_THREADS_TRUE= - WIN32_THREADS_FALSE='#' -else - WIN32_THREADS_TRUE='#' - WIN32_THREADS_FALSE= -fi - - -compiler_suncc=no -case "$host" in - powerpc-*-darwin*) - powerpc_darwin=true - ;; - *-*-solaris*) - if test "$GCC" != yes; then - # Solaris SunCC - compiler_suncc=yes - CFLAGS="-O $CFLAGS" - fi - ;; - *-*-wince*) - if test "$enable_gc_debug" != "no"; then - -$as_echo "#define GC_READ_ENV_FILE 1" >>confdefs.h - - fi - ;; -esac - -if test "$GCC" = yes; then - # Output all warnings. - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for gcc -Wextra" >&5 -$as_echo_n "checking for gcc -Wextra... " >&6; } - old_CFLAGS="$CFLAGS" - CFLAGS="-Wextra $CFLAGS" - 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_cc_wextra=yes -else - ac_cv_cc_wextra=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - CFLAGS="$old_CFLAGS" - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_cc_wextra" >&5 -$as_echo "$ac_cv_cc_wextra" >&6; } - if test "$ac_cv_cc_wextra" = yes; then : - WEXTRA="-Wextra" -else - WEXTRA="-W" -fi - CFLAGS="-Wall $WEXTRA $CFLAGS" -fi - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for xlc" >&5 -$as_echo_n "checking for xlc... " >&6; } -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - #ifndef __xlC__ - # error - #endif - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - compiler_xlc=yes -else - compiler_xlc=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $compiler_xlc" >&5 -$as_echo "$compiler_xlc" >&6; } -if test $compiler_xlc = yes -a "$powerpc_darwin" = true; then - # the darwin stack-frame-walking code is completely broken on xlc - -$as_echo "#define DARWIN_DONT_PARSE_STACK 1" >>confdefs.h - -fi - -# XLC neither requires nor tolerates the unnecessary assembler goop. -# Similar for the Sun C compiler. - if test $compiler_xlc = yes -o $compiler_suncc = yes; then - ASM_WITH_CPP_UNSUPPORTED_TRUE= - ASM_WITH_CPP_UNSUPPORTED_FALSE='#' -else - ASM_WITH_CPP_UNSUPPORTED_TRUE='#' - ASM_WITH_CPP_UNSUPPORTED_FALSE= -fi - - -if test "$GCC" = yes; then - # Disable aliasing optimization unless forced to. - { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether gcc supports -fno-strict-aliasing" >&5 -$as_echo_n "checking whether gcc supports -fno-strict-aliasing... " >&6; } - ac_cv_fno_strict_aliasing=no - for cflag in $CFLAGS; do - case "$cflag" in - -fstrict-aliasing) - # Opposite option already present - ac_cv_fno_strict_aliasing=skipped - break - ;; - esac - done - if test "$ac_cv_fno_strict_aliasing" != skipped; then - old_CFLAGS="$CFLAGS" - CFLAGS="$CFLAGS -fno-strict-aliasing" - 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_fno_strict_aliasing=yes -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - CFLAGS="$old_CFLAGS" - if test "$ac_cv_fno_strict_aliasing" = yes; then : - CFLAGS="$CFLAGS -fno-strict-aliasing" -fi - fi - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_fno_strict_aliasing" >&5 -$as_echo "$ac_cv_fno_strict_aliasing" >&6; } -fi - -case "$host" in -# While IRIX 6 has libdl for the O32 and N32 ABIs, it's missing for N64 -# and unnecessary everywhere. - mips-sgi-irix6*) ;; -# We never want libdl on darwin. It is a fake libdl that just ends up making -# dyld calls anyway. The same applies to Cygwin. - *-*-darwin*) ;; - *-*-cygwin*) ;; - *) - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5 -$as_echo_n "checking for dlopen in -ldl... " >&6; } -if ${ac_cv_lib_dl_dlopen+:} false; 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" = xyes; then : - THREADDLLIBS="$THREADDLLIBS -ldl" -fi - - ;; -esac - -case "$host" in - *-*-hpux*) - avoid_cpp_lib=yes;; - *) - avoid_cpp_lib=no; - ;; -esac - if test $avoid_cpp_lib = yes; then - AVOID_CPP_LIB_TRUE= - AVOID_CPP_LIB_FALSE='#' -else - AVOID_CPP_LIB_TRUE='#' - AVOID_CPP_LIB_FALSE= -fi - - -# extra LD Flags which are required for targets -case "${host}" in - *-*-darwin*) - extra_ldflags_libgc=-Wl,-single_module - ;; -esac - - - - -target_all=libgc.la - - -TARGET_ECOS="no" - -# Check whether --with-ecos was given. -if test "${with_ecos+set}" = set; then : - withval=$with_ecos; TARGET_ECOS="$with_ecos" - -fi - - -addobjs= -addlibs= -CXXLIBS= - -case "$TARGET_ECOS" in - no) - ;; - *) - -$as_echo "#define ECOS 1" >>confdefs.h - - AM_CPPFLAGS="-I${TARGET_ECOS}/include $AM_CPPFLAGS" - addobjs="$addobjs ecos.lo" - ;; -esac - - if test "${enable_cplusplus}" = yes; then - CPLUSPLUS_TRUE= - CPLUSPLUS_FALSE='#' -else - CPLUSPLUS_TRUE='#' - CPLUSPLUS_FALSE= -fi - - -if test "$GCC" = yes; then - if test "${enable_cplusplus}" = yes; then - case "$host" in - *-*-cygwin* | *-*-mingw*) - { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether libsupc++ required" >&5 -$as_echo_n "checking whether libsupc++ required... " >&6; } - SUPC="`$CXX -print-file-name=libsupc++.a 2>/dev/null`" - if test -n "$SUPC" -a "$SUPC" != "libsupc++.a"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } - CXXLIBS="-lsupc++" - else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } - fi - ;; - esac - fi -fi - - - - - - -# Configuration of shared libraries -# -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to build shared libraries" >&5 -$as_echo_n "checking whether to build shared libraries... " >&6; } -# 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 - - - - - - - -case "$host" in - alpha-*-openbsd*) - enable_shared=no - ;; - *) - ;; -esac - -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $enable_shared" >&5 -$as_echo "$enable_shared" >&6; } - -# Compile with GC_DLL defined unless building static libraries. -if test "${enable_shared}" = yes; then - if test "${enable_static}" = no; then - $as_echo "#define GC_DLL 1" >>confdefs.h - - if test "$GCC" = yes; then - # Pass -fvisibility=hidden option if supported - { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether gcc supports -fvisibility" >&5 -$as_echo_n "checking whether gcc supports -fvisibility... " >&6; } - old_CFLAGS="$CFLAGS" - CFLAGS="-Werror -fvisibility=hidden $CFLAGS" - 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_fvisibility_hidden=yes -else - ac_cv_fvisibility_hidden=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - CFLAGS="$old_CFLAGS" - if test "$ac_cv_fvisibility_hidden" = yes; then : - CFLAGS="-DGC_VISIBILITY_HIDDEN_SET -fvisibility=hidden $CFLAGS" -fi - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_fvisibility_hidden" >&5 -$as_echo "$ac_cv_fvisibility_hidden" >&6; } - fi - fi -fi - -# Configuration of machine-dependent code -# -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking which machine-dependent code should be used" >&5 -$as_echo_n "checking which machine-dependent code should be used... " >&6; } -machdep= -case "$host" in - alpha-*-openbsd*) - if test x"${ac_cv_lib_dl_dlopen}" != xyes ; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: \"OpenBSD/Alpha without dlopen(). Shared library support is disabled.\"" >&5 -$as_echo "$as_me: WARNING: \"OpenBSD/Alpha without dlopen(). Shared library support is disabled.\"" >&2;} - fi - ;; - i?86-*-solaris2.[89]) - # PROC_VDB appears to work in 2.8 and 2.9 but not in 2.10+ (for now). - -$as_echo "#define SOLARIS25_PROC_VDB_BUG_FIXED 1" >>confdefs.h - - ;; - mips-*-*) - ;; - sparc-*-netbsd*) - machdep="sparc_netbsd_mach_dep.lo" - ;; - sparc*-*-linux* | sparc*-*-openbsd* | sparc64-*-freebsd* | sparc64-*-netbsd*) - machdep="sparc_mach_dep.lo" - ;; - sparc-sun-solaris2.3) - machdep="sparc_mach_dep.lo" - -$as_echo "#define SUNOS53_SHARED_LIB 1" >>confdefs.h - - ;; - sparc*-sun-solaris2*) - machdep="sparc_mach_dep.lo" - ;; - ia64-*-*) - machdep="ia64_save_regs_in_stack.lo" - ;; -esac -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $machdep" >&5 -$as_echo "$machdep" >&6; } -addobjs="$addobjs $machdep" - - - - - - -# Check whether --with-target-subdir was given. -if test "${with_target_subdir+set}" = set; then : - withval=$with_target_subdir; -fi - - -# Check whether --with-cross-host was given. -if test "${with_cross_host+set}" = set; then : - withval=$with_cross_host; -fi - - -# automake wants to see AC_EXEEXT. But we don't need it. And having -# it is actually a problem, because the compiler we're passed can't -# necessarily do a full link. So we fool automake here. -if false; then - # autoconf 2.50 runs AC_EXEEXT by default, and the macro expands - # to nothing, so nothing would remain between `then' and `fi' if it - # were not for the `:' below. - : - -fi - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether Solaris gcc optimization fix is necessary" >&5 -$as_echo_n "checking whether Solaris gcc optimization fix is necessary... " >&6; } -case "$host" in - *aix*) - if test "$GCC" = yes; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } - new_CFLAGS= - for i in $CFLAGS; do - case "$i" in - -O*) - ;; - *) - new_CFLAGS="$new_CFLAGS $i" - ;; - esac - done - CFLAGS="$new_CFLAGS" - 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 - - -$as_echo "#define NO_EXECUTE_PERMISSION 1" >>confdefs.h - - -$as_echo "#define ALL_INTERIOR_POINTERS 1" >>confdefs.h - - - -# Check whether --enable-gcj-support was given. -if test "${enable_gcj_support+set}" = set; then : - enableval=$enable_gcj_support; -fi - -if test x"$enable_gcj_support" != xno; then - -$as_echo "#define GC_GCJ_SUPPORT 1" >>confdefs.h - -fi - -# Check whether --enable-sigrt-signals was given. -if test "${enable_sigrt_signals+set}" = set; then : - enableval=$enable_sigrt_signals; -fi - -if test x"${enable_sigrt_signals}" = xyes; then - -$as_echo "#define GC_USESIGRT_SIGNALS 1" >>confdefs.h - -fi - - - - - - -UNWINDLIBS= -# Check whether --enable-gc-debug was given. -if test "${enable_gc_debug+set}" = set; then : - enableval=$enable_gc_debug; if test "$enable_gc_debug" = "yes"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: \"Should define GC_DEBUG and use debug alloc in clients.\"" >&5 -$as_echo "$as_me: WARNING: \"Should define GC_DEBUG and use debug alloc in clients.\"" >&2;} - -$as_echo "#define KEEP_BACK_PTRS 1" >>confdefs.h - - keep_back_ptrs=true - -$as_echo "#define DBG_HDRS_ALL 1" >>confdefs.h - - - - case $host in - ia64-*-linux* ) - $as_echo "#define MAKE_BACK_GRAPH 1" >>confdefs.h - - $as_echo "#define SAVE_CALL_COUNT 8" >>confdefs.h - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for backtrace in -lunwind" >&5 -$as_echo_n "checking for backtrace in -lunwind... " >&6; } -if ${ac_cv_lib_unwind_backtrace+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_check_lib_save_LIBS=$LIBS -LIBS="-lunwind $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 backtrace (); -int -main () -{ -return backtrace (); - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - ac_cv_lib_unwind_backtrace=yes -else - ac_cv_lib_unwind_backtrace=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_unwind_backtrace" >&5 -$as_echo "$ac_cv_lib_unwind_backtrace" >&6; } -if test "x$ac_cv_lib_unwind_backtrace" = xyes; then : - - $as_echo "#define GC_HAVE_BUILTIN_BACKTRACE 1" >>confdefs.h - - UNWINDLIBS=-lunwind - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: \"Client code may need to link against libunwind.\"" >&5 -$as_echo "$as_me: WARNING: \"Client code may need to link against libunwind.\"" >&2;} - -fi - - ;; - x86-*-linux* | i586-*-linux* | i686-*-linux* | x86_64-*-linux* ) - $as_echo "#define MAKE_BACK_GRAPH 1" >>confdefs.h - - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: \"Client must not use -fomit-frame-pointer.\"" >&5 -$as_echo "$as_me: WARNING: \"Client must not use -fomit-frame-pointer.\"" >&2;} - $as_echo "#define SAVE_CALL_COUNT 8" >>confdefs.h - - ;; - i345686-*-dgux*) - $as_echo "#define MAKE_BACK_GRAPH 1" >>confdefs.h - - ;; - esac - fi -fi - - if test x"$enable_gc_debug" = xyes; then - MAKE_BACK_GRAPH_TRUE= - MAKE_BACK_GRAPH_FALSE='#' -else - MAKE_BACK_GRAPH_TRUE='#' - MAKE_BACK_GRAPH_FALSE= -fi - - if test x"$keep_back_ptrs" = xtrue; then - KEEP_BACK_PTRS_TRUE= - KEEP_BACK_PTRS_FALSE='#' -else - KEEP_BACK_PTRS_TRUE='#' - KEEP_BACK_PTRS_FALSE= -fi - - -# Check for dladdr (used for debugging). -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for dladdr" >&5 -$as_echo_n "checking for dladdr... " >&6; } -have_dladdr=no -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -#define _GNU_SOURCE 1 -#include -int -main () -{ -{ - Dl_info info; - (void)dladdr("", &info); -} - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - have_dladdr=yes -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $have_dladdr" >&5 -$as_echo "$have_dladdr" >&6; } -if test x"$have_dladdr" = xyes; then - -$as_echo "#define HAVE_DLADDR 1" >>confdefs.h - -fi - -# Check for AViiON Machines running DGUX -ac_is_dgux=no -ac_fn_c_check_header_mongrel "$LINENO" "sys/dg_sys_info.h" "ac_cv_header_sys_dg_sys_info_h" "$ac_includes_default" -if test "x$ac_cv_header_sys_dg_sys_info_h" = xyes; then : - ac_is_dgux=yes; -fi - - - - ## :GOTCHA: we do not check anything but sys/dg_sys_info.h -if test $ac_is_dgux = yes; then - dgux_spec_opts="-DDGUX -D_DGUX_SOURCE -Di386 -mno-legend -O2" - CFLAGS="$dgux_spec_opts $CFLAGS" - CXXFLAGS="$dgux_spec_opts $CXXFLAGS" - if test "$enable_gc_debug" = "yes"; then - CFLAGS="-g -mstandard $CFLAGS" - CXXFLAGS="-g -mstandard $CXXFLAGS" - fi - - -fi - -# Check whether --enable-java-finalization was given. -if test "${enable_java_finalization+set}" = set; then : - enableval=$enable_java_finalization; -fi - -if test x"$enable_java_finalization" != xno; then - -$as_echo "#define JAVA_FINALIZATION 1" >>confdefs.h - -fi - -# Check whether --enable-atomic-uncollectable was given. -if test "${enable_atomic_uncollectable+set}" = set; then : - enableval=$enable_atomic_uncollectable; -fi - -if test x"$enable_atomic_uncollectible" != x"no"; then - -$as_echo "#define ATOMIC_UNCOLLECTABLE 1" >>confdefs.h - -fi - -# Check whether --enable-redirect-malloc was given. -if test "${enable_redirect_malloc+set}" = set; then : - enableval=$enable_redirect_malloc; -fi - - -if test "${enable_redirect_malloc}" = yes; then - if test "${enable_gc_debug}" = yes; then - -$as_echo "#define REDIRECT_MALLOC GC_debug_malloc_replacement" >>confdefs.h - - -$as_echo "#define REDIRECT_REALLOC GC_debug_realloc_replacement" >>confdefs.h - - -$as_echo "#define REDIRECT_FREE GC_debug_free" >>confdefs.h - - else - $as_echo "#define REDIRECT_MALLOC GC_malloc" >>confdefs.h - - fi - -$as_echo "#define GC_USE_DLOPEN_WRAP 1" >>confdefs.h - -fi - -# Check whether --enable-disclaim was given. -if test "${enable_disclaim+set}" = set; then : - enableval=$enable_disclaim; -fi - -if test x"$enable_disclaim" != xno; then - -$as_echo "#define ENABLE_DISCLAIM 1" >>confdefs.h - -fi - if test x"$enable_disclaim" != xno; then - ENABLE_DISCLAIM_TRUE= - ENABLE_DISCLAIM_FALSE='#' -else - ENABLE_DISCLAIM_TRUE='#' - ENABLE_DISCLAIM_FALSE= -fi - - -# Check whether --enable-large-config was given. -if test "${enable_large_config+set}" = set; then : - enableval=$enable_large_config; -fi - - -if test "${enable_large_config}" = yes; then - -$as_echo "#define LARGE_CONFIG 1" >>confdefs.h - -fi - -# Check whether --enable-handle-fork was given. -if test "${enable_handle_fork+set}" = set; then : - enableval=$enable_handle_fork; -fi - - -if test "${enable_handle_fork}" = yes; then - -$as_echo "#define HANDLE_FORK 1" >>confdefs.h - -elif test "${enable_handle_fork}" = no; then - -$as_echo "#define NO_HANDLE_FORK 1" >>confdefs.h - -fi - -if test -n "${with_cross_host}"; then - -$as_echo "#define NO_CLOCK 1" >>confdefs.h - - -$as_echo "#define SMALL_CONFIG 1" >>confdefs.h - -fi - -if test "$enable_gc_debug" = "no"; then - -$as_echo "#define NO_DEBUGGING 1" >>confdefs.h - -fi - - - -# Check whether --enable-gc-assertions was given. -if test "${enable_gc_assertions+set}" = set; then : - enableval=$enable_gc_assertions; -fi - -if test "${enable_gc_assertions}" = yes; then - -$as_echo "#define GC_ASSERTIONS 1" >>confdefs.h - -fi - -# Check whether --enable-munmap was given. -if test "${enable_munmap+set}" = set; then : - enableval=$enable_munmap; MUNMAP_THRESHOLD=$enableval -fi - -if test "${enable_munmap}" != ""; then - -$as_echo "#define USE_MMAP 1" >>confdefs.h - - case "$host" in - *-*-cygwin*) - # Workaround for Cygwin: use VirtualAlloc since mmap(PROT_NONE) fails - -$as_echo "#define USE_WINALLOC 1" >>confdefs.h - - ;; - esac - -$as_echo "#define USE_MUNMAP 1" >>confdefs.h - - if test "${MUNMAP_THRESHOLD}" = "yes"; then - MUNMAP_THRESHOLD=6 - fi - -cat >>confdefs.h <<_ACEOF -#define MUNMAP_THRESHOLD ${MUNMAP_THRESHOLD} -_ACEOF - -else - if test "${gc_use_mmap}" = "yes"; then - -$as_echo "#define USE_MMAP 1" >>confdefs.h - - fi -fi - - if test -z "$with_cross_host"; then - USE_LIBDIR_TRUE= - USE_LIBDIR_FALSE='#' -else - USE_LIBDIR_TRUE='#' - USE_LIBDIR_FALSE= -fi - - -# Check whether --enable-single-obj-compilation was given. -if test "${enable_single_obj_compilation+set}" = set; then : - enableval=$enable_single_obj_compilation; single_obj_compilation=yes -fi - - if test "$single_obj_compilation" = "yes"; then - SINGLE_GC_OBJ_TRUE= - SINGLE_GC_OBJ_FALSE='#' -else - SINGLE_GC_OBJ_TRUE='#' - SINGLE_GC_OBJ_FALSE= -fi - - -# Atomic Ops -# ---------- - -# Do we want to use an external libatomic_ops? By default use it if it's -# found. - -# Check whether --with-libatomic-ops was given. -if test "${with_libatomic_ops+set}" = set; then : - withval=$with_libatomic_ops; -else - with_libatomic_ops=check -fi - - -# Check for an external libatomic_ops if the answer was yes or check. If not -# found, fail on yes, and convert check to no. -# Note: "syntax error near unexpected token ATOMIC_OPS" reported by configure -# means Autotools pkg.m4 file was not found during aclocal.m4 generation. -missing_libatomic_ops=false - - - - - - - -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 ${ac_cv_path_PKG_CONFIG+:} false; 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 as_fn_executable_p "$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 ${ac_cv_path_ac_pt_PKG_CONFIG+:} false; 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 as_fn_executable_p "$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 -if test x"$with_libatomic_ops" != xno; then : - -pkg_failed=no -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for ATOMIC_OPS" >&5 -$as_echo_n "checking for ATOMIC_OPS... " >&6; } - -if test -n "$ATOMIC_OPS_CFLAGS"; then - pkg_cv_ATOMIC_OPS_CFLAGS="$ATOMIC_OPS_CFLAGS" - elif test -n "$PKG_CONFIG"; then - if test -n "$PKG_CONFIG" && \ - { { $as_echo "$as_me:${as_lineno-$LINENO}: \$PKG_CONFIG --exists --print-errors \"atomic_ops\""; } >&5 - ($PKG_CONFIG --exists --print-errors "atomic_ops") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; then - pkg_cv_ATOMIC_OPS_CFLAGS=`$PKG_CONFIG --cflags "atomic_ops" 2>/dev/null` - test "x$?" != "x0" && pkg_failed=yes -else - pkg_failed=yes -fi - else - pkg_failed=untried -fi -if test -n "$ATOMIC_OPS_LIBS"; then - pkg_cv_ATOMIC_OPS_LIBS="$ATOMIC_OPS_LIBS" - elif test -n "$PKG_CONFIG"; then - if test -n "$PKG_CONFIG" && \ - { { $as_echo "$as_me:${as_lineno-$LINENO}: \$PKG_CONFIG --exists --print-errors \"atomic_ops\""; } >&5 - ($PKG_CONFIG --exists --print-errors "atomic_ops") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; then - pkg_cv_ATOMIC_OPS_LIBS=`$PKG_CONFIG --libs "atomic_ops" 2>/dev/null` - test "x$?" != "x0" && pkg_failed=yes -else - pkg_failed=yes -fi - else - pkg_failed=untried -fi - - - -if test $pkg_failed = yes; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } - -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 - ATOMIC_OPS_PKG_ERRORS=`$PKG_CONFIG --short-errors --print-errors --cflags --libs "atomic_ops" 2>&1` - else - ATOMIC_OPS_PKG_ERRORS=`$PKG_CONFIG --print-errors --cflags --libs "atomic_ops" 2>&1` - fi - # Put the nasty error message in config.log where it belongs - echo "$ATOMIC_OPS_PKG_ERRORS" >&5 - - missing_libatomic_ops=true -elif test $pkg_failed = untried; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } - missing_libatomic_ops=true -else - ATOMIC_OPS_CFLAGS=$pkg_cv_ATOMIC_OPS_CFLAGS - ATOMIC_OPS_LIBS=$pkg_cv_ATOMIC_OPS_LIBS - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } - -fi -fi -if test x$missing_libatomic_ops = xtrue ; then : - if test x"$with_libatomic_ops" != xcheck; then : - as_fn_error $? "An external libatomic_ops was not found" "$LINENO" 5 -fi - with_libatomic_ops=no -fi - -# If we have neither an external or an internal version, offer a useful hint -# and exit. -if test x"$with_libatomic_ops" = xno -a ! -e "$srcdir/libatomic_ops"; then : - as_fn_error $? "libatomic_ops is required. You can either install it on - your system, or fetch and unpack a recent version into the - source directory and link or rename it to libatomic_ops." "$LINENO" 5 -fi - -# Finally, emit the definitions for bundled or external AO. -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking which libatomic_ops to use" >&5 -$as_echo_n "checking which libatomic_ops to use... " >&6; } - - -if test x"$with_libatomic_ops" != xno; then : - { $as_echo "$as_me:${as_lineno-$LINENO}: result: external" >&5 -$as_echo "external" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: internal" >&5 -$as_echo "internal" >&6; } - ATOMIC_OPS_CFLAGS='-I$(top_builddir)/libatomic_ops/src -I$(top_srcdir)/libatomic_ops/src' - ATOMIC_OPS_LIBS="" - - subdirs="$subdirs libatomic_ops" - - -fi - if test x$with_libatomic_ops = xno -a x"$THREADS" != xnone; then - USE_INTERNAL_LIBATOMIC_OPS_TRUE= - USE_INTERNAL_LIBATOMIC_OPS_FALSE='#' -else - USE_INTERNAL_LIBATOMIC_OPS_TRUE='#' - USE_INTERNAL_LIBATOMIC_OPS_FALSE= -fi - - if test x$with_libatomic_ops = xno -a x$need_atomic_ops_asm = xtrue; then - NEED_ATOMIC_OPS_ASM_TRUE= - NEED_ATOMIC_OPS_ASM_FALSE='#' -else - NEED_ATOMIC_OPS_ASM_TRUE='#' - NEED_ATOMIC_OPS_ASM_FALSE= -fi - - - -ac_config_files="$ac_config_files Makefile bdw-gc.pc" - - -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 - if test "x$cache_file" != "x/dev/null"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 -$as_echo "$as_me: updating cache $cache_file" >&6;} - if test ! -f "$cache_file" || test -h "$cache_file"; then - cat confcache >"$cache_file" - else - case $cache_file in #( - */* | ?:*) - mv -f confcache "$cache_file"$$ && - mv -f "$cache_file"$$ "$cache_file" ;; #( - *) - mv -f confcache "$cache_file" ;; - esac - fi - fi - 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= -U= -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 - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking that generated files are newer than configure" >&5 -$as_echo_n "checking that generated files are newer than configure... " >&6; } - if test -n "$am_sleep_pid"; then - # Hide warnings about reused PIDs. - wait $am_sleep_pid 2>/dev/null - fi - { $as_echo "$as_me:${as_lineno-$LINENO}: result: done" >&5 -$as_echo "done" >&6; } - if test -n "$EXEEXT"; then - am__EXEEXT_TRUE= - am__EXEEXT_FALSE='#' -else - am__EXEEXT_TRUE='#' - am__EXEEXT_FALSE= -fi - -if test -z "${MAINTAINER_MODE_TRUE}" && test -z "${MAINTAINER_MODE_FALSE}"; then - as_fn_error $? "conditional \"MAINTAINER_MODE\" was never defined. -Usually this means the macro was only invoked conditionally." "$LINENO" 5 -fi -if test -z "${AMDEP_TRUE}" && test -z "${AMDEP_FALSE}"; then - as_fn_error $? "conditional \"AMDEP\" was never defined. -Usually this means the macro was only invoked conditionally." "$LINENO" 5 -fi -if test -z "${am__fastdepCC_TRUE}" && test -z "${am__fastdepCC_FALSE}"; then - as_fn_error $? "conditional \"am__fastdepCC\" was never defined. -Usually this means the macro was only invoked conditionally." "$LINENO" 5 -fi -if test -z "${am__fastdepCXX_TRUE}" && test -z "${am__fastdepCXX_FALSE}"; then - as_fn_error $? "conditional \"am__fastdepCXX\" was never defined. -Usually this means the macro was only invoked conditionally." "$LINENO" 5 -fi -if test -z "${am__fastdepCCAS_TRUE}" && test -z "${am__fastdepCCAS_FALSE}"; then - as_fn_error $? "conditional \"am__fastdepCCAS\" was never defined. -Usually this means the macro was only invoked conditionally." "$LINENO" 5 -fi -if test -z "${THREADS_TRUE}" && test -z "${THREADS_FALSE}"; then - as_fn_error $? "conditional \"THREADS\" was never defined. -Usually this means the macro was only invoked conditionally." "$LINENO" 5 -fi -if test -z "${PTHREADS_TRUE}" && test -z "${PTHREADS_FALSE}"; then - as_fn_error $? "conditional \"PTHREADS\" was never defined. -Usually this means the macro was only invoked conditionally." "$LINENO" 5 -fi -if test -z "${DARWIN_THREADS_TRUE}" && test -z "${DARWIN_THREADS_FALSE}"; then - as_fn_error $? "conditional \"DARWIN_THREADS\" was never defined. -Usually this means the macro was only invoked conditionally." "$LINENO" 5 -fi -if test -z "${WIN32_THREADS_TRUE}" && test -z "${WIN32_THREADS_FALSE}"; then - as_fn_error $? "conditional \"WIN32_THREADS\" was never defined. -Usually this means the macro was only invoked conditionally." "$LINENO" 5 -fi -if test -z "${ASM_WITH_CPP_UNSUPPORTED_TRUE}" && test -z "${ASM_WITH_CPP_UNSUPPORTED_FALSE}"; then - as_fn_error $? "conditional \"ASM_WITH_CPP_UNSUPPORTED\" was never defined. -Usually this means the macro was only invoked conditionally." "$LINENO" 5 -fi -if test -z "${AVOID_CPP_LIB_TRUE}" && test -z "${AVOID_CPP_LIB_FALSE}"; then - as_fn_error $? "conditional \"AVOID_CPP_LIB\" was never defined. -Usually this means the macro was only invoked conditionally." "$LINENO" 5 -fi -if test -z "${CPLUSPLUS_TRUE}" && test -z "${CPLUSPLUS_FALSE}"; then - as_fn_error $? "conditional \"CPLUSPLUS\" was never defined. -Usually this means the macro was only invoked conditionally." "$LINENO" 5 -fi -if test -z "${MAKE_BACK_GRAPH_TRUE}" && test -z "${MAKE_BACK_GRAPH_FALSE}"; then - as_fn_error $? "conditional \"MAKE_BACK_GRAPH\" was never defined. -Usually this means the macro was only invoked conditionally." "$LINENO" 5 -fi -if test -z "${KEEP_BACK_PTRS_TRUE}" && test -z "${KEEP_BACK_PTRS_FALSE}"; then - as_fn_error $? "conditional \"KEEP_BACK_PTRS\" was never defined. -Usually this means the macro was only invoked conditionally." "$LINENO" 5 -fi -if test -z "${ENABLE_DISCLAIM_TRUE}" && test -z "${ENABLE_DISCLAIM_FALSE}"; then - as_fn_error $? "conditional \"ENABLE_DISCLAIM\" was never defined. -Usually this means the macro was only invoked conditionally." "$LINENO" 5 -fi -if test -z "${USE_LIBDIR_TRUE}" && test -z "${USE_LIBDIR_FALSE}"; then - as_fn_error $? "conditional \"USE_LIBDIR\" was never defined. -Usually this means the macro was only invoked conditionally." "$LINENO" 5 -fi -if test -z "${SINGLE_GC_OBJ_TRUE}" && test -z "${SINGLE_GC_OBJ_FALSE}"; then - as_fn_error $? "conditional \"SINGLE_GC_OBJ\" was never defined. -Usually this means the macro was only invoked conditionally." "$LINENO" 5 -fi -if test -z "${USE_INTERNAL_LIBATOMIC_OPS_TRUE}" && test -z "${USE_INTERNAL_LIBATOMIC_OPS_FALSE}"; then - as_fn_error $? "conditional \"USE_INTERNAL_LIBATOMIC_OPS\" was never defined. -Usually this means the macro was only invoked conditionally." "$LINENO" 5 -fi -if test -z "${NEED_ATOMIC_OPS_ASM_TRUE}" && test -z "${NEED_ATOMIC_OPS_ASM_FALSE}"; then - as_fn_error $? "conditional \"NEED_ATOMIC_OPS_ASM\" was never defined. -Usually this means the macro was only invoked conditionally." "$LINENO" 5 -fi - -: "${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. -as_myself= -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 STATUS 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=$1; test $as_status -eq 0 && as_status=1 - if test "$4"; then - as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 - fi - $as_echo "$as_me: error: $2" >&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 -pR'. - ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || - as_ln_s='cp -pR' - elif ln conf$$.file conf$$ 2>/dev/null; then - as_ln_s=ln - else - as_ln_s='cp -pR' - fi -else - as_ln_s='cp -pR' -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 - - -# as_fn_executable_p FILE -# ----------------------- -# Test if FILE is an executable regular file. -as_fn_executable_p () -{ - test -f "$1" && test -x "$1" -} # as_fn_executable_p -as_test_x='test -x' -as_executable_p=as_fn_executable_p - -# 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 gc $as_me 7.5.0, which was -generated by GNU Autoconf 2.69. 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 - --config print configuration, 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 ." - -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" -ac_cs_version="\\ -gc config.status 7.5.0 -configured by $0, generated by GNU Autoconf 2.69, - with options \\"\$ac_cs_config\\" - -Copyright (C) 2012 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' -MKDIR_P='$MKDIR_P' -AWK='$AWK' -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=`expr "X$1" : 'X\([^=]*\)='` - ac_optarg= - 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 ;; - --config | --confi | --conf | --con | --co | --c ) - $as_echo "$ac_cs_config"; 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"` ;; - '') as_fn_error $? "missing file argument" ;; - 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 -# -AMDEP_TRUE="$AMDEP_TRUE" ac_aux_dir="$ac_aux_dir" - - -# 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 "$macro_version" | $SED "$delay_single_quote_subst"`' -macro_revision='`$ECHO "$macro_revision" | $SED "$delay_single_quote_subst"`' -enable_shared='`$ECHO "$enable_shared" | $SED "$delay_single_quote_subst"`' -enable_static='`$ECHO "$enable_static" | $SED "$delay_single_quote_subst"`' -pic_mode='`$ECHO "$pic_mode" | $SED "$delay_single_quote_subst"`' -enable_fast_install='`$ECHO "$enable_fast_install" | $SED "$delay_single_quote_subst"`' -shared_archive_member_spec='`$ECHO "$shared_archive_member_spec" | $SED "$delay_single_quote_subst"`' -SHELL='`$ECHO "$SHELL" | $SED "$delay_single_quote_subst"`' -ECHO='`$ECHO "$ECHO" | $SED "$delay_single_quote_subst"`' -PATH_SEPARATOR='`$ECHO "$PATH_SEPARATOR" | $SED "$delay_single_quote_subst"`' -host_alias='`$ECHO "$host_alias" | $SED "$delay_single_quote_subst"`' -host='`$ECHO "$host" | $SED "$delay_single_quote_subst"`' -host_os='`$ECHO "$host_os" | $SED "$delay_single_quote_subst"`' -build_alias='`$ECHO "$build_alias" | $SED "$delay_single_quote_subst"`' -build='`$ECHO "$build" | $SED "$delay_single_quote_subst"`' -build_os='`$ECHO "$build_os" | $SED "$delay_single_quote_subst"`' -SED='`$ECHO "$SED" | $SED "$delay_single_quote_subst"`' -Xsed='`$ECHO "$Xsed" | $SED "$delay_single_quote_subst"`' -GREP='`$ECHO "$GREP" | $SED "$delay_single_quote_subst"`' -EGREP='`$ECHO "$EGREP" | $SED "$delay_single_quote_subst"`' -FGREP='`$ECHO "$FGREP" | $SED "$delay_single_quote_subst"`' -LD='`$ECHO "$LD" | $SED "$delay_single_quote_subst"`' -NM='`$ECHO "$NM" | $SED "$delay_single_quote_subst"`' -LN_S='`$ECHO "$LN_S" | $SED "$delay_single_quote_subst"`' -max_cmd_len='`$ECHO "$max_cmd_len" | $SED "$delay_single_quote_subst"`' -ac_objext='`$ECHO "$ac_objext" | $SED "$delay_single_quote_subst"`' -exeext='`$ECHO "$exeext" | $SED "$delay_single_quote_subst"`' -lt_unset='`$ECHO "$lt_unset" | $SED "$delay_single_quote_subst"`' -lt_SP2NL='`$ECHO "$lt_SP2NL" | $SED "$delay_single_quote_subst"`' -lt_NL2SP='`$ECHO "$lt_NL2SP" | $SED "$delay_single_quote_subst"`' -lt_cv_to_host_file_cmd='`$ECHO "$lt_cv_to_host_file_cmd" | $SED "$delay_single_quote_subst"`' -lt_cv_to_tool_file_cmd='`$ECHO "$lt_cv_to_tool_file_cmd" | $SED "$delay_single_quote_subst"`' -reload_flag='`$ECHO "$reload_flag" | $SED "$delay_single_quote_subst"`' -reload_cmds='`$ECHO "$reload_cmds" | $SED "$delay_single_quote_subst"`' -OBJDUMP='`$ECHO "$OBJDUMP" | $SED "$delay_single_quote_subst"`' -deplibs_check_method='`$ECHO "$deplibs_check_method" | $SED "$delay_single_quote_subst"`' -file_magic_cmd='`$ECHO "$file_magic_cmd" | $SED "$delay_single_quote_subst"`' -file_magic_glob='`$ECHO "$file_magic_glob" | $SED "$delay_single_quote_subst"`' -want_nocaseglob='`$ECHO "$want_nocaseglob" | $SED "$delay_single_quote_subst"`' -DLLTOOL='`$ECHO "$DLLTOOL" | $SED "$delay_single_quote_subst"`' -sharedlib_from_linklib_cmd='`$ECHO "$sharedlib_from_linklib_cmd" | $SED "$delay_single_quote_subst"`' -AR='`$ECHO "$AR" | $SED "$delay_single_quote_subst"`' -AR_FLAGS='`$ECHO "$AR_FLAGS" | $SED "$delay_single_quote_subst"`' -archiver_list_spec='`$ECHO "$archiver_list_spec" | $SED "$delay_single_quote_subst"`' -STRIP='`$ECHO "$STRIP" | $SED "$delay_single_quote_subst"`' -RANLIB='`$ECHO "$RANLIB" | $SED "$delay_single_quote_subst"`' -old_postinstall_cmds='`$ECHO "$old_postinstall_cmds" | $SED "$delay_single_quote_subst"`' -old_postuninstall_cmds='`$ECHO "$old_postuninstall_cmds" | $SED "$delay_single_quote_subst"`' -old_archive_cmds='`$ECHO "$old_archive_cmds" | $SED "$delay_single_quote_subst"`' -lock_old_archive_extraction='`$ECHO "$lock_old_archive_extraction" | $SED "$delay_single_quote_subst"`' -CC='`$ECHO "$CC" | $SED "$delay_single_quote_subst"`' -CFLAGS='`$ECHO "$CFLAGS" | $SED "$delay_single_quote_subst"`' -compiler='`$ECHO "$compiler" | $SED "$delay_single_quote_subst"`' -GCC='`$ECHO "$GCC" | $SED "$delay_single_quote_subst"`' -lt_cv_sys_global_symbol_pipe='`$ECHO "$lt_cv_sys_global_symbol_pipe" | $SED "$delay_single_quote_subst"`' -lt_cv_sys_global_symbol_to_cdecl='`$ECHO "$lt_cv_sys_global_symbol_to_cdecl" | $SED "$delay_single_quote_subst"`' -lt_cv_sys_global_symbol_to_import='`$ECHO "$lt_cv_sys_global_symbol_to_import" | $SED "$delay_single_quote_subst"`' -lt_cv_sys_global_symbol_to_c_name_address='`$ECHO "$lt_cv_sys_global_symbol_to_c_name_address" | $SED "$delay_single_quote_subst"`' -lt_cv_sys_global_symbol_to_c_name_address_lib_prefix='`$ECHO "$lt_cv_sys_global_symbol_to_c_name_address_lib_prefix" | $SED "$delay_single_quote_subst"`' -lt_cv_nm_interface='`$ECHO "$lt_cv_nm_interface" | $SED "$delay_single_quote_subst"`' -nm_file_list_spec='`$ECHO "$nm_file_list_spec" | $SED "$delay_single_quote_subst"`' -lt_sysroot='`$ECHO "$lt_sysroot" | $SED "$delay_single_quote_subst"`' -lt_cv_truncate_bin='`$ECHO "$lt_cv_truncate_bin" | $SED "$delay_single_quote_subst"`' -objdir='`$ECHO "$objdir" | $SED "$delay_single_quote_subst"`' -MAGIC_CMD='`$ECHO "$MAGIC_CMD" | $SED "$delay_single_quote_subst"`' -lt_prog_compiler_no_builtin_flag='`$ECHO "$lt_prog_compiler_no_builtin_flag" | $SED "$delay_single_quote_subst"`' -lt_prog_compiler_pic='`$ECHO "$lt_prog_compiler_pic" | $SED "$delay_single_quote_subst"`' -lt_prog_compiler_wl='`$ECHO "$lt_prog_compiler_wl" | $SED "$delay_single_quote_subst"`' -lt_prog_compiler_static='`$ECHO "$lt_prog_compiler_static" | $SED "$delay_single_quote_subst"`' -lt_cv_prog_compiler_c_o='`$ECHO "$lt_cv_prog_compiler_c_o" | $SED "$delay_single_quote_subst"`' -need_locks='`$ECHO "$need_locks" | $SED "$delay_single_quote_subst"`' -MANIFEST_TOOL='`$ECHO "$MANIFEST_TOOL" | $SED "$delay_single_quote_subst"`' -DSYMUTIL='`$ECHO "$DSYMUTIL" | $SED "$delay_single_quote_subst"`' -NMEDIT='`$ECHO "$NMEDIT" | $SED "$delay_single_quote_subst"`' -LIPO='`$ECHO "$LIPO" | $SED "$delay_single_quote_subst"`' -OTOOL='`$ECHO "$OTOOL" | $SED "$delay_single_quote_subst"`' -OTOOL64='`$ECHO "$OTOOL64" | $SED "$delay_single_quote_subst"`' -libext='`$ECHO "$libext" | $SED "$delay_single_quote_subst"`' -shrext_cmds='`$ECHO "$shrext_cmds" | $SED "$delay_single_quote_subst"`' -extract_expsyms_cmds='`$ECHO "$extract_expsyms_cmds" | $SED "$delay_single_quote_subst"`' -archive_cmds_need_lc='`$ECHO "$archive_cmds_need_lc" | $SED "$delay_single_quote_subst"`' -enable_shared_with_static_runtimes='`$ECHO "$enable_shared_with_static_runtimes" | $SED "$delay_single_quote_subst"`' -export_dynamic_flag_spec='`$ECHO "$export_dynamic_flag_spec" | $SED "$delay_single_quote_subst"`' -whole_archive_flag_spec='`$ECHO "$whole_archive_flag_spec" | $SED "$delay_single_quote_subst"`' -compiler_needs_object='`$ECHO "$compiler_needs_object" | $SED "$delay_single_quote_subst"`' -old_archive_from_new_cmds='`$ECHO "$old_archive_from_new_cmds" | $SED "$delay_single_quote_subst"`' -old_archive_from_expsyms_cmds='`$ECHO "$old_archive_from_expsyms_cmds" | $SED "$delay_single_quote_subst"`' -archive_cmds='`$ECHO "$archive_cmds" | $SED "$delay_single_quote_subst"`' -archive_expsym_cmds='`$ECHO "$archive_expsym_cmds" | $SED "$delay_single_quote_subst"`' -module_cmds='`$ECHO "$module_cmds" | $SED "$delay_single_quote_subst"`' -module_expsym_cmds='`$ECHO "$module_expsym_cmds" | $SED "$delay_single_quote_subst"`' -with_gnu_ld='`$ECHO "$with_gnu_ld" | $SED "$delay_single_quote_subst"`' -allow_undefined_flag='`$ECHO "$allow_undefined_flag" | $SED "$delay_single_quote_subst"`' -no_undefined_flag='`$ECHO "$no_undefined_flag" | $SED "$delay_single_quote_subst"`' -hardcode_libdir_flag_spec='`$ECHO "$hardcode_libdir_flag_spec" | $SED "$delay_single_quote_subst"`' -hardcode_libdir_separator='`$ECHO "$hardcode_libdir_separator" | $SED "$delay_single_quote_subst"`' -hardcode_direct='`$ECHO "$hardcode_direct" | $SED "$delay_single_quote_subst"`' -hardcode_direct_absolute='`$ECHO "$hardcode_direct_absolute" | $SED "$delay_single_quote_subst"`' -hardcode_minus_L='`$ECHO "$hardcode_minus_L" | $SED "$delay_single_quote_subst"`' -hardcode_shlibpath_var='`$ECHO "$hardcode_shlibpath_var" | $SED "$delay_single_quote_subst"`' -hardcode_automatic='`$ECHO "$hardcode_automatic" | $SED "$delay_single_quote_subst"`' -inherit_rpath='`$ECHO "$inherit_rpath" | $SED "$delay_single_quote_subst"`' -link_all_deplibs='`$ECHO "$link_all_deplibs" | $SED "$delay_single_quote_subst"`' -always_export_symbols='`$ECHO "$always_export_symbols" | $SED "$delay_single_quote_subst"`' -export_symbols_cmds='`$ECHO "$export_symbols_cmds" | $SED "$delay_single_quote_subst"`' -exclude_expsyms='`$ECHO "$exclude_expsyms" | $SED "$delay_single_quote_subst"`' -include_expsyms='`$ECHO "$include_expsyms" | $SED "$delay_single_quote_subst"`' -prelink_cmds='`$ECHO "$prelink_cmds" | $SED "$delay_single_quote_subst"`' -postlink_cmds='`$ECHO "$postlink_cmds" | $SED "$delay_single_quote_subst"`' -file_list_spec='`$ECHO "$file_list_spec" | $SED "$delay_single_quote_subst"`' -variables_saved_for_relink='`$ECHO "$variables_saved_for_relink" | $SED "$delay_single_quote_subst"`' -need_lib_prefix='`$ECHO "$need_lib_prefix" | $SED "$delay_single_quote_subst"`' -need_version='`$ECHO "$need_version" | $SED "$delay_single_quote_subst"`' -version_type='`$ECHO "$version_type" | $SED "$delay_single_quote_subst"`' -runpath_var='`$ECHO "$runpath_var" | $SED "$delay_single_quote_subst"`' -shlibpath_var='`$ECHO "$shlibpath_var" | $SED "$delay_single_quote_subst"`' -shlibpath_overrides_runpath='`$ECHO "$shlibpath_overrides_runpath" | $SED "$delay_single_quote_subst"`' -libname_spec='`$ECHO "$libname_spec" | $SED "$delay_single_quote_subst"`' -library_names_spec='`$ECHO "$library_names_spec" | $SED "$delay_single_quote_subst"`' -soname_spec='`$ECHO "$soname_spec" | $SED "$delay_single_quote_subst"`' -install_override_mode='`$ECHO "$install_override_mode" | $SED "$delay_single_quote_subst"`' -postinstall_cmds='`$ECHO "$postinstall_cmds" | $SED "$delay_single_quote_subst"`' -postuninstall_cmds='`$ECHO "$postuninstall_cmds" | $SED "$delay_single_quote_subst"`' -finish_cmds='`$ECHO "$finish_cmds" | $SED "$delay_single_quote_subst"`' -finish_eval='`$ECHO "$finish_eval" | $SED "$delay_single_quote_subst"`' -hardcode_into_libs='`$ECHO "$hardcode_into_libs" | $SED "$delay_single_quote_subst"`' -sys_lib_search_path_spec='`$ECHO "$sys_lib_search_path_spec" | $SED "$delay_single_quote_subst"`' -configure_time_dlsearch_path='`$ECHO "$configure_time_dlsearch_path" | $SED "$delay_single_quote_subst"`' -configure_time_lt_sys_library_path='`$ECHO "$configure_time_lt_sys_library_path" | $SED "$delay_single_quote_subst"`' -hardcode_action='`$ECHO "$hardcode_action" | $SED "$delay_single_quote_subst"`' -enable_dlopen='`$ECHO "$enable_dlopen" | $SED "$delay_single_quote_subst"`' -enable_dlopen_self='`$ECHO "$enable_dlopen_self" | $SED "$delay_single_quote_subst"`' -enable_dlopen_self_static='`$ECHO "$enable_dlopen_self_static" | $SED "$delay_single_quote_subst"`' -old_striplib='`$ECHO "$old_striplib" | $SED "$delay_single_quote_subst"`' -striplib='`$ECHO "$striplib" | $SED "$delay_single_quote_subst"`' -compiler_lib_search_dirs='`$ECHO "$compiler_lib_search_dirs" | $SED "$delay_single_quote_subst"`' -predep_objects='`$ECHO "$predep_objects" | $SED "$delay_single_quote_subst"`' -postdep_objects='`$ECHO "$postdep_objects" | $SED "$delay_single_quote_subst"`' -predeps='`$ECHO "$predeps" | $SED "$delay_single_quote_subst"`' -postdeps='`$ECHO "$postdeps" | $SED "$delay_single_quote_subst"`' -compiler_lib_search_path='`$ECHO "$compiler_lib_search_path" | $SED "$delay_single_quote_subst"`' -LD_CXX='`$ECHO "$LD_CXX" | $SED "$delay_single_quote_subst"`' -reload_flag_CXX='`$ECHO "$reload_flag_CXX" | $SED "$delay_single_quote_subst"`' -reload_cmds_CXX='`$ECHO "$reload_cmds_CXX" | $SED "$delay_single_quote_subst"`' -old_archive_cmds_CXX='`$ECHO "$old_archive_cmds_CXX" | $SED "$delay_single_quote_subst"`' -compiler_CXX='`$ECHO "$compiler_CXX" | $SED "$delay_single_quote_subst"`' -GCC_CXX='`$ECHO "$GCC_CXX" | $SED "$delay_single_quote_subst"`' -lt_prog_compiler_no_builtin_flag_CXX='`$ECHO "$lt_prog_compiler_no_builtin_flag_CXX" | $SED "$delay_single_quote_subst"`' -lt_prog_compiler_pic_CXX='`$ECHO "$lt_prog_compiler_pic_CXX" | $SED "$delay_single_quote_subst"`' -lt_prog_compiler_wl_CXX='`$ECHO "$lt_prog_compiler_wl_CXX" | $SED "$delay_single_quote_subst"`' -lt_prog_compiler_static_CXX='`$ECHO "$lt_prog_compiler_static_CXX" | $SED "$delay_single_quote_subst"`' -lt_cv_prog_compiler_c_o_CXX='`$ECHO "$lt_cv_prog_compiler_c_o_CXX" | $SED "$delay_single_quote_subst"`' -archive_cmds_need_lc_CXX='`$ECHO "$archive_cmds_need_lc_CXX" | $SED "$delay_single_quote_subst"`' -enable_shared_with_static_runtimes_CXX='`$ECHO "$enable_shared_with_static_runtimes_CXX" | $SED "$delay_single_quote_subst"`' -export_dynamic_flag_spec_CXX='`$ECHO "$export_dynamic_flag_spec_CXX" | $SED "$delay_single_quote_subst"`' -whole_archive_flag_spec_CXX='`$ECHO "$whole_archive_flag_spec_CXX" | $SED "$delay_single_quote_subst"`' -compiler_needs_object_CXX='`$ECHO "$compiler_needs_object_CXX" | $SED "$delay_single_quote_subst"`' -old_archive_from_new_cmds_CXX='`$ECHO "$old_archive_from_new_cmds_CXX" | $SED "$delay_single_quote_subst"`' -old_archive_from_expsyms_cmds_CXX='`$ECHO "$old_archive_from_expsyms_cmds_CXX" | $SED "$delay_single_quote_subst"`' -archive_cmds_CXX='`$ECHO "$archive_cmds_CXX" | $SED "$delay_single_quote_subst"`' -archive_expsym_cmds_CXX='`$ECHO "$archive_expsym_cmds_CXX" | $SED "$delay_single_quote_subst"`' -module_cmds_CXX='`$ECHO "$module_cmds_CXX" | $SED "$delay_single_quote_subst"`' -module_expsym_cmds_CXX='`$ECHO "$module_expsym_cmds_CXX" | $SED "$delay_single_quote_subst"`' -with_gnu_ld_CXX='`$ECHO "$with_gnu_ld_CXX" | $SED "$delay_single_quote_subst"`' -allow_undefined_flag_CXX='`$ECHO "$allow_undefined_flag_CXX" | $SED "$delay_single_quote_subst"`' -no_undefined_flag_CXX='`$ECHO "$no_undefined_flag_CXX" | $SED "$delay_single_quote_subst"`' -hardcode_libdir_flag_spec_CXX='`$ECHO "$hardcode_libdir_flag_spec_CXX" | $SED "$delay_single_quote_subst"`' -hardcode_libdir_separator_CXX='`$ECHO "$hardcode_libdir_separator_CXX" | $SED "$delay_single_quote_subst"`' -hardcode_direct_CXX='`$ECHO "$hardcode_direct_CXX" | $SED "$delay_single_quote_subst"`' -hardcode_direct_absolute_CXX='`$ECHO "$hardcode_direct_absolute_CXX" | $SED "$delay_single_quote_subst"`' -hardcode_minus_L_CXX='`$ECHO "$hardcode_minus_L_CXX" | $SED "$delay_single_quote_subst"`' -hardcode_shlibpath_var_CXX='`$ECHO "$hardcode_shlibpath_var_CXX" | $SED "$delay_single_quote_subst"`' -hardcode_automatic_CXX='`$ECHO "$hardcode_automatic_CXX" | $SED "$delay_single_quote_subst"`' -inherit_rpath_CXX='`$ECHO "$inherit_rpath_CXX" | $SED "$delay_single_quote_subst"`' -link_all_deplibs_CXX='`$ECHO "$link_all_deplibs_CXX" | $SED "$delay_single_quote_subst"`' -always_export_symbols_CXX='`$ECHO "$always_export_symbols_CXX" | $SED "$delay_single_quote_subst"`' -export_symbols_cmds_CXX='`$ECHO "$export_symbols_cmds_CXX" | $SED "$delay_single_quote_subst"`' -exclude_expsyms_CXX='`$ECHO "$exclude_expsyms_CXX" | $SED "$delay_single_quote_subst"`' -include_expsyms_CXX='`$ECHO "$include_expsyms_CXX" | $SED "$delay_single_quote_subst"`' -prelink_cmds_CXX='`$ECHO "$prelink_cmds_CXX" | $SED "$delay_single_quote_subst"`' -postlink_cmds_CXX='`$ECHO "$postlink_cmds_CXX" | $SED "$delay_single_quote_subst"`' -file_list_spec_CXX='`$ECHO "$file_list_spec_CXX" | $SED "$delay_single_quote_subst"`' -hardcode_action_CXX='`$ECHO "$hardcode_action_CXX" | $SED "$delay_single_quote_subst"`' -compiler_lib_search_dirs_CXX='`$ECHO "$compiler_lib_search_dirs_CXX" | $SED "$delay_single_quote_subst"`' -predep_objects_CXX='`$ECHO "$predep_objects_CXX" | $SED "$delay_single_quote_subst"`' -postdep_objects_CXX='`$ECHO "$postdep_objects_CXX" | $SED "$delay_single_quote_subst"`' -predeps_CXX='`$ECHO "$predeps_CXX" | $SED "$delay_single_quote_subst"`' -postdeps_CXX='`$ECHO "$postdeps_CXX" | $SED "$delay_single_quote_subst"`' -compiler_lib_search_path_CXX='`$ECHO "$compiler_lib_search_path_CXX" | $SED "$delay_single_quote_subst"`' - -LTCC='$LTCC' -LTCFLAGS='$LTCFLAGS' -compiler='$compiler_DEFAULT' - -# A function that is used when there is no print builtin or printf. -func_fallback_echo () -{ - eval 'cat <<_LTECHO_EOF -\$1 -_LTECHO_EOF' -} - -# Quote evaled strings. -for var in SHELL \ -ECHO \ -PATH_SEPARATOR \ -SED \ -GREP \ -EGREP \ -FGREP \ -LD \ -NM \ -LN_S \ -lt_SP2NL \ -lt_NL2SP \ -reload_flag \ -OBJDUMP \ -deplibs_check_method \ -file_magic_cmd \ -file_magic_glob \ -want_nocaseglob \ -DLLTOOL \ -sharedlib_from_linklib_cmd \ -AR \ -AR_FLAGS \ -archiver_list_spec \ -STRIP \ -RANLIB \ -CC \ -CFLAGS \ -compiler \ -lt_cv_sys_global_symbol_pipe \ -lt_cv_sys_global_symbol_to_cdecl \ -lt_cv_sys_global_symbol_to_import \ -lt_cv_sys_global_symbol_to_c_name_address \ -lt_cv_sys_global_symbol_to_c_name_address_lib_prefix \ -lt_cv_nm_interface \ -nm_file_list_spec \ -lt_cv_truncate_bin \ -lt_prog_compiler_no_builtin_flag \ -lt_prog_compiler_pic \ -lt_prog_compiler_wl \ -lt_prog_compiler_static \ -lt_cv_prog_compiler_c_o \ -need_locks \ -MANIFEST_TOOL \ -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_separator \ -exclude_expsyms \ -include_expsyms \ -file_list_spec \ -variables_saved_for_relink \ -libname_spec \ -library_names_spec \ -soname_spec \ -install_override_mode \ -finish_eval \ -old_striplib \ -striplib \ -compiler_lib_search_dirs \ -predep_objects \ -postdep_objects \ -predeps \ -postdeps \ -compiler_lib_search_path \ -LD_CXX \ -reload_flag_CXX \ -compiler_CXX \ -lt_prog_compiler_no_builtin_flag_CXX \ -lt_prog_compiler_pic_CXX \ -lt_prog_compiler_wl_CXX \ -lt_prog_compiler_static_CXX \ -lt_cv_prog_compiler_c_o_CXX \ -export_dynamic_flag_spec_CXX \ -whole_archive_flag_spec_CXX \ -compiler_needs_object_CXX \ -with_gnu_ld_CXX \ -allow_undefined_flag_CXX \ -no_undefined_flag_CXX \ -hardcode_libdir_flag_spec_CXX \ -hardcode_libdir_separator_CXX \ -exclude_expsyms_CXX \ -include_expsyms_CXX \ -file_list_spec_CXX \ -compiler_lib_search_dirs_CXX \ -predep_objects_CXX \ -postdep_objects_CXX \ -predeps_CXX \ -postdeps_CXX \ -compiler_lib_search_path_CXX; do - case \`eval \\\\\$ECHO \\\\""\\\\\$\$var"\\\\"\` in - *[\\\\\\\`\\"\\\$]*) - eval "lt_\$var=\\\\\\"\\\`\\\$ECHO \\"\\\$\$var\\" | \\\$SED \\"\\\$sed_quote_subst\\"\\\`\\\\\\"" ## exclude from sc_prohibit_nested_quotes - ;; - *) - 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 \ -postlink_cmds \ -postinstall_cmds \ -postuninstall_cmds \ -finish_cmds \ -sys_lib_search_path_spec \ -configure_time_dlsearch_path \ -configure_time_lt_sys_library_path \ -reload_cmds_CXX \ -old_archive_cmds_CXX \ -old_archive_from_new_cmds_CXX \ -old_archive_from_expsyms_cmds_CXX \ -archive_cmds_CXX \ -archive_expsym_cmds_CXX \ -module_cmds_CXX \ -module_expsym_cmds_CXX \ -export_symbols_cmds_CXX \ -prelink_cmds_CXX \ -postlink_cmds_CXX; do - case \`eval \\\\\$ECHO \\\\""\\\\\$\$var"\\\\"\` in - *[\\\\\\\`\\"\\\$]*) - eval "lt_\$var=\\\\\\"\\\`\\\$ECHO \\"\\\$\$var\\" | \\\$SED -e \\"\\\$double_quote_subst\\" -e \\"\\\$sed_quote_subst\\" -e \\"\\\$delay_variable_subst\\"\\\`\\\\\\"" ## exclude from sc_prohibit_nested_quotes - ;; - *) - eval "lt_\$var=\\\\\\"\\\$\$var\\\\\\"" - ;; - esac -done - -ac_aux_dir='$ac_aux_dir' - -# See if we are running on zsh, and set the options that 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' - RM='$RM' - ofile='$ofile' - - - - - - srcdir="${srcdir}" - host=${host} - CONFIG_SHELL=${CONFIG_SHELL-/bin/sh} - CC="${CC}" - DEFS="$DEFS" - -_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 - "include/config.h") CONFIG_HEADERS="$CONFIG_HEADERS include/config.h" ;; - "depfiles") CONFIG_COMMANDS="$CONFIG_COMMANDS depfiles" ;; - "libtool") CONFIG_COMMANDS="$CONFIG_COMMANDS libtool" ;; - "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; - "bdw-gc.pc") CONFIG_FILES="$CONFIG_FILES bdw-gc.pc" ;; - "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= ac_tmp= - trap 'exit_status=$? - : "${ac_tmp:=$tmp}" - { test ! -d "$ac_tmp" || rm -fr "$ac_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 -d "$tmp" -} || -{ - tmp=./conf$$-$RANDOM - (umask 077 && mkdir "$tmp") -} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 -ac_tmp=$tmp - -# 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 {' >"$ac_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 >>"\$ac_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 >>"\$ac_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 < "$ac_tmp/subs1.awk" > "$ac_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 sole $(srcdir), -# ${srcdir} and @srcdir@ entries 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[ ]*=[ ]*/{ -h -s/// -s/^/:/ -s/[ ]*$/:/ -s/:\$(srcdir):/:/g -s/:\${srcdir}:/:/g -s/:@srcdir@:/:/g -s/^:*// -s/:*$// -x -s/\(=[ ]*\).*/\1/ -G -s/\n// -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 >"$ac_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_tt=`sed -n "/$ac_delim/p" confdefs.h` - if test -z "$ac_tt"; 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="$ac_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 1 "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 >"$ac_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 - ac_MKDIR_P=$MKDIR_P - case $MKDIR_P in - [\\/$]* | ?:[\\/]* ) ;; - */*) ac_MKDIR_P=$ac_top_build_prefix$MKDIR_P ;; - 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 -s&@MKDIR_P@&$ac_MKDIR_P&;t t -$ac_datarootdir_hack -" -eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ - >$ac_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' "$ac_tmp/out"`; test -n "$ac_out"; } && - { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ - "$ac_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 "$ac_tmp/stdin" - case $ac_file in - -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; - *) rm -f "$ac_file" && mv "$ac_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 "$ac_tmp/defines.awk"' "$ac_file_inputs" - } >"$ac_tmp/config.h" \ - || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - if diff "$ac_file" "$ac_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 "$ac_tmp/config.h" "$ac_file" \ - || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - fi - else - $as_echo "/* $configure_input */" \ - && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" \ - || as_fn_error $? "could not create -" "$LINENO" 5 - fi -# Compute "$ac_file"'s index in $config_headers. -_am_arg="$ac_file" -_am_stamp_count=1 -for _am_header in $config_headers :; do - case $_am_header in - $_am_arg | $_am_arg:* ) - break ;; - * ) - _am_stamp_count=`expr $_am_stamp_count + 1` ;; - esac -done -echo "timestamp for $_am_arg" >`$as_dirname -- "$_am_arg" || -$as_expr X"$_am_arg" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$_am_arg" : 'X\(//\)[^/]' \| \ - X"$_am_arg" : 'X\(//\)$' \| \ - X"$_am_arg" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$_am_arg" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'`/stamp-h$_am_stamp_count - ;; - - :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 - "depfiles":C) test x"$AMDEP_TRUE" != x"" || { - # Older Autoconf quotes --file arguments for eval, but not when files - # are listed without --file. Let's play safe and only enable the eval - # if we detect the quoting. - case $CONFIG_FILES in - *\'*) eval set x "$CONFIG_FILES" ;; - *) set x $CONFIG_FILES ;; - esac - shift - for mf - do - # Strip MF so we end up with the name of the file. - mf=`echo "$mf" | sed -e 's/:.*$//'` - # Check whether this is an Automake generated Makefile or not. - # We used to match only the files named 'Makefile.in', but - # some people rename them; so instead we look at the file content. - # Grep'ing the first line is not enough: some people post-process - # each Makefile.in and add a new line on top of each file to say so. - # Grep'ing the whole file is not good either: AIX grep has a line - # limit of 2048, but all sed's we know have understand at least 4000. - if sed -n 's,^#.*generated by automake.*,X,p' "$mf" | grep X >/dev/null 2>&1; then - dirpart=`$as_dirname -- "$mf" || -$as_expr X"$mf" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$mf" : 'X\(//\)[^/]' \| \ - X"$mf" : 'X\(//\)$' \| \ - X"$mf" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$mf" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - else - continue - fi - # Extract the definition of DEPDIR, am__include, and am__quote - # from the Makefile without running 'make'. - DEPDIR=`sed -n 's/^DEPDIR = //p' < "$mf"` - test -z "$DEPDIR" && continue - am__include=`sed -n 's/^am__include = //p' < "$mf"` - test -z "$am__include" && continue - am__quote=`sed -n 's/^am__quote = //p' < "$mf"` - # Find all dependency output files, they are included files with - # $(DEPDIR) in their names. We invoke sed twice because it is the - # simplest approach to changing $(DEPDIR) to its actual value in the - # expansion. - for file in `sed -n " - s/^$am__include $am__quote\(.*(DEPDIR).*\)$am__quote"'$/\1/p' <"$mf" | \ - sed -e 's/\$(DEPDIR)/'"$DEPDIR"'/g'`; do - # Make sure the directory exists. - test -f "$dirpart/$file" && continue - fdir=`$as_dirname -- "$file" || -$as_expr X"$file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$file" : 'X\(//\)[^/]' \| \ - X"$file" : 'X\(//\)$' \| \ - X"$file" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$file" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - as_dir=$dirpart/$fdir; as_fn_mkdir_p - # echo "creating $dirpart/$file" - echo '# dummy' > "$dirpart/$file" - done - done -} - ;; - "libtool":C) - - # See if we are running on zsh, and set the options that 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 -# Generated automatically by $as_me ($PACKAGE) $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. - -# Provide generalized library-building support services. -# Written by Gordon Matzigkeit, 1996 - -# Copyright (C) 2014 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 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 this program. If not, see . - - -# The names of the tagged configurations supported by this script. -available_tags='CXX ' - -# Configured defaults for sys_lib_dlsearch_path munging. -: \${LT_SYS_LIBRARY_PATH="$configure_time_lt_sys_library_path"} - -# ### 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 - -# Shared archive member basename,for filename based shared library versioning on AIX. -shared_archive_member_spec=$shared_archive_member_spec - -# Shell to use when invoking shell scripts. -SHELL=$lt_SHELL - -# An echo program that protects backslashes. -ECHO=$lt_ECHO - -# The PATH separator for the build system. -PATH_SEPARATOR=$lt_PATH_SEPARATOR - -# 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 - -# convert \$build file names to \$host format. -to_host_file_cmd=$lt_cv_to_host_file_cmd - -# convert \$build files to toolchain format. -to_tool_file_cmd=$lt_cv_to_tool_file_cmd - -# 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 - -# How to find potential files when deplibs_check_method = "file_magic". -file_magic_glob=$lt_file_magic_glob - -# Find potential files using nocaseglob when deplibs_check_method = "file_magic". -want_nocaseglob=$lt_want_nocaseglob - -# DLL creation program. -DLLTOOL=$lt_DLLTOOL - -# Command to associate shared and link libraries. -sharedlib_from_linklib_cmd=$lt_sharedlib_from_linklib_cmd - -# The archiver. -AR=$lt_AR - -# Flags to create an archive. -AR_FLAGS=$lt_AR_FLAGS - -# How to feed a file listing to the archiver. -archiver_list_spec=$lt_archiver_list_spec - -# 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 - -# Whether to use a lock for old archive extraction. -lock_old_archive_extraction=$lock_old_archive_extraction - -# 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 into a list of symbols to manually relocate. -global_symbol_to_import=$lt_lt_cv_sys_global_symbol_to_import - -# 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 lister interface. -nm_interface=$lt_lt_cv_nm_interface - -# Specify filename containing input files for \$NM. -nm_file_list_spec=$lt_nm_file_list_spec - -# The root where to search for dependent libraries,and where our libraries should be installed. -lt_sysroot=$lt_sysroot - -# Command to truncate a binary pipe. -lt_truncate_bin=$lt_lt_cv_truncate_bin - -# The name of the directory that contains temporary libtool files. -objdir=$objdir - -# 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 - -# Manifest tool. -MANIFEST_TOOL=$lt_MANIFEST_TOOL - -# 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 - -# Permission mode override for installation of shared libraries. -install_override_mode=$lt_install_override_mode - -# 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 - -# Detected run-time system search path for libraries. -sys_lib_dlsearch_path_spec=$lt_configure_time_dlsearch_path - -# Explicit LT_SYS_LIBRARY_PATH set during ./configure time. -configure_time_lt_sys_library_path=$lt_configure_time_lt_sys_library_path - -# 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 - -# How to create reloadable object files. -reload_flag=$lt_reload_flag -reload_cmds=$lt_reload_cmds - -# 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 - -# Additional compiler flags for building library objects. -pic_flag=$lt_lt_prog_compiler_pic - -# How to pass a linker flag through the compiler. -wl=$lt_lt_prog_compiler_wl - -# 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 - -# 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 - -# 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 - -# Commands necessary for finishing linking programs. -postlink_cmds=$lt_postlink_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 - -# The directories searched by this compiler when creating a shared library. -compiler_lib_search_dirs=$lt_compiler_lib_search_dirs - -# Dependencies to place before and after the objects being linked to -# create a shared library. -predep_objects=$lt_predep_objects -postdep_objects=$lt_postdep_objects -predeps=$lt_predeps -postdeps=$lt_postdeps - -# The library search path used internally by the compiler when linking -# a shared library. -compiler_lib_search_path=$lt_compiler_lib_search_path - -# ### END LIBTOOL CONFIG - -_LT_EOF - - cat <<'_LT_EOF' >> "$cfgfile" - -# ### BEGIN FUNCTIONS SHARED WITH CONFIGURE - -# func_munge_path_list VARIABLE PATH -# ----------------------------------- -# VARIABLE is name of variable containing _space_ separated list of -# directories to be munged by the contents of PATH, which is string -# having a format: -# "DIR[:DIR]:" -# string "DIR[ DIR]" will be prepended to VARIABLE -# ":DIR[:DIR]" -# string "DIR[ DIR]" will be appended to VARIABLE -# "DIRP[:DIRP]::[DIRA:]DIRA" -# string "DIRP[ DIRP]" will be prepended to VARIABLE and string -# "DIRA[ DIRA]" will be appended to VARIABLE -# "DIR[:DIR]" -# VARIABLE will be replaced by "DIR[ DIR]" -func_munge_path_list () -{ - case x$2 in - x) - ;; - *:) - eval $1=\"`$ECHO $2 | $SED 's/:/ /g'` \$$1\" - ;; - x:*) - eval $1=\"\$$1 `$ECHO $2 | $SED 's/:/ /g'`\" - ;; - *::*) - eval $1=\"\$$1\ `$ECHO $2 | $SED -e 's/.*:://' -e 's/:/ /g'`\" - eval $1=\"`$ECHO $2 | $SED -e 's/::.*//' -e 's/:/ /g'`\ \$$1\" - ;; - *) - eval $1=\"`$ECHO $2 | $SED 's/:/ /g'`\" - ;; - esac -} - - -# Calculate cc_basename. Skip known compiler wrappers and cross-prefix. -func_cc_basename () -{ - for cc_temp in $*""; do - case $cc_temp in - compile | *[\\/]compile | ccache | *[\\/]ccache ) ;; - distcc | *[\\/]distcc | purify | *[\\/]purify ) ;; - \-*) ;; - *) break;; - esac - done - func_cc_basename_result=`$ECHO "$cc_temp" | $SED "s%.*/%%; s%^$host_alias-%%"` -} - - -# ### END FUNCTIONS SHARED WITH CONFIGURE - -_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 set != "${COLLECT_NAMES+set}"; 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 '$q' "$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" - -# ### BEGIN LIBTOOL TAG CONFIG: CXX - -# The linker used to build libraries. -LD=$lt_LD_CXX - -# How to create reloadable object files. -reload_flag=$lt_reload_flag_CXX -reload_cmds=$lt_reload_cmds_CXX - -# Commands used to build an old-style archive. -old_archive_cmds=$lt_old_archive_cmds_CXX - -# A language specific compiler. -CC=$lt_compiler_CXX - -# Is the compiler the GNU compiler? -with_gcc=$GCC_CXX - -# Compiler flag to turn off builtin functions. -no_builtin_flag=$lt_lt_prog_compiler_no_builtin_flag_CXX - -# Additional compiler flags for building library objects. -pic_flag=$lt_lt_prog_compiler_pic_CXX - -# How to pass a linker flag through the compiler. -wl=$lt_lt_prog_compiler_wl_CXX - -# Compiler flag to prevent dynamic linking. -link_static_flag=$lt_lt_prog_compiler_static_CXX - -# Does compiler simultaneously support -c and -o options? -compiler_c_o=$lt_lt_cv_prog_compiler_c_o_CXX - -# Whether or not to add -lc for building shared libraries. -build_libtool_need_lc=$archive_cmds_need_lc_CXX - -# Whether or not to disallow shared libs when runtime libs are static. -allow_libtool_libs_with_static_runtimes=$enable_shared_with_static_runtimes_CXX - -# Compiler flag to allow reflexive dlopens. -export_dynamic_flag_spec=$lt_export_dynamic_flag_spec_CXX - -# Compiler flag to generate shared objects directly from archives. -whole_archive_flag_spec=$lt_whole_archive_flag_spec_CXX - -# Whether the compiler copes with passing no objects directly. -compiler_needs_object=$lt_compiler_needs_object_CXX - -# Create an old-style archive from a shared archive. -old_archive_from_new_cmds=$lt_old_archive_from_new_cmds_CXX - -# Create a temporary old-style archive to link instead of a shared archive. -old_archive_from_expsyms_cmds=$lt_old_archive_from_expsyms_cmds_CXX - -# Commands used to build a shared archive. -archive_cmds=$lt_archive_cmds_CXX -archive_expsym_cmds=$lt_archive_expsym_cmds_CXX - -# Commands used to build a loadable module if different from building -# a shared archive. -module_cmds=$lt_module_cmds_CXX -module_expsym_cmds=$lt_module_expsym_cmds_CXX - -# Whether we are building with GNU ld or not. -with_gnu_ld=$lt_with_gnu_ld_CXX - -# Flag that allows shared libraries with undefined symbols to be built. -allow_undefined_flag=$lt_allow_undefined_flag_CXX - -# Flag that enforces no undefined symbols. -no_undefined_flag=$lt_no_undefined_flag_CXX - -# 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_CXX - -# Whether we need a single "-rpath" flag with a separated argument. -hardcode_libdir_separator=$lt_hardcode_libdir_separator_CXX - -# Set to "yes" if using DIR/libNAME\$shared_ext during linking hardcodes -# DIR into the resulting binary. -hardcode_direct=$hardcode_direct_CXX - -# 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_CXX - -# Set to "yes" if using the -LDIR flag during linking hardcodes DIR -# into the resulting binary. -hardcode_minus_L=$hardcode_minus_L_CXX - -# Set to "yes" if using SHLIBPATH_VAR=DIR during linking hardcodes DIR -# into the resulting binary. -hardcode_shlibpath_var=$hardcode_shlibpath_var_CXX - -# 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_CXX - -# Set to yes if linker adds runtime paths of dependent libraries -# to runtime path list. -inherit_rpath=$inherit_rpath_CXX - -# Whether libtool must link a program against all its dependency libraries. -link_all_deplibs=$link_all_deplibs_CXX - -# Set to "yes" if exported symbols are required. -always_export_symbols=$always_export_symbols_CXX - -# The commands to list exported symbols. -export_symbols_cmds=$lt_export_symbols_cmds_CXX - -# Symbols that should not be listed in the preloaded symbols. -exclude_expsyms=$lt_exclude_expsyms_CXX - -# Symbols that must always be exported. -include_expsyms=$lt_include_expsyms_CXX - -# Commands necessary for linking programs (against libraries) with templates. -prelink_cmds=$lt_prelink_cmds_CXX - -# Commands necessary for finishing linking programs. -postlink_cmds=$lt_postlink_cmds_CXX - -# Specify filename containing input files. -file_list_spec=$lt_file_list_spec_CXX - -# How to hardcode a shared library path into an executable. -hardcode_action=$hardcode_action_CXX - -# The directories searched by this compiler when creating a shared library. -compiler_lib_search_dirs=$lt_compiler_lib_search_dirs_CXX - -# Dependencies to place before and after the objects being linked to -# create a shared library. -predep_objects=$lt_predep_objects_CXX -postdep_objects=$lt_postdep_objects_CXX -predeps=$lt_predeps_CXX -postdeps=$lt_postdeps_CXX - -# The library search path used internally by the compiler when linking -# a shared library. -compiler_lib_search_path=$lt_compiler_lib_search_path_CXX - -# ### END LIBTOOL TAG CONFIG: CXX -_LT_EOF - - ;; - - 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 1 -fi - -# -# CONFIG_SUBDIRS section. -# -if test "$no_recursion" != yes; then - - # Remove --cache-file, --srcdir, and --disable-option-checking arguments - # so they do not pile up. - ac_sub_configure_args= - ac_prev= - eval "set x $ac_configure_args" - shift - for ac_arg - do - if test -n "$ac_prev"; then - ac_prev= - continue - fi - case $ac_arg in - -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=*) - ;; - --config-cache | -C) - ;; - -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) - ac_prev=srcdir ;; - -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) - ;; - -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) - ac_prev=prefix ;; - -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) - ;; - --disable-option-checking) - ;; - *) - case $ac_arg in - *\'*) ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; - esac - as_fn_append ac_sub_configure_args " '$ac_arg'" ;; - esac - done - - # Always prepend --prefix to ensure using the same prefix - # in subdir configurations. - ac_arg="--prefix=$prefix" - case $ac_arg in - *\'*) ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; - esac - ac_sub_configure_args="'$ac_arg' $ac_sub_configure_args" - - # Pass --silent - if test "$silent" = yes; then - ac_sub_configure_args="--silent $ac_sub_configure_args" - fi - - # Always prepend --disable-option-checking to silence warnings, since - # different subdirs can have different --enable and --with options. - ac_sub_configure_args="--disable-option-checking $ac_sub_configure_args" - - ac_popdir=`pwd` - for ac_dir in : $subdirs; do test "x$ac_dir" = x: && continue - - # Do not complain, so a configure script can configure whichever - # parts of a large source tree are present. - test -d "$srcdir/$ac_dir" || continue - - ac_msg="=== configuring in $ac_dir (`pwd`/$ac_dir)" - $as_echo "$as_me:${as_lineno-$LINENO}: $ac_msg" >&5 - $as_echo "$ac_msg" >&6 - 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 - - - cd "$ac_dir" - - # Check for guested configure; otherwise get Cygnus style configure. - if test -f "$ac_srcdir/configure.gnu"; then - ac_sub_configure=$ac_srcdir/configure.gnu - elif test -f "$ac_srcdir/configure"; then - ac_sub_configure=$ac_srcdir/configure - elif test -f "$ac_srcdir/configure.in"; then - # This should be Cygnus configure. - ac_sub_configure=$ac_aux_dir/configure - else - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: no configuration information is in $ac_dir" >&5 -$as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2;} - ac_sub_configure= - fi - - # The recursion is here. - if test -n "$ac_sub_configure"; then - # Make the cache file name correct relative to the subdirectory. - case $cache_file in - [\\/]* | ?:[\\/]* ) ac_sub_cache_file=$cache_file ;; - *) # Relative name. - ac_sub_cache_file=$ac_top_build_prefix$cache_file ;; - esac - - { $as_echo "$as_me:${as_lineno-$LINENO}: running $SHELL $ac_sub_configure $ac_sub_configure_args --cache-file=$ac_sub_cache_file --srcdir=$ac_srcdir" >&5 -$as_echo "$as_me: running $SHELL $ac_sub_configure $ac_sub_configure_args --cache-file=$ac_sub_cache_file --srcdir=$ac_srcdir" >&6;} - # The eval makes quoting arguments work. - eval "\$SHELL \"\$ac_sub_configure\" $ac_sub_configure_args \ - --cache-file=\"\$ac_sub_cache_file\" --srcdir=\"\$ac_srcdir\"" || - as_fn_error $? "$ac_sub_configure failed for $ac_dir" "$LINENO" 5 - fi - - cd "$ac_popdir" - done -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 - diff -Nru ecl-16.1.2/src/bdwgc/configure.ac ecl-16.1.3+ds/src/bdwgc/configure.ac --- ecl-16.1.2/src/bdwgc/configure.ac 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/configure.ac 1970-01-01 00:00:00.000000000 +0000 @@ -1,954 +0,0 @@ -# Copyright (c) 1999-2001 by Red Hat, Inc. All rights reserved. -# -# THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED -# OR IMPLIED. ANY USE IS AT YOUR OWN RISK. -# -# Permission is hereby granted to use or copy this program -# for any purpose, provided the above notices are retained on all copies. -# Permission to modify the code and to distribute modified code is granted, -# provided the above notices are retained, and a notice that the code was -# modified is included with the above copyright notice. - -dnl Process this file with autoconf to produce configure. - -# Initialization -AC_INIT(gc,7.5.0,bdwgc@lists.opendylan.org) - ## version must conform to [0-9]+[.][0-9]+[.][0-9]+ -AC_CONFIG_SRCDIR(gcj_mlc.c) -AC_CONFIG_MACRO_DIR([m4]) -AC_CANONICAL_TARGET -AC_PREREQ(2.61) -GC_SET_VERSION -AM_INIT_AUTOMAKE([foreign dist-bzip2 nostdinc subdir-objects]) -AC_CONFIG_HEADERS([include/config.h]) -AM_MAINTAINER_MODE - -AC_SUBST(PACKAGE) -AC_SUBST(GC_VERSION) - -AM_PROG_CC_C_O -AC_PROG_CXX -AM_PROG_AS -AC_PROG_INSTALL -LT_INIT -# Note: If Autoconf reports that LIBTOOL (or AC_ENABLE_SHARED, or -# AC_PROG_LIBTOOL) is undefined, Libtool installation should be checked. - -# Special CFLAGS to use when building -gc_cflags="" - -# gc_use_mmap Set to "yes" on platforms where mmap should be used instead -# of sbrk. This will define USE_MMAP. -gc_use_mmap="" - -# We should set -fexceptions if we are using gcc and might be used -# inside something like gcj. This is the zeroth approximation: -if test :"$GCC": = :yes: ; then - gc_cflags="${gc_cflags} -fexceptions" -else - case "$host" in - hppa*-*-hpux* ) - if test :$GCC: != :"yes": ; then - gc_cflags="${gc_flags} +ESdbgasm" - fi - # :TODO: actaully we should check using Autoconf if - # the compiler supports this option. - ;; - esac -fi - -case "${host}" in - *-linux*) - # FIXME: This seems to be no longer needed as configured in gcconfig.h - #gc_use_mmap=yes - ;; -esac - -# target_optspace --enable-target-optspace ("yes", "no", "") -case "${target_optspace}:${host}" in - yes:*) - gc_cflags="${gc_cflags} -Os" - ;; - :m32r-* | :d10v-* | :d30v-*) - gc_cflags="${gc_cflags} -Os" - ;; - no:* | :*) - # Nothing. - ;; -esac - -# Set any host dependent compiler flags. -case "${host}" in - mips-tx39-*|mipstx39-unknown-*) - gc_cflags="${gc_cflags} -G 0" - ;; - *) - ;; -esac - - -GC_CFLAGS=${gc_cflags} -AC_SUBST(GC_CFLAGS) - -AC_ARG_ENABLE(threads, - [AC_HELP_STRING([--enable-threads=TYPE], [choose threading package])], - THREADS=$enableval, - [ AC_MSG_CHECKING([for thread model used by GCC]) - THREADS=`$CC -v 2>&1 | sed -n 's/^Thread model: //p'` - if test -z "$THREADS"; then - THREADS=no - fi - if test "$THREADS" = "posix"; then - case "$host" in - *-*-mingw*) - # Adjust thread model if cross-compiling for MinGW. - THREADS=win32 - ;; - esac - fi - AC_MSG_RESULT([$THREADS]) ]) - -AC_ARG_ENABLE(parallel-mark, - [AC_HELP_STRING([--enable-parallel-mark], - [parallelize marking and free list construction])], - [case "$THREADS" in - no | none | single) - if test "${enable_parallel_mark}" != no; then - AC_MSG_ERROR([Parallel mark requires --enable-threads=x spec]) - fi - ;; - esac ] -) - -AC_ARG_ENABLE(cplusplus, - [AC_HELP_STRING([--enable-cplusplus], [install C++ support])]) - -dnl Features which may be selected in the following thread-detection switch. -AH_TEMPLATE([PARALLEL_MARK], [Define to enable parallel marking.]) -AH_TEMPLATE([THREAD_LOCAL_ALLOC], - [Define to enable thread-local allocation optimization.]) -AH_TEMPLATE([USE_COMPILER_TLS], - [Define to use of compiler-support for thread-local variables.]) - -dnl Thread selection macros. -AH_TEMPLATE([GC_THREADS], [Define to support platform-specific - threads.]) -AH_TEMPLATE([GC_AIX_THREADS], [Define to support IBM AIX threads.]) -AH_TEMPLATE([GC_DARWIN_THREADS], [Define to support Darwin pthreads.]) -AH_TEMPLATE([GC_FREEBSD_THREADS], [Define to support FreeBSD pthreads.]) -AH_TEMPLATE([GC_GNU_THREADS], [Define to support GNU pthreads.]) -AH_TEMPLATE([GC_HPUX_THREADS], [Define to support HP/UX 11 pthreads.]) -AH_TEMPLATE([GC_IRIX_THREADS], [Define to support Irix pthreads.]) -AH_TEMPLATE([GC_LINUX_THREADS], [Define to support pthreads on Linux.]) -AH_TEMPLATE([GC_NETBSD_THREADS], [Define to support NetBSD pthreads.]) -AH_TEMPLATE([GC_OPENBSD_THREADS], [Define to support OpenBSD pthreads.]) -AH_TEMPLATE([GC_OSF1_THREADS], [Define to support Tru64 pthreads.]) -AH_TEMPLATE([GC_SOLARIS_THREADS], [Define to support Solaris pthreads.]) -AH_TEMPLATE([GC_WIN32_THREADS], [Define to support Win32 threads.]) -AH_TEMPLATE([GC_WIN32_PTHREADS], - [Define to support pthreads-win32 or winpthreads.]) -AH_TEMPLATE([GC_RTEMS_PTHREADS], [Define to support rtems-pthreads.]) - -dnl System header feature requests. -AH_TEMPLATE([_POSIX_C_SOURCE], [The POSIX feature macro.]) -AH_TEMPLATE([_PTHREADS], [Indicates the use of pthreads (NetBSD).]) - -dnl Win32-specific API usage controls. -AH_TEMPLATE([GC_UNDERSCORE_STDCALL], - [Explicitly prefix exported/imported WINAPI symbols with '_'.]) -AH_TEMPLATE([UNICODE], - [Use Unicode (W) variant of Win32 API instead of ASCII (A) one.]) - -dnl GC API symbols export control. -AH_TEMPLATE([GC_DLL], - [Define to build dynamic libraries with only API symbols exposed.]) - -dnl Check for a flavor of supported inline keyword. -AC_C_INLINE - -THREADDLLIBS= -need_atomic_ops_asm=false -## Libraries needed to support dynamic loading and/or threads. -case "$THREADS" in - no | none | single) - THREADS=none - ;; - posix | pthreads) - THREADS=posix - AC_CHECK_LIB(pthread, pthread_self, THREADDLLIBS="-lpthread",,) - case "$host" in - x86-*-linux* | ia64-*-linux* | i586-*-linux* | i686-*-linux* \ - | x86_64-*-linux* | alpha-*-linux* | powerpc*-*-linux* | sparc*-*-linux*) - AC_DEFINE(GC_LINUX_THREADS) - AC_DEFINE(_REENTRANT) - if test "${enable_parallel_mark}" != no; then - AC_DEFINE(PARALLEL_MARK) - fi - AC_DEFINE(THREAD_LOCAL_ALLOC) - AC_MSG_WARN("Explicit GC_INIT() calls may be required."); - ;; - *-*-linux*) - AC_DEFINE(GC_LINUX_THREADS) - AC_DEFINE(_REENTRANT) - ;; - *-*-aix*) - AC_DEFINE(GC_AIX_THREADS) - AC_DEFINE(_REENTRANT) - ;; - *-*-hpux11*) - AC_MSG_WARN("Only HP/UX 11 POSIX threads are supported.") - AC_DEFINE(GC_HPUX_THREADS) - AC_DEFINE(_POSIX_C_SOURCE,199506L) - if test "${enable_parallel_mark}" = yes; then - AC_DEFINE(PARALLEL_MARK) - fi - AC_DEFINE(THREAD_LOCAL_ALLOC) - AC_MSG_WARN("Explicit GC_INIT() calls may be required."); - THREADDLLIBS="-lpthread -lrt" - # HPUX needs REENTRANT for the _r calls. - AC_DEFINE(_REENTRANT, 1, [Required define if using POSIX threads.]) - ;; - *-*-hpux10*) - AC_MSG_WARN("Only HP-UX 11 POSIX threads are supported.") - ;; - *-*-openbsd*) - AC_DEFINE(GC_OPENBSD_THREADS) - THREADDLLIBS=-pthread - AM_CFLAGS="$AM_CFLAGS -pthread" - ;; - *-*-freebsd*) - AC_MSG_WARN("FreeBSD does not yet fully support threads with Boehm GC.") - AC_DEFINE(GC_FREEBSD_THREADS) - AM_CFLAGS="$AM_CFLAGS -pthread" - if test "${enable_parallel_mark}" = yes; then - AC_DEFINE(PARALLEL_MARK) - fi - AC_DEFINE(THREAD_LOCAL_ALLOC) - ;; - *-*-kfreebsd*-gnu) - AC_DEFINE(GC_FREEBSD_THREADS) - AM_CFLAGS="$AM_CFLAGS -pthread" - THREADDLLIBS=-pthread - AC_DEFINE(_REENTRANT) - if test "${enable_parallel_mark}" = yes; then - AC_DEFINE(PARALLEL_MARK) - fi - AC_DEFINE(THREAD_LOCAL_ALLOC) - AC_DEFINE(USE_COMPILER_TLS) - ;; - *-*-gnu*) - AC_DEFINE(GC_GNU_THREADS) - AC_DEFINE(_REENTRANT) - AC_DEFINE(THREAD_LOCAL_ALLOC) - ;; - *-*-netbsd*) - AC_MSG_WARN("Only on NetBSD 2.0 or later.") - AC_DEFINE(GC_NETBSD_THREADS) - AC_DEFINE(_REENTRANT) - AC_DEFINE(_PTHREADS) - THREADDLLIBS="-lpthread -lrt" - ;; - *-*-solaris*) - AC_DEFINE(GC_SOLARIS_THREADS) - if test "${enable_parallel_mark}" != no; then - AC_DEFINE(PARALLEL_MARK) - fi - AC_DEFINE(THREAD_LOCAL_ALLOC) - # Need to use alternate thread library, otherwise gctest hangs - # on Solaris 8. - multi_os_directory=`$CC -print-multi-os-directory` - THREADDLLIBS="-L/usr/lib/lwp/$multi_os_directory \ - -R/usr/lib/lwp/$multi_os_directory -lpthread -lrt" - ;; - *-*-irix*) - AC_DEFINE(GC_IRIX_THREADS) - ;; - *-*-cygwin*) - AC_DEFINE(GC_WIN32_THREADS) - if test "${enable_parallel_mark}" != no; then - AC_DEFINE(PARALLEL_MARK) - fi - AC_DEFINE(THREAD_LOCAL_ALLOC) - # Cygwin doesn't have a real libpthread, so Libtool can't link - # against it. - THREADDLLIBS="" - win32_threads=true - ;; - *-*-mingw*) - AC_DEFINE(GC_WIN32_PTHREADS) - # Using pthreads-win32 (or other non-Cygwin pthreads) library. - if test "${enable_parallel_mark}" != no; then - AC_DEFINE(PARALLEL_MARK) - fi - AC_DEFINE(THREAD_LOCAL_ALLOC) - THREADDLLIBS="-lpthread" - win32_threads=true - ;; - *-*-darwin*) - AC_DEFINE(GC_DARWIN_THREADS) - AC_MSG_WARN("Explicit GC_INIT() calls may be required."); - # Parallel-mark is not well-tested on Darwin - if test "${enable_parallel_mark}" != no; then - AC_DEFINE(PARALLEL_MARK) - fi - AC_DEFINE(THREAD_LOCAL_ALLOC) - darwin_threads=true - ;; - *-*-osf*) - AC_DEFINE(GC_OSF1_THREADS) - if test "${enable_parallel_mark}" = yes; then - AC_DEFINE(PARALLEL_MARK) - AC_DEFINE(THREAD_LOCAL_ALLOC) - AC_MSG_WARN("Explicit GC_INIT() calls may be required."); - # May want to enable it in other cases, too. - # Measurements have not yet been done. - fi - AM_CFLAGS="$AM_CFLAGS -pthread" - THREADDLLIBS="-lpthread -lrt" - ;; - *) - AC_MSG_ERROR("Pthreads not supported by the GC on this platform.") - ;; - esac - case "$host" in - sparc*-*-solaris*) - if test "$GCC" != yes; then - need_atomic_ops_asm=true - fi - ;; - esac - ;; - win32) - AC_DEFINE(GC_WIN32_THREADS) - if test "${enable_parallel_mark}" != no; then - AC_DEFINE(PARALLEL_MARK) - AC_DEFINE(THREAD_LOCAL_ALLOC) - else - if test "${enable_shared}" != yes || test "${enable_static}" != no; then - # Imply THREAD_LOCAL_ALLOC unless GC_DLL. - AC_DEFINE(THREAD_LOCAL_ALLOC) - fi - fi - if test "${enable_win32_dllmain}" = yes; then - AC_DEFINE(GC_INSIDE_DLL, 1, - [Enable Win32 DllMain-based approach of threads registering.]) - fi - win32_threads=true - AC_DEFINE([EMPTY_GETENV_RESULTS], [1], - [Wine getenv may not return NULL for missing entry.]) - ;; - dgux386) - THREADS=dgux386 - AC_MSG_RESULT($THREADDLLIBS) - # Use pthread GCC switch - THREADDLLIBS=-pthread - if test "${enable_parallel_mark}" = yes; then - AC_DEFINE(PARALLEL_MARK) - fi - AC_DEFINE(THREAD_LOCAL_ALLOC) - AC_MSG_WARN("Explicit GC_INIT() calls may be required."); - AC_DEFINE([GC_DGUX386_THREADS], 1, - [Define to enable support for DB/UX threads on i386.]) - AC_DEFINE([DGUX_THREADS], 1, - [Define to enable support for DB/UX threads.]) - # Enable _POSIX4A_DRAFT10_SOURCE with flag -pthread - AM_CFLAGS="-pthread $AM_CFLAGS" - ;; - aix) - THREADS=posix - THREADDLLIBS=-lpthread - AC_DEFINE(GC_AIX_THREADS) - AC_DEFINE(_REENTRANT) - ;; - rtems) - THREADS=posix - AC_DEFINE(GC_RTEMS_PTHREADS) - AC_DEFINE(THREAD_LOCAL_ALLOC) - ;; - decosf1 | irix | mach | os2 | solaris | dce | vxworks) - AC_MSG_ERROR(thread package $THREADS not yet supported) - ;; - *) - AC_MSG_ERROR($THREADS is an unknown thread package) - ;; -esac -AC_SUBST(THREADDLLIBS) -AM_CONDITIONAL(THREADS, test x$THREADS != xnone) -AM_CONDITIONAL(PTHREADS, test x$THREADS = xposix) -AM_CONDITIONAL(DARWIN_THREADS, test x$darwin_threads = xtrue) -AM_CONDITIONAL(WIN32_THREADS, test x$win32_threads = xtrue) - -compiler_suncc=no -case "$host" in - powerpc-*-darwin*) - powerpc_darwin=true - ;; - *-*-solaris*) - if test "$GCC" != yes; then - # Solaris SunCC - compiler_suncc=yes - CFLAGS="-O $CFLAGS" - fi - ;; - *-*-wince*) - if test "$enable_gc_debug" != "no"; then - AC_DEFINE([GC_READ_ENV_FILE], 1, - [Read environment variables from the GC 'env' file.]) - fi - ;; -esac - -if test "$GCC" = yes; then - # Output all warnings. - AC_MSG_CHECKING(for gcc -Wextra) - old_CFLAGS="$CFLAGS" - CFLAGS="-Wextra $CFLAGS" - AC_TRY_COMPILE([],[], [ac_cv_cc_wextra=yes], [ac_cv_cc_wextra=no]) - CFLAGS="$old_CFLAGS" - AC_MSG_RESULT($ac_cv_cc_wextra) - AS_IF([test "$ac_cv_cc_wextra" = yes], [WEXTRA="-Wextra"], [WEXTRA="-W"]) - CFLAGS="-Wall $WEXTRA $CFLAGS" -fi - -AC_MSG_CHECKING(for xlc) -AC_TRY_COMPILE([],[ - #ifndef __xlC__ - # error - #endif -], [compiler_xlc=yes], [compiler_xlc=no]) -AC_MSG_RESULT($compiler_xlc) -if test $compiler_xlc = yes -a "$powerpc_darwin" = true; then - # the darwin stack-frame-walking code is completely broken on xlc - AC_DEFINE([DARWIN_DONT_PARSE_STACK], 1, [See doc/README.macros.]) -fi - -# XLC neither requires nor tolerates the unnecessary assembler goop. -# Similar for the Sun C compiler. -AM_CONDITIONAL([ASM_WITH_CPP_UNSUPPORTED], - [test $compiler_xlc = yes -o $compiler_suncc = yes]) - -if test "$GCC" = yes; then - # Disable aliasing optimization unless forced to. - AC_MSG_CHECKING([whether gcc supports -fno-strict-aliasing]) - ac_cv_fno_strict_aliasing=no - for cflag in $CFLAGS; do - case "$cflag" in - -fstrict-aliasing) - # Opposite option already present - ac_cv_fno_strict_aliasing=skipped - break - ;; - esac - done - if test "$ac_cv_fno_strict_aliasing" != skipped; then - old_CFLAGS="$CFLAGS" - CFLAGS="$CFLAGS -fno-strict-aliasing" - AC_TRY_COMPILE([],[], [ac_cv_fno_strict_aliasing=yes], []) - CFLAGS="$old_CFLAGS" - AS_IF([test "$ac_cv_fno_strict_aliasing" = yes], - [CFLAGS="$CFLAGS -fno-strict-aliasing"], []) - fi - AC_MSG_RESULT($ac_cv_fno_strict_aliasing) -fi - -case "$host" in -# While IRIX 6 has libdl for the O32 and N32 ABIs, it's missing for N64 -# and unnecessary everywhere. - mips-sgi-irix6*) ;; -# We never want libdl on darwin. It is a fake libdl that just ends up making -# dyld calls anyway. The same applies to Cygwin. - *-*-darwin*) ;; - *-*-cygwin*) ;; - *) - AC_CHECK_LIB(dl, dlopen, THREADDLLIBS="$THREADDLLIBS -ldl") - ;; -esac - -case "$host" in - *-*-hpux*) - avoid_cpp_lib=yes;; - *) - avoid_cpp_lib=no; - ;; -esac -AM_CONDITIONAL(AVOID_CPP_LIB,test $avoid_cpp_lib = yes) - -# extra LD Flags which are required for targets -case "${host}" in - *-*-darwin*) - extra_ldflags_libgc=-Wl,-single_module - ;; -esac -AC_SUBST(extra_ldflags_libgc) - -AC_SUBST(EXTRA_TEST_LIBS) - -target_all=libgc.la -AC_SUBST(target_all) - -dnl If the target is an eCos system, use the appropriate eCos -dnl I/O routines. -dnl FIXME: this should not be a local option but a global target -dnl system; at present there is no eCos target. -TARGET_ECOS="no" -AC_ARG_WITH(ecos, -[ --with-ecos enable runtime eCos target support], -TARGET_ECOS="$with_ecos" -) - -addobjs= -addlibs= -CXXLIBS= - -case "$TARGET_ECOS" in - no) - ;; - *) - AC_DEFINE([ECOS], 1, [Define to enable eCos target support.]) - AM_CPPFLAGS="-I${TARGET_ECOS}/include $AM_CPPFLAGS" - addobjs="$addobjs ecos.lo" - ;; -esac - -AM_CONDITIONAL(CPLUSPLUS, test "${enable_cplusplus}" = yes) - -if test "$GCC" = yes; then - if test "${enable_cplusplus}" = yes; then - case "$host" in - *-*-cygwin* | *-*-mingw*) - AC_MSG_CHECKING([whether libsupc++ required]) - SUPC="`$CXX -print-file-name=libsupc++.a 2>/dev/null`" - if test -n "$SUPC" -a "$SUPC" != "libsupc++.a"; then - AC_MSG_RESULT(yes) - CXXLIBS="-lsupc++" - else - AC_MSG_RESULT(no) - fi - ;; - esac - fi -fi - -AC_SUBST(CXX) -AC_SUBST(AM_CFLAGS) -AC_SUBST(AM_CPPFLAGS) -AC_SUBST(CXXLIBS) - -# Configuration of shared libraries -# -AC_MSG_CHECKING(whether to build shared libraries) -AC_ENABLE_SHARED - -case "$host" in - alpha-*-openbsd*) - enable_shared=no - ;; - *) - ;; -esac - -AC_MSG_RESULT($enable_shared) - -# Compile with GC_DLL defined unless building static libraries. -if test "${enable_shared}" = yes; then - if test "${enable_static}" = no; then - AC_DEFINE(GC_DLL) - if test "$GCC" = yes; then - # Pass -fvisibility=hidden option if supported - AC_MSG_CHECKING([whether gcc supports -fvisibility]) - old_CFLAGS="$CFLAGS" - CFLAGS="-Werror -fvisibility=hidden $CFLAGS" - AC_TRY_COMPILE([],[], [ac_cv_fvisibility_hidden=yes], - [ac_cv_fvisibility_hidden=no]) - CFLAGS="$old_CFLAGS" - AS_IF([test "$ac_cv_fvisibility_hidden" = yes], - [CFLAGS="-DGC_VISIBILITY_HIDDEN_SET -fvisibility=hidden $CFLAGS"]) - AC_MSG_RESULT($ac_cv_fvisibility_hidden) - fi - fi -fi - -# Configuration of machine-dependent code -# -AC_MSG_CHECKING(which machine-dependent code should be used) -machdep= -case "$host" in - alpha-*-openbsd*) - if test x"${ac_cv_lib_dl_dlopen}" != xyes ; then - AC_MSG_WARN( - "OpenBSD/Alpha without dlopen(). Shared library support is disabled.") - fi - ;; - i?86-*-solaris2.[[89]]) - # PROC_VDB appears to work in 2.8 and 2.9 but not in 2.10+ (for now). - AC_DEFINE([SOLARIS25_PROC_VDB_BUG_FIXED], 1, - [See the comment in gcconfig.h.]) - ;; - mips-*-*) - dnl AC_DEFINE(NO_EXECUTE_PERMISSION) - dnl This is now redundant, but it is also important for incremental GC - dnl performance under Irix. - ;; - sparc-*-netbsd*) - machdep="sparc_netbsd_mach_dep.lo" - ;; - sparc*-*-linux* | sparc*-*-openbsd* | sparc64-*-freebsd* | sparc64-*-netbsd*) - machdep="sparc_mach_dep.lo" - ;; - sparc-sun-solaris2.3) - machdep="sparc_mach_dep.lo" - AC_DEFINE(SUNOS53_SHARED_LIB, 1, - [Define to work around a Solaris 5.3 bug (see dyn_load.c).]) - ;; - sparc*-sun-solaris2*) - machdep="sparc_mach_dep.lo" - ;; - ia64-*-*) - machdep="ia64_save_regs_in_stack.lo" - ;; -esac -AC_MSG_RESULT($machdep) -addobjs="$addobjs $machdep" -AC_SUBST(addobjs) -AC_SUBST(addlibs) - -AC_PROG_LIBTOOL - -dnl We use these options to decide which functions to include. -AC_ARG_WITH(target-subdir, -[ --with-target-subdir=SUBDIR - configuring with a cross compiler]) -AC_ARG_WITH(cross-host, -[ --with-cross-host=HOST configuring with a cross compiler]) - -# automake wants to see AC_EXEEXT. But we don't need it. And having -# it is actually a problem, because the compiler we're passed can't -# necessarily do a full link. So we fool automake here. -if false; then - # autoconf 2.50 runs AC_EXEEXT by default, and the macro expands - # to nothing, so nothing would remain between `then' and `fi' if it - # were not for the `:' below. - : - AC_EXEEXT -fi - -dnl As of 4.13a2, the collector will not properly work on Solaris when -dnl built with gcc and -O. So we remove -O in the appropriate case. -dnl Not needed anymore on Solaris. -AC_MSG_CHECKING(whether Solaris gcc optimization fix is necessary) -case "$host" in - *aix*) - if test "$GCC" = yes; then - AC_MSG_RESULT(yes) - new_CFLAGS= - for i in $CFLAGS; do - case "$i" in - -O*) - ;; - *) - new_CFLAGS="$new_CFLAGS $i" - ;; - esac - done - CFLAGS="$new_CFLAGS" - else - AC_MSG_RESULT(no) - fi - ;; - *) AC_MSG_RESULT(no) ;; -esac - -dnl Include defines that have become de facto standard. -dnl ALL_INTERIOR_POINTERS and NO_EXECUTE_PERMISSION can be overridden -dnl in the startup code. -AC_DEFINE([NO_EXECUTE_PERMISSION], [1], - [Define to make the collector not allocate executable memory - by default.]) -AC_DEFINE([ALL_INTERIOR_POINTERS], [1], - [Define to recognise all pointers to the interior of objects.]) - - -dnl Interface Selection -dnl ------------------- -dnl -dnl By default, make the library as general as possible. -dnl enable_gcj_support=no -AC_ARG_ENABLE(gcj-support, - [AC_HELP_STRING([--disable-gcj-support], - [Disable support for gcj.])]) -if test x"$enable_gcj_support" != xno; then - AC_DEFINE(GC_GCJ_SUPPORT, 1, [Define to include support for gcj.]) -fi - -dnl Interaction with other programs that might use signals. -AC_ARG_ENABLE(sigrt-signals, - [AC_HELP_STRING([--enable-sigrt-signals], - [Force GC to use SIGRTMIN-based signals for thread suspend/resume])]) -if test x"${enable_sigrt_signals}" = xyes; then - AC_DEFINE([GC_USESIGRT_SIGNALS], 1, - [Force the GC to use signals based on SIGRTMIN+k.]) -fi - - -dnl Debugging -dnl --------- - -AH_TEMPLATE([GC_HAVE_BUILTIN_BACKTRACE], - [Define if backtrace information is supported.]) -AH_TEMPLATE([MAKE_BACK_GRAPH], [See doc/README.macros.]) -AH_TEMPLATE([SAVE_CALL_COUNT], - [The number of caller frames saved when allocating with the - debugging API.]) -UNWINDLIBS= -AC_ARG_ENABLE(gc-debug, -[AC_HELP_STRING([--enable-gc-debug], - [include full support for pointer backtracing etc.])], -[ if test "$enable_gc_debug" = "yes"; then - AC_MSG_WARN("Should define GC_DEBUG and use debug alloc in clients.") - AC_DEFINE([KEEP_BACK_PTRS], 1, - [Define to save back-pointers in debugging headers.]) - keep_back_ptrs=true - AC_DEFINE([DBG_HDRS_ALL], 1, - [Define to force debug headers on all objects.]) - AH_TEMPLATE([SHORT_DBG_HDRS], - [Shorten the headers to minimize object size at the expense - of checking for writes past the end (see doc/README.macros).]) - - case $host in - ia64-*-linux* ) - AC_DEFINE(MAKE_BACK_GRAPH) - AC_DEFINE(SAVE_CALL_COUNT, 8) - AC_CHECK_LIB(unwind, backtrace, [ - AC_DEFINE(GC_HAVE_BUILTIN_BACKTRACE) - UNWINDLIBS=-lunwind - AC_MSG_WARN("Client code may need to link against libunwind.") - ]) - ;; - x86-*-linux* | i586-*-linux* | i686-*-linux* | x86_64-*-linux* ) - AC_DEFINE(MAKE_BACK_GRAPH) - AC_MSG_WARN("Client must not use -fomit-frame-pointer.") - AC_DEFINE(SAVE_CALL_COUNT, 8) - ;; - i[3456]86-*-dgux*) - AC_DEFINE(MAKE_BACK_GRAPH) - ;; - esac ] - fi) -AM_CONDITIONAL([MAKE_BACK_GRAPH], [test x"$enable_gc_debug" = xyes]) -AM_CONDITIONAL([KEEP_BACK_PTRS], [test x"$keep_back_ptrs" = xtrue]) - -# Check for dladdr (used for debugging). -AC_MSG_CHECKING(for dladdr) -have_dladdr=no -AC_TRY_COMPILE([ -#define _GNU_SOURCE 1 -#include ], [{ - Dl_info info; - (void)dladdr("", &info); -}], [ have_dladdr=yes ]) -AC_MSG_RESULT($have_dladdr) -if test x"$have_dladdr" = xyes; then - AC_DEFINE([HAVE_DLADDR], 1, [Define to use 'dladdr' function.]) -fi - -# Check for AViiON Machines running DGUX -ac_is_dgux=no -AC_CHECK_HEADER(sys/dg_sys_info.h, -[ac_is_dgux=yes;]) - - ## :GOTCHA: we do not check anything but sys/dg_sys_info.h -if test $ac_is_dgux = yes; then - dgux_spec_opts="-DDGUX -D_DGUX_SOURCE -Di386 -mno-legend -O2" - CFLAGS="$dgux_spec_opts $CFLAGS" - CXXFLAGS="$dgux_spec_opts $CXXFLAGS" - if test "$enable_gc_debug" = "yes"; then - CFLAGS="-g -mstandard $CFLAGS" - CXXFLAGS="-g -mstandard $CXXFLAGS" - fi - AC_SUBST(CFLAGS) - AC_SUBST(CXXFLAGS) -fi - -AC_ARG_ENABLE(java-finalization, - [AC_HELP_STRING([--disable-java-finalization], - [Disable support for java finalization.])]) -if test x"$enable_java_finalization" != xno; then - AC_DEFINE([JAVA_FINALIZATION], 1, [See doc/README.macros.]) -fi - -AC_ARG_ENABLE(atomic-uncollectable, - [AC_HELP_STRING([--disable-atomic-uncollectible], - [Disable support for atomic uncollectible allocation.])]) -if test x"$enable_atomic_uncollectible" != x"no"; then - AC_DEFINE(ATOMIC_UNCOLLECTABLE, 1, - [Define to enable atomic uncollectible allocation.]) -fi - -AC_ARG_ENABLE(redirect-malloc, - [AC_HELP_STRING([--enable-redirect-malloc], - [Redirect malloc and friends to GC routines])]) - -if test "${enable_redirect_malloc}" = yes; then - if test "${enable_gc_debug}" = yes; then - AC_DEFINE([REDIRECT_MALLOC], GC_debug_malloc_replacement, - [If defined, redirect malloc to this function.]) - AC_DEFINE([REDIRECT_REALLOC], GC_debug_realloc_replacement, - [If defined, redirect GC_realloc to this function.]) - AC_DEFINE([REDIRECT_FREE], GC_debug_free, - [If defined, redirect free to this function.]) - else - AC_DEFINE(REDIRECT_MALLOC, GC_malloc) - fi - AC_DEFINE([GC_USE_DLOPEN_WRAP], 1, [See doc/README.macros.]) -fi - -AC_ARG_ENABLE(disclaim, - [AC_HELP_STRING([--disable-disclaim], - [Disable alternative (more efficient) finalization interface.])]) -if test x"$enable_disclaim" != xno; then - AC_DEFINE(ENABLE_DISCLAIM, 1, - [Define to enable alternative finalization interface.]) -fi -AM_CONDITIONAL(ENABLE_DISCLAIM, - [test x"$enable_disclaim" != xno]) - -AC_ARG_ENABLE(large-config, - [AC_HELP_STRING([--enable-large-config], - [Optimize for large (> 100 MB) heap or root set])]) - -if test "${enable_large_config}" = yes; then - AC_DEFINE(LARGE_CONFIG, 1, [Define to optimize for large heaps or root sets.]) -fi - -AC_ARG_ENABLE(handle-fork, - [AC_HELP_STRING([--enable-handle-fork], - [Attempt to ensure a usable collector after fork() in multi-threaded - programs.])]) - -if test "${enable_handle_fork}" = yes; then - AC_DEFINE(HANDLE_FORK, 1, - [Define to install pthread_atfork() handlers by default.]) -elif test "${enable_handle_fork}" = no; then - AC_DEFINE(NO_HANDLE_FORK, 1, - [Prohibit installation of pthread_atfork() handlers.]) -fi - -dnl This is something of a hack. When cross-compiling we turn off -dnl some functionality. We also enable the "small" configuration. -dnl These is only correct when targetting an embedded system. FIXME. -if test -n "${with_cross_host}"; then - AC_DEFINE([NO_CLOCK], 1, [Define to not use system clock (cross compiling).]) - AC_DEFINE([SMALL_CONFIG], 1, - [Define to tune the collector for small heap sizes.]) -fi - -if test "$enable_gc_debug" = "no"; then - AC_DEFINE([NO_DEBUGGING], 1, - [Disable debugging, like GC_dump and its callees.]) -fi - -AC_SUBST(UNWINDLIBS) - -AC_ARG_ENABLE(gc-assertions, - [AC_HELP_STRING([--enable-gc-assertions], - [collector-internal assertion checking])]) -if test "${enable_gc_assertions}" = yes; then - AC_DEFINE([GC_ASSERTIONS], 1, [Define to enable internal debug assertions.]) -fi - -AC_ARG_ENABLE(munmap, - [AC_HELP_STRING([--enable-munmap=N], - [return page to the os if empty for N collections])], - MUNMAP_THRESHOLD=$enableval) -if test "${enable_munmap}" != ""; then - AC_DEFINE([USE_MMAP], 1, - [Define to use mmap instead of sbrk to expand the heap.]) - case "$host" in - *-*-cygwin*) - # Workaround for Cygwin: use VirtualAlloc since mmap(PROT_NONE) fails - AC_DEFINE([USE_WINALLOC], 1, - [Define to use Win32 VirtualAlloc (instead of sbrk or - mmap) to expand the heap.]) - ;; - esac - AC_DEFINE([USE_MUNMAP], 1, - [Define to return memory to OS with munmap calls - (see doc/README.macros).]) - if test "${MUNMAP_THRESHOLD}" = "yes"; then - MUNMAP_THRESHOLD=6 - fi - AC_DEFINE_UNQUOTED([MUNMAP_THRESHOLD], [${MUNMAP_THRESHOLD}], - [Number of GC cycles to wait before unmapping an unused block.]) -else - if test "${gc_use_mmap}" = "yes"; then - AC_DEFINE([USE_MMAP], 1, - [Define to use mmap instead of sbrk to expand the heap.]) - fi -fi - -AM_CONDITIONAL(USE_LIBDIR, test -z "$with_cross_host") - -AC_ARG_ENABLE(single-obj-compilation, - [AC_HELP_STRING([--enable-single-obj-compilation], - [Compile all library .c files into single .o])], - [single_obj_compilation=yes]) -AM_CONDITIONAL([SINGLE_GC_OBJ], [test "$single_obj_compilation" = "yes"]) - -# Atomic Ops -# ---------- - -# Do we want to use an external libatomic_ops? By default use it if it's -# found. -AC_ARG_WITH([libatomic-ops], - [AS_HELP_STRING([--with-libatomic-ops[=yes|no|check]], - [Use a external libatomic_ops? (default: check)])], - [], [with_libatomic_ops=check]) - -# Check for an external libatomic_ops if the answer was yes or check. If not -# found, fail on yes, and convert check to no. -# Note: "syntax error near unexpected token ATOMIC_OPS" reported by configure -# means Autotools pkg.m4 file was not found during aclocal.m4 generation. -missing_libatomic_ops=false -AS_IF([test x"$with_libatomic_ops" != xno], - [ PKG_CHECK_MODULES([ATOMIC_OPS], [atomic_ops], [], - [ missing_libatomic_ops=true ]) ]) -AS_IF([test x$missing_libatomic_ops = xtrue ], - [ AS_IF([test x"$with_libatomic_ops" != xcheck], - [ AC_MSG_ERROR([An external libatomic_ops was not found]) ]) - with_libatomic_ops=no ]) - -# If we have neither an external or an internal version, offer a useful hint -# and exit. -AS_IF([test x"$with_libatomic_ops" = xno -a ! -e "$srcdir/libatomic_ops"], - [ AC_MSG_ERROR([libatomic_ops is required. You can either install it on - your system, or fetch and unpack a recent version into the - source directory and link or rename it to libatomic_ops.]) ]) - -# Finally, emit the definitions for bundled or external AO. -AC_MSG_CHECKING([which libatomic_ops to use]) -AS_IF([test x"$with_libatomic_ops" != xno], - [ AC_MSG_RESULT([external]) ], - [ AC_MSG_RESULT([internal]) - ATOMIC_OPS_CFLAGS='-I$(top_builddir)/libatomic_ops/src -I$(top_srcdir)/libatomic_ops/src' - ATOMIC_OPS_LIBS="" - AC_SUBST([ATOMIC_OPS_CFLAGS]) - AC_CONFIG_SUBDIRS([libatomic_ops]) - ]) -AM_CONDITIONAL([USE_INTERNAL_LIBATOMIC_OPS], - [test x$with_libatomic_ops = xno -a x"$THREADS" != xnone]) -AM_CONDITIONAL([NEED_ATOMIC_OPS_ASM], - [test x$with_libatomic_ops = xno -a x$need_atomic_ops_asm = xtrue]) - -dnl Produce the Files -dnl ----------------- - -AC_CONFIG_FILES([Makefile bdw-gc.pc]) - -AC_CONFIG_COMMANDS([default],, - [ srcdir="${srcdir}" - host=${host} - CONFIG_SHELL=${CONFIG_SHELL-/bin/sh} - CC="${CC}" - DEFS="$DEFS" ]) - -AC_OUTPUT diff -Nru ecl-16.1.2/src/bdwgc/cord/cord.am ecl-16.1.3+ds/src/bdwgc/cord/cord.am --- ecl-16.1.2/src/bdwgc/cord/cord.am 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/cord/cord.am 1970-01-01 00:00:00.000000000 +0000 @@ -1,28 +0,0 @@ - -lib_LTLIBRARIES += libcord.la - -libcord_la_LIBADD = $(top_builddir)/libgc.la -libcord_la_LDFLAGS = -version-info 1:3:0 -no-undefined -libcord_la_CPPFLAGS = $(AM_CPPFLAGS) - -libcord_la_SOURCES = \ - cord/cordbscs.c \ - cord/cordprnt.c \ - cord/cordxtra.c - -TESTS += cordtest$(EXEEXT) -check_PROGRAMS += cordtest -cordtest_SOURCES = cord/tests/cordtest.c -cordtest_LDADD = $(top_builddir)/libgc.la $(top_builddir)/libcord.la - -EXTRA_DIST += \ - cord/tests/de.c \ - cord/tests/de_cmds.h \ - cord/tests/de_win.c \ - cord/tests/de_win.h \ - cord/tests/de_win.rc - -pkginclude_HEADERS += \ - include/cord.h \ - include/cord_pos.h \ - include/ec.h diff -Nru ecl-16.1.2/src/bdwgc/cord/cordbscs.c ecl-16.1.3+ds/src/bdwgc/cord/cordbscs.c --- ecl-16.1.2/src/bdwgc/cord/cordbscs.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/cord/cordbscs.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,923 +0,0 @@ -/* - * Copyright (c) 1993-1994 by Xerox Corporation. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#ifdef HAVE_CONFIG_H -# include "config.h" -#endif -#ifndef CORD_BUILD -# define CORD_BUILD -#endif - -# include "gc.h" -# include "cord.h" -# include -# include -# include - -/* An implementation of the cord primitives. These are the only */ -/* Functions that understand the representation. We perform only */ -/* minimal checks on arguments to these functions. Out of bounds */ -/* arguments to the iteration functions may result in client functions */ -/* invoked on garbage data. In most cases, client functions should be */ -/* programmed defensively enough that this does not result in memory */ -/* smashes. */ - -typedef void (* oom_fn)(void); - -oom_fn CORD_oom_fn = (oom_fn) 0; - -# define OUT_OF_MEMORY { if (CORD_oom_fn != (oom_fn) 0) (*CORD_oom_fn)(); \ - ABORT("Out of memory\n"); } -# define ABORT(msg) { fprintf(stderr, "%s\n", msg); abort(); } - -typedef unsigned long word; - -typedef union { - struct Concatenation { - char null; - char header; - char depth; /* concatenation nesting depth. */ - unsigned char left_len; - /* Length of left child if it is sufficiently */ - /* short; 0 otherwise. */ -# define MAX_LEFT_LEN 255 - word len; - CORD left; /* length(left) > 0 */ - CORD right; /* length(right) > 0 */ - } concatenation; - struct Function { - char null; - char header; - char depth; /* always 0 */ - char left_len; /* always 0 */ - word len; - CORD_fn fn; - void * client_data; - } function; - struct Generic { - char null; - char header; - char depth; - char left_len; - word len; - } generic; - char string[1]; -} CordRep; - -# define CONCAT_HDR 1 - -# define FN_HDR 4 -# define SUBSTR_HDR 6 - /* Substring nodes are a special case of function nodes. */ - /* The client_data field is known to point to a substr_args */ - /* structure, and the function is either CORD_apply_access_fn */ - /* or CORD_index_access_fn. */ - -/* The following may be applied only to function and concatenation nodes: */ -#define IS_CONCATENATION(s) (((CordRep *)s)->generic.header == CONCAT_HDR) - -#define IS_FUNCTION(s) ((((CordRep *)s)->generic.header & FN_HDR) != 0) - -#define IS_SUBSTR(s) (((CordRep *)s)->generic.header == SUBSTR_HDR) - -#define LEN(s) (((CordRep *)s) -> generic.len) -#define DEPTH(s) (((CordRep *)s) -> generic.depth) -#define GEN_LEN(s) (CORD_IS_STRING(s) ? strlen(s) : LEN(s)) - -#define LEFT_LEN(c) ((c) -> left_len != 0? \ - (c) -> left_len \ - : (CORD_IS_STRING((c) -> left) ? \ - (c) -> len - GEN_LEN((c) -> right) \ - : LEN((c) -> left))) - -#define SHORT_LIMIT (sizeof(CordRep) - 1) - /* Cords shorter than this are C strings */ - - -/* Dump the internal representation of x to stdout, with initial */ -/* indentation level n. */ -void CORD_dump_inner(CORD x, unsigned n) -{ - register size_t i; - - for (i = 0; i < (size_t)n; i++) { - fputs(" ", stdout); - } - if (x == 0) { - fputs("NIL\n", stdout); - } else if (CORD_IS_STRING(x)) { - for (i = 0; i <= SHORT_LIMIT; i++) { - if (x[i] == '\0') break; - putchar(x[i]); - } - if (x[i] != '\0') fputs("...", stdout); - putchar('\n'); - } else if (IS_CONCATENATION(x)) { - register struct Concatenation * conc = - &(((CordRep *)x) -> concatenation); - printf("Concatenation: %p (len: %d, depth: %d)\n", - x, (int)(conc -> len), (int)(conc -> depth)); - CORD_dump_inner(conc -> left, n+1); - CORD_dump_inner(conc -> right, n+1); - } else /* function */{ - register struct Function * func = - &(((CordRep *)x) -> function); - if (IS_SUBSTR(x)) printf("(Substring) "); - printf("Function: %p (len: %d): ", x, (int)(func -> len)); - for (i = 0; i < 20 && i < func -> len; i++) { - putchar((*(func -> fn))(i, func -> client_data)); - } - if (i < func -> len) fputs("...", stdout); - putchar('\n'); - } -} - -/* Dump the internal representation of x to stdout */ -void CORD_dump(CORD x) -{ - CORD_dump_inner(x, 0); - fflush(stdout); -} - -CORD CORD_cat_char_star(CORD x, const char * y, size_t leny) -{ - register size_t result_len; - register size_t lenx; - register int depth; - - if (x == CORD_EMPTY) return(y); - if (leny == 0) return(x); - if (CORD_IS_STRING(x)) { - lenx = strlen(x); - result_len = lenx + leny; - if (result_len <= SHORT_LIMIT) { - register char * result = GC_MALLOC_ATOMIC(result_len+1); - - if (result == 0) OUT_OF_MEMORY; - memcpy(result, x, lenx); - memcpy(result + lenx, y, leny); - result[result_len] = '\0'; - return((CORD) result); - } else { - depth = 1; - } - } else { - register CORD right; - register CORD left; - register char * new_right; - register size_t right_len; - - lenx = LEN(x); - - if (leny <= SHORT_LIMIT/2 - && IS_CONCATENATION(x) - && CORD_IS_STRING(right = ((CordRep *)x) -> concatenation.right)) { - /* Merge y into right part of x. */ - if (!CORD_IS_STRING(left = ((CordRep *)x) -> concatenation.left)) { - right_len = lenx - LEN(left); - } else if (((CordRep *)x) -> concatenation.left_len != 0) { - right_len = lenx - ((CordRep *)x) -> concatenation.left_len; - } else { - right_len = strlen(right); - } - result_len = right_len + leny; /* length of new_right */ - if (result_len <= SHORT_LIMIT) { - new_right = GC_MALLOC_ATOMIC(result_len + 1); - if (new_right == 0) OUT_OF_MEMORY; - memcpy(new_right, right, right_len); - memcpy(new_right + right_len, y, leny); - new_right[result_len] = '\0'; - y = new_right; - leny = result_len; - x = left; - lenx -= right_len; - /* Now fall through to concatenate the two pieces: */ - } - if (CORD_IS_STRING(x)) { - depth = 1; - } else { - depth = DEPTH(x) + 1; - } - } else { - depth = DEPTH(x) + 1; - } - result_len = lenx + leny; - } - { - /* The general case; lenx, result_len is known: */ - register struct Concatenation * result; - - result = GC_NEW(struct Concatenation); - if (result == 0) OUT_OF_MEMORY; - result->header = CONCAT_HDR; - result->depth = depth; - if (lenx <= MAX_LEFT_LEN) result->left_len = lenx; - result->len = result_len; - result->left = x; - result->right = y; - if (depth >= MAX_DEPTH) { - return(CORD_balance((CORD)result)); - } else { - return((CORD) result); - } - } -} - - -CORD CORD_cat(CORD x, CORD y) -{ - register size_t result_len; - register int depth; - register size_t lenx; - - if (x == CORD_EMPTY) return(y); - if (y == CORD_EMPTY) return(x); - if (CORD_IS_STRING(y)) { - return(CORD_cat_char_star(x, y, strlen(y))); - } else if (CORD_IS_STRING(x)) { - lenx = strlen(x); - depth = DEPTH(y) + 1; - } else { - register int depthy = DEPTH(y); - - lenx = LEN(x); - depth = DEPTH(x) + 1; - if (depthy >= depth) depth = depthy + 1; - } - result_len = lenx + LEN(y); - { - register struct Concatenation * result; - - result = GC_NEW(struct Concatenation); - if (result == 0) OUT_OF_MEMORY; - result->header = CONCAT_HDR; - result->depth = depth; - if (lenx <= MAX_LEFT_LEN) result->left_len = lenx; - result->len = result_len; - result->left = x; - result->right = y; - if (depth >= MAX_DEPTH) { - return(CORD_balance((CORD)result)); - } else { - return((CORD) result); - } - } -} - - - -CORD CORD_from_fn(CORD_fn fn, void * client_data, size_t len) -{ - if (len <= 0) return(0); - if (len <= SHORT_LIMIT) { - register char * result; - register size_t i; - char buf[SHORT_LIMIT+1]; - register char c; - - for (i = 0; i < len; i++) { - c = (*fn)(i, client_data); - if (c == '\0') goto gen_case; - buf[i] = c; - } - - result = GC_MALLOC_ATOMIC(len+1); - if (result == 0) OUT_OF_MEMORY; - memcpy(result, buf, len); - result[len] = '\0'; - return((CORD) result); - } - gen_case: - { - register struct Function * result; - - result = GC_NEW(struct Function); - if (result == 0) OUT_OF_MEMORY; - result->header = FN_HDR; - /* depth is already 0 */ - result->len = len; - result->fn = fn; - result->client_data = client_data; - return((CORD) result); - } -} - -size_t CORD_len(CORD x) -{ - if (x == 0) { - return(0); - } else { - return(GEN_LEN(x)); - } -} - -struct substr_args { - CordRep * sa_cord; - size_t sa_index; -}; - -char CORD_index_access_fn(size_t i, void * client_data) -{ - register struct substr_args *descr = (struct substr_args *)client_data; - - return(((char *)(descr->sa_cord))[i + descr->sa_index]); -} - -char CORD_apply_access_fn(size_t i, void * client_data) -{ - register struct substr_args *descr = (struct substr_args *)client_data; - register struct Function * fn_cord = &(descr->sa_cord->function); - - return((*(fn_cord->fn))(i + descr->sa_index, fn_cord->client_data)); -} - -/* A version of CORD_substr that simply returns a function node, thus */ -/* postponing its work. The fourth argument is a function that may */ -/* be used for efficient access to the ith character. */ -/* Assumes i >= 0 and i + n < length(x). */ -CORD CORD_substr_closure(CORD x, size_t i, size_t n, CORD_fn f) -{ - register struct substr_args * sa = GC_NEW(struct substr_args); - CORD result; - - if (sa == 0) OUT_OF_MEMORY; - sa->sa_cord = (CordRep *)x; - sa->sa_index = i; - result = CORD_from_fn(f, (void *)sa, n); - if (result == CORD_EMPTY) return CORD_EMPTY; /* n == 0 */ - ((CordRep *)result) -> function.header = SUBSTR_HDR; - return (result); -} - -# define SUBSTR_LIMIT (10 * SHORT_LIMIT) - /* Substrings of function nodes and flat strings shorter than */ - /* this are flat strings. Othewise we use a functional */ - /* representation, which is significantly slower to access. */ - -/* A version of CORD_substr that assumes i >= 0, n > 0, and i + n < length(x).*/ -CORD CORD_substr_checked(CORD x, size_t i, size_t n) -{ - if (CORD_IS_STRING(x)) { - if (n > SUBSTR_LIMIT) { - return(CORD_substr_closure(x, i, n, CORD_index_access_fn)); - } else { - register char * result = GC_MALLOC_ATOMIC(n+1); - - if (result == 0) OUT_OF_MEMORY; - strncpy(result, x+i, n); - result[n] = '\0'; - return(result); - } - } else if (IS_CONCATENATION(x)) { - register struct Concatenation * conc - = &(((CordRep *)x) -> concatenation); - register size_t left_len; - register size_t right_len; - - left_len = LEFT_LEN(conc); - right_len = conc -> len - left_len; - if (i >= left_len) { - if (n == right_len) return(conc -> right); - return(CORD_substr_checked(conc -> right, i - left_len, n)); - } else if (i+n <= left_len) { - if (n == left_len) return(conc -> left); - return(CORD_substr_checked(conc -> left, i, n)); - } else { - /* Need at least one character from each side. */ - register CORD left_part; - register CORD right_part; - register size_t left_part_len = left_len - i; - - if (i == 0) { - left_part = conc -> left; - } else { - left_part = CORD_substr_checked(conc -> left, i, left_part_len); - } - if (i + n == right_len + left_len) { - right_part = conc -> right; - } else { - right_part = CORD_substr_checked(conc -> right, 0, - n - left_part_len); - } - return(CORD_cat(left_part, right_part)); - } - } else /* function */ { - if (n > SUBSTR_LIMIT) { - if (IS_SUBSTR(x)) { - /* Avoid nesting substring nodes. */ - register struct Function * f = &(((CordRep *)x) -> function); - register struct substr_args *descr = - (struct substr_args *)(f -> client_data); - - return(CORD_substr_closure((CORD)descr->sa_cord, - i + descr->sa_index, - n, f -> fn)); - } else { - return(CORD_substr_closure(x, i, n, CORD_apply_access_fn)); - } - } else { - char * result; - register struct Function * f = &(((CordRep *)x) -> function); - char buf[SUBSTR_LIMIT+1]; - register char * p = buf; - register char c; - register int j; - register int lim = i + n; - - for (j = i; j < lim; j++) { - c = (*(f -> fn))(j, f -> client_data); - if (c == '\0') { - return(CORD_substr_closure(x, i, n, CORD_apply_access_fn)); - } - *p++ = c; - } - result = GC_MALLOC_ATOMIC(n+1); - if (result == 0) OUT_OF_MEMORY; - memcpy(result, buf, n); - result[n] = '\0'; - return(result); - } - } -} - -CORD CORD_substr(CORD x, size_t i, size_t n) -{ - register size_t len = CORD_len(x); - - if (i >= len || n <= 0) return(0); - /* n < 0 is impossible in a correct C implementation, but */ - /* quite possible under SunOS 4.X. */ - if (i + n > len) n = len - i; - return(CORD_substr_checked(x, i, n)); -} - -/* See cord.h for definition. We assume i is in range. */ -int CORD_iter5(CORD x, size_t i, CORD_iter_fn f1, - CORD_batched_iter_fn f2, void * client_data) -{ - if (x == 0) return(0); - if (CORD_IS_STRING(x)) { - register const char *p = x+i; - - if (*p == '\0') ABORT("2nd arg to CORD_iter5 too big"); - if (f2 != CORD_NO_FN) { - return((*f2)(p, client_data)); - } else { - while (*p) { - if ((*f1)(*p, client_data)) return(1); - p++; - } - return(0); - } - } else if (IS_CONCATENATION(x)) { - register struct Concatenation * conc - = &(((CordRep *)x) -> concatenation); - - - if (i > 0) { - register size_t left_len = LEFT_LEN(conc); - - if (i >= left_len) { - return(CORD_iter5(conc -> right, i - left_len, f1, f2, - client_data)); - } - } - if (CORD_iter5(conc -> left, i, f1, f2, client_data)) { - return(1); - } - return(CORD_iter5(conc -> right, 0, f1, f2, client_data)); - } else /* function */ { - register struct Function * f = &(((CordRep *)x) -> function); - register size_t j; - register size_t lim = f -> len; - - for (j = i; j < lim; j++) { - if ((*f1)((*(f -> fn))(j, f -> client_data), client_data)) { - return(1); - } - } - return(0); - } -} - -#undef CORD_iter -int CORD_iter(CORD x, CORD_iter_fn f1, void * client_data) -{ - return(CORD_iter5(x, 0, f1, CORD_NO_FN, client_data)); -} - -int CORD_riter4(CORD x, size_t i, CORD_iter_fn f1, void * client_data) -{ - if (x == 0) return(0); - if (CORD_IS_STRING(x)) { - register const char *p = x + i; - register char c; - - for(;;) { - c = *p; - if (c == '\0') ABORT("2nd arg to CORD_riter4 too big"); - if ((*f1)(c, client_data)) return(1); - if (p == x) break; - p--; - } - return(0); - } else if (IS_CONCATENATION(x)) { - register struct Concatenation * conc - = &(((CordRep *)x) -> concatenation); - register CORD left_part = conc -> left; - register size_t left_len; - - left_len = LEFT_LEN(conc); - if (i >= left_len) { - if (CORD_riter4(conc -> right, i - left_len, f1, client_data)) { - return(1); - } - return(CORD_riter4(left_part, left_len - 1, f1, client_data)); - } else { - return(CORD_riter4(left_part, i, f1, client_data)); - } - } else /* function */ { - register struct Function * f = &(((CordRep *)x) -> function); - register size_t j; - - for (j = i; ; j--) { - if ((*f1)((*(f -> fn))(j, f -> client_data), client_data)) { - return(1); - } - if (j == 0) return(0); - } - } -} - -int CORD_riter(CORD x, CORD_iter_fn f1, void * client_data) -{ - size_t len = CORD_len(x); - if (len == 0) return(0); - return(CORD_riter4(x, len - 1, f1, client_data)); -} - -/* - * The following functions are concerned with balancing cords. - * Strategy: - * Scan the cord from left to right, keeping the cord scanned so far - * as a forest of balanced trees of exponentially decreasing length. - * When a new subtree needs to be added to the forest, we concatenate all - * shorter ones to the new tree in the appropriate order, and then insert - * the result into the forest. - * Crucial invariants: - * 1. The concatenation of the forest (in decreasing order) with the - * unscanned part of the rope is equal to the rope being balanced. - * 2. All trees in the forest are balanced. - * 3. forest[i] has depth at most i. - */ - -typedef struct { - CORD c; - size_t len; /* Actual length of c */ -} ForestElement; - -static size_t min_len [ MAX_DEPTH ]; - -static int min_len_init = 0; - -int CORD_max_len; - -typedef ForestElement Forest [ MAX_DEPTH ]; - /* forest[i].len >= fib(i+1) */ - /* The string is the concatenation */ - /* of the forest in order of DECREASING */ - /* indices. */ - -void CORD_init_min_len(void) -{ - register int i; - register size_t last, previous, current; - - min_len[0] = previous = 1; - min_len[1] = last = 2; - for (i = 2; i < MAX_DEPTH; i++) { - current = last + previous; - if (current < last) /* overflow */ current = last; - min_len[i] = current; - previous = last; - last = current; - } - CORD_max_len = last - 1; - min_len_init = 1; -} - - -void CORD_init_forest(ForestElement * forest, size_t max_len) -{ - register int i; - - for (i = 0; i < MAX_DEPTH; i++) { - forest[i].c = 0; - if (min_len[i] > max_len) return; - } - ABORT("Cord too long"); -} - -/* Add a leaf to the appropriate level in the forest, cleaning */ -/* out lower levels as necessary. */ -/* Also works if x is a balanced tree of concatenations; however */ -/* in this case an extra concatenation node may be inserted above x; */ -/* This node should not be counted in the statement of the invariants. */ -void CORD_add_forest(ForestElement * forest, CORD x, size_t len) -{ - register int i = 0; - register CORD sum = CORD_EMPTY; - register size_t sum_len = 0; - - while (len > min_len[i + 1]) { - if (forest[i].c != 0) { - sum = CORD_cat(forest[i].c, sum); - sum_len += forest[i].len; - forest[i].c = 0; - } - i++; - } - /* Sum has depth at most 1 greter than what would be required */ - /* for balance. */ - sum = CORD_cat(sum, x); - sum_len += len; - /* If x was a leaf, then sum is now balanced. To see this */ - /* consider the two cases in which forest[i-1] either is or is */ - /* not empty. */ - while (sum_len >= min_len[i]) { - if (forest[i].c != 0) { - sum = CORD_cat(forest[i].c, sum); - sum_len += forest[i].len; - /* This is again balanced, since sum was balanced, and has */ - /* allowable depth that differs from i by at most 1. */ - forest[i].c = 0; - } - i++; - } - i--; - forest[i].c = sum; - forest[i].len = sum_len; -} - -CORD CORD_concat_forest(ForestElement * forest, size_t expected_len) -{ - register int i = 0; - CORD sum = 0; - size_t sum_len = 0; - - while (sum_len != expected_len) { - if (forest[i].c != 0) { - sum = CORD_cat(forest[i].c, sum); - sum_len += forest[i].len; - } - i++; - } - return(sum); -} - -/* Insert the frontier of x into forest. Balanced subtrees are */ -/* treated as leaves. This potentially adds one to the depth */ -/* of the final tree. */ -void CORD_balance_insert(CORD x, size_t len, ForestElement * forest) -{ - register int depth; - - if (CORD_IS_STRING(x)) { - CORD_add_forest(forest, x, len); - } else if (IS_CONCATENATION(x) - && ((depth = DEPTH(x)) >= MAX_DEPTH - || len < min_len[depth])) { - register struct Concatenation * conc - = &(((CordRep *)x) -> concatenation); - size_t left_len = LEFT_LEN(conc); - - CORD_balance_insert(conc -> left, left_len, forest); - CORD_balance_insert(conc -> right, len - left_len, forest); - } else /* function or balanced */ { - CORD_add_forest(forest, x, len); - } -} - - -CORD CORD_balance(CORD x) -{ - Forest forest; - register size_t len; - - if (x == 0) return(0); - if (CORD_IS_STRING(x)) return(x); - if (!min_len_init) CORD_init_min_len(); - len = LEN(x); - CORD_init_forest(forest, len); - CORD_balance_insert(x, len, forest); - return(CORD_concat_forest(forest, len)); -} - - -/* Position primitives */ - -/* Private routines to deal with the hard cases only: */ - -/* P contains a prefix of the path to cur_pos. Extend it to a full */ -/* path and set up leaf info. */ -/* Return 0 if past the end of cord, 1 o.w. */ -void CORD__extend_path(register CORD_pos p) -{ - register struct CORD_pe * current_pe = &(p[0].path[p[0].path_len]); - register CORD top = current_pe -> pe_cord; - register size_t pos = p[0].cur_pos; - register size_t top_pos = current_pe -> pe_start_pos; - register size_t top_len = GEN_LEN(top); - - /* Fill in the rest of the path. */ - while(!CORD_IS_STRING(top) && IS_CONCATENATION(top)) { - register struct Concatenation * conc = - &(((CordRep *)top) -> concatenation); - register size_t left_len; - - left_len = LEFT_LEN(conc); - current_pe++; - if (pos >= top_pos + left_len) { - current_pe -> pe_cord = top = conc -> right; - current_pe -> pe_start_pos = top_pos = top_pos + left_len; - top_len -= left_len; - } else { - current_pe -> pe_cord = top = conc -> left; - current_pe -> pe_start_pos = top_pos; - top_len = left_len; - } - p[0].path_len++; - } - /* Fill in leaf description for fast access. */ - if (CORD_IS_STRING(top)) { - p[0].cur_leaf = top; - p[0].cur_start = top_pos; - p[0].cur_end = top_pos + top_len; - } else { - p[0].cur_end = 0; - } - if (pos >= top_pos + top_len) p[0].path_len = CORD_POS_INVALID; -} - -char CORD__pos_fetch(register CORD_pos p) -{ - /* Leaf is a function node */ - struct CORD_pe * pe = &((p)[0].path[(p)[0].path_len]); - CORD leaf = pe -> pe_cord; - register struct Function * f = &(((CordRep *)leaf) -> function); - - if (!IS_FUNCTION(leaf)) ABORT("CORD_pos_fetch: bad leaf"); - return ((*(f -> fn))(p[0].cur_pos - pe -> pe_start_pos, f -> client_data)); -} - -void CORD__next(register CORD_pos p) -{ - register size_t cur_pos = p[0].cur_pos + 1; - register struct CORD_pe * current_pe = &((p)[0].path[(p)[0].path_len]); - register CORD leaf = current_pe -> pe_cord; - - /* Leaf is not a string or we're at end of leaf */ - p[0].cur_pos = cur_pos; - if (!CORD_IS_STRING(leaf)) { - /* Function leaf */ - register struct Function * f = &(((CordRep *)leaf) -> function); - register size_t start_pos = current_pe -> pe_start_pos; - register size_t end_pos = start_pos + f -> len; - - if (cur_pos < end_pos) { - /* Fill cache and return. */ - register size_t i; - register size_t limit = cur_pos + FUNCTION_BUF_SZ; - register CORD_fn fn = f -> fn; - register void * client_data = f -> client_data; - - if (limit > end_pos) { - limit = end_pos; - } - for (i = cur_pos; i < limit; i++) { - p[0].function_buf[i - cur_pos] = - (*fn)(i - start_pos, client_data); - } - p[0].cur_start = cur_pos; - p[0].cur_leaf = p[0].function_buf; - p[0].cur_end = limit; - return; - } - } - /* End of leaf */ - /* Pop the stack until we find two concatenation nodes with the */ - /* same start position: this implies we were in left part. */ - { - while (p[0].path_len > 0 - && current_pe[0].pe_start_pos != current_pe[-1].pe_start_pos) { - p[0].path_len--; - current_pe--; - } - if (p[0].path_len == 0) { - p[0].path_len = CORD_POS_INVALID; - return; - } - } - p[0].path_len--; - CORD__extend_path(p); -} - -void CORD__prev(register CORD_pos p) -{ - register struct CORD_pe * pe = &(p[0].path[p[0].path_len]); - - if (p[0].cur_pos == 0) { - p[0].path_len = CORD_POS_INVALID; - return; - } - p[0].cur_pos--; - if (p[0].cur_pos >= pe -> pe_start_pos) return; - - /* Beginning of leaf */ - - /* Pop the stack until we find two concatenation nodes with the */ - /* different start position: this implies we were in right part. */ - { - register struct CORD_pe * current_pe = &((p)[0].path[(p)[0].path_len]); - - while (p[0].path_len > 0 - && current_pe[0].pe_start_pos == current_pe[-1].pe_start_pos) { - p[0].path_len--; - current_pe--; - } - } - p[0].path_len--; - CORD__extend_path(p); -} - -#undef CORD_pos_fetch -#undef CORD_next -#undef CORD_prev -#undef CORD_pos_to_index -#undef CORD_pos_to_cord -#undef CORD_pos_valid - -char CORD_pos_fetch(register CORD_pos p) -{ - if (p[0].cur_start <= p[0].cur_pos && p[0].cur_pos < p[0].cur_end) { - return(p[0].cur_leaf[p[0].cur_pos - p[0].cur_start]); - } else { - return(CORD__pos_fetch(p)); - } -} - -void CORD_next(CORD_pos p) -{ - if (p[0].cur_pos < p[0].cur_end - 1) { - p[0].cur_pos++; - } else { - CORD__next(p); - } -} - -void CORD_prev(CORD_pos p) -{ - if (p[0].cur_end != 0 && p[0].cur_pos > p[0].cur_start) { - p[0].cur_pos--; - } else { - CORD__prev(p); - } -} - -size_t CORD_pos_to_index(CORD_pos p) -{ - return(p[0].cur_pos); -} - -CORD CORD_pos_to_cord(CORD_pos p) -{ - return(p[0].path[0].pe_cord); -} - -int CORD_pos_valid(CORD_pos p) -{ - return(p[0].path_len != CORD_POS_INVALID); -} - -void CORD_set_pos(CORD_pos p, CORD x, size_t i) -{ - if (x == CORD_EMPTY) { - p[0].path_len = CORD_POS_INVALID; - return; - } - p[0].path[0].pe_cord = x; - p[0].path[0].pe_start_pos = 0; - p[0].path_len = 0; - p[0].cur_pos = i; - CORD__extend_path(p); -} diff -Nru ecl-16.1.2/src/bdwgc/cord/cordprnt.c ecl-16.1.3+ds/src/bdwgc/cord/cordprnt.c --- ecl-16.1.2/src/bdwgc/cord/cordprnt.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/cord/cordprnt.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,413 +0,0 @@ -/* - * Copyright (c) 1993-1994 by Xerox Corporation. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ -/* An sprintf implementation that understands cords. This is probably */ -/* not terribly portable. It assumes an ANSI stdarg.h. It further */ -/* assumes that I can make copies of va_list variables, and read */ -/* arguments repeatedly by applying va_arg to the copies. This */ -/* could be avoided at some performance cost. */ -/* We also assume that unsigned and signed integers of various kinds */ -/* have the same sizes, and can be cast back and forth. */ -/* We assume that void * and char * have the same size. */ -/* All this cruft is needed because we want to rely on the underlying */ -/* sprintf implementation whenever possible. */ - -#ifdef HAVE_CONFIG_H -# include "config.h" -#endif -#ifndef CORD_BUILD -# define CORD_BUILD -#endif - -#include "cord.h" -#include "ec.h" -#include -#include -#include -#include "gc.h" - -#define CONV_SPEC_LEN 50 /* Maximum length of a single */ - /* conversion specification. */ -#define CONV_RESULT_LEN 50 /* Maximum length of any */ - /* conversion with default */ - /* width and prec. */ - - -static int ec_len(CORD_ec x) -{ - return(CORD_len(x[0].ec_cord) + (x[0].ec_bufptr - x[0].ec_buf)); -} - -/* Possible nonumeric precision values. */ -# define NONE -1 -# define VARIABLE -2 -/* Copy the conversion specification from CORD_pos into the buffer buf */ -/* Return negative on error. */ -/* Source initially points one past the leading %. */ -/* It is left pointing at the conversion type. */ -/* Assign field width and precision to *width and *prec. */ -/* If width or prec is *, VARIABLE is assigned. */ -/* Set *left to 1 if left adjustment flag is present. */ -/* Set *long_arg to 1 if long flag ('l' or 'L') is present, or to */ -/* -1 if 'h' is present. */ -static int extract_conv_spec(CORD_pos source, char *buf, - int * width, int *prec, int *left, int * long_arg) -{ - register int result = 0; - register int current_number = 0; - register int saw_period = 0; - register int saw_number = 0; - register int chars_so_far = 0; - register char current; - - *width = NONE; - buf[chars_so_far++] = '%'; - while(CORD_pos_valid(source)) { - if (chars_so_far >= CONV_SPEC_LEN) return(-1); - current = CORD_pos_fetch(source); - buf[chars_so_far++] = current; - switch(current) { - case '*': - saw_number = 1; - current_number = VARIABLE; - break; - case '0': - if (!saw_number) { - /* Zero fill flag; ignore */ - break; - } /* otherwise fall through: */ - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - case '8': - case '9': - saw_number = 1; - current_number *= 10; - current_number += current - '0'; - break; - case '.': - saw_period = 1; - if(saw_number) { - *width = current_number; - saw_number = 0; - } - current_number = 0; - break; - case 'l': - case 'L': - *long_arg = 1; - current_number = 0; - break; - case 'h': - *long_arg = -1; - current_number = 0; - break; - case ' ': - case '+': - case '#': - current_number = 0; - break; - case '-': - *left = 1; - current_number = 0; - break; - case 'd': - case 'i': - case 'o': - case 'u': - case 'x': - case 'X': - case 'f': - case 'e': - case 'E': - case 'g': - case 'G': - case 'c': - case 'C': - case 's': - case 'S': - case 'p': - case 'n': - case 'r': - goto done; - default: - return(-1); - } - CORD_next(source); - } - return(-1); - done: - if (saw_number) { - if (saw_period) { - *prec = current_number; - } else { - *prec = NONE; - *width = current_number; - } - } else { - *prec = NONE; - } - buf[chars_so_far] = '\0'; - return(result); -} - -int CORD_vsprintf(CORD * out, CORD format, va_list args) -{ - CORD_ec result; - register int count; - register char current; - CORD_pos pos; - char conv_spec[CONV_SPEC_LEN + 1]; - - CORD_ec_init(result); - for (CORD_set_pos(pos, format, 0); CORD_pos_valid(pos); CORD_next(pos)) { - current = CORD_pos_fetch(pos); - if (current == '%') { - CORD_next(pos); - if (!CORD_pos_valid(pos)) return(-1); - current = CORD_pos_fetch(pos); - if (current == '%') { - CORD_ec_append(result, current); - } else { - int width, prec; - int left_adj = 0; - int long_arg = 0; - CORD arg; - size_t len; - - if (extract_conv_spec(pos, conv_spec, - &width, &prec, - &left_adj, &long_arg) < 0) { - return(-1); - } - current = CORD_pos_fetch(pos); - switch(current) { - case 'n': - /* Assign length to next arg */ - if (long_arg == 0) { - int * pos_ptr; - pos_ptr = va_arg(args, int *); - *pos_ptr = ec_len(result); - } else if (long_arg > 0) { - long * pos_ptr; - pos_ptr = va_arg(args, long *); - *pos_ptr = ec_len(result); - } else { - short * pos_ptr; - pos_ptr = va_arg(args, short *); - *pos_ptr = ec_len(result); - } - goto done; - case 'r': - /* Append cord and any padding */ - if (width == VARIABLE) width = va_arg(args, int); - if (prec == VARIABLE) prec = va_arg(args, int); - arg = va_arg(args, CORD); - len = CORD_len(arg); - if (prec != NONE && len > (size_t)prec) { - if (prec < 0) return(-1); - arg = CORD_substr(arg, 0, prec); - len = prec; - } - if (width != NONE && len < (size_t)width) { - char * blanks = GC_MALLOC_ATOMIC(width-len+1); - - memset(blanks, ' ', width-len); - blanks[width-len] = '\0'; - if (left_adj) { - arg = CORD_cat(arg, blanks); - } else { - arg = CORD_cat(blanks, arg); - } - } - CORD_ec_append_cord(result, arg); - goto done; - case 'c': - if (width == NONE && prec == NONE) { - register char c; - - c = (char)va_arg(args, int); - CORD_ec_append(result, c); - goto done; - } - break; - case 's': - if (width == NONE && prec == NONE) { - char * str = va_arg(args, char *); - register char c; - - while ((c = *str++)) { - CORD_ec_append(result, c); - } - goto done; - } - break; - default: - break; - } - /* Use standard sprintf to perform conversion */ - { - register char * buf; - va_list vsprintf_args; - int max_size = 0; - int res; -# ifdef __va_copy - __va_copy(vsprintf_args, args); -# else -# if defined(__GNUC__) && !defined(__DJGPP__) \ - && !defined(__EMX__) /* and probably in other cases */ - va_copy(vsprintf_args, args); -# else - vsprintf_args = args; -# endif -# endif - if (width == VARIABLE) width = va_arg(args, int); - if (prec == VARIABLE) prec = va_arg(args, int); - if (width != NONE) max_size = width; - if (prec != NONE && prec > max_size) max_size = prec; - max_size += CONV_RESULT_LEN; - if (max_size >= CORD_BUFSZ) { - buf = GC_MALLOC_ATOMIC(max_size + 1); - } else { - if (CORD_BUFSZ - (result[0].ec_bufptr-result[0].ec_buf) - < max_size) { - CORD_ec_flush_buf(result); - } - buf = result[0].ec_bufptr; - } - switch(current) { - case 'd': - case 'i': - case 'o': - case 'u': - case 'x': - case 'X': - case 'c': - if (long_arg <= 0) { - (void) va_arg(args, int); - } else if (long_arg > 0) { - (void) va_arg(args, long); - } - break; - case 's': - case 'p': - (void) va_arg(args, char *); - break; - case 'f': - case 'e': - case 'E': - case 'g': - case 'G': - (void) va_arg(args, double); - break; - default: -# if defined(__va_copy) \ - || (defined(__GNUC__) && !defined(__DJGPP__) \ - && !defined(__EMX__)) - va_end(vsprintf_args); -# endif - return(-1); - } - res = vsprintf(buf, conv_spec, vsprintf_args); -# if defined(__va_copy) \ - || (defined(__GNUC__) && !defined(__DJGPP__) \ - && !defined(__EMX__)) - va_end(vsprintf_args); -# endif - len = (size_t)res; - if ((char *)(GC_word)res == buf) { - /* old style vsprintf */ - len = strlen(buf); - } else if (res < 0) { - return(-1); - } - if (buf != result[0].ec_bufptr) { - register char c; - - while ((c = *buf++)) { - CORD_ec_append(result, c); - } - } else { - result[0].ec_bufptr = buf + len; - } - } - done:; - } - } else { - CORD_ec_append(result, current); - } - } - count = ec_len(result); - *out = CORD_balance(CORD_ec_to_cord(result)); - return(count); -} - -int CORD_sprintf(CORD * out, CORD format, ...) -{ - va_list args; - int result; - - va_start(args, format); - result = CORD_vsprintf(out, format, args); - va_end(args); - return(result); -} - -int CORD_fprintf(FILE * f, CORD format, ...) -{ - va_list args; - int result; - CORD out = CORD_EMPTY; /* initialized to prevent compiler warning */ - - va_start(args, format); - result = CORD_vsprintf(&out, format, args); - va_end(args); - if (result > 0) CORD_put(out, f); - return(result); -} - -int CORD_vfprintf(FILE * f, CORD format, va_list args) -{ - int result; - CORD out = CORD_EMPTY; - - result = CORD_vsprintf(&out, format, args); - if (result > 0) CORD_put(out, f); - return(result); -} - -int CORD_printf(CORD format, ...) -{ - va_list args; - int result; - CORD out = CORD_EMPTY; - - va_start(args, format); - result = CORD_vsprintf(&out, format, args); - va_end(args); - if (result > 0) CORD_put(out, stdout); - return(result); -} - -int CORD_vprintf(CORD format, va_list args) -{ - int result; - CORD out = CORD_EMPTY; - - result = CORD_vsprintf(&out, format, args); - if (result > 0) CORD_put(out, stdout); - return(result); -} diff -Nru ecl-16.1.2/src/bdwgc/cord/cordxtra.c ecl-16.1.3+ds/src/bdwgc/cord/cordxtra.c --- ecl-16.1.2/src/bdwgc/cord/cordxtra.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/cord/cordxtra.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,635 +0,0 @@ -/* - * Copyright (c) 1993-1994 by Xerox Corporation. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -/* - * These are functions on cords that do not need to understand their - * implementation. They serve also serve as example client code for - * cord_basics. - */ - -#ifdef HAVE_CONFIG_H -# include "config.h" -#endif -#ifndef CORD_BUILD -# define CORD_BUILD -#endif - -# include -# include -# include -# include - -# include "cord.h" -# include "ec.h" - -# define I_HIDE_POINTERS /* So we get access to allocation lock. */ - /* We use this for lazy file reading, */ - /* so that we remain independent */ - /* of the threads primitives. */ -# include "gc.h" - -/* For now we assume that pointer reads and writes are atomic, */ -/* i.e. another thread always sees the state before or after */ -/* a write. This might be false on a Motorola M68K with */ -/* pointers that are not 32-bit aligned. But there probably */ -/* aren't too many threads packages running on those. */ -# define ATOMIC_WRITE(x,y) (x) = (y) -# define ATOMIC_READ(x) (*(x)) - -/* The standard says these are in stdio.h, but they aren't always: */ -# ifndef SEEK_SET -# define SEEK_SET 0 -# endif -# ifndef SEEK_END -# define SEEK_END 2 -# endif - -# define BUFSZ 2048 /* Size of stack allocated buffers when */ - /* we want large buffers. */ - -typedef void (* oom_fn)(void); - -# define OUT_OF_MEMORY { if (CORD_oom_fn != (oom_fn) 0) (*CORD_oom_fn)(); \ - ABORT("Out of memory\n"); } -# define ABORT(msg) { fprintf(stderr, "%s\n", msg); abort(); } - -#if __GNUC__ > 3 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 4) -# define CORD_ATTR_UNUSED __attribute__((__unused__)) -#else -# define CORD_ATTR_UNUSED /* empty */ -#endif - -CORD CORD_cat_char(CORD x, char c) -{ - register char * string; - - if (c == '\0') return(CORD_cat(x, CORD_nul(1))); - string = GC_MALLOC_ATOMIC(2); - if (string == 0) OUT_OF_MEMORY; - string[0] = c; - string[1] = '\0'; - return(CORD_cat_char_star(x, string, 1)); -} - -CORD CORD_catn(int nargs, ...) -{ - register CORD result = CORD_EMPTY; - va_list args; - register int i; - - va_start(args, nargs); - for (i = 0; i < nargs; i++) { - register CORD next = va_arg(args, CORD); - result = CORD_cat(result, next); - } - va_end(args); - return(result); -} - -typedef struct { - size_t len; - size_t count; - char * buf; -} CORD_fill_data; - -int CORD_fill_proc(char c, void * client_data) -{ - register CORD_fill_data * d = (CORD_fill_data *)client_data; - register size_t count = d -> count; - - (d -> buf)[count] = c; - d -> count = ++count; - if (count >= d -> len) { - return(1); - } else { - return(0); - } -} - -int CORD_batched_fill_proc(const char * s, void * client_data) -{ - register CORD_fill_data * d = (CORD_fill_data *)client_data; - register size_t count = d -> count; - register size_t max = d -> len; - register char * buf = d -> buf; - register const char * t = s; - - while((buf[count] = *t++) != '\0') { - count++; - if (count >= max) { - d -> count = count; - return(1); - } - } - d -> count = count; - return(0); -} - -/* Fill buf with len characters starting at i. */ -/* Assumes len characters are available. */ -void CORD_fill_buf(CORD x, size_t i, size_t len, char * buf) -{ - CORD_fill_data fd; - - fd.len = len; - fd.buf = buf; - fd.count = 0; - (void)CORD_iter5(x, i, CORD_fill_proc, CORD_batched_fill_proc, &fd); -} - -int CORD_cmp(CORD x, CORD y) -{ - CORD_pos xpos; - CORD_pos ypos; - register size_t avail, yavail; - - if (y == CORD_EMPTY) return(x != CORD_EMPTY); - if (x == CORD_EMPTY) return(-1); - if (CORD_IS_STRING(y) && CORD_IS_STRING(x)) return(strcmp(x,y)); - CORD_set_pos(xpos, x, 0); - CORD_set_pos(ypos, y, 0); - for(;;) { - if (!CORD_pos_valid(xpos)) { - if (CORD_pos_valid(ypos)) { - return(-1); - } else { - return(0); - } - } - if (!CORD_pos_valid(ypos)) { - return(1); - } - if ((avail = CORD_pos_chars_left(xpos)) <= 0 - || (yavail = CORD_pos_chars_left(ypos)) <= 0) { - register char xcurrent = CORD_pos_fetch(xpos); - register char ycurrent = CORD_pos_fetch(ypos); - if (xcurrent != ycurrent) return(xcurrent - ycurrent); - CORD_next(xpos); - CORD_next(ypos); - } else { - /* process as many characters as we can */ - register int result; - - if (avail > yavail) avail = yavail; - result = strncmp(CORD_pos_cur_char_addr(xpos), - CORD_pos_cur_char_addr(ypos), avail); - if (result != 0) return(result); - CORD_pos_advance(xpos, avail); - CORD_pos_advance(ypos, avail); - } - } -} - -int CORD_ncmp(CORD x, size_t x_start, CORD y, size_t y_start, size_t len) -{ - CORD_pos xpos; - CORD_pos ypos; - register size_t count; - register long avail, yavail; - - CORD_set_pos(xpos, x, x_start); - CORD_set_pos(ypos, y, y_start); - for(count = 0; count < len;) { - if (!CORD_pos_valid(xpos)) { - if (CORD_pos_valid(ypos)) { - return(-1); - } else { - return(0); - } - } - if (!CORD_pos_valid(ypos)) { - return(1); - } - if ((avail = CORD_pos_chars_left(xpos)) <= 0 - || (yavail = CORD_pos_chars_left(ypos)) <= 0) { - register char xcurrent = CORD_pos_fetch(xpos); - register char ycurrent = CORD_pos_fetch(ypos); - if (xcurrent != ycurrent) return(xcurrent - ycurrent); - CORD_next(xpos); - CORD_next(ypos); - count++; - } else { - /* process as many characters as we can */ - register int result; - - if (avail > yavail) avail = yavail; - count += avail; - if (count > len) avail -= (count - len); - result = strncmp(CORD_pos_cur_char_addr(xpos), - CORD_pos_cur_char_addr(ypos), (size_t)avail); - if (result != 0) return(result); - CORD_pos_advance(xpos, (size_t)avail); - CORD_pos_advance(ypos, (size_t)avail); - } - } - return(0); -} - -char * CORD_to_char_star(CORD x) -{ - register size_t len = CORD_len(x); - char * result = GC_MALLOC_ATOMIC(len + 1); - - if (result == 0) OUT_OF_MEMORY; - CORD_fill_buf(x, 0, len, result); - result[len] = '\0'; - return(result); -} - -CORD CORD_from_char_star(const char *s) -{ - char * result; - size_t len = strlen(s); - - if (0 == len) return(CORD_EMPTY); - result = GC_MALLOC_ATOMIC(len + 1); - if (result == 0) OUT_OF_MEMORY; - memcpy(result, s, len+1); - return(result); -} - -const char * CORD_to_const_char_star(CORD x) -{ - if (x == 0) return(""); - if (CORD_IS_STRING(x)) return((const char *)x); - return(CORD_to_char_star(x)); -} - -char CORD_fetch(CORD x, size_t i) -{ - CORD_pos xpos; - - CORD_set_pos(xpos, x, i); - if (!CORD_pos_valid(xpos)) ABORT("bad index?"); - return(CORD_pos_fetch(xpos)); -} - - -int CORD_put_proc(char c, void * client_data) -{ - register FILE * f = (FILE *)client_data; - - return(putc(c, f) == EOF); -} - -int CORD_batched_put_proc(const char * s, void * client_data) -{ - register FILE * f = (FILE *)client_data; - - return(fputs(s, f) == EOF); -} - - -int CORD_put(CORD x, FILE * f) -{ - if (CORD_iter5(x, 0, CORD_put_proc, CORD_batched_put_proc, f)) { - return(EOF); - } else { - return(1); - } -} - -typedef struct { - size_t pos; /* Current position in the cord */ - char target; /* Character we're looking for */ -} chr_data; - -int CORD_chr_proc(char c, void * client_data) -{ - register chr_data * d = (chr_data *)client_data; - - if (c == d -> target) return(1); - (d -> pos) ++; - return(0); -} - -int CORD_rchr_proc(char c, void * client_data) -{ - register chr_data * d = (chr_data *)client_data; - - if (c == d -> target) return(1); - (d -> pos) --; - return(0); -} - -int CORD_batched_chr_proc(const char *s, void * client_data) -{ - register chr_data * d = (chr_data *)client_data; - register char * occ = strchr(s, d -> target); - - if (occ == 0) { - d -> pos += strlen(s); - return(0); - } else { - d -> pos += occ - s; - return(1); - } -} - -size_t CORD_chr(CORD x, size_t i, int c) -{ - chr_data d; - - d.pos = i; - d.target = c; - if (CORD_iter5(x, i, CORD_chr_proc, CORD_batched_chr_proc, &d)) { - return(d.pos); - } else { - return(CORD_NOT_FOUND); - } -} - -size_t CORD_rchr(CORD x, size_t i, int c) -{ - chr_data d; - - d.pos = i; - d.target = c; - if (CORD_riter4(x, i, CORD_rchr_proc, &d)) { - return(d.pos); - } else { - return(CORD_NOT_FOUND); - } -} - -/* Find the first occurrence of s in x at position start or later. */ -/* This uses an asymptotically poor algorithm, which should typically */ -/* perform acceptably. We compare the first few characters directly, */ -/* and call CORD_ncmp whenever there is a partial match. */ -/* This has the advantage that we allocate very little, or not at all. */ -/* It's very fast if there are few close misses. */ -size_t CORD_str(CORD x, size_t start, CORD s) -{ - CORD_pos xpos; - size_t xlen = CORD_len(x); - size_t slen; - register size_t start_len; - const char * s_start; - unsigned long s_buf = 0; /* The first few characters of s */ - unsigned long x_buf = 0; /* Start of candidate substring. */ - /* Initialized only to make compilers */ - /* happy. */ - unsigned long mask = 0; - register size_t i; - register size_t match_pos; - - if (s == CORD_EMPTY) return(start); - if (CORD_IS_STRING(s)) { - s_start = s; - slen = strlen(s); - } else { - s_start = CORD_to_char_star(CORD_substr(s, 0, sizeof(unsigned long))); - slen = CORD_len(s); - } - if (xlen < start || xlen - start < slen) return(CORD_NOT_FOUND); - start_len = slen; - if (start_len > sizeof(unsigned long)) start_len = sizeof(unsigned long); - CORD_set_pos(xpos, x, start); - for (i = 0; i < start_len; i++) { - mask <<= 8; - mask |= 0xff; - s_buf <<= 8; - s_buf |= (unsigned char)s_start[i]; - x_buf <<= 8; - x_buf |= (unsigned char)CORD_pos_fetch(xpos); - CORD_next(xpos); - } - for (match_pos = start; ; match_pos++) { - if ((x_buf & mask) == s_buf) { - if (slen == start_len || - CORD_ncmp(x, match_pos + start_len, - s, start_len, slen - start_len) == 0) { - return(match_pos); - } - } - if ( match_pos == xlen - slen ) { - return(CORD_NOT_FOUND); - } - x_buf <<= 8; - x_buf |= (unsigned char)CORD_pos_fetch(xpos); - CORD_next(xpos); - } -} - -void CORD_ec_flush_buf(CORD_ec x) -{ - register size_t len = x[0].ec_bufptr - x[0].ec_buf; - char * s; - - if (len == 0) return; - s = GC_MALLOC_ATOMIC(len+1); - memcpy(s, x[0].ec_buf, len); - s[len] = '\0'; - x[0].ec_cord = CORD_cat_char_star(x[0].ec_cord, s, len); - x[0].ec_bufptr = x[0].ec_buf; -} - -void CORD_ec_append_cord(CORD_ec x, CORD s) -{ - CORD_ec_flush_buf(x); - x[0].ec_cord = CORD_cat(x[0].ec_cord, s); -} - -char CORD_nul_func(size_t i CORD_ATTR_UNUSED, void * client_data) -{ - return((char)(unsigned long)client_data); -} - - -CORD CORD_chars(char c, size_t i) -{ - return(CORD_from_fn(CORD_nul_func, (void *)(unsigned long)c, i)); -} - -CORD CORD_from_file_eager(FILE * f) -{ - register int c; - CORD_ec ecord; - - CORD_ec_init(ecord); - for(;;) { - c = getc(f); - if (c == 0) { - /* Append the right number of NULs */ - /* Note that any string of NULs is represented in 4 words, */ - /* independent of its length. */ - register size_t count = 1; - - CORD_ec_flush_buf(ecord); - while ((c = getc(f)) == 0) count++; - ecord[0].ec_cord = CORD_cat(ecord[0].ec_cord, CORD_nul(count)); - } - if (c == EOF) break; - CORD_ec_append(ecord, c); - } - (void) fclose(f); - return(CORD_balance(CORD_ec_to_cord(ecord))); -} - -/* The state maintained for a lazily read file consists primarily */ -/* of a large direct-mapped cache of previously read values. */ -/* We could rely more on stdio buffering. That would have 2 */ -/* disadvantages: */ -/* 1) Empirically, not all fseek implementations preserve the */ -/* buffer whenever they could. */ -/* 2) It would fail if 2 different sections of a long cord */ -/* were being read alternately. */ -/* We do use the stdio buffer for read ahead. */ -/* To guarantee thread safety in the presence of atomic pointer */ -/* writes, cache lines are always replaced, and never modified in */ -/* place. */ - -# define LOG_CACHE_SZ 14 -# define CACHE_SZ (1 << LOG_CACHE_SZ) -# define LOG_LINE_SZ 9 -# define LINE_SZ (1 << LOG_LINE_SZ) - -typedef struct { - size_t tag; - char data[LINE_SZ]; - /* data[i%LINE_SZ] = ith char in file if tag = i/LINE_SZ */ -} cache_line; - -typedef struct { - FILE * lf_file; - size_t lf_current; /* Current file pointer value */ - cache_line * volatile lf_cache[CACHE_SZ/LINE_SZ]; -} lf_state; - -# define MOD_CACHE_SZ(n) ((n) & (CACHE_SZ - 1)) -# define DIV_CACHE_SZ(n) ((n) >> LOG_CACHE_SZ) -# define MOD_LINE_SZ(n) ((n) & (LINE_SZ - 1)) -# define DIV_LINE_SZ(n) ((n) >> LOG_LINE_SZ) -# define LINE_START(n) ((n) & ~(LINE_SZ - 1)) - -typedef struct { - lf_state * state; - size_t file_pos; /* Position of needed character. */ - cache_line * new_cache; -} refill_data; - -/* Executed with allocation lock. */ -static char refill_cache(refill_data * client_data) -{ - register lf_state * state = client_data -> state; - register size_t file_pos = client_data -> file_pos; - FILE *f = state -> lf_file; - size_t line_start = LINE_START(file_pos); - size_t line_no = DIV_LINE_SZ(MOD_CACHE_SZ(file_pos)); - cache_line * new_cache = client_data -> new_cache; - - if (line_start != state -> lf_current - && fseek(f, line_start, SEEK_SET) != 0) { - ABORT("fseek failed"); - } - if (fread(new_cache -> data, sizeof(char), LINE_SZ, f) - <= file_pos - line_start) { - ABORT("fread failed"); - } - new_cache -> tag = DIV_LINE_SZ(file_pos); - /* Store barrier goes here. */ - ATOMIC_WRITE(state -> lf_cache[line_no], new_cache); - state -> lf_current = line_start + LINE_SZ; - return(new_cache->data[MOD_LINE_SZ(file_pos)]); -} - -char CORD_lf_func(size_t i, void * client_data) -{ - register lf_state * state = (lf_state *)client_data; - register cache_line * volatile * cl_addr = - &(state -> lf_cache[DIV_LINE_SZ(MOD_CACHE_SZ(i))]); - register cache_line * cl = (cache_line *)ATOMIC_READ(cl_addr); - - if (cl == 0 || cl -> tag != DIV_LINE_SZ(i)) { - /* Cache miss */ - refill_data rd; - - rd.state = state; - rd.file_pos = i; - rd.new_cache = GC_NEW_ATOMIC(cache_line); - if (rd.new_cache == 0) OUT_OF_MEMORY; - return((char)(GC_word) - GC_call_with_alloc_lock((GC_fn_type) refill_cache, &rd)); - } - return(cl -> data[MOD_LINE_SZ(i)]); -} - -void CORD_lf_close_proc(void * obj, void * client_data CORD_ATTR_UNUSED) -{ - if (fclose(((lf_state *)obj) -> lf_file) != 0) { - ABORT("CORD_lf_close_proc: fclose failed"); - } -} - -CORD CORD_from_file_lazy_inner(FILE * f, size_t len) -{ - register lf_state * state = GC_NEW(lf_state); - register int i; - - if (state == 0) OUT_OF_MEMORY; - if (len != 0) { - /* Dummy read to force buffer allocation. */ - /* This greatly increases the probability */ - /* of avoiding deadlock if buffer allocation */ - /* is redirected to GC_malloc and the */ - /* world is multi-threaded. */ - char buf[1]; - - if (fread(buf, 1, 1, f) > 1) { - /* Just to suppress "unused result" compiler warning. */ - ABORT("fread unexpected result"); - } - rewind(f); - } - state -> lf_file = f; - for (i = 0; i < CACHE_SZ/LINE_SZ; i++) { - state -> lf_cache[i] = 0; - } - state -> lf_current = 0; - GC_REGISTER_FINALIZER(state, CORD_lf_close_proc, 0, 0, 0); - return(CORD_from_fn(CORD_lf_func, state, len)); -} - -CORD CORD_from_file_lazy(FILE * f) -{ - register long len; - - if (fseek(f, 0l, SEEK_END) != 0) { - ABORT("Bad fd argument - fseek failed"); - } - if ((len = ftell(f)) < 0) { - ABORT("Bad fd argument - ftell failed"); - } - rewind(f); - return(CORD_from_file_lazy_inner(f, (size_t)len)); -} - -# define LAZY_THRESHOLD (128*1024 + 1) - -CORD CORD_from_file(FILE * f) -{ - register long len; - - if (fseek(f, 0l, SEEK_END) != 0) { - ABORT("Bad fd argument - fseek failed"); - } - if ((len = ftell(f)) < 0) { - ABORT("Bad fd argument - ftell failed"); - } - rewind(f); - if (len < LAZY_THRESHOLD) { - return(CORD_from_file_eager(f)); - } else { - return(CORD_from_file_lazy_inner(f, (size_t)len)); - } -} diff -Nru ecl-16.1.2/src/bdwgc/cord/tests/cordtest.c ecl-16.1.3+ds/src/bdwgc/cord/tests/cordtest.c --- ecl-16.1.2/src/bdwgc/cord/tests/cordtest.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/cord/tests/cordtest.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,265 +0,0 @@ -/* - * Copyright (c) 1993-1994 by Xerox Corporation. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -# include "gc.h" /* For GC_INIT() only */ -# include "cord.h" -# include -# include -# include -/* This is a very incomplete test of the cord package. It knows about */ -/* a few internals of the package (e.g. when C strings are returned) */ -/* that real clients shouldn't rely on. */ - -# define ABORT(string) \ - { int x = 0; fprintf(stderr, "FAILED: %s\n", string); x = 1 / x; abort(); } - -int count; - -int test_fn(char c, void * client_data) -{ - if (client_data != (void *)13) ABORT("bad client data"); - if (count < 64*1024+1) { - if ((count & 1) == 0) { - if (c != 'b') ABORT("bad char"); - } else { - if (c != 'a') ABORT("bad char"); - } - count++; - return(0); - } else { - if (c != 'c') ABORT("bad char"); - count++; - return(1); - } -} - -char id_cord_fn(size_t i, void * client_data) -{ - if (client_data != 0) ABORT("id_cord_fn: bad client data"); - return((char)i); -} - -void test_basics(void) -{ - CORD x = CORD_from_char_star("ab"); - register int i; - char c; - CORD y; - CORD_pos p; - - x = CORD_cat(x,x); - if (x == CORD_EMPTY) ABORT("CORD_cat(x,x) returned empty cord"); - if (!CORD_IS_STRING(x)) ABORT("short cord should usually be a string"); - if (strcmp(x, "abab") != 0) ABORT("bad CORD_cat result"); - - for (i = 1; i < 16; i++) { - x = CORD_cat(x,x); - } - x = CORD_cat(x,"c"); - if (CORD_len(x) != 128*1024+1) ABORT("bad length"); - - count = 0; - if (CORD_iter5(x, 64*1024-1, test_fn, CORD_NO_FN, (void *)13) == 0) { - ABORT("CORD_iter5 failed"); - } - if (count != 64*1024 + 2) ABORT("CORD_iter5 failed"); - - count = 0; - CORD_set_pos(p, x, 64*1024-1); - while(CORD_pos_valid(p)) { - (void) test_fn(CORD_pos_fetch(p), (void *)13); - CORD_next(p); - } - if (count != 64*1024 + 2) ABORT("Position based iteration failed"); - - y = CORD_substr(x, 1023, 5); - if (!y) ABORT("CORD_substr returned NULL"); - if (!CORD_IS_STRING(y)) ABORT("short cord should usually be a string"); - if (strcmp(y, "babab") != 0) ABORT("bad CORD_substr result"); - - y = CORD_substr(x, 1024, 8); - if (!y) ABORT("CORD_substr returned NULL"); - if (!CORD_IS_STRING(y)) ABORT("short cord should usually be a string"); - if (strcmp(y, "abababab") != 0) ABORT("bad CORD_substr result"); - - y = CORD_substr(x, 128*1024-1, 8); - if (!y) ABORT("CORD_substr returned NULL"); - if (!CORD_IS_STRING(y)) ABORT("short cord should usually be a string"); - if (strcmp(y, "bc") != 0) ABORT("bad CORD_substr result"); - - x = CORD_balance(x); - if (CORD_len(x) != 128*1024+1) ABORT("bad length"); - - count = 0; - if (CORD_iter5(x, 64*1024-1, test_fn, CORD_NO_FN, (void *)13) == 0) { - ABORT("CORD_iter5 failed"); - } - if (count != 64*1024 + 2) ABORT("CORD_iter5 failed"); - - y = CORD_substr(x, 1023, 5); - if (!y) ABORT("CORD_substr returned NULL"); - if (!CORD_IS_STRING(y)) ABORT("short cord should usually be a string"); - if (strcmp(y, "babab") != 0) ABORT("bad CORD_substr result"); - y = CORD_from_fn(id_cord_fn, 0, 13); - i = 0; - CORD_set_pos(p, y, i); - while(CORD_pos_valid(p)) { - c = CORD_pos_fetch(p); - if(c != i) ABORT("Traversal of function node failed"); - CORD_next(p); i++; - } - if (i != 13) ABORT("Bad apparent length for function node"); -} - -void test_extras(void) -{ -# define FNAME1 "cordtst1.tmp" /* short name (8+3) for portability */ -# define FNAME2 "cordtst2.tmp" - register int i; - CORD y = "abcdefghijklmnopqrstuvwxyz0123456789"; - CORD x = "{}"; - CORD w, z; - FILE *f; - FILE *f1a, *f1b, *f2; - - w = CORD_cat(CORD_cat(y,y),y); - z = CORD_catn(3,y,y,y); - if (CORD_cmp(w,z) != 0) ABORT("CORD_catn comparison wrong"); - for (i = 1; i < 100; i++) { - x = CORD_cat(x, y); - } - z = CORD_balance(x); - if (CORD_cmp(x,z) != 0) ABORT("balanced string comparison wrong"); - if (CORD_cmp(x,CORD_cat(z, CORD_nul(13))) >= 0) ABORT("comparison 2"); - if (CORD_cmp(CORD_cat(x, CORD_nul(13)), z) <= 0) ABORT("comparison 3"); - if (CORD_cmp(x,CORD_cat(z, "13")) >= 0) ABORT("comparison 4"); - if ((f = fopen(FNAME1, "w")) == 0) ABORT("open failed"); - if (CORD_put(z,f) == EOF) ABORT("CORD_put failed"); - if (fclose(f) == EOF) ABORT("fclose failed"); - f1a = fopen(FNAME1, "rb"); - if (!f1a) ABORT("Unable to open " FNAME1); - w = CORD_from_file(f1a); - if (CORD_len(w) != CORD_len(z)) ABORT("file length wrong"); - if (CORD_cmp(w,z) != 0) ABORT("file comparison wrong"); - if (CORD_cmp(CORD_substr(w, 50*36+2, 36), y) != 0) - ABORT("file substr wrong"); - f1b = fopen(FNAME1, "rb"); - if (!f1b) ABORT("2nd open failed: " FNAME1); - z = CORD_from_file_lazy(f1b); - if (CORD_cmp(w,z) != 0) ABORT("File conversions differ"); - if (CORD_chr(w, 0, '9') != 37) ABORT("CORD_chr failed 1"); - if (CORD_chr(w, 3, 'a') != 38) ABORT("CORD_chr failed 2"); - if (CORD_rchr(w, CORD_len(w) - 1, '}') != 1) ABORT("CORD_rchr failed"); - x = y; - for (i = 1; i < 14; i++) { - x = CORD_cat(x,x); - } - if ((f = fopen(FNAME2, "w")) == 0) ABORT("2nd open failed"); -# ifdef __DJGPP__ - /* FIXME: DJGPP workaround. Why does this help? */ - if (fflush(f) != 0) ABORT("fflush failed"); -# endif - if (CORD_put(x,f) == EOF) ABORT("CORD_put failed"); - if (fclose(f) == EOF) ABORT("fclose failed"); - f2 = fopen(FNAME2, "rb"); - if (!f2) ABORT("Unable to open " FNAME2); - w = CORD_from_file(f2); - if (CORD_len(w) != CORD_len(x)) ABORT("file length wrong"); - if (CORD_cmp(w,x) != 0) ABORT("file comparison wrong"); - if (CORD_cmp(CORD_substr(w, 1000*36, 36), y) != 0) - ABORT("file substr wrong"); - if (strcmp(CORD_to_char_star(CORD_substr(w, 1000*36, 36)), y) != 0) - ABORT("char * file substr wrong"); - if (strcmp(CORD_substr(w, 1000*36, 2), "ab") != 0) - ABORT("short file substr wrong"); - if (CORD_str(x,1,"9a") != 35) ABORT("CORD_str failed 1"); - if (CORD_str(x,0,"9abcdefghijk") != 35) ABORT("CORD_str failed 2"); - if (CORD_str(x,0,"9abcdefghijx") != CORD_NOT_FOUND) - ABORT("CORD_str failed 3"); - if (CORD_str(x,0,"9>") != CORD_NOT_FOUND) ABORT("CORD_str failed 4"); - /* Note: f1a, f1b, f2 handles are closed lazily by CORD library. */ - /* TODO: Propose and use CORD_fclose. */ - *(CORD volatile *)&w = CORD_EMPTY; - *(CORD volatile *)&z = CORD_EMPTY; - GC_gcollect(); - GC_invoke_finalizers(); - /* Of course, this does not guarantee the files are closed. */ - if (remove(FNAME1) != 0) { - /* On some systems, e.g. OS2, this may fail if f1 is still open. */ - /* But we cannot call fclose as it might lead to double close. */ - fprintf(stderr, "WARNING: remove(FNAME1) failed\n"); - } - if (remove(FNAME2) != 0) { - fprintf(stderr, "WARNING: remove(FNAME2) failed\n"); - } -} - -#if defined(__DJGPP__) || defined(__STRICT_ANSI__) - /* snprintf is missing in DJGPP (v2.0.3) */ -#else -# if defined(_MSC_VER) -# if defined(_WIN32_WCE) - /* _snprintf is deprecated in WinCE */ -# define GC_SNPRINTF StringCchPrintfA -# else -# define GC_SNPRINTF _snprintf -# endif -# else -# define GC_SNPRINTF snprintf -# endif -#endif - -void test_printf(void) -{ - CORD result; - char result2[200]; - long l = -1; - short s = (short)-1; - CORD x; - - if (CORD_sprintf(&result, "%7.2f%ln", 3.14159F, &l) != 7) - ABORT("CORD_sprintf failed 1"); - if (CORD_cmp(result, " 3.14") != 0)ABORT("CORD_sprintf goofed 1"); - if (l != 7) ABORT("CORD_sprintf goofed 2"); - if (CORD_sprintf(&result, "%-7.2s%hn%c%s", "abcd", &s, 'x', "yz") != 10) - ABORT("CORD_sprintf failed 2"); - if (CORD_cmp(result, "ab xyz") != 0)ABORT("CORD_sprintf goofed 3"); - if (s != 7) ABORT("CORD_sprintf goofed 4"); - x = "abcdefghij"; - x = CORD_cat(x,x); - x = CORD_cat(x,x); - x = CORD_cat(x,x); - if (CORD_sprintf(&result, "->%-120.78r!\n", x) != 124) - ABORT("CORD_sprintf failed 3"); -# ifdef GC_SNPRINTF - (void)GC_SNPRINTF(result2, sizeof(result2), "->%-120.78s!\n", - CORD_to_char_star(x)); -# else - (void)sprintf(result2, "->%-120.78s!\n", CORD_to_char_star(x)); -# endif - result2[sizeof(result2) - 1] = '\0'; - if (CORD_cmp(result, result2) != 0)ABORT("CORD_sprintf goofed 5"); -} - -int main(void) -{ -# ifdef THINK_C - printf("cordtest:\n"); -# endif - GC_INIT(); - test_basics(); - test_extras(); - test_printf(); - CORD_fprintf(stdout, "SUCCEEDED\n"); - return(0); -} diff -Nru ecl-16.1.2/src/bdwgc/cord/tests/de.c ecl-16.1.3+ds/src/bdwgc/cord/tests/de.c --- ecl-16.1.2/src/bdwgc/cord/tests/de.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/cord/tests/de.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,600 +0,0 @@ -/* - * Copyright (c) 1993-1994 by Xerox Corporation. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -/* - * A really simple-minded text editor based on cords. - * Things it does right: - * No size bounds. - * Inbounded undo. - * Shouldn't crash no matter what file you invoke it on (e.g. /vmunix) - * (Make sure /vmunix is not writable before you try this.) - * Scrolls horizontally. - * Things it does wrong: - * It doesn't handle tabs reasonably (use "expand" first). - * The command set is MUCH too small. - * The redisplay algorithm doesn't let curses do the scrolling. - * The rule for moving the window over the file is suboptimal. - */ - -#include -#include "gc.h" -#include "cord.h" - -#ifdef THINK_C -#define MACINTOSH -#include -#endif - -#if (defined(__BORLANDC__) || defined(__CYGWIN__)) && !defined(WIN32) - /* If this is DOS or win16, we'll fail anyway. */ - /* Might as well assume win32. */ -# define WIN32 -#endif - -#if defined(WIN32) -# include -# include "de_win.h" -#elif defined(MACINTOSH) -# include -/* curses emulation. */ -# define initscr() -# define endwin() -# define nonl() -# define noecho() csetmode(C_NOECHO, stdout) -# define cbreak() csetmode(C_CBREAK, stdout) -# define refresh() -# define addch(c) putchar(c) -# define standout() cinverse(1, stdout) -# define standend() cinverse(0, stdout) -# define move(line,col) cgotoxy(col + 1, line + 1, stdout) -# define clrtoeol() ccleol(stdout) -# define de_error(s) { fprintf(stderr, s); getchar(); } -# define LINES 25 -# define COLS 80 -#else -# include -# define de_error(s) { fprintf(stderr, s); sleep(2); } -#endif -#include "de_cmds.h" - -/* List of line number to position mappings, in descending order. */ -/* There may be holes. */ -typedef struct LineMapRep { - int line; - size_t pos; - struct LineMapRep * previous; -} * line_map; - -/* List of file versions, one per edit operation */ -typedef struct HistoryRep { - CORD file_contents; - struct HistoryRep * previous; - line_map map; /* Invalid for first record "now" */ -} * history; - -history now = 0; -CORD current; /* == now -> file_contents. */ -size_t current_len; /* Current file length. */ -line_map current_map = 0; /* Current line no. to pos. map */ -size_t current_map_size = 0; /* Number of current_map entries. */ - /* Not always accurate, but reset */ - /* by prune_map. */ -# define MAX_MAP_SIZE 3000 - -/* Current display position */ -int dis_line = 0; -int dis_col = 0; - -# define ALL -1 -# define NONE - 2 -int need_redisplay = 0; /* Line that needs to be redisplayed. */ - - -/* Current cursor position. Always within file. */ -int line = 0; -int col = 0; -size_t file_pos = 0; /* Character position corresponding to cursor. */ - -/* Invalidate line map for lines > i */ -void invalidate_map(int i) -{ - while(current_map -> line > i) { - current_map = current_map -> previous; - current_map_size--; - } -} - -/* Reduce the number of map entries to save space for huge files. */ -/* This also affects maps in histories. */ -void prune_map(void) -{ - line_map map = current_map; - int start_line = map -> line; - - current_map_size = 0; - do { - current_map_size++; - if (map -> line < start_line - LINES && map -> previous != 0) { - map -> previous = map -> previous -> previous; - } - map = map -> previous; - } while (map != 0); -} - -/* Add mapping entry */ -void add_map(int line, size_t pos) -{ - line_map new_map = GC_NEW(struct LineMapRep); - - if (current_map_size >= MAX_MAP_SIZE) prune_map(); - new_map -> line = line; - new_map -> pos = pos; - new_map -> previous = current_map; - current_map = new_map; - current_map_size++; -} - - - -/* Return position of column *c of ith line in */ -/* current file. Adjust *c to be within the line.*/ -/* A 0 pointer is taken as 0 column. */ -/* Returns CORD_NOT_FOUND if i is too big. */ -/* Assumes i > dis_line. */ -size_t line_pos(int i, int *c) -{ - int j; - size_t cur; - size_t next; - line_map map = current_map; - - while (map -> line > i) map = map -> previous; - if (map -> line < i - 2) /* rebuild */ invalidate_map(i); - for (j = map -> line, cur = map -> pos; j < i;) { - cur = CORD_chr(current, cur, '\n'); - if (cur == current_len-1) return(CORD_NOT_FOUND); - cur++; - if (++j > current_map -> line) add_map(j, cur); - } - if (c != 0) { - next = CORD_chr(current, cur, '\n'); - if (next == CORD_NOT_FOUND) next = current_len - 1; - if (next < cur + *c) { - *c = next - cur; - } - cur += *c; - } - return(cur); -} - -void add_hist(CORD s) -{ - history new_file = GC_NEW(struct HistoryRep); - - new_file -> file_contents = current = s; - current_len = CORD_len(s); - new_file -> previous = now; - if (now != 0) now -> map = current_map; - now = new_file; -} - -void del_hist(void) -{ - now = now -> previous; - current = now -> file_contents; - current_map = now -> map; - current_len = CORD_len(current); -} - -/* Current screen_contents; a dynamically allocated array of CORDs */ -CORD * screen = 0; -int screen_size = 0; - -# ifndef WIN32 -/* Replace a line in the curses stdscr. All control characters are */ -/* displayed as upper case characters in standout mode. This isn't */ -/* terribly appropriate for tabs. */ -void replace_line(int i, CORD s) -{ - register int c; - CORD_pos p; -# if !defined(MACINTOSH) - size_t len = CORD_len(s); -# endif - - if (screen == 0 || LINES > screen_size) { - screen_size = LINES; - screen = (CORD *)GC_MALLOC(screen_size * sizeof(CORD)); - } -# if !defined(MACINTOSH) - /* A gross workaround for an apparent curses bug: */ - if (i == LINES-1 && len == COLS) { - s = CORD_substr(s, 0, len - 1); - } -# endif - if (CORD_cmp(screen[i], s) != 0) { - move(i, 0); clrtoeol(); move(i,0); - - CORD_FOR (p, s) { - c = CORD_pos_fetch(p) & 0x7f; - if (iscntrl(c)) { - standout(); addch(c + 0x40); standend(); - } else { - addch(c); - } - } - screen[i] = s; - } -} -#else -# define replace_line(i,s) invalidate_line(i) -#endif - -/* Return up to COLS characters of the line of s starting at pos, */ -/* returning only characters after the given column. */ -CORD retrieve_line(CORD s, size_t pos, unsigned column) -{ - CORD candidate = CORD_substr(s, pos, column + COLS); - /* avoids scanning very long lines */ - size_t eol = CORD_chr(candidate, 0, '\n'); - int len; - - if (eol == CORD_NOT_FOUND) eol = CORD_len(candidate); - len = (int)eol - (int)column; - if (len < 0) len = 0; - return(CORD_substr(s, pos + column, len)); -} - -# ifdef WIN32 -# define refresh(); - - CORD retrieve_screen_line(int i) - { - register size_t pos; - - invalidate_map(dis_line + LINES); /* Prune search */ - pos = line_pos(dis_line + i, 0); - if (pos == CORD_NOT_FOUND) return(CORD_EMPTY); - return(retrieve_line(current, pos, dis_col)); - } -# endif - -/* Display the visible section of the current file */ -void redisplay(void) -{ - register int i; - - invalidate_map(dis_line + LINES); /* Prune search */ - for (i = 0; i < LINES; i++) { - if (need_redisplay == ALL || need_redisplay == i) { - register size_t pos = line_pos(dis_line + i, 0); - - if (pos == CORD_NOT_FOUND) break; - replace_line(i, retrieve_line(current, pos, dis_col)); - if (need_redisplay == i) goto done; - } - } - for (; i < LINES; i++) replace_line(i, CORD_EMPTY); -done: - refresh(); - need_redisplay = NONE; -} - -int dis_granularity; - -/* Update dis_line, dis_col, and dis_pos to make cursor visible. */ -/* Assumes line, col, dis_line, dis_pos are in bounds. */ -void normalize_display(void) -{ - int old_line = dis_line; - int old_col = dis_col; - - dis_granularity = 1; - if (LINES > 15 && COLS > 15) dis_granularity = 2; - while (dis_line > line) dis_line -= dis_granularity; - while (dis_col > col) dis_col -= dis_granularity; - while (line >= dis_line + LINES) dis_line += dis_granularity; - while (col >= dis_col + COLS) dis_col += dis_granularity; - if (old_line != dis_line || old_col != dis_col) { - need_redisplay = ALL; - } -} - -# if defined(WIN32) -# elif defined(MACINTOSH) -# define move_cursor(x,y) cgotoxy(x + 1, y + 1, stdout) -# else -# define move_cursor(x,y) move(y,x) -# endif - -/* Adjust display so that cursor is visible; move cursor into position */ -/* Update screen if necessary. */ -void fix_cursor(void) -{ - normalize_display(); - if (need_redisplay != NONE) redisplay(); - move_cursor(col - dis_col, line - dis_line); - refresh(); -# ifndef WIN32 - fflush(stdout); -# endif -} - -/* Make sure line, col, and dis_pos are somewhere inside file. */ -/* Recompute file_pos. Assumes dis_pos is accurate or past eof */ -void fix_pos(void) -{ - int my_col = col; - - if ((size_t)line > current_len) line = current_len; - file_pos = line_pos(line, &my_col); - if (file_pos == CORD_NOT_FOUND) { - for (line = current_map -> line, file_pos = current_map -> pos; - file_pos < current_len; - line++, file_pos = CORD_chr(current, file_pos, '\n') + 1); - line--; - file_pos = line_pos(line, &col); - } else { - col = my_col; - } -} - -#if defined(WIN32) -# define beep() Beep(1000 /* Hz */, 300 /* msecs */) -#elif defined(MACINTOSH) -# define beep() SysBeep(1) -#else -/* - * beep() is part of some curses packages and not others. - * We try to match the type of the builtin one, if any. - */ - int beep(void) - { - putc('\007', stderr); - return(0); - } -#endif /* !WIN32 && !MACINTOSH */ - -# define NO_PREFIX -1 -# define BARE_PREFIX -2 -int repeat_count = NO_PREFIX; /* Current command prefix. */ - -int locate_mode = 0; /* Currently between 2 ^Ls */ -CORD locate_string = CORD_EMPTY; /* Current search string. */ - -char * arg_file_name; - -#ifdef WIN32 -/* Change the current position to whatever is currently displayed at */ -/* the given SCREEN coordinates. */ -void set_position(int c, int l) -{ - line = l + dis_line; - col = c + dis_col; - fix_pos(); - move_cursor(col - dis_col, line - dis_line); -} -#endif /* WIN32 */ - -/* Perform the command associated with character c. C may be an */ -/* integer > 256 denoting a windows command, one of the above control */ -/* characters, or another ASCII character to be used as either a */ -/* character to be inserted, a repeat count, or a search string, */ -/* depending on the current state. */ -void do_command(int c) -{ - int i; - int need_fix_pos; - FILE * out; - - if ( c == '\r') c = '\n'; - if (locate_mode) { - size_t new_pos; - - if (c == LOCATE) { - locate_mode = 0; - locate_string = CORD_EMPTY; - return; - } - locate_string = CORD_cat_char(locate_string, (char)c); - new_pos = CORD_str(current, file_pos - CORD_len(locate_string) + 1, - locate_string); - if (new_pos != CORD_NOT_FOUND) { - need_redisplay = ALL; - new_pos += CORD_len(locate_string); - for (;;) { - file_pos = line_pos(line + 1, 0); - if (file_pos > new_pos) break; - line++; - } - col = new_pos - line_pos(line, 0); - file_pos = new_pos; - fix_cursor(); - } else { - locate_string = CORD_substr(locate_string, 0, - CORD_len(locate_string) - 1); - beep(); - } - return; - } - if (c == REPEAT) { - repeat_count = BARE_PREFIX; return; - } else if (c < 0x100 && isdigit(c)){ - if (repeat_count == BARE_PREFIX) { - repeat_count = c - '0'; return; - } else if (repeat_count != NO_PREFIX) { - repeat_count = 10 * repeat_count + c - '0'; return; - } - } - if (repeat_count == NO_PREFIX) repeat_count = 1; - if (repeat_count == BARE_PREFIX && (c == UP || c == DOWN)) { - repeat_count = LINES - dis_granularity; - } - if (repeat_count == BARE_PREFIX) repeat_count = 8; - need_fix_pos = 0; - for (i = 0; i < repeat_count; i++) { - switch(c) { - case LOCATE: - locate_mode = 1; - break; - case TOP: - line = col = file_pos = 0; - break; - case UP: - if (line != 0) { - line--; - need_fix_pos = 1; - } - break; - case DOWN: - line++; - need_fix_pos = 1; - break; - case LEFT: - if (col != 0) { - col--; file_pos--; - } - break; - case RIGHT: - if (CORD_fetch(current, file_pos) == '\n') break; - col++; file_pos++; - break; - case UNDO: - del_hist(); - need_redisplay = ALL; need_fix_pos = 1; - break; - case BS: - if (col == 0) { - beep(); - break; - } - col--; file_pos--; - /* fall through: */ - case DEL: - if (file_pos == current_len-1) break; - /* Can't delete trailing newline */ - if (CORD_fetch(current, file_pos) == '\n') { - need_redisplay = ALL; need_fix_pos = 1; - } else { - need_redisplay = line - dis_line; - } - add_hist(CORD_cat( - CORD_substr(current, 0, file_pos), - CORD_substr(current, file_pos+1, current_len))); - invalidate_map(line); - break; - case WRITE: - { - CORD name = CORD_cat(CORD_from_char_star(arg_file_name), - ".new"); - - if ((out = fopen(CORD_to_const_char_star(name), "wb")) == NULL - || CORD_put(current, out) == EOF) { - de_error("Write failed\n"); - need_redisplay = ALL; - } else { - fclose(out); - } - } - break; - default: - { - CORD left_part = CORD_substr(current, 0, file_pos); - CORD right_part = CORD_substr(current, file_pos, current_len); - - add_hist(CORD_cat(CORD_cat_char(left_part, (char)c), - right_part)); - invalidate_map(line); - if (c == '\n') { - col = 0; line++; file_pos++; - need_redisplay = ALL; - } else { - col++; file_pos++; - need_redisplay = line - dis_line; - } - break; - } - } - } - if (need_fix_pos) fix_pos(); - fix_cursor(); - repeat_count = NO_PREFIX; -} - -/* OS independent initialization */ - -void generic_init(void) -{ - FILE * f; - CORD initial; - - if ((f = fopen(arg_file_name, "rb")) == NULL) { - initial = "\n"; - } else { - initial = CORD_from_file(f); - if (initial == CORD_EMPTY - || CORD_fetch(initial, CORD_len(initial)-1) != '\n') { - initial = CORD_cat(initial, "\n"); - } - } - add_map(0,0); - add_hist(initial); - now -> map = current_map; - now -> previous = now; /* Can't back up further: beginning of the world */ - need_redisplay = ALL; - fix_cursor(); -} - -#ifndef WIN32 - -main(argc, argv) -int argc; -char ** argv; -{ - int c; - -#if defined(MACINTOSH) - console_options.title = "\pDumb Editor"; - cshow(stdout); - argc = ccommand(&argv); -#endif - GC_INIT(); - - if (argc != 2) goto usage; - arg_file_name = argv[1]; - setvbuf(stdout, GC_MALLOC_ATOMIC(8192), _IOFBF, 8192); - initscr(); - noecho(); nonl(); cbreak(); - generic_init(); - while ((c = getchar()) != QUIT) { - if (c == EOF) break; - do_command(c); - } -done: - move(LINES-1, 0); - clrtoeol(); - refresh(); - nl(); - echo(); - endwin(); - exit(0); -usage: - fprintf(stderr, "Usage: %s file\n", argv[0]); - fprintf(stderr, "Cursor keys: ^B(left) ^F(right) ^P(up) ^N(down)\n"); - fprintf(stderr, "Undo: ^U Write to .new: ^W"); - fprintf(stderr, "Quit:^D Repeat count: ^R[n]\n"); - fprintf(stderr, "Top: ^T Locate (search, find): ^L text ^L\n"); - exit(1); -} - -#endif /* !WIN32 */ diff -Nru ecl-16.1.2/src/bdwgc/cord/tests/de_cmds.h ecl-16.1.3+ds/src/bdwgc/cord/tests/de_cmds.h --- ecl-16.1.2/src/bdwgc/cord/tests/de_cmds.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/cord/tests/de_cmds.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,31 +0,0 @@ -/* - * Copyright (c) 1994 by Xerox Corporation. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#ifndef DE_CMDS_H - -# define DE_CMDS_H - -# define UP 16 /* ^P */ -# define DOWN 14 /* ^N */ -# define LEFT 2 /* ^B */ -# define RIGHT 6 /* ^F */ -# define DEL 127 /* ^? */ -# define BS 8 /* ^H */ -# define UNDO 21 /* ^U */ -# define WRITE 23 /* ^W */ -# define QUIT 4 /* ^D */ -# define REPEAT 18 /* ^R */ -# define LOCATE 12 /* ^L */ -# define TOP 20 /* ^T */ - -#endif diff -Nru ecl-16.1.2/src/bdwgc/cord/tests/de_win.c ecl-16.1.3+ds/src/bdwgc/cord/tests/de_win.c --- ecl-16.1.2/src/bdwgc/cord/tests/de_win.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/cord/tests/de_win.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,369 +0,0 @@ -/* - * Copyright (c) 1994 by Xerox Corporation. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -/* - * The MS Windows specific part of de. - * This started as the generic Windows application template - * but significant parts didn't survive to the final version. - * - * This was written by a nonexpert windows programmer. - */ - -#include "windows.h" -#include "gc.h" -#include "cord.h" -#include "de_cmds.h" -#include "de_win.h" - -int LINES = 0; -int COLS = 0; - -#define szAppName TEXT("DE") - -HWND hwnd; - -void de_error(char *s) -{ - (void)MessageBoxA(hwnd, s, "Demonstration Editor", - MB_ICONINFORMATION | MB_OK); - InvalidateRect(hwnd, NULL, TRUE); -} - -int APIENTRY WinMain (HINSTANCE hInstance, HINSTANCE hPrevInstance, - LPSTR command_line, int nCmdShow) -{ - MSG msg; - WNDCLASS wndclass; - HANDLE hAccel; - -# ifdef THREAD_LOCAL_ALLOC - GC_INIT(); /* Required if GC is built with THREAD_LOCAL_ALLOC */ - /* Always safe, but this is used as a GC test. */ -# endif - - if (!hPrevInstance) - { - wndclass.style = CS_HREDRAW | CS_VREDRAW; - wndclass.lpfnWndProc = WndProc; - wndclass.cbClsExtra = 0; - wndclass.cbWndExtra = DLGWINDOWEXTRA; - wndclass.hInstance = hInstance; - wndclass.hIcon = LoadIcon (hInstance, szAppName); - wndclass.hCursor = LoadCursor (NULL, IDC_ARROW); - wndclass.hbrBackground = GetStockObject(WHITE_BRUSH); - wndclass.lpszMenuName = TEXT("DE"); - wndclass.lpszClassName = szAppName; - - if (RegisterClass (&wndclass) == 0) { - char buf[50]; - - sprintf(buf, "RegisterClass: error code: 0x%X", - (unsigned)GetLastError()); - de_error(buf); - return(0); - } - } - - /* Empirically, the command line does not include the command name ... - if (command_line != 0) { - while (isspace(*command_line)) command_line++; - while (*command_line != 0 && !isspace(*command_line)) command_line++; - while (isspace(*command_line)) command_line++; - } */ - - if (command_line == 0 || *command_line == 0) { - de_error("File name argument required"); - return( 0 ); - } else { - char *p = command_line; - - while (*p != 0 && !isspace(*(unsigned char *)p)) - p++; - arg_file_name = CORD_to_char_star( - CORD_substr(command_line, 0, p - command_line)); - } - - hwnd = CreateWindow (szAppName, - TEXT("Demonstration Editor"), - WS_OVERLAPPEDWINDOW | WS_CAPTION, /* Window style */ - CW_USEDEFAULT, 0, /* default pos. */ - CW_USEDEFAULT, 0, /* default width, height */ - NULL, /* No parent */ - NULL, /* Window class menu */ - hInstance, NULL); - if (hwnd == NULL) { - char buf[50]; - - sprintf(buf, "CreateWindow: error code: 0x%X", - (unsigned)GetLastError()); - de_error(buf); - return(0); - } - - ShowWindow (hwnd, nCmdShow); - - hAccel = LoadAccelerators( hInstance, szAppName ); - - while (GetMessage (&msg, NULL, 0, 0)) - { - if( !TranslateAccelerator( hwnd, hAccel, &msg ) ) - { - TranslateMessage (&msg); - DispatchMessage (&msg); - } - } - return msg.wParam; -} - -/* Return the argument with all control characters replaced by blanks. */ -char * plain_chars(char * text, size_t len) -{ - char * result = GC_MALLOC_ATOMIC(len + 1); - register size_t i; - - for (i = 0; i < len; i++) { - if (iscntrl(((unsigned char *)text)[i])) { - result[i] = ' '; - } else { - result[i] = text[i]; - } - } - result[len] = '\0'; - return(result); -} - -/* Return the argument with all non-control-characters replaced by */ -/* blank, and all control characters c replaced by c + 32. */ -char * control_chars(char * text, size_t len) -{ - char * result = GC_MALLOC_ATOMIC(len + 1); - register size_t i; - - for (i = 0; i < len; i++) { - if (iscntrl(((unsigned char *)text)[i])) { - result[i] = text[i] + 0x40; - } else { - result[i] = ' '; - } - } - result[len] = '\0'; - return(result); -} - -int char_width; -int char_height; - -void get_line_rect(int line, int win_width, RECT * rectp) -{ - rectp -> top = line * char_height; - rectp -> bottom = rectp->top + char_height; - rectp -> left = 0; - rectp -> right = win_width; -} - -int caret_visible = 0; /* Caret is currently visible. */ - -int screen_was_painted = 0;/* Screen has been painted at least once. */ - -void update_cursor(void); - -INT_PTR CALLBACK AboutBoxCallback( HWND hDlg, UINT message, - WPARAM wParam, LPARAM lParam ) -{ - (void)lParam; - switch( message ) - { - case WM_INITDIALOG: - SetFocus( GetDlgItem( hDlg, IDOK ) ); - break; - - case WM_COMMAND: - switch( wParam ) - { - case IDOK: - EndDialog( hDlg, TRUE ); - break; - } - break; - - case WM_CLOSE: - EndDialog( hDlg, TRUE ); - return TRUE; - - } - return FALSE; -} - -LRESULT CALLBACK WndProc (HWND hwnd, UINT message, - WPARAM wParam, LPARAM lParam) -{ - static HANDLE hInstance; - HDC dc; - PAINTSTRUCT ps; - RECT client_area; - RECT this_line; - RECT dummy; - TEXTMETRIC tm; - register int i; - int id; - - switch (message) - { - case WM_CREATE: - hInstance = ( (LPCREATESTRUCT) lParam)->hInstance; - dc = GetDC(hwnd); - SelectObject(dc, GetStockObject(SYSTEM_FIXED_FONT)); - GetTextMetrics(dc, &tm); - ReleaseDC(hwnd, dc); - char_width = tm.tmAveCharWidth; - char_height = tm.tmHeight + tm.tmExternalLeading; - GetClientRect(hwnd, &client_area); - COLS = (client_area.right - client_area.left)/char_width; - LINES = (client_area.bottom - client_area.top)/char_height; - generic_init(); - return(0); - - case WM_CHAR: - if (wParam == QUIT) { - SendMessage( hwnd, WM_CLOSE, 0, 0L ); - } else { - do_command((int)wParam); - } - return(0); - - case WM_SETFOCUS: - CreateCaret(hwnd, NULL, char_width, char_height); - ShowCaret(hwnd); - caret_visible = 1; - update_cursor(); - return(0); - - case WM_KILLFOCUS: - HideCaret(hwnd); - DestroyCaret(); - caret_visible = 0; - return(0); - - case WM_LBUTTONUP: - { - unsigned xpos = LOWORD(lParam); /* From left */ - unsigned ypos = HIWORD(lParam); /* from top */ - - set_position(xpos / (unsigned)char_width, - ypos / (unsigned)char_height); - return(0); - } - - case WM_COMMAND: - id = LOWORD(wParam); - if (id & EDIT_CMD_FLAG) { - if (id & REPEAT_FLAG) do_command(REPEAT); - do_command(CHAR_CMD(id)); - return( 0 ); - } else { - switch(id) { - case IDM_FILEEXIT: - SendMessage( hwnd, WM_CLOSE, 0, 0L ); - return( 0 ); - - case IDM_HELPABOUT: - if( DialogBox( hInstance, TEXT("ABOUTBOX"), - hwnd, AboutBoxCallback ) ) - InvalidateRect( hwnd, NULL, TRUE ); - return( 0 ); - case IDM_HELPCONTENTS: - de_error( - "Cursor keys: ^B(left) ^F(right) ^P(up) ^N(down)\n" - "Undo: ^U Write: ^W Quit:^D Repeat count: ^R[n]\n" - "Top: ^T Locate (search, find): ^L text ^L\n"); - return( 0 ); - } - } - break; - - case WM_CLOSE: - DestroyWindow( hwnd ); - return 0; - - case WM_DESTROY: - PostQuitMessage (0); - GC_win32_free_heap(); - return 0; - - case WM_PAINT: - dc = BeginPaint(hwnd, &ps); - GetClientRect(hwnd, &client_area); - COLS = (client_area.right - client_area.left)/char_width; - LINES = (client_area.bottom - client_area.top)/char_height; - SelectObject(dc, GetStockObject(SYSTEM_FIXED_FONT)); - for (i = 0; i < LINES; i++) { - get_line_rect(i, client_area.right, &this_line); - if (IntersectRect(&dummy, &this_line, &ps.rcPaint)) { - CORD raw_line = retrieve_screen_line(i); - size_t len = CORD_len(raw_line); - char * text = CORD_to_char_star(raw_line); - /* May contain embedded NULLs */ - char * plain = plain_chars(text, len); - char * blanks = CORD_to_char_star(CORD_chars(' ', - COLS - len)); - char * control = control_chars(text, len); -# define RED RGB(255,0,0) - - SetBkMode(dc, OPAQUE); - SetTextColor(dc, GetSysColor(COLOR_WINDOWTEXT)); - - TextOutA(dc, this_line.left, this_line.top, - plain, (int)len); - TextOutA(dc, this_line.left + (int)len * char_width, - this_line.top, - blanks, (int)(COLS - len)); - SetBkMode(dc, TRANSPARENT); - SetTextColor(dc, RED); - TextOutA(dc, this_line.left, this_line.top, - control, (int)strlen(control)); - } - } - EndPaint(hwnd, &ps); - screen_was_painted = 1; - return 0; - } - return DefWindowProc (hwnd, message, wParam, lParam); -} - -int last_col; -int last_line; - -void move_cursor(int c, int l) -{ - last_col = c; - last_line = l; - - if (caret_visible) update_cursor(); -} - -void update_cursor(void) -{ - SetCaretPos(last_col * char_width, last_line * char_height); - ShowCaret(hwnd); -} - -void invalidate_line(int i) -{ - RECT line; - - if (!screen_was_painted) return; - /* Invalidating a rectangle before painting seems result in a */ - /* major performance problem. */ - get_line_rect(i, COLS*char_width, &line); - InvalidateRect(hwnd, &line, FALSE); -} diff -Nru ecl-16.1.2/src/bdwgc/cord/tests/de_win.h ecl-16.1.3+ds/src/bdwgc/cord/tests/de_win.h --- ecl-16.1.2/src/bdwgc/cord/tests/de_win.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/cord/tests/de_win.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,101 +0,0 @@ -/* - * Copyright (c) 1994 by Xerox Corporation. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -/* cord.h, de_cmds.h, and windows.h should be included before this. */ - -# define OTHER_FLAG 0x100 -# define EDIT_CMD_FLAG 0x200 -# define REPEAT_FLAG 0x400 - -# define CHAR_CMD(i) ((i) & 0xff) - -/* MENU: DE */ -#define IDM_FILESAVE (EDIT_CMD_FLAG + WRITE) -#define IDM_FILEEXIT (OTHER_FLAG + 1) -#define IDM_HELPABOUT (OTHER_FLAG + 2) -#define IDM_HELPCONTENTS (OTHER_FLAG + 3) - -#define IDM_EDITPDOWN (REPEAT_FLAG + EDIT_CMD_FLAG + DOWN) -#define IDM_EDITPUP (REPEAT_FLAG + EDIT_CMD_FLAG + UP) -#define IDM_EDITUNDO (EDIT_CMD_FLAG + UNDO) -#define IDM_EDITLOCATE (EDIT_CMD_FLAG + LOCATE) -#define IDM_EDITDOWN (EDIT_CMD_FLAG + DOWN) -#define IDM_EDITUP (EDIT_CMD_FLAG + UP) -#define IDM_EDITLEFT (EDIT_CMD_FLAG + LEFT) -#define IDM_EDITRIGHT (EDIT_CMD_FLAG + RIGHT) -#define IDM_EDITBS (EDIT_CMD_FLAG + BS) -#define IDM_EDITDEL (EDIT_CMD_FLAG + DEL) -#define IDM_EDITREPEAT (EDIT_CMD_FLAG + REPEAT) -#define IDM_EDITTOP (EDIT_CMD_FLAG + TOP) - - - - -/* Windows UI stuff */ - -LRESULT CALLBACK WndProc (HWND hwnd, UINT message, - UINT wParam, LONG lParam); - -LRESULT CALLBACK AboutBox( HWND hDlg, UINT message, - UINT wParam, LONG lParam ); - - -/* Screen dimensions. Maintained by de_win.c. */ -extern int LINES; -extern int COLS; - -/* File being edited. */ -extern char * arg_file_name; - -/* Current display position in file. Maintained by de.c */ -extern int dis_line; -extern int dis_col; - -/* Current cursor position in file. */ -extern int line; -extern int col; - -/* - * Calls from de_win.c to de.c - */ - -CORD retrieve_screen_line(int i); - /* Get the contents of i'th screen line. */ - /* Relies on COLS. */ - -void set_position(int x, int y); - /* Set column, row. Upper left of window = (0,0). */ - -void do_command(int); - /* Execute an editor command. */ - /* Agument is a command character or one */ - /* of the IDM_ commands. */ - -void generic_init(void); - /* OS independent initialization */ - - -/* - * Calls from de.c to de_win.c - */ - -void move_cursor(int column, int line); - /* Physically move the cursor on the display, */ - /* so that it appears at */ - /* (column, line). */ - -void invalidate_line(int line); - /* Invalidate line i on the screen. */ - -void de_error(char *s); - /* Display error message. */ diff -Nru ecl-16.1.2/src/bdwgc/cord/tests/de_win.rc ecl-16.1.3+ds/src/bdwgc/cord/tests/de_win.rc --- ecl-16.1.2/src/bdwgc/cord/tests/de_win.rc 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/cord/tests/de_win.rc 1970-01-01 00:00:00.000000000 +0000 @@ -1,75 +0,0 @@ -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to copy this garbage collector for any purpose, - * provided the above notices are retained on all copies. - */ - -#include "windows.h" -#include "de_cmds.h" -#include "de_win.h" - - -ABOUTBOX DIALOG 19, 21, 163, 47 -STYLE DS_MODALFRAME | WS_POPUP | WS_CAPTION | WS_SYSMENU -CAPTION "About Demonstration Text Editor" -BEGIN - /* ICON "DE", -1, 8, 8, 13, 13, WS_CHILD | WS_VISIBLE */ - LTEXT "Demonstration Text Editor", -1, 44, 8, 118, 8, WS_CHILD | WS_VISIBLE | WS_GROUP - LTEXT "Version 4.1", -1, 44, 16, 60, 8, WS_CHILD | WS_VISIBLE | WS_GROUP - PUSHBUTTON "OK", IDOK, 118, 27, 24, 14, WS_CHILD | WS_VISIBLE | WS_TABSTOP -END - - -DE MENU -BEGIN - POPUP "&File" - BEGIN - MENUITEM "&Save\t^W", IDM_FILESAVE - MENUITEM "E&xit\t^D", IDM_FILEEXIT - END - - POPUP "&Edit" - BEGIN - MENUITEM "Page &Down\t^R^N", IDM_EDITPDOWN - MENUITEM "Page &Up\t^R^P", IDM_EDITPUP - MENUITEM "U&ndo\t^U", IDM_EDITUNDO - MENUITEM "&Locate\t^L ... ^L", IDM_EDITLOCATE - MENUITEM "D&own\t^N", IDM_EDITDOWN - MENUITEM "U&p\t^P", IDM_EDITUP - MENUITEM "Le&ft\t^B", IDM_EDITLEFT - MENUITEM "&Right\t^F", IDM_EDITRIGHT - MENUITEM "Delete &Backward\tBS", IDM_EDITBS - MENUITEM "Delete F&orward\tDEL", IDM_EDITDEL - MENUITEM "&Top\t^T", IDM_EDITTOP - END - - POPUP "&Help" - BEGIN - MENUITEM "&Contents", IDM_HELPCONTENTS - MENUITEM "&About...", IDM_HELPABOUT - END - - MENUITEM "Page_&Down", IDM_EDITPDOWN - MENUITEM "Page_&Up", IDM_EDITPUP -END - - -DE ACCELERATORS -BEGIN - "^R", IDM_EDITREPEAT - "^N", IDM_EDITDOWN - "^P", IDM_EDITUP - "^L", IDM_EDITLOCATE - "^B", IDM_EDITLEFT - "^F", IDM_EDITRIGHT - "^T", IDM_EDITTOP - VK_DELETE, IDM_EDITDEL, VIRTKEY - VK_BACK, IDM_EDITBS, VIRTKEY -END - - -/* DE ICON cord\de_win.ICO */ diff -Nru ecl-16.1.2/src/bdwgc/darwin_stop_world.c ecl-16.1.3+ds/src/bdwgc/darwin_stop_world.c --- ecl-16.1.2/src/bdwgc/darwin_stop_world.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/darwin_stop_world.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,711 +0,0 @@ -/* - * Copyright (c) 1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996 by Silicon Graphics. All rights reserved. - * Copyright (c) 1998 by Fergus Henderson. All rights reserved. - * Copyright (c) 2000-2010 by Hewlett-Packard Development Company. - * All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#include "private/pthread_support.h" - -/* This probably needs more porting work to ppc64. */ - -#if defined(GC_DARWIN_THREADS) - -#include -#include -#include - -/* From "Inside Mac OS X - Mach-O Runtime Architecture" published by Apple - Page 49: - "The space beneath the stack pointer, where a new stack frame would normally - be allocated, is called the red zone. This area as shown in Figure 3-2 may - be used for any purpose as long as a new stack frame does not need to be - added to the stack." - - Page 50: "If a leaf procedure's red zone usage would exceed 224 bytes, then - it must set up a stack frame just like routines that call other routines." -*/ -#ifdef POWERPC -# if CPP_WORDSZ == 32 -# define PPC_RED_ZONE_SIZE 224 -# elif CPP_WORDSZ == 64 -# define PPC_RED_ZONE_SIZE 320 -# endif -#endif - -#ifndef DARWIN_DONT_PARSE_STACK - -typedef struct StackFrame { - unsigned long savedSP; - unsigned long savedCR; - unsigned long savedLR; - unsigned long reserved[2]; - unsigned long savedRTOC; -} StackFrame; - -GC_INNER ptr_t GC_FindTopOfStack(unsigned long stack_start) -{ - StackFrame *frame; - -# ifdef POWERPC - if (stack_start == 0) { -# if CPP_WORDSZ == 32 - __asm__ __volatile__ ("lwz %0,0(r1)" : "=r" (frame)); -# else - __asm__ __volatile__ ("ld %0,0(r1)" : "=r" (frame)); -# endif - } else -# else - GC_ASSERT(stack_start != 0); /* not implemented */ -# endif /* !POWERPC */ - /* else */ { - frame = (StackFrame *)stack_start; - } - -# ifdef DEBUG_THREADS_EXTRA - GC_log_printf("FindTopOfStack start at sp = %p\n", frame); -# endif - while (frame->savedSP != 0) { - /* if there are no more stack frames, stop */ - - frame = (StackFrame*)frame->savedSP; - - /* we do these next two checks after going to the next frame - because the LR for the first stack frame in the loop - is not set up on purpose, so we shouldn't check it. */ - if ((frame->savedLR & ~0x3) == 0 || (frame->savedLR & ~0x3) == ~0x3U) - break; /* if the next LR is bogus, stop */ - } -# ifdef DEBUG_THREADS_EXTRA - GC_log_printf("FindTopOfStack finish at sp = %p\n", frame); -# endif - return (ptr_t)frame; -} - -#endif /* !DARWIN_DONT_PARSE_STACK */ - -/* GC_query_task_threads controls whether to obtain the list of */ -/* the threads from the kernel or to use GC_threads table. */ -#ifdef GC_NO_THREADS_DISCOVERY -# define GC_query_task_threads FALSE -#elif defined(GC_DISCOVER_TASK_THREADS) -# define GC_query_task_threads TRUE -#else - STATIC GC_bool GC_query_task_threads = FALSE; -#endif /* !GC_NO_THREADS_DISCOVERY */ - -/* Use implicit threads registration (all task threads excluding the GC */ -/* special ones are stopped and scanned). Should be called before */ -/* GC_INIT() (or, at least, before going multi-threaded). Deprecated. */ -GC_API void GC_CALL GC_use_threads_discovery(void) -{ -# if defined(GC_NO_THREADS_DISCOVERY) || defined(DARWIN_DONT_PARSE_STACK) - ABORT("Darwin task-threads-based stop and push unsupported"); -# else -# ifndef GC_ALWAYS_MULTITHREADED - GC_ASSERT(!GC_need_to_lock); -# endif -# ifndef GC_DISCOVER_TASK_THREADS - GC_query_task_threads = TRUE; -# endif - GC_init_parallel(); /* just to be consistent with Win32 one */ -# endif -} - -#ifndef kCFCoreFoundationVersionNumber_iOS_8_0 -# define kCFCoreFoundationVersionNumber_iOS_8_0 1140.1 -#endif - -/* Evaluates the stack range for a given thread. Returns the lower */ -/* bound and sets *phi to the upper one. */ -STATIC ptr_t GC_stack_range_for(ptr_t *phi, thread_act_t thread, GC_thread p, - GC_bool thread_blocked, mach_port_t my_thread) -{ - ptr_t lo; - if (thread == my_thread) { - GC_ASSERT(!thread_blocked); - lo = GC_approx_sp(); -# ifndef DARWIN_DONT_PARSE_STACK - *phi = GC_FindTopOfStack(0); -# endif - - } else if (thread_blocked) { - lo = p->stop_info.stack_ptr; -# ifndef DARWIN_DONT_PARSE_STACK - *phi = p->topOfStack; -# endif - - } else { - /* MACHINE_THREAD_STATE_COUNT does not seem to be defined */ - /* everywhere. Hence we use our own version. Alternatively, */ - /* we could use THREAD_STATE_MAX (but seems to be not optimal). */ - kern_return_t kern_result; - GC_THREAD_STATE_T state; - -# if defined(ARM32) && defined(ARM_THREAD_STATE32) - /* Use ARM_UNIFIED_THREAD_STATE on iOS8+ 32-bit targets and on */ - /* 64-bit H/W (iOS7+ 32-bit mode). */ - size_t size; - static cpu_type_t cputype = 0; - - if (cputype == 0) { - sysctlbyname("hw.cputype", &cputype, &size, NULL, 0); - } - if (cputype == CPU_TYPE_ARM64 - || kCFCoreFoundationVersionNumber - >= kCFCoreFoundationVersionNumber_iOS_8_0) { - arm_unified_thread_state_t unified_state; - mach_msg_type_number_t unified_thread_state_count - = ARM_UNIFIED_THREAD_STATE_COUNT; - - kern_result = thread_get_state(thread, ARM_UNIFIED_THREAD_STATE, - (natural_t *)&unified_state, - &unified_thread_state_count); - if (unified_state.ash.flavor != ARM_THREAD_STATE32) { - ABORT("unified_state flavor should be ARM_THREAD_STATE32"); - } - state = unified_state.ts_32; - } else -# endif - /* else */ { - mach_msg_type_number_t thread_state_count = GC_MACH_THREAD_STATE_COUNT; - - /* Get the thread state (registers, etc) */ - kern_result = thread_get_state(thread, GC_MACH_THREAD_STATE, - (natural_t *)&state, - &thread_state_count); - } -# ifdef DEBUG_THREADS - GC_log_printf("thread_get_state returns value = %d\n", kern_result); -# endif - if (kern_result != KERN_SUCCESS) - ABORT("thread_get_state failed"); - -# if defined(I386) - lo = (void *)state.THREAD_FLD(esp); -# ifndef DARWIN_DONT_PARSE_STACK - *phi = GC_FindTopOfStack(state.THREAD_FLD(esp)); -# endif - GC_push_one(state.THREAD_FLD(eax)); - GC_push_one(state.THREAD_FLD(ebx)); - GC_push_one(state.THREAD_FLD(ecx)); - GC_push_one(state.THREAD_FLD(edx)); - GC_push_one(state.THREAD_FLD(edi)); - GC_push_one(state.THREAD_FLD(esi)); - GC_push_one(state.THREAD_FLD(ebp)); - -# elif defined(X86_64) - lo = (void *)state.THREAD_FLD(rsp); -# ifndef DARWIN_DONT_PARSE_STACK - *phi = GC_FindTopOfStack(state.THREAD_FLD(rsp)); -# endif - GC_push_one(state.THREAD_FLD(rax)); - GC_push_one(state.THREAD_FLD(rbx)); - GC_push_one(state.THREAD_FLD(rcx)); - GC_push_one(state.THREAD_FLD(rdx)); - GC_push_one(state.THREAD_FLD(rdi)); - GC_push_one(state.THREAD_FLD(rsi)); - GC_push_one(state.THREAD_FLD(rbp)); - /* GC_push_one(state.THREAD_FLD(rsp)); */ - GC_push_one(state.THREAD_FLD(r8)); - GC_push_one(state.THREAD_FLD(r9)); - GC_push_one(state.THREAD_FLD(r10)); - GC_push_one(state.THREAD_FLD(r11)); - GC_push_one(state.THREAD_FLD(r12)); - GC_push_one(state.THREAD_FLD(r13)); - GC_push_one(state.THREAD_FLD(r14)); - GC_push_one(state.THREAD_FLD(r15)); - -# elif defined(POWERPC) - lo = (void *)(state.THREAD_FLD(r1) - PPC_RED_ZONE_SIZE); -# ifndef DARWIN_DONT_PARSE_STACK - *phi = GC_FindTopOfStack(state.THREAD_FLD(r1)); -# endif - GC_push_one(state.THREAD_FLD(r0)); - GC_push_one(state.THREAD_FLD(r2)); - GC_push_one(state.THREAD_FLD(r3)); - GC_push_one(state.THREAD_FLD(r4)); - GC_push_one(state.THREAD_FLD(r5)); - GC_push_one(state.THREAD_FLD(r6)); - GC_push_one(state.THREAD_FLD(r7)); - GC_push_one(state.THREAD_FLD(r8)); - GC_push_one(state.THREAD_FLD(r9)); - GC_push_one(state.THREAD_FLD(r10)); - GC_push_one(state.THREAD_FLD(r11)); - GC_push_one(state.THREAD_FLD(r12)); - GC_push_one(state.THREAD_FLD(r13)); - GC_push_one(state.THREAD_FLD(r14)); - GC_push_one(state.THREAD_FLD(r15)); - GC_push_one(state.THREAD_FLD(r16)); - GC_push_one(state.THREAD_FLD(r17)); - GC_push_one(state.THREAD_FLD(r18)); - GC_push_one(state.THREAD_FLD(r19)); - GC_push_one(state.THREAD_FLD(r20)); - GC_push_one(state.THREAD_FLD(r21)); - GC_push_one(state.THREAD_FLD(r22)); - GC_push_one(state.THREAD_FLD(r23)); - GC_push_one(state.THREAD_FLD(r24)); - GC_push_one(state.THREAD_FLD(r25)); - GC_push_one(state.THREAD_FLD(r26)); - GC_push_one(state.THREAD_FLD(r27)); - GC_push_one(state.THREAD_FLD(r28)); - GC_push_one(state.THREAD_FLD(r29)); - GC_push_one(state.THREAD_FLD(r30)); - GC_push_one(state.THREAD_FLD(r31)); - -# elif defined(ARM32) - lo = (void *)state.THREAD_FLD(sp); -# ifndef DARWIN_DONT_PARSE_STACK - *phi = GC_FindTopOfStack(state.THREAD_FLD(sp)); -# endif - { - int j; - for (j = 0; j <= 12; j++) { - GC_push_one(state.THREAD_FLD(r[j])); - } - } - /* "pc" and "sp" are skipped */ - GC_push_one(state.THREAD_FLD(lr)); - GC_push_one(state.THREAD_FLD(cpsr)); - -# elif defined(AARCH64) - lo = (void *)state.THREAD_FLD(sp); -# ifndef DARWIN_DONT_PARSE_STACK - *phi = GC_FindTopOfStack(state.THREAD_FLD(sp)); -# endif - { - int j; - for (j = 0; j <= 28; j++) { - GC_push_one(state.THREAD_FLD(x[j])); - } - } - /* "cpsr", "pc" and "sp" are skipped */ - GC_push_one(state.THREAD_FLD(fp)); - GC_push_one(state.THREAD_FLD(lr)); - -# else -# error FIXME for non-x86 || ppc || arm architectures -# endif - } /* thread != my_thread */ - -# ifdef DARWIN_DONT_PARSE_STACK - /* p is guaranteed to be non-NULL regardless of GC_query_task_threads. */ - *phi = (p->flags & MAIN_THREAD) != 0 ? GC_stackbottom : p->stack_end; -# endif -# ifdef DEBUG_THREADS - GC_log_printf("Darwin: Stack for thread %p = [%p,%p)\n", - (void *)thread, lo, *phi); -# endif - return lo; -} - -GC_INNER void GC_push_all_stacks(void) -{ - int i; - ptr_t lo, hi; - task_t my_task = current_task(); - mach_port_t my_thread = mach_thread_self(); - GC_bool found_me = FALSE; - int nthreads = 0; - word total_size = 0; - mach_msg_type_number_t listcount = (mach_msg_type_number_t)THREAD_TABLE_SZ; - if (!EXPECT(GC_thr_initialized, TRUE)) - GC_thr_init(); - -# ifndef DARWIN_DONT_PARSE_STACK - if (GC_query_task_threads) { - kern_return_t kern_result; - thread_act_array_t act_list = 0; - - /* Obtain the list of the threads from the kernel. */ - kern_result = task_threads(my_task, &act_list, &listcount); - if (kern_result != KERN_SUCCESS) - ABORT("task_threads failed"); - - for (i = 0; i < (int)listcount; i++) { - thread_act_t thread = act_list[i]; - lo = GC_stack_range_for(&hi, thread, NULL, FALSE, my_thread); - GC_ASSERT((word)lo <= (word)hi); - total_size += hi - lo; - GC_push_all_stack(lo, hi); - nthreads++; - if (thread == my_thread) - found_me = TRUE; - mach_port_deallocate(my_task, thread); - } /* for (i=0; ...) */ - - vm_deallocate(my_task, (vm_address_t)act_list, - sizeof(thread_t) * listcount); - } else -# endif /* !DARWIN_DONT_PARSE_STACK */ - /* else */ { - for (i = 0; i < (int)listcount; i++) { - GC_thread p; - for (p = GC_threads[i]; p != NULL; p = p->next) - if ((p->flags & FINISHED) == 0) { - thread_act_t thread = (thread_act_t)p->stop_info.mach_thread; - lo = GC_stack_range_for(&hi, thread, p, (GC_bool)p->thread_blocked, - my_thread); - GC_ASSERT((word)lo <= (word)hi); - total_size += hi - lo; - GC_push_all_stack_sections(lo, hi, p->traced_stack_sect); - nthreads++; - if (thread == my_thread) - found_me = TRUE; - } - } /* for (i=0; ...) */ - } - - mach_port_deallocate(my_task, my_thread); - GC_VERBOSE_LOG_PRINTF("Pushed %d thread stacks\n", nthreads); - if (!found_me && !GC_in_thread_creation) - ABORT("Collecting from unknown thread"); - GC_total_stacksize = total_size; -} - -#ifndef GC_NO_THREADS_DISCOVERY - -# ifdef MPROTECT_VDB - STATIC mach_port_t GC_mach_handler_thread = 0; - STATIC GC_bool GC_use_mach_handler_thread = FALSE; - - GC_INNER void GC_darwin_register_mach_handler_thread(mach_port_t thread) - { - GC_mach_handler_thread = thread; - GC_use_mach_handler_thread = TRUE; - } -# endif /* MPROTECT_VDB */ - -# ifndef GC_MAX_MACH_THREADS -# define GC_MAX_MACH_THREADS THREAD_TABLE_SZ -# endif - - struct GC_mach_thread { - thread_act_t thread; - GC_bool already_suspended; - }; - - struct GC_mach_thread GC_mach_threads[GC_MAX_MACH_THREADS]; - STATIC int GC_mach_threads_count = 0; - /* FIXME: it is better to implement GC_mach_threads as a hash set. */ - -/* returns true if there's a thread in act_list that wasn't in old_list */ -STATIC GC_bool GC_suspend_thread_list(thread_act_array_t act_list, int count, - thread_act_array_t old_list, - int old_count, mach_port_t my_thread) -{ - int i; - int j = -1; - GC_bool changed = FALSE; - - for (i = 0; i < count; i++) { - thread_act_t thread = act_list[i]; - GC_bool found; - struct thread_basic_info info; - mach_msg_type_number_t outCount; - kern_return_t kern_result; - - if (thread == my_thread -# ifdef MPROTECT_VDB - || (GC_mach_handler_thread == thread && GC_use_mach_handler_thread) -# endif - ) { - /* Don't add our and the handler threads. */ - continue; - } -# ifdef PARALLEL_MARK - if (GC_is_mach_marker(thread)) - continue; /* ignore the parallel marker threads */ -# endif - -# ifdef DEBUG_THREADS - GC_log_printf("Attempting to suspend thread %p\n", (void *)thread); -# endif - /* find the current thread in the old list */ - found = FALSE; - { - int last_found = j; /* remember the previous found thread index */ - - /* Search for the thread starting from the last found one first. */ - while (++j < old_count) - if (old_list[j] == thread) { - found = TRUE; - break; - } - if (!found) { - /* If not found, search in the rest (beginning) of the list. */ - for (j = 0; j < last_found; j++) - if (old_list[j] == thread) { - found = TRUE; - break; - } - - if (!found) { - /* add it to the GC_mach_threads list */ - if (GC_mach_threads_count == GC_MAX_MACH_THREADS) - ABORT("Too many threads"); - GC_mach_threads[GC_mach_threads_count].thread = thread; - /* default is not suspended */ - GC_mach_threads[GC_mach_threads_count].already_suspended = FALSE; - changed = TRUE; - } - } - } - - outCount = THREAD_INFO_MAX; - kern_result = thread_info(thread, THREAD_BASIC_INFO, - (thread_info_t)&info, &outCount); - if (kern_result != KERN_SUCCESS) { - /* The thread may have quit since the thread_threads() call we */ - /* mark already suspended so it's not dealt with anymore later. */ - if (!found) - GC_mach_threads[GC_mach_threads_count++].already_suspended = TRUE; - continue; - } -# ifdef DEBUG_THREADS - GC_log_printf("Thread state for %p = %d\n", (void *)thread, info.run_state); -# endif - if (info.suspend_count != 0) { - /* thread is already suspended. */ - if (!found) - GC_mach_threads[GC_mach_threads_count++].already_suspended = TRUE; - continue; - } - -# ifdef DEBUG_THREADS - GC_log_printf("Suspending %p\n", (void *)thread); -# endif - kern_result = thread_suspend(thread); - if (kern_result != KERN_SUCCESS) { - /* The thread may have quit since the thread_threads() call we */ - /* mark already suspended so it's not dealt with anymore later. */ - if (!found) - GC_mach_threads[GC_mach_threads_count++].already_suspended = TRUE; - continue; - } - if (!found) - GC_mach_threads_count++; - } - return changed; -} - -#endif /* !GC_NO_THREADS_DISCOVERY */ - -/* Caller holds allocation lock. */ -GC_INNER void GC_stop_world(void) -{ - unsigned i; - task_t my_task = current_task(); - mach_port_t my_thread = mach_thread_self(); - kern_return_t kern_result; - -# ifdef DEBUG_THREADS - GC_log_printf("Stopping the world from thread %p\n", (void *)my_thread); -# endif -# ifdef PARALLEL_MARK - if (GC_parallel) { - /* Make sure all free list construction has stopped before we */ - /* start. No new construction can start, since free list */ - /* construction is required to acquire and release the GC lock */ - /* before it starts, and we have the lock. */ - GC_acquire_mark_lock(); - GC_ASSERT(GC_fl_builder_count == 0); - /* We should have previously waited for it to become zero. */ - } -# endif /* PARALLEL_MARK */ - - if (GC_query_task_threads) { -# ifndef GC_NO_THREADS_DISCOVERY - GC_bool changed; - thread_act_array_t act_list, prev_list; - mach_msg_type_number_t listcount, prevcount; - - /* Clear out the mach threads list table. We do not need to */ - /* really clear GC_mach_threads[] as it is used only in the range */ - /* from 0 to GC_mach_threads_count-1, inclusive. */ - GC_mach_threads_count = 0; - - /* Loop stopping threads until you have gone over the whole list */ - /* twice without a new one appearing. thread_create() won't */ - /* return (and thus the thread stop) until the new thread exists, */ - /* so there is no window whereby you could stop a thread, */ - /* recognize it is stopped, but then have a new thread it created */ - /* before stopping show up later. */ - changed = TRUE; - prev_list = NULL; - prevcount = 0; - do { - kern_result = task_threads(my_task, &act_list, &listcount); - - if (kern_result == KERN_SUCCESS) { - changed = GC_suspend_thread_list(act_list, listcount, prev_list, - prevcount, my_thread); - - if (prev_list != NULL) { - for (i = 0; i < prevcount; i++) - mach_port_deallocate(my_task, prev_list[i]); - - vm_deallocate(my_task, (vm_address_t)prev_list, - sizeof(thread_t) * prevcount); - } - - /* Repeat while having changes. */ - prev_list = act_list; - prevcount = listcount; - } - } while (changed); - - GC_ASSERT(prev_list != 0); - for (i = 0; i < prevcount; i++) - mach_port_deallocate(my_task, prev_list[i]); - vm_deallocate(my_task, (vm_address_t)act_list, - sizeof(thread_t) * listcount); -# endif /* !GC_NO_THREADS_DISCOVERY */ - - } else { - for (i = 0; i < THREAD_TABLE_SZ; i++) { - GC_thread p; - - for (p = GC_threads[i]; p != NULL; p = p->next) { - if ((p->flags & FINISHED) == 0 && !p->thread_blocked && - p->stop_info.mach_thread != my_thread) { - - kern_result = thread_suspend(p->stop_info.mach_thread); - if (kern_result != KERN_SUCCESS) - ABORT("thread_suspend failed"); - } - } - } - } - -# ifdef MPROTECT_VDB - if(GC_incremental) { - GC_mprotect_stop(); - } -# endif -# ifdef PARALLEL_MARK - if (GC_parallel) - GC_release_mark_lock(); -# endif - -# ifdef DEBUG_THREADS - GC_log_printf("World stopped from %p\n", (void *)my_thread); -# endif - mach_port_deallocate(my_task, my_thread); -} - -GC_INLINE void GC_thread_resume(thread_act_t thread) -{ - kern_return_t kern_result; -# if defined(DEBUG_THREADS) || defined(GC_ASSERTIONS) - struct thread_basic_info info; - mach_msg_type_number_t outCount = THREAD_INFO_MAX; - kern_result = thread_info(thread, THREAD_BASIC_INFO, - (thread_info_t)&info, &outCount); - if (kern_result != KERN_SUCCESS) - ABORT("thread_info failed"); -# endif -# ifdef DEBUG_THREADS - GC_log_printf("Resuming thread %p with state %d\n", (void *)thread, - info.run_state); -# endif - /* Resume the thread */ - kern_result = thread_resume(thread); - if (kern_result != KERN_SUCCESS) - ABORT("thread_resume failed"); -} - -/* Caller holds allocation lock, and has held it continuously since */ -/* the world stopped. */ -GC_INNER void GC_start_world(void) -{ - task_t my_task = current_task(); - int i; -# ifdef DEBUG_THREADS - GC_log_printf("World starting\n"); -# endif -# ifdef MPROTECT_VDB - if(GC_incremental) { - GC_mprotect_resume(); - } -# endif - - if (GC_query_task_threads) { -# ifndef GC_NO_THREADS_DISCOVERY - int j = GC_mach_threads_count; - kern_return_t kern_result; - thread_act_array_t act_list; - mach_msg_type_number_t listcount; - - kern_result = task_threads(my_task, &act_list, &listcount); - if (kern_result != KERN_SUCCESS) - ABORT("task_threads failed"); - - for (i = 0; i < (int)listcount; i++) { - thread_act_t thread = act_list[i]; - int last_found = j; /* The thread index found during the */ - /* previous iteration (count value */ - /* means no thread found yet). */ - - /* Search for the thread starting from the last found one first. */ - while (++j < GC_mach_threads_count) { - if (GC_mach_threads[j].thread == thread) - break; - } - if (j >= GC_mach_threads_count) { - /* If not found, search in the rest (beginning) of the list. */ - for (j = 0; j < last_found; j++) { - if (GC_mach_threads[j].thread == thread) - break; - } - } - - if (j != last_found) { - /* The thread is found in GC_mach_threads. */ - if (GC_mach_threads[j].already_suspended) { -# ifdef DEBUG_THREADS - GC_log_printf("Not resuming already suspended thread %p\n", - (void *)thread); -# endif - } else { - GC_thread_resume(thread); - } - } - - mach_port_deallocate(my_task, thread); - } - vm_deallocate(my_task, (vm_address_t)act_list, - sizeof(thread_t) * listcount); -# endif /* !GC_NO_THREADS_DISCOVERY */ - - } else { - mach_port_t my_thread = mach_thread_self(); - - for (i = 0; i < THREAD_TABLE_SZ; i++) { - GC_thread p; - for (p = GC_threads[i]; p != NULL; p = p->next) { - if ((p->flags & FINISHED) == 0 && !p->thread_blocked && - p->stop_info.mach_thread != my_thread) - GC_thread_resume(p->stop_info.mach_thread); - } - } - - mach_port_deallocate(my_task, my_thread); - } - -# ifdef DEBUG_THREADS - GC_log_printf("World started\n"); -# endif -} - -#endif /* GC_DARWIN_THREADS */ diff -Nru ecl-16.1.2/src/bdwgc/dbg_mlc.c ecl-16.1.3+ds/src/bdwgc/dbg_mlc.c --- ecl-16.1.2/src/bdwgc/dbg_mlc.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/dbg_mlc.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,1264 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1995 by Xerox Corporation. All rights reserved. - * Copyright (c) 1997 by Silicon Graphics. All rights reserved. - * Copyright (c) 1999-2004 Hewlett-Packard Development Company, L.P. - * Copyright (C) 2007 Free Software Foundation, Inc - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#include "private/dbg_mlc.h" - -#ifndef MSWINCE -# include -#endif -#include - -#ifndef SHORT_DBG_HDRS - /* Check whether object with base pointer p has debugging info. */ - /* p is assumed to point to a legitimate object in our part */ - /* of the heap. */ - /* This excludes the check as to whether the back pointer is */ - /* odd, which is added by the GC_HAS_DEBUG_INFO macro. */ - /* Note that if DBG_HDRS_ALL is set, uncollectible objects */ - /* on free lists may not have debug information set. Thus it's */ - /* not always safe to return TRUE (1), even if the client does */ - /* its part. Return -1 if the object with debug info has been */ - /* marked as deallocated. */ - GC_INNER int GC_has_other_debug_info(ptr_t p) - { - ptr_t body = (ptr_t)((oh *)p + 1); - word sz = GC_size(p); - - if (HBLKPTR(p) != HBLKPTR((ptr_t)body) - || sz < DEBUG_BYTES + EXTRA_BYTES) { - return 0; - } - if (((oh *)p) -> oh_sf != (START_FLAG ^ (word)body) - && ((word *)p)[BYTES_TO_WORDS(sz)-1] != (END_FLAG ^ (word)body)) { - return 0; - } - if (((oh *)p)->oh_sz == sz) { - /* Object may have had debug info, but has been deallocated */ - return -1; - } - return 1; - } -#endif /* !SHORT_DBG_HDRS */ - -#ifdef KEEP_BACK_PTRS - -# include - -# if defined(__GLIBC__) || defined(SOLARIS) \ - || defined(HPUX) || defined(IRIX5) || defined(OSF1) -# define RANDOM() random() -# else -# define RANDOM() (long)rand() -# endif - - /* Store back pointer to source in dest, if that appears to be possible. */ - /* This is not completely safe, since we may mistakenly conclude that */ - /* dest has a debugging wrapper. But the error probability is very */ - /* small, and this shouldn't be used in production code. */ - /* We assume that dest is the real base pointer. Source will usually */ - /* be a pointer to the interior of an object. */ - GC_INNER void GC_store_back_pointer(ptr_t source, ptr_t dest) - { - if (GC_HAS_DEBUG_INFO(dest)) { - ((oh *)dest) -> oh_back_ptr = HIDE_BACK_PTR(source); - } - } - - GC_INNER void GC_marked_for_finalization(ptr_t dest) - { - GC_store_back_pointer(MARKED_FOR_FINALIZATION, dest); - } - - /* Store information about the object referencing dest in *base_p */ - /* and *offset_p. */ - /* source is root ==> *base_p = address, *offset_p = 0 */ - /* source is heap object ==> *base_p != 0, *offset_p = offset */ - /* Returns 1 on success, 0 if source couldn't be determined. */ - /* Dest can be any address within a heap object. */ - GC_API GC_ref_kind GC_CALL GC_get_back_ptr_info(void *dest, void **base_p, - size_t *offset_p) - { - oh * hdr = (oh *)GC_base(dest); - ptr_t bp; - ptr_t bp_base; - -# ifdef LINT2 - /* Explicitly instruct the code analysis tool that */ - /* GC_get_back_ptr_info is not expected to be called with an */ - /* incorrect "dest" value. */ - if (!hdr) ABORT("Invalid GC_get_back_ptr_info argument"); -# endif - if (!GC_HAS_DEBUG_INFO((ptr_t) hdr)) return GC_NO_SPACE; - bp = GC_REVEAL_POINTER(hdr -> oh_back_ptr); - if (MARKED_FOR_FINALIZATION == bp) return GC_FINALIZER_REFD; - if (MARKED_FROM_REGISTER == bp) return GC_REFD_FROM_REG; - if (NOT_MARKED == bp) return GC_UNREFERENCED; -# if ALIGNMENT == 1 - /* Heuristically try to fix off by 1 errors we introduced by */ - /* insisting on even addresses. */ - { - ptr_t alternate_ptr = bp + 1; - ptr_t target = *(ptr_t *)bp; - ptr_t alternate_target = *(ptr_t *)alternate_ptr; - - if ((word)alternate_target >= (word)GC_least_plausible_heap_addr - && (word)alternate_target <= (word)GC_greatest_plausible_heap_addr - && ((word)target < (word)GC_least_plausible_heap_addr - || (word)target > (word)GC_greatest_plausible_heap_addr)) { - bp = alternate_ptr; - } - } -# endif - bp_base = GC_base(bp); - if (0 == bp_base) { - *base_p = bp; - *offset_p = 0; - return GC_REFD_FROM_ROOT; - } else { - if (GC_HAS_DEBUG_INFO(bp_base)) bp_base += sizeof(oh); - *base_p = bp_base; - *offset_p = bp - bp_base; - return GC_REFD_FROM_HEAP; - } - } - - /* Generate a random heap address. */ - /* The resulting address is in the heap, but */ - /* not necessarily inside a valid object. */ - GC_API void * GC_CALL GC_generate_random_heap_address(void) - { - size_t i; - size_t size; - word heap_offset = RANDOM(); - - if (GC_heapsize > RAND_MAX) { - heap_offset *= RAND_MAX; - heap_offset += RANDOM(); - } - heap_offset %= GC_heapsize; - /* This doesn't yield a uniform distribution, especially if */ - /* e.g. RAND_MAX = 1.5* GC_heapsize. But for typical cases, */ - /* it's not too bad. */ - for (i = 0;; ++i) { - if (i >= GC_n_heap_sects) - ABORT("GC_generate_random_heap_address: size inconsistency"); - - size = GC_heap_sects[i].hs_bytes; - if (heap_offset < size) { - break; - } else { - heap_offset -= size; - } - } - return GC_heap_sects[i].hs_start + heap_offset; - } - - /* Generate a random address inside a valid marked heap object. */ - GC_API void * GC_CALL GC_generate_random_valid_address(void) - { - ptr_t result; - ptr_t base; - do { - result = GC_generate_random_heap_address(); - base = GC_base(result); - } while (base == 0 || !GC_is_marked(base)); - return result; - } - - /* Print back trace for p */ - GC_API void GC_CALL GC_print_backtrace(void *p) - { - void *current = p; - int i; - GC_ref_kind source; - size_t offset; - void *base; - - GC_print_heap_obj(GC_base(current)); - - for (i = 0; ; ++i) { - source = GC_get_back_ptr_info(current, &base, &offset); - if (GC_UNREFERENCED == source) { - GC_err_printf("Reference could not be found\n"); - goto out; - } - if (GC_NO_SPACE == source) { - GC_err_printf("No debug info in object: Can't find reference\n"); - goto out; - } - GC_err_printf("Reachable via %d levels of pointers from ", i); - switch(source) { - case GC_REFD_FROM_ROOT: - GC_err_printf("root at %p\n\n", base); - goto out; - case GC_REFD_FROM_REG: - GC_err_printf("root in register\n\n"); - goto out; - case GC_FINALIZER_REFD: - GC_err_printf("list of finalizable objects\n\n"); - goto out; - case GC_REFD_FROM_HEAP: - GC_err_printf("offset %ld in object:\n", (long)offset); - /* Take GC_base(base) to get real base, i.e. header. */ - GC_print_heap_obj(GC_base(base)); - break; - default: - GC_err_printf("INTERNAL ERROR: UNEXPECTED SOURCE!!!!\n"); - goto out; - } - current = base; - } - out:; - } - - /* Force a garbage collection and generate/print a backtrace */ - /* from a random heap address. */ - GC_INNER void GC_generate_random_backtrace_no_gc(void) - { - void * current; - current = GC_generate_random_valid_address(); - GC_printf("\n****Chosen address %p in object\n", current); - GC_print_backtrace(current); - } - - GC_API void GC_CALL GC_generate_random_backtrace(void) - { - if (GC_try_to_collect(GC_never_stop_func) == 0) { - GC_err_printf("Cannot generate a backtrace: " - "garbage collection is disabled!\n"); - return; - } - GC_generate_random_backtrace_no_gc(); - } - -#endif /* KEEP_BACK_PTRS */ - -# define CROSSES_HBLK(p, sz) \ - (((word)((p) + sizeof(oh) + (sz) - 1) ^ (word)(p)) >= HBLKSIZE) - -/* Store debugging info into p. Return displaced pointer. */ -/* This version assumes we do hold the allocation lock. */ -STATIC ptr_t GC_store_debug_info_inner(ptr_t p, word sz GC_ATTR_UNUSED, - const char *string, int linenum) -{ - word * result = (word *)((oh *)p + 1); - - GC_ASSERT(GC_size(p) >= sizeof(oh) + sz); - GC_ASSERT(!(SMALL_OBJ(sz) && CROSSES_HBLK(p, sz))); -# ifdef KEEP_BACK_PTRS - ((oh *)p) -> oh_back_ptr = HIDE_BACK_PTR(NOT_MARKED); -# endif -# ifdef MAKE_BACK_GRAPH - ((oh *)p) -> oh_bg_ptr = HIDE_BACK_PTR((ptr_t)0); -# endif - ((oh *)p) -> oh_string = string; - ((oh *)p) -> oh_int = (word)linenum; -# ifndef SHORT_DBG_HDRS - ((oh *)p) -> oh_sz = sz; - ((oh *)p) -> oh_sf = START_FLAG ^ (word)result; - ((word *)p)[BYTES_TO_WORDS(GC_size(p))-1] = - result[SIMPLE_ROUNDED_UP_WORDS(sz)] = END_FLAG ^ (word)result; -# endif - return((ptr_t)result); -} - -GC_INNER ptr_t GC_store_debug_info(ptr_t p, word sz, const char *string, - int linenum) -{ - ptr_t result; - DCL_LOCK_STATE; - - LOCK(); - result = GC_store_debug_info_inner(p, sz, string, linenum); - UNLOCK(); - return result; -} - -#ifndef SHORT_DBG_HDRS - /* Check the object with debugging info at ohdr. */ - /* Return NULL if it's OK. Else return clobbered */ - /* address. */ - STATIC ptr_t GC_check_annotated_obj(oh *ohdr) - { - ptr_t body = (ptr_t)(ohdr + 1); - word gc_sz = GC_size((ptr_t)ohdr); - if (ohdr -> oh_sz + DEBUG_BYTES > gc_sz) { - return((ptr_t)(&(ohdr -> oh_sz))); - } - if (ohdr -> oh_sf != (START_FLAG ^ (word)body)) { - return((ptr_t)(&(ohdr -> oh_sf))); - } - if (((word *)ohdr)[BYTES_TO_WORDS(gc_sz)-1] != (END_FLAG ^ (word)body)) { - return((ptr_t)((word *)ohdr + BYTES_TO_WORDS(gc_sz)-1)); - } - if (((word *)body)[SIMPLE_ROUNDED_UP_WORDS(ohdr -> oh_sz)] - != (END_FLAG ^ (word)body)) { - return((ptr_t)((word *)body + SIMPLE_ROUNDED_UP_WORDS(ohdr->oh_sz))); - } - return(0); - } -#endif /* !SHORT_DBG_HDRS */ - -STATIC GC_describe_type_fn GC_describe_type_fns[MAXOBJKINDS] = {0}; - -GC_API void GC_CALL GC_register_describe_type_fn(int kind, - GC_describe_type_fn fn) -{ - GC_describe_type_fns[kind] = fn; -} - -#define GET_OH_LINENUM(ohdr) ((int)(ohdr)->oh_int) - -#ifndef SHORT_DBG_HDRS -# define IF_NOT_SHORTDBG_HDRS(x) x -# define COMMA_IFNOT_SHORTDBG_HDRS(x) /* comma */, x -#else -# define IF_NOT_SHORTDBG_HDRS(x) /* empty */ -# define COMMA_IFNOT_SHORTDBG_HDRS(x) /* empty */ -#endif - -/* Print a human-readable description of the object to stderr. */ -/* p points to somewhere inside an object with the debugging info. */ -STATIC void GC_print_obj(ptr_t p) -{ - oh * ohdr = (oh *)GC_base(p); - ptr_t q; - hdr * hhdr; - int kind; - char *kind_str; - char buffer[GC_TYPE_DESCR_LEN + 1]; - - GC_ASSERT(I_DONT_HOLD_LOCK()); -# ifdef LINT2 - if (!ohdr) ABORT("Invalid GC_print_obj argument"); -# endif - - q = (ptr_t)(ohdr + 1); - /* Print a type description for the object whose client-visible */ - /* address is q. */ - hhdr = GC_find_header(q); - kind = hhdr -> hb_obj_kind; - if (0 != GC_describe_type_fns[kind] && GC_is_marked(ohdr)) { - /* This should preclude free list objects except with */ - /* thread-local allocation. */ - buffer[GC_TYPE_DESCR_LEN] = 0; - (GC_describe_type_fns[kind])(q, buffer); - GC_ASSERT(buffer[GC_TYPE_DESCR_LEN] == 0); - kind_str = buffer; - } else { - switch(kind) { - case PTRFREE: - kind_str = "PTRFREE"; - break; - case NORMAL: - kind_str = "NORMAL"; - break; - case UNCOLLECTABLE: - kind_str = "UNCOLLECTABLE"; - break; -# ifdef ATOMIC_UNCOLLECTABLE - case AUNCOLLECTABLE: - kind_str = "ATOMIC_UNCOLLECTABLE"; - break; -# endif - case STUBBORN: - kind_str = "STUBBORN"; - break; - default: - kind_str = NULL; - /* The alternative is to use snprintf(buffer) but it is */ - /* not quite portable (see vsnprintf in misc.c). */ - } - } - - if (NULL != kind_str) { - GC_err_printf("%p (%s:%d," IF_NOT_SHORTDBG_HDRS(" sz=%lu,") " %s)\n", - (ptr_t)ohdr + sizeof(oh), - ohdr->oh_string, GET_OH_LINENUM(ohdr) /*, */ - COMMA_IFNOT_SHORTDBG_HDRS((unsigned long)ohdr->oh_sz), - kind_str); - } else { - GC_err_printf("%p (%s:%d," IF_NOT_SHORTDBG_HDRS(" sz=%lu,") - " kind=%d descr=0x%lx)\n", (ptr_t)ohdr + sizeof(oh), - ohdr->oh_string, GET_OH_LINENUM(ohdr) /*, */ - COMMA_IFNOT_SHORTDBG_HDRS((unsigned long)ohdr->oh_sz), - kind, (unsigned long)hhdr->hb_descr); - } - PRINT_CALL_CHAIN(ohdr); -} - -STATIC void GC_debug_print_heap_obj_proc(ptr_t p) -{ - GC_ASSERT(I_DONT_HOLD_LOCK()); - if (GC_HAS_DEBUG_INFO(p)) { - GC_print_obj(p); - } else { - GC_default_print_heap_obj_proc(p); - } -} - -#ifndef SHORT_DBG_HDRS - /* Use GC_err_printf and friends to print a description of the object */ - /* whose client-visible address is p, and which was smashed at */ - /* clobbered_addr. */ - STATIC void GC_print_smashed_obj(const char *msg, ptr_t p, - ptr_t clobbered_addr) - { - oh * ohdr = (oh *)GC_base(p); - - GC_ASSERT(I_DONT_HOLD_LOCK()); -# ifdef LINT2 - if (!ohdr) ABORT("Invalid GC_print_smashed_obj argument"); -# endif - if ((word)clobbered_addr <= (word)(&ohdr->oh_sz) - || ohdr -> oh_string == 0) { - GC_err_printf( - "%s %p in or near object at %p(, appr. sz = %lu)\n", - msg, clobbered_addr, p, - (unsigned long)(GC_size((ptr_t)ohdr) - DEBUG_BYTES)); - } else { - GC_err_printf("%s %p in or near object at %p (%s:%d, sz=%lu)\n", - msg, clobbered_addr, p, - (word)(ohdr -> oh_string) < HBLKSIZE ? "(smashed string)" : - ohdr -> oh_string[0] == '\0' ? "EMPTY(smashed?)" : - ohdr -> oh_string, - GET_OH_LINENUM(ohdr), (unsigned long)(ohdr -> oh_sz)); - PRINT_CALL_CHAIN(ohdr); - } - } -#endif - -#ifndef SHORT_DBG_HDRS - STATIC void GC_check_heap_proc (void); - STATIC void GC_print_all_smashed_proc (void); -#else - STATIC void GC_do_nothing(void) {} -#endif - -STATIC void GC_start_debugging_inner(void) -{ - GC_ASSERT(I_HOLD_LOCK()); -# ifndef SHORT_DBG_HDRS - GC_check_heap = GC_check_heap_proc; - GC_print_all_smashed = GC_print_all_smashed_proc; -# else - GC_check_heap = GC_do_nothing; - GC_print_all_smashed = GC_do_nothing; -# endif - GC_print_heap_obj = GC_debug_print_heap_obj_proc; - GC_debugging_started = TRUE; - GC_register_displacement_inner((word)sizeof(oh)); -} - -GC_INNER void GC_start_debugging(void) -{ - DCL_LOCK_STATE; - - LOCK(); - GC_start_debugging_inner(); - UNLOCK(); -} - -size_t GC_debug_header_size = sizeof(oh); - -GC_API void GC_CALL GC_debug_register_displacement(size_t offset) -{ - DCL_LOCK_STATE; - - LOCK(); - GC_register_displacement_inner(offset); - GC_register_displacement_inner((word)sizeof(oh) + offset); - UNLOCK(); -} - -#ifdef GC_ADD_CALLER -# if defined(HAVE_DLADDR) && defined(GC_RETURN_ADDR_PARENT) -# include - - STATIC void GC_caller_func_offset(word ad, const char **symp, int *offp) - { - Dl_info caller; - - if (ad && dladdr((void *)ad, &caller) && caller.dli_sname != NULL) { - *symp = caller.dli_sname; - *offp = (int)((char *)ad - (char *)caller.dli_saddr); - } - if (NULL == *symp) { - *symp = "unknown"; - } - } -# else -# define GC_caller_func_offset(ad, symp, offp) (void)(*(symp) = "unknown") -# endif -#endif /* GC_ADD_CALLER */ - -GC_API GC_ATTR_MALLOC void * GC_CALL GC_debug_malloc(size_t lb, - GC_EXTRA_PARAMS) -{ - void * result; - - /* Note that according to malloc() specification, if size is 0 then */ - /* malloc() returns either NULL, or a unique pointer value that can */ - /* later be successfully passed to free(). We always do the latter. */ - result = GC_malloc(lb + DEBUG_BYTES); -# ifdef GC_ADD_CALLER - if (s == NULL) { - GC_caller_func_offset(ra, &s, &i); - } -# endif - if (result == 0) { - GC_err_printf("GC_debug_malloc(%lu) returning NULL (%s:%d)\n", - (unsigned long)lb, s, i); - return(0); - } - if (!GC_debugging_started) { - GC_start_debugging(); - } - ADD_CALL_CHAIN(result, ra); - return (GC_store_debug_info(result, (word)lb, s, i)); -} - -GC_API GC_ATTR_MALLOC void * GC_CALL - GC_debug_malloc_ignore_off_page(size_t lb, GC_EXTRA_PARAMS) -{ - void * result = GC_malloc_ignore_off_page(lb + DEBUG_BYTES); - - if (result == 0) { - GC_err_printf("GC_debug_malloc_ignore_off_page(%lu)" - " returning NULL (%s:%d)\n", (unsigned long)lb, s, i); - return(0); - } - if (!GC_debugging_started) { - GC_start_debugging(); - } - ADD_CALL_CHAIN(result, ra); - return (GC_store_debug_info(result, (word)lb, s, i)); -} - -GC_API GC_ATTR_MALLOC void * GC_CALL - GC_debug_malloc_atomic_ignore_off_page(size_t lb, GC_EXTRA_PARAMS) -{ - void * result = GC_malloc_atomic_ignore_off_page(lb + DEBUG_BYTES); - - if (result == 0) { - GC_err_printf("GC_debug_malloc_atomic_ignore_off_page(%lu)" - " returning NULL (%s:%d)\n", (unsigned long)lb, s, i); - return(0); - } - if (!GC_debugging_started) { - GC_start_debugging(); - } - ADD_CALL_CHAIN(result, ra); - return (GC_store_debug_info(result, (word)lb, s, i)); -} - -STATIC void * GC_debug_generic_malloc(size_t lb, int knd, GC_EXTRA_PARAMS) -{ - void * result = GC_generic_malloc(lb + DEBUG_BYTES, knd); - - if (NULL == result) { - GC_err_printf( - "GC_debug_generic_malloc(%lu, %d) returning NULL (%s:%d)\n", - (unsigned long)lb, knd, s, i); - return NULL; - } - if (!GC_debugging_started) { - GC_start_debugging(); - } - ADD_CALL_CHAIN(result, ra); - return GC_store_debug_info(result, (word)lb, s, i); -} - -#ifdef DBG_HDRS_ALL - /* An allocation function for internal use. Normally internally */ - /* allocated objects do not have debug information. But in this */ - /* case, we need to make sure that all objects have debug headers. */ - /* We assume debugging was started in collector initialization, and */ - /* we already hold the GC lock. */ - GC_INNER void * GC_debug_generic_malloc_inner(size_t lb, int k) - { - void * result = GC_generic_malloc_inner(lb + DEBUG_BYTES, k); - - if (result == 0) { - GC_err_printf("GC internal allocation (%lu bytes) returning NULL\n", - (unsigned long) lb); - return(0); - } - if (!GC_debugging_started) { - GC_start_debugging_inner(); - } - ADD_CALL_CHAIN(result, GC_RETURN_ADDR); - return (GC_store_debug_info_inner(result, (word)lb, "INTERNAL", 0)); - } - - GC_INNER void * GC_debug_generic_malloc_inner_ignore_off_page(size_t lb, - int k) - { - void * result = GC_generic_malloc_inner_ignore_off_page( - lb + DEBUG_BYTES, k); - - if (result == 0) { - GC_err_printf("GC internal allocation (%lu bytes) returning NULL\n", - (unsigned long) lb); - return(0); - } - if (!GC_debugging_started) { - GC_start_debugging_inner(); - } - ADD_CALL_CHAIN(result, GC_RETURN_ADDR); - return (GC_store_debug_info_inner(result, (word)lb, "INTERNAL", 0)); - } -#endif /* DBG_HDRS_ALL */ - -#ifdef STUBBORN_ALLOC - GC_API GC_ATTR_MALLOC void * GC_CALL GC_debug_malloc_stubborn(size_t lb, - GC_EXTRA_PARAMS) - { - void * result = GC_malloc_stubborn(lb + DEBUG_BYTES); - - if (result == 0) { - GC_err_printf("GC_debug_malloc_stubborn(%lu)" - " returning NULL (%s:%d)\n", (unsigned long)lb, s, i); - return(0); - } - if (!GC_debugging_started) { - GC_start_debugging(); - } - ADD_CALL_CHAIN(result, ra); - return (GC_store_debug_info(result, (word)lb, s, i)); - } - - GC_API void GC_CALL GC_debug_change_stubborn(const void *p) - { - const void * q = GC_base_C(p); - hdr * hhdr; - - if (q == 0) { - ABORT_ARG1("GC_debug_change_stubborn: bad arg", ": %p", p); - } - hhdr = HDR(q); - if (hhdr -> hb_obj_kind != STUBBORN) { - ABORT_ARG1("GC_debug_change_stubborn: arg not stubborn", ": %p", p); - } - GC_change_stubborn(q); - } - - GC_API void GC_CALL GC_debug_end_stubborn_change(const void *p) - { - const void * q = GC_base_C(p); - hdr * hhdr; - - if (q == 0) { - ABORT_ARG1("GC_debug_end_stubborn_change: bad arg", ": %p", p); - } - hhdr = HDR(q); - if (hhdr -> hb_obj_kind != STUBBORN) { - ABORT_ARG1("GC_debug_end_stubborn_change: arg not stubborn", - ": %p", p); - } - GC_end_stubborn_change(q); - } - -#else /* !STUBBORN_ALLOC */ - - GC_API GC_ATTR_MALLOC void * GC_CALL GC_debug_malloc_stubborn(size_t lb, - GC_EXTRA_PARAMS) - { - return GC_debug_malloc(lb, OPT_RA s, i); - } - - GC_API void GC_CALL GC_debug_change_stubborn( - const void * p GC_ATTR_UNUSED) {} - - GC_API void GC_CALL GC_debug_end_stubborn_change( - const void * p GC_ATTR_UNUSED) {} -#endif /* !STUBBORN_ALLOC */ - -GC_API GC_ATTR_MALLOC void * GC_CALL GC_debug_malloc_atomic(size_t lb, - GC_EXTRA_PARAMS) -{ - void * result = GC_malloc_atomic(lb + DEBUG_BYTES); - - if (result == 0) { - GC_err_printf("GC_debug_malloc_atomic(%lu) returning NULL (%s:%d)\n", - (unsigned long)lb, s, i); - return(0); - } - if (!GC_debugging_started) { - GC_start_debugging(); - } - ADD_CALL_CHAIN(result, ra); - return (GC_store_debug_info(result, (word)lb, s, i)); -} - -GC_API GC_ATTR_MALLOC char * GC_CALL GC_debug_strdup(const char *str, - GC_EXTRA_PARAMS) -{ - char *copy; - size_t lb; - if (str == NULL) { - if (GC_find_leak) - GC_err_printf("strdup(NULL) behavior is undefined\n"); - return NULL; - } - - lb = strlen(str) + 1; - copy = GC_debug_malloc_atomic(lb, OPT_RA s, i); - if (copy == NULL) { -# ifndef MSWINCE - errno = ENOMEM; -# endif - return NULL; - } - BCOPY(str, copy, lb); - return copy; -} - -GC_API GC_ATTR_MALLOC char * GC_CALL GC_debug_strndup(const char *str, - size_t size, GC_EXTRA_PARAMS) -{ - char *copy; - size_t len = strlen(str); /* str is expected to be non-NULL */ - if (len > size) - len = size; - copy = GC_debug_malloc_atomic(len + 1, OPT_RA s, i); - if (copy == NULL) { -# ifndef MSWINCE - errno = ENOMEM; -# endif - return NULL; - } - BCOPY(str, copy, len); - copy[len] = '\0'; - return copy; -} - -#ifdef GC_REQUIRE_WCSDUP -# include /* for wcslen() */ - - GC_API GC_ATTR_MALLOC wchar_t * GC_CALL GC_debug_wcsdup(const wchar_t *str, - GC_EXTRA_PARAMS) - { - size_t lb = (wcslen(str) + 1) * sizeof(wchar_t); - wchar_t *copy = GC_debug_malloc_atomic(lb, OPT_RA s, i); - if (copy == NULL) { -# ifndef MSWINCE - errno = ENOMEM; -# endif - return NULL; - } - BCOPY(str, copy, lb); - return copy; - } -#endif /* GC_REQUIRE_WCSDUP */ - -GC_API GC_ATTR_MALLOC void * GC_CALL GC_debug_malloc_uncollectable(size_t lb, - GC_EXTRA_PARAMS) -{ - void * result = GC_malloc_uncollectable(lb + UNCOLLECTABLE_DEBUG_BYTES); - - if (result == 0) { - GC_err_printf("GC_debug_malloc_uncollectable(%lu)" - " returning NULL (%s:%d)\n", (unsigned long)lb, s, i); - return(0); - } - if (!GC_debugging_started) { - GC_start_debugging(); - } - ADD_CALL_CHAIN(result, ra); - return (GC_store_debug_info(result, (word)lb, s, i)); -} - -#ifdef ATOMIC_UNCOLLECTABLE - GC_API GC_ATTR_MALLOC void * GC_CALL - GC_debug_malloc_atomic_uncollectable(size_t lb, GC_EXTRA_PARAMS) - { - void * result = - GC_malloc_atomic_uncollectable(lb + UNCOLLECTABLE_DEBUG_BYTES); - - if (result == 0) { - GC_err_printf("GC_debug_malloc_atomic_uncollectable(%lu)" - " returning NULL (%s:%d)\n", (unsigned long)lb, s, i); - return(0); - } - if (!GC_debugging_started) { - GC_start_debugging(); - } - ADD_CALL_CHAIN(result, ra); - return (GC_store_debug_info(result, (word)lb, s, i)); - } -#endif /* ATOMIC_UNCOLLECTABLE */ - -#ifndef GC_FREED_MEM_MARKER -# if CPP_WORDSZ == 32 -# define GC_FREED_MEM_MARKER 0xdeadbeef -# else -# define GC_FREED_MEM_MARKER GC_WORD_C(0xEFBEADDEdeadbeef) -# endif -#endif - -GC_API void GC_CALL GC_debug_free(void * p) -{ - ptr_t base; - if (0 == p) return; - - base = GC_base(p); - if (base == 0) { - ABORT_ARG1("Invalid pointer passed to free()", ": %p", p); - } - if ((ptr_t)p - (ptr_t)base != sizeof(oh)) { - GC_err_printf( - "GC_debug_free called on pointer %p w/o debugging info\n", p); - } else { -# ifndef SHORT_DBG_HDRS - ptr_t clobbered = GC_check_annotated_obj((oh *)base); - word sz = GC_size(base); - if (clobbered != 0) { - GC_have_errors = TRUE; - if (((oh *)base) -> oh_sz == sz) { - GC_print_smashed_obj( - "GC_debug_free: found previously deallocated (?) object at", - p, clobbered); - return; /* ignore double free */ - } else { - GC_print_smashed_obj("GC_debug_free: found smashed location at", - p, clobbered); - } - } - /* Invalidate size (mark the object as deallocated) */ - ((oh *)base) -> oh_sz = sz; -# endif /* SHORT_DBG_HDRS */ - } - if (GC_find_leak -# ifndef SHORT_DBG_HDRS - && ((ptr_t)p - (ptr_t)base != sizeof(oh) || !GC_findleak_delay_free) -# endif - ) { - GC_free(base); - } else { - hdr * hhdr = HDR(p); - if (hhdr -> hb_obj_kind == UNCOLLECTABLE -# ifdef ATOMIC_UNCOLLECTABLE - || hhdr -> hb_obj_kind == AUNCOLLECTABLE -# endif - ) { - GC_free(base); - } else { - size_t i; - size_t obj_sz = BYTES_TO_WORDS(hhdr -> hb_sz - sizeof(oh)); - - for (i = 0; i < obj_sz; ++i) - ((word *)p)[i] = GC_FREED_MEM_MARKER; - GC_ASSERT((word *)p + i == (word *)(base + hhdr -> hb_sz)); - } - } /* !GC_find_leak */ -} - -#if defined(THREADS) && defined(DBG_HDRS_ALL) - /* Used internally; we assume it's called correctly. */ - GC_INNER void GC_debug_free_inner(void * p) - { - ptr_t base = GC_base(p); - GC_ASSERT((ptr_t)p - (ptr_t)base == sizeof(oh)); -# ifdef LINT2 - if (!base) ABORT("Invalid GC_debug_free_inner argument"); -# endif -# ifndef SHORT_DBG_HDRS - /* Invalidate size */ - ((oh *)base) -> oh_sz = GC_size(base); -# endif - GC_free_inner(base); - } -#endif - -GC_API void * GC_CALL GC_debug_realloc(void * p, size_t lb, GC_EXTRA_PARAMS) -{ - void * base; - void * result; - hdr * hhdr; - - if (p == 0) { - return GC_debug_malloc(lb, OPT_RA s, i); - } -# ifdef GC_ADD_CALLER - if (s == NULL) { - GC_caller_func_offset(ra, &s, &i); - } -# endif - base = GC_base(p); - if (base == 0) { - ABORT_ARG1("Invalid pointer passed to realloc()", ": %p", p); - } - if ((ptr_t)p - (ptr_t)base != sizeof(oh)) { - GC_err_printf( - "GC_debug_realloc called on pointer %p w/o debugging info\n", p); - return(GC_realloc(p, lb)); - } - hhdr = HDR(base); - switch (hhdr -> hb_obj_kind) { -# ifdef STUBBORN_ALLOC - case STUBBORN: - result = GC_debug_malloc_stubborn(lb, OPT_RA s, i); - break; -# endif - case NORMAL: - result = GC_debug_malloc(lb, OPT_RA s, i); - break; - case PTRFREE: - result = GC_debug_malloc_atomic(lb, OPT_RA s, i); - break; - case UNCOLLECTABLE: - result = GC_debug_malloc_uncollectable(lb, OPT_RA s, i); - break; -# ifdef ATOMIC_UNCOLLECTABLE - case AUNCOLLECTABLE: - result = GC_debug_malloc_atomic_uncollectable(lb, OPT_RA s, i); - break; -# endif - default: - result = NULL; /* initialized to prevent warning. */ - ABORT_RET("GC_debug_realloc: encountered bad kind"); - } - - if (result != NULL) { - size_t old_sz; -# ifdef SHORT_DBG_HDRS - old_sz = GC_size(base) - sizeof(oh); -# else - old_sz = ((oh *)base) -> oh_sz; -# endif - BCOPY(p, result, old_sz < lb ? old_sz : lb); - GC_debug_free(p); - } - return(result); -} - -GC_API GC_ATTR_MALLOC void * GC_CALL - GC_debug_generic_or_special_malloc(size_t lb, int knd, GC_EXTRA_PARAMS) -{ - switch (knd) { -# ifdef STUBBORN_ALLOC - case STUBBORN: - return GC_debug_malloc_stubborn(lb, OPT_RA s, i); -# endif - case PTRFREE: - return GC_debug_malloc_atomic(lb, OPT_RA s, i); - case NORMAL: - return GC_debug_malloc(lb, OPT_RA s, i); - case UNCOLLECTABLE: - return GC_debug_malloc_uncollectable(lb, OPT_RA s, i); -# ifdef ATOMIC_UNCOLLECTABLE - case AUNCOLLECTABLE: - return GC_debug_malloc_atomic_uncollectable(lb, OPT_RA s, i); -# endif - default: - return GC_debug_generic_malloc(lb, knd, OPT_RA s, i); - } -} - -#ifndef SHORT_DBG_HDRS - -/* List of smashed (clobbered) locations. We defer printing these, */ -/* since we can't always print them nicely with the allocation lock */ -/* held. We put them here instead of in GC_arrays, since it may be */ -/* useful to be able to look at them with the debugger. */ -#ifndef MAX_SMASHED -# define MAX_SMASHED 20 -#endif -STATIC ptr_t GC_smashed[MAX_SMASHED] = {0}; -STATIC unsigned GC_n_smashed = 0; - -STATIC void GC_add_smashed(ptr_t smashed) -{ - GC_ASSERT(GC_is_marked(GC_base(smashed))); - /* FIXME: Prevent adding an object while printing smashed list. */ - GC_smashed[GC_n_smashed] = smashed; - if (GC_n_smashed < MAX_SMASHED - 1) ++GC_n_smashed; - /* In case of overflow, we keep the first MAX_SMASHED-1 */ - /* entries plus the last one. */ - GC_have_errors = TRUE; -} - -/* Print all objects on the list. Clear the list. */ -STATIC void GC_print_all_smashed_proc(void) -{ - unsigned i; - - GC_ASSERT(I_DONT_HOLD_LOCK()); - if (GC_n_smashed == 0) return; - GC_err_printf("GC_check_heap_block: found %u smashed heap objects:\n", - GC_n_smashed); - for (i = 0; i < GC_n_smashed; ++i) { - ptr_t base = (ptr_t)GC_base(GC_smashed[i]); - -# ifdef LINT2 - if (!base) ABORT("Invalid GC_smashed element"); -# endif - GC_print_smashed_obj("", base + sizeof(oh), GC_smashed[i]); - GC_smashed[i] = 0; - } - GC_n_smashed = 0; -} - -/* Check all marked objects in the given block for validity */ -/* Avoid GC_apply_to_each_object for performance reasons. */ -STATIC void GC_check_heap_block(struct hblk *hbp, word dummy GC_ATTR_UNUSED) -{ - struct hblkhdr * hhdr = HDR(hbp); - size_t sz = hhdr -> hb_sz; - size_t bit_no; - char *p, *plim; - - p = hbp->hb_body; - if (sz > MAXOBJBYTES) { - plim = p; - } else { - plim = hbp->hb_body + HBLKSIZE - sz; - } - /* go through all words in block */ - for (bit_no = 0; (word)p <= (word)plim; - bit_no += MARK_BIT_OFFSET(sz), p += sz) { - if (mark_bit_from_hdr(hhdr, bit_no) && GC_HAS_DEBUG_INFO((ptr_t)p)) { - ptr_t clobbered = GC_check_annotated_obj((oh *)p); - if (clobbered != 0) - GC_add_smashed(clobbered); - } - } -} - -/* This assumes that all accessible objects are marked, and that */ -/* I hold the allocation lock. Normally called by collector. */ -STATIC void GC_check_heap_proc(void) -{ - GC_STATIC_ASSERT((sizeof(oh) & (GRANULE_BYTES - 1)) == 0); - /* FIXME: Should we check for twice that alignment? */ - GC_apply_to_all_blocks(GC_check_heap_block, 0); -} - -GC_INNER GC_bool GC_check_leaked(ptr_t base) -{ - size_t i; - size_t obj_sz; - word *p; - - if ( -# if defined(KEEP_BACK_PTRS) || defined(MAKE_BACK_GRAPH) - (*(word *)base & 1) != 0 && -# endif - GC_has_other_debug_info(base) >= 0) - return TRUE; /* object has leaked */ - - /* Validate freed object's content. */ - p = (word *)(base + sizeof(oh)); - obj_sz = BYTES_TO_WORDS(HDR(base)->hb_sz - sizeof(oh)); - for (i = 0; i < obj_sz; ++i) - if (p[i] != GC_FREED_MEM_MARKER) { - GC_set_mark_bit(base); /* do not reclaim it in this cycle */ - GC_add_smashed((ptr_t)(&p[i])); /* alter-after-free detected */ - break; /* don't report any other smashed locations in the object */ - } - - return FALSE; /* GC_debug_free() has been called */ -} - -#endif /* !SHORT_DBG_HDRS */ - -#ifndef GC_NO_FINALIZATION - -struct closure { - GC_finalization_proc cl_fn; - void * cl_data; -}; - -STATIC void * GC_make_closure(GC_finalization_proc fn, void * data) -{ - struct closure * result = -# ifdef DBG_HDRS_ALL - (struct closure *) GC_debug_malloc(sizeof (struct closure), - GC_EXTRAS); -# else - (struct closure *) GC_malloc(sizeof (struct closure)); -# endif - if (result != 0) { - result -> cl_fn = fn; - result -> cl_data = data; - } - return((void *)result); -} - -/* An auxiliary fns to make finalization work correctly with displaced */ -/* pointers introduced by the debugging allocators. */ -STATIC void GC_CALLBACK GC_debug_invoke_finalizer(void * obj, void * data) -{ - struct closure * cl = (struct closure *) data; - (*(cl -> cl_fn))((void *)((char *)obj + sizeof(oh)), cl -> cl_data); -} - -/* Special finalizer_proc value to detect GC_register_finalizer() failure. */ -#define OFN_UNSET (GC_finalization_proc)(signed_word)-1 - -/* Set ofn and ocd to reflect the values we got back. */ -static void store_old(void *obj, GC_finalization_proc my_old_fn, - struct closure *my_old_cd, GC_finalization_proc *ofn, - void **ocd) -{ - if (0 != my_old_fn) { - if (my_old_fn == OFN_UNSET) { - /* register_finalizer() failed; (*ofn) and (*ocd) are unchanged. */ - return; - } - if (my_old_fn != GC_debug_invoke_finalizer) { - GC_err_printf("Debuggable object at %p had a non-debug finalizer\n", - obj); - /* This should probably be fatal. */ - } else { - if (ofn) *ofn = my_old_cd -> cl_fn; - if (ocd) *ocd = my_old_cd -> cl_data; - } - } else { - if (ofn) *ofn = 0; - if (ocd) *ocd = 0; - } -} - -GC_API void GC_CALL GC_debug_register_finalizer(void * obj, - GC_finalization_proc fn, - void * cd, GC_finalization_proc *ofn, - void * *ocd) -{ - GC_finalization_proc my_old_fn = OFN_UNSET; - void * my_old_cd; - ptr_t base = GC_base(obj); - if (0 == base) { - /* We won't collect it, hence finalizer wouldn't be run. */ - if (ocd) *ocd = 0; - if (ofn) *ofn = 0; - return; - } - if ((ptr_t)obj - base != sizeof(oh)) { - GC_err_printf("GC_debug_register_finalizer called with" - " non-base-pointer %p\n", obj); - } - if (0 == fn) { - GC_register_finalizer(base, 0, 0, &my_old_fn, &my_old_cd); - } else { - cd = GC_make_closure(fn, cd); - if (cd == 0) return; /* out of memory */ - GC_register_finalizer(base, GC_debug_invoke_finalizer, - cd, &my_old_fn, &my_old_cd); - } - store_old(obj, my_old_fn, (struct closure *)my_old_cd, ofn, ocd); -} - -GC_API void GC_CALL GC_debug_register_finalizer_no_order - (void * obj, GC_finalization_proc fn, - void * cd, GC_finalization_proc *ofn, - void * *ocd) -{ - GC_finalization_proc my_old_fn = OFN_UNSET; - void * my_old_cd; - ptr_t base = GC_base(obj); - if (0 == base) { - /* We won't collect it, hence finalizer wouldn't be run. */ - if (ocd) *ocd = 0; - if (ofn) *ofn = 0; - return; - } - if ((ptr_t)obj - base != sizeof(oh)) { - GC_err_printf("GC_debug_register_finalizer_no_order called with" - " non-base-pointer %p\n", obj); - } - if (0 == fn) { - GC_register_finalizer_no_order(base, 0, 0, &my_old_fn, &my_old_cd); - } else { - cd = GC_make_closure(fn, cd); - if (cd == 0) return; /* out of memory */ - GC_register_finalizer_no_order(base, GC_debug_invoke_finalizer, - cd, &my_old_fn, &my_old_cd); - } - store_old(obj, my_old_fn, (struct closure *)my_old_cd, ofn, ocd); -} - -GC_API void GC_CALL GC_debug_register_finalizer_unreachable - (void * obj, GC_finalization_proc fn, - void * cd, GC_finalization_proc *ofn, - void * *ocd) -{ - GC_finalization_proc my_old_fn = OFN_UNSET; - void * my_old_cd; - ptr_t base = GC_base(obj); - if (0 == base) { - /* We won't collect it, hence finalizer wouldn't be run. */ - if (ocd) *ocd = 0; - if (ofn) *ofn = 0; - return; - } - if ((ptr_t)obj - base != sizeof(oh)) { - GC_err_printf("GC_debug_register_finalizer_unreachable called with" - " non-base-pointer %p\n", obj); - } - if (0 == fn) { - GC_register_finalizer_unreachable(base, 0, 0, &my_old_fn, &my_old_cd); - } else { - cd = GC_make_closure(fn, cd); - if (cd == 0) return; /* out of memory */ - GC_register_finalizer_unreachable(base, GC_debug_invoke_finalizer, - cd, &my_old_fn, &my_old_cd); - } - store_old(obj, my_old_fn, (struct closure *)my_old_cd, ofn, ocd); -} - -GC_API void GC_CALL GC_debug_register_finalizer_ignore_self - (void * obj, GC_finalization_proc fn, - void * cd, GC_finalization_proc *ofn, - void * *ocd) -{ - GC_finalization_proc my_old_fn = OFN_UNSET; - void * my_old_cd; - ptr_t base = GC_base(obj); - if (0 == base) { - /* We won't collect it, hence finalizer wouldn't be run. */ - if (ocd) *ocd = 0; - if (ofn) *ofn = 0; - return; - } - if ((ptr_t)obj - base != sizeof(oh)) { - GC_err_printf("GC_debug_register_finalizer_ignore_self called with" - " non-base-pointer %p\n", obj); - } - if (0 == fn) { - GC_register_finalizer_ignore_self(base, 0, 0, &my_old_fn, &my_old_cd); - } else { - cd = GC_make_closure(fn, cd); - if (cd == 0) return; /* out of memory */ - GC_register_finalizer_ignore_self(base, GC_debug_invoke_finalizer, - cd, &my_old_fn, &my_old_cd); - } - store_old(obj, my_old_fn, (struct closure *)my_old_cd, ofn, ocd); -} - -#endif /* !GC_NO_FINALIZATION */ - -GC_API GC_ATTR_MALLOC void * GC_CALL GC_debug_malloc_replacement(size_t lb) -{ - return GC_debug_malloc(lb, GC_DBG_EXTRAS); -} - -GC_API void * GC_CALL GC_debug_realloc_replacement(void *p, size_t lb) -{ - return GC_debug_realloc(p, lb, GC_DBG_EXTRAS); -} diff -Nru ecl-16.1.2/src/bdwgc/depcomp ecl-16.1.3+ds/src/bdwgc/depcomp --- ecl-16.1.2/src/bdwgc/depcomp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/depcomp 1970-01-01 00:00:00.000000000 +0000 @@ -1,791 +0,0 @@ -#! /bin/sh -# depcomp - compile a program generating dependencies as side-effects - -scriptversion=2013-05-30.07; # UTC - -# Copyright (C) 1999-2014 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, see . - -# 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 Alexandre Oliva . - -case $1 in - '') - echo "$0: No command. Try '$0 --help' for more information." 1>&2 - exit 1; - ;; - -h | --h*) - cat <<\EOF -Usage: depcomp [--help] [--version] PROGRAM [ARGS] - -Run PROGRAMS ARGS to compile a file, generating dependencies -as side-effects. - -Environment variables: - depmode Dependency tracking mode. - source Source file read by 'PROGRAMS ARGS'. - object Object file output by 'PROGRAMS ARGS'. - DEPDIR directory where to store dependencies. - depfile Dependency file to output. - tmpdepfile Temporary file to use when outputting dependencies. - libtool Whether libtool is used (yes/no). - -Report bugs to . -EOF - exit $? - ;; - -v | --v*) - echo "depcomp $scriptversion" - exit $? - ;; -esac - -# Get the directory component of the given path, and save it in the -# global variables '$dir'. Note that this directory component will -# be either empty or ending with a '/' character. This is deliberate. -set_dir_from () -{ - case $1 in - */*) dir=`echo "$1" | sed -e 's|/[^/]*$|/|'`;; - *) dir=;; - esac -} - -# Get the suffix-stripped basename of the given path, and save it the -# global variable '$base'. -set_base_from () -{ - base=`echo "$1" | sed -e 's|^.*/||' -e 's/\.[^.]*$//'` -} - -# If no dependency file was actually created by the compiler invocation, -# we still have to create a dummy depfile, to avoid errors with the -# Makefile "include basename.Plo" scheme. -make_dummy_depfile () -{ - echo "#dummy" > "$depfile" -} - -# Factor out some common post-processing of the generated depfile. -# Requires the auxiliary global variable '$tmpdepfile' to be set. -aix_post_process_depfile () -{ - # If the compiler actually managed to produce a dependency file, - # post-process it. - if test -f "$tmpdepfile"; then - # Each line is of the form 'foo.o: dependency.h'. - # Do two passes, one to just change these to - # $object: dependency.h - # and one to simply output - # dependency.h: - # which is needed to avoid the deleted-header problem. - { sed -e "s,^.*\.[$lower]*:,$object:," < "$tmpdepfile" - sed -e "s,^.*\.[$lower]*:[$tab ]*,," -e 's,$,:,' < "$tmpdepfile" - } > "$depfile" - rm -f "$tmpdepfile" - else - make_dummy_depfile - fi -} - -# A tabulation character. -tab=' ' -# A newline character. -nl=' -' -# Character ranges might be problematic outside the C locale. -# These definitions help. -upper=ABCDEFGHIJKLMNOPQRSTUVWXYZ -lower=abcdefghijklmnopqrstuvwxyz -digits=0123456789 -alpha=${upper}${lower} - -if test -z "$depmode" || test -z "$source" || test -z "$object"; then - echo "depcomp: Variables source, object and depmode must be set" 1>&2 - exit 1 -fi - -# Dependencies for sub/bar.o or sub/bar.obj go into sub/.deps/bar.Po. -depfile=${depfile-`echo "$object" | - sed 's|[^\\/]*$|'${DEPDIR-.deps}'/&|;s|\.\([^.]*\)$|.P\1|;s|Pobj$|Po|'`} -tmpdepfile=${tmpdepfile-`echo "$depfile" | sed 's/\.\([^.]*\)$/.T\1/'`} - -rm -f "$tmpdepfile" - -# Avoid interferences from the environment. -gccflag= dashmflag= - -# Some modes work just like other modes, but use different flags. We -# parameterize here, but still list the modes in the big case below, -# to make depend.m4 easier to write. Note that we *cannot* use a case -# here, because this file can only contain one case statement. -if test "$depmode" = hp; then - # HP compiler uses -M and no extra arg. - gccflag=-M - depmode=gcc -fi - -if test "$depmode" = dashXmstdout; then - # This is just like dashmstdout with a different argument. - dashmflag=-xM - depmode=dashmstdout -fi - -cygpath_u="cygpath -u -f -" -if test "$depmode" = msvcmsys; then - # This is just like msvisualcpp but w/o cygpath translation. - # Just convert the backslash-escaped backslashes to single forward - # slashes to satisfy depend.m4 - cygpath_u='sed s,\\\\,/,g' - depmode=msvisualcpp -fi - -if test "$depmode" = msvc7msys; then - # This is just like msvc7 but w/o cygpath translation. - # Just convert the backslash-escaped backslashes to single forward - # slashes to satisfy depend.m4 - cygpath_u='sed s,\\\\,/,g' - depmode=msvc7 -fi - -if test "$depmode" = xlc; then - # IBM C/C++ Compilers xlc/xlC can output gcc-like dependency information. - gccflag=-qmakedep=gcc,-MF - depmode=gcc -fi - -case "$depmode" in -gcc3) -## gcc 3 implements dependency tracking that does exactly what -## we want. Yay! Note: for some reason libtool 1.4 doesn't like -## it if -MD -MP comes after the -MF stuff. Hmm. -## Unfortunately, FreeBSD c89 acceptance of flags depends upon -## the command line argument order; so add the flags where they -## appear in depend2.am. Note that the slowdown incurred here -## affects only configure: in makefiles, %FASTDEP% shortcuts this. - for arg - do - case $arg in - -c) set fnord "$@" -MT "$object" -MD -MP -MF "$tmpdepfile" "$arg" ;; - *) set fnord "$@" "$arg" ;; - esac - shift # fnord - shift # $arg - done - "$@" - stat=$? - if test $stat -ne 0; then - rm -f "$tmpdepfile" - exit $stat - fi - mv "$tmpdepfile" "$depfile" - ;; - -gcc) -## Note that this doesn't just cater to obsosete pre-3.x GCC compilers. -## but also to in-use compilers like IMB xlc/xlC and the HP C compiler. -## (see the conditional assignment to $gccflag above). -## There are various ways to get dependency output from gcc. Here's -## why we pick this rather obscure method: -## - Don't want to use -MD because we'd like the dependencies to end -## up in a subdir. Having to rename by hand is ugly. -## (We might end up doing this anyway to support other compilers.) -## - The DEPENDENCIES_OUTPUT environment variable makes gcc act like -## -MM, not -M (despite what the docs say). Also, it might not be -## supported by the other compilers which use the 'gcc' depmode. -## - Using -M directly means running the compiler twice (even worse -## than renaming). - if test -z "$gccflag"; then - gccflag=-MD, - fi - "$@" -Wp,"$gccflag$tmpdepfile" - stat=$? - if test $stat -ne 0; then - rm -f "$tmpdepfile" - exit $stat - fi - rm -f "$depfile" - echo "$object : \\" > "$depfile" - # The second -e expression handles DOS-style file names with drive - # letters. - sed -e 's/^[^:]*: / /' \ - -e 's/^['$alpha']:\/[^:]*: / /' < "$tmpdepfile" >> "$depfile" -## This next piece of magic avoids the "deleted header file" problem. -## The problem is that when a header file which appears in a .P file -## is deleted, the dependency causes make to die (because there is -## typically no way to rebuild the header). We avoid this by adding -## dummy dependencies for each header file. Too bad gcc doesn't do -## this for us directly. -## Some versions of gcc put a space before the ':'. On the theory -## that the space means something, we add a space to the output as -## well. hp depmode also adds that space, but also prefixes the VPATH -## to the object. Take care to not repeat it in the output. -## Some versions of the HPUX 10.20 sed can't process this invocation -## correctly. Breaking it into two sed invocations is a workaround. - tr ' ' "$nl" < "$tmpdepfile" \ - | sed -e 's/^\\$//' -e '/^$/d' -e "s|.*$object$||" -e '/:$/d' \ - | sed -e 's/$/ :/' >> "$depfile" - rm -f "$tmpdepfile" - ;; - -hp) - # This case exists only to let depend.m4 do its work. It works by - # looking at the text of this script. This case will never be run, - # since it is checked for above. - exit 1 - ;; - -sgi) - if test "$libtool" = yes; then - "$@" "-Wp,-MDupdate,$tmpdepfile" - else - "$@" -MDupdate "$tmpdepfile" - fi - stat=$? - if test $stat -ne 0; then - rm -f "$tmpdepfile" - exit $stat - fi - rm -f "$depfile" - - if test -f "$tmpdepfile"; then # yes, the sourcefile depend on other files - echo "$object : \\" > "$depfile" - # Clip off the initial element (the dependent). Don't try to be - # clever and replace this with sed code, as IRIX sed won't handle - # lines with more than a fixed number of characters (4096 in - # IRIX 6.2 sed, 8192 in IRIX 6.5). We also remove comment lines; - # the IRIX cc adds comments like '#:fec' to the end of the - # dependency line. - tr ' ' "$nl" < "$tmpdepfile" \ - | sed -e 's/^.*\.o://' -e 's/#.*$//' -e '/^$/ d' \ - | tr "$nl" ' ' >> "$depfile" - echo >> "$depfile" - # The second pass generates a dummy entry for each header file. - tr ' ' "$nl" < "$tmpdepfile" \ - | sed -e 's/^.*\.o://' -e 's/#.*$//' -e '/^$/ d' -e 's/$/:/' \ - >> "$depfile" - else - make_dummy_depfile - fi - rm -f "$tmpdepfile" - ;; - -xlc) - # This case exists only to let depend.m4 do its work. It works by - # looking at the text of this script. This case will never be run, - # since it is checked for above. - exit 1 - ;; - -aix) - # The C for AIX Compiler uses -M and outputs the dependencies - # in a .u file. In older versions, this file always lives in the - # current directory. Also, the AIX compiler puts '$object:' at the - # start of each line; $object doesn't have directory information. - # Version 6 uses the directory in both cases. - set_dir_from "$object" - set_base_from "$object" - if test "$libtool" = yes; then - tmpdepfile1=$dir$base.u - tmpdepfile2=$base.u - tmpdepfile3=$dir.libs/$base.u - "$@" -Wc,-M - else - tmpdepfile1=$dir$base.u - tmpdepfile2=$dir$base.u - tmpdepfile3=$dir$base.u - "$@" -M - fi - stat=$? - if test $stat -ne 0; then - rm -f "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" - exit $stat - fi - - for tmpdepfile in "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" - do - test -f "$tmpdepfile" && break - done - aix_post_process_depfile - ;; - -tcc) - # tcc (Tiny C Compiler) understand '-MD -MF file' since version 0.9.26 - # FIXME: That version still under development at the moment of writing. - # Make that this statement remains true also for stable, released - # versions. - # It will wrap lines (doesn't matter whether long or short) with a - # trailing '\', as in: - # - # foo.o : \ - # foo.c \ - # foo.h \ - # - # It will put a trailing '\' even on the last line, and will use leading - # spaces rather than leading tabs (at least since its commit 0394caf7 - # "Emit spaces for -MD"). - "$@" -MD -MF "$tmpdepfile" - stat=$? - if test $stat -ne 0; then - rm -f "$tmpdepfile" - exit $stat - fi - rm -f "$depfile" - # Each non-empty line is of the form 'foo.o : \' or ' dep.h \'. - # We have to change lines of the first kind to '$object: \'. - sed -e "s|.*:|$object :|" < "$tmpdepfile" > "$depfile" - # And for each line of the second kind, we have to emit a 'dep.h:' - # dummy dependency, to avoid the deleted-header problem. - sed -n -e 's|^ *\(.*\) *\\$|\1:|p' < "$tmpdepfile" >> "$depfile" - rm -f "$tmpdepfile" - ;; - -## The order of this option in the case statement is important, since the -## shell code in configure will try each of these formats in the order -## listed in this file. A plain '-MD' option would be understood by many -## compilers, so we must ensure this comes after the gcc and icc options. -pgcc) - # Portland's C compiler understands '-MD'. - # Will always output deps to 'file.d' where file is the root name of the - # source file under compilation, even if file resides in a subdirectory. - # The object file name does not affect the name of the '.d' file. - # pgcc 10.2 will output - # foo.o: sub/foo.c sub/foo.h - # and will wrap long lines using '\' : - # foo.o: sub/foo.c ... \ - # sub/foo.h ... \ - # ... - set_dir_from "$object" - # Use the source, not the object, to determine the base name, since - # that's sadly what pgcc will do too. - set_base_from "$source" - tmpdepfile=$base.d - - # For projects that build the same source file twice into different object - # files, the pgcc approach of using the *source* file root name can cause - # problems in parallel builds. Use a locking strategy to avoid stomping on - # the same $tmpdepfile. - lockdir=$base.d-lock - trap " - echo '$0: caught signal, cleaning up...' >&2 - rmdir '$lockdir' - exit 1 - " 1 2 13 15 - numtries=100 - i=$numtries - while test $i -gt 0; do - # mkdir is a portable test-and-set. - if mkdir "$lockdir" 2>/dev/null; then - # This process acquired the lock. - "$@" -MD - stat=$? - # Release the lock. - rmdir "$lockdir" - break - else - # If the lock is being held by a different process, wait - # until the winning process is done or we timeout. - while test -d "$lockdir" && test $i -gt 0; do - sleep 1 - i=`expr $i - 1` - done - fi - i=`expr $i - 1` - done - trap - 1 2 13 15 - if test $i -le 0; then - echo "$0: failed to acquire lock after $numtries attempts" >&2 - echo "$0: check lockdir '$lockdir'" >&2 - exit 1 - fi - - if test $stat -ne 0; then - rm -f "$tmpdepfile" - exit $stat - fi - rm -f "$depfile" - # Each line is of the form `foo.o: dependent.h', - # or `foo.o: dep1.h dep2.h \', or ` dep3.h dep4.h \'. - # Do two passes, one to just change these to - # `$object: dependent.h' and one to simply `dependent.h:'. - sed "s,^[^:]*:,$object :," < "$tmpdepfile" > "$depfile" - # Some versions of the HPUX 10.20 sed can't process this invocation - # correctly. Breaking it into two sed invocations is a workaround. - sed 's,^[^:]*: \(.*\)$,\1,;s/^\\$//;/^$/d;/:$/d' < "$tmpdepfile" \ - | sed -e 's/$/ :/' >> "$depfile" - rm -f "$tmpdepfile" - ;; - -hp2) - # The "hp" stanza above does not work with aCC (C++) and HP's ia64 - # compilers, which have integrated preprocessors. The correct option - # to use with these is +Maked; it writes dependencies to a file named - # 'foo.d', which lands next to the object file, wherever that - # happens to be. - # Much of this is similar to the tru64 case; see comments there. - set_dir_from "$object" - set_base_from "$object" - if test "$libtool" = yes; then - tmpdepfile1=$dir$base.d - tmpdepfile2=$dir.libs/$base.d - "$@" -Wc,+Maked - else - tmpdepfile1=$dir$base.d - tmpdepfile2=$dir$base.d - "$@" +Maked - fi - stat=$? - if test $stat -ne 0; then - rm -f "$tmpdepfile1" "$tmpdepfile2" - exit $stat - fi - - for tmpdepfile in "$tmpdepfile1" "$tmpdepfile2" - do - test -f "$tmpdepfile" && break - done - if test -f "$tmpdepfile"; then - sed -e "s,^.*\.[$lower]*:,$object:," "$tmpdepfile" > "$depfile" - # Add 'dependent.h:' lines. - sed -ne '2,${ - s/^ *// - s/ \\*$// - s/$/:/ - p - }' "$tmpdepfile" >> "$depfile" - else - make_dummy_depfile - fi - rm -f "$tmpdepfile" "$tmpdepfile2" - ;; - -tru64) - # The Tru64 compiler uses -MD to generate dependencies as a side - # effect. 'cc -MD -o foo.o ...' puts the dependencies into 'foo.o.d'. - # At least on Alpha/Redhat 6.1, Compaq CCC V6.2-504 seems to put - # dependencies in 'foo.d' instead, so we check for that too. - # Subdirectories are respected. - set_dir_from "$object" - set_base_from "$object" - - if test "$libtool" = yes; then - # Libtool generates 2 separate objects for the 2 libraries. These - # two compilations output dependencies in $dir.libs/$base.o.d and - # in $dir$base.o.d. We have to check for both files, because - # one of the two compilations can be disabled. We should prefer - # $dir$base.o.d over $dir.libs/$base.o.d because the latter is - # automatically cleaned when .libs/ is deleted, while ignoring - # the former would cause a distcleancheck panic. - tmpdepfile1=$dir$base.o.d # libtool 1.5 - tmpdepfile2=$dir.libs/$base.o.d # Likewise. - tmpdepfile3=$dir.libs/$base.d # Compaq CCC V6.2-504 - "$@" -Wc,-MD - else - tmpdepfile1=$dir$base.d - tmpdepfile2=$dir$base.d - tmpdepfile3=$dir$base.d - "$@" -MD - fi - - stat=$? - if test $stat -ne 0; then - rm -f "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" - exit $stat - fi - - for tmpdepfile in "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" - do - test -f "$tmpdepfile" && break - done - # Same post-processing that is required for AIX mode. - aix_post_process_depfile - ;; - -msvc7) - if test "$libtool" = yes; then - showIncludes=-Wc,-showIncludes - else - showIncludes=-showIncludes - fi - "$@" $showIncludes > "$tmpdepfile" - stat=$? - grep -v '^Note: including file: ' "$tmpdepfile" - if test $stat -ne 0; then - rm -f "$tmpdepfile" - exit $stat - fi - rm -f "$depfile" - echo "$object : \\" > "$depfile" - # The first sed program below extracts the file names and escapes - # backslashes for cygpath. The second sed program outputs the file - # name when reading, but also accumulates all include files in the - # hold buffer in order to output them again at the end. This only - # works with sed implementations that can handle large buffers. - sed < "$tmpdepfile" -n ' -/^Note: including file: *\(.*\)/ { - s//\1/ - s/\\/\\\\/g - p -}' | $cygpath_u | sort -u | sed -n ' -s/ /\\ /g -s/\(.*\)/'"$tab"'\1 \\/p -s/.\(.*\) \\/\1:/ -H -$ { - s/.*/'"$tab"'/ - G - p -}' >> "$depfile" - echo >> "$depfile" # make sure the fragment doesn't end with a backslash - rm -f "$tmpdepfile" - ;; - -msvc7msys) - # This case exists only to let depend.m4 do its work. It works by - # looking at the text of this script. This case will never be run, - # since it is checked for above. - exit 1 - ;; - -#nosideeffect) - # This comment above is used by automake to tell side-effect - # dependency tracking mechanisms from slower ones. - -dashmstdout) - # Important note: in order to support this mode, a compiler *must* - # always write the preprocessed file to stdout, regardless of -o. - "$@" || exit $? - - # Remove the call to Libtool. - if test "$libtool" = yes; then - while test "X$1" != 'X--mode=compile'; do - shift - done - shift - fi - - # Remove '-o $object'. - IFS=" " - for arg - do - case $arg in - -o) - shift - ;; - $object) - shift - ;; - *) - set fnord "$@" "$arg" - shift # fnord - shift # $arg - ;; - esac - done - - test -z "$dashmflag" && dashmflag=-M - # Require at least two characters before searching for ':' - # in the target name. This is to cope with DOS-style filenames: - # a dependency such as 'c:/foo/bar' could be seen as target 'c' otherwise. - "$@" $dashmflag | - sed "s|^[$tab ]*[^:$tab ][^:][^:]*:[$tab ]*|$object: |" > "$tmpdepfile" - rm -f "$depfile" - cat < "$tmpdepfile" > "$depfile" - # Some versions of the HPUX 10.20 sed can't process this sed invocation - # correctly. Breaking it into two sed invocations is a workaround. - tr ' ' "$nl" < "$tmpdepfile" \ - | sed -e 's/^\\$//' -e '/^$/d' -e '/:$/d' \ - | sed -e 's/$/ :/' >> "$depfile" - rm -f "$tmpdepfile" - ;; - -dashXmstdout) - # This case only exists to satisfy depend.m4. It is never actually - # run, as this mode is specially recognized in the preamble. - exit 1 - ;; - -makedepend) - "$@" || exit $? - # Remove any Libtool call - if test "$libtool" = yes; then - while test "X$1" != 'X--mode=compile'; do - shift - done - shift - fi - # X makedepend - shift - cleared=no eat=no - for arg - do - case $cleared in - no) - set ""; shift - cleared=yes ;; - esac - if test $eat = yes; then - eat=no - continue - fi - case "$arg" in - -D*|-I*) - set fnord "$@" "$arg"; shift ;; - # Strip any option that makedepend may not understand. Remove - # the object too, otherwise makedepend will parse it as a source file. - -arch) - eat=yes ;; - -*|$object) - ;; - *) - set fnord "$@" "$arg"; shift ;; - esac - done - obj_suffix=`echo "$object" | sed 's/^.*\././'` - touch "$tmpdepfile" - ${MAKEDEPEND-makedepend} -o"$obj_suffix" -f"$tmpdepfile" "$@" - rm -f "$depfile" - # makedepend may prepend the VPATH from the source file name to the object. - # No need to regex-escape $object, excess matching of '.' is harmless. - sed "s|^.*\($object *:\)|\1|" "$tmpdepfile" > "$depfile" - # Some versions of the HPUX 10.20 sed can't process the last invocation - # correctly. Breaking it into two sed invocations is a workaround. - sed '1,2d' "$tmpdepfile" \ - | tr ' ' "$nl" \ - | sed -e 's/^\\$//' -e '/^$/d' -e '/:$/d' \ - | sed -e 's/$/ :/' >> "$depfile" - rm -f "$tmpdepfile" "$tmpdepfile".bak - ;; - -cpp) - # Important note: in order to support this mode, a compiler *must* - # always write the preprocessed file to stdout. - "$@" || exit $? - - # Remove the call to Libtool. - if test "$libtool" = yes; then - while test "X$1" != 'X--mode=compile'; do - shift - done - shift - fi - - # Remove '-o $object'. - IFS=" " - for arg - do - case $arg in - -o) - shift - ;; - $object) - shift - ;; - *) - set fnord "$@" "$arg" - shift # fnord - shift # $arg - ;; - esac - done - - "$@" -E \ - | sed -n -e '/^# [0-9][0-9]* "\([^"]*\)".*/ s:: \1 \\:p' \ - -e '/^#line [0-9][0-9]* "\([^"]*\)".*/ s:: \1 \\:p' \ - | sed '$ s: \\$::' > "$tmpdepfile" - rm -f "$depfile" - echo "$object : \\" > "$depfile" - cat < "$tmpdepfile" >> "$depfile" - sed < "$tmpdepfile" '/^$/d;s/^ //;s/ \\$//;s/$/ :/' >> "$depfile" - rm -f "$tmpdepfile" - ;; - -msvisualcpp) - # Important note: in order to support this mode, a compiler *must* - # always write the preprocessed file to stdout. - "$@" || exit $? - - # Remove the call to Libtool. - if test "$libtool" = yes; then - while test "X$1" != 'X--mode=compile'; do - shift - done - shift - fi - - IFS=" " - for arg - do - case "$arg" in - -o) - shift - ;; - $object) - shift - ;; - "-Gm"|"/Gm"|"-Gi"|"/Gi"|"-ZI"|"/ZI") - set fnord "$@" - shift - shift - ;; - *) - set fnord "$@" "$arg" - shift - shift - ;; - esac - done - "$@" -E 2>/dev/null | - sed -n '/^#line [0-9][0-9]* "\([^"]*\)"/ s::\1:p' | $cygpath_u | sort -u > "$tmpdepfile" - rm -f "$depfile" - echo "$object : \\" > "$depfile" - sed < "$tmpdepfile" -n -e 's% %\\ %g' -e '/^\(.*\)$/ s::'"$tab"'\1 \\:p' >> "$depfile" - echo "$tab" >> "$depfile" - sed < "$tmpdepfile" -n -e 's% %\\ %g' -e '/^\(.*\)$/ s::\1\::p' >> "$depfile" - rm -f "$tmpdepfile" - ;; - -msvcmsys) - # This case exists only to let depend.m4 do its work. It works by - # looking at the text of this script. This case will never be run, - # since it is checked for above. - exit 1 - ;; - -none) - exec "$@" - ;; - -*) - echo "Unknown depmode $depmode" 1>&2 - exit 1 - ;; -esac - -exit 0 - -# Local Variables: -# mode: shell-script -# sh-indentation: 2 -# eval: (add-hook 'write-file-hooks 'time-stamp) -# time-stamp-start: "scriptversion=" -# time-stamp-format: "%:y-%02m-%02d.%02H" -# time-stamp-time-zone: "UTC" -# time-stamp-end: "; # UTC" -# End: diff -Nru ecl-16.1.2/src/bdwgc/digimars.mak ecl-16.1.3+ds/src/bdwgc/digimars.mak --- ecl-16.1.2/src/bdwgc/digimars.mak 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/digimars.mak 1970-01-01 00:00:00.000000000 +0000 @@ -1,92 +0,0 @@ -# Makefile to build Hans Boehm garbage collector using the Digital Mars -# compiler from www.digitalmars.com -# Written by Walter Bright - - -DEFINES=-DNDEBUG -D_WINDOWS -DGC_DLL -DALL_INTERIOR_POINTERS -DWIN32_THREADS -CFLAGS=-Iinclude $(DEFINES) -wx -g -LFLAGS=/ma/implib/co -CC=sc - -.c.obj: - $(CC) -c $(CFLAGS) $* - -.cpp.obj: - $(CC) -c $(CFLAGS) -Aa $* - -OBJS= \ - allchblk.obj\ - alloc.obj\ - blacklst.obj\ - checksums.obj\ - dbg_mlc.obj\ - fnlz_mlc.obj\ - dyn_load.obj\ - finalize.obj\ - gc_cpp.obj\ - headers.obj\ - mach_dep.obj\ - malloc.obj\ - mallocx.obj\ - mark.obj\ - mark_rts.obj\ - misc.obj\ - new_hblk.obj\ - obj_map.obj\ - os_dep.obj\ - ptr_chck.obj\ - reclaim.obj\ - stubborn.obj\ - typd_mlc.obj\ - win32_threads.obj - -targets: gc.dll gc.lib gctest.exe - -gc.dll: $(OBJS) gc.def digimars.mak - sc -ogc.dll $(OBJS) -L$(LFLAGS) gc.def kernel32.lib user32.lib - -gc.def: digimars.mak - echo LIBRARY GC >gc.def - echo DESCRIPTION "Hans Boehm Garbage Collector" >>gc.def - echo EXETYPE NT >>gc.def - echo EXPORTS >>gc.def - echo GC_is_visible_print_proc >>gc.def - echo GC_is_valid_displacement_print_proc >>gc.def - -clean: - del gc.def - del $(OBJS) - - -gctest.exe : gc.lib tests\test.obj - sc -ogctest.exe tests\test.obj gc.lib - -tests\test.obj : tests\test.c - $(CC) -c -g -DNDEBUG -D_WINDOWS -DGC_DLL \ - -DALL_INTERIOR_POINTERS -DWIN32_THREADS \ - -Iinclude tests\test.c -otests\test.obj - -allchblk.obj: allchblk.c -alloc.obj: alloc.c -blacklst.obj: blacklst.c -checksums.obj: checksums.c -dbg_mlc.obj: dbg_mlc.c -dyn_load.obj: dyn_load.c -finalize.obj: finalize.c -fnlz_mlc.obj: fnlz_mlc.c -gc_cpp.obj: gc_cpp.cpp -headers.obj: headers.c -mach_dep.obj: mach_dep.c -malloc.obj: malloc.c -mallocx.obj: mallocx.c -mark.obj: mark.c -mark_rts.obj: mark_rts.c -misc.obj: misc.c -new_hblk.obj: new_hblk.c -obj_map.obj: obj_map.c -os_dep.obj: os_dep.c -ptr_chck.obj: ptr_chck.c -reclaim.obj: reclaim.c -stubborn.obj: stubborn.c -typd_mlc.obj: typd_mlc.c -win32_threads.obj: win32_threads.c diff -Nru ecl-16.1.2/src/bdwgc/doc/debugging.html ecl-16.1.3+ds/src/bdwgc/doc/debugging.html --- ecl-16.1.2/src/bdwgc/doc/debugging.html 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/debugging.html 1970-01-01 00:00:00.000000000 +0000 @@ -1,304 +0,0 @@ - - - - -Debugging Garbage Collector Related Problems - - -

Debugging Garbage Collector Related Problems

-This page contains some hints on -debugging issues specific to -the Boehm-Demers-Weiser conservative garbage collector. -It applies both to debugging issues in client code that manifest themselves -as collector misbehavior, and to debugging the collector itself. -

-If you suspect a bug in the collector itself, it is strongly recommended -that you try the latest collector release before proceeding. -

Bus Errors and Segmentation Violations

-

-If the fault occurred in GC_find_limit, or with incremental collection enabled, -this is probably normal. The collector installs handlers to take care of -these. You will not see these unless you are using a debugger. -Your debugger should allow you to continue. -It's often preferable to tell the debugger to ignore SIGBUS and SIGSEGV -("handle SIGSEGV SIGBUS nostop noprint" in gdb, -"ignore SIGSEGV SIGBUS" in most versions of dbx) -and set a breakpoint in abort. -The collector will call abort if the signal had another cause, -and there was not other handler previously installed. -

-We recommend debugging without incremental collection if possible. -(This applies directly to UNIX systems. -Debugging with incremental collection under win32 is worse. See README.win32.) -

-If the application generates an unhandled SIGSEGV or equivalent, it may -often be easiest to set the environment variable GC_LOOP_ON_ABORT. On many -platforms, this will cause the collector to loop in a handler when the -SIGSEGV is encountered (or when the collector aborts for some other reason), -and a debugger can then be attached to the looping -process. This sidesteps common operating system problems related -to incomplete core files for multi-threaded applications, etc. -

Other Signals

-On most platforms, the multi-threaded version of the collector needs one or -two other signals for internal use by the collector in stopping threads. -It is normally wise to tell the debugger to ignore these. On Linux, -the collector currently uses SIGPWR and SIGXCPU by default. -

Warning Messages About Needing to Allocate Blacklisted Blocks

-The garbage collector generates warning messages of the form -
-Needed to allocate blacklisted block at 0x...
-
-or -
-Repeated allocation of very large block ...
-
-when it needs to allocate a block at a location that it knows to be -referenced by a false pointer. These false pointers can be either permanent -(e.g. a static integer variable that never changes) or temporary. -In the latter case, the warning is largely spurious, and the block will -eventually be reclaimed normally. -In the former case, the program will still run correctly, but the block -will never be reclaimed. Unless the block is intended to be -permanent, the warning indicates a memory leak. -
    -
  1. Ignore these warnings while you are using GC_DEBUG. Some of the routines -mentioned below don't have debugging equivalents. (Alternatively, write -the missing routines and send them to me.) -
  2. Replace allocator calls that request large blocks with calls to -GC_malloc_ignore_off_page or -GC_malloc_atomic_ignore_off_page. You may want to set a -breakpoint in GC_default_warn_proc to help you identify such calls. -Make sure that a pointer to somewhere near the beginning of the resulting block -is maintained in a (preferably volatile) variable as long as -the block is needed. -
  3. -If the large blocks are allocated with realloc, we suggest instead allocating -them with something like the following. Note that the realloc size increment -should be fairly large (e.g. a factor of 3/2) for this to exhibit reasonable -performance. But we all know we should do that anyway. -
    -void * big_realloc(void *p, size_t new_size)
-{
-    size_t old_size = GC_size(p);
-    void * result;
-
-    if (new_size <= 10000) return(GC_realloc(p, new_size));
-    if (new_size <= old_size) return(p);
-    result = GC_malloc_ignore_off_page(new_size);
-    if (result == 0) return(0);
-    memcpy(result,p,old_size);
-    GC_free(p);
-    return(result);
-}
-
    - -
  4. In the unlikely case that even relatively small object -(<20KB) allocations are triggering these warnings, then your address -space contains lots of "bogus pointers", i.e. values that appear to -be pointers but aren't. Usually this can be solved by using GC_malloc_atomic -or the routines in gc_typed.h to allocate large pointer-free regions of bitmaps, etc. Sometimes the problem can be solved with trivial changes of encoding -in certain values. It is possible, to identify the source of the bogus -pointers by building the collector with -DPRINT_BLACK_LIST, -which will cause it to print the "bogus pointers", along with their location. - -
  5. If you get only a fixed number of these warnings, you are probably only -introducing a bounded leak by ignoring them. If the data structures being -allocated are intended to be permanent, then it is also safe to ignore them. -The warnings can be turned off by calling GC_set_warn_proc with a procedure -that ignores these warnings (e.g. by doing absolutely nothing). -
- -

The Collector References a Bad Address in GC_malloc

- -This typically happens while the collector is trying to remove an entry from -its free list, and the free list pointer is bad because the free list link -in the last allocated object was bad. -

-With > 99% probability, you wrote past the end of an allocated object. -Try setting GC_DEBUG before including gc.h and -allocating with GC_MALLOC. This will try to detect such -overwrite errors. - -

Unexpectedly Large Heap

- -Unexpected heap growth can be due to one of the following: -
    -
  1. Data structures that are being unintentionally retained. This -is commonly caused by data structures that are no longer being used, -but were not cleared, or by caches growing without bounds. -
  2. Pointer misidentification. The garbage collector is interpreting -integers or other data as pointers and retaining the "referenced" -objects. A common symptom is that GC_dump() shows much of the heap -as black-listed. -
  3. Heap fragmentation. This should never result in unbounded growth, -but it may account for larger heaps. This is most commonly caused -by allocation of large objects. On some platforms it can be reduced -by building with -DUSE_MUNMAP, which will cause the collector to unmap -memory corresponding to pages that have not been recently used. -
  4. Per object overhead. This is usually a relatively minor effect, but -it may be worth considering. If the collector recognizes interior -pointers, object sizes are increased, so that one-past-the-end pointers -are correctly recognized. The collector can be configured not to do this -(-DDONT_ADD_BYTE_AT_END). -

    -The collector rounds up object sizes so the result fits well into the -chunk size (HBLKSIZE, normally 4K on 32 bit machines, 8K -on 64 bit machines) used by the collector. Thus it may be worth avoiding -objects of size 2K + 1 (or 2K if a byte is being added at the end.) -

-The last two cases can often be identified by looking at the output -of a call to GC_dump(). Among other things, it will print the -list of free heap blocks, and a very brief description of all chunks in -the heap, the object sizes they correspond to, and how many live objects -were found in the chunk at the last collection. -

-Growing data structures can usually be identified by -

    -
  1. Building the collector with -DKEEP_BACK_PTRS, -
  2. Preferably using debugging allocation (defining GC_DEBUG -before including gc.h and allocating with GC_MALLOC), -so that objects will be identified by their allocation site, -
  3. Running the application long enough so -that most of the heap is composed of "leaked" memory, and -
  4. Then calling GC_generate_random_backtrace() from backptr.h -a few times to determine why some randomly sampled objects in the heap are -being retained. -
-

-The same technique can often be used to identify problems with false -pointers, by noting whether the reference chains printed by -GC_generate_random_backtrace() involve any misidentified pointers. -An alternate technique is to build the collector with --DPRINT_BLACK_LIST which will cause it to report values that -are almost, but not quite, look like heap pointers. It is very likely that -actual false pointers will come from similar sources. -

-In the unlikely case that false pointers are an issue, it can usually -be resolved using one or more of the following techniques: -

    -
  1. Use GC_malloc_atomic for objects containing no pointers. -This is especially important for large arrays containing compressed data, -pseudo-random numbers, and the like. It is also likely to improve GC -performance, perhaps drastically so if the application is paging. -
  2. If you allocate large objects containing only -one or two pointers at the beginning, either try the typed allocation -primitives is gc_typed.h, or separate out the pointer-free component. -
  3. Consider using GC_malloc_ignore_off_page() -to allocate large objects. (See gc.h and above for details. -Large means > 100K in most environments.) -
  4. If your heap size is larger than 100MB or so, build the collector with --DLARGE_CONFIG. -This allows the collector to keep more precise black-list -information. -
  5. If you are using heaps close to, or larger than, a gigabyte on a 32-bit -machine, you may want to consider moving to a platform with 64-bit pointers. -This is very likely to resolve any false pointer issues. -
-

Prematurely Reclaimed Objects

-The usual symptom of this is a segmentation fault, or an obviously overwritten -value in a heap object. This should, of course, be impossible. In practice, -it may happen for reasons like the following: -
    -
  1. The collector did not intercept the creation of threads correctly in -a multi-threaded application, e.g. because the client called -pthread_create without including gc.h, which redefines it. -
  2. The last pointer to an object in the garbage collected heap was stored -somewhere were the collector couldn't see it, e.g. in an -object allocated with system malloc, in certain types of -mmaped files, -or in some data structure visible only to the OS. (On some platforms, -thread-local storage is one of these.) -
  3. The last pointer to an object was somehow disguised, e.g. by -XORing it with another pointer. -
  4. Incorrect use of GC_malloc_atomic or typed allocation. -
  5. An incorrect GC_free call. -
  6. The client program overwrote an internal garbage collector data structure. -
  7. A garbage collector bug. -
  8. (Empirically less likely than any of the above.) A compiler optimization -that disguised the last pointer. -
-The following relatively simple techniques should be tried first to narrow -down the problem: -
    -
  1. If you are using the incremental collector try turning it off for -debugging. -
  2. If you are using shared libraries, try linking statically. If that works, -ensure that DYNAMIC_LOADING is defined on your platform. -
  3. Try to reproduce the problem with fully debuggable unoptimized code. -This will eliminate the last possibility, as well as making debugging easier. -
  4. Try replacing any suspect typed allocation and GC_malloc_atomic -calls with calls to GC_malloc. -
  5. Try removing any GC_free calls (e.g. with a suitable -#define). -
  6. Rebuild the collector with -DGC_ASSERTIONS. -
  7. If the following works on your platform (i.e. if gctest still works -if you do this), try building the collector with --DREDIRECT_MALLOC=GC_malloc_uncollectable. This will cause -the collector to scan memory allocated with malloc. -
-If all else fails, you will have to attack this with a debugger. -Suggested steps: -
    -
  1. Call GC_dump() from the debugger around the time of the failure. Verify -that the collectors idea of the root set (i.e. static data regions which -it should scan for pointers) looks plausible. If not, i.e. if it doesn't -include some static variables, report this as -a collector bug. Be sure to describe your platform precisely, since this sort -of problem is nearly always very platform dependent. -
  2. Especially if the failure is not deterministic, try to isolate it to -a relatively small test case. -
  3. Set a break point in GC_finish_collection. This is a good -point to examine what has been marked, i.e. found reachable, by the -collector. -
  4. If the failure is deterministic, run the process -up to the last collection before the failure. -Note that the variable GC_gc_no counts collections and can be used -to set a conditional breakpoint in the right one. It is incremented just -before the call to GC_finish_collection. -If object p was prematurely recycled, it may be helpful to -look at *GC_find_header(p) at the failure point. -The hb_last_reclaimed field will identify the collection number -during which its block was last swept. -
  5. Verify that the offending object still has its correct contents at -this point. -Then call GC_is_marked(p) from the debugger to verify that the -object has not been marked, and is about to be reclaimed. Note that -GC_is_marked(p) expects the real address of an object (the -address of the debug header if there is one), and thus it may -be more appropriate to call GC_is_marked(GC_base(p)) -instead. -
  6. Determine a path from a root, i.e. static variable, stack, or -register variable, -to the reclaimed object. Call GC_is_marked(q) for each object -q along the path, trying to locate the first unmarked object, say -r. -
  7. If r is pointed to by a static root, -verify that the location -pointing to it is part of the root set printed by GC_dump(). If it -is on the stack in the main (or only) thread, verify that -GC_stackbottom is set correctly to the base of the stack. If it is -in another thread stack, check the collector's thread data structure -(GC_thread[] on several platforms) to make sure that stack bounds -are set correctly. -
  8. If r is pointed to by heap object s, check that the -collector's layout description for s is such that the pointer field -will be scanned. Call *GC_find_header(s) to look at the descriptor -for the heap chunk. The hb_descr field specifies the layout -of objects in that chunk. See gc_mark.h for the meaning of the descriptor. -(If it's low order 2 bits are zero, then it is just the length of the -object prefix to be scanned. This form is always used for objects allocated -with GC_malloc or GC_malloc_atomic.) -
  9. If the failure is not deterministic, you may still be able to apply some -of the above technique at the point of failure. But remember that objects -allocated since the last collection will not have been marked, even if the -collector is functioning properly. On some platforms, the collector -can be configured to save call chains in objects for debugging. -Enabling this feature will also cause it to save the call stack at the -point of the last GC in GC_arrays._last_stack. -
  10. When looking at GC internal data structures remember that a number -of GC_xxx variables are really macro defined to -GC_arrays._xxx, so that -the collector can avoid scanning them. -
- - diff -Nru ecl-16.1.2/src/bdwgc/doc/doc.am ecl-16.1.3+ds/src/bdwgc/doc/doc.am --- ecl-16.1.2/src/bdwgc/doc/doc.am 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/doc.am 1970-01-01 00:00:00.000000000 +0000 @@ -1,49 +0,0 @@ -# -# THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED -# OR IMPLIED. ANY USE IS AT YOUR OWN RISK. -# -# Permission is hereby granted to use or copy this program -# for any purpose, provided the above notices are retained on all copies. -# Permission to modify the code and to distribute modified code is granted, -# provided the above notices are retained, and a notice that the code was -# modified is included with the above copyright notice. - -## Process this file with automake to produce Makefile.in. - -# installed documentation -# -dist_pkgdata_DATA = \ - AUTHORS \ - README.md \ - doc/README.DGUX386 \ - doc/README.Mac \ - doc/README.OS2 \ - doc/README.amiga \ - doc/README.arm.cross \ - doc/README.autoconf \ - doc/README.cmake \ - doc/README.cords \ - doc/README.darwin \ - doc/README.environment \ - doc/README.ews4800 \ - doc/README.hp \ - doc/README.linux \ - doc/README.macros \ - doc/README.rs6000 \ - doc/README.sgi \ - doc/README.solaris2 \ - doc/README.symbian \ - doc/README.uts \ - doc/README.win32 \ - doc/README.win64 \ - doc/debugging.html \ - doc/finalization.html \ - doc/gc.man \ - doc/gcdescr.html \ - doc/gcinterface.html \ - doc/leak.html \ - doc/overview.html \ - doc/porting.html \ - doc/scale.html \ - doc/simple_example.html \ - doc/tree.html diff -Nru ecl-16.1.2/src/bdwgc/doc/finalization.html ecl-16.1.3+ds/src/bdwgc/doc/finalization.html --- ecl-16.1.2/src/bdwgc/doc/finalization.html 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/finalization.html 1970-01-01 00:00:00.000000000 +0000 @@ -1,190 +0,0 @@ - - -Finalization in the Boehm-Demers-Weiser collector - - -

Finalization

-Many garbage collectors provide a facility for executing user code -just before an object is collected. This can be used to reclaim any -system resources or non-garbage-collected memory associated with the -object. -Experience has shown that this can be a useful facility. -It is indispensable in cases in which system resources are embedded -in complex data structures (e.g. file descriptors -in the cord package). -

-Our collector provides the necessary functionality through -GC_register_finalizer in -gc.h, or by -inheriting from gc_cleanup -in gc_cpp.h. -

-However, finalization should not be used in the same way as C++ -destructors. In well-written programs there will typically be -very few uses of finalization. (Garbage collected programs that -interact with explicitly memory-managed libraries may be an exception.) -

-In general the following guidelines should be followed: -

    -
  • -Actions that must be executed promptly do not belong in finalizers. -They should be handled by explicit calls in the code (or C++ -destructors if you prefer). If you expect the action to occur at -a specific point, this is probably not hard. -
  • -Finalizers are intended for resource reclamation. -
  • -Scarce system resources should be managed explicitly whenever -convenient. Use finalizers only as a backup mechanism for the -cases that would be hard to handle explicitly. -
  • -If scarce resources are managed with finalization, the allocation -routine for that resource (e.g. open for file handles) should force -a garbage collection (two if that doesn't suffice) if it finds itself -short of the resource. -
  • -If extremely scarce resources are managed by finalization (e.g. -file descriptors on systems which have a limit of 20 open files), -it may be necessary to introduce a descriptor caching scheme to -hide the resource limit. -(E.g., the program would keep real file descriptors -for the 20 most recently used logically open files. -Any other needed files would be closed after saving their state. -They would then be reopened on demand. -Finalization would logically close the file, closing the -real descriptor only if it happened to be cached.) -Note that most modern systems (e.g. Irix®) allow hundreds or -thousands of open files, and this is typically not an issue. -
  • -Finalization code may -be run anyplace an allocation or other call to the collector -takes place. -In multi-threaded programs, finalizers have to obey the normal -locking conventions to ensure safety. -Code run directly from finalizers should not acquire locks that may -be held during allocation. This restriction can be easily circumvented -by registering a finalizer which enqueues the real action for execution -in a separate thread. -

    -In single-threaded code, it is also often easiest to have finalizers -queue actions, which are then explicitly run during an -explicit call by the user's program. -

-

Topologically Ordered Finalization

-Our conservative garbage collector supports -a form of finalization -(with GC_register_finalizer) -in which objects are finalized in topological -order. If A points to B, and both are registered for -finalization, it is guaranteed the A will be finalized first. -This usually guarantees that finalization procedures see only -unfinalized objects. -

-This decision is often questioned, particularly since it has an obvious -disadvantage. The current implementation finalizes long chains of -finalizable objects one per collection. This is hard to avoid, since -the first finalizer invoked may store a pointer to the rest of the chain -in a global variable, making it accessible again. Or it may mutate the -rest of the chain. -

-Cycles involving one or more finalizable objects are never finalized. -

-Why topological ordering? -

-It is important to keep in mind that the choice of finalization ordering -matters only in relatively rare cases. In spite of the fact that it has -received a lot of discussion, it is not one of the more important -decisions in designing a system. Many, especially smaller, applications -will never notice the difference. Nonetheless, we believe that topologically -ordered finalization is the right choice. -

-To understand the justification, observe that if As -finalization procedure does not refer to B, we could fairly easily have -avoided the dependency. We could have split A into A' -and A'' such that any references to A become references to -A', A' points to A'' but not vice-versa, only fields -needed for finalization are stored in A'', and A'' is enabled -for finalization. (GC_register_disappearing_link provides an -alternative mechanism that does not require breaking up objects.) -

-Thus assume that A actually does need access to B during -finalization. To make things concrete, assume that B is -finalizable because it holds a pointer to a C object, which must be -explicitly deallocated. (This is likely to be one of the most common -uses of finalization.) If B happens to be finalized first, -A will see a dangling pointer during its finalization. But a -principal goal of garbage collection was to avoid dangling pointers. -

-Note that the client program could enforce topological ordering -even if the system didn't. A pointer to B could be stored in -some globally visible place, where it is cleared only by As -finalizer. But this puts the burden to ensure safety back on the -programmer. -

-With topologically ordered finalization, the programmer -can fail to split an object, thus leaving an accidental cycle. This -results in a leak, which is arguably less dangerous than a dangling -pointer. More importantly, it is much easier to diagnose, -since the garbage collector would have to go out of its way not to -notice finalization cycles. It can trivially report them. -

-Furthermore unordered finalization does not really solve the problem -of cycles. Consider the above case in which As -finalization procedure depends on B, and thus a pointer to B -is stored in a global data structure, to be cleared by As finalizer. -If there is an accidental pointer from B back to A, and -thus a cycle, neither B nor A will become unreachable. -The leak is there, just as in the topologically ordered case, but it is -hidden from easy diagnosis. -

-A number of alternative finalization orderings have been proposed, e.g. -based on statically assigned priorities. In our opinion, these are much -more likely to require complex programming discipline to use in a large -modular system. (Some of them, e.g. Guardians proposed by Dybvig, -Bruggeman, and Eby, do avoid some problems which arise in combination -with certain other collection algorithms.) -

-Fundamentally, a garbage collector assumes that objects reachable -via pointer chains may be accessed, and thus should be preserved. -Topologically ordered finalization simply extends this to object finalization; -an finalizable object reachable from another finalizer via a pointer chain -is presumed to be accessible by the finalizer, and thus should not be -finalized. - -

Programming with topological finalization

-Experience with Cedar has shown that cycles or long chains of finalizable -objects are typically not a problem. -Finalizable objects are typically rare. -There are several ways to reduce spurious dependencies between finalizable -objects. Splitting objects as discussed above is one technique. -The collector also provides GC_register_disappearing_link, which -explicitly nils a pointer before determining finalization ordering. -

-Some so-called "operating systems" fail to clean up some resources associated -with a process. These resources must be deallocated at all cost before -process exit whether or not they are still referenced. Probably the best -way to deal with those is by not relying exclusively on finalization. -They should be registered in a table of weak pointers (implemented as -disguised pointers cleared by the finalization procedure that deallocates -the resource). If any references are still left at process exit, they -can be explicitly deallocated then. - -

Getting around topological finalization ordering

-There are certain situations in which cycles between finalizable objects are -genuinely unavoidable. Most notably, C++ compilers introduce self-cycles -to represent inheritance. GC_register_finalizer_ignore_self tells the -finalization part of the collector to ignore self cycles. -This is used by the C++ interface. -

-Finalize.c actually contains an intentionally undocumented mechanism -for registering a finalizable object with user-defined dependencies. -The problem is that this dependency information is also used for memory -reclamation, not just finalization ordering. Thus misuse can result in -dangling pointers even if finalization doesn't create any. -The risk of dangling pointers can be eliminated by building the collector -with -DJAVA_FINALIZATION. This forces objects reachable from finalizers -to be marked, even though this dependency is not considered for finalization -ordering. - - - diff -Nru ecl-16.1.2/src/bdwgc/doc/gcdescr.html ecl-16.1.3+ds/src/bdwgc/doc/gcdescr.html --- ecl-16.1.2/src/bdwgc/doc/gcdescr.html 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/gcdescr.html 1970-01-01 00:00:00.000000000 +0000 @@ -1,628 +0,0 @@ - - - Conservative GC Algorithmic Overview - Hans-J. Boehm, HP Labs (Some of this was written at SGI) - - -

This is under construction, and may always be.

-

Conservative GC Algorithmic Overview

-

-This is a description of the algorithms and data structures used in our -conservative garbage collector. I expect the level of detail to increase -with time. For a survey of GC algorithms, see for example - Paul Wilson's -excellent paper. For an overview of the collector interface, -see here. -

-This description is targeted primarily at someone trying to understand the -source code. It specifically refers to variable and function names. -It may also be useful for understanding the algorithms at a higher level. -

-The description here assumes that the collector is used in default mode. -In particular, we assume that it used as a garbage collector, and not just -a leak detector. We initially assume that it is used in stop-the-world, -non-incremental mode, though the presence of the incremental collector -will be apparent in the design. -We assume the default finalization model, but the code affected by that -is very localized. -

Introduction

-The garbage collector uses a modified mark-sweep algorithm. Conceptually -it operates roughly in four phases, which are performed occasionally -as part of a memory allocation: - -
    - -
  1. -Preparation Each object has an associated mark bit. -Clear all mark bits, indicating that all objects -are potentially unreachable. - -
  2. -Mark phase Marks all objects that can be reachable via chains of -pointers from variables. Often the collector has no real information -about the location of pointer variables in the heap, so it -views all static data areas, stacks and registers as potentially containing -pointers. Any bit patterns that represent addresses inside -heap objects managed by the collector are viewed as pointers. -Unless the client program has made heap object layout information -available to the collector, any heap objects found to be reachable from -variables are again scanned similarly. - -
  3. -Sweep phase Scans the heap for inaccessible, and hence unmarked, -objects, and returns them to an appropriate free list for reuse. This is -not really a separate phase; even in non incremental mode this is operation -is usually performed on demand during an allocation that discovers an empty -free list. Thus the sweep phase is very unlikely to touch a page that -would not have been touched shortly thereafter anyway. - -
  4. -Finalization phase Unreachable objects which had been registered -for finalization are enqueued for finalization outside the collector. - -
- -

-The remaining sections describe the memory allocation data structures, -and then the last 3 collection phases in more detail. We conclude by -outlining some of the additional features implemented in the collector. - -

Allocation

-The collector includes its own memory allocator. The allocator obtains -memory from the system in a platform-dependent way. Under UNIX, it -uses either malloc, sbrk, or mmap. -

-Most static data used by the allocator, as well as that needed by the -rest of the garbage collector is stored inside the -_GC_arrays structure. -This allows the garbage collector to easily ignore the collectors own -data structures when it searches for root pointers. Other allocator -and collector internal data structures are allocated dynamically -with GC_scratch_alloc. GC_scratch_alloc does not -allow for deallocation, and is therefore used only for permanent data -structures. -

-The allocator allocates objects of different kinds. -Different kinds are handled somewhat differently by certain parts -of the garbage collector. Certain kinds are scanned for pointers, -others are not. Some may have per-object type descriptors that -determine pointer locations. Or a specific kind may correspond -to one specific object layout. Two built-in kinds are uncollectible. -One (STUBBORN) is immutable without special precautions. -In spite of that, it is very likely that most C clients of the -collector currently -use at most two kinds: NORMAL and PTRFREE objects. -The gcj runtime also makes -heavy use of a kind (allocated with GC_gcj_malloc) that stores -type information at a known offset in method tables. -

-The collector uses a two level allocator. A large block is defined to -be one larger than half of HBLKSIZE, which is a power of 2, -typically on the order of the page size. -

-Large block sizes are rounded up to -the next multiple of HBLKSIZE and then allocated by -GC_allochblk. Recent versions of the collector -use an approximate best fit algorithm by keeping free lists for -several large block sizes. -The actual -implementation of GC_allochblk -is significantly complicated by black-listing issues -(see below). -

-Small blocks are allocated in chunks of size HBLKSIZE. -Each chunk is -dedicated to only one object size and kind. -

-The allocator maintains -separate free lists for each size and kind of object. -Associated with each kind is an array of free list pointers, -with entry freelist[i] pointing to -a free list of size i objects. -In recent versions of the -collector, index i is expressed in granules, which are the -minimum allocatable unit, typically 8 or 16 bytes. -The free lists themselves are -linked through the first word in each object (see obj_link() -macro). -

-Once a large block is split for use in smaller objects, it can only -be used for objects of that size, unless the collector discovers a completely -empty chunk. Completely empty chunks are restored to the appropriate -large block free list. -

-In order to avoid allocating blocks for too many distinct object sizes, -the collector normally does not directly allocate objects of every possible -request size. Instead request are rounded up to one of a smaller number -of allocated sizes, for which free lists are maintained. The exact -allocated sizes are computed on demand, but subject to the constraint -that they increase roughly in geometric progression. Thus objects -requested early in the execution are likely to be allocated with exactly -the requested size, subject to alignment constraints. -See GC_init_size_map for details. -

-The actual size rounding operation during small object allocation is -implemented as a table lookup in GC_size_map which maps -a requested allocation size in bytes to a number of granules. -

-Both collector initialization and computation of allocated sizes are -handled carefully so that they do not slow down the small object fast -allocation path. An attempt to allocate before the collector is initialized, -or before the appropriate GC_size_map entry is computed, -will take the same path as an allocation attempt with an empty free list. -This results in a call to the slow path code (GC_generic_malloc_inner) -which performs the appropriate initialization checks. -

-In non-incremental mode, we make a decision about whether to garbage collect -whenever an allocation would otherwise have failed with the current heap size. -If the total amount of allocation since the last collection is less than -the heap size divided by GC_free_space_divisor, we try to -expand the heap. Otherwise, we initiate a garbage collection. This ensures -that the amount of garbage collection work per allocated byte remains -constant. -

-The above is in fact an oversimplification of the real heap expansion -and GC triggering heuristic, which adjusts slightly for root size -and certain kinds of -fragmentation. In particular: -

    -
  • Programs with a large root set size and -little live heap memory will expand the heap to amortize the cost of -scanning the roots. -
  • Versions 5.x of the collector actually collect more frequently in -nonincremental mode. The large block allocator usually refuses to split -large heap blocks once the garbage collection threshold is -reached. This often has the effect of collecting well before the -heap fills up, thus reducing fragmentation and working set size at the -expense of GC time. Versions 6.x choose an intermediate strategy depending -on how much large object allocation has taken place in the past. -(If the collector is configured to unmap unused pages, versions 6.x -use the 5.x strategy.) -
  • In calculating the amount of allocation since the last collection we -give partial credit for objects we expect to be explicitly deallocated. -Even if all objects are explicitly managed, it is often desirable to collect -on rare occasion, since that is our only mechanism for coalescing completely -empty chunks. -
-

-It has been suggested that this should be adjusted so that we favor -expansion if the resulting heap still fits into physical memory. -In many cases, that would no doubt help. But it is tricky to do this -in a way that remains robust if multiple application are contending -for a single pool of physical memory. - -

Mark phase

- -At each collection, the collector marks all objects that are -possibly reachable from pointer variables. Since it cannot generally -tell where pointer variables are located, it scans the following -root segments for pointers: -
    -
  • The registers. Depending on the architecture, this may be done using -assembly code, or by calling a setjmp-like function which saves -register contents on the stack. -
  • The stack(s). In the case of a single-threaded application, -on most platforms this -is done by scanning the memory between (an approximation of) the current -stack pointer and GC_stackbottom. (For Itanium, the register stack -scanned separately.) The GC_stackbottom variable is set in -a highly platform-specific way depending on the appropriate configuration -information in gcconfig.h. Note that the currently active -stack needs to be scanned carefully, since callee-save registers of -client code may appear inside collector stack frames, which may -change during the mark process. This is addressed by scanning -some sections of the stack "eagerly", effectively capturing a snapshot -at one point in time. -
  • Static data region(s). In the simplest case, this is the region -between DATASTART and DATAEND, as defined in -gcconfig.h. However, in most cases, this will also involve -static data regions associated with dynamic libraries. These are -identified by the mostly platform-specific code in dyn_load.c. -
-The marker maintains an explicit stack of memory regions that are known -to be accessible, but that have not yet been searched for contained pointers. -Each stack entry contains the starting address of the block to be scanned, -as well as a descriptor of the block. If no layout information is -available for the block, then the descriptor is simply a length. -(For other possibilities, see gc_mark.h.) -

-At the beginning of the mark phase, all root segments -(as described above) are pushed on the -stack by GC_push_roots. (Registers and eagerly processed -stack sections are processed by pushing the referenced objects instead -of the stack section itself.) If ALL_INTERIOR_PTRS is not -defined, then stack roots require special treatment. In this case, the -normal marking code ignores interior pointers, but GC_push_all_stack -explicitly checks for interior pointers and pushes descriptors for target -objects. -

-The marker is structured to allow incremental marking. -Each call to GC_mark_some performs a small amount of -work towards marking the heap. -It maintains -explicit state in the form of GC_mark_state, which -identifies a particular sub-phase. Some other pieces of state, most -notably the mark stack, identify how much work remains to be done -in each sub-phase. The normal progression of mark states for -a stop-the-world collection is: -

    -
  1. MS_INVALID indicating that there may be accessible unmarked -objects. In this case GC_objects_are_marked will simultaneously -be false, so the mark state is advanced to -
  2. MS_PUSH_UNCOLLECTABLE indicating that it suffices to push -uncollectible objects, roots, and then mark everything reachable from them. -Scan_ptr is advanced through the heap until all uncollectible -objects are pushed, and objects reachable from them are marked. -At that point, the next call to GC_mark_some calls -GC_push_roots to push the roots. It the advances the -mark state to -
  3. MS_ROOTS_PUSHED asserting that once the mark stack is -empty, all reachable objects are marked. Once in this state, we work -only on emptying the mark stack. Once this is completed, the state -changes to -
  4. MS_NONE indicating that reachable objects are marked. -
- -The core mark routine GC_mark_from, is called -repeatedly by several of the sub-phases when the mark stack starts to fill -up. It is also called repeatedly in MS_ROOTS_PUSHED state -to empty the mark stack. -The routine is designed to only perform a limited amount of marking at -each call, so that it can also be used by the incremental collector. -It is fairly carefully tuned, since it usually consumes a large majority -of the garbage collection time. -

-The fact that it perform a only a small amount of work per call also -allows it to be used as the core routine of the parallel marker. In that -case it is normally invoked on thread-private mark stacks instead of the -global mark stack. More details can be found in -scale.html -

-The marker correctly handles mark stack overflows. Whenever the mark stack -overflows, the mark state is reset to MS_INVALID. -Since there are already marked objects in the heap, -this eventually forces a complete -scan of the heap, searching for pointers, during which any unmarked objects -referenced by marked objects are again pushed on the mark stack. This -process is repeated until the mark phase completes without a stack overflow. -Each time the stack overflows, an attempt is made to grow the mark stack. -All pieces of the collector that push regions onto the mark stack have to be -careful to ensure forward progress, even in case of repeated mark stack -overflows. Every mark attempt results in additional marked objects. -

-Each mark stack entry is processed by examining all candidate pointers -in the range described by the entry. If the region has no associated -type information, then this typically requires that each 4-byte aligned -quantity (8-byte aligned with 64-bit pointers) be considered a candidate -pointer. -

-We determine whether a candidate pointer is actually the address of -a heap block. This is done in the following steps: - -

  • The candidate pointer is checked against rough heap bounds. -These heap bounds are maintained such that all actual heap objects -fall between them. In order to facilitate black-listing (see below) -we also include address regions that the heap is likely to expand into. -Most non-pointers fail this initial test. -
  • The candidate pointer is divided into two pieces; the most significant -bits identify a HBLKSIZE-sized page in the address space, and -the least significant bits specify an offset within that page. -(A hardware page may actually consist of multiple such pages. -HBLKSIZE is usually the page size divided by a small power of two.) -
  • -The page address part of the candidate pointer is looked up in a -table. -Each table entry contains either 0, indicating that the page is not part -of the garbage collected heap, a small integer n, indicating -that the page is part of large object, starting at least n pages -back, or a pointer to a descriptor for the page. In the first case, -the candidate pointer i not a true pointer and can be safely ignored. -In the last two cases, we can obtain a descriptor for the page containing -the beginning of the object. -
  • -The starting address of the referenced object is computed. -The page descriptor contains the size of the object(s) -in that page, the object kind, and the necessary mark bits for those -objects. The size information can be used to map the candidate pointer -to the object starting address. To accelerate this process, the page header -also contains a pointer to a precomputed map of page offsets to displacements -from the beginning of an object. The use of this map avoids a -potentially slow integer remainder operation in computing the object -start address. -
  • -The mark bit for the target object is checked and set. If the object -was previously unmarked, the object is pushed on the mark stack. -The descriptor is read from the page descriptor. (This is computed -from information GC_obj_kinds when the page is first allocated.) - -

    -At the end of the mark phase, mark bits for left-over free lists are cleared, -in case a free list was accidentally marked due to a stray pointer. - -

    Sweep phase

    - -At the end of the mark phase, all blocks in the heap are examined. -Unmarked large objects are immediately returned to the large object free list. -Each small object page is checked to see if all mark bits are clear. -If so, the entire page is returned to the large object free list. -Small object pages containing some reachable object are queued for later -sweeping, unless we determine that the page contains very little free -space, in which case it is not examined further. -

    -This initial sweep pass touches only block headers, not -the blocks themselves. Thus it does not require significant paging, even -if large sections of the heap are not in physical memory. -

    -Nonempty small object pages are swept when an allocation attempt -encounters an empty free list for that object size and kind. -Pages for the correct size and kind are repeatedly swept until at -least one empty block is found. Sweeping such a page involves -scanning the mark bit array in the page header, and building a free -list linked through the first words in the objects themselves. -This does involve touching the appropriate data page, but in most cases -it will be touched only just before it is used for allocation. -Hence any paging is essentially unavoidable. -

    -Except in the case of pointer-free objects, we maintain the invariant -that any object in a small object free list is cleared (except possibly -for the link field). Thus it becomes the burden of the small object -sweep routine to clear objects. This has the advantage that we can -easily recover from accidentally marking a free list, though that could -also be handled by other means. The collector currently spends a fair -amount of time clearing objects, and this approach should probably be -revisited. -

    -In most configurations, we use specialized sweep routines to handle common -small object sizes. Since we allocate one mark bit per word, it becomes -easier to examine the relevant mark bits if the object size divides -the word length evenly. We also suitably unroll the inner sweep loop -in each case. (It is conceivable that profile-based procedure cloning -in the compiler could make this unnecessary and counterproductive. I -know of no existing compiler to which this applies.) -

    -The sweeping of small object pages could be avoided completely at the expense -of examining mark bits directly in the allocator. This would probably -be more expensive, since each allocation call would have to reload -a large amount of state (e.g. next object address to be swept, position -in mark bit table) before it could do its work. The current scheme -keeps the allocator simple and allows useful optimizations in the sweeper. - -

    Finalization

    -Both GC_register_disappearing_link and -GC_register_finalizer add the request to a corresponding hash -table. The hash table is allocated out of collected memory, but -the reference to the finalizable object is hidden from the collector. -Currently finalization requests are processed non-incrementally at the -end of a mark cycle. -

    -The collector makes an initial pass over the table of finalizable objects, -pushing the contents of unmarked objects onto the mark stack. -After pushing each object, the marker is invoked to mark all objects -reachable from it. The object itself is not explicitly marked. -This assures that objects on which a finalizer depends are neither -collected nor finalized. -

    -If in the process of marking from an object the -object itself becomes marked, we have uncovered -a cycle involving the object. This usually results in a warning from the -collector. Such objects are not finalized, since it may be -unsafe to do so. See the more detailed - discussion of finalization semantics. -

    -Any objects remaining unmarked at the end of this process are added to -a queue of objects whose finalizers can be run. Depending on collector -configuration, finalizers are dequeued and run either implicitly during -allocation calls, or explicitly in response to a user request. -(Note that the former is unfortunately both the default and not generally safe. -If finalizers perform synchronization, it may result in deadlocks. -Nontrivial finalizers generally need to perform synchronization, and -thus require a different collector configuration.) -

    -The collector provides a mechanism for replacing the procedure that is -used to mark through objects. This is used both to provide support for -Java-style unordered finalization, and to ignore certain kinds of cycles, -e.g. those arising from C++ implementations of virtual inheritance. - -

    Generational Collection and Dirty Bits

    -We basically use the concurrent and generational GC algorithm described in -"Mostly Parallel Garbage Collection", -by Boehm, Demers, and Shenker. -

    -The most significant modification is that -the collector always starts running in the allocating thread. -There is no separate garbage collector thread. (If parallel GC is -enabled, helper threads may also be woken up.) -If an allocation attempt either requests a large object, or encounters -an empty small object free list, and notices that there is a collection -in progress, it immediately performs a small amount of marking work -as described above. -

    -This change was made both because we wanted to easily accommodate -single-threaded environments, and because a separate GC thread requires -very careful control over the scheduler to prevent the mutator from -out-running the collector, and hence provoking unneeded heap growth. -

    -In incremental mode, the heap is always expanded when we encounter -insufficient space for an allocation. Garbage collection is triggered -whenever we notice that more than -GC_heap_size/2 * GC_free_space_divisor -bytes of allocation have taken place. -After GC_full_freq minor collections a major collection -is started. -

    -All collections initially run uninterrupted until a predetermined -amount of time (50 msecs by default) has expired. If this allows -the collection to complete entirely, we can avoid correcting -for data structure modifications during the collection. If it does -not complete, we return control to the mutator, and perform small -amounts of additional GC work during those later allocations that -cannot be satisfied from small object free lists. When marking completes, -the set of modified pages is retrieved, and we mark once again from -marked objects on those pages, this time with the mutator stopped. -

    -We keep track of modified pages using one of several distinct mechanisms: -

      -
    1. -Through explicit mutator cooperation. Currently this requires -the use of GC_malloc_stubborn, and is rarely used. -
    2. -(MPROTECT_VDB) By write-protecting physical pages and -catching write faults. This is -implemented for many Unix-like systems and for win32. It is not possible -in a few environments. -
    3. -(PROC_VDB) By retrieving dirty bit information from /proc. -(Currently only Sun's -Solaris supports this. Though this is considerably cleaner, performance -may actually be better with mprotect and signals.) -
    4. -(PCR_VDB) By relying on an external dirty bit implementation, in this -case the one in Xerox PCR. -
    5. -(DEFAULT_VDB) By treating all pages as dirty. This is the default if -none of the other techniques is known to be usable, and -GC_malloc_stubborn is not used. Practical only for testing, or if -the vast majority of objects use GC_malloc_stubborn. -
    - -

    Black-listing

    - -The collector implements black-listing of pages, as described -in - -Boehm, ``Space Efficient Conservative Collection'', PLDI '93, also available -here. -

    -During the mark phase, the collector tracks ``near misses'', i.e. attempts -to follow a ``pointer'' to just outside the garbage-collected heap, or -to a currently unallocated page inside the heap. Pages that have been -the targets of such near misses are likely to be the targets of -misidentified ``pointers'' in the future. To minimize the future -damage caused by such misidentification, they will be allocated only to -small pointer-free objects. -

    -The collector understands two different kinds of black-listing. A -page may be black listed for interior pointer references -(GC_add_to_black_list_stack), if it was the target of a near -miss from a location that requires interior pointer recognition, -e.g. the stack, or the heap if GC_all_interior_pointers -is set. In this case, we also avoid allocating large blocks that include -this page. -

    -If the near miss came from a source that did not require interior -pointer recognition, it is black-listed with -GC_add_to_black_list_normal. -A page black-listed in this way may appear inside a large object, -so long as it is not the first page of a large object. -

    -The GC_allochblk routine respects black-listing when assigning -a block to a particular object kind and size. It occasionally -drops (i.e. allocates and forgets) blocks that are completely black-listed -in order to avoid excessively long large block free lists containing -only unusable blocks. This would otherwise become an issue -if there is low demand for small pointer-free objects. - -

    Thread support

    -We support several different threading models. Unfortunately Pthreads, -the only reasonably well standardized thread model, supports too narrow -an interface for conservative garbage collection. There appears to be -no completely portable way to allow the collector -to coexist with various Pthreads -implementations. Hence we currently support only the more -common Pthreads implementations. -

    -In particular, it is very difficult for the collector to stop all other -threads in the system and examine the register contents. This is currently -accomplished with very different mechanisms for some Pthreads -implementations. The Solaris implementation temporarily disables much -of the user-level threads implementation by stopping kernel-level threads -("lwp"s). The Linux/HPUX/OSF1 and Irix implementations sends signals to -individual Pthreads and has them wait in the signal handler. -

    -The Linux and Irix implementations use -only documented Pthreads calls, but rely on extensions to their semantics. -The Linux implementation linux_threads.c relies on only very -mild extensions to the pthreads semantics, and already supports a large number -of other Unix-like pthreads implementations. Our goal is to make this the -only pthread support in the collector. -

    -(The Irix implementation is separate only for historical reasons and should -clearly be merged. The current Solaris implementation probably performs -better in the uniprocessor case, but does not support thread operations in the -collector. Hence it cannot support the parallel marker.) -

    -All implementations must -intercept thread creation and a few other thread-specific calls to allow -enumeration of threads and location of thread stacks. This is current -accomplished with # define's in gc.h -(really gc_pthread_redirects.h), or optionally -by using ld's function call wrapping mechanism under Linux. -

    -Recent versions of the collector support several facilities to enhance -the processor-scalability and thread performance of the collector. -These are discussed in more detail here. -We briefly outline the data approach to thread-local allocation in the -next section. -

    Thread-local allocation

    -If thread-local allocation is enabled, the collector keeps separate -arrays of free lists for each thread. Thread-local allocation -is currently only supported on a few platforms. -

    -The free list arrays associated -with each thread are only used to satisfy requests for objects that -are both very small, and belong to one of a small number of well-known -kinds. These currently include "normal" and pointer-free objects. -Depending on the configuration, "gcj" objects may also be included. -

    -Thread-local free list entries contain either a pointer to the first -element of a free list, or they contain a counter of the number of -allocation granules, corresponding to objects of this size, -allocated so far. Initially they contain the -value one, i.e. a small counter value. -

    -Thread-local allocation allocates directly through the global -allocator, if the object is of a size or kind not covered by the -local free lists. -

    -If there is an appropriate local free list, the allocator checks whether it -contains a sufficiently small counter value. If so, the counter is simply -incremented by the counter value, and the global allocator is used. -In this way, the initial few allocations of a given size bypass the local -allocator. A thread that only allocates a handful of objects of a given -size will not build up its own free list for that size. This avoids -wasting space for unpopular objects sizes or kinds. -

    -Once the counter passes a threshold, GC_malloc_many is called -to allocate roughly HBLKSIZE space and put it on the corresponding -local free list. Further allocations of that size and kind then use -this free list, and no longer need to acquire the allocation lock. -The allocation procedure is otherwise similar to the global free lists. -The local free lists are also linked using the first word in the object. -In most cases this means they require considerably less time. -

    -Local free lists are treated buy most of the rest of the collector -as though they were in-use reachable data. This requires some care, -since pointer-free objects are not normally traced, and hence a special -tracing procedure is required to mark all objects on pointer-free and -gcj local free lists. -

    -On thread exit, any remaining thread-local free list entries are -transferred back to the global free list. -

    -Note that if the collector is configured for thread-local allocation, -GC versions before 7 do not invoke the thread-local allocator by default. -GC_malloc only uses thread-local allocation in version 7 and later. -

    -For some more details see here, and the -technical report entitled - -"Fast Multiprocessor Memory Allocation and Garbage Collection" -

    -

    -

    -Comments are appreciated. Please send mail to -bdwgc@lists.opendylan.org -(GC mailing list) or -boehm@acm.org - - diff -Nru ecl-16.1.2/src/bdwgc/doc/gcinterface.html ecl-16.1.3+ds/src/bdwgc/doc/gcinterface.html --- ecl-16.1.2/src/bdwgc/doc/gcinterface.html 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/gcinterface.html 1970-01-01 00:00:00.000000000 +0000 @@ -1,283 +0,0 @@ - - - - -Garbage Collector Interface - - -

    C Interface

    -On many platforms, a single-threaded garbage collector library can be built -to act as a plug-in malloc replacement. -(Build with -DREDIRECT_MALLOC=GC_malloc -DIGNORE_FREE.) -This is often the best way to deal with third-party libraries -which leak or prematurely free objects. --DREDIRECT_MALLOC=GC_malloc is intended -primarily as an easy way to adapt old code, not for new development. -

    -New code should use the interface discussed below. -

    -Code must be linked against the GC library. On most UNIX platforms, -depending on how the collector is built, this will be gc.a -or libgc.{a,so}. -

    -The following describes the standard C interface to the garbage collector. -It is not a complete definition of the interface. It describes only the -most commonly used functionality, approximately in decreasing order of -frequency of use. -The full interface is described in -gc.h -or gc.h in the distribution. -

    -Clients should include gc.h. -

    -In the case of multi-threaded code, -gc.h should be included after the threads header file, and -after defining the appropriate GC_XXXX_THREADS macro. -(For 6.2alpha4 and later, simply defining GC_THREADS should suffice.) -The header file gc.h must be included -in files that use either GC or threads primitives, since threads primitives -will be redefined to cooperate with the GC on many platforms. -

    -Thread users should also be aware that on many platforms objects reachable -only from thread-local variables may be prematurely reclaimed. -Thus objects pointed to by thread-local variables should also be pointed to -by a globally visible data structure. (This is viewed as a bug, but as -one that is exceedingly hard to fix without some libc hooks.) -

    -
    void * GC_MALLOC(size_t nbytes) -
    -Allocates and clears nbytes of storage. -Requires (amortized) time proportional to nbytes. -The resulting object will be automatically deallocated when unreferenced. -References from objects allocated with the system malloc are usually not -considered by the collector. (See GC_MALLOC_UNCOLLECTABLE, however. -Building the collector with -DREDIRECT_MALLOC=GC_malloc_uncollectable -is often a way around this.) -GC_MALLOC is a macro which invokes GC_malloc by default or, -if GC_DEBUG -is defined before gc.h is included, a debugging version that checks -occasionally for overwrite errors, and the like. -
    void * GC_MALLOC_ATOMIC(size_t nbytes) -
    -Allocates nbytes of storage. -Requires (amortized) time proportional to nbytes. -The resulting object will be automatically deallocated when unreferenced. -The client promises that the resulting object will never contain any pointers. -The memory is not cleared. -This is the preferred way to allocate strings, floating point arrays, -bitmaps, etc. -More precise information about pointer locations can be communicated to the -collector using the interface in -gc_typed.h in the distribution. -
    void * GC_MALLOC_UNCOLLECTABLE(size_t nbytes) -
    -Identical to GC_MALLOC, -except that the resulting object is not automatically -deallocated. Unlike the system-provided malloc, the collector does -scan the object for pointers to garbage-collectible memory, even if the -block itself does not appear to be reachable. (Objects allocated in this way -are effectively treated as roots by the collector.) -
    void * GC_REALLOC(void *old, size_t new_size) -
    -Allocate a new object of the indicated size and copy (a prefix of) the -old object into the new object. The old object is reused in place if -convenient. If the original object was allocated with -GC_MALLOC_ATOMIC, -the new object is subject to the same constraints. If it was allocated -as an uncollectible object, then the new object is uncollectible, and -the old object (if different) is deallocated. -
    void GC_FREE(void *dead) -
    -Explicitly deallocate an object. Typically not useful for small -collectible objects. -
    void * GC_MALLOC_IGNORE_OFF_PAGE(size_t nbytes) -
    -
    void * GC_MALLOC_ATOMIC_IGNORE_OFF_PAGE(size_t nbytes) -
    -Analogous to GC_MALLOC and GC_MALLOC_ATOMIC, -except that the client -guarantees that as long -as the resulting object is of use, a pointer is maintained to someplace -inside the first 512 bytes of the object. This pointer should be declared -volatile to avoid interference from compiler optimizations. -(Other nonvolatile pointers to the object may exist as well.) -This is the -preferred way to allocate objects that are likely to be > 100KBytes in size. -It greatly reduces the risk that such objects will be accidentally retained -when they are no longer needed. Thus space usage may be significantly reduced. -
    void GC_INIT(void) -
    -On some platforms, it is necessary to invoke this -from the main executable, not from a dynamic library, before -the initial invocation of a GC routine. It is recommended that this be done -in portable code, though we try to ensure that it expands to a no-op -on as many platforms as possible. In GC 7.0, it was required if -thread-local allocation is enabled in the collector build, and malloc -is not redirected to GC_malloc. -
    void GC_gcollect(void) -
    -Explicitly force a garbage collection. -
    void GC_enable_incremental(void) -
    -Cause the garbage collector to perform a small amount of work -every few invocations of GC_MALLOC or the like, instead of performing -an entire collection at once. This is likely to increase total -running time. It will improve response on a platform that either has -suitable support in the garbage collector (Linux and most Unix -versions, win32 if the collector was suitably built) or if "stubborn" -allocation is used (see -gc.h). -On many platforms this interacts poorly with system calls -that write to the garbage collected heap. -
    GC_warn_proc GC_set_warn_proc(GC_warn_proc p) -
    -Replace the default procedure used by the collector to print warnings. -The collector -may otherwise write to stderr, most commonly because GC_malloc was used -in a situation in which GC_malloc_ignore_off_page would have been more -appropriate. See gc.h for details. -
    void GC_REGISTER_FINALIZER(...) -
    -Register a function to be called when an object becomes inaccessible. -This is often useful as a backup method for releasing system resources -(e.g. closing files) when the object referencing them becomes -inaccessible. -It is not an acceptable method to perform actions that must be performed -in a timely fashion. -See gc.h for details of the interface. -See here for a more detailed discussion -of the design. -

    -Note that an object may become inaccessible before client code is done -operating on objects referenced by its fields. -Suitable synchronization is usually required. -See here -or here -for details. -

    -

    -If you are concerned with multiprocessor performance and scalability, -you should consider enabling and using thread local allocation. -

    -If your platform -supports it, you should build the collector with parallel marking support -(-DPARALLEL_MARK, or --enable-parallel-mark). -

    -If the collector is used in an environment in which pointer location -information for heap objects is easily available, this can be passed on -to the collector using the interfaces in either gc_typed.h -or gc_gcj.h. -

    -The collector distribution also includes a string package that takes -advantage of the collector. For details see -cord.h - -

    C++ Interface

    -The C++ interface is implemented as a thin layer on the C interface. -Unfortunately, this thin layer appears to be very sensitive to variations -in C++ implementations, particularly since it tries to replace the global -::new operator, something that appears to not be well-standardized. -Your platform may need minor adjustments in this layer (gc_cpp.cc, gc_cpp.h, -and possibly gc_allocator.h). Such changes do not require understanding -of collector internals, though they may require a good understanding of -your platform. (Patches enhancing portability are welcome. -But it's easy to break one platform by fixing another.) -

    -Usage of the collector from C++ is also complicated by the fact that there -are many "standard" ways to allocate memory in C++. The default ::new -operator, default malloc, and default STL allocators allocate memory -that is not garbage collected, and is not normally "traced" by the -collector. This means that any pointers in memory allocated by these -default allocators will not be seen by the collector. Garbage-collectible -memory referenced only by pointers stored in such default-allocated -objects is likely to be reclaimed prematurely by the collector. -

    -It is the programmers responsibility to ensure that garbage-collectible -memory is referenced by pointers stored in one of -

      -
    • Program variables -
    • Garbage-collected objects -
    • Uncollected but "traceable" objects -
    -"Traceable" objects are not necessarily reclaimed by the collector, -but are scanned for pointers to collectible objects. -They are usually allocated by GC_MALLOC_UNCOLLECTABLE, as described -above, and through some interfaces described below. -

    -(On most platforms, the collector may not trace correctly from in-flight -exception objects. Thus objects thrown as exceptions should only -point to otherwise reachable memory. This is another bug whose -proper repair requires platform hooks.) -

    -The easiest way to ensure that collectible objects are properly referenced -is to allocate only collectible objects. This requires that every -allocation go through one of the following interfaces, each one of -which replaces a standard C++ allocation mechanism. Note that -this requires that all STL containers be explicitly instantiated with -gc_allocator. -

    -
    STL allocators -
    -

    -Recent versions of the collector include a hopefully standard-conforming -allocator implementation in gc_allocator.h. It defines -

      -
    • traceable_allocator -
    • gc_allocator -
    -which may be used either directly to allocate memory or to instantiate -container templates. -The former allocates uncollectible but traced memory. -The latter allocates garbage-collected memory. -

    -These should work with any fully standard-conforming C++ compiler. -

    -Users of the SGI extended STL -or its derivatives (including most g++ versions) -may instead be able to include new_gc_alloc.h before including -STL header files. This is increasingly discouraged. -

    -This defines SGI-style allocators -

      -
    • alloc -
    • single_client_alloc -
    • gc_alloc -
    • single_client_gc_alloc -
    -The first two allocate uncollectible but traced -memory, while the second two allocate collectible memory. -The single_client versions are not safe for concurrent access by -multiple threads, but are faster. -

    -For an example, click here. -

    Class inheritance based interface for new-based allocation -
    -Users may include gc_cpp.h and then cause members of classes to -be allocated in garbage collectible memory by having those classes -inherit from class gc. -For details see gc_cpp.h. -

    -Linking against libgccpp in addition to the gc library overrides -::new (and friends) to allocate traceable memory but uncollectible -memory, making it safe to refer to collectible objects from the resulting -memory. -

    C interface -
    -It is also possible to use the C interface from -gc.h directly. -On platforms which use malloc to implement ::new, it should usually be possible -to use a version of the collector that has been compiled as a malloc -replacement. It is also possible to replace ::new and other allocation -functions suitably, as is done by libgccpp. -

    -Note that user-implemented small-block allocation often works poorly with -an underlying garbage-collected large block allocator, since the collector -has to view all objects accessible from the user's free list as reachable. -This is likely to cause problems if GC_MALLOC -is used with something like -the original HP version of STL. -This approach works well with the SGI versions of the STL only if the -malloc_alloc allocator is used. -

    - - diff -Nru ecl-16.1.2/src/bdwgc/doc/gc.man ecl-16.1.3+ds/src/bdwgc/doc/gc.man --- ecl-16.1.2/src/bdwgc/doc/gc.man 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/gc.man 1970-01-01 00:00:00.000000000 +0000 @@ -1,103 +0,0 @@ -.TH GC_MALLOC 1L "2 October 2003" -.SH NAME -GC_malloc, GC_malloc_atomic, GC_free, GC_realloc, GC_enable_incremental, GC_register_finalizer, GC_malloc_ignore_off_page, GC_malloc_atomic_ignore_off_page, GC_set_warn_proc \- Garbage collecting malloc replacement -.SH SYNOPSIS -#include "gc.h" -.br -void * GC_malloc(size_t size); -.br -void GC_free(void *ptr); -.br -void * GC_realloc(void *ptr, size_t size); -.br -.sp -cc ... gc.a -.LP -.SH DESCRIPTION -.I GC_malloc -and -.I GC_free -are plug-in replacements for standard malloc and free. However, -.I -GC_malloc -will attempt to reclaim inaccessible space automatically by invoking a conservative garbage collector at appropriate points. The collector traverses all data structures accessible by following pointers from the machines registers, stack(s), data, and bss segments. Inaccessible structures will be reclaimed. A machine word is considered to be a valid pointer if it is an address inside an object allocated by -.I -GC_malloc -or friends. -.LP -In most cases it is preferable to call the macros GC_MALLOC, GC_FREE, etc. -instead of calling GC_malloc and friends directly. This allows debugging -versions of the routines to be substituted by defining GC_DEBUG before -including gc.h. -.LP -See the documentation in the include files gc_cpp.h and gc_allocator.h, -as well as the gcinterface.html file in the distribution, -for an alternate, C++ specific interface to the garbage collector. -Note that C++ programs generally -need to be careful to ensure that all allocated memory (whether via new, -malloc, or STL allocators) that may point to garbage collected memory -is either itself garbage collected, or at least traced by the collector. -.LP -Unlike the standard implementations of malloc, -.I -GC_malloc -clears the newly allocated storage. -.I -GC_malloc_atomic -does not. Furthermore, it informs the collector that the resulting object will never contain any pointers, and should therefore not be scanned by the collector. -.LP -.I -GC_free -can be used to deallocate objects, but its use is optional, and generally discouraged. -.I -GC_realloc -has the standard realloc semantics. It preserves pointer-free-ness. -.I -GC_register_finalizer -allows for registration of functions that are invoked when an object becomes inaccessible. -.LP -The garbage collector tries to avoid allocating memory at locations that already appear to be referenced before allocation. (Such apparent ``pointers'' are usually large integers and the like that just happen to look like an address.) This may make it hard to allocate very large objects. An attempt to do so may generate a warning. -.LP -.I -GC_malloc_ignore_off_page -and -.I -GC_malloc_atomic_ignore_off_page -inform the collector that the client code will always maintain a pointer to near the beginning of the object (within the first 512 bytes), and that pointers beyond that can be ignored by the collector. This makes it much easier for the collector to place large objects. These are recommended for large object allocation. (Objects expected to be larger than about 100KBytes should be allocated this way.) -.LP -It is also possible to use the collector to find storage leaks in programs destined to be run with standard malloc/free. The collector can be compiled for thread-safe operation. Unlike standard malloc, it is safe to call malloc after a previous malloc call was interrupted by a signal, provided the original malloc call is not resumed. -.LP -The collector may, on rare occasion produce warning messages. On UNIX machines these appear on stderr. Warning messages can be filtered, redirected, or ignored with -.I -GC_set_warn_proc -This is recommended for production code. See gc.h for details. -.LP -Fully portable code should call -.I -GC_INIT -from the main program before making any other GC calls. -On most platforms this does nothing and the collector is initialized on first use. -On a few platforms explicit initialization is necessary. And it can never hurt. -.LP -Debugging versions of many of the above routines are provided as macros. Their names are identical to the above, but consist of all capital letters. If GC_DEBUG is defined before gc.h is included, these routines do additional checking, and allow the leak detecting version of the collector to produce slightly more useful output. Without GC_DEBUG defined, they behave exactly like the lower-case versions. -.LP -On some machines, collection will be performed incrementally after a call to -.I -GC_enable_incremental. -This may temporarily write protect pages in the heap. See the README file for more information on how this interacts with system calls that write to the heap. -.LP -Other facilities not discussed here include limited facilities to support incremental collection on machines without appropriate VM support, provisions for providing more explicit object layout information to the garbage collector, more direct support for ``weak'' pointers, support for ``abortable'' garbage collections during idle time, etc. -.LP -.SH "SEE ALSO" -The README and gc.h files in the distribution. More detailed definitions of the functions exported by the collector are given there. (The above list is not complete.) -.LP -The web site at http://www.hboehm.info/gc/ . -.LP -Boehm, H., and M. Weiser, "Garbage Collection in an Uncooperative Environment", -"Software Practice & Experience", September 1988, pp. 807-820. -.LP -The malloc(3) man page. -.LP -.SH AUTHOR -Hans-J. Boehm (boehm@acm.org). -Some of the code was written by others, most notably Alan Demers. diff -Nru ecl-16.1.2/src/bdwgc/doc/leak.html ecl-16.1.3+ds/src/bdwgc/doc/leak.html --- ecl-16.1.2/src/bdwgc/doc/leak.html 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/leak.html 1970-01-01 00:00:00.000000000 +0000 @@ -1,207 +0,0 @@ - - - - -Using the Garbage Collector as Leak Detector - - -

    Using the Garbage Collector as Leak Detector

    -The garbage collector may be used as a leak detector. -In this case, the primary function of the collector is to report -objects that were allocated (typically with GC_MALLOC), -not deallocated (normally with GC_FREE), but are -no longer accessible. Since the object is no longer accessible, -there in normally no way to deallocate the object at a later time; -thus it can safely be assumed that the object has been "leaked". -

    -This is substantially different from counting leak detectors, -which simply verify that all allocated objects are eventually -deallocated. A garbage-collector based leak detector can provide -somewhat more precise information when an object was leaked. -More importantly, it does not report objects that are never -deallocated because they are part of "permanent" data structures. -Thus it does not require all objects to be deallocated at process -exit time, a potentially useless activity that often triggers -large amounts of paging. -

    -All non-ancient versions of the garbage collector provide -leak detection support. Version 5.3 adds the following -features: -

      -
    1. Leak detection mode can be initiated at run-time by -setting GC_find_leak instead of building the -collector with FIND_LEAK -defined. This variable should be set to a nonzero value -at program startup. -
    2. Leaked objects should be reported and then correctly garbage collected. -Prior versions either reported leaks or functioned as a garbage collector. -
    -For the rest of this description we will give instructions that work -with any reasonable version of the collector. -

    -To use the collector as a leak detector, follow the following steps: -

      -
    1. Build the collector with -DFIND_LEAK. Otherwise use default -build options. -
    2. Change the program so that all allocation and deallocation goes -through the garbage collector. -
    3. Arrange to call GC_gcollect at appropriate points to check -for leaks. -(For sufficiently long running programs, this will happen implicitly, -but probably not with sufficient frequency.) -
    -The second step can usually be accomplished with the --DREDIRECT_MALLOC=GC_malloc option when the collector is built, -or by defining malloc, calloc, -realloc and free -to call the corresponding garbage collector functions. -But this, by itself, will not yield very informative diagnostics, -since the collector does not keep track of information about -how objects were allocated. The error reports will include -only object addresses. -

    -For more precise error reports, as much of the program as possible -should use the all uppercase variants of these functions, after -defining GC_DEBUG, and then including gc.h. -In this environment GC_MALLOC is a macro which causes -at least the file name and line number at the allocation point to -be saved as part of the object. Leak reports will then also include -this information. -

    -Many collector features (e.g stubborn objects, finalization, -and disappearing links) are less useful in this context, and are not -fully supported. Their use will usually generate additional bogus -leak reports, since the collector itself drops some associated objects. -

    -The same is generally true of thread support. However, as of 6.0alpha4, -correct leak reports should be generated with linuxthreads. -

    -On a few platforms (currently Solaris/SPARC, Irix, and, with -DSAVE_CALL_CHAIN, -Linux/X86), GC_MALLOC -also causes some more information about its call stack to be saved -in the object. Such information is reproduced in the error -reports in very non-symbolic form, but it can be very useful with the -aid of a debugger. -

    An Example

    -The following header file leak_detector.h is included in the -"include" subdirectory of the distribution: -
    -#define GC_DEBUG
-#include "gc.h"
-#define malloc(n) GC_MALLOC(n)
-#define calloc(m,n) GC_MALLOC((m)*(n))
-#define free(p) GC_FREE(p)
-#define realloc(p,n) GC_REALLOC((p),(n))
-#define CHECK_LEAKS() GC_gcollect()
-
    -

    -Assume the collector has been built with -DFIND_LEAK. (For -newer versions of the collector, we could instead add the statement -GC_find_leak = 1 as the first statement in main(). -

    -The program to be tested for leaks can then look like: -

    -#include "leak_detector.h"
-
-main() {
-    int *p[10];
-    int i;
-    /* GC_find_leak = 1; for new collector versions not         */
-    /* compiled with -DFIND_LEAK.                               */
-    for (i = 0; i < 10; ++i) {
-        p[i] = malloc(sizeof(int)+i);
-    }
-    for (i = 1; i < 10; ++i) {
-        free(p[i]);
-    }
-    for (i = 0; i < 9; ++i) {
-        p[i] = malloc(sizeof(int)+i);
-    }
-    CHECK_LEAKS();
-}
-
    -

    -On an Intel X86 Linux system this produces on the stderr stream: -

    -Leaked composite object at 0x806dff0 (leak_test.c:8, sz=4)
-
    -(On most unmentioned operating systems, the output is similar to this. -If the collector had been built on Linux/X86 with -DSAVE_CALL_CHAIN, -the output would be closer to the Solaris example. For this to work, -the program should not be compiled with -fomit_frame_pointer.) -

    -On Irix it reports -

    -Leaked composite object at 0x10040fe0 (leak_test.c:8, sz=4)
-        Caller at allocation:
-                ##PC##= 0x10004910
-
    -and on Solaris the error report is -
    -Leaked composite object at 0xef621fc8 (leak_test.c:8, sz=4)
-        Call chain at allocation:
-                args: 4 (0x4), 200656 (0x30FD0)
-                ##PC##= 0x14ADC
-                args: 1 (0x1), -268436012 (0xEFFFFDD4)
-                ##PC##= 0x14A64
-
    -In the latter two cases some additional information is given about -how malloc was called when the leaked object was allocated. For -Solaris, the first line specifies the arguments to GC_debug_malloc -(the actual allocation routine), The second the program counter inside -main, the third the arguments to main, and finally the program -counter inside the caller to main (i.e. in the C startup code). -

    -In the Irix case, only the address inside the caller to main is given. -

    -In many cases, a debugger is needed to interpret the additional information. -On systems supporting the "adb" debugger, the tools/callprocs.sh -script can be used to replace program counter values with symbolic names. -As of version 6.1, the collector tries to generate symbolic names for -call stacks if it knows how to do so on the platform. This is true on -Linux/X86, but not on most other platforms. -

    Simplified leak detection under Linux

    -Since version 6.1, it should be possible to run the collector in leak -detection mode on a program a.out under Linux/X86 as follows: -
      -
    1. Ensure that a.out is a single-threaded executable, or you are using -a very recent (7.0alpha7+) collector version on Linux. -On most platforms this does not work at all for the multi-threaded programs. -
    2. If possible, ensure that the addr2line program is installed in -/usr/bin. (It comes with most Linux distributions.) -
    3. If possible, compile your program, which we'll call a.out, -with full debug information. -This will improve the quality of the leak reports. With this approach, it is -no longer necessary to call GC_ routines explicitly, -though that can also -improve the quality of the leak reports. -
    4. Build the collector and install it in directory foo as follows: -
        -
      • configure --prefix=foo --enable-gc-debug --enable-redirect-malloc ---disable-threads -
      • make -
      • make install -
      -With a very recent collector on Linux, it may sometimes be safe to omit -the --disable-threads. But the combination of thread support -and malloc replacement is not yet rock solid. -
    5. Set environment variables as follows: -
        -
      • LD_PRELOAD=foo/lib/libgc.so -
      • GC_FIND_LEAK -
      • You may also want to set GC_PRINT_STATS -(to confirm that the collector is running) and/or -GC_LOOP_ON_ABORT (to facilitate debugging from another -window if something goes wrong). -
      -
    6. Simply run a.out as you normally would. Note that if you run anything -else (e.g. your editor) with those environment variables set, -it will also be leak tested. This may or may not be useful and/or -embarrassing. It can generate -mountains of leak reports if the application wasn't designed to avoid leaks, -e.g. because it's always short-lived. -
    -This has not yet been thoroughly tested on large applications, but it's known -to do the right thing on at least some small ones. - - diff -Nru ecl-16.1.2/src/bdwgc/doc/overview.html ecl-16.1.3+ds/src/bdwgc/doc/overview.html --- ecl-16.1.2/src/bdwgc/doc/overview.html 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/overview.html 1970-01-01 00:00:00.000000000 +0000 @@ -1,434 +0,0 @@ - -A garbage collector for C and C++ - - - - - - - - - - -
    Interface OverviewTutorial SlidesFAQExampleDownloadLicense
    -

    A garbage collector for C and C++

    - -[ This is an updated version of the page formerly at -www.hpl.hp.com/personal/Hans_Boehm/gc/, -before that at -http://reality.sgi.com/boehm/gc.html -and before that at - -ftp://ftp.parc.xerox.com/pub/gc/gc.html. ] -

    -The Boehm-Demers-Weiser -conservative garbage collector can -be used as a garbage collecting -replacement for C malloc or C++ new. -It allows you to allocate memory basically as you normally would, -without explicitly deallocating memory that is no longer useful. -The collector automatically recycles memory when it determines -that it can no longer be otherwise accessed. -A simple example of such a use is given -here. -

    -The collector is also used by a number of programming language -implementations that either use C as intermediate code, want -to facilitate easier interoperation with C libraries, or -just prefer the simple collector interface. -For a more detailed description of the interface, see -here. -

    -Alternatively, the garbage collector may be used as -a leak detector -for C or C++ programs, though that is not its primary goal. -

    -Typically several versions will be available. -Usually you should first try to use -gc_source/gc.tar.gz, -which is normally an older, more stable version. -

    -If that fails, try the latest explicitly numbered version -in -gc_source/. -Later versions may contain additional features, platform support, -or bug fixes, but are likely to be less well tested. -

    -A slightly older version of the garbage collector is now also -included as part of the -GNU compiler -distribution. The source -code for that version is available for browsing -here. -

    -The arguments for and against conservative garbage collection -in C and C++ are briefly -discussed in -issues.html. -The beginnings of a frequently-asked-questions list are -here. -

    -The garbage collector code is copyrighted by -Hans-J. Boehm, -Alan J. Demers, -Xerox Corporation, -Silicon Graphics, -and -Hewlett-Packard Company. -It may be used and copied without payment of a fee under minimal restrictions. -See the README file in the distribution or the -license for more details. -IT IS PROVIDED AS IS, -WITH ABSOLUTELY NO WARRANTY EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. -

    -Empirically, this collector works with most unmodified C programs, -simply by replacing -malloc with GC_malloc calls, -replacing realloc with GC_realloc calls, and removing -free calls. Exceptions are discussed -in issues.html. -

    Platforms

    -The collector is not completely portable, but the distribution -includes ports to most standard PC and UNIX/Linux platforms. -The collector should work on Linux, *BSD, recent Windows versions, -MacOS X, HP/UX, Solaris, -Tru64, Irix and a few other operating systems. -Some ports are more polished than others. -

    -Irix pthreads, Linux threads, Win32 threads, Solaris threads -(pthreads only), -HP/UX 11 pthreads, Tru64 pthreads, and MacOS X threads are supported -in recent versions. -

    Separately distributed ports

    -For MacOS 9/Classic use, Patrick Beard's latest port is available from - -http://homepage.mac.com/pcbeard/gc/. -(Unfortunately, that's now quite dated. -I'm not in a position to test under MacOS. Although I try to -incorporate changes, it is impossible for -me to update the project file.) -

    -Precompiled versions of the collector for NetBSD are available -here. -

    -Debian Linux includes prepackaged -versions of the collector. -

    Scalable multiprocessor versions

    -Kenjiro Taura, Toshio Endo, and Akinori Yonezawa have made available -a parallel collector -based on this one. Their collector takes advantage of multiple processors -during a collection. Starting with collector version 6.0alpha1 -we also do this, though with more modest processor scalability goals. -Our approach is discussed briefly in -scale.html. -

    Some Collector Details

    -The collector uses a mark-sweep algorithm. -It provides incremental and generational -collection under operating systems which provide the right kind of -virtual memory support. (Currently this includes SunOS[45], IRIX, -OSF/1, Linux, and Windows, with varying restrictions.) -It allows finalization code -to be invoked when an object is collected. -It can take advantage of type information to locate pointers if such -information is provided, but it is usually used without such information. -See the README and -gc.h files in the distribution for more details. -

    -For an overview of the implementation, see here. -

    -The garbage collector distribution includes a C string -(cord) package that provides -for fast concatenation and substring operations on long strings. -A simple curses- and win32-based editor that represents the entire file -as a cord is included as a -sample application. -

    -Performance of the nonincremental collector is typically competitive -with malloc/free implementations. Both space and time overhead are -likely to be only slightly higher -for programs written for malloc/free -(see Detlefs, Dosser and Zorn's -Memory Allocation Costs in Large C and C++ Programs.) -For programs allocating primarily very small objects, the collector -may be faster; for programs allocating primarily large objects it will -be slower. If the collector is used in a multi-threaded environment -and configured for thread-local allocation, it may in some cases -significantly outperform malloc/free allocation in time. -

    -We also expect that in many cases any additional overhead -will be more than compensated for by decreased copying etc. -if programs are written -and tuned for garbage collection. -

    Further Reading:

    -The beginnings of a frequently asked questions list for this -collector are here. -

    -The following provide information on garbage collection in general: -

    -Paul Wilson's garbage collection ftp archive and GC survey. -

    -The Ravenbrook -Memory Management Reference. -

    -David Chase's -GC FAQ. -

    -Richard Jones' - -Garbage Collection Page and - -his book. -

    -The following papers describe the collector algorithms we use -and the underlying design decisions at -a higher level. -

    -(Some of the lower level details can be found -here.) -

    -The first one is not available -electronically due to copyright considerations. Most of the others are -subject to ACM copyright. -

    -Boehm, H., "Dynamic Memory Allocation and Garbage Collection", Computers in Physics -9, 3, May/June 1995, pp. 297-303. This is directed at an otherwise sophisticated -audience unfamiliar with memory allocation issues. The algorithmic details differ -from those in the implementation. There is a related letter to the editor and a minor -correction in the next issue. -

    -Boehm, H., and M. Weiser, -"Garbage Collection in an Uncooperative Environment", -Software Practice & Experience, September 1988, pp. 807-820. -

    -Boehm, H., A. Demers, and S. Shenker, "Mostly Parallel Garbage Collection", -Proceedings of the ACM SIGPLAN '91 Conference on Programming Language Design and Implementation, -SIGPLAN Notices 26, 6 (June 1991), pp. 157-164. -

    -Boehm, H., "Space Efficient Conservative Garbage Collection", -Proceedings of the ACM SIGPLAN '93 Conference on Programming Language Design -and Implementation, SIGPLAN Notices 28, 6 (June 1993), pp. 197-206. -

    -Boehm, H., "Reducing Garbage Collector Cache Misses", - Proceedings of the 2000 International Symposium on Memory Management . - -Official version. - -Technical report version. Describes the prefetch strategy -incorporated into the collector for some platforms. Explains why -the sweep phase of a "mark-sweep" collector should not really be -a distinct phase. -

    -M. Serrano, H. Boehm, -"Understanding Memory Allocation of Scheme Programs", -Proceedings of the Fifth ACM SIGPLAN International Conference on -Functional Programming, 2000, Montreal, Canada, pp. 245-256. - -Official version. - -Earlier Technical Report version. Includes some discussion of the -collector debugging facilities for identifying causes of memory retention. -

    -Boehm, H., -"Fast Multiprocessor Memory Allocation and Garbage Collection", - -HP Labs Technical Report HPL 2000-165. Discusses the parallel -collection algorithms, and presents some performance results. -

    -Boehm, H., "Bounding Space Usage of Conservative Garbage Collectors", -Proceedings of the 2002 ACM SIGPLAN-SIGACT Symposium on Principles of -Programming Languages, Jan. 2002, pp. 93-100. - -Official version. - -Technical report version. -Includes a discussion of a collector facility to much more reliably test for -the potential of unbounded heap growth. -

    -The following papers discuss language and compiler restrictions necessary to guaranteed -safety of conservative garbage collection. -

    -We thank John Levine and JCLT for allowing -us to make the second paper available electronically, and providing PostScript for the final -version. -

    -Boehm, H., "Simple Garbage-Collector-Safety", -Proceedings of the ACM SIGPLAN '96 Conference on Programming Language Design -and Implementation. -

    -Boehm, H., and D. Chase, "A Proposal for Garbage-Collector-Safe C Compilation", -Journal of C Language Translation 4, 2 (Decemeber 1992), pp. 126-141. -

    -Other related information: -

    -The Detlefs, Dosser and Zorn's Memory Allocation Costs in Large C and C++ Programs. - This is a performance comparison of the Boehm-Demers-Weiser collector to malloc/free, -using programs written for malloc/free. -

    -Joel Bartlett's mostly copying conservative garbage collector for C++. -

    -John Ellis and David Detlef's Safe Efficient Garbage Collection for C++ proposal. -

    -Henry Baker's paper collection. -

    -Slides for Hans Boehm's Allocation and GC Myths talk. -

    Current users:

    -Known current users of some variant of this collector include: -

    -The runtime system for GCJ, -the static GNU java compiler. -

    -W3m, a text-based web browser. -

    -Some versions of the Xerox DocuPrint printer software. -

    -The Mozilla project, as leak -detector. -

    -The Mono project, -an open source implementation of the .NET development framework. -

    -The DotGNU Portable.NET -project, another open source .NET implementation. -

    -The Irssi IRC client. -

    -The Berkeley Titanium project. -

    -The NAGWare f90 Fortran 90 compiler. -

    -Elwood Corporation's Eclipse Common Lisp system, C library, and translator. -

    -The Bigloo Scheme -and Camloo ML compilers -written by Manuel Serrano and others. -

    -Brent Benson's libscheme. -

    -The MzScheme scheme implementation. -

    -The University of Washington Cecil Implementation. -

    -The Berkeley Sather implementation. -

    -The Berkeley Harmonia Project. -

    -The Toba Java Virtual -Machine to C translator. -

    -The Gwydion Dylan compiler. -

    -The -GNU Objective C runtime. -

    -Macaulay 2, a system to support -research in algebraic geometry and commutative algebra. -

    -The Vesta configuration management -system. -

    -Visual Prolog 6. -

    -Asymptote LaTeX-compatible -vector graphics language. -

    More collector information at this site

    -A simple illustration of how to build and -use the collector. -

    -Description of alternate interfaces to the -garbage collector. -

    -Slides from an ISMM 2004 tutorial about the GC. -

    -A FAQ (frequently asked questions) list. -

    -How to use the garbage collector as a leak detector. -

    -Some hints on debugging garbage collected -applications. -

    -An overview of the implementation of the -garbage collector. -

    -The data structure used for fast pointer lookups. -

    -Scalability of the collector to multiprocessors. -

    -Directory containing garbage collector source. -

    More background information at this site

    -An attempt to establish a bound on space usage of -conservative garbage collectors. -

    -Mark-sweep versus copying garbage collectors -and their complexity. -

    -Pros and cons of conservative garbage collectors, -in comparison to other collectors. -

    -Issues related to garbage collection vs. -manual memory management in C/C++. -

    -An example of a case in which garbage collection -results in a much faster implementation as a result of reduced synchronization. -

    -Slide set discussing performance of nonmoving -garbage collectors. -

    - -Slide set discussing Destructors, Finalizers, and Synchronization -(POPL 2003). -

    - -Paper corresponding to above slide set -( -Technical Report version). -

    -A Java/Scheme/C/C++ garbage collection benchmark. -

    -Slides for talk on memory allocation myths. -

    -Slides for OOPSLA 98 garbage collection talk. -

    -Related papers. -

    Contacts and Mailing List

    -We have recently set up two mailing list for collector announcements -and discussions: -
      -
    • bdwgc-announce@lists.opendylan.org -is used for announcements of new versions. Postings are restricted. -We expect this to always remain a very low volume list. -
    • bdwgc@lists.opendylan.org -is used for discussions, bug reports, and the like. Subscribers may post. -On-topic posts by nonsubscribers will usually also be accepted, but -it may take some time to review them. -
    -To subscribe to these lists, please visit -lists.opendylan.org/mailman/listinfo/bdwgc-announce -and -lists.opendylan.org/mailman/listinfo/bdwgc, -respectively. -

    -The archives for these lists appear -here and -here, -respectively. -The gc list archive may also be read at -gmane.org. -

    -Some prior discussion of the collector has taken place on the gcc -java mailing list, whose archives appear -here, and also on -gclist@iecc.com. -

    -Comments and bug reports may also be sent to -(boehm@acm.org), but the gc -mailing list is usually preferred. -

    diff -Nru ecl-16.1.2/src/bdwgc/doc/porting.html ecl-16.1.3+ds/src/bdwgc/doc/porting.html --- ecl-16.1.2/src/bdwgc/doc/porting.html 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/porting.html 1970-01-01 00:00:00.000000000 +0000 @@ -1,333 +0,0 @@ - - - Conservative GC Porting Directions - - -

    Conservative GC Porting Directions

    -The collector is designed to be relatively easy to port, but is not -portable code per se. The collector inherently has to perform operations, -such as scanning the stack(s), that are not possible in portable C code. -

    -All of the following assumes that the collector is being ported to a -byte-addressable 32- or 64-bit machine. Currently all successful ports -to 64-bit machines involve LP64 targets. The code base includes some -provisions for P64 targets (notably win64), but that has not been tested. -You are hereby discouraged from attempting a port to non-byte-addressable, -or 8-bit, or 16-bit machines. -

    -The difficulty of porting the collector varies greatly depending on the needed -functionality. In the simplest case, only some small additions are needed -for the include/private/gcconfig.h file. This is described in the -following section. Later sections discuss some of the optional features, -which typically involve more porting effort. -

    -Note that the collector makes heavy use of ifdefs. Unlike -some other software projects, we have concluded repeatedly that this is preferable -to system dependent files, with code duplicated between the files. -However, to keep this manageable, we do strongly believe in indenting -ifdefs correctly (for historical reasons usually without the leading -sharp sign). (Separate source files are of course fine if they don't result in -code duplication.) -

    Adding Platforms to gcconfig.h

    -If neither thread support, nor tracing of dynamic library data is required, -these are often the only changes you will need to make. -

    -The gcconfig.h file consists of three sections: -

      -
    1. A section that defines GC-internal macros -that identify the architecture (e.g. IA64 or I386) -and operating system (e.g. LINUX or MSWIN32). -This is usually done by testing predefined macros. By defining -our own macros instead of using the predefined ones directly, we can -impose a bit more consistency, and somewhat isolate ourselves from -compiler differences. -

      -It is relatively straightforward to add a new entry here. But please try -to be consistent with the existing code. In particular, 64-bit variants -of 32-bit architectures general are not treated as a new architecture. -Instead we explicitly test for 64-bit-ness in the few places in which it -matters. (The notable exception here is I386 and X86_64. -This is partially historical, and partially justified by the fact that there -are arguably more substantial architecture and ABI differences here than -for RISC variants.) -

      -on GNU-based systems, cpp -dM empty_source_file.c seems to generate -a set of predefined macros. On some other systems, the "verbose" -compiler option may do so, or the manual page may list them. -

    2. -A section that defines a small number of platform-specific macros, which are -then used directly by the collector. For simple ports, this is where most of -the effort is required. We describe the macros below. -

      -This section contains a subsection for each architecture (enclosed in a -suitable ifdef. Each subsection usually contains some -architecture-dependent defines, followed by several sets of OS-dependent -defines, again enclosed in ifdefs. -

    3. -A section that fills in defaults for some macros left undefined in the preceding -section, and defines some other macros that rarely need adjustment for -new platforms. You will typically not have to touch these. -If you are porting to an OS that -was previously completely unsupported, it is likely that you will -need to add another clause to the definition of GET_MEM. -
    -The following macros must be defined correctly for each architecture and operating -system: -
    -
    MACH_TYPE -
    -Defined to a string that represents the machine architecture. Usually -just the macro name used to identify the architecture, but enclosed in quotes. -
    OS_TYPE -
    -Defined to a string that represents the operating system name. Usually -just the macro name used to identify the operating system, but enclosed in quotes. -
    CPP_WORDSZ -
    -The word size in bits as a constant suitable for preprocessor tests, -i.e. without casts or sizeof expressions. Currently always defined as -either 64 or 32. For platforms supporting both 32- and 64-bit ABIs, -this should be conditionally defined depending on the current ABI. -There is a default of 32. -
    ALIGNMENT -
    -Defined to be the largest N, such that -all pointer are guaranteed to be aligned on N-byte boundaries. -defining it to be 1 will always work, but perform poorly. -For all modern 32-bit platforms, this is 4. For all modern 64-bit -platforms, this is 8. Whether or not X86 qualifies as a modern -architecture here is compiler- and OS-dependent. -
    DATASTART -
    -The beginning of the main data segment. The collector will trace all -memory between DATASTART and DATAEND for root pointers. -On some platforms, this can be defined to a constant address, -though experience has shown that to be risky. Ideally the linker will -define a symbol (e.g. _data whose address is the beginning -of the data segment. Sometimes the value can be computed using -the GC_SysVGetDataStart function. Not used if either -the next macro is defined, or if dynamic loading is supported, and the -dynamic loading support defines a function -GC_register_main_static_data() which returns false. -
    SEARCH_FOR_DATA_START -
    -If this is defined DATASTART will be defined to a dynamically -computed value which is obtained by starting with the address of -_end and walking backwards until non-addressable memory is found. -This often works on Posix-like platforms. It makes it harder to debug -client programs, since startup involves generating and catching a -segmentation fault, which tends to confuse users. -
    DATAEND -
    -Set to the end of the main data segment. Defaults to end, -where that is declared as an array. This works in some cases, since -the linker introduces a suitable symbol. -
    DATASTART2, DATAEND2 -
    -Some platforms have two discontiguous main data segments, e.g. -for initialized and uninitialized data. If so, these two macros -should be defined to the limits of the second main data segment. -
    STACK_GROWS_UP -
    -Should be defined if the stack (or thread stacks) grow towards higher -addresses. (This appears to be true only on PA-RISC. If your architecture -has more than one stack per thread, and is not already supported, you will -need to do more work. Grep for "IA64" in the source for an example.) -
    STACKBOTTOM -
    -Defined to be the cool end of the stack, which is usually the -highest address in the stack. It must bound the region of the -stack that contains pointers into the GC heap. With thread support, -this must be the cold end of the main stack, which typically -cannot be found in the same way as the other thread stacks. -If this is not defined and none of the following three macros -is defined, client code must explicitly set -GC_stackbottom to an appropriate value before calling -GC_INIT() or any other GC_ routine. -
    LINUX_STACKBOTTOM -
    -May be defined instead of STACKBOTTOM. -If defined, then the cold end of the stack will be determined -Currently we usually read it from /proc. -
    HEURISTIC1 -
    -May be defined instead of STACKBOTTOM. -STACK_GRAN should generally also be undefined and defined. -The cold end of the stack is determined by taking an address inside -GC_init's frame, and rounding it up to -the next multiple of STACK_GRAN. This works well if the stack base is -always aligned to a large power of two. -(STACK_GRAN is predefined to 0x1000000, which is -rarely optimal.) -
    HEURISTIC2 -
    -May be defined instead of STACKBOTTOM. -The cold end of the stack is determined by taking an address inside -GC_init's frame, incrementing it repeatedly -in small steps (decrement if STACK_GROWS_UP), and reading the value -at each location. We remember the value when the first -Segmentation violation or Bus error is signalled, round that -to the nearest plausible page boundary, and use that as the -stack base. -
    DYNAMIC_LOADING -
    -Should be defined if dyn_load.c has been updated for this -platform and tracing of dynamic library roots is supported. -
    MPROTECT_VDB, PROC_VDB -
    -May be defined if the corresponding "virtual dirty bit" -implementation in os_dep.c is usable on this platform. This -allows incremental/generational garbage collection. -MPROTECT_VDB identifies modified pages by -write protecting the heap and catching faults. -PROC_VDB uses the /proc primitives to read dirty bits. -
    PREFETCH, PREFETCH_FOR_WRITE -
    -The collector uses PREFETCH(x) to preload the cache -with *x. -This defaults to a no-op. -
    CLEAR_DOUBLE -
    -If CLEAR_DOUBLE is defined, then -CLEAR_DOUBLE(x) is used as a fast way to -clear the two words at GC_malloc-aligned address x. By default, -word stores of 0 are used instead. -
    HEAP_START -
    -HEAP_START may be defined as the initial address hint for mmap-based -allocation. -
    ALIGN_DOUBLE -
    -Should be defined if the architecture requires double-word alignment -of GC_malloced memory, e.g. 8-byte alignment with a -32-bit ABI. Most modern machines are likely to require this. -This is no longer needed for GC7 and later. -
    -

    Additional requirements for a basic port

    -In some cases, you may have to add additional platform-specific code -to other files. A likely candidate is the implementation of -GC_with_callee_saves_pushed in     mach_dep.c. -This ensure that register contents that the collector must trace -from are copied to the stack. Typically this can be done portably, -but on some platforms it may require assembly code, or just -tweaking of conditional compilation tests. -

    -For GC7, if your platform supports getcontext(), then defining -the macro UNIX_LIKE for your OS in gcconfig.h -(if it isn't defined there already) is likely to solve the problem. -otherwise, if you are using gcc, _builtin_unwind_init() -will be used, and should work fine. If that is not applicable either, -the implementation will try to use setjmp(). This will work if your -setjmp implementation saves all possibly pointer-valued registers -into the buffer, as opposed to trying to unwind the stack at -longjmp time. The setjmp_test test tries to determine this, -but often doesn't get it right. -

    -In GC6.x versions of the collector, tracing of registers -was more commonly handled -with assembly code. In GC7, this is generally to be avoided. -

    -Most commonly os_dep.c will not require attention, but see below. -

    Thread support

    -Supporting threads requires that the collector be able to find and suspend -all threads potentially accessing the garbage-collected heap, and locate -any state associated with each thread that must be traced. -

    -The functionality needed for thread support is generally implemented -in one or more files specific to the particular thread interface. -For example, somewhat portable pthread support is implemented -in pthread_support.c and pthread_stop_world.c. -The essential functionality consists of -

    -
    GC_stop_world() -
    -Stops all threads which may access the garbage collected heap, other -than the caller. -
    GC_start_world() -
    -Restart other threads. -
    GC_push_all_stacks() -
    -Push the contents of all thread stacks (or at least of pointer-containing -regions in the thread stacks) onto the mark stack. -
    -These very often require that the garbage collector maintain its -own data structures to track active threads. -

    -In addition, LOCK and UNLOCK must be implemented -in gc_locks.h -

    -The easiest case is probably a new pthreads platform -on which threads can be stopped -with signals. In this case, the changes involve: -

      -
    1. Introducing a suitable GC_X_THREADS macro, which should -be automatically defined by gc_config_macros.h in the right cases. -It should also result in a definition of GC_PTHREADS, as for the -existing cases. -
    2. For GC7+, ensuring that the atomic_ops package at least -minimally supports the platform. -If incremental GC is needed, or if pthread locks don't -perform adequately as the allocation lock, you will probably need to -ensure that a sufficient atomic_ops port -exists for the platform to provided an atomic test and set -operation. (Current GC7 versions require moreatomic_ops -support than necessary. This is a bug.) For earlier versions define -GC_test_and_set in gc_locks.h. -
    3. Making any needed adjustments to pthread_stop_world.c and -pthread_support.c. Ideally none should be needed. In fact, -not all of this is as well standardized as one would like, and outright -bugs requiring workarounds are common. -
    -Non-preemptive threads packages will probably require further work. Similarly -thread-local allocation and parallel marking requires further work -in pthread_support.c, and may require better atomic_ops -support. -

    Dynamic library support

    -So long as DATASTART and DATAEND are defined correctly, -the collector will trace memory reachable from file scope or static -variables defined as part of the main executable. This is sufficient -if either the program is statically linked, or if pointers to the -garbage-collected heap are never stored in non-stack variables -defined in dynamic libraries. -

    -If dynamic library data sections must also be traced, then -

      -
    • DYNAMIC_LOADING must be defined in the appropriate section -of gcconfig.h. -
    • An appropriate versions of the functions -GC_register_dynamic_libraries() should be defined in -dyn_load.c. This function should invoke -GC_cond_add_roots(region_start, region_end, TRUE) -on each dynamic library data section. -
    -

    -Implementations that scan for writable data segments are error prone, particularly -in the presence of threads. They frequently result in race conditions -when threads exit and stacks disappear. They may also accidentally trace -large regions of graphics memory, or mapped files. On at least -one occasion they have been known to try to trace device memory that -could not safely be read in the manner the GC wanted to read it. -

    -It is usually safer to walk the dynamic linker data structure, especially -if the linker exports an interface to do so. But beware of poorly documented -locking behavior in this case. -

    Incremental GC support

    -For incremental and generational collection to work, os_dep.c -must contain a suitable "virtual dirty bit" implementation, which -allows the collector to track which heap pages (assumed to be -a multiple of the collectors block size) have been written during -a certain time interval. The collector provides several -implementations, which might be adapted. The default -(DEFAULT_VDB) is a placeholder which treats all pages -as having been written. This ensures correctness, but renders -incremental and generational collection essentially useless. -

    Stack traces for debug support

    -If stack traces in objects are need for debug support, -GC_dave_callers and GC_print_callers must be -implemented. -

    Disclaimer

    -This is an initial pass at porting guidelines. Some things -have no doubt been overlooked. - - diff -Nru ecl-16.1.2/src/bdwgc/doc/README.amiga ecl-16.1.3+ds/src/bdwgc/doc/README.amiga --- ecl-16.1.2/src/bdwgc/doc/README.amiga 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/README.amiga 1970-01-01 00:00:00.000000000 +0000 @@ -1,288 +0,0 @@ - Kjetil S. Matheussen's notes (28-11-2000) - -Compiles under SAS/C again. Should also still compile under other -Amiga compilers without big changes. I haven't checked if it still -works under gcc, because I don't have gcc for Amiga. But I have -updated 'Makefile', and hope it compiles fine. - - -WHATS NEW: - -1. - Made a pretty big effort in preventing GCs allocating-functions from returning - chip-mem. - - The lower part of the new file AmigaOS.c does this in various ways, mainly by - wrapping GC_malloc, GC_malloc_atomic, GC_malloc_uncollectable, - GC_malloc_atomic_uncollectable, GC_malloc_stubborn, GC_malloc_ignore_off_page - and GC_malloc_atomic_ignore_off_page. GC_realloc is also wrapped, but - doesn't do the same effort in preventing to return chip-mem. - Other allocating-functions (f.ex. GC_*_typed_) can probably be - used without any problems, but beware that the warn hook will not be called. - In case of problems, don't define GC_AMIGA_FASTALLOC. - - Programs using more time actually using the memory allocated - (instead of just allocate and free rapidly) have - the most to earn on this, but even gctest now normally runs twice - as fast and uses less memory, on my poor 8MB machine. - - The changes have only effect when there is no more - fast-mem left. But with the way GC works, it - could happen quite often. Beware that an atexit handler had to be added, - so using the abort() function will make a big memory-loss. - If you absolutely must call abort() instead of exit(), try calling - the GC_amiga_free_all_mem function before abort(). - - New Amiga-specific compilation flags: - - GC_AMIGA_FASTALLOC - By NOT defining this option, GC will work like before, - it will not try to force fast-mem out of the OS, and - it will use normal calloc for allocation, and the rest - of the following flags will have no effect. - - GC_AMIGA_ONLYFAST - Makes GC never to return chip-mem. GC_AMIGA_RETRY have - no effect if this flag is set. - - GC_AMIGA_GC - If gc returns NULL, do a GC_gcollect, and try again. This - usually is a success with the standard GC configuration. - It is also the most important flag to set to prevent - GC from returning chip-mem. Beware that it slows down a lot - when a program is rapidly allocating/deallocating when - theres either very little fast-memory left or verly little - chip-memory left. Its not a very common situation, but gctest - sometimes (very rare) use many minutes because of this. - - GC_AMIGA_RETRY - If gc succeed allocating memory, but it is chip-mem, - try again and see if it is fast-mem. Most of the time, - it will actually return fast-mem for the second try. - I have set max number of retries to 9 or size/5000. You - can change this if you like. (see GC_amiga_rec_alloc()) - - GC_AMIGA_PRINTSTATS - Gather some statistics during the execution of a - program, and prints out the info when the atexit-handler - is called. - - My reccomendation is to set all this flags, except GC_AMIGA_PRINTSTATS and - GC_AMIGA_ONLYFAST. - - If your program demands high response-time, you should - not define GC_AMIGA_GC, and possible also define GC_AMIGA_ONLYFAST. - GC_AMIGA_RETRY does not seem to slow down much. - - Also, when compiling up programs, and GC_AMIGA_FASTALLOC was not defined when - compilling gc, you can define GC_AMIGA_MAKINGLIB to avoid having these allocation- - functions wrapped. (see gc.h) - - Note that GC_realloc must not be called before any of - the other above mentioned allocating-functions have been called. (shouldn't be - any programs doing so either, I hope). - - Another note. The allocation-function is wrapped when defining - GC_AMIGA_FASTALLOC by letting the function go thru the new - GC_amiga_allocwrapper_do function-pointer (see gc.h). Means that - sending function-pointers, such as GC_malloc, GC_malloc_atomic, etc., - for later to be called like f.ex this, (*GC_malloc_function_pointer)(size), - will not wrap the function. This is normally not a big problem, unless - all allocation function is called like this, which will cause the - atexit un-allocating function never to be called. Then you either - have to manually add the atexit handler, or call the allocation- - functions function-pointer functions like this; - (*GC_amiga_allocwrapper_do)(size,GC_malloc_function_pointer). - There are probably better ways this problem could be handled, unfortunately, - I didn't find any without rewriting or replacing a lot of the GC-code, which - I really didn't want to. (Making new GC_malloc_* functions, and just - define f.ex GC_malloc as GC_amiga_malloc should work too). - - - New Amiga-specific function: - - void GC_amiga_set_toany(void (*func)(void)); - - 'func' is a function that will be called right before gc has to change - allocation-method from MEMF_FAST to MEMF_ANY. Ie. when it is likely - it will return chip-mem. - - -2. A few small compiler-specific additions to make it compile with SAS/C again. - -3. Updated and rewritten the smakefile, so that it works again and that - the "unnecessary" 'SCOPTIONS' files could be removed. Also included - the cord-smakefile stuff in the main smakefile, so that the cord smakefile - could be removed too. By writing smake -f Smakefile.smk, both gc.lib and - cord.lib will be made. - - - -STILL MISSING: - -Programs can not be started from workbench, at least not for SAS/C. (Martin -Tauchmanns note about that it now works with workbench is definitely wrong -when concerning SAS/C). An iconx-script solves this problem. - - -BEWARE! - --To run gctest, set the stack to around 200000 bytes first. --SAS/C-specific: cord will crash if you compile gc.lib with - either parm=reg or parm=both. (missing legal prototypes for - function-pointers someplace is the reason I guess.). - - -tested with software: Radium, http://www.stud.ifi.uio.no/~ksvalast/radium/ -tested with hardware: MC68060 - - - Martin Tauchmann's notes (1-Apr-99) - -Works now, also with the GNU-C compiler V2.7.2.1. -Modify the `Makefile` -CC=cc $(ABI_FLAG) -to -CC=gcc $(ABI_FLAG) - -TECHNICAL NOTES - -- `GC_get_stack_base()`, `GC_register_data_segments()` works now with every - C compiler; also Workbench. - -- Removed AMIGA_SKIP_SEG, but the Code-Segment must not be scanned by GC. - - -PROBLEMS -- When the Linker, does`t merge all Code-Segments to an single one. LD of GCC - do it always. - -- With ixemul.library V47.3, when an GC program launched from another program - (example: `Make` or `if_mach M68K AMIGA gctest`), `GC_register_data_segments()` - found the Segment-List of the caller program. - Can be fixed, if the run-time initialization code (for C programs, usually *crt0*) - support `__data` and `__bss`. - -- PowerPC Amiga currently not supported. - -- Dynamic libraries (dyn_load.c) not supported. - - -TESTED WITH SOFTWARE - -`Optimized Oberon 2 C` (oo2c) - - -TESTED WITH HARDWARE - -MC68030 - - - Michel Schinz's notes - -WHO DID WHAT - -The original Amiga port was made by Jesper Peterson. I (Michel Schinz) -modified it slightly to reflect the changes made in the new official -distributions, and to take advantage of the new SAS/C 6.x features. I also -created a makefile to compile the "cord" package (see the cord -subdirectory). - -TECHNICAL NOTES - -In addition to Jesper's notes, I have the following to say: - -- Starting with version 4.3, gctest checks to see if the code segment is - added to the root set or not, and complains if it is. Previous versions - of this Amiga port added the code segment to the root set, so I tried to - fix that. The only problem is that, as far as I know, it is impossible to - know which segments are code segments and which are data segments (there - are indeed solutions to this problem, like scanning the program on disk - or patch the LoadSeg functions, but they are rather complicated). The - solution I have chosen (see os_dep.c) is to test whether the program - counter is in the segment we are about to add to the root set, and if it - is, to skip the segment. The problems are that this solution is rather - awkward and that it works only for one code segment. This means that if - your program has more than one code segment, all of them but one will be - added to the root set. This isn't a big problem in fact, since the - collector will continue to work correctly, but it may be slower. - - Anyway, the code which decides whether to skip a segment or not can be - removed simply by not defining AMIGA_SKIP_SEG. But notice that if you do - so, gctest will complain (it will say that "GC_is_visible produced wrong - failure indication"). However, it may be useful if you happen to have - pointers stored in a code segment (you really shouldn't). - - If anyone has a good solution to the problem of finding, when a program - is loaded in memory, whether a segment is a code or a data segment, - please let me know. - - - Jesper Peterson's notes - -ADDITIONAL NOTES FOR AMIGA PORT - -These notes assume some familiarity with Amiga internals. - -WHY I PORTED TO THE AMIGA - -The sole reason why I made this port was as a first step in getting -the Sather(*) language on the Amiga. A port of this language will -be done as soon as the Sather 1.0 sources are made available to me. -Given this motivation, the garbage collection (GC) port is rather -minimal. - -(*) For information on Sather read the comp.lang.sather newsgroup. - -LIMITATIONS - -This port assumes that the startup code linked with target programs -is that supplied with SAS/C versions 6.0 or later. This allows -assumptions to be made about where to find the stack base pointer -and data segments when programs are run from WorkBench, as opposed -to running from the CLI. The compiler dependent code is all in the -GC_get_stack_base() and GC_register_data_segments() functions, but -may spread as I add Amiga specific features. - -Given that SAS/C was assumed, the port is set up to be built with -"smake" using the "SMakefile". Compiler options in "SCoptions" can -be set with "scopts" program. Both "smake" and "scopts" are part of -the SAS/C commercial development system. - -In keeping with the porting philosophy outlined above, this port -will not behave well with Amiga specific code. Especially not inter- -process comms via messages, and setting up public structures like -Intuition objects or anything else in the system lists. For the -time being the use of this library is limited to single threaded -ANSI/POSIX compliant or near-complient code. (ie. Stick to stdio -for now). Given this limitation there is currently no mechanism for -allocating "CHIP" or "PUBLIC" memory under the garbage collector. -I'll add this after giving it considerable thought. The major -problem is the entire physical address space may have to me scanned, -since there is no telling who we may have passed memory to. - -If you allocate your own stack in client code, you will have to -assign the pointer plus stack size to GC_stackbottom. - -The initial stack size of the target program can be compiled in by -setting the __stack symbol (see SAS documentaion). It can be over- -ridden from the CLI by running the AmigaDOS "stack" program, or from -the WorkBench by setting the stack size in the tool types window. - -SAS/C COMPILER OPTIONS (SCoptions) - -You may wish to check the "CPU" code option is appropriate for your -intended target system. - -Under no circumstances set the "StackExtend" code option in either -compiling the library or *ANY* client code. - -All benign compiler warnings have been suppressed. These mainly -involve lack of prototypes in the code, and dead assignments -detected by the optimizer. - -THE GOOD NEWS - -The library as it stands is compatible with the GigaMem commercial -virtual memory software, and probably similar PD software. - -The performance of "gctest" on an Amiga 2630 (68030 @ 25Mhz) -compares favourably with an HP9000 with similar architecture (a 325 -with a 68030 I think). - ------------------------------------------------------------------------ diff -Nru ecl-16.1.2/src/bdwgc/doc/README.arm.cross ecl-16.1.3+ds/src/bdwgc/doc/README.arm.cross --- ecl-16.1.2/src/bdwgc/doc/README.arm.cross 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/README.arm.cross 1970-01-01 00:00:00.000000000 +0000 @@ -1,62 +0,0 @@ -From: Margaret Fleck - -Here's the key details of what worked for me, in case anyone else needs them. -There may well be better ways to do some of this, but .... - -- Margaret - - -The badge4 has a StrongArm-1110 processor and a StrongArm-1111 coprocessor. - -Assume that the garbage collector distribution is unpacked into /home/arm/gc6.0, -which is visible to both the ARM machine and a linux desktop (e.g. via NFS mounting). - -Assume that you have a file /home/arm/config.site with contents something like the -example attached below. Notice that our local ARM toolchain lives in -/skiff/local. - -Go to /home/arm/gc6.0 directory. Do - CONFIG_SITE=/home/arm/config.site ./configure --target=arm-linux ---prefix=/home/arm/gc6.0 - -On your desktop, do: - make - make install -The main garbage collector library should now be in ../gc6.0/lib/libgc.so. - -To test the garbage collector, first do the following on your desktop - make gctest - ./gctest -Then do the following on the ARM machine - cd .libs - ./lt-gctest - -Do not try to do "make test" (the usual way of running the test -program). This does not work and seems to erase some of the important -files. - -The gctest program claims to have succeeded. Haven't run any further tests -with it, though I'll be doing so in the near future. - -------------------------------- -# config.site for configure - -HOSTCC=gcc - -# Names of the cross-compilers -CC=/skiff/local/bin/arm-linux-gcc -CXX=/skiff/local/bin/arm-linux-gcc - -# The cross compiler specific options -CFLAGS="-O2 -fno-exceptions" -CXXFLAGS="-O2 -fno-exceptions" -CPPFLAGS="-O2 -fno-exceptions" -LDFLAGS="" - -# Some other programs -AR=/skiff/local/bin/arm-linux-ar -RANLIB=/skiff/local/bin/arm-linux-ranlib -NM=/skiff/local/bin/arm-linux-nm -ac_cv_path_NM=/skiff/local/bin/arm-linux-nm -ac_cv_func_setpgrp_void=yes -x_includes=/skiff/local/arm-linux/include/X11 -x_libraries=/skiff/local/arm-linux/lib/X11 diff -Nru ecl-16.1.2/src/bdwgc/doc/README.autoconf ecl-16.1.3+ds/src/bdwgc/doc/README.autoconf --- ecl-16.1.2/src/bdwgc/doc/README.autoconf 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/README.autoconf 1970-01-01 00:00:00.000000000 +0000 @@ -1,59 +0,0 @@ -Starting from GC v6.0, we support GNU-style builds based on automake, -autoconf and libtool. This is based almost entirely on Tom Tromey's work -with gcj. - -To build and install libraries use - -configure; make; make install - -The advantages of this process are: - -1) It should eventually do a better job of automatically determining the -right compiler to use, etc. It probably already does in some cases. - -2) It tries to automatically set a good set of default GC parameters for -the platform (e.g. thread support). It provides an easier way to configure -some of the others. - -3) It integrates better with other projects using a GNU-style build process. - -4) It builds both dynamic and static libraries. - -The known disadvantages are: - -1) The build scripts are much more complex and harder to debug (though largely -standard). I don't understand them all, and there's probably lots of redundant -stuff. - -2) It probably doesn't work on all Un*x-like platforms yet. It probably will -never work on the rest. - -3) The scripts are not yet complete. Some of the standard GNU targets don't -yet work. (Corrections/additions are very welcome.) - -The distribution should contain all files needed to run "configure" and "make", -as well as the sources needed to regenerate the derived files. (If I missed -some, please let me know.) - -Note that the distribution comes without "Makefile" which is generated by -"configure". The distribution also contains "Makefile.direct" which is not -always equivalent to the generated one. - -Important options to configure: - - --prefix=PREFIX install architecture-independent files in PREFIX - [/usr/local] - --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX - [same as prefix] - --enable-threads=TYPE choose threading package - --enable-parallel-mark parallelize marking and free list construction - --enable-gc-debug (--enable-full-debug before about 7.0) - include full support for pointer back-tracing etc. - - -Unless --prefix is set (or --exec-prefix or one of the more obscure options), -make install will install libgc.a and libgc.so in /usr/local/bin, which -would typically require the "make install" to be run as root. - -Most commonly --enable-threads=posix or will be needed. --enable-parallel-mark -is recommended for multiprocessors if it is supported on the platform. diff -Nru ecl-16.1.2/src/bdwgc/doc/README.cmake ecl-16.1.3+ds/src/bdwgc/doc/README.cmake --- ecl-16.1.2/src/bdwgc/doc/README.cmake 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/README.cmake 1970-01-01 00:00:00.000000000 +0000 @@ -1,50 +0,0 @@ - -CMAKE ------ - -Win32 binaries (both 32- and 64-bit) can be built using CMake. CMake is an -open-source tool like automake - it generates makefiles. - -Some preliminary work has been done to make this work on other platforms, but -the support is not yet complete. - -CMake will generate: - - Borland Makefiles - MSYS Makefiles - MinGW Makefiles - NMake Makefiles - Unix Makefiles - . Visual Studio project files - Visual Studio 6 - Visual Studio 7 - Visual Studio 7 .NET 2003 - Visual Studio 8 2005 - Visual Studio 8 2005 Win64 - Visual Studio 9 2008 - Visual Studio 9 2008 Win64 - Watcom WMake - - -BUILD PROCESS -------------- - - . install cmake (cmake.org) - . add directory containing cmake.exe to %PATH% - . run cmake from the gc root directory, passing the target with -G: - e.g., - > cmake -G "Visual Studio 8 2005" - use the gc.sln file generated by cmake to build gc - . you can also run cmake from a build directory to build outside of - the source tree. Just specify the path to the source tree: - e.g., - > mkdir build - > cd build - > cmake .. -G "Visual Studio 8 2005" - - -INPUT ------ - -The main input to cmake are the CMakeLists.txt files in each directory. For -help, goto cmake.org. diff -Nru ecl-16.1.2/src/bdwgc/doc/README.cords ecl-16.1.3+ds/src/bdwgc/doc/README.cords --- ecl-16.1.2/src/bdwgc/doc/README.cords 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/README.cords 1970-01-01 00:00:00.000000000 +0000 @@ -1,50 +0,0 @@ -Copyright (c) 1993-1994 by Xerox Corporation. All rights reserved. - -THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED -OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - -Permission is hereby granted to use or copy this program -for any purpose, provided the above notices are retained on all copies. -Permission to modify the code and to distribute modified code is granted, -provided the above notices are retained, and a notice that the code was -modified is included with the above copyright notice. - -Please send bug reports to Hans-J. Boehm. - -This is a string packages that uses a tree-based representation. -See cord.h for a description of the functions provided. Ec.h describes -"extensible cords", which are essentially output streams that write -to a cord. These allow for efficient construction of cords without -requiring a bound on the size of a cord. - -More details on the data structure can be found in - -Boehm, Atkinson, and Plass, "Ropes: An Alternative to Strings", -Software Practice and Experience 25, 12, December 1995, pp. 1315-1330. - -A fundamentally similar "rope" data structure is also part of SGI's standard -template library implementation, and its descendants, which include the -GNU C++ library. That uses reference counting by default. -There is a short description of that data structure at -http://www.sgi.com/tech/stl/ropeimpl.html . - -All of these are descendants of the "ropes" in Xerox Cedar. - -cord/tests/de.c is a very dumb text editor that illustrates the use of cords. -It maintains a list of file versions. Each version is simply a -cord representing the file contents. Nonetheless, standard -editing operations are efficient, even on very large files. -(Its 3 line "user manual" can be obtained by invoking it without -arguments. Note that ^R^N and ^R^P move the cursor by -almost a screen. It does not understand tabs, which will show -up as highlighted "I"s. Use the UNIX "expand" program first.) -To build the editor, type "make cord/de" in the gc directory. - -This package assumes an ANSI C compiler such as gcc. It will -not compile with an old-style K&R compiler. - -Note that CORD_printf iand friends use C functions with variable numbers -of arguments in non-standard-conforming ways. This code is known to -break on some platforms, notably PowerPC. It should be possible to -build the remainder of the library (everything but cordprnt.c) on -any platform that supports the collector. diff -Nru ecl-16.1.2/src/bdwgc/doc/README.darwin ecl-16.1.3+ds/src/bdwgc/doc/README.darwin --- ecl-16.1.2/src/bdwgc/doc/README.darwin 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/README.darwin 1970-01-01 00:00:00.000000000 +0000 @@ -1,144 +0,0 @@ -Darwin/MacOSX Support - December 16, 2003 - -== Build Notes == - -Building can be done with autoconf as normal. If you want to build -a Universal library using autoconf, you need to disable dependency -tracking and specify your desired architectures in CFLAGS: - -CFLAGS="-arch ppc -arch i386 -arch x86_64" ./configure --disable-dependency-tracking - - -== Important Usage Notes == - -GC_init() MUST be called before calling any other GC functions. This -is necessary to properly register segments in dynamic libraries. This -call is required even if you code does not use dynamic libraries as the -dyld code handles registering all data segments. - -When your use of the garbage collector is confined to dylibs and you -cannot call GC_init() before your libraries' static initializers have -run and perhaps called GC_malloc(), create an initialization routine -for each library to call GC_init(): - -#include -extern "C" void my_library_init() { GC_init(); } - -Compile this code into a my_library_init.o, and link it into your -dylib. When you link the dylib, pass the -init argument with -_my_library_init (e.g. gcc -dynamiclib -o my_library.dylib a.o b.o c.o -my_library_init.o -init _my_library_init). This causes -my_library_init() to be called before any static initializers, and -will initialize the garbage collector properly. - -Note: It doesn't hurt to call GC_init() more than once, so it's best, -if you have an application or set of libraries that all use the -garbage collector, to create an initialization routine for each of -them that calls GC_init(). Better safe than sorry. - -The incremental collector is still a bit flaky on darwin. It seems to -work reliably with workarounds for a few possible bugs in place however -these workaround may not work correctly in all cases. There may also -be additional problems that I have not found. - -Thread-local GC allocation will not work with threads that are not -created using the GC-provided override of pthread_create(). Threads -created without the GC-provided pthread_create() do not have the -necessary data structures in the GC to store this data. - - -== Implementation Information == - -Darwin/MacOSX support is nearly complete. Thread support is reliable on -Darwin 6.x (MacOSX 10.2) and there have been reports of success on older -Darwin versions (MacOSX 10.1). Shared library support had also been -added and the gc can be run from a shared library. - -Thread support is implemented in terms of mach thread_suspend and -thread_resume calls. These provide a very clean interface to thread -suspension. This implementation doesn't rely on pthread_kill so the -code works on Darwin < 6.0 (MacOSX 10.1). All the code to stop and -start the world is located in darwin_stop_world.c. - -Since not all uses of the GC enable clients to override pthread_create() -before threads have been created, the code for stopping the world has -been rewritten to look for threads using Mach kernel calls. Each -thread identified in this way is suspended and resumed as above. In -addition, since Mach kernel threads do not contain pointers to their -stacks, a stack-walking function has been written to find the stack -limits. Given an initial stack pointer (for the current thread, a -pointer to a stack-allocated local variable will do; for a non-active -thread, we grab the value of register 1 (on PowerPC)), it -will walk the PPC Mach-O-ABI compliant stack chain until it reaches the -top of the stack. This appears to work correctly for GCC-compiled C, -C++, Objective-C, and Objective-C++ code, as well as for Java -programs that use JNI. If you run code that does not follow the stack -layout or stack pointer conventions laid out in the PPC Mach-O ABI, -then this will likely crash the garbage collector. - -The original incremental collector support unfortunately no longer works -on recent Darwin versions. It also relied on some undocumented kernel -structures. Mach, however, does have a very clean interface to exception -handing. The current implementation uses Mach's exception handling. - -Much thanks goes to Andrew Stone, Dietmar Planitzer, Andrew Begel, -Jeff Sturm, and Jesse Rosenstock for all their work on the -Darwin/OS X port. - --Brian Alliet - -== gc_cpp.h usage == - -Replacement of operator new and delete is apparently not supported with -dynamic libraries. This means that applications using gc_cpp.h -(including the built-in test) will probably not work correctly with -the collector in a dynamic library, unless special care is taken. - -See -http://article.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/1421 -for some details. - -- Hans Boehm (based on information from Andrew Begel) - - -== Older Information (Most of this no longer applies to the current code) == - -While the GC should work on MacOS X Server, MacOS X and Darwin, I only tested -it on MacOS X Server. -I've added a PPC assembly version of GC_push_regs(), thus the setjmp() hack is -no longer necessary. Incremental collection is supported via mprotect/signal. -The current solution isn't really optimal because the signal handler must decode -the faulting PPC machine instruction in order to find the correct heap address. -Further, it must poke around in the register state which the kernel saved away -in some obscure register state structure before it calls the signal handler - -needless to say the layout of this structure is no where documented. -Threads and dynamic libraries are not yet supported (adding dynamic library -support via the low-level dyld API shouldn't be that hard). - -The original MacOS X port was brought to you by Andrew Stone. - - -June, 1 2000 - -Dietmar Planitzer - -Note from Andrew Begel: - -One more fix to enable gc.a to link successfully into a shared library for -MacOS X. You have to add -fno-common to the CFLAGS in the Makefile. MacOSX -disallows common symbols in anything that eventually finds its way into a -shared library. (I don't completely understand why, but -fno-common seems to -work and doesn't mess up the garbage collector's functionality). - -Feb 26, 2003 - -Jeff Sturm and Jesse Rosenstock provided a patch that adds thread support. -GC_MACOSX_THREADS should be defined in the build and in clients. Real -dynamic library support is still missing, i.e. dynamic library data segments -are still not scanned. Code that stores pointers to the garbage collected -heap in statically allocated variables should not reside in a dynamic -library. This still doesn't appear to be 100% reliable. - -Mar 10, 2003 -Brian Alliet contributed dynamic library support for MacOSX. It could also -use more testing. diff -Nru ecl-16.1.2/src/bdwgc/doc/README.DGUX386 ecl-16.1.3+ds/src/bdwgc/doc/README.DGUX386 --- ecl-16.1.2/src/bdwgc/doc/README.DGUX386 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/README.DGUX386 1970-01-01 00:00:00.000000000 +0000 @@ -1,45 +0,0 @@ - Garbage Collector (parallel iversion) for ix86 DG/UX Release R4.20MU07 - - - *READ* the file README.QUICK. - - You need the GCC-3.0.3 rev (DG/UX) compiler to build this tree. - This compiler has the new "dgux386" threads package implemented. - It also supports the switch "-pthread" needed to link correctly - the DG/UX's -lrte -lthread with -lgcc and the system's -lc. - Finally we support parralleli-mark for the SMP DG/UX machines. - To build the garbage collector do: - - ./configure --enable-parallel-mark - make - make gctest - - Before you run "gctest" you need to set your LD_LIBRARY_PATH - correctly so that "gctest" can find the shared library libgc. - Alternatively you can do a configuration - - ./configure --enable-parallel-mark --disable-shared - - to build only the static version of libgc. - - To enable debugging messages please do: - 1) Add the "--enable-gc-debug" flag during configuration. - 2) Edit the file linux-threads.c and uncomment the line: - - /* #define DEBUG_THREADS 1 */ to ---> - - #define DEBUG_THREADS 1 - - Then give "make" as usual. - - In a machine with 4 CPUs (my own machine) the option parallel - mark (aka --enable-parallel-mark) makes a BIG difference. - - Takis Psarogiannakopoulos - -Note (HB): - The integration of this patch is currently not complete. - The following patches against 6.1alpha3 where hard to move - to alpha4, and are not integrated. There may also be minor - problems with stylistic corrections made by me. -[The diff for ltconfig and ltmain.sh was removed from this file on 2011-08-22] diff -Nru ecl-16.1.2/src/bdwgc/doc/README.environment ecl-16.1.3+ds/src/bdwgc/doc/README.environment --- ecl-16.1.2/src/bdwgc/doc/README.environment 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/README.environment 1970-01-01 00:00:00.000000000 +0000 @@ -1,187 +0,0 @@ -The garbage collector looks at a number of environment variables which are, -then, used to affect its operation. - -GC_INITIAL_HEAP_SIZE= - Initial heap size in bytes. May speed up - process start-up. Optionally, may be - specified with a multiplier ('k', 'M' or 'G') - suffix. - -GC_MAXIMUM_HEAP_SIZE= - Maximum collected heap size. Allows - a multiplier suffix. - -GC_LOOP_ON_ABORT - Causes the collector abort routine to enter a tight loop. - This may make it easier to debug, such a process, especially - for multi-threaded platforms that don't produce usable core - files, or if a core file would be too large. On some - platforms, this also causes SIGSEGV to be caught and - result in an infinite loop in a handler, allowing - similar debugging techniques. - -GC_PRINT_STATS - Turn on GC logging. Not functional with SMALL_CONFIG. - -GC_LOG_FILE - The name of the log file. Stderr by default. Not functional - with SMALL_CONFIG. - -GC_ONLY_LOG_TO_FILE - Turns off redirection of GC stdout and stderr to the log - file specified by GC_LOG_FILE. Has no effect unless - GC_LOG_FILE is set. Not functional with SMALL_CONFIG. - -GC_PRINT_VERBOSE_STATS - Turn on even more logging. Not functional with - SMALL_CONFIG. - -GC_DUMP_REGULARLY - Generate a GC debugging dump GC_dump() on startup - and during every collection. Very verbose. Useful - if you have a bug to report, but please include only the - last complete dump. - -GC_COLLECT_AT_MALLOC= - Override the default value specified by - GC_COLLECT_AT_MALLOC macro. Has no effect unless - GC is built with GC_COLLECT_AT_MALLOC defined. - -GC_BACKTRACES= - Generate n random back-traces (for heap profiling) after - each GC. Collector must have been built with - KEEP_BACK_PTRS. This won't generate useful output unless - most objects in the heap were allocated through debug - allocators. This is intended to be only a statistical - sample; individual traces may be erroneous due to - concurrent heap mutation. - -GC_PRINT_ADDRESS_MAP - Linux only. Dump /proc/self/maps, i.e. various address - maps for the process, to stderr on every GC. Useful for - mapping root addresses to source for deciphering leak - reports. - -GC_NPROCS= - Linux w/threads only. Explicitly sets the number of processors - that the GC should expect to use. Note that setting this to 1 - when multiple processors are available will preserve - correctness, but may lead to really horrible performance, - since the lock implementation will immediately yield without - first spinning. - -GC_MARKERS= - Only if compiled with PARALLEL_MARK. Set the number - of marker threads. This is normally set to the number of - processors. It is safer to adjust GC_MARKERS than GC_NPROCS, - since GC_MARKERS has no impact on the lock implementation. - -GC_NO_BLACKLIST_WARNING - Prevents the collector from issuing - warnings about allocations of very large blocks. - Deprecated. Use GC_LARGE_ALLOC_WARN_INTERVAL instead. - -GC_LARGE_ALLOC_WARN_INTERVAL= - Print every nth warning about very large - block allocations, starting with the nth one. Small values - of n are generally benign, in that a bounded number of - such warnings generally indicate at most a bounded leak. - For best results it should be set at 1 during testing. - Default is 5. Very large numbers effectively disable the - warning. - -GC_IGNORE_GCJ_INFO - Ignore the type descriptors implicitly supplied by - GC_gcj_malloc and friends. This is useful for debugging - descriptor generation problems, and possibly for - temporarily working around such problems. It forces a - fully conservative scan of all heap objects except - those known to be pointer-free, and may thus have other - adverse effects. - -GC_PRINT_BACK_HEIGHT - Print max length of chain through unreachable objects - ending in a reachable one. If this number remains - bounded, then the program is "GC robust". This ensures - that a fixed number of misidentified pointers can only - result in a bounded space leak. This currently only - works if debugging allocation is used throughout. - It increases GC space and time requirements appreciably. - This feature is still somewhat experimental, and requires - that the collector have been built with MAKE_BACK_GRAPH - defined. For details, see Boehm, "Bounding Space Usage - of Conservative Garbage Collectors", POPL 2001 - (http://www.hpl.hp.com/techreports/2001/HPL-2001-251.html). - -GC_RETRY_SIGNALS, GC_NO_RETRY_SIGNALS - Try to compensate for lost - thread suspend signals in linux_threads.c. On by - default for GC_OSF1_THREADS, off otherwise. Note - that this does not work around a possible loss of - thread restart signals. This seems to be necessary for - some versions of Tru64. Since we've previously seen - similar issues on some other operating systems, it - was turned into a runtime flag to enable last-minute - work-arounds. - -GC_USE_GETWRITEWATCH= - Only if MPROTECT_VDB and GWW_VDB are both defined - (Win32 only). Explicitly specify which strategy of - keeping track of dirtied pages should be used. - If n=0 then GetWriteWatch() is not used (falling back to - protecting pages and catching memory faults strategy) - else the collector tries to use GetWriteWatch-based - strategy (GWW_VDB) first if available. - -GC_DISABLE_INCREMENTAL - Ignore runtime requests to enable incremental GC. - Useful for debugging. - -The following turn on runtime flags that are also program settable. Checked -only during initialization. We expect that they will usually be set through -other means, but this may help with debugging and testing: - -GC_ENABLE_INCREMENTAL - Turn on incremental collection at startup. Note that, - depending on platform and collector configuration, this - may involve write protecting pieces of the heap to - track modifications. These pieces may include - pointer-free objects or not. Although this is intended - to be transparent, it may cause unintended system call - failures. Use with caution. - -GC_PAUSE_TIME_TARGET - Set the desired garbage collector pause time in msecs. - This only has an effect if incremental collection is - enabled. If a collection requires appreciably more time - than this, the client will be restarted, and the collector - will need to do additional work to compensate. The - special value "999999" indicates that pause time is - unlimited, and the incremental collector will behave - completely like a simple generational collector. If - the collector is configured for parallel marking, and - run on a multiprocessor, incremental collection should - only be used with unlimited pause time. - -GC_FULL_FREQUENCY - Set the desired number of partial collections between full - collections. Matters only if GC_incremental is set. - Not functional with SMALL_CONFIG. - -GC_FREE_SPACE_DIVISOR - Set GC_free_space_divisor to the indicated value. - Setting it to larger values decreases space consumption - and increases GC frequency. - -GC_UNMAP_THRESHOLD - Set the desired memory blocks unmapping threshold (the - number of sequential garbage collections for which - a candidate block for unmapping should remain free). The - special value "0" completely disables unmapping. - -GC_FORCE_UNMAP_ON_GCOLLECT - Turn "unmap as much as possible on explicit GC" - mode on (overrides the default value). Has no effect on - implicitly-initiated garbage collections. Has no effect if - memory unmapping is disabled (or not compiled in) or if the - unmapping threshold is 1. - -GC_FIND_LEAK - Turns on GC_find_leak and thus leak detection. Forces a - collection at program termination to detect leaks that would - otherwise occur after the last GC. - -GC_FINDLEAK_DELAY_FREE - Turns on deferred freeing of objects in the - leak-finding mode (see the corresponding macro - description for more information). - -GC_ABORT_ON_LEAK - Causes the application to be terminated once leaked or - smashed objects are found. - -GC_ALL_INTERIOR_POINTERS - Turns on GC_all_interior_pointers and thus interior - pointer recognition. - -GC_DONT_GC - Turns off garbage collection. Use cautiously. - -GC_USE_ENTIRE_HEAP - Set desired GC_use_entire_heap value at start-up. See - the similar macro description in README.macros. - -GC_TRACE=addr - Intended for collector debugging. Requires that the collector - have been built with ENABLE_TRACE defined. Causes the debugger - to log information about the tracing of address ranges - containing addr. Typically addr is the address that contains - a pointer to an object that mysteriously failed to get marked. - Addr must be specified as a hexadecimal integer. diff -Nru ecl-16.1.2/src/bdwgc/doc/README.ews4800 ecl-16.1.3+ds/src/bdwgc/doc/README.ews4800 --- ecl-16.1.2/src/bdwgc/doc/README.ews4800 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/README.ews4800 1970-01-01 00:00:00.000000000 +0000 @@ -1,80 +0,0 @@ -GC on EWS4800 -------------- - -1. About EWS4800 - EWS4800 is 32bit/64bit workstation. - - Vender: NEC Corporation - OS: UX/4800 R9.* - R13.* (SystemV R4.2) - CPU: R4000, R4400, R10000 (MIPS) - -2. Compiler - - 32bit: - Use ANSI C compiler. - CC = /usr/abiccs/bin/cc - - 64bit: - Use 64bit ANSI C compiler. - CC = /usr/ccs64/bin/cc - AR = /usr/ccs64/bin/ar - -3. ELF file format - *** Caution: The following infomation is empirical. *** - - 32bit: - ELF file has an unique format. (See a.out(4) and end(3C).) - - &_start - : text segment - &etext - DATASTART - : data segment (initialized) - &edata - DATASTART2 - : data segment (uninitialized) - &end - - Here, DATASTART and DATASTART2 are macros of GC, and are defined as - the following equations. (See include/private/gcconfig.h.) - The algorithm for DATASTART is similar with the function - GC_SysVGetDataStart() in os_dep.c. - - DATASTART = ((&etext + 0x3ffff) & ~0x3ffff) + (&etext & 0xffff) - - Dynamically linked: - DATASTART2 = (&_gp + 0x8000 + 0x3ffff) & ~0x3ffff - - Statically linked: - DATASTART2 = &edata - - GC has to check addresses both between DATASTART and &edata, and - between DATASTART2 and &end. If a program accesses between &etext - and DATASTART, or between &edata and DATASTART2, the segmentation - error occurs and the program stops. - - If a program is statically linked, there is not a gap between - &edata and DATASTART2. The global symbol &_DYNAMIC_LINKING is used - for the detection. - - 64bit: - ELF file has a simple format. (See end(3C).) - - _ftext - : text segment - _etext - _fdata = DATASTART - : data segment (initialized) - _edata - _fbss - : data segment (uninitialized) - _end = DATAEND - --- -Hironori SAKAMOTO - - -When using the new "configure; make" build process, please -run configure with the --disable-shared option. "Make check" does not -yet pass with dynamic libraries. Ther reasons for that are not yet -understood. (HB, paraphrasing message from Hironori SAKAMOTO.) diff -Nru ecl-16.1.2/src/bdwgc/doc/README.hp ecl-16.1.3+ds/src/bdwgc/doc/README.hp --- ecl-16.1.2/src/bdwgc/doc/README.hp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/README.hp 1970-01-01 00:00:00.000000000 +0000 @@ -1,18 +0,0 @@ -Dynamic loading support requires that executables be linked with -ldld. -The alternative is to build the collector without defining DYNAMIC_LOADING -in gcconfig.h and ensuring that all garbage collectible objects are -accessible without considering statically allocated variables in dynamic -libraries. - -The collector should compile with either plain cc or cc -Ae. Cc -Aa -fails to define _HPUX_SOURCE and thus will not configure the collector -correctly. - -Incremental collection support was reccently added, and should now work. - -In spite of past claims, pthread support under HP/UX 11 should now work. -Define GC_HPUX_THREADS for the build. Incremental collection still does not -work in combination with it. - -The stack finding code can be confused by putenv calls before collector -initialization. Call GC_malloc or GC_init before any putenv calls. diff -Nru ecl-16.1.2/src/bdwgc/doc/README.linux ecl-16.1.3+ds/src/bdwgc/doc/README.linux --- ecl-16.1.2/src/bdwgc/doc/README.linux 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/README.linux 1970-01-01 00:00:00.000000000 +0000 @@ -1,129 +0,0 @@ -See README.alpha for Linux on DEC AXP info. - -This file applies mostly to Linux/Intel IA32. Ports to Linux on an M68K, -IA64, SPARC, MIPS, Alpha and PowerPC are integrated too. They should behave -similarly, except that the PowerPC port lacks incremental GC support, and -it is unknown to what extent the Linux threads code is functional. -See below for M68K specific notes. - -Incremental GC is generally supported. - -Dynamic libraries are supported on an ELF system. A static executable -should be linked with the gcc option "-Wl,-defsym,_DYNAMIC=0". - -The collector appears to work reliably with Linux threads, but beware -of older versions of glibc and gdb. - -The garbage collector uses SIGPWR and SIGXCPU if it is used with -Linux threads. These should not be touched by the client program. - -To use threads, you need to abide by the following requirements: - -1) You need to use LinuxThreads or NPTL (which are included in libc6). - - The collector relies on some implementation details of the LinuxThreads - package. This code may not work on other - pthread implementations (in particular it will *not* work with - MIT pthreads). - -2) You must compile the collector with -DGC_LINUX_THREADS (or - just -DGC_THREADS) and -D_REENTRANT specified in the Makefile. - -3a) Every file that makes thread calls should define GC_LINUX_THREADS and - _REENTRANT and then include gc.h. Gc.h redefines some of the - pthread primitives as macros which also provide the collector with - information it requires. - -3b) A new alternative to (3a) is to build the collector and compile GC clients - with -DGC_USE_LD_WRAP, and to link the final program with - - (for ld) --wrap dlopen --wrap pthread_create \ - --wrap pthread_join --wrap pthread_detach \ - --wrap pthread_sigmask --wrap pthread_exit --wrap pthread_cancel - - (for gcc) -Wl,--wrap -Wl,dlopen -Wl,--wrap -Wl,pthread_create \ - -Wl,--wrap -Wl,pthread_join -Wl,--wrap -Wl,pthread_detach \ - -Wl,--wrap -Wl,pthread_sigmask -Wl,--wrap -Wl,pthread_exit \ - -Wl,--wrap -Wl,pthread_cancel - - In any case, _REENTRANT should be defined during compilation. - -4) Dlopen() disables collection during its execution. (It can't run - concurrently with the collector, since the collector looks at its - data structures. It can't acquire the allocator lock, since arbitrary - user startup code may run as part of dlopen().) Under unusual - conditions, this may cause unexpected heap growth. - -5) The combination of GC_LINUX_THREADS, REDIRECT_MALLOC, and incremental - collection is probably not fully reliable, though it now seems to work - in simple cases. - -6) Thread local storage may not be viewed as part of the root set by the - collector. This probably depends on the linuxthreads version. For the - time being, any collectible memory referenced by thread local storage - should also be referenced from elsewhere, or be allocated as uncollectible. - (This is really a bug that should be fixed somehow. The current GC - version probably gets things right if there are not too many tls locations - and if dlopen is not used.) - - -M68K LINUX: -(From Richard Zidlicky) -The bad news is that it can crash every linux-m68k kernel on a 68040, -so an additional test is needed somewhere on startup. I have meanwhile -patches to correct the problem in 68040 buserror handler but it is not -yet in any standard kernel. - -Here is a simple test program to detect whether the kernel has the -problem. It could be run as a separate check in configure or tested -upon startup. If it fails (return !0) than mprotect can't be used -on that system. - -/* - * test for bug that may crash 68040 based Linux - */ - -#include -#include -#include -#include -#include - - -char *membase; -int pagesize=4096; -int pageshift=12; -int x_taken=0; - -int sighandler(int sig) -{ - mprotect(membase,pagesize,PROT_READ|PROT_WRITE); - x_taken=1; -} - -main() -{ - long l; - - signal(SIGSEGV,sighandler); - l=(long)mmap(NULL,pagesize,PROT_READ,MAP_PRIVATE | MAP_ANON,-1,0); - if (l==-1) - { - perror("mmap/malloc"); - abort(); - } - membase=(char*)l; - *(long*)(membase+sizeof(long))=123456789; - if (*(long*)(membase+sizeof(long)) != 123456789 ) - { - fprintf(stderr,"writeback failed !\n"); - exit(1); - } - if (!x_taken) - { - fprintf(stderr,"exception not taken !\n"); - exit(1); - } - fprintf(stderr,"vmtest Ok\n"); - exit(0); -} diff -Nru ecl-16.1.2/src/bdwgc/doc/README.Mac ecl-16.1.3+ds/src/bdwgc/doc/README.Mac --- ecl-16.1.2/src/bdwgc/doc/README.Mac 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/README.Mac 1970-01-01 00:00:00.000000000 +0000 @@ -1,363 +0,0 @@ -The contents of this file are old and pertain to pre-MacOSX versions. -You probably really wanted README.darwin. - ---------------------------------------------- - -Patrick Beard's Notes for building GC v4.12 with CodeWarrior Pro 2: ----------------------------------------------------------------------------- -The current build environment for the collector is CodeWarrior Pro 2. -Projects for CodeWarrior Pro 2 (and for quite a few older versions) -are distributed in the file Mac_projects.sit.hqx. The project file -:Mac_projects:gc.prj builds static library versions of the collector. -:Mac_projects:gctest.prj builds the GC test suite. - -Configuring the collector is still done by editing the file -:extra:Mac_files:MacOS_config.h. - -Lars Farm's suggestions on building the collector: ----------------------------------------------------------------------------- -Garbage Collection on MacOS - a manual 'MakeFile' -------------------------------------------------- - -Project files and IDE's are great on the Macintosh, but they do have -problems when used as distribution media. This note tries to provide -porting instructions in pure TEXT form to avoid those problems. A manual -'makefile' if you like. - - GC version: 4.12a2 - Codewarrior: CWPro1 - date: 18 July 1997 - -The notes may or may not apply to earlier or later versions of the -GC/CWPro. Actually, they do apply to earlier versions of both except that -until recently a project could only build one target so each target was a -separate project. The notes will most likely apply to future versions too. -Possibly with minor tweaks. - -This is just to record my experiences. These notes do not mean I now -provide a supported port of the GC to MacOS. It works for me. If it works -for you, great. If it doesn't, sorry, try again...;-) Still, if you find -errors, please let me know. - - -Porting to MacOS is a bit more complex than it first seems. Which MacOS? -68K/PowerPC? Which compiler? Each supports both 68K and PowerPC and offer a -large number of (unique to each environment) compiler settings. Each -combination of compiler/68K/PPC/settings require a unique combination of -standard libraries. And the IDE's does not select them for you. They don't -even check that the library is built with compatible setting and this is -the major source of problems when porting the GC (and otherwise too). - -You will have to make choices when you configure the GC. I've made some -choices here, but there are other combinations of settings and #defines -that work too. - -As for target settings the major obstacles may be: -- 68K Processor: check "4-byte Ints". -- PPC Processor: uncheck "Store Static Data in TOC". - -What you need to do: -1) Build the GC as a library -2) Test that the library works with 'test.c'. -3) Test that the C++ interface 'gc_cpp.cc/h' works with 'test_cpp.cc'. - -== 1. The Libraries == - -I made one project with four targets (68K/PPC tempmem or appheap). One target -will suffice if you're able to decide which one you want. I wasn't... - -Codewarrior allows a large number of compiler/linker settings. I used these: - -Settings shared by all targets: ------------------------------- -o Access Paths: - - User Paths: the GC folder - - System Paths: {Compiler}:Metrowerks Standard Library: - {Compiler}:MacOS Support:Headers: - {Compiler}:MacOS Support:MacHeaders: -o C/C++ language: - - inlining: normal - - direct to SOM: off - - enable/check: exceptions, RTTI, bool (and if you like pool strings) - -PowerPC target settings ------------------------ -o Target Settings: - - name of target - - MacOS PPC Linker -o PPC Target - - name of library -o C/C++ language - - prefix file as described below -o PPC Processor - - Struct Alignment: PowerPC - - uncheck "Store Static Data in TOC" -- important! - I don't think the others matter, I use full optimization and it is OK -o PPC Linker - - Factory Settings (SYM file with full paths, faster linking, dead-strip - static init, Main: __start) - - -68K target settings -------------------- -o Target Settings: - - name of target - - MacOS 68K Linker -o 68K Target - - name of library - - A5 relative data -o C/C++ language - - prefix file as described below -o 68K Processor - - Code model: smart - - Struct alignment: 68K - - FP: SANE - - enable 4-Byte Ints -- important! - I don't think the others matter. I selected... - - enable: 68020 - - enable: global register allocation -o IR Optimizer - - enable: Optimize Space, Optimize Speed - I suppose the others would work too, but haven't tried... -o 68K Linker - - Factory Settings (New Style MacsBug, SYM file with full paths, - A6 Frames, fast link, Merge compiler glue into segment 1, - dead-strip static init) - -Prefix Files to configure the GC sources ----------------------------------------- -The Codewarrior equivalent of commandline compilers -DNAME=X is to use -prefix-files. A TEXT file that is automatically #included before the first byte -of every source file. I used these: - ----- ( cut here ) ---- gc_prefix_tempmem.h -- 68K and PPC ----- - #include "gc_prefix_common.h" - #undef USE_TEMPORARY_MEMORY - #define USE_TEMPORARY_MEMORY ----- ( cut here ) ---- gc_prefix_appmem.h -- 68K and PPC ----- - #include "gc_prefix_common.h" - #undef USE_TEMPORARY_MEMORY -// #define USE_TEMPORARY_MEMORY - ----- ( cut here ) ---- gc_prefix_common.h -------------------- -// gc_prefix_common.h -// ------------------ -// Codewarrior prefix file to configure the GC libraries -// -// prefix files are the Codewarrior equivalent of the -// command line option -Dname=x frequently seen in makefiles - -#if !__MWERKS__ - #error only tried this with Codewarrior -#endif - -#if macintosh - #define MSL_USE_PRECOMPILED_HEADERS 0 - #include - - // See list of #defines to configure the library in: 'MakeFile' - // see also README - - #define ALL_INTERIOR_POINTERS // follows interior pointers. -//#define DONT_ADD_BYTE_AT_END // disables the padding if defined. -//#define SMALL_CONFIG // whether to use a smaller heap. - #define ATOMIC_UNCOLLECTABLE // GC_malloc_atomic_uncollectable() - - // define either or none as per personal preference - // used in malloc.c - #define REDIRECT_MALLOC GC_malloc -//#define REDIRECT_MALLOC GC_malloc_uncollectable - // if REDIRECT_MALLOC is #defined make sure that the GC library - // is listed before the ANSI/ISO libs in the Codewarrior - // 'Link order' panel -//#define IGNORE_FREE - - // mac specific configs -//#define USE_TEMPORARY_MEMORY // use Macintosh temporary memory. -//#define SHARED_LIBRARY_BUILD // build for use in a shared library. - -#else - // could build Win32 here too, or in the future - // Rhapsody PPC-mach, Rhapsody PPC-MacOS, - // Rhapsody Intel-mach, Rhapsody Intel-Win32,... - // ... ugh this will get messy ... -#endif - -// make sure ints are at least 32-bit -// ( could be set to 16-bit by compiler settings (68K) ) - -struct gc_private_assert_intsize_{ char x[ sizeof(int)>=4 ? 1 : 0 ]; }; - -#if __powerc - #if __option(toc_data) - #error turn off "store static data in TOC" when using GC - // ... or find a way to add TOC to the root set...(?) - #endif -#endif ----- ( cut here ) ---- end of gc_prefix_common.h ----------------- - -Files to build the GC libraries: --------------------------------- - allchblk.c - alloc.c - blacklst.c - checksums.c - dbg_mlc.c - finalize.c - headers.c - mach_dep.c - MacOS.c -- contains MacOS code - malloc.c - mallocx.c - mark.c - mark_rts.c - misc.c - new_hblk.c - obj_map.c - os_dep.c -- contains MacOS code - ptr_chck.c - reclaim.c - stubborn.c - typd_mlc.c - gc++.cc -- this is 'gc_cpp.cc' with less 'inline' and - -- throw std::bad_alloc when out of memory - -- gc_cpp.cc works just fine too - -== 2. Test that the library works with 'test.c' == - -The test app is just an ordinary ANSI-C console app. Make sure settings -match the library you're testing. - -Files ------ - test.c - the GC library to test -- link order before ANSI libs - suitable Mac+ANSI libraries - -prefix: ------- ----- ( cut here ) ---- gc_prefix_testlib.h -- all libs ----- -#define MSL_USE_PRECOMPILED_HEADERS 0 -#include -#undef NDEBUG - -#define ALL_INTERIOR_POINTERS /* for GC_priv.h */ ----- ( cut here ) ---- - -== 3. Test that the C++ interface 'gc_cpp.cc/h' works with 'test_cpp.cc' == - -The test app is just an ordinary ANSI-C console app. Make sure settings match -the library you're testing. - -Files ------ - test_cpp.cc - the GC library to test -- link order before ANSI libs - suitable Mac+ANSI libraries - -prefix: ------- -same as for test.c - -For convenience I used one test-project with several targets so that all -test apps are build at once. Two for each library to test: test.c and -gc_app.cc. When I was satisfied that the libraries were OK. I put the -libraries + gc.h + the c++ interface-file in a folder that I then put into -the MSL hierarchy so that I don't have to alter access-paths in projects -that use the GC. - -After that, just add the proper GC library to your project and the GC is in -action! malloc will call GC_malloc and free GC_free, new/delete too. You -don't have to call free or delete. You may have to be a bit cautious about -delete if you're freeing other resources than RAM. See gc_cpp.h. You can -also keep coding as always with delete/free. That works too. If you want, -"include and tweak it's use a bit. - -== Symantec SPM == - -It has been a while since I tried the GC in SPM, but I think that the above -instructions should be sufficient to guide you through in SPM too. SPM -needs to know where the global data is. Use the files 'datastart.c' and -'dataend.c'. Put 'datastart.c' at the top of your project and 'dataend.c' -at the bottom of your project so that all data is surrounded. This is not -needed in Codewarrior because it provides intrinsic variables -__datastart__, __data_end__ that wraps all globals. - -== Source Changes (GC 4.12a2) == - -Very few. Just one tiny in the GC, not strictly needed. -- test_cpp.cc - made the first lines of main() look like this: - ------------ - int main( int argc, char* argv[] ) { - #endif - #if macintosh // MacOS - char* argv_[] = {"test_cpp","10"}; // doesn't - argv=argv_; // have a - argc = sizeof(argv_)/sizeof(argv_[0]); // commandline - #endif // - - int i, iters, n; - # ifndef __GNUC__ - alloc dummy_to_fool_the_compiler_into_doing_things_it_currently_cant_handle; - ------------ - -- config.h [now gcconfig.h] - __MWERKS__ does not have to mean MACOS. You can use Codewarrior to - build a Win32 or BeOS library and soon a Rhapsody library. You may - have to change that #if... - - - - It worked for me, hope it works for you. - - Lars Farm ----------------------------------------------------------------------------- - - -Patrick Beard's instructions (may be dated): - -v4.3 of the collector now runs under Symantec C++/THINK C v7.0.4, and -Metrowerks C/C++ v4.5 both 68K and PowerPC. Project files are provided -to build and test the collector under both development systems. - -Configuration -------------- - -To configure the collector, under both development systems, a prefix file -is used to set preprocessor directives. This file is called "MacOS_config.h". - -Testing -------- - -To test the collector (always a good idea), build one of the gctest projects, -gctest. (Symantec C++/THINK C), mw/gctest.68K, or mw/gctest.PPC. The -test will ask you how many times to run; 1 should be sufficient. - -Building --------- - -For your convenience project files for the major Macintosh development -systems are provided. - -For Symantec C++/THINK C, you must build the two projects gclib-1 and -gclib-2. It has to be split up because the collector has more than 32k -of static data and no library can have more than this in the Symantec -environment. (Future versions will probably fix this.) - -For Metrowerks C/C++ 4.5 you build gc.68K/PPC and the result will -be a library called gc.68K.lib/gc.PPC.lib. - -Using ------ - -Under Symantec C++/THINK C, you can just add the gclib-1 and gclib-2 -projects to your own project. Under Metrowerks, you add gc.68K.lib or -gc.PPC.lib and two additional files. You add the files called datastart.c -and dataend.c to your project, bracketing all files that use the collector. -See mw/gctest for an example. - -Include the projects/libraries you built above into your own project, -#include "gc.h", and call GC_malloc. You don't have to call GC_free. - -Patrick C. Beard diff -Nru ecl-16.1.2/src/bdwgc/doc/README.macros ecl-16.1.3+ds/src/bdwgc/doc/README.macros --- ecl-16.1.2/src/bdwgc/doc/README.macros 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/README.macros 1970-01-01 00:00:00.000000000 +0000 @@ -1,574 +0,0 @@ -The collector uses a large amount of conditional compilation in order to -deal with platform dependencies. This violates a number of known coding -standards. On the other hand, it seems to be the only practical way to -support this many platforms without excessive code duplication. - -A few guidelines have mostly been followed in order to keep this manageable: - -1) #if and #ifdef directives are properly indented whenever easily possible. -All known C compilers allow whitespace between the "#" and the "if" to make -this possible. ANSI C also allows white space before the "#", though we -avoid that. It has the known disadvantages that it differs from the normal -GNU conventions, and that it makes patches larger than otherwise necessary. -In my opinion, it's still well worth it, for the same reason that we indent -ordinary "if" statements. - -2) Whenever possible, tests are performed on the macros defined in gcconfig.h -instead of directly testing platform-specific predefined macros. This makes -it relatively easy to adapt to new compilers with a different set of -predefined macros. Currently these macros generally identify platforms -instead of features. In many cases, this is a mistake. - -Many of the tested configuration macros are at least somewhat defined in -either include/private/gcconfig.h or in Makefile.direct. Here is an attempt -at documenting these macros: (Thanks to Walter Bright for suggesting -this. This is a work in progress) - -MACRO EXPLANATION ------ ----------- - -GC_DEBUG Tested by gc.h. Causes all-upper-case macros to - expand to calls to debug versions of collector routines. - -GC_NAMESPACE Tested by gc_cpp.h. Causes gc_cpp symbols to be defined - in "boehmgc" namespace. - -GC_DEBUG_REPLACEMENT Tested by gc.h. Causes GC_MALLOC/REALLOC() to be - defined as GC_debug_malloc/realloc_replacement(). - -GC_NO_THREAD_REDIRECTS Tested by gc.h. Prevents redirection of thread - creation routines etc. to GC_ versions. Requires the - programmer to explicitly handle thread registration. - -GC_NO_THREAD_DECLS Tested by gc.h. MS Windows only. Do not declare - Windows thread creation routines and do not include windows.h. - -GC_UNDERSCORE_STDCALL Tested by gc.h. Explicitly prefix exported/imported - WINAPI (__stdcall) symbols with '_' (underscore). Could be - used with MinGW (for x86) compiler (in conjunction with - GC_DLL) to follow MS conventions for __stdcall symbols naming. - -_ENABLE_ARRAYNEW - #define'd by the Digital Mars C++ compiler when - operator new[] and delete[] are separately - overloadable. Used in gc_cpp.h. - -_DLL Tested by gc_config_macros.h. Defined by Visual C++ if runtime - dynamic libraries are in use. Used (only if none of GC_DLL, - GC_NOT_DLL, __GNUC__ are defined) to test whether - __declspec(dllimport) needs to be added to declarations - to support the case in which the collector is in a DLL. - -GC_DLL Defined by user if dynamic libraries are being built - or used. Also set by gc.h if _DLL is defined (except for - mingw) while GC_NOT_DLL and __GNUC__ are both undefined. - This is the macro that is tested internally to determine - whether the GC is in its own dynamic library. May need - to be set by clients before including gc.h. Note that - inside the GC implementation it indicates that the - collector is in its own dynamic library, should export - its symbols, etc. But in clients it indicates that the - GC resides in a different DLL, its entry points should - be referenced accordingly, and precautions may need to - be taken to properly deal with statically allocated - variables in the main program. Used for MS Windows. - Also used by GCC v4+ (only when the dynamic shared library - is being built) to hide internally used symbols. - -GC_NOT_DLL User-settable macro that overrides _DLL, e.g. if runtime - dynamic libraries are used, but the collector is in a static - library. Tested by gc_config_macros.h. - -GC_REQUIRE_WCSDUP Force GC to export GC_wcsdup() (the Unicode version - of GC_strdup); could be useful in the leak-finding mode. - - -These define arguments influence the collector configuration: - -FIND_LEAK Causes GC_find_leak to be initially set. This causes the - collector to assume that all inaccessible objects should have been - explicitly deallocated, and reports exceptions. Finalization and the test - program are not usable in this mode. - -GC_FINDLEAK_DELAY_FREE Turns on deferred freeing of objects in the - leak-finding mode letting the collector to detect alter-object-after-free - errors as well as detect leaked objects sooner (instead of only when program - terminates). Has no effect if SHORT_DBG_HDRS. - -GC_ABORT_ON_LEAK Causes the application to be terminated once leaked or - smashed (corrupted on use-after-free) objects are found (after printing the - information about that objects). - -SUNOS5SIGS Solaris-like signal handling. This is probably misnamed, - since it really doesn't guarantee much more than POSIX. Currently set only - for Solaris2.X, HPUX, and DRSNX. Should probably be set for some other - platforms. - -PCR Set if the collector is being built as part of the Xerox Portable - Common Runtime. - -USE_COMPILER_TLS Assume the existence of __thread-style thread-local storage. - Set automatically for thread-local allocation with the HP/UX vendor - compiler. Usable with gcc on sufficiently up-to-date ELF platforms. - -IMPORTANT: Any of the _THREADS options must normally also be defined in - the client before including gc.h. This redefines thread primitives to - invoke the GC_ versions instead. Alternatively, linker-based symbol - interception can be used on a few platforms. - -GC_THREADS Should set the appropriate one of the below macros, - except GC_WIN32_PTHREADS, which must be set explicitly. Tested by gc.h. - -GC_SOLARIS_THREADS Enables support for Solaris pthreads. - Must also define _REENTRANT. - -GC_IRIX_THREADS Enables support for Irix pthreads. See README.sgi. - -GC_HPUX_THREADS Enables support for HP/UX 11 pthreads. - Also requires _REENTRANT or _POSIX_C_SOURCE=199506L. See README.hp. - -GC_LINUX_THREADS Enables support for Xavier Leroy's Linux threads - or NPTL threads. See README.linux. _REENTRANT may also be required. - -GC_OSF1_THREADS Enables support for Tru64 pthreads. - -GC_FREEBSD_THREADS Enables support for FreeBSD pthreads. - Appeared to run into some underlying thread problems. - -GC_NETBSD_THREADS Enables support for NetBSD pthreads. - -GC_OPENBSD_THREADS Enables support for OpenBSD pthreads. - -GC_DARWIN_THREADS Enables support for Mac OS X pthreads. - -GC_AIX_THREADS Enables support for IBM AIX threads. - -GC_DGUX386_THREADS Enables support for DB/UX on I386 threads. - See README.DGUX386. (Probably has not been tested recently.) - -GC_WIN32_THREADS Enables support for Win32 threads. That makes sense - for this Makefile only under Cygwin. - -GC_WIN32_PTHREADS Enables support for pthreads-win32 (or other - non-Cygwin pthreads library for Windows). This cannot be enabled - automatically by GC_THREADS, which would assume Win32 native threads. - -PTW32_STATIC_LIB Causes the static version of the Mingw pthreads - library to be used. Requires GC_WIN32_PTHREADS. - -GC_PTHREADS_PARAMARK Causes pthread-based parallel mark implementation - to be used even if GC_WIN32_PTHREADS is undefined. (Useful for WinCE.) - -ALL_INTERIOR_POINTERS Allows all pointers to the interior of objects to be - recognized. (See gc_priv.h for consequences.) Alternatively, - GC_all_interior_pointers can be set at process initialization time. - -SMALL_CONFIG Tries to tune the collector for small heap sizes, - usually causing it to use less space in such situations. Incremental - collection no longer works in this case. Also, removes some - statistic-printing code. Turns off some optimization algorithms (like data - prefetching in the mark routine). - -GC_DISABLE_INCREMENTAL Turn off the incremental collection support. - -NO_INCREMENTAL Causes the gctest program to not invoke the incremental - collector. This has no impact on the generated library, only on the test - program. (This is often useful for debugging failures unrelated to - incremental GC.) - -LARGE_CONFIG Tunes the collector for unusually large heaps. - Necessary for heaps larger than about 4 GiB on most (64-bit) machines. - Recommended for heaps larger than about 500 MiB. Not recommended for - embedded systems. Could be used in conjunction with SMALL_CONFIG to - generate smaller code (by disabling incremental collection support, - statistic printing and some optimization algorithms). - -DONT_ADD_BYTE_AT_END Meaningful only with ALL_INTERIOR_POINTERS or - GC_all_interior_pointers = 1. Normally ALL_INTERIOR_POINTERS - causes all objects to be padded so that pointers just past the end of - an object can be recognized. This can be expensive. (The padding - is normally more than one byte due to alignment constraints.) - DONT_ADD_BYTE_AT_END disables the padding. - -NO_EXECUTE_PERMISSION May cause some or all of the heap to not - have execute permission, i.e. it may be impossible to execute - code from the heap. Currently this only affects the incremental - collector on UNIX machines. It may greatly improve its performance, - since this may avoid some expensive cache synchronization. Alternatively, - GC_set_pages_executable can be called at the process initialization time. - -GC_NO_OPERATOR_NEW_ARRAY Declares that the C++ compiler does not - support the new syntax "operator new[]" for allocating and deleting arrays. - See gc_cpp.h for details. No effect on the C part of the collector. - This is defined implicitly in a few environments. Must also be defined - by clients that use gc_cpp.h. - -REDIRECT_MALLOC= Causes malloc to be defined as alias for X. - Unless the following macros are defined, realloc is also redirected - to GC_realloc, and free is redirected to GC_free. - Calloc and str[n]dup are redefined in terms of the new malloc. X should - be either GC_malloc or GC_malloc_uncollectable, or - GC_debug_malloc_replacement. (The latter invokes GC_debug_malloc - with dummy source location information, but still results in - properly remembered call stacks on Linux/X86 and Solaris/SPARC. - It requires that the following two macros also be used.) - The former is occasionally useful for working around leaks in code - you don't want to (or can't) look at. It may not work for - existing code, but it often does. Neither works on all platforms, - since some ports use malloc or calloc to obtain system memory. - (Probably works for UNIX, and Win32.) If you build with DBG_HDRS_ALL, - you should only use GC_debug_malloc_replacement as a malloc - replacement. - -REDIRECT_REALLOC= Causes GC_realloc to be redirected to X. - The canonical use is REDIRECT_REALLOC=GC_debug_realloc_replacement, - together with REDIRECT_MALLOC=GC_debug_malloc_replacement to - generate leak reports with call stacks for both malloc and realloc. - This also requires REDIRECT_FREE. - -REDIRECT_FREE= Causes free to be redirected to X. The canonical use - is REDIRECT_FREE=GC_debug_free. - -IGNORE_FREE Turns calls to free into a no-op. Only useful with - REDIRECT_MALLOC. - -NO_DEBUGGING Removes GC_dump and the debugging routines it calls. - Reduces code size slightly at the expense of debuggability. - -GC_DUMP_REGULARLY Generate regular debugging dumps. - -DEBUG_THREADS Turn on printing additional thread-support debugging - information. - -GC_COLLECT_AT_MALLOC= Force garbage collection at every - GC_malloc_* call with the size greater than the specified value. - (Might be useful for application debugging or in find-leak mode.) - -JAVA_FINALIZATION Makes it somewhat safer to finalize objects out of - order by specifying a nonstandard finalization mark procedure (see - finalize.c). Objects reachable from finalizable objects will be marked - in a separate post-pass, and hence their memory won't be reclaimed. - Not recommended unless you are implementing a language that specifies - these semantics. Since 5.0, determines only the initial value - of GC_java_finalization variable. - -FINALIZE_ON_DEMAND Causes finalizers to be run only in response - to explicit GC_invoke_finalizers() calls. - In 5.0 this became runtime adjustable, and this only determines the - initial value of GC_finalize_on_demand. - -GC_NO_FINALIZATION Exclude finalization support (for smaller code size) - -ATOMIC_UNCOLLECTABLE Includes code for GC_malloc_atomic_uncollectable. - This is useful if either the vendor malloc implementation is poor, - or if REDIRECT_MALLOC is used. - -MARK_BIT_PER_GRANULE Requests that a mark bit (or often byte) - be allocated for each allocation granule, as opposed to each object. - This often improves speed, possibly at some cost in space and/or - cache footprint. Normally it is best to let this decision be - made automatically depending on platform. - -MARK_BIT_PER_OBJ Requests that a mark bit be allocated for each - object instead of allocation granule. The opposite of - MARK_BIT_PER_GRANULE. - -HBLKSIZE= Explicitly sets the heap block size (where ddd is a power of - 2 between 512 and 16384). Each heap block is devoted to a single size and - kind of object. For the incremental collector it makes sense to match - the most likely page size. Otherwise large values result in more - fragmentation, but generally better performance for large heaps. - -USE_MMAP Use MMAP instead of sbrk to get new memory. - Works for Linux, FreeBSD, Cygwin, Solaris and Irix. - -USE_MUNMAP Causes memory to be returned to the OS under the right - circumstances. This currently disables VM-based incremental collection - (except for Win32 with GetWriteWatch() available). - Works under some Unix, Linux and Windows versions. - Requires USE_MMAP except for Windows. - -USE_WINALLOC (Cygwin only) Use Win32 VirtualAlloc (instead of sbrk or mmap) - to get new memory. Useful if memory unmapping (USE_MUNMAP) is enabled. - -MUNMAP_THRESHOLD= Set the desired memory blocks unmapping - threshold (the number of sequential garbage collections for which - a candidate block for unmapping should remain free). - -GC_FORCE_UNMAP_ON_GCOLLECT Set "unmap as much as possible on explicit GC" - mode on by default. The mode could be changed at run-time. Has no effect - unless unmapping is turned on. Has no effect on implicitly-initiated - garbage collections. - -PRINT_BLACK_LIST Whenever a black list entry is added, i.e. whenever - the garbage collector detects a value that looks almost, but not quite, - like a pointer, print both the address containing the value, and the - value of the near-bogus-pointer. Can be used to identify regions of - memory that are likely to contribute misidentified pointers. - -KEEP_BACK_PTRS Add code to save back pointers in debugging headers - for objects allocated with the debugging allocator. If all objects - through GC_MALLOC with GC_DEBUG defined, this allows the client - to determine how particular or randomly chosen objects are reachable - for debugging/profiling purposes. The gc_backptr.h interface is - implemented only if this is defined. - -GC_ASSERTIONS Enable some internal GC assertion checking. Currently - this facility is only used in a few places. It is intended primarily - for debugging of the garbage collector itself, but could also... - -DBG_HDRS_ALL Make sure that all objects have debug headers. Increases - the reliability (from 99.9999% to 100% mod. bugs) of some of the debugging - code (especially KEEP_BACK_PTRS). Makes SHORT_DBG_HDRS possible. - Assumes that all client allocation is done through debugging allocators. - -SHORT_DBG_HDRS Assume that all objects have debug headers. Shorten - the headers to minimize object size, at the expense of checking for - writes past the end of an object. This is intended for environments - in which most client code is written in a "safe" language, such as - Scheme or Java. Assumes that all client allocation is done using - the GC_debug_ functions, or through the macros that expand to these, - or by redirecting malloc to GC_debug_malloc_replacement. - (Also eliminates the field for the requested object size.) - Occasionally could be useful for debugging of client code. Slows down the - collector somewhat, but not drastically. - -SAVE_CALL_COUNT= Set the number of call frames saved with objects - allocated through the debugging interface. Affects the amount of - information generated in leak reports. Only matters on platforms - on which we can quickly generate call stacks, currently Linux/(X86 & SPARC) - and Solaris/SPARC and platforms that provide execinfo.h. - Default is zero. On X86, client - code should NOT be compiled with -fomit-frame-pointer. - -SAVE_CALL_NARGS= Set the number of functions arguments to be saved - with each call frame. Default is zero. Ignored if we don't know how to - retrieve arguments on the platform. - -CHECKSUMS Reports on erroneously clear dirty bits, and unexpectedly - altered stubborn objects, at substantial performance cost. Use only for - debugging of the incremental collector. Not compatible with USE_MUNMAP - or threads. - -GC_GCJ_SUPPORT Includes support for gcj (and possibly other systems - that include a pointer to a type descriptor in each allocated object). - Building this way requires an ANSI C compiler. - -USE_I686_PREFETCH Causes the collector to issue Pentium III style - prefetch instructions. No effect except on X86 Linux platforms. - Assumes a very recent gcc-compatible compiler and assembler. - (Gas prefetcht0 support was added around May 1999.) - Empirically the code appears to still run correctly on Pentium II - processors, though with no performance benefit. May not run on other - X86 processors? In some cases this improves performance by - 15% or so. - -USE_3DNOW_PREFETCH Causes the collector to issue AMD 3DNow style - prefetch instructions. Same restrictions as USE_I686_PREFETCH. - Minimally tested. Didn't appear to be an obvious win on a K6-2/500. - -USE_PPC_PREFETCH Causes the collector to issue PowerPC style - prefetch instructions. No effect except on PowerPC OS X platforms. - Performance impact untested. - -GC_USE_LD_WRAP In combination with the old flags listed in README.linux - causes the collector some system and pthread calls in a more transparent - fashion than the usual macro-based approach. Requires GNU ld, and - currently probably works only with Linux. - -GC_USE_DLOPEN_WRAP Causes the collector to redefine malloc and - intercepted pthread routines with their real names, and causes it to use - dlopen and dlsym to refer to the original versions. This makes it possible - to build an LD_PRELOADable malloc replacement library. - -THREAD_LOCAL_ALLOC Defines GC_malloc(), GC_malloc_atomic() and - GC_gcj_malloc() to use a per-thread set of free-lists. These then allocate - in a way that usually does not involve acquisition of a global lock. - Recommended for multiprocessors. Requires explicit GC_INIT() call, unless - REDIRECT_MALLOC is defined and GC_malloc is used first. - -USE_COMPILER_TLS Causes thread local allocation to use - the compiler-supported "__thread" thread-local variables. This is the - default in HP/UX. It may help performance on recent Linux installations. - (It failed for me on RedHat 8, but appears to work on RedHat 9.) - -PARALLEL_MARK Allows the marker to run in multiple threads. Recommended - for multiprocessors. - -GC_ALWAYS_MULTITHREADED Force multi-threaded mode at GC initialization. - (Turns GC_allow_register_threads into a no-op routine.) - -GC_WINMAIN_REDIRECT (Win32 only) Redirect (rename) an application - WinMain to GC_WinMain; implement the "real" WinMain which starts a new - thread to call GC_WinMain after initializing the GC. Useful for WinCE. - Incompatible with GC_DLL. - -GC_REGISTER_MEM_PRIVATE (Win32 only) Force to register MEM_PRIVATE R/W - sections as data roots. Might be needed for some WinCE 6.0+ custom builds. - (May result in numerous "Data Abort" messages logged to WinCE debugging - console.) Incompatible with GCC toolchains for WinCE. - -NO_GETENV Prevents the collector from looking at environment variables. - These may otherwise alter its configuration, or turn off GC altogether. - I don't know of a reason to disable this, except possibly if the resulting - process runs as a privileged user. (This is on by default for WinCE.) - -EMPTY_GETENV_RESULTS Define to workaround a reputed Wine bug in getenv - (getenv() may return an empty string instead of NULL for a missing entry). - -GC_READ_ENV_FILE (Win32 only) Read environment variables from the GC "env" - file (named as the program name plus ".gc.env" extension). Useful for WinCE - targets (which have no getenv()). In the file, every variable is specified - in a separate line and the format is as "=" (without spaces). - A comment line may start with any character except for the Latin letters, - the digits and the underscore ('_'). The file encoding is Latin-1. - -USE_GLOBAL_ALLOC (Win32 only) Use GlobalAlloc() instead of VirtualAlloc() - to allocate the heap. May be needed to work around a Windows NT/2000 issue. - Incompatible with USE_MUNMAP. See README.win32 for details. - -MAKE_BACK_GRAPH Enable GC_PRINT_BACK_HEIGHT environment variable. - See README.environment for details. Experimental. Limited platform - support. Implies DBG_HDRS_ALL. All allocation should be done using - the debug interface. - -GC_PRINT_BACK_HEIGHT Permanently turn on back-height printing mode - (useful when NO_GETENV). See the similar environment variable description - in README.environment. Requires MAKE_BACK_GRAPH defined. - -STUBBORN_ALLOC Allows allocation of "hard to change" objects, and thus - makes incremental collection easier. Was enabled by default until 6.0. - Rarely used, to my knowledge. - -HANDLE_FORK (Unix and Cygwin only) Attempt by default to make GC_malloc() - work in a child process fork()'ed from a multi-threaded parent. Not fully - POSIX-compliant and could be disabled at runtime (before GC_INIT). - -TEST_WITH_SYSTEM_MALLOC Causes gctest to allocate (and leak) large - chunks of memory with the standard system malloc. This will cause the root - set and collected heap to grow significantly if malloc'ed memory is somehow - getting traced by the collector. This has no impact on the generated - library; it only affects the test. - -POINTER_MASK=<0x...> Causes candidate pointers to be AND'ed with the given - mask before being considered. If either this or the following macro is - defined, it will be assumed that all pointers stored in the heap need to be - processed this way. Stack and register pointers will be considered both - with and without processing. These macros are normally needed only to - support systems that use high-order pointer tags. EXPERIMENTAL. - -POINTER_SHIFT= Causes the collector to left shift candidate pointers - by the indicated amount before trying to interpret them. Applied after - POINTER_MASK. EXPERIMENTAL. See also the preceding macro. - -ENABLE_TRACE Enables the GC_TRACE=addr environment setting to do its job. - By default this is not supported in order to keep the marker as fast as - possible. - -DARWIN_DONT_PARSE_STACK Causes the Darwin port to discover thread - stack bounds in the same way as other pthread ports, without trying to - walk the frames on the stack. This is recommended only as a fall-back for - applications that don't support proper stack unwinding. - -GC_NO_THREADS_DISCOVERY (Darwin and Win32+DLL only) Exclude DllMain-based - (on Windows) and task-threads-based (on Darwin) thread registration support. - -GC_INSIDE_DLL (Win32 only) Enable DllMain-based approach of threads - registering even in case GC_DLL is not defined. - -GC_DISCOVER_TASK_THREADS (Darwin and Win32+DLL only) Compile the collector - with the implicitly turned on task-threads-based (on Darwin) or - DllMain-based (on Windows) approach of threads registering. Only for - compatibility and for the case when it is not possible to call - GC_use_threads_discovery() early (before other GC calls). - -USE_PROC_FOR_LIBRARIES Causes the Linux collector to treat writable - memory mappings (as reported by /proc) as roots, if it doesn't have - other information about them. It no longer traverses dynamic loader - data structures to find dynamic library static data. This may be - required for applications that store pointers in mmapped segments without - informing the collector. But it typically performs poorly, especially - since it will scan inactive but cached NPTL thread stacks completely. - -IGNORE_DYNAMIC_LOADING Don't define DYNAMIC_LOADING even if supported by the - platform (that is, build the collector with disabled tracing of dynamic - library data roots). - -NO_PROC_STAT Causes the collector to avoid relying on Linux - "/proc/self/stat". - -NO_GETCONTEXT Causes the collector to not assume the existence of the - getcontext() function on linux-like platforms. This currently happens - implicitly on Darwin, Hurd, or ARM or MIPS hardware. It is explicitly - needed for some old versions of FreeBSD. - -STATIC=static Causes various GC_ symbols that could logically be declared - static to be declared (this is the default if NO_DEBUGGING is specified). - Reduces the number of visible symbols (letting the optimizer do its work - better), which is probably cleaner, but may make some kinds of debugging - and profiling harder. - -GC_DLL Build dynamic-link library (or dynamic shared object). For Unix this - causes the exported symbols to have 'default' visibility (ignored unless - GCC v4+) and the internal ones to have 'hidden' visibility. - -DONT_USE_USER32_DLL (Win32 only) Don't use "user32" DLL import library - (containing MessageBox() entry); useful for a static GC library. - -GC_PREFER_MPROTECT_VDB Choose MPROTECT_VDB manually in case of multiple - virtual dirty bit strategies are implemented (at present useful on Win32 and - Solaris to force MPROTECT_VDB strategy instead of the default GWW_VDB or - PROC_VDB ones). - -GC_IGNORE_GCJ_INFO Disable GCJ-style type information (useful for - debugging on WinCE). - -GC_PRINT_VERBOSE_STATS Permanently turn on verbose logging (useful for - debugging and profiling on WinCE). - -GC_ONLY_LOG_TO_FILE Don't redirect GC stdout and stderr to the log file - specified by GC_LOG_FILE environment variable. Has effect only when the - variable is set (to anything other than "0"). - -GC_ANDROID_LOG (Android only) Output error/debug information to Android log. - -GC_DONT_EXPAND Don't expand the heap unless explicitly requested or forced to. - -GC_USE_ENTIRE_HEAP Causes the non-incremental collector to use the - entire heap before collecting. This sometimes results in more large block - fragmentation, since very large blocks will tend to get broken up during - each GC cycle. It is likely to result in a larger working set, but lower - collection frequencies, and hence fewer instructions executed in the - collector. This macro controls only the default GC_use_entire_heap value. - -GC_INITIAL_HEAP_SIZE= Set the desired default initial heap size - in bytes. - -GC_FREE_SPACE_DIVISOR= Set alternate default GC_free_space_divisor - value. - -GC_TIME_LIMIT= Set alternate default GC_time_limit value - (setting this to GC_TIME_UNLIMITED will essentially disable incremental - collection while leaving generational collection enabled). - -GC_FULL_FREQ= Set alternate default number of partial collections - between full collections (matters only if incremental collection is on). - -NO_CANCEL_SAFE (Posix platforms with threads only) Don't bother trying - to make the collector safe for thread cancellation; cancellation is not - used. (Note that if cancellation is used anyway, threads may end up - getting cancelled in unexpected places.) Even without this option, - PTHREAD_CANCEL_ASYNCHRONOUS is never safe with the collector. (We could - argue about its safety without the collector.) - -UNICODE (Win32 only) Use the Unicode variant ('W') of the Win32 API instead - of ANSI/ASCII one ('A'). Useful for WinCE. - -PLATFORM_ANDROID (or __ANDROID__) Compile for Android NDK platform. - -SN_TARGET_PS3 Compile for Sony PS/3. - -USE_GET_STACKBASE_FOR_MAIN (Linux only) Use pthread_attr_getstack() instead - of __libc_stack_end (or instead of any hard-coded value) for getting the - primordial thread stack base (useful if the client modifies the program's - address space). diff -Nru ecl-16.1.2/src/bdwgc/doc/README.OS2 ecl-16.1.3+ds/src/bdwgc/doc/README.OS2 --- ecl-16.1.2/src/bdwgc/doc/README.OS2 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/README.OS2 1970-01-01 00:00:00.000000000 +0000 @@ -1,6 +0,0 @@ -The code assumes static linking, and a single thread. The editor de has -not been ported. The cord test program has. The supplied OS2_MAKEFILE -assumes the IBM C Set/2 environment, but the code shouldn't. - -Since we haven't figured out hoe to do perform partial links or to build static -libraries, clients currently need to link against a long list of executables. diff -Nru ecl-16.1.2/src/bdwgc/doc/README.rs6000 ecl-16.1.3+ds/src/bdwgc/doc/README.rs6000 --- ecl-16.1.2/src/bdwgc/doc/README.rs6000 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/README.rs6000 1970-01-01 00:00:00.000000000 +0000 @@ -1,9 +0,0 @@ -We have so far failed to find a good way to determine the stack base. -It is highly recommended that GC_stackbottom be set explicitly on program -startup. The supplied value sometimes causes failure under AIX 4.1, though -it appears to work under 3.X. HEURISTIC2 seems to work under 4.1, but -involves a substantial performance penalty, and will fail if there is -no limit on stack size. - -There is no thread support. (I assume recent versions of AIX provide -pthreads? I no longer have access to a machine ...) diff -Nru ecl-16.1.2/src/bdwgc/doc/README.sgi ecl-16.1.3+ds/src/bdwgc/doc/README.sgi --- ecl-16.1.2/src/bdwgc/doc/README.sgi 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/README.sgi 1970-01-01 00:00:00.000000000 +0000 @@ -1,40 +0,0 @@ -Performance of the incremental collector can be greatly enhanced with --DNO_EXECUTE_PERMISSION. - -The collector should run with all of the -32, -n32 and -64 ABIs. Remember to -define the AS macro in the Makefile to be "as -64", or "as -n32". - -If you use -DREDIRECT_MALLOC=GC_malloc with C++ code, your code should make -at least one explicit call to malloc instead of new to ensure that the proper -version of malloc is linked in. - -Sproc threads are not supported in this version, though there may exist other -ports. - -Pthreads support is provided. This requires that: - -1) You compile the collector with -DGC_IRIX_THREADS specified in the Makefile. - -2) You have the latest pthreads patches installed. - -(Though the collector makes only documented pthread calls, -it relies on signal/threads interactions working just right in ways -that are not required by the standard. It is unlikely that this code -will run on other pthreads platforms. But please tell me if it does.) - -3) Every file that makes thread calls should define IRIX_THREADS and then -include gc.h. Gc.h redefines some of the pthread primitives as macros which -also provide the collector with information it requires. - -4) pthread_cond_wait and pthread_cond_timed_wait should be prepared for -premature wakeups. (I believe the pthreads and realted standards require this -anyway. Irix pthreads often terminate a wait if a signal arrives. -The garbage collector uses signals to stop threads.) - -5) It is expensive to stop a thread waiting in IO at the time the request is -initiated. Applications with many such threads may not exhibit acceptable -performance with the collector. (Increasing the heap size may help.) - -6) The collector should not be compiled with -DREDIRECT_MALLOC. This -confuses some library calls made by the pthreads implementation, which -expect the standard malloc. diff -Nru ecl-16.1.2/src/bdwgc/doc/README.solaris2 ecl-16.1.3+ds/src/bdwgc/doc/README.solaris2 --- ecl-16.1.2/src/bdwgc/doc/README.solaris2 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/README.solaris2 1970-01-01 00:00:00.000000000 +0000 @@ -1,72 +0,0 @@ -The collector supports both incremental collection and threads under -Solaris 2. The incremental collector normally retrieves page dirty information -through the appropriate /proc calls. But it can also be configured -(by defining MPROTECT_VDB instead of PROC_VDB in gcconfig.h) to use mprotect -and signals. This may result in shorter pause times, but it is no longer -safe to issue arbitrary system calls that write to the heap. - -Under other UNIX versions, -the collector normally obtains memory through sbrk. There is some reason -to expect that this is not safe if the client program also calls the system -malloc, or especially realloc. The sbrk man page strongly suggests this is -not safe: "Many library routines use malloc() internally, so use brk() -and sbrk() only when you know that malloc() definitely will not be used by -any library routine." This doesn't make a lot of sense to me, since there -seems to be no documentation as to which routines can transitively call malloc. -Nonetheless, under Solaris2, the collector now allocates -memory using mmap by default. (It defines USE_MMAP in gcconfig.h.) -You may want to reverse this decisions if you use -DREDIRECT_MALLOC=... - -Note: -Before you run "make check", you need to set your LD_LIBRARY_PATH correctly -(e.g., to "/usr/local/lib") so that tests can find the shared library -libgcc_s.so.1. Alternatively, you can configure with --disable-shared. - -SOLARIS THREADS: - -Threads support is enabled by configure "--enable-threads=posix" option. -(In case of GCC compiler, multi-threading support is on by default.) -This causes the collector to be compiled with -D GC_THREADS (or --D GC_SOLARIS_THREADS) ensuring thread safety. -This assumes use of the pthread_ interface. Old style Solaris threads -are no longer supported. -Thread-local allocation is now on by default. Parallel marking is on by -default starting from GC v7.3 but it could be enabled or disabled manually -by the corresponding "--enable/disable-parallel-mark" options. - -It is also essential that gc.h be included in files that call pthread_create, -pthread_join, pthread_detach, or dlopen. gc.h macro defines these to also do -GC bookkeeping, etc. gc.h must be included with one or both of these macros -defined, otherwise these replacements are not visible. A collector built in -this way way only be used by programs that are linked with the threads library. - -Since 5.0 alpha5, dlopen disables collection temporarily, -unless USE_PROC_FOR_LIBRARIES is defined. In some unlikely cases, this -can result in unpleasant heap growth. But it seems better than the -race/deadlock issues we had before. - -If threads are used on an X86 processor with malloc redirected to -GC_malloc, it is necessary to call GC_INIT explicitly before forking the -first thread. (This avoids a deadlock arising from calling GC_thr_init -with the allocation lock held.) - -It appears that there is a problem in using gc_cpp.h in conjunction with -Solaris threads and Sun's C++ runtime. Apparently the overloaded new operator -is invoked by some iostream initialization code before threads are correctly -initialized. As a result, call to thr_self() in garbage collector -initialization SEGV faults. Currently the only known workaround is to not -invoke the garbage collector from a user defined global operator new, or to -have it invoke the garbage-collector's allocators only after main has started. -(Note that the latter requires a moderately expensive test in operator -delete.) - -I encountered "symbol : offet .... is non-aligned" errors. These -appear to be traceable to the use of the GNU assembler with the Sun linker. -The former appears to generate a relocation not understood by the latter. -The fix appears to be to use a consistent tool chain. (As a non-Solaris-expert -my solution involved hacking the libtool script, but I'm sure you can -do something less ugly.) - -Hans-J. Boehm -(The above contains my personal opinions, which are probably not shared -by anyone else.) diff -Nru ecl-16.1.2/src/bdwgc/doc/README.symbian ecl-16.1.3+ds/src/bdwgc/doc/README.symbian --- ecl-16.1.2/src/bdwgc/doc/README.symbian 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/README.symbian 1970-01-01 00:00:00.000000000 +0000 @@ -1,13 +0,0 @@ -Instructions for Symbian: -1. base version: libgc 7.1 -2. Build: use libgc.mmp -3. Limitations -3.1.No multi-threaded support - -3.2. Be careful with limitation that emulator introduces: Static roots are not -dynamically accessible (there are Symbian APIs for this purpose but are just -stubs, returning irrelevant values). -Consequently, on emulator, you can only use dlls or exe, and retrieve static -roots by calling global_init_static_root per dll (or exe). -On target, only libs are supported, because static roots are retrieved by -linker flags, by calling global_init_static_root in main exe. diff -Nru ecl-16.1.2/src/bdwgc/doc/README.uts ecl-16.1.3+ds/src/bdwgc/doc/README.uts --- ecl-16.1.2/src/bdwgc/doc/README.uts 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/README.uts 1970-01-01 00:00:00.000000000 +0000 @@ -1,2 +0,0 @@ -Alistair Crooks supplied the port. He used Lexa C version 2.1.3 with --Xa to compile. diff -Nru ecl-16.1.2/src/bdwgc/doc/README.win32 ecl-16.1.3+ds/src/bdwgc/doc/README.win32 --- ecl-16.1.2/src/bdwgc/doc/README.win32 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/README.win32 1970-01-01 00:00:00.000000000 +0000 @@ -1,223 +0,0 @@ -The collector has at various times been compiled under Windows 95 & later, NT, -and XP, with the original Microsoft SDK, with Visual C++ 2.0, 4.0, and 6, with -the GNU win32 tools, with Borland 4.5, with Watcom C, and recently -with the Digital Mars compiler. It is likely that some of these have been -broken in the meantime. Patches are appreciated. - -For historical reasons, -the collector test program "gctest" is linked as a GUI application, -but does not open any windows. Its output normally appears in the file -"gctest.gc.log". It may be started from the file manager. The hour glass -cursor may appear as long as it's running. If it is started from the -command line, it will usually run in the background. Wait a few -minutes (a few seconds on a modern machine) before you check the output. -You should see either a failure indication or a "Collector appears to -work" message. - -The cord test program has not been ported (but should port -easily). A toy editor (cord/de.exe) based on cords (heavyweight -strings represented as trees) has been ported and is included. -It runs fine under either win32 or win32S. It serves as an example -of a true Windows application, except that it was written by a -nonexpert Windows programmer. (There are some peculiarities -in the way files are displayed. The is displayed explicitly -for standard DOS text files. As in the UNIX version, control -characters are displayed explicitly, but in this case as red text. -This may be suboptimal for some tastes and/or sets of default -window colors.) - -In general -DREDIRECT_MALLOC is unlikely to work unless the -application is completely statically linked. - -The collector normally allocates memory from the OS with VirtualAlloc. -This appears to cause problems under Windows NT and Windows 2000 (but -not Windows 95/98) if the memory is later passed to CreateDIBitmap. -To work around this problem, build the collector with -DUSE_GLOBAL_ALLOC. -This is currently incompatible with -DUSE_MUNMAP. (Thanks to Jonathan -Clark for tracking this down. There's some chance this may be fixed -in 6.1alpha4, since we now separate heap sections with an unused page.) - -[Threads and incremental collection are discussed near the end, below.] - -Microsoft Tools ---------------- -For Microsoft development tools, rename NT_MAKEFILE as -MAKEFILE. (Make sure that the CPU environment variable is defined -to be i386.) In order to use the gc_cpp.h C++ interface, all -client code should include gc_cpp.h. - -For historical reasons, -the collector test program "gctest" is linked as a GUI application, -but does not open any windows. Its output appears in the file -"gctest.gc.log". It may be started from the file manager. The hour glass -cursor may appear as long as it's running. If it is started from the -command line, it will usually run in the background. Wait a few -minutes (a few seconds on a modern machine) before you check the output. -You should see either a failure indication or a "Collector appears to -work" message. - -If you would prefer a VC++ .NET project file, ask Hans Boehm. One has -been contributed, but it seems to contain some absolute paths etc., so -it can presumably only be a starting point, and is not in the standard -distribution. It is unclear (to me, Hans Boehm) whether it is feasible to -change that. - -Clients may need to define GC_NOT_DLL before including gc.h, if the -collector was built as a static library (as it normally is in the -absence of thread support). - -GNU Tools ---------- -The collector should be buildable under Cygwin with the -"./configure; make check" machinery. - -MinGW builds (including for x86_64) are available via cross-compilation, e.g. -"./configure --host=i686-pc-mingw32; make check" - -To build the collector as a DLL, pass "--enable-shared --disable-static" to -configure (this will instruct make compile with -D GC_DLL). - -Parallel marker could be enabled via "--enable-parallel-mark". -Memory unmapping could be enabled via "--enable-munmap". - -Borland Tools -------------- -[Rarely tested.] -For Borland tools, use BCC_MAKEFILE. Note that -Borland's compiler defaults to 1 byte alignment in structures (-a1), -whereas Visual C++ appears to default to 8 byte alignment (/Zp8). -The garbage collector in its default configuration EXPECTS AT -LEAST 4 BYTE ALIGNMENT. Thus the BORLAND DEFAULT MUST -BE OVERRIDDEN. (In my opinion, it should usually be anyway. -I expect that -a1 introduces major performance penalties on a -486 or Pentium.) Note that this changes structure layouts. (As a last -resort, gcconfig.h can be changed to allow 1 byte alignment. But -this has significant negative performance implications.) -The Makefile is set up to assume Borland 4.5. If you have another -version, change the line near the top. By default, it does not -require the assembler. If you do have the assembler, I recommend -removing the -DUSE_GENERIC. - -Digital Mars compiler ---------------------- - -Same as MS Visual C++ but might require --DAO_OLD_STYLE_INTERLOCKED_COMPARE_EXCHANGE option to compile with the -parallel marker enabled. - -Watcom compiler ---------------- - -Ivan V. Demakov's README for the Watcom port: - -The collector has been compiled with Watcom C 10.6 and 11.0. -It runs under win32, win32s, and even under msdos with dos4gw -dos-extender. It should also run under OS/2, though this isn't -tested. Under win32 the collector can be built either as dll -or as static library. - -Note that all compilations were done under Windows 95 or NT. -For unknown reason compiling under Windows 3.11 for NT (one -attempt has been made) leads to broken executables. - -Incremental collection is not supported. - -cord is not ported. - -Before compiling you may need to edit WCC_MAKEFILE to set target -platform, library type (dynamic or static), calling conventions, and -optimization options. - -To compile the collector and testing programs use the command: - wmake -f WCC_MAKEFILE - -All programs using gc should be compiled with 4-byte alignment. -For further explanations on this see comments about Borland. - -If the gc is compiled as dll, the macro "GC_DLL" should be defined before -including "gc.h" (for example, with -DGC_DLL compiler option). It's -important, otherwise resulting programs will not run. - - -Special note for OpenWatcom users: the C (unlike the C++) compiler (of the -latest stable release, not sure for older ones) doesn't force pointer global -variables (i.e. not struct fields, not sure for locals) to be aligned unless -optimizing for speed (e.g., "-ot" option is set); the "-zp" option (or align -pragma) only controls alignment for structs; I don't know whether it's a bug or -a feature (see an old report of same kind - -http://bugzilla.openwatcom.org/show_bug.cgi?id=664), so You are warned. - - -Incremental Collection ----------------------- -There is some support for incremental collection. By default, the -collector chooses between explicit page protection, and GetWriteWatch-based -write tracking automatically, depending on the platform. - -The former is slow and interacts poorly with a debugger. -Pages are protected. Protection faults are caught by a handler -installed at the bottom of the handler -stack. Whenever possible, I recommend adding a call to -GC_enable_incremental at the last possible moment, after most -debugging is complete. No system -calls are wrapped by the collector itself. It may be necessary -to wrap ReadFile calls that use a buffer in the heap, so that the -call does not encounter a protection fault while it's running. -(As usual, none of this is an issue unless GC_enable_incremental -is called.) - -Note that incremental collection is disabled with -DSMALL_CONFIG. - -Threads -------- - -This version of the collector by default handles threads similarly -to other platforms. James Clark's code which tracks threads attached -to the collector DLL still exists, but requires that both -- the collector is built in a DLL with GC_DLL defined, and -- GC_use_threads_discovery() is called before GC initialization, which - in turn must happen before creating additional threads. -We generally recommend avoiding this if possible, since it seems to -be less than 100% reliable. - -Use gc.mak (a.k.a NT_THREADS_MAKEFILE) instead of NT_MAKEFILE -to build a version that supports both kinds of thread tracking. -To build the garbage collector -test with VC++ from the command line, use - -nmake /F ".\gc.mak" CFG="gctest - Win32 Release" - -This requires that the subdirectory gctest\Release exist. -The test program and DLL will reside in the Release directory. - -This version currently supports incremental collection only if it is -enabled before any additional threads are created. - -Since 6.3alpha2, threads are also better supported in static library builds -with Microsoft tools (use NT_STATIC_THREADS_MAKEFILE) and with the GNU -tools. The collector must be built with GC_THREADS defined. -(NT_STATIC_THREADS_MAKEFILE does this implicitly. Under Cygwin, -./configure --enable-threads=posix should be used.) - -For the normal, non-dll-based thread tracking to work properly, -threads should be created with GC_CreateThread or GC_beginthreadex, -and exit normally or call GC_endthreadex or GC_ExitThread. (For -Cygwin, use standard pthread calls instead.) As in the pthread -case, including gc.h will redefine CreateThread, _beginthreadex, -_endthreadex, and ExitThread to call the GC_ versions instead. - -Note that, as usual, GC_CreateThread tends to introduce resource leaks -that are avoided by GC_beginthreadex. There is currently no equivalent of -_beginthread, and it should not be used. - -GC_INIT should be called from the main executable before other GC calls. - -We strongly advise against using the TerminateThread() win32 API call, -especially with the garbage collector. Any use is likely to provoke a -crash in the GC, since it makes it impossible for the collector to -correctly track threads. - -To build the collector for MinGW pthreads-win32 (or other non-Cygwin pthreads -implementation for Windows), use Makefile.direct and explicitly set -GC_WIN32_PTHREADS (or pass --enable-threads=pthreads to configure). -Use -DPTW32_STATIC_LIB for the static threads library. diff -Nru ecl-16.1.2/src/bdwgc/doc/README.win64 ecl-16.1.3+ds/src/bdwgc/doc/README.win64 --- ecl-16.1.2/src/bdwgc/doc/README.win64 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/README.win64 1970-01-01 00:00:00.000000000 +0000 @@ -1,26 +0,0 @@ -64-bit Windows on AMD64/Intel EM64T is somewhat supported in the 7.0 -and later release. A collector can be built with Microsoft Visual C++ 2005 -or with mingw-w64 gcc. -More testing would clearly be helpful. - -NT_X64_STATIC_THREADS_MAKEFILE has been used in -this environment. Copy this file to MAKEFILE, and then type "nmake" -in a Visual C++ command line window to build the static library -and the usual test programs. To verify that the collector is -at least somewhat functional, run gctest.exe. This should create -gctest.gc.log after a few seconds. - -This process is completely analogous to NT_STATIC_THREADS_MAKEFILE -for the 32-bit version. - -A similar procedure using NT_X64_THREADS_MAKEFILE should be usable to -build the dynamic library. Test_cpp.exe did not seem to run correctly this -way. It seems that we're getting the wrong instances of operator new/delete -in some cases. The C tests seemed OK. - -Note that currently a few warnings are still generated by default, -and a number of others have been explicitly turned off in the makefile. - -VC++ note: to suppress warnings use -D_CRT_SECURE_NO_DEPRECATE. - -gcc note: -fno-strict-aliasing should be used if optimizing. diff -Nru ecl-16.1.2/src/bdwgc/doc/scale.html ecl-16.1.3+ds/src/bdwgc/doc/scale.html --- ecl-16.1.2/src/bdwgc/doc/scale.html 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/scale.html 1970-01-01 00:00:00.000000000 +0000 @@ -1,211 +0,0 @@ - - -Garbage collector scalability - - -

    Garbage collector scalability

    -In its default configuration, the Boehm-Demers-Weiser garbage collector -is not thread-safe. It can be made thread-safe for a number of environments -by building the collector with the appropriate --DXXX-THREADS compilation -flag. This has primarily two effects: -
      -
    1. It causes the garbage collector to stop all other threads when -it needs to see a consistent memory state. -
    2. It causes the collector to acquire a lock around essentially all -allocation and garbage collection activity. -
    -Since a single lock is used for all allocation-related activity, only one -thread can be allocating or collecting at one point. This inherently -limits performance of multi-threaded applications on multiprocessors. -

    -On most platforms, the allocator/collector lock is implemented as a -spin lock with exponential back-off. Longer wait times are implemented -by yielding and/or sleeping. If a collection is in progress, the pure -spinning stage is skipped. This has the advantage that uncontested and -thus most uniprocessor lock acquisitions are very cheap. It has the -disadvantage that the application may sleep for small periods of time -even when there is work to be done. And threads may be unnecessarily -woken up for short periods. Nonetheless, this scheme empirically -outperforms native queue-based mutual exclusion implementations in most -cases, sometimes drastically so. -

    Options for enhanced scalability

    -Version 6.0 of the collector adds two facilities to enhance collector -scalability on multiprocessors. As of 6.0alpha1, these are supported -only under Linux on X86 and IA64 processors, though ports to other -otherwise supported Pthreads platforms should be straightforward. -They are intended to be used together. -
      -
    • -Building the collector with -DPARALLEL_MARK allows the collector to -run the mark phase in parallel in multiple threads, and thus on multiple -processors. The mark phase typically consumes the large majority of the -collection time. Thus this largely parallelizes the garbage collector -itself, though not the allocation process. Currently the marking is -performed by the thread that triggered the collection, together with -N-1 dedicated -threads, where N is the number of processors detected by the collector. -The dedicated threads are created once at initialization time. -

      -A second effect of this flag is to switch to a more concurrent -implementation of GC_malloc_many, so that free lists can be -built, and memory can be cleared, by more than one thread concurrently. -

    • -Building the collector with -DTHREAD_LOCAL_ALLOC adds support for thread -local allocation. This causes GC_malloc, GC_malloc_atomic, and -GC_gcj_malloc to be redefined to perform thread-local allocation. -

      -Memory returned from thread-local allocators is completely interchangeable -with that returned by the standard allocators. It may be used by other -threads. The only difference is that, if the thread allocates enough -memory of a certain kind, it will build a thread-local free list for -objects of that kind, and allocate from that. This greatly reduces -locking. The thread-local free lists are refilled using -GC_malloc_many. -

      -An important side effect of this flag is to replace the default -spin-then-sleep lock to be replace by a spin-then-queue based implementation. -This reduces performance for the standard allocation functions, -though it usually improves performance when thread-local allocation is -used heavily, and thus the number of short-duration lock acquisitions -is greatly reduced. -

    -

    -The easiest way to switch an application to thread-local allocation -in a pre-version-7.0 collector was to -

      -
    1. Define the macro GC_REDIRECT_TO_LOCAL, -and then include the gc.h -header in each client source file. -
    2. Invoke GC_thr_init() before any allocation. -
    3. Allocate using GC_MALLOC, GC_MALLOC_ATOMIC, -and/or GC_GCJ_MALLOC. -
    -

    The Parallel Marking Algorithm

    -We use an algorithm similar to -that developed by -Endo, Taura, and Yonezawa at the University of Tokyo. -However, the data structures and implementation are different, -and represent a smaller change to the original collector source, -probably at the expense of extreme scalability. Some of -the refinements they suggest, e.g. splitting large -objects, were also incorporated into out approach. -

    -The global mark stack is transformed into a global work queue. -Unlike the usual case, it never shrinks during a mark phase. -The mark threads remove objects from the queue by copying them to a -local mark stack and changing the global descriptor to zero, indicating -that there is no more work to be done for this entry. -This removal -is done with no synchronization. Thus it is possible for more than -one worker to remove the same entry, resulting in some work duplication. -

    -The global work queue grows only if a marker thread decides to -return some of its local mark stack to the global one. This -is done if the global queue appears to be running low, or if -the local stack is in danger of overflowing. It does require -synchronization, but should be relatively rare. -

    -The sequential marking code is reused to process local mark stacks. -Hence the amount of additional code required for parallel marking -is minimal. -

    -It should be possible to use generational collection in the presence of the -parallel collector, by calling GC_enable_incremental(). -This does not result in fully incremental collection, since parallel mark -phases cannot currently be interrupted, and doing so may be too -expensive. -

    -Gcj-style mark descriptors do not currently mix with the combination -of local allocation and incremental collection. They should work correctly -with one or the other, but not both. -

    -The number of marker threads is set on startup to the number of -available processors (or to the value of the GC_NPROCS -environment variable). If only a single processor is detected, -parallel marking is disabled. -

    -Note that setting GC_NPROCS to 1 also causes some lock acquisitions inside -the collector to immediately yield the processor instead of busy waiting -first. In the case of a multiprocessor and a client with multiple -simultaneously runnable threads, this may have disastrous performance -consequences (e.g. a factor of 10 slowdown). -

    Performance

    -We conducted some simple experiments with a version of -our GC benchmark -that was slightly modified to -run multiple concurrent client threads in the same address space. -Each client thread does the same work as the original benchmark, but they share -a heap. -This benchmark involves very little work outside of memory allocation. -This was run with GC 6.0alpha3 on a dual processor Pentium III/500 machine -under Linux 2.2.12. -

    -Running with a thread-unsafe collector, the benchmark ran in 9 -seconds. With the simple thread-safe collector, -built with -DLINUX_THREADS, the execution time -increased to 10.3 seconds, or 23.5 elapsed seconds with two clients. -(The times for the malloc/ifree version -with glibc malloc -are 10.51 (standard library, pthreads not linked), -20.90 (one thread, pthreads linked), -and 24.55 seconds respectively. The benchmark favors a -garbage collector, since most objects are small.) -

    -The following table gives execution times for the collector built -with parallel marking and thread-local allocation support -(-DGC_LINUX_THREADS -DPARALLEL_MARK -DTHREAD_LOCAL_ALLOC). We tested -the client using either one or two marker threads, and running -one or two client threads. Note that the client uses thread local -allocation exclusively. With -DTHREAD_LOCAL_ALLOC the collector -switches to a locking strategy that is better tuned to less frequent -lock acquisition. The standard allocation primitives thus perform -slightly worse than without -DTHREAD_LOCAL_ALLOC, and should be -avoided in time-critical code. -

    -(The results using pthread_mutex_lock -directly for allocation locking would have been worse still, at -least for older versions of linuxthreads. -With THREAD_LOCAL_ALLOC, we first repeatedly try to acquire the -lock with pthread_mutex_try_lock(), busy_waiting between attempts. -After a fixed number of attempts, we use pthread_mutex_lock().) -

    -These measurements do not use incremental collection, nor was prefetching -enabled in the marker. We used the C version of the benchmark. -All measurements are in elapsed seconds on an unloaded machine. -

    - - - - - -
    Number of threads1 marker thread (secs.)2 marker threads (secs.)
    1 client10.457.85
    2 clients19.9512.3
    - -The execution time for the single threaded case is slightly worse than with -simple locking. However, even the single-threaded benchmark runs faster than -even the thread-unsafe version if a second processor is available. -The execution time for two clients with thread local allocation time is -only 1.4 times the sequential execution time for a single thread in a -thread-unsafe environment, even though it involves twice the client work. -That represents close to a -factor of 2 improvement over the 2 client case with the old collector. -The old collector clearly -still suffered from some contention overhead, in spite of the fact that the -locking scheme had been fairly well tuned. -

    -Full linear speedup (i.e. the same execution time for 1 client on one -processor as 2 clients on 2 processors) -is probably not achievable on this kind of -hardware even with such a small number of processors, -since the memory system is -a major constraint for the garbage collector, -the processors usually share a single memory bus, and thus -the aggregate memory bandwidth does not increase in -proportion to the number of processors. -

    -These results are likely to be very sensitive to both hardware and OS -issues. Preliminary experiments with an older Pentium Pro machine running -an older kernel were far less encouraging. - - - diff -Nru ecl-16.1.2/src/bdwgc/doc/simple_example.html ecl-16.1.3+ds/src/bdwgc/doc/simple_example.html --- ecl-16.1.2/src/bdwgc/doc/simple_example.html 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/simple_example.html 1970-01-01 00:00:00.000000000 +0000 @@ -1,229 +0,0 @@ - - - - -Using the Garbage Collector: A simple example - - -

    Using the Garbage Collector: A simple example

    -The following consists of step-by-step instructions for building and -using the collector. We'll assume a Linux/gcc platform and -a single-threaded application. The green -text contains information about other platforms or scenarios. -It can be skipped, especially on first reading. -

    Building the collector

    -If you haven't already so, unpack the collector and enter -the newly created directory with -
    -tar xvfz gc<version>.tar.gz
-cd gc<version>
-
    -

    -You can configure, build, and install the collector in a private -directory, say /home/xyz/gc, with the following commands: -

    -./configure --prefix=/home/xyz/gc --disable-threads
-make
-make check
-make install
-
    -Here the "make check" command is optional, but highly recommended. -It runs a basic correctness test which usually takes well under a minute. -

    Other platforms

    - -On non-Unix, non-Linux platforms, the collector is usually built by copying -the appropriate makefile (see the platform-specific README in doc/README.xxx -in the distribution) to the file "Makefile", and then typing "make" -(or "nmake" or ...). This builds the library in the source tree. You may -want to move it and the files in the include directory to a more convenient -place. - -

    - -If you use a makefile that does not require running a configure script, -you should first look at the makefile, and adjust any options that are -documented there. - -

    - -If your platform provides a "make" utility, that is generally preferred -to platform- and compiler- dependent "project" files. (At least that is the -strong preference of the would-be maintainer of those project files.) - -

    Threads

    - -If you need thread support, configure the collector with - -
    ---enable-threads=posix --enable-thread-local-alloc --enable-parallel-mark
-
    - -instead of ---disable-threads -If your target is a real old-fashioned uniprocessor (no "hyperthreading", -etc.) you will want to omit --enable-parallel-mark. - -

    C++

    - -You will need to include the C++ support, which unfortunately tends to -be among the least portable parts of the collector, since it seems -to rely on some corner cases of the language. On Linux, it -suffices to add --enable-cplusplus to the configure options. - -

    Writing the program

    -You will need a -
    -#include "gc.h"
-
    -at the beginning of every file that allocates memory through the -garbage collector. Call GC_MALLOC wherever you would -have call malloc. This initializes memory to zero like -calloc; there is no need to explicitly clear the -result. -

    -If you know that an object will not contain pointers to the -garbage-collected heap, and you don't need it to be initialized, -call GC_MALLOC_ATOMIC instead. -

    -A function GC_FREE is provided but need not be called. -For very small objects, your program will probably perform better if -you do not call it, and let the collector do its job. -

    -A GC_REALLOC function behaves like the C library realloc. -It allocates uninitialized pointer-free memory if the original -object was allocated that way. -

    -The following program loop.c is a trivial example: -

    -#include "gc.h"
-#include <assert.h>
-#include <stdio.h>
-
-int main()
-{
-  int i;
-
-  GC_INIT();
-  for (i = 0; i < 10000000; ++i)
-   {
-     int **p = (int **) GC_MALLOC(sizeof(int *));
-     int *q = (int *) GC_MALLOC_ATOMIC(sizeof(int));
-     assert(*p == 0);
-     *p = (int *) GC_REALLOC(q, 2 * sizeof(int));
-     if (i % 100000 == 0)
-       printf("Heap size = %d\n", GC_get_heap_size());
-   }
-  return 0;
-}
-
    -

    Interaction with the system malloc

    - -It is usually best not to mix garbage-collected allocation with the system -malloc-free. If you do, you need to be careful not to store -pointers to the garbage-collected heap in memory allocated with the system -malloc. - - -

    Other Platforms

    - -On some other platforms it is necessary to call GC_INIT() from the main program, -which is presumed to be part of the main executable, not a dynamic library. -This can never hurt, and is thus generally good practice. - - -

    Threads

    - -For a multi-threaded program, some more rules apply: - -
      -
    • - -Files that either allocate through the GC or make thread-related calls -should first define the macro GC_THREADS, and then -include "gc.h". On some platforms this will redefine some -threads primitives, e.g. to let the collector keep track of thread creation. - -
    • - -To take advantage of fast thread-local allocation in versions before 7.0, -use the following instead -of including gc.h: - -
      -#define GC_REDIRECT_TO_LOCAL
-#include "gc_local_alloc.h"
-
      - -This will cause GC_MALLOC and GC_MALLOC_ATOMIC to keep per-thread allocation -caches, and greatly reduce the number of lock acquisitions during allocation. -For versions after 7.0, this happens implicitly if the collector is built -with thread-local allocation enabled. - -
    - -

    C++

    - -In the case of C++, you need to be especially careful not to store pointers -to the garbage-collected heap in areas that are not traced by the collector. -The collector includes some alternate interfaces -to make that easier. - - -

    Debugging

    - -Additional debug checks can be performed by defining GC_DEBUG before -including gc.h. Additional options are available if the collector -is also built with --enable-gc-debug (--enable-full-debug in -some older versions) and all allocations are -performed with GC_DEBUG defined. - - -

    What if I can't rewrite/recompile my program?

    - -You may be able to build the collector with --enable-redirect-malloc -and set the LD_PRELOAD environment variable to point to the resulting -library, thus replacing the standard malloc with its garbage-collected -counterpart. This is rather platform dependent. See the -leak detection documentation for some more details. - - -

    Compiling and linking

    - -The above application loop.c test program can be compiled and linked -with - -
    -cc -I/home/xyz/gc/include loop.c /home/xyz/gc/lib/libgc.a -o loop
-
    - -The -I option directs the compiler to the right include -directory. In this case, we list the static library -directly on the compile line; the dynamic library could have been -used instead, provided we arranged for the dynamic loader to find -it, e.g. by setting LD_LIBRARY_PATH. - -

    Threads

    - -On pthread platforms, you will of course also have to link with --lpthread, -and compile with any thread-safety options required by your compiler. -On some platforms, you may also need to link with -ldl -or -lrt. -Looking at tools/threadlibs.c should give you the appropriate -list if a plain -lpthread doesn't work. - - -

    Running the executable

    - -The executable can of course be run normally, e.g. by typing - -
    -./loop
-
    - -The operation of the collector is affected by a number of environment variables. -For example, setting GC_PRINT_STATS produces some -GC statistics on stdout. -See README.environment in the distribution for details. - - diff -Nru ecl-16.1.2/src/bdwgc/doc/tree.html ecl-16.1.3+ds/src/bdwgc/doc/tree.html --- ecl-16.1.2/src/bdwgc/doc/tree.html 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/doc/tree.html 1970-01-01 00:00:00.000000000 +0000 @@ -1,195 +0,0 @@ - - - Two-Level Tree Structure for Fast Pointer Lookup - Hans-J. Boehm, Silicon Graphics (now at HP) - - -

    Two-Level Tree Structure for Fast Pointer Lookup

    -

    -The BDWGC conservative garbage collector uses a 2-level tree -data structure to aid in fast pointer identification. -This data structure is described in a bit more detail here, since -

      -
    1. Variations of the data structure are more generally useful. -
    2. It appears to be hard to understand by reading the code. -
    3. Some other collectors appear to use inferior data structures to -solve the same problem. -
    4. It is central to fast collector operation. -
    -A candidate pointer is divided into three sections, the high, -middle, and low bits. The exact division between these -three groups of bits is dependent on the detailed collector configuration. -

    -The high and middle bits are used to look up an entry in the table described -here. The resulting table entry consists of either a block descriptor -(struct hblkhdr * or hdr *) -identifying the layout of objects in the block, or an indication that this -address range corresponds to the middle of a large block, together with a -hint for locating the actual block descriptor. Such a hint consist -of a displacement that can be subtracted from the middle bits of the candidate -pointer without leaving the object. -

    -In either case, the block descriptor (struct hblkhdr) -refers to a table of object starting addresses (the hb_map field). -The starting address table is indexed by the low bits if the candidate pointer. -The resulting entry contains a displacement to the beginning of the object, -or an indication that this cannot be a valid object pointer. -(If all interior pointer are recognized, pointers into large objects -are handled specially, as appropriate.) - -

    The Tree

    -

    -The rest of this discussion focuses on the two level data structure -used to map the high and middle bits to the block descriptor. -

    -The high bits are used as an index into the GC_top_index (really -GC_arrays._top_index) array. Each entry points to a -bottom_index data structure. This structure in turn consists -mostly of an array index indexed by the middle bits of -the candidate pointer. The index array contains the actual -hdr pointers. -

    -Thus a pointer lookup consists primarily of a handful of memory references, -and can be quite fast: -

      -
    1. The appropriate bottom_index pointer is looked up in -GC_top_index, based on the high bits of the candidate pointer. -
    2. The appropriate hdr pointer is looked up in the -bottom_index structure, based on the middle bits. -
    3. The block layout map pointer is retrieved from the hdr -structure. (This memory reference is necessary since we try to share -block layout maps.) -
    4. The displacement to the beginning of the object is retrieved from the -above map. -
    -

    -In order to conserve space, not all GC_top_index entries in fact -point to distinct bottom_index structures. If no address with -the corresponding high bits is part of the heap, then the entry points -to GC_all_nils, a single bottom_index structure consisting -only of NULL hdr pointers. -

    -Bottom_index structures contain slightly more information than -just hdr pointers. The asc_link field is used to link -all bottom_index structures in ascending order for fast traversal. -This list is pointed to be GC_all_bottom_indices. -It is maintained with the aid of key field that contains the -high bits corresponding to the bottom_index. - -

    64 bit addresses

    -

    -In the case of 64 bit addresses, this picture is complicated slightly -by the fact that one of the index structures would have to be huge to -cover the entire address space with a two level tree. We deal with this -by turning GC_top_index into a chained hash table, instead of -a simple array. This adds a hash_link field to the -bottom_index structure. -

    -The "hash function" consists of dropping the high bits. This is cheap to -compute, and guarantees that there will be no collisions if the heap -is contiguous and not excessively large. - -

    A picture

    -

    -The following is an ASCII diagram of the data structure. -This was contributed by Dave Barrett several years ago. -

    -
-                Data Structure used by GC_base in gc3.7:
-                              21-Apr-94
-
-
-
-
-    63                  LOG_TOP_SZ[11]  LOG_BOTTOM_SZ[10]   LOG_HBLKSIZE[13]
-   +------------------+----------------+------------------+------------------+
- p:|                  |   TL_HASH(hi)  |                  |   HBLKDISPL(p)   |
-   +------------------+----------------+------------------+------------------+
-    \-----------------------HBLKPTR(p)-------------------/
-    \------------hi-------------------/
-                      \______ ________/ \________ _______/ \________ _______/
-                             V                   V                  V
-                             |                   |                  |
-           GC_top_index[]    |                   |                  |
- ---      +--------------+   |                   |                  |
-  ^       |              |   |                   |                  |
-  |       |              |   |                   |                  |
- TOP      +--------------+<--+                   |                  |
- _SZ   +-<|      []      | *                     |                  |
-(items)|  +--------------+  if 0 < bi< HBLKSIZE  |                  |
-  |    |  |              | then large object     |                  |
-  |    |  |              | starts at the bi'th   |                  |
-  v    |  |              | HBLK before p.        |             i    |
- ---   |  +--------------+                       |          (word-  |
-       v                                         |         aligned) |
-   bi= |GET_BI(p){->hash_link}->key==hi          |                  |
-       v                                         |                  |
-       |   (bottom_index)  \ scratch_alloc'd     |                  |
-       |   ( struct  bi )  / by get_index()      |                  |
- ---   +->+--------------+                       |                  |
-  ^       |              |                       |                  |
-  ^       |              |                       |                  |
- BOTTOM   |              |   ha=GET_HDR_ADDR(p)  |                  |
-_SZ(items)+--------------+<----------------------+          +-------+
-  |   +--<|   index[]    |                                  |
-  |   |   +--------------+                      GC_obj_map: v
-  |   |   |              |              from      / +-+-+-----+-+-+-+-+  ---
-  v   |   |              |              GC_add   < 0| | |     | | | | |   ^
- ---  |   +--------------+             _map_entry \ +-+-+-----+-+-+-+-+   |
-      |   |   asc_link   |                          +-+-+-----+-+-+-+-+ MAXOBJSZ
-      |   +--------------+                      +-->| | |  j  | | | | |  +1
-      |   |     key      |                      |   +-+-+-----+-+-+-+-+   |
-      |   +--------------+                      |   +-+-+-----+-+-+-+-+   |
-      |   |  hash_link   |                      |   | | |     | | | | |   v
-      |   +--------------+                      |   +-+-+-----+-+-+-+-+  ---
-      |                                         |   |<--MAX_OFFSET--->|
-      |                                         |         (bytes)
-HDR(p)| GC_find_header(p)                       |   |<--MAP_ENTRIES-->|
-      |                           \ from        |    =HBLKSIZE/WORDSZ
-      |    (hdr) (struct hblkhdr) / alloc_hdr() |    (1024 on Alpha)
-      +-->+----------------------+              |    (8/16 bits each)
-GET_HDR(p)| word   hb_sz (words) |              |
-          +----------------------+              |
-          | struct hblk *hb_next |              |
-          +----------------------+              |
-          |mark_proc hb_mark_proc|              |
-          +----------------------+              |
-          | char * hb_map        |>-------------+
-          +----------------------+
-          | ushort hb_obj_kind   |
-          +----------------------+
-          |   hb_last_reclaimed  |
- ---      +----------------------+
-  ^       |                      |
- MARK_BITS|       hb_marks[]     | *if hdr is free, hb_sz
-_SZ(words)|                      |  is the size of a heap chunk (struct hblk)
-  v       |                      |  of at least MININCR*HBLKSIZE bytes (below),
- ---      +----------------------+  otherwise, size of each object in chunk.
-
-Dynamic data structures above are interleaved throughout the heap in blocks of
-size MININCR * HBLKSIZE bytes as done by gc_scratch_alloc which cannot be
-freed; free lists are used (e.g. alloc_hdr).  HBLK's below are collected.
-
-              (struct hblk)                                  HDR_BYTES
- ---      +----------------------+ < HBLKSIZE  ---            (bytes)
-  ^       +-----hb_body----------+ (and WORDSZ) ^         ---   ---
-  |       |                      |   aligned    |          ^     ^
-  |       |                      |              |        hb_sz   |
-  |       |                      |              |       (words)  |
-  |       |      Object 0        |              |          |     |
-  |       |                      |            i |(word-    v     |
-  |       + - - - - - - - - - - -+ ---   (bytes)|aligned) ---    |
-  |       |                      |  ^           |          ^     |
-  |       |                      |  j (words)   |          |     |
-  n *     |      Object 1        |  v           v        hb_sz BODY_SZ
- HBLKSIZE |                      |---------------          |   (words)
- (bytes)  |                      |                         v   MAX_OFFSET
-  |       + - - - - - - - - - - -+                        ---  (bytes)
-  |       |                      | !All_INTERIOR_PTRS      ^     |
-  |       |                      | sets j only for       hb_sz   |
-  |       |      Object N        | valid object offsets.   |     |
-  v       |                      | All objects WORDSZ      v     v
- ---      +----------------------+ aligned.               ---   ---
-
-
    - diff -Nru ecl-16.1.2/src/bdwgc/dyn_load.c ecl-16.1.3+ds/src/bdwgc/dyn_load.c --- ecl-16.1.2/src/bdwgc/dyn_load.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/dyn_load.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,1514 +0,0 @@ -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1997 by Silicon Graphics. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#include "private/gc_priv.h" - -/* - * This is incredibly OS specific code for tracking down data sections in - * dynamic libraries. There appears to be no way of doing this quickly - * without groveling through undocumented data structures. We would argue - * that this is a bug in the design of the dlopen interface. THIS CODE - * MAY BREAK IN FUTURE OS RELEASES. If this matters to you, don't hesitate - * to let your vendor know ... - * - * None of this is safe with dlclose and incremental collection. - * But then not much of anything is safe in the presence of dlclose. - */ - -#if !defined(MACOS) && !defined(_WIN32_WCE) && !defined(__CC_ARM) -# include -#endif - -/* BTL: avoid circular redefinition of dlopen if GC_SOLARIS_THREADS defined */ -#undef GC_MUST_RESTORE_REDEFINED_DLOPEN -#if defined(GC_PTHREADS) && !defined(GC_NO_DLOPEN) \ - && !defined(GC_NO_THREAD_REDIRECTS) && !defined(GC_USE_LD_WRAP) - /* To support threads in Solaris, gc.h interposes on dlopen by */ - /* defining "dlopen" to be "GC_dlopen", which is implemented below. */ - /* However, both GC_FirstDLOpenedLinkMap() and GC_dlopen() use the */ - /* real system dlopen() in their implementation. We first remove */ - /* gc.h's dlopen definition and restore it later, after GC_dlopen(). */ -# undef dlopen -# define GC_MUST_RESTORE_REDEFINED_DLOPEN -#endif /* !GC_NO_DLOPEN */ - -/* A user-supplied routine (custom filter) that might be called to */ -/* determine whether a DSO really needs to be scanned by the GC. */ -/* 0 means no filter installed. May be unused on some platforms. */ -/* FIXME: Add filter support for more platforms. */ -STATIC GC_has_static_roots_func GC_has_static_roots = 0; - -#if (defined(DYNAMIC_LOADING) || defined(MSWIN32) || defined(MSWINCE) \ - || defined(CYGWIN32)) && !defined(PCR) - -#if !defined(SOLARISDL) && !defined(IRIX5) && \ - !defined(MSWIN32) && !defined(MSWINCE) && !defined(CYGWIN32) && \ - !(defined(ALPHA) && defined(OSF1)) && \ - !defined(HPUX) && !(defined(LINUX) && defined(__ELF__)) && \ - !defined(AIX) && !defined(SCO_ELF) && !defined(DGUX) && \ - !(defined(FREEBSD) && defined(__ELF__)) && \ - !(defined(OPENBSD) && (defined(__ELF__) || defined(M68K))) && \ - !(defined(NETBSD) && defined(__ELF__)) && !defined(HURD) && \ - !defined(DARWIN) && !defined(CYGWIN32) - --> We only know how to find data segments of dynamic libraries for the - --> above. Additional SVR4 variants might not be too - --> hard to add. -#endif - -#include -#ifdef SOLARISDL -# include -# include -# include -#endif - -#if defined(NETBSD) -# include -# include -# include -# define ELFSIZE ARCH_ELFSIZE -#endif - -#if defined(OPENBSD) -# include -# if OpenBSD >= 200519 -# define HAVE_DL_ITERATE_PHDR -# endif -#endif /* OPENBSD */ - -#if defined(SCO_ELF) || defined(DGUX) || defined(HURD) \ - || (defined(__ELF__) && (defined(LINUX) || defined(FREEBSD) \ - || defined(NETBSD) || defined(OPENBSD))) -# include -# if !defined(OPENBSD) && !defined(PLATFORM_ANDROID) - /* OpenBSD does not have elf.h file; link.h below is sufficient. */ - /* Exclude Android because linker.h below includes its own version. */ -# include -# endif -# ifdef PLATFORM_ANDROID - /* If you don't need the "dynamic loading" feature, you may build */ - /* the collector with -D IGNORE_DYNAMIC_LOADING. */ -# ifdef BIONIC_ELFDATA_REDEF_BUG - /* Workaround a problem in Bionic (as of Android 4.2) which has */ - /* mismatching ELF_DATA definitions in sys/exec_elf.h and */ - /* asm/elf.h included from linker.h file (similar to EM_ALPHA). */ -# include -# include -# undef ELF_DATA -# undef EM_ALPHA -# endif -# include -# if !defined(GC_DONT_DEFINE_LINK_MAP) - /* link_map and r_debug should be defined explicitly, */ - /* as only bionic/linker/linker.h defines them but the header */ - /* itself is a C++ one starting from Android 4.3. */ - struct link_map { - uintptr_t l_addr; - char* l_name; - uintptr_t l_ld; - struct link_map* l_next; - struct link_map* l_prev; - }; - struct r_debug { - int32_t r_version; - struct link_map* r_map; - void (*r_brk)(void); - int32_t r_state; - uintptr_t r_ldbase; - }; -# endif -# else -# include -# endif -#endif - -/* Newer versions of GNU/Linux define this macro. We - * define it similarly for any ELF systems that don't. */ -# ifndef ElfW -# if defined(FREEBSD) -# if __ELF_WORD_SIZE == 32 -# define ElfW(type) Elf32_##type -# else -# define ElfW(type) Elf64_##type -# endif -# elif defined(NETBSD) || defined(OPENBSD) -# if ELFSIZE == 32 -# define ElfW(type) Elf32_##type -# else -# define ElfW(type) Elf64_##type -# endif -# else -# if !defined(ELF_CLASS) || ELF_CLASS == ELFCLASS32 -# define ElfW(type) Elf32_##type -# else -# define ElfW(type) Elf64_##type -# endif -# endif -# endif - -#if defined(SOLARISDL) && !defined(USE_PROC_FOR_LIBRARIES) - -#ifdef LINT - Elf32_Dyn _DYNAMIC; -#endif - -STATIC struct link_map * -GC_FirstDLOpenedLinkMap(void) -{ - extern ElfW(Dyn) _DYNAMIC; - ElfW(Dyn) *dp; - static struct link_map * cachedResult = 0; - static ElfW(Dyn) *dynStructureAddr = 0; - /* BTL: added to avoid Solaris 5.3 ld.so _DYNAMIC bug */ - -# ifdef SUNOS53_SHARED_LIB - /* BTL: Avoid the Solaris 5.3 bug that _DYNAMIC isn't being set */ - /* up properly in dynamically linked .so's. This means we have */ - /* to use its value in the set of original object files loaded */ - /* at program startup. */ - if( dynStructureAddr == 0 ) { - void* startupSyms = dlopen(0, RTLD_LAZY); - dynStructureAddr = (ElfW(Dyn)*)dlsym(startupSyms, "_DYNAMIC"); - } -# else - dynStructureAddr = &_DYNAMIC; -# endif - - if (dynStructureAddr == 0) { - /* _DYNAMIC symbol not resolved. */ - return(0); - } - if( cachedResult == 0 ) { - int tag; - for( dp = ((ElfW(Dyn) *)(&_DYNAMIC)); (tag = dp->d_tag) != 0; dp++ ) { - if( tag == DT_DEBUG ) { - struct link_map *lm - = ((struct r_debug *)(dp->d_un.d_ptr))->r_map; - if( lm != 0 ) cachedResult = lm->l_next; /* might be NULL */ - break; - } - } - } - return cachedResult; -} - -#endif /* SOLARISDL ... */ - -/* BTL: added to fix circular dlopen definition if GC_SOLARIS_THREADS defined */ -# ifdef GC_MUST_RESTORE_REDEFINED_DLOPEN -# define dlopen GC_dlopen -# endif - -# if defined(SOLARISDL) - -/* Add dynamic library data sections to the root set. */ -# if !defined(PCR) && !defined(GC_SOLARIS_THREADS) && defined(THREADS) - --> fix mutual exclusion with dlopen -# endif - -# ifndef USE_PROC_FOR_LIBRARIES -GC_INNER void GC_register_dynamic_libraries(void) -{ - struct link_map *lm; - - for (lm = GC_FirstDLOpenedLinkMap(); lm != 0; lm = lm->l_next) { - ElfW(Ehdr) * e; - ElfW(Phdr) * p; - unsigned long offset; - char * start; - int i; - - e = (ElfW(Ehdr) *) lm->l_addr; - p = ((ElfW(Phdr) *)(((char *)(e)) + e->e_phoff)); - offset = ((unsigned long)(lm->l_addr)); - for( i = 0; i < (int)e->e_phnum; i++, p++ ) { - switch( p->p_type ) { - case PT_LOAD: - { - if( !(p->p_flags & PF_W) ) break; - start = ((char *)(p->p_vaddr)) + offset; - GC_add_roots_inner( - start, - start + p->p_memsz, - TRUE - ); - } - break; - default: - break; - } - } - } -} - -# endif /* !USE_PROC ... */ -# endif /* SOLARISDL */ - -#if defined(SCO_ELF) || defined(DGUX) || defined(HURD) \ - || (defined(__ELF__) && (defined(LINUX) || defined(FREEBSD) \ - || defined(NETBSD) || defined(OPENBSD))) - -#ifdef USE_PROC_FOR_LIBRARIES - -#include - -#include -#include -#include - -#define MAPS_BUF_SIZE (32*1024) - -/* Sort an array of HeapSects by start address. */ -/* Unfortunately at least some versions of */ -/* Linux qsort end up calling malloc by way of sysconf, and hence can't */ -/* be used in the collector. Hence we roll our own. Should be */ -/* reasonably fast if the array is already mostly sorted, as we expect */ -/* it to be. */ -static void sort_heap_sects(struct HeapSect *base, size_t number_of_elements) -{ - signed_word n = (signed_word)number_of_elements; - signed_word nsorted = 1; - signed_word i; - - while (nsorted < n) { - while (nsorted < n && - (word)base[nsorted-1].hs_start < (word)base[nsorted].hs_start) - ++nsorted; - if (nsorted == n) break; - GC_ASSERT((word)base[nsorted-1].hs_start > (word)base[nsorted].hs_start); - i = nsorted - 1; - while (i >= 0 && (word)base[i].hs_start > (word)base[i+1].hs_start) { - struct HeapSect tmp = base[i]; - base[i] = base[i+1]; - base[i+1] = tmp; - --i; - } - GC_ASSERT((word)base[nsorted-1].hs_start < (word)base[nsorted].hs_start); - ++nsorted; - } -} - -STATIC word GC_register_map_entries(char *maps) -{ - char *prot; - char *buf_ptr = maps; - ptr_t start, end; - unsigned int maj_dev; - ptr_t least_ha, greatest_ha; - unsigned i; - ptr_t datastart; - -# ifdef DATASTART_IS_FUNC - static ptr_t datastart_cached = (ptr_t)(word)-1; - - /* Evaluate DATASTART only once. */ - if (datastart_cached == (ptr_t)(word)-1) { - datastart_cached = (ptr_t)(DATASTART); - } - datastart = datastart_cached; -# else - datastart = (ptr_t)(DATASTART); -# endif - - GC_ASSERT(I_HOLD_LOCK()); - sort_heap_sects(GC_our_memory, GC_n_memory); - least_ha = GC_our_memory[0].hs_start; - greatest_ha = GC_our_memory[GC_n_memory-1].hs_start - + GC_our_memory[GC_n_memory-1].hs_bytes; - - for (;;) { - buf_ptr = GC_parse_map_entry(buf_ptr, &start, &end, &prot, - &maj_dev, 0); - if (buf_ptr == NULL) return 1; - if (prot[1] == 'w') { - /* This is a writable mapping. Add it to */ - /* the root set unless it is already otherwise */ - /* accounted for. */ - if ((word)start <= (word)GC_stackbottom - && (word)end >= (word)GC_stackbottom) { - /* Stack mapping; discard */ - continue; - } -# ifdef THREADS - /* This may fail, since a thread may already be */ - /* unregistered, but its thread stack may still be there. */ - /* That can fail because the stack may disappear while */ - /* we're marking. Thus the marker is, and has to be */ - /* prepared to recover from segmentation faults. */ - - if (GC_segment_is_thread_stack(start, end)) continue; - - /* FIXME: NPTL squirrels */ - /* away pointers in pieces of the stack segment that we */ - /* don't scan. We work around this */ - /* by treating anything allocated by libpthread as */ - /* uncollectible, as we do in some other cases. */ - /* A specifically identified problem is that */ - /* thread stacks contain pointers to dynamic thread */ - /* vectors, which may be reused due to thread caching. */ - /* They may not be marked if the thread is still live. */ - /* This specific instance should be addressed by */ - /* INCLUDE_LINUX_THREAD_DESCR, but that doesn't quite */ - /* seem to suffice. */ - /* We currently trace entire thread stacks, if they are */ - /* are currently cached but unused. This is */ - /* very suboptimal for performance reasons. */ -# endif - /* We no longer exclude the main data segment. */ - if ((word)end <= (word)least_ha - || (word)start >= (word)greatest_ha) { - /* The easy case; just trace entire segment */ - GC_add_roots_inner((char *)start, (char *)end, TRUE); - continue; - } - /* Add sections that don't belong to us. */ - i = 0; - while ((word)(GC_our_memory[i].hs_start - + GC_our_memory[i].hs_bytes) < (word)start) - ++i; - GC_ASSERT(i < GC_n_memory); - if ((word)GC_our_memory[i].hs_start <= (word)start) { - start = GC_our_memory[i].hs_start - + GC_our_memory[i].hs_bytes; - ++i; - } - while (i < GC_n_memory - && (word)GC_our_memory[i].hs_start < (word)end - && (word)start < (word)end) { - if ((word)start < (word)GC_our_memory[i].hs_start) - GC_add_roots_inner((char *)start, - GC_our_memory[i].hs_start, TRUE); - start = GC_our_memory[i].hs_start - + GC_our_memory[i].hs_bytes; - ++i; - } - if ((word)start < (word)end) - GC_add_roots_inner((char *)start, (char *)end, TRUE); - } - } - return 1; -} - -GC_INNER void GC_register_dynamic_libraries(void) -{ - if (!GC_register_map_entries(GC_get_maps())) - ABORT("Failed to read /proc for library registration"); -} - -/* We now take care of the main data segment ourselves: */ -GC_INNER GC_bool GC_register_main_static_data(void) -{ - return FALSE; -} - -# define HAVE_REGISTER_MAIN_STATIC_DATA - -#else /* !USE_PROC_FOR_LIBRARIES */ - -/* The following is the preferred way to walk dynamic libraries */ -/* for glibc 2.2.4+. Unfortunately, it doesn't work for older */ -/* versions. Thanks to Jakub Jelinek for most of the code. */ - -#if __GLIBC__ > 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ > 2) \ - || (__GLIBC__ == 2 && __GLIBC_MINOR__ == 2 && defined(DT_CONFIG)) \ - || defined(PLATFORM_ANDROID) /* Are others OK here, too? */ -/* We have the header files for a glibc that includes dl_iterate_phdr. */ -/* It may still not be available in the library on the target system. */ -/* Thus we also treat it as a weak symbol. */ -# define HAVE_DL_ITERATE_PHDR -# ifdef PLATFORM_ANDROID - /* Android headers might have no such definition for some targets. */ - int dl_iterate_phdr(int (*cb)(struct dl_phdr_info *, size_t, void *), - void *data); -# endif -# pragma weak dl_iterate_phdr -#endif - -#if (defined(FREEBSD) && __FreeBSD__ >= 7) - /* On the FreeBSD system, any target system at major version 7 shall */ - /* have dl_iterate_phdr; therefore, we need not make it weak as above. */ -# define HAVE_DL_ITERATE_PHDR -# define DL_ITERATE_PHDR_STRONG -#endif - -#if defined(HAVE_DL_ITERATE_PHDR) - -# ifdef PT_GNU_RELRO -/* Instead of registering PT_LOAD sections directly, we keep them */ -/* in a temporary list, and filter them by excluding PT_GNU_RELRO */ -/* segments. Processing PT_GNU_RELRO sections with */ -/* GC_exclude_static_roots instead would be superficially cleaner. But */ -/* it runs into trouble if a client registers an overlapping segment, */ -/* which unfortunately seems quite possible. */ - -# define MAX_LOAD_SEGS MAX_ROOT_SETS - - static struct load_segment { - ptr_t start; - ptr_t end; - /* Room for a second segment if we remove a RELRO segment */ - /* from the middle. */ - ptr_t start2; - ptr_t end2; - } load_segs[MAX_LOAD_SEGS]; - - static int n_load_segs; -# endif /* PT_GNU_RELRO */ - -STATIC int GC_register_dynlib_callback(struct dl_phdr_info * info, - size_t size, void * ptr) -{ - const ElfW(Phdr) * p; - ptr_t start, end; - int i; - - /* Make sure struct dl_phdr_info is at least as big as we need. */ - if (size < offsetof (struct dl_phdr_info, dlpi_phnum) - + sizeof (info->dlpi_phnum)) - return -1; - - p = info->dlpi_phdr; - for( i = 0; i < (int)info->dlpi_phnum; i++, p++ ) { - switch( p->p_type ) { -# ifdef PT_GNU_RELRO - case PT_GNU_RELRO: - /* This entry is known to be constant and will eventually be remapped - read-only. However, the address range covered by this entry is - typically a subset of a previously encountered "LOAD" segment, so - we need to exclude it. */ - { - int j; - - start = ((ptr_t)(p->p_vaddr)) + info->dlpi_addr; - end = start + p->p_memsz; - for (j = n_load_segs; --j >= 0; ) { - if ((word)start >= (word)load_segs[j].start - && (word)start < (word)load_segs[j].end) { - if (load_segs[j].start2 != 0) { - WARN("More than one GNU_RELRO segment per load seg\n",0); - } else { - GC_ASSERT((word)end <= (word)load_segs[j].end); - /* Remove from the existing load segment */ - load_segs[j].end2 = load_segs[j].end; - load_segs[j].end = start; - load_segs[j].start2 = end; - } - break; - } - if (j == 0) WARN("Failed to find PT_GNU_RELRO segment" - " inside PT_LOAD region", 0); - } - } - - break; -# endif - - case PT_LOAD: - { - GC_has_static_roots_func callback = GC_has_static_roots; - if( !(p->p_flags & PF_W) ) break; - start = ((char *)(p->p_vaddr)) + info->dlpi_addr; - end = start + p->p_memsz; - - if (callback != 0 && !callback(info->dlpi_name, start, p->p_memsz)) - break; -# ifdef PT_GNU_RELRO - if (n_load_segs >= MAX_LOAD_SEGS) ABORT("Too many PT_LOAD segs"); -# if CPP_WORDSZ == 64 - /* FIXME: GC_push_all eventually does the correct */ - /* rounding to the next multiple of ALIGNMENT, so, most */ - /* probably, we should remove the corresponding assertion */ - /* check in GC_add_roots_inner along with this code line. */ - /* start pointer value may require aligning */ - start = (ptr_t)((word)start & ~(sizeof(word) - 1)); -# endif - load_segs[n_load_segs].start = start; - load_segs[n_load_segs].end = end; - load_segs[n_load_segs].start2 = 0; - load_segs[n_load_segs].end2 = 0; - ++n_load_segs; -# else - GC_add_roots_inner(start, end, TRUE); -# endif /* PT_GNU_RELRO */ - } - break; - default: - break; - } - } - - *(int *)ptr = 1; /* Signal that we were called */ - return 0; -} - -/* Do we need to separately register the main static data segment? */ -GC_INNER GC_bool GC_register_main_static_data(void) -{ -# ifdef DL_ITERATE_PHDR_STRONG - /* If dl_iterate_phdr is not a weak symbol then don't test against */ - /* zero (otherwise a compiler might issue a warning). */ - return FALSE; -# else - return (dl_iterate_phdr == 0); /* implicit conversion to function ptr */ -# endif -} - -/* Return TRUE if we succeed, FALSE if dl_iterate_phdr wasn't there. */ -STATIC GC_bool GC_register_dynamic_libraries_dl_iterate_phdr(void) -{ - int did_something; - if (GC_register_main_static_data()) - return FALSE; - -# ifdef PT_GNU_RELRO - { - static GC_bool excluded_segs = FALSE; - n_load_segs = 0; - if (!EXPECT(excluded_segs, TRUE)) { - GC_exclude_static_roots_inner((ptr_t)load_segs, - (ptr_t)load_segs + sizeof(load_segs)); - excluded_segs = TRUE; - } - } -# endif - - did_something = 0; - dl_iterate_phdr(GC_register_dynlib_callback, &did_something); - if (did_something) { -# ifdef PT_GNU_RELRO - int i; - - for (i = 0; i < n_load_segs; ++i) { - if ((word)load_segs[i].end > (word)load_segs[i].start) { - GC_add_roots_inner(load_segs[i].start, load_segs[i].end, TRUE); - } - if ((word)load_segs[i].end2 > (word)load_segs[i].start2) { - GC_add_roots_inner(load_segs[i].start2, load_segs[i].end2, TRUE); - } - } -# endif - } else { - char *datastart; - char *dataend; -# ifdef DATASTART_IS_FUNC - static ptr_t datastart_cached = (ptr_t)(word)-1; - - /* Evaluate DATASTART only once. */ - if (datastart_cached == (ptr_t)(word)-1) { - datastart_cached = (ptr_t)(DATASTART); - } - datastart = (char *)datastart_cached; -# else - datastart = DATASTART; -# endif -# ifdef DATAEND_IS_FUNC - { - static ptr_t dataend_cached = 0; - /* Evaluate DATAEND only once. */ - if (dataend_cached == 0) { - dataend_cached = (ptr_t)(DATAEND); - } - dataend = (char *)dataend_cached; - } -# else - dataend = DATAEND; -# endif - - /* dl_iterate_phdr may forget the static data segment in */ - /* statically linked executables. */ - GC_add_roots_inner(datastart, dataend, TRUE); -# if defined(DATASTART2) - GC_add_roots_inner(DATASTART2, (char *)(DATAEND2), TRUE); -# endif - } - return TRUE; -} - -# define HAVE_REGISTER_MAIN_STATIC_DATA - -#else /* !HAVE_DL_ITERATE_PHDR */ - -/* Dynamic loading code for Linux running ELF. Somewhat tested on - * Linux/x86, untested but hopefully should work on Linux/Alpha. - * This code was derived from the Solaris/ELF support. Thanks to - * whatever kind soul wrote that. - Patrick Bridges */ - -/* This doesn't necessarily work in all cases, e.g. with preloaded - * dynamic libraries. */ - -# if defined(NETBSD) || defined(OPENBSD) -# include - /* for compatibility with 1.4.x */ -# ifndef DT_DEBUG -# define DT_DEBUG 21 -# endif -# ifndef PT_LOAD -# define PT_LOAD 1 -# endif -# ifndef PF_W -# define PF_W 2 -# endif -# elif !defined(PLATFORM_ANDROID) -# include -# endif - -# ifndef PLATFORM_ANDROID -# include -# endif - -#endif /* !HAVE_DL_ITERATE_PHDR */ - -#ifdef __GNUC__ -# pragma weak _DYNAMIC -#endif -extern ElfW(Dyn) _DYNAMIC[]; - -STATIC struct link_map * -GC_FirstDLOpenedLinkMap(void) -{ - ElfW(Dyn) *dp; - static struct link_map *cachedResult = 0; - - if (0 == (ptr_t)_DYNAMIC) { - /* _DYNAMIC symbol not resolved. */ - return(0); - } - if( cachedResult == 0 ) { -# if defined(NETBSD) && defined(RTLD_DI_LINKMAP) - struct link_map *lm = NULL; - if (!dlinfo(RTLD_SELF, RTLD_DI_LINKMAP, &lm) && lm != NULL) { - /* Now lm points link_map object of libgc. Since it */ - /* might not be the first dynamically linked object, */ - /* try to find it (object next to the main object). */ - while (lm->l_prev != NULL) { - lm = lm->l_prev; - } - cachedResult = lm->l_next; - } -# else - int tag; - for( dp = _DYNAMIC; (tag = dp->d_tag) != 0; dp++ ) { - if( tag == DT_DEBUG ) { - struct link_map *lm - = ((struct r_debug *)(dp->d_un.d_ptr))->r_map; - if( lm != 0 ) cachedResult = lm->l_next; /* might be NULL */ - break; - } - } -# endif /* !NETBSD || !RTLD_DI_LINKMAP */ - } - return cachedResult; -} - -GC_INNER void GC_register_dynamic_libraries(void) -{ - struct link_map *lm; - -# ifdef HAVE_DL_ITERATE_PHDR - if (GC_register_dynamic_libraries_dl_iterate_phdr()) { - return; - } -# endif - for (lm = GC_FirstDLOpenedLinkMap(); lm != 0; lm = lm->l_next) - { - ElfW(Ehdr) * e; - ElfW(Phdr) * p; - unsigned long offset; - char * start; - int i; - - e = (ElfW(Ehdr) *) lm->l_addr; -# ifdef PLATFORM_ANDROID - if (e == NULL) - continue; -# endif - p = ((ElfW(Phdr) *)(((char *)(e)) + e->e_phoff)); - offset = ((unsigned long)(lm->l_addr)); - for( i = 0; i < (int)e->e_phnum; i++, p++ ) { - switch( p->p_type ) { - case PT_LOAD: - { - if( !(p->p_flags & PF_W) ) break; - start = ((char *)(p->p_vaddr)) + offset; - GC_add_roots_inner(start, start + p->p_memsz, TRUE); - } - break; - default: - break; - } - } - } -} - -#endif /* !USE_PROC_FOR_LIBRARIES */ - -#endif /* LINUX */ - -#if defined(IRIX5) || (defined(USE_PROC_FOR_LIBRARIES) && !defined(LINUX)) - -#include -#include -#include -#include -#include -#include /* Only for the following test. */ -#ifndef _sigargs -# define IRIX6 -#endif - -/* We use /proc to track down all parts of the address space that are */ -/* mapped by the process, and throw out regions we know we shouldn't */ -/* worry about. This may also work under other SVR4 variants. */ -GC_INNER void GC_register_dynamic_libraries(void) -{ - static int fd = -1; - char buf[30]; - static prmap_t * addr_map = 0; - static int current_sz = 0; /* Number of records currently in addr_map */ - static int needed_sz; /* Required size of addr_map */ - int i; - long flags; - ptr_t start; - ptr_t limit; - ptr_t heap_start = HEAP_START; - ptr_t heap_end = heap_start; - -# ifdef SOLARISDL -# define MA_PHYS 0 -# endif /* SOLARISDL */ - - if (fd < 0) { - (void)snprintf(buf, sizeof(buf), "/proc/%ld", (long)getpid()); - buf[sizeof(buf) - 1] = '\0'; - /* The above generates a lint complaint, since pid_t varies. */ - /* It's unclear how to improve this. */ - fd = open(buf, O_RDONLY); - if (fd < 0) { - ABORT("/proc open failed"); - } - } - if (ioctl(fd, PIOCNMAP, &needed_sz) < 0) { - ABORT_ARG2("/proc PIOCNMAP ioctl failed", - ": fd = %d, errno = %d", fd, errno); - } - if (needed_sz >= current_sz) { - current_sz = needed_sz * 2 + 1; - /* Expansion, plus room for 0 record */ - addr_map = (prmap_t *)GC_scratch_alloc( - (word)current_sz * sizeof(prmap_t)); - if (addr_map == NULL) - ABORT("Insufficient memory for address map"); - } - if (ioctl(fd, PIOCMAP, addr_map) < 0) { - ABORT_ARG3("/proc PIOCMAP ioctl failed", - ": errcode= %d, needed_sz= %d, addr_map= %p", - errno, needed_sz, addr_map); - }; - if (GC_n_heap_sects > 0) { - heap_end = GC_heap_sects[GC_n_heap_sects-1].hs_start - + GC_heap_sects[GC_n_heap_sects-1].hs_bytes; - if ((word)heap_end < (word)GC_scratch_last_end_ptr) - heap_end = GC_scratch_last_end_ptr; - } - for (i = 0; i < needed_sz; i++) { - flags = addr_map[i].pr_mflags; - if ((flags & (MA_BREAK | MA_STACK | MA_PHYS - | MA_FETCHOP | MA_NOTCACHED)) != 0) goto irrelevant; - if ((flags & (MA_READ | MA_WRITE)) != (MA_READ | MA_WRITE)) - goto irrelevant; - /* The latter test is empirically useless in very old Irix */ - /* versions. Other than the */ - /* main data and stack segments, everything appears to be */ - /* mapped readable, writable, executable, and shared(!!). */ - /* This makes no sense to me. - HB */ - start = (ptr_t)(addr_map[i].pr_vaddr); - if (GC_roots_present(start)) goto irrelevant; - if ((word)start < (word)heap_end && (word)start >= (word)heap_start) - goto irrelevant; - - limit = start + addr_map[i].pr_size; - /* The following seemed to be necessary for very old versions */ - /* of Irix, but it has been reported to discard relevant */ - /* segments under Irix 6.5. */ -# ifndef IRIX6 - if (addr_map[i].pr_off == 0 && strncmp(start, ELFMAG, 4) == 0) { - /* Discard text segments, i.e. 0-offset mappings against */ - /* executable files which appear to have ELF headers. */ - caddr_t arg; - int obj; -# define MAP_IRR_SZ 10 - static ptr_t map_irr[MAP_IRR_SZ]; - /* Known irrelevant map entries */ - static int n_irr = 0; - struct stat buf; - register int j; - - for (j = 0; j < n_irr; j++) { - if (map_irr[j] == start) goto irrelevant; - } - arg = (caddr_t)start; - obj = ioctl(fd, PIOCOPENM, &arg); - if (obj >= 0) { - fstat(obj, &buf); - close(obj); - if ((buf.st_mode & 0111) != 0) { - if (n_irr < MAP_IRR_SZ) { - map_irr[n_irr++] = start; - } - goto irrelevant; - } - } - } -# endif /* !IRIX6 */ - GC_add_roots_inner(start, limit, TRUE); - irrelevant: ; - } - /* Don't keep cached descriptor, for now. Some kernels don't like us */ - /* to keep a /proc file descriptor around during kill -9. */ - if (close(fd) < 0) ABORT("Couldn't close /proc file"); - fd = -1; -} - -# endif /* USE_PROC || IRIX5 */ - -# if defined(MSWIN32) || defined(MSWINCE) || defined(CYGWIN32) - -# ifndef WIN32_LEAN_AND_MEAN -# define WIN32_LEAN_AND_MEAN 1 -# endif -# define NOSERVICE -# include -# include - - /* We traverse the entire address space and register all segments */ - /* that could possibly have been written to. */ - STATIC void GC_cond_add_roots(char *base, char * limit) - { -# ifdef GC_WIN32_THREADS - char * curr_base = base; - char * next_stack_lo; - char * next_stack_hi; - - if (base == limit) return; - for(;;) { - GC_get_next_stack(curr_base, limit, &next_stack_lo, &next_stack_hi); - if ((word)next_stack_lo >= (word)limit) break; - if ((word)next_stack_lo > (word)curr_base) - GC_add_roots_inner(curr_base, next_stack_lo, TRUE); - curr_base = next_stack_hi; - } - if ((word)curr_base < (word)limit) - GC_add_roots_inner(curr_base, limit, TRUE); -# else - char * stack_top - = (char *)((word)GC_approx_sp() & - ~(GC_sysinfo.dwAllocationGranularity - 1)); - - if (base == limit) return; - if ((word)limit > (word)stack_top - && (word)base < (word)GC_stackbottom) { - /* Part of the stack; ignore it. */ - return; - } - GC_add_roots_inner(base, limit, TRUE); -# endif - } - -#ifdef DYNAMIC_LOADING - /* GC_register_main_static_data is not needed unless DYNAMIC_LOADING. */ - GC_INNER GC_bool GC_register_main_static_data(void) - { -# if defined(MSWINCE) || defined(CYGWIN32) - /* Do we need to separately register the main static data segment? */ - return FALSE; -# else - return GC_no_win32_dlls; -# endif - } -# define HAVE_REGISTER_MAIN_STATIC_DATA -#endif /* DYNAMIC_LOADING */ - -# ifdef DEBUG_VIRTUALQUERY - void GC_dump_meminfo(MEMORY_BASIC_INFORMATION *buf) - { - GC_printf("BaseAddress = 0x%lx, AllocationBase = 0x%lx," - " RegionSize = 0x%lx(%lu)\n", buf -> BaseAddress, - buf -> AllocationBase, buf -> RegionSize, buf -> RegionSize); - GC_printf("\tAllocationProtect = 0x%lx, State = 0x%lx, Protect = 0x%lx, " - "Type = 0x%lx\n", buf -> AllocationProtect, buf -> State, - buf -> Protect, buf -> Type); - } -# endif /* DEBUG_VIRTUALQUERY */ - -# if defined(MSWINCE) || defined(CYGWIN32) - /* FIXME: Should we really need to scan MEM_PRIVATE sections? */ - /* For now, we don't add MEM_PRIVATE sections to the data roots for */ - /* WinCE because otherwise SEGV fault sometimes happens to occur in */ - /* GC_mark_from() (and, even if we use WRAP_MARK_SOME, WinCE prints */ - /* a "Data Abort" message to the debugging console). */ - /* To workaround that, use -DGC_REGISTER_MEM_PRIVATE. */ -# define GC_wnt TRUE -# endif - - GC_INNER void GC_register_dynamic_libraries(void) - { - MEMORY_BASIC_INFORMATION buf; - size_t result; - DWORD protect; - LPVOID p; - char * base; - char * limit, * new_limit; - -# ifdef MSWIN32 - if (GC_no_win32_dlls) return; -# endif - base = limit = p = GC_sysinfo.lpMinimumApplicationAddress; - while ((word)p < (word)GC_sysinfo.lpMaximumApplicationAddress) { - result = VirtualQuery(p, &buf, sizeof(buf)); -# ifdef MSWINCE - if (result == 0) { - /* Page is free; advance to the next possible allocation base */ - new_limit = (char *) - (((DWORD) p + GC_sysinfo.dwAllocationGranularity) - & ~(GC_sysinfo.dwAllocationGranularity-1)); - } else -# endif - /* else */ { - if (result != sizeof(buf)) { - ABORT("Weird VirtualQuery result"); - } - new_limit = (char *)p + buf.RegionSize; - protect = buf.Protect; - if (buf.State == MEM_COMMIT - && (protect == PAGE_EXECUTE_READWRITE - || protect == PAGE_READWRITE) - && (buf.Type == MEM_IMAGE -# ifdef GC_REGISTER_MEM_PRIVATE - || (protect == PAGE_READWRITE && buf.Type == MEM_PRIVATE) -# else - /* There is some evidence that we cannot always */ - /* ignore MEM_PRIVATE sections under Windows ME */ - /* and predecessors. Hence we now also check for */ - /* that case. */ - || (!GC_wnt && buf.Type == MEM_PRIVATE) -# endif - ) - && !GC_is_heap_base(buf.AllocationBase)) { -# ifdef DEBUG_VIRTUALQUERY - GC_dump_meminfo(&buf); -# endif - if ((char *)p != limit) { - GC_cond_add_roots(base, limit); - base = p; - } - limit = new_limit; - } - } - if ((word)p > (word)new_limit /* overflow */) break; - p = (LPVOID)new_limit; - } - GC_cond_add_roots(base, limit); - } - -#endif /* MSWIN32 || MSWINCE || CYGWIN32 */ - -#if defined(ALPHA) && defined(OSF1) - -#include - -extern char *sys_errlist[]; -extern int sys_nerr; -extern int errno; - -GC_INNER void GC_register_dynamic_libraries(void) -{ - int status; - ldr_process_t mypid; - - /* module */ - ldr_module_t moduleid = LDR_NULL_MODULE; - ldr_module_info_t moduleinfo; - size_t moduleinfosize = sizeof(moduleinfo); - size_t modulereturnsize; - - /* region */ - ldr_region_t region; - ldr_region_info_t regioninfo; - size_t regioninfosize = sizeof(regioninfo); - size_t regionreturnsize; - - /* Obtain id of this process */ - mypid = ldr_my_process(); - - /* For each module */ - while (TRUE) { - - /* Get the next (first) module */ - status = ldr_next_module(mypid, &moduleid); - - /* Any more modules? */ - if (moduleid == LDR_NULL_MODULE) - break; /* No more modules */ - - /* Check status AFTER checking moduleid because */ - /* of a bug in the non-shared ldr_next_module stub. */ - if (status != 0) { - ABORT_ARG3("ldr_next_module failed", - ": status= %d, errcode= %d (%s)", status, errno, - errno < sys_nerr ? sys_errlist[errno] : ""); - } - - /* Get the module information */ - status = ldr_inq_module(mypid, moduleid, &moduleinfo, - moduleinfosize, &modulereturnsize); - if (status != 0 ) - ABORT("ldr_inq_module failed"); - - /* is module for the main program (i.e. nonshared portion)? */ - if (moduleinfo.lmi_flags & LDR_MAIN) - continue; /* skip the main module */ - -# ifdef DL_VERBOSE - GC_log_printf("---Module---\n"); - GC_log_printf("Module ID\t = %16ld\n", moduleinfo.lmi_modid); - GC_log_printf("Count of regions = %16d\n", moduleinfo.lmi_nregion); - GC_log_printf("flags for module = %16lx\n", moduleinfo.lmi_flags); - GC_log_printf("module pathname\t = \"%s\"\n", moduleinfo.lmi_name); -# endif - - /* For each region in this module */ - for (region = 0; region < moduleinfo.lmi_nregion; region++) { - /* Get the region information */ - status = ldr_inq_region(mypid, moduleid, region, ®ioninfo, - regioninfosize, ®ionreturnsize); - if (status != 0 ) - ABORT("ldr_inq_region failed"); - - /* only process writable (data) regions */ - if (! (regioninfo.lri_prot & LDR_W)) - continue; - -# ifdef DL_VERBOSE - GC_log_printf("--- Region ---\n"); - GC_log_printf("Region number\t = %16ld\n", - regioninfo.lri_region_no); - GC_log_printf("Protection flags = %016x\n", regioninfo.lri_prot); - GC_log_printf("Virtual address\t = %16p\n", regioninfo.lri_vaddr); - GC_log_printf("Mapped address\t = %16p\n", - regioninfo.lri_mapaddr); - GC_log_printf("Region size\t = %16ld\n", regioninfo.lri_size); - GC_log_printf("Region name\t = \"%s\"\n", regioninfo.lri_name); -# endif - - /* register region as a garbage collection root */ - GC_add_roots_inner((char *)regioninfo.lri_mapaddr, - (char *)regioninfo.lri_mapaddr + regioninfo.lri_size, - TRUE); - - } - } -} -#endif - -#if defined(HPUX) - -#include -#include - -extern char *sys_errlist[]; -extern int sys_nerr; - -GC_INNER void GC_register_dynamic_libraries(void) -{ - int status; - int index = 1; /* Ordinal position in shared library search list */ - struct shl_descriptor *shl_desc; /* Shared library info, see dl.h */ - - /* For each dynamic library loaded */ - while (TRUE) { - - /* Get info about next shared library */ - status = shl_get(index, &shl_desc); - - /* Check if this is the end of the list or if some error occurred */ - if (status != 0) { -# ifdef GC_HPUX_THREADS - /* I've seen errno values of 0. The man page is not clear */ - /* as to whether errno should get set on a -1 return. */ - break; -# else - if (errno == EINVAL) { - break; /* Moved past end of shared library list --> finished */ - } else { - ABORT_ARG3("shl_get failed", - ": status= %d, errcode= %d (%s)", status, errno, - errno < sys_nerr ? sys_errlist[errno] : ""); - } -# endif - } - -# ifdef DL_VERBOSE - GC_log_printf("---Shared library---\n"); - GC_log_printf("\tfilename\t= \"%s\"\n", shl_desc->filename); - GC_log_printf("\tindex\t\t= %d\n", index); - GC_log_printf("\thandle\t\t= %08x\n", - (unsigned long) shl_desc->handle); - GC_log_printf("\ttext seg.start\t= %08x\n", shl_desc->tstart); - GC_log_printf("\ttext seg.end\t= %08x\n", shl_desc->tend); - GC_log_printf("\tdata seg.start\t= %08x\n", shl_desc->dstart); - GC_log_printf("\tdata seg.end\t= %08x\n", shl_desc->dend); - GC_log_printf("\tref.count\t= %lu\n", shl_desc->ref_count); -# endif - - /* register shared library's data segment as a garbage collection root */ - GC_add_roots_inner((char *) shl_desc->dstart, - (char *) shl_desc->dend, TRUE); - - index++; - } -} -#endif /* HPUX */ - -#ifdef AIX -# pragma alloca -# include -# include - GC_INNER void GC_register_dynamic_libraries(void) - { - int len; - char *ldibuf; - int ldibuflen; - struct ld_info *ldi; - - ldibuf = alloca(ldibuflen = 8192); - - while ( (len = loadquery(L_GETINFO,ldibuf,ldibuflen)) < 0) { - if (errno != ENOMEM) { - ABORT("loadquery failed"); - } - ldibuf = alloca(ldibuflen *= 2); - } - - ldi = (struct ld_info *)ldibuf; - while (ldi) { - len = ldi->ldinfo_next; - GC_add_roots_inner( - ldi->ldinfo_dataorg, - (ptr_t)(unsigned long)ldi->ldinfo_dataorg - + ldi->ldinfo_datasize, - TRUE); - ldi = len ? (struct ld_info *)((char *)ldi + len) : 0; - } - } -#endif /* AIX */ - -#ifdef DARWIN - -/* __private_extern__ hack required for pre-3.4 gcc versions. */ -#ifndef __private_extern__ -# define __private_extern__ extern -# include -# undef __private_extern__ -#else -# include -#endif -#include - -/*#define DARWIN_DEBUG*/ - -/* Writable sections generally available on Darwin. */ -STATIC const struct { - const char *seg; - const char *sect; -} GC_dyld_sections[] = { - { SEG_DATA, SECT_DATA }, - /* Used by FSF GCC, but not by OS X system tools, so far. */ - { SEG_DATA, "__static_data" }, - { SEG_DATA, SECT_BSS }, - { SEG_DATA, SECT_COMMON }, - /* FSF GCC - zero-sized object sections for targets */ - /*supporting section anchors. */ - { SEG_DATA, "__zobj_data" }, - { SEG_DATA, "__zobj_bss" } -}; - -/* Additional writable sections: */ -/* GCC on Darwin constructs aligned sections "on demand", where */ -/* the alignment size is embedded in the section name. */ -/* Furthermore, there are distinctions between sections */ -/* containing private vs. public symbols. It also constructs */ -/* sections specifically for zero-sized objects, when the */ -/* target supports section anchors. */ -STATIC const char * const GC_dyld_add_sect_fmts[] = { - "__bss%u", - "__pu_bss%u", - "__zo_bss%u", - "__zo_pu_bss%u" -}; - -/* Currently, mach-o will allow up to the max of 2^15 alignment */ -/* in an object file. */ -#ifndef L2_MAX_OFILE_ALIGNMENT -# define L2_MAX_OFILE_ALIGNMENT 15 -#endif - -STATIC const char *GC_dyld_name_for_hdr(const struct GC_MACH_HEADER *hdr) -{ - unsigned long i, c; - c = _dyld_image_count(); - for (i = 0; i < c; i++) - if ((const struct GC_MACH_HEADER *)_dyld_get_image_header(i) == hdr) - return _dyld_get_image_name(i); - return NULL; -} - -/* This should never be called by a thread holding the lock. */ -STATIC void GC_dyld_image_add(const struct GC_MACH_HEADER *hdr, - intptr_t slide) -{ - unsigned long start, end; - unsigned i, j; - const struct GC_MACH_SECTION *sec; - const char *name; - GC_has_static_roots_func callback = GC_has_static_roots; - char secnam[16]; - const char *fmt; - DCL_LOCK_STATE; - - if (GC_no_dls) return; -# ifdef DARWIN_DEBUG - name = GC_dyld_name_for_hdr(hdr); -# else - name = callback != 0 ? GC_dyld_name_for_hdr(hdr) : NULL; -# endif - for (i = 0; i < sizeof(GC_dyld_sections)/sizeof(GC_dyld_sections[0]); i++) { - sec = GC_GETSECTBYNAME(hdr, GC_dyld_sections[i].seg, - GC_dyld_sections[i].sect); - if (sec == NULL || sec->size < sizeof(word)) - continue; - start = slide + sec->addr; - end = start + sec->size; - LOCK(); - /* The user callback is called holding the lock. */ - if (callback == 0 || callback(name, (void*)start, (size_t)sec->size)) { -# ifdef DARWIN_DEBUG - GC_log_printf( - "Adding section __DATA,%s at %p-%p (%lu bytes) from image %s\n", - GC_dyld_sections[i].sect, (void*)start, (void*)end, - (unsigned long)sec->size, name); -# endif - GC_add_roots_inner((ptr_t)start, (ptr_t)end, FALSE); - } - UNLOCK(); - } - - /* Sections constructed on demand. */ - for (j = 0; j < sizeof(GC_dyld_add_sect_fmts) / sizeof(char *); j++) { - fmt = GC_dyld_add_sect_fmts[j]; - /* Add our manufactured aligned BSS sections. */ - for (i = 0; i <= L2_MAX_OFILE_ALIGNMENT; i++) { - (void)snprintf(secnam, sizeof(secnam), fmt, (unsigned)i); - secnam[sizeof(secnam) - 1] = '\0'; - sec = GC_GETSECTBYNAME(hdr, SEG_DATA, secnam); - if (sec == NULL || sec->size == 0) - continue; - start = slide + sec->addr; - end = start + sec->size; -# ifdef DARWIN_DEBUG - GC_log_printf("Adding on-demand section __DATA,%s at" - " %p-%p (%lu bytes) from image %s\n", - secnam, (void*)start, (void*)end, - (unsigned long)sec->size, name); -# endif - GC_add_roots((char*)start, (char*)end); - } - } - -# ifdef DARWIN_DEBUG - GC_print_static_roots(); -# endif -} - -/* This should never be called by a thread holding the lock. */ -STATIC void GC_dyld_image_remove(const struct GC_MACH_HEADER *hdr, - intptr_t slide) -{ - unsigned long start, end; - unsigned i, j; - const struct GC_MACH_SECTION *sec; - char secnam[16]; - const char *fmt; - - for (i = 0; i < sizeof(GC_dyld_sections)/sizeof(GC_dyld_sections[0]); i++) { - sec = GC_GETSECTBYNAME(hdr, GC_dyld_sections[i].seg, - GC_dyld_sections[i].sect); - if (sec == NULL || sec->size == 0) - continue; - start = slide + sec->addr; - end = start + sec->size; -# ifdef DARWIN_DEBUG - GC_log_printf( - "Removing section __DATA,%s at %p-%p (%lu bytes) from image %s\n", - GC_dyld_sections[i].sect, (void*)start, (void*)end, - (unsigned long)sec->size, GC_dyld_name_for_hdr(hdr)); -# endif - GC_remove_roots((char*)start, (char*)end); - } - - /* Remove our on-demand sections. */ - for (j = 0; j < sizeof(GC_dyld_add_sect_fmts) / sizeof(char *); j++) { - fmt = GC_dyld_add_sect_fmts[j]; - for (i = 0; i <= L2_MAX_OFILE_ALIGNMENT; i++) { - (void)snprintf(secnam, sizeof(secnam), fmt, (unsigned)i); - secnam[sizeof(secnam) - 1] = '\0'; - sec = GC_GETSECTBYNAME(hdr, SEG_DATA, secnam); - if (sec == NULL || sec->size == 0) - continue; - start = slide + sec->addr; - end = start + sec->size; -# ifdef DARWIN_DEBUG - GC_log_printf("Removing on-demand section __DATA,%s at" - " %p-%p (%lu bytes) from image %s\n", secnam, - (void*)start, (void*)end, (unsigned long)sec->size, - GC_dyld_name_for_hdr(hdr)); -# endif - GC_remove_roots((char*)start, (char*)end); - } - } - -# ifdef DARWIN_DEBUG - GC_print_static_roots(); -# endif -} - -GC_INNER void GC_register_dynamic_libraries(void) -{ - /* Currently does nothing. The callbacks are setup by GC_init_dyld() - The dyld library takes it from there. */ -} - -/* The _dyld_* functions have an internal lock so no _dyld functions - can be called while the world is stopped without the risk of a deadlock. - Because of this we MUST setup callbacks BEFORE we ever stop the world. - This should be called BEFORE any thread in created and WITHOUT the - allocation lock held. */ - -GC_INNER void GC_init_dyld(void) -{ - static GC_bool initialized = FALSE; - - if (initialized) return; - -# ifdef DARWIN_DEBUG - GC_log_printf("Registering dyld callbacks...\n"); -# endif - - /* Apple's Documentation: - When you call _dyld_register_func_for_add_image, the dynamic linker - runtime calls the specified callback (func) once for each of the images - that is currently loaded into the program. When a new image is added to - the program, your callback is called again with the mach_header for the - new image, and the virtual memory slide amount of the new image. - - This WILL properly register already linked libraries and libraries - linked in the future. - */ - - _dyld_register_func_for_add_image(GC_dyld_image_add); - _dyld_register_func_for_remove_image(GC_dyld_image_remove); - /* Ignore 2 compiler warnings here: passing argument 1 of */ - /* '_dyld_register_func_for_add/remove_image' from incompatible */ - /* pointer type. */ - - /* Set this early to avoid reentrancy issues. */ - initialized = TRUE; - -# ifdef NO_DYLD_BIND_FULLY_IMAGE - /* FIXME: What should we do in this case? */ -# else - if (GC_no_dls) return; /* skip main data segment registration */ - - /* When the environment variable is set, the dynamic linker binds */ - /* all undefined symbols the application needs at launch time. */ - /* This includes function symbols that are normally bound lazily at */ - /* the time of their first invocation. */ - if (GETENV("DYLD_BIND_AT_LAUNCH") == 0) { - /* The environment variable is unset, so we should bind manually. */ -# ifdef DARWIN_DEBUG - GC_log_printf("Forcing full bind of GC code...\n"); -# endif - /* FIXME: '_dyld_bind_fully_image_containing_address' is deprecated. */ - if (!_dyld_bind_fully_image_containing_address( - (unsigned long *)GC_malloc)) - ABORT("_dyld_bind_fully_image_containing_address failed"); - } -# endif -} - -#define HAVE_REGISTER_MAIN_STATIC_DATA -GC_INNER GC_bool GC_register_main_static_data(void) -{ - /* Already done through dyld callbacks */ - return FALSE; -} - -#endif /* DARWIN */ - -#elif defined(PCR) - -# include "il/PCR_IL.h" -# include "th/PCR_ThCtl.h" -# include "mm/PCR_MM.h" - - GC_INNER void GC_register_dynamic_libraries(void) - { - /* Add new static data areas of dynamically loaded modules. */ - PCR_IL_LoadedFile * p = PCR_IL_GetLastLoadedFile(); - PCR_IL_LoadedSegment * q; - - /* Skip uncommitted files */ - while (p != NIL && !(p -> lf_commitPoint)) { - /* The loading of this file has not yet been committed */ - /* Hence its description could be inconsistent. */ - /* Furthermore, it hasn't yet been run. Hence its data */ - /* segments can't possibly reference heap allocated */ - /* objects. */ - p = p -> lf_prev; - } - for (; p != NIL; p = p -> lf_prev) { - for (q = p -> lf_ls; q != NIL; q = q -> ls_next) { - if ((q -> ls_flags & PCR_IL_SegFlags_Traced_MASK) - == PCR_IL_SegFlags_Traced_on) { - GC_add_roots_inner((char *)(q -> ls_addr), - (char *)(q -> ls_addr) + q -> ls_bytes, TRUE); - } - } - } - } -#endif /* PCR && !DYNAMIC_LOADING && !MSWIN32 */ - -#if !defined(HAVE_REGISTER_MAIN_STATIC_DATA) && defined(DYNAMIC_LOADING) - /* Do we need to separately register the main static data segment? */ - GC_INNER GC_bool GC_register_main_static_data(void) - { - return TRUE; - } -#endif /* HAVE_REGISTER_MAIN_STATIC_DATA */ - -/* Register a routine to filter dynamic library registration. */ -GC_API void GC_CALL GC_register_has_static_roots_callback( - GC_has_static_roots_func callback) -{ - GC_has_static_roots = callback; -} diff -Nru ecl-16.1.2/src/bdwgc/EMX_MAKEFILE ecl-16.1.3+ds/src/bdwgc/EMX_MAKEFILE --- ecl-16.1.2/src/bdwgc/EMX_MAKEFILE 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/EMX_MAKEFILE 1970-01-01 00:00:00.000000000 +0000 @@ -1,113 +0,0 @@ -# -# OS/2 specific Makefile for the EMX environment -# -# You need GNU Make 3.71, gcc 2.5.7, emx 0.8h and GNU fileutils 3.9 -# or similar tools. C++ interface and de.exe weren't tested. -# - -# Primary targets: -# gc.a - builds basic library -# c++ - adds C++ interface to library and include directory -# cords - adds cords (heavyweight strings) to library and include directory -# test - prints porting information, then builds basic version of gc.a, and runs -# some tests of collector and cords. Does not add cords or c++ interface to gc.a -# cord/de.exe - builds dumb editor based on cords. -CC= gcc -CXX=g++ -# Needed only for "make c++", which adds the c++ interface - -CFLAGS= -O -DALL_INTERIOR_POINTERS -I$(srcdir)/include -# Setjmp_test may yield overly optimistic results when compiled -# without optimization. - -CXXFLAGS= $(CFLAGS) -AR= ar -RANLIB= ar s - -# Redefining srcdir allows object code for the nonPCR version of the collector -# to be generated in different directories -srcdir = . -VPATH = $(srcdir) - -OBJS= alloc.o reclaim.o allchblk.o misc.o mach_dep.o os_dep.o mark_rts.o headers.o mark.o obj_map.o blacklst.o finalize.o new_hblk.o dyn_load.o dbg_mlc.o fnlz_mlc.o malloc.o stubborn.o checksums.o typd_mlc.o ptr_chck.o mallocx.o - -CORD_OBJS= cord/cordbscs.o cord/cordxtra.o cord/cordprnt.o - -CORD_INCLUDE_FILES= $(srcdir)/include/gc.h $(srcdir)/include/cord.h \ - $(srcdir)/include/ec.h $(srcdir)/include/cord_pos.h - -# Libraries needed for curses applications. Only needed for de. -CURSES= -lcurses -ltermlib - -SPECIALCFLAGS = -I$(srcdir)/include -# Alternative flags to the C compiler for mach_dep.c. -# Mach_dep.c often doesn't like optimization, and it's -# not time-critical anyway. - -all: gc.a gctest.exe - -$(OBJS) test.o: $(srcdir)/include/private/gc_priv.h \ - $(srcdir)/include/private/gc_hdrs.h $(srcdir)/include/gc.h \ - $(srcdir)/include/private/gcconfig.h $(srcdir)/include/gc_typed.h -# The dependency on Makefile is needed. Changing -# options affects the size of GC_arrays, -# invalidating all .o files that rely on gc_priv.h - -mark.o typd_mlc.o finalize.o: $(srcdir)/include/gc_mark.h $(srcdir)/include/private/gc_pmark.h - -gc.a: $(OBJS) - $(AR) ru gc.a $(OBJS) - $(RANLIB) gc.a - -cords: $(CORD_OBJS) cord/cordtest.exe - $(AR) ru gc.a $(CORD_OBJS) - $(RANLIB) gc.a - -gc_cpp.o: $(srcdir)/gc_cpp.cc $(srcdir)/include/gc_cpp.h - $(CXX) -c $(CXXFLAGS) $(srcdir)/gc_cpp.cc - -c++: gc_cpp.o $(srcdir)/include/gc_cpp.h - $(AR) ru gc.a gc_cpp.o - $(RANLIB) gc.a - -mach_dep.o: $(srcdir)/mach_dep.c - $(CC) -o mach_dep.o -c $(SPECIALCFLAGS) $(srcdir)/mach_dep.c - -mark_rts.o: $(srcdir)/mark_rts.c - $(CC) -o mark_rts.o -c $(CFLAGS) $(srcdir)/mark_rts.c - -cord/cordbscs.o: $(srcdir)/cord/cordbscs.c $(CORD_INCLUDE_FILES) - $(CC) $(CFLAGS) -c $(srcdir)/cord/cordbscs.c -o cord/cordbscs.o - -cord/cordxtra.o: $(srcdir)/cord/cordxtra.c $(CORD_INCLUDE_FILES) - $(CC) $(CFLAGS) -c $(srcdir)/cord/cordxtra.c -o cord/cordxtra.o - -cord/cordprnt.o: $(srcdir)/cord/cordprnt.c $(CORD_INCLUDE_FILES) - $(CC) $(CFLAGS) -c $(srcdir)/cord/cordprnt.c -o cord/cordprnt.o - -cord/cordtest.exe: $(srcdir)/cord/tests/cordtest.c $(CORD_OBJS) gc.a - $(CC) $(CFLAGS) -o cord/cordtest.exe $(srcdir)/cord/tests/cordtest.c $(CORD_OBJS) gc.a - -cord/de.exe: $(srcdir)/cord/tests/de.c $(srcdir)/cord/cordbscs.o $(srcdir)/cord/cordxtra.o gc.a - $(CC) $(CFLAGS) -o cord/de.exe $(srcdir)/cord/tests/de.c $(srcdir)/cord/cordbscs.o $(srcdir)/cord/cordxtra.o gc.a $(CURSES) - -clean: - rm -f gc.a tests/test.o gctest.exe output-local output-diff $(OBJS) \ - setjmp_test mon.out gmon.out a.out core \ - $(CORD_OBJS) cord/cordtest.exe cord/de.exe - -rm -f *~ - -gctest.exe: tests/test.o gc.a - $(CC) $(CFLAGS) -o gctest.exe tests/test.o gc.a - -# If an optimized setjmp_test generates a segmentation fault, -# odds are your compiler is broken. Gctest may still work. -# Try compiling setjmp_t.c unoptimized. -setjmp_test.exe: $(srcdir)/tools/setjmp_t.c $(srcdir)/include/gc.h - $(CC) $(CFLAGS) -o setjmp_test.exe $(srcdir)/tools/setjmp_t.c - -test: setjmp_test.exe gctest.exe - ./setjmp_test - ./gctest - make cord/cordtest.exe - cord/cordtest diff -Nru ecl-16.1.2/src/bdwgc/extra/AmigaOS.c ecl-16.1.3+ds/src/bdwgc/extra/AmigaOS.c --- ecl-16.1.2/src/bdwgc/extra/AmigaOS.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/extra/AmigaOS.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,548 +0,0 @@ - - -/****************************************************************** - - AmigaOS-specific routines for GC. - This file is normally included from os_dep.c - -******************************************************************/ - - -#if !defined(GC_AMIGA_DEF) && !defined(GC_AMIGA_SB) && !defined(GC_AMIGA_DS) && !defined(GC_AMIGA_AM) -# include "gc_priv.h" -# include -# include -# define GC_AMIGA_DEF -# define GC_AMIGA_SB -# define GC_AMIGA_DS -# define GC_AMIGA_AM -#endif - - -#ifdef GC_AMIGA_DEF - -# ifndef __GNUC__ -# include -# endif -# include -# include -# include -# include - -#endif - - - - -#ifdef GC_AMIGA_SB - -/****************************************************************** - Find the base of the stack. -******************************************************************/ - -ptr_t GC_get_main_stack_base() -{ - struct Process *proc = (struct Process*)SysBase->ThisTask; - - /* Reference: Amiga Guru Book Pages: 42,567,574 */ - if (proc->pr_Task.tc_Node.ln_Type==NT_PROCESS - && proc->pr_CLI != NULL) { - /* first ULONG is StackSize */ - /*longPtr = proc->pr_ReturnAddr; - size = longPtr[0];*/ - - return (char *)proc->pr_ReturnAddr + sizeof(ULONG); - } else { - return (char *)proc->pr_Task.tc_SPUpper; - } -} - -#endif - - -#ifdef GC_AMIGA_DS -/****************************************************************** - Register data segments. -******************************************************************/ - - void GC_register_data_segments() - { - struct Process *proc; - struct CommandLineInterface *cli; - BPTR myseglist; - ULONG *data; - - int num; - - -# ifdef __GNUC__ - ULONG dataSegSize; - GC_bool found_segment = FALSE; - extern char __data_size[]; - - dataSegSize=__data_size+8; - /* Can`t find the Location of __data_size, because - it`s possible that is it, inside the segment. */ - -# endif - - proc= (struct Process*)SysBase->ThisTask; - - /* Reference: Amiga Guru Book Pages: 538ff,565,573 - and XOper.asm */ - if (proc->pr_Task.tc_Node.ln_Type==NT_PROCESS) { - if (proc->pr_CLI == NULL) { - myseglist = proc->pr_SegList; - } else { - /* ProcLoaded 'Loaded as a command: '*/ - cli = BADDR(proc->pr_CLI); - myseglist = cli->cli_Module; - } - } else { - ABORT("Not a Process."); - } - - if (myseglist == NULL) { - ABORT("Arrrgh.. can't find segments, aborting"); - } - - /* xoper hunks Shell Process */ - - num=0; - for (data = (ULONG *)BADDR(myseglist); data != NULL; - data = (ULONG *)BADDR(data[0])) { - if (((ULONG) GC_register_data_segments < (ULONG) &data[1]) || - ((ULONG) GC_register_data_segments > (ULONG) &data[1] + data[-1])) { -# ifdef __GNUC__ - if (dataSegSize == data[-1]) { - found_segment = TRUE; - } -# endif - GC_add_roots_inner((char *)&data[1], - ((char *)&data[1]) + data[-1], FALSE); - } - ++num; - } /* for */ -# ifdef __GNUC__ - if (!found_segment) { - ABORT("Can`t find correct Segments.\nSolution: Use an newer version of ixemul.library"); - } -# endif - } - -#endif - - - -#ifdef GC_AMIGA_AM - -#ifndef GC_AMIGA_FASTALLOC - -void *GC_amiga_allocwrapper(size_t size,void *(*AllocFunction)(size_t size2)){ - return (*AllocFunction)(size); -} - -void *(*GC_amiga_allocwrapper_do)(size_t size,void *(*AllocFunction)(size_t size2)) - =GC_amiga_allocwrapper; - -#else - - - - -void *GC_amiga_allocwrapper_firsttime(size_t size,void *(*AllocFunction)(size_t size2)); - -void *(*GC_amiga_allocwrapper_do)(size_t size,void *(*AllocFunction)(size_t size2)) - =GC_amiga_allocwrapper_firsttime; - - -/****************************************************************** - Amiga-specific routines to obtain memory, and force GC to give - back fast-mem whenever possible. - These hacks makes gc-programs go many times faster when - the Amiga is low on memory, and are therefore strictly necessary. - - -Kjetil S. Matheussen, 2000. -******************************************************************/ - - - -/* List-header for all allocated memory. */ - -struct GC_Amiga_AllocedMemoryHeader{ - ULONG size; - struct GC_Amiga_AllocedMemoryHeader *next; -}; -struct GC_Amiga_AllocedMemoryHeader *GC_AMIGAMEM=(struct GC_Amiga_AllocedMemoryHeader *)(int)~(NULL); - - - -/* Type of memory. Once in the execution of a program, this might change to MEMF_ANY|MEMF_CLEAR */ - -ULONG GC_AMIGA_MEMF = MEMF_FAST | MEMF_CLEAR; - - -/* Prevents GC_amiga_get_mem from allocating memory if this one is TRUE. */ -#ifndef GC_AMIGA_ONLYFAST -BOOL GC_amiga_dontalloc=FALSE; -#endif - -#ifdef GC_AMIGA_PRINTSTATS -int succ=0,succ2=0; -int nsucc=0,nsucc2=0; -int nullretries=0; -int numcollects=0; -int chipa=0; -int allochip=0; -int allocfast=0; -int cur0=0; -int cur1=0; -int cur10=0; -int cur50=0; -int cur150=0; -int cur151=0; -int ncur0=0; -int ncur1=0; -int ncur10=0; -int ncur50=0; -int ncur150=0; -int ncur151=0; -#endif - -/* Free everything at program-end. */ - -void GC_amiga_free_all_mem(void){ - struct GC_Amiga_AllocedMemoryHeader *gc_am=(struct GC_Amiga_AllocedMemoryHeader *)(~(int)(GC_AMIGAMEM)); - struct GC_Amiga_AllocedMemoryHeader *temp; - -#ifdef GC_AMIGA_PRINTSTATS - printf("\n\n" - "%d bytes of chip-mem, and %d bytes of fast-mem where allocated from the OS.\n", - allochip,allocfast - ); - printf( - "%d bytes of chip-mem were returned from the GC_AMIGA_FASTALLOC supported allocating functions.\n", - chipa - ); - printf("\n"); - printf("GC_gcollect was called %d times to avoid returning NULL or start allocating with the MEMF_ANY flag.\n",numcollects); - printf("%d of them was a success. (the others had to use allocation from the OS.)\n",nullretries); - printf("\n"); - printf("Succeded forcing %d gc-allocations (%d bytes) of chip-mem to be fast-mem.\n",succ,succ2); - printf("Failed forcing %d gc-allocations (%d bytes) of chip-mem to be fast-mem.\n",nsucc,nsucc2); - printf("\n"); - printf( - "Number of retries before succeding a chip->fast force:\n" - "0: %d, 1: %d, 2-9: %d, 10-49: %d, 50-149: %d, >150: %d\n", - cur0,cur1,cur10,cur50,cur150,cur151 - ); - printf( - "Number of retries before giving up a chip->fast force:\n" - "0: %d, 1: %d, 2-9: %d, 10-49: %d, 50-149: %d, >150: %d\n", - ncur0,ncur1,ncur10,ncur50,ncur150,ncur151 - ); -#endif - - while(gc_am!=NULL){ - temp=gc_am->next; - FreeMem(gc_am,gc_am->size); - gc_am=(struct GC_Amiga_AllocedMemoryHeader *)(~(int)(temp)); - } -} - -#ifndef GC_AMIGA_ONLYFAST - -/* All memory with address lower than this one is chip-mem. */ - -char *chipmax; - - -/* - * Always set to the last size of memory tried to be allocated. - * Needed to ensure allocation when the size is bigger than 100000. - * - */ -size_t latestsize; - -#endif - - -/* - * The actual function that is called with the GET_MEM macro. - * - */ - -void *GC_amiga_get_mem(size_t size){ - struct GC_Amiga_AllocedMemoryHeader *gc_am; - -#ifndef GC_AMIGA_ONLYFAST - if(GC_amiga_dontalloc==TRUE){ -// printf("rejected, size: %d, latestsize: %d\n",size,latestsize); - return NULL; - } - - // We really don't want to use chip-mem, but if we must, then as little as possible. - if(GC_AMIGA_MEMF==(MEMF_ANY|MEMF_CLEAR) && size>100000 && latestsize<50000) return NULL; -#endif - - gc_am=AllocMem((ULONG)(size + sizeof(struct GC_Amiga_AllocedMemoryHeader)),GC_AMIGA_MEMF); - if(gc_am==NULL) return NULL; - - gc_am->next=GC_AMIGAMEM; - gc_am->size=size + sizeof(struct GC_Amiga_AllocedMemoryHeader); - GC_AMIGAMEM=(struct GC_Amiga_AllocedMemoryHeader *)(~(int)(gc_am)); - -// printf("Allocated %d (%d) bytes at address: %x. Latest: %d\n",size,tot,gc_am,latestsize); - -#ifdef GC_AMIGA_PRINTSTATS - if((char *)gc_amchipmax || ret==NULL){ - if(ret==NULL){ - nsucc++; - nsucc2+=size; - if(rec==0) ncur0++; - if(rec==1) ncur1++; - if(rec>1 && rec<10) ncur10++; - if(rec>=10 && rec<50) ncur50++; - if(rec>=50 && rec<150) ncur150++; - if(rec>=150) ncur151++; - }else{ - succ++; - succ2+=size; - if(rec==0) cur0++; - if(rec==1) cur1++; - if(rec>1 && rec<10) cur10++; - if(rec>=10 && rec<50) cur50++; - if(rec>=50 && rec<150) cur150++; - if(rec>=150) cur151++; - } - } -#endif - - if (((char *)ret)<=chipmax && ret!=NULL && (rec<(size>500000?9:size/5000))){ - ret=GC_amiga_rec_alloc(size,AllocFunction,rec+1); -// GC_free(ret2); - } - - return ret; -} -#endif - - -/* The allocating-functions defined inside the Amiga-blocks in gc.h is called - * via these functions. - */ - - -void *GC_amiga_allocwrapper_any(size_t size,void *(*AllocFunction)(size_t size2)){ - void *ret,*ret2; - - GC_amiga_dontalloc=TRUE; // Pretty tough thing to do, but its indeed necessary. - latestsize=size; - - ret=(*AllocFunction)(size); - - if(((char *)ret) <= chipmax){ - if(ret==NULL){ - //Give GC access to allocate memory. -#ifdef GC_AMIGA_GC - if(!GC_dont_gc){ - GC_gcollect(); -#ifdef GC_AMIGA_PRINTSTATS - numcollects++; -#endif - ret=(*AllocFunction)(size); - } -#endif - if(ret==NULL){ - GC_amiga_dontalloc=FALSE; - ret=(*AllocFunction)(size); - if(ret==NULL){ - WARN("Out of Memory! Returning NIL!\n", 0); - } - } -#ifdef GC_AMIGA_PRINTSTATS - else{ - nullretries++; - } - if(ret!=NULL && (char *)ret<=chipmax) chipa+=size; -#endif - } -#ifdef GC_AMIGA_RETRY - else{ - /* We got chip-mem. Better try again and again and again etc., we might get fast-mem sooner or later... */ - /* Using gctest to check the effectiveness of doing this, does seldom give a very good result. */ - /* However, real programs doesn't normally rapidly allocate and deallocate. */ -// printf("trying to force... %d bytes... ",size); - if( - AllocFunction!=GC_malloc_uncollectable -#ifdef ATOMIC_UNCOLLECTABLE - && AllocFunction!=GC_malloc_atomic_uncollectable -#endif - ){ - ret2=GC_amiga_rec_alloc(size,AllocFunction,0); - }else{ - ret2=(*AllocFunction)(size); -#ifdef GC_AMIGA_PRINTSTATS - if((char *)ret2chipmax){ -// printf("Succeeded.\n"); - GC_free(ret); - ret=ret2; - }else{ - GC_free(ret2); -// printf("But did not succeed.\n"); - } - } -#endif - } - - GC_amiga_dontalloc=FALSE; - - return ret; -} - - - -void (*GC_amiga_toany)(void)=NULL; - -void GC_amiga_set_toany(void (*func)(void)){ - GC_amiga_toany=func; -} - -#endif // !GC_AMIGA_ONLYFAST - - -void *GC_amiga_allocwrapper_fast(size_t size,void *(*AllocFunction)(size_t size2)){ - void *ret; - - ret=(*AllocFunction)(size); - - if(ret==NULL){ - // Enable chip-mem allocation. -// printf("ret==NULL\n"); -#ifdef GC_AMIGA_GC - if(!GC_dont_gc){ - GC_gcollect(); -#ifdef GC_AMIGA_PRINTSTATS - numcollects++; -#endif - ret=(*AllocFunction)(size); - } -#endif - if(ret==NULL){ -#ifndef GC_AMIGA_ONLYFAST - GC_AMIGA_MEMF=MEMF_ANY | MEMF_CLEAR; - if(GC_amiga_toany!=NULL) (*GC_amiga_toany)(); - GC_amiga_allocwrapper_do=GC_amiga_allocwrapper_any; - return GC_amiga_allocwrapper_any(size,AllocFunction); -#endif - } -#ifdef GC_AMIGA_PRINTSTATS - else{ - nullretries++; - } -#endif - } - - return ret; -} - -void *GC_amiga_allocwrapper_firsttime(size_t size,void *(*AllocFunction)(size_t size2)){ - atexit(&GC_amiga_free_all_mem); - chipmax=(char *)SysBase->MaxLocMem; // For people still having SysBase in chip-mem, this might speed up a bit. - GC_amiga_allocwrapper_do=GC_amiga_allocwrapper_fast; - return GC_amiga_allocwrapper_fast(size,AllocFunction); -} - - -#endif //GC_AMIGA_FASTALLOC - - - -/* - * The wrapped realloc function. - * - */ -void *GC_amiga_realloc(void *old_object,size_t new_size_in_bytes){ -#ifndef GC_AMIGA_FASTALLOC - return GC_realloc(old_object,new_size_in_bytes); -#else - void *ret; - latestsize=new_size_in_bytes; - ret=GC_realloc(old_object,new_size_in_bytes); - if(ret==NULL && GC_AMIGA_MEMF==(MEMF_FAST | MEMF_CLEAR)){ - /* Out of fast-mem. */ -#ifdef GC_AMIGA_GC - if(!GC_dont_gc){ - GC_gcollect(); -#ifdef GC_AMIGA_PRINTSTATS - numcollects++; -#endif - ret=GC_realloc(old_object,new_size_in_bytes); - } -#endif - if(ret==NULL){ -#ifndef GC_AMIGA_ONLYFAST - GC_AMIGA_MEMF=MEMF_ANY | MEMF_CLEAR; - if(GC_amiga_toany!=NULL) (*GC_amiga_toany)(); - GC_amiga_allocwrapper_do=GC_amiga_allocwrapper_any; - ret=GC_realloc(old_object,new_size_in_bytes); -#endif - } -#ifdef GC_AMIGA_PRINTSTATS - else{ - nullretries++; - } -#endif - } - if(ret==NULL){ - WARN("Out of Memory! Returning NIL!\n", 0); - } -#ifdef GC_AMIGA_PRINTSTATS - if(((char *)ret) - - 11/16/95 pcb Updated compilation flags to reflect latest 4.6 Makefile. - - by Patrick C. Beard. - */ -/* Boehm, November 17, 1995 12:10 pm PST */ - -#ifdef __MWERKS__ - -// for CodeWarrior Pro with Metrowerks Standard Library (MSL). -// #define MSL_USE_PRECOMPILED_HEADERS 0 -#include -#endif /* __MWERKS__ */ - -// these are defined again in gc_priv.h. -#undef TRUE -#undef FALSE - -#define ALL_INTERIOR_POINTERS // follows interior pointers. -//#define DONT_ADD_BYTE_AT_END // no padding. -//#define SMALL_CONFIG // whether to use a smaller heap. -#define USE_TEMPORARY_MEMORY // use Macintosh temporary memory. diff -Nru ecl-16.1.2/src/bdwgc/extra/MacOS.c ecl-16.1.3+ds/src/bdwgc/extra/MacOS.c --- ecl-16.1.2/src/bdwgc/extra/MacOS.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/extra/MacOS.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,157 +0,0 @@ -/* - MacOS.c - - Some routines for the Macintosh OS port of the Hans-J. Boehm, Alan J. Demers - garbage collector. - - - - 11/22/94 pcb StripAddress the temporary memory handle for 24-bit mode. - 11/30/94 pcb Tracking all memory usage so we can deallocate it all at once. - 02/10/96 pcb Added routine to perform a final collection when -unloading shared library. - - by Patrick C. Beard. - */ -/* Boehm, February 15, 1996 2:55 pm PST */ - -#include -#include -#include -#include -#include -#include - -#define GC_BUILD -#include "gc.h" -#include "gc_priv.h" - -// use 'CODE' resource 0 to get exact location of the beginning of global space. - -typedef struct { - unsigned long aboveA5; - unsigned long belowA5; - unsigned long JTSize; - unsigned long JTOffset; -} *CodeZeroPtr, **CodeZeroHandle; - -void* GC_MacGetDataStart() -{ - CodeZeroHandle code0 = (CodeZeroHandle)GetResource('CODE', 0); - if (code0) { - long belowA5Size = (**code0).belowA5; - ReleaseResource((Handle)code0); - return (LMGetCurrentA5() - belowA5Size); - } - fprintf(stderr, "Couldn't load the jump table."); - exit(-1); - return 0; -} - -/* track the use of temporary memory so it can be freed all at once. */ - -typedef struct TemporaryMemoryBlock TemporaryMemoryBlock, **TemporaryMemoryHandle; - -struct TemporaryMemoryBlock { - TemporaryMemoryHandle nextBlock; - char data[]; -}; - -static TemporaryMemoryHandle theTemporaryMemory = NULL; -static Boolean firstTime = true; - -void GC_MacFreeTemporaryMemory(void); - -Ptr GC_MacTemporaryNewPtr(size_t size, Boolean clearMemory) -{ - static Boolean firstTime = true; - OSErr result; - TemporaryMemoryHandle tempMemBlock; - Ptr tempPtr = nil; - - tempMemBlock = (TemporaryMemoryHandle)TempNewHandle(size + sizeof(TemporaryMemoryBlock), &result); - if (tempMemBlock && result == noErr) { - HLockHi((Handle)tempMemBlock); - tempPtr = (**tempMemBlock).data; - if (clearMemory) memset(tempPtr, 0, size); - tempPtr = StripAddress(tempPtr); - - // keep track of the allocated blocks. - (**tempMemBlock).nextBlock = theTemporaryMemory; - theTemporaryMemory = tempMemBlock; - } - -# if !defined(SHARED_LIBRARY_BUILD) - // install an exit routine to clean up the memory used at the end. - if (firstTime) { - atexit(&GC_MacFreeTemporaryMemory); - firstTime = false; - } -# endif - - return tempPtr; -} - -extern word GC_fo_entries; - -static void perform_final_collection() -{ - unsigned i; - word last_fo_entries = 0; - - /* adjust the stack bottom, because CFM calls us from another stack - location. */ - GC_stackbottom = (ptr_t)&i; - - /* try to collect and finalize everything in sight */ - for (i = 0; i < 2 || GC_fo_entries < last_fo_entries; i++) { - last_fo_entries = GC_fo_entries; - GC_gcollect(); - } -} - - -void GC_MacFreeTemporaryMemory() -{ -# if defined(SHARED_LIBRARY_BUILD) - /* if possible, collect all memory, and invoke all finalizers. */ - perform_final_collection(); -# endif - - if (theTemporaryMemory != NULL) { - long totalMemoryUsed = 0; - TemporaryMemoryHandle tempMemBlock = theTemporaryMemory; - while (tempMemBlock != NULL) { - TemporaryMemoryHandle nextBlock = (**tempMemBlock).nextBlock; - totalMemoryUsed += GetHandleSize((Handle)tempMemBlock); - DisposeHandle((Handle)tempMemBlock); - tempMemBlock = nextBlock; - } - theTemporaryMemory = NULL; - -# if !defined(SHARED_LIBRARY_BUILD) - if (GC_print_stats) { - fprintf(stdout, "[total memory used: %ld bytes.]\n", - totalMemoryUsed); - fprintf(stdout, "[total collections: %ld.]\n", GC_gc_no); - } -# endif - } -} - -#if __option(far_data) - - void* GC_MacGetDataEnd() - { - CodeZeroHandle code0 = (CodeZeroHandle)GetResource('CODE', 0); - if (code0) { - long aboveA5Size = (**code0).aboveA5; - ReleaseResource((Handle)code0); - return (LMGetCurrentA5() + aboveA5Size); - } - fprintf(stderr, "Couldn't load the jump table."); - exit(-1); - return 0; - } - -#endif /* __option(far_data) */ diff -Nru ecl-16.1.2/src/bdwgc/extra/msvc_dbg.c ecl-16.1.3+ds/src/bdwgc/extra/msvc_dbg.c --- ecl-16.1.2/src/bdwgc/extra/msvc_dbg.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/extra/msvc_dbg.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,381 +0,0 @@ -/* - Copyright (c) 2004 Andrei Polushin - - 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 - AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN - THE SOFTWARE. -*/ - -#if !defined(_M_AMD64) && defined(_MSC_VER) - -/* X86_64 is currently missing some meachine-dependent code below. */ - -#define GC_BUILD -#include "private/msvc_dbg.h" -#include "gc.h" - -#define WIN32_LEAN_AND_MEAN -#include - -#pragma pack(push, 8) -#include -#pragma pack(pop) - -#pragma comment(lib, "dbghelp.lib") -#pragma optimize("gy", off) - -typedef GC_word word; -#define GC_ULONG_PTR word - -#ifdef _WIN64 - typedef GC_ULONG_PTR ULONG_ADDR; -#else - typedef ULONG ULONG_ADDR; -#endif - -static HANDLE GetSymHandle() -{ - static HANDLE symHandle = NULL; - if (!symHandle) { - BOOL bRet = SymInitialize(symHandle = GetCurrentProcess(), NULL, FALSE); - if (bRet) { - DWORD dwOptions = SymGetOptions(); - dwOptions &= ~SYMOPT_UNDNAME; - dwOptions |= SYMOPT_LOAD_LINES; - SymSetOptions(dwOptions); - } - } - return symHandle; -} - -static void* CALLBACK FunctionTableAccess(HANDLE hProcess, - ULONG_ADDR dwAddrBase) -{ - return SymFunctionTableAccess(hProcess, dwAddrBase); -} - -static ULONG_ADDR CALLBACK GetModuleBase(HANDLE hProcess, ULONG_ADDR dwAddress) -{ - MEMORY_BASIC_INFORMATION memoryInfo; - ULONG_ADDR dwAddrBase = SymGetModuleBase(hProcess, dwAddress); - if (dwAddrBase) { - return dwAddrBase; - } - if (VirtualQueryEx(hProcess, (void*)(GC_ULONG_PTR)dwAddress, &memoryInfo, - sizeof(memoryInfo))) { - char filePath[_MAX_PATH]; - char curDir[_MAX_PATH]; - char exePath[_MAX_PATH]; - DWORD size = GetModuleFileNameA((HINSTANCE)memoryInfo.AllocationBase, - filePath, sizeof(filePath)); - - /* Save and restore current directory around SymLoadModule, see KB */ - /* article Q189780. */ - GetCurrentDirectoryA(sizeof(curDir), curDir); - GetModuleFileNameA(NULL, exePath, sizeof(exePath)); -#if defined(_MSC_VER) && _MSC_VER == 1200 - /* use strcat for VC6 */ - strcat(exePath, "\\.."); -#else - strcat_s(exePath, sizeof(exePath), "\\.."); -#endif /* _MSC_VER >= 1200 */ - SetCurrentDirectoryA(exePath); -#ifdef _DEBUG - GetCurrentDirectoryA(sizeof(exePath), exePath); -#endif - SymLoadModule(hProcess, NULL, size ? filePath : NULL, NULL, - (ULONG_ADDR)(GC_ULONG_PTR)memoryInfo.AllocationBase, 0); - SetCurrentDirectoryA(curDir); - } - return (ULONG_ADDR)(GC_ULONG_PTR)memoryInfo.AllocationBase; -} - -static ULONG_ADDR CheckAddress(void* address) -{ - ULONG_ADDR dwAddress = (ULONG_ADDR)(GC_ULONG_PTR)address; - GetModuleBase(GetSymHandle(), dwAddress); - return dwAddress; -} - -size_t GetStackFrames(size_t skip, void* frames[], size_t maxFrames) -{ - HANDLE hProcess = GetSymHandle(); - HANDLE hThread = GetCurrentThread(); - CONTEXT context; - context.ContextFlags = CONTEXT_FULL; - if (!GetThreadContext(hThread, &context)) { - return 0; - } - /* GetThreadContext might return invalid context for the current thread. */ -#if defined(_M_IX86) - __asm mov context.Ebp, ebp -#endif - return GetStackFramesFromContext(hProcess, hThread, &context, skip + 1, - frames, maxFrames); -} - -size_t GetStackFramesFromContext(HANDLE hProcess, HANDLE hThread, - CONTEXT* context, size_t skip, - void* frames[], size_t maxFrames) -{ - size_t frameIndex; - DWORD machineType; - STACKFRAME stackFrame = { 0 }; - stackFrame.AddrPC.Mode = AddrModeFlat; -#if defined(_M_IX86) - machineType = IMAGE_FILE_MACHINE_I386; - stackFrame.AddrPC.Offset = context->Eip; - stackFrame.AddrStack.Mode = AddrModeFlat; - stackFrame.AddrStack.Offset = context->Esp; - stackFrame.AddrFrame.Mode = AddrModeFlat; - stackFrame.AddrFrame.Offset = context->Ebp; -#elif defined(_M_MRX000) - machineType = IMAGE_FILE_MACHINE_R4000; - stackFrame.AddrPC.Offset = context->Fir; -#elif defined(_M_ALPHA) - machineType = IMAGE_FILE_MACHINE_ALPHA; - stackFrame.AddrPC.Offset = (unsigned long)context->Fir; -#elif defined(_M_PPC) - machineType = IMAGE_FILE_MACHINE_POWERPC; - stackFrame.AddrPC.Offset = context->Iar; -#elif defined(_M_IA64) - machineType = IMAGE_FILE_MACHINE_IA64; - stackFrame.AddrPC.Offset = context->StIIP; -#elif defined(_M_ALPHA64) - machineType = IMAGE_FILE_MACHINE_ALPHA64; - stackFrame.AddrPC.Offset = context->Fir; -#else -#error Unknown CPU -#endif - for (frameIndex = 0; frameIndex < maxFrames; ) { - BOOL bRet = StackWalk(machineType, hProcess, hThread, &stackFrame, - &context, NULL, FunctionTableAccess, GetModuleBase, NULL); - if (!bRet) { - break; - } - if (skip) { - skip--; - } else { - frames[frameIndex++] = (void*)(GC_ULONG_PTR)stackFrame.AddrPC.Offset; - } - } - return frameIndex; -} - -size_t GetModuleNameFromAddress(void* address, char* moduleName, size_t size) -{ - if (size) *moduleName = 0; - { - const char* sourceName; - IMAGEHLP_MODULE moduleInfo = { sizeof (moduleInfo) }; - if (!SymGetModuleInfo(GetSymHandle(), CheckAddress(address), - &moduleInfo)) { - return 0; - } - sourceName = strrchr(moduleInfo.ImageName, '\\'); - if (sourceName) { - sourceName++; - } else { - sourceName = moduleInfo.ImageName; - } - if (size) { - strncpy(moduleName, sourceName, size)[size - 1] = 0; - } - return strlen(sourceName); - } -} - -size_t GetModuleNameFromStack(size_t skip, char* moduleName, size_t size) -{ - void* address = NULL; - GetStackFrames(skip + 1, &address, 1); - if (address) { - return GetModuleNameFromAddress(address, moduleName, size); - } - return 0; -} - -size_t GetSymbolNameFromAddress(void* address, char* symbolName, size_t size, - size_t* offsetBytes) -{ - if (size) *symbolName = 0; - if (offsetBytes) *offsetBytes = 0; - __try { - ULONG_ADDR dwOffset = 0; - union { - IMAGEHLP_SYMBOL sym; - char symNameBuffer[sizeof(IMAGEHLP_SYMBOL) + MAX_SYM_NAME]; - } u; - u.sym.SizeOfStruct = sizeof(u.sym); - u.sym.MaxNameLength = sizeof(u.symNameBuffer) - sizeof(u.sym); - - if (!SymGetSymFromAddr(GetSymHandle(), CheckAddress(address), &dwOffset, - &u.sym)) { - return 0; - } else { - const char* sourceName = u.sym.Name; - char undName[1024]; - if (UnDecorateSymbolName(u.sym.Name, undName, sizeof(undName), - UNDNAME_NO_MS_KEYWORDS | UNDNAME_NO_ACCESS_SPECIFIERS)) { - sourceName = undName; - } else if (SymUnDName(&u.sym, undName, sizeof(undName))) { - sourceName = undName; - } - if (offsetBytes) { - *offsetBytes = dwOffset; - } - if (size) { - strncpy(symbolName, sourceName, size)[size - 1] = 0; - } - return strlen(sourceName); - } - } __except (EXCEPTION_EXECUTE_HANDLER) { - SetLastError(GetExceptionCode()); - } - return 0; -} - -size_t GetSymbolNameFromStack(size_t skip, char* symbolName, size_t size, - size_t* offsetBytes) -{ - void* address = NULL; - GetStackFrames(skip + 1, &address, 1); - if (address) { - return GetSymbolNameFromAddress(address, symbolName, size, offsetBytes); - } - return 0; -} - -size_t GetFileLineFromAddress(void* address, char* fileName, size_t size, - size_t* lineNumber, size_t* offsetBytes) -{ - if (size) *fileName = 0; - if (lineNumber) *lineNumber = 0; - if (offsetBytes) *offsetBytes = 0; - { - char* sourceName; - IMAGEHLP_LINE line = { sizeof (line) }; - GC_ULONG_PTR dwOffset = 0; - if (!SymGetLineFromAddr(GetSymHandle(), CheckAddress(address), &dwOffset, - &line)) { - return 0; - } - if (lineNumber) { - *lineNumber = line.LineNumber; - } - if (offsetBytes) { - *offsetBytes = dwOffset; - } - sourceName = line.FileName; - /* TODO: resolve relative filenames, found in 'source directories' */ - /* registered with MSVC IDE. */ - if (size) { - strncpy(fileName, sourceName, size)[size - 1] = 0; - } - return strlen(sourceName); - } -} - -size_t GetFileLineFromStack(size_t skip, char* fileName, size_t size, - size_t* lineNumber, size_t* offsetBytes) -{ - void* address = NULL; - GetStackFrames(skip + 1, &address, 1); - if (address) { - return GetFileLineFromAddress(address, fileName, size, lineNumber, - offsetBytes); - } - return 0; -} - -size_t GetDescriptionFromAddress(void* address, const char* format, - char* buffer, size_t size) -{ - char*const begin = buffer; - char*const end = buffer + size; - size_t line_number = 0; - char str[128]; - - if (size) { - *buffer = 0; - } - buffer += GetFileLineFromAddress(address, buffer, size, &line_number, NULL); - size = (GC_ULONG_PTR)end < (GC_ULONG_PTR)buffer ? 0 : end - buffer; - - if (line_number) { - wsprintf(str, "(%d) : ", line_number); - if (size) { - strncpy(buffer, str, size)[size - 1] = 0; - } - buffer += strlen(str); - size = (GC_ULONG_PTR)end < (GC_ULONG_PTR)buffer ? 0 : end - buffer; - } - - if (size) { - strncpy(buffer, "at ", size)[size - 1] = 0; - } - buffer += strlen("at "); - size = (GC_ULONG_PTR)end < (GC_ULONG_PTR)buffer ? 0 : end - buffer; - - buffer += GetSymbolNameFromAddress(address, buffer, size, NULL); - size = (GC_ULONG_PTR)end < (GC_ULONG_PTR)buffer ? 0 : end - buffer; - - if (size) { - strncpy(buffer, " in ", size)[size - 1] = 0; - } - buffer += strlen(" in "); - size = (GC_ULONG_PTR)end < (GC_ULONG_PTR)buffer ? 0 : end - buffer; - - buffer += GetModuleNameFromAddress(address, buffer, size); - size = (GC_ULONG_PTR)end < (GC_ULONG_PTR)buffer ? 0 : end - buffer; - - return buffer - begin; -} - -size_t GetDescriptionFromStack(void* const frames[], size_t count, - const char* format, char* description[], - size_t size) -{ - char*const begin = (char*)description; - char*const end = begin + size; - char* buffer = begin + (count + 1) * sizeof(char*); - size_t i; - for (i = 0; i < count; ++i) { - if (description) description[i] = buffer; - size = (GC_ULONG_PTR)end < (GC_ULONG_PTR)buffer ? 0 : end - buffer; - buffer += 1 + GetDescriptionFromAddress(frames[i], NULL, buffer, size); - } - if (description) description[count] = NULL; - return buffer - begin; -} - -/* Compatibility with */ - -int backtrace(void* addresses[], int count) -{ - return GetStackFrames(1, addresses, count); -} - -char** backtrace_symbols(void*const* addresses, int count) -{ - size_t size = GetDescriptionFromStack(addresses, count, NULL, NULL, 0); - char** symbols = (char**)malloc(size); - GetDescriptionFromStack(addresses, count, NULL, symbols, size); - return symbols; -} - -#endif /* !_M_AMD64 */ diff -Nru ecl-16.1.2/src/bdwgc/extra/symbian/global_end.cpp ecl-16.1.3+ds/src/bdwgc/extra/symbian/global_end.cpp --- ecl-16.1.2/src/bdwgc/extra/symbian/global_end.cpp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/extra/symbian/global_end.cpp 1970-01-01 00:00:00.000000000 +0000 @@ -1,16 +0,0 @@ -// Symbian-specific file. - -// INCLUDE FILES -#include "private/gcconfig.h" - -#ifdef __cplusplus -extern "C" { -#endif - -int winscw_data_end; - -#ifdef __cplusplus - } -#endif - -// End Of File diff -Nru ecl-16.1.2/src/bdwgc/extra/symbian/global_start.cpp ecl-16.1.3+ds/src/bdwgc/extra/symbian/global_start.cpp --- ecl-16.1.2/src/bdwgc/extra/symbian/global_start.cpp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/extra/symbian/global_start.cpp 1970-01-01 00:00:00.000000000 +0000 @@ -1,16 +0,0 @@ -// Symbian-specific file. - -// INCLUDE FILES -#include "private/gcconfig.h" - -#ifdef __cplusplus -extern "C" { -#endif - -int winscw_data_start; - -#ifdef __cplusplus - } -#endif - -// End Of File diff -Nru ecl-16.1.2/src/bdwgc/extra/symbian/init_global_static_roots.cpp ecl-16.1.3+ds/src/bdwgc/extra/symbian/init_global_static_roots.cpp --- ecl-16.1.2/src/bdwgc/extra/symbian/init_global_static_roots.cpp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/extra/symbian/init_global_static_roots.cpp 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -// Symbian-specific file. - -// INCLUDE FILES -#include - -#include "private/gcconfig.h" -#include "gc.h" - -#ifdef __cplusplus -extern "C" { -#endif - -void GC_init_global_static_roots() -{ - ptr_t dataStart = NULL; - ptr_t dataEnd = NULL; -# if defined (__WINS__) - extern int winscw_data_start, winscw_data_end; - dataStart = ((ptr_t)&winscw_data_start); - dataEnd = ((ptr_t)&winscw_data_end); -# else - extern int Image$$RW$$Limit[], Image$$RW$$Base[]; - dataStart = ((ptr_t)Image$$RW$$Base); - dataEnd = ((ptr_t)Image$$RW$$Limit); -# endif - - GC_add_roots(dataStart, dataEnd); - -} - -#ifdef __cplusplus - } -#endif diff -Nru ecl-16.1.2/src/bdwgc/extra/symbian.cpp ecl-16.1.3+ds/src/bdwgc/extra/symbian.cpp --- ecl-16.1.2/src/bdwgc/extra/symbian.cpp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/extra/symbian.cpp 1970-01-01 00:00:00.000000000 +0000 @@ -1,55 +0,0 @@ - -#include -#include -#include -#include -#include -#include - -#ifdef __cplusplus -extern "C" { -#endif - -int GC_get_main_symbian_stack_base() - { - TThreadStackInfo aInfo; - TInt err = RThread().StackInfo(aInfo); - if ( !err ) - { - return aInfo.iBase; - } - else - { - return 0; - } - } - -char* GC_get_private_path_and_zero_file() - { - // always on c: drive - RFs fs; - fs.Connect(); - fs.CreatePrivatePath( EDriveC ); - TFileName path; - fs.PrivatePath( path ); - fs.Close(); - _LIT( KCDrive, "c:" ); - path.Insert( 0, KCDrive ); - - - //convert to char*, assume ascii - TBuf8 path8; - path8.Copy( path ); - _LIT8( KZero8, "zero" ); - path8.Append( KZero8 ); - - size_t size = path8.Length() + 1; - char* copyChar = (char*) malloc( size ); - memcpy( copyChar, path8.PtrZ(), size ); - - return copyChar; // ownership passed - } - -#ifdef __cplusplus - } -#endif diff -Nru ecl-16.1.2/src/bdwgc/finalize.c ecl-16.1.3+ds/src/bdwgc/finalize.c --- ecl-16.1.2/src/bdwgc/finalize.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/finalize.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,1114 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1996 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (C) 2007 Free Software Foundation, Inc - - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#include "private/gc_pmark.h" - -#ifndef GC_NO_FINALIZATION - -/* Type of mark procedure used for marking from finalizable object. */ -/* This procedure normally does not mark the object, only its */ -/* descendants. */ -typedef void (* finalization_mark_proc)(ptr_t /* finalizable_obj_ptr */); - -#define HASH3(addr,size,log_size) \ - ((((word)(addr) >> 3) ^ ((word)(addr) >> (3 + (log_size)))) \ - & ((size) - 1)) -#define HASH2(addr,log_size) HASH3(addr, 1 << (log_size), log_size) - -struct hash_chain_entry { - word hidden_key; - struct hash_chain_entry * next; -}; - -struct disappearing_link { - struct hash_chain_entry prolog; -# define dl_hidden_link prolog.hidden_key - /* Field to be cleared. */ -# define dl_next(x) (struct disappearing_link *)((x) -> prolog.next) -# define dl_set_next(x, y) \ - (void)((x)->prolog.next = (struct hash_chain_entry *)(y)) - word dl_hidden_obj; /* Pointer to object base */ -}; - -struct dl_hashtbl_s { - struct disappearing_link **head; - signed_word log_size; - word entries; -}; - -STATIC struct dl_hashtbl_s GC_dl_hashtbl = { - /* head */ NULL, /* log_size */ -1, /* entries */ 0 }; -#ifndef GC_LONG_REFS_NOT_NEEDED - STATIC struct dl_hashtbl_s GC_ll_hashtbl = { NULL, -1, 0 }; -#endif - -STATIC struct finalizable_object { - struct hash_chain_entry prolog; -# define fo_hidden_base prolog.hidden_key - /* Pointer to object base. */ - /* No longer hidden once object */ - /* is on finalize_now queue. */ -# define fo_next(x) (struct finalizable_object *)((x) -> prolog.next) -# define fo_set_next(x,y) ((x)->prolog.next = (struct hash_chain_entry *)(y)) - GC_finalization_proc fo_fn; /* Finalizer. */ - ptr_t fo_client_data; - word fo_object_size; /* In bytes. */ - finalization_mark_proc fo_mark_proc; /* Mark-through procedure */ -} **GC_fo_head = 0; - -STATIC struct finalizable_object * GC_finalize_now = 0; - /* List of objects that should be finalized now. */ - -static signed_word log_fo_table_size = -1; - -GC_INNER void GC_push_finalizer_structures(void) -{ - GC_ASSERT((word)&GC_dl_hashtbl.head % sizeof(word) == 0); - GC_ASSERT((word)&GC_fo_head % sizeof(word) == 0); - GC_ASSERT((word)&GC_finalize_now % sizeof(word) == 0); - -# ifndef GC_LONG_REFS_NOT_NEEDED - GC_ASSERT((word)&GC_ll_hashtbl.head % sizeof(word) == 0); - GC_push_all((ptr_t)(&GC_ll_hashtbl.head), - (ptr_t)(&GC_ll_hashtbl.head) + sizeof(word)); -# endif - - GC_push_all((ptr_t)(&GC_dl_hashtbl.head), - (ptr_t)(&GC_dl_hashtbl.head) + sizeof(word)); - GC_push_all((ptr_t)(&GC_fo_head), (ptr_t)(&GC_fo_head) + sizeof(word)); - GC_push_all((ptr_t)(&GC_finalize_now), - (ptr_t)(&GC_finalize_now) + sizeof(word)); -} - -/* Double the size of a hash table. *size_ptr is the log of its current */ -/* size. May be a no-op. */ -/* *table is a pointer to an array of hash headers. If we succeed, we */ -/* update both *table and *log_size_ptr. Lock is held. */ -STATIC void GC_grow_table(struct hash_chain_entry ***table, - signed_word *log_size_ptr) -{ - register word i; - register struct hash_chain_entry *p; - signed_word log_old_size = *log_size_ptr; - signed_word log_new_size = log_old_size + 1; - word old_size = ((log_old_size == -1)? 0: (1 << log_old_size)); - word new_size = (word)1 << log_new_size; - /* FIXME: Power of 2 size often gets rounded up to one more page. */ - struct hash_chain_entry **new_table = (struct hash_chain_entry **) - GC_INTERNAL_MALLOC_IGNORE_OFF_PAGE( - (size_t)new_size * sizeof(struct hash_chain_entry *), NORMAL); - - if (new_table == 0) { - if (*table == 0) { - ABORT("Insufficient space for initial table allocation"); - } else { - return; - } - } - for (i = 0; i < old_size; i++) { - p = (*table)[i]; - while (p != 0) { - ptr_t real_key = GC_REVEAL_POINTER(p -> hidden_key); - struct hash_chain_entry *next = p -> next; - size_t new_hash = HASH3(real_key, new_size, log_new_size); - - p -> next = new_table[new_hash]; - new_table[new_hash] = p; - p = next; - } - } - *log_size_ptr = log_new_size; - *table = new_table; -} - -GC_API int GC_CALL GC_register_disappearing_link(void * * link) -{ - ptr_t base; - - base = (ptr_t)GC_base(link); - if (base == 0) - ABORT("Bad arg to GC_register_disappearing_link"); - return(GC_general_register_disappearing_link(link, base)); -} - -STATIC int GC_register_disappearing_link_inner( - struct dl_hashtbl_s *dl_hashtbl, void **link, - const void *obj) -{ - struct disappearing_link *curr_dl; - size_t index; - struct disappearing_link * new_dl; - DCL_LOCK_STATE; - - LOCK(); - GC_ASSERT(obj != NULL && GC_base_C(obj) == obj); - if (dl_hashtbl -> log_size == -1 - || dl_hashtbl -> entries > ((word)1 << dl_hashtbl -> log_size)) { - GC_grow_table((struct hash_chain_entry ***)&dl_hashtbl -> head, - &dl_hashtbl -> log_size); - GC_COND_LOG_PRINTF("Grew dl table to %u entries\n", - 1 << (unsigned)dl_hashtbl -> log_size); - } - index = HASH2(link, dl_hashtbl -> log_size); - for (curr_dl = dl_hashtbl -> head[index]; curr_dl != 0; - curr_dl = dl_next(curr_dl)) { - if (curr_dl -> dl_hidden_link == GC_HIDE_POINTER(link)) { - curr_dl -> dl_hidden_obj = GC_HIDE_POINTER(obj); - UNLOCK(); - return GC_DUPLICATE; - } - } - new_dl = (struct disappearing_link *) - GC_INTERNAL_MALLOC(sizeof(struct disappearing_link),NORMAL); - if (0 == new_dl) { - GC_oom_func oom_fn = GC_oom_fn; - UNLOCK(); - new_dl = (struct disappearing_link *) - (*oom_fn)(sizeof(struct disappearing_link)); - if (0 == new_dl) { - return GC_NO_MEMORY; - } - /* It's not likely we'll make it here, but ... */ - LOCK(); - /* Recalculate index since the table may grow. */ - index = HASH2(link, dl_hashtbl -> log_size); - /* Check again that our disappearing link not in the table. */ - for (curr_dl = dl_hashtbl -> head[index]; curr_dl != 0; - curr_dl = dl_next(curr_dl)) { - if (curr_dl -> dl_hidden_link == GC_HIDE_POINTER(link)) { - curr_dl -> dl_hidden_obj = GC_HIDE_POINTER(obj); - UNLOCK(); -# ifndef DBG_HDRS_ALL - /* Free unused new_dl returned by GC_oom_fn() */ - GC_free((void *)new_dl); -# endif - return GC_DUPLICATE; - } - } - } - new_dl -> dl_hidden_obj = GC_HIDE_POINTER(obj); - new_dl -> dl_hidden_link = GC_HIDE_POINTER(link); - dl_set_next(new_dl, dl_hashtbl -> head[index]); - dl_hashtbl -> head[index] = new_dl; - dl_hashtbl -> entries++; - UNLOCK(); - return GC_SUCCESS; -} - -GC_API int GC_CALL GC_general_register_disappearing_link(void * * link, - const void * obj) -{ - if (((word)link & (ALIGNMENT-1)) != 0 || NULL == link) - ABORT("Bad arg to GC_general_register_disappearing_link"); - return GC_register_disappearing_link_inner(&GC_dl_hashtbl, link, obj); -} - -#ifdef DBG_HDRS_ALL -# define FREE_DL_ENTRY(curr_dl) dl_set_next(curr_dl, NULL) -#else -# define FREE_DL_ENTRY(curr_dl) GC_free(curr_dl) -#endif - -/* Unregisters given link and returns the link entry to free. */ -/* Assume the lock is held. */ -GC_INLINE struct disappearing_link *GC_unregister_disappearing_link_inner( - struct dl_hashtbl_s *dl_hashtbl, void **link) -{ - struct disappearing_link *curr_dl; - struct disappearing_link *prev_dl = NULL; - size_t index = HASH2(link, dl_hashtbl->log_size); - - for (curr_dl = dl_hashtbl -> head[index]; curr_dl; - curr_dl = dl_next(curr_dl)) { - if (curr_dl -> dl_hidden_link == GC_HIDE_POINTER(link)) { - /* Remove found entry from the table. */ - if (NULL == prev_dl) { - dl_hashtbl -> head[index] = dl_next(curr_dl); - } else { - dl_set_next(prev_dl, dl_next(curr_dl)); - } - dl_hashtbl -> entries--; - break; - } - prev_dl = curr_dl; - } - return curr_dl; -} - -GC_API int GC_CALL GC_unregister_disappearing_link(void * * link) -{ - struct disappearing_link *curr_dl; - DCL_LOCK_STATE; - - if (((word)link & (ALIGNMENT-1)) != 0) return(0); /* Nothing to do. */ - - LOCK(); - curr_dl = GC_unregister_disappearing_link_inner(&GC_dl_hashtbl, link); - UNLOCK(); - if (NULL == curr_dl) return 0; - FREE_DL_ENTRY(curr_dl); - return 1; -} - -#ifndef GC_LONG_REFS_NOT_NEEDED - GC_API int GC_CALL GC_register_long_link(void * * link, const void * obj) - { - if (((word)link & (ALIGNMENT-1)) != 0 || NULL == link) - ABORT("Bad arg to GC_register_long_link"); - return GC_register_disappearing_link_inner(&GC_ll_hashtbl, link, obj); - } - - GC_API int GC_CALL GC_unregister_long_link(void * * link) - { - struct disappearing_link *curr_dl; - DCL_LOCK_STATE; - - if (((word)link & (ALIGNMENT-1)) != 0) return(0); /* Nothing to do. */ - - LOCK(); - curr_dl = GC_unregister_disappearing_link_inner(&GC_ll_hashtbl, link); - UNLOCK(); - if (NULL == curr_dl) return 0; - FREE_DL_ENTRY(curr_dl); - return 1; - } -#endif /* !GC_LONG_REFS_NOT_NEEDED */ - -#ifndef GC_MOVE_DISAPPEARING_LINK_NOT_NEEDED - /* Moves a link. Assume the lock is held. */ - STATIC int GC_move_disappearing_link_inner( - struct dl_hashtbl_s *dl_hashtbl, - void **link, void **new_link) - { - struct disappearing_link *curr_dl, *prev_dl, *new_dl; - size_t curr_index, new_index; - word curr_hidden_link; - word new_hidden_link; - - /* Find current link. */ - curr_index = HASH2(link, dl_hashtbl -> log_size); - curr_hidden_link = GC_HIDE_POINTER(link); - prev_dl = NULL; - for (curr_dl = dl_hashtbl -> head[curr_index]; curr_dl; - curr_dl = dl_next(curr_dl)) { - if (curr_dl -> dl_hidden_link == curr_hidden_link) - break; - prev_dl = curr_dl; - } - - if (NULL == curr_dl) { - return GC_NOT_FOUND; - } - - if (link == new_link) { - return GC_SUCCESS; /* Nothing to do. */ - } - - /* link found; now check new_link not present. */ - new_index = HASH2(new_link, dl_hashtbl -> log_size); - new_hidden_link = GC_HIDE_POINTER(new_link); - for (new_dl = dl_hashtbl -> head[new_index]; new_dl; - new_dl = dl_next(new_dl)) { - if (new_dl -> dl_hidden_link == new_hidden_link) { - /* Target already registered; bail. */ - return GC_DUPLICATE; - } - } - - /* Remove from old, add to new, update link. */ - if (NULL == prev_dl) { - dl_hashtbl -> head[curr_index] = dl_next(curr_dl); - } else { - dl_set_next(prev_dl, dl_next(curr_dl)); - } - curr_dl -> dl_hidden_link = new_hidden_link; - dl_set_next(curr_dl, dl_hashtbl -> head[new_index]); - dl_hashtbl -> head[new_index] = curr_dl; - return GC_SUCCESS; - } - - GC_API int GC_CALL GC_move_disappearing_link(void **link, void **new_link) - { - int result; - DCL_LOCK_STATE; - - if (((word)new_link & (ALIGNMENT-1)) != 0 || new_link == NULL) - ABORT("Bad new_link arg to GC_move_disappearing_link"); - if (((word)link & (ALIGNMENT-1)) != 0) - return GC_NOT_FOUND; /* Nothing to do. */ - - LOCK(); - result = GC_move_disappearing_link_inner(&GC_dl_hashtbl, link, new_link); - UNLOCK(); - return result; - } - -# ifndef GC_LONG_REFS_NOT_NEEDED - GC_API int GC_CALL GC_move_long_link(void **link, void **new_link) - { - int result; - DCL_LOCK_STATE; - - if (((word)new_link & (ALIGNMENT-1)) != 0 || new_link == NULL) - ABORT("Bad new_link arg to GC_move_disappearing_link"); - if (((word)link & (ALIGNMENT-1)) != 0) - return GC_NOT_FOUND; /* Nothing to do. */ - - LOCK(); - result = GC_move_disappearing_link_inner(&GC_ll_hashtbl, link, new_link); - UNLOCK(); - return result; - } -# endif /* !GC_LONG_REFS_NOT_NEEDED */ -#endif /* !GC_MOVE_DISAPPEARING_LINK_NOT_NEEDED */ - -/* Possible finalization_marker procedures. Note that mark stack */ -/* overflow is handled by the caller, and is not a disaster. */ -STATIC void GC_normal_finalize_mark_proc(ptr_t p) -{ - hdr * hhdr = HDR(p); - - PUSH_OBJ(p, hhdr, GC_mark_stack_top, - &(GC_mark_stack[GC_mark_stack_size])); -} - -/* This only pays very partial attention to the mark descriptor. */ -/* It does the right thing for normal and atomic objects, and treats */ -/* most others as normal. */ -STATIC void GC_ignore_self_finalize_mark_proc(ptr_t p) -{ - hdr * hhdr = HDR(p); - word descr = hhdr -> hb_descr; - ptr_t q; - word r; - ptr_t scan_limit; - ptr_t target_limit = p + hhdr -> hb_sz - 1; - - if ((descr & GC_DS_TAGS) == GC_DS_LENGTH) { - scan_limit = p + descr - sizeof(word); - } else { - scan_limit = target_limit + 1 - sizeof(word); - } - for (q = p; (word)q <= (word)scan_limit; q += ALIGNMENT) { - r = *(word *)q; - if (r < (word)p || r > (word)target_limit) { - GC_PUSH_ONE_HEAP(r, q, GC_mark_stack_top); - } - } -} - -STATIC void GC_null_finalize_mark_proc(ptr_t p GC_ATTR_UNUSED) {} - -/* Possible finalization_marker procedures. Note that mark stack */ -/* overflow is handled by the caller, and is not a disaster. */ - -/* GC_unreachable_finalize_mark_proc is an alias for normal marking, */ -/* but it is explicitly tested for, and triggers different */ -/* behavior. Objects registered in this way are not finalized */ -/* if they are reachable by other finalizable objects, even if those */ -/* other objects specify no ordering. */ -STATIC void GC_unreachable_finalize_mark_proc(ptr_t p) -{ - GC_normal_finalize_mark_proc(p); -} - -/* Register a finalization function. See gc.h for details. */ -/* The last parameter is a procedure that determines */ -/* marking for finalization ordering. Any objects marked */ -/* by that procedure will be guaranteed to not have been */ -/* finalized when this finalizer is invoked. */ -STATIC void GC_register_finalizer_inner(void * obj, - GC_finalization_proc fn, void *cd, - GC_finalization_proc *ofn, void **ocd, - finalization_mark_proc mp) -{ - ptr_t base; - struct finalizable_object * curr_fo, * prev_fo; - size_t index; - struct finalizable_object *new_fo = 0; - hdr *hhdr = NULL; /* initialized to prevent warning. */ - GC_oom_func oom_fn; - DCL_LOCK_STATE; - - LOCK(); - if (log_fo_table_size == -1 - || GC_fo_entries > ((word)1 << log_fo_table_size)) { - GC_grow_table((struct hash_chain_entry ***)&GC_fo_head, - &log_fo_table_size); - GC_COND_LOG_PRINTF("Grew fo table to %u entries\n", - 1 << (unsigned)log_fo_table_size); - } - /* in the THREADS case we hold allocation lock. */ - base = (ptr_t)obj; - for (;;) { - index = HASH2(base, log_fo_table_size); - prev_fo = 0; - curr_fo = GC_fo_head[index]; - while (curr_fo != 0) { - GC_ASSERT(GC_size(curr_fo) >= sizeof(struct finalizable_object)); - if (curr_fo -> fo_hidden_base == GC_HIDE_POINTER(base)) { - /* Interruption by a signal in the middle of this */ - /* should be safe. The client may see only *ocd */ - /* updated, but we'll declare that to be his problem. */ - if (ocd) *ocd = (void *) (curr_fo -> fo_client_data); - if (ofn) *ofn = curr_fo -> fo_fn; - /* Delete the structure for base. */ - if (prev_fo == 0) { - GC_fo_head[index] = fo_next(curr_fo); - } else { - fo_set_next(prev_fo, fo_next(curr_fo)); - } - if (fn == 0) { - GC_fo_entries--; - /* May not happen if we get a signal. But a high */ - /* estimate will only make the table larger than */ - /* necessary. */ -# if !defined(THREADS) && !defined(DBG_HDRS_ALL) - GC_free((void *)curr_fo); -# endif - } else { - curr_fo -> fo_fn = fn; - curr_fo -> fo_client_data = (ptr_t)cd; - curr_fo -> fo_mark_proc = mp; - /* Reinsert it. We deleted it first to maintain */ - /* consistency in the event of a signal. */ - if (prev_fo == 0) { - GC_fo_head[index] = curr_fo; - } else { - fo_set_next(prev_fo, curr_fo); - } - } - UNLOCK(); -# ifndef DBG_HDRS_ALL - if (EXPECT(new_fo != 0, FALSE)) { - /* Free unused new_fo returned by GC_oom_fn() */ - GC_free((void *)new_fo); - } -# endif - return; - } - prev_fo = curr_fo; - curr_fo = fo_next(curr_fo); - } - if (EXPECT(new_fo != 0, FALSE)) { - /* new_fo is returned by GC_oom_fn(), so fn != 0 and hhdr != 0. */ - break; - } - if (fn == 0) { - if (ocd) *ocd = 0; - if (ofn) *ofn = 0; - UNLOCK(); - return; - } - GET_HDR(base, hhdr); - if (EXPECT(0 == hhdr, FALSE)) { - /* We won't collect it, hence finalizer wouldn't be run. */ - if (ocd) *ocd = 0; - if (ofn) *ofn = 0; - UNLOCK(); - return; - } - new_fo = (struct finalizable_object *) - GC_INTERNAL_MALLOC(sizeof(struct finalizable_object),NORMAL); - if (EXPECT(new_fo != 0, TRUE)) - break; - oom_fn = GC_oom_fn; - UNLOCK(); - new_fo = (struct finalizable_object *) - (*oom_fn)(sizeof(struct finalizable_object)); - if (0 == new_fo) { - /* No enough memory. *ocd and *ofn remains unchanged. */ - return; - } - /* It's not likely we'll make it here, but ... */ - LOCK(); - /* Recalculate index since the table may grow and */ - /* check again that our finalizer is not in the table. */ - } - GC_ASSERT(GC_size(new_fo) >= sizeof(struct finalizable_object)); - if (ocd) *ocd = 0; - if (ofn) *ofn = 0; - new_fo -> fo_hidden_base = GC_HIDE_POINTER(base); - new_fo -> fo_fn = fn; - new_fo -> fo_client_data = (ptr_t)cd; - new_fo -> fo_object_size = hhdr -> hb_sz; - new_fo -> fo_mark_proc = mp; - fo_set_next(new_fo, GC_fo_head[index]); - GC_fo_entries++; - GC_fo_head[index] = new_fo; - UNLOCK(); -} - -GC_API void GC_CALL GC_register_finalizer(void * obj, - GC_finalization_proc fn, void * cd, - GC_finalization_proc *ofn, void ** ocd) -{ - GC_register_finalizer_inner(obj, fn, cd, ofn, - ocd, GC_normal_finalize_mark_proc); -} - -GC_API void GC_CALL GC_register_finalizer_ignore_self(void * obj, - GC_finalization_proc fn, void * cd, - GC_finalization_proc *ofn, void ** ocd) -{ - GC_register_finalizer_inner(obj, fn, cd, ofn, - ocd, GC_ignore_self_finalize_mark_proc); -} - -GC_API void GC_CALL GC_register_finalizer_no_order(void * obj, - GC_finalization_proc fn, void * cd, - GC_finalization_proc *ofn, void ** ocd) -{ - GC_register_finalizer_inner(obj, fn, cd, ofn, - ocd, GC_null_finalize_mark_proc); -} - -static GC_bool need_unreachable_finalization = FALSE; - /* Avoid the work if this isn't used. */ - -GC_API void GC_CALL GC_register_finalizer_unreachable(void * obj, - GC_finalization_proc fn, void * cd, - GC_finalization_proc *ofn, void ** ocd) -{ - need_unreachable_finalization = TRUE; - GC_ASSERT(GC_java_finalization); - GC_register_finalizer_inner(obj, fn, cd, ofn, - ocd, GC_unreachable_finalize_mark_proc); -} - -#ifndef NO_DEBUGGING - STATIC void GC_dump_finalization_links( - const struct dl_hashtbl_s *dl_hashtbl) - { - struct disappearing_link *curr_dl; - ptr_t real_ptr, real_link; - size_t dl_size = dl_hashtbl->log_size == -1 ? 0 : - 1 << dl_hashtbl->log_size; - size_t i; - - for (i = 0; i < dl_size; i++) { - for (curr_dl = dl_hashtbl -> head[i]; curr_dl != 0; - curr_dl = dl_next(curr_dl)) { - real_ptr = GC_REVEAL_POINTER(curr_dl -> dl_hidden_obj); - real_link = GC_REVEAL_POINTER(curr_dl -> dl_hidden_link); - GC_printf("Object: %p, link: %p\n", real_ptr, real_link); - } - } - } - - void GC_dump_finalization(void) - { - struct finalizable_object * curr_fo; - size_t fo_size = log_fo_table_size == -1 ? 0 : 1 << log_fo_table_size; - ptr_t real_ptr; - size_t i; - - GC_printf("Disappearing (short) links:\n"); - GC_dump_finalization_links(&GC_dl_hashtbl); -# ifndef GC_LONG_REFS_NOT_NEEDED - GC_printf("Disappearing long links:\n"); - GC_dump_finalization_links(&GC_ll_hashtbl); -# endif - GC_printf("Finalizers:\n"); - for (i = 0; i < fo_size; i++) { - for (curr_fo = GC_fo_head[i]; curr_fo != 0; - curr_fo = fo_next(curr_fo)) { - real_ptr = GC_REVEAL_POINTER(curr_fo -> fo_hidden_base); - GC_printf("Finalizable object: %p\n", real_ptr); - } - } - } -#endif /* !NO_DEBUGGING */ - -#ifndef SMALL_CONFIG - STATIC word GC_old_dl_entries = 0; /* for stats printing */ -# ifndef GC_LONG_REFS_NOT_NEEDED - STATIC word GC_old_ll_entries = 0; -# endif -#endif /* !SMALL_CONFIG */ - -#ifndef THREADS - /* Global variables to minimize the level of recursion when a client */ - /* finalizer allocates memory. */ - STATIC int GC_finalizer_nested = 0; - /* Only the lowest byte is used, the rest is */ - /* padding for proper global data alignment */ - /* required for some compilers (like Watcom). */ - STATIC unsigned GC_finalizer_skipped = 0; - - /* Checks and updates the level of finalizers recursion. */ - /* Returns NULL if GC_invoke_finalizers() should not be called by the */ - /* collector (to minimize the risk of a deep finalizers recursion), */ - /* otherwise returns a pointer to GC_finalizer_nested. */ - STATIC unsigned char *GC_check_finalizer_nested(void) - { - unsigned nesting_level = *(unsigned char *)&GC_finalizer_nested; - if (nesting_level) { - /* We are inside another GC_invoke_finalizers(). */ - /* Skip some implicitly-called GC_invoke_finalizers() */ - /* depending on the nesting (recursion) level. */ - if (++GC_finalizer_skipped < (1U << nesting_level)) return NULL; - GC_finalizer_skipped = 0; - } - *(char *)&GC_finalizer_nested = (char)(nesting_level + 1); - return (unsigned char *)&GC_finalizer_nested; - } -#endif /* THREADS */ - -#define ITERATE_DL_HASHTBL_BEGIN(dl_hashtbl, curr_dl, prev_dl) \ - { \ - size_t i; \ - size_t dl_size = dl_hashtbl->log_size == -1 ? 0 : \ - 1 << dl_hashtbl->log_size; \ - for (i = 0; i < dl_size; i++) { \ - curr_dl = dl_hashtbl -> head[i]; \ - prev_dl = NULL; \ - while (curr_dl) { - -#define ITERATE_DL_HASHTBL_END(curr_dl, prev_dl) \ - prev_dl = curr_dl; \ - curr_dl = dl_next(curr_dl); \ - } \ - } \ - } - -#define DELETE_DL_HASHTBL_ENTRY(dl_hashtbl, curr_dl, prev_dl, next_dl) \ - { \ - next_dl = dl_next(curr_dl); \ - if (NULL == prev_dl) { \ - dl_hashtbl -> head[i] = next_dl; \ - } else { \ - dl_set_next(prev_dl, next_dl); \ - } \ - GC_clear_mark_bit(curr_dl); \ - dl_hashtbl -> entries--; \ - curr_dl = next_dl; \ - continue; \ - } - -GC_INLINE void GC_make_disappearing_links_disappear( - struct dl_hashtbl_s* dl_hashtbl) -{ - struct disappearing_link *curr, *prev, *next; - ptr_t real_ptr, real_link; - - ITERATE_DL_HASHTBL_BEGIN(dl_hashtbl, curr, prev) - real_ptr = GC_REVEAL_POINTER(curr -> dl_hidden_obj); - real_link = GC_REVEAL_POINTER(curr -> dl_hidden_link); - if (!GC_is_marked(real_ptr)) { - *(word *)real_link = 0; - GC_clear_mark_bit(curr); - DELETE_DL_HASHTBL_ENTRY(dl_hashtbl, curr, prev, next); - } - ITERATE_DL_HASHTBL_END(curr, prev) -} - -GC_INLINE void GC_remove_dangling_disappearing_links( - struct dl_hashtbl_s* dl_hashtbl) -{ - struct disappearing_link *curr, *prev, *next; - ptr_t real_link; - - ITERATE_DL_HASHTBL_BEGIN(dl_hashtbl, curr, prev) - real_link = GC_base(GC_REVEAL_POINTER(curr -> dl_hidden_link)); - if (NULL != real_link && !GC_is_marked(real_link)) { - GC_clear_mark_bit(curr); - DELETE_DL_HASHTBL_ENTRY(dl_hashtbl, curr, prev, next); - } - ITERATE_DL_HASHTBL_END(curr, prev) -} - -/* Called with held lock (but the world is running). */ -/* Cause disappearing links to disappear and unreachable objects to be */ -/* enqueued for finalization. */ -GC_INNER void GC_finalize(void) -{ - struct finalizable_object * curr_fo, * prev_fo, * next_fo; - ptr_t real_ptr; - size_t i; - size_t fo_size = log_fo_table_size == -1 ? 0 : 1 << log_fo_table_size; - -# ifndef SMALL_CONFIG - /* Save current GC_[dl/ll]_entries value for stats printing */ - GC_old_dl_entries = GC_dl_hashtbl.entries; -# ifndef GC_LONG_REFS_NOT_NEEDED - GC_old_ll_entries = GC_ll_hashtbl.entries; -# endif -# endif - - GC_make_disappearing_links_disappear(&GC_dl_hashtbl); - - /* Mark all objects reachable via chains of 1 or more pointers */ - /* from finalizable objects. */ - GC_ASSERT(GC_mark_state == MS_NONE); - for (i = 0; i < fo_size; i++) { - for (curr_fo = GC_fo_head[i]; curr_fo != 0; - curr_fo = fo_next(curr_fo)) { - GC_ASSERT(GC_size(curr_fo) >= sizeof(struct finalizable_object)); - real_ptr = GC_REVEAL_POINTER(curr_fo -> fo_hidden_base); - if (!GC_is_marked(real_ptr)) { - GC_MARKED_FOR_FINALIZATION(real_ptr); - GC_MARK_FO(real_ptr, curr_fo -> fo_mark_proc); - if (GC_is_marked(real_ptr)) { - WARN("Finalization cycle involving %p\n", real_ptr); - } - } - } - } - /* Enqueue for finalization all objects that are still */ - /* unreachable. */ - GC_bytes_finalized = 0; - for (i = 0; i < fo_size; i++) { - curr_fo = GC_fo_head[i]; - prev_fo = 0; - while (curr_fo != 0) { - real_ptr = GC_REVEAL_POINTER(curr_fo -> fo_hidden_base); - if (!GC_is_marked(real_ptr)) { - if (!GC_java_finalization) { - GC_set_mark_bit(real_ptr); - } - /* Delete from hash table */ - next_fo = fo_next(curr_fo); - if (prev_fo == 0) { - GC_fo_head[i] = next_fo; - } else { - fo_set_next(prev_fo, next_fo); - } - GC_fo_entries--; - /* Add to list of objects awaiting finalization. */ - fo_set_next(curr_fo, GC_finalize_now); - GC_finalize_now = curr_fo; - /* unhide object pointer so any future collections will */ - /* see it. */ - curr_fo -> fo_hidden_base = - (word)GC_REVEAL_POINTER(curr_fo -> fo_hidden_base); - GC_bytes_finalized += - curr_fo -> fo_object_size - + sizeof(struct finalizable_object); - GC_ASSERT(GC_is_marked(GC_base(curr_fo))); - curr_fo = next_fo; - } else { - prev_fo = curr_fo; - curr_fo = fo_next(curr_fo); - } - } - } - - if (GC_java_finalization) { - /* make sure we mark everything reachable from objects finalized - using the no_order mark_proc */ - for (curr_fo = GC_finalize_now; - curr_fo != NULL; curr_fo = fo_next(curr_fo)) { - real_ptr = (ptr_t)curr_fo -> fo_hidden_base; - if (!GC_is_marked(real_ptr)) { - if (curr_fo -> fo_mark_proc == GC_null_finalize_mark_proc) { - GC_MARK_FO(real_ptr, GC_normal_finalize_mark_proc); - } - if (curr_fo -> fo_mark_proc != GC_unreachable_finalize_mark_proc) { - GC_set_mark_bit(real_ptr); - } - } - } - - /* now revive finalize-when-unreachable objects reachable from - other finalizable objects */ - if (need_unreachable_finalization) { - curr_fo = GC_finalize_now; - prev_fo = 0; - while (curr_fo != 0) { - next_fo = fo_next(curr_fo); - if (curr_fo -> fo_mark_proc == GC_unreachable_finalize_mark_proc) { - real_ptr = (ptr_t)curr_fo -> fo_hidden_base; - if (!GC_is_marked(real_ptr)) { - GC_set_mark_bit(real_ptr); - } else { - if (prev_fo == 0) - GC_finalize_now = next_fo; - else - fo_set_next(prev_fo, next_fo); - - curr_fo -> fo_hidden_base = - GC_HIDE_POINTER(curr_fo -> fo_hidden_base); - GC_bytes_finalized -= - curr_fo->fo_object_size + sizeof(struct finalizable_object); - - i = HASH2(real_ptr, log_fo_table_size); - fo_set_next (curr_fo, GC_fo_head[i]); - GC_fo_entries++; - GC_fo_head[i] = curr_fo; - curr_fo = prev_fo; - } - } - prev_fo = curr_fo; - curr_fo = next_fo; - } - } - } - - GC_remove_dangling_disappearing_links(&GC_dl_hashtbl); -# ifndef GC_LONG_REFS_NOT_NEEDED - GC_make_disappearing_links_disappear(&GC_ll_hashtbl); - GC_remove_dangling_disappearing_links(&GC_ll_hashtbl); -# endif - - if (GC_fail_count) { - /* Don't prevent running finalizers if there has been an allocation */ - /* failure recently. */ -# ifdef THREADS - GC_reset_finalizer_nested(); -# else - GC_finalizer_nested = 0; -# endif - } -} - -#ifndef JAVA_FINALIZATION_NOT_NEEDED - - /* Enqueue all remaining finalizers to be run - Assumes lock is held. */ - STATIC void GC_enqueue_all_finalizers(void) - { - struct finalizable_object * curr_fo, * prev_fo, * next_fo; - ptr_t real_ptr; - register int i; - int fo_size; - - fo_size = log_fo_table_size == -1 ? 0 : 1 << log_fo_table_size; - GC_bytes_finalized = 0; - for (i = 0; i < fo_size; i++) { - curr_fo = GC_fo_head[i]; - prev_fo = 0; - while (curr_fo != 0) { - real_ptr = GC_REVEAL_POINTER(curr_fo -> fo_hidden_base); - GC_MARK_FO(real_ptr, GC_normal_finalize_mark_proc); - GC_set_mark_bit(real_ptr); - - /* Delete from hash table */ - next_fo = fo_next(curr_fo); - if (prev_fo == 0) { - GC_fo_head[i] = next_fo; - } else { - fo_set_next(prev_fo, next_fo); - } - GC_fo_entries--; - - /* Add to list of objects awaiting finalization. */ - fo_set_next(curr_fo, GC_finalize_now); - GC_finalize_now = curr_fo; - - /* unhide object pointer so any future collections will */ - /* see it. */ - curr_fo -> fo_hidden_base = - (word)GC_REVEAL_POINTER(curr_fo -> fo_hidden_base); - GC_bytes_finalized += - curr_fo -> fo_object_size + sizeof(struct finalizable_object); - curr_fo = next_fo; - } - } - } - - /* Invoke all remaining finalizers that haven't yet been run. - * This is needed for strict compliance with the Java standard, - * which can make the runtime guarantee that all finalizers are run. - * Unfortunately, the Java standard implies we have to keep running - * finalizers until there are no more left, a potential infinite loop. - * YUCK. - * Note that this is even more dangerous than the usual Java - * finalizers, in that objects reachable from static variables - * may have been finalized when these finalizers are run. - * Finalizers run at this point must be prepared to deal with a - * mostly broken world. - * This routine is externally callable, so is called without - * the allocation lock. - */ - GC_API void GC_CALL GC_finalize_all(void) - { - DCL_LOCK_STATE; - - LOCK(); - while (GC_fo_entries > 0) { - GC_enqueue_all_finalizers(); - UNLOCK(); - GC_invoke_finalizers(); - /* Running the finalizers in this thread is arguably not a good */ - /* idea when we should be notifying another thread to run them. */ - /* But otherwise we don't have a great way to wait for them to */ - /* run. */ - LOCK(); - } - UNLOCK(); - } - -#endif /* !JAVA_FINALIZATION_NOT_NEEDED */ - -/* Returns true if it is worth calling GC_invoke_finalizers. (Useful if */ -/* finalizers can only be called from some kind of "safe state" and */ -/* getting into that safe state is expensive.) */ -GC_API int GC_CALL GC_should_invoke_finalizers(void) -{ - return GC_finalize_now != 0; -} - -/* Invoke finalizers for all objects that are ready to be finalized. */ -/* Should be called without allocation lock. */ -GC_API int GC_CALL GC_invoke_finalizers(void) -{ - struct finalizable_object * curr_fo; - int count = 0; - word bytes_freed_before = 0; /* initialized to prevent warning. */ - DCL_LOCK_STATE; - - while (GC_finalize_now != 0) { -# ifdef THREADS - LOCK(); -# endif - if (count == 0) { - bytes_freed_before = GC_bytes_freed; - /* Don't do this outside, since we need the lock. */ - } - curr_fo = GC_finalize_now; -# ifdef THREADS - if (curr_fo != 0) GC_finalize_now = fo_next(curr_fo); - UNLOCK(); - if (curr_fo == 0) break; -# else - GC_finalize_now = fo_next(curr_fo); -# endif - fo_set_next(curr_fo, 0); - (*(curr_fo -> fo_fn))((ptr_t)(curr_fo -> fo_hidden_base), - curr_fo -> fo_client_data); - curr_fo -> fo_client_data = 0; - ++count; -# ifdef UNDEFINED - /* This is probably a bad idea. It throws off accounting if */ - /* nearly all objects are finalizable. O.w. it shouldn't */ - /* matter. */ - GC_free((void *)curr_fo); -# endif - } - /* bytes_freed_before is initialized whenever count != 0 */ - if (count != 0 && bytes_freed_before != GC_bytes_freed) { - LOCK(); - GC_finalizer_bytes_freed += (GC_bytes_freed - bytes_freed_before); - UNLOCK(); - } - return count; -} - -static GC_word last_finalizer_notification = 0; - -GC_INNER void GC_notify_or_invoke_finalizers(void) -{ - GC_finalizer_notifier_proc notifier_fn = 0; -# if defined(KEEP_BACK_PTRS) || defined(MAKE_BACK_GRAPH) - static word last_back_trace_gc_no = 1; /* Skip first one. */ -# endif - DCL_LOCK_STATE; - -# if defined(THREADS) && !defined(KEEP_BACK_PTRS) \ - && !defined(MAKE_BACK_GRAPH) - /* Quick check (while unlocked) for an empty finalization queue. */ - if (GC_finalize_now == 0) return; -# endif - LOCK(); - - /* This is a convenient place to generate backtraces if appropriate, */ - /* since that code is not callable with the allocation lock. */ -# if defined(KEEP_BACK_PTRS) || defined(MAKE_BACK_GRAPH) - if (GC_gc_no > last_back_trace_gc_no) { -# ifdef KEEP_BACK_PTRS - long i; - /* Stops when GC_gc_no wraps; that's OK. */ - last_back_trace_gc_no = (word)(-1); /* disable others. */ - for (i = 0; i < GC_backtraces; ++i) { - /* FIXME: This tolerates concurrent heap mutation, */ - /* which may cause occasional mysterious results. */ - /* We need to release the GC lock, since GC_print_callers */ - /* acquires it. It probably shouldn't. */ - UNLOCK(); - GC_generate_random_backtrace_no_gc(); - LOCK(); - } - last_back_trace_gc_no = GC_gc_no; -# endif -# ifdef MAKE_BACK_GRAPH - if (GC_print_back_height) { - UNLOCK(); - GC_print_back_graph_stats(); - LOCK(); - } -# endif - } -# endif - if (GC_finalize_now == 0) { - UNLOCK(); - return; - } - - if (!GC_finalize_on_demand) { - unsigned char *pnested = GC_check_finalizer_nested(); - UNLOCK(); - /* Skip GC_invoke_finalizers() if nested */ - if (pnested != NULL) { - (void) GC_invoke_finalizers(); - *pnested = 0; /* Reset since no more finalizers. */ -# ifndef THREADS - GC_ASSERT(GC_finalize_now == 0); -# endif /* Otherwise GC can run concurrently and add more */ - } - return; - } - - /* These variables require synchronization to avoid data races. */ - if (last_finalizer_notification != GC_gc_no) { - last_finalizer_notification = GC_gc_no; - notifier_fn = GC_finalizer_notifier; - } - UNLOCK(); - if (notifier_fn != 0) - (*notifier_fn)(); /* Invoke the notifier */ -} - -#ifndef SMALL_CONFIG -# ifndef GC_LONG_REFS_NOT_NEEDED -# define IF_LONG_REFS_PRESENT_ELSE(x,y) (x) -# else -# define IF_LONG_REFS_PRESENT_ELSE(x,y) (y) -# endif - - GC_INNER void GC_print_finalization_stats(void) - { - struct finalizable_object *fo; - unsigned long ready = 0; - - GC_log_printf("%lu finalization entries;" - " %lu/%lu short/long disappearing links alive\n", - (unsigned long)GC_fo_entries, - (unsigned long)GC_dl_hashtbl.entries, - (unsigned long)IF_LONG_REFS_PRESENT_ELSE( - GC_ll_hashtbl.entries, 0)); - - for (fo = GC_finalize_now; 0 != fo; fo = fo_next(fo)) - ++ready; - GC_log_printf("%lu finalization-ready objects;" - " %ld/%ld short/long links cleared\n", - ready, - (long)GC_old_dl_entries - (long)GC_dl_hashtbl.entries, - (long)IF_LONG_REFS_PRESENT_ELSE( - GC_old_ll_entries - GC_ll_hashtbl.entries, 0)); - } -#endif /* !SMALL_CONFIG */ - -#endif /* !GC_NO_FINALIZATION */ diff -Nru ecl-16.1.2/src/bdwgc/fnlz_mlc.c ecl-16.1.3+ds/src/bdwgc/fnlz_mlc.c --- ecl-16.1.2/src/bdwgc/fnlz_mlc.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/fnlz_mlc.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,170 +0,0 @@ -/* - * Copyright (c) 2011 by Hewlett-Packard Company. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -#include "private/gc_priv.h" - -#ifdef ENABLE_DISCLAIM - -#include "gc_disclaim.h" - -#ifdef THREAD_LOCAL_ALLOC -# include "private/thread_local_alloc.h" -#else - STATIC ptr_t * GC_finalized_objfreelist = NULL; -#endif /* !THREAD_LOCAL_ALLOC */ - -STATIC int GC_finalized_kind = 0; - -STATIC int GC_CALLBACK GC_finalized_disclaim(void *obj) -{ - word fc_word = *(word *)obj; - - if ((fc_word & 1) != 0) { - /* The disclaim function may be passed fragments from the */ - /* free-list, on which it should not run finalization. */ - /* To recognize this case, we use the fact that the first word */ - /* on such fragments are always even (a link to the next */ - /* fragment, or NULL). If it is desirable to have a finalizer */ - /* which does not use the first word for storing finalization */ - /* info, GC_reclaim_with_finalization must be extended to clear */ - /* fragments so that the assumption holds for the selected word. */ - const struct GC_finalizer_closure *fc = (void *)(fc_word & ~(word)1); - (*fc->proc)((word *)obj + 1, fc->cd); - } - return 0; -} - -static GC_bool done_init = FALSE; - -GC_API void GC_CALL GC_init_finalized_malloc(void) -{ - DCL_LOCK_STATE; - - GC_init(); /* In case it's not already done. */ - LOCK(); - if (done_init) { - UNLOCK(); - return; - } - done_init = TRUE; - - /* The finalizer closure is placed in the first word in order to */ - /* use the lower bits to distinguish live objects from objects on */ - /* the free list. The downside of this is that we need one-word */ - /* offset interior pointers, and that GC_base does not return the */ - /* start of the user region. */ - GC_register_displacement_inner(sizeof(word)); - - GC_finalized_objfreelist = (ptr_t *)GC_new_free_list_inner(); - GC_finalized_kind = GC_new_kind_inner((void **)GC_finalized_objfreelist, - GC_DS_LENGTH, TRUE, TRUE); - GC_register_disclaim_proc(GC_finalized_kind, GC_finalized_disclaim, TRUE); - UNLOCK(); -} - -GC_API void GC_CALL GC_register_disclaim_proc(int kind, GC_disclaim_proc proc, - int mark_unconditionally) -{ - GC_ASSERT((unsigned)kind < MAXOBJKINDS); - GC_obj_kinds[kind].ok_disclaim_proc = proc; - GC_obj_kinds[kind].ok_mark_unconditionally = (GC_bool)mark_unconditionally; -} - -#ifdef THREAD_LOCAL_ALLOC - STATIC void * GC_core_finalized_malloc(size_t lb, - const struct GC_finalizer_closure *fclos) -#else - GC_API GC_ATTR_MALLOC void * GC_CALL GC_finalized_malloc(size_t lb, - const struct GC_finalizer_closure *fclos) -#endif -{ - ptr_t op; - word lg; - DCL_LOCK_STATE; - - lb += sizeof(word); - GC_ASSERT(done_init); - if (SMALL_OBJ(lb)) { - GC_DBG_COLLECT_AT_MALLOC(lb); - lg = GC_size_map[lb]; - LOCK(); - op = GC_finalized_objfreelist[lg]; - if (EXPECT(0 == op, FALSE)) { - UNLOCK(); - op = GC_generic_malloc(lb, GC_finalized_kind); - if (NULL == op) - return NULL; - /* GC_generic_malloc has extended the size map for us. */ - lg = GC_size_map[lb]; - } else { - GC_finalized_objfreelist[lg] = obj_link(op); - obj_link(op) = 0; - GC_bytes_allocd += GRANULES_TO_BYTES(lg); - UNLOCK(); - } - GC_ASSERT(lg > 0); - } else { - op = GC_generic_malloc(lb, GC_finalized_kind); - if (NULL == op) - return NULL; - GC_ASSERT(GC_size(op) >= lb); - } - *(word *)op = (word)fclos | 1; - return GC_clear_stack((word *)op + 1); -} - -#ifdef THREAD_LOCAL_ALLOC - GC_API GC_ATTR_MALLOC void * GC_CALL GC_finalized_malloc(size_t client_lb, - const struct GC_finalizer_closure *fclos) - { - size_t lb = client_lb + sizeof(word); - size_t lg = ROUNDED_UP_GRANULES(lb); - GC_tlfs tsd; - void *result; - void **tiny_fl, **my_fl, *my_entry; - void *next; - - if (EXPECT(lg >= GC_TINY_FREELISTS, FALSE)) - return GC_core_finalized_malloc(client_lb, fclos); - - tsd = GC_getspecific(GC_thread_key); - tiny_fl = tsd->finalized_freelists; - my_fl = tiny_fl + lg; - my_entry = *my_fl; - while (EXPECT((word)my_entry - <= DIRECT_GRANULES + GC_TINY_FREELISTS + 1, FALSE)) { - if ((word)my_entry - 1 < DIRECT_GRANULES) { - *my_fl = (ptr_t)my_entry + lg + 1; - return GC_core_finalized_malloc(client_lb, fclos); - } else { - GC_generic_malloc_many(GC_RAW_BYTES_FROM_INDEX(lg), - GC_finalized_kind, my_fl); - my_entry = *my_fl; - if (my_entry == 0) { - return (*GC_get_oom_fn())(lb); - } - } - } - - next = obj_link(my_entry); - result = (void *)my_entry; - *my_fl = next; - obj_link(result) = 0; - *(word *)result = (word)fclos | 1; - PREFETCH_FOR_WRITE(next); - return (word *)result + 1; - } -#endif /* THREAD_LOCAL_ALLOC */ - -#endif /* ENABLE_DISCLAIM */ diff -Nru ecl-16.1.2/src/bdwgc/gc_cpp.cc ecl-16.1.3+ds/src/bdwgc/gc_cpp.cc --- ecl-16.1.2/src/bdwgc/gc_cpp.cc 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/gc_cpp.cc 1970-01-01 00:00:00.000000000 +0000 @@ -1,88 +0,0 @@ -/* - * Copyright (c) 1994 by Xerox Corporation. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to copy this code for any purpose, - * provided the above notices are retained on all copies. - */ - -/************************************************************************* -This implementation module for gc_c++.h provides an implementation of -the global operators "new" and "delete" that calls the Boehm -allocator. All objects allocated by this implementation will be -uncollectible but part of the root set of the collector. - -You should ensure (using implementation-dependent techniques) that the -linker finds this module before the library that defines the default -built-in "new" and "delete". -**************************************************************************/ - -#ifdef HAVE_CONFIG_H -# include "config.h" -#endif - -#ifndef GC_BUILD -# define GC_BUILD -#endif - -#include "gc_cpp.h" - -#if !defined(GC_NEW_DELETE_NEED_THROW) && defined(__GNUC__) \ - && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 2)) -# define GC_NEW_DELETE_NEED_THROW -#endif - -#ifdef GC_NEW_DELETE_NEED_THROW -# include /* for std::bad_alloc */ -# define GC_DECL_NEW_THROW throw(std::bad_alloc) -# define GC_DECL_DELETE_THROW throw() -#else -# define GC_DECL_NEW_THROW /* empty */ -# define GC_DECL_DELETE_THROW /* empty */ -#endif /* !GC_NEW_DELETE_NEED_THROW */ - -void* operator new( size_t size ) GC_DECL_NEW_THROW { - return GC_MALLOC_UNCOLLECTABLE(size); -} - -#if !defined(__CYGWIN__) - void operator delete( void* obj ) GC_DECL_DELETE_THROW { - GC_FREE(obj); - } -#endif /* !__CYGWIN__ */ - -#ifdef GC_OPERATOR_NEW_ARRAY - void* operator new[]( size_t size ) GC_DECL_NEW_THROW { - return GC_MALLOC_UNCOLLECTABLE(size); - } - - void operator delete[]( void* obj ) GC_DECL_DELETE_THROW { - GC_FREE(obj); - } -#endif /* GC_OPERATOR_NEW_ARRAY */ - -#ifdef _MSC_VER - - // This new operator is used by VC++ in case of Debug builds! - void* operator new( size_t size, int /* nBlockUse */, - const char * szFileName, int nLine ) GC_DECL_NEW_THROW - { -# ifndef GC_DEBUG - return GC_malloc_uncollectable(size); -# else - return GC_debug_malloc_uncollectable(size, szFileName, nLine); -# endif - } - -# if _MSC_VER > 1020 - // This new operator is used by VC++ 7.0 and later in Debug builds. - void* operator new[]( size_t size, int nBlockUse, - const char* szFileName, int nLine ) GC_DECL_NEW_THROW - { - return operator new(size, nBlockUse, szFileName, nLine); - } -# endif - -#endif /* _MSC_VER */ diff -Nru ecl-16.1.2/src/bdwgc/gc_cpp.cpp ecl-16.1.3+ds/src/bdwgc/gc_cpp.cpp --- ecl-16.1.2/src/bdwgc/gc_cpp.cpp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/gc_cpp.cpp 1970-01-01 00:00:00.000000000 +0000 @@ -1,2 +0,0 @@ -// Visual C++ seems to prefer a .cpp extension to .cc -#include "gc_cpp.cc" diff -Nru ecl-16.1.2/src/bdwgc/gc_dlopen.c ecl-16.1.3+ds/src/bdwgc/gc_dlopen.c --- ecl-16.1.2/src/bdwgc/gc_dlopen.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/gc_dlopen.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,100 +0,0 @@ -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1997 by Silicon Graphics. All rights reserved. - * Copyright (c) 2000 by Hewlett-Packard Company. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#include "private/gc_priv.h" - -/* This used to be in dyn_load.c. It was extracted into a separate */ -/* file to avoid having to link against libdl.{a,so} if the client */ -/* doesn't call dlopen. Of course this fails if the collector is in */ -/* a dynamic library. -HB */ -#if defined(GC_PTHREADS) && !defined(GC_NO_DLOPEN) - -#undef GC_MUST_RESTORE_REDEFINED_DLOPEN -#if defined(dlopen) && !defined(GC_USE_LD_WRAP) - /* To support various threads pkgs, gc.h interposes on dlopen by */ - /* defining "dlopen" to be "GC_dlopen", which is implemented below. */ - /* However, both GC_FirstDLOpenedLinkMap() and GC_dlopen() use the */ - /* real system dlopen() in their implementation. We first remove */ - /* gc.h's dlopen definition and restore it later, after GC_dlopen(). */ -# undef dlopen -# define GC_MUST_RESTORE_REDEFINED_DLOPEN -#endif - -/* Make sure we're not in the middle of a collection, and make sure we */ -/* don't start any. This is invoked prior to a dlopen call to avoid */ -/* synchronization issues. We can't just acquire the allocation lock, */ -/* since startup code in dlopen may try to allocate. This solution */ -/* risks heap growth (or, even, heap overflow) in the presence of many */ -/* dlopen calls in either a multi-threaded environment, or if the */ -/* library initialization code allocates substantial amounts of GC'ed */ -/* memory. */ -#ifndef USE_PROC_FOR_LIBRARIES - static void disable_gc_for_dlopen(void) - { - DCL_LOCK_STATE; - LOCK(); - while (GC_incremental && GC_collection_in_progress()) { - GC_collect_a_little_inner(1000); - } - ++GC_dont_gc; - UNLOCK(); - } -#endif - -/* Redefine dlopen to guarantee mutual exclusion with */ -/* GC_register_dynamic_libraries. Should probably happen for */ -/* other operating systems, too. */ - -/* This is similar to WRAP/REAL_FUNC() in pthread_support.c. */ -#ifdef GC_USE_LD_WRAP -# define WRAP_DLFUNC(f) __wrap_##f -# define REAL_DLFUNC(f) __real_##f - void * REAL_DLFUNC(dlopen)(const char *, int); -#else -# define WRAP_DLFUNC(f) GC_##f -# define REAL_DLFUNC(f) f -#endif - -GC_API void * WRAP_DLFUNC(dlopen)(const char *path, int mode) -{ - void * result; - -# ifndef USE_PROC_FOR_LIBRARIES - /* Disable collections. This solution risks heap growth (or, */ - /* even, heap overflow) but there seems no better solutions. */ - disable_gc_for_dlopen(); -# endif - result = REAL_DLFUNC(dlopen)(path, mode); -# ifndef USE_PROC_FOR_LIBRARIES - GC_enable(); /* undoes disable_gc_for_dlopen */ -# endif - return(result); -} - -#ifdef GC_USE_LD_WRAP - /* Define GC_ function as an alias for the plain one, which will be */ - /* intercepted. This allows files which include gc.h, and hence */ - /* generate references to the GC_ symbol, to see the right symbol. */ - GC_API void *GC_dlopen(const char *path, int mode) - { - return dlopen(path, mode); - } -#endif /* GC_USE_LD_WRAP */ - -#ifdef GC_MUST_RESTORE_REDEFINED_DLOPEN -# define dlopen GC_dlopen -#endif - -#endif /* GC_PTHREADS && !GC_NO_DLOPEN */ diff -Nru ecl-16.1.2/src/bdwgc/gcj_mlc.c ecl-16.1.3+ds/src/bdwgc/gcj_mlc.c --- ecl-16.1.2/src/bdwgc/gcj_mlc.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/gcj_mlc.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,274 +0,0 @@ -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1999-2004 Hewlett-Packard Development Company, L.P. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -#include "private/gc_pmark.h" /* includes gc_priv.h */ - -#ifdef GC_GCJ_SUPPORT - -/* - * This is an allocator interface tuned for gcj (the GNU static - * java compiler). - * - * Each allocated object has a pointer in its first word to a vtable, - * which for our purposes is simply a structure describing the type of - * the object. - * This descriptor structure contains a GC marking descriptor at offset - * MARK_DESCR_OFFSET. - * - * It is hoped that this interface may also be useful for other systems, - * possibly with some tuning of the constants. But the immediate goal - * is to get better gcj performance. - * - * We assume: - * 1) Counting on explicit initialization of this interface is OK; - * 2) FASTLOCK is not a significant win. - */ - -#include "gc_gcj.h" -#include "private/dbg_mlc.h" - -#ifdef GC_ASSERTIONS - GC_INNER /* variable is also used in thread_local_alloc.c */ -#else - STATIC -#endif -GC_bool GC_gcj_malloc_initialized = FALSE; - -int GC_gcj_kind = 0; /* Object kind for objects with descriptors */ - /* in "vtable". */ -int GC_gcj_debug_kind = 0; - /* The kind of objects that is always marked */ - /* with a mark proc call. */ - -GC_INNER ptr_t * GC_gcjobjfreelist = NULL; - -STATIC ptr_t * GC_gcjdebugobjfreelist = NULL; - -STATIC struct GC_ms_entry * GC_gcj_fake_mark_proc(word * addr GC_ATTR_UNUSED, - struct GC_ms_entry *mark_stack_ptr, - struct GC_ms_entry * mark_stack_limit GC_ATTR_UNUSED, - word env GC_ATTR_UNUSED) -{ - ABORT_RET("No client gcj mark proc is specified"); - return mark_stack_ptr; -} - -/* Caller does not hold allocation lock. */ -GC_API void GC_CALL GC_init_gcj_malloc(int mp_index, - void * /* really GC_mark_proc */mp) -{ - GC_bool ignore_gcj_info; - DCL_LOCK_STATE; - - if (mp == 0) /* In case GC_DS_PROC is unused. */ - mp = (void *)(word)GC_gcj_fake_mark_proc; - - GC_init(); /* In case it's not already done. */ - LOCK(); - if (GC_gcj_malloc_initialized) { - UNLOCK(); - return; - } - GC_gcj_malloc_initialized = TRUE; -# ifdef GC_IGNORE_GCJ_INFO - /* This is useful for debugging on platforms with missing getenv(). */ - ignore_gcj_info = 1; -# else - ignore_gcj_info = (0 != GETENV("GC_IGNORE_GCJ_INFO")); -# endif - if (ignore_gcj_info) { - GC_COND_LOG_PRINTF("Gcj-style type information is disabled!\n"); - } - GC_ASSERT(GC_mark_procs[mp_index] == (GC_mark_proc)0); /* unused */ - GC_mark_procs[mp_index] = (GC_mark_proc)(word)mp; - if ((unsigned)mp_index >= GC_n_mark_procs) - ABORT("GC_init_gcj_malloc: bad index"); - /* Set up object kind gcj-style indirect descriptor. */ - GC_gcjobjfreelist = (ptr_t *)GC_new_free_list_inner(); - if (ignore_gcj_info) { - /* Use a simple length-based descriptor, thus forcing a fully */ - /* conservative scan. */ - GC_gcj_kind = GC_new_kind_inner((void **)GC_gcjobjfreelist, - (0 | GC_DS_LENGTH), - TRUE, TRUE); - } else { - GC_gcj_kind = GC_new_kind_inner( - (void **)GC_gcjobjfreelist, - (((word)(-(signed_word)MARK_DESCR_OFFSET - - GC_INDIR_PER_OBJ_BIAS)) - | GC_DS_PER_OBJECT), - FALSE, TRUE); - } - /* Set up object kind for objects that require mark proc call. */ - if (ignore_gcj_info) { - GC_gcj_debug_kind = GC_gcj_kind; - GC_gcjdebugobjfreelist = GC_gcjobjfreelist; - } else { - GC_gcjdebugobjfreelist = (ptr_t *)GC_new_free_list_inner(); - GC_gcj_debug_kind = GC_new_kind_inner( - (void **)GC_gcjdebugobjfreelist, - GC_MAKE_PROC(mp_index, - 1 /* allocated with debug info */), - FALSE, TRUE); - } - UNLOCK(); -} - -#define GENERAL_MALLOC_INNER(lb,k) \ - GC_clear_stack(GC_generic_malloc_inner(lb, k)) - -#define GENERAL_MALLOC_INNER_IOP(lb,k) \ - GC_clear_stack(GC_generic_malloc_inner_ignore_off_page(lb, k)) - -/* We need a mechanism to release the lock and invoke finalizers. */ -/* We don't really have an opportunity to do this on a rarely executed */ -/* path on which the lock is not held. Thus we check at a */ -/* rarely executed point at which it is safe to release the lock. */ -/* We do this even where we could just call GC_INVOKE_FINALIZERS, */ -/* since it's probably cheaper and certainly more uniform. */ -/* FIXME - Consider doing the same elsewhere? */ -static void maybe_finalize(void) -{ - static word last_finalized_no = 0; - DCL_LOCK_STATE; - - if (GC_gc_no == last_finalized_no || - !EXPECT(GC_is_initialized, TRUE)) return; - UNLOCK(); - GC_INVOKE_FINALIZERS(); - LOCK(); - last_finalized_no = GC_gc_no; -} - -/* Allocate an object, clear it, and store the pointer to the */ -/* type structure (vtable in gcj). */ -/* This adds a byte at the end of the object if GC_malloc would.*/ -#ifdef THREAD_LOCAL_ALLOC - GC_INNER void * GC_core_gcj_malloc(size_t lb, - void * ptr_to_struct_containing_descr) -#else - GC_API GC_ATTR_MALLOC void * GC_CALL GC_gcj_malloc(size_t lb, - void * ptr_to_struct_containing_descr) -#endif -{ - ptr_t op; - word lg; - DCL_LOCK_STATE; - - GC_DBG_COLLECT_AT_MALLOC(lb); - if(SMALL_OBJ(lb)) { - lg = GC_size_map[lb]; - LOCK(); - op = GC_gcjobjfreelist[lg]; - if(EXPECT(0 == op, FALSE)) { - maybe_finalize(); - op = (ptr_t)GENERAL_MALLOC_INNER((word)lb, GC_gcj_kind); - if (0 == op) { - GC_oom_func oom_fn = GC_oom_fn; - UNLOCK(); - return((*oom_fn)(lb)); - } - } else { - GC_gcjobjfreelist[lg] = obj_link(op); - GC_bytes_allocd += GRANULES_TO_BYTES(lg); - } - *(void **)op = ptr_to_struct_containing_descr; - GC_ASSERT(((void **)op)[1] == 0); - UNLOCK(); - } else { - LOCK(); - maybe_finalize(); - op = (ptr_t)GENERAL_MALLOC_INNER((word)lb, GC_gcj_kind); - if (0 == op) { - GC_oom_func oom_fn = GC_oom_fn; - UNLOCK(); - return((*oom_fn)(lb)); - } - *(void **)op = ptr_to_struct_containing_descr; - UNLOCK(); - } - return((void *) op); -} - -/* Similar to GC_gcj_malloc, but add debug info. This is allocated */ -/* with GC_gcj_debug_kind. */ -GC_API GC_ATTR_MALLOC void * GC_CALL GC_debug_gcj_malloc(size_t lb, - void * ptr_to_struct_containing_descr, GC_EXTRA_PARAMS) -{ - void * result; - DCL_LOCK_STATE; - - /* We're careful to avoid extra calls, which could */ - /* confuse the backtrace. */ - LOCK(); - maybe_finalize(); - result = GC_generic_malloc_inner(lb + DEBUG_BYTES, GC_gcj_debug_kind); - if (result == 0) { - GC_oom_func oom_fn = GC_oom_fn; - UNLOCK(); - GC_err_printf("GC_debug_gcj_malloc(%lu, %p) returning NULL (%s:%d)\n", - (unsigned long)lb, ptr_to_struct_containing_descr, s, i); - return((*oom_fn)(lb)); - } - *((void **)((ptr_t)result + sizeof(oh))) = ptr_to_struct_containing_descr; - UNLOCK(); - if (!GC_debugging_started) { - GC_start_debugging(); - } - ADD_CALL_CHAIN(result, ra); - return (GC_store_debug_info(result, (word)lb, s, i)); -} - -/* There is no THREAD_LOCAL_ALLOC for GC_gcj_malloc_ignore_off_page(). */ -GC_API GC_ATTR_MALLOC void * GC_CALL GC_gcj_malloc_ignore_off_page(size_t lb, - void * ptr_to_struct_containing_descr) -{ - ptr_t op; - word lg; - DCL_LOCK_STATE; - - GC_DBG_COLLECT_AT_MALLOC(lb); - if(SMALL_OBJ(lb)) { - lg = GC_size_map[lb]; - LOCK(); - op = GC_gcjobjfreelist[lg]; - if (EXPECT(0 == op, FALSE)) { - maybe_finalize(); - op = (ptr_t)GENERAL_MALLOC_INNER_IOP(lb, GC_gcj_kind); - if (0 == op) { - GC_oom_func oom_fn = GC_oom_fn; - UNLOCK(); - return((*oom_fn)(lb)); - } - } else { - GC_gcjobjfreelist[lg] = obj_link(op); - GC_bytes_allocd += GRANULES_TO_BYTES(lg); - } - } else { - LOCK(); - maybe_finalize(); - op = (ptr_t)GENERAL_MALLOC_INNER_IOP(lb, GC_gcj_kind); - if (0 == op) { - GC_oom_func oom_fn = GC_oom_fn; - UNLOCK(); - return((*oom_fn)(lb)); - } - } - *(void **)op = ptr_to_struct_containing_descr; - UNLOCK(); - return((void *) op); -} - -#endif /* GC_GCJ_SUPPORT */ diff -Nru ecl-16.1.2/src/bdwgc/gc.mak ecl-16.1.3+ds/src/bdwgc/gc.mak --- ecl-16.1.2/src/bdwgc/gc.mak 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/gc.mak 1970-01-01 00:00:00.000000000 +0000 @@ -1,2283 +0,0 @@ -# Microsoft Developer Studio Generated NMAKE File, Format Version 4.10 -# This has been hand-edited way too many times. -# A clean, manually generated makefile would be an improvement. - -# TARGTYPE "Win32 (x86) Application" 0x0101 -# TARGTYPE "Win32 (x86) Dynamic-Link Library" 0x0102 - -!IF "$(CFG)" == "" -CFG=gctest - Win32 Release -!MESSAGE No configuration specified. Defaulting to cord - Win32 Debug. -!ENDIF - -!IF "$(CFG)" != "gc - Win32 Release" && "$(CFG)" != "gc - Win32 Debug" &&\ - "$(CFG)" != "gctest - Win32 Release" && "$(CFG)" != "gctest - Win32 Debug" &&\ - "$(CFG)" != "cord - Win32 Release" && "$(CFG)" != "cord - Win32 Debug" -!MESSAGE Invalid configuration "$(CFG)" specified. -!MESSAGE You can specify a configuration when running NMAKE on this makefile -!MESSAGE by defining the macro CFG on the command line. For example: -!MESSAGE -!MESSAGE NMAKE /f "gc.mak" CFG="cord - Win32 Debug" -!MESSAGE -!MESSAGE Possible choices for configuration are: -!MESSAGE -!MESSAGE "gc - Win32 Release" (based on "Win32 (x86) Dynamic-Link Library") -!MESSAGE "gc - Win32 Debug" (based on "Win32 (x86) Dynamic-Link Library") -!MESSAGE "gctest - Win32 Release" (based on "Win32 (x86) Application") -!MESSAGE "gctest - Win32 Debug" (based on "Win32 (x86) Application") -!MESSAGE "cord - Win32 Release" (based on "Win32 (x86) Application") -!MESSAGE "cord - Win32 Debug" (based on "Win32 (x86) Application") -!MESSAGE -!ERROR An invalid configuration is specified. -!ENDIF - -!IF "$(OS)" == "Windows_NT" -NULL= -!ELSE -NULL=nul -!ENDIF -################################################################################ -# Begin Project -# PROP Target_Last_Scanned "gctest - Win32 Debug" - -!IF "$(CFG)" == "gc - Win32 Release" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 0 -# PROP BASE Output_Dir "Release" -# PROP BASE Intermediate_Dir "Release" -# PROP BASE Target_Dir "" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 0 -# PROP Output_Dir "Release" -# PROP Intermediate_Dir "Release" -# PROP Target_Dir "" -OUTDIR=.\Release -INTDIR=.\Release - -ALL : ".\Release\gc.dll" ".\Release\gc.bsc" - -CLEAN : - -@erase ".\Release\allchblk.obj" - -@erase ".\Release\allchblk.sbr" - -@erase ".\Release\alloc.obj" - -@erase ".\Release\alloc.sbr" - -@erase ".\Release\blacklst.obj" - -@erase ".\Release\blacklst.sbr" - -@erase ".\Release\checksums.obj" - -@erase ".\Release\checksums.sbr" - -@erase ".\Release\dbg_mlc.obj" - -@erase ".\Release\dbg_mlc.sbr" - -@erase ".\Release\dyn_load.obj" - -@erase ".\Release\dyn_load.sbr" - -@erase ".\Release\finalize.obj" - -@erase ".\Release\finalize.sbr" - -@erase ".\Release\fnlz_mlc.obj" - -@erase ".\Release\fnlz_mlc.sbr" - -@erase ".\Release\gc.bsc" - -@erase ".\Release\gc_cpp.obj" - -@erase ".\Release\gc_cpp.sbr" - -@erase ".\Release\gc.dll" - -@erase ".\Release\gc.exp" - -@erase ".\Release\gc.lib" - -@erase ".\Release\headers.obj" - -@erase ".\Release\headers.sbr" - -@erase ".\Release\mach_dep.obj" - -@erase ".\Release\mach_dep.sbr" - -@erase ".\Release\malloc.obj" - -@erase ".\Release\malloc.sbr" - -@erase ".\Release\mallocx.obj" - -@erase ".\Release\mallocx.sbr" - -@erase ".\Release\mark.obj" - -@erase ".\Release\mark.sbr" - -@erase ".\Release\mark_rts.obj" - -@erase ".\Release\mark_rts.sbr" - -@erase ".\Release\misc.obj" - -@erase ".\Release\misc.sbr" - -@erase ".\Release\new_hblk.obj" - -@erase ".\Release\new_hblk.sbr" - -@erase ".\Release\obj_map.obj" - -@erase ".\Release\obj_map.sbr" - -@erase ".\Release\os_dep.obj" - -@erase ".\Release\os_dep.sbr" - -@erase ".\Release\ptr_chck.obj" - -@erase ".\Release\ptr_chck.sbr" - -@erase ".\Release\reclaim.obj" - -@erase ".\Release\reclaim.sbr" - -@erase ".\Release\stubborn.obj" - -@erase ".\Release\stubborn.sbr" - -@erase ".\Release\typd_mlc.obj" - -@erase ".\Release\typd_mlc.sbr" - -@erase ".\Release\win32_threads.obj" - -@erase ".\Release\win32_threads.sbr" - -@erase ".\Release\msvc_dbg.obj" - -@erase ".\Release\msvc_dbg.sbr" - -"$(OUTDIR)" : - if not exist "$(OUTDIR)/$(NULL)" mkdir "$(OUTDIR)" - -CPP=cl.exe -# ADD BASE CPP /nologo /MT /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /YX /c -# ADD CPP /nologo /MD /W3 /GX /O2 /I include /D "NDEBUG" /D "WIN32" /D "_WINDOWS" /D "ALL_INTERIOR_POINTERS" /D "GC_THREADS" /FR /YX /c -CPP_PROJ=/nologo /MD /W3 /GX /O2 /I include /D "NDEBUG" /D\ - "WIN32" /D "_WINDOWS" /D "ALL_INTERIOR_POINTERS" /D "GC_THREADS" \ - /FR"$(INTDIR)/" /Fp"$(INTDIR)/gc.pch" \ - /I./libatomic_ops/src /YX /Fo"$(INTDIR)/" /c -CPP_OBJS=.\Release/ -CPP_SBRS=.\Release/ - -.c{$(CPP_OBJS)}.obj: - $(CPP) $(CPP_PROJ) $< - -.cpp{$(CPP_OBJS)}.obj: - $(CPP) $(CPP_PROJ) $< - -.cxx{$(CPP_OBJS)}.obj: - $(CPP) $(CPP_PROJ) $< - -.c{$(CPP_SBRS)}.sbr: - $(CPP) $(CPP_PROJ) $< - -.cpp{$(CPP_SBRS)}.sbr: - $(CPP) $(CPP_PROJ) $< - -.cxx{$(CPP_SBRS)}.sbr: - $(CPP) $(CPP_PROJ) $< - -MTL=mktyplib.exe -# ADD BASE MTL /nologo /D "NDEBUG" /win32 -# ADD MTL /nologo /D "NDEBUG" /win32 -MTL_PROJ=/nologo /D "NDEBUG" /win32 -RSC=rc.exe -# ADD BASE RSC /l 0x809 /d "NDEBUG" -# ADD RSC /l 0x809 /d "NDEBUG" -BSC32=bscmake.exe -# ADD BASE BSC32 /nologo -# ADD BSC32 /nologo -BSC32_FLAGS=/nologo /o"$(OUTDIR)/gc.bsc" -BSC32_SBRS= \ - ".\Release\allchblk.sbr" \ - ".\Release\alloc.sbr" \ - ".\Release\blacklst.sbr" \ - ".\Release\checksums.sbr" \ - ".\Release\dbg_mlc.sbr" \ - ".\Release\dyn_load.sbr" \ - ".\Release\finalize.sbr" \ - ".\Release\fnlz_mlc.sbr" \ - ".\Release\gc_cpp.sbr" \ - ".\Release\headers.sbr" \ - ".\Release\mach_dep.sbr" \ - ".\Release\malloc.sbr" \ - ".\Release\mallocx.sbr" \ - ".\Release\mark.sbr" \ - ".\Release\mark_rts.sbr" \ - ".\Release\misc.sbr" \ - ".\Release\new_hblk.sbr" \ - ".\Release\obj_map.sbr" \ - ".\Release\os_dep.sbr" \ - ".\Release\ptr_chck.sbr" \ - ".\Release\reclaim.sbr" \ - ".\Release\stubborn.sbr" \ - ".\Release\typd_mlc.sbr" \ - ".\Release\msvc_dbg.sbr" \ - ".\Release\win32_threads.sbr" - -".\Release\gc.bsc" : "$(OUTDIR)" $(BSC32_SBRS) - $(BSC32) @<< - $(BSC32_FLAGS) $(BSC32_SBRS) -<< - -LINK32=link.exe -# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:windows /dll /machine:I386 -# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:windows /dll /machine:I386 -LINK32_FLAGS=kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib\ - advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib\ - odbccp32.lib /nologo /subsystem:windows /dll /incremental:no\ - /pdb:"$(OUTDIR)/gc.pdb" /machine:I386 /out:"$(OUTDIR)/gc.dll"\ - /implib:"$(OUTDIR)/gc.lib" -LINK32_OBJS= \ - ".\Release\allchblk.obj" \ - ".\Release\alloc.obj" \ - ".\Release\blacklst.obj" \ - ".\Release\checksums.obj" \ - ".\Release\dbg_mlc.obj" \ - ".\Release\dyn_load.obj" \ - ".\Release\finalize.obj" \ - ".\Release\fnlz_mlc.obj" \ - ".\Release\gc_cpp.obj" \ - ".\Release\headers.obj" \ - ".\Release\mach_dep.obj" \ - ".\Release\malloc.obj" \ - ".\Release\mallocx.obj" \ - ".\Release\mark.obj" \ - ".\Release\mark_rts.obj" \ - ".\Release\misc.obj" \ - ".\Release\new_hblk.obj" \ - ".\Release\obj_map.obj" \ - ".\Release\os_dep.obj" \ - ".\Release\ptr_chck.obj" \ - ".\Release\reclaim.obj" \ - ".\Release\stubborn.obj" \ - ".\Release\typd_mlc.obj" \ - ".\Release\msvc_dbg.obj" \ - ".\Release\win32_threads.obj" - -".\Release\gc.dll" : "$(OUTDIR)" $(DEF_FILE) $(LINK32_OBJS) - $(LINK32) @<< - $(LINK32_FLAGS) $(LINK32_OBJS) -<< - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 1 -# PROP BASE Output_Dir "Debug" -# PROP BASE Intermediate_Dir "Debug" -# PROP BASE Target_Dir "" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 1 -# PROP Output_Dir "Debug" -# PROP Intermediate_Dir "Debug" -# PROP Target_Dir "" -OUTDIR=.\Debug -INTDIR=.\Debug - -ALL : ".\Debug\gc.dll" ".\Debug\gc.bsc" - -CLEAN : - -@erase ".\Debug\allchblk.obj" - -@erase ".\Debug\allchblk.sbr" - -@erase ".\Debug\alloc.obj" - -@erase ".\Debug\alloc.sbr" - -@erase ".\Debug\blacklst.obj" - -@erase ".\Debug\blacklst.sbr" - -@erase ".\Debug\checksums.obj" - -@erase ".\Debug\checksums.sbr" - -@erase ".\Debug\dbg_mlc.obj" - -@erase ".\Debug\dbg_mlc.sbr" - -@erase ".\Debug\dyn_load.obj" - -@erase ".\Debug\dyn_load.sbr" - -@erase ".\Debug\finalize.obj" - -@erase ".\Debug\finalize.sbr" - -@erase ".\Debug\fnlz_mlc.obj" - -@erase ".\Debug\fnlz_mlc.sbr" - -@erase ".\Debug\gc_cpp.obj" - -@erase ".\Debug\gc_cpp.sbr" - -@erase ".\Debug\gc.bsc" - -@erase ".\Debug\gc.dll" - -@erase ".\Debug\gc.exp" - -@erase ".\Debug\gc.lib" - -@erase ".\Debug\gc.map" - -@erase ".\Debug\gc.pdb" - -@erase ".\Debug\headers.obj" - -@erase ".\Debug\headers.sbr" - -@erase ".\Debug\mach_dep.obj" - -@erase ".\Debug\mach_dep.sbr" - -@erase ".\Debug\malloc.obj" - -@erase ".\Debug\malloc.sbr" - -@erase ".\Debug\mallocx.obj" - -@erase ".\Debug\mallocx.sbr" - -@erase ".\Debug\mark.obj" - -@erase ".\Debug\mark.sbr" - -@erase ".\Debug\mark_rts.obj" - -@erase ".\Debug\mark_rts.sbr" - -@erase ".\Debug\misc.obj" - -@erase ".\Debug\misc.sbr" - -@erase ".\Debug\new_hblk.obj" - -@erase ".\Debug\new_hblk.sbr" - -@erase ".\Debug\obj_map.obj" - -@erase ".\Debug\obj_map.sbr" - -@erase ".\Debug\os_dep.obj" - -@erase ".\Debug\os_dep.sbr" - -@erase ".\Debug\ptr_chck.obj" - -@erase ".\Debug\ptr_chck.sbr" - -@erase ".\Debug\reclaim.obj" - -@erase ".\Debug\reclaim.sbr" - -@erase ".\Debug\stubborn.obj" - -@erase ".\Debug\stubborn.sbr" - -@erase ".\Debug\typd_mlc.obj" - -@erase ".\Debug\typd_mlc.sbr" - -@erase ".\Debug\vc40.idb" - -@erase ".\Debug\vc40.pdb" - -@erase ".\Debug\win32_threads.obj" - -@erase ".\Debug\win32_threads.sbr" - -@erase ".\Debug\msvc_dbg.obj" - -@erase ".\Debug\msvc_dbg.sbr" - -"$(OUTDIR)" : - if not exist "$(OUTDIR)/$(NULL)" mkdir "$(OUTDIR)" - -CPP=cl.exe -# ADD BASE CPP /nologo /MTd /W3 /Gm /GX /Zi /Od /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /YX /c -# ADD CPP /nologo /MDd /W3 /Gm /GX /Zi /Od /I include /D "_DEBUG" /D "WIN32" /D "_WINDOWS" /D "ALL_INTERIOR_POINTERS" /D "GC_THREADS" /FR /YX /c -CPP_PROJ=/nologo /MDd /W3 /Gm /GX /Zi /Od /I include /D "_DEBUG"\ - /D "WIN32" /D "_WINDOWS" /D "ALL_INTERIOR_POINTERS" \ - /D "GC_ASSERTIONS" /D "GC_THREADS" \ - /FR"$(INTDIR)/" /Fp"$(INTDIR)/gc.pch" /YX /Fo"$(INTDIR)/"\ - /I./libatomic_ops/src /Fd"$(INTDIR)/" /c -CPP_OBJS=.\Debug/ -CPP_SBRS=.\Debug/ - -.c{$(CPP_OBJS)}.obj: - $(CPP) $(CPP_PROJ) $< - -.cpp{$(CPP_OBJS)}.obj: - $(CPP) $(CPP_PROJ) $< - -.cxx{$(CPP_OBJS)}.obj: - $(CPP) $(CPP_PROJ) $< - -.c{$(CPP_SBRS)}.sbr: - $(CPP) $(CPP_PROJ) $< - -.cpp{$(CPP_SBRS)}.sbr: - $(CPP) $(CPP_PROJ) $< - -.cxx{$(CPP_SBRS)}.sbr: - $(CPP) $(CPP_PROJ) $< - -MTL=mktyplib.exe -# ADD BASE MTL /nologo /D "_DEBUG" /win32 -# ADD MTL /nologo /D "_DEBUG" /win32 -MTL_PROJ=/nologo /D "_DEBUG" /win32 -RSC=rc.exe -# ADD BASE RSC /l 0x809 /d "_DEBUG" -# ADD RSC /l 0x809 /d "_DEBUG" -BSC32=bscmake.exe -# ADD BASE BSC32 /nologo -# ADD BSC32 /nologo -BSC32_FLAGS=/nologo /o"$(OUTDIR)/gc.bsc" -BSC32_SBRS= \ - ".\Debug\allchblk.sbr" \ - ".\Debug\alloc.sbr" \ - ".\Debug\blacklst.sbr" \ - ".\Debug\checksums.sbr" \ - ".\Debug\dbg_mlc.sbr" \ - ".\Debug\dyn_load.sbr" \ - ".\Debug\finalize.sbr" \ - ".\Debug\fnlz_mlc.sbr" \ - ".\Debug\gc_cpp.sbr" \ - ".\Debug\headers.sbr" \ - ".\Debug\mach_dep.sbr" \ - ".\Debug\malloc.sbr" \ - ".\Debug\mallocx.sbr" \ - ".\Debug\mark.sbr" \ - ".\Debug\mark_rts.sbr" \ - ".\Debug\misc.sbr" \ - ".\Debug\new_hblk.sbr" \ - ".\Debug\obj_map.sbr" \ - ".\Debug\os_dep.sbr" \ - ".\Debug\ptr_chck.sbr" \ - ".\Debug\reclaim.sbr" \ - ".\Debug\stubborn.sbr" \ - ".\Debug\typd_mlc.sbr" \ - ".\Debug\msvc_dbg.sbr" \ - ".\Debug\win32_threads.sbr" - -".\Debug\gc.bsc" : "$(OUTDIR)" $(BSC32_SBRS) - $(BSC32) @<< - $(BSC32_FLAGS) $(BSC32_SBRS) -<< - -LINK32=link.exe -# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:windows /dll /debug /machine:I386 -# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:windows /dll /incremental:no /map /debug /machine:I386 -LINK32_FLAGS=kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib\ - advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib\ - odbccp32.lib /nologo /subsystem:windows /dll /incremental:no\ - /pdb:"$(OUTDIR)/gc.pdb" /map:"$(INTDIR)/gc.map" /debug /machine:I386\ - /out:"$(OUTDIR)/gc.dll" /implib:"$(OUTDIR)/gc.lib" -LINK32_OBJS= \ - ".\Debug\allchblk.obj" \ - ".\Debug\alloc.obj" \ - ".\Debug\blacklst.obj" \ - ".\Debug\checksums.obj" \ - ".\Debug\dbg_mlc.obj" \ - ".\Debug\dyn_load.obj" \ - ".\Debug\finalize.obj" \ - ".\Debug\fnlz_mlc.obj" \ - ".\Debug\gc_cpp.obj" \ - ".\Debug\headers.obj" \ - ".\Debug\mach_dep.obj" \ - ".\Debug\malloc.obj" \ - ".\Debug\mallocx.obj" \ - ".\Debug\mark.obj" \ - ".\Debug\mark_rts.obj" \ - ".\Debug\misc.obj" \ - ".\Debug\new_hblk.obj" \ - ".\Debug\obj_map.obj" \ - ".\Debug\os_dep.obj" \ - ".\Debug\ptr_chck.obj" \ - ".\Debug\reclaim.obj" \ - ".\Debug\stubborn.obj" \ - ".\Debug\typd_mlc.obj" \ - ".\Debug\msvc_dbg.obj" \ - ".\Debug\win32_threads.obj" - -".\Debug\gc.dll" : "$(OUTDIR)" $(DEF_FILE) $(LINK32_OBJS) - $(LINK32) @<< - $(LINK32_FLAGS) $(LINK32_OBJS) -<< - -!ELSEIF "$(CFG)" == "gctest - Win32 Release" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 0 -# PROP BASE Output_Dir "gctest\Release" -# PROP BASE Intermediate_Dir "gctest\Release" -# PROP BASE Target_Dir "gctest" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 0 -# PROP Output_Dir "gctest\Release" -# PROP Intermediate_Dir "gctest\Release" -# PROP Target_Dir "gctest" -OUTDIR=.\gctest\Release -INTDIR=.\gctest\Release - -ALL : "gc - Win32 Release" ".\Release\gctest.exe" - -CLEAN : - -@erase ".\gctest\Release\test.obj" - -@erase ".\Release\gctest.exe" - -"$(OUTDIR)" : - if not exist "$(OUTDIR)/$(NULL)" mkdir "$(OUTDIR)" - -test.c : tests\test.c - copy tests\test.c test.c - -CPP=cl.exe -# ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /YX /c -# ADD CPP /nologo /MD /W3 /GX /O2 /I include /D "NDEBUG" /D "WIN32" /D "_WINDOWS" /D "ALL_INTERIOR_POINTERS" /D "GC_THREADS" /YX /c -CPP_PROJ=/nologo /MD /W3 /GX /O2 /I include /D "NDEBUG" /D "WIN32" /D "_WINDOWS" /D\ - "ALL_INTERIOR_POINTERS" /D "GC_THREADS" \ - /I./libatomic_ops/src /Fp"$(INTDIR)/gctest.pch" \ - /YX /Fo"$(INTDIR)/" /c -CPP_OBJS=.\gctest\Release/ -CPP_SBRS=.\. - -.c{$(CPP_OBJS)}.obj: - $(CPP) $(CPP_PROJ) $< - -.cpp{$(CPP_OBJS)}.obj: - $(CPP) $(CPP_PROJ) $< - -.cxx{$(CPP_OBJS)}.obj: - $(CPP) $(CPP_PROJ) $< - -.c{$(CPP_SBRS)}.sbr: - $(CPP) $(CPP_PROJ) $< - -.cpp{$(CPP_SBRS)}.sbr: - $(CPP) $(CPP_PROJ) $< - -.cxx{$(CPP_SBRS)}.sbr: - $(CPP) $(CPP_PROJ) $< - -MTL=mktyplib.exe -# ADD BASE MTL /nologo /D "NDEBUG" /win32 -# ADD MTL /nologo /D "NDEBUG" /win32 -MTL_PROJ=/nologo /D "NDEBUG" /win32 -RSC=rc.exe -# ADD BASE RSC /l 0x809 /d "NDEBUG" -# ADD RSC /l 0x809 /d "NDEBUG" -BSC32=bscmake.exe -# ADD BASE BSC32 /nologo -# ADD BSC32 /nologo -BSC32_FLAGS=/nologo /o"$(OUTDIR)/gctest.bsc" -BSC32_SBRS= \ - -LINK32=link.exe -# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:windows /machine:I386 -# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:windows /machine:I386 /out:"Release/gctest.exe" -LINK32_FLAGS=kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib\ - advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib\ - odbccp32.lib /nologo /subsystem:windows /incremental:no\ - /pdb:"$(OUTDIR)/gctest.pdb" /machine:I386 /out:"Release/gctest.exe" -LINK32_OBJS= \ - ".\gctest\Release\test.obj" \ - ".\Release\gc.lib" - -".\Release\gctest.exe" : "$(OUTDIR)" $(DEF_FILE) $(LINK32_OBJS) - $(LINK32) @<< - $(LINK32_FLAGS) $(LINK32_OBJS) -<< - -!ELSEIF "$(CFG)" == "gctest - Win32 Debug" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 1 -# PROP BASE Output_Dir "gctest\Debug" -# PROP BASE Intermediate_Dir "gctest\Debug" -# PROP BASE Target_Dir "gctest" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 1 -# PROP Output_Dir "gctest\Debug" -# PROP Intermediate_Dir "gctest\Debug" -# PROP Target_Dir "gctest" -OUTDIR=.\gctest\Debug -INTDIR=.\gctest\Debug - -ALL : "gc - Win32 Debug" ".\Debug\gctest.exe" ".\gctest\Debug\gctest.bsc" - -CLEAN : - -@erase ".\Debug\gctest.exe" - -@erase ".\gctest\Debug\gctest.bsc" - -@erase ".\gctest\Debug\gctest.map" - -@erase ".\gctest\Debug\gctest.pdb" - -@erase ".\gctest\Debug\test.obj" - -@erase ".\gctest\Debug\test.sbr" - -@erase ".\gctest\Debug\vc40.idb" - -@erase ".\gctest\Debug\vc40.pdb" - -"$(OUTDIR)" : - if not exist "$(OUTDIR)/$(NULL)" mkdir "$(OUTDIR)" - -CPP=cl.exe -# ADD BASE CPP /nologo /W3 /Gm /GX /Zi /Od /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /YX /c -# ADD CPP /nologo /MDd /W3 /Gm /GX /Zi /Od /D "_DEBUG" /D "WIN32" /D "_WINDOWS" /D "ALL_INTERIOR_POINTERS" /D "GC_THREADS" /FR /YX /c -CPP_PROJ=/nologo /MDd /W3 /Gm /GX /Zi /Od /I include /D "_DEBUG" /D "WIN32" /D "_WINDOWS"\ - /D "ALL_INTERIOR_POINTERS" /D "GC_THREADS" /FR"$(INTDIR)/"\ - /I./libatomic_ops/src /Fp"$(INTDIR)/gctest.pch" /YX /Fo"$(INTDIR)/" /Fd"$(INTDIR)/" /c -CPP_OBJS=.\gctest\Debug/ -CPP_SBRS=.\gctest\Debug/ - -.c{$(CPP_OBJS)}.obj: - $(CPP) $(CPP_PROJ) $< - -.cpp{$(CPP_OBJS)}.obj: - $(CPP) $(CPP_PROJ) $< - -.cxx{$(CPP_OBJS)}.obj: - $(CPP) $(CPP_PROJ) $< - -.c{$(CPP_SBRS)}.sbr: - $(CPP) $(CPP_PROJ) $< - -.cpp{$(CPP_SBRS)}.sbr: - $(CPP) $(CPP_PROJ) $< - -.cxx{$(CPP_SBRS)}.sbr: - $(CPP) $(CPP_PROJ) $< - -MTL=mktyplib.exe -# ADD BASE MTL /nologo /D "_DEBUG" /win32 -# ADD MTL /nologo /D "_DEBUG" /win32 -MTL_PROJ=/nologo /D "_DEBUG" /win32 -RSC=rc.exe -# ADD BASE RSC /l 0x809 /d "_DEBUG" -# ADD RSC /l 0x809 /d "_DEBUG" -BSC32=bscmake.exe -# ADD BASE BSC32 /nologo -# ADD BSC32 /nologo -BSC32_FLAGS=/nologo /o"$(OUTDIR)/gctest.bsc" -BSC32_SBRS= \ - ".\gctest\Debug\test.sbr" - -".\gctest\Debug\gctest.bsc" : "$(OUTDIR)" $(BSC32_SBRS) - $(BSC32) @<< - $(BSC32_FLAGS) $(BSC32_SBRS) -<< - -LINK32=link.exe -# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:windows /debug /machine:I386 -# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:windows /incremental:no /map /debug /machine:I386 /out:"Debug/gctest.exe" -LINK32_FLAGS=kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib\ - advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib\ - odbccp32.lib /nologo /subsystem:windows /incremental:no\ - /pdb:"$(OUTDIR)/gctest.pdb" /map:"$(INTDIR)/gctest.map" /debug /machine:I386\ - /out:"Debug/gctest.exe" -LINK32_OBJS= \ - ".\Debug\gc.lib" \ - ".\gctest\Debug\test.obj" - -".\Debug\gctest.exe" : "$(OUTDIR)" $(DEF_FILE) $(LINK32_OBJS) - $(LINK32) @<< - $(LINK32_FLAGS) $(LINK32_OBJS) -<< - -!ELSEIF "$(CFG)" == "cord - Win32 Release" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 0 -# PROP BASE Output_Dir "cord\Release" -# PROP BASE Intermediate_Dir "cord\Release" -# PROP BASE Target_Dir "cord" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 0 -# PROP Output_Dir "cord\Release" -# PROP Intermediate_Dir "cord\Release" -# PROP Target_Dir "cord" -OUTDIR=.\cord\Release -INTDIR=.\cord\Release - -ALL : "gc - Win32 Release" ".\Release\de.exe" - -CLEAN : - -@erase ".\cord\Release\cordbscs.obj" - -@erase ".\cord\Release\cordxtra.obj" - -@erase ".\cord\Release\de.obj" - -@erase ".\cord\Release\de_win.obj" - -@erase ".\cord\Release\de_win.res" - -@erase ".\Release\de.exe" - -"$(OUTDIR)" : - if not exist "$(OUTDIR)/$(NULL)" mkdir "$(OUTDIR)" - -CPP=cl.exe -# ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /YX /c -# ADD CPP /nologo /MD /W3 /GX /O2 /I "." /D "NDEBUG" /D "WIN32" /D "_WINDOWS" /D "ALL_INTERIOR_POINTERS" /YX /c -CPP_PROJ=/nologo /MD /W3 /GX /O2 /I "." /I include /D "NDEBUG" /D "WIN32" /D "_WINDOWS" /D\ - /I./libatomic_ops/src "ALL_INTERIOR_POINTERS" /Fp"$(INTDIR)/cord.pch" /YX /Fo"$(INTDIR)/" /c -CPP_OBJS=.\cord\Release/ -CPP_SBRS=.\. - -.c{$(CPP_OBJS)}.obj: - $(CPP) $(CPP_PROJ) $< - -.cpp{$(CPP_OBJS)}.obj: - $(CPP) $(CPP_PROJ) $< - -.cxx{$(CPP_OBJS)}.obj: - $(CPP) $(CPP_PROJ) $< - -.c{$(CPP_SBRS)}.sbr: - $(CPP) $(CPP_PROJ) $< - -.cpp{$(CPP_SBRS)}.sbr: - $(CPP) $(CPP_PROJ) $< - -.cxx{$(CPP_SBRS)}.sbr: - $(CPP) $(CPP_PROJ) $< - -MTL=mktyplib.exe -# ADD BASE MTL /nologo /D "NDEBUG" /win32 -# ADD MTL /nologo /D "NDEBUG" /win32 -MTL_PROJ=/nologo /D "NDEBUG" /win32 -RSC=rc.exe -# ADD BASE RSC /l 0x809 /d "NDEBUG" -# ADD RSC /l 0x809 /d "NDEBUG" -RSC_PROJ=/l 0x809 /fo"$(INTDIR)/de_win.res" /d "NDEBUG" -BSC32=bscmake.exe -# ADD BASE BSC32 /nologo -# ADD BSC32 /nologo -BSC32_FLAGS=/nologo /o"$(OUTDIR)/cord.bsc" -BSC32_SBRS= \ - -LINK32=link.exe -# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:windows /machine:I386 -# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:windows /machine:I386 /out:"Release/de.exe" -LINK32_FLAGS=kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib\ - advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib\ - odbccp32.lib /nologo /subsystem:windows /incremental:no /pdb:"$(OUTDIR)/de.pdb"\ - /machine:I386 /out:"Release/de.exe" -LINK32_OBJS= \ - ".\cord\Release\cordbscs.obj" \ - ".\cord\Release\cordxtra.obj" \ - ".\cord\Release\de.obj" \ - ".\cord\Release\de_win.obj" \ - ".\cord\Release\de_win.res" \ - ".\Release\gc.lib" - -".\Release\de.exe" : "$(OUTDIR)" $(DEF_FILE) $(LINK32_OBJS) - $(LINK32) @<< - $(LINK32_FLAGS) $(LINK32_OBJS) -<< - -!ELSEIF "$(CFG)" == "cord - Win32 Debug" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 1 -# PROP BASE Output_Dir "cord\Debug" -# PROP BASE Intermediate_Dir "cord\Debug" -# PROP BASE Target_Dir "cord" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 1 -# PROP Output_Dir "cord\Debug" -# PROP Intermediate_Dir "cord\Debug" -# PROP Target_Dir "cord" -OUTDIR=.\cord\Debug -INTDIR=.\cord\Debug - -ALL : "gc - Win32 Debug" ".\Debug\de.exe" - -CLEAN : - -@erase ".\cord\Debug\cordbscs.obj" - -@erase ".\cord\Debug\cordxtra.obj" - -@erase ".\cord\Debug\de.obj" - -@erase ".\cord\Debug\de.pdb" - -@erase ".\cord\Debug\de_win.obj" - -@erase ".\cord\Debug\de_win.res" - -@erase ".\cord\Debug\vc40.idb" - -@erase ".\cord\Debug\vc40.pdb" - -@erase ".\Debug\de.exe" - -@erase ".\Debug\de.ilk" - -"$(OUTDIR)" : - if not exist "$(OUTDIR)/$(NULL)" mkdir "$(OUTDIR)" - -CPP=cl.exe -# ADD BASE CPP /nologo /W3 /Gm /GX /Zi /Od /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /YX /c -# ADD CPP /nologo /MDd /W3 /Gm /GX /Zi /Od /I "." /D "_DEBUG" /D "WIN32" /D "_WINDOWS" /D "ALL_INTERIOR_POINTERS" /YX /c -CPP_PROJ=/nologo /MDd /W3 /Gm /GX /Zi /Od /I "." /I include /D "_DEBUG" /D "WIN32" /D\ - "_WINDOWS" /D "ALL_INTERIOR_POINTERS" /Fp"$(INTDIR)/cord.pch" /YX\ - /I./libatomic_ops/src /Fo"$(INTDIR)/" /Fd"$(INTDIR)/" /c -CPP_OBJS=.\cord\Debug/ -CPP_SBRS=.\. - -.c{$(CPP_OBJS)}.obj: - $(CPP) $(CPP_PROJ) $< - -.cpp{$(CPP_OBJS)}.obj: - $(CPP) $(CPP_PROJ) $< - -.cxx{$(CPP_OBJS)}.obj: - $(CPP) $(CPP_PROJ) $< - -.c{$(CPP_SBRS)}.sbr: - $(CPP) $(CPP_PROJ) $< - -.cpp{$(CPP_SBRS)}.sbr: - $(CPP) $(CPP_PROJ) $< - -.cxx{$(CPP_SBRS)}.sbr: - $(CPP) $(CPP_PROJ) $< - -MTL=mktyplib.exe -# ADD BASE MTL /nologo /D "_DEBUG" /win32 -# ADD MTL /nologo /D "_DEBUG" /win32 -MTL_PROJ=/nologo /D "_DEBUG" /win32 -RSC=rc.exe -# ADD BASE RSC /l 0x809 /d "_DEBUG" -# ADD RSC /l 0x809 /d "_DEBUG" -RSC_PROJ=/l 0x809 /fo"$(INTDIR)/de_win.res" /d "_DEBUG" -BSC32=bscmake.exe -# ADD BASE BSC32 /nologo -# ADD BSC32 /nologo -BSC32_FLAGS=/nologo /o"$(OUTDIR)/cord.bsc" -BSC32_SBRS= \ - -LINK32=link.exe -# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:windows /debug /machine:I386 -# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:windows /debug /machine:I386 /out:"Debug/de.exe" -LINK32_FLAGS=kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib\ - advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib\ - odbccp32.lib /nologo /subsystem:windows /incremental:yes\ - /pdb:"$(OUTDIR)/de.pdb" /debug /machine:I386 /out:"Debug/de.exe" -LINK32_OBJS= \ - ".\cord\Debug\cordbscs.obj" \ - ".\cord\Debug\cordxtra.obj" \ - ".\cord\Debug\de.obj" \ - ".\cord\Debug\de_win.obj" \ - ".\cord\Debug\de_win.res" \ - ".\Debug\gc.lib" - -".\Debug\de.exe" : "$(OUTDIR)" $(DEF_FILE) $(LINK32_OBJS) - $(LINK32) @<< - $(LINK32_FLAGS) $(LINK32_OBJS) -<< - -!ENDIF - -################################################################################ -# Begin Target - -# Name "gc - Win32 Release" -# Name "gc - Win32 Debug" - -!IF "$(CFG)" == "gc - Win32 Release" - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -!ENDIF - -################################################################################ -# Begin Source File - -SOURCE=.\gc_cpp.cpp - -!IF "$(CFG)" == "gc - Win32 Release" - -DEP_CPP_RECLA=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - ".\include\gc_cpp.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_RECLA=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Release\gc_cpp.obj" : $(SOURCE) $(DEP_CPP_RECLA) "$(INTDIR)" - -".\Release\gc_cpp.sbr" : $(SOURCE) $(DEP_CPP_RECLA) "$(INTDIR)" - - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -DEP_CPP_RECLA=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - ".\include\gc_cpp.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_RECLA=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Debug\gc_cpp.obj" : $(SOURCE) $(DEP_CPP_RECLA) "$(INTDIR)" - -".\Debug\gc_cpp.sbr" : $(SOURCE) $(DEP_CPP_RECLA) "$(INTDIR)" - - -!ENDIF - -# End Source File -################################################################################ -# Begin Source File - -SOURCE=.\reclaim.c - -!IF "$(CFG)" == "gc - Win32 Release" - -DEP_CPP_RECLA=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_RECLA=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Release\reclaim.obj" : $(SOURCE) $(DEP_CPP_RECLA) "$(INTDIR)" - -".\Release\reclaim.sbr" : $(SOURCE) $(DEP_CPP_RECLA) "$(INTDIR)" - - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -DEP_CPP_RECLA=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_RECLA=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Debug\reclaim.obj" : $(SOURCE) $(DEP_CPP_RECLA) "$(INTDIR)" - -".\Debug\reclaim.sbr" : $(SOURCE) $(DEP_CPP_RECLA) "$(INTDIR)" - - -!ENDIF - -# End Source File - -################################################################################ -# Begin Source File - -SOURCE=.\os_dep.c - -!IF "$(CFG)" == "gc - Win32 Release" - -DEP_CPP_OS_DE=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\STAT.H"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_OS_DE=\ - ".\il\PCR_IL.h"\ - ".\mm\PCR_MM.h"\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - ".\vd\PCR_VD.h"\ - - -".\Release\os_dep.obj" : $(SOURCE) $(DEP_CPP_OS_DE) "$(INTDIR)" - -".\Release\os_dep.sbr" : $(SOURCE) $(DEP_CPP_OS_DE) "$(INTDIR)" - - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -DEP_CPP_OS_DE=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\STAT.H"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_OS_DE=\ - ".\il\PCR_IL.h"\ - ".\mm\PCR_MM.h"\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - ".\vd\PCR_VD.h"\ - - -".\Debug\os_dep.obj" : $(SOURCE) $(DEP_CPP_OS_DE) "$(INTDIR)" - -".\Debug\os_dep.sbr" : $(SOURCE) $(DEP_CPP_OS_DE) "$(INTDIR)" - - -!ENDIF - -# End Source File -################################################################################ -# Begin Source File - -SOURCE=.\misc.c - -!IF "$(CFG)" == "gc - Win32 Release" - -DEP_CPP_MISC_=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_MISC_=\ - ".\il\PCR_IL.h"\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Release\misc.obj" : $(SOURCE) $(DEP_CPP_MISC_) "$(INTDIR)" - -".\Release\misc.sbr" : $(SOURCE) $(DEP_CPP_MISC_) "$(INTDIR)" - - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -DEP_CPP_MISC_=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_MISC_=\ - ".\il\PCR_IL.h"\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Debug\misc.obj" : $(SOURCE) $(DEP_CPP_MISC_) "$(INTDIR)" - -".\Debug\misc.sbr" : $(SOURCE) $(DEP_CPP_MISC_) "$(INTDIR)" - - -!ENDIF - -# End Source File -################################################################################ -# Begin Source File - -SOURCE=.\mark_rts.c - -!IF "$(CFG)" == "gc - Win32 Release" - -DEP_CPP_MARK_=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_MARK_=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Release\mark_rts.obj" : $(SOURCE) $(DEP_CPP_MARK_) "$(INTDIR)" - -".\Release\mark_rts.sbr" : $(SOURCE) $(DEP_CPP_MARK_) "$(INTDIR)" - - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -DEP_CPP_MARK_=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_MARK_=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Debug\mark_rts.obj" : $(SOURCE) $(DEP_CPP_MARK_) "$(INTDIR)" - -".\Debug\mark_rts.sbr" : $(SOURCE) $(DEP_CPP_MARK_) "$(INTDIR)" - - -!ENDIF - -# End Source File -################################################################################ -# Begin Source File - -SOURCE=.\mach_dep.c - -!IF "$(CFG)" == "gc - Win32 Release" - -DEP_CPP_MACH_=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_MACH_=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Release\mach_dep.obj" : $(SOURCE) $(DEP_CPP_MACH_) "$(INTDIR)" - -".\Release\mach_dep.sbr" : $(SOURCE) $(DEP_CPP_MACH_) "$(INTDIR)" - - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -DEP_CPP_MACH_=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_MACH_=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Debug\mach_dep.obj" : $(SOURCE) $(DEP_CPP_MACH_) "$(INTDIR)" - -".\Debug\mach_dep.sbr" : $(SOURCE) $(DEP_CPP_MACH_) "$(INTDIR)" - - -!ENDIF - -# End Source File -################################################################################ -# Begin Source File - -SOURCE=.\headers.c - -!IF "$(CFG)" == "gc - Win32 Release" - -DEP_CPP_HEADE=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_HEADE=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Release\headers.obj" : $(SOURCE) $(DEP_CPP_HEADE) "$(INTDIR)" - -".\Release\headers.sbr" : $(SOURCE) $(DEP_CPP_HEADE) "$(INTDIR)" - - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -DEP_CPP_HEADE=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_HEADE=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Debug\headers.obj" : $(SOURCE) $(DEP_CPP_HEADE) "$(INTDIR)" - -".\Debug\headers.sbr" : $(SOURCE) $(DEP_CPP_HEADE) "$(INTDIR)" - - -!ENDIF - -# End Source File -################################################################################ -# Begin Source File - -SOURCE=.\alloc.c - -!IF "$(CFG)" == "gc - Win32 Release" - -DEP_CPP_ALLOC=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_ALLOC=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Release\alloc.obj" : $(SOURCE) $(DEP_CPP_ALLOC) "$(INTDIR)" - -".\Release\alloc.sbr" : $(SOURCE) $(DEP_CPP_ALLOC) "$(INTDIR)" - - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -DEP_CPP_ALLOC=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_ALLOC=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Debug\alloc.obj" : $(SOURCE) $(DEP_CPP_ALLOC) "$(INTDIR)" - -".\Debug\alloc.sbr" : $(SOURCE) $(DEP_CPP_ALLOC) "$(INTDIR)" - - -!ENDIF - -# End Source File -################################################################################ -# Begin Source File - -SOURCE=.\allchblk.c - -!IF "$(CFG)" == "gc - Win32 Release" - -DEP_CPP_ALLCH=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_ALLCH=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Release\allchblk.obj" : $(SOURCE) $(DEP_CPP_ALLCH) "$(INTDIR)" - -".\Release\allchblk.sbr" : $(SOURCE) $(DEP_CPP_ALLCH) "$(INTDIR)" - - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -DEP_CPP_ALLCH=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_ALLCH=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Debug\allchblk.obj" : $(SOURCE) $(DEP_CPP_ALLCH) "$(INTDIR)" - -".\Debug\allchblk.sbr" : $(SOURCE) $(DEP_CPP_ALLCH) "$(INTDIR)" - - -!ENDIF - -# End Source File -################################################################################ -# Begin Source File - -SOURCE=.\stubborn.c - -!IF "$(CFG)" == "gc - Win32 Release" - -DEP_CPP_STUBB=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_STUBB=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Release\stubborn.obj" : $(SOURCE) $(DEP_CPP_STUBB) "$(INTDIR)" - -".\Release\stubborn.sbr" : $(SOURCE) $(DEP_CPP_STUBB) "$(INTDIR)" - - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -DEP_CPP_STUBB=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_STUBB=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Debug\stubborn.obj" : $(SOURCE) $(DEP_CPP_STUBB) "$(INTDIR)" - -".\Debug\stubborn.sbr" : $(SOURCE) $(DEP_CPP_STUBB) "$(INTDIR)" - - -!ENDIF - -# End Source File -################################################################################ -# Begin Source File - -SOURCE=.\obj_map.c - -!IF "$(CFG)" == "gc - Win32 Release" - -DEP_CPP_OBJ_M=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_OBJ_M=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Release\obj_map.obj" : $(SOURCE) $(DEP_CPP_OBJ_M) "$(INTDIR)" - -".\Release\obj_map.sbr" : $(SOURCE) $(DEP_CPP_OBJ_M) "$(INTDIR)" - - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -DEP_CPP_OBJ_M=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_OBJ_M=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Debug\obj_map.obj" : $(SOURCE) $(DEP_CPP_OBJ_M) "$(INTDIR)" - -".\Debug\obj_map.sbr" : $(SOURCE) $(DEP_CPP_OBJ_M) "$(INTDIR)" - - -!ENDIF - -# End Source File -################################################################################ -# Begin Source File - -SOURCE=.\new_hblk.c - -!IF "$(CFG)" == "gc - Win32 Release" - -DEP_CPP_NEW_H=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_NEW_H=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Release\new_hblk.obj" : $(SOURCE) $(DEP_CPP_NEW_H) "$(INTDIR)" - -".\Release\new_hblk.sbr" : $(SOURCE) $(DEP_CPP_NEW_H) "$(INTDIR)" - - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -DEP_CPP_NEW_H=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_NEW_H=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Debug\new_hblk.obj" : $(SOURCE) $(DEP_CPP_NEW_H) "$(INTDIR)" - -".\Debug\new_hblk.sbr" : $(SOURCE) $(DEP_CPP_NEW_H) "$(INTDIR)" - - -!ENDIF - -# End Source File -################################################################################ -# Begin Source File - -SOURCE=.\mark.c - -!IF "$(CFG)" == "gc - Win32 Release" - -DEP_CPP_MARK_C=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_pmark.h"\ - ".\include\gc_mark.h"\ - ".\include\gc_disclaim.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_MARK_C=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Release\mark.obj" : $(SOURCE) $(DEP_CPP_MARK_C) "$(INTDIR)" - -".\Release\mark.sbr" : $(SOURCE) $(DEP_CPP_MARK_C) "$(INTDIR)" - - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -DEP_CPP_MARK_C=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_pmark.h"\ - ".\include\gc_mark.h"\ - ".\include\gc_disclaim.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_MARK_C=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Debug\mark.obj" : $(SOURCE) $(DEP_CPP_MARK_C) "$(INTDIR)" - -".\Debug\mark.sbr" : $(SOURCE) $(DEP_CPP_MARK_C) "$(INTDIR)" - - -!ENDIF - -# End Source File -################################################################################ -# Begin Source File - -SOURCE=.\malloc.c - -!IF "$(CFG)" == "gc - Win32 Release" - -DEP_CPP_MALLO=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_MALLO=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Release\malloc.obj" : $(SOURCE) $(DEP_CPP_MALLO) "$(INTDIR)" - -".\Release\malloc.sbr" : $(SOURCE) $(DEP_CPP_MALLO) "$(INTDIR)" - - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -DEP_CPP_MALLO=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_MALLO=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Debug\malloc.obj" : $(SOURCE) $(DEP_CPP_MALLO) "$(INTDIR)" - -".\Debug\malloc.sbr" : $(SOURCE) $(DEP_CPP_MALLO) "$(INTDIR)" - - -!ENDIF - -# End Source File -################################################################################ -# Begin Source File - -SOURCE=.\mallocx.c - -!IF "$(CFG)" == "gc - Win32 Release" - -DEP_CPP_MALLX=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_MALLX=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Release\mallocx.obj" : $(SOURCE) $(DEP_CPP_MALLX) "$(INTDIR)" - -".\Release\mallocx.sbr" : $(SOURCE) $(DEP_CPP_MALLX) "$(INTDIR)" - - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -DEP_CPP_MALLX=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_MALLX=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Debug\mallocx.obj" : $(SOURCE) $(DEP_CPP_MALLX) "$(INTDIR)" - -".\Debug\mallocx.sbr" : $(SOURCE) $(DEP_CPP_MALLX) "$(INTDIR)" - - -!ENDIF - -# End Source File -################################################################################ -# Begin Source File - -SOURCE=.\finalize.c - -!IF "$(CFG)" == "gc - Win32 Release" - -DEP_CPP_FINAL=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_pmark.h"\ - ".\include\gc_mark.h"\ - ".\include\gc_disclaim.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_FINAL=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Release\finalize.obj" : $(SOURCE) $(DEP_CPP_FINAL) "$(INTDIR)" - -".\Release\finalize.sbr" : $(SOURCE) $(DEP_CPP_FINAL) "$(INTDIR)" - - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -DEP_CPP_FINAL=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_pmark.h"\ - ".\include\gc_mark.h"\ - ".\include\gc_disclaim.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_FINAL=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Debug\finalize.obj" : $(SOURCE) $(DEP_CPP_FINAL) "$(INTDIR)" - -".\Debug\finalize.sbr" : $(SOURCE) $(DEP_CPP_FINAL) "$(INTDIR)" - - -!ENDIF - -# End Source File -################################################################################ -# Begin Source File - -SOURCE=.\dbg_mlc.c - -!IF "$(CFG)" == "gc - Win32 Release" - -DEP_CPP_DBG_M=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_DBG_M=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Release\dbg_mlc.obj" : $(SOURCE) $(DEP_CPP_DBG_M) "$(INTDIR)" - -".\Release\dbg_mlc.sbr" : $(SOURCE) $(DEP_CPP_DBG_M) "$(INTDIR)" - - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -DEP_CPP_DBG_M=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_DBG_M=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Debug\dbg_mlc.obj" : $(SOURCE) $(DEP_CPP_DBG_M) "$(INTDIR)" - -".\Debug\dbg_mlc.sbr" : $(SOURCE) $(DEP_CPP_DBG_M) "$(INTDIR)" - - -!ENDIF - -# End Source File -################################################################################ -# Begin Source File - -SOURCE=.\fnlz_mlc.c - -!IF "$(CFG)" == "gc - Win32 Release" - -DEP_CPP_DBG_M=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_DBG_M=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Release\fnlz_mlc.obj" : $(SOURCE) $(DEP_CPP_DBG_M) "$(INTDIR)" - -".\Release\fnlz_mlc.sbr" : $(SOURCE) $(DEP_CPP_DBG_M) "$(INTDIR)" - - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -DEP_CPP_DBG_M=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_DBG_M=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Debug\fnlz_mlc.obj" : $(SOURCE) $(DEP_CPP_DBG_M) "$(INTDIR)" - -".\Debug\fnlz_mlc.sbr" : $(SOURCE) $(DEP_CPP_DBG_M) "$(INTDIR)" - - -!ENDIF - -# End Source File -################################################################################ -# Begin Source File - -SOURCE=.\blacklst.c - -!IF "$(CFG)" == "gc - Win32 Release" - -DEP_CPP_BLACK=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_BLACK=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Release\blacklst.obj" : $(SOURCE) $(DEP_CPP_BLACK) "$(INTDIR)" - -".\Release\blacklst.sbr" : $(SOURCE) $(DEP_CPP_BLACK) "$(INTDIR)" - - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -DEP_CPP_BLACK=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_BLACK=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Debug\blacklst.obj" : $(SOURCE) $(DEP_CPP_BLACK) "$(INTDIR)" - -".\Debug\blacklst.sbr" : $(SOURCE) $(DEP_CPP_BLACK) "$(INTDIR)" - - -!ENDIF - -# End Source File -################################################################################ -# Begin Source File - -SOURCE=.\typd_mlc.c - -!IF "$(CFG)" == "gc - Win32 Release" - -DEP_CPP_TYPD_=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_pmark.h"\ - ".\include\gc_mark.h"\ - ".\include\gc_disclaim.h"\ - ".\include\private\gc_priv.h"\ - ".\include\gc_typed.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_TYPD_=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Release\typd_mlc.obj" : $(SOURCE) $(DEP_CPP_TYPD_) "$(INTDIR)" - -".\Release\typd_mlc.sbr" : $(SOURCE) $(DEP_CPP_TYPD_) "$(INTDIR)" - - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -DEP_CPP_TYPD_=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_pmark.h"\ - ".\include\gc_mark.h"\ - ".\include\gc_disclaim.h"\ - ".\include\private\gc_priv.h"\ - ".\include\gc_typed.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_TYPD_=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Debug\typd_mlc.obj" : $(SOURCE) $(DEP_CPP_TYPD_) "$(INTDIR)" - -".\Debug\typd_mlc.sbr" : $(SOURCE) $(DEP_CPP_TYPD_) "$(INTDIR)" - - -!ENDIF - -# End Source File -################################################################################ -# Begin Source File - -SOURCE=.\ptr_chck.c - -!IF "$(CFG)" == "gc - Win32 Release" - -DEP_CPP_PTR_C=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_pmark.h"\ - ".\include\gc_mark.h"\ - ".\include\gc_disclaim.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_PTR_C=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Release\ptr_chck.obj" : $(SOURCE) $(DEP_CPP_PTR_C) "$(INTDIR)" - -".\Release\ptr_chck.sbr" : $(SOURCE) $(DEP_CPP_PTR_C) "$(INTDIR)" - - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -DEP_CPP_PTR_C=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_pmark.h"\ - ".\include\gc_mark.h"\ - ".\include\gc_disclaim.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_PTR_C=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Debug\ptr_chck.obj" : $(SOURCE) $(DEP_CPP_PTR_C) "$(INTDIR)" - -".\Debug\ptr_chck.sbr" : $(SOURCE) $(DEP_CPP_PTR_C) "$(INTDIR)" - - -!ENDIF - -# End Source File -################################################################################ -# Begin Source File - -SOURCE=.\dyn_load.c - -!IF "$(CFG)" == "gc - Win32 Release" - -DEP_CPP_DYN_L=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\STAT.H"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_DYN_L=\ - ".\il\PCR_IL.h"\ - ".\mm\PCR_MM.h"\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Release\dyn_load.obj" : $(SOURCE) $(DEP_CPP_DYN_L) "$(INTDIR)" - -".\Release\dyn_load.sbr" : $(SOURCE) $(DEP_CPP_DYN_L) "$(INTDIR)" - - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -DEP_CPP_DYN_L=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\STAT.H"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_DYN_L=\ - ".\il\PCR_IL.h"\ - ".\mm\PCR_MM.h"\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Debug\dyn_load.obj" : $(SOURCE) $(DEP_CPP_DYN_L) "$(INTDIR)" - -".\Debug\dyn_load.sbr" : $(SOURCE) $(DEP_CPP_DYN_L) "$(INTDIR)" - - -!ENDIF - -# End Source File -################################################################################ -# Begin Source File - -SOURCE=.\win32_threads.c - -!IF "$(CFG)" == "gc - Win32 Release" - -DEP_CPP_WIN32=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_WIN32=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Release\win32_threads.obj" : $(SOURCE) $(DEP_CPP_WIN32) "$(INTDIR)" - -".\Release\win32_threads.sbr" : $(SOURCE) $(DEP_CPP_WIN32) "$(INTDIR)" - - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -DEP_CPP_WIN32=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_WIN32=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Debug\win32_threads.obj" : $(SOURCE) $(DEP_CPP_WIN32) "$(INTDIR)" - -".\Debug\win32_threads.sbr" : $(SOURCE) $(DEP_CPP_WIN32) "$(INTDIR)" - - -!ENDIF - -# End Source File -################################################################################ -# Begin Source File - -SOURCE=.\extra\msvc_dbg.c - -!IF "$(CFG)" == "gc - Win32 Release" - -DEP_CPP_WIN32=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - ".\include\private\msvc_dbg.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_WIN32=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Release\msvc_dbg.obj" : $(SOURCE) $(DEP_CPP_WIN32) "$(INTDIR)" - -".\Release\msvc_dbg.sbr" : $(SOURCE) $(DEP_CPP_WIN32) "$(INTDIR)" - - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -DEP_CPP_WIN32=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - ".\include\private\msvc_dbg.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_WIN32=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Debug\msvc_dbg.obj" : $(SOURCE) $(DEP_CPP_WIN32) "$(INTDIR)" - -".\Debug\msvc_dbg.sbr" : $(SOURCE) $(DEP_CPP_WIN32) "$(INTDIR)" - - -!ENDIF - -# End Source File -################################################################################ -# Begin Source File - -SOURCE=.\checksums.c - -!IF "$(CFG)" == "gc - Win32 Release" - -DEP_CPP_CHECK=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_CHECK=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Release\checksums.obj" : $(SOURCE) $(DEP_CPP_CHECK) "$(INTDIR)" - -".\Release\checksums.sbr" : $(SOURCE) $(DEP_CPP_CHECK) "$(INTDIR)" - - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -DEP_CPP_CHECK=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_CHECK=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -".\Debug\checksums.obj" : $(SOURCE) $(DEP_CPP_CHECK) "$(INTDIR)" - -".\Debug\checksums.sbr" : $(SOURCE) $(DEP_CPP_CHECK) "$(INTDIR)" - - -!ENDIF - -# End Source File -# End Target -################################################################################ -# Begin Target - -# Name "gctest - Win32 Release" -# Name "gctest - Win32 Debug" - -!IF "$(CFG)" == "gctest - Win32 Release" - -!ELSEIF "$(CFG)" == "gctest - Win32 Debug" - -!ENDIF - -################################################################################ -# Begin Project Dependency - -# Project_Dep_Name "gc" - -!IF "$(CFG)" == "gctest - Win32 Release" - -"gc - Win32 Release" : - $(MAKE) /$(MAKEFLAGS) /F ".\gc.mak" CFG="gc - Win32 Release" - -!ELSEIF "$(CFG)" == "gctest - Win32 Debug" - -"gc - Win32 Debug" : - $(MAKE) /$(MAKEFLAGS) /F ".\gc.mak" CFG="gc - Win32 Debug" - -!ENDIF - -# End Project Dependency -################################################################################ -# Begin Source File - -SOURCE=.\tests\test.c -DEP_CPP_TEST_=\ - ".\include\private\gcconfig.h"\ - ".\include\gc.h"\ - ".\include\private\gc_hdrs.h"\ - ".\include\private\gc_priv.h"\ - ".\include\gc_typed.h"\ - {$(INCLUDE)}"\sys\TYPES.H"\ - -NODEP_CPP_TEST_=\ - ".\th\PCR_Th.h"\ - ".\th\PCR_ThCrSec.h"\ - ".\th\PCR_ThCtl.h"\ - - -!IF "$(CFG)" == "gctest - Win32 Release" - - -".\gctest\Release\test.obj" : $(SOURCE) $(DEP_CPP_TEST_) "$(INTDIR)" - - -!ELSEIF "$(CFG)" == "gctest - Win32 Debug" - - -".\gctest\Debug\test.obj" : $(SOURCE) $(DEP_CPP_TEST_) "$(INTDIR)" - -".\gctest\Debug\test.sbr" : $(SOURCE) $(DEP_CPP_TEST_) "$(INTDIR)" - - -!ENDIF - -# End Source File -# End Target -################################################################################ -# Begin Target - -# Name "cord - Win32 Release" -# Name "cord - Win32 Debug" - -!IF "$(CFG)" == "cord - Win32 Release" - -!ELSEIF "$(CFG)" == "cord - Win32 Debug" - -!ENDIF - -################################################################################ -# Begin Project Dependency - -# Project_Dep_Name "gc" - -!IF "$(CFG)" == "cord - Win32 Release" - -"gc - Win32 Release" : - $(MAKE) /$(MAKEFLAGS) /F ".\gc.mak" CFG="gc - Win32 Release" - -!ELSEIF "$(CFG)" == "cord - Win32 Debug" - -"gc - Win32 Debug" : - $(MAKE) /$(MAKEFLAGS) /F ".\gc.mak" CFG="gc - Win32 Debug" - -!ENDIF - -# End Project Dependency -################################################################################ -# Begin Source File - -SOURCE=.\cord\tests\de_win.c -DEP_CPP_DE_WI=\ - ".\include\cord.h"\ - ".\cord\tests\de_cmds.h"\ - ".\cord\tests\de_win.h"\ - ".\include\cord_pos.h"\ - -NODEP_CPP_DE_WI=\ - ".\include\gc.h"\ - - -!IF "$(CFG)" == "cord - Win32 Release" - - -".\cord\Release\de_win.obj" : $(SOURCE) $(DEP_CPP_DE_WI) "$(INTDIR)" - $(CPP) $(CPP_PROJ) $(SOURCE) - - -!ELSEIF "$(CFG)" == "cord - Win32 Debug" - - -".\cord\Debug\de_win.obj" : $(SOURCE) $(DEP_CPP_DE_WI) "$(INTDIR)" - $(CPP) $(CPP_PROJ) $(SOURCE) - - -!ENDIF - -# End Source File -################################################################################ -# Begin Source File - -SOURCE=.\cord\tests\de.c -DEP_CPP_DE_C2e=\ - ".\include\cord.h"\ - ".\cord\tests\de_cmds.h"\ - ".\cord\tests\de_win.h"\ - ".\include\cord_pos.h"\ - -NODEP_CPP_DE_C2e=\ - ".\include\gc.h"\ - - -!IF "$(CFG)" == "cord - Win32 Release" - - -".\cord\Release\de.obj" : $(SOURCE) $(DEP_CPP_DE_C2e) "$(INTDIR)" - $(CPP) $(CPP_PROJ) $(SOURCE) - - -!ELSEIF "$(CFG)" == "cord - Win32 Debug" - - -".\cord\Debug\de.obj" : $(SOURCE) $(DEP_CPP_DE_C2e) "$(INTDIR)" - $(CPP) $(CPP_PROJ) $(SOURCE) - - -!ENDIF - -# End Source File -################################################################################ -# Begin Source File - -SOURCE=.\cord\cordxtra.c -DEP_CPP_CORDX=\ - ".\include\cord.h"\ - ".\include\ec.h"\ - ".\include\cord_pos.h"\ - -NODEP_CPP_CORDX=\ - ".\include\gc.h"\ - - -!IF "$(CFG)" == "cord - Win32 Release" - - -".\cord\Release\cordxtra.obj" : $(SOURCE) $(DEP_CPP_CORDX) "$(INTDIR)" - $(CPP) $(CPP_PROJ) $(SOURCE) - - -!ELSEIF "$(CFG)" == "cord - Win32 Debug" - - -".\cord\Debug\cordxtra.obj" : $(SOURCE) $(DEP_CPP_CORDX) "$(INTDIR)" - $(CPP) $(CPP_PROJ) $(SOURCE) - - -!ENDIF - -# End Source File -################################################################################ -# Begin Source File - -SOURCE=.\cord\cordbscs.c -DEP_CPP_CORDB=\ - ".\include\cord.h"\ - ".\include\cord_pos.h"\ - -NODEP_CPP_CORDB=\ - ".\include\gc.h"\ - - -!IF "$(CFG)" == "cord - Win32 Release" - - -".\cord\Release\cordbscs.obj" : $(SOURCE) $(DEP_CPP_CORDB) "$(INTDIR)" - $(CPP) $(CPP_PROJ) $(SOURCE) - - -!ELSEIF "$(CFG)" == "cord - Win32 Debug" - - -".\cord\Debug\cordbscs.obj" : $(SOURCE) $(DEP_CPP_CORDB) "$(INTDIR)" - $(CPP) $(CPP_PROJ) $(SOURCE) - - -!ENDIF - -# End Source File -################################################################################ -# Begin Source File - -SOURCE=.\cord\tests\de_win.rc - -!IF "$(CFG)" == "cord - Win32 Release" - - -".\cord\Release\de_win.res" : $(SOURCE) "$(INTDIR)" - $(RSC) /l 0x809 /fo"$(INTDIR)/de_win.res" /i "cord" /d "NDEBUG" $(SOURCE) - - -!ELSEIF "$(CFG)" == "cord - Win32 Debug" - - -".\cord\Debug\de_win.res" : $(SOURCE) "$(INTDIR)" - $(RSC) /l 0x809 /fo"$(INTDIR)/de_win.res" /i "cord" /d "_DEBUG" $(SOURCE) - - -!ENDIF - -# End Source File -# End Target -# End Project -################################################################################ diff -Nru ecl-16.1.2/src/bdwgc/.gitattributes ecl-16.1.3+ds/src/bdwgc/.gitattributes --- ecl-16.1.2/src/bdwgc/.gitattributes 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/.gitattributes 1970-01-01 00:00:00.000000000 +0000 @@ -1,11 +0,0 @@ -# Git repo attributes. - -# Ensure all text files have normalized (LF) line endings in the repository. -* text=auto - -# These files should use CR/LF line ending: -/BCC_MAKEFILE -text -/digimars.mak -text - -# Note: "core.eol" configuration variable controls which line endings to use -# for the normalized files in the working directory (the default is native). diff -Nru ecl-16.1.2/src/bdwgc/.gitignore ecl-16.1.3+ds/src/bdwgc/.gitignore --- ecl-16.1.2/src/bdwgc/.gitignore 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/.gitignore 1970-01-01 00:00:00.000000000 +0000 @@ -1,125 +0,0 @@ -# Ignored files in bdwgc Git repo. - -# Binary files (in root dir, cord, tests): -*.dll -*.exe -*.gcda -*.gch -*.gcno -*.la -*.lib -*.lo -*.o -*.obj - -.dirstamp -/*.gc.log -/*_bench.log -/*_bench.trs -/*test.log -/*test.trs -/.libs/ -/Makefile -/add_gc_prefix -/base_lib -/bdw-gc.pc -/c++ -/config.cache -/config.log -/config.status -/cord/cordtest -/cord/de -/cord/de_win.rbj -/cord/de_win.res -/cord/tests/de_win.res -/cordtest -/core -/de -/disclaim_bench -/disclaim_test -/gc-* -/gc.a -/gc.log -/gcname -/gctest -/hugetest -/if_mach -/if_not_there -/initsecondarythread_test -/leaktest -/libtool -/middletest -/realloc_test -/setjmp_test -/smashtest -/staticrootstest -/subthreadcreate_test -/test-suite.log -/test_cpp -/test_cpp.log -/test_cpp.trs -/threadkey_test -/threadleaktest -/threadlibs -/tracetest - -# Config, dependency and stamp files generated by configure: -.deps/ -config.h -config.h.in~ -stamp-h1 - -# External library (without trailing slash to allow symlinks): -# /libatomic_ops* -# /pthreads-w32* - -# These files are generated by autoreconf: -# /Makefile.in -# /aclocal.m4 -# /autom4te.cache/ -# /compile -# /config.guess -# /config.sub -# /configure -# /depcomp -# /include/config.h.in -# /install-sh -# /ltmain.sh -# /m4/libtool.m4 -# /m4/ltoptions.m4 -# /m4/ltsugar.m4 -# /m4/ltversion.m4 -# /m4/lt~obsolete.m4 -# /missing -# /mkinstalldirs -# /test-driver - -# These files are generated by CMake: -/*.vcxproj -/*.vcxproj.filters -/CMakeCache.txt -/CMakeFiles/ -/cmake_install.cmake -/gc.sln -/tests/*.vcxproj -/tests/*.vcxproj.filters -/tests/CMakeFiles/ -/tests/Makefile -/tests/cmake_install.cmake - -# Rarely generated files (mostly by some Win/DOS compilers): -/*.bsc -/*.csm -/*.err -/*.exp -/*.lb1 -/*.lnk -/*.map -/*.out -/*.pdb -/*.rbj -/*.res -/*.sbr -/*.stackdump -/*.sym -/*.tmp diff -Nru ecl-16.1.2/src/bdwgc/headers.c ecl-16.1.3+ds/src/bdwgc/headers.c --- ecl-16.1.2/src/bdwgc/headers.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/headers.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,406 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996 by Silicon Graphics. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#include "private/gc_priv.h" - -/* - * This implements: - * 1. allocation of heap block headers - * 2. A map from addresses to heap block addresses to heap block headers - * - * Access speed is crucial. We implement an index structure based on a 2 - * level tree. - */ - -STATIC bottom_index * GC_all_bottom_indices = 0; - /* Pointer to first (lowest addr) */ - /* bottom_index. */ - -STATIC bottom_index * GC_all_bottom_indices_end = 0; - /* Pointer to last (highest addr) */ - /* bottom_index. */ - -/* Non-macro version of header location routine */ -GC_INNER hdr * GC_find_header(ptr_t h) -{ -# ifdef HASH_TL - hdr * result; - GET_HDR(h, result); - return(result); -# else - return(HDR_INNER(h)); -# endif -} - -/* Handle a header cache miss. Returns a pointer to the */ -/* header corresponding to p, if p can possibly be a valid */ -/* object pointer, and 0 otherwise. */ -/* GUARANTEED to return 0 for a pointer past the first page */ -/* of an object unless both GC_all_interior_pointers is set */ -/* and p is in fact a valid object pointer. */ -/* Never returns a pointer to a free hblk. */ -GC_INNER hdr * -#ifdef PRINT_BLACK_LIST - GC_header_cache_miss(ptr_t p, hdr_cache_entry *hce, ptr_t source) -#else - GC_header_cache_miss(ptr_t p, hdr_cache_entry *hce) -#endif -{ - hdr *hhdr; - HC_MISS(); - GET_HDR(p, hhdr); - if (IS_FORWARDING_ADDR_OR_NIL(hhdr)) { - if (GC_all_interior_pointers) { - if (hhdr != 0) { - ptr_t current = p; - - current = (ptr_t)HBLKPTR(current); - do { - current = current - HBLKSIZE*(word)hhdr; - hhdr = HDR(current); - } while(IS_FORWARDING_ADDR_OR_NIL(hhdr)); - /* current points to near the start of the large object */ - if (hhdr -> hb_flags & IGNORE_OFF_PAGE) - return 0; - if (HBLK_IS_FREE(hhdr) - || p - current >= (ptrdiff_t)(hhdr->hb_sz)) { - GC_ADD_TO_BLACK_LIST_NORMAL(p, source); - /* Pointer past the end of the block */ - return 0; - } - } else { - GC_ADD_TO_BLACK_LIST_NORMAL(p, source); - /* And return zero: */ - } - GC_ASSERT(hhdr == 0 || !HBLK_IS_FREE(hhdr)); - return hhdr; - /* Pointers past the first page are probably too rare */ - /* to add them to the cache. We don't. */ - /* And correctness relies on the fact that we don't. */ - } else { - if (hhdr == 0) { - GC_ADD_TO_BLACK_LIST_NORMAL(p, source); - } - return 0; - } - } else { - if (HBLK_IS_FREE(hhdr)) { - GC_ADD_TO_BLACK_LIST_NORMAL(p, source); - return 0; - } else { - hce -> block_addr = (word)(p) >> LOG_HBLKSIZE; - hce -> hce_hdr = hhdr; - return hhdr; - } - } -} - -/* Routines to dynamically allocate collector data structures that will */ -/* never be freed. */ - -static ptr_t scratch_free_ptr = 0; - -/* GC_scratch_last_end_ptr is end point of last obtained scratch area. */ -/* GC_scratch_end_ptr is end point of current scratch area. */ - -GC_INNER ptr_t GC_scratch_alloc(size_t bytes) -{ - ptr_t result = scratch_free_ptr; - word bytes_to_get; - - bytes = ROUNDUP_GRANULE_SIZE(bytes); - for (;;) { - scratch_free_ptr += bytes; - if ((word)scratch_free_ptr <= (word)GC_scratch_end_ptr) { - /* Unallocated space of scratch buffer has enough size. */ - return result; - } - - if (bytes >= MINHINCR * HBLKSIZE) { - bytes_to_get = ROUNDUP_PAGESIZE_IF_MMAP(bytes); - result = (ptr_t)GET_MEM(bytes_to_get); - GC_add_to_our_memory(result, bytes_to_get); - /* Undo scratch free area pointer update; get memory directly. */ - scratch_free_ptr -= bytes; - if (result != NULL) { - /* Update end point of last obtained area (needed only */ - /* by GC_register_dynamic_libraries for some targets). */ - GC_scratch_last_end_ptr = result + bytes; - } - return result; - } - - bytes_to_get = ROUNDUP_PAGESIZE_IF_MMAP(MINHINCR * HBLKSIZE); - /* round up for safety */ - result = (ptr_t)GET_MEM(bytes_to_get); - GC_add_to_our_memory(result, bytes_to_get); - if (NULL == result) { - WARN("Out of memory - trying to allocate requested amount" - " (%" WARN_PRIdPTR " bytes)...\n", (word)bytes); - scratch_free_ptr -= bytes; /* Undo free area pointer update */ - bytes_to_get = ROUNDUP_PAGESIZE_IF_MMAP(bytes); - result = (ptr_t)GET_MEM(bytes_to_get); - GC_add_to_our_memory(result, bytes_to_get); - return result; - } - /* Update scratch area pointers and retry. */ - scratch_free_ptr = result; - GC_scratch_end_ptr = scratch_free_ptr + bytes_to_get; - GC_scratch_last_end_ptr = GC_scratch_end_ptr; - } -} - -static hdr * hdr_free_list = 0; - -/* Return an uninitialized header */ -static hdr * alloc_hdr(void) -{ - register hdr * result; - - if (hdr_free_list == 0) { - result = (hdr *) GC_scratch_alloc((word)(sizeof(hdr))); - } else { - result = hdr_free_list; - hdr_free_list = (hdr *) (result -> hb_next); - } - return(result); -} - -GC_INLINE void free_hdr(hdr * hhdr) -{ - hhdr -> hb_next = (struct hblk *) hdr_free_list; - hdr_free_list = hhdr; -} - -#ifdef COUNT_HDR_CACHE_HITS - /* Used for debugging/profiling (the symbols are externally visible). */ - word GC_hdr_cache_hits = 0; - word GC_hdr_cache_misses = 0; -#endif - -GC_INNER void GC_init_headers(void) -{ - register unsigned i; - - GC_all_nils = (bottom_index *)GC_scratch_alloc((word)sizeof(bottom_index)); - if (GC_all_nils == NULL) { - GC_err_printf("Insufficient memory for GC_all_nils\n"); - EXIT(); - } - BZERO(GC_all_nils, sizeof(bottom_index)); - for (i = 0; i < TOP_SZ; i++) { - GC_top_index[i] = GC_all_nils; - } -} - -/* Make sure that there is a bottom level index block for address addr */ -/* Return FALSE on failure. */ -static GC_bool get_index(word addr) -{ - word hi = (word)(addr) >> (LOG_BOTTOM_SZ + LOG_HBLKSIZE); - bottom_index * r; - bottom_index * p; - bottom_index ** prev; - bottom_index *pi; - -# ifdef HASH_TL - word i = TL_HASH(hi); - bottom_index * old; - - old = p = GC_top_index[i]; - while(p != GC_all_nils) { - if (p -> key == hi) return(TRUE); - p = p -> hash_link; - } - r = (bottom_index*)GC_scratch_alloc((word)(sizeof (bottom_index))); - if (r == 0) return(FALSE); - BZERO(r, sizeof (bottom_index)); - r -> hash_link = old; - GC_top_index[i] = r; -# else - if (GC_top_index[hi] != GC_all_nils) return(TRUE); - r = (bottom_index*)GC_scratch_alloc((word)(sizeof (bottom_index))); - if (r == 0) return(FALSE); - GC_top_index[hi] = r; - BZERO(r, sizeof (bottom_index)); -# endif - r -> key = hi; - /* Add it to the list of bottom indices */ - prev = &GC_all_bottom_indices; /* pointer to p */ - pi = 0; /* bottom_index preceding p */ - while ((p = *prev) != 0 && p -> key < hi) { - pi = p; - prev = &(p -> asc_link); - } - r -> desc_link = pi; - if (0 == p) { - GC_all_bottom_indices_end = r; - } else { - p -> desc_link = r; - } - r -> asc_link = p; - *prev = r; - return(TRUE); -} - -/* Install a header for block h. */ -/* The header is uninitialized. */ -/* Returns the header or 0 on failure. */ -GC_INNER struct hblkhdr * GC_install_header(struct hblk *h) -{ - hdr * result; - - if (!get_index((word) h)) return(0); - result = alloc_hdr(); - if (result) { - SET_HDR(h, result); -# ifdef USE_MUNMAP - result -> hb_last_reclaimed = (unsigned short)GC_gc_no; -# endif - } - return(result); -} - -/* Set up forwarding counts for block h of size sz */ -GC_INNER GC_bool GC_install_counts(struct hblk *h, size_t sz/* bytes */) -{ - struct hblk * hbp; - word i; - - for (hbp = h; (word)hbp < (word)h + sz; hbp += BOTTOM_SZ) { - if (!get_index((word) hbp)) return(FALSE); - } - if (!get_index((word)h + sz - 1)) return(FALSE); - for (hbp = h + 1; (word)hbp < (word)h + sz; hbp += 1) { - i = HBLK_PTR_DIFF(hbp, h); - SET_HDR(hbp, (hdr *)(i > MAX_JUMP? MAX_JUMP : i)); - } - return(TRUE); -} - -/* Remove the header for block h */ -GC_INNER void GC_remove_header(struct hblk *h) -{ - hdr **ha; - GET_HDR_ADDR(h, ha); - free_hdr(*ha); - *ha = 0; -} - -/* Remove forwarding counts for h */ -GC_INNER void GC_remove_counts(struct hblk *h, size_t sz/* bytes */) -{ - register struct hblk * hbp; - for (hbp = h+1; (word)hbp < (word)h + sz; hbp += 1) { - SET_HDR(hbp, 0); - } -} - -/* Apply fn to all allocated blocks */ -/*VARARGS1*/ -void GC_apply_to_all_blocks(void (*fn)(struct hblk *h, word client_data), - word client_data) -{ - signed_word j; - bottom_index * index_p; - - for (index_p = GC_all_bottom_indices; index_p != 0; - index_p = index_p -> asc_link) { - for (j = BOTTOM_SZ-1; j >= 0;) { - if (!IS_FORWARDING_ADDR_OR_NIL(index_p->index[j])) { - if (!HBLK_IS_FREE(index_p->index[j])) { - (*fn)(((struct hblk *) - (((index_p->key << LOG_BOTTOM_SZ) + (word)j) - << LOG_HBLKSIZE)), - client_data); - } - j--; - } else if (index_p->index[j] == 0) { - j--; - } else { - j -= (signed_word)(index_p->index[j]); - } - } - } -} - -/* Get the next valid block whose address is at least h */ -/* Return 0 if there is none. */ -GC_INNER struct hblk * GC_next_used_block(struct hblk *h) -{ - register bottom_index * bi; - register word j = ((word)h >> LOG_HBLKSIZE) & (BOTTOM_SZ-1); - - GET_BI(h, bi); - if (bi == GC_all_nils) { - register word hi = (word)h >> (LOG_BOTTOM_SZ + LOG_HBLKSIZE); - bi = GC_all_bottom_indices; - while (bi != 0 && bi -> key < hi) bi = bi -> asc_link; - j = 0; - } - while(bi != 0) { - while (j < BOTTOM_SZ) { - hdr * hhdr = bi -> index[j]; - if (IS_FORWARDING_ADDR_OR_NIL(hhdr)) { - j++; - } else { - if (!HBLK_IS_FREE(hhdr)) { - return((struct hblk *) - (((bi -> key << LOG_BOTTOM_SZ) + j) - << LOG_HBLKSIZE)); - } else { - j += divHBLKSZ(hhdr -> hb_sz); - } - } - } - j = 0; - bi = bi -> asc_link; - } - return(0); -} - -/* Get the last (highest address) block whose address is */ -/* at most h. Return 0 if there is none. */ -/* Unlike the above, this may return a free block. */ -GC_INNER struct hblk * GC_prev_block(struct hblk *h) -{ - register bottom_index * bi; - register signed_word j = ((word)h >> LOG_HBLKSIZE) & (BOTTOM_SZ-1); - - GET_BI(h, bi); - if (bi == GC_all_nils) { - register word hi = (word)h >> (LOG_BOTTOM_SZ + LOG_HBLKSIZE); - bi = GC_all_bottom_indices_end; - while (bi != 0 && bi -> key > hi) bi = bi -> desc_link; - j = BOTTOM_SZ - 1; - } - while(bi != 0) { - while (j >= 0) { - hdr * hhdr = bi -> index[j]; - if (0 == hhdr) { - --j; - } else if (IS_FORWARDING_ADDR_OR_NIL(hhdr)) { - j -= (signed_word)hhdr; - } else { - return((struct hblk *) - (((bi -> key << LOG_BOTTOM_SZ) + j) - << LOG_HBLKSIZE)); - } - } - j = BOTTOM_SZ - 1; - bi = bi -> desc_link; - } - return(0); -} diff -Nru ecl-16.1.2/src/bdwgc/ia64_save_regs_in_stack.s ecl-16.1.3+ds/src/bdwgc/ia64_save_regs_in_stack.s --- ecl-16.1.2/src/bdwgc/ia64_save_regs_in_stack.s 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/ia64_save_regs_in_stack.s 1970-01-01 00:00:00.000000000 +0000 @@ -1,11 +0,0 @@ - .text - .align 16 - .global GC_save_regs_in_stack - .proc GC_save_regs_in_stack -GC_save_regs_in_stack: - .body - flushrs - ;; - mov r8=ar.bsp - br.ret.sptk.few rp - .endp GC_save_regs_in_stack diff -Nru ecl-16.1.2/src/bdwgc/include/config.h.in ecl-16.1.3+ds/src/bdwgc/include/config.h.in --- ecl-16.1.2/src/bdwgc/include/config.h.in 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/config.h.in 1970-01-01 00:00:00.000000000 +0000 @@ -1,256 +0,0 @@ -/* include/config.h.in. Generated from configure.ac by autoheader. */ - -/* Define to recognise all pointers to the interior of objects. */ -#undef ALL_INTERIOR_POINTERS - -/* Define to enable atomic uncollectible allocation. */ -#undef ATOMIC_UNCOLLECTABLE - -/* See doc/README.macros. */ -#undef DARWIN_DONT_PARSE_STACK - -/* Define to force debug headers on all objects. */ -#undef DBG_HDRS_ALL - -/* Define to enable support for DB/UX threads. */ -#undef DGUX_THREADS - -/* Define to enable eCos target support. */ -#undef ECOS - -/* Wine getenv may not return NULL for missing entry. */ -#undef EMPTY_GETENV_RESULTS - -/* Define to enable alternative finalization interface. */ -#undef ENABLE_DISCLAIM - -/* Define to support IBM AIX threads. */ -#undef GC_AIX_THREADS - -/* Define to enable internal debug assertions. */ -#undef GC_ASSERTIONS - -/* Define to support Darwin pthreads. */ -#undef GC_DARWIN_THREADS - -/* Define to enable support for DB/UX threads on i386. */ -#undef GC_DGUX386_THREADS - -/* Define to build dynamic libraries with only API symbols exposed. */ -#undef GC_DLL - -/* Define to support FreeBSD pthreads. */ -#undef GC_FREEBSD_THREADS - -/* Define to include support for gcj. */ -#undef GC_GCJ_SUPPORT - -/* Define to support GNU pthreads. */ -#undef GC_GNU_THREADS - -/* Define if backtrace information is supported. */ -#undef GC_HAVE_BUILTIN_BACKTRACE - -/* Define to support HP/UX 11 pthreads. */ -#undef GC_HPUX_THREADS - -/* Enable Win32 DllMain-based approach of threads registering. */ -#undef GC_INSIDE_DLL - -/* Define to support Irix pthreads. */ -#undef GC_IRIX_THREADS - -/* Define to support pthreads on Linux. */ -#undef GC_LINUX_THREADS - -/* Define to support NetBSD pthreads. */ -#undef GC_NETBSD_THREADS - -/* Define to support OpenBSD pthreads. */ -#undef GC_OPENBSD_THREADS - -/* Define to support Tru64 pthreads. */ -#undef GC_OSF1_THREADS - -/* Read environment variables from the GC 'env' file. */ -#undef GC_READ_ENV_FILE - -/* Define to support rtems-pthreads. */ -#undef GC_RTEMS_PTHREADS - -/* Define to support Solaris pthreads. */ -#undef GC_SOLARIS_THREADS - -/* Define to support platform-specific threads. */ -#undef GC_THREADS - -/* Explicitly prefix exported/imported WINAPI symbols with '_'. */ -#undef GC_UNDERSCORE_STDCALL - -/* Force the GC to use signals based on SIGRTMIN+k. */ -#undef GC_USESIGRT_SIGNALS - -/* See doc/README.macros. */ -#undef GC_USE_DLOPEN_WRAP - -/* Define to support pthreads-win32 or winpthreads. */ -#undef GC_WIN32_PTHREADS - -/* Define to support Win32 threads. */ -#undef GC_WIN32_THREADS - -/* Define to install pthread_atfork() handlers by default. */ -#undef HANDLE_FORK - -/* Define to use 'dladdr' function. */ -#undef HAVE_DLADDR - -/* Define to 1 if you have the header file. */ -#undef HAVE_DLFCN_H - -/* Define to 1 if you have the header file. */ -#undef HAVE_INTTYPES_H - -/* Define to 1 if you have the header file. */ -#undef HAVE_MEMORY_H - -/* 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 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 header file. */ -#undef HAVE_SYS_STAT_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_UNISTD_H - -/* See doc/README.macros. */ -#undef JAVA_FINALIZATION - -/* Define to save back-pointers in debugging headers. */ -#undef KEEP_BACK_PTRS - -/* Define to optimize for large heaps or root sets. */ -#undef LARGE_CONFIG - -/* Define to the sub-directory where libtool stores uninstalled libraries. */ -#undef LT_OBJDIR - -/* See doc/README.macros. */ -#undef MAKE_BACK_GRAPH - -/* Number of GC cycles to wait before unmapping an unused block. */ -#undef MUNMAP_THRESHOLD - -/* Define to not use system clock (cross compiling). */ -#undef NO_CLOCK - -/* Disable debugging, like GC_dump and its callees. */ -#undef NO_DEBUGGING - -/* Define to make the collector not allocate executable memory by default. */ -#undef NO_EXECUTE_PERMISSION - -/* Prohibit installation of pthread_atfork() handlers. */ -#undef NO_HANDLE_FORK - -/* Name of package */ -#undef PACKAGE - -/* 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 to enable parallel marking. */ -#undef PARALLEL_MARK - -/* If defined, redirect free to this function. */ -#undef REDIRECT_FREE - -/* If defined, redirect malloc to this function. */ -#undef REDIRECT_MALLOC - -/* If defined, redirect GC_realloc to this function. */ -#undef REDIRECT_REALLOC - -/* The number of caller frames saved when allocating with the debugging API. - */ -#undef SAVE_CALL_COUNT - -/* Shorten the headers to minimize object size at the expense of checking for - writes past the end (see doc/README.macros). */ -#undef SHORT_DBG_HDRS - -/* Define to tune the collector for small heap sizes. */ -#undef SMALL_CONFIG - -/* See the comment in gcconfig.h. */ -#undef SOLARIS25_PROC_VDB_BUG_FIXED - -/* Define to 1 if you have the ANSI C header files. */ -#undef STDC_HEADERS - -/* Define to work around a Solaris 5.3 bug (see dyn_load.c). */ -#undef SUNOS53_SHARED_LIB - -/* Define to enable thread-local allocation optimization. */ -#undef THREAD_LOCAL_ALLOC - -/* Use Unicode (W) variant of Win32 API instead of ASCII (A) one. */ -#undef UNICODE - -/* Define to use of compiler-support for thread-local variables. */ -#undef USE_COMPILER_TLS - -/* Define to use mmap instead of sbrk to expand the heap. */ -#undef USE_MMAP - -/* Define to return memory to OS with munmap calls (see doc/README.macros). */ -#undef USE_MUNMAP - -/* Define to use Win32 VirtualAlloc (instead of sbrk or mmap) to expand the - heap. */ -#undef USE_WINALLOC - -/* Version number of package */ -#undef VERSION - -/* The POSIX feature macro. */ -#undef _POSIX_C_SOURCE - -/* Indicates the use of pthreads (NetBSD). */ -#undef _PTHREADS - -/* Required define if using POSIX threads. */ -#undef _REENTRANT - -/* 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 diff -Nru ecl-16.1.2/src/bdwgc/include/cord.h ecl-16.1.3+ds/src/bdwgc/include/cord.h --- ecl-16.1.2/src/bdwgc/include/cord.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/cord.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,354 +0,0 @@ -/* - * Copyright (c) 1993-1994 by Xerox Corporation. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -/* - * Cords are immutable character strings. A number of operations - * on long cords are much more efficient than their strings.h counterpart. - * In particular, concatenation takes constant time independent of the length - * of the arguments. (Cords are represented as trees, with internal - * nodes representing concatenation and leaves consisting of either C - * strings or a functional description of the string.) - * - * The following are reasonable applications of cords. They would perform - * unacceptably if C strings were used: - * - A compiler that produces assembly language output by repeatedly - * concatenating instructions onto a cord representing the output file. - * - A text editor that converts the input file to a cord, and then - * performs editing operations by producing a new cord representing - * the file after each character change (and keeping the old ones in an - * edit history) - * - * For optimal performance, cords should be built by - * concatenating short sections. - * This interface is designed for maximum compatibility with C strings. - * ASCII NUL characters may be embedded in cords using CORD_from_fn. - * This is handled correctly, but CORD_to_char_star will produce a string - * with embedded NULs when given such a cord. - * - * This interface is fairly big, largely for performance reasons. - * The most basic constants and functions: - * - * CORD - the type of a cord; - * CORD_EMPTY - empty cord; - * CORD_len(cord) - length of a cord; - * CORD_cat(cord1,cord2) - concatenation of two cords; - * CORD_substr(cord, start, len) - substring (or subcord); - * CORD_pos i; CORD_FOR(i, cord) { ... CORD_pos_fetch(i) ... } - - * examine each character in a cord. CORD_pos_fetch(i) is the char. - * CORD_fetch(int i) - Retrieve i'th character (slowly). - * CORD_cmp(cord1, cord2) - compare two cords. - * CORD_from_file(FILE * f) - turn a read-only file into a cord. - * CORD_to_char_star(cord) - convert to C string. - * (Non-NULL C constant strings are cords.) - * CORD_printf (etc.) - cord version of printf. Use %r for cords. - */ -#ifndef CORD_H -#define CORD_H - -#include -#include - -#ifdef GC_DLL - /* Same as for GC_API in gc_config_macros.h. */ -# ifdef CORD_BUILD -# if defined(__MINGW32__) || defined(__CEGCC__) -# define CORD_API __declspec(dllexport) -# elif defined(_MSC_VER) || defined(__DMC__) || defined(__BORLANDC__) \ - || defined(__CYGWIN__) || defined(__WATCOMC__) -# define CORD_API extern __declspec(dllexport) -# elif defined(__GNUC__) && (__GNUC__ >= 4 \ - || defined(GC_VISIBILITY_HIDDEN_SET)) - /* Only matters if used in conjunction with -fvisibility=hidden option. */ -# define CORD_API extern __attribute__((__visibility__("default"))) -# endif -# else -# if defined(__MINGW32__) || defined(__CEGCC__) || defined(_MSC_VER) \ - || defined(__DMC__) || defined(__BORLANDC__) || defined(__CYGWIN__) -# define CORD_API __declspec(dllimport) -# elif defined(__WATCOMC__) -# define CORD_API extern __declspec(dllimport) -# endif -# endif /* !CORD_BUILD */ -#endif /* GC_DLL */ - -#ifndef CORD_API -# define CORD_API extern -#endif - -/* Cords have type const char *. This is cheating quite a bit, and not */ -/* 100% portable. But it means that nonempty character string */ -/* constants may be used as cords directly, provided the string is */ -/* never modified in place. The empty cord is represented by, and */ -/* can be written as, 0. */ - -typedef const char * CORD; - -/* An empty cord is always represented as nil */ -#define CORD_EMPTY 0 - -/* Is a nonempty cord represented as a C string? */ -#define CORD_IS_STRING(s) (*(s) != '\0') - -/* Concatenate two cords. If the arguments are C strings, they may */ -/* not be subsequently altered. */ -CORD_API CORD CORD_cat(CORD x, CORD y); - -/* Concatenate a cord and a C string with known length. Except for the */ -/* empty string case, this is a special case of CORD_cat. Since the */ -/* length is known, it can be faster. */ -/* The string y is shared with the resulting CORD. Hence it should */ -/* not be altered by the caller. */ -CORD_API CORD CORD_cat_char_star(CORD x, const char * y, size_t leny); - -/* Compute the length of a cord */ -CORD_API size_t CORD_len(CORD x); - -/* Cords may be represented by functions defining the ith character */ -typedef char (* CORD_fn)(size_t i, void * client_data); - -/* Turn a functional description into a cord. */ -CORD_API CORD CORD_from_fn(CORD_fn fn, void * client_data, size_t len); - -/* Return the substring (subcord really) of x with length at most n, */ -/* starting at position i. (The initial character has position 0.) */ -CORD_API CORD CORD_substr(CORD x, size_t i, size_t n); - -/* Return the argument, but rebalanced to allow more efficient */ -/* character retrieval, substring operations, and comparisons. */ -/* This is useful only for cords that were built using repeated */ -/* concatenation. Guarantees log time access to the result, unless */ -/* x was obtained through a large number of repeated substring ops */ -/* or the embedded functional descriptions take longer to evaluate. */ -/* May reallocate significant parts of the cord. The argument is not */ -/* modified; only the result is balanced. */ -CORD_API CORD CORD_balance(CORD x); - -/* The following traverse a cord by applying a function to each */ -/* character. This is occasionally appropriate, especially where */ -/* speed is crucial. But, since C doesn't have nested functions, */ -/* clients of this sort of traversal are clumsy to write. Consider */ -/* the functions that operate on cord positions instead. */ - -/* Function to iteratively apply to individual characters in cord. */ -typedef int (* CORD_iter_fn)(char c, void * client_data); - -/* Function to apply to substrings of a cord. Each substring is a */ -/* a C character string, not a general cord. */ -typedef int (* CORD_batched_iter_fn)(const char * s, void * client_data); -#define CORD_NO_FN ((CORD_batched_iter_fn)0) - -/* Apply f1 to each character in the cord, in ascending order, */ -/* starting at position i. If */ -/* f2 is not CORD_NO_FN, then multiple calls to f1 may be replaced by */ -/* a single call to f2. The parameter f2 is provided only to allow */ -/* some optimization by the client. This terminates when the right */ -/* end of this string is reached, or when f1 or f2 return != 0. In the */ -/* latter case CORD_iter returns != 0. Otherwise it returns 0. */ -/* The specified value of i must be < CORD_len(x). */ -CORD_API int CORD_iter5(CORD x, size_t i, CORD_iter_fn f1, - CORD_batched_iter_fn f2, void * client_data); - -/* A simpler version that starts at 0, and without f2: */ -CORD_API int CORD_iter(CORD x, CORD_iter_fn f1, void * client_data); -#define CORD_iter(x, f1, cd) CORD_iter5(x, 0, f1, CORD_NO_FN, cd) - -/* Similar to CORD_iter5, but end-to-beginning. No provisions for */ -/* CORD_batched_iter_fn. */ -CORD_API int CORD_riter4(CORD x, size_t i, CORD_iter_fn f1, void * client_data); - -/* A simpler version that starts at the end: */ -CORD_API int CORD_riter(CORD x, CORD_iter_fn f1, void * client_data); - -/* Functions that operate on cord positions. The easy way to traverse */ -/* cords. A cord position is logically a pair consisting of a cord */ -/* and an index into that cord. But it is much faster to retrieve a */ -/* character based on a position than on an index. Unfortunately, */ -/* positions are big (order of a few 100 bytes), so allocate them with */ -/* caution. */ -/* Things in cord_pos.h should be treated as opaque, except as */ -/* described below. Also note that */ -/* CORD_pos_fetch, CORD_next and CORD_prev have both macro and function */ -/* definitions. The former may evaluate their argument more than once. */ -#include "cord_pos.h" - -/* - Visible definitions from above: - - typedef CORD_pos[1]; - - * Extract the cord from a position: - CORD CORD_pos_to_cord(CORD_pos p); - - * Extract the current index from a position: - size_t CORD_pos_to_index(CORD_pos p); - - * Fetch the character located at the given position: - char CORD_pos_fetch(CORD_pos p); - - * Initialize the position to refer to the given cord and index. - * Note that this is the most expensive function on positions: - void CORD_set_pos(CORD_pos p, CORD x, size_t i); - - * Advance the position to the next character. - * P must be initialized and valid. - * Invalidates p if past end: - void CORD_next(CORD_pos p); - - * Move the position to the preceding character. - * P must be initialized and valid. - * Invalidates p if past beginning: - void CORD_prev(CORD_pos p); - - * Is the position valid, i.e. inside the cord? - int CORD_pos_valid(CORD_pos p); -*/ -#define CORD_FOR(pos, cord) \ - for (CORD_set_pos(pos, cord, 0); CORD_pos_valid(pos); CORD_next(pos)) - - -/* An out of memory handler to call. May be supplied by client. */ -/* Must not return. */ -extern void (* CORD_oom_fn)(void); - -/* Dump the representation of x to stdout in an implementation defined */ -/* manner. Intended for debugging only. */ -CORD_API void CORD_dump(CORD x); - -/* The following could easily be implemented by the client. They are */ -/* provided in cordxtra.c for convenience. */ - -/* Concatenate a character to the end of a cord. */ -CORD_API CORD CORD_cat_char(CORD x, char c); - -/* Concatenate n cords. */ -CORD_API CORD CORD_catn(int n, /* CORD */ ...); - -/* Return the character in CORD_substr(x, i, 1) */ -CORD_API char CORD_fetch(CORD x, size_t i); - -/* Return < 0, 0, or > 0, depending on whether x < y, x = y, x > y */ -CORD_API int CORD_cmp(CORD x, CORD y); - -/* A generalization that takes both starting positions for the */ -/* comparison, and a limit on the number of characters to be compared. */ -CORD_API int CORD_ncmp(CORD x, size_t x_start, CORD y, size_t y_start, - size_t len); - -/* Find the first occurrence of s in x at position start or later. */ -/* Return the position of the first character of s in x, or */ -/* CORD_NOT_FOUND if there is none. */ -CORD_API size_t CORD_str(CORD x, size_t start, CORD s); - -/* Return a cord consisting of i copies of (possibly NUL) c. Dangerous */ -/* in conjunction with CORD_to_char_star. */ -/* The resulting representation takes constant space, independent of i. */ -CORD_API CORD CORD_chars(char c, size_t i); -#define CORD_nul(i) CORD_chars('\0', (i)) - -/* Turn a file into cord. The file must be seekable. Its contents */ -/* must remain constant. The file may be accessed as an immediate */ -/* result of this call and/or as a result of subsequent accesses to */ -/* the cord. Short files are likely to be immediately read, but */ -/* long files are likely to be read on demand, possibly relying on */ -/* stdio for buffering. */ -/* We must have exclusive access to the descriptor f, i.e. we may */ -/* read it at any time, and expect the file pointer to be */ -/* where we left it. Normally this should be invoked as */ -/* CORD_from_file(fopen(...)) */ -/* CORD_from_file arranges to close the file descriptor when it is no */ -/* longer needed (e.g. when the result becomes inaccessible). */ -/* The file f must be such that ftell reflects the actual character */ -/* position in the file, i.e. the number of characters that can be */ -/* or were read with fread. On UNIX systems this is always true. On */ -/* MS Windows systems, f must be opened in binary mode. */ -CORD_API CORD CORD_from_file(FILE * f); - -/* Equivalent to the above, except that the entire file will be read */ -/* and the file pointer will be closed immediately. */ -/* The binary mode restriction from above does not apply. */ -CORD_API CORD CORD_from_file_eager(FILE * f); - -/* Equivalent to the above, except that the file will be read on demand.*/ -/* The binary mode restriction applies. */ -CORD_API CORD CORD_from_file_lazy(FILE * f); - -/* Turn a cord into a C string. The result shares no structure with */ -/* x, and is thus modifiable. */ -CORD_API char * CORD_to_char_star(CORD x); - -/* Turn a C string into a CORD. The C string is copied, and so may */ -/* subsequently be modified. */ -CORD_API CORD CORD_from_char_star(const char *s); - -/* Identical to the above, but the result may share structure with */ -/* the argument and is thus not modifiable. */ -CORD_API const char * CORD_to_const_char_star(CORD x); - -/* Write a cord to a file, starting at the current position. No */ -/* trailing NULs are newlines are added. */ -/* Returns EOF if a write error occurs, 1 otherwise. */ -CORD_API int CORD_put(CORD x, FILE * f); - -/* "Not found" result for the following two functions. */ -#define CORD_NOT_FOUND ((size_t)(-1)) - -/* A vague analog of strchr. Returns the position (an integer, not */ -/* a pointer) of the first occurrence of (char) c inside x at position */ -/* i or later. The value i must be < CORD_len(x). */ -CORD_API size_t CORD_chr(CORD x, size_t i, int c); - -/* A vague analog of strrchr. Returns index of the last occurrence */ -/* of (char) c inside x at position i or earlier. The value i */ -/* must be < CORD_len(x). */ -CORD_API size_t CORD_rchr(CORD x, size_t i, int c); - - -/* The following are also not primitive, but are implemented in */ -/* cordprnt.c. They provide functionality similar to the ANSI C */ -/* functions with corresponding names, but with the following */ -/* additions and changes: */ -/* 1. A %r conversion specification specifies a CORD argument. Field */ -/* width, precision, etc. have the same semantics as for %s. */ -/* (Note that %c, %C, and %S were already taken.) */ -/* 2. The format string is represented as a CORD. */ -/* 3. CORD_sprintf and CORD_vsprintf assign the result through the 1st */ -/* argument. Unlike their ANSI C versions, there is no need to guess */ -/* the correct buffer size. */ -/* 4. Most of the conversions are implement through the native */ -/* vsprintf. Hence they are usually no faster, and */ -/* idiosyncrasies of the native printf are preserved. However, */ -/* CORD arguments to CORD_sprintf and CORD_vsprintf are NOT copied; */ -/* the result shares the original structure. This may make them */ -/* very efficient in some unusual applications. */ -/* The format string is copied. */ -/* All functions return the number of characters generated or -1 on */ -/* error. This complies with the ANSI standard, but is inconsistent */ -/* with some older implementations of sprintf. */ - -/* The implementation of these is probably less portable than the rest */ -/* of this package. */ - -#ifndef CORD_NO_IO - -#include - -CORD_API int CORD_sprintf(CORD * out, CORD format, ...); -CORD_API int CORD_vsprintf(CORD * out, CORD format, va_list args); -CORD_API int CORD_fprintf(FILE * f, CORD format, ...); -CORD_API int CORD_vfprintf(FILE * f, CORD format, va_list args); -CORD_API int CORD_printf(CORD format, ...); -CORD_API int CORD_vprintf(CORD format, va_list args); - -#endif /* CORD_NO_IO */ - -#endif /* CORD_H */ diff -Nru ecl-16.1.2/src/bdwgc/include/cord_pos.h ecl-16.1.3+ds/src/bdwgc/include/cord_pos.h --- ecl-16.1.2/src/bdwgc/include/cord_pos.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/cord_pos.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,120 +0,0 @@ -/* - * Copyright (c) 1993-1994 by Xerox Corporation. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -/* This should never be included directly; included only from cord.h. */ -#if !defined(CORD_POSITION_H) && defined(CORD_H) -#define CORD_POSITION_H - -/* The representation of CORD_position. This is private to the */ -/* implementation, but the size is known to clients. Also */ -/* the implementation of some exported macros relies on it. */ -/* Don't use anything defined here and not in cord.h. */ - -# define MAX_DEPTH 48 - /* The maximum depth of a balanced cord + 1. */ - /* We don't let cords get deeper than MAX_DEPTH. */ - -struct CORD_pe { - CORD pe_cord; - size_t pe_start_pos; -}; - -/* A structure describing an entry on the path from the root */ -/* to current position. */ -typedef struct CORD_Pos { - size_t cur_pos; - int path_len; -# define CORD_POS_INVALID (0x55555555) - /* path_len == INVALID <==> position invalid */ - const char *cur_leaf; /* Current leaf, if it is a string. */ - /* If the current leaf is a function, */ - /* then this may point to function_buf */ - /* containing the next few characters. */ - /* Always points to a valid string */ - /* containing the current character */ - /* unless cur_end is 0. */ - size_t cur_start; /* Start position of cur_leaf */ - size_t cur_end; /* Ending position of cur_leaf */ - /* 0 if cur_leaf is invalid. */ - struct CORD_pe path[MAX_DEPTH + 1]; - /* path[path_len] is the leaf corresponding to cur_pos */ - /* path[0].pe_cord is the cord we point to. */ -# define FUNCTION_BUF_SZ 8 - char function_buf[FUNCTION_BUF_SZ]; /* Space for next few chars */ - /* from function node. */ -} CORD_pos[1]; - -/* Extract the cord from a position: */ -CORD_API CORD CORD_pos_to_cord(CORD_pos p); - -/* Extract the current index from a position: */ -CORD_API size_t CORD_pos_to_index(CORD_pos p); - -/* Fetch the character located at the given position: */ -CORD_API char CORD_pos_fetch(CORD_pos p); - -/* Initialize the position to refer to the give cord and index. */ -/* Note that this is the most expensive function on positions: */ -CORD_API void CORD_set_pos(CORD_pos p, CORD x, size_t i); - -/* Advance the position to the next character. */ -/* P must be initialized and valid. */ -/* Invalidates p if past end: */ -CORD_API void CORD_next(CORD_pos p); - -/* Move the position to the preceding character. */ -/* P must be initialized and valid. */ -/* Invalidates p if past beginning: */ -CORD_API void CORD_prev(CORD_pos p); - -/* Is the position valid, i.e. inside the cord? */ -CORD_API int CORD_pos_valid(CORD_pos p); - -CORD_API char CORD__pos_fetch(CORD_pos); -CORD_API void CORD__next(CORD_pos); -CORD_API void CORD__prev(CORD_pos); - -#define CORD_pos_fetch(p) \ - (((p)[0].cur_end != 0)? \ - (p)[0].cur_leaf[(p)[0].cur_pos - (p)[0].cur_start] \ - : CORD__pos_fetch(p)) - -#define CORD_next(p) \ - (((p)[0].cur_pos + 1 < (p)[0].cur_end)? \ - (p)[0].cur_pos++ \ - : (CORD__next(p), 0)) - -#define CORD_prev(p) \ - (((p)[0].cur_end != 0 && (p)[0].cur_pos > (p)[0].cur_start)? \ - (p)[0].cur_pos-- \ - : (CORD__prev(p), 0)) - -#define CORD_pos_to_index(p) ((p)[0].cur_pos) - -#define CORD_pos_to_cord(p) ((p)[0].path[0].pe_cord) - -#define CORD_pos_valid(p) ((p)[0].path_len != CORD_POS_INVALID) - -/* Some grubby stuff for performance-critical friends: */ -#define CORD_pos_chars_left(p) ((long)((p)[0].cur_end) - (long)((p)[0].cur_pos)) - /* Number of characters in cache. <= 0 ==> none */ - -#define CORD_pos_advance(p,n) ((p)[0].cur_pos += (n) - 1, CORD_next(p)) - /* Advance position by n characters */ - /* 0 < n < CORD_pos_chars_left(p) */ - -#define CORD_pos_cur_char_addr(p) \ - (p)[0].cur_leaf + ((p)[0].cur_pos - (p)[0].cur_start) - /* address of current character in cache. */ - -#endif diff -Nru ecl-16.1.2/src/bdwgc/include/ec.h ecl-16.1.3+ds/src/bdwgc/include/ec.h --- ecl-16.1.2/src/bdwgc/include/ec.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/ec.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,68 +0,0 @@ -# ifndef EC_H -# define EC_H - -# ifndef CORD_H -# include "cord.h" -# endif - -/* Extensible cords are strings that may be destructively appended to. */ -/* They allow fast construction of cords from characters that are */ -/* being read from a stream. */ -/* - * A client might look like: - * - * { - * CORD_ec x; - * CORD result; - * char c; - * FILE *f; - * - * ... - * CORD_ec_init(x); - * while(...) { - * c = getc(f); - * ... - * CORD_ec_append(x, c); - * } - * result = CORD_balance(CORD_ec_to_cord(x)); - * - * If a C string is desired as the final result, the call to CORD_balance - * may be replaced by a call to CORD_to_char_star. - */ - -# ifndef CORD_BUFSZ -# define CORD_BUFSZ 128 -# endif - -typedef struct CORD_ec_struct { - CORD ec_cord; - char * ec_bufptr; - char ec_buf[CORD_BUFSZ+1]; -} CORD_ec[1]; - -/* This structure represents the concatenation of ec_cord with */ -/* ec_buf[0 ... (ec_bufptr-ec_buf-1)] */ - -/* Flush the buffer part of the extended chord into ec_cord. */ -/* Note that this is almost the only real function, and it is */ -/* implemented in 6 lines in cordxtra.c */ -void CORD_ec_flush_buf(CORD_ec x); - -/* Convert an extensible cord to a cord. */ -# define CORD_ec_to_cord(x) (CORD_ec_flush_buf(x), (x)[0].ec_cord) - -/* Initialize an extensible cord. */ -#define CORD_ec_init(x) \ - ((x)[0].ec_cord = 0, (void)((x)[0].ec_bufptr = (x)[0].ec_buf)) - -/* Append a character to an extensible cord. */ -#define CORD_ec_append(x, c) \ - (((x)[0].ec_bufptr == (x)[0].ec_buf + CORD_BUFSZ ? \ - (CORD_ec_flush_buf(x), 0) : 0), \ - (void)(*(x)[0].ec_bufptr++ = (c))) - -/* Append a cord to an extensible cord. Structure remains shared with */ -/* original. */ -void CORD_ec_append_cord(CORD_ec x, CORD s); - -# endif /* EC_H */ diff -Nru ecl-16.1.2/src/bdwgc/include/extra/gc_cpp.h ecl-16.1.3+ds/src/bdwgc/include/extra/gc_cpp.h --- ecl-16.1.2/src/bdwgc/include/extra/gc_cpp.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/extra/gc_cpp.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,2 +0,0 @@ -/* This file is installed for backward compatibility. */ -#include diff -Nru ecl-16.1.2/src/bdwgc/include/extra/gc.h ecl-16.1.3+ds/src/bdwgc/include/extra/gc.h --- ecl-16.1.2/src/bdwgc/include/extra/gc.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/extra/gc.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,2 +0,0 @@ -/* This file is installed for backward compatibility. */ -#include diff -Nru ecl-16.1.2/src/bdwgc/include/gc_allocator.h ecl-16.1.3+ds/src/bdwgc/include/gc_allocator.h --- ecl-16.1.2/src/bdwgc/include/gc_allocator.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/gc_allocator.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,325 +0,0 @@ -/* - * Copyright (c) 1996-1997 - * Silicon Graphics Computer Systems, Inc. - * - * Permission to use, copy, modify, distribute and sell this software - * and its documentation for any purpose is hereby granted without fee, - * provided that the above copyright notice appear in all copies and - * that both that copyright notice and this permission notice appear - * in supporting documentation. Silicon Graphics makes no - * representations about the suitability of this software for any - * purpose. It is provided "as is" without express or implied warranty. - * - * Copyright (c) 2002 - * Hewlett-Packard Company - * - * Permission to use, copy, modify, distribute and sell this software - * and its documentation for any purpose is hereby granted without fee, - * provided that the above copyright notice appear in all copies and - * that both that copyright notice and this permission notice appear - * in supporting documentation. Hewlett-Packard Company makes no - * representations about the suitability of this software for any - * purpose. It is provided "as is" without express or implied warranty. - */ - -/* - * This implements standard-conforming allocators that interact with - * the garbage collector. Gc_allocator allocates garbage-collectible - * objects of type T. Traceable_allocator allocates objects that - * are not themselves garbage collected, but are scanned by the - * collector for pointers to collectible objects. Traceable_alloc - * should be used for explicitly managed STL containers that may - * point to collectible objects. - * - * This code was derived from an earlier version of the GNU C++ standard - * library, which itself was derived from the SGI STL implementation. - * - * Ignore-off-page allocator: George T. Talbot - */ - -#ifndef GC_ALLOCATOR_H - -#define GC_ALLOCATOR_H - -#include "gc.h" -#include // for placement new - -#if defined(__GNUC__) -# define GC_ATTR_UNUSED __attribute__((__unused__)) -#else -# define GC_ATTR_UNUSED -#endif - -/* First some helpers to allow us to dispatch on whether or not a type - * is known to be pointer-free. - * These are private, except that the client may invoke the - * GC_DECLARE_PTRFREE macro. - */ - -struct GC_true_type {}; -struct GC_false_type {}; - -template -struct GC_type_traits { - GC_false_type GC_is_ptr_free; -}; - -# define GC_DECLARE_PTRFREE(T) \ -template<> struct GC_type_traits { GC_true_type GC_is_ptr_free; } - -GC_DECLARE_PTRFREE(char); -GC_DECLARE_PTRFREE(signed char); -GC_DECLARE_PTRFREE(unsigned char); -GC_DECLARE_PTRFREE(signed short); -GC_DECLARE_PTRFREE(unsigned short); -GC_DECLARE_PTRFREE(signed int); -GC_DECLARE_PTRFREE(unsigned int); -GC_DECLARE_PTRFREE(signed long); -GC_DECLARE_PTRFREE(unsigned long); -GC_DECLARE_PTRFREE(float); -GC_DECLARE_PTRFREE(double); -GC_DECLARE_PTRFREE(long double); -/* The client may want to add others. */ - -// In the following GC_Tp is GC_true_type if we are allocating a -// pointer-free object. -template -inline void * GC_selective_alloc(size_t n, GC_Tp, bool ignore_off_page) { - return ignore_off_page?GC_MALLOC_IGNORE_OFF_PAGE(n):GC_MALLOC(n); -} - -template <> -inline void * GC_selective_alloc(size_t n, GC_true_type, - bool ignore_off_page) { - return ignore_off_page? GC_MALLOC_ATOMIC_IGNORE_OFF_PAGE(n) - : GC_MALLOC_ATOMIC(n); -} - -/* Now the public gc_allocator class: - */ -template -class gc_allocator { -public: - typedef size_t size_type; - typedef ptrdiff_t difference_type; - typedef GC_Tp* pointer; - typedef const GC_Tp* const_pointer; - typedef GC_Tp& reference; - typedef const GC_Tp& const_reference; - typedef GC_Tp value_type; - - template struct rebind { - typedef gc_allocator other; - }; - - gc_allocator() {} - gc_allocator(const gc_allocator&) throw() {} -# if !(GC_NO_MEMBER_TEMPLATES || 0 < _MSC_VER && _MSC_VER <= 1200) - // MSVC++ 6.0 do not support member templates - template gc_allocator(const gc_allocator&) throw() {} -# endif - ~gc_allocator() throw() {} - - pointer address(reference GC_x) const { return &GC_x; } - const_pointer address(const_reference GC_x) const { return &GC_x; } - - // GC_n is permitted to be 0. The C++ standard says nothing about what - // the return value is when GC_n == 0. - GC_Tp* allocate(size_type GC_n, const void* = 0) { - GC_type_traits traits; - return static_cast - (GC_selective_alloc(GC_n * sizeof(GC_Tp), - traits.GC_is_ptr_free, false)); - } - - // __p is not permitted to be a null pointer. - void deallocate(pointer __p, size_type GC_ATTR_UNUSED GC_n) - { GC_FREE(__p); } - - size_type max_size() const throw() - { return size_t(-1) / sizeof(GC_Tp); } - - void construct(pointer __p, const GC_Tp& __val) { new(__p) GC_Tp(__val); } - void destroy(pointer __p) { __p->~GC_Tp(); } -}; - -template<> -class gc_allocator { - typedef size_t size_type; - typedef ptrdiff_t difference_type; - typedef void* pointer; - typedef const void* const_pointer; - typedef void value_type; - - template struct rebind { - typedef gc_allocator other; - }; -}; - - -template -inline bool operator==(const gc_allocator&, const gc_allocator&) -{ - return true; -} - -template -inline bool operator!=(const gc_allocator&, const gc_allocator&) -{ - return false; -} - - -/* Now the public gc_allocator_ignore_off_page class: - */ -template -class gc_allocator_ignore_off_page { -public: - typedef size_t size_type; - typedef ptrdiff_t difference_type; - typedef GC_Tp* pointer; - typedef const GC_Tp* const_pointer; - typedef GC_Tp& reference; - typedef const GC_Tp& const_reference; - typedef GC_Tp value_type; - - template struct rebind { - typedef gc_allocator_ignore_off_page other; - }; - - gc_allocator_ignore_off_page() {} - gc_allocator_ignore_off_page(const gc_allocator_ignore_off_page&) throw() {} -# if !(GC_NO_MEMBER_TEMPLATES || 0 < _MSC_VER && _MSC_VER <= 1200) - // MSVC++ 6.0 do not support member templates - template - gc_allocator_ignore_off_page(const gc_allocator_ignore_off_page&) - throw() {} -# endif - ~gc_allocator_ignore_off_page() throw() {} - - pointer address(reference GC_x) const { return &GC_x; } - const_pointer address(const_reference GC_x) const { return &GC_x; } - - // GC_n is permitted to be 0. The C++ standard says nothing about what - // the return value is when GC_n == 0. - GC_Tp* allocate(size_type GC_n, const void* = 0) { - GC_type_traits traits; - return static_cast - (GC_selective_alloc(GC_n * sizeof(GC_Tp), - traits.GC_is_ptr_free, true)); - } - - // __p is not permitted to be a null pointer. - void deallocate(pointer __p, size_type GC_ATTR_UNUSED GC_n) - { GC_FREE(__p); } - - size_type max_size() const throw() - { return size_t(-1) / sizeof(GC_Tp); } - - void construct(pointer __p, const GC_Tp& __val) { new(__p) GC_Tp(__val); } - void destroy(pointer __p) { __p->~GC_Tp(); } -}; - -template<> -class gc_allocator_ignore_off_page { - typedef size_t size_type; - typedef ptrdiff_t difference_type; - typedef void* pointer; - typedef const void* const_pointer; - typedef void value_type; - - template struct rebind { - typedef gc_allocator_ignore_off_page other; - }; -}; - -template -inline bool operator==(const gc_allocator_ignore_off_page&, const gc_allocator_ignore_off_page&) -{ - return true; -} - -template -inline bool operator!=(const gc_allocator_ignore_off_page&, const gc_allocator_ignore_off_page&) -{ - return false; -} - -/* - * And the public traceable_allocator class. - */ - -// Note that we currently don't specialize the pointer-free case, since a -// pointer-free traceable container doesn't make that much sense, -// though it could become an issue due to abstraction boundaries. -template -class traceable_allocator { -public: - typedef size_t size_type; - typedef ptrdiff_t difference_type; - typedef GC_Tp* pointer; - typedef const GC_Tp* const_pointer; - typedef GC_Tp& reference; - typedef const GC_Tp& const_reference; - typedef GC_Tp value_type; - - template struct rebind { - typedef traceable_allocator other; - }; - - traceable_allocator() throw() {} - traceable_allocator(const traceable_allocator&) throw() {} -# if !(GC_NO_MEMBER_TEMPLATES || 0 < _MSC_VER && _MSC_VER <= 1200) - // MSVC++ 6.0 do not support member templates - template traceable_allocator - (const traceable_allocator&) throw() {} -# endif - ~traceable_allocator() throw() {} - - pointer address(reference GC_x) const { return &GC_x; } - const_pointer address(const_reference GC_x) const { return &GC_x; } - - // GC_n is permitted to be 0. The C++ standard says nothing about what - // the return value is when GC_n == 0. - GC_Tp* allocate(size_type GC_n, const void* = 0) { - return static_cast(GC_MALLOC_UNCOLLECTABLE(GC_n * sizeof(GC_Tp))); - } - - // __p is not permitted to be a null pointer. - void deallocate(pointer __p, size_type GC_ATTR_UNUSED GC_n) - { GC_FREE(__p); } - - size_type max_size() const throw() - { return size_t(-1) / sizeof(GC_Tp); } - - void construct(pointer __p, const GC_Tp& __val) { new(__p) GC_Tp(__val); } - void destroy(pointer __p) { __p->~GC_Tp(); } -}; - -template<> -class traceable_allocator { - typedef size_t size_type; - typedef ptrdiff_t difference_type; - typedef void* pointer; - typedef const void* const_pointer; - typedef void value_type; - - template struct rebind { - typedef traceable_allocator other; - }; -}; - - -template -inline bool operator==(const traceable_allocator&, const traceable_allocator&) -{ - return true; -} - -template -inline bool operator!=(const traceable_allocator&, const traceable_allocator&) -{ - return false; -} - -#endif /* GC_ALLOCATOR_H */ diff -Nru ecl-16.1.2/src/bdwgc/include/gc_backptr.h ecl-16.1.3+ds/src/bdwgc/include/gc_backptr.h --- ecl-16.1.2/src/bdwgc/include/gc_backptr.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/gc_backptr.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,98 +0,0 @@ -/* - * Copyright (c) 1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996 by Silicon Graphics. All rights reserved. - * Copyright (c) 1998 by Fergus Henderson. All rights reserved. - * Copyright (c) 2000-2009 by Hewlett-Packard Development Company. - * All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -/* - * This is a simple API to implement pointer back tracing, i.e. - * to answer questions such as "who is pointing to this" or - * "why is this object being retained by the collector" - * - * This API assumes that we have an ANSI C compiler. - * - * Most of these calls yield useful information on only after - * a garbage collection. Usually the client will first force - * a full collection and then gather information, preferably - * before much intervening allocation. - * - * The implementation of the interface is only about 99.9999% - * correct. It is intended to be good enough for profiling, - * but is not intended to be used with production code. - * - * Results are likely to be much more useful if all allocation is - * accomplished through the debugging allocators. - * - * The implementation idea is due to A. Demers. - */ - -#ifndef GC_BACKPTR_H -#define GC_BACKPTR_H - -#ifndef GC_H -# include "gc.h" -#endif - -#ifdef __cplusplus - extern "C" { -#endif - -/* Store information about the object referencing dest in *base_p */ -/* and *offset_p. */ -/* If multiple objects or roots point to dest, the one reported */ -/* will be the last on used by the garbage collector to trace the */ -/* object. */ -/* source is root ==> *base_p = address, *offset_p = 0 */ -/* source is heap object ==> *base_p != 0, *offset_p = offset */ -/* Returns 1 on success, 0 if source couldn't be determined. */ -/* Dest can be any address within a heap object. */ -typedef enum { - GC_UNREFERENCED, /* No reference info available. */ - GC_NO_SPACE, /* Dest not allocated with debug alloc. */ - GC_REFD_FROM_ROOT, /* Referenced directly by root *base_p. */ - GC_REFD_FROM_REG, /* Referenced from a register, i.e. */ - /* a root without an address. */ - GC_REFD_FROM_HEAP, /* Referenced from another heap obj. */ - GC_FINALIZER_REFD /* Finalizable and hence accessible. */ -} GC_ref_kind; - -GC_API GC_ref_kind GC_CALL GC_get_back_ptr_info(void * /* dest */, - void ** /* base_p */, size_t * /* offset_p */) - GC_ATTR_NONNULL(1); - -/* Generate a random heap address. */ -/* The resulting address is in the heap, but */ -/* not necessarily inside a valid object. */ -GC_API void * GC_CALL GC_generate_random_heap_address(void); - -/* Generate a random address inside a valid marked heap object. */ -GC_API void * GC_CALL GC_generate_random_valid_address(void); - -/* Force a garbage collection and generate a backtrace from a */ -/* random heap address. */ -/* This uses the GC logging mechanism (GC_printf) to produce */ -/* output. It can often be called from a debugger. The */ -/* source in dbg_mlc.c also serves as a sample client. */ -GC_API void GC_CALL GC_generate_random_backtrace(void); - -/* Print a backtrace from a specific address. Used by the */ -/* above. The client should call GC_gcollect() immediately */ -/* before invocation. */ -GC_API void GC_CALL GC_print_backtrace(void *) GC_ATTR_NONNULL(1); - -#ifdef __cplusplus - } /* end of extern "C" */ -#endif - -#endif /* GC_BACKPTR_H */ diff -Nru ecl-16.1.2/src/bdwgc/include/gc_config_macros.h ecl-16.1.3+ds/src/bdwgc/include/gc_config_macros.h --- ecl-16.1.2/src/bdwgc/include/gc_config_macros.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/gc_config_macros.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,390 +0,0 @@ -/* - * Copyright (c) 1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996 by Silicon Graphics. All rights reserved. - * Copyright (c) 1998 by Fergus Henderson. All rights reserved. - * Copyright (c) 2000-2009 by Hewlett-Packard Development Company. - * All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -/* This should never be included directly; it is included only from gc.h. */ -/* We separate it only to make gc.h more suitable as documentation. */ -#if defined(GC_H) - -/* Some tests for old macros. These violate our namespace rules and */ -/* will disappear shortly. Use the GC_ names. */ -#if defined(SOLARIS_THREADS) || defined(_SOLARIS_THREADS) \ - || defined(_SOLARIS_PTHREADS) || defined(GC_SOLARIS_PTHREADS) - /* We no longer support old style Solaris threads. */ - /* GC_SOLARIS_THREADS now means pthreads. */ -# ifndef GC_SOLARIS_THREADS -# define GC_SOLARIS_THREADS -# endif -#endif -#if defined(IRIX_THREADS) -# define GC_IRIX_THREADS -#endif -#if defined(DGUX_THREADS) && !defined(GC_DGUX386_THREADS) -# define GC_DGUX386_THREADS -#endif -#if defined(AIX_THREADS) -# define GC_AIX_THREADS -#endif -#if defined(HPUX_THREADS) -# define GC_HPUX_THREADS -#endif -#if defined(OSF1_THREADS) -# define GC_OSF1_THREADS -#endif -#if defined(LINUX_THREADS) -# define GC_LINUX_THREADS -#endif -#if defined(WIN32_THREADS) -# define GC_WIN32_THREADS -#endif -#if defined(RTEMS_THREADS) -# define GC_RTEMS_PTHREADS -#endif -#if defined(USE_LD_WRAP) -# define GC_USE_LD_WRAP -#endif - -#if defined(GC_WIN32_PTHREADS) && !defined(GC_WIN32_THREADS) - /* Using pthreads-win32 library (or other Win32 implementation). */ -# define GC_WIN32_THREADS -#endif - -#if defined(GC_AIX_THREADS) || defined(GC_DARWIN_THREADS) \ - || defined(GC_DGUX386_THREADS) || defined(GC_FREEBSD_THREADS) \ - || defined(GC_GNU_THREADS) || defined(GC_HPUX_THREADS) \ - || defined(GC_IRIX_THREADS) || defined(GC_LINUX_THREADS) \ - || defined(GC_NETBSD_THREADS) || defined(GC_OPENBSD_THREADS) \ - || defined(GC_OSF1_THREADS) || defined(GC_SOLARIS_THREADS) \ - || defined(GC_WIN32_THREADS) || defined(GC_RTEMS_PTHREADS) -# ifndef GC_THREADS -# define GC_THREADS -# endif -#elif defined(GC_THREADS) -# if defined(__linux__) -# define GC_LINUX_THREADS -# endif -# if !defined(__linux__) && (defined(_PA_RISC1_1) || defined(_PA_RISC2_0) \ - || defined(hppa) || defined(__HPPA)) \ - || (defined(__ia64) && defined(_HPUX_SOURCE)) -# define GC_HPUX_THREADS -# endif -# if !defined(__linux__) && (defined(__alpha) || defined(__alpha__)) -# define GC_OSF1_THREADS -# endif -# if defined(__mips) && !defined(__linux__) -# define GC_IRIX_THREADS -# endif -# if defined(__sparc) && !defined(__linux__) \ - || defined(sun) && (defined(i386) || defined(__i386__) \ - || defined(__amd64__)) -# define GC_SOLARIS_THREADS -# elif defined(__APPLE__) && defined(__MACH__) -# define GC_DARWIN_THREADS -# elif defined(__OpenBSD__) -# define GC_OPENBSD_THREADS -# elif !defined(GC_LINUX_THREADS) && !defined(GC_HPUX_THREADS) \ - && !defined(GC_OSF1_THREADS) && !defined(GC_IRIX_THREADS) - /* FIXME: Should we really need for FreeBSD and NetBSD to check */ - /* that no other GC_xxx_THREADS macro is set? */ -# if defined(__FreeBSD__) || defined(__DragonFly__) -# define GC_FREEBSD_THREADS -# elif defined(__NetBSD__) -# define GC_NETBSD_THREADS -# endif -# endif -# if defined(DGUX) && (defined(i386) || defined(__i386__)) -# define GC_DGUX386_THREADS -# endif -# if defined(_AIX) -# define GC_AIX_THREADS -# endif -# if (defined(_WIN32) || defined(_MSC_VER) || defined(__BORLANDC__) \ - || defined(__CYGWIN32__) || defined(__CYGWIN__) || defined(__CEGCC__) \ - || defined(_WIN32_WCE) || defined(__MINGW32__)) \ - && !defined(GC_WIN32_THREADS) - /* Either posix or native Win32 threads. */ -# define GC_WIN32_THREADS -# endif -# if defined(__rtems__) && (defined(i386) || defined(__i386__)) -# define GC_RTEMS_PTHREADS -# endif -#endif /* GC_THREADS */ - -#undef GC_PTHREADS -#if (!defined(GC_WIN32_THREADS) || defined(GC_WIN32_PTHREADS) \ - || defined(__CYGWIN32__) || defined(__CYGWIN__)) && defined(GC_THREADS) - /* Posix threads. */ -# define GC_PTHREADS -#endif - -#if !defined(_PTHREADS) && defined(GC_NETBSD_THREADS) -# define _PTHREADS -#endif - -#if defined(GC_DGUX386_THREADS) && !defined(_POSIX4A_DRAFT10_SOURCE) -# define _POSIX4A_DRAFT10_SOURCE 1 -#endif - -#if !defined(_REENTRANT) && defined(GC_PTHREADS) && !defined(GC_WIN32_THREADS) - /* Better late than never. This fails if system headers that depend */ - /* on this were previously included. */ -# define _REENTRANT -#endif - -#define __GC -#if !defined(_WIN32_WCE) || defined(__GNUC__) -# include -# if defined(__MINGW32__) && !defined(_WIN32_WCE) -# include - /* We mention uintptr_t. */ - /* Perhaps this should be included in pure msft environments */ - /* as well? */ -# endif -#else /* _WIN32_WCE */ - /* Yet more kludges for WinCE. */ -# include /* size_t is defined here */ -# ifndef _PTRDIFF_T_DEFINED - /* ptrdiff_t is not defined */ -# define _PTRDIFF_T_DEFINED - typedef long ptrdiff_t; -# endif -#endif /* _WIN32_WCE */ - -#if !defined(GC_NOT_DLL) && !defined(GC_DLL) \ - && ((defined(_DLL) && !defined(__GNUC__)) \ - || (defined(DLL_EXPORT) && defined(GC_BUILD))) -# define GC_DLL -#endif - -#if defined(GC_DLL) && !defined(GC_API) - -# if defined(__MINGW32__) || defined(__CEGCC__) -# ifdef GC_BUILD -# define GC_API __declspec(dllexport) -# else -# define GC_API __declspec(dllimport) -# endif - -# elif defined(_MSC_VER) || defined(__DMC__) || defined(__BORLANDC__) \ - || defined(__CYGWIN__) -# ifdef GC_BUILD -# define GC_API extern __declspec(dllexport) -# else -# define GC_API __declspec(dllimport) -# endif - -# elif defined(__WATCOMC__) -# ifdef GC_BUILD -# define GC_API extern __declspec(dllexport) -# else -# define GC_API extern __declspec(dllimport) -# endif - -# elif defined(__SYMBIAN32__) -# ifdef GC_BUILD -# define GC_API extern EXPORT_C -# else -# define GC_API extern IMPORT_C -# endif - -# elif defined(__GNUC__) - /* Only matters if used in conjunction with -fvisibility=hidden option. */ -# if defined(GC_BUILD) && (__GNUC__ >= 4 \ - || defined(GC_VISIBILITY_HIDDEN_SET)) -# define GC_API extern __attribute__((__visibility__("default"))) -# endif -# endif -#endif /* GC_DLL */ - -#ifndef GC_API -# define GC_API extern -#endif - -#ifndef GC_CALL -# define GC_CALL -#endif - -#ifndef GC_CALLBACK -# define GC_CALLBACK GC_CALL -#endif - -#ifndef GC_ATTR_MALLOC - /* 'malloc' attribute should be used for all malloc-like functions */ - /* (to tell the compiler that a function may be treated as if any */ - /* non-NULL pointer it returns cannot alias any other pointer valid */ - /* when the function returns). If the client code violates this rule */ - /* by using custom GC_oom_func then define GC_OOM_FUNC_RETURNS_ALIAS. */ -# ifdef GC_OOM_FUNC_RETURNS_ALIAS -# define GC_ATTR_MALLOC /* empty */ -# elif defined(__GNUC__) && (__GNUC__ > 3 \ - || (__GNUC__ == 3 && __GNUC_MINOR__ >= 1)) -# define GC_ATTR_MALLOC __attribute__((__malloc__)) -# elif defined(_MSC_VER) && _MSC_VER >= 14 -# define GC_ATTR_MALLOC __declspec(noalias) __declspec(restrict) -# else -# define GC_ATTR_MALLOC -# endif -#endif - -#ifndef GC_ATTR_ALLOC_SIZE - /* 'alloc_size' attribute improves __builtin_object_size correctness. */ - /* Only single-argument form of 'alloc_size' attribute is used. */ -# ifdef __clang__ -# if __has_attribute(__alloc_size__) -# define GC_ATTR_ALLOC_SIZE(argnum) __attribute__((__alloc_size__(argnum))) -# else -# define GC_ATTR_ALLOC_SIZE(argnum) /* empty */ -# endif -# elif __GNUC__ > 4 \ - || (__GNUC__ == 4 && __GNUC_MINOR__ >= 3 && !defined(__ICC)) -# define GC_ATTR_ALLOC_SIZE(argnum) __attribute__((__alloc_size__(argnum))) -# else -# define GC_ATTR_ALLOC_SIZE(argnum) /* empty */ -# endif -#endif - -#ifndef GC_ATTR_NONNULL -# if defined(__GNUC__) && __GNUC__ >= 4 -# define GC_ATTR_NONNULL(argnum) __attribute__((__nonnull__(argnum))) -# else -# define GC_ATTR_NONNULL(argnum) /* empty */ -# endif -#endif - -#ifndef GC_ATTR_DEPRECATED -# ifdef GC_BUILD -# undef GC_ATTR_DEPRECATED -# define GC_ATTR_DEPRECATED /* empty */ -# elif defined(__GNUC__) && __GNUC__ >= 4 -# define GC_ATTR_DEPRECATED __attribute__((__deprecated__)) -# elif defined(_MSC_VER) && _MSC_VER >= 12 -# define GC_ATTR_DEPRECATED __declspec(deprecated) -# else -# define GC_ATTR_DEPRECATED /* empty */ -# endif -#endif - -#if defined(__sgi) && !defined(__GNUC__) && _COMPILER_VERSION >= 720 -# define GC_ADD_CALLER -# define GC_RETURN_ADDR (GC_word)__return_address -#endif - -#if defined(__linux__) || defined(__GLIBC__) -# if !defined(__native_client__) -# include -# endif -# if (__GLIBC__ == 2 && __GLIBC_MINOR__ >= 1 || __GLIBC__ > 2) \ - && !defined(__ia64__) && !defined(__UCLIBC__) \ - && !defined(GC_HAVE_BUILTIN_BACKTRACE) -# define GC_HAVE_BUILTIN_BACKTRACE -# endif -# if defined(__i386__) || defined(__amd64__) || defined(__x86_64__) -# define GC_CAN_SAVE_CALL_STACKS -# endif -#endif /* GLIBC */ - -#if defined(_MSC_VER) && _MSC_VER >= 1200 /* version 12.0+ (MSVC 6.0+) */ \ - && !defined(_AMD64_) && !defined(_M_X64) && !defined(_WIN32_WCE) \ - && !defined(GC_HAVE_NO_BUILTIN_BACKTRACE) \ - && !defined(GC_HAVE_BUILTIN_BACKTRACE) -# define GC_HAVE_BUILTIN_BACKTRACE -#endif - -#if defined(GC_HAVE_BUILTIN_BACKTRACE) && !defined(GC_CAN_SAVE_CALL_STACKS) -# define GC_CAN_SAVE_CALL_STACKS -#endif - -#if defined(__sparc__) -# define GC_CAN_SAVE_CALL_STACKS -#endif - -/* If we're on a platform on which we can't save call stacks, but */ -/* gcc is normally used, we go ahead and define GC_ADD_CALLER. */ -/* We make this decision independent of whether gcc is actually being */ -/* used, in order to keep the interface consistent, and allow mixing */ -/* of compilers. */ -/* This may also be desirable if it is possible but expensive to */ -/* retrieve the call chain. */ -#if (defined(__linux__) || defined(__NetBSD__) || defined(__OpenBSD__) \ - || defined(__FreeBSD__) || defined(__DragonFly__) \ - || defined(PLATFORM_ANDROID) || defined(__ANDROID__)) \ - && !defined(GC_CAN_SAVE_CALL_STACKS) -# define GC_ADD_CALLER -# if __GNUC__ >= 3 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 95) - /* gcc knows how to retrieve return address, but we don't know */ - /* how to generate call stacks. */ -# define GC_RETURN_ADDR (GC_word)__builtin_return_address(0) -# if (__GNUC__ >= 4) && (defined(__i386__) || defined(__amd64__) \ - || defined(__x86_64__) /* and probably others... */) -# define GC_RETURN_ADDR_PARENT \ - (GC_word)__builtin_extract_return_addr(__builtin_return_address(1)) -# endif -# else - /* Just pass 0 for gcc compatibility. */ -# define GC_RETURN_ADDR 0 -# endif -#endif /* !GC_CAN_SAVE_CALL_STACKS */ - -#ifdef GC_PTHREADS - -# if (defined(GC_DARWIN_THREADS) || defined(GC_WIN32_PTHREADS) \ - || defined(__native_client__) || defined(GC_RTEMS_PTHREADS)) \ - && !defined(GC_NO_DLOPEN) - /* Either there is no dlopen() or we do not need to intercept it. */ -# define GC_NO_DLOPEN -# endif - -# if (defined(GC_DARWIN_THREADS) || defined(GC_WIN32_PTHREADS) \ - || defined(GC_OPENBSD_THREADS) || defined(__native_client__)) \ - && !defined(GC_NO_PTHREAD_SIGMASK) - /* Either there is no pthread_sigmask() or no need to intercept it. */ -# define GC_NO_PTHREAD_SIGMASK -# endif - -# if defined(__native_client__) - /* At present, NaCl pthread_create() prototype does not have */ - /* "const" for its "attr" argument; also, NaCl pthread_exit() one */ - /* does not have "noreturn" attribute. */ -# ifndef GC_PTHREAD_CREATE_CONST -# define GC_PTHREAD_CREATE_CONST /* empty */ -# endif -# ifndef GC_PTHREAD_EXIT_ATTRIBUTE -# define GC_PTHREAD_EXIT_ATTRIBUTE /* empty */ -# endif -# endif - -# if !defined(GC_PTHREAD_EXIT_ATTRIBUTE) \ - && !defined(PLATFORM_ANDROID) && !defined(__ANDROID__) \ - && (defined(GC_LINUX_THREADS) || defined(GC_SOLARIS_THREADS)) - /* Intercept pthread_exit on Linux and Solaris. */ -# if defined(__GNUC__) /* since GCC v2.7 */ -# define GC_PTHREAD_EXIT_ATTRIBUTE __attribute__((__noreturn__)) -# elif defined(__NORETURN) /* used in Solaris */ -# define GC_PTHREAD_EXIT_ATTRIBUTE __NORETURN -# else -# define GC_PTHREAD_EXIT_ATTRIBUTE /* empty */ -# endif -# endif - -# if (!defined(GC_PTHREAD_EXIT_ATTRIBUTE) || defined(__native_client__)) \ - && !defined(GC_NO_PTHREAD_CANCEL) - /* Either there is no pthread_cancel() or no need to intercept it. */ -# define GC_NO_PTHREAD_CANCEL -# endif - -#endif /* GC_PTHREADS */ - -#endif diff -Nru ecl-16.1.2/src/bdwgc/include/gc_cpp.h ecl-16.1.3+ds/src/bdwgc/include/gc_cpp.h --- ecl-16.1.2/src/bdwgc/include/gc_cpp.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/gc_cpp.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,436 +0,0 @@ -/* - * Copyright (c) 1994 by Xerox Corporation. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program for any - * purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is - * granted, provided the above notices are retained, and a notice that - * the code was modified is included with the above copyright notice. - */ - -#ifndef GC_CPP_H -#define GC_CPP_H - -/**************************************************************************** -C++ Interface to the Boehm Collector - - John R. Ellis and Jesse Hull - -This interface provides access to the Boehm collector. It provides -basic facilities similar to those described in "Safe, Efficient -Garbage Collection for C++", by John R. Ellis and David L. Detlefs -(ftp://ftp.parc.xerox.com/pub/ellis/gc). - -All heap-allocated objects are either "collectible" or -"uncollectible". Programs must explicitly delete uncollectible -objects, whereas the garbage collector will automatically delete -collectible objects when it discovers them to be inaccessible. -Collectible objects may freely point at uncollectible objects and vice -versa. - -Objects allocated with the built-in "::operator new" are uncollectible. - -Objects derived from class "gc" are collectible. For example: - - class A: public gc {...}; - A* a = new A; // a is collectible. - -Collectible instances of non-class types can be allocated using the GC -(or UseGC) placement: - - typedef int A[ 10 ]; - A* a = new (GC) A; - -Uncollectible instances of classes derived from "gc" can be allocated -using the NoGC placement: - - class A: public gc {...}; - A* a = new (NoGC) A; // a is uncollectible. - -The new(PointerFreeGC) syntax allows the allocation of collectible -objects that are not scanned by the collector. This useful if you -are allocating compressed data, bitmaps, or network packets. (In -the latter case, it may remove danger of unfriendly network packets -intentionally containing values that cause spurious memory retention.) - -Both uncollectible and collectible objects can be explicitly deleted -with "delete", which invokes an object's destructors and frees its -storage immediately. - -A collectible object may have a clean-up function, which will be -invoked when the collector discovers the object to be inaccessible. -An object derived from "gc_cleanup" or containing a member derived -from "gc_cleanup" has a default clean-up function that invokes the -object's destructors. Explicit clean-up functions may be specified as -an additional placement argument: - - A* a = ::new (GC, MyCleanup) A; - -An object is considered "accessible" by the collector if it can be -reached by a path of pointers from static variables, automatic -variables of active functions, or from some object with clean-up -enabled; pointers from an object to itself are ignored. - -Thus, if objects A and B both have clean-up functions, and A points at -B, B is considered accessible. After A's clean-up is invoked and its -storage released, B will then become inaccessible and will have its -clean-up invoked. If A points at B and B points to A, forming a -cycle, then that's considered a storage leak, and neither will be -collectible. See the interface gc.h for low-level facilities for -handling such cycles of objects with clean-up. - -The collector cannot guarantee that it will find all inaccessible -objects. In practice, it finds almost all of them. - - -Cautions: - -1. Be sure the collector has been augmented with "make c++" or -"--enable-cplusplus". - -2. If your compiler supports the new "operator new[]" syntax, then -add -DGC_OPERATOR_NEW_ARRAY to the Makefile. - -If your compiler doesn't support "operator new[]", beware that an -array of type T, where T is derived from "gc", may or may not be -allocated as a collectible object (it depends on the compiler). Use -the explicit GC placement to make the array collectible. For example: - - class A: public gc {...}; - A* a1 = new A[ 10 ]; // collectible or uncollectible? - A* a2 = new (GC) A[ 10 ]; // collectible. - -3. The destructors of collectible arrays of objects derived from -"gc_cleanup" will not be invoked properly. For example: - - class A: public gc_cleanup {...}; - A* a = new (GC) A[ 10 ]; // destructors not invoked correctly - -Typically, only the destructor for the first element of the array will -be invoked when the array is garbage-collected. To get all the -destructors of any array executed, you must supply an explicit -clean-up function: - - A* a = new (GC, MyCleanUp) A[ 10 ]; - -(Implementing clean-up of arrays correctly, portably, and in a way -that preserves the correct exception semantics requires a language -extension, e.g. the "gc" keyword.) - -4. Compiler bugs (now hopefully history): - -* Solaris 2's CC (SC3.0) doesn't implement t->~T() correctly, so the -destructors of classes derived from gc_cleanup won't be invoked. -You'll have to explicitly register a clean-up function with -new-placement syntax. - -* Evidently cfront 3.0 does not allow destructors to be explicitly -invoked using the ANSI-conforming syntax t->~T(). If you're using -cfront 3.0, you'll have to comment out the class gc_cleanup, which -uses explicit invocation. - -5. GC name conflicts: - -Many other systems seem to use the identifier "GC" as an abbreviation -for "Graphics Context". Since version 5.0, GC placement has been replaced -by UseGC. GC is an alias for UseGC, unless GC_NAME_CONFLICT is defined. - -****************************************************************************/ - -#include "gc.h" - -#ifdef GC_NAMESPACE -# define GC_NS_QUALIFY(T) boehmgc::T -#else -# define GC_NS_QUALIFY(T) T -#endif - -#ifndef THINK_CPLUS -# define GC_cdecl GC_CALLBACK -#else -# define GC_cdecl _cdecl -#endif - -#if ! defined( GC_NO_OPERATOR_NEW_ARRAY ) \ - && !defined(_ENABLE_ARRAYNEW) /* Digimars */ \ - && (defined(__BORLANDC__) && (__BORLANDC__ < 0x450) \ - || (defined(__GNUC__) && \ - (__GNUC__ < 2 || __GNUC__ == 2 && __GNUC_MINOR__ < 6)) \ - || (defined(_MSC_VER) && _MSC_VER <= 1020) \ - || (defined(__WATCOMC__) && __WATCOMC__ < 1050)) -# define GC_NO_OPERATOR_NEW_ARRAY -#endif - -#if !defined(GC_NO_OPERATOR_NEW_ARRAY) && !defined(GC_OPERATOR_NEW_ARRAY) -# define GC_OPERATOR_NEW_ARRAY -#endif - -#if (!defined(__BORLANDC__) || __BORLANDC__ > 0x0620) \ - && ! defined ( __sgi ) && ! defined( __WATCOMC__ ) \ - && (!defined(_MSC_VER) || _MSC_VER > 1020) -# define GC_PLACEMENT_DELETE -#endif - -#ifdef GC_NAMESPACE -namespace boehmgc -{ -#endif - -enum GCPlacement { - UseGC, -# ifndef GC_NAME_CONFLICT - GC=UseGC, -# endif - NoGC, - PointerFreeGC -}; - -class gc { - public: - inline void* operator new( size_t size ); - inline void* operator new( size_t size, GCPlacement gcp ); - inline void* operator new( size_t size, void *p ); - /* Must be redefined here, since the other overloadings */ - /* hide the global definition. */ - inline void operator delete( void* obj ); -# ifdef GC_PLACEMENT_DELETE - inline void operator delete( void*, GCPlacement ); - /* called if construction fails. */ - inline void operator delete( void*, void* ); -# endif - -#ifdef GC_OPERATOR_NEW_ARRAY - inline void* operator new[]( size_t size ); - inline void* operator new[]( size_t size, GCPlacement gcp ); - inline void* operator new[]( size_t size, void *p ); - inline void operator delete[]( void* obj ); -# ifdef GC_PLACEMENT_DELETE - inline void operator delete[]( void*, GCPlacement ); - inline void operator delete[]( void*, void* ); -# endif -#endif /* GC_OPERATOR_NEW_ARRAY */ -}; - /* - Instances of classes derived from "gc" will be allocated in the - collected heap by default, unless an explicit NoGC placement is - specified. */ - -class gc_cleanup: virtual public gc { - public: - inline gc_cleanup(); - inline virtual ~gc_cleanup(); -private: - inline static void GC_cdecl cleanup( void* obj, void* clientData ); -}; - /* - Instances of classes derived from "gc_cleanup" will be allocated - in the collected heap by default. When the collector discovers an - inaccessible object derived from "gc_cleanup" or containing a - member derived from "gc_cleanup", its destructors will be - invoked. */ - -extern "C" { - typedef void (GC_CALLBACK * GCCleanUpFunc)( void* obj, void* clientData ); -} - -#ifdef GC_NAMESPACE -} -#endif - -#ifdef _MSC_VER - // Disable warning that "no matching operator delete found; memory will - // not be freed if initialization throws an exception" -# pragma warning(disable:4291) -#endif - -inline void* operator new( size_t size, GC_NS_QUALIFY(GCPlacement) gcp, - GC_NS_QUALIFY(GCCleanUpFunc) cleanup = 0, - void* clientData = 0 ); - /* - Allocates a collectible or uncollectible object, according to the - value of "gcp". - - For collectible objects, if "cleanup" is non-null, then when the - allocated object "obj" becomes inaccessible, the collector will - invoke the function "cleanup( obj, clientData )" but will not - invoke the object's destructors. It is an error to explicitly - delete an object allocated with a non-null "cleanup". - - It is an error to specify a non-null "cleanup" with NoGC or for - classes derived from "gc_cleanup" or containing members derived - from "gc_cleanup". */ - -#ifdef GC_PLACEMENT_DELETE - inline void operator delete( void*, GC_NS_QUALIFY(GCPlacement), - GC_NS_QUALIFY(GCCleanUpFunc), void * ); -#endif - -#ifdef _MSC_VER - /** This ensures that the system default operator new[] doesn't get - * undefined, which is what seems to happen on VC++ 6 for some reason - * if we define a multi-argument operator new[]. - * There seems to be no way to redirect new in this environment without - * including this everywhere. - */ -# if _MSC_VER > 1020 - void *operator new[]( size_t size ); - void operator delete[]( void* obj ); -# endif - - void* operator new( size_t size ); - void operator delete( void* obj ); - - // This new operator is used by VC++ in case of Debug builds ! - void* operator new( size_t size, int /* nBlockUse */, - const char * szFileName, int nLine ); -#endif /* _MSC_VER */ - -#ifdef GC_OPERATOR_NEW_ARRAY - inline void* operator new[]( size_t size, GC_NS_QUALIFY(GCPlacement) gcp, - GC_NS_QUALIFY(GCCleanUpFunc) cleanup = 0, - void* clientData = 0 ); - /* The operator new for arrays, identical to the above. */ -#endif /* GC_OPERATOR_NEW_ARRAY */ - -/**************************************************************************** - -Inline implementation - -****************************************************************************/ - -#ifdef GC_NAMESPACE -namespace boehmgc -{ -#endif - -inline void* gc::operator new( size_t size ) { - return GC_MALLOC( size ); -} - -inline void* gc::operator new( size_t size, GCPlacement gcp ) { - if (gcp == UseGC) - return GC_MALLOC( size ); - else if (gcp == PointerFreeGC) - return GC_MALLOC_ATOMIC( size ); - else - return GC_MALLOC_UNCOLLECTABLE( size ); -} - -inline void* gc::operator new( size_t /* size */, void *p ) { - return p; -} - -inline void gc::operator delete( void* obj ) { - GC_FREE( obj ); -} - -#ifdef GC_PLACEMENT_DELETE - inline void gc::operator delete( void*, void* ) {} - - inline void gc::operator delete( void* p, GCPlacement /* gcp */ ) { - GC_FREE(p); - } -#endif - -#ifdef GC_OPERATOR_NEW_ARRAY - inline void* gc::operator new[]( size_t size ) { - return gc::operator new( size ); - } - - inline void* gc::operator new[]( size_t size, GCPlacement gcp ) { - return gc::operator new( size, gcp ); - } - - inline void* gc::operator new[]( size_t /* size */, void *p ) { - return p; - } - - inline void gc::operator delete[]( void* obj ) { - gc::operator delete( obj ); - } - -# ifdef GC_PLACEMENT_DELETE - inline void gc::operator delete[]( void*, void* ) {} - - inline void gc::operator delete[]( void* p, GCPlacement /* gcp */ ) { - gc::operator delete(p); - } -# endif -#endif /* GC_OPERATOR_NEW_ARRAY */ - -inline gc_cleanup::~gc_cleanup() { - GC_register_finalizer_ignore_self( GC_base(this), 0, 0, 0, 0 ); -} - -inline void GC_CALLBACK gc_cleanup::cleanup( void* obj, void* displ ) { - ((gc_cleanup*) ((char*) obj + (ptrdiff_t) displ))->~gc_cleanup(); -} - -inline gc_cleanup::gc_cleanup() { - GC_finalization_proc oldProc; - void* oldData; - void* base = GC_base( (void *) this ); - if (0 != base) { - // Don't call the debug version, since this is a real base address. - GC_register_finalizer_ignore_self( base, (GC_finalization_proc)cleanup, - (void*)((char*)this - (char*)base), - &oldProc, &oldData ); - if (0 != oldProc) { - GC_register_finalizer_ignore_self( base, oldProc, oldData, 0, 0 ); - } - } -} - -#ifdef GC_NAMESPACE -} -#endif - -inline void* operator new( size_t size, GC_NS_QUALIFY(GCPlacement) gcp, - GC_NS_QUALIFY(GCCleanUpFunc) cleanup, - void* clientData ) -{ - void* obj; - - if (gcp == GC_NS_QUALIFY(UseGC)) { - obj = GC_MALLOC( size ); - if (cleanup != 0) - GC_REGISTER_FINALIZER_IGNORE_SELF( obj, cleanup, clientData, - 0, 0 ); - } else if (gcp == GC_NS_QUALIFY(PointerFreeGC)) { - obj = GC_MALLOC_ATOMIC( size ); - } else { - obj = GC_MALLOC_UNCOLLECTABLE( size ); - }; - return obj; -} - -#ifdef GC_PLACEMENT_DELETE - inline void operator delete( void *p, GC_NS_QUALIFY(GCPlacement) /* gcp */, - GC_NS_QUALIFY(GCCleanUpFunc) /* cleanup */, - void* /* clientData */ ) - { - GC_FREE(p); - } -#endif /* GC_PLACEMENT_DELETE */ - -#ifdef GC_OPERATOR_NEW_ARRAY - inline void* operator new[]( size_t size, GC_NS_QUALIFY(GCPlacement) gcp, - GC_NS_QUALIFY(GCCleanUpFunc) cleanup, - void* clientData ) - { - return ::operator new( size, gcp, cleanup, clientData ); - } -#endif /* GC_OPERATOR_NEW_ARRAY */ - -#if defined(__CYGWIN__) -# include // for delete throw() - inline void operator delete(void *p) - { - GC_FREE(p); - } -#endif - -#endif /* GC_CPP_H */ diff -Nru ecl-16.1.2/src/bdwgc/include/gc_disclaim.h ecl-16.1.3+ds/src/bdwgc/include/gc_disclaim.h --- ecl-16.1.2/src/bdwgc/include/gc_disclaim.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/gc_disclaim.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,55 +0,0 @@ -/* - * Copyright (c) 2007-2011 by Hewlett-Packard Company. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -#ifndef GC_DISCLAIM_H -#define GC_DISCLAIM_H - -#include "gc.h" - -/* This API is defined only if the library has been suitably compiled */ -/* (i.e. with ENABLE_DISCLAIM defined). */ - -/* Prepare the object kind used by GC_finalized_malloc. Call it from */ -/* your initialization code or, at least, at some point before using */ -/* finalized allocations. The function is thread-safe. */ -GC_API void GC_CALL GC_init_finalized_malloc(void); - -/* Type of a disclaim call-back. */ -typedef int (GC_CALLBACK * GC_disclaim_proc)(void * /*obj*/); - -/* Register "proc" to be called on each object of "kind" ready to be */ -/* reclaimed. If "proc" returns non-zero, the collector will not */ -/* reclaim the object on this GC cycle. Objects reachable from "proc" */ -/* will be protected from collection if "mark_from_all" is non-zero, */ -/* but at the expense that long chains of objects will take many cycles */ -/* to reclaim. */ -GC_API void GC_CALL GC_register_disclaim_proc(int /*kind*/, - GC_disclaim_proc /*proc*/, - int /*mark_from_all*/); - -/* The finalizer closure used by GC_finalized_malloc. */ -struct GC_finalizer_closure { - GC_finalization_proc proc; - void *cd; -}; - -/* Allocate "size" bytes which is finalized by "fc". This uses a */ -/* dedicated object kind with a disclaim procedure, and is more */ -/* efficient than GC_register_finalizer and friends. */ -/* GC_init_finalized_malloc must be called before using this. */ -GC_API GC_ATTR_MALLOC GC_ATTR_ALLOC_SIZE(1) void * GC_CALL - GC_finalized_malloc(size_t /*size*/, - const struct GC_finalizer_closure * /*fc*/); - -#endif diff -Nru ecl-16.1.2/src/bdwgc/include/gc_gcj.h ecl-16.1.3+ds/src/bdwgc/include/gc_gcj.h --- ecl-16.1.2/src/bdwgc/include/gc_gcj.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/gc_gcj.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,110 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1995 by Xerox Corporation. All rights reserved. - * Copyright 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright 1999 by Hewlett-Packard Company. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -/* This file assumes the collector has been compiled with GC_GCJ_SUPPORT. */ - -/* - * We allocate objects whose first word contains a pointer to a struct - * describing the object type. This struct contains a garbage collector mark - * descriptor at offset MARK_DESCR_OFFSET. Alternatively, the objects - * may be marked by the mark procedure passed to GC_init_gcj_malloc. - */ - -#ifndef GC_GCJ_H -#define GC_GCJ_H - - /* Gcj keeps GC descriptor as second word of vtable. This */ - /* probably needs to be adjusted for other clients. */ - /* We currently assume that this offset is such that: */ - /* - all objects of this kind are large enough to have */ - /* a value at that offset, and */ - /* - it is not zero. */ - /* These assumptions allow objects on the free list to be */ - /* marked normally. */ - -#ifndef GC_H -# include "gc.h" -#endif - -#ifdef __cplusplus - extern "C" { -#endif - -/* The following allocators signal an out of memory condition with */ -/* return GC_oom_fn(bytes); */ - -/* The following function must be called before the gcj allocators */ -/* can be invoked. */ -/* mp_index and mp are the index and mark_proc (see gc_mark.h) */ -/* respectively for the allocated objects. Mark_proc will be */ -/* used to build the descriptor for objects allocated through the */ -/* debugging interface. The mark_proc will be invoked on all such */ -/* objects with an "environment" value of 1. The client may choose */ -/* to use the same mark_proc for some of its generated mark descriptors.*/ -/* In that case, it should use a different "environment" value to */ -/* detect the presence or absence of the debug header. */ -/* Mp is really of type mark_proc, as defined in gc_mark.h. We don't */ -/* want to include that here for namespace pollution reasons. */ -/* Passing in mp_index here instead of having GC_init_gcj_malloc() */ -/* internally call GC_new_proc() is quite ugly, but in typical usage */ -/* scenarios a compiler also has to know about mp_index, so */ -/* generating it dynamically is not acceptable. Mp_index will */ -/* typically be an integer < RESERVED_MARK_PROCS, so that it doesn't */ -/* collide with GC_new_proc allocated indices. If the application */ -/* needs no other reserved indices, zero */ -/* (GC_GCJ_RESERVED_MARK_PROC_INDEX in gc_mark.h) is an obvious choice. */ -GC_API void GC_CALL GC_init_gcj_malloc(int /* mp_index */, - void * /* really mark_proc */ /* mp */); - -/* Allocate an object, clear it, and store the pointer to the */ -/* type structure (vtable in gcj). */ -/* This adds a byte at the end of the object if GC_malloc would.*/ -GC_API GC_ATTR_MALLOC GC_ATTR_ALLOC_SIZE(1) void * GC_CALL - GC_gcj_malloc(size_t /* lb */, - void * /* ptr_to_struct_containing_descr */); - -/* The debug versions allocate such that the specified mark_proc */ -/* is always invoked. */ -GC_API GC_ATTR_MALLOC GC_ATTR_ALLOC_SIZE(1) void * GC_CALL - GC_debug_gcj_malloc(size_t /* lb */, - void * /* ptr_to_struct_containing_descr */, - GC_EXTRA_PARAMS); - -/* Similar to GC_gcj_malloc, but assumes that a pointer to near the */ -/* beginning of the resulting object is always maintained. */ -GC_API GC_ATTR_MALLOC GC_ATTR_ALLOC_SIZE(1) void * GC_CALL - GC_gcj_malloc_ignore_off_page(size_t /* lb */, - void * /* ptr_to_struct_containing_descr */); - -/* The kind numbers of normal and debug gcj objects. */ -/* Useful only for debug support, we hope. */ -GC_API int GC_gcj_kind; - -GC_API int GC_gcj_debug_kind; - -#ifdef GC_DEBUG -# define GC_GCJ_MALLOC(s,d) GC_debug_gcj_malloc(s,d,GC_EXTRAS) -# define GC_GCJ_MALLOC_IGNORE_OFF_PAGE(s,d) GC_debug_gcj_malloc(s,d,GC_EXTRAS) -#else -# define GC_GCJ_MALLOC(s,d) GC_gcj_malloc(s,d) -# define GC_GCJ_MALLOC_IGNORE_OFF_PAGE(s,d) GC_gcj_malloc_ignore_off_page(s,d) -#endif - -#ifdef __cplusplus - } /* end of extern "C" */ -#endif - -#endif /* GC_GCJ_H */ diff -Nru ecl-16.1.2/src/bdwgc/include/gc.h ecl-16.1.3+ds/src/bdwgc/include/gc.h --- ecl-16.1.2/src/bdwgc/include/gc.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/gc.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,1783 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1995 by Xerox Corporation. All rights reserved. - * Copyright 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright 1999 by Hewlett-Packard Company. All rights reserved. - * Copyright (C) 2007 Free Software Foundation, Inc - * Copyright (c) 2000-2011 by Hewlett-Packard Development Company. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -/* - * Note that this defines a large number of tuning hooks, which can - * safely be ignored in nearly all cases. For normal use it suffices - * to call only GC_MALLOC and perhaps GC_REALLOC. - * For better performance, also look at GC_MALLOC_ATOMIC, and - * GC_enable_incremental. If you need an action to be performed - * immediately before an object is collected, look at GC_register_finalizer. - * If you are using Solaris threads, look at the end of this file. - * Everything else is best ignored unless you encounter performance - * problems. - */ - -#ifndef GC_H -#define GC_H - -#include "gc_version.h" - /* Define version numbers here to allow test on build machine */ - /* for cross-builds. Note that this defines the header */ - /* version number, which may or may not match that of the */ - /* dynamic library. GC_get_version() can be used to obtain */ - /* the latter. */ - -#include "gc_config_macros.h" - -#ifdef __cplusplus - extern "C" { -#endif - -typedef void * GC_PTR; /* preserved only for backward compatibility */ - -/* Define word and signed_word to be unsigned and signed types of the */ -/* size as char * or void *. There seems to be no way to do this */ -/* even semi-portably. The following is probably no better/worse */ -/* than almost anything else. */ -/* The ANSI standard suggests that size_t and ptrdiff_t might be */ -/* better choices. But those had incorrect definitions on some older */ -/* systems. Notably "typedef int size_t" is WRONG. */ -#ifdef _WIN64 -# ifdef __int64 - typedef unsigned __int64 GC_word; - typedef __int64 GC_signed_word; -# else - typedef unsigned long long GC_word; - typedef long long GC_signed_word; -# endif -#else - typedef unsigned long GC_word; - typedef long GC_signed_word; -#endif - -/* Get the GC library version. The returned value is a constant in the */ -/* form: ((version_major<<16) | (version_minor<<8) | version_micro). */ -GC_API unsigned GC_CALL GC_get_version(void); - -/* Public read-only variables */ -/* The supplied getter functions are preferred for new code. */ - -GC_API GC_ATTR_DEPRECATED GC_word GC_gc_no; - /* Counter incremented per collection. */ - /* Includes empty GCs at startup. */ -GC_API GC_word GC_CALL GC_get_gc_no(void); - /* GC_get_gc_no() is unsynchronized, so */ - /* it requires GC_call_with_alloc_lock() to */ - /* avoid data races on multiprocessors. */ - -#ifdef GC_THREADS - GC_API GC_ATTR_DEPRECATED int GC_parallel; - /* GC is parallelized for performance on */ - /* multiprocessors. Currently set only */ - /* implicitly if collector is built with */ - /* PARALLEL_MARK defined and if either: */ - /* Env variable GC_NPROC is set to > 1, or */ - /* GC_NPROC is not set and this is an MP. */ - /* If GC_parallel is on (non-zero), incremental */ - /* collection is only partially functional, */ - /* and may not be desirable. The getter does */ - /* not use or need synchronization (i.e. */ - /* acquiring the GC lock). Starting from */ - /* GC v7.3, GC_parallel value is equal to the */ - /* number of marker threads minus one (i.e. */ - /* number of existing parallel marker threads */ - /* excluding the initiating one). */ - GC_API int GC_CALL GC_get_parallel(void); -#endif - - -/* Public R/W variables */ -/* The supplied setter and getter functions are preferred for new code. */ - -typedef void * (GC_CALLBACK * GC_oom_func)(size_t /* bytes_requested */); -GC_API GC_ATTR_DEPRECATED GC_oom_func GC_oom_fn; - /* When there is insufficient memory to satisfy */ - /* an allocation request, we return */ - /* (*GC_oom_fn)(size). By default this just */ - /* returns NULL. */ - /* If it returns, it must return 0 or a valid */ - /* pointer to a previously allocated heap */ - /* object. GC_oom_fn must not be 0. */ - /* Both the supplied setter and the getter */ - /* acquire the GC lock (to avoid data races). */ -GC_API void GC_CALL GC_set_oom_fn(GC_oom_func) GC_ATTR_NONNULL(1); -GC_API GC_oom_func GC_CALL GC_get_oom_fn(void); - -typedef void (GC_CALLBACK * GC_on_heap_resize_proc)(GC_word /* new_size */); -GC_API GC_ATTR_DEPRECATED GC_on_heap_resize_proc GC_on_heap_resize; - /* Invoked when the heap grows or shrinks. */ - /* Called with the world stopped (and the */ - /* allocation lock held). May be 0. */ -GC_API void GC_CALL GC_set_on_heap_resize(GC_on_heap_resize_proc); -GC_API GC_on_heap_resize_proc GC_CALL GC_get_on_heap_resize(void); - /* Both the supplied setter and the getter */ - /* acquire the GC lock (to avoid data races). */ - -GC_API GC_ATTR_DEPRECATED int GC_find_leak; - /* Do not actually garbage collect, but simply */ - /* report inaccessible memory that was not */ - /* deallocated with GC_free. Initial value */ - /* is determined by FIND_LEAK macro. */ - /* The value should not typically be modified */ - /* after GC initialization (and, thus, it does */ - /* not use or need synchronization). */ -GC_API void GC_CALL GC_set_find_leak(int); -GC_API int GC_CALL GC_get_find_leak(void); - -GC_API GC_ATTR_DEPRECATED int GC_all_interior_pointers; - /* Arrange for pointers to object interiors to */ - /* be recognized as valid. Typically should */ - /* not be changed after GC initialization (in */ - /* case of calling it after the GC is */ - /* initialized, the setter acquires the GC lock */ - /* (to avoid data races). The initial value */ - /* depends on whether the GC is built with */ - /* ALL_INTERIOR_POINTERS macro defined or not. */ - /* Unless DONT_ADD_BYTE_AT_END is defined, this */ - /* also affects whether sizes are increased by */ - /* at least a byte to allow "off the end" */ - /* pointer recognition. Must be only 0 or 1. */ -GC_API void GC_CALL GC_set_all_interior_pointers(int); -GC_API int GC_CALL GC_get_all_interior_pointers(void); - -GC_API GC_ATTR_DEPRECATED int GC_finalize_on_demand; - /* If nonzero, finalizers will only be run in */ - /* response to an explicit GC_invoke_finalizers */ - /* call. The default is determined by whether */ - /* the FINALIZE_ON_DEMAND macro is defined */ - /* when the collector is built. */ - /* The setter and getter are unsynchronized. */ -GC_API void GC_CALL GC_set_finalize_on_demand(int); -GC_API int GC_CALL GC_get_finalize_on_demand(void); - -GC_API GC_ATTR_DEPRECATED int GC_java_finalization; - /* Mark objects reachable from finalizable */ - /* objects in a separate post-pass. This makes */ - /* it a bit safer to use non-topologically- */ - /* ordered finalization. Default value is */ - /* determined by JAVA_FINALIZATION macro. */ - /* Enables register_finalizer_unreachable to */ - /* work correctly. */ - /* The setter and getter are unsynchronized. */ -GC_API void GC_CALL GC_set_java_finalization(int); -GC_API int GC_CALL GC_get_java_finalization(void); - -typedef void (GC_CALLBACK * GC_finalizer_notifier_proc)(void); -GC_API GC_ATTR_DEPRECATED GC_finalizer_notifier_proc GC_finalizer_notifier; - /* Invoked by the collector when there are */ - /* objects to be finalized. Invoked at most */ - /* once per GC cycle. Never invoked unless */ - /* GC_finalize_on_demand is set. */ - /* Typically this will notify a finalization */ - /* thread, which will call GC_invoke_finalizers */ - /* in response. May be 0 (means no notifier). */ - /* Both the supplied setter and the getter */ - /* acquire the GC lock (to avoid data races). */ -GC_API void GC_CALL GC_set_finalizer_notifier(GC_finalizer_notifier_proc); -GC_API GC_finalizer_notifier_proc GC_CALL GC_get_finalizer_notifier(void); - -GC_API -# ifndef GC_DONT_GC - GC_ATTR_DEPRECATED -# endif - int GC_dont_gc; /* != 0 ==> Don't collect. In versions 6.2a1+, */ - /* this overrides explicit GC_gcollect() calls. */ - /* Used as a counter, so that nested enabling */ - /* and disabling work correctly. Should */ - /* normally be updated with GC_enable() and */ - /* GC_disable() calls. Direct assignment to */ - /* GC_dont_gc is deprecated. To check whether */ - /* GC is disabled, GC_is_disabled() is */ - /* preferred for new code. */ - -GC_API GC_ATTR_DEPRECATED int GC_dont_expand; - /* Do not expand the heap unless explicitly */ - /* requested or forced to. The setter and */ - /* getter are unsynchronized. */ -GC_API void GC_CALL GC_set_dont_expand(int); -GC_API int GC_CALL GC_get_dont_expand(void); - -GC_API GC_ATTR_DEPRECATED int GC_use_entire_heap; - /* Causes the non-incremental collector to use the */ - /* entire heap before collecting. This was the only */ - /* option for GC versions < 5.0. This sometimes */ - /* results in more large block fragmentation, since */ - /* very large blocks will tend to get broken up */ - /* during each GC cycle. It is likely to result in a */ - /* larger working set, but lower collection */ - /* frequencies, and hence fewer instructions executed */ - /* in the collector. */ - -GC_API GC_ATTR_DEPRECATED int GC_full_freq; - /* Number of partial collections between */ - /* full collections. Matters only if */ - /* GC_incremental is set. */ - /* Full collections are also triggered if */ - /* the collector detects a substantial */ - /* increase in the number of in-use heap */ - /* blocks. Values in the tens are now */ - /* perfectly reasonable, unlike for */ - /* earlier GC versions. */ - /* The setter and getter are unsynchronized, so */ - /* GC_call_with_alloc_lock() is required to */ - /* avoid data races (if the value is modified */ - /* after the GC is put to multi-threaded mode). */ -GC_API void GC_CALL GC_set_full_freq(int); -GC_API int GC_CALL GC_get_full_freq(void); - -GC_API GC_ATTR_DEPRECATED GC_word GC_non_gc_bytes; - /* Bytes not considered candidates for */ - /* collection. Used only to control scheduling */ - /* of collections. Updated by */ - /* GC_malloc_uncollectable and GC_free. */ - /* Wizards only. */ - /* The setter and getter are unsynchronized, so */ - /* GC_call_with_alloc_lock() is required to */ - /* avoid data races (if the value is modified */ - /* after the GC is put to multi-threaded mode). */ -GC_API void GC_CALL GC_set_non_gc_bytes(GC_word); -GC_API GC_word GC_CALL GC_get_non_gc_bytes(void); - -GC_API GC_ATTR_DEPRECATED int GC_no_dls; - /* Don't register dynamic library data segments. */ - /* Wizards only. Should be used only if the */ - /* application explicitly registers all roots. */ - /* (In some environments like Microsoft Windows */ - /* and Apple's Darwin, this may also prevent */ - /* registration of the main data segment as part */ - /* of the root set.) */ - /* The setter and getter are unsynchronized. */ -GC_API void GC_CALL GC_set_no_dls(int); -GC_API int GC_CALL GC_get_no_dls(void); - -GC_API GC_ATTR_DEPRECATED GC_word GC_free_space_divisor; - /* We try to make sure that we allocate at */ - /* least N/GC_free_space_divisor bytes between */ - /* collections, where N is twice the number */ - /* of traced bytes, plus the number of untraced */ - /* bytes (bytes in "atomic" objects), plus */ - /* a rough estimate of the root set size. */ - /* N approximates GC tracing work per GC. */ - /* Initially, GC_free_space_divisor = 3. */ - /* Increasing its value will use less space */ - /* but more collection time. Decreasing it */ - /* will appreciably decrease collection time */ - /* at the expense of space. */ - /* The setter and getter are unsynchronized, so */ - /* GC_call_with_alloc_lock() is required to */ - /* avoid data races (if the value is modified */ - /* after the GC is put to multi-threaded mode). */ -GC_API void GC_CALL GC_set_free_space_divisor(GC_word); -GC_API GC_word GC_CALL GC_get_free_space_divisor(void); - -GC_API GC_ATTR_DEPRECATED GC_word GC_max_retries; - /* The maximum number of GCs attempted before */ - /* reporting out of memory after heap */ - /* expansion fails. Initially 0. */ - /* The setter and getter are unsynchronized, so */ - /* GC_call_with_alloc_lock() is required to */ - /* avoid data races (if the value is modified */ - /* after the GC is put to multi-threaded mode). */ -GC_API void GC_CALL GC_set_max_retries(GC_word); -GC_API GC_word GC_CALL GC_get_max_retries(void); - - -GC_API GC_ATTR_DEPRECATED char *GC_stackbottom; - /* Cool end of user stack. */ - /* May be set in the client prior to */ - /* calling any GC_ routines. This */ - /* avoids some overhead, and */ - /* potentially some signals that can */ - /* confuse debuggers. Otherwise the */ - /* collector attempts to set it */ - /* automatically. */ - /* For multi-threaded code, this is the */ - /* cold end of the stack for the */ - /* primordial thread. Portable clients */ - /* should use GC_get_stack_base(), */ - /* GC_call_with_gc_active() and */ - /* GC_register_my_thread() instead. */ - -GC_API GC_ATTR_DEPRECATED int GC_dont_precollect; - /* Do not collect as part of GC */ - /* initialization. Should be set only */ - /* if the client wants a chance to */ - /* manually initialize the root set */ - /* before the first collection. */ - /* Interferes with blacklisting. */ - /* Wizards only. The setter and getter */ - /* are unsynchronized (and no external */ - /* locking is needed since the value is */ - /* accessed at GC initialization only). */ -GC_API void GC_CALL GC_set_dont_precollect(int); -GC_API int GC_CALL GC_get_dont_precollect(void); - -GC_API GC_ATTR_DEPRECATED unsigned long GC_time_limit; - /* If incremental collection is enabled, */ - /* We try to terminate collections */ - /* after this many milliseconds. Not a */ - /* hard time bound. Setting this to */ - /* GC_TIME_UNLIMITED will essentially */ - /* disable incremental collection while */ - /* leaving generational collection */ - /* enabled. */ -#define GC_TIME_UNLIMITED 999999 - /* Setting GC_time_limit to this value */ - /* will disable the "pause time exceeded"*/ - /* tests. */ - /* The setter and getter are unsynchronized, so */ - /* GC_call_with_alloc_lock() is required to */ - /* avoid data races (if the value is modified */ - /* after the GC is put to multi-threaded mode). */ -GC_API void GC_CALL GC_set_time_limit(unsigned long); -GC_API unsigned long GC_CALL GC_get_time_limit(void); - -/* Public procedures */ - -/* Set whether the GC will allocate executable memory pages or not. */ -/* A non-zero argument instructs the collector to allocate memory with */ -/* the executable flag on. Must be called before the collector is */ -/* initialized. May have no effect on some platforms. The default */ -/* value is controlled by NO_EXECUTE_PERMISSION macro (if present then */ -/* the flag is off). Portable clients should have */ -/* GC_set_pages_executable(1) call (before GC_INIT) provided they are */ -/* going to execute code on any of the GC-allocated memory objects. */ -GC_API void GC_CALL GC_set_pages_executable(int); - -/* Returns non-zero value if the GC is set to the allocate-executable */ -/* mode. The mode could be changed by GC_set_pages_executable (before */ -/* GC_INIT) unless the former has no effect on the platform. Does not */ -/* use or need synchronization (i.e. acquiring the allocator lock). */ -GC_API int GC_CALL GC_get_pages_executable(void); - -/* Overrides the default handle-fork mode. Non-zero value means GC */ -/* should install proper pthread_atfork handlers. Has effect only if */ -/* called before GC_INIT. Clients should invoke GC_set_handle_fork */ -/* with non-zero argument if going to use fork with GC functions called */ -/* in the forked child. (Note that such client and atfork handlers */ -/* activities are not fully POSIX-compliant.) GC_set_handle_fork */ -/* instructs GC_init to setup GC fork handlers using pthread_atfork, */ -/* the latter might fail (or, even, absent on some targets) causing */ -/* abort at GC initialization. Starting from 7.3alpha3, problems with */ -/* missing (or failed) pthread_atfork() could be avoided by invocation */ -/* of GC_set_handle_fork(-1) at application start-up and surrounding */ -/* each fork() with the relevant GC_atfork_prepare/parent/child calls. */ -GC_API void GC_CALL GC_set_handle_fork(int); - -/* Routines to handle POSIX fork() manually (no-op if handled */ -/* automatically). GC_atfork_prepare should be called immediately */ -/* before fork(); GC_atfork_parent should be invoked just after fork in */ -/* the branch that corresponds to parent process (i.e., fork result is */ -/* non-zero); GC_atfork_child is to be called immediately in the child */ -/* branch (i.e., fork result is 0). Note that GC_atfork_child() call */ -/* should, of course, precede GC_start_mark_threads call (if any). */ -GC_API void GC_CALL GC_atfork_prepare(void); -GC_API void GC_CALL GC_atfork_parent(void); -GC_API void GC_CALL GC_atfork_child(void); - -/* Initialize the collector. Portable clients should call GC_INIT() */ -/* from the main program instead. */ -GC_API void GC_CALL GC_init(void); - -/* General purpose allocation routines, with roughly malloc calling */ -/* conv. The atomic versions promise that no relevant pointers are */ -/* contained in the object. The non-atomic versions guarantee that the */ -/* new object is cleared. GC_malloc_stubborn promises that no changes */ -/* to the object will occur after GC_end_stubborn_change has been */ -/* called on the result of GC_malloc_stubborn. GC_malloc_uncollectable */ -/* allocates an object that is scanned for pointers to collectible */ -/* objects, but is not itself collectible. The object is scanned even */ -/* if it does not appear to be reachable. GC_malloc_uncollectable and */ -/* GC_free called on the resulting object implicitly update */ -/* GC_non_gc_bytes appropriately. */ -/* Note that the GC_malloc_stubborn support doesn't really exist */ -/* anymore. MANUAL_VDB provides comparable functionality. */ -GC_API GC_ATTR_MALLOC GC_ATTR_ALLOC_SIZE(1) void * GC_CALL - GC_malloc(size_t /* size_in_bytes */); -GC_API GC_ATTR_MALLOC GC_ATTR_ALLOC_SIZE(1) void * GC_CALL - GC_malloc_atomic(size_t /* size_in_bytes */); -GC_API GC_ATTR_MALLOC char * GC_CALL GC_strdup(const char *); -GC_API GC_ATTR_MALLOC char * GC_CALL - GC_strndup(const char *, size_t) GC_ATTR_NONNULL(1); -GC_API GC_ATTR_MALLOC GC_ATTR_ALLOC_SIZE(1) void * GC_CALL - GC_malloc_uncollectable(size_t /* size_in_bytes */); -GC_API GC_ATTR_MALLOC GC_ATTR_ALLOC_SIZE(1) void * GC_CALL - GC_malloc_stubborn(size_t /* size_in_bytes */); - -/* GC_memalign() is not well tested. */ -GC_API GC_ATTR_MALLOC GC_ATTR_ALLOC_SIZE(2) void * GC_CALL - GC_memalign(size_t /* align */, size_t /* lb */); -GC_API int GC_CALL GC_posix_memalign(void ** /* memptr */, size_t /* align */, - size_t /* lb */) GC_ATTR_NONNULL(1); - -/* Explicitly deallocate an object. Dangerous if used incorrectly. */ -/* Requires a pointer to the base of an object. */ -/* If the argument is stubborn, it should not be changeable when freed. */ -/* An object should not be enabled for finalization (and it should not */ -/* contain registered disappearing links of any kind) when it is */ -/* explicitly deallocated. */ -/* GC_free(0) is a no-op, as required by ANSI C for free. */ -GC_API void GC_CALL GC_free(void *); - -/* Stubborn objects may be changed only if the collector is explicitly */ -/* informed. The collector is implicitly informed of coming change */ -/* when such an object is first allocated. The following routines */ -/* inform the collector that an object will no longer be changed, or */ -/* that it will once again be changed. Only non-NULL pointer stores */ -/* into the object are considered to be changes. The argument to */ -/* GC_end_stubborn_change must be exactly the value returned by */ -/* GC_malloc_stubborn or passed to GC_change_stubborn. (In the second */ -/* case, it may be an interior pointer within 512 bytes of the */ -/* beginning of the objects.) There is a performance penalty for */ -/* allowing more than one stubborn object to be changed at once, but it */ -/* is acceptable to do so. The same applies to dropping stubborn */ -/* objects that are still changeable. */ -GC_API void GC_CALL GC_change_stubborn(const void *) GC_ATTR_NONNULL(1); -GC_API void GC_CALL GC_end_stubborn_change(const void *) GC_ATTR_NONNULL(1); - -/* Return a pointer to the base (lowest address) of an object given */ -/* a pointer to a location within the object. */ -/* I.e., map an interior pointer to the corresponding base pointer. */ -/* Note that with debugging allocation, this returns a pointer to the */ -/* actual base of the object, i.e. the debug information, not to */ -/* the base of the user object. */ -/* Return 0 if displaced_pointer doesn't point to within a valid */ -/* object. */ -/* Note that a deallocated object in the garbage collected heap */ -/* may be considered valid, even if it has been deallocated with */ -/* GC_free. */ -GC_API void * GC_CALL GC_base(void * /* displaced_pointer */); - -/* Return non-zero (TRUE) if and only if the argument points to */ -/* somewhere in GC heap. Primary use is as a fast alternative to */ -/* GC_base to check whether the pointed object is allocated by GC */ -/* or not. It is assumed that the collector is already initialized. */ -GC_API int GC_CALL GC_is_heap_ptr(const void *); - -/* Given a pointer to the base of an object, return its size in bytes. */ -/* The returned size may be slightly larger than what was originally */ -/* requested. */ -GC_API size_t GC_CALL GC_size(const void * /* obj_addr */) GC_ATTR_NONNULL(1); - -/* For compatibility with C library. This is occasionally faster than */ -/* a malloc followed by a bcopy. But if you rely on that, either here */ -/* or with the standard C library, your code is broken. In my */ -/* opinion, it shouldn't have been invented, but now we're stuck. -HB */ -/* The resulting object has the same kind as the original. */ -/* If the argument is stubborn, the result will have changes enabled. */ -/* It is an error to have changes enabled for the original object. */ -/* Follows ANSI conventions for NULL old_object. */ -GC_API void * GC_CALL GC_realloc(void * /* old_object */, - size_t /* new_size_in_bytes */) - /* 'realloc' attr */ GC_ATTR_ALLOC_SIZE(2); - -/* Explicitly increase the heap size. */ -/* Returns 0 on failure, 1 on success. */ -GC_API int GC_CALL GC_expand_hp(size_t /* number_of_bytes */); - -/* Limit the heap size to n bytes. Useful when you're debugging, */ -/* especially on systems that don't handle running out of memory well. */ -/* n == 0 ==> unbounded. This is the default. This setter function is */ -/* unsynchronized (so it might require GC_call_with_alloc_lock to avoid */ -/* data races). */ -GC_API void GC_CALL GC_set_max_heap_size(GC_word /* n */); - -/* Inform the collector that a certain section of statically allocated */ -/* memory contains no pointers to garbage collected memory. Thus it */ -/* need not be scanned. This is sometimes important if the application */ -/* maps large read/write files into the address space, which could be */ -/* mistaken for dynamic library data segments on some systems. */ -/* Both section start and end are not needed to be pointer-aligned. */ -GC_API void GC_CALL GC_exclude_static_roots(void * /* low_address */, - void * /* high_address_plus_1 */); - -/* Clear the set of root segments. Wizards only. */ -GC_API void GC_CALL GC_clear_roots(void); - -/* Add a root segment. Wizards only. */ -/* Both segment start and end are not needed to be pointer-aligned. */ -/* low_address must not be greater than high_address_plus_1. */ -GC_API void GC_CALL GC_add_roots(void * /* low_address */, - void * /* high_address_plus_1 */); - -/* Remove a root segment. Wizards only. */ -/* May be unimplemented on some platforms. */ -GC_API void GC_CALL GC_remove_roots(void * /* low_address */, - void * /* high_address_plus_1 */); - -/* Add a displacement to the set of those considered valid by the */ -/* collector. GC_register_displacement(n) means that if p was returned */ -/* by GC_malloc, then (char *)p + n will be considered to be a valid */ -/* pointer to p. N must be small and less than the size of p. */ -/* (All pointers to the interior of objects from the stack are */ -/* considered valid in any case. This applies to heap objects and */ -/* static data.) */ -/* Preferably, this should be called before any other GC procedures. */ -/* Calling it later adds to the probability of excess memory */ -/* retention. */ -/* This is a no-op if the collector has recognition of */ -/* arbitrary interior pointers enabled, which is now the default. */ -GC_API void GC_CALL GC_register_displacement(size_t /* n */); - -/* The following version should be used if any debugging allocation is */ -/* being done. */ -GC_API void GC_CALL GC_debug_register_displacement(size_t /* n */); - -/* Explicitly trigger a full, world-stop collection. */ -GC_API void GC_CALL GC_gcollect(void); - -/* Same as above but ignores the default stop_func setting and tries to */ -/* unmap as much memory as possible (regardless of the corresponding */ -/* switch setting). The recommended usage: on receiving a system */ -/* low-memory event; before retrying a system call failed because of */ -/* the system is running out of resources. */ -GC_API void GC_CALL GC_gcollect_and_unmap(void); - -/* Trigger a full world-stopped collection. Abort the collection if */ -/* and when stop_func returns a nonzero value. Stop_func will be */ -/* called frequently, and should be reasonably fast. (stop_func is */ -/* called with the allocation lock held and the world might be stopped; */ -/* it's not allowed for stop_func to manipulate pointers to the garbage */ -/* collected heap or call most of GC functions.) This works even */ -/* if virtual dirty bits, and hence incremental collection is not */ -/* available for this architecture. Collections can be aborted faster */ -/* than normal pause times for incremental collection. However, */ -/* aborted collections do no useful work; the next collection needs */ -/* to start from the beginning. stop_func must not be 0. */ -/* GC_try_to_collect() returns 0 if the collection was aborted (or the */ -/* collections are disabled), 1 if it succeeded. */ -typedef int (GC_CALLBACK * GC_stop_func)(void); -GC_API int GC_CALL GC_try_to_collect(GC_stop_func /* stop_func */) - GC_ATTR_NONNULL(1); - -/* Set and get the default stop_func. The default stop_func is used by */ -/* GC_gcollect() and by implicitly trigged collections (except for the */ -/* case when handling out of memory). Must not be 0. */ -/* Both the setter and getter acquire the GC lock to avoid data races. */ -GC_API void GC_CALL GC_set_stop_func(GC_stop_func /* stop_func */) - GC_ATTR_NONNULL(1); -GC_API GC_stop_func GC_CALL GC_get_stop_func(void); - -/* Return the number of bytes in the heap. Excludes collector private */ -/* data structures. Excludes the unmapped memory (returned to the OS). */ -/* Includes empty blocks and fragmentation loss. Includes some pages */ -/* that were allocated but never written. */ -/* This is an unsynchronized getter, so it should be called typically */ -/* with the GC lock held to avoid data races on multiprocessors (the */ -/* alternative is to use GC_get_heap_usage_safe or GC_get_prof_stats */ -/* API calls instead). */ -/* This getter remains lock-free (unsynchronized) for compatibility */ -/* reason since some existing clients call it from a GC callback */ -/* holding the allocator lock. (This API function and the following */ -/* four ones bellow were made thread-safe in GC v7.2alpha1 and */ -/* reverted back in v7.2alpha7 for the reason described.) */ -GC_API size_t GC_CALL GC_get_heap_size(void); - -/* Return a lower bound on the number of free bytes in the heap */ -/* (excluding the unmapped memory space). This is an unsynchronized */ -/* getter (see GC_get_heap_size comment regarding thread-safety). */ -GC_API size_t GC_CALL GC_get_free_bytes(void); - -/* Return the size (in bytes) of the unmapped memory (which is returned */ -/* to the OS but could be remapped back by the collector later unless */ -/* the OS runs out of system/virtual memory). This is an unsynchronized */ -/* getter (see GC_get_heap_size comment regarding thread-safety). */ -GC_API size_t GC_CALL GC_get_unmapped_bytes(void); - -/* Return the number of bytes allocated since the last collection. */ -/* This is an unsynchronized getter (see GC_get_heap_size comment */ -/* regarding thread-safety). */ -GC_API size_t GC_CALL GC_get_bytes_since_gc(void); - -/* Return the total number of bytes allocated in this process. */ -/* Never decreases, except due to wrapping. This is an unsynchronized */ -/* getter (see GC_get_heap_size comment regarding thread-safety). */ -GC_API size_t GC_CALL GC_get_total_bytes(void); - -/* Return the heap usage information. This is a thread-safe (atomic) */ -/* alternative for the five above getters. (This function acquires */ -/* the allocator lock thus preventing data racing and returning the */ -/* consistent result.) Passing NULL pointer is allowed for any */ -/* argument. Returned (filled in) values are of word type. */ -/* (This API function was introduced in GC v7.2alpha7 at the same time */ -/* when GC_get_heap_size and the friends were made lock-free again.) */ -GC_API void GC_CALL GC_get_heap_usage_safe(GC_word * /* pheap_size */, - GC_word * /* pfree_bytes */, - GC_word * /* punmapped_bytes */, - GC_word * /* pbytes_since_gc */, - GC_word * /* ptotal_bytes */); - -/* Structure used to query GC statistics (profiling information). */ -/* More fields could be added in the future. To preserve compatibility */ -/* new fields should be added only to the end, and no deprecated fields */ -/* should be removed from. */ -struct GC_prof_stats_s { - GC_word heapsize_full; - /* Heap size in bytes (including the area unmapped to OS). */ - /* Same as GC_get_heap_size() + GC_get_unmapped_bytes(). */ - GC_word free_bytes_full; - /* Total bytes contained in free and unmapped blocks. */ - /* Same as GC_get_free_bytes() + GC_get_unmapped_bytes(). */ - GC_word unmapped_bytes; - /* Amount of memory unmapped to OS. Same as the value */ - /* returned by GC_get_unmapped_bytes(). */ - GC_word bytes_allocd_since_gc; - /* Number of bytes allocated since the recent collection. */ - /* Same as returned by GC_get_bytes_since_gc(). */ - GC_word allocd_bytes_before_gc; - /* Number of bytes allocated before the recent garbage */ - /* collection. The value may wrap. Same as the result of */ - /* GC_get_total_bytes() - GC_get_bytes_since_gc(). */ - GC_word non_gc_bytes; - /* Number of bytes not considered candidates for garbage */ - /* collection. Same as returned by GC_get_non_gc_bytes(). */ - GC_word gc_no; - /* Garbage collection cycle number. The value may wrap */ - /* (and could be -1). Same as returned by GC_get_gc_no(). */ - GC_word markers_m1; - /* Number of marker threads (excluding the initiating one). */ - /* Same as returned by GC_get_parallel (or 0 if the */ - /* collector is single-threaded). */ - GC_word bytes_reclaimed_since_gc; - /* Approximate number of reclaimed bytes after recent GC. */ - GC_word reclaimed_bytes_before_gc; - /* Approximate number of bytes reclaimed before the recent */ - /* garbage collection. The value may wrap. */ -}; - -/* Atomically get GC statistics (various global counters). Clients */ -/* should pass the size of the buffer (of GC_prof_stats_s type) to fill */ -/* in the values - this is for interoperability between different GC */ -/* versions, an old client could have fewer fields, and vice versa, */ -/* client could use newer gc.h (with more entries declared in the */ -/* structure) than that of the linked libgc binary; in the latter case, */ -/* unsupported (unknown) fields are filled in with -1. Return the size */ -/* (in bytes) of the filled in part of the structure (excluding all */ -/* unknown fields, if any). */ -GC_API size_t GC_CALL GC_get_prof_stats(struct GC_prof_stats_s *, - size_t /* stats_sz */); -#ifdef GC_THREADS - /* Same as above but unsynchronized (i.e., not holding the allocation */ - /* lock). Clients should call it using GC_call_with_alloc_lock to */ - /* avoid data races on multiprocessors. */ - GC_API size_t GC_CALL GC_get_prof_stats_unsafe(struct GC_prof_stats_s *, - size_t /* stats_sz */); -#endif - -/* Disable garbage collection. Even GC_gcollect calls will be */ -/* ineffective. */ -GC_API void GC_CALL GC_disable(void); - -/* Return non-zero (TRUE) if and only if garbage collection is disabled */ -/* (i.e., GC_dont_gc value is non-zero). Does not acquire the lock. */ -GC_API int GC_CALL GC_is_disabled(void); - -/* Try to re-enable garbage collection. GC_disable() and GC_enable() */ -/* calls nest. Garbage collection is enabled if the number of calls to */ -/* both functions is equal. */ -GC_API void GC_CALL GC_enable(void); - -/* Enable incremental/generational collection. Not advisable unless */ -/* dirty bits are available or most heap objects are pointer-free */ -/* (atomic) or immutable. Don't use in leak finding mode. Ignored if */ -/* GC_dont_gc is non-zero. Only the generational piece of this is */ -/* functional if GC_parallel is non-zero or if GC_time_limit is */ -/* GC_TIME_UNLIMITED. Causes thread-local variant of GC_gcj_malloc() */ -/* to revert to locked allocation. Must be called before any such */ -/* GC_gcj_malloc() calls. For best performance, should be called as */ -/* early as possible. On some platforms, calling it later may have */ -/* adverse effects. */ -/* Safe to call before GC_INIT(). Includes a GC_init() call. */ -GC_API void GC_CALL GC_enable_incremental(void); - -/* Does incremental mode write-protect pages? Returns zero or */ -/* more of the following, or'ed together: */ -#define GC_PROTECTS_POINTER_HEAP 1 /* May protect non-atomic objs. */ -#define GC_PROTECTS_PTRFREE_HEAP 2 -#define GC_PROTECTS_STATIC_DATA 4 /* Currently never. */ -#define GC_PROTECTS_STACK 8 /* Probably impractical. */ - -#define GC_PROTECTS_NONE 0 -/* The collector is assumed to be initialized before this call. */ -GC_API int GC_CALL GC_incremental_protection_needs(void); - -/* Perform some garbage collection work, if appropriate. */ -/* Return 0 if there is no more work to be done. */ -/* Typically performs an amount of work corresponding roughly */ -/* to marking from one page. May do more work if further */ -/* progress requires it, e.g. if incremental collection is */ -/* disabled. It is reasonable to call this in a wait loop */ -/* until it returns 0. */ -GC_API int GC_CALL GC_collect_a_little(void); - -/* Allocate an object of size lb bytes. The client guarantees that */ -/* as long as the object is live, it will be referenced by a pointer */ -/* that points to somewhere within the first 256 bytes of the object. */ -/* (This should normally be declared volatile to prevent the compiler */ -/* from invalidating this assertion.) This routine is only useful */ -/* if a large array is being allocated. It reduces the chance of */ -/* accidentally retaining such an array as a result of scanning an */ -/* integer that happens to be an address inside the array. (Actually, */ -/* it reduces the chance of the allocator not finding space for such */ -/* an array, since it will try hard to avoid introducing such a false */ -/* reference.) On a SunOS 4.X or MS Windows system this is recommended */ -/* for arrays likely to be larger than 100K or so. For other systems, */ -/* or if the collector is not configured to recognize all interior */ -/* pointers, the threshold is normally much higher. */ -GC_API GC_ATTR_MALLOC GC_ATTR_ALLOC_SIZE(1) void * GC_CALL - GC_malloc_ignore_off_page(size_t /* lb */); -GC_API GC_ATTR_MALLOC GC_ATTR_ALLOC_SIZE(1) void * GC_CALL - GC_malloc_atomic_ignore_off_page(size_t /* lb */); - -#ifdef GC_ADD_CALLER -# define GC_EXTRAS GC_RETURN_ADDR, __FILE__, __LINE__ -# define GC_EXTRA_PARAMS GC_word ra, const char * s, int i -#else -# define GC_EXTRAS __FILE__, __LINE__ -# define GC_EXTRA_PARAMS const char * s, int i -#endif - -/* The following is only defined if the library has been suitably */ -/* compiled: */ -GC_API GC_ATTR_MALLOC GC_ATTR_ALLOC_SIZE(1) void * GC_CALL - GC_malloc_atomic_uncollectable(size_t /* size_in_bytes */); -GC_API GC_ATTR_MALLOC GC_ATTR_ALLOC_SIZE(1) void * GC_CALL - GC_debug_malloc_atomic_uncollectable(size_t, GC_EXTRA_PARAMS); - -/* Debugging (annotated) allocation. GC_gcollect will check */ -/* objects allocated in this way for overwrites, etc. */ -GC_API GC_ATTR_MALLOC GC_ATTR_ALLOC_SIZE(1) void * GC_CALL - GC_debug_malloc(size_t /* size_in_bytes */, GC_EXTRA_PARAMS); -GC_API GC_ATTR_MALLOC GC_ATTR_ALLOC_SIZE(1) void * GC_CALL - GC_debug_malloc_atomic(size_t /* size_in_bytes */, GC_EXTRA_PARAMS); -GC_API GC_ATTR_MALLOC char * GC_CALL - GC_debug_strdup(const char *, GC_EXTRA_PARAMS); -GC_API GC_ATTR_MALLOC char * GC_CALL - GC_debug_strndup(const char *, size_t, GC_EXTRA_PARAMS) - GC_ATTR_NONNULL(1); -GC_API GC_ATTR_MALLOC GC_ATTR_ALLOC_SIZE(1) void * GC_CALL - GC_debug_malloc_uncollectable(size_t /* size_in_bytes */, - GC_EXTRA_PARAMS); -GC_API GC_ATTR_MALLOC GC_ATTR_ALLOC_SIZE(1) void * GC_CALL - GC_debug_malloc_stubborn(size_t /* size_in_bytes */, GC_EXTRA_PARAMS); -GC_API GC_ATTR_MALLOC GC_ATTR_ALLOC_SIZE(1) void * GC_CALL - GC_debug_malloc_ignore_off_page(size_t /* size_in_bytes */, - GC_EXTRA_PARAMS); -GC_API GC_ATTR_MALLOC GC_ATTR_ALLOC_SIZE(1) void * GC_CALL - GC_debug_malloc_atomic_ignore_off_page(size_t /* size_in_bytes */, - GC_EXTRA_PARAMS); -GC_API void GC_CALL GC_debug_free(void *); -GC_API void * GC_CALL GC_debug_realloc(void * /* old_object */, - size_t /* new_size_in_bytes */, GC_EXTRA_PARAMS) - /* 'realloc' attr */ GC_ATTR_ALLOC_SIZE(2); -GC_API void GC_CALL GC_debug_change_stubborn(const void *) GC_ATTR_NONNULL(1); -GC_API void GC_CALL GC_debug_end_stubborn_change(const void *) - GC_ATTR_NONNULL(1); - -/* Routines that allocate objects with debug information (like the */ -/* above), but just fill in dummy file and line number information. */ -/* Thus they can serve as drop-in malloc/realloc replacements. This */ -/* can be useful for two reasons: */ -/* 1) It allows the collector to be built with DBG_HDRS_ALL defined */ -/* even if some allocation calls come from 3rd party libraries */ -/* that can't be recompiled. */ -/* 2) On some platforms, the file and line information is redundant, */ -/* since it can be reconstructed from a stack trace. On such */ -/* platforms it may be more convenient not to recompile, e.g. for */ -/* leak detection. This can be accomplished by instructing the */ -/* linker to replace malloc/realloc with these. */ -GC_API GC_ATTR_MALLOC GC_ATTR_ALLOC_SIZE(1) void * GC_CALL - GC_debug_malloc_replacement(size_t /* size_in_bytes */); -GC_API /* 'realloc' attr */ GC_ATTR_ALLOC_SIZE(2) void * GC_CALL - GC_debug_realloc_replacement(void * /* object_addr */, - size_t /* size_in_bytes */); - -#ifdef GC_DEBUG_REPLACEMENT -# define GC_MALLOC(sz) GC_debug_malloc_replacement(sz) -# define GC_REALLOC(old, sz) GC_debug_realloc_replacement(old, sz) -#elif defined(GC_DEBUG) -# define GC_MALLOC(sz) GC_debug_malloc(sz, GC_EXTRAS) -# define GC_REALLOC(old, sz) GC_debug_realloc(old, sz, GC_EXTRAS) -#else -# define GC_MALLOC(sz) GC_malloc(sz) -# define GC_REALLOC(old, sz) GC_realloc(old, sz) -#endif /* !GC_DEBUG_REPLACEMENT && !GC_DEBUG */ - -#ifdef GC_DEBUG -# define GC_MALLOC_ATOMIC(sz) GC_debug_malloc_atomic(sz, GC_EXTRAS) -# define GC_STRDUP(s) GC_debug_strdup(s, GC_EXTRAS) -# define GC_STRNDUP(s, sz) GC_debug_strndup(s, sz, GC_EXTRAS) -# define GC_MALLOC_ATOMIC_UNCOLLECTABLE(sz) \ - GC_debug_malloc_atomic_uncollectable(sz, GC_EXTRAS) -# define GC_MALLOC_UNCOLLECTABLE(sz) \ - GC_debug_malloc_uncollectable(sz, GC_EXTRAS) -# define GC_MALLOC_IGNORE_OFF_PAGE(sz) \ - GC_debug_malloc_ignore_off_page(sz, GC_EXTRAS) -# define GC_MALLOC_ATOMIC_IGNORE_OFF_PAGE(sz) \ - GC_debug_malloc_atomic_ignore_off_page(sz, GC_EXTRAS) -# define GC_FREE(p) GC_debug_free(p) -# define GC_REGISTER_FINALIZER(p, f, d, of, od) \ - GC_debug_register_finalizer(p, f, d, of, od) -# define GC_REGISTER_FINALIZER_IGNORE_SELF(p, f, d, of, od) \ - GC_debug_register_finalizer_ignore_self(p, f, d, of, od) -# define GC_REGISTER_FINALIZER_NO_ORDER(p, f, d, of, od) \ - GC_debug_register_finalizer_no_order(p, f, d, of, od) -# define GC_REGISTER_FINALIZER_UNREACHABLE(p, f, d, of, od) \ - GC_debug_register_finalizer_unreachable(p, f, d, of, od) -# define GC_MALLOC_STUBBORN(sz) GC_debug_malloc_stubborn(sz, GC_EXTRAS) -# define GC_CHANGE_STUBBORN(p) GC_debug_change_stubborn(p) -# define GC_END_STUBBORN_CHANGE(p) GC_debug_end_stubborn_change(p) -# define GC_GENERAL_REGISTER_DISAPPEARING_LINK(link, obj) \ - GC_general_register_disappearing_link(link, \ - GC_base((/* no const */ void *)(obj))) -# define GC_REGISTER_LONG_LINK(link, obj) \ - GC_register_long_link(link, GC_base((/* no const */ void *)(obj))) -# define GC_REGISTER_DISPLACEMENT(n) GC_debug_register_displacement(n) -#else -# define GC_MALLOC_ATOMIC(sz) GC_malloc_atomic(sz) -# define GC_STRDUP(s) GC_strdup(s) -# define GC_STRNDUP(s, sz) GC_strndup(s, sz) -# define GC_MALLOC_ATOMIC_UNCOLLECTABLE(sz) GC_malloc_atomic_uncollectable(sz) -# define GC_MALLOC_UNCOLLECTABLE(sz) GC_malloc_uncollectable(sz) -# define GC_MALLOC_IGNORE_OFF_PAGE(sz) \ - GC_malloc_ignore_off_page(sz) -# define GC_MALLOC_ATOMIC_IGNORE_OFF_PAGE(sz) \ - GC_malloc_atomic_ignore_off_page(sz) -# define GC_FREE(p) GC_free(p) -# define GC_REGISTER_FINALIZER(p, f, d, of, od) \ - GC_register_finalizer(p, f, d, of, od) -# define GC_REGISTER_FINALIZER_IGNORE_SELF(p, f, d, of, od) \ - GC_register_finalizer_ignore_self(p, f, d, of, od) -# define GC_REGISTER_FINALIZER_NO_ORDER(p, f, d, of, od) \ - GC_register_finalizer_no_order(p, f, d, of, od) -# define GC_REGISTER_FINALIZER_UNREACHABLE(p, f, d, of, od) \ - GC_register_finalizer_unreachable(p, f, d, of, od) -# define GC_MALLOC_STUBBORN(sz) GC_malloc_stubborn(sz) -# define GC_CHANGE_STUBBORN(p) GC_change_stubborn(p) -# define GC_END_STUBBORN_CHANGE(p) GC_end_stubborn_change(p) -# define GC_GENERAL_REGISTER_DISAPPEARING_LINK(link, obj) \ - GC_general_register_disappearing_link(link, obj) -# define GC_REGISTER_LONG_LINK(link, obj) \ - GC_register_long_link(link, obj) -# define GC_REGISTER_DISPLACEMENT(n) GC_register_displacement(n) -#endif /* !GC_DEBUG */ - -/* The following are included because they are often convenient, and */ -/* reduce the chance for a misspecified size argument. But calls may */ -/* expand to something syntactically incorrect if t is a complicated */ -/* type expression. Note that, unlike C++ new operator, these ones */ -/* may return NULL (if out of memory). */ -#define GC_NEW(t) ((t*)GC_MALLOC(sizeof(t))) -#define GC_NEW_ATOMIC(t) ((t*)GC_MALLOC_ATOMIC(sizeof(t))) -#define GC_NEW_STUBBORN(t) ((t*)GC_MALLOC_STUBBORN(sizeof(t))) -#define GC_NEW_UNCOLLECTABLE(t) ((t*)GC_MALLOC_UNCOLLECTABLE(sizeof(t))) - -#ifdef GC_REQUIRE_WCSDUP - /* This might be unavailable on some targets (or not needed). */ - /* wchar_t should be defined in stddef.h */ - GC_API GC_ATTR_MALLOC wchar_t * GC_CALL - GC_wcsdup(const wchar_t *) GC_ATTR_NONNULL(1); - GC_API GC_ATTR_MALLOC wchar_t * GC_CALL - GC_debug_wcsdup(const wchar_t *, GC_EXTRA_PARAMS) GC_ATTR_NONNULL(1); -# ifdef GC_DEBUG -# define GC_WCSDUP(s) GC_debug_wcsdup(s, GC_EXTRAS) -# else -# define GC_WCSDUP(s) GC_wcsdup(s) -# endif -#endif /* GC_REQUIRE_WCSDUP */ - -/* Finalization. Some of these primitives are grossly unsafe. */ -/* The idea is to make them both cheap, and sufficient to build */ -/* a safer layer, closer to Modula-3, Java, or PCedar finalization. */ -/* The interface represents my conclusions from a long discussion */ -/* with Alan Demers, Dan Greene, Carl Hauser, Barry Hayes, */ -/* Christian Jacobi, and Russ Atkinson. It's not perfect, and */ -/* probably nobody else agrees with it. Hans-J. Boehm 3/13/92 */ -typedef void (GC_CALLBACK * GC_finalization_proc)(void * /* obj */, - void * /* client_data */); - -GC_API void GC_CALL GC_register_finalizer(void * /* obj */, - GC_finalization_proc /* fn */, void * /* cd */, - GC_finalization_proc * /* ofn */, void ** /* ocd */) - GC_ATTR_NONNULL(1); -GC_API void GC_CALL GC_debug_register_finalizer(void * /* obj */, - GC_finalization_proc /* fn */, void * /* cd */, - GC_finalization_proc * /* ofn */, void ** /* ocd */) - GC_ATTR_NONNULL(1); - /* When obj is no longer accessible, invoke */ - /* (*fn)(obj, cd). If a and b are inaccessible, and */ - /* a points to b (after disappearing links have been */ - /* made to disappear), then only a will be */ - /* finalized. (If this does not create any new */ - /* pointers to b, then b will be finalized after the */ - /* next collection.) Any finalizable object that */ - /* is reachable from itself by following one or more */ - /* pointers will not be finalized (or collected). */ - /* Thus cycles involving finalizable objects should */ - /* be avoided, or broken by disappearing links. */ - /* All but the last finalizer registered for an object */ - /* is ignored. */ - /* Finalization may be removed by passing 0 as fn. */ - /* Finalizers are implicitly unregistered when they are */ - /* enqueued for finalization (i.e. become ready to be */ - /* finalized). */ - /* The old finalizer and client data are stored in */ - /* *ofn and *ocd. (ofn and/or ocd may be NULL. */ - /* The allocation lock is held while *ofn and *ocd are */ - /* updated. In case of error (no memory to register */ - /* new finalizer), *ofn and *ocd remain unchanged.) */ - /* Fn is never invoked on an accessible object, */ - /* provided hidden pointers are converted to real */ - /* pointers only if the allocation lock is held, and */ - /* such conversions are not performed by finalization */ - /* routines. */ - /* If GC_register_finalizer is aborted as a result of */ - /* a signal, the object may be left with no */ - /* finalization, even if neither the old nor new */ - /* finalizer were NULL. */ - /* Obj should be the starting address of an object */ - /* allocated by GC_malloc or friends. Obj may also be */ - /* NULL or point to something outside GC heap (in this */ - /* case, fn is ignored, *ofn and *ocd are set to NULL). */ - /* Note that any garbage collectible object referenced */ - /* by cd will be considered accessible until the */ - /* finalizer is invoked. */ - -/* Another versions of the above follow. It ignores */ -/* self-cycles, i.e. pointers from a finalizable object to */ -/* itself. There is a stylistic argument that this is wrong, */ -/* but it's unavoidable for C++, since the compiler may */ -/* silently introduce these. It's also benign in that specific */ -/* case. And it helps if finalizable objects are split to */ -/* avoid cycles. */ -/* Note that cd will still be viewed as accessible, even if it */ -/* refers to the object itself. */ -GC_API void GC_CALL GC_register_finalizer_ignore_self(void * /* obj */, - GC_finalization_proc /* fn */, void * /* cd */, - GC_finalization_proc * /* ofn */, void ** /* ocd */) - GC_ATTR_NONNULL(1); -GC_API void GC_CALL GC_debug_register_finalizer_ignore_self(void * /* obj */, - GC_finalization_proc /* fn */, void * /* cd */, - GC_finalization_proc * /* ofn */, void ** /* ocd */) - GC_ATTR_NONNULL(1); - -/* Another version of the above. It ignores all cycles. */ -/* It should probably only be used by Java implementations. */ -/* Note that cd will still be viewed as accessible, even if it */ -/* refers to the object itself. */ -GC_API void GC_CALL GC_register_finalizer_no_order(void * /* obj */, - GC_finalization_proc /* fn */, void * /* cd */, - GC_finalization_proc * /* ofn */, void ** /* ocd */) - GC_ATTR_NONNULL(1); -GC_API void GC_CALL GC_debug_register_finalizer_no_order(void * /* obj */, - GC_finalization_proc /* fn */, void * /* cd */, - GC_finalization_proc * /* ofn */, void ** /* ocd */) - GC_ATTR_NONNULL(1); - -/* This is a special finalizer that is useful when an object's */ -/* finalizer must be run when the object is known to be no */ -/* longer reachable, not even from other finalizable objects. */ -/* It behaves like "normal" finalization, except that the */ -/* finalizer is not run while the object is reachable from */ -/* other objects specifying unordered finalization. */ -/* Effectively it allows an object referenced, possibly */ -/* indirectly, from an unordered finalizable object to override */ -/* the unordered finalization request. */ -/* This can be used in combination with finalizer_no_order so */ -/* as to release resources that must not be released while an */ -/* object can still be brought back to life by other */ -/* finalizers. */ -/* Only works if GC_java_finalization is set. Probably only */ -/* of interest when implementing a language that requires */ -/* unordered finalization (e.g. Java, C#). */ -GC_API void GC_CALL GC_register_finalizer_unreachable(void * /* obj */, - GC_finalization_proc /* fn */, void * /* cd */, - GC_finalization_proc * /* ofn */, void ** /* ocd */) - GC_ATTR_NONNULL(1); -GC_API void GC_CALL GC_debug_register_finalizer_unreachable(void * /* obj */, - GC_finalization_proc /* fn */, void * /* cd */, - GC_finalization_proc * /* ofn */, void ** /* ocd */) - GC_ATTR_NONNULL(1); - -#define GC_NO_MEMORY 2 /* Failure due to lack of memory. */ - -/* The following routine may be used to break cycles between */ -/* finalizable objects, thus causing cyclic finalizable */ -/* objects to be finalized in the correct order. Standard */ -/* use involves calling GC_register_disappearing_link(&p), */ -/* where p is a pointer that is not followed by finalization */ -/* code, and should not be considered in determining */ -/* finalization order. */ -GC_API int GC_CALL GC_register_disappearing_link(void ** /* link */) - GC_ATTR_NONNULL(1); - /* Link should point to a field of a heap allocated */ - /* object obj. *link will be cleared when obj is */ - /* found to be inaccessible. This happens BEFORE any */ - /* finalization code is invoked, and BEFORE any */ - /* decisions about finalization order are made. */ - /* This is useful in telling the finalizer that */ - /* some pointers are not essential for proper */ - /* finalization. This may avoid finalization cycles. */ - /* Note that obj may be resurrected by another */ - /* finalizer, and thus the clearing of *link may */ - /* be visible to non-finalization code. */ - /* There's an argument that an arbitrary action should */ - /* be allowed here, instead of just clearing a pointer. */ - /* But this causes problems if that action alters, or */ - /* examines connectivity. Returns GC_DUPLICATE if link */ - /* was already registered, GC_SUCCESS if registration */ - /* succeeded, GC_NO_MEMORY if it failed for lack of */ - /* memory, and GC_oom_fn did not handle the problem. */ - /* Only exists for backward compatibility. See below: */ - -GC_API int GC_CALL GC_general_register_disappearing_link(void ** /* link */, - const void * /* obj */) - GC_ATTR_NONNULL(1) GC_ATTR_NONNULL(2); - /* A slight generalization of the above. *link is */ - /* cleared when obj first becomes inaccessible. This */ - /* can be used to implement weak pointers easily and */ - /* safely. Typically link will point to a location */ - /* holding a disguised pointer to obj. (A pointer */ - /* inside an "atomic" object is effectively disguised.) */ - /* In this way, weak pointers are broken before any */ - /* object reachable from them gets finalized. */ - /* Each link may be registered only with one obj value, */ - /* i.e. all objects but the last one (link registered */ - /* with) are ignored. This was added after a long */ - /* email discussion with John Ellis. */ - /* link must be non-NULL (and be properly aligned). */ - /* obj must be a pointer to the first word of an object */ - /* allocated by GC_malloc or friends. A link */ - /* disappears when it is unregistered manually, or when */ - /* (*link) is cleared, or when the object containing */ - /* this link is garbage collected. It is unsafe to */ - /* explicitly deallocate the object containing link. */ - /* Explicit deallocation of obj may or may not cause */ - /* link to eventually be cleared. */ - /* This function can be used to implement certain types */ - /* of weak pointers. Note, however, this generally */ - /* requires that the allocation lock is held (see */ - /* GC_call_with_alloc_lock() below) when the disguised */ - /* pointer is accessed. Otherwise a strong pointer */ - /* could be recreated between the time the collector */ - /* decides to reclaim the object and the link is */ - /* cleared. Returns GC_SUCCESS if registration */ - /* succeeded (a new link is registered), GC_DUPLICATE */ - /* if link was already registered (with some object), */ - /* GC_NO_MEMORY if registration failed for lack of */ - /* memory (and GC_oom_fn did not handle the problem). */ - -GC_API int GC_CALL GC_move_disappearing_link(void ** /* link */, - void ** /* new_link */) - GC_ATTR_NONNULL(2); - /* Moves a link previously registered via */ - /* GC_general_register_disappearing_link (or */ - /* GC_register_disappearing_link). Does not change the */ - /* target object of the weak reference. Does not */ - /* change (*new_link) content. May be called with */ - /* new_link equal to link (to check whether link has */ - /* been registered). Returns GC_SUCCESS on success, */ - /* GC_DUPLICATE if there is already another */ - /* disappearing link at the new location (never */ - /* returned if new_link is equal to link), GC_NOT_FOUND */ - /* if no link is registered at the original location. */ - -GC_API int GC_CALL GC_unregister_disappearing_link(void ** /* link */); - /* Undoes a registration by either of the above two */ - /* routines. Returns 0 if link was not actually */ - /* registered (otherwise returns 1). */ - -GC_API int GC_CALL GC_register_long_link(void ** /* link */, - const void * /* obj */) - GC_ATTR_NONNULL(1) GC_ATTR_NONNULL(2); - /* Similar to GC_general_register_disappearing_link but */ - /* *link only gets cleared when obj becomes truly */ - /* inaccessible. An object becomes truly inaccessible */ - /* when it can no longer be resurrected from its */ - /* finalizer (e.g. by assigning itself to a pointer */ - /* traceable from root). This can be used to implement */ - /* long weak pointers easily and safely. */ - -GC_API int GC_CALL GC_move_long_link(void ** /* link */, - void ** /* new_link */) - GC_ATTR_NONNULL(2); - /* Similar to GC_move_disappearing_link but for a link */ - /* previously registered via GC_register_long_link. */ - -GC_API int GC_CALL GC_unregister_long_link(void ** /* link */); - /* Similar to GC_unregister_disappearing_link but for a */ - /* registration by either of the above two routines. */ - -/* Returns !=0 if GC_invoke_finalizers has something to do. */ -GC_API int GC_CALL GC_should_invoke_finalizers(void); - -GC_API int GC_CALL GC_invoke_finalizers(void); - /* Run finalizers for all objects that are ready to */ - /* be finalized. Return the number of finalizers */ - /* that were run. Normally this is also called */ - /* implicitly during some allocations. If */ - /* GC_finalize_on_demand is nonzero, it must be called */ - /* explicitly. */ - -/* Explicitly tell the collector that an object is reachable */ -/* at a particular program point. This prevents the argument */ -/* pointer from being optimized away, even it is otherwise no */ -/* longer needed. It should have no visible effect in the */ -/* absence of finalizers or disappearing links. But it may be */ -/* needed to prevent finalizers from running while the */ -/* associated external resource is still in use. */ -/* The function is sometimes called keep_alive in other */ -/* settings. */ -#if defined(__GNUC__) && !defined(__INTEL_COMPILER) -# define GC_reachable_here(ptr) \ - __asm__ __volatile__(" " : : "X"(ptr) : "memory") -#else - GC_API void GC_CALL GC_noop1(GC_word); -# define GC_reachable_here(ptr) GC_noop1((GC_word)(ptr)) -#endif - -/* GC_set_warn_proc can be used to redirect or filter warning messages. */ -/* p may not be a NULL pointer. msg is printf format string (arg must */ -/* match the format). Both the setter and the getter acquire the GC */ -/* lock (to avoid data races). */ -typedef void (GC_CALLBACK * GC_warn_proc)(char * /* msg */, - GC_word /* arg */); -GC_API void GC_CALL GC_set_warn_proc(GC_warn_proc /* p */) GC_ATTR_NONNULL(1); -/* GC_get_warn_proc returns the current warn_proc. */ -GC_API GC_warn_proc GC_CALL GC_get_warn_proc(void); - -/* GC_ignore_warn_proc may be used as an argument for GC_set_warn_proc */ -/* to suppress all warnings (unless statistics printing is turned on). */ -GC_API void GC_CALLBACK GC_ignore_warn_proc(char *, GC_word); - -/* Change file descriptor of GC log. Unavailable on some targets. */ -GC_API void GC_CALL GC_set_log_fd(int); - -/* abort_func is invoked on GC fatal aborts (just before OS-dependent */ -/* abort or exit(1) is called). Must be non-NULL. The default one */ -/* outputs msg to stderr provided msg is non-NULL. msg is NULL if */ -/* invoked before exit(1) otherwise msg is non-NULL (i.e., if invoked */ -/* before abort). Both the setter and getter acquire the GC lock. */ -/* Both the setter and getter are defined only if the library has been */ -/* compiled without SMALL_CONFIG. */ -typedef void (GC_CALLBACK * GC_abort_func)(const char * /* msg */); -GC_API void GC_CALL GC_set_abort_func(GC_abort_func) GC_ATTR_NONNULL(1); -GC_API GC_abort_func GC_CALL GC_get_abort_func(void); - -/* The following is intended to be used by a higher level */ -/* (e.g. Java-like) finalization facility. It is expected */ -/* that finalization code will arrange for hidden pointers to */ -/* disappear. Otherwise objects can be accessed after they */ -/* have been collected. */ -/* Note that putting pointers in atomic objects or in */ -/* non-pointer slots of "typed" objects is equivalent to */ -/* disguising them in this way, and may have other advantages. */ -typedef GC_word GC_hidden_pointer; -#define GC_HIDE_POINTER(p) (~(GC_hidden_pointer)(p)) -/* Converting a hidden pointer to a real pointer requires verifying */ -/* that the object still exists. This involves acquiring the */ -/* allocator lock to avoid a race with the collector. */ -#define GC_REVEAL_POINTER(p) ((void *)GC_HIDE_POINTER(p)) - -#if defined(I_HIDE_POINTERS) || defined(GC_I_HIDE_POINTERS) - /* This exists only for compatibility (the GC-prefixed symbols are */ - /* preferred for new code). */ -# define HIDE_POINTER(p) GC_HIDE_POINTER(p) -# define REVEAL_POINTER(p) GC_REVEAL_POINTER(p) -#endif - -typedef void * (GC_CALLBACK * GC_fn_type)(void * /* client_data */); -GC_API void * GC_CALL GC_call_with_alloc_lock(GC_fn_type /* fn */, - void * /* client_data */) GC_ATTR_NONNULL(1); - -/* These routines are intended to explicitly notify the collector */ -/* of new threads. Often this is unnecessary because thread creation */ -/* is implicitly intercepted by the collector, using header-file */ -/* defines, or linker-based interception. In the long run the intent */ -/* is to always make redundant registration safe. In the short run, */ -/* this is being implemented a platform at a time. */ -/* The interface is complicated by the fact that we probably will not */ -/* ever be able to automatically determine the stack base for thread */ -/* stacks on all platforms. */ - -/* Structure representing the base of a thread stack. On most */ -/* platforms this contains just a single address. */ -struct GC_stack_base { - void * mem_base; /* Base of memory stack. */ -# if defined(__ia64) || defined(__ia64__) || defined(_M_IA64) - void * reg_base; /* Base of separate register stack. */ -# endif -}; - -typedef void * (GC_CALLBACK * GC_stack_base_func)( - struct GC_stack_base * /* sb */, void * /* arg */); - -/* Call a function with a stack base structure corresponding to */ -/* somewhere in the GC_call_with_stack_base frame. This often can */ -/* be used to provide a sufficiently accurate stack base. And we */ -/* implement it everywhere. */ -GC_API void * GC_CALL GC_call_with_stack_base(GC_stack_base_func /* fn */, - void * /* arg */) GC_ATTR_NONNULL(1); - -#define GC_SUCCESS 0 -#define GC_DUPLICATE 1 /* Was already registered. */ -#define GC_NO_THREADS 2 /* No thread support in GC. */ - /* GC_NO_THREADS is not returned by any GC function anymore. */ -#define GC_UNIMPLEMENTED 3 /* Not yet implemented on this platform. */ -#define GC_NOT_FOUND 4 /* Requested link not found (returned */ - /* by GC_move_disappearing_link). */ - -#if defined(GC_DARWIN_THREADS) || defined(GC_WIN32_THREADS) - /* Use implicit thread registration and processing (via Win32 DllMain */ - /* or Darwin task_threads). Deprecated. Must be called before */ - /* GC_INIT() and other GC routines. Should be avoided if */ - /* GC_pthread_create, GC_beginthreadex (or GC_CreateThread) could be */ - /* called instead. Disables parallelized GC on Win32. */ - GC_API void GC_CALL GC_use_threads_discovery(void); -#endif - -#ifdef GC_THREADS - /* Suggest the GC to use the specific signal to suspend threads. */ - /* Has no effect after GC_init and on non-POSIX systems. */ - GC_API void GC_CALL GC_set_suspend_signal(int); - - /* Suggest the GC to use the specific signal to resume threads. */ - /* Has no effect after GC_init and on non-POSIX systems. */ - GC_API void GC_CALL GC_set_thr_restart_signal(int); - - /* Return the signal number (constant after initialization) used by */ - /* the GC to suspend threads on POSIX systems. Return -1 otherwise. */ - GC_API int GC_CALL GC_get_suspend_signal(void); - - /* Return the signal number (constant after initialization) used by */ - /* the garbage collector to restart (resume) threads on POSIX */ - /* systems. Return -1 otherwise. */ - GC_API int GC_CALL GC_get_thr_restart_signal(void); - - /* Restart marker threads after POSIX fork in child. Meaningless in */ - /* other situations. Should not be called if fork followed by exec. */ - GC_API void GC_CALL GC_start_mark_threads(void); - - /* Explicitly enable GC_register_my_thread() invocation. */ - /* Done implicitly if a GC thread-creation function is called (or */ - /* implicit thread registration is activated, or the collector is */ - /* compiled with GC_ALWAYS_MULTITHREADED defined). Otherwise, it */ - /* must be called from the main (or any previously registered) thread */ - /* between the collector initialization and the first explicit */ - /* registering of a thread (it should be called as late as possible). */ - GC_API void GC_CALL GC_allow_register_threads(void); - - /* Register the current thread, with the indicated stack base, as */ - /* a new thread whose stack(s) should be traced by the GC. If it */ - /* is not implicitly called by the GC, this must be called before a */ - /* thread can allocate garbage collected memory, or assign pointers */ - /* to the garbage collected heap. Once registered, a thread will be */ - /* stopped during garbage collections. */ - /* This call must be previously enabled (see above). */ - /* This should never be called from the main thread, where it is */ - /* always done implicitly. This is normally done implicitly if GC_ */ - /* functions are called to create the thread, e.g. by including gc.h */ - /* (which redefines some system functions) before calling the system */ - /* thread creation function. Nonetheless, thread cleanup routines */ - /* (e.g., pthread key destructor) typically require manual thread */ - /* registering (and unregistering) if pointers to GC-allocated */ - /* objects are manipulated inside. */ - /* It is also always done implicitly on some platforms if */ - /* GC_use_threads_discovery() is called at start-up. Except for the */ - /* latter case, the explicit call is normally required for threads */ - /* created by third-party libraries. */ - /* A manually registered thread requires manual unregistering. */ - GC_API int GC_CALL GC_register_my_thread(const struct GC_stack_base *) - GC_ATTR_NONNULL(1); - - /* Return non-zero (TRUE) if and only if the calling thread is */ - /* registered with the garbage collector. */ - GC_API int GC_CALL GC_thread_is_registered(void); - - /* Unregister the current thread. Only an explicitly registered */ - /* thread (i.e. for which GC_register_my_thread() returns GC_SUCCESS) */ - /* is allowed (and required) to call this function. (As a special */ - /* exception, it is also allowed to once unregister the main thread.) */ - /* The thread may no longer allocate garbage collected memory or */ - /* manipulate pointers to the garbage collected heap after making */ - /* this call. Specifically, if it wants to return or otherwise */ - /* communicate a pointer to the garbage-collected heap to another */ - /* thread, it must do this before calling GC_unregister_my_thread, */ - /* most probably by saving it in a global data structure. Must not */ - /* be called inside a GC callback function (except for */ - /* GC_call_with_stack_base() one). */ - GC_API int GC_CALL GC_unregister_my_thread(void); -#endif /* GC_THREADS */ - -/* Wrapper for functions that are likely to block (or, at least, do not */ -/* allocate garbage collected memory and/or manipulate pointers to the */ -/* garbage collected heap) for an appreciable length of time. While fn */ -/* is running, the collector is said to be in the "inactive" state for */ -/* the current thread (this means that the thread is not suspended and */ -/* the thread's stack frames "belonging" to the functions in the */ -/* "inactive" state are not scanned during garbage collections). It is */ -/* allowed for fn to call GC_call_with_gc_active() (even recursively), */ -/* thus temporarily toggling the collector's state back to "active". */ -GC_API void * GC_CALL GC_do_blocking(GC_fn_type /* fn */, - void * /* client_data */) GC_ATTR_NONNULL(1); - -/* Call a function switching to the "active" state of the collector for */ -/* the current thread (i.e. the user function is allowed to call any */ -/* GC function and/or manipulate pointers to the garbage collected */ -/* heap). GC_call_with_gc_active() has the functionality opposite to */ -/* GC_do_blocking() one. It is assumed that the collector is already */ -/* initialized and the current thread is registered. fn may toggle */ -/* the collector thread's state temporarily to "inactive" one by using */ -/* GC_do_blocking. GC_call_with_gc_active() often can be used to */ -/* provide a sufficiently accurate stack base. */ -GC_API void * GC_CALL GC_call_with_gc_active(GC_fn_type /* fn */, - void * /* client_data */) GC_ATTR_NONNULL(1); - -/* Attempt to fill in the GC_stack_base structure with the stack base */ -/* for this thread. This appears to be required to implement anything */ -/* like the JNI AttachCurrentThread in an environment in which new */ -/* threads are not automatically registered with the collector. */ -/* It is also unfortunately hard to implement well on many platforms. */ -/* Returns GC_SUCCESS or GC_UNIMPLEMENTED. This function acquires the */ -/* GC lock on some platforms. */ -GC_API int GC_CALL GC_get_stack_base(struct GC_stack_base *) - GC_ATTR_NONNULL(1); - -/* The following routines are primarily intended for use with a */ -/* preprocessor which inserts calls to check C pointer arithmetic. */ -/* They indicate failure by invoking the corresponding _print_proc. */ - -/* Check that p and q point to the same object. */ -/* Fail conspicuously if they don't. */ -/* Returns the first argument. */ -/* Succeeds if neither p nor q points to the heap. */ -/* May succeed if both p and q point to between heap objects. */ -GC_API void * GC_CALL GC_same_obj(void * /* p */, void * /* q */); - -/* Checked pointer pre- and post- increment operations. Note that */ -/* the second argument is in units of bytes, not multiples of the */ -/* object size. This should either be invoked from a macro, or the */ -/* call should be automatically generated. */ -GC_API void * GC_CALL GC_pre_incr(void **, ptrdiff_t /* how_much */) - GC_ATTR_NONNULL(1); -GC_API void * GC_CALL GC_post_incr(void **, ptrdiff_t /* how_much */) - GC_ATTR_NONNULL(1); - -/* Check that p is visible */ -/* to the collector as a possibly pointer containing location. */ -/* If it isn't fail conspicuously. */ -/* Returns the argument in all cases. May erroneously succeed */ -/* in hard cases. (This is intended for debugging use with */ -/* untyped allocations. The idea is that it should be possible, though */ -/* slow, to add such a call to all indirect pointer stores.) */ -/* Currently useless for multi-threaded worlds. */ -GC_API void * GC_CALL GC_is_visible(void * /* p */); - -/* Check that if p is a pointer to a heap page, then it points to */ -/* a valid displacement within a heap object. */ -/* Fail conspicuously if this property does not hold. */ -/* Uninteresting with GC_all_interior_pointers. */ -/* Always returns its argument. */ -GC_API void * GC_CALL GC_is_valid_displacement(void * /* p */); - -/* Explicitly dump the GC state. This is most often called from the */ -/* debugger, or by setting the GC_DUMP_REGULARLY environment variable, */ -/* but it may be useful to call it from client code during debugging. */ -/* Defined only if the library has been compiled without NO_DEBUGGING. */ -GC_API void GC_CALL GC_dump(void); - -/* Safer, but slow, pointer addition. Probably useful mainly with */ -/* a preprocessor. Useful only for heap pointers. */ -/* Only the macros without trailing digits are meant to be used */ -/* by clients. These are designed to model the available C pointer */ -/* arithmetic expressions. */ -/* Even then, these are probably more useful as */ -/* documentation than as part of the API. */ -/* Note that GC_PTR_ADD evaluates the first argument more than once. */ -#if defined(GC_DEBUG) && defined(__GNUC__) -# define GC_PTR_ADD3(x, n, type_of_result) \ - ((type_of_result)GC_same_obj((x)+(n), (x))) -# define GC_PRE_INCR3(x, n, type_of_result) \ - ((type_of_result)GC_pre_incr((void **)(&(x)), (n)*sizeof(*x))) -# define GC_POST_INCR3(x, n, type_of_result) \ - ((type_of_result)GC_post_incr((void **)(&(x)), (n)*sizeof(*x))) -# define GC_PTR_ADD(x, n) GC_PTR_ADD3(x, n, typeof(x)) -# define GC_PRE_INCR(x, n) GC_PRE_INCR3(x, n, typeof(x)) -# define GC_POST_INCR(x) GC_POST_INCR3(x, 1, typeof(x)) -# define GC_POST_DECR(x) GC_POST_INCR3(x, -1, typeof(x)) -#else /* !GC_DEBUG || !__GNUC__ */ - /* We can't do this right without typeof, which ANSI decided was not */ - /* sufficiently useful. Without it we resort to the non-debug version. */ - /* FIXME: This should eventually support C++0x decltype. */ -# define GC_PTR_ADD(x, n) ((x)+(n)) -# define GC_PRE_INCR(x, n) ((x) += (n)) -# define GC_POST_INCR(x) ((x)++) -# define GC_POST_DECR(x) ((x)--) -#endif /* !GC_DEBUG || !__GNUC__ */ - -/* Safer assignment of a pointer to a non-stack location. */ -#ifdef GC_DEBUG -# define GC_PTR_STORE(p, q) \ - (*(void **)GC_is_visible(p) = GC_is_valid_displacement(q)) -#else -# define GC_PTR_STORE(p, q) (*(p) = (q)) -#endif - -/* Functions called to report pointer checking errors */ -GC_API void (GC_CALLBACK * GC_same_obj_print_proc)(void * /* p */, - void * /* q */); -GC_API void (GC_CALLBACK * GC_is_valid_displacement_print_proc)(void *); -GC_API void (GC_CALLBACK * GC_is_visible_print_proc)(void *); - -#ifdef GC_PTHREADS - /* For pthread support, we generally need to intercept a number of */ - /* thread library calls. We do that here by macro defining them. */ -# include "gc_pthread_redirects.h" -#endif - -/* This returns a list of objects, linked through their first word. */ -/* Its use can greatly reduce lock contention problems, since the */ -/* allocation lock can be acquired and released many fewer times. */ -GC_API GC_ATTR_MALLOC void * GC_CALL GC_malloc_many(size_t /* lb */); -#define GC_NEXT(p) (*(void * *)(p)) /* Retrieve the next element */ - /* in returned list. */ - -/* A filter function to control the scanning of dynamic libraries. */ -/* If implemented, called by GC before registering a dynamic library */ -/* (discovered by GC) section as a static data root (called only as */ -/* a last reason not to register). The filename of the library, the */ -/* address and the length of the memory region (section) are passed. */ -/* This routine should return nonzero if that region should be scanned. */ -/* Always called with the allocation lock held. Depending on the */ -/* platform, might be called with the "world" stopped. */ -typedef int (GC_CALLBACK * GC_has_static_roots_func)( - const char * /* dlpi_name */, - void * /* section_start */, - size_t /* section_size */); - -/* Register a new callback (a user-supplied filter) to control the */ -/* scanning of dynamic libraries. Replaces any previously registered */ -/* callback. May be 0 (means no filtering). May be unused on some */ -/* platforms (if the filtering is unimplemented or inappropriate). */ -GC_API void GC_CALL GC_register_has_static_roots_callback( - GC_has_static_roots_func); - -#if defined(GC_WIN32_THREADS) \ - && (!defined(GC_PTHREADS) || defined(GC_BUILD) || defined(WINAPI)) - /* Note: for Cygwin and pthreads-win32, this is skipped */ - /* unless windows.h is included before gc.h. */ - -# if !defined(GC_NO_THREAD_DECLS) || defined(GC_BUILD) - -# ifdef __cplusplus - } /* Including windows.h in an extern "C" context no longer works. */ -# endif - -# if !defined(_WIN32_WCE) && !defined(__CEGCC__) -# include /* For _beginthreadex, _endthreadex */ -# endif - -# include - -# ifdef __cplusplus - extern "C" { -# endif - -# ifdef GC_UNDERSCORE_STDCALL - /* Explicitly prefix exported/imported WINAPI (__stdcall) symbols */ - /* with '_' (underscore). Might be useful if MinGW/x86 is used. */ -# define GC_CreateThread _GC_CreateThread -# define GC_ExitThread _GC_ExitThread -# endif - -# ifdef GC_INSIDE_DLL - /* Export GC DllMain to be invoked from client DllMain. */ -# ifdef GC_UNDERSCORE_STDCALL -# define GC_DllMain _GC_DllMain -# endif - GC_API BOOL WINAPI GC_DllMain(HINSTANCE /* inst */, ULONG /* reason */, - LPVOID /* reserved */); -# endif /* GC_INSIDE_DLL */ - -# if !defined(_UINTPTR_T) && !defined(_UINTPTR_T_DEFINED) \ - && !defined(UINTPTR_MAX) - typedef GC_word GC_uintptr_t; -# else - typedef uintptr_t GC_uintptr_t; -# endif -# define GC_WIN32_SIZE_T GC_uintptr_t - - /* All threads must be created using GC_CreateThread or */ - /* GC_beginthreadex, or must explicitly call GC_register_my_thread */ - /* (and call GC_unregister_my_thread before thread termination), so */ - /* that they will be recorded in the thread table. For backward */ - /* compatibility, it is possible to build the GC with GC_DLL */ - /* defined, and to call GC_use_threads_discovery. This implicitly */ - /* registers all created threads, but appears to be less robust. */ - /* Currently the collector expects all threads to fall through and */ - /* terminate normally, or call GC_endthreadex() or GC_ExitThread, */ - /* so that the thread is properly unregistered. */ - GC_API HANDLE WINAPI GC_CreateThread( - LPSECURITY_ATTRIBUTES /* lpThreadAttributes */, - GC_WIN32_SIZE_T /* dwStackSize */, - LPTHREAD_START_ROUTINE /* lpStartAddress */, - LPVOID /* lpParameter */, DWORD /* dwCreationFlags */, - LPDWORD /* lpThreadId */); - -# ifndef DECLSPEC_NORETURN - /* Typically defined in winnt.h. */ -# define DECLSPEC_NORETURN /* empty */ -# endif - - GC_API DECLSPEC_NORETURN void WINAPI GC_ExitThread( - DWORD /* dwExitCode */); - -# if !defined(_WIN32_WCE) && !defined(__CEGCC__) - GC_API GC_uintptr_t GC_CALL GC_beginthreadex( - void * /* security */, unsigned /* stack_size */, - unsigned (__stdcall *)(void *), - void * /* arglist */, unsigned /* initflag */, - unsigned * /* thrdaddr */); - - /* Note: _endthreadex() is not currently marked as no-return in */ - /* VC++ and MinGW headers, so we don't mark it neither. */ - GC_API void GC_CALL GC_endthreadex(unsigned /* retval */); -# endif /* !_WIN32_WCE */ - -# endif /* !GC_NO_THREAD_DECLS */ - -# ifdef GC_WINMAIN_REDIRECT - /* win32_threads.c implements the real WinMain(), which will start */ - /* a new thread to call GC_WinMain() after initializing the garbage */ - /* collector. */ -# define WinMain GC_WinMain -# endif - - /* For compatibility only. */ -# define GC_use_DllMain GC_use_threads_discovery - -# ifndef GC_NO_THREAD_REDIRECTS -# define CreateThread GC_CreateThread -# define ExitThread GC_ExitThread -# undef _beginthreadex -# define _beginthreadex GC_beginthreadex -# undef _endthreadex -# define _endthreadex GC_endthreadex -/* #define _beginthread { > "Please use _beginthreadex instead of _beginthread" < } */ -# endif /* !GC_NO_THREAD_REDIRECTS */ - -#endif /* GC_WIN32_THREADS */ - -/* Public setter and getter for switching "unmap as much as possible" */ -/* mode on(1) and off(0). Has no effect unless unmapping is turned on. */ -/* Has no effect on implicitly-initiated garbage collections. Initial */ -/* value is controlled by GC_FORCE_UNMAP_ON_GCOLLECT. The setter and */ -/* getter are unsynchronized. */ -GC_API void GC_CALL GC_set_force_unmap_on_gcollect(int); -GC_API int GC_CALL GC_get_force_unmap_on_gcollect(void); - -/* Fully portable code should call GC_INIT() from the main program */ -/* before making any other GC_ calls. On most platforms this is a */ -/* no-op and the collector self-initializes. But a number of */ -/* platforms make that too hard. */ -/* A GC_INIT call is required if the collector is built with */ -/* THREAD_LOCAL_ALLOC defined and the initial allocation call is not */ -/* to GC_malloc() or GC_malloc_atomic(). */ - -#if defined(__CYGWIN32__) || defined(__CYGWIN__) - /* Similarly gnu-win32 DLLs need explicit initialization from the */ - /* main program, as does AIX. */ - extern int _data_start__[], _data_end__[], _bss_start__[], _bss_end__[]; -# define GC_DATASTART ((GC_word)_data_start__ < (GC_word)_bss_start__ ? \ - (void *)_data_start__ : (void *)_bss_start__) -# define GC_DATAEND ((GC_word)_data_end__ > (GC_word)_bss_end__ ? \ - (void *)_data_end__ : (void *)_bss_end__) -# define GC_INIT_CONF_ROOTS GC_add_roots(GC_DATASTART, GC_DATAEND); \ - GC_gcollect() /* For blacklisting. */ - /* Required at least if GC is in a DLL. And doesn't hurt. */ -#elif defined(_AIX) - extern int _data[], _end[]; -# define GC_DATASTART ((void *)((ulong)_data)) -# define GC_DATAEND ((void *)((ulong)_end)) -# define GC_INIT_CONF_ROOTS GC_add_roots(GC_DATASTART, GC_DATAEND) -#elif (defined(PLATFORM_ANDROID) || defined(__ANDROID__)) \ - && !defined(GC_NOT_DLL) -# pragma weak __data_start - extern int __data_start[], _end[]; -# pragma weak _etext -# pragma weak __dso_handle - extern int _etext[], __dso_handle[]; - /* Explicitly register caller static data roots (__data_start points */ - /* to the beginning typically but NDK "gold" linker could provide it */ - /* incorrectly, so the workaround is to check the value and use */ - /* __dso_handle as an alternative data start reference if provided). */ - /* It also works for Android/x86 target where __data_start is not */ - /* defined currently (regardless of linker used). */ -# define GC_INIT_CONF_ROOTS \ - (void)((GC_word)__data_start < (GC_word)_etext \ - && (GC_word)_etext < (GC_word)__dso_handle ? \ - (GC_add_roots(__dso_handle, _end), 0) : \ - (GC_word)__data_start != 0 ? \ - (GC_add_roots(__data_start, _end), 0) : 0) -#else -# define GC_INIT_CONF_ROOTS /* empty */ -#endif - -#ifdef GC_DONT_EXPAND - /* Set GC_dont_expand to TRUE at start-up */ -# define GC_INIT_CONF_DONT_EXPAND GC_set_dont_expand(1) -#else -# define GC_INIT_CONF_DONT_EXPAND /* empty */ -#endif - -#ifdef GC_FORCE_UNMAP_ON_GCOLLECT - /* Turn on "unmap as much as possible on explicit GC" mode at start-up */ -# define GC_INIT_CONF_FORCE_UNMAP_ON_GCOLLECT \ - GC_set_force_unmap_on_gcollect(1) -#else -# define GC_INIT_CONF_FORCE_UNMAP_ON_GCOLLECT /* empty */ -#endif - -#ifdef GC_DONT_GC - /* This is for debugging only (useful if environment variables are */ - /* unsupported); cannot call GC_disable as goes before GC_init. */ -# define GC_INIT_CONF_MAX_RETRIES (void)(GC_dont_gc = 1) -#elif defined(GC_MAX_RETRIES) - /* Set GC_max_retries to the desired value at start-up */ -# define GC_INIT_CONF_MAX_RETRIES GC_set_max_retries(GC_MAX_RETRIES) -#else -# define GC_INIT_CONF_MAX_RETRIES /* empty */ -#endif - -#ifdef GC_FREE_SPACE_DIVISOR - /* Set GC_free_space_divisor to the desired value at start-up */ -# define GC_INIT_CONF_FREE_SPACE_DIVISOR \ - GC_set_free_space_divisor(GC_FREE_SPACE_DIVISOR) -#else -# define GC_INIT_CONF_FREE_SPACE_DIVISOR /* empty */ -#endif - -#ifdef GC_FULL_FREQ - /* Set GC_full_freq to the desired value at start-up */ -# define GC_INIT_CONF_FULL_FREQ GC_set_full_freq(GC_FULL_FREQ) -#else -# define GC_INIT_CONF_FULL_FREQ /* empty */ -#endif - -#ifdef GC_TIME_LIMIT - /* Set GC_time_limit to the desired value at start-up */ -# define GC_INIT_CONF_TIME_LIMIT GC_set_time_limit(GC_TIME_LIMIT) -#else -# define GC_INIT_CONF_TIME_LIMIT /* empty */ -#endif - -#if defined(GC_SIG_SUSPEND) && defined(GC_THREADS) -# define GC_INIT_CONF_SUSPEND_SIGNAL GC_set_suspend_signal(GC_SIG_SUSPEND) -#else -# define GC_INIT_CONF_SUSPEND_SIGNAL /* empty */ -#endif - -#if defined(GC_SIG_THR_RESTART) && defined(GC_THREADS) -# define GC_INIT_CONF_THR_RESTART_SIGNAL \ - GC_set_thr_restart_signal(GC_SIG_THR_RESTART) -#else -# define GC_INIT_CONF_THR_RESTART_SIGNAL /* empty */ -#endif - -#ifdef GC_MAXIMUM_HEAP_SIZE - /* Limit the heap size to the desired value (useful for debugging). */ - /* The limit could be overridden either at the program start-up by */ - /* the similar environment variable or anytime later by the */ - /* corresponding API function call. */ -# define GC_INIT_CONF_MAXIMUM_HEAP_SIZE \ - GC_set_max_heap_size(GC_MAXIMUM_HEAP_SIZE) -#else -# define GC_INIT_CONF_MAXIMUM_HEAP_SIZE /* empty */ -#endif - -#ifdef GC_IGNORE_WARN - /* Turn off all warnings at start-up (after GC initialization) */ -# define GC_INIT_CONF_IGNORE_WARN GC_set_warn_proc(GC_ignore_warn_proc) -#else -# define GC_INIT_CONF_IGNORE_WARN /* empty */ -#endif - -#ifdef GC_INITIAL_HEAP_SIZE - /* Set heap size to the desired value at start-up */ -# define GC_INIT_CONF_INITIAL_HEAP_SIZE \ - { size_t heap_size = GC_get_heap_size(); \ - if (heap_size < (GC_INITIAL_HEAP_SIZE)) \ - (void)GC_expand_hp((GC_INITIAL_HEAP_SIZE) - heap_size); } -#else -# define GC_INIT_CONF_INITIAL_HEAP_SIZE /* empty */ -#endif - -/* Portable clients should call this at the program start-up. More */ -/* over, some platforms require this call to be done strictly from the */ -/* primordial thread. */ -#define GC_INIT() { GC_INIT_CONF_DONT_EXPAND; /* pre-init */ \ - GC_INIT_CONF_FORCE_UNMAP_ON_GCOLLECT; \ - GC_INIT_CONF_MAX_RETRIES; \ - GC_INIT_CONF_FREE_SPACE_DIVISOR; \ - GC_INIT_CONF_FULL_FREQ; \ - GC_INIT_CONF_TIME_LIMIT; \ - GC_INIT_CONF_SUSPEND_SIGNAL; \ - GC_INIT_CONF_THR_RESTART_SIGNAL; \ - GC_INIT_CONF_MAXIMUM_HEAP_SIZE; \ - GC_init(); /* real GC initialization */ \ - GC_INIT_CONF_ROOTS; /* post-init */ \ - GC_INIT_CONF_IGNORE_WARN; \ - GC_INIT_CONF_INITIAL_HEAP_SIZE; } - -/* win32S may not free all resources on process exit. */ -/* This explicitly deallocates the heap. */ -GC_API void GC_CALL GC_win32_free_heap(void); - -#if defined(__SYMBIAN32__) - void GC_init_global_static_roots(void); -#endif - -#if defined(_AMIGA) && !defined(GC_AMIGA_MAKINGLIB) - /* Allocation really goes through GC_amiga_allocwrapper_do. */ - void *GC_amiga_realloc(void *, size_t); -# define GC_realloc(a,b) GC_amiga_realloc(a,b) - void GC_amiga_set_toany(void (*)(void)); - extern int GC_amiga_free_space_divisor_inc; - extern void *(*GC_amiga_allocwrapper_do)(size_t, void *(GC_CALL *)(size_t)); -# define GC_malloc(a) \ - (*GC_amiga_allocwrapper_do)(a,GC_malloc) -# define GC_malloc_atomic(a) \ - (*GC_amiga_allocwrapper_do)(a,GC_malloc_atomic) -# define GC_malloc_uncollectable(a) \ - (*GC_amiga_allocwrapper_do)(a,GC_malloc_uncollectable) -# define GC_malloc_stubborn(a) \ - (*GC_amiga_allocwrapper_do)(a,GC_malloc_stubborn) -# define GC_malloc_atomic_uncollectable(a) \ - (*GC_amiga_allocwrapper_do)(a,GC_malloc_atomic_uncollectable) -# define GC_malloc_ignore_off_page(a) \ - (*GC_amiga_allocwrapper_do)(a,GC_malloc_ignore_off_page) -# define GC_malloc_atomic_ignore_off_page(a) \ - (*GC_amiga_allocwrapper_do)(a,GC_malloc_atomic_ignore_off_page) -#endif /* _AMIGA && !GC_AMIGA_MAKINGLIB */ - -#ifdef __cplusplus - } /* end of extern "C" */ -#endif - -#endif /* GC_H */ diff -Nru ecl-16.1.2/src/bdwgc/include/gc_inline.h ecl-16.1.3+ds/src/bdwgc/include/gc_inline.h --- ecl-16.1.2/src/bdwgc/include/gc_inline.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/gc_inline.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,146 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1995 by Xerox Corporation. All rights reserved. - * Copyright (c) 2005 Hewlett-Packard Development Company, L.P. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#ifndef GC_INLINE_H -#define GC_INLINE_H - -/* WARNING: */ -/* Note that for these routines, it is the clients responsibility to */ -/* add the extra byte at the end to deal with one-past-the-end pointers.*/ -/* In the standard collector configuration, the collector assumes that */ -/* such a byte has been added, and hence does not trace the last word */ -/* in the resulting object. */ -/* This is not an issue if the collector is compiled with */ -/* DONT_ADD_BYTE_AT_END, or if GC_all_interior_pointers is not set. */ -/* This interface is most useful for compilers that generate C. */ -/* It is also used internally for thread-local allocation. */ -/* Manual use is hereby discouraged. */ - -#include "gc.h" -#include "gc_tiny_fl.h" - -#if __GNUC__ >= 3 -# define GC_EXPECT(expr, outcome) __builtin_expect(expr,outcome) - /* Equivalent to (expr), but predict that usually (expr)==outcome. */ -#else -# define GC_EXPECT(expr, outcome) (expr) -#endif /* __GNUC__ */ - -#ifndef GC_ASSERT -# define GC_ASSERT(expr) /* empty */ -#endif - -/* Store a pointer to a list of newly allocated objects of kind k and */ -/* size lb in *result. The caller must make sure that *result is */ -/* traced even if objects are ptrfree. */ -GC_API void GC_CALL GC_generic_malloc_many(size_t /* lb */, int /* k */, - void ** /* result */); - -/* The ultimately general inline allocation macro. Allocate an object */ -/* of size granules, putting the resulting pointer in result. Tiny_fl */ -/* is a "tiny" free list array, which will be used first, if the size */ -/* is appropriate. If granules is too large, we allocate with */ -/* default_expr instead. If we need to refill the free list, we use */ -/* GC_generic_malloc_many with the indicated kind. */ -/* Tiny_fl should be an array of GC_TINY_FREELISTS void * pointers. */ -/* If num_direct is nonzero, and the individual free list pointers */ -/* are initialized to (void *)1, then we allocate numdirect granules */ -/* directly using gmalloc before putting multiple objects into the */ -/* tiny_fl entry. If num_direct is zero, then the free lists may also */ -/* be initialized to (void *)0. */ -/* Note that we use the zeroth free list to hold objects 1 granule in */ -/* size that are used to satisfy size 0 allocation requests. */ -/* We rely on much of this hopefully getting optimized away in the */ -/* num_direct = 0 case. */ -/* Particularly if granules is constant, this should generate a small */ -/* amount of code. */ -# define GC_FAST_MALLOC_GRANS(result,granules,tiny_fl,num_direct,\ - kind,default_expr,init) \ - do { \ - if (GC_EXPECT((granules) >= GC_TINY_FREELISTS,0)) { \ - result = (default_expr); \ - } else { \ - void **my_fl = (tiny_fl) + (granules); \ - void *my_entry=*my_fl; \ - void *next; \ - \ - while (GC_EXPECT((GC_word)my_entry \ - <= (num_direct) + GC_TINY_FREELISTS + 1, 0)) { \ - /* Entry contains counter or NULL */ \ - if ((GC_word)my_entry - 1 < (num_direct)) { \ - /* Small counter value, not NULL */ \ - *my_fl = (char *)my_entry + (granules) + 1; \ - result = (default_expr); \ - goto out; \ - } else { \ - /* Large counter or NULL */ \ - GC_generic_malloc_many(((granules) == 0? GC_GRANULE_BYTES : \ - GC_RAW_BYTES_FROM_INDEX(granules)), \ - kind, my_fl); \ - my_entry = *my_fl; \ - if (my_entry == 0) { \ - result = (*GC_get_oom_fn())((granules)*GC_GRANULE_BYTES); \ - goto out; \ - } \ - } \ - } \ - next = *(void **)(my_entry); \ - result = (void *)my_entry; \ - *my_fl = next; \ - init; \ - PREFETCH_FOR_WRITE(next); \ - GC_ASSERT(GC_size(result) >= (granules)*GC_GRANULE_BYTES); \ - GC_ASSERT((kind) == PTRFREE || ((GC_word *)result)[1] == 0); \ - out: ; \ - } \ - } while (0) - -# define GC_WORDS_TO_WHOLE_GRANULES(n) \ - GC_WORDS_TO_GRANULES((n) + GC_GRANULE_WORDS - 1) - -/* Allocate n words (NOT BYTES). X is made to point to the result. */ -/* This should really only be used if GC_all_interior_pointers is */ -/* not set, or DONT_ADD_BYTE_AT_END is set. See above. */ -/* The semantics changed in version 7.0; we no longer lock, and */ -/* the caller is responsible for supplying a cleared tiny_fl */ -/* free list array. For single-threaded applications, this may be */ -/* a global array. */ -# define GC_MALLOC_WORDS(result,n,tiny_fl) \ - do { \ - size_t grans = GC_WORDS_TO_WHOLE_GRANULES(n); \ - GC_FAST_MALLOC_GRANS(result, grans, tiny_fl, 0, \ - NORMAL, GC_malloc(grans*GC_GRANULE_BYTES), \ - *(void **)(result) = 0); \ - } while (0) - -# define GC_MALLOC_ATOMIC_WORDS(result,n,tiny_fl) \ - do { \ - size_t grans = GC_WORDS_TO_WHOLE_GRANULES(n); \ - GC_FAST_MALLOC_GRANS(result, grans, tiny_fl, 0, \ - PTRFREE, GC_malloc_atomic(grans*GC_GRANULE_BYTES), \ - (void)0 /* no initialization */); \ - } while (0) - -/* And once more for two word initialized objects: */ -# define GC_CONS(result, first, second, tiny_fl) \ - do { \ - size_t grans = GC_WORDS_TO_WHOLE_GRANULES(2); \ - GC_FAST_MALLOC_GRANS(result, grans, tiny_fl, 0, \ - NORMAL, GC_malloc(grans*GC_GRANULE_BYTES), \ - *(void **)(result) = (void *)(first)); \ - ((void **)(result))[1] = (void *)(second); \ - } while (0) - -#endif /* !GC_INLINE_H */ diff -Nru ecl-16.1.2/src/bdwgc/include/gc_mark.h ecl-16.1.3+ds/src/bdwgc/include/gc_mark.h --- ecl-16.1.2/src/bdwgc/include/gc_mark.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/gc_mark.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,294 +0,0 @@ -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 2001 by Hewlett-Packard Company. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -/* - * This contains interfaces to the GC marker that are likely to be useful to - * clients that provide detailed heap layout information to the collector. - * This interface should not be used by normal C or C++ clients. - * It will be useful to runtimes for other languages. - * - * This is an experts-only interface! There are many ways to break the - * collector in subtle ways by using this functionality. - */ -#ifndef GC_MARK_H -#define GC_MARK_H - -#ifndef GC_H -# include "gc.h" -#endif - -#ifdef __cplusplus - extern "C" { -#endif - -/* A client supplied mark procedure. Returns new mark stack pointer. */ -/* Primary effect should be to push new entries on the mark stack. */ -/* Mark stack pointer values are passed and returned explicitly. */ -/* Global variables describing mark stack are not necessarily valid. */ -/* (This usually saves a few cycles by keeping things in registers.) */ -/* Assumed to scan about GC_PROC_BYTES on average. If it needs to do */ -/* much more work than that, it should do it in smaller pieces by */ -/* pushing itself back on the mark stack. */ -/* Note that it should always do some work (defined as marking some */ -/* objects) before pushing more than one entry on the mark stack. */ -/* This is required to ensure termination in the event of mark stack */ -/* overflows. */ -/* This procedure is always called with at least one empty entry on the */ -/* mark stack. */ -/* Currently we require that mark procedures look for pointers in a */ -/* subset of the places the conservative marker would. It must be safe */ -/* to invoke the normal mark procedure instead. */ -/* WARNING: Such a mark procedure may be invoked on an unused object */ -/* residing on a free list. Such objects are cleared, except for a */ -/* free list link field in the first word. Thus mark procedures may */ -/* not count on the presence of a type descriptor, and must handle this */ -/* case correctly somehow. */ -#define GC_PROC_BYTES 100 - -#ifdef GC_BUILD - struct GC_ms_entry; -#else - struct GC_ms_entry { void *opaque; }; -#endif -typedef struct GC_ms_entry * (*GC_mark_proc)(GC_word * /* addr */, - struct GC_ms_entry * /* mark_stack_ptr */, - struct GC_ms_entry * /* mark_stack_limit */, - GC_word /* env */); - -#define GC_LOG_MAX_MARK_PROCS 6 -#define GC_MAX_MARK_PROCS (1 << GC_LOG_MAX_MARK_PROCS) - -/* In a few cases it's necessary to assign statically known indices to */ -/* certain mark procs. Thus we reserve a few for well known clients. */ -/* (This is necessary if mark descriptors are compiler generated.) */ -#define GC_RESERVED_MARK_PROCS 8 -#define GC_GCJ_RESERVED_MARK_PROC_INDEX 0 - -/* Object descriptors on mark stack or in objects. Low order two */ -/* bits are tags distinguishing among the following 4 possibilities */ -/* for the high order 30 bits. */ -#define GC_DS_TAG_BITS 2 -#define GC_DS_TAGS ((1 << GC_DS_TAG_BITS) - 1) -#define GC_DS_LENGTH 0 /* The entire word is a length in bytes that */ - /* must be a multiple of 4. */ -#define GC_DS_BITMAP 1 /* 30 (62) bits are a bitmap describing pointer */ - /* fields. The msb is 1 if the first word */ - /* is a pointer. */ - /* (This unconventional ordering sometimes */ - /* makes the marker slightly faster.) */ - /* Zeroes indicate definite nonpointers. Ones */ - /* indicate possible pointers. */ - /* Only usable if pointers are word aligned. */ -#define GC_DS_PROC 2 - /* The objects referenced by this object can be */ - /* pushed on the mark stack by invoking */ - /* PROC(descr). ENV(descr) is passed as the */ - /* last argument. */ -#define GC_MAKE_PROC(proc_index, env) \ - (((((env) << GC_LOG_MAX_MARK_PROCS) \ - | (proc_index)) << GC_DS_TAG_BITS) | GC_DS_PROC) -#define GC_DS_PER_OBJECT 3 /* The real descriptor is at the */ - /* byte displacement from the beginning of the */ - /* object given by descr & ~DS_TAGS */ - /* If the descriptor is negative, the real */ - /* descriptor is at (*) - */ - /* (descr & ~DS_TAGS) - GC_INDIR_PER_OBJ_BIAS */ - /* The latter alternative can be used if each */ - /* object contains a type descriptor in the */ - /* first word. */ - /* Note that in the multi-threaded environments */ - /* per-object descriptors must be located in */ - /* either the first two or last two words of */ - /* the object, since only those are guaranteed */ - /* to be cleared while the allocation lock is */ - /* held. */ -#define GC_INDIR_PER_OBJ_BIAS 0x10 - -GC_API void * GC_least_plausible_heap_addr; -GC_API void * GC_greatest_plausible_heap_addr; - /* Bounds on the heap. Guaranteed valid */ - /* Likely to include future heap expansion. */ - /* Hence usually includes not-yet-mapped */ - /* memory. */ - -/* Handle nested references in a custom mark procedure. */ -/* Check if obj is a valid object. If so, ensure that it is marked. */ -/* If it was not previously marked, push its contents onto the mark */ -/* stack for future scanning. The object will then be scanned using */ -/* its mark descriptor. */ -/* Returns the new mark stack pointer. */ -/* Handles mark stack overflows correctly. */ -/* Since this marks first, it makes progress even if there are mark */ -/* stack overflows. */ -/* Src is the address of the pointer to obj, which is used only */ -/* for back pointer-based heap debugging. */ -/* It is strongly recommended that most objects be handled without mark */ -/* procedures, e.g. with bitmap descriptors, and that mark procedures */ -/* be reserved for exceptional cases. That will ensure that */ -/* performance of this call is not extremely performance critical. */ -/* (Otherwise we would need to inline GC_mark_and_push completely, */ -/* which would tie the client code to a fixed collector version.) */ -/* Note that mark procedures should explicitly call FIXUP_POINTER() */ -/* if required. */ -GC_API struct GC_ms_entry * GC_CALL GC_mark_and_push(void * /* obj */, - struct GC_ms_entry * /* mark_stack_ptr */, - struct GC_ms_entry * /* mark_stack_limit */, - void ** /* src */); - -#define GC_MARK_AND_PUSH(obj, msp, lim, src) \ - ((GC_word)(obj) >= (GC_word)GC_least_plausible_heap_addr && \ - (GC_word)(obj) <= (GC_word)GC_greatest_plausible_heap_addr ? \ - GC_mark_and_push(obj, msp, lim, src) : (msp)) - -GC_API size_t GC_debug_header_size; - /* The size of the header added to objects allocated through */ - /* the GC_debug routines. */ - /* Defined as a variable so that client mark procedures don't */ - /* need to be recompiled for collector version changes. */ -#define GC_USR_PTR_FROM_BASE(p) ((void *)((char *)(p) + GC_debug_header_size)) - -/* And some routines to support creation of new "kinds", e.g. with */ -/* custom mark procedures, by language runtimes. */ -/* The _inner versions assume the caller holds the allocation lock. */ - -/* Return a new free list array. */ -GC_API void ** GC_CALL GC_new_free_list(void); -GC_API void ** GC_CALL GC_new_free_list_inner(void); - -/* Return a new kind, as specified. */ -GC_API unsigned GC_CALL GC_new_kind(void ** /* free_list */, - GC_word /* mark_descriptor_template */, - int /* add_size_to_descriptor */, - int /* clear_new_objects */) GC_ATTR_NONNULL(1); - /* The last two parameters must be zero or one. */ -GC_API unsigned GC_CALL GC_new_kind_inner(void ** /* free_list */, - GC_word /* mark_descriptor_template */, - int /* add_size_to_descriptor */, - int /* clear_new_objects */) GC_ATTR_NONNULL(1); - -/* Return a new mark procedure identifier, suitable for use as */ -/* the first argument in GC_MAKE_PROC. */ -GC_API unsigned GC_CALL GC_new_proc(GC_mark_proc); -GC_API unsigned GC_CALL GC_new_proc_inner(GC_mark_proc); - -/* Allocate an object of a given kind. By default, there are only */ -/* a few kinds: composite (pointer-free), atomic, uncollectible, etc. */ -/* We claim it is possible for clever client code that understands the */ -/* GC internals to add more, e.g. to communicate object layout */ -/* information to the collector. Note that in the multi-threaded */ -/* contexts, this is usually unsafe for kinds that have the descriptor */ -/* in the object itself, since there is otherwise a window in which */ -/* the descriptor is not correct. Even in the single-threaded case, */ -/* we need to be sure that cleared objects on a free list don't */ -/* cause a GC crash if they are accidentally traced. */ -GC_API GC_ATTR_MALLOC GC_ATTR_ALLOC_SIZE(1) void * GC_CALL GC_generic_malloc( - size_t /* lb */, - int /* knd */); - -GC_API GC_ATTR_MALLOC GC_ATTR_ALLOC_SIZE(1) void * GC_CALL - GC_generic_malloc_ignore_off_page( - size_t /* lb */, int /* knd */); - /* As above, but pointers to past the */ - /* first page of the resulting object */ - /* are ignored. */ - -/* Same as above but primary for allocating an object of the same kind */ -/* as an existing one (kind obtained by GC_get_kind_and_size). */ -/* Not suitable for GCJ and typed-malloc kinds. */ -GC_API GC_ATTR_MALLOC GC_ATTR_ALLOC_SIZE(1) void * GC_CALL - GC_generic_or_special_malloc( - size_t /* size */, int /* knd */); -GC_API GC_ATTR_MALLOC GC_ATTR_ALLOC_SIZE(1) void * GC_CALL - GC_debug_generic_or_special_malloc( - size_t /* size */, int /* knd */, - GC_EXTRA_PARAMS); - -#ifdef GC_DEBUG -# define GC_GENERIC_OR_SPECIAL_MALLOC(sz, knd) \ - GC_debug_generic_or_special_malloc(sz, knd, GC_EXTRAS) -#else -# define GC_GENERIC_OR_SPECIAL_MALLOC(sz, knd) \ - GC_generic_or_special_malloc(sz, knd) -#endif /* !GC_DEBUG */ - -/* Similar to GC_size but returns object kind. Size is returned too */ -/* if psize is not NULL. */ -GC_API int GC_CALL GC_get_kind_and_size(const void *, size_t * /* psize */) - GC_ATTR_NONNULL(1); - -typedef void (GC_CALLBACK * GC_describe_type_fn)(void * /* p */, - char * /* out_buf */); - /* A procedure which */ - /* produces a human-readable */ - /* description of the "type" of object */ - /* p into the buffer out_buf of length */ - /* GC_TYPE_DESCR_LEN. This is used by */ - /* the debug support when printing */ - /* objects. */ - /* These functions should be as robust */ - /* as possible, though we do avoid */ - /* invoking them on objects on the */ - /* global free list. */ -#define GC_TYPE_DESCR_LEN 40 - -GC_API void GC_CALL GC_register_describe_type_fn(int /* kind */, - GC_describe_type_fn); - /* Register a describe_type function */ - /* to be used when printing objects */ - /* of a particular kind. */ - -/* Clear some of the inaccessible part of the stack. Returns its */ -/* argument, so it can be used in a tail call position, hence clearing */ -/* another frame. Argument may be NULL. */ -GC_API void * GC_CALL GC_clear_stack(void *); - -/* Set and get the client notifier on collections. The client function */ -/* is called at the start of every full GC (called with the allocation */ -/* lock held). May be 0. This is a really tricky interface to use */ -/* correctly. Unless you really understand the collector internals, */ -/* the callback should not, directly or indirectly, make any GC_ or */ -/* potentially blocking calls. In particular, it is not safe to */ -/* allocate memory using the garbage collector from within the callback */ -/* function. Both the setter and getter acquire the GC lock. */ -typedef void (GC_CALLBACK * GC_start_callback_proc)(void); -GC_API void GC_CALL GC_set_start_callback(GC_start_callback_proc); -GC_API GC_start_callback_proc GC_CALL GC_get_start_callback(void); - -/* Slow/general mark bit manipulation. The caller must hold the */ -/* allocation lock. GC_is_marked returns 1 (TRUE) or 0. */ -GC_API int GC_CALL GC_is_marked(const void *) GC_ATTR_NONNULL(1); -GC_API void GC_CALL GC_clear_mark_bit(const void *) GC_ATTR_NONNULL(1); -GC_API void GC_CALL GC_set_mark_bit(const void *) GC_ATTR_NONNULL(1); - -/* Push everything in the given range onto the mark stack. */ -/* (GC_push_conditional pushes either all or only dirty pages depending */ -/* on the third argument.) */ -GC_API void GC_CALL GC_push_all(char * /* bottom */, char * /* top */); -GC_API void GC_CALL GC_push_conditional(char * /* bottom */, char * /* top */, - int /* bool all */); - -/* Set and get the client push-other-roots procedure. A client */ -/* supplied procedure should also call the original procedure. */ -/* Note that both the setter and getter require some external */ -/* synchronization to avoid data race. */ -typedef void (GC_CALLBACK * GC_push_other_roots_proc)(void); -GC_API void GC_CALL GC_set_push_other_roots(GC_push_other_roots_proc); -GC_API GC_push_other_roots_proc GC_CALL GC_get_push_other_roots(void); - -#ifdef __cplusplus - } /* end of extern "C" */ -#endif - -#endif /* GC_MARK_H */ diff -Nru ecl-16.1.2/src/bdwgc/include/gc_pthread_redirects.h ecl-16.1.3+ds/src/bdwgc/include/gc_pthread_redirects.h --- ecl-16.1.2/src/bdwgc/include/gc_pthread_redirects.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/gc_pthread_redirects.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,97 +0,0 @@ -/* - * Copyright (c) 1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996 by Silicon Graphics. All rights reserved. - * Copyright (c) 1998 by Fergus Henderson. All rights reserved. - * Copyright (c) 2000-2010 by Hewlett-Packard Development Company. - * All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -/* Our pthread support normally needs to intercept a number of thread */ -/* calls. We arrange to do that here, if appropriate. */ - -/* Included from gc.h only. Included only if GC_PTHREADS. */ -#if defined(GC_H) && defined(GC_PTHREADS) - -/* We need to intercept calls to many of the threads primitives, so */ -/* that we can locate thread stacks and stop the world. */ -/* Note also that the collector cannot always see thread specific data. */ -/* Thread specific data should generally consist of pointers to */ -/* uncollectible objects (allocated with GC_malloc_uncollectable, */ -/* not the system malloc), which are deallocated using the destructor */ -/* facility in thr_keycreate. Alternatively, keep a redundant pointer */ -/* to thread specific data on the thread stack. */ - -#ifndef GC_PTHREAD_REDIRECTS_ONLY -# include - -# ifndef GC_NO_DLOPEN -# include - GC_API void *GC_dlopen(const char * /* path */, int /* mode */); -# endif /* !GC_NO_DLOPEN */ - -# ifndef GC_NO_PTHREAD_SIGMASK -# include - GC_API int GC_pthread_sigmask(int /* how */, const sigset_t *, - sigset_t * /* oset */); -# endif /* !GC_NO_PTHREAD_SIGMASK */ - -# ifndef GC_PTHREAD_CREATE_CONST - /* This is used for pthread_create() only. */ -# define GC_PTHREAD_CREATE_CONST const -# endif - - GC_API int GC_pthread_create(pthread_t *, - GC_PTHREAD_CREATE_CONST pthread_attr_t *, - void *(*)(void *), void * /* arg */); - GC_API int GC_pthread_join(pthread_t, void ** /* retval */); - GC_API int GC_pthread_detach(pthread_t); - -# ifndef GC_NO_PTHREAD_CANCEL - GC_API int GC_pthread_cancel(pthread_t); -# endif - -# if defined(GC_PTHREAD_EXIT_ATTRIBUTE) && !defined(GC_PTHREAD_EXIT_DECLARED) -# define GC_PTHREAD_EXIT_DECLARED - GC_API void GC_pthread_exit(void *) GC_PTHREAD_EXIT_ATTRIBUTE; -# endif -#endif /* !GC_PTHREAD_REDIRECTS_ONLY */ - -#if !defined(GC_NO_THREAD_REDIRECTS) && !defined(GC_USE_LD_WRAP) - /* Unless the compiler supports #pragma extern_prefix, the Tru64 */ - /* UNIX redefines some POSIX thread functions to use */ - /* mangled names. Anyway, it's safe to undef them before redefining. */ -# undef pthread_create -# undef pthread_join -# undef pthread_detach -# define pthread_create GC_pthread_create -# define pthread_join GC_pthread_join -# define pthread_detach GC_pthread_detach - -# ifndef GC_NO_PTHREAD_SIGMASK -# undef pthread_sigmask -# define pthread_sigmask GC_pthread_sigmask -# endif -# ifndef GC_NO_DLOPEN -# undef dlopen -# define dlopen GC_dlopen -# endif -# ifndef GC_NO_PTHREAD_CANCEL -# undef pthread_cancel -# define pthread_cancel GC_pthread_cancel -# endif -# ifdef GC_PTHREAD_EXIT_ATTRIBUTE -# undef pthread_exit -# define pthread_exit GC_pthread_exit -# endif -#endif /* !GC_NO_THREAD_REDIRECTS */ - -#endif /* GC_PTHREADS */ diff -Nru ecl-16.1.2/src/bdwgc/include/gc_tiny_fl.h ecl-16.1.3+ds/src/bdwgc/include/gc_tiny_fl.h --- ecl-16.1.2/src/bdwgc/include/gc_tiny_fl.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/gc_tiny_fl.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,90 +0,0 @@ -/* - * Copyright (c) 1999-2005 Hewlett-Packard Development Company, L.P. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#ifndef GC_TINY_FL_H -#define GC_TINY_FL_H -/* - * Constants and data structures for "tiny" free lists. - * These are used for thread-local allocation or in-lined allocators. - * Each global free list also essentially starts with one of these. - * However, global free lists are known to the GC. "Tiny" free lists - * are basically private to the client. Their contents are viewed as - * "in use" and marked accordingly by the core of the GC. - * - * Note that inlined code might know about the layout of these and the constants - * involved. Thus any change here may invalidate clients, and such changes should - * be avoided. Hence we keep this as simple as possible. - */ - -/* - * We always set GC_GRANULE_BYTES to twice the length of a pointer. - * This means that all allocation requests are rounded up to the next - * multiple of 16 on 64-bit architectures or 8 on 32-bit architectures. - * This appears to be a reasonable compromise between fragmentation overhead - * and space usage for mark bits (usually mark bytes). - * On many 64-bit architectures some memory references require 16-byte - * alignment, making this necessary anyway. - * For a few 32-bit architecture (e.g. x86), we may also need 16-byte alignment - * for certain memory references. But currently that does not seem to be the - * default for all conventional malloc implementations, so we ignore that - * problem. - * It would always be safe, and often useful, to be able to allocate very - * small objects with smaller alignment. But that would cost us mark bit - * space, so we no longer do so. - */ -#ifndef GC_GRANULE_BYTES - /* GC_GRANULE_BYTES should not be overridden in any instances of the GC */ - /* library that may be shared between applications, since it affects */ - /* the binary interface to the library. */ -# if defined(__LP64__) || defined (_LP64) || defined(_WIN64) \ - || defined(__s390x__) \ - || (defined(__x86_64__) && !defined(__ILP32__)) \ - || defined(__alpha__) || defined(__powerpc64__) \ - || defined(__arch64__) -# define GC_GRANULE_BYTES 16 -# define GC_GRANULE_WORDS 2 -# else -# define GC_GRANULE_BYTES 8 -# define GC_GRANULE_WORDS 2 -# endif -#endif /* !GC_GRANULE_BYTES */ - -#if GC_GRANULE_WORDS == 2 -# define GC_WORDS_TO_GRANULES(n) ((n)>>1) -#else -# define GC_WORDS_TO_GRANULES(n) ((n)*sizeof(void *)/GC_GRANULE_BYTES) -#endif - -/* A "tiny" free list header contains TINY_FREELISTS pointers to */ -/* singly linked lists of objects of different sizes, the ith one */ -/* containing objects i granules in size. Note that there is a list */ -/* of size zero objects. */ -#ifndef GC_TINY_FREELISTS -# if GC_GRANULE_BYTES == 16 -# define GC_TINY_FREELISTS 25 -# else -# define GC_TINY_FREELISTS 33 /* Up to and including 256 bytes */ -# endif -#endif /* !GC_TINY_FREELISTS */ - -/* The ith free list corresponds to size i*GC_GRANULE_BYTES */ -/* Internally to the collector, the index can be computed with */ -/* ROUNDED_UP_GRANULES. Externally, we don't know whether */ -/* DONT_ADD_BYTE_AT_END is set, but the client should know. */ - -/* Convert a free list index to the actual size of objects */ -/* on that list, including extra space we added. Not an */ -/* inverse of the above. */ -#define GC_RAW_BYTES_FROM_INDEX(i) ((i) * GC_GRANULE_BYTES) - -#endif /* GC_TINY_FL_H */ diff -Nru ecl-16.1.2/src/bdwgc/include/gc_typed.h ecl-16.1.3+ds/src/bdwgc/include/gc_typed.h --- ecl-16.1.2/src/bdwgc/include/gc_typed.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/gc_typed.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,117 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright 1996 Silicon Graphics. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -/* - * Some simple primitives for allocation with explicit type information. - * Facilities for dynamic type inference may be added later. - * Should be used only for extremely performance critical applications, - * or if conservative collector leakage is otherwise a problem (unlikely). - * Note that this is implemented completely separately from the rest - * of the collector, and is not linked in unless referenced. - * This does not currently support GC_DEBUG in any interesting way. - */ - -#ifndef GC_TYPED_H -#define GC_TYPED_H - -#ifndef GC_H -# include "gc.h" -#endif - -#ifdef __cplusplus - extern "C" { -#endif - -typedef GC_word * GC_bitmap; - /* The least significant bit of the first word is one if */ - /* the first word in the object may be a pointer. */ - -#define GC_WORDSZ (8 * sizeof(GC_word)) -#define GC_get_bit(bm, index) \ - (((bm)[(index) / GC_WORDSZ] >> ((index) % GC_WORDSZ)) & 1) -#define GC_set_bit(bm, index) \ - ((bm)[(index) / GC_WORDSZ] |= (GC_word)1 << ((index) % GC_WORDSZ)) -#define GC_WORD_OFFSET(t, f) (offsetof(t,f) / sizeof(GC_word)) -#define GC_WORD_LEN(t) (sizeof(t) / sizeof(GC_word)) -#define GC_BITMAP_SIZE(t) ((GC_WORD_LEN(t) + GC_WORDSZ - 1) / GC_WORDSZ) - -typedef GC_word GC_descr; - -GC_API GC_descr GC_CALL GC_make_descriptor(const GC_word * /* GC_bitmap bm */, - size_t /* len */); - /* Return a type descriptor for the object whose layout */ - /* is described by the argument. */ - /* The least significant bit of the first word is one */ - /* if the first word in the object may be a pointer. */ - /* The second argument specifies the number of */ - /* meaningful bits in the bitmap. The actual object */ - /* may be larger (but not smaller). Any additional */ - /* words in the object are assumed not to contain */ - /* pointers. */ - /* Returns a conservative approximation in the */ - /* (unlikely) case of insufficient memory to build */ - /* the descriptor. Calls to GC_make_descriptor */ - /* may consume some amount of a finite resource. This */ - /* is intended to be called once per type, not once */ - /* per allocation. */ - -/* It is possible to generate a descriptor for a C type T with */ -/* word aligned pointer fields f1, f2, ... as follows: */ -/* */ -/* GC_descr T_descr; */ -/* GC_word T_bitmap[GC_BITMAP_SIZE(T)] = {0}; */ -/* GC_set_bit(T_bitmap, GC_WORD_OFFSET(T,f1)); */ -/* GC_set_bit(T_bitmap, GC_WORD_OFFSET(T,f2)); */ -/* ... */ -/* T_descr = GC_make_descriptor(T_bitmap, GC_WORD_LEN(T)); */ - -GC_API GC_ATTR_MALLOC GC_ATTR_ALLOC_SIZE(1) void * GC_CALL - GC_malloc_explicitly_typed(size_t /* size_in_bytes */, - GC_descr /* d */); - /* Allocate an object whose layout is described by d. */ - /* The resulting object MAY NOT BE PASSED TO REALLOC. */ - /* The returned object is cleared. */ - -GC_API GC_ATTR_MALLOC GC_ATTR_ALLOC_SIZE(1) void * GC_CALL - GC_malloc_explicitly_typed_ignore_off_page(size_t /* size_in_bytes */, - GC_descr /* d */); - -GC_API GC_ATTR_MALLOC void * GC_CALL - GC_calloc_explicitly_typed(size_t /* nelements */, - size_t /* element_size_in_bytes */, - GC_descr /* d */); - /* Allocate an array of nelements elements, each of the */ - /* given size, and with the given descriptor. */ - /* The element size must be a multiple of the byte */ - /* alignment required for pointers. E.g. on a 32-bit */ - /* machine with 16-bit aligned pointers, size_in_bytes */ - /* must be a multiple of 2. */ - /* Returned object is cleared. */ - -#ifdef GC_DEBUG -# define GC_MALLOC_EXPLICITLY_TYPED(bytes, d) GC_MALLOC(bytes) -# define GC_CALLOC_EXPLICITLY_TYPED(n, bytes, d) GC_MALLOC((n) * (bytes)) -#else -# define GC_MALLOC_EXPLICITLY_TYPED(bytes, d) \ - GC_malloc_explicitly_typed(bytes, d) -# define GC_CALLOC_EXPLICITLY_TYPED(n, bytes, d) \ - GC_calloc_explicitly_typed(n, bytes, d) -#endif - -#ifdef __cplusplus - } /* matches extern "C" */ -#endif - -#endif /* GC_TYPED_H */ diff -Nru ecl-16.1.2/src/bdwgc/include/gc_version.h ecl-16.1.3+ds/src/bdwgc/include/gc_version.h --- ecl-16.1.2/src/bdwgc/include/gc_version.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/gc_version.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,47 +0,0 @@ -/* - * Copyright (c) 1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996 by Silicon Graphics. All rights reserved. - * Copyright (c) 1998 by Fergus Henderson. All rights reserved. - * Copyright (c) 2000-2009 by Hewlett-Packard Development Company. - * All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -/* This should never be included directly; it is included only from gc.h. */ -#if defined(GC_H) - -/* The policy regarding version numbers: development code has odd */ -/* "minor" number (and "micro" part is 0); when development is finished */ -/* and a release is prepared, "minor" number is incremented (keeping */ -/* "micro" number still zero), whenever a defect is fixed a new release */ -/* is prepared incrementing "micro" part to odd value (the most stable */ -/* release has the biggest "micro" number). */ - -/* The version here should match that in configure/configure.ac */ -/* Eventually this one may become unnecessary. For now we need */ -/* it to keep the old-style build process working. */ -#define GC_TMP_VERSION_MAJOR 7 -#define GC_TMP_VERSION_MINOR 5 -#define GC_TMP_VERSION_MICRO 0 /* 7.5.0 */ - -#ifdef GC_VERSION_MAJOR -# if GC_TMP_VERSION_MAJOR != GC_VERSION_MAJOR \ - || GC_TMP_VERSION_MINOR != GC_VERSION_MINOR \ - || GC_TMP_VERSION_MICRO != GC_VERSION_MICRO -# error Inconsistent version info. Check README.md, include/gc_version.h and configure.ac. -# endif -#else -# define GC_VERSION_MAJOR GC_TMP_VERSION_MAJOR -# define GC_VERSION_MINOR GC_TMP_VERSION_MINOR -# define GC_VERSION_MICRO GC_TMP_VERSION_MICRO -#endif /* !GC_VERSION_MAJOR */ - -#endif diff -Nru ecl-16.1.2/src/bdwgc/include/include.am ecl-16.1.3+ds/src/bdwgc/include/include.am --- ecl-16.1.2/src/bdwgc/include/include.am 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/include.am 1970-01-01 00:00:00.000000000 +0000 @@ -1,55 +0,0 @@ -# -# THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED -# OR IMPLIED. ANY USE IS AT YOUR OWN RISK. -# -# Permission is hereby granted to use or copy this program -# for any purpose, provided the above notices are retained on all copies. -# Permission to modify the code and to distribute modified code is granted, -# provided the above notices are retained, and a notice that the code was -# modified is included with the above copyright notice. - -## Process this file with automake to produce part of Makefile.in. - -# installed headers -# -pkginclude_HEADERS += \ - include/gc.h \ - include/gc_allocator.h \ - include/gc_backptr.h \ - include/gc_config_macros.h \ - include/gc_disclaim.h \ - include/gc_gcj.h \ - include/gc_inline.h \ - include/gc_mark.h \ - include/gc_pthread_redirects.h \ - include/gc_tiny_fl.h \ - include/gc_typed.h \ - include/gc_version.h \ - include/javaxfc.h \ - include/leak_detector.h \ - include/weakpointer.h - -# headers which are not installed -# -dist_noinst_HEADERS += \ - include/cord.h \ - include/cord_pos.h \ - include/ec.h \ - include/new_gc_alloc.h \ - include/private/darwin_semaphore.h \ - include/private/darwin_stop_world.h \ - include/private/dbg_mlc.h \ - include/private/gc_hdrs.h \ - include/private/gc_locks.h \ - include/private/gc_pmark.h \ - include/private/gc_priv.h \ - include/private/gcconfig.h \ - include/private/msvc_dbg.h \ - include/private/pthread_stop_world.h \ - include/private/pthread_support.h \ - include/private/specific.h \ - include/private/thread_local_alloc.h - -# unprefixed header -include_HEADERS += \ - include/extra/gc.h diff -Nru ecl-16.1.2/src/bdwgc/include/javaxfc.h ecl-16.1.3+ds/src/bdwgc/include/javaxfc.h --- ecl-16.1.2/src/bdwgc/include/javaxfc.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/javaxfc.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,45 +0,0 @@ -/* - * Copyright (c) 1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996 by Silicon Graphics. All rights reserved. - * Copyright (c) 1998 by Fergus Henderson. All rights reserved. - * Copyright (c) 2000-2009 by Hewlett-Packard Development Company. - * All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#ifndef GC_H -# include "gc.h" -#endif - -#ifdef __cplusplus - extern "C" { -#endif - -/* - * Invoke all remaining finalizers that haven't yet been run. (Since the - * notifier is not called, this should be called from a separate thread.) - * This function is needed for strict compliance with the Java standard, - * which can make the runtime guarantee that all finalizers are run. - * This is problematic for several reasons: - * 1) It means that finalizers, and all methods called by them, - * must be prepared to deal with objects that have been finalized in - * spite of the fact that they are still referenced by statically - * allocated pointer variables. - * 1) It may mean that we get stuck in an infinite loop running - * finalizers which create new finalizable objects, though that's - * probably unlikely. - * Thus this is not recommended for general use. - */ -GC_API void GC_CALL GC_finalize_all(void); - -#ifdef __cplusplus - } /* end of extern "C" */ -#endif diff -Nru ecl-16.1.2/src/bdwgc/include/leak_detector.h ecl-16.1.3+ds/src/bdwgc/include/leak_detector.h --- ecl-16.1.2/src/bdwgc/include/leak_detector.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/leak_detector.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,68 +0,0 @@ -/* - * Copyright (c) 2000-2011 by Hewlett-Packard Development Company. - * All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#ifndef GC_LEAK_DETECTOR_H -#define GC_LEAK_DETECTOR_H - -/* Include leak_detector.h (e.g., via GCC --include directive) */ -/* to turn BoehmGC into a Leak Detector. */ - -#ifndef GC_DEBUG -# define GC_DEBUG -#endif -#include "gc.h" - -#ifndef GC_DONT_INCLUDE_STDLIB - /* We ensure stdlib.h and string.h are included before */ - /* redirecting malloc() and the accompanying functions. */ -# include -# include -#endif - -#undef malloc -#define malloc(n) GC_MALLOC(n) -#undef calloc -#define calloc(m,n) GC_MALLOC((m)*(n)) -#undef free -#define free(p) GC_FREE(p) -#undef realloc -#define realloc(p,n) GC_REALLOC(p,n) - -#undef strdup -#define strdup(s) GC_STRDUP(s) -#undef strndup -#define strndup(s,n) GC_STRNDUP(s,n) - -#ifdef GC_REQUIRE_WCSDUP - /* The collector should be built with GC_REQUIRE_WCSDUP */ - /* defined as well to redirect wcsdup(). */ -# include -# undef wcsdup -# define wcsdup(s) GC_WCSDUP(s) -#endif - -#undef memalign -#define memalign(a,n) GC_memalign(a,n) -#undef posix_memalign -#define posix_memalign(p,a,n) GC_posix_memalign(p,a,n) - -#ifndef CHECK_LEAKS -# define CHECK_LEAKS() GC_gcollect() - /* Note 1: CHECK_LEAKS does not have GC prefix (preserved for */ - /* backward compatibility). */ - /* Note 2: GC_gcollect() is also called automatically in the */ - /* leak-finding mode at program exit. */ -#endif - -#endif /* GC_LEAK_DETECTOR_H */ diff -Nru ecl-16.1.2/src/bdwgc/include/new_gc_alloc.h ecl-16.1.3+ds/src/bdwgc/include/new_gc_alloc.h --- ecl-16.1.2/src/bdwgc/include/new_gc_alloc.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/new_gc_alloc.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,480 +0,0 @@ -/* - * Copyright (c) 1996-1998 by Silicon Graphics. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -// -// This is a revision of gc_alloc.h for SGI STL versions > 3.0 -// Unlike earlier versions, it supplements the standard "alloc.h" -// instead of replacing it. -// -// This is sloppy about variable names used in header files. -// It also doesn't yet understand the new header file names or -// namespaces. -// -// This assumes the collector has been compiled with -DATOMIC_UNCOLLECTABLE. -// The user should also consider -DREDIRECT_MALLOC=GC_uncollectable_malloc, -// to ensure that object allocated through malloc are traced. -// -// Some of this could be faster in the explicit deallocation case. -// In particular, we spend too much time clearing objects on the -// free lists. That could be avoided. -// -// This uses template classes with static members, and hence does not work -// with g++ 2.7.2 and earlier. -// -// Unlike its predecessor, this one simply defines -// gc_alloc -// single_client_gc_alloc -// traceable_alloc -// single_client_traceable_alloc -// -// It does not redefine alloc. Nor does it change the default allocator, -// though the user may wish to do so. (The argument against changing -// the default allocator is that it may introduce subtle link compatibility -// problems. The argument for changing it is that the usual default -// allocator is usually a very bad choice for a garbage collected environment.) -// - -#ifndef GC_ALLOC_H - -#include "gc.h" - -#if (__GNUC__ < 3) -# include // A more portable way to get stl_alloc.h . -#else -# include -# ifndef __STL_BEGIN_NAMESPACE -# define __STL_BEGIN_NAMESPACE namespace std { -# define __STL_END_NAMESPACE }; -# endif -#ifndef __STL_USE_STD_ALLOCATORS -#define __STL_USE_STD_ALLOCATORS -#endif -#endif - -/* A hack to deal with gcc 3.1. If you are using gcc3.1 and later, */ -/* you should probably really use gc_allocator.h instead. */ -#if defined (__GNUC__) && \ - (__GNUC__ > 3 || (__GNUC__ == 3 && (__GNUC_MINOR__ >= 1))) -# define simple_alloc __simple_alloc -#endif - -#define GC_ALLOC_H - -#include -#include - -// The following need to match collector data structures. -// We can't include gc_priv.h, since that pulls in way too much stuff. -// This should eventually be factored out into another include file. - -extern "C" { - GC_API void ** const GC_objfreelist_ptr; - GC_API void ** const GC_aobjfreelist_ptr; - GC_API void ** const GC_uobjfreelist_ptr; - GC_API void ** const GC_auobjfreelist_ptr; - - GC_API void GC_CALL GC_incr_bytes_allocd(size_t bytes); - GC_API void GC_CALL GC_incr_bytes_freed(size_t bytes); - - GC_API char * GC_CALL GC_generic_malloc_words_small(size_t word, int kind); - /* FIXME: Doesn't exist anymore. */ -} - -// Object kinds; must match PTRFREE, NORMAL, UNCOLLECTABLE, and -// AUNCOLLECTABLE in gc_priv.h. - -enum { GC_PTRFREE = 0, GC_NORMAL = 1, GC_UNCOLLECTABLE = 2, - GC_AUNCOLLECTABLE = 3 }; - -enum { GC_max_fast_bytes = 255 }; - -enum { GC_bytes_per_word = sizeof(char *) }; - -enum { GC_byte_alignment = 8 }; - -enum { GC_word_alignment = GC_byte_alignment/GC_bytes_per_word }; - -inline void * &GC_obj_link(void * p) -{ return *reinterpret_cast(p); } - -// Compute a number of words >= n+1 bytes. -// The +1 allows for pointers one past the end. -inline size_t GC_round_up(size_t n) -{ - return ((n + GC_byte_alignment)/GC_byte_alignment)*GC_word_alignment; -} - -// The same but don't allow for extra byte. -inline size_t GC_round_up_uncollectable(size_t n) -{ - return ((n + GC_byte_alignment - 1)/GC_byte_alignment)*GC_word_alignment; -} - -template -class GC_aux_template { -public: - // File local count of allocated words. Occasionally this is - // added into the global count. A separate count is necessary since the - // real one must be updated with a procedure call. - static size_t GC_bytes_recently_allocd; - - // Same for uncollectible memory. Not yet reflected in either - // GC_bytes_recently_allocd or GC_non_gc_bytes. - static size_t GC_uncollectable_bytes_recently_allocd; - - // Similar counter for explicitly deallocated memory. - static size_t GC_bytes_recently_freed; - - // Again for uncollectible memory. - static size_t GC_uncollectable_bytes_recently_freed; - - static void * GC_out_of_line_malloc(size_t nwords, int kind); -}; - -template -size_t GC_aux_template::GC_bytes_recently_allocd = 0; - -template -size_t GC_aux_template::GC_uncollectable_bytes_recently_allocd = 0; - -template -size_t GC_aux_template::GC_bytes_recently_freed = 0; - -template -size_t GC_aux_template::GC_uncollectable_bytes_recently_freed = 0; - -template -void * GC_aux_template::GC_out_of_line_malloc(size_t nwords, int kind) -{ - GC_bytes_recently_allocd += GC_uncollectable_bytes_recently_allocd; - GC_non_gc_bytes += - GC_uncollectable_bytes_recently_allocd; - GC_uncollectable_bytes_recently_allocd = 0; - - GC_bytes_recently_freed += GC_uncollectable_bytes_recently_freed; - GC_non_gc_bytes -= GC_uncollectable_bytes_recently_freed; - GC_uncollectable_bytes_recently_freed = 0; - - GC_incr_bytes_allocd(GC_bytes_recently_allocd); - GC_bytes_recently_allocd = 0; - - GC_incr_bytes_freed(GC_bytes_recently_freed); - GC_bytes_recently_freed = 0; - - return GC_generic_malloc_words_small(nwords, kind); -} - -typedef GC_aux_template<0> GC_aux; - -// A fast, single-threaded, garbage-collected allocator -// We assume the first word will be immediately overwritten. -// In this version, deallocation is not a no-op, and explicit -// deallocation is likely to help performance. -template -class single_client_gc_alloc_template { - public: - static void * allocate(size_t n) - { - size_t nwords = GC_round_up(n); - void ** flh; - void * op; - - if (n > GC_max_fast_bytes) return GC_malloc(n); - flh = GC_objfreelist_ptr + nwords; - if (0 == (op = *flh)) { - return GC_aux::GC_out_of_line_malloc(nwords, GC_NORMAL); - } - *flh = GC_obj_link(op); - GC_aux::GC_bytes_recently_allocd += nwords * GC_bytes_per_word; - return op; - } - static void * ptr_free_allocate(size_t n) - { - size_t nwords = GC_round_up(n); - void ** flh; - void * op; - - if (n > GC_max_fast_bytes) return GC_malloc_atomic(n); - flh = GC_aobjfreelist_ptr + nwords; - if (0 == (op = *flh)) { - return GC_aux::GC_out_of_line_malloc(nwords, GC_PTRFREE); - } - *flh = GC_obj_link(op); - GC_aux::GC_bytes_recently_allocd += nwords * GC_bytes_per_word; - return op; - } - static void deallocate(void *p, size_t n) - { - size_t nwords = GC_round_up(n); - void ** flh; - - if (n > GC_max_fast_bytes) { - GC_free(p); - } else { - flh = GC_objfreelist_ptr + nwords; - GC_obj_link(p) = *flh; - memset(reinterpret_cast(p) + GC_bytes_per_word, 0, - GC_bytes_per_word * (nwords - 1)); - *flh = p; - GC_aux::GC_bytes_recently_freed += nwords * GC_bytes_per_word; - } - } - static void ptr_free_deallocate(void *p, size_t n) - { - size_t nwords = GC_round_up(n); - void ** flh; - - if (n > GC_max_fast_bytes) { - GC_free(p); - } else { - flh = GC_aobjfreelist_ptr + nwords; - GC_obj_link(p) = *flh; - *flh = p; - GC_aux::GC_bytes_recently_freed += nwords * GC_bytes_per_word; - } - } -}; - -typedef single_client_gc_alloc_template<0> single_client_gc_alloc; - -// Once more, for uncollectible objects. -template -class single_client_traceable_alloc_template { - public: - static void * allocate(size_t n) - { - size_t nwords = GC_round_up_uncollectable(n); - void ** flh; - void * op; - - if (n > GC_max_fast_bytes) return GC_malloc_uncollectable(n); - flh = GC_uobjfreelist_ptr + nwords; - if (0 == (op = *flh)) { - return GC_aux::GC_out_of_line_malloc(nwords, GC_UNCOLLECTABLE); - } - *flh = GC_obj_link(op); - GC_aux::GC_uncollectable_bytes_recently_allocd += - nwords * GC_bytes_per_word; - return op; - } - static void * ptr_free_allocate(size_t n) - { - size_t nwords = GC_round_up_uncollectable(n); - void ** flh; - void * op; - - if (n > GC_max_fast_bytes) return GC_malloc_atomic_uncollectable(n); - flh = GC_auobjfreelist_ptr + nwords; - if (0 == (op = *flh)) { - return GC_aux::GC_out_of_line_malloc(nwords, GC_AUNCOLLECTABLE); - } - *flh = GC_obj_link(op); - GC_aux::GC_uncollectable_bytes_recently_allocd += - nwords * GC_bytes_per_word; - return op; - } - static void deallocate(void *p, size_t n) - { - size_t nwords = GC_round_up_uncollectable(n); - void ** flh; - - if (n > GC_max_fast_bytes) { - GC_free(p); - } else { - flh = GC_uobjfreelist_ptr + nwords; - GC_obj_link(p) = *flh; - *flh = p; - GC_aux::GC_uncollectable_bytes_recently_freed += - nwords * GC_bytes_per_word; - } - } - static void ptr_free_deallocate(void *p, size_t n) - { - size_t nwords = GC_round_up_uncollectable(n); - void ** flh; - - if (n > GC_max_fast_bytes) { - GC_free(p); - } else { - flh = GC_auobjfreelist_ptr + nwords; - GC_obj_link(p) = *flh; - *flh = p; - GC_aux::GC_uncollectable_bytes_recently_freed += - nwords * GC_bytes_per_word; - } - } -}; - -typedef single_client_traceable_alloc_template<0> single_client_traceable_alloc; - -template < int dummy > -class gc_alloc_template { - public: - static void * allocate(size_t n) { return GC_malloc(n); } - static void * ptr_free_allocate(size_t n) - { return GC_malloc_atomic(n); } - static void deallocate(void *, size_t) { } - static void ptr_free_deallocate(void *, size_t) { } -}; - -typedef gc_alloc_template < 0 > gc_alloc; - -template < int dummy > -class traceable_alloc_template { - public: - static void * allocate(size_t n) { return GC_malloc_uncollectable(n); } - static void * ptr_free_allocate(size_t n) - { return GC_malloc_atomic_uncollectable(n); } - static void deallocate(void *p, size_t) { GC_free(p); } - static void ptr_free_deallocate(void *p, size_t) { GC_free(p); } -}; - -typedef traceable_alloc_template < 0 > traceable_alloc; - -// We want to specialize simple_alloc so that it does the right thing -// for all pointer-free types. At the moment there is no portable way to -// even approximate that. The following approximation should work for -// SGI compilers, and recent versions of g++. - -// GC_SPECIALIZE() is used internally. -#define GC_SPECIALIZE(T,alloc) \ - class simple_alloc { \ - public: \ - static T *allocate(size_t n) \ - { return 0 == n? 0 : \ - reinterpret_cast(alloc::ptr_free_allocate(n * sizeof(T))); } \ - static T *allocate(void) \ - { return reinterpret_cast(alloc::ptr_free_allocate(sizeof(T))); } \ - static void deallocate(T *p, size_t n) \ - { if (0 != n) alloc::ptr_free_deallocate(p, n * sizeof(T)); } \ - static void deallocate(T *p) \ - { alloc::ptr_free_deallocate(p, sizeof(T)); } \ - }; - -__STL_BEGIN_NAMESPACE - -GC_SPECIALIZE(char, gc_alloc) -GC_SPECIALIZE(int, gc_alloc) -GC_SPECIALIZE(unsigned, gc_alloc) -GC_SPECIALIZE(float, gc_alloc) -GC_SPECIALIZE(double, gc_alloc) - -GC_SPECIALIZE(char, traceable_alloc) -GC_SPECIALIZE(int, traceable_alloc) -GC_SPECIALIZE(unsigned, traceable_alloc) -GC_SPECIALIZE(float, traceable_alloc) -GC_SPECIALIZE(double, traceable_alloc) - -GC_SPECIALIZE(char, single_client_gc_alloc) -GC_SPECIALIZE(int, single_client_gc_alloc) -GC_SPECIALIZE(unsigned, single_client_gc_alloc) -GC_SPECIALIZE(float, single_client_gc_alloc) -GC_SPECIALIZE(double, single_client_gc_alloc) - -GC_SPECIALIZE(char, single_client_traceable_alloc) -GC_SPECIALIZE(int, single_client_traceable_alloc) -GC_SPECIALIZE(unsigned, single_client_traceable_alloc) -GC_SPECIALIZE(float, single_client_traceable_alloc) -GC_SPECIALIZE(double, single_client_traceable_alloc) - -__STL_END_NAMESPACE - -#ifdef __STL_USE_STD_ALLOCATORS - -__STL_BEGIN_NAMESPACE - -template -struct _Alloc_traits<_Tp, gc_alloc > -{ - static const bool _S_instanceless = true; - typedef simple_alloc<_Tp, gc_alloc > _Alloc_type; - typedef __allocator<_Tp, gc_alloc > allocator_type; -}; - -inline bool operator==(const gc_alloc&, - const gc_alloc&) -{ - return true; -} - -inline bool operator!=(const gc_alloc&, - const gc_alloc&) -{ - return false; -} - -template -struct _Alloc_traits<_Tp, single_client_gc_alloc > -{ - static const bool _S_instanceless = true; - typedef simple_alloc<_Tp, single_client_gc_alloc > _Alloc_type; - typedef __allocator<_Tp, single_client_gc_alloc > allocator_type; -}; - -inline bool operator==(const single_client_gc_alloc&, - const single_client_gc_alloc&) -{ - return true; -} - -inline bool operator!=(const single_client_gc_alloc&, - const single_client_gc_alloc&) -{ - return false; -} - -template -struct _Alloc_traits<_Tp, traceable_alloc > -{ - static const bool _S_instanceless = true; - typedef simple_alloc<_Tp, traceable_alloc > _Alloc_type; - typedef __allocator<_Tp, traceable_alloc > allocator_type; -}; - -inline bool operator==(const traceable_alloc&, - const traceable_alloc&) -{ - return true; -} - -inline bool operator!=(const traceable_alloc&, - const traceable_alloc&) -{ - return false; -} - -template -struct _Alloc_traits<_Tp, single_client_traceable_alloc > -{ - static const bool _S_instanceless = true; - typedef simple_alloc<_Tp, single_client_traceable_alloc > _Alloc_type; - typedef __allocator<_Tp, single_client_traceable_alloc > allocator_type; -}; - -inline bool operator==(const single_client_traceable_alloc&, - const single_client_traceable_alloc&) -{ - return true; -} - -inline bool operator!=(const single_client_traceable_alloc&, - const single_client_traceable_alloc&) -{ - return false; -} - -__STL_END_NAMESPACE - -#endif /* __STL_USE_STD_ALLOCATORS */ - -#endif /* GC_ALLOC_H */ diff -Nru ecl-16.1.2/src/bdwgc/include/private/darwin_semaphore.h ecl-16.1.3+ds/src/bdwgc/include/private/darwin_semaphore.h --- ecl-16.1.2/src/bdwgc/include/private/darwin_semaphore.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/private/darwin_semaphore.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,80 +0,0 @@ -/* - * Copyright (c) 1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996 by Silicon Graphics. All rights reserved. - * Copyright (c) 1998 by Fergus Henderson. All rights reserved. - * Copyright (c) 2000-2009 by Hewlett-Packard Development Company. - * All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#ifndef GC_DARWIN_SEMAPHORE_H -#define GC_DARWIN_SEMAPHORE_H - -#if !defined(GC_DARWIN_THREADS) -# error darwin_semaphore.h included with GC_DARWIN_THREADS not defined -#endif - -/* This is a very simple semaphore implementation for Darwin. It is */ -/* implemented in terms of pthread calls so it is not async signal */ -/* safe. But this is not a problem because signals are not used to */ -/* suspend threads on Darwin. */ - -typedef struct { - pthread_mutex_t mutex; - pthread_cond_t cond; - int value; -} sem_t; - -GC_INLINE int sem_init(sem_t *sem, int pshared, int value) { - if (pshared != 0) { - errno = EPERM; /* unsupported */ - return -1; - } - sem->value = value; - if (pthread_mutex_init(&sem->mutex, NULL) != 0) - return -1; - if (pthread_cond_init(&sem->cond, NULL) != 0) { - (void)pthread_mutex_destroy(&sem->mutex); - return -1; - } - return 0; -} - -GC_INLINE int sem_post(sem_t *sem) { - if (pthread_mutex_lock(&sem->mutex) != 0) - return -1; - sem->value++; - if (pthread_cond_signal(&sem->cond) != 0) { - (void)pthread_mutex_unlock(&sem->mutex); - return -1; - } - return pthread_mutex_unlock(&sem->mutex) != 0 ? -1 : 0; -} - -GC_INLINE int sem_wait(sem_t *sem) { - if (pthread_mutex_lock(&sem->mutex) != 0) - return -1; - while (sem->value == 0) { - if (pthread_cond_wait(&sem->cond, &sem->mutex) != 0) { - (void)pthread_mutex_unlock(&sem->mutex); - return -1; - } - } - sem->value--; - return pthread_mutex_unlock(&sem->mutex) != 0 ? -1 : 0; -} - -GC_INLINE int sem_destroy(sem_t *sem) { - return pthread_cond_destroy(&sem->cond) != 0 - || pthread_mutex_destroy(&sem->mutex) != 0 ? -1 : 0; -} - -#endif diff -Nru ecl-16.1.2/src/bdwgc/include/private/darwin_stop_world.h ecl-16.1.3+ds/src/bdwgc/include/private/darwin_stop_world.h --- ecl-16.1.2/src/bdwgc/include/private/darwin_stop_world.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/private/darwin_stop_world.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,46 +0,0 @@ -/* - * Copyright (c) 1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996 by Silicon Graphics. All rights reserved. - * Copyright (c) 1998 by Fergus Henderson. All rights reserved. - * Copyright (c) 2000-2009 by Hewlett-Packard Development Company. - * All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#ifndef GC_DARWIN_STOP_WORLD_H -#define GC_DARWIN_STOP_WORLD_H - -#if !defined(GC_DARWIN_THREADS) -# error darwin_stop_world.h included without GC_DARWIN_THREADS defined -#endif - -#include -#include - -struct thread_stop_info { - mach_port_t mach_thread; - ptr_t stack_ptr; /* Valid only when thread is in a "blocked" state. */ -}; - -#ifndef DARWIN_DONT_PARSE_STACK - GC_INNER ptr_t GC_FindTopOfStack(unsigned long); -#endif - -#ifdef MPROTECT_VDB - GC_INNER void GC_mprotect_stop(void); - GC_INNER void GC_mprotect_resume(void); -#endif - -#if defined(PARALLEL_MARK) && !defined(GC_NO_THREADS_DISCOVERY) - GC_INNER GC_bool GC_is_mach_marker(thread_act_t); -#endif - -#endif diff -Nru ecl-16.1.2/src/bdwgc/include/private/dbg_mlc.h ecl-16.1.3+ds/src/bdwgc/include/private/dbg_mlc.h --- ecl-16.1.2/src/bdwgc/include/private/dbg_mlc.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/private/dbg_mlc.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,166 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1995 by Xerox Corporation. All rights reserved. - * Copyright (c) 1997 by Silicon Graphics. All rights reserved. - * Copyright (c) 1999 by Hewlett-Packard Company. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -/* - * This is mostly an internal header file. Typical clients should - * not use it. Clients that define their own object kinds with - * debugging allocators will probably want to include this, however. - * No attempt is made to keep the namespace clean. This should not be - * included from header files that are frequently included by clients. - */ - -#ifndef _DBG_MLC_H -#define _DBG_MLC_H - -#include "gc_priv.h" -#ifdef KEEP_BACK_PTRS -# include "gc_backptr.h" -#endif - -#if CPP_WORDSZ == 32 -# define START_FLAG (word)0xfedcedcb -# define END_FLAG (word)0xbcdecdef -#else -# define START_FLAG GC_WORD_C(0xFEDCEDCBfedcedcb) -# define END_FLAG GC_WORD_C(0xBCDECDEFbcdecdef) -#endif - /* Stored both one past the end of user object, and one before */ - /* the end of the object as seen by the allocator. */ - -#if defined(KEEP_BACK_PTRS) || defined(PRINT_BLACK_LIST) \ - || defined(MAKE_BACK_GRAPH) - /* Pointer "source"s that aren't real locations. */ - /* Used in oh_back_ptr fields and as "source" */ - /* argument to some marking functions. */ -# define NOT_MARKED (ptr_t)0 -# define MARKED_FOR_FINALIZATION ((ptr_t)(word)2) - /* Object was marked because it is finalizable. */ -# define MARKED_FROM_REGISTER ((ptr_t)(word)4) - /* Object was marked from a register. Hence the */ - /* source of the reference doesn't have an address. */ -#endif /* KEEP_BACK_PTRS || PRINT_BLACK_LIST */ - -/* Object header */ -typedef struct { -# if defined(KEEP_BACK_PTRS) || defined(MAKE_BACK_GRAPH) - /* We potentially keep two different kinds of back */ - /* pointers. KEEP_BACK_PTRS stores a single back */ - /* pointer in each reachable object to allow reporting */ - /* of why an object was retained. MAKE_BACK_GRAPH */ - /* builds a graph containing the inverse of all */ - /* "points-to" edges including those involving */ - /* objects that have just become unreachable. This */ - /* allows detection of growing chains of unreachable */ - /* objects. It may be possible to eventually combine */ - /* both, but for now we keep them separate. Both */ - /* kinds of back pointers are hidden using the */ - /* following macros. In both cases, the plain version */ - /* is constrained to have an least significant bit of 1, */ - /* to allow it to be distinguished from a free list */ - /* link. This means the plain version must have an */ - /* lsb of 0. */ - /* Note that blocks dropped by black-listing will */ - /* also have the lsb clear once debugging has */ - /* started. */ - /* We're careful never to overwrite a value with lsb 0. */ -# if ALIGNMENT == 1 - /* Fudge back pointer to be even. */ -# define HIDE_BACK_PTR(p) GC_HIDE_POINTER(~1 & (GC_word)(p)) -# else -# define HIDE_BACK_PTR(p) GC_HIDE_POINTER(p) -# endif -# ifdef KEEP_BACK_PTRS - GC_hidden_pointer oh_back_ptr; -# endif -# ifdef MAKE_BACK_GRAPH - GC_hidden_pointer oh_bg_ptr; -# endif -# if defined(KEEP_BACK_PTRS) != defined(MAKE_BACK_GRAPH) - /* Keep double-pointer-sized alignment. */ - word oh_dummy; -# endif -# endif - const char * oh_string; /* object descriptor string */ - word oh_int; /* object descriptor integers */ -# ifdef NEED_CALLINFO - struct callinfo oh_ci[NFRAMES]; -# endif -# ifndef SHORT_DBG_HDRS - word oh_sz; /* Original malloc arg. */ - word oh_sf; /* start flag */ -# endif /* SHORT_DBG_HDRS */ -} oh; -/* The size of the above structure is assumed not to de-align things, */ -/* and to be a multiple of the word length. */ - -#ifdef SHORT_DBG_HDRS -# define DEBUG_BYTES (sizeof (oh)) -# define UNCOLLECTABLE_DEBUG_BYTES DEBUG_BYTES -#else - /* Add space for END_FLAG, but use any extra space that was already */ - /* added to catch off-the-end pointers. */ - /* For uncollectible objects, the extra byte is not added. */ -# define UNCOLLECTABLE_DEBUG_BYTES (sizeof (oh) + sizeof (word)) -# define DEBUG_BYTES (UNCOLLECTABLE_DEBUG_BYTES - EXTRA_BYTES) -#endif - -/* Round bytes to words without adding extra byte at end. */ -#define SIMPLE_ROUNDED_UP_WORDS(n) BYTES_TO_WORDS((n) + WORDS_TO_BYTES(1) - 1) - -/* ADD_CALL_CHAIN stores a (partial) call chain into an object */ -/* header. It may be called with or without the allocation */ -/* lock. */ -/* PRINT_CALL_CHAIN prints the call chain stored in an object */ -/* to stderr. It requires that we do not hold the lock. */ -#if defined(SAVE_CALL_CHAIN) - struct callinfo; - GC_INNER void GC_save_callers(struct callinfo info[NFRAMES]); - GC_INNER void GC_print_callers(struct callinfo info[NFRAMES]); -# define ADD_CALL_CHAIN(base, ra) GC_save_callers(((oh *)(base)) -> oh_ci) -# define PRINT_CALL_CHAIN(base) GC_print_callers(((oh *)(base)) -> oh_ci) -#elif defined(GC_ADD_CALLER) - struct callinfo; - GC_INNER void GC_print_callers(struct callinfo info[NFRAMES]); -# define ADD_CALL_CHAIN(base, ra) ((oh *)(base)) -> oh_ci[0].ci_pc = (ra) -# define PRINT_CALL_CHAIN(base) GC_print_callers(((oh *)(base)) -> oh_ci) -#else -# define ADD_CALL_CHAIN(base, ra) -# define PRINT_CALL_CHAIN(base) -#endif - -#ifdef GC_ADD_CALLER -# define OPT_RA ra, -#else -# define OPT_RA -#endif - -/* Check whether object with base pointer p has debugging info */ -/* p is assumed to point to a legitimate object in our part */ -/* of the heap. */ -#ifdef SHORT_DBG_HDRS -# define GC_has_other_debug_info(p) 1 -#else - GC_INNER int GC_has_other_debug_info(ptr_t p); -#endif - -#if defined(KEEP_BACK_PTRS) || defined(MAKE_BACK_GRAPH) -# define GC_HAS_DEBUG_INFO(p) \ - ((*((word *)p) & 1) && GC_has_other_debug_info(p) > 0) -#else -# define GC_HAS_DEBUG_INFO(p) (GC_has_other_debug_info(p) > 0) -#endif - -#endif /* _DBG_MLC_H */ diff -Nru ecl-16.1.2/src/bdwgc/include/private/gcconfig.h ecl-16.1.3+ds/src/bdwgc/include/private/gcconfig.h --- ecl-16.1.2/src/bdwgc/include/private/gcconfig.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/private/gcconfig.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,3034 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996 by Silicon Graphics. All rights reserved. - * Copyright (c) 2000-2004 Hewlett-Packard Development Company, L.P. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -/* - * This header is private to the gc. It is almost always included from - * gc_priv.h. However it is possible to include it by itself if just the - * configuration macros are needed. In that - * case, a few declarations relying on types declared in gc_priv.h will be - * omitted. - */ - -#ifndef GCCONFIG_H -#define GCCONFIG_H - -# ifndef GC_PRIVATE_H - /* Fake ptr_t declaration, just to avoid compilation errors. */ - /* This avoids many instances if "ifndef GC_PRIVATE_H" below. */ - typedef struct GC_undefined_struct * ptr_t; -# include /* For size_t etc. */ -# endif - -/* Machine dependent parameters. Some tuning parameters can be found */ -/* near the top of gc_private.h. */ - -/* Machine specific parts contributed by various people. See README file. */ - -#if defined(__ANDROID__) && !defined(PLATFORM_ANDROID) - /* __ANDROID__ macro is defined by Android NDK gcc. */ -# define PLATFORM_ANDROID 1 -#endif - -#if defined(__SYMBIAN32__) && !defined(SYMBIAN) -# define SYMBIAN -# ifdef __WINS__ -# pragma data_seg(".data2") -# endif -#endif - -/* First a unified test for Linux: */ -# if (defined(linux) || defined(__linux__) || defined(PLATFORM_ANDROID)) \ - && !defined(LINUX) && !defined(__native_client__) -# define LINUX -# endif - -/* And one for QNX: */ -# if defined(__QNX__) -# define I386 -# define OS_TYPE "QNX" -# define SA_RESTART 0 -# define HEURISTIC1 - extern char etext[]; -# define DATASTART ((ptr_t)(etext)) - extern int _end[]; -# define DATAEND (_end) -# define mach_type_known -# endif - -/* And one for NetBSD: */ -# if defined(__NetBSD__) -# define NETBSD -# endif - -/* And one for OpenBSD: */ -# if defined(__OpenBSD__) -# define OPENBSD -# endif - -/* And one for FreeBSD: */ -# if (defined(__FreeBSD__) || defined(__DragonFly__) \ - || defined(__FreeBSD_kernel__)) && !defined(FREEBSD) -# define FREEBSD -# endif - -/* And one for Darwin: */ -# if defined(macosx) || (defined(__APPLE__) && defined(__MACH__)) -# define DARWIN -# endif - -/* Determine the machine type: */ -# if defined(__native_client__) -# define NACL -# define I386 -# define mach_type_known -# endif -# if defined(__aarch64__) -# define AARCH64 -# if !defined(LINUX) && !defined(DARWIN) -# define NOSYS -# define mach_type_known -# endif -# endif -# if defined(__arm) || defined(__arm__) || defined(__thumb__) -# define ARM32 -# if !defined(LINUX) && !defined(NETBSD) && !defined(FREEBSD) \ - && !defined(OPENBSD) && !defined(DARWIN) \ - && !defined(_WIN32) && !defined(__CEGCC__) && !defined(SYMBIAN) -# define NOSYS -# define mach_type_known -# endif -# endif -# if defined(sun) && defined(mc68000) -# error SUNOS4 no longer supported -# endif -# if defined(hp9000s300) -# error M68K based HP machines no longer supported. -# endif -# if defined(OPENBSD) && defined(m68k) - /* FIXME: Should we remove this case? */ -# define M68K -# define mach_type_known -# endif -# if defined(OPENBSD) && defined(__sparc__) -# define SPARC -# define mach_type_known -# endif -# if defined(OPENBSD) && defined(__arm__) -# define ARM32 -# define mach_type_known -# endif -# if defined(OPENBSD) && defined(__sh__) -# define SH -# define mach_type_known -# endif -# if defined(NETBSD) && (defined(m68k) || defined(__m68k__)) -# define M68K -# define mach_type_known -# endif -# if defined(NETBSD) && defined(__powerpc__) -# define POWERPC -# define mach_type_known -# endif -# if defined(NETBSD) && (defined(__arm32__) || defined(__arm__)) -# define ARM32 -# define mach_type_known -# endif -# if defined(NETBSD) && defined(__sh__) -# define SH -# define mach_type_known -# endif -# if defined(vax) || defined(__vax__) -# define VAX -# ifdef ultrix -# define ULTRIX -# else -# define BSD -# endif -# define mach_type_known -# endif -# if defined(__NetBSD__) && defined(__vax__) -# define VAX -# define mach_type_known -# endif -# if defined(mips) || defined(__mips) || defined(_mips) -# define MIPS -# if defined(nec_ews) || defined(_nec_ews) -# define EWS4800 -# endif -# if !defined(LINUX) && !defined(EWS4800) && !defined(NETBSD) \ - && !defined(OPENBSD) -# if defined(ultrix) || defined(__ultrix) -# define ULTRIX -# else -# define IRIX5 /* or IRIX 6.X */ -# endif -# endif /* !LINUX */ -# if defined(__NetBSD__) && defined(__MIPSEL__) -# undef ULTRIX -# endif -# define mach_type_known -# endif -# if defined(__or1k__) -# define OR1K /* OpenRISC/or1k */ -# define mach_type_known -# endif -# if defined(DGUX) && (defined(i386) || defined(__i386__)) -# define I386 -# ifndef _USING_DGUX -# define _USING_DGUX -# endif -# define mach_type_known -# endif -# if defined(sequent) && (defined(i386) || defined(__i386__)) -# define I386 -# define SEQUENT -# define mach_type_known -# endif -# if defined(sun) && (defined(i386) || defined(__i386__)) -# define I386 -# define SOLARIS -# define mach_type_known -# endif -# if defined(sun) && defined(__amd64) -# define X86_64 -# define SOLARIS -# define mach_type_known -# endif -# if (defined(__OS2__) || defined(__EMX__)) && defined(__32BIT__) -# define I386 -# define OS2 -# define mach_type_known -# endif -# if defined(ibm032) -# error IBM PC/RT no longer supported. -# endif -# if defined(sun) && (defined(sparc) || defined(__sparc)) -# define SPARC - /* Test for SunOS 5.x */ -# include -# define SOLARIS -# define mach_type_known -# endif -# if defined(sparc) && defined(unix) && !defined(sun) && !defined(linux) \ - && !defined(__OpenBSD__) && !defined(__NetBSD__) \ - && !defined(__FreeBSD__) && !defined(__DragonFly__) -# define SPARC -# define DRSNX -# define mach_type_known -# endif -# if defined(_IBMR2) -# define POWERPC -# define AIX -# define mach_type_known -# endif -# if defined(__NetBSD__) && defined(__sparc__) -# define SPARC -# define mach_type_known -# endif -# if defined(_M_XENIX) && defined(_M_SYSV) && defined(_M_I386) - /* The above test may need refinement */ -# define I386 -# if defined(_SCO_ELF) -# define SCO_ELF -# else -# define SCO -# endif -# define mach_type_known -# endif -# if defined(_AUX_SOURCE) -# error A/UX no longer supported -# endif -# if defined(_PA_RISC1_0) || defined(_PA_RISC1_1) || defined(_PA_RISC2_0) \ - || defined(hppa) || defined(__hppa__) -# define HP_PA -# if !defined(LINUX) && !defined(HPUX) && !defined(OPENBSD) -# define HPUX -# endif -# define mach_type_known -# endif -# if defined(__ia64) && (defined(_HPUX_SOURCE) || defined(__HP_aCC)) -# define IA64 -# ifndef HPUX -# define HPUX -# endif -# define mach_type_known -# endif -# if defined(__BEOS__) && defined(_X86_) -# define I386 -# define BEOS -# define mach_type_known -# endif -# if defined(OPENBSD) && defined(__amd64__) -# define X86_64 -# define mach_type_known -# endif -# if defined(LINUX) && (defined(i386) || defined(__i386__)) -# define I386 -# define mach_type_known -# endif -# if defined(LINUX) && defined(__x86_64__) -# define X86_64 -# define mach_type_known -# endif -# if defined(LINUX) && (defined(__ia64__) || defined(__ia64)) -# define IA64 -# define mach_type_known -# endif -# if defined(LINUX) && defined(__aarch64__) -# define AARCH64 -# define mach_type_known -# endif -# if defined(LINUX) && (defined(__arm) || defined(__arm__)) -# define ARM32 -# define mach_type_known -# endif -# if defined(LINUX) && defined(__cris__) -# ifndef CRIS -# define CRIS -# endif -# define mach_type_known -# endif -# if defined(LINUX) && (defined(powerpc) || defined(__powerpc__) \ - || defined(powerpc64) || defined(__powerpc64__)) -# define POWERPC -# define mach_type_known -# endif -# if defined(LINUX) && defined(__mc68000__) -# define M68K -# define mach_type_known -# endif -# if defined(LINUX) && (defined(sparc) || defined(__sparc__)) -# define SPARC -# define mach_type_known -# endif -# if defined(LINUX) && defined(__sh__) -# define SH -# define mach_type_known -# endif -# if defined(LINUX) && defined(__avr32__) -# define AVR32 -# define mach_type_known -# endif -# if defined(LINUX) && defined(__m32r__) -# define M32R -# define mach_type_known -# endif -# if defined(__alpha) || defined(__alpha__) -# define ALPHA -# if !defined(LINUX) && !defined(NETBSD) && !defined(OPENBSD) \ - && !defined(FREEBSD) -# define OSF1 /* a.k.a Digital Unix */ -# endif -# define mach_type_known -# endif -# if defined(_AMIGA) && !defined(AMIGA) -# define AMIGA -# endif -# ifdef AMIGA -# define M68K -# define mach_type_known -# endif -# if defined(THINK_C) \ - || (defined(__MWERKS__) && !defined(__powerc) && !defined(SYMBIAN)) -# define M68K -# define MACOS -# define mach_type_known -# endif -# if defined(__MWERKS__) && defined(__powerc) && !defined(__MACH__) \ - && !defined(SYMBIAN) -# define POWERPC -# define MACOS -# define mach_type_known -# endif -# if defined(__OpenBSD__) && defined(__powerpc__) -# define POWERPC -# define OPENBSD -# define mach_type_known -# endif -# if defined(DARWIN) -# if defined(__ppc__) || defined(__ppc64__) -# define POWERPC -# define mach_type_known -# elif defined(__x86_64__) || defined(__x86_64) -# define X86_64 -# define mach_type_known -# elif defined(__i386__) -# define I386 -# define mach_type_known -# elif defined(__arm__) -# define ARM32 -# define mach_type_known -# define DARWIN_DONT_PARSE_STACK -# elif defined(__aarch64__) -# define AARCH64 -# define mach_type_known -# define DARWIN_DONT_PARSE_STACK -# endif -# endif -# if defined(__rtems__) && (defined(i386) || defined(__i386__)) -# define I386 -# define RTEMS -# define mach_type_known -# endif -# if defined(NeXT) && defined(mc68000) -# define M68K -# define NEXT -# define mach_type_known -# endif -# if defined(NeXT) && (defined(i386) || defined(__i386__)) -# define I386 -# define NEXT -# define mach_type_known -# endif -# if defined(__OpenBSD__) && (defined(i386) || defined(__i386__)) -# define I386 -# define OPENBSD -# define mach_type_known -# endif -# if defined(__NetBSD__) && (defined(i386) || defined(__i386__)) -# define I386 -# define mach_type_known -# endif -# if defined(__NetBSD__) && defined(__x86_64__) -# define X86_64 -# define mach_type_known -# endif -# if defined(FREEBSD) && (defined(i386) || defined(__i386__)) -# define I386 -# define mach_type_known -# endif -# if defined(FREEBSD) && (defined(__amd64__) || defined(__x86_64__)) -# define X86_64 -# define mach_type_known -# endif -# if defined(FREEBSD) && defined(__ia64__) -# define IA64 -# define mach_type_known -# endif -# if defined(FREEBSD) && defined(__sparc__) -# define SPARC -# define mach_type_known -# endif -# if defined(FREEBSD) && (defined(powerpc) || defined(__powerpc__)) -# define POWERPC -# define mach_type_known -# endif -# if defined(FREEBSD) && defined(__arm__) -# define ARM32 -# define mach_type_known -# endif -# if defined(bsdi) && (defined(i386) || defined(__i386__)) -# define I386 -# define BSDI -# define mach_type_known -# endif -# if !defined(mach_type_known) && defined(__386BSD__) -# define I386 -# define THREE86BSD -# define mach_type_known -# endif -# if defined(_CX_UX) && defined(_M88K) -# define M88K -# define CX_UX -# define mach_type_known -# endif -# if defined(DGUX) && defined(m88k) -# define M88K - /* DGUX defined */ -# define mach_type_known -# endif -# if defined(_WIN32_WCE) || defined(__CEGCC__) || defined(__MINGW32CE__) - /* SH3, SH4, MIPS already defined for corresponding architectures */ -# if defined(SH3) || defined(SH4) -# define SH -# endif -# if defined(x86) || defined(__i386__) -# define I386 -# endif -# if defined(_M_ARM) || defined(ARM) || defined(_ARM_) -# define ARM32 -# endif -# define MSWINCE -# define mach_type_known -# else -# if ((defined(_MSDOS) || defined(_MSC_VER)) && (_M_IX86 >= 300)) \ - || (defined(_WIN32) && !defined(__CYGWIN32__) && !defined(__CYGWIN__) \ - && !defined(SYMBIAN)) -# if defined(__LP64__) || defined(_WIN64) -# define X86_64 -# else -# define I386 -# endif -# define MSWIN32 /* or Win64 */ -# define mach_type_known -# endif -# if defined(_MSC_VER) && defined(_M_IA64) -# define IA64 -# define MSWIN32 /* Really win64, but we don't treat 64-bit */ - /* variants as a different platform. */ -# endif -# endif -# if defined(__DJGPP__) -# define I386 -# ifndef DJGPP -# define DJGPP /* MSDOS running the DJGPP port of GCC */ -# endif -# define mach_type_known -# endif -# if defined(__CYGWIN32__) || defined(__CYGWIN__) -# if defined(__LP64__) -# define X86_64 -# else -# define I386 -# endif -# define CYGWIN32 -# define mach_type_known -# endif -# if defined(__MINGW32__) && !defined(mach_type_known) -# define I386 -# define MSWIN32 -# define mach_type_known -# endif -# if defined(__BORLANDC__) -# define I386 -# define MSWIN32 -# define mach_type_known -# endif -# if defined(_UTS) && !defined(mach_type_known) -# define S370 -# define UTS4 -# define mach_type_known -# endif -# if defined(__pj__) -# error PicoJava no longer supported - /* The implementation had problems, and I haven't heard of users */ - /* in ages. If you want it resurrected, let me know. */ -# endif -# if defined(__embedded__) && defined(PPC) -# define POWERPC -# define NOSYS -# define mach_type_known -# endif - -# if defined(__WATCOMC__) && defined(__386__) -# define I386 -# if !defined(OS2) && !defined(MSWIN32) && !defined(DOS4GW) -# if defined(__OS2__) -# define OS2 -# else -# if defined(__WINDOWS_386__) || defined(__NT__) -# define MSWIN32 -# else -# define DOS4GW -# endif -# endif -# endif -# define mach_type_known -# endif -# if defined(__s390__) && defined(LINUX) -# define S390 -# define mach_type_known -# endif -# if defined(__GNU__) -# if defined(__i386__) -/* The Debian Hurd running on generic PC */ -# define HURD -# define I386 -# define mach_type_known -# endif -# endif -# if defined(__TANDEM) - /* Nonstop S-series */ - /* FIXME: Should recognize Integrity series? */ -# define MIPS -# define NONSTOP -# define mach_type_known -# endif -# if defined(__hexagon__) && defined(LINUX) -# define HEXAGON -# define mach_type_known -# endif - -# if defined(SYMBIAN) -# define mach_type_known -# endif - -# if defined(__EMSCRIPTEN__) -# define I386 -# define mach_type_known -# endif - -/* Feel free to add more clauses here */ - -/* Or manually define the machine type here. A machine type is */ -/* characterized by the architecture. Some */ -/* machine types are further subdivided by OS. */ -/* Macros such as LINUX, FREEBSD, etc. distinguish them. */ -/* SYSV on an M68K actually means A/UX. */ -/* The distinction in these cases is usually the stack starting address */ -# ifndef mach_type_known -# error "The collector has not been ported to this machine/OS combination." -# endif - /* Mapping is: M68K ==> Motorola 680X0 */ - /* (NEXT, and SYSV (A/UX), */ - /* MACOS and AMIGA variants) */ - /* I386 ==> Intel 386 */ - /* (SEQUENT, OS2, SCO, LINUX, NETBSD, */ - /* FREEBSD, THREE86BSD, MSWIN32, */ - /* BSDI, SOLARIS, NEXT and others) */ - /* NS32K ==> Encore Multimax */ - /* MIPS ==> R2000 through R14K */ - /* (many variants) */ - /* VAX ==> DEC VAX */ - /* (BSD, ULTRIX variants) */ - /* HP_PA ==> HP9000/700 & /800 */ - /* HP/UX, LINUX */ - /* SPARC ==> SPARC v7/v8/v9 */ - /* (SOLARIS, LINUX, DRSNX variants) */ - /* ALPHA ==> DEC Alpha */ - /* (OSF1 and LINUX variants) */ - /* M88K ==> Motorola 88XX0 */ - /* (CX_UX and DGUX) */ - /* S370 ==> 370-like machine */ - /* running Amdahl UTS4 */ - /* S390 ==> 390-like machine */ - /* running LINUX */ - /* AARCH64 ==> ARM AArch64 */ - /* ARM32 ==> Intel StrongARM */ - /* IA64 ==> Intel IPF */ - /* (e.g. Itanium) */ - /* (LINUX and HPUX) */ - /* SH ==> Hitachi SuperH */ - /* (LINUX & MSWINCE) */ - /* X86_64 ==> AMD x86-64 */ - /* POWERPC ==> IBM/Apple PowerPC */ - /* (MACOS(<=9),DARWIN(incl.MACOSX),*/ - /* LINUX, NETBSD, AIX, NOSYS */ - /* variants) */ - /* Handles 32 and 64-bit variants. */ - /* CRIS ==> Axis Etrax */ - /* M32R ==> Renesas M32R */ - /* HEXAGON ==> Qualcomm Hexagon */ - - -/* - * For each architecture and OS, the following need to be defined: - * - * CPP_WORDSZ is a simple integer constant representing the word size. - * in bits. We assume byte addressability, where a byte has 8 bits. - * We also assume CPP_WORDSZ is either 32 or 64. - * (We care about the length of pointers, not hardware - * bus widths. Thus a 64 bit processor with a C compiler that uses - * 32 bit pointers should use CPP_WORDSZ of 32, not 64. Default is 32.) - * - * MACH_TYPE is a string representation of the machine type. - * OS_TYPE is analogous for the OS. - * - * ALIGNMENT is the largest N, such that - * all pointer are guaranteed to be aligned on N byte boundaries. - * defining it to be 1 will always work, but perform poorly. - * - * DATASTART is the beginning of the data segment. - * On some platforms SEARCH_FOR_DATA_START is defined. - * SEARCH_FOR_DATASTART will cause GC_data_start to - * be set to an address determined by accessing data backwards from _end - * until an unmapped page is found. DATASTART will be defined to be - * GC_data_start. - * On UNIX-like systems, the collector will scan the area between DATASTART - * and DATAEND for root pointers. - * - * DATAEND, if not "end", where "end" is defined as "extern int end[]". - * RTH suggests gaining access to linker script synth'd values with - * this idiom instead of "&end", where "end" is defined as "extern int end". - * Otherwise, "GCC will assume these are in .sdata/.sbss" and it will, e.g., - * cause failures on alpha*-*-* with -msmall-data or -fpic or mips-*-* - * without any special options. - * - * STACKBOTTOM is the cool end of the stack, which is usually the - * highest address in the stack. - * Under PCR or OS/2, we have other ways of finding thread stacks. - * For each machine, the following should: - * 1) define STACK_GROWS_UP if the stack grows toward higher addresses, and - * 2) define exactly one of - * STACKBOTTOM (should be defined to be an expression) - * LINUX_STACKBOTTOM - * HEURISTIC1 - * HEURISTIC2 - * If STACKBOTTOM is defined, then it's value will be used directly as the - * stack base. If LINUX_STACKBOTTOM is defined, then it will be determined - * with a method appropriate for most Linux systems. Currently we look - * first for __libc_stack_end (currently only if USE_LIBC_PRIVATES is - * defined), and if that fails read it from /proc. (If USE_LIBC_PRIVATES - * is not defined and NO_PROC_STAT is defined, we revert to HEURISTIC2.) - * If either of the last two macros are defined, then STACKBOTTOM is computed - * during collector startup using one of the following two heuristics: - * HEURISTIC1: Take an address inside GC_init's frame, and round it up to - * the next multiple of STACK_GRAN. - * HEURISTIC2: Take an address inside GC_init's frame, increment it repeatedly - * in small steps (decrement if STACK_GROWS_UP), and read the value - * at each location. Remember the value when the first - * Segmentation violation or Bus error is signaled. Round that - * to the nearest plausible page boundary, and use that instead - * of STACKBOTTOM. - * - * Gustavo Rodriguez-Rivera points out that on most (all?) Unix machines, - * the value of environ is a pointer that can serve as STACKBOTTOM. - * I expect that HEURISTIC2 can be replaced by this approach, which - * interferes far less with debugging. However it has the disadvantage - * that it's confused by a putenv call before the collector is initialized. - * This could be dealt with by intercepting putenv ... - * - * If no expression for STACKBOTTOM can be found, and neither of the above - * heuristics are usable, the collector can still be used with all of the above - * undefined, provided one of the following is done: - * 1) GC_mark_roots can be changed to somehow mark from the correct stack(s) - * without reference to STACKBOTTOM. This is appropriate for use in - * conjunction with thread packages, since there will be multiple stacks. - * (Allocating thread stacks in the heap, and treating them as ordinary - * heap data objects is also possible as a last resort. However, this is - * likely to introduce significant amounts of excess storage retention - * unless the dead parts of the thread stacks are periodically cleared.) - * 2) Client code may set GC_stackbottom before calling any GC_ routines. - * If the author of the client code controls the main program, this is - * easily accomplished by introducing a new main program, setting - * GC_stackbottom to the address of a local variable, and then calling - * the original main program. The new main program would read something - * like (provided real_main() is not inlined by the compiler): - * - * # include "gc_private.h" - * - * main(argc, argv, envp) - * int argc; - * char **argv, **envp; - * { - * volatile int dummy; - * - * GC_stackbottom = (ptr_t)(&dummy); - * return(real_main(argc, argv, envp)); - * } - * - * - * Each architecture may also define the style of virtual dirty bit - * implementation to be used: - * MPROTECT_VDB: Write protect the heap and catch faults. - * GWW_VDB: Use win32 GetWriteWatch primitive. - * PROC_VDB: Use the SVR4 /proc primitives to read dirty bits. - * - * The first and second one may be combined, in which case a runtime - * selection will be made, based on GetWriteWatch availability. - * - * An architecture may define DYNAMIC_LOADING if dyn_load.c - * defined GC_register_dynamic_libraries() for the architecture. - * - * An architecture may define PREFETCH(x) to preload the cache with *x. - * This defaults to GCC built-in operation (or a no-op for other compilers). - * - * PREFETCH_FOR_WRITE(x) is used if *x is about to be written. - * - * An architecture may also define CLEAR_DOUBLE(x) to be a fast way to - * clear the two words at GC_malloc-aligned address x. By default, - * word stores of 0 are used instead. - * - * HEAP_START may be defined as the initial address hint for mmap-based - * allocation. - */ - -/* If we are using a recent version of gcc, we can use */ -/* __builtin_unwind_init() to push the relevant registers onto the stack. */ -# if defined(__GNUC__) && ((__GNUC__ >= 3) \ - || (__GNUC__ == 2 && __GNUC_MINOR__ >= 8)) \ - && !defined(__INTEL_COMPILER) && !defined(__PATHCC__) \ - && !defined(__FUJITSU) /* for FX10 system */ \ - && !(defined(POWERPC) && defined(DARWIN)) /* for MacOS X 10.3.9 */ \ - && !defined(RTEMS) \ - && !defined(__clang__) /* since no-op in clang (3.0) */ -# define HAVE_BUILTIN_UNWIND_INIT -# endif - -# ifdef SYMBIAN -# define MACH_TYPE "SYMBIAN" -# define OS_TYPE "SYMBIAN" -# define CPP_WORDSZ 32 -# define ALIGNMENT 4 -# define DATASTART NULL -# define DATAEND NULL -# endif - -# ifdef __EMSCRIPTEN__ -# define OS_TYPE "EMSCRIPTEN" -# define CPP_WORDSZ 32 -# define ALIGNMENT 4 -# define DATASTART NULL -# define DATAEND NULL -# define STACK_NOT_SCANNED -# endif - -# define STACK_GRAN 0x1000000 -# ifdef M68K -# define MACH_TYPE "M68K" -# define ALIGNMENT 2 -# ifdef OPENBSD - /* FIXME: Should we remove this case? */ -# define OS_TYPE "OPENBSD" -# define HEURISTIC2 -# ifdef __ELF__ - extern ptr_t GC_data_start; -# define DATASTART GC_data_start -# define DYNAMIC_LOADING -# else - extern char etext[]; -# define DATASTART ((ptr_t)(etext)) -# endif -# endif -# ifdef NETBSD -# define OS_TYPE "NETBSD" -# define HEURISTIC2 -# ifdef __ELF__ - extern ptr_t GC_data_start; -# define DATASTART GC_data_start -# define DYNAMIC_LOADING -# else - extern char etext[]; -# define DATASTART ((ptr_t)(etext)) -# endif -# endif -# ifdef LINUX -# define OS_TYPE "LINUX" -# define LINUX_STACKBOTTOM -# define MPROTECT_VDB -# ifdef __ELF__ -# define DYNAMIC_LOADING -# include -# if defined(__GLIBC__) && __GLIBC__ >= 2 -# define SEARCH_FOR_DATA_START -# else /* !GLIBC2 */ -# ifdef PLATFORM_ANDROID -# define __environ environ -# endif - extern char **__environ; -# define DATASTART ((ptr_t)(&__environ)) - /* hideous kludge: __environ is the first */ - /* word in crt0.o, and delimits the start */ - /* of the data segment, no matter which */ - /* ld options were passed through. */ - /* We could use _etext instead, but that */ - /* would include .rodata, which may */ - /* contain large read-only data tables */ - /* that we'd rather not scan. */ -# endif /* !GLIBC2 */ - extern int _end[]; -# define DATAEND (ptr_t)(_end) -# else - extern int etext[]; -# define DATASTART ((ptr_t)((((word) (etext)) + 0xfff) & ~0xfff)) -# endif -# endif -# ifdef AMIGA -# define OS_TYPE "AMIGA" - /* STACKBOTTOM and DATASTART handled specially */ - /* in os_dep.c */ -# define DATAEND /* not needed */ -# define GETPAGESIZE() 4096 -# endif -# ifdef MACOS -# ifndef __LOWMEM__ -# include -# endif -# define OS_TYPE "MACOS" - /* see os_dep.c for details of global data segments. */ -# define STACKBOTTOM ((ptr_t) LMGetCurStackBase()) -# define DATAEND /* not needed */ -# define GETPAGESIZE() 4096 -# endif -# ifdef NEXT -# define OS_TYPE "NEXT" -# define DATASTART ((ptr_t) get_etext()) -# define DATASTART_IS_FUNC -# define STACKBOTTOM ((ptr_t) 0x4000000) -# define DATAEND /* not needed */ -# endif -# endif - -# if defined(POWERPC) -# define MACH_TYPE "POWERPC" -# ifdef MACOS -# define ALIGNMENT 2 /* Still necessary? Could it be 4? */ -# ifndef __LOWMEM__ -# include -# endif -# define OS_TYPE "MACOS" - /* see os_dep.c for details of global data segments. */ -# define STACKBOTTOM ((ptr_t) LMGetCurStackBase()) -# define DATAEND /* not needed */ -# endif -# ifdef LINUX -# if defined(__powerpc64__) -# define ALIGNMENT 8 -# define CPP_WORDSZ 64 -# ifndef HBLKSIZE -# define HBLKSIZE 4096 -# endif -# else -# define ALIGNMENT 4 -# endif -# define OS_TYPE "LINUX" - /* HEURISTIC1 has been reliably reported to fail for a 32-bit */ - /* executable on a 64 bit kernel. */ -# if defined(__bg__) - /* The Linux Compute Node Kernel (used on BlueGene systems) */ - /* does not support LINUX_STACKBOTTOM way. */ -# define HEURISTIC2 -# define NO_PTHREAD_GETATTR_NP -# else -# define LINUX_STACKBOTTOM -# endif -# define DYNAMIC_LOADING -# define SEARCH_FOR_DATA_START - extern int _end[]; -# define DATAEND (ptr_t)(_end) -# endif -# ifdef DARWIN -# define OS_TYPE "DARWIN" -# define DYNAMIC_LOADING -# if defined(__ppc64__) -# define ALIGNMENT 8 -# define CPP_WORDSZ 64 -# define STACKBOTTOM ((ptr_t) 0x7fff5fc00000) -# define CACHE_LINE_SIZE 64 -# ifndef HBLKSIZE -# define HBLKSIZE 4096 -# endif -# else -# define ALIGNMENT 4 -# define STACKBOTTOM ((ptr_t) 0xc0000000) -# endif - /* XXX: see get_end(3), get_etext() and get_end() should not be used. */ - /* These aren't used when dyld support is enabled (it is by default). */ -# define DATASTART ((ptr_t) get_etext()) -# define DATAEND ((ptr_t) get_end()) -# ifndef USE_MMAP -# define USE_MMAP -# endif -# define USE_MMAP_ANON -# define MPROTECT_VDB -# include -# define GETPAGESIZE() getpagesize() -# if defined(USE_PPC_PREFETCH) && defined(__GNUC__) - /* The performance impact of prefetches is untested */ -# define PREFETCH(x) \ - __asm__ __volatile__ ("dcbt 0,%0" : : "r" ((const void *) (x))) -# define PREFETCH_FOR_WRITE(x) \ - __asm__ __volatile__ ("dcbtst 0,%0" : : "r" ((const void *) (x))) -# endif - /* There seems to be some issues with trylock hanging on darwin. */ - /* This should be looked into some more. */ -# define NO_PTHREAD_TRYLOCK -# endif -# ifdef OPENBSD -# define OS_TYPE "OPENBSD" -# define ALIGNMENT 4 -# ifndef GC_OPENBSD_THREADS -# include -# include -# define STACKBOTTOM ((ptr_t) USRSTACK) -# endif - extern int __data_start[]; -# define DATASTART ((ptr_t)__data_start) - extern char _end[]; -# define DATAEND ((ptr_t)(&_end)) -# define DYNAMIC_LOADING -# endif -# ifdef FREEBSD -# if defined(__powerpc64__) -# define ALIGNMENT 8 -# define CPP_WORDSZ 64 -# ifndef HBLKSIZE -# define HBLKSIZE 4096 -# endif -# else -# define ALIGNMENT 4 -# endif -# define OS_TYPE "FREEBSD" -# ifndef GC_FREEBSD_THREADS -# define MPROTECT_VDB -# endif -# define SIG_SUSPEND SIGUSR1 -# define SIG_THR_RESTART SIGUSR2 -# define FREEBSD_STACKBOTTOM -# ifdef __ELF__ -# define DYNAMIC_LOADING -# endif - extern char etext[]; - ptr_t GC_FreeBSDGetDataStart(size_t, ptr_t); -# define DATASTART GC_FreeBSDGetDataStart(0x1000, (ptr_t)etext) -# define DATASTART_IS_FUNC -# endif -# ifdef NETBSD -# define ALIGNMENT 4 -# define OS_TYPE "NETBSD" -# define HEURISTIC2 - extern ptr_t GC_data_start; -# define DATASTART GC_data_start -# define DYNAMIC_LOADING -# endif -# ifdef SN_TARGET_PS3 -# define NO_GETENV -# define CPP_WORDSZ 32 -# define ALIGNMENT 4 - extern int _end []; - extern int __bss_start; -# define DATAEND (ptr_t)(_end) -# define DATASTART (ptr_t)(__bss_start) -# define STACKBOTTOM ((ptr_t)ps3_get_stack_bottom()) -# define NO_PTHREAD_TRYLOCK - /* Current GC LOCK() implementation for PS3 explicitly */ - /* use pthread_mutex_lock for some reason. */ -# endif -# ifdef AIX -# define OS_TYPE "AIX" -# undef ALIGNMENT /* in case it's defined */ -# undef IA64 - /* DOB: some AIX installs stupidly define IA64 in */ - /* /usr/include/sys/systemcfg.h */ -# ifdef __64BIT__ -# define ALIGNMENT 8 -# define CPP_WORDSZ 64 -# define STACKBOTTOM ((ptr_t)0x1000000000000000) -# else -# define ALIGNMENT 4 -# define CPP_WORDSZ 32 -# define STACKBOTTOM ((ptr_t)((ulong)&errno)) -# endif -# ifndef USE_MMAP -# define USE_MMAP -# endif -# define USE_MMAP_ANON - /* From AIX linker man page: - _text Specifies the first location of the program. - _etext Specifies the first location after the program. - _data Specifies the first location of the data. - _edata Specifies the first location after the initialized data - _end or end Specifies the first location after all data. - */ - extern int _data[], _end[]; -# define DATASTART ((ptr_t)((ulong)_data)) -# define DATAEND ((ptr_t)((ulong)_end)) - extern int errno; -# define DYNAMIC_LOADING - /* For really old versions of AIX, this may have to be removed. */ -# endif - -# ifdef NOSYS -# define ALIGNMENT 4 -# define OS_TYPE "NOSYS" - extern void __end[], __dso_handle[]; -# define DATASTART (__dso_handle) /* OK, that's ugly. */ -# define DATAEND (ptr_t)(__end) - /* Stack starts at 0xE0000000 for the simulator. */ -# undef STACK_GRAN -# define STACK_GRAN 0x10000000 -# define HEURISTIC1 -# endif -# endif - -# ifdef VAX -# define MACH_TYPE "VAX" -# define ALIGNMENT 4 /* Pointers are longword aligned by 4.2 C compiler */ - extern char etext[]; -# define DATASTART ((ptr_t)(etext)) -# ifdef BSD -# define OS_TYPE "BSD" -# define HEURISTIC1 - /* HEURISTIC2 may be OK, but it's hard to test. */ -# endif -# ifdef ULTRIX -# define OS_TYPE "ULTRIX" -# define STACKBOTTOM ((ptr_t) 0x7fffc800) -# endif -# endif - -# ifdef SPARC -# define MACH_TYPE "SPARC" -# if defined(__arch64__) || defined(__sparcv9) -# define ALIGNMENT 8 -# define CPP_WORDSZ 64 -# define ELF_CLASS ELFCLASS64 -# else -# define ALIGNMENT 4 /* Required by hardware */ -# define CPP_WORDSZ 32 -# endif - /* Don't define USE_ASM_PUSH_REGS. We do use an asm helper, but */ - /* not to push the registers on the mark stack. */ -# ifdef SOLARIS -# define OS_TYPE "SOLARIS" - extern int _etext[]; - extern int _end[]; - ptr_t GC_SysVGetDataStart(size_t, ptr_t); -# define DATASTART GC_SysVGetDataStart(0x10000, (ptr_t)_etext) -# define DATASTART_IS_FUNC -# define DATAEND (ptr_t)(_end) -# if !defined(USE_MMAP) && defined(REDIRECT_MALLOC) -# define USE_MMAP - /* Otherwise we now use calloc. Mmap may result in the */ - /* heap interleaved with thread stacks, which can result in */ - /* excessive blacklisting. Sbrk is unusable since it */ - /* doesn't interact correctly with the system malloc. */ -# endif -# ifdef USE_MMAP -# define HEAP_START (ptr_t)0x40000000 -# else -# define HEAP_START DATAEND -# endif -# define PROC_VDB -/* HEURISTIC1 reportedly no longer works under 2.7. */ -/* HEURISTIC2 probably works, but this appears to be preferable. */ -/* Apparently USRSTACK is defined to be USERLIMIT, but in some */ -/* installations that's undefined. We work around this with a */ -/* gross hack: */ -# include -# ifdef USERLIMIT - /* This should work everywhere, but doesn't. */ -# define STACKBOTTOM ((ptr_t) USRSTACK) -# else -# define HEURISTIC2 -# endif -# include -# define GETPAGESIZE() sysconf(_SC_PAGESIZE) - /* getpagesize() appeared to be missing from at least one */ - /* Solaris 5.4 installation. Weird. */ -# define DYNAMIC_LOADING -# endif -# ifdef DRSNX -# define OS_TYPE "DRSNX" - ptr_t GC_SysVGetDataStart(size_t, ptr_t); - extern int etext[]; -# define DATASTART GC_SysVGetDataStart(0x10000, (ptr_t)etext) -# define DATASTART_IS_FUNC -# define MPROTECT_VDB -# define STACKBOTTOM ((ptr_t) 0xdfff0000) -# define DYNAMIC_LOADING -# endif -# ifdef LINUX -# define OS_TYPE "LINUX" -# ifdef __ELF__ -# define DYNAMIC_LOADING -# else -# error --> Linux SPARC a.out not supported -# endif - extern int _end[]; - extern int _etext[]; -# define DATAEND (ptr_t)(_end) -# define SVR4 - ptr_t GC_SysVGetDataStart(size_t, ptr_t); -# ifdef __arch64__ -# define DATASTART GC_SysVGetDataStart(0x100000, (ptr_t)_etext) -# else -# define DATASTART GC_SysVGetDataStart(0x10000, (ptr_t)_etext) -# endif -# define DATASTART_IS_FUNC -# define LINUX_STACKBOTTOM -# endif -# ifdef OPENBSD -# define OS_TYPE "OPENBSD" -# ifndef GC_OPENBSD_THREADS -# include -# include -# define STACKBOTTOM ((ptr_t) USRSTACK) -# endif - extern int __data_start[]; -# define DATASTART ((ptr_t)__data_start) - extern char _end[]; -# define DATAEND ((ptr_t)(&_end)) -# define DYNAMIC_LOADING -# endif -# ifdef NETBSD -# define OS_TYPE "NETBSD" -# define HEURISTIC2 -# ifdef __ELF__ - extern ptr_t GC_data_start; -# define DATASTART GC_data_start -# define DYNAMIC_LOADING -# else - extern char etext[]; -# define DATASTART ((ptr_t)(etext)) -# endif -# endif -# ifdef FREEBSD -# define OS_TYPE "FREEBSD" -# define SIG_SUSPEND SIGUSR1 -# define SIG_THR_RESTART SIGUSR2 -# define FREEBSD_STACKBOTTOM -# ifdef __ELF__ -# define DYNAMIC_LOADING -# endif - extern char etext[]; - extern char edata[]; - extern char end[]; -# define NEED_FIND_LIMIT -# define DATASTART ((ptr_t)(&etext)) - ptr_t GC_find_limit(ptr_t, GC_bool); -# define DATAEND (GC_find_limit (DATASTART, TRUE)) -# define DATAEND_IS_FUNC -# define DATASTART2 ((ptr_t)(&edata)) -# define DATAEND2 ((ptr_t)(&end)) -# endif -# endif - -# ifdef I386 -# define MACH_TYPE "I386" -# if defined(__LP64__) || defined(_WIN64) -# error This should be handled as X86_64 -# else -# define CPP_WORDSZ 32 -# define ALIGNMENT 4 - /* Appears to hold for all "32 bit" compilers */ - /* except Borland. The -a4 option fixes */ - /* Borland. For Watcom the option is -zp4. */ -# endif -# ifdef SEQUENT -# define OS_TYPE "SEQUENT" - extern int etext[]; -# define DATASTART ((ptr_t)((((word) (etext)) + 0xfff) & ~0xfff)) -# define STACKBOTTOM ((ptr_t) 0x3ffff000) -# endif -# ifdef BEOS -# define OS_TYPE "BEOS" -# include -# define GETPAGESIZE() B_PAGE_SIZE - extern int etext[]; -# define DATASTART ((ptr_t)((((word) (etext)) + 0xfff) & ~0xfff)) -# endif -# ifdef SOLARIS -# define OS_TYPE "SOLARIS" - extern int _etext[], _end[]; - ptr_t GC_SysVGetDataStart(size_t, ptr_t); -# define DATASTART GC_SysVGetDataStart(0x1000, (ptr_t)_etext) -# define DATASTART_IS_FUNC -# define DATAEND (ptr_t)(_end) -/* # define STACKBOTTOM ((ptr_t)(_start)) worked through 2.7, */ -/* but reportedly breaks under 2.8. It appears that the stack */ -/* base is a property of the executable, so this should not break */ -/* old executables. */ -/* HEURISTIC2 probably works, but this appears to be preferable. */ -# include -# define STACKBOTTOM ((ptr_t) USRSTACK) -/* At least in Solaris 2.5, PROC_VDB gives wrong values for dirty bits. */ -/* It appears to be fixed in 2.8 and 2.9. */ -# ifdef SOLARIS25_PROC_VDB_BUG_FIXED -# define PROC_VDB -# endif -# ifndef GC_THREADS -# define MPROTECT_VDB -# endif -# define DYNAMIC_LOADING -# if !defined(USE_MMAP) && defined(REDIRECT_MALLOC) -# define USE_MMAP - /* Otherwise we now use calloc. Mmap may result in the */ - /* heap interleaved with thread stacks, which can result in */ - /* excessive blacklisting. Sbrk is unusable since it */ - /* doesn't interact correctly with the system malloc. */ -# endif -# ifdef USE_MMAP -# define HEAP_START (ptr_t)0x40000000 -# else -# define HEAP_START DATAEND -# endif -# endif -# ifdef SCO -# define OS_TYPE "SCO" - extern int etext[]; -# define DATASTART ((ptr_t)((((word) (etext)) + 0x3fffff) \ - & ~0x3fffff) \ - +((word)etext & 0xfff)) -# define STACKBOTTOM ((ptr_t) 0x7ffffffc) -# endif -# ifdef SCO_ELF -# define OS_TYPE "SCO_ELF" - extern int etext[]; -# define DATASTART ((ptr_t)(etext)) -# define STACKBOTTOM ((ptr_t) 0x08048000) -# define DYNAMIC_LOADING -# define ELF_CLASS ELFCLASS32 -# endif -# ifdef DGUX -# define OS_TYPE "DGUX" - extern int _etext, _end; - ptr_t GC_SysVGetDataStart(size_t, ptr_t); -# define DATASTART GC_SysVGetDataStart(0x1000, (ptr_t)(&_etext)) -# define DATASTART_IS_FUNC -# define DATAEND (ptr_t)(&_end) -# define STACK_GROWS_DOWN -# define HEURISTIC2 -# include -# define GETPAGESIZE() sysconf(_SC_PAGESIZE) -# define DYNAMIC_LOADING -# ifndef USE_MMAP -# define USE_MMAP -# endif -# define MAP_FAILED (void *) ((word)-1) -# ifdef USE_MMAP -# define HEAP_START (ptr_t)0x40000000 -# else -# define HEAP_START DATAEND -# endif -# endif /* DGUX */ - -# ifdef NACL -# define OS_TYPE "NACL" - extern int etext[]; -/* #define DATASTART ((ptr_t)((((word) (etext)) + 0xfff) & ~0xfff)) */ -# define DATASTART ((ptr_t)0x10000000) - extern int _end[]; -# define DATAEND (_end) -# undef STACK_GRAN -# define STACK_GRAN 0x10000 -# define HEURISTIC1 -# define NO_PTHREAD_GETATTR_NP -# define GETPAGESIZE() 65536 -# ifndef MAX_NACL_GC_THREADS -# define MAX_NACL_GC_THREADS 1024 -# endif -# endif /* NACL */ - -# ifdef LINUX -# define OS_TYPE "LINUX" -# define LINUX_STACKBOTTOM -# if !defined(GC_LINUX_THREADS) || !defined(REDIRECT_MALLOC) -# define MPROTECT_VDB -# else - /* We seem to get random errors in incremental mode, */ - /* possibly because Linux threads is itself a malloc client */ - /* and can't deal with the signals. */ -# endif -# define HEAP_START (ptr_t)0x1000 - /* This encourages mmap to give us low addresses, */ - /* thus allowing the heap to grow to ~3GB */ -# ifdef __ELF__ -# define DYNAMIC_LOADING -# ifdef UNDEFINED /* includes ro data */ - extern int _etext[]; -# define DATASTART ((ptr_t)((((word) (_etext)) + 0xfff) & ~0xfff)) -# endif -# include -# if defined(__GLIBC__) && __GLIBC__ >= 2 \ - || defined(PLATFORM_ANDROID) -# define SEARCH_FOR_DATA_START -# else - extern char **__environ; -# define DATASTART ((ptr_t)(&__environ)) - /* hideous kludge: __environ is the first */ - /* word in crt0.o, and delimits the start */ - /* of the data segment, no matter which */ - /* ld options were passed through. */ - /* We could use _etext instead, but that */ - /* would include .rodata, which may */ - /* contain large read-only data tables */ - /* that we'd rather not scan. */ -# endif - extern int _end[]; -# define DATAEND (ptr_t)(_end) -# if defined(PLATFORM_ANDROID) && !defined(GC_NO_SIGSETJMP) - /* As of Android NDK r8b, _sigsetjmp is still missing */ - /* for x86 (setjmp is used instead to find data_start). */ -# define GC_NO_SIGSETJMP -# endif -# else - extern int etext[]; -# define DATASTART ((ptr_t)((((word) (etext)) + 0xfff) & ~0xfff)) -# endif -# ifdef USE_I686_PREFETCH -# define PREFETCH(x) \ - __asm__ __volatile__ ("prefetchnta %0" : : "m"(*(char *)(x))) - /* Empirically prefetcht0 is much more effective at reducing */ - /* cache miss stalls for the targeted load instructions. But it */ - /* seems to interfere enough with other cache traffic that the */ - /* net result is worse than prefetchnta. */ -# ifdef FORCE_WRITE_PREFETCH - /* Using prefetches for write seems to have a slight negative */ - /* impact on performance, at least for a PIII/500. */ -# define PREFETCH_FOR_WRITE(x) \ - __asm__ __volatile__ ("prefetcht0 %0" : : "m"(*(char *)(x))) -# else -# define NO_PREFETCH_FOR_WRITE -# endif -# elif defined(USE_3DNOW_PREFETCH) -# define PREFETCH(x) \ - __asm__ __volatile__ ("prefetch %0" : : "m"(*(char *)(x))) -# define PREFETCH_FOR_WRITE(x) \ - __asm__ __volatile__ ("prefetchw %0" : : "m"(*(char *)(x))) -# endif -# if defined(__GLIBC__) - /* Workaround lock elision implementation for some glibc. */ -# define GLIBC_2_19_TSX_BUG -# include /* for gnu_get_libc_version() */ -# endif -# endif -# ifdef CYGWIN32 -# define OS_TYPE "CYGWIN32" -# define DATASTART ((ptr_t)GC_DATASTART) /* From gc.h */ -# define DATAEND ((ptr_t)GC_DATAEND) -# undef STACK_GRAN -# define STACK_GRAN 0x10000 -# ifdef USE_MMAP -# define NEED_FIND_LIMIT -# define USE_MMAP_ANON -# endif -# endif -# ifdef OS2 -# define OS_TYPE "OS2" - /* STACKBOTTOM and DATASTART are handled specially in */ - /* os_dep.c. OS2 actually has the right */ - /* system call! */ -# define DATAEND /* not needed */ -# endif -# ifdef MSWIN32 -# define OS_TYPE "MSWIN32" - /* STACKBOTTOM and DATASTART are handled specially in */ - /* os_dep.c. */ -# define MPROTECT_VDB -# define GWW_VDB -# define DATAEND /* not needed */ -# endif -# ifdef MSWINCE -# define OS_TYPE "MSWINCE" -# define DATAEND /* not needed */ -# endif -# ifdef DJGPP -# define OS_TYPE "DJGPP" -# include "stubinfo.h" - extern int etext[]; - extern int _stklen; - extern int __djgpp_stack_limit; -# define DATASTART ((ptr_t)((((word) (etext)) + 0x1ff) & ~0x1ff)) -/* #define STACKBOTTOM ((ptr_t)((word)_stubinfo+_stubinfo->size+_stklen)) */ -# define STACKBOTTOM ((ptr_t)((word) __djgpp_stack_limit + _stklen)) - /* This may not be right. */ -# endif -# ifdef OPENBSD -# define OS_TYPE "OPENBSD" -# ifndef GC_OPENBSD_THREADS -# include -# include -# define STACKBOTTOM ((ptr_t) USRSTACK) -# endif - extern int __data_start[]; -# define DATASTART ((ptr_t)__data_start) - extern char _end[]; -# define DATAEND ((ptr_t)(&_end)) -# define DYNAMIC_LOADING -# endif -# ifdef FREEBSD -# define OS_TYPE "FREEBSD" -# ifndef GC_FREEBSD_THREADS -# define MPROTECT_VDB -# endif -# ifdef __GLIBC__ -# define SIG_SUSPEND (32+6) -# define SIG_THR_RESTART (32+5) - extern int _end[]; -# define DATAEND (ptr_t)(_end) -# else -# define SIG_SUSPEND SIGUSR1 -# define SIG_THR_RESTART SIGUSR2 - /* SIGTSTP and SIGCONT could be used alternatively. */ -# endif -# define FREEBSD_STACKBOTTOM -# ifdef __ELF__ -# define DYNAMIC_LOADING -# endif - extern char etext[]; - char * GC_FreeBSDGetDataStart(size_t, ptr_t); -# define DATASTART GC_FreeBSDGetDataStart(0x1000, (ptr_t)etext) -# define DATASTART_IS_FUNC -# endif -# ifdef NETBSD -# define OS_TYPE "NETBSD" -# ifdef __ELF__ -# define DYNAMIC_LOADING -# endif -# endif -# ifdef THREE86BSD -# define OS_TYPE "THREE86BSD" -# endif -# ifdef BSDI -# define OS_TYPE "BSDI" -# endif -# if defined(NETBSD) || defined(THREE86BSD) || defined(BSDI) -# define HEURISTIC2 - extern char etext[]; -# define DATASTART ((ptr_t)(etext)) -# endif -# ifdef NEXT -# define OS_TYPE "NEXT" -# define DATASTART ((ptr_t) get_etext()) -# define DATASTART_IS_FUNC -# define STACKBOTTOM ((ptr_t)0xc0000000) -# define DATAEND /* not needed */ -# endif -# ifdef RTEMS -# define OS_TYPE "RTEMS" -# include - extern int etext[]; - extern int end[]; - void *rtems_get_stack_bottom(void); -# define InitStackBottom rtems_get_stack_bottom() -# define DATASTART ((ptr_t)etext) -# define DATAEND ((ptr_t)end) -# define STACKBOTTOM ((ptr_t)InitStackBottom) -# define SIG_SUSPEND SIGUSR1 -# define SIG_THR_RESTART SIGUSR2 -# endif -# ifdef DOS4GW -# define OS_TYPE "DOS4GW" - extern long __nullarea; - extern char _end; - extern char *_STACKTOP; - /* Depending on calling conventions Watcom C either precedes */ - /* or does not precedes with underscore names of C-variables. */ - /* Make sure startup code variables always have the same names. */ - #pragma aux __nullarea "*"; - #pragma aux _end "*"; -# define STACKBOTTOM ((ptr_t) _STACKTOP) - /* confused? me too. */ -# define DATASTART ((ptr_t) &__nullarea) -# define DATAEND ((ptr_t) &_end) -# endif -# ifdef HURD -# define OS_TYPE "HURD" -# define STACK_GROWS_DOWN -# define HEURISTIC2 -# define SIG_SUSPEND SIGUSR1 -# define SIG_THR_RESTART SIGUSR2 -# define SEARCH_FOR_DATA_START - extern int _end[]; -# define DATAEND ((ptr_t) (_end)) -/* # define MPROTECT_VDB Not quite working yet? */ -# define DYNAMIC_LOADING -# endif -# ifdef DARWIN -# define OS_TYPE "DARWIN" -# define DARWIN_DONT_PARSE_STACK -# define DYNAMIC_LOADING - /* XXX: see get_end(3), get_etext() and get_end() should not be used. */ - /* These aren't used when dyld support is enabled (it is by default). */ -# define DATASTART ((ptr_t) get_etext()) -# define DATAEND ((ptr_t) get_end()) -# define STACKBOTTOM ((ptr_t) 0xc0000000) -# ifndef USE_MMAP -# define USE_MMAP -# endif -# define USE_MMAP_ANON -# define MPROTECT_VDB -# include -# define GETPAGESIZE() getpagesize() - /* There seems to be some issues with trylock hanging on darwin. */ - /* This should be looked into some more. */ -# define NO_PTHREAD_TRYLOCK -# endif /* DARWIN */ -# endif - -# ifdef NS32K -# define MACH_TYPE "NS32K" -# define ALIGNMENT 4 - extern char **environ; -# define DATASTART ((ptr_t)(&environ)) - /* hideous kludge: environ is the first */ - /* word in crt0.o, and delimits the start */ - /* of the data segment, no matter which */ - /* ld options were passed through. */ -# define STACKBOTTOM ((ptr_t) 0xfffff000) /* for Encore */ -# endif - -# ifdef MIPS -# define MACH_TYPE "MIPS" -# ifdef LINUX -# define OS_TYPE "LINUX" -# define DYNAMIC_LOADING - extern int _end[]; -# define DATAEND (ptr_t)(_end) -# pragma weak __data_start - extern int __data_start[]; -# define DATASTART ((ptr_t)(__data_start)) -# ifdef _MIPS_SZPTR -# define CPP_WORDSZ _MIPS_SZPTR -# define ALIGNMENT (_MIPS_SZPTR/8) -# else -# define ALIGNMENT 4 -# endif -# ifndef HBLKSIZE -# define HBLKSIZE 4096 -# endif -# if __GLIBC__ == 2 && __GLIBC_MINOR__ >= 2 || __GLIBC__ > 2 -# define LINUX_STACKBOTTOM -# else -# define STACKBOTTOM ((ptr_t)0x7fff8000) -# endif -# endif /* Linux */ -# ifdef EWS4800 -# define HEURISTIC2 -# if defined(_MIPS_SZPTR) && (_MIPS_SZPTR == 64) - extern int _fdata[], _end[]; -# define DATASTART ((ptr_t)_fdata) -# define DATAEND ((ptr_t)_end) -# define CPP_WORDSZ _MIPS_SZPTR -# define ALIGNMENT (_MIPS_SZPTR/8) -# else - extern int etext[], edata[], end[]; - extern int _DYNAMIC_LINKING[], _gp[]; -# define DATASTART ((ptr_t)((((word)etext + 0x3ffff) & ~0x3ffff) \ - + ((word)etext & 0xffff))) -# define DATAEND (ptr_t)(edata) -# define DATASTART2 (_DYNAMIC_LINKING \ - ? (ptr_t)(((word)_gp + 0x8000 + 0x3ffff) & ~0x3ffff) \ - : (ptr_t)edata) -# define DATAEND2 (ptr_t)(end) -# define ALIGNMENT 4 -# endif -# define OS_TYPE "EWS4800" -# endif -# ifdef ULTRIX -# define HEURISTIC2 -# define DATASTART (ptr_t)0x10000000 - /* Could probably be slightly higher since */ - /* startup code allocates lots of stuff. */ -# define OS_TYPE "ULTRIX" -# define ALIGNMENT 4 -# endif -# ifdef IRIX5 -# define HEURISTIC2 - extern int _fdata[]; -# define DATASTART ((ptr_t)(_fdata)) -# ifdef USE_MMAP -# define HEAP_START (ptr_t)0x30000000 -# else -# define HEAP_START DATASTART -# endif - /* Lowest plausible heap address. */ - /* In the MMAP case, we map there. */ - /* In either case it is used to identify */ - /* heap sections so they're not */ - /* considered as roots. */ -# define OS_TYPE "IRIX5" -/*# define MPROTECT_VDB DOB: this should work, but there is evidence */ -/* of recent breakage. */ -# ifdef _MIPS_SZPTR -# define CPP_WORDSZ _MIPS_SZPTR -# define ALIGNMENT (_MIPS_SZPTR/8) -# else -# define ALIGNMENT 4 -# endif -# define DYNAMIC_LOADING -# endif -# ifdef MSWINCE -# define OS_TYPE "MSWINCE" -# define ALIGNMENT 4 -# define DATAEND /* not needed */ -# endif -# if defined(NETBSD) -# define OS_TYPE "NETBSD" -# define ALIGNMENT 4 -# define HEURISTIC2 -# ifdef __ELF__ - extern ptr_t GC_data_start; -# define DATASTART GC_data_start -# define NEED_FIND_LIMIT -# define DYNAMIC_LOADING -# else -# define DATASTART ((ptr_t) 0x10000000) -# define STACKBOTTOM ((ptr_t) 0x7ffff000) -# endif /* _ELF_ */ -# endif -# ifdef OPENBSD -# define OS_TYPE "OPENBSD" -# define ALIGNMENT 4 -# ifndef GC_OPENBSD_THREADS -# include -# include -# define STACKBOTTOM ((ptr_t) USRSTACK) -# endif - extern int _fdata[]; -# define DATASTART ((ptr_t)_fdata) - extern char _end[]; -# define DATAEND ((ptr_t)(&_end)) -# define DYNAMIC_LOADING -# endif -# if defined(NONSTOP) -# define CPP_WORDSZ 32 -# define OS_TYPE "NONSTOP" -# define ALIGNMENT 4 -# define DATASTART ((ptr_t) 0x08000000) - extern char **environ; -# define DATAEND ((ptr_t)(environ - 0x10)) -# define STACKBOTTOM ((ptr_t) 0x4fffffff) -# endif -# endif - -# ifdef OR1K -# define CPP_WORDSZ 32 -# define MACH_TYPE "OR1K" -# ifdef LINUX -# define OS_TYPE "LINUX" -# define DYNAMIC_LOADING - extern int _end[]; -# define DATAEND (ptr_t)(_end) - extern int __data_start[]; -# define DATASTART ((ptr_t)(__data_start)) -# define ALIGNMENT 4 -# ifndef HBLKSIZE -# define HBLKSIZE 4096 -# endif -# define LINUX_STACKBOTTOM -# endif /* Linux */ -# endif - -# ifdef HP_PA -# define MACH_TYPE "HP_PA" -# ifdef __LP64__ -# define CPP_WORDSZ 64 -# define ALIGNMENT 8 -# else -# define CPP_WORDSZ 32 -# define ALIGNMENT 4 -# endif -# if !defined(GC_HPUX_THREADS) && !defined(GC_LINUX_THREADS) \ - && !defined(OPENBSD) && !defined(LINUX) /* For now. */ -# define MPROTECT_VDB -# endif -# define STACK_GROWS_UP -# ifdef HPUX -# define OS_TYPE "HPUX" - extern int __data_start[]; -# define DATASTART ((ptr_t)(__data_start)) -# ifdef USE_HPUX_FIXED_STACKBOTTOM - /* The following appears to work for 7xx systems running HP/UX */ - /* 9.xx. Furthermore, it might result in much faster */ - /* collections than HEURISTIC2, which may involve scanning */ - /* segments that directly precede the stack. It is not the */ - /* default, since it may not work on older machine/OS */ - /* combinations. (Thanks to Raymond X.T. Nijssen for uncovering */ - /* this.) */ -# define STACKBOTTOM ((ptr_t) 0x7b033000) /* from /etc/conf/h/param.h */ -# else - /* Gustavo Rodriguez-Rivera suggested changing HEURISTIC2 */ - /* to this. Note that the GC must be initialized before the */ - /* first putenv call. */ - extern char ** environ; -# define STACKBOTTOM ((ptr_t)environ) -# endif -# define DYNAMIC_LOADING -# include -# define GETPAGESIZE() sysconf(_SC_PAGE_SIZE) -# ifndef __GNUC__ -# define PREFETCH(x) do { \ - register long addr = (long)(x); \ - (void) _asm ("LDW", 0, 0, addr, 0); \ - } while (0) -# endif -# endif /* HPUX */ -# ifdef LINUX -# define OS_TYPE "LINUX" -# define LINUX_STACKBOTTOM -# define DYNAMIC_LOADING -# define SEARCH_FOR_DATA_START - extern int _end[]; -# define DATAEND (ptr_t)(&_end) -# endif /* LINUX */ -# ifdef OPENBSD -# define OS_TYPE "OPENBSD" -# ifndef GC_OPENBSD_THREADS -# include -# include -# define STACKBOTTOM ((ptr_t) USRSTACK) -# endif - extern int __data_start[]; -# define DATASTART ((ptr_t)__data_start) - extern char _end[]; -# define DATAEND ((ptr_t)(&_end)) -# define DYNAMIC_LOADING -# endif -# endif /* HP_PA */ - -# ifdef ALPHA -# define MACH_TYPE "ALPHA" -# define ALIGNMENT 8 -# define CPP_WORDSZ 64 -# ifdef NETBSD -# define OS_TYPE "NETBSD" -# define HEURISTIC2 - extern ptr_t GC_data_start; -# define DATASTART GC_data_start -# define ELFCLASS32 32 -# define ELFCLASS64 64 -# define ELF_CLASS ELFCLASS64 -# define DYNAMIC_LOADING -# endif -# ifdef OPENBSD -# define OS_TYPE "OPENBSD" -# define ELF_CLASS ELFCLASS64 -# ifndef GC_OPENBSD_THREADS -# include -# include -# define STACKBOTTOM ((ptr_t) USRSTACK) -# endif - extern int __data_start[]; -# define DATASTART ((ptr_t)__data_start) - extern char _end[]; -# define DATAEND ((ptr_t)(&_end)) -# define DYNAMIC_LOADING -# endif -# ifdef FREEBSD -# define OS_TYPE "FREEBSD" -/* MPROTECT_VDB is not yet supported at all on FreeBSD/alpha. */ -# define SIG_SUSPEND SIGUSR1 -# define SIG_THR_RESTART SIGUSR2 - /* SIGTSTP and SIGCONT could be used alternatively. */ -# define FREEBSD_STACKBOTTOM -# ifdef __ELF__ -# define DYNAMIC_LOADING -# endif -/* Handle unmapped hole alpha*-*-freebsd[45]* puts between etext and edata. */ - extern char etext[]; - extern char edata[]; - extern char end[]; -# define NEED_FIND_LIMIT -# define DATASTART ((ptr_t)(&etext)) - ptr_t GC_find_limit(ptr_t, GC_bool); -# define DATAEND (GC_find_limit (DATASTART, TRUE)) -# define DATAEND_IS_FUNC -# define DATASTART2 ((ptr_t)(&edata)) -# define DATAEND2 ((ptr_t)(&end)) -# endif -# ifdef OSF1 -# define OS_TYPE "OSF1" -# define DATASTART ((ptr_t) 0x140000000) - extern int _end[]; -# define DATAEND ((ptr_t) &_end) - extern char ** environ; - /* round up from the value of environ to the nearest page boundary */ - /* Probably breaks if putenv is called before collector */ - /* initialization. */ -# define STACKBOTTOM ((ptr_t)(((word)(environ) | (getpagesize()-1))+1)) -/* # define HEURISTIC2 */ - /* Normally HEURISTIC2 is too conservative, since */ - /* the text segment immediately follows the stack. */ - /* Hence we give an upper pound. */ - /* This is currently unused, since we disabled HEURISTIC2 */ - extern int __start[]; -# define HEURISTIC2_LIMIT ((ptr_t)((word)(__start) & ~(getpagesize()-1))) -# ifndef GC_OSF1_THREADS - /* Unresolved signal issues with threads. */ -# define MPROTECT_VDB -# endif -# define DYNAMIC_LOADING -# endif -# ifdef LINUX -# define OS_TYPE "LINUX" -# define LINUX_STACKBOTTOM -# ifdef __ELF__ -# define SEARCH_FOR_DATA_START -# define DYNAMIC_LOADING -# else -# define DATASTART ((ptr_t) 0x140000000) -# endif - extern int _end[]; -# define DATAEND (ptr_t)(_end) -# define MPROTECT_VDB - /* Has only been superficially tested. May not */ - /* work on all versions. */ -# endif -# endif - -# ifdef IA64 -# define MACH_TYPE "IA64" -# ifdef HPUX -# ifdef _ILP32 -# define CPP_WORDSZ 32 - /* Requires 8 byte alignment for malloc */ -# define ALIGNMENT 4 -# else -# ifndef _LP64 -# error --> unknown ABI -# endif -# define CPP_WORDSZ 64 - /* Requires 16 byte alignment for malloc */ -# define ALIGNMENT 8 -# endif -# define OS_TYPE "HPUX" - extern int __data_start[]; -# define DATASTART ((ptr_t)(__data_start)) - /* Gustavo Rodriguez-Rivera suggested changing HEURISTIC2 */ - /* to this. Note that the GC must be initialized before the */ - /* first putenv call. */ - extern char ** environ; -# define STACKBOTTOM ((ptr_t)environ) -# define HPUX_STACKBOTTOM -# define DYNAMIC_LOADING -# include -# define GETPAGESIZE() sysconf(_SC_PAGE_SIZE) - /* The following was empirically determined, and is probably */ - /* not very robust. */ - /* Note that the backing store base seems to be at a nice */ - /* address minus one page. */ -# define BACKING_STORE_DISPLACEMENT 0x1000000 -# define BACKING_STORE_ALIGNMENT 0x1000 - extern ptr_t GC_register_stackbottom; -# define BACKING_STORE_BASE GC_register_stackbottom - /* Known to be wrong for recent HP/UX versions!!! */ -# endif -# ifdef LINUX -# define CPP_WORDSZ 64 -# define ALIGNMENT 8 -# define OS_TYPE "LINUX" - /* The following works on NUE and older kernels: */ -/* # define STACKBOTTOM ((ptr_t) 0xa000000000000000l) */ - /* This does not work on NUE: */ -# define LINUX_STACKBOTTOM - /* We also need the base address of the register stack */ - /* backing store. */ - extern ptr_t GC_register_stackbottom; -# define BACKING_STORE_BASE GC_register_stackbottom -# define SEARCH_FOR_DATA_START -# ifdef __GNUC__ -# define DYNAMIC_LOADING -# else - /* In the Intel compiler environment, we seem to end up with */ - /* statically linked executables and an undefined reference */ - /* to _DYNAMIC */ -# endif -# define MPROTECT_VDB - /* Requires Linux 2.3.47 or later. */ - extern int _end[]; -# define DATAEND (ptr_t)(_end) -# ifdef __GNUC__ -# ifndef __INTEL_COMPILER -# define PREFETCH(x) \ - __asm__ (" lfetch [%0]": : "r"(x)) -# define PREFETCH_FOR_WRITE(x) \ - __asm__ (" lfetch.excl [%0]": : "r"(x)) -# define CLEAR_DOUBLE(x) \ - __asm__ (" stf.spill [%0]=f0": : "r"((void *)(x))) -# else -# include -# define PREFETCH(x) __lfetch(__lfhint_none, (x)) -# define PREFETCH_FOR_WRITE(x) __lfetch(__lfhint_nta, (x)) -# define CLEAR_DOUBLE(x) __stf_spill((void *)(x), 0) -# endif /* __INTEL_COMPILER */ -# endif -# endif -# ifdef CYGWIN32 -# define OS_TYPE "CYGWIN32" -# define DATASTART ((ptr_t)GC_DATASTART) /* From gc.h */ -# define DATAEND ((ptr_t)GC_DATAEND) -# undef STACK_GRAN -# define STACK_GRAN 0x10000 -# ifdef USE_MMAP -# define NEED_FIND_LIMIT -# define USE_MMAP_ANON -# endif -# endif -# ifdef MSWIN32 - /* FIXME: This is a very partial guess. There is no port, yet. */ -# define OS_TYPE "MSWIN32" - /* STACKBOTTOM and DATASTART are handled specially in */ - /* os_dep.c. */ -# define DATAEND /* not needed */ -# if defined(_WIN64) -# define CPP_WORDSZ 64 -# else -# define CPP_WORDSZ 32 /* Is this possible? */ -# endif -# define ALIGNMENT 8 -# endif -# endif - -# ifdef M88K -# define MACH_TYPE "M88K" -# define ALIGNMENT 4 - extern int etext[]; -# ifdef CX_UX -# define OS_TYPE "CX_UX" -# define DATASTART ((((word)etext + 0x3fffff) & ~0x3fffff) + 0x10000) -# endif -# ifdef DGUX -# define OS_TYPE "DGUX" - ptr_t GC_SysVGetDataStart(size_t, ptr_t); -# define DATASTART GC_SysVGetDataStart(0x10000, (ptr_t)etext) -# define DATASTART_IS_FUNC -# endif -# define STACKBOTTOM ((char*)0xf0000000) /* determined empirically */ -# endif - -# ifdef S370 - /* If this still works, and if anyone cares, this should probably */ - /* be moved to the S390 category. */ -# define MACH_TYPE "S370" -# define ALIGNMENT 4 /* Required by hardware */ -# ifdef UTS4 -# define OS_TYPE "UTS4" - extern int etext[]; - extern int _etext[]; - extern int _end[]; - ptr_t GC_SysVGetDataStart(size_t, ptr_t); -# define DATASTART GC_SysVGetDataStart(0x10000, (ptr_t)_etext) -# define DATASTART_IS_FUNC -# define DATAEND (ptr_t)(_end) -# define HEURISTIC2 -# endif -# endif - -# ifdef S390 -# define MACH_TYPE "S390" -# ifndef __s390x__ -# define ALIGNMENT 4 -# define CPP_WORDSZ 32 -# else -# define ALIGNMENT 8 -# define CPP_WORDSZ 64 -# ifndef HBLKSIZE -# define HBLKSIZE 4096 -# endif -# endif -# ifdef LINUX -# define OS_TYPE "LINUX" -# define LINUX_STACKBOTTOM -# define DYNAMIC_LOADING - extern int __data_start[] __attribute__((__weak__)); -# define DATASTART ((ptr_t)(__data_start)) - extern int _end[] __attribute__((__weak__)); -# define DATAEND (ptr_t)(_end) -# define CACHE_LINE_SIZE 256 -# define GETPAGESIZE() 4096 -# endif -# endif - -# ifdef AARCH64 -# define MACH_TYPE "AARCH64" -# ifdef __ILP32__ -# define CPP_WORDSZ 32 -# define ALIGNMENT 4 -# else -# define CPP_WORDSZ 64 -# define ALIGNMENT 8 -# endif -# ifndef HBLKSIZE -# define HBLKSIZE 4096 -# endif -# ifdef LINUX -# define OS_TYPE "LINUX" -# define LINUX_STACKBOTTOM -# define DYNAMIC_LOADING - extern int __data_start[]; -# define DATASTART ((ptr_t)__data_start) - extern char _end[]; -# define DATAEND ((ptr_t)(&_end)) -# endif -# ifdef DARWIN - /* iOS */ -# define OS_TYPE "DARWIN" -# ifndef GC_DONT_REGISTER_MAIN_STATIC_DATA -# define DYNAMIC_LOADING -# endif -# define DATASTART ((ptr_t) get_etext()) -# define DATAEND ((ptr_t) get_end()) -# define STACKBOTTOM ((ptr_t) 0x16fdfffff) -# ifndef USE_MMAP -# define USE_MMAP -# endif -# define USE_MMAP_ANON -# define MPROTECT_VDB -# include -# define GETPAGESIZE() getpagesize() - /* FIXME: There seems to be some issues with trylock hanging on */ - /* darwin. This should be looked into some more. */ -# define NO_PTHREAD_TRYLOCK -# ifndef NO_DYLD_BIND_FULLY_IMAGE -# define NO_DYLD_BIND_FULLY_IMAGE -# endif -# endif -# ifdef NOSYS - /* __data_start is usually defined in the target linker script. */ - extern int __data_start[]; -# define DATASTART ((ptr_t)__data_start) - extern void *__stack_base__; -# define STACKBOTTOM ((ptr_t)__stack_base__) -# endif -# endif - -# ifdef ARM32 -# define CPP_WORDSZ 32 -# define MACH_TYPE "ARM32" -# define ALIGNMENT 4 -# ifdef NETBSD -# define OS_TYPE "NETBSD" -# define HEURISTIC2 -# ifdef __ELF__ - extern ptr_t GC_data_start; -# define DATASTART GC_data_start -# define DYNAMIC_LOADING -# else - extern char etext[]; -# define DATASTART ((ptr_t)(etext)) -# endif -# endif -# ifdef LINUX -# define OS_TYPE "LINUX" -# define LINUX_STACKBOTTOM -# undef STACK_GRAN -# define STACK_GRAN 0x10000000 -# ifdef __ELF__ -# define DYNAMIC_LOADING -# include -# if defined(__GLIBC__) && __GLIBC__ >= 2 \ - || defined(PLATFORM_ANDROID) -# define SEARCH_FOR_DATA_START -# else - extern char **__environ; -# define DATASTART ((ptr_t)(&__environ)) - /* hideous kludge: __environ is the first */ - /* word in crt0.o, and delimits the start */ - /* of the data segment, no matter which */ - /* ld options were passed through. */ - /* We could use _etext instead, but that */ - /* would include .rodata, which may */ - /* contain large read-only data tables */ - /* that we'd rather not scan. */ -# endif - extern int _end[]; -# define DATAEND (ptr_t)(_end) -# else - extern int etext[]; -# define DATASTART ((ptr_t)((((word) (etext)) + 0xfff) & ~0xfff)) -# endif -# endif -# ifdef MSWINCE -# define OS_TYPE "MSWINCE" -# define DATAEND /* not needed */ -# endif -# ifdef FREEBSD - /* FreeBSD/arm */ -# define ALIGNMENT 4 -# define OS_TYPE "FREEBSD" -# ifdef __ELF__ -# define DYNAMIC_LOADING -# endif -# define HEURISTIC2 - extern char etext[]; -# define SEARCH_FOR_DATA_START -# endif -# ifdef DARWIN - /* iPhone */ -# define OS_TYPE "DARWIN" -# ifndef GC_DONT_REGISTER_MAIN_STATIC_DATA -# define DYNAMIC_LOADING -# endif -# define DATASTART ((ptr_t) get_etext()) -# define DATAEND ((ptr_t) get_end()) -# define STACKBOTTOM ((ptr_t) 0x30000000) -# ifndef USE_MMAP -# define USE_MMAP -# endif -# define USE_MMAP_ANON -# define MPROTECT_VDB -# include -# define GETPAGESIZE() getpagesize() - /* FIXME: There seems to be some issues with trylock hanging on */ - /* darwin. This should be looked into some more. */ -# define NO_PTHREAD_TRYLOCK -# ifndef NO_DYLD_BIND_FULLY_IMAGE -# define NO_DYLD_BIND_FULLY_IMAGE -# endif -# endif -# ifdef OPENBSD -# define ALIGNMENT 4 -# define OS_TYPE "OPENBSD" -# ifndef GC_OPENBSD_THREADS -# include -# include -# define STACKBOTTOM ((ptr_t) USRSTACK) -# endif - extern int __data_start[]; -# define DATASTART ((ptr_t)__data_start) - extern char _end[]; -# define DATAEND ((ptr_t)(&_end)) -# define DYNAMIC_LOADING -# endif -# ifdef NOSYS - /* __data_start is usually defined in the target linker script. */ - extern int __data_start[]; -# define DATASTART (ptr_t)(__data_start) - /* __stack_base__ is set in newlib/libc/sys/arm/crt0.S */ - extern void *__stack_base__; -# define STACKBOTTOM ((ptr_t) (__stack_base__)) -# endif -#endif - -# ifdef CRIS -# define MACH_TYPE "CRIS" -# define CPP_WORDSZ 32 -# define ALIGNMENT 1 -# define OS_TYPE "LINUX" -# define DYNAMIC_LOADING -# define LINUX_STACKBOTTOM -# define SEARCH_FOR_DATA_START - extern int _end[]; -# define DATAEND (ptr_t)(_end) -# endif - -# if defined(SH) && !defined(SH4) -# define MACH_TYPE "SH" -# define ALIGNMENT 4 -# ifdef MSWINCE -# define OS_TYPE "MSWINCE" -# define DATAEND /* not needed */ -# endif -# ifdef LINUX -# define OS_TYPE "LINUX" -# define LINUX_STACKBOTTOM -# define DYNAMIC_LOADING -# define SEARCH_FOR_DATA_START - extern int _end[]; -# define DATAEND (ptr_t)(_end) -# endif -# ifdef NETBSD -# define OS_TYPE "NETBSD" -# define HEURISTIC2 - extern ptr_t GC_data_start; -# define DATASTART GC_data_start -# define DYNAMIC_LOADING -# endif -# ifdef OPENBSD -# define OS_TYPE "OPENBSD" -# ifndef GC_OPENBSD_THREADS -# include -# include -# define STACKBOTTOM ((ptr_t) USRSTACK) -# endif - extern int __data_start[]; -# define DATASTART ((ptr_t)__data_start) - extern char _end[]; -# define DATAEND ((ptr_t)(&_end)) -# define DYNAMIC_LOADING -# endif -# endif - -# ifdef SH4 -# define MACH_TYPE "SH4" -# define OS_TYPE "MSWINCE" -# define ALIGNMENT 4 -# define DATAEND /* not needed */ -# endif - -# ifdef AVR32 -# define MACH_TYPE "AVR32" -# define CPP_WORDSZ 32 -# define ALIGNMENT 4 -# define OS_TYPE "LINUX" -# define DYNAMIC_LOADING -# define LINUX_STACKBOTTOM -# define SEARCH_FOR_DATA_START - extern int _end[]; -# define DATAEND (_end) -# endif - -# ifdef M32R -# define CPP_WORDSZ 32 -# define MACH_TYPE "M32R" -# define ALIGNMENT 4 -# ifdef LINUX -# define OS_TYPE "LINUX" -# define LINUX_STACKBOTTOM -# undef STACK_GRAN -# define STACK_GRAN 0x10000000 -# define DYNAMIC_LOADING -# define SEARCH_FOR_DATA_START - extern int _end[]; -# define DATAEND (ptr_t)(_end) -# endif -# endif - -# ifdef X86_64 -# define MACH_TYPE "X86_64" -# ifdef __ILP32__ -# define ALIGNMENT 4 -# define CPP_WORDSZ 32 -# else -# define ALIGNMENT 8 -# define CPP_WORDSZ 64 -# endif -# ifndef HBLKSIZE -# define HBLKSIZE 4096 -# endif -# define CACHE_LINE_SIZE 64 -# ifdef OPENBSD -# define OS_TYPE "OPENBSD" -# define ELF_CLASS ELFCLASS64 -# ifndef GC_OPENBSD_THREADS -# include -# include -# define STACKBOTTOM ((ptr_t) USRSTACK) -# endif - extern int __data_start[]; -# define DATASTART ((ptr_t)__data_start) - extern char _end[]; -# define DATAEND ((ptr_t)(&_end)) -# define DYNAMIC_LOADING -# endif -# ifdef LINUX -# define OS_TYPE "LINUX" -# define LINUX_STACKBOTTOM -# if !defined(GC_LINUX_THREADS) || !defined(REDIRECT_MALLOC) -# define MPROTECT_VDB -# else - /* We seem to get random errors in incremental mode, */ - /* possibly because Linux threads is itself a malloc client */ - /* and can't deal with the signals. */ -# endif -# ifdef __ELF__ -# define DYNAMIC_LOADING -# ifdef UNDEFINED /* includes ro data */ - extern int _etext[]; -# define DATASTART ((ptr_t)((((word) (_etext)) + 0xfff) & ~0xfff)) -# endif -# include -# define SEARCH_FOR_DATA_START - extern int _end[]; -# define DATAEND (ptr_t)(_end) -# else - extern int etext[]; -# define DATASTART ((ptr_t)((((word) (etext)) + 0xfff) & ~0xfff)) -# endif -# if defined(__GLIBC__) && !defined(__UCLIBC__) - /* At present, there's a bug in GLibc getcontext() on */ - /* Linux/x64 (it clears FPU exception mask). We define this */ - /* macro to workaround it. */ - /* FIXME: This seems to be fixed in GLibc v2.14. */ -# define GETCONTEXT_FPU_EXCMASK_BUG -# endif -# if defined(__GLIBC__) - /* Workaround lock elision implementation for some glibc. */ -# define GLIBC_2_19_TSX_BUG -# include /* for gnu_get_libc_version() */ -# endif -# endif -# ifdef DARWIN -# define OS_TYPE "DARWIN" -# define DARWIN_DONT_PARSE_STACK -# define DYNAMIC_LOADING - /* XXX: see get_end(3), get_etext() and get_end() should not be used. */ - /* These aren't used when dyld support is enabled (it is by default) */ -# define DATASTART ((ptr_t) get_etext()) -# define DATAEND ((ptr_t) get_end()) -# define STACKBOTTOM ((ptr_t) 0x7fff5fc00000) -# ifndef USE_MMAP -# define USE_MMAP -# endif -# define USE_MMAP_ANON -# define MPROTECT_VDB -# include -# define GETPAGESIZE() getpagesize() - /* There seems to be some issues with trylock hanging on darwin. */ - /* This should be looked into some more. */ -# define NO_PTHREAD_TRYLOCK -# endif -# ifdef FREEBSD -# define OS_TYPE "FREEBSD" -# ifndef GC_FREEBSD_THREADS -# define MPROTECT_VDB -# endif -# ifdef __GLIBC__ -# define SIG_SUSPEND (32+6) -# define SIG_THR_RESTART (32+5) - extern int _end[]; -# define DATAEND (ptr_t)(_end) -# else -# define SIG_SUSPEND SIGUSR1 -# define SIG_THR_RESTART SIGUSR2 - /* SIGTSTP and SIGCONT could be used alternatively. */ -# endif -# define FREEBSD_STACKBOTTOM -# ifdef __ELF__ -# define DYNAMIC_LOADING -# endif - extern char etext[]; - ptr_t GC_FreeBSDGetDataStart(size_t, ptr_t); -# define DATASTART GC_FreeBSDGetDataStart(0x1000, (ptr_t)etext) -# define DATASTART_IS_FUNC -# endif -# ifdef NETBSD -# define OS_TYPE "NETBSD" -# define HEURISTIC2 -# ifdef __ELF__ - extern ptr_t GC_data_start; -# define DATASTART GC_data_start -# define DYNAMIC_LOADING -# else -# define SEARCH_FOR_DATA_START -# endif -# endif -# ifdef SOLARIS -# define OS_TYPE "SOLARIS" -# define ELF_CLASS ELFCLASS64 - extern int _etext[], _end[]; - ptr_t GC_SysVGetDataStart(size_t, ptr_t); -# define DATASTART GC_SysVGetDataStart(0x1000, (ptr_t)_etext) -# define DATASTART_IS_FUNC -# define DATAEND (ptr_t)(_end) -/* # define STACKBOTTOM ((ptr_t)(_start)) worked through 2.7, */ -/* but reportedly breaks under 2.8. It appears that the stack */ -/* base is a property of the executable, so this should not break */ -/* old executables. */ -/* HEURISTIC2 probably works, but this appears to be preferable. */ -/* Apparently USRSTACK is defined to be USERLIMIT, but in some */ -/* installations that's undefined. We work around this with a */ -/* gross hack: */ -# include -# ifdef USERLIMIT - /* This should work everywhere, but doesn't. */ -# define STACKBOTTOM ((ptr_t) USRSTACK) -# else -# define HEURISTIC2 -# endif -/* At least in Solaris 2.5, PROC_VDB gives wrong values for dirty bits. */ -/* It appears to be fixed in 2.8 and 2.9. */ -# ifdef SOLARIS25_PROC_VDB_BUG_FIXED -# define PROC_VDB -# endif -# ifndef GC_THREADS -# define MPROTECT_VDB -# endif -# define DYNAMIC_LOADING -# if !defined(USE_MMAP) && defined(REDIRECT_MALLOC) -# define USE_MMAP - /* Otherwise we now use calloc. Mmap may result in the */ - /* heap interleaved with thread stacks, which can result in */ - /* excessive blacklisting. Sbrk is unusable since it */ - /* doesn't interact correctly with the system malloc. */ -# endif -# ifdef USE_MMAP -# define HEAP_START (ptr_t)0x40000000 -# else -# define HEAP_START DATAEND -# endif -# endif -# ifdef MSWIN32 -# define OS_TYPE "MSWIN32" - /* STACKBOTTOM and DATASTART are handled specially in */ - /* os_dep.c. */ -# if !defined(__GNUC__) || defined(__INTEL_COMPILER) - /* GCC does not currently support SetUnhandledExceptionFilter */ - /* (does not generate SEH unwinding information) on x64. */ -# define MPROTECT_VDB -# endif -# define GWW_VDB -# define DATAEND /* not needed */ -# endif -# endif /* X86_64 */ - -# ifdef HEXAGON -# define CPP_WORDSZ 32 -# define MACH_TYPE "HEXAGON" -# define ALIGNMENT 4 -# ifdef LINUX -# define OS_TYPE "LINUX" -# define LINUX_STACKBOTTOM -# define MPROTECT_VDB -# ifdef __ELF__ -# define DYNAMIC_LOADING -# include -# if defined(__GLIBC__) && __GLIBC__ >= 2 -# define SEARCH_FOR_DATA_START -# else -# error --> unknown Hexagon libc configuration -# endif - extern int _end[]; -# define DATAEND (ptr_t)(_end) -# else -# error --> bad Hexagon Linux configuration -# endif -# else -# error --> unknown Hexagon OS configuration -# endif -# endif - -#if defined(__GLIBC__) && !defined(DONT_USE_LIBC_PRIVATES) - /* Use glibc's stack-end marker. */ -# define USE_LIBC_PRIVATES -#endif - -#if defined(LINUX_STACKBOTTOM) && defined(NO_PROC_STAT) \ - && !defined(USE_LIBC_PRIVATES) - /* This combination will fail, since we have no way to get */ - /* the stack base. Use HEURISTIC2 instead. */ -# undef LINUX_STACKBOTTOM -# define HEURISTIC2 - /* This may still fail on some architectures like IA64. */ - /* We tried ... */ -#endif - -#if defined(LINUX) && defined(USE_MMAP) - /* The kernel may do a somewhat better job merging mappings etc. */ - /* with anonymous mappings. */ -# define USE_MMAP_ANON -#endif - -#if defined(GC_LINUX_THREADS) && defined(REDIRECT_MALLOC) \ - && !defined(USE_PROC_FOR_LIBRARIES) - /* Nptl allocates thread stacks with mmap, which is fine. But it */ - /* keeps a cache of thread stacks. Thread stacks contain the */ - /* thread control blocks. These in turn contain a pointer to */ - /* (sizeof (void *) from the beginning of) the dtv for thread-local */ - /* storage, which is calloc allocated. If we don't scan the cached */ - /* thread stacks, we appear to lose the dtv. This tends to */ - /* result in something that looks like a bogus dtv count, which */ - /* tends to result in a memset call on a block that is way too */ - /* large. Sometimes we're lucky and the process just dies ... */ - /* There seems to be a similar issue with some other memory */ - /* allocated by the dynamic loader. */ - /* This should be avoidable by either: */ - /* - Defining USE_PROC_FOR_LIBRARIES here. */ - /* That performs very poorly, precisely because we end up */ - /* scanning cached stacks. */ - /* - Have calloc look at its callers. */ - /* In spite of the fact that it is gross and disgusting. */ - /* In fact neither seems to suffice, probably in part because */ - /* even with USE_PROC_FOR_LIBRARIES, we don't scan parts of stack */ - /* segments that appear to be out of bounds. Thus we actually */ - /* do both, which seems to yield the best results. */ - -# define USE_PROC_FOR_LIBRARIES -#endif - -#ifndef STACK_GROWS_UP -# define STACK_GROWS_DOWN -#endif - -#ifndef CPP_WORDSZ -# define CPP_WORDSZ 32 -#endif - -#ifndef OS_TYPE -# define OS_TYPE "" -#endif - -#ifndef DATAEND - extern int end[]; -# define DATAEND (ptr_t)(end) -#endif - -#if defined(PLATFORM_ANDROID) && !defined(THREADS) \ - && !defined(USE_GET_STACKBASE_FOR_MAIN) - /* Always use pthread_attr_getstack on Android ("-lpthread" option is */ - /* not needed to be specified manually) since GC_linux_main_stack_base */ - /* causes app crash if invoked inside Dalvik VM. */ -# define USE_GET_STACKBASE_FOR_MAIN -#endif - -#if (defined(SVR4) || defined(PLATFORM_ANDROID)) && !defined(GETPAGESIZE) -# include -# define GETPAGESIZE() sysconf(_SC_PAGESIZE) -#endif - -#ifndef GETPAGESIZE -# if defined(SOLARIS) || defined(IRIX5) || defined(LINUX) \ - || defined(NETBSD) || defined(FREEBSD) || defined(HPUX) -# include -# endif -# define GETPAGESIZE() getpagesize() -#endif - -#if defined(SOLARIS) || defined(DRSNX) || defined(UTS4) - /* OS has SVR4 generic features. */ - /* Probably others also qualify. */ -# define SVR4 -#endif - -#if defined(SOLARIS) || defined(DRSNX) - /* OS has SOLARIS style semi-undocumented interface */ - /* to dynamic loader. */ -# define SOLARISDL - /* OS has SOLARIS style signal handlers. */ -# define SUNOS5SIGS -#endif - -#if defined(HPUX) -# define SUNOS5SIGS -#endif - -#if defined(FREEBSD) && (defined(__DragonFly__) || __FreeBSD__ >= 4 \ - || (__FreeBSD_kernel__ >= 4)) -# define SUNOS5SIGS -#endif - -#if !defined(GC_EXPLICIT_SIGNALS_UNBLOCK) && defined(SUNOS5SIGS) \ - && !defined(GC_NO_PTHREAD_SIGMASK) -# define GC_EXPLICIT_SIGNALS_UNBLOCK -#endif - -#ifdef GC_NETBSD_THREADS -# define SIGRTMIN 33 -# define SIGRTMAX 63 -#endif - -#ifdef GC_OPENBSD_THREADS -# include - /* Prior to 5.2 release, OpenBSD had user threads and required */ - /* special handling. */ -# if OpenBSD < 201211 -# define GC_OPENBSD_UTHREADS 1 -# endif -#endif /* GC_OPENBSD_THREADS */ - -#if defined(SVR4) || defined(LINUX) || defined(IRIX5) || defined(HPUX) \ - || defined(OPENBSD) || defined(NETBSD) || defined(FREEBSD) \ - || defined(DGUX) || defined(BSD) || defined(HURD) \ - || defined(AIX) || defined(DARWIN) || defined(OSF1) -# define UNIX_LIKE /* Basic Unix-like system calls work. */ -#endif - -#if CPP_WORDSZ != 32 && CPP_WORDSZ != 64 -# error --> bad word size -#endif - -#ifndef ALIGNMENT -# error --> undefined ALIGNMENT -#endif - -#ifdef PCR -# undef DYNAMIC_LOADING -# undef STACKBOTTOM -# undef HEURISTIC1 -# undef HEURISTIC2 -# undef PROC_VDB -# undef MPROTECT_VDB -# define PCR_VDB -#endif - -#if !defined(STACKBOTTOM) && (defined(ECOS) || defined(NOSYS)) -# error --> undefined STACKBOTTOM -#endif - -#ifdef IGNORE_DYNAMIC_LOADING -# undef DYNAMIC_LOADING -#endif - -#if defined(SMALL_CONFIG) && !defined(GC_DISABLE_INCREMENTAL) - /* Presumably not worth the space it takes. */ -# define GC_DISABLE_INCREMENTAL -#endif - -#if (defined(MSWIN32) || defined(MSWINCE)) && !defined(USE_WINALLOC) - /* USE_WINALLOC is only an option for Cygwin. */ -# define USE_WINALLOC -#endif - -#ifdef USE_WINALLOC -# undef USE_MMAP -#endif - -#if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS) || defined(IRIX5) \ - || ((defined(USE_MMAP) || defined(USE_MUNMAP)) && !defined(USE_WINALLOC)) -# define MMAP_SUPPORTED -#endif - -#if defined(GC_DISABLE_INCREMENTAL) || defined(MANUAL_VDB) -# undef GWW_VDB -# undef MPROTECT_VDB -# undef PCR_VDB -# undef PROC_VDB -#endif - -#ifdef GC_DISABLE_INCREMENTAL -# undef CHECKSUMS -#endif - -#ifdef USE_GLOBAL_ALLOC - /* Cannot pass MEM_WRITE_WATCH to GlobalAlloc(). */ -# undef GWW_VDB -#endif - -#ifdef USE_MUNMAP - /* FIXME: Remove this undef if possible. */ -# undef MPROTECT_VDB /* Can't deal with address space holes. */ -#endif - -/* PARALLEL_MARK does not cause undef MPROTECT_VDB any longer. */ - -#if defined(MPROTECT_VDB) && defined(GC_PREFER_MPROTECT_VDB) - /* Choose MPROTECT_VDB manually (if multiple strategies available). */ -# undef PCR_VDB -# undef PROC_VDB - /* #undef GWW_VDB - handled in os_dep.c */ -#endif - -#ifdef PROC_VDB - /* Multi-VDB mode is not implemented. */ -# undef MPROTECT_VDB -#endif - -#if !defined(PCR_VDB) && !defined(PROC_VDB) && !defined(MPROTECT_VDB) \ - && !defined(GWW_VDB) && !defined(MANUAL_VDB) \ - && !defined(GC_DISABLE_INCREMENTAL) -# define DEFAULT_VDB -#endif - -#if ((defined(UNIX_LIKE) && (defined(DARWIN) || defined(HURD) \ - || defined(OPENBSD) || defined(ARM32) \ - || defined(MIPS) || defined(AVR32) \ - || defined(OR1K))) \ - || (defined(LINUX) && (defined(SPARC) || defined(M68K))) \ - || ((defined(RTEMS) || defined(PLATFORM_ANDROID)) && defined(I386))) \ - && !defined(NO_GETCONTEXT) -# define NO_GETCONTEXT -#endif - -#ifndef PREFETCH -# if defined(__GNUC__) && __GNUC__ >= 3 && !defined(NO_PREFETCH) -# define PREFETCH(x) __builtin_prefetch((x), 0, 0) -# else -# define PREFETCH(x) (void)0 -# endif -#endif - -#ifndef PREFETCH_FOR_WRITE -# if defined(__GNUC__) && __GNUC__ >= 3 && !defined(NO_PREFETCH_FOR_WRITE) -# define PREFETCH_FOR_WRITE(x) __builtin_prefetch((x), 1) -# else -# define PREFETCH_FOR_WRITE(x) (void)0 -# endif -#endif - -#ifndef CACHE_LINE_SIZE -# define CACHE_LINE_SIZE 32 /* Wild guess */ -#endif - -#ifndef STATIC -# ifndef NO_DEBUGGING -# define STATIC /* ignore to aid profiling and possibly debugging */ -# else -# define STATIC static -# endif -#endif - -#if defined(LINUX) && (defined(USE_PROC_FOR_LIBRARIES) || defined(IA64) \ - || !defined(SMALL_CONFIG)) -# define NEED_PROC_MAPS -#endif - -#if defined(LINUX) || defined(HURD) || defined(__GLIBC__) -# define REGISTER_LIBRARIES_EARLY - /* We sometimes use dl_iterate_phdr, which may acquire an internal */ - /* lock. This isn't safe after the world has stopped. So we must */ - /* call GC_register_dynamic_libraries before stopping the world. */ - /* For performance reasons, this may be beneficial on other */ - /* platforms as well, though it should be avoided in win32. */ -#endif /* LINUX */ - -#if defined(SEARCH_FOR_DATA_START) - extern ptr_t GC_data_start; -# define DATASTART GC_data_start -#endif - -#ifndef CLEAR_DOUBLE -# define CLEAR_DOUBLE(x) (((word*)(x))[0] = 0, ((word*)(x))[1] = 0) -#endif - -#if defined(GC_LINUX_THREADS) && defined(REDIRECT_MALLOC) \ - && !defined(INCLUDE_LINUX_THREAD_DESCR) - /* Will not work, since libc and the dynamic loader use thread */ - /* locals, sometimes as the only reference. */ -# define INCLUDE_LINUX_THREAD_DESCR -#endif - -#if defined(GC_IRIX_THREADS) && !defined(IRIX5) -# error --> inconsistent configuration -#endif -#if defined(GC_LINUX_THREADS) && !defined(LINUX) && !defined(NACL) -# error --> inconsistent configuration -#endif -#if defined(GC_NETBSD_THREADS) && !defined(NETBSD) -# error --> inconsistent configuration -#endif -#if defined(GC_FREEBSD_THREADS) && !defined(FREEBSD) -# error --> inconsistent configuration -#endif -#if defined(GC_SOLARIS_THREADS) && !defined(SOLARIS) -# error --> inconsistent configuration -#endif -#if defined(GC_HPUX_THREADS) && !defined(HPUX) -# error --> inconsistent configuration -#endif -#if defined(GC_AIX_THREADS) && !defined(_AIX) -# error --> inconsistent configuration -#endif -#if defined(GC_GNU_THREADS) && !defined(HURD) -# error --> inconsistent configuration -#endif -#if defined(GC_WIN32_THREADS) && !defined(MSWIN32) && !defined(CYGWIN32) \ - && !defined(MSWINCE) -# error --> inconsistent configuration -#endif - -#if defined(PCR) || defined(GC_WIN32_THREADS) || defined(GC_PTHREADS) \ - || defined(SN_TARGET_PS3) -# define THREADS -#endif - -#if defined(PARALLEL_MARK) && !defined(THREADS) -# error "invalid config - PARALLEL_MARK requires GC_THREADS" -#endif - -#if defined(UNIX_LIKE) && defined(THREADS) && !defined(NO_CANCEL_SAFE) \ - && !defined(PLATFORM_ANDROID) - /* Make the code cancellation-safe. This basically means that we */ - /* ensure that cancellation requests are ignored while we are in */ - /* the collector. This applies only to Posix deferred cancellation; */ - /* we don't handle Posix asynchronous cancellation. */ - /* Note that this only works if pthread_setcancelstate is */ - /* async-signal-safe, at least in the absence of asynchronous */ - /* cancellation. This appears to be true for the glibc version, */ - /* though it is not documented. Without that assumption, there */ - /* seems to be no way to safely wait in a signal handler, which */ - /* we need to do for thread suspension. */ - /* Also note that little other code appears to be cancellation-safe. */ - /* Hence it may make sense to turn this off for performance. */ -# define CANCEL_SAFE -#endif - -#ifdef CANCEL_SAFE -# define IF_CANCEL(x) x -#else -# define IF_CANCEL(x) /* empty */ -#endif - -#if !defined(CAN_HANDLE_FORK) && !defined(NO_HANDLE_FORK) \ - && !defined(HAVE_NO_FORK) \ - && ((defined(GC_PTHREADS) && !defined(NACL) \ - && !defined(GC_WIN32_PTHREADS) && !defined(USE_WINALLOC)) \ - || (defined(DARWIN) && defined(MPROTECT_VDB)) || defined(HANDLE_FORK)) - /* Attempts (where supported and requested) to make GC_malloc work in */ - /* a child process fork'ed from a multi-threaded parent. */ -# define CAN_HANDLE_FORK -#endif - -#if defined(CAN_HANDLE_FORK) && !defined(CAN_CALL_ATFORK) \ - && !defined(HURD) && !defined(PLATFORM_ANDROID) - /* Have working pthread_atfork(). */ -# define CAN_CALL_ATFORK -#endif - -#if !defined(CAN_HANDLE_FORK) && !defined(HAVE_NO_FORK) \ - && (defined(MSWIN32) || defined(MSWINCE) || defined(DOS4GW) \ - || defined(OS2) || defined(SYMBIAN) /* and probably others ... */) -# define HAVE_NO_FORK -#endif - -#if !defined(USE_MARK_BITS) && !defined(USE_MARK_BYTES) \ - && defined(PARALLEL_MARK) - /* Minimize compare-and-swap usage. */ -# define USE_MARK_BYTES -#endif - -#if defined(MSWINCE) && !defined(__CEGCC__) && !defined(NO_GETENV) -# define NO_GETENV -#endif - -#if (defined(NO_GETENV) || defined(MSWINCE)) && !defined(NO_GETENV_WIN32) -# define NO_GETENV_WIN32 -#endif - -#ifndef STRTOULL -# if defined(_WIN64) && !defined(__GNUC__) -# define STRTOULL _strtoui64 -# elif defined(_LLP64) || defined(__LLP64__) || defined(_WIN64) -# define STRTOULL strtoull -# else - /* strtoul() fits since sizeof(long) >= sizeof(word). */ -# define STRTOULL strtoul -# endif -#endif /* !STRTOULL */ - -#ifndef GC_WORD_C -# if defined(_WIN64) && !defined(__GNUC__) -# define GC_WORD_C(val) val##ui64 -# elif defined(_LLP64) || defined(__LLP64__) || defined(_WIN64) -# define GC_WORD_C(val) val##ULL -# else -# define GC_WORD_C(val) ((word)val##UL) -# endif -#endif /* !GC_WORD_C */ - -#if defined(SPARC) -# define ASM_CLEAR_CODE /* Stack clearing is crucial, and we */ - /* include assembly code to do it well. */ -#endif - -/* Can we save call chain in objects for debugging? */ -/* SET NFRAMES (# of saved frames) and NARGS (#of args for each */ -/* frame) to reasonable values for the platform. */ -/* Set SAVE_CALL_CHAIN if we can. SAVE_CALL_COUNT can be specified */ -/* at build time, though we feel free to adjust it slightly. */ -/* Define NEED_CALLINFO if we either save the call stack or */ -/* GC_ADD_CALLER is defined. */ -/* GC_CAN_SAVE_CALL_STACKS is set in gc.h. */ -#if defined(SPARC) -# define CAN_SAVE_CALL_ARGS -#endif -#if (defined(I386) || defined(X86_64)) \ - && (defined(LINUX) || defined(__GLIBC__)) - /* SAVE_CALL_CHAIN is supported if the code is compiled to save */ - /* frame pointers by default, i.e. no -fomit-frame-pointer flag. */ -# define CAN_SAVE_CALL_ARGS -#endif - -#if defined(SAVE_CALL_COUNT) && !defined(GC_ADD_CALLER) \ - && defined(GC_CAN_SAVE_CALL_STACKS) -# define SAVE_CALL_CHAIN -#endif -#ifdef SAVE_CALL_CHAIN -# if defined(SAVE_CALL_NARGS) && defined(CAN_SAVE_CALL_ARGS) -# define NARGS SAVE_CALL_NARGS -# else -# define NARGS 0 /* Number of arguments to save for each call. */ -# endif -#endif -#ifdef SAVE_CALL_CHAIN -# ifndef SAVE_CALL_COUNT -# define NFRAMES 6 /* Number of frames to save. Even for */ - /* alignment reasons. */ -# else -# define NFRAMES ((SAVE_CALL_COUNT + 1) & ~1) -# endif -# define NEED_CALLINFO -#endif /* SAVE_CALL_CHAIN */ -#ifdef GC_ADD_CALLER -# define NFRAMES 1 -# define NARGS 0 -# define NEED_CALLINFO -#endif - -#if (defined(FREEBSD) || (defined(DARWIN) && !defined(_POSIX_C_SOURCE)) \ - || (defined(SOLARIS) && (!defined(_XOPEN_SOURCE) \ - || defined(__EXTENSIONS__))) \ - || defined(LINUX)) && !defined(HAVE_DLADDR) -# define HAVE_DLADDR -#endif - -#if defined(MAKE_BACK_GRAPH) && !defined(DBG_HDRS_ALL) -# define DBG_HDRS_ALL -#endif - -#if defined(POINTER_MASK) && !defined(POINTER_SHIFT) -# define POINTER_SHIFT 0 -#endif - -#if defined(POINTER_SHIFT) && !defined(POINTER_MASK) -# define POINTER_MASK ((GC_word)(-1)) -#endif - -#if !defined(FIXUP_POINTER) && defined(POINTER_MASK) -# define FIXUP_POINTER(p) (p = ((p) & POINTER_MASK) << POINTER_SHIFT) -#endif - -#if defined(FIXUP_POINTER) -# define NEED_FIXUP_POINTER 1 -#else -# define NEED_FIXUP_POINTER 0 -# define FIXUP_POINTER(p) -#endif - -#if !defined(MARK_BIT_PER_GRANULE) && !defined(MARK_BIT_PER_OBJ) -# define MARK_BIT_PER_GRANULE /* Usually faster */ -#endif - -/* Some static sanity tests. */ -#if defined(MARK_BIT_PER_GRANULE) && defined(MARK_BIT_PER_OBJ) -# error Define only one of MARK_BIT_PER_GRANULE and MARK_BIT_PER_OBJ. -#endif - -#if defined(STACK_GROWS_UP) && defined(STACK_GROWS_DOWN) -# error "Only one of STACK_GROWS_UP and STACK_GROWS_DOWN should be defd." -#endif -#if !defined(STACK_GROWS_UP) && !defined(STACK_GROWS_DOWN) -# error "One of STACK_GROWS_UP and STACK_GROWS_DOWN should be defd." -#endif - -#if defined(REDIRECT_MALLOC) && defined(THREADS) && !defined(LINUX) -# error "REDIRECT_MALLOC with THREADS works at most on Linux." -#endif - -#ifdef GC_PRIVATE_H - /* This relies on some type definitions from gc_priv.h, from */ - /* where it's normally included. */ - /* */ - /* How to get heap memory from the OS: */ - /* Note that sbrk()-like allocation is preferred, since it */ - /* usually makes it possible to merge consecutively allocated */ - /* chunks. It also avoids unintended recursion with */ - /* REDIRECT_MALLOC macro defined. */ - /* GET_MEM() returns a HLKSIZE aligned chunk. */ - /* 0 is taken to mean failure. */ - /* In case of MMAP_SUPPORTED, the argument must also be */ - /* a multiple of a physical page size. */ - /* GET_MEM is currently not assumed to retrieve 0 filled space, */ - /* though we should perhaps take advantage of the case in which */ - /* does. */ - struct hblk; /* See gc_priv.h. */ -# if defined(PCR) - char * real_malloc(size_t bytes); -# define GET_MEM(bytes) HBLKPTR(real_malloc((size_t)(bytes) + GC_page_size) \ - + GC_page_size-1) -# elif defined(OS2) - void * os2_alloc(size_t bytes); -# define GET_MEM(bytes) HBLKPTR((ptr_t)os2_alloc((size_t)(bytes) \ - + GC_page_size) + GC_page_size-1) -# elif defined(NEXT) || defined(DOS4GW) || defined(NONSTOP) \ - || (defined(AMIGA) && !defined(GC_AMIGA_FASTALLOC)) \ - || (defined(SOLARIS) && !defined(USE_MMAP)) || defined(RTEMS) \ - || defined(__CC_ARM) -# define GET_MEM(bytes) HBLKPTR((size_t)calloc(1, \ - (size_t)(bytes) + GC_page_size) \ - + GC_page_size - 1) -# elif defined(MSWIN32) || defined(CYGWIN32) - ptr_t GC_win32_get_mem(GC_word bytes); -# define GET_MEM(bytes) (struct hblk *)GC_win32_get_mem(bytes) -# elif defined(MACOS) -# if defined(USE_TEMPORARY_MEMORY) - Ptr GC_MacTemporaryNewPtr(size_t size, Boolean clearMemory); -# define GET_MEM(bytes) HBLKPTR( \ - GC_MacTemporaryNewPtr((bytes) + GC_page_size, true) \ - + GC_page_size-1) -# else -# define GET_MEM(bytes) HBLKPTR(NewPtrClear((bytes) + GC_page_size) \ - + GC_page_size-1) -# endif -# elif defined(MSWINCE) - ptr_t GC_wince_get_mem(GC_word bytes); -# define GET_MEM(bytes) (struct hblk *)GC_wince_get_mem(bytes) -# elif defined(AMIGA) && defined(GC_AMIGA_FASTALLOC) - void *GC_amiga_get_mem(size_t size); -# define GET_MEM(bytes) HBLKPTR((size_t) \ - GC_amiga_get_mem((size_t)(bytes) + GC_page_size) \ - + GC_page_size-1) -# elif defined(SN_TARGET_PS3) - void *ps3_get_mem(size_t size); -# define GET_MEM(bytes) (struct hblk*)ps3_get_mem(bytes) -# else - ptr_t GC_unix_get_mem(GC_word bytes); -# define GET_MEM(bytes) (struct hblk *)GC_unix_get_mem(bytes) -# endif -#endif /* GC_PRIVATE_H */ - -#endif /* GCCONFIG_H */ diff -Nru ecl-16.1.2/src/bdwgc/include/private/gc_hdrs.h ecl-16.1.3+ds/src/bdwgc/include/private/gc_hdrs.h --- ecl-16.1.2/src/bdwgc/include/private/gc_hdrs.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/private/gc_hdrs.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,212 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#ifndef GC_HEADERS_H -#define GC_HEADERS_H - -typedef struct hblkhdr hdr; - -#if CPP_WORDSZ != 32 && CPP_WORDSZ < 36 - --> Get a real machine. -#endif - -/* - * The 2 level tree data structure that is used to find block headers. - * If there are more than 32 bits in a pointer, the top level is a hash - * table. - * - * This defines HDR, GET_HDR, and SET_HDR, the main macros used to - * retrieve and set object headers. - * - * We take advantage of a header lookup - * cache. This is a locally declared direct mapped cache, used inside - * the marker. The HC_GET_HDR macro uses and maintains this - * cache. Assuming we get reasonable hit rates, this shaves a few - * memory references from each pointer validation. - */ - -#if CPP_WORDSZ > 32 -# define HASH_TL -#endif - -/* Define appropriate out-degrees for each of the two tree levels */ -#if defined(LARGE_CONFIG) || !defined(SMALL_CONFIG) -# define LOG_BOTTOM_SZ 10 -#else -# define LOG_BOTTOM_SZ 11 - /* Keep top index size reasonable with smaller blocks. */ -#endif -#define BOTTOM_SZ (1 << LOG_BOTTOM_SZ) - -#ifndef HASH_TL -# define LOG_TOP_SZ (WORDSZ - LOG_BOTTOM_SZ - LOG_HBLKSIZE) -#else -# define LOG_TOP_SZ 11 -#endif -#define TOP_SZ (1 << LOG_TOP_SZ) - -/* #define COUNT_HDR_CACHE_HITS */ - -#ifdef COUNT_HDR_CACHE_HITS - extern word GC_hdr_cache_hits; /* used for debugging/profiling */ - extern word GC_hdr_cache_misses; -# define HC_HIT() ++GC_hdr_cache_hits -# define HC_MISS() ++GC_hdr_cache_misses -#else -# define HC_HIT() -# define HC_MISS() -#endif - -typedef struct hce { - word block_addr; /* right shifted by LOG_HBLKSIZE */ - hdr * hce_hdr; -} hdr_cache_entry; - -#define HDR_CACHE_SIZE 8 /* power of 2 */ - -#define DECLARE_HDR_CACHE \ - hdr_cache_entry hdr_cache[HDR_CACHE_SIZE] - -#define INIT_HDR_CACHE BZERO(hdr_cache, sizeof(hdr_cache)) - -#define HCE(h) hdr_cache + (((word)(h) >> LOG_HBLKSIZE) & (HDR_CACHE_SIZE-1)) - -#define HCE_VALID_FOR(hce,h) ((hce) -> block_addr == \ - ((word)(h) >> LOG_HBLKSIZE)) - -#define HCE_HDR(h) ((hce) -> hce_hdr) - -#ifdef PRINT_BLACK_LIST - GC_INNER hdr * GC_header_cache_miss(ptr_t p, hdr_cache_entry *hce, - ptr_t source); -# define HEADER_CACHE_MISS(p, hce, source) \ - GC_header_cache_miss(p, hce, source) -#else - GC_INNER hdr * GC_header_cache_miss(ptr_t p, hdr_cache_entry *hce); -# define HEADER_CACHE_MISS(p, hce, source) GC_header_cache_miss(p, hce) -#endif - -/* Set hhdr to the header for p. Analogous to GET_HDR below, */ -/* except that in the case of large objects, it */ -/* gets the header for the object beginning, if GC_all_interior_ptrs */ -/* is set. */ -/* Returns zero if p points to somewhere other than the first page */ -/* of an object, and it is not a valid pointer to the object. */ -#define HC_GET_HDR(p, hhdr, source, exit_label) \ - do { \ - hdr_cache_entry * hce = HCE(p); \ - if (EXPECT(HCE_VALID_FOR(hce, p), TRUE)) { \ - HC_HIT(); \ - hhdr = hce -> hce_hdr; \ - } else { \ - hhdr = HEADER_CACHE_MISS(p, hce, source); \ - if (0 == hhdr) goto exit_label; \ - } \ - } while (0) - -typedef struct bi { - hdr * index[BOTTOM_SZ]; - /* - * The bottom level index contains one of three kinds of values: - * 0 means we're not responsible for this block, - * or this is a block other than the first one in a free block. - * 1 < (long)X <= MAX_JUMP means the block starts at least - * X * HBLKSIZE bytes before the current address. - * A valid pointer points to a hdr structure. (The above can't be - * valid pointers due to the GET_MEM return convention.) - */ - struct bi * asc_link; /* All indices are linked in */ - /* ascending order... */ - struct bi * desc_link; /* ... and in descending order. */ - word key; /* high order address bits. */ -# ifdef HASH_TL - struct bi * hash_link; /* Hash chain link. */ -# endif -} bottom_index; - -/* bottom_index GC_all_nils; - really part of GC_arrays */ - -/* extern bottom_index * GC_top_index []; - really part of GC_arrays */ - /* Each entry points to a bottom_index. */ - /* On a 32 bit machine, it points to */ - /* the index for a set of high order */ - /* bits equal to the index. For longer */ - /* addresses, we hash the high order */ - /* bits to compute the index in */ - /* GC_top_index, and each entry points */ - /* to a hash chain. */ - /* The last entry in each chain is */ - /* GC_all_nils. */ - - -#define MAX_JUMP (HBLKSIZE - 1) - -#define HDR_FROM_BI(bi, p) \ - ((bi)->index[((word)(p) >> LOG_HBLKSIZE) & (BOTTOM_SZ - 1)]) -#ifndef HASH_TL -# define BI(p) (GC_top_index \ - [(word)(p) >> (LOG_BOTTOM_SZ + LOG_HBLKSIZE)]) -# define HDR_INNER(p) HDR_FROM_BI(BI(p),p) -# ifdef SMALL_CONFIG -# define HDR(p) GC_find_header((ptr_t)(p)) -# else -# define HDR(p) HDR_INNER(p) -# endif -# define GET_BI(p, bottom_indx) (void)((bottom_indx) = BI(p)) -# define GET_HDR(p, hhdr) (void)((hhdr) = HDR(p)) -# define SET_HDR(p, hhdr) (void)(HDR_INNER(p) = (hhdr)) -# define GET_HDR_ADDR(p, ha) (void)((ha) = &HDR_INNER(p)) -#else /* hash */ - /* Hash function for tree top level */ -# define TL_HASH(hi) ((hi) & (TOP_SZ - 1)) - /* Set bottom_indx to point to the bottom index for address p */ -# define GET_BI(p, bottom_indx) \ - do { \ - register word hi = \ - (word)(p) >> (LOG_BOTTOM_SZ + LOG_HBLKSIZE); \ - register bottom_index * _bi = GC_top_index[TL_HASH(hi)]; \ - while (_bi -> key != hi && _bi != GC_all_nils) \ - _bi = _bi -> hash_link; \ - (bottom_indx) = _bi; \ - } while (0) -# define GET_HDR_ADDR(p, ha) \ - do { \ - register bottom_index * bi; \ - GET_BI(p, bi); \ - (ha) = &HDR_FROM_BI(bi, p); \ - } while (0) -# define GET_HDR(p, hhdr) \ - do { \ - register hdr ** _ha; \ - GET_HDR_ADDR(p, _ha); \ - (hhdr) = *_ha; \ - } while (0) -# define SET_HDR(p, hhdr) \ - do { \ - register hdr ** _ha; \ - GET_HDR_ADDR(p, _ha); \ - *_ha = (hhdr); \ - } while (0) -# define HDR(p) GC_find_header((ptr_t)(p)) -#endif - -/* Is the result a forwarding address to someplace closer to the */ -/* beginning of the block or NULL? */ -#define IS_FORWARDING_ADDR_OR_NIL(hhdr) ((size_t) (hhdr) <= MAX_JUMP) - -/* Get an HBLKSIZE aligned address closer to the beginning of the block */ -/* h. Assumes hhdr == HDR(h) and IS_FORWARDING_ADDR(hhdr). */ -#define FORWARDED_ADDR(h, hhdr) ((struct hblk *)(h) - (size_t)(hhdr)) - -#endif /* GC_HEADERS_H */ diff -Nru ecl-16.1.2/src/bdwgc/include/private/gc_locks.h ecl-16.1.3+ds/src/bdwgc/include/private/gc_locks.h --- ecl-16.1.2/src/bdwgc/include/private/gc_locks.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/private/gc_locks.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,231 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 1999 by Hewlett-Packard Company. All rights reserved. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#ifndef GC_LOCKS_H -#define GC_LOCKS_H - -/* - * Mutual exclusion between allocator/collector routines. - * Needed if there is more than one allocator thread. - * DCL_LOCK_STATE declares any local variables needed by LOCK and UNLOCK. - * - * Note that I_HOLD_LOCK and I_DONT_HOLD_LOCK are used only positively - * in assertions, and may return TRUE in the "don't know" case. - */ -# ifdef THREADS - -# if defined(GC_PTHREADS) && !defined(GC_WIN32_THREADS) -# include "atomic_ops.h" -# endif - -# ifdef PCR -# include -# include - GC_EXTERN PCR_Th_ML GC_allocate_ml; -# define DCL_LOCK_STATE \ - PCR_ERes GC_fastLockRes; PCR_sigset_t GC_old_sig_mask -# define UNCOND_LOCK() PCR_Th_ML_Acquire(&GC_allocate_ml) -# define UNCOND_UNLOCK() PCR_Th_ML_Release(&GC_allocate_ml) -# endif - -# if (!defined(AO_HAVE_test_and_set_acquire) || defined(GC_RTEMS_PTHREADS) \ - || defined(SN_TARGET_PS3) || defined(GC_WIN32_THREADS) \ - || defined(LINT2)) && defined(GC_PTHREADS) -# define USE_PTHREAD_LOCKS -# endif - -# if defined(GC_WIN32_THREADS) && !defined(USE_PTHREAD_LOCKS) -# ifndef WIN32_LEAN_AND_MEAN -# define WIN32_LEAN_AND_MEAN 1 -# endif -# define NOSERVICE -# include -# define NO_THREAD (DWORD)(-1) - GC_EXTERN CRITICAL_SECTION GC_allocate_ml; -# ifdef GC_ASSERTIONS - GC_EXTERN DWORD GC_lock_holder; -# define SET_LOCK_HOLDER() GC_lock_holder = GetCurrentThreadId() -# define UNSET_LOCK_HOLDER() GC_lock_holder = NO_THREAD -# define I_HOLD_LOCK() (!GC_need_to_lock \ - || GC_lock_holder == GetCurrentThreadId()) -# define I_DONT_HOLD_LOCK() (!GC_need_to_lock \ - || GC_lock_holder != GetCurrentThreadId()) -# define UNCOND_LOCK() \ - { GC_ASSERT(I_DONT_HOLD_LOCK()); \ - EnterCriticalSection(&GC_allocate_ml); \ - SET_LOCK_HOLDER(); } -# define UNCOND_UNLOCK() \ - { GC_ASSERT(I_HOLD_LOCK()); UNSET_LOCK_HOLDER(); \ - LeaveCriticalSection(&GC_allocate_ml); } -# else -# define UNCOND_LOCK() EnterCriticalSection(&GC_allocate_ml) -# define UNCOND_UNLOCK() LeaveCriticalSection(&GC_allocate_ml) -# endif /* !GC_ASSERTIONS */ -# elif defined(GC_PTHREADS) -# include - - /* Posix allows pthread_t to be a struct, though it rarely is. */ - /* Unfortunately, we need to use a pthread_t to index a data */ - /* structure. It also helps if comparisons don't involve a */ - /* function call. Hence we introduce platform-dependent macros */ - /* to compare pthread_t ids and to map them to integers. */ - /* The mapping to integers does not need to result in different */ - /* integers for each thread, though that should be true as much */ - /* as possible. */ - /* Refine to exclude platforms on which pthread_t is struct. */ -# if !defined(GC_WIN32_PTHREADS) -# define NUMERIC_THREAD_ID(id) ((unsigned long)(id)) -# define THREAD_EQUAL(id1, id2) ((id1) == (id2)) -# define NUMERIC_THREAD_ID_UNIQUE -# elif defined(__WINPTHREADS_VERSION_MAJOR) /* winpthreads */ -# define NUMERIC_THREAD_ID(id) ((unsigned long)(id)) -# define THREAD_EQUAL(id1, id2) ((id1) == (id2)) -# ifndef _WIN64 - /* NUMERIC_THREAD_ID is 32-bit and not unique on Win64. */ -# define NUMERIC_THREAD_ID_UNIQUE -# endif -# else /* pthreads-win32 */ -# define NUMERIC_THREAD_ID(id) ((unsigned long)(id.p)) - /* Using documented internal details of pthreads-win32 library. */ - /* Faster than pthread_equal(). Should not change with */ - /* future versions of pthreads-win32 library. */ -# define THREAD_EQUAL(id1, id2) ((id1.p == id2.p) && (id1.x == id2.x)) -# undef NUMERIC_THREAD_ID_UNIQUE - /* Generic definitions based on pthread_equal() always work but */ - /* will result in poor performance (as NUMERIC_THREAD_ID is */ - /* defined to just a constant) and weak assertion checking. */ -# endif -# define NO_THREAD ((unsigned long)(-1l)) - /* != NUMERIC_THREAD_ID(pthread_self()) for any thread */ - -# if !defined(THREAD_LOCAL_ALLOC) && !defined(USE_PTHREAD_LOCKS) - /* In the THREAD_LOCAL_ALLOC case, the allocation lock tends to */ - /* be held for long periods, if it is held at all. Thus spinning */ - /* and sleeping for fixed periods are likely to result in */ - /* significant wasted time. We thus rely mostly on queued locks. */ -# define USE_SPIN_LOCK - GC_EXTERN volatile AO_TS_t GC_allocate_lock; - GC_INNER void GC_lock(void); - /* Allocation lock holder. Only set if acquired by client through */ - /* GC_call_with_alloc_lock. */ -# ifdef GC_ASSERTIONS -# define UNCOND_LOCK() \ - { GC_ASSERT(I_DONT_HOLD_LOCK()); \ - if (AO_test_and_set_acquire(&GC_allocate_lock) == AO_TS_SET) \ - GC_lock(); \ - SET_LOCK_HOLDER(); } -# define UNCOND_UNLOCK() \ - { GC_ASSERT(I_HOLD_LOCK()); UNSET_LOCK_HOLDER(); \ - AO_CLEAR(&GC_allocate_lock); } -# else -# define UNCOND_LOCK() \ - { GC_ASSERT(I_DONT_HOLD_LOCK()); \ - if (AO_test_and_set_acquire(&GC_allocate_lock) == AO_TS_SET) \ - GC_lock(); } -# define UNCOND_UNLOCK() AO_CLEAR(&GC_allocate_lock) -# endif /* !GC_ASSERTIONS */ -# else /* THREAD_LOCAL_ALLOC || USE_PTHREAD_LOCKS */ -# ifndef USE_PTHREAD_LOCKS -# define USE_PTHREAD_LOCKS -# endif -# endif /* THREAD_LOCAL_ALLOC || USE_PTHREAD_LOCKS */ -# ifdef USE_PTHREAD_LOCKS -# include - GC_EXTERN pthread_mutex_t GC_allocate_ml; -# ifdef GC_ASSERTIONS -# define UNCOND_LOCK() { GC_ASSERT(I_DONT_HOLD_LOCK()); \ - GC_lock(); SET_LOCK_HOLDER(); } -# define UNCOND_UNLOCK() \ - { GC_ASSERT(I_HOLD_LOCK()); UNSET_LOCK_HOLDER(); \ - pthread_mutex_unlock(&GC_allocate_ml); } -# else /* !GC_ASSERTIONS */ -# if defined(NO_PTHREAD_TRYLOCK) -# ifdef USE_SPIN_LOCK -# define UNCOND_LOCK() GC_lock() -# else -# define UNCOND_LOCK() pthread_mutex_lock(&GC_allocate_ml) -# endif -# else -# define UNCOND_LOCK() \ - { if (0 != pthread_mutex_trylock(&GC_allocate_ml)) \ - GC_lock(); } -# endif -# define UNCOND_UNLOCK() pthread_mutex_unlock(&GC_allocate_ml) -# endif /* !GC_ASSERTIONS */ -# endif /* USE_PTHREAD_LOCKS */ -# ifdef GC_ASSERTIONS - GC_EXTERN unsigned long GC_lock_holder; -# define SET_LOCK_HOLDER() \ - GC_lock_holder = NUMERIC_THREAD_ID(pthread_self()) -# define UNSET_LOCK_HOLDER() GC_lock_holder = NO_THREAD -# define I_HOLD_LOCK() \ - (!GC_need_to_lock \ - || GC_lock_holder == NUMERIC_THREAD_ID(pthread_self())) -# ifndef NUMERIC_THREAD_ID_UNIQUE -# define I_DONT_HOLD_LOCK() 1 /* Conservatively say yes */ -# else -# define I_DONT_HOLD_LOCK() \ - (!GC_need_to_lock \ - || GC_lock_holder != NUMERIC_THREAD_ID(pthread_self())) -# endif -# endif /* GC_ASSERTIONS */ - GC_EXTERN volatile GC_bool GC_collecting; -# define ENTER_GC() GC_collecting = 1; -# define EXIT_GC() GC_collecting = 0; - GC_INNER void GC_lock(void); -# endif /* GC_PTHREADS with linux_threads.c implementation */ -# ifdef GC_ALWAYS_MULTITHREADED -# define GC_need_to_lock TRUE -# else - GC_EXTERN GC_bool GC_need_to_lock; -# endif - -# else /* !THREADS */ -# define LOCK() (void)0 -# define UNLOCK() (void)0 -# ifdef GC_ASSERTIONS -# define I_HOLD_LOCK() TRUE -# define I_DONT_HOLD_LOCK() TRUE - /* Used only in positive assertions or to test whether */ - /* we still need to acquire the lock. TRUE works in */ - /* either case. */ -# endif -# endif /* !THREADS */ - -#if defined(UNCOND_LOCK) && !defined(LOCK) -# if defined(LINT2) || defined(GC_ALWAYS_MULTITHREADED) - /* Instruct code analysis tools not to care about GC_need_to_lock */ - /* influence to LOCK/UNLOCK semantic. */ -# define LOCK() UNCOND_LOCK() -# define UNLOCK() UNCOND_UNLOCK() -# else - /* At least two thread running; need to lock. */ -# define LOCK() do { if (GC_need_to_lock) UNCOND_LOCK(); } while (0) -# define UNLOCK() do { if (GC_need_to_lock) UNCOND_UNLOCK(); } while (0) -# endif -#endif - -# ifndef ENTER_GC -# define ENTER_GC() -# define EXIT_GC() -# endif - -# ifndef DCL_LOCK_STATE -# define DCL_LOCK_STATE -# endif - -#endif /* GC_LOCKS_H */ diff -Nru ecl-16.1.2/src/bdwgc/include/private/gc_pmark.h ecl-16.1.3+ds/src/bdwgc/include/private/gc_pmark.h --- ecl-16.1.2/src/bdwgc/include/private/gc_pmark.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/private/gc_pmark.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,473 +0,0 @@ -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 2001 by Hewlett-Packard Company. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -/* Private declarations of GC marker data structures and macros */ - -/* - * Declarations of mark stack. Needed by marker and client supplied mark - * routines. Transitively include gc_priv.h. - */ -#ifndef GC_PMARK_H -#define GC_PMARK_H - -#ifdef HAVE_CONFIG_H -# include "config.h" -#endif - -#ifndef GC_BUILD -# define GC_BUILD -#endif - -#if defined(KEEP_BACK_PTRS) || defined(PRINT_BLACK_LIST) -# include "dbg_mlc.h" -#endif - -#ifndef GC_MARK_H -# include "../gc_mark.h" -#endif - -#ifndef GC_PRIVATE_H -# include "gc_priv.h" -#endif - -/* The real declarations of the following is in gc_priv.h, so that */ -/* we can avoid scanning the following table. */ -/* -mark_proc GC_mark_procs[MAX_MARK_PROCS]; -*/ - -#ifndef MARK_DESCR_OFFSET -# define MARK_DESCR_OFFSET sizeof(word) -#endif - -/* - * Mark descriptor stuff that should remain private for now, mostly - * because it's hard to export WORDSZ without including gcconfig.h. - */ -#define BITMAP_BITS (WORDSZ - GC_DS_TAG_BITS) -#define PROC(descr) \ - (GC_mark_procs[((descr) >> GC_DS_TAG_BITS) & (GC_MAX_MARK_PROCS-1)]) -#define ENV(descr) \ - ((descr) >> (GC_DS_TAG_BITS + GC_LOG_MAX_MARK_PROCS)) -#define MAX_ENV \ - (((word)1 << (WORDSZ - GC_DS_TAG_BITS - GC_LOG_MAX_MARK_PROCS)) - 1) - -GC_EXTERN unsigned GC_n_mark_procs; - -/* Number of mark stack entries to discard on overflow. */ -#define GC_MARK_STACK_DISCARDS (INITIAL_MARK_STACK_SIZE/8) - -GC_EXTERN size_t GC_mark_stack_size; - -#ifdef PARALLEL_MARK - /* - * Allow multiple threads to participate in the marking process. - * This works roughly as follows: - * The main mark stack never shrinks, but it can grow. - * - * The initiating threads holds the GC lock, and sets GC_help_wanted. - * - * Other threads: - * 1) update helper_count (while holding mark_lock.) - * 2) allocate a local mark stack - * repeatedly: - * 3) Steal a global mark stack entry by atomically replacing - * its descriptor with 0. - * 4) Copy it to the local stack. - * 5) Mark on the local stack until it is empty, or - * it may be profitable to copy it back. - * 6) If necessary, copy local stack to global one, - * holding mark lock. - * 7) Stop when the global mark stack is empty. - * 8) decrement helper_count (holding mark_lock). - * - * This is an experiment to see if we can do something along the lines - * of the University of Tokyo SGC in a less intrusive, though probably - * also less performant, way. - */ - - /* GC_mark_stack_top is protected by mark lock. */ - - /* - * GC_notify_all_marker() is used when GC_help_wanted is first set, - * when the last helper becomes inactive, - * when something is added to the global mark stack, and just after - * GC_mark_no is incremented. - * This could be split into multiple CVs (and probably should be to - * scale to really large numbers of processors.) - */ -#endif /* PARALLEL_MARK */ - -GC_INNER mse * GC_signal_mark_stack_overflow(mse *msp); - -/* Push the object obj with corresponding heap block header hhdr onto */ -/* the mark stack. */ -#define PUSH_OBJ(obj, hhdr, mark_stack_top, mark_stack_limit) \ - do { \ - register word _descr = (hhdr) -> hb_descr; \ - GC_ASSERT(!HBLK_IS_FREE(hhdr)); \ - if (_descr != 0) { \ - mark_stack_top++; \ - if ((word)mark_stack_top >= (word)(mark_stack_limit)) { \ - mark_stack_top = GC_signal_mark_stack_overflow(mark_stack_top); \ - } \ - mark_stack_top -> mse_start = (obj); \ - mark_stack_top -> mse_descr.w = _descr; \ - } \ - } while (0) - -/* Push the contents of current onto the mark stack if it is a valid */ -/* ptr to a currently unmarked object. Mark it. */ -/* If we assumed a standard-conforming compiler, we could probably */ -/* generate the exit_label transparently. */ -#define PUSH_CONTENTS(current, mark_stack_top, mark_stack_limit, \ - source, exit_label) \ - do { \ - hdr * my_hhdr; \ - HC_GET_HDR(current, my_hhdr, source, exit_label); \ - PUSH_CONTENTS_HDR(current, mark_stack_top, mark_stack_limit, \ - source, exit_label, my_hhdr, TRUE); \ - exit_label: ; \ - } while (0) - -/* Set mark bit, exit if it was already set. */ -#ifdef USE_MARK_BYTES - /* There is a race here, and we may set */ - /* the bit twice in the concurrent case. This can result in the */ - /* object being pushed twice. But that's only a performance issue. */ -# define SET_MARK_BIT_EXIT_IF_SET(hhdr,bit_no,exit_label) \ - do { \ - char * mark_byte_addr = (char *)hhdr -> hb_marks + (bit_no); \ - if (*mark_byte_addr) goto exit_label; \ - *mark_byte_addr = 1; \ - } while (0) -#else -# ifdef PARALLEL_MARK - /* This is used only if we explicitly set USE_MARK_BITS. */ - /* The following may fail to exit even if the bit was already set. */ - /* For our uses, that's benign: */ -# define OR_WORD_EXIT_IF_SET(addr, bits, exit_label) \ - do { \ - if (!(*(addr) & (bits))) { \ - AO_or((volatile AO_t *)(addr), (AO_t)(bits)); \ - } else { \ - goto exit_label; \ - } \ - } while (0) -# else -# define OR_WORD_EXIT_IF_SET(addr, bits, exit_label) \ - do { \ - word old = *(addr); \ - word my_bits = (bits); \ - if (old & my_bits) goto exit_label; \ - *(addr) = (old | my_bits); \ - } while (0) -# endif /* !PARALLEL_MARK */ -# define SET_MARK_BIT_EXIT_IF_SET(hhdr,bit_no,exit_label) \ - do { \ - word * mark_word_addr = hhdr -> hb_marks + divWORDSZ(bit_no); \ - OR_WORD_EXIT_IF_SET(mark_word_addr, (word)1 << modWORDSZ(bit_no), \ - exit_label); \ - } while (0) -#endif /* !USE_MARK_BYTES */ - -#ifdef PARALLEL_MARK -# define INCR_MARKS(hhdr) \ - AO_store(&hhdr->hb_n_marks, AO_load(&hhdr->hb_n_marks) + 1) -#else -# define INCR_MARKS(hhdr) (void)(++hhdr->hb_n_marks) -#endif - -#ifdef ENABLE_TRACE -# define TRACE(source, cmd) \ - if (GC_trace_addr != 0 && (ptr_t)(source) == GC_trace_addr) cmd -# define TRACE_TARGET(target, cmd) \ - if (GC_trace_addr != 0 && (target) == *(ptr_t *)GC_trace_addr) cmd -#else -# define TRACE(source, cmd) -# define TRACE_TARGET(source, cmd) -#endif - -#if defined(I386) && defined(__GNUC__) -# define LONG_MULT(hprod, lprod, x, y) \ - do { \ - __asm__ __volatile__("mull %2" : "=a"(lprod), "=d"(hprod) \ - : "g"(y), "0"(x)); \ - } while (0) -#else -# define LONG_MULT(hprod, lprod, x, y) \ - do { \ - unsigned long long prod = (unsigned long long)(x) \ - * (unsigned long long)(y); \ - GC_STATIC_ASSERT(sizeof(x) + sizeof(y) <= sizeof(prod)); \ - hprod = prod >> 32; \ - lprod = (unsigned32)prod; \ - } while (0) -#endif /* !I386 */ - -/* If the mark bit corresponding to current is not set, set it, and */ -/* push the contents of the object on the mark stack. Current points */ -/* to the beginning of the object. We rely on the fact that the */ -/* preceding header calculation will succeed for a pointer past the */ -/* first page of an object, only if it is in fact a valid pointer */ -/* to the object. Thus we can omit the otherwise necessary tests */ -/* here. Note in particular that the "displ" value is the displacement */ -/* from the beginning of the heap block, which may itself be in the */ -/* interior of a large object. */ -#ifdef MARK_BIT_PER_GRANULE -# define PUSH_CONTENTS_HDR(current, mark_stack_top, mark_stack_limit, \ - source, exit_label, hhdr, do_offset_check) \ - do { \ - size_t displ = HBLKDISPL(current); /* Displacement in block; in bytes. */\ - /* displ is always within range. If current doesn't point to */ \ - /* first block, then we are in the all_interior_pointers case, and */ \ - /* it is safe to use any displacement value. */ \ - size_t gran_displ = BYTES_TO_GRANULES(displ); \ - size_t gran_offset = hhdr -> hb_map[gran_displ]; \ - size_t byte_offset = displ & (GRANULE_BYTES - 1); \ - ptr_t base = current; \ - /* The following always fails for large block references. */ \ - if (EXPECT((gran_offset | byte_offset) != 0, FALSE)) { \ - if ((hhdr -> hb_flags & LARGE_BLOCK) != 0) { \ - /* gran_offset is bogus. */ \ - size_t obj_displ; \ - base = (ptr_t)(hhdr -> hb_block); \ - obj_displ = (ptr_t)(current) - base; \ - if (obj_displ != displ) { \ - GC_ASSERT(obj_displ < hhdr -> hb_sz); \ - /* Must be in all_interior_pointer case, not first block */ \ - /* already did validity check on cache miss. */ \ - } else { \ - if (do_offset_check && !GC_valid_offsets[obj_displ]) { \ - GC_ADD_TO_BLACK_LIST_NORMAL(current, source); \ - goto exit_label; \ - } \ - } \ - gran_displ = 0; \ - GC_ASSERT(hhdr -> hb_sz > HBLKSIZE || \ - hhdr -> hb_block == HBLKPTR(current)); \ - GC_ASSERT((word)hhdr->hb_block <= (word)(current)); \ - } else { \ - size_t obj_displ = GRANULES_TO_BYTES(gran_offset) \ - + byte_offset; \ - if (do_offset_check && !GC_valid_offsets[obj_displ]) { \ - GC_ADD_TO_BLACK_LIST_NORMAL(current, source); \ - goto exit_label; \ - } \ - gran_displ -= gran_offset; \ - base -= obj_displ; \ - } \ - } \ - GC_ASSERT(hhdr == GC_find_header(base)); \ - GC_ASSERT(gran_displ % BYTES_TO_GRANULES(hhdr -> hb_sz) == 0); \ - TRACE(source, GC_log_printf("GC #%u: passed validity tests\n", \ - (unsigned)GC_gc_no)); \ - SET_MARK_BIT_EXIT_IF_SET(hhdr, gran_displ, exit_label); \ - TRACE(source, GC_log_printf("GC #%u: previously unmarked\n", \ - (unsigned)GC_gc_no)); \ - TRACE_TARGET(base, \ - GC_log_printf("GC #%u: marking %p from %p instead\n", \ - (unsigned)GC_gc_no, base, source)); \ - INCR_MARKS(hhdr); \ - GC_STORE_BACK_PTR((ptr_t)source, base); \ - PUSH_OBJ(base, hhdr, mark_stack_top, mark_stack_limit); \ - } while (0) -#endif /* MARK_BIT_PER_GRANULE */ - -#ifdef MARK_BIT_PER_OBJ -# define PUSH_CONTENTS_HDR(current, mark_stack_top, mark_stack_limit, \ - source, exit_label, hhdr, do_offset_check) \ - do { \ - size_t displ = HBLKDISPL(current); /* Displacement in block; in bytes. */\ - unsigned32 low_prod, high_prod; \ - unsigned32 inv_sz = hhdr -> hb_inv_sz; \ - ptr_t base = current; \ - LONG_MULT(high_prod, low_prod, displ, inv_sz); \ - /* product is > and within sz_in_bytes of displ * sz_in_bytes * 2**32 */ \ - if (EXPECT(low_prod >> 16 != 0, FALSE)) { \ - /* FIXME: fails if offset is a multiple of HBLKSIZE which becomes 0 */ \ - if (inv_sz == LARGE_INV_SZ) { \ - size_t obj_displ; \ - base = (ptr_t)(hhdr -> hb_block); \ - obj_displ = (ptr_t)(current) - base; \ - if (obj_displ != displ) { \ - GC_ASSERT(obj_displ < hhdr -> hb_sz); \ - /* Must be in all_interior_pointer case, not first block */ \ - /* already did validity check on cache miss. */ \ - } else { \ - if (do_offset_check && !GC_valid_offsets[obj_displ]) { \ - GC_ADD_TO_BLACK_LIST_NORMAL(current, source); \ - goto exit_label; \ - } \ - } \ - GC_ASSERT(hhdr -> hb_sz > HBLKSIZE || \ - hhdr -> hb_block == HBLKPTR(current)); \ - GC_ASSERT((word)hhdr->hb_block < (word)(current)); \ - } else { \ - /* Accurate enough if HBLKSIZE <= 2**15. */ \ - GC_STATIC_ASSERT(HBLKSIZE <= (1 << 15)); \ - size_t obj_displ = (((low_prod >> 16) + 1) * (hhdr->hb_sz)) >> 16; \ - if (do_offset_check && !GC_valid_offsets[obj_displ]) { \ - GC_ADD_TO_BLACK_LIST_NORMAL(current, source); \ - goto exit_label; \ - } \ - base -= obj_displ; \ - } \ - } \ - /* May get here for pointer to start of block not at */ \ - /* beginning of object. If so, it's valid, and we're fine. */ \ - GC_ASSERT(high_prod <= HBLK_OBJS(hhdr -> hb_sz)); \ - TRACE(source, GC_log_printf("GC #%u: passed validity tests\n", \ - (unsigned)GC_gc_no)); \ - SET_MARK_BIT_EXIT_IF_SET(hhdr, high_prod, exit_label); \ - TRACE(source, GC_log_printf("GC #%u: previously unmarked\n", \ - (unsigned)GC_gc_no)); \ - TRACE_TARGET(base, \ - GC_log_printf("GC #%u: marking %p from %p instead\n", \ - (unsigned)GC_gc_no, base, source)); \ - INCR_MARKS(hhdr); \ - GC_STORE_BACK_PTR((ptr_t)source, base); \ - PUSH_OBJ(base, hhdr, mark_stack_top, mark_stack_limit); \ - } while (0) -#endif /* MARK_BIT_PER_OBJ */ - -#if defined(PRINT_BLACK_LIST) || defined(KEEP_BACK_PTRS) -# define PUSH_ONE_CHECKED_STACK(p, source) \ - GC_mark_and_push_stack((ptr_t)(p), (ptr_t)(source)) -#else -# define PUSH_ONE_CHECKED_STACK(p, source) \ - GC_mark_and_push_stack((ptr_t)(p)) -#endif - -/* - * Push a single value onto mark stack. Mark from the object pointed to by p. - * Invoke FIXUP_POINTER(p) before any further processing. - * P is considered valid even if it is an interior pointer. - * Previously marked objects are not pushed. Hence we make progress even - * if the mark stack overflows. - */ - -#if NEED_FIXUP_POINTER - /* Try both the raw version and the fixed up one. */ -# define GC_PUSH_ONE_STACK(p, source) \ - do { \ - if ((word)(p) >= (word)GC_least_plausible_heap_addr \ - && (word)(p) < (word)GC_greatest_plausible_heap_addr) { \ - PUSH_ONE_CHECKED_STACK(p, source); \ - } \ - FIXUP_POINTER(p); \ - if ((word)(p) >= (word)GC_least_plausible_heap_addr \ - && (word)(p) < (word)GC_greatest_plausible_heap_addr) { \ - PUSH_ONE_CHECKED_STACK(p, source); \ - } \ - } while (0) -#else /* !NEED_FIXUP_POINTER */ -# define GC_PUSH_ONE_STACK(p, source) \ - do { \ - if ((word)(p) >= (word)GC_least_plausible_heap_addr \ - && (word)(p) < (word)GC_greatest_plausible_heap_addr) { \ - PUSH_ONE_CHECKED_STACK(p, source); \ - } \ - } while (0) -#endif - -/* As above, but interior pointer recognition as for normal heap pointers. */ -#define GC_PUSH_ONE_HEAP(p,source,mark_stack_top) \ - do { \ - FIXUP_POINTER(p); \ - if ((word)(p) >= (word)GC_least_plausible_heap_addr \ - && (word)(p) < (word)GC_greatest_plausible_heap_addr) \ - mark_stack_top = GC_mark_and_push((void *)(p), mark_stack_top, \ - GC_mark_stack_limit, (void * *)(source)); \ - } while (0) - -/* Mark starting at mark stack entry top (incl.) down to */ -/* mark stack entry bottom (incl.). Stop after performing */ -/* about one page worth of work. Return the new mark stack */ -/* top entry. */ -GC_INNER mse * GC_mark_from(mse * top, mse * bottom, mse *limit); - -#define MARK_FROM_MARK_STACK() \ - GC_mark_stack_top = GC_mark_from(GC_mark_stack_top, \ - GC_mark_stack, \ - GC_mark_stack + GC_mark_stack_size); - -#define GC_mark_stack_empty() ((word)GC_mark_stack_top < (word)GC_mark_stack) - -/* - * Mark from one finalizable object using the specified - * mark proc. May not mark the object pointed to by - * real_ptr. That is the job of the caller, if appropriate. - * Note that this is called with the mutator running, but - * with us holding the allocation lock. This is safe only if the - * mutator needs the allocation lock to reveal hidden pointers. - * FIXME: Why do we need the GC_mark_state test below? - */ -#define GC_MARK_FO(real_ptr, mark_proc) \ - do { \ - (*(mark_proc))(real_ptr); \ - while (!GC_mark_stack_empty()) MARK_FROM_MARK_STACK(); \ - if (GC_mark_state != MS_NONE) { \ - GC_set_mark_bit(real_ptr); \ - while (!GC_mark_some((ptr_t)0)) { /* empty */ } \ - } \ - } while (0) - -GC_EXTERN GC_bool GC_mark_stack_too_small; - /* We need a larger mark stack. May be */ - /* set by client supplied mark routines.*/ - -typedef int mark_state_t; /* Current state of marking, as follows:*/ - /* Used to remember where we are during */ - /* concurrent marking. */ - - /* We say something is dirty if it was */ - /* written since the last time we */ - /* retrieved dirty bits. We say it's */ - /* grungy if it was marked dirty in the */ - /* last set of bits we retrieved. */ - - /* Invariant I: all roots and marked */ - /* objects p are either dirty, or point */ - /* to objects q that are either marked */ - /* or a pointer to q appears in a range */ - /* on the mark stack. */ - -#define MS_NONE 0 /* No marking in progress. I holds. */ - /* Mark stack is empty. */ - -#define MS_PUSH_RESCUERS 1 /* Rescuing objects are currently */ - /* being pushed. I holds, except */ - /* that grungy roots may point to */ - /* unmarked objects, as may marked */ - /* grungy objects above scan_ptr. */ - -#define MS_PUSH_UNCOLLECTABLE 2 /* I holds, except that marked */ - /* uncollectible objects above scan_ptr */ - /* may point to unmarked objects. */ - /* Roots may point to unmarked objects */ - -#define MS_ROOTS_PUSHED 3 /* I holds, mark stack may be nonempty */ - -#define MS_PARTIALLY_INVALID 4 /* I may not hold, e.g. because of M.S. */ - /* overflow. However marked heap */ - /* objects below scan_ptr point to */ - /* marked or stacked objects. */ - -#define MS_INVALID 5 /* I may not hold. */ - -GC_EXTERN mark_state_t GC_mark_state; - -#endif /* GC_PMARK_H */ diff -Nru ecl-16.1.2/src/bdwgc/include/private/gc_priv.h ecl-16.1.3+ds/src/bdwgc/include/private/gc_priv.h --- ecl-16.1.2/src/bdwgc/include/private/gc_priv.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/private/gc_priv.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,2540 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 1999-2004 Hewlett-Packard Development Company, L.P. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#ifndef GC_PRIVATE_H -#define GC_PRIVATE_H - -#ifdef HAVE_CONFIG_H -# include "config.h" -#endif - -#ifndef GC_BUILD -# define GC_BUILD -#endif - -#if (defined(__linux__) || defined(__GLIBC__) || defined(__GNU__)) \ - && !defined(_GNU_SOURCE) - /* Can't test LINUX, since this must be defined before other includes. */ -# define _GNU_SOURCE 1 -#endif - -#if (defined(DGUX) && defined(GC_THREADS) || defined(DGUX386_THREADS) \ - || defined(GC_DGUX386_THREADS)) && !defined(_USING_POSIX4A_DRAFT10) -# define _USING_POSIX4A_DRAFT10 1 -#endif - -# if defined(NO_DEBUGGING) && !defined(GC_ASSERTIONS) && !defined(NDEBUG) - /* To turn off assertion checking (in atomic_ops.h). */ -# define NDEBUG 1 -# endif - -#ifndef GC_H -# include "../gc.h" -#endif - -#include -#if !defined(sony_news) -# include -#endif - -#ifdef DGUX -# include -# include -# include -#endif /* DGUX */ - -#ifdef BSD_TIME -# include -# include -# include -#endif /* BSD_TIME */ - -#ifdef PARALLEL_MARK -# define AO_REQUIRE_CAS -# if !defined(__GNUC__) && !defined(AO_ASSUME_WINDOWS98) -# define AO_ASSUME_WINDOWS98 -# endif -#endif - -#ifndef GC_TINY_FL_H -# include "../gc_tiny_fl.h" -#endif - -#ifndef GC_MARK_H -# include "../gc_mark.h" -#endif - -typedef GC_word word; -typedef GC_signed_word signed_word; -typedef unsigned int unsigned32; - -typedef int GC_bool; -#define TRUE 1 -#define FALSE 0 - -typedef char * ptr_t; /* A generic pointer to which we can add */ - /* byte displacements and which can be used */ - /* for address comparisons. */ - -#ifndef GCCONFIG_H -# include "gcconfig.h" -#endif - -#ifndef GC_INNER - /* This tagging macro must be used at the start of every variable */ - /* definition which is declared with GC_EXTERN. Should be also used */ - /* for the GC-scope function definitions and prototypes. Must not be */ - /* used in gcconfig.h. Shouldn't be used for the debugging-only */ - /* functions. Currently, not used for the functions declared in or */ - /* called from the "dated" source files (pcr_interface.c and files */ - /* located in the "extra" folder). */ -# if defined(GC_DLL) && defined(__GNUC__) && !defined(MSWIN32) \ - && !defined(MSWINCE) && !defined(CYGWIN32) -# if __GNUC__ >= 4 - /* See the corresponding GC_API definition. */ -# define GC_INNER __attribute__((__visibility__("hidden"))) -# else - /* The attribute is unsupported. */ -# define GC_INNER /* empty */ -# endif -# else -# define GC_INNER /* empty */ -# endif - -# define GC_EXTERN extern GC_INNER - /* Used only for the GC-scope variables (prefixed with "GC_") */ - /* declared in the header files. Must not be used for thread-local */ - /* variables. Must not be used in gcconfig.h. Shouldn't be used for */ - /* the debugging-only or profiling-only variables. Currently, not */ - /* used for the variables accessed from the "dated" source files */ - /* (pcr_interface.c, specific.c/h, and in the "extra" folder). */ - /* The corresponding variable definition must start with GC_INNER. */ -#endif /* !GC_INNER */ - -#ifndef HEADERS_H -# include "gc_hdrs.h" -#endif - -#ifndef GC_ATTR_UNUSED -# if __GNUC__ > 3 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 4) -# define GC_ATTR_UNUSED __attribute__((__unused__)) -# else -# define GC_ATTR_UNUSED /* empty */ -# endif -#endif /* !GC_ATTR_UNUSED */ - -#if __GNUC__ >= 3 && !defined(LINT2) -# define EXPECT(expr, outcome) __builtin_expect(expr,outcome) - /* Equivalent to (expr), but predict that usually (expr)==outcome. */ -#else -# define EXPECT(expr, outcome) (expr) -#endif /* __GNUC__ */ - -#ifdef HAVE_CONFIG_H - /* The "inline" keyword is determined by Autoconf AC_C_INLINE. */ -# define GC_INLINE static inline -#elif defined(_MSC_VER) || defined(__INTEL_COMPILER) || defined(__DMC__) \ - || ((__GNUC__ >= 3) && defined(__STRICT_ANSI__)) \ - || defined(__WATCOMC__) -# define GC_INLINE static __inline -#elif (__GNUC__ >= 3) || defined(__sun) -# define GC_INLINE static inline -#else -# define GC_INLINE static -#endif - -#ifndef GC_API_OSCALL - /* This is used to identify GC routines called by name from OS. */ -# if defined(__GNUC__) -# if __GNUC__ >= 4 - /* Same as GC_API if GC_DLL. */ -# define GC_API_OSCALL extern __attribute__((__visibility__("default"))) -# else - /* The attribute is unsupported. */ -# define GC_API_OSCALL extern -# endif -# else -# define GC_API_OSCALL GC_API -# endif -#endif - -#ifndef GC_API_PRIV -# define GC_API_PRIV GC_API -#endif - -#ifndef GC_LOCKS_H -# include "gc_locks.h" -#endif - -#define ONES ((word)(signed_word)(-1)) - -# ifdef STACK_GROWS_DOWN -# define COOLER_THAN > -# define HOTTER_THAN < -# define MAKE_COOLER(x,y) if ((word)((x) + (y)) > (word)(x)) {(x) += (y);} \ - else (x) = (ptr_t)ONES -# define MAKE_HOTTER(x,y) (x) -= (y) -# else -# define COOLER_THAN < -# define HOTTER_THAN > -# define MAKE_COOLER(x,y) if ((word)((x) - (y)) < (word)(x)) {(x) -= (y);} \ - else (x) = 0 -# define MAKE_HOTTER(x,y) (x) += (y) -# endif - -#if defined(AMIGA) && defined(__SASC) -# define GC_FAR __far -#else -# define GC_FAR -#endif - - -/*********************************/ -/* */ -/* Definitions for conservative */ -/* collector */ -/* */ -/*********************************/ - -/*********************************/ -/* */ -/* Easily changeable parameters */ -/* */ -/*********************************/ - -/* #define STUBBORN_ALLOC */ - /* Enable stubborn allocation, and thus a limited */ - /* form of incremental collection w/o dirty bits. */ - -/* #define ALL_INTERIOR_POINTERS */ - /* Forces all pointers into the interior of an */ - /* object to be considered valid. Also causes the */ - /* sizes of all objects to be inflated by at least */ - /* one byte. This should suffice to guarantee */ - /* that in the presence of a compiler that does */ - /* not perform garbage-collector-unsafe */ - /* optimizations, all portable, strictly ANSI */ - /* conforming C programs should be safely usable */ - /* with malloc replaced by GC_malloc and free */ - /* calls removed. There are several disadvantages: */ - /* 1. There are probably no interesting, portable, */ - /* strictly ANSI conforming C programs. */ - /* 2. This option makes it hard for the collector */ - /* to allocate space that is not "pointed to" */ - /* by integers, etc. Under SunOS 4.X with a */ - /* statically linked libc, we empirically */ - /* observed that it would be difficult to */ - /* allocate individual objects larger than 100K. */ - /* Even if only smaller objects are allocated, */ - /* more swap space is likely to be needed. */ - /* Fortunately, much of this will never be */ - /* touched. */ - /* If you can easily avoid using this option, do. */ - /* If not, try to keep individual objects small. */ - /* This is now really controlled at startup, */ - /* through GC_all_interior_pointers. */ - - -#ifndef GC_NO_FINALIZATION -# define GC_INVOKE_FINALIZERS() GC_notify_or_invoke_finalizers() - GC_INNER void GC_notify_or_invoke_finalizers(void); - /* If GC_finalize_on_demand is not set, invoke */ - /* eligible finalizers. Otherwise: */ - /* Call *GC_finalizer_notifier if there are */ - /* finalizers to be run, and we haven't called */ - /* this procedure yet this GC cycle. */ - - GC_INNER void GC_push_finalizer_structures(void); - GC_INNER void GC_finalize(void); - /* Perform all indicated finalization actions */ - /* on unmarked objects. */ - /* Unreachable finalizable objects are enqueued */ - /* for processing by GC_invoke_finalizers. */ - /* Invoked with lock. */ - -# ifndef SMALL_CONFIG - GC_INNER void GC_print_finalization_stats(void); -# endif -#else -# define GC_INVOKE_FINALIZERS() (void)0 -#endif /* GC_NO_FINALIZATION */ - -#if !defined(DONT_ADD_BYTE_AT_END) -# ifdef LINT2 - /* Explicitly instruct the code analysis tool that */ - /* GC_all_interior_pointers is assumed to have only 0 or 1 value. */ -# define EXTRA_BYTES (GC_all_interior_pointers? 1 : 0) -# else -# define EXTRA_BYTES GC_all_interior_pointers -# endif -# define MAX_EXTRA_BYTES 1 -#else -# define EXTRA_BYTES 0 -# define MAX_EXTRA_BYTES 0 -#endif - - -# ifndef LARGE_CONFIG -# define MINHINCR 16 /* Minimum heap increment, in blocks of HBLKSIZE */ - /* Must be multiple of largest page size. */ -# define MAXHINCR 2048 /* Maximum heap increment, in blocks */ -# else -# define MINHINCR 64 -# define MAXHINCR 4096 -# endif - -# define BL_LIMIT GC_black_list_spacing - /* If we need a block of N bytes, and we have */ - /* a block of N + BL_LIMIT bytes available, */ - /* and N > BL_LIMIT, */ - /* but all possible positions in it are */ - /* blacklisted, we just use it anyway (and */ - /* print a warning, if warnings are enabled). */ - /* This risks subsequently leaking the block */ - /* due to a false reference. But not using */ - /* the block risks unreasonable immediate */ - /* heap growth. */ - -/*********************************/ -/* */ -/* Stack saving for debugging */ -/* */ -/*********************************/ - -#ifdef NEED_CALLINFO - struct callinfo { - word ci_pc; /* Caller, not callee, pc */ -# if NARGS > 0 - word ci_arg[NARGS]; /* bit-wise complement to avoid retention */ -# endif -# if (NFRAMES * (NARGS + 1)) % 2 == 1 - /* Likely alignment problem. */ - word ci_dummy; -# endif - }; -#endif - -#ifdef SAVE_CALL_CHAIN - /* Fill in the pc and argument information for up to NFRAMES of my */ - /* callers. Ignore my frame and my callers frame. */ - GC_INNER void GC_save_callers(struct callinfo info[NFRAMES]); - GC_INNER void GC_print_callers(struct callinfo info[NFRAMES]); -#endif - - -/*********************************/ -/* */ -/* OS interface routines */ -/* */ -/*********************************/ - -#ifdef BSD_TIME -# undef CLOCK_TYPE -# undef GET_TIME -# undef MS_TIME_DIFF -# define CLOCK_TYPE struct timeval -# define GET_TIME(x) \ - do { \ - struct rusage rusage; \ - getrusage(RUSAGE_SELF, &rusage); \ - x = rusage.ru_utime; \ - } while (0) -# define MS_TIME_DIFF(a,b) ((unsigned long)(a.tv_sec - b.tv_sec) * 1000 \ - + (unsigned long)(a.tv_usec - b.tv_usec) / 1000) -#elif defined(MSWIN32) || defined(MSWINCE) -# ifndef WIN32_LEAN_AND_MEAN -# define WIN32_LEAN_AND_MEAN 1 -# endif -# define NOSERVICE -# include -# include -# define CLOCK_TYPE DWORD -# define GET_TIME(x) (void)(x = GetTickCount()) -# define MS_TIME_DIFF(a,b) ((long)((a)-(b))) -#else /* !MSWIN32, !MSWINCE, !BSD_TIME */ -# include -# if defined(FREEBSD) && !defined(CLOCKS_PER_SEC) -# include -# define CLOCKS_PER_SEC CLK_TCK -# endif -# if !defined(CLOCKS_PER_SEC) -# define CLOCKS_PER_SEC 1000000 - /* This is technically a bug in the implementation. */ - /* ANSI requires that CLOCKS_PER_SEC be defined. But at least */ - /* under SunOS 4.1.1, it isn't. Also note that the combination of */ - /* ANSI C and POSIX is incredibly gross here. The type clock_t */ - /* is used by both clock() and times(). But on some machines */ - /* these use different notions of a clock tick, CLOCKS_PER_SEC */ - /* seems to apply only to clock. Hence we use it here. On many */ - /* machines, including SunOS, clock actually uses units of */ - /* microseconds (which are not really clock ticks). */ -# endif -# define CLOCK_TYPE clock_t -# define GET_TIME(x) (void)(x = clock()) -# define MS_TIME_DIFF(a,b) (CLOCKS_PER_SEC % 1000 == 0 ? \ - (unsigned long)((a) - (b)) / (unsigned long)(CLOCKS_PER_SEC / 1000) \ - : ((unsigned long)((a) - (b)) * 1000) / (unsigned long)CLOCKS_PER_SEC) - /* Avoid using double type since some targets (like ARM) might */ - /* require -lm option for double-to-long conversion. */ -#endif /* !BSD_TIME && !MSWIN32 */ - -/* We use bzero and bcopy internally. They may not be available. */ -# if defined(SPARC) && defined(SUNOS4) -# define BCOPY_EXISTS -# endif -# if defined(M68K) && defined(AMIGA) -# define BCOPY_EXISTS -# endif -# if defined(M68K) && defined(NEXT) -# define BCOPY_EXISTS -# endif -# if defined(VAX) -# define BCOPY_EXISTS -# endif -# if defined(AMIGA) -# include -# define BCOPY_EXISTS -# endif -# if defined(DARWIN) -# include -# define BCOPY_EXISTS -# endif -# if defined(MACOS) && defined(POWERPC) -# include -# define bcopy(x,y,n) BlockMoveData(x, y, n) -# define bzero(x,n) BlockZero(x, n) -# define BCOPY_EXISTS -# endif - -# ifndef BCOPY_EXISTS -# include -# define BCOPY(x,y,n) memcpy(y, x, (size_t)(n)) -# define BZERO(x,n) memset(x, 0, (size_t)(n)) -# else -# define BCOPY(x,y,n) bcopy((void *)(x),(void *)(y),(size_t)(n)) -# define BZERO(x,n) bzero((void *)(x),(size_t)(n)) -# endif - -/* - * Stop and restart mutator threads. - */ -# ifdef PCR -# include "th/PCR_ThCtl.h" -# define STOP_WORLD() \ - PCR_ThCtl_SetExclusiveMode(PCR_ThCtl_ExclusiveMode_stopNormal, \ - PCR_allSigsBlocked, \ - PCR_waitForever) -# define START_WORLD() \ - PCR_ThCtl_SetExclusiveMode(PCR_ThCtl_ExclusiveMode_null, \ - PCR_allSigsBlocked, \ - PCR_waitForever) -# else -# if defined(GC_WIN32_THREADS) || defined(GC_PTHREADS) - GC_INNER void GC_stop_world(void); - GC_INNER void GC_start_world(void); -# define STOP_WORLD() GC_stop_world() -# define START_WORLD() GC_start_world() -# else - /* Just do a sanity check: we are not inside GC_do_blocking(). */ -# define STOP_WORLD() GC_ASSERT(GC_blocked_sp == NULL) -# define START_WORLD() -# endif -# endif - -/* Abandon ship */ -# ifdef PCR -# define ABORT(s) PCR_Base_Panic(s) -# else -# if defined(MSWINCE) && !defined(DebugBreak) \ - && (!defined(UNDER_CE) || (defined(__MINGW32CE__) && !defined(ARM32))) - /* This simplifies linking for WinCE (and, probably, doesn't */ - /* hurt debugging much); use -DDebugBreak=DebugBreak to override */ - /* this behavior if really needed. This is also a workaround for */ - /* x86mingw32ce toolchain (if it is still declaring DebugBreak() */ - /* instead of defining it as a macro). */ -# define DebugBreak() _exit(-1) /* there is no abort() in WinCE */ -# endif -# ifdef SMALL_CONFIG -# define GC_on_abort(msg) (void)0 /* be silent on abort */ -# else - GC_API_PRIV GC_abort_func GC_on_abort; -# endif /* !SMALL_CONFIG */ -# if defined(MSWIN32) && (defined(NO_DEBUGGING) || defined(LINT2)) - /* A more user-friendly abort after showing fatal message. */ -# define ABORT(msg) (GC_on_abort(msg), _exit(-1)) - /* Exit on error without running "at-exit" callbacks. */ -# elif defined(MSWINCE) && defined(NO_DEBUGGING) -# define ABORT(msg) (GC_on_abort(msg), ExitProcess(-1)) -# elif defined(MSWIN32) || defined(MSWINCE) -# define ABORT(msg) { GC_on_abort(msg); DebugBreak(); } - /* Note that: on a WinCE box, this could be silently */ - /* ignored (i.e., the program is not aborted); */ - /* DebugBreak is a statement in some toolchains. */ -# else -# define ABORT(msg) (GC_on_abort(msg), abort()) -# endif /* !MSWIN32 */ -# endif /* !PCR */ - -/* For abort message with 1-3 arguments. C_msg and C_fmt should be */ -/* literals. C_msg should not contain format specifiers. Arguments */ -/* should match their format specifiers. */ -#define ABORT_ARG1(C_msg, C_fmt, arg1) \ - do { \ - GC_COND_LOG_PRINTF(C_msg /* + */ C_fmt, arg1); \ - ABORT(C_msg); \ - } while (0) -#define ABORT_ARG2(C_msg, C_fmt, arg1, arg2) \ - do { \ - GC_COND_LOG_PRINTF(C_msg /* + */ C_fmt, arg1, arg2); \ - ABORT(C_msg); \ - } while (0) -#define ABORT_ARG3(C_msg, C_fmt, arg1, arg2, arg3) \ - do { \ - GC_COND_LOG_PRINTF(C_msg /* + */ C_fmt, arg1, arg2, arg3); \ - ABORT(C_msg); \ - } while (0) - -/* Same as ABORT but does not have 'no-return' attribute. */ -/* ABORT on a dummy condition (which is always true). */ -#define ABORT_RET(msg) \ - if ((signed_word)GC_current_warn_proc == -1) {} else ABORT(msg) - -/* Exit abnormally, but without making a mess (e.g. out of memory) */ -# ifdef PCR -# define EXIT() PCR_Base_Exit(1,PCR_waitForever) -# else -# define EXIT() (GC_on_abort(NULL), exit(1 /* EXIT_FAILURE */)) -# endif - -/* Print warning message, e.g. almost out of memory. */ -/* The argument (if any) format specifier should be: */ -/* "%s", "%p" or "%"WARN_PRIdPTR. */ -#define WARN(msg, arg) (*GC_current_warn_proc)("GC Warning: " msg, \ - (GC_word)(arg)) -GC_EXTERN GC_warn_proc GC_current_warn_proc; - -/* Print format type macro for decimal signed_word value passed WARN(). */ -/* This could be redefined for Win64 or LLP64, but typically should */ -/* not be done as the WARN format string is, possibly, processed on the */ -/* client side, so non-standard print type modifiers (like MS "I64d") */ -/* should be avoided here if possible. */ -#ifndef WARN_PRIdPTR - /* Assume sizeof(void *) == sizeof(long) (or a little-endian machine) */ -# define WARN_PRIdPTR "ld" -#endif - -/* Get environment entry */ -#ifdef GC_READ_ENV_FILE - GC_INNER char * GC_envfile_getenv(const char *name); -# define GETENV(name) GC_envfile_getenv(name) -#elif defined(NO_GETENV) -# define GETENV(name) NULL -#elif defined(EMPTY_GETENV_RESULTS) - /* Workaround for a reputed Wine bug. */ - GC_INLINE char * fixed_getenv(const char *name) - { - char *value = getenv(name); - return value != NULL && *value != '\0' ? value : NULL; - } -# define GETENV(name) fixed_getenv(name) -#else -# define GETENV(name) getenv(name) -#endif - -#if defined(DARWIN) -# include -# ifndef MAC_OS_X_VERSION_MAX_ALLOWED -# include - /* Include this header just to import the above macro. */ -# endif -# if defined(POWERPC) -# if CPP_WORDSZ == 32 -# define GC_THREAD_STATE_T ppc_thread_state_t -# else -# define GC_THREAD_STATE_T ppc_thread_state64_t -# define GC_MACH_THREAD_STATE PPC_THREAD_STATE64 -# define GC_MACH_THREAD_STATE_COUNT PPC_THREAD_STATE64_COUNT -# endif -# elif defined(I386) || defined(X86_64) -# if CPP_WORDSZ == 32 -# if defined(i386_THREAD_STATE_COUNT) && !defined(x86_THREAD_STATE32_COUNT) - /* Use old naming convention for 32-bit x86. */ -# define GC_THREAD_STATE_T i386_thread_state_t -# define GC_MACH_THREAD_STATE i386_THREAD_STATE -# define GC_MACH_THREAD_STATE_COUNT i386_THREAD_STATE_COUNT -# else -# define GC_THREAD_STATE_T x86_thread_state32_t -# define GC_MACH_THREAD_STATE x86_THREAD_STATE32 -# define GC_MACH_THREAD_STATE_COUNT x86_THREAD_STATE32_COUNT -# endif -# else -# define GC_THREAD_STATE_T x86_thread_state64_t -# define GC_MACH_THREAD_STATE x86_THREAD_STATE64 -# define GC_MACH_THREAD_STATE_COUNT x86_THREAD_STATE64_COUNT -# endif -# elif defined(ARM32) && defined(ARM_UNIFIED_THREAD_STATE) -# define GC_THREAD_STATE_T arm_unified_thread_state_t -# define GC_MACH_THREAD_STATE ARM_UNIFIED_THREAD_STATE -# define GC_MACH_THREAD_STATE_COUNT ARM_UNIFIED_THREAD_STATE_COUNT -# elif defined(ARM32) -# define GC_THREAD_STATE_T arm_thread_state_t -# ifdef ARM_MACHINE_THREAD_STATE_COUNT -# define GC_MACH_THREAD_STATE ARM_MACHINE_THREAD_STATE -# define GC_MACH_THREAD_STATE_COUNT ARM_MACHINE_THREAD_STATE_COUNT -# endif -# elif defined(AARCH64) -# define GC_THREAD_STATE_T arm_thread_state64_t -# define GC_MACH_THREAD_STATE ARM_THREAD_STATE64 -# define GC_MACH_THREAD_STATE_COUNT ARM_THREAD_STATE64_COUNT -# else -# error define GC_THREAD_STATE_T -# endif -# ifndef GC_MACH_THREAD_STATE -# define GC_MACH_THREAD_STATE MACHINE_THREAD_STATE -# define GC_MACH_THREAD_STATE_COUNT MACHINE_THREAD_STATE_COUNT -# endif - -# if CPP_WORDSZ == 32 -# define GC_MACH_HEADER mach_header -# define GC_MACH_SECTION section -# define GC_GETSECTBYNAME getsectbynamefromheader -# else -# define GC_MACH_HEADER mach_header_64 -# define GC_MACH_SECTION section_64 -# define GC_GETSECTBYNAME getsectbynamefromheader_64 -# endif - - /* Try to work out the right way to access thread state structure */ - /* members. The structure has changed its definition in different */ - /* Darwin versions. This now defaults to the (older) names */ - /* without __, thus hopefully, not breaking any existing */ - /* Makefile.direct builds. */ -# if __DARWIN_UNIX03 -# if defined(ARM32) && defined(ARM_UNIFIED_THREAD_STATE) -# define THREAD_FLD(x) ts_32.__ ## x -# else -# define THREAD_FLD(x) __ ## x -# endif -# else -# if defined(ARM32) && defined(ARM_UNIFIED_THREAD_STATE) -# define THREAD_FLD(x) ts_32. ## x -# else -# define THREAD_FLD(x) x -# endif -# endif -#endif /* DARWIN */ - -/*********************************/ -/* */ -/* Word-size-dependent defines */ -/* */ -/*********************************/ - -#if CPP_WORDSZ == 32 -# define WORDS_TO_BYTES(x) ((x)<<2) -# define BYTES_TO_WORDS(x) ((x)>>2) -# define LOGWL ((word)5) /* log[2] of CPP_WORDSZ */ -# define modWORDSZ(n) ((n) & 0x1f) /* n mod size of word */ -# if ALIGNMENT != 4 -# define UNALIGNED_PTRS -# endif -#endif - -#if CPP_WORDSZ == 64 -# define WORDS_TO_BYTES(x) ((x)<<3) -# define BYTES_TO_WORDS(x) ((x)>>3) -# define LOGWL ((word)6) /* log[2] of CPP_WORDSZ */ -# define modWORDSZ(n) ((n) & 0x3f) /* n mod size of word */ -# if ALIGNMENT != 8 -# define UNALIGNED_PTRS -# endif -#endif - -/* The first TINY_FREELISTS free lists correspond to the first */ -/* TINY_FREELISTS multiples of GRANULE_BYTES, i.e. we keep */ -/* separate free lists for each multiple of GRANULE_BYTES */ -/* up to (TINY_FREELISTS-1) * GRANULE_BYTES. After that they */ -/* may be spread out further. */ -#include "../gc_tiny_fl.h" -#define GRANULE_BYTES GC_GRANULE_BYTES -#define TINY_FREELISTS GC_TINY_FREELISTS - -#define WORDSZ ((word)CPP_WORDSZ) -#define SIGNB ((word)1 << (WORDSZ-1)) -#define BYTES_PER_WORD ((word)(sizeof (word))) -#define divWORDSZ(n) ((n) >> LOGWL) /* divide n by size of word */ - -#if GRANULE_BYTES == 8 -# define BYTES_TO_GRANULES(n) ((n)>>3) -# define GRANULES_TO_BYTES(n) ((n)<<3) -# if CPP_WORDSZ == 64 -# define GRANULES_TO_WORDS(n) (n) -# elif CPP_WORDSZ == 32 -# define GRANULES_TO_WORDS(n) ((n)<<1) -# else -# define GRANULES_TO_WORDS(n) BYTES_TO_WORDS(GRANULES_TO_BYTES(n)) -# endif -#elif GRANULE_BYTES == 16 -# define BYTES_TO_GRANULES(n) ((n)>>4) -# define GRANULES_TO_BYTES(n) ((n)<<4) -# if CPP_WORDSZ == 64 -# define GRANULES_TO_WORDS(n) ((n)<<1) -# elif CPP_WORDSZ == 32 -# define GRANULES_TO_WORDS(n) ((n)<<2) -# else -# define GRANULES_TO_WORDS(n) BYTES_TO_WORDS(GRANULES_TO_BYTES(n)) -# endif -#else -# error Bad GRANULE_BYTES value -#endif - -/*********************/ -/* */ -/* Size Parameters */ -/* */ -/*********************/ - -/* Heap block size, bytes. Should be power of 2. */ -/* Incremental GC with MPROTECT_VDB currently requires the */ -/* page size to be a multiple of HBLKSIZE. Since most modern */ -/* architectures support variable page sizes down to 4K, and */ -/* X86 is generally 4K, we now default to 4K, except for */ -/* Alpha: Seems to be used with 8K pages. */ -/* SMALL_CONFIG: Want less block-level fragmentation. */ -#ifndef HBLKSIZE -# if defined(LARGE_CONFIG) || !defined(SMALL_CONFIG) -# ifdef ALPHA -# define CPP_LOG_HBLKSIZE 13 -# else -# define CPP_LOG_HBLKSIZE 12 -# endif -# else -# define CPP_LOG_HBLKSIZE 10 -# endif -#else -# if HBLKSIZE == 512 -# define CPP_LOG_HBLKSIZE 9 -# elif HBLKSIZE == 1024 -# define CPP_LOG_HBLKSIZE 10 -# elif HBLKSIZE == 2048 -# define CPP_LOG_HBLKSIZE 11 -# elif HBLKSIZE == 4096 -# define CPP_LOG_HBLKSIZE 12 -# elif HBLKSIZE == 8192 -# define CPP_LOG_HBLKSIZE 13 -# elif HBLKSIZE == 16384 -# define CPP_LOG_HBLKSIZE 14 -# else - --> fix HBLKSIZE -# endif -# undef HBLKSIZE -#endif - -# define CPP_HBLKSIZE (1 << CPP_LOG_HBLKSIZE) -# define LOG_HBLKSIZE ((size_t)CPP_LOG_HBLKSIZE) -# define HBLKSIZE ((size_t)CPP_HBLKSIZE) - - -/* max size objects supported by freelist (larger objects are */ -/* allocated directly with allchblk(), by rounding to the next */ -/* multiple of HBLKSIZE. */ - -#define CPP_MAXOBJBYTES (CPP_HBLKSIZE/2) -#define MAXOBJBYTES ((size_t)CPP_MAXOBJBYTES) -#define CPP_MAXOBJWORDS BYTES_TO_WORDS(CPP_MAXOBJBYTES) -#define MAXOBJWORDS ((size_t)CPP_MAXOBJWORDS) -#define CPP_MAXOBJGRANULES BYTES_TO_GRANULES(CPP_MAXOBJBYTES) -#define MAXOBJGRANULES ((size_t)CPP_MAXOBJGRANULES) - -# define divHBLKSZ(n) ((n) >> LOG_HBLKSIZE) - -# define HBLK_PTR_DIFF(p,q) divHBLKSZ((ptr_t)p - (ptr_t)q) - /* Equivalent to subtracting 2 hblk pointers. */ - /* We do it this way because a compiler should */ - /* find it hard to use an integer division */ - /* instead of a shift. The bundled SunOS 4.1 */ - /* o.w. sometimes pessimizes the subtraction to */ - /* involve a call to .div. */ - -# define modHBLKSZ(n) ((n) & (HBLKSIZE-1)) - -# define HBLKPTR(objptr) ((struct hblk *)(((word) (objptr)) & ~(HBLKSIZE-1))) - -# define HBLKDISPL(objptr) (((size_t) (objptr)) & (HBLKSIZE-1)) - -/* Round up allocation size (in bytes) to a multiple of a granule. */ -#define ROUNDUP_GRANULE_SIZE(bytes) \ - (((bytes) + (GRANULE_BYTES - 1)) & ~(GRANULE_BYTES - 1)) - -/* Round up byte allocation requests to integral number of words, etc. */ -# define ROUNDED_UP_GRANULES(n) \ - BYTES_TO_GRANULES((n) + (GRANULE_BYTES - 1 + EXTRA_BYTES)) -# if MAX_EXTRA_BYTES == 0 -# define SMALL_OBJ(bytes) EXPECT((bytes) <= (MAXOBJBYTES), TRUE) -# else -# define SMALL_OBJ(bytes) \ - (EXPECT((bytes) <= (MAXOBJBYTES - MAX_EXTRA_BYTES), TRUE) \ - || (bytes) <= MAXOBJBYTES - EXTRA_BYTES) - /* This really just tests bytes <= MAXOBJBYTES - EXTRA_BYTES. */ - /* But we try to avoid looking up EXTRA_BYTES. */ -# endif -# define ADD_SLOP(bytes) ((bytes) + EXTRA_BYTES) -# ifndef MIN_WORDS -# define MIN_WORDS 2 /* FIXME: obsolete */ -# endif - -/* - * Hash table representation of sets of pages. - * Implements a map from aligned HBLKSIZE chunks of the address space to one - * bit each. - * This assumes it is OK to spuriously set bits, e.g. because multiple - * addresses are represented by a single location. - * Used by black-listing code, and perhaps by dirty bit maintenance code. - */ - -# ifdef LARGE_CONFIG -# if CPP_WORDSZ == 32 -# define LOG_PHT_ENTRIES 20 /* Collisions likely at 1M blocks, */ - /* which is >= 4GB. Each table takes */ - /* 128KB, some of which may never be */ - /* touched. */ -# else -# define LOG_PHT_ENTRIES 21 /* Collisions likely at 2M blocks, */ - /* which is >= 8GB. Each table takes */ - /* 256KB, some of which may never be */ - /* touched. */ -# endif -# elif !defined(SMALL_CONFIG) -# define LOG_PHT_ENTRIES 18 /* Collisions are likely if heap grows */ - /* to more than 256K hblks >= 1GB. */ - /* Each hash table occupies 32K bytes. */ - /* Even for somewhat smaller heaps, */ - /* say half that, collisions may be an */ - /* issue because we blacklist */ - /* addresses outside the heap. */ -# else -# define LOG_PHT_ENTRIES 15 /* Collisions are likely if heap grows */ - /* to more than 32K hblks = 128MB. */ - /* Each hash table occupies 4K bytes. */ -# endif -# define PHT_ENTRIES ((word)1 << LOG_PHT_ENTRIES) -# define PHT_SIZE (PHT_ENTRIES >> LOGWL) -typedef word page_hash_table[PHT_SIZE]; - -# define PHT_HASH(addr) ((((word)(addr)) >> LOG_HBLKSIZE) & (PHT_ENTRIES - 1)) - -# define get_pht_entry_from_index(bl, index) \ - (((bl)[divWORDSZ(index)] >> modWORDSZ(index)) & 1) -# define set_pht_entry_from_index(bl, index) \ - (bl)[divWORDSZ(index)] |= (word)1 << modWORDSZ(index) -# define clear_pht_entry_from_index(bl, index) \ - (bl)[divWORDSZ(index)] &= ~((word)1 << modWORDSZ(index)) -/* And a dumb but thread-safe version of set_pht_entry_from_index. */ -/* This sets (many) extra bits. */ -# define set_pht_entry_from_index_safe(bl, index) \ - (bl)[divWORDSZ(index)] = ONES - - -/********************************************/ -/* */ -/* H e a p B l o c k s */ -/* */ -/********************************************/ - -/* heap block header */ -#define HBLKMASK (HBLKSIZE-1) - -#define MARK_BITS_PER_HBLK (HBLKSIZE/GRANULE_BYTES) - /* upper bound */ - /* We allocate 1 bit per allocation granule. */ - /* If MARK_BIT_PER_GRANULE is defined, we use */ - /* every nth bit, where n is the number of */ - /* allocation granules per object. If */ - /* MARK_BIT_PER_OBJ is defined, we only use the */ - /* initial group of mark bits, and it is safe */ - /* to allocate smaller header for large objects. */ - -#ifdef PARALLEL_MARK -# include "atomic_ops.h" -# define counter_t volatile AO_t -#else - typedef size_t counter_t; -# if defined(THREADS) && (defined(MPROTECT_VDB) \ - || (defined(GC_ASSERTIONS) && defined(THREAD_LOCAL_ALLOC))) -# include "atomic_ops.h" -# endif -#endif /* !PARALLEL_MARK */ - -union word_ptr_ao_u { - word w; - signed_word sw; - void *vp; -# ifdef AO_HAVE_load - volatile AO_t ao; -# endif -}; - -/* We maintain layout maps for heap blocks containing objects of a given */ -/* size. Each entry in this map describes a byte offset and has the */ -/* following type. */ -struct hblkhdr { - struct hblk * hb_next; /* Link field for hblk free list */ - /* and for lists of chunks waiting to be */ - /* reclaimed. */ - struct hblk * hb_prev; /* Backwards link for free list. */ - struct hblk * hb_block; /* The corresponding block. */ - unsigned char hb_obj_kind; - /* Kind of objects in the block. Each kind */ - /* identifies a mark procedure and a set of */ - /* list headers. Sometimes called regions. */ - unsigned char hb_flags; -# define IGNORE_OFF_PAGE 1 /* Ignore pointers that do not */ - /* point to the first page of */ - /* this object. */ -# define WAS_UNMAPPED 2 /* This is a free block, which has */ - /* been unmapped from the address */ - /* space. */ - /* GC_remap must be invoked on it */ - /* before it can be reallocated. */ - /* Only set with USE_MUNMAP. */ -# define FREE_BLK 4 /* Block is free, i.e. not in use. */ -# ifdef ENABLE_DISCLAIM -# define HAS_DISCLAIM 8 - /* This kind has a callback on reclaim. */ -# define MARK_UNCONDITIONALLY 0x10 - /* Mark from all objects, marked or */ - /* not. Used to mark objects needed by */ - /* reclaim notifier. */ -# endif -# ifdef MARK_BIT_PER_GRANULE -# define LARGE_BLOCK 0x20 -# endif - unsigned short hb_last_reclaimed; - /* Value of GC_gc_no when block was */ - /* last allocated or swept. May wrap. */ - /* For a free block, this is maintained */ - /* only for USE_MUNMAP, and indicates */ - /* when the header was allocated, or */ - /* when the size of the block last */ - /* changed. */ -# ifdef MARK_BIT_PER_OBJ - unsigned32 hb_inv_sz; /* A good upper bound for 2**32/hb_sz. */ - /* For large objects, we use */ - /* LARGE_INV_SZ. */ -# define LARGE_INV_SZ (1 << 16) -# endif - size_t hb_sz; /* If in use, size in bytes, of objects in the block. */ - /* if free, the size in bytes of the whole block */ - /* We assume that this is convertible to signed_word */ - /* without generating a negative result. We avoid */ - /* generating free blocks larger than that. */ - word hb_descr; /* object descriptor for marking. See */ - /* mark.h. */ -# ifdef MARK_BIT_PER_GRANULE - short * hb_map; /* Essentially a table of remainders */ - /* mod BYTES_TO_GRANULES(hb_sz), except */ - /* for large blocks. See GC_obj_map. */ -# endif - counter_t hb_n_marks; /* Number of set mark bits, excluding */ - /* the one always set at the end. */ - /* Currently it is concurrently */ - /* updated and hence only approximate. */ - /* But a zero value does guarantee that */ - /* the block contains no marked */ - /* objects. */ - /* Ensuring this property means that we */ - /* never decrement it to zero during a */ - /* collection, and hence the count may */ - /* be one too high. Due to concurrent */ - /* updates, an arbitrary number of */ - /* increments, but not all of them (!) */ - /* may be lost, hence it may in theory */ - /* be much too low. */ - /* The count may also be too high if */ - /* multiple mark threads mark the */ - /* same object due to a race. */ - /* Without parallel marking, the count */ - /* is accurate. */ -# ifdef USE_MARK_BYTES -# define MARK_BITS_SZ (MARK_BITS_PER_HBLK + 1) - /* Unlike the other case, this is in units of bytes. */ - /* Since we force double-word alignment, we need at most one */ - /* mark bit per 2 words. But we do allocate and set one */ - /* extra mark bit to avoid an explicit check for the */ - /* partial object at the end of each block. */ - union { - char _hb_marks[MARK_BITS_SZ]; - /* The i'th byte is 1 if the object */ - /* starting at granule i or object i is */ - /* marked, 0 o.w. */ - /* The mark bit for the "one past the */ - /* end" object is always set to avoid a */ - /* special case test in the marker. */ - word dummy; /* Force word alignment of mark bytes. */ - } _mark_byte_union; -# define hb_marks _mark_byte_union._hb_marks -# else -# define MARK_BITS_SZ (MARK_BITS_PER_HBLK/CPP_WORDSZ + 1) - word hb_marks[MARK_BITS_SZ]; -# endif /* !USE_MARK_BYTES */ -}; - -# define ANY_INDEX 23 /* "Random" mark bit index for assertions */ - -/* heap block body */ - -# define HBLK_WORDS (HBLKSIZE/sizeof(word)) -# define HBLK_GRANULES (HBLKSIZE/GRANULE_BYTES) - -/* The number of objects in a block dedicated to a certain size. */ -/* may erroneously yield zero (instead of one) for large objects. */ -# define HBLK_OBJS(sz_in_bytes) (HBLKSIZE/(sz_in_bytes)) - -struct hblk { - char hb_body[HBLKSIZE]; -}; - -# define HBLK_IS_FREE(hdr) (((hdr) -> hb_flags & FREE_BLK) != 0) - -# define OBJ_SZ_TO_BLOCKS(sz) divHBLKSZ((sz) + HBLKSIZE-1) - /* Size of block (in units of HBLKSIZE) needed to hold objects of */ - /* given sz (in bytes). */ - -/* Object free list link */ -# define obj_link(p) (*(void **)(p)) - -# define LOG_MAX_MARK_PROCS 6 -# define MAX_MARK_PROCS (1 << LOG_MAX_MARK_PROCS) - -/* Root sets. Logically private to mark_rts.c. But we don't want the */ -/* tables scanned, so we put them here. */ -/* MAX_ROOT_SETS is the maximum number of ranges that can be */ -/* registered as static roots. */ -# ifdef LARGE_CONFIG -# define MAX_ROOT_SETS 8192 -# elif !defined(SMALL_CONFIG) -# define MAX_ROOT_SETS 2048 -# else -# define MAX_ROOT_SETS 512 -# endif - -# define MAX_EXCLUSIONS (MAX_ROOT_SETS/4) -/* Maximum number of segments that can be excluded from root sets. */ - -/* - * Data structure for excluded static roots. - */ -struct exclusion { - ptr_t e_start; - ptr_t e_end; -}; - -/* Data structure for list of root sets. */ -/* We keep a hash table, so that we can filter out duplicate additions. */ -/* Under Win32, we need to do a better job of filtering overlaps, so */ -/* we resort to sequential search, and pay the price. */ -struct roots { - ptr_t r_start;/* multiple of word size */ - ptr_t r_end; /* multiple of word size and greater than r_start */ -# if !defined(MSWIN32) && !defined(MSWINCE) && !defined(CYGWIN32) - struct roots * r_next; -# endif - GC_bool r_tmp; - /* Delete before registering new dynamic libraries */ -}; - -#if !defined(MSWIN32) && !defined(MSWINCE) && !defined(CYGWIN32) - /* Size of hash table index to roots. */ -# define LOG_RT_SIZE 6 -# define RT_SIZE (1 << LOG_RT_SIZE) /* Power of 2, may be != MAX_ROOT_SETS */ -#endif - -#ifndef MAX_HEAP_SECTS -# ifdef LARGE_CONFIG -# if CPP_WORDSZ > 32 -# define MAX_HEAP_SECTS 8192 /* overflows at roughly 128 GB */ -# else -# define MAX_HEAP_SECTS 768 /* Separately added heap sections. */ -# endif -# elif defined(SMALL_CONFIG) && !defined(USE_PROC_FOR_LIBRARIES) -# if defined(PARALLEL_MARK) && (defined(MSWIN32) || defined(CYGWIN32)) -# define MAX_HEAP_SECTS 384 -# else -# define MAX_HEAP_SECTS 128 /* Roughly 256MB (128*2048*1K) */ -# endif -# elif CPP_WORDSZ > 32 -# define MAX_HEAP_SECTS 1024 /* Roughly 8GB */ -# else -# define MAX_HEAP_SECTS 512 /* Roughly 4GB */ -# endif -#endif /* !MAX_HEAP_SECTS */ - -typedef struct GC_ms_entry { - ptr_t mse_start; /* First word of object, word aligned. */ - union word_ptr_ao_u mse_descr; - /* Descriptor; low order two bits are tags, */ - /* as described in gc_mark.h. */ -} mse; - -/* Lists of all heap blocks and free lists */ -/* as well as other random data structures */ -/* that should not be scanned by the */ -/* collector. */ -/* These are grouped together in a struct */ -/* so that they can be easily skipped by the */ -/* GC_mark routine. */ -/* The ordering is weird to make GC_malloc */ -/* faster by keeping the important fields */ -/* sufficiently close together that a */ -/* single load of a base register will do. */ -/* Scalars that could easily appear to */ -/* be pointers are also put here. */ -/* The main fields should precede any */ -/* conditionally included fields, so that */ -/* gc_inl.h will work even if a different set */ -/* of macros is defined when the client is */ -/* compiled. */ - -struct _GC_arrays { - word _heapsize; /* Heap size in bytes (value never goes down). */ - word _requested_heapsize; /* Heap size due to explicit expansion. */ - ptr_t _last_heap_addr; - ptr_t _prev_heap_addr; - word _large_free_bytes; - /* Total bytes contained in blocks on large object free */ - /* list. */ - word _large_allocd_bytes; - /* Total number of bytes in allocated large objects blocks. */ - /* For the purposes of this counter and the next one only, a */ - /* large object is one that occupies a block of at least */ - /* 2*HBLKSIZE. */ - word _max_large_allocd_bytes; - /* Maximum number of bytes that were ever allocated in */ - /* large object blocks. This is used to help decide when it */ - /* is safe to split up a large block. */ - word _bytes_allocd_before_gc; - /* Number of bytes allocated before this */ - /* collection cycle. */ -# ifndef SEPARATE_GLOBALS -# define GC_bytes_allocd GC_arrays._bytes_allocd - word _bytes_allocd; - /* Number of bytes allocated during this collection cycle. */ -# endif - word _bytes_dropped; - /* Number of black-listed bytes dropped during GC cycle */ - /* as a result of repeated scanning during allocation */ - /* attempts. These are treated largely as allocated, */ - /* even though they are not useful to the client. */ - word _bytes_finalized; - /* Approximate number of bytes in objects (and headers) */ - /* that became ready for finalization in the last */ - /* collection. */ - word _bytes_freed; - /* Number of explicitly deallocated bytes of memory */ - /* since last collection. */ - word _finalizer_bytes_freed; - /* Bytes of memory explicitly deallocated while */ - /* finalizers were running. Used to approximate mem. */ - /* explicitly deallocated by finalizers. */ - ptr_t _scratch_end_ptr; - ptr_t _scratch_last_end_ptr; - /* Used by headers.c, and can easily appear to point to */ - /* heap. Also used by GC_register_dynamic_libraries(). */ - mse *_mark_stack; - /* Limits of stack for GC_mark routine. All ranges */ - /* between GC_mark_stack (incl.) and GC_mark_stack_top */ - /* (incl.) still need to be marked from. */ - mse *_mark_stack_limit; -# ifdef PARALLEL_MARK - mse *volatile _mark_stack_top; - /* Updated only with mark lock held, but read asynchronously. */ - /* TODO: Use union to avoid casts to AO_t */ -# else - mse *_mark_stack_top; -# endif - word _composite_in_use; /* Number of bytes in the accessible */ - /* composite objects. */ - word _atomic_in_use; /* Number of bytes in the accessible */ - /* atomic objects. */ -# ifdef USE_MUNMAP -# define GC_unmapped_bytes GC_arrays._unmapped_bytes - word _unmapped_bytes; -# else -# define GC_unmapped_bytes 0 -# endif - bottom_index * _all_nils; -# ifdef ENABLE_TRACE -# define GC_trace_addr GC_arrays._trace_addr - ptr_t _trace_addr; -# endif - GC_mark_proc _mark_procs[MAX_MARK_PROCS]; - /* Table of user-defined mark procedures. There is */ - /* a small number of these, which can be referenced */ - /* by DS_PROC mark descriptors. See gc_mark.h. */ - char _modws_valid_offsets[sizeof(word)]; - /* GC_valid_offsets[i] ==> */ - /* GC_modws_valid_offsets[i%sizeof(word)] */ -# if !defined(MSWIN32) && !defined(MSWINCE) && !defined(CYGWIN32) -# define GC_root_index GC_arrays._root_index - struct roots * _root_index[RT_SIZE]; -# endif -# ifdef SAVE_CALL_CHAIN -# define GC_last_stack GC_arrays._last_stack - struct callinfo _last_stack[NFRAMES]; - /* Stack at last garbage collection. Useful for */ - /* debugging mysterious object disappearances. In the */ - /* multi-threaded case, we currently only save the */ - /* calling stack. */ -# endif -# ifndef SEPARATE_GLOBALS -# define GC_objfreelist GC_arrays._objfreelist - void *_objfreelist[MAXOBJGRANULES+1]; - /* free list for objects */ -# define GC_aobjfreelist GC_arrays._aobjfreelist - void *_aobjfreelist[MAXOBJGRANULES+1]; - /* free list for atomic objs */ -# endif - void *_uobjfreelist[MAXOBJGRANULES+1]; - /* Uncollectible but traced objs */ - /* objects on this and auobjfreelist */ - /* are always marked, except during */ - /* garbage collections. */ -# ifdef ATOMIC_UNCOLLECTABLE -# define GC_auobjfreelist GC_arrays._auobjfreelist - void *_auobjfreelist[MAXOBJGRANULES+1]; - /* Atomic uncollectible but traced objs */ -# endif - size_t _size_map[MAXOBJBYTES+1]; - /* Number of granules to allocate when asked for a certain */ - /* number of bytes. */ -# ifdef STUBBORN_ALLOC -# define GC_sobjfreelist GC_arrays._sobjfreelist - ptr_t _sobjfreelist[MAXOBJGRANULES+1]; - /* Free list for immutable objects. */ -# endif -# ifdef MARK_BIT_PER_GRANULE -# define GC_obj_map GC_arrays._obj_map - short * _obj_map[MAXOBJGRANULES+1]; - /* If not NULL, then a pointer to a map of valid */ - /* object addresses. */ - /* _obj_map[sz_in_granules][i] is */ - /* i % sz_in_granules. */ - /* This is now used purely to replace a */ - /* division in the marker by a table lookup. */ - /* _obj_map[0] is used for large objects and */ - /* contains all nonzero entries. This gets us */ - /* out of the marker fast path without an extra */ - /* test. */ -# define MAP_LEN BYTES_TO_GRANULES(HBLKSIZE) -# endif -# define VALID_OFFSET_SZ HBLKSIZE - char _valid_offsets[VALID_OFFSET_SZ]; - /* GC_valid_offsets[i] == TRUE ==> i */ - /* is registered as a displacement. */ -# ifdef STUBBORN_ALLOC -# define GC_changed_pages GC_arrays._changed_pages - page_hash_table _changed_pages; - /* Stubborn object pages that were changes since last call to */ - /* GC_read_changed. */ -# define GC_prev_changed_pages GC_arrays._prev_changed_pages - page_hash_table _prev_changed_pages; - /* Stubborn object pages that were changes before last call to */ - /* GC_read_changed. */ -# endif -# if defined(PROC_VDB) || defined(MPROTECT_VDB) \ - || defined(GWW_VDB) || defined(MANUAL_VDB) -# define GC_grungy_pages GC_arrays._grungy_pages - page_hash_table _grungy_pages; /* Pages that were dirty at last */ - /* GC_read_dirty. */ -# endif -# if defined(MPROTECT_VDB) || defined(MANUAL_VDB) -# define GC_dirty_pages GC_arrays._dirty_pages - volatile page_hash_table _dirty_pages; - /* Pages dirtied since last GC_read_dirty. */ -# endif -# if defined(PROC_VDB) || defined(GWW_VDB) -# define GC_written_pages GC_arrays._written_pages - page_hash_table _written_pages; /* Pages ever dirtied */ -# endif -# define GC_heap_sects GC_arrays._heap_sects - struct HeapSect { - ptr_t hs_start; - size_t hs_bytes; - } _heap_sects[MAX_HEAP_SECTS]; /* Heap segments potentially */ - /* client objects. */ -# if defined(USE_PROC_FOR_LIBRARIES) -# define GC_our_memory GC_arrays._our_memory - struct HeapSect _our_memory[MAX_HEAP_SECTS]; - /* All GET_MEM allocated */ - /* memory. Includes block */ - /* headers and the like. */ -# endif -# if defined(MSWIN32) || defined(MSWINCE) || defined(CYGWIN32) -# define GC_heap_bases GC_arrays._heap_bases - ptr_t _heap_bases[MAX_HEAP_SECTS]; - /* Start address of memory regions obtained from kernel. */ -# endif -# ifdef MSWINCE -# define GC_heap_lengths GC_arrays._heap_lengths - word _heap_lengths[MAX_HEAP_SECTS]; - /* Committed lengths of memory regions obtained from kernel. */ -# endif - struct roots _static_roots[MAX_ROOT_SETS]; - struct exclusion _excl_table[MAX_EXCLUSIONS]; - /* Block header index; see gc_headers.h */ - bottom_index * _top_index[TOP_SZ]; -}; - -GC_API_PRIV GC_FAR struct _GC_arrays GC_arrays; - -#define GC_all_nils GC_arrays._all_nils -#define GC_atomic_in_use GC_arrays._atomic_in_use -#define GC_bytes_allocd_before_gc GC_arrays._bytes_allocd_before_gc -#define GC_bytes_dropped GC_arrays._bytes_dropped -#define GC_bytes_finalized GC_arrays._bytes_finalized -#define GC_bytes_freed GC_arrays._bytes_freed -#define GC_composite_in_use GC_arrays._composite_in_use -#define GC_excl_table GC_arrays._excl_table -#define GC_finalizer_bytes_freed GC_arrays._finalizer_bytes_freed -#define GC_heapsize GC_arrays._heapsize -#define GC_large_allocd_bytes GC_arrays._large_allocd_bytes -#define GC_large_free_bytes GC_arrays._large_free_bytes -#define GC_last_heap_addr GC_arrays._last_heap_addr -#define GC_mark_stack GC_arrays._mark_stack -#define GC_mark_stack_limit GC_arrays._mark_stack_limit -#define GC_mark_stack_top GC_arrays._mark_stack_top -#define GC_mark_procs GC_arrays._mark_procs -#define GC_max_large_allocd_bytes GC_arrays._max_large_allocd_bytes -#define GC_modws_valid_offsets GC_arrays._modws_valid_offsets -#define GC_prev_heap_addr GC_arrays._prev_heap_addr -#define GC_requested_heapsize GC_arrays._requested_heapsize -#define GC_scratch_end_ptr GC_arrays._scratch_end_ptr -#define GC_scratch_last_end_ptr GC_arrays._scratch_last_end_ptr -#define GC_size_map GC_arrays._size_map -#define GC_static_roots GC_arrays._static_roots -#define GC_top_index GC_arrays._top_index -#define GC_uobjfreelist GC_arrays._uobjfreelist -#define GC_valid_offsets GC_arrays._valid_offsets - -#define beginGC_arrays ((ptr_t)(&GC_arrays)) -#define endGC_arrays (((ptr_t)(&GC_arrays)) + (sizeof GC_arrays)) -#define USED_HEAP_SIZE (GC_heapsize - GC_large_free_bytes) - -/* Object kinds: */ -#define MAXOBJKINDS 16 - -GC_EXTERN struct obj_kind { - void **ok_freelist; /* Array of free listheaders for this kind of object */ - /* Point either to GC_arrays or to storage allocated */ - /* with GC_scratch_alloc. */ - struct hblk **ok_reclaim_list; - /* List headers for lists of blocks waiting to be */ - /* swept. */ - /* Indexed by object size in granules. */ - word ok_descriptor; /* Descriptor template for objects in this */ - /* block. */ - GC_bool ok_relocate_descr; - /* Add object size in bytes to descriptor */ - /* template to obtain descriptor. Otherwise */ - /* template is used as is. */ - GC_bool ok_init; /* Clear objects before putting them on the free list. */ -# ifdef ENABLE_DISCLAIM - GC_bool ok_mark_unconditionally; - /* Mark from all, including unmarked, objects */ - /* in block. Used to protect objects reachable */ - /* from reclaim notifiers. */ - int (GC_CALLBACK *ok_disclaim_proc)(void * /*obj*/); - /* The disclaim procedure is called before obj */ - /* is reclaimed, but must also tolerate being */ - /* called with object from freelist. Non-zero */ - /* exit prevents object from being reclaimed. */ -# define OK_DISCLAIM_INITZ /* comma */, FALSE, 0 -# else -# define OK_DISCLAIM_INITZ /* empty */ -# endif /* !ENABLE_DISCLAIM */ -} GC_obj_kinds[MAXOBJKINDS]; - -#define beginGC_obj_kinds ((ptr_t)(&GC_obj_kinds)) -#define endGC_obj_kinds (beginGC_obj_kinds + (sizeof GC_obj_kinds)) - -/* Variables that used to be in GC_arrays, but need to be accessed by */ -/* inline allocation code. If they were in GC_arrays, the inlined */ -/* allocation code would include GC_arrays offsets (as it did), which */ -/* introduce maintenance problems. */ - -#ifdef SEPARATE_GLOBALS - extern word GC_bytes_allocd; - /* Number of bytes allocated during this collection cycle. */ - extern ptr_t GC_objfreelist[MAXOBJGRANULES+1]; - /* free list for NORMAL objects */ -# define beginGC_objfreelist ((ptr_t)(&GC_objfreelist)) -# define endGC_objfreelist (beginGC_objfreelist + sizeof(GC_objfreelist)) - - extern ptr_t GC_aobjfreelist[MAXOBJGRANULES+1]; - /* free list for atomic (PTRFREE) objs */ -# define beginGC_aobjfreelist ((ptr_t)(&GC_aobjfreelist)) -# define endGC_aobjfreelist (beginGC_aobjfreelist + sizeof(GC_aobjfreelist)) -#endif /* SEPARATE_GLOBALS */ - -/* Predefined kinds: */ -#define PTRFREE 0 -#define NORMAL 1 -#define UNCOLLECTABLE 2 -#ifdef ATOMIC_UNCOLLECTABLE -# define AUNCOLLECTABLE 3 -# define STUBBORN 4 -# define IS_UNCOLLECTABLE(k) (((k) & ~1) == UNCOLLECTABLE) -#else -# define STUBBORN 3 -# define IS_UNCOLLECTABLE(k) ((k) == UNCOLLECTABLE) -#endif - -GC_EXTERN unsigned GC_n_kinds; - -GC_EXTERN word GC_n_heap_sects; /* Number of separately added heap */ - /* sections. */ - -#ifdef USE_PROC_FOR_LIBRARIES - GC_EXTERN word GC_n_memory; /* Number of GET_MEM allocated memory */ - /* sections. */ -#endif - -GC_EXTERN word GC_page_size; - -/* Round up allocation size to a multiple of a page size. */ -/* GC_setpagesize() is assumed to be already invoked. */ -#define ROUNDUP_PAGESIZE(bytes) \ - (((bytes) + GC_page_size - 1) & ~(GC_page_size - 1)) - -/* Same as above but used to make GET_MEM() argument safe. */ -#ifdef MMAP_SUPPORTED -# define ROUNDUP_PAGESIZE_IF_MMAP(bytes) ROUNDUP_PAGESIZE(bytes) -#else -# define ROUNDUP_PAGESIZE_IF_MMAP(bytes) (bytes) -#endif - -#if defined(MSWIN32) || defined(MSWINCE) || defined(CYGWIN32) - struct _SYSTEM_INFO; - GC_EXTERN struct _SYSTEM_INFO GC_sysinfo; - GC_INNER GC_bool GC_is_heap_base(ptr_t p); -#endif - -GC_EXTERN word GC_black_list_spacing; - /* Average number of bytes between blacklisted */ - /* blocks. Approximate. */ - /* Counts only blocks that are */ - /* "stack-blacklisted", i.e. that are */ - /* problematic in the interior of an object. */ - -#ifdef GC_GCJ_SUPPORT - extern struct hblk * GC_hblkfreelist[]; - /* Remains visible to GNU GCJ. */ -#endif - -#ifdef GC_DISABLE_INCREMENTAL -# define GC_incremental FALSE - /* Hopefully allow optimizer to remove some code. */ -# define TRUE_INCREMENTAL FALSE -#else - GC_EXTERN GC_bool GC_incremental; - /* Using incremental/generational collection. */ -# define TRUE_INCREMENTAL \ - (GC_incremental && GC_time_limit != GC_TIME_UNLIMITED) - /* True incremental, not just generational, mode */ -#endif /* !GC_DISABLE_INCREMENTAL */ - -GC_EXTERN word GC_root_size; /* Total size of registered root sections. */ - -GC_EXTERN GC_bool GC_debugging_started; - /* GC_debug_malloc has been called. */ - -/* This is used by GC_do_blocking[_inner](). */ -struct blocking_data { - GC_fn_type fn; - void * client_data; /* and result */ -}; - -/* This is used by GC_call_with_gc_active(), GC_push_all_stack_sections(). */ -struct GC_traced_stack_sect_s { - ptr_t saved_stack_ptr; -# ifdef IA64 - ptr_t saved_backing_store_ptr; - ptr_t backing_store_end; -# endif - struct GC_traced_stack_sect_s *prev; -}; - -#ifdef THREADS - /* Process all "traced stack sections" - scan entire stack except for */ - /* frames belonging to the user functions invoked by GC_do_blocking. */ - GC_INNER void GC_push_all_stack_sections(ptr_t lo, ptr_t hi, - struct GC_traced_stack_sect_s *traced_stack_sect); - GC_EXTERN word GC_total_stacksize; /* updated on every push_all_stacks */ -#else - GC_EXTERN ptr_t GC_blocked_sp; - GC_EXTERN struct GC_traced_stack_sect_s *GC_traced_stack_sect; - /* Points to the "frame" data held in stack by */ - /* the innermost GC_call_with_gc_active(). */ - /* NULL if no such "frame" active. */ -#endif /* !THREADS */ - -#ifdef IA64 - /* Similar to GC_push_all_stack_sections() but for IA-64 registers store. */ - GC_INNER void GC_push_all_register_sections(ptr_t bs_lo, ptr_t bs_hi, - int eager, struct GC_traced_stack_sect_s *traced_stack_sect); -#endif - -/* Marks are in a reserved area in */ -/* each heap block. Each word has one mark bit associated */ -/* with it. Only those corresponding to the beginning of an */ -/* object are used. */ - -/* Mark bit operations */ - -/* - * Retrieve, set, clear the nth mark bit in a given heap block. - * - * (Recall that bit n corresponds to nth object or allocation granule - * relative to the beginning of the block, including unused words) - */ - -#ifdef USE_MARK_BYTES -# define mark_bit_from_hdr(hhdr,n) ((hhdr)->hb_marks[n]) -# define set_mark_bit_from_hdr(hhdr,n) ((hhdr)->hb_marks[n] = 1) -# define clear_mark_bit_from_hdr(hhdr,n) ((hhdr)->hb_marks[n] = 0) -#else -/* Set mark bit correctly, even if mark bits may be concurrently */ -/* accessed. */ -# ifdef PARALLEL_MARK - /* This is used only if we explicitly set USE_MARK_BITS. */ -# define OR_WORD(addr, bits) AO_or((volatile AO_t *)(addr), (AO_t)(bits)) -# else -# define OR_WORD(addr, bits) (void)(*(addr) |= (bits)) -# endif -# define mark_bit_from_hdr(hhdr,n) \ - (((hhdr)->hb_marks[divWORDSZ(n)] >> modWORDSZ(n)) & (word)1) -# define set_mark_bit_from_hdr(hhdr,n) \ - OR_WORD((hhdr)->hb_marks+divWORDSZ(n), (word)1 << modWORDSZ(n)) -# define clear_mark_bit_from_hdr(hhdr,n) \ - ((hhdr)->hb_marks[divWORDSZ(n)] &= ~((word)1 << modWORDSZ(n))) -#endif /* !USE_MARK_BYTES */ - -#ifdef MARK_BIT_PER_OBJ -# define MARK_BIT_NO(offset, sz) (((unsigned)(offset))/(sz)) - /* Get the mark bit index corresponding to the given byte */ - /* offset and size (in bytes). */ -# define MARK_BIT_OFFSET(sz) 1 - /* Spacing between useful mark bits. */ -# define IF_PER_OBJ(x) x -# define FINAL_MARK_BIT(sz) ((sz) > MAXOBJBYTES? 1 : HBLK_OBJS(sz)) - /* Position of final, always set, mark bit. */ -#else /* MARK_BIT_PER_GRANULE */ -# define MARK_BIT_NO(offset, sz) BYTES_TO_GRANULES((unsigned)(offset)) -# define MARK_BIT_OFFSET(sz) BYTES_TO_GRANULES(sz) -# define IF_PER_OBJ(x) -# define FINAL_MARK_BIT(sz) \ - ((sz) > MAXOBJBYTES ? MARK_BITS_PER_HBLK \ - : BYTES_TO_GRANULES((sz) * HBLK_OBJS(sz))) -#endif - -/* Important internal collector routines */ - -GC_INNER ptr_t GC_approx_sp(void); - -GC_INNER GC_bool GC_should_collect(void); - -void GC_apply_to_all_blocks(void (*fn)(struct hblk *h, word client_data), - word client_data); - /* Invoke fn(hbp, client_data) for each */ - /* allocated heap block. */ -GC_INNER struct hblk * GC_next_used_block(struct hblk * h); - /* Return first in-use block >= h */ -GC_INNER struct hblk * GC_prev_block(struct hblk * h); - /* Return last block <= h. Returned block */ - /* is managed by GC, but may or may not be in */ - /* use. */ -GC_INNER void GC_mark_init(void); -GC_INNER void GC_clear_marks(void); - /* Clear mark bits for all heap objects. */ -GC_INNER void GC_invalidate_mark_state(void); - /* Tell the marker that marked */ - /* objects may point to unmarked */ - /* ones, and roots may point to */ - /* unmarked objects. Reset mark stack. */ -GC_INNER GC_bool GC_mark_some(ptr_t cold_gc_frame); - /* Perform about one pages worth of marking */ - /* work of whatever kind is needed. Returns */ - /* quickly if no collection is in progress. */ - /* Return TRUE if mark phase finished. */ -GC_INNER void GC_initiate_gc(void); - /* initiate collection. */ - /* If the mark state is invalid, this */ - /* becomes full collection. Otherwise */ - /* it's partial. */ - -GC_INNER GC_bool GC_collection_in_progress(void); - /* Collection is in progress, or was abandoned. */ - -#ifndef GC_DISABLE_INCREMENTAL -# define GC_PUSH_CONDITIONAL(b, t, all) \ - GC_push_conditional((ptr_t)(b), (ptr_t)(t), all) - /* Do either of GC_push_all or GC_push_selected */ - /* depending on the third arg. */ -#else -# define GC_PUSH_CONDITIONAL(b, t, all) GC_push_all((ptr_t)(b), (ptr_t)(t)) -#endif - -GC_INNER void GC_push_all_stack(ptr_t b, ptr_t t); - /* As GC_push_all but consider */ - /* interior pointers as valid. */ -GC_INNER void GC_push_all_eager(ptr_t b, ptr_t t); - /* Same as GC_push_all_stack, but */ - /* ensures that stack is scanned */ - /* immediately, not just scheduled */ - /* for scanning. */ - - /* In the threads case, we push part of the current thread stack */ - /* with GC_push_all_eager when we push the registers. This gets the */ - /* callee-save registers that may disappear. The remainder of the */ - /* stacks are scheduled for scanning in *GC_push_other_roots, which */ - /* is thread-package-specific. */ - -GC_INNER void GC_push_roots(GC_bool all, ptr_t cold_gc_frame); - /* Push all or dirty roots. */ - -GC_API_PRIV GC_push_other_roots_proc GC_push_other_roots; - /* Push system or application specific roots */ - /* onto the mark stack. In some environments */ - /* (e.g. threads environments) this is */ - /* predefined to be non-zero. A client */ - /* supplied replacement should also call the */ - /* original function. Remains externally */ - /* visible as used by some well-known 3rd-party */ - /* software (e.g., ECL) currently. */ - -#ifdef THREADS - void GC_push_thread_structures(void); -#endif -GC_EXTERN void (*GC_push_typed_structures)(void); - /* A pointer such that we can avoid linking in */ - /* the typed allocation support if unused. */ - -GC_INNER void GC_with_callee_saves_pushed(void (*fn)(ptr_t, void *), - ptr_t arg); - -#if defined(SPARC) || defined(IA64) - /* Cause all stacked registers to be saved in memory. Return a */ - /* pointer to the top of the corresponding memory stack. */ - ptr_t GC_save_regs_in_stack(void); -#endif - /* Push register contents onto mark stack. */ - -#if defined(MSWIN32) || defined(MSWINCE) - void __cdecl GC_push_one(word p); -#else - void GC_push_one(word p); - /* If p points to an object, mark it */ - /* and push contents on the mark stack */ - /* Pointer recognition test always */ - /* accepts interior pointers, i.e. this */ - /* is appropriate for pointers found on */ - /* stack. */ -#endif - -#if defined(PRINT_BLACK_LIST) || defined(KEEP_BACK_PTRS) - GC_INNER void GC_mark_and_push_stack(ptr_t p, ptr_t source); - /* Ditto, omits plausibility test */ -#else - GC_INNER void GC_mark_and_push_stack(ptr_t p); -#endif - -GC_INNER void GC_clear_hdr_marks(hdr * hhdr); - /* Clear the mark bits in a header */ -GC_INNER void GC_set_hdr_marks(hdr * hhdr); - /* Set the mark bits in a header */ -GC_INNER void GC_set_fl_marks(ptr_t p); - /* Set all mark bits associated with */ - /* a free list. */ -#if defined(GC_ASSERTIONS) && defined(THREADS) && defined(THREAD_LOCAL_ALLOC) - void GC_check_fl_marks(void **); - /* Check that all mark bits */ - /* associated with a free list are */ - /* set. Abort if not. */ -#endif -void GC_add_roots_inner(ptr_t b, ptr_t e, GC_bool tmp); -GC_INNER void GC_exclude_static_roots_inner(void *start, void *finish); -#if defined(DYNAMIC_LOADING) || defined(MSWIN32) || defined(MSWINCE) \ - || defined(CYGWIN32) || defined(PCR) - GC_INNER void GC_register_dynamic_libraries(void); - /* Add dynamic library data sections to the root set. */ -#endif -GC_INNER void GC_cond_register_dynamic_libraries(void); - /* Remove and reregister dynamic libraries if we're */ - /* configured to do that at each GC. */ - -/* Machine dependent startup routines */ -ptr_t GC_get_main_stack_base(void); /* Cold end of stack. */ -#ifdef IA64 - GC_INNER ptr_t GC_get_register_stack_base(void); - /* Cold end of register stack. */ -#endif -void GC_register_data_segments(void); - -#ifdef THREADS - GC_INNER void GC_thr_init(void); - GC_INNER void GC_init_parallel(void); -#else - GC_INNER GC_bool GC_is_static_root(ptr_t p); - /* Is the address p in one of the registered static */ - /* root sections? */ -#endif - -/* Black listing: */ -#ifdef PRINT_BLACK_LIST - GC_INNER void GC_add_to_black_list_normal(word p, ptr_t source); - /* Register bits as a possible future false */ - /* reference from the heap or static data */ -# define GC_ADD_TO_BLACK_LIST_NORMAL(bits, source) \ - if (GC_all_interior_pointers) { \ - GC_add_to_black_list_stack((word)(bits), (source)); \ - } else \ - GC_add_to_black_list_normal((word)(bits), (source)) - GC_INNER void GC_add_to_black_list_stack(word p, ptr_t source); -# define GC_ADD_TO_BLACK_LIST_STACK(bits, source) \ - GC_add_to_black_list_stack((word)(bits), (source)) -#else - GC_INNER void GC_add_to_black_list_normal(word p); -# define GC_ADD_TO_BLACK_LIST_NORMAL(bits, source) \ - if (GC_all_interior_pointers) { \ - GC_add_to_black_list_stack((word)(bits)); \ - } else \ - GC_add_to_black_list_normal((word)(bits)) - GC_INNER void GC_add_to_black_list_stack(word p); -# define GC_ADD_TO_BLACK_LIST_STACK(bits, source) \ - GC_add_to_black_list_stack((word)(bits)) -#endif /* PRINT_BLACK_LIST */ - -struct hblk * GC_is_black_listed(struct hblk * h, word len); - /* If there are likely to be false references */ - /* to a block starting at h of the indicated */ - /* length, then return the next plausible */ - /* starting location for h that might avoid */ - /* these false references. Remains externally */ - /* visible as used by GNU GCJ currently. */ - -GC_INNER void GC_promote_black_lists(void); - /* Declare an end to a black listing phase. */ -GC_INNER void GC_unpromote_black_lists(void); - /* Approximately undo the effect of the above. */ - /* This actually loses some information, but */ - /* only in a reasonably safe way. */ - -GC_INNER ptr_t GC_scratch_alloc(size_t bytes); - /* GC internal memory allocation for */ - /* small objects. Deallocation is not */ - /* possible. May return NULL. */ - -/* Heap block layout maps: */ -GC_INNER GC_bool GC_add_map_entry(size_t sz); - /* Add a heap block map for objects of */ - /* size sz to obj_map. */ - /* Return FALSE on failure. */ -GC_INNER void GC_register_displacement_inner(size_t offset); - /* Version of GC_register_displacement */ - /* that assumes lock is already held. */ - -/* hblk allocation: */ -GC_INNER void GC_new_hblk(size_t size_in_granules, int kind); - /* Allocate a new heap block, and build */ - /* a free list in it. */ - -GC_INNER ptr_t GC_build_fl(struct hblk *h, size_t words, GC_bool clear, - ptr_t list); - /* Build a free list for objects of */ - /* size sz in block h. Append list to */ - /* end of the free lists. Possibly */ - /* clear objects on the list. Normally */ - /* called by GC_new_hblk, but also */ - /* called explicitly without GC lock. */ - -GC_INNER struct hblk * GC_allochblk(size_t size_in_bytes, int kind, - unsigned flags); - /* Allocate a heap block, inform */ - /* the marker that block is valid */ - /* for objects of indicated size. */ - -GC_INNER ptr_t GC_alloc_large(size_t lb, int k, unsigned flags); - /* Allocate a large block of size lb bytes. */ - /* The block is not cleared. */ - /* Flags is 0 or IGNORE_OFF_PAGE. */ - /* Calls GC_allchblk to do the actual */ - /* allocation, but also triggers GC and/or */ - /* heap expansion as appropriate. */ - /* Does not update GC_bytes_allocd, but does */ - /* other accounting. */ - -GC_INNER void GC_freehblk(struct hblk * p); - /* Deallocate a heap block and mark it */ - /* as invalid. */ - -/* Misc GC: */ -GC_INNER GC_bool GC_expand_hp_inner(word n); -GC_INNER void GC_start_reclaim(GC_bool abort_if_found); - /* Restore unmarked objects to free */ - /* lists, or (if abort_if_found is */ - /* TRUE) report them. */ - /* Sweeping of small object pages is */ - /* largely deferred. */ -GC_INNER void GC_continue_reclaim(size_t sz, int kind); - /* Sweep pages of the given size and */ - /* kind, as long as possible, and */ - /* as long as the corr. free list is */ - /* empty. Sz is in granules. */ - -GC_INNER GC_bool GC_reclaim_all(GC_stop_func stop_func, GC_bool ignore_old); - /* Reclaim all blocks. Abort (in a */ - /* consistent state) if f returns TRUE. */ -GC_INNER ptr_t GC_reclaim_generic(struct hblk * hbp, hdr *hhdr, size_t sz, - GC_bool init, ptr_t list, - signed_word *count); - /* Rebuild free list in hbp with */ - /* header hhdr, with objects of size sz */ - /* bytes. Add list to the end of the */ - /* free list. Add the number of */ - /* reclaimed bytes to *count. */ -GC_INNER GC_bool GC_block_empty(hdr * hhdr); - /* Block completely unmarked? */ -GC_INNER int GC_CALLBACK GC_never_stop_func(void); - /* Always returns 0 (FALSE). */ -GC_INNER GC_bool GC_try_to_collect_inner(GC_stop_func f); - - /* Collect; caller must have acquired */ - /* lock. Collection is aborted if f */ - /* returns TRUE. Returns TRUE if it */ - /* completes successfully. */ -#define GC_gcollect_inner() \ - (void)GC_try_to_collect_inner(GC_never_stop_func) - -GC_EXTERN GC_bool GC_is_initialized; /* GC_init() has been run. */ - -#if defined(MSWIN32) || defined(MSWINCE) - void GC_deinit(void); - /* Free any resources allocated by */ - /* GC_init */ -#endif - -GC_INNER void GC_collect_a_little_inner(int n); - /* Do n units worth of garbage */ - /* collection work, if appropriate. */ - /* A unit is an amount appropriate for */ - /* HBLKSIZE bytes of allocation. */ - -GC_INNER void * GC_generic_malloc_inner(size_t lb, int k); - /* Allocate an object of the given */ - /* kind but assuming lock already held. */ -GC_INNER void * GC_generic_malloc_inner_ignore_off_page(size_t lb, int k); - /* Allocate an object, where */ - /* the client guarantees that there */ - /* will always be a pointer to the */ - /* beginning of the object while the */ - /* object is live. */ - -GC_INNER ptr_t GC_allocobj(size_t sz, int kind); - /* Make the indicated */ - /* free list nonempty, and return its */ - /* head. Sz is in granules. */ - -#ifdef GC_ADD_CALLER - /* GC_DBG_EXTRAS is used by GC debug API functions (unlike GC_EXTRAS */ - /* used by GC debug API macros) thus GC_RETURN_ADDR_PARENT (pointing */ - /* to client caller) should be used if possible. */ -# ifdef GC_RETURN_ADDR_PARENT -# define GC_DBG_EXTRAS GC_RETURN_ADDR_PARENT, NULL, 0 -# else -# define GC_DBG_EXTRAS GC_RETURN_ADDR, NULL, 0 -# endif -#else -# define GC_DBG_EXTRAS "unknown", 0 -#endif - -/* We make the GC_clear_stack() call a tail one, hoping to get more of */ -/* the stack. */ -#define GENERAL_MALLOC(lb,k) \ - GC_clear_stack(GC_generic_malloc(lb, k)) -#define GENERAL_MALLOC_IOP(lb,k) \ - GC_clear_stack(GC_generic_malloc_ignore_off_page(lb, k)) - -#ifdef GC_COLLECT_AT_MALLOC - extern size_t GC_dbg_collect_at_malloc_min_lb; - /* variable visible outside for debugging */ -# define GC_DBG_COLLECT_AT_MALLOC(lb) \ - (void)((lb) >= GC_dbg_collect_at_malloc_min_lb ? \ - (GC_gcollect(), 0) : 0) -#else -# define GC_DBG_COLLECT_AT_MALLOC(lb) (void)0 -#endif /* !GC_COLLECT_AT_MALLOC */ - -/* Allocation routines that bypass the thread local cache. */ -#ifdef THREAD_LOCAL_ALLOC - GC_INNER void * GC_core_malloc(size_t); - GC_INNER void * GC_core_malloc_atomic(size_t); -# ifdef GC_GCJ_SUPPORT - GC_INNER void * GC_core_gcj_malloc(size_t, void *); -# endif -#endif /* THREAD_LOCAL_ALLOC */ - -GC_INNER void GC_init_headers(void); -GC_INNER struct hblkhdr * GC_install_header(struct hblk *h); - /* Install a header for block h. */ - /* Return 0 on failure, or the header */ - /* otherwise. */ -GC_INNER GC_bool GC_install_counts(struct hblk * h, size_t sz); - /* Set up forwarding counts for block */ - /* h of size sz. */ - /* Return FALSE on failure. */ -GC_INNER void GC_remove_header(struct hblk * h); - /* Remove the header for block h. */ -GC_INNER void GC_remove_counts(struct hblk * h, size_t sz); - /* Remove forwarding counts for h. */ -GC_INNER hdr * GC_find_header(ptr_t h); - -GC_INNER void GC_add_to_heap(struct hblk *p, size_t bytes); - /* Add a HBLKSIZE aligned chunk to the heap. */ - -#ifdef USE_PROC_FOR_LIBRARIES - GC_INNER void GC_add_to_our_memory(ptr_t p, size_t bytes); - /* Add a chunk to GC_our_memory. */ - /* If p == 0, do nothing. */ -#else -# define GC_add_to_our_memory(p, bytes) -#endif - -GC_INNER void GC_print_all_errors(void); - /* Print smashed and leaked objects, if any. */ - /* Clear the lists of such objects. */ - -GC_EXTERN void (*GC_check_heap)(void); - /* Check that all objects in the heap with */ - /* debugging info are intact. */ - /* Add any that are not to GC_smashed list. */ -GC_EXTERN void (*GC_print_all_smashed)(void); - /* Print GC_smashed if it's not empty. */ - /* Clear GC_smashed list. */ -GC_EXTERN void (*GC_print_heap_obj)(ptr_t p); - /* If possible print (using GC_err_printf) */ - /* a more detailed description (terminated with */ - /* "\n") of the object referred to by p. */ - -#if defined(LINUX) && defined(__ELF__) && !defined(SMALL_CONFIG) - void GC_print_address_map(void); - /* Print an address map of the process. */ -#endif - -#ifndef SHORT_DBG_HDRS - GC_EXTERN GC_bool GC_findleak_delay_free; - /* Do not immediately deallocate object on */ - /* free() in the leak-finding mode, just mark */ - /* it as freed (and deallocate it after GC). */ - GC_INNER GC_bool GC_check_leaked(ptr_t base); /* from dbg_mlc.c */ -#endif - -GC_EXTERN GC_bool GC_have_errors; /* We saw a smashed or leaked object. */ - /* Call error printing routine */ - /* occasionally. It is OK to read it */ - /* without acquiring the lock. */ - -#define VERBOSE 2 -#ifndef SMALL_CONFIG - /* GC_print_stats should be visible to extra/MacOS.c. */ - extern int GC_print_stats; /* Nonzero generates basic GC log. */ - /* VERBOSE generates add'l messages. */ -#else /* SMALL_CONFIG */ -# define GC_print_stats 0 - /* Will this remove the message character strings from the executable? */ - /* With a particular level of optimizations, it should... */ -#endif - -#ifdef KEEP_BACK_PTRS - GC_EXTERN long GC_backtraces; - GC_INNER void GC_generate_random_backtrace_no_gc(void); -#endif - -GC_EXTERN GC_bool GC_print_back_height; - -#ifdef MAKE_BACK_GRAPH - void GC_print_back_graph_stats(void); -#endif - -#ifdef THREADS - GC_INNER void GC_free_inner(void * p); -#endif - -/* Macros used for collector internal allocation. */ -/* These assume the collector lock is held. */ -#ifdef DBG_HDRS_ALL - GC_INNER void * GC_debug_generic_malloc_inner(size_t lb, int k); - GC_INNER void * GC_debug_generic_malloc_inner_ignore_off_page(size_t lb, - int k); -# define GC_INTERNAL_MALLOC GC_debug_generic_malloc_inner -# define GC_INTERNAL_MALLOC_IGNORE_OFF_PAGE \ - GC_debug_generic_malloc_inner_ignore_off_page -# ifdef THREADS - GC_INNER void GC_debug_free_inner(void * p); -# define GC_INTERNAL_FREE GC_debug_free_inner -# else -# define GC_INTERNAL_FREE GC_debug_free -# endif -#else -# define GC_INTERNAL_MALLOC GC_generic_malloc_inner -# define GC_INTERNAL_MALLOC_IGNORE_OFF_PAGE \ - GC_generic_malloc_inner_ignore_off_page -# ifdef THREADS -# define GC_INTERNAL_FREE GC_free_inner -# else -# define GC_INTERNAL_FREE GC_free -# endif -#endif /* !DBG_HDRS_ALL */ - -#ifdef USE_MUNMAP - /* Memory unmapping: */ - GC_INNER void GC_unmap_old(void); - GC_INNER void GC_merge_unmapped(void); - GC_INNER void GC_unmap(ptr_t start, size_t bytes); - GC_INNER void GC_remap(ptr_t start, size_t bytes); - GC_INNER void GC_unmap_gap(ptr_t start1, size_t bytes1, ptr_t start2, - size_t bytes2); -#endif - -#ifdef CAN_HANDLE_FORK - GC_EXTERN int GC_handle_fork; - /* Fork-handling mode: */ - /* 0 means no fork handling requested (but client could */ - /* anyway call fork() provided it is surrounded with */ - /* GC_atfork_prepare/parent/child calls); */ - /* -1 means GC tries to use pthread_at_fork if it is */ - /* available (if it succeeds then GC_handle_fork value */ - /* is changed to 1), client should nonetheless surround */ - /* fork() with GC_atfork_prepare/parent/child (for the */ - /* case of pthread_at_fork failure or absence); */ - /* 1 (or other values) means client fully relies on */ - /* pthread_at_fork (so if it is missing or failed then */ - /* abort occurs in GC_init), GC_atfork_prepare and the */ - /* accompanying routines are no-op in such a case. */ -#endif - -#ifndef GC_DISABLE_INCREMENTAL - GC_EXTERN GC_bool GC_dirty_maintained; - /* Dirty bits are being maintained, */ - /* either for incremental collection, */ - /* or to limit the root set. */ - - /* Virtual dirty bit implementation: */ - /* Each implementation exports the following: */ - GC_INNER void GC_read_dirty(void); - /* Retrieve dirty bits. */ - GC_INNER GC_bool GC_page_was_dirty(struct hblk *h); - /* Read retrieved dirty bits. */ - GC_INNER void GC_remove_protection(struct hblk *h, word nblocks, - GC_bool pointerfree); - /* h is about to be written or allocated. Ensure */ - /* that it's not write protected by the virtual */ - /* dirty bit implementation. */ - - GC_INNER void GC_dirty_init(void); -#endif /* !GC_DISABLE_INCREMENTAL */ - -/* Same as GC_base but excepts and returns a pointer to const object. */ -#define GC_base_C(p) ((const void *)GC_base((/* no const */ void *)(p))) - -/* Stubborn objects: */ -void GC_read_changed(void); /* Analogous to GC_read_dirty */ -GC_bool GC_page_was_changed(struct hblk * h); - /* Analogous to GC_page_was_dirty */ -void GC_clean_changing_list(void); - /* Collect obsolete changing list entries */ -void GC_stubborn_init(void); - -/* Debugging print routines: */ -void GC_print_block_list(void); -void GC_print_hblkfreelist(void); -void GC_print_heap_sects(void); -void GC_print_static_roots(void); -/* void GC_dump(void); - declared in gc.h */ - -extern word GC_fo_entries; /* should be visible in extra/MacOS.c */ - -#ifdef KEEP_BACK_PTRS - GC_INNER void GC_store_back_pointer(ptr_t source, ptr_t dest); - GC_INNER void GC_marked_for_finalization(ptr_t dest); -# define GC_STORE_BACK_PTR(source, dest) GC_store_back_pointer(source, dest) -# define GC_MARKED_FOR_FINALIZATION(dest) GC_marked_for_finalization(dest) -#else -# define GC_STORE_BACK_PTR(source, dest) -# define GC_MARKED_FOR_FINALIZATION(dest) -#endif - -/* Make arguments appear live to compiler */ -void GC_noop6(word, word, word, word, word, word); - -GC_API void GC_CALL GC_noop1(word); - -#ifndef GC_ATTR_FORMAT_PRINTF -# if defined(__GNUC__) && __GNUC__ >= 3 -# define GC_ATTR_FORMAT_PRINTF(spec_argnum, first_checked) \ - __attribute__((__format__(__printf__, spec_argnum, first_checked))) -# else -# define GC_ATTR_FORMAT_PRINTF(spec_argnum, first_checked) -# endif -#endif - -/* Logging and diagnostic output: */ -/* GC_printf is used typically on client explicit print requests. */ -/* For all GC_X_printf routines, it is recommended to put "\n" at */ -/* 'format' string end (for output atomicity). */ -GC_API_PRIV void GC_printf(const char * format, ...) - GC_ATTR_FORMAT_PRINTF(1, 2); - /* A version of printf that doesn't allocate, */ - /* 1K total output length. */ - /* (We use sprintf. Hopefully that doesn't */ - /* allocate for long arguments.) */ -GC_API_PRIV void GC_err_printf(const char * format, ...) - GC_ATTR_FORMAT_PRINTF(1, 2); - -/* Basic logging routine. Typically, GC_log_printf is called directly */ -/* only inside various DEBUG_x blocks. */ -#if defined(__cplusplus) && defined(SYMBIAN) - extern "C" { -#endif -GC_API_PRIV void GC_log_printf(const char * format, ...) - GC_ATTR_FORMAT_PRINTF(1, 2); -#if defined(__cplusplus) && defined(SYMBIAN) - } -#endif - -#ifndef GC_ANDROID_LOG -# define GC_PRINT_STATS_FLAG (GC_print_stats != 0) -# define GC_INFOLOG_PRINTF GC_COND_LOG_PRINTF - /* GC_verbose_log_printf is called only if GC_print_stats is VERBOSE. */ -# define GC_verbose_log_printf GC_log_printf -#else - extern GC_bool GC_quiet; -# define GC_PRINT_STATS_FLAG (!GC_quiet) - /* INFO/DBG loggers are enabled even if GC_print_stats is off. */ -# ifndef GC_INFOLOG_PRINTF -# define GC_INFOLOG_PRINTF if (GC_quiet) {} else GC_info_log_printf -# endif - GC_INNER void GC_info_log_printf(const char *format, ...) - GC_ATTR_FORMAT_PRINTF(1, 2); - GC_INNER void GC_verbose_log_printf(const char *format, ...) - GC_ATTR_FORMAT_PRINTF(1, 2); -#endif /* GC_ANDROID_LOG */ - -/* Convenient macros for GC_[verbose_]log_printf invocation. */ -#define GC_COND_LOG_PRINTF \ - if (EXPECT(!GC_print_stats, TRUE)) {} else GC_log_printf -#define GC_VERBOSE_LOG_PRINTF \ - if (EXPECT(GC_print_stats != VERBOSE, TRUE)) {} else GC_verbose_log_printf -#ifndef GC_DBGLOG_PRINTF -# define GC_DBGLOG_PRINTF if (!GC_PRINT_STATS_FLAG) {} else GC_log_printf -#endif - -void GC_err_puts(const char *s); - /* Write s to stderr, don't buffer, don't add */ - /* newlines, don't ... */ - -/* Handy macro for logging size values (of word type) in KiB (rounding */ -/* to nearest value). */ -#define TO_KiB_UL(v) ((unsigned long)(((v) + ((1 << 9) - 1)) >> 10)) - -GC_EXTERN unsigned GC_fail_count; - /* How many consecutive GC/expansion failures? */ - /* Reset by GC_allochblk(); defined in alloc.c. */ - -GC_EXTERN long GC_large_alloc_warn_interval; /* defined in misc.c */ - -GC_EXTERN signed_word GC_bytes_found; - /* Number of reclaimed bytes after garbage collection; */ - /* protected by GC lock; defined in reclaim.c. */ - -#ifndef GC_GET_HEAP_USAGE_NOT_NEEDED - GC_EXTERN word GC_reclaimed_bytes_before_gc; - /* Number of bytes reclaimed before this */ - /* collection cycle; used for statistics only. */ -#endif - -#ifdef USE_MUNMAP - GC_EXTERN int GC_unmap_threshold; /* defined in allchblk.c */ - GC_EXTERN GC_bool GC_force_unmap_on_gcollect; /* defined in misc.c */ -#endif - -#ifdef MSWIN32 - GC_EXTERN GC_bool GC_no_win32_dlls; /* defined in os_dep.c */ - GC_EXTERN GC_bool GC_wnt; /* Is Windows NT derivative; */ - /* defined and set in os_dep.c. */ -#endif - -#ifdef THREADS -# if defined(MSWIN32) || defined(MSWINCE) - GC_EXTERN CRITICAL_SECTION GC_write_cs; /* defined in misc.c */ -# ifdef GC_ASSERTIONS - GC_EXTERN GC_bool GC_write_disabled; - /* defined in win32_threads.c; */ - /* protected by GC_write_cs. */ - -# endif -# endif -# ifdef MPROTECT_VDB - GC_EXTERN volatile AO_TS_t GC_fault_handler_lock; - /* defined in os_dep.c */ -# endif -# ifdef MSWINCE - GC_EXTERN GC_bool GC_dont_query_stack_min; - /* Defined and set in os_dep.c. */ -# endif -#elif defined(IA64) - GC_EXTERN ptr_t GC_save_regs_ret_val; /* defined in mach_dep.c. */ - /* Previously set to backing store pointer. */ -#endif /* !THREADS */ - -#ifdef THREAD_LOCAL_ALLOC - GC_EXTERN GC_bool GC_world_stopped; /* defined in alloc.c */ - GC_INNER void GC_mark_thread_local_free_lists(void); -#endif - -#ifdef GC_GCJ_SUPPORT -# ifdef GC_ASSERTIONS - GC_EXTERN GC_bool GC_gcj_malloc_initialized; /* defined in gcj_mlc.c */ -# endif - GC_EXTERN ptr_t * GC_gcjobjfreelist; -#endif - -#if defined(GWW_VDB) && defined(MPROTECT_VDB) - GC_INNER GC_bool GC_gww_dirty_init(void); - /* Defined in os_dep.c. Returns TRUE if GetWriteWatch is available. */ - /* May be called repeatedly. */ -#endif - -#if defined(CHECKSUMS) || defined(PROC_VDB) - GC_INNER GC_bool GC_page_was_ever_dirty(struct hblk * h); - /* Could the page contain valid heap pointers? */ -#endif - -GC_INNER void GC_default_print_heap_obj_proc(ptr_t p); - -GC_INNER void GC_extend_size_map(size_t); /* in misc.c */ - -GC_INNER void GC_setpagesize(void); - -GC_INNER void GC_initialize_offsets(void); /* defined in obj_map.c */ - -GC_INNER void GC_bl_init(void); -GC_INNER void GC_bl_init_no_interiors(void); /* defined in blacklst.c */ - -GC_INNER void GC_start_debugging(void); /* defined in dbg_mlc.c */ - -/* Store debugging info into p. Return displaced pointer. */ -/* Assumes we don't hold allocation lock. */ -GC_INNER ptr_t GC_store_debug_info(ptr_t p, word sz, const char *str, - int linenum); - -#ifdef REDIRECT_MALLOC -# ifdef GC_LINUX_THREADS - GC_INNER GC_bool GC_text_mapping(char *nm, ptr_t *startp, ptr_t *endp); - /* from os_dep.c */ -# endif -#elif defined(USE_WINALLOC) - GC_INNER void GC_add_current_malloc_heap(void); -#endif /* !REDIRECT_MALLOC */ - -#ifdef MAKE_BACK_GRAPH - GC_INNER void GC_build_back_graph(void); - GC_INNER void GC_traverse_back_graph(void); -#endif - -#ifdef MSWIN32 - GC_INNER void GC_init_win32(void); -#endif - -#if !defined(MSWIN32) && !defined(MSWINCE) && !defined(CYGWIN32) - GC_INNER void * GC_roots_present(ptr_t); - /* The type is a lie, since the real type doesn't make sense here, */ - /* and we only test for NULL. */ -#endif - -#ifdef GC_WIN32_THREADS - GC_INNER void GC_get_next_stack(char *start, char * limit, char **lo, - char **hi); -# ifdef MPROTECT_VDB - GC_INNER void GC_set_write_fault_handler(void); -# endif -#endif /* GC_WIN32_THREADS */ - -#ifdef THREADS - GC_INNER void GC_reset_finalizer_nested(void); - GC_INNER unsigned char *GC_check_finalizer_nested(void); - GC_INNER void GC_do_blocking_inner(ptr_t data, void * context); - GC_INNER void GC_push_all_stacks(void); -# ifdef USE_PROC_FOR_LIBRARIES - GC_INNER GC_bool GC_segment_is_thread_stack(ptr_t lo, ptr_t hi); -# endif -# ifdef IA64 - GC_INNER ptr_t GC_greatest_stack_base_below(ptr_t bound); -# endif -#endif /* THREADS */ - -#ifdef DYNAMIC_LOADING - GC_INNER GC_bool GC_register_main_static_data(void); -# ifdef DARWIN - GC_INNER void GC_init_dyld(void); -# endif -#endif /* DYNAMIC_LOADING */ - -#ifdef SEARCH_FOR_DATA_START - GC_INNER void GC_init_linux_data_start(void); -#endif - -#if defined(NETBSD) && defined(__ELF__) - GC_INNER void GC_init_netbsd_elf(void); -#endif - -#ifdef UNIX_LIKE - GC_INNER void GC_set_and_save_fault_handler(void (*handler)(int)); -#endif - -#ifdef NEED_PROC_MAPS -# if defined(DYNAMIC_LOADING) && defined(USE_PROC_FOR_LIBRARIES) - GC_INNER char *GC_parse_map_entry(char *buf_ptr, ptr_t *start, ptr_t *end, - char **prot, unsigned int *maj_dev, - char **mapping_name); -# endif - GC_INNER char *GC_get_maps(void); /* from os_dep.c */ -#endif /* NEED_PROC_MAPS */ - -#ifdef GC_ASSERTIONS -# define GC_ASSERT(expr) \ - do { \ - if (!(expr)) { \ - GC_err_printf("Assertion failure: %s:%d\n", \ - __FILE__, __LINE__); \ - ABORT("assertion failure"); \ - } \ - } while (0) - GC_INNER word GC_compute_large_free_bytes(void); - GC_INNER word GC_compute_root_size(void); -#else -# define GC_ASSERT(expr) -#endif - -/* Check a compile time assertion at compile time. The error */ -/* message for failure is a bit baroque, but ... */ -#if defined(mips) && !defined(__GNUC__) -/* DOB: MIPSPro C gets an internal error taking the sizeof an array type. - This code works correctly (ugliness is to avoid "unused var" warnings) */ -# define GC_STATIC_ASSERT(expr) \ - do { if (0) { char j[(expr)? 1 : -1]; j[0]='\0'; j[0]=j[0]; } } while(0) -#else -# define GC_STATIC_ASSERT(expr) (void)sizeof(char[(expr)? 1 : -1]) -#endif - -#define COND_DUMP_CHECKS \ - do { \ - GC_ASSERT(GC_compute_large_free_bytes() == GC_large_free_bytes); \ - GC_ASSERT(GC_compute_root_size() == GC_root_size); \ - } while (0) - -#ifndef NO_DEBUGGING - GC_EXTERN GC_bool GC_dump_regularly; - /* Generate regular debugging dumps. */ -# define COND_DUMP if (EXPECT(GC_dump_regularly, FALSE)) GC_dump(); \ - else COND_DUMP_CHECKS -#else -# define COND_DUMP COND_DUMP_CHECKS -#endif - -#if defined(PARALLEL_MARK) - /* We need additional synchronization facilities from the thread */ - /* support. We believe these are less performance critical */ - /* than the main garbage collector lock; standard pthreads-based */ - /* implementations should be sufficient. */ - -# define GC_markers_m1 GC_parallel - /* Number of mark threads we would like to have */ - /* excluding the initiating thread. */ - - /* The mark lock and condition variable. If the GC lock is also */ - /* acquired, the GC lock must be acquired first. The mark lock is */ - /* used to both protect some variables used by the parallel */ - /* marker, and to protect GC_fl_builder_count, below. */ - /* GC_notify_all_marker() is called when */ - /* the state of the parallel marker changes */ - /* in some significant way (see gc_mark.h for details). The */ - /* latter set of events includes incrementing GC_mark_no. */ - /* GC_notify_all_builder() is called when GC_fl_builder_count */ - /* reaches 0. */ - - GC_INNER void GC_acquire_mark_lock(void); - GC_INNER void GC_release_mark_lock(void); - GC_INNER void GC_notify_all_builder(void); - GC_INNER void GC_wait_for_reclaim(void); - - GC_EXTERN word GC_fl_builder_count; /* Protected by mark lock. */ - - GC_INNER void GC_notify_all_marker(void); - GC_INNER void GC_wait_marker(void); - GC_EXTERN word GC_mark_no; /* Protected by mark lock. */ - - GC_INNER void GC_help_marker(word my_mark_no); - /* Try to help out parallel marker for mark cycle */ - /* my_mark_no. Returns if the mark cycle finishes or */ - /* was already done, or there was nothing to do for */ - /* some other reason. */ -#endif /* PARALLEL_MARK */ - -#if defined(GC_PTHREADS) && !defined(GC_WIN32_THREADS) && !defined(NACL) \ - && !defined(GC_DARWIN_THREADS) && !defined(SIG_SUSPEND) - /* We define the thread suspension signal here, so that we can refer */ - /* to it in the dirty bit implementation, if necessary. Ideally we */ - /* would allocate a (real-time?) signal using the standard mechanism. */ - /* unfortunately, there is no standard mechanism. (There is one */ - /* in Linux glibc, but it's not exported.) Thus we continue to use */ - /* the same hard-coded signals we've always used. */ -# if (defined(GC_LINUX_THREADS) || defined(GC_DGUX386_THREADS)) \ - && !defined(GC_USESIGRT_SIGNALS) -# if defined(SPARC) && !defined(SIGPWR) - /* SPARC/Linux doesn't properly define SIGPWR in . */ - /* It is aliased to SIGLOST in asm/signal.h, though. */ -# define SIG_SUSPEND SIGLOST -# else - /* Linuxthreads itself uses SIGUSR1 and SIGUSR2. */ -# define SIG_SUSPEND SIGPWR -# endif -# elif defined(GC_OPENBSD_THREADS) -# ifndef GC_OPENBSD_UTHREADS -# define SIG_SUSPEND SIGXFSZ -# endif -# elif defined(_SIGRTMIN) -# define SIG_SUSPEND _SIGRTMIN + 6 -# else -# define SIG_SUSPEND SIGRTMIN + 6 -# endif -#endif /* GC_PTHREADS && !SIG_SUSPEND */ - -#if defined(GC_PTHREADS) && !defined(GC_SEM_INIT_PSHARED) -# define GC_SEM_INIT_PSHARED 0 -#endif - -#include - -/* Some macros for setjmp that works across signal handlers */ -/* were possible, and a couple of routines to facilitate */ -/* catching accesses to bad addresses when that's */ -/* possible/needed. */ -#if (defined(UNIX_LIKE) || (defined(NEED_FIND_LIMIT) && defined(CYGWIN32))) \ - && !defined(GC_NO_SIGSETJMP) -# if defined(SUNOS5SIGS) && !defined(FREEBSD) && !defined(LINUX) -# include -# endif - /* Define SETJMP and friends to be the version that restores */ - /* the signal mask. */ -# define SETJMP(env) sigsetjmp(env, 1) -# define LONGJMP(env, val) siglongjmp(env, val) -# define JMP_BUF sigjmp_buf -#else -# ifdef ECOS -# define SETJMP(env) hal_setjmp(env) -# else -# define SETJMP(env) setjmp(env) -# endif -# define LONGJMP(env, val) longjmp(env, val) -# define JMP_BUF jmp_buf -#endif /* !UNIX_LIKE || GC_NO_SIGSETJMP */ - -/* Do we need the GC_find_limit machinery to find the end of a */ -/* data segment. */ -#if defined(HEURISTIC2) || defined(SEARCH_FOR_DATA_START) -# define NEED_FIND_LIMIT -#endif - -#if !defined(STACKBOTTOM) && defined(HEURISTIC2) -# define NEED_FIND_LIMIT -#endif - -#if (defined(SVR4) || defined(AUX) || defined(DGUX) \ - || (defined(LINUX) && defined(SPARC))) && !defined(PCR) -# define NEED_FIND_LIMIT -#endif - -#if defined(FREEBSD) && (defined(I386) || defined(X86_64) \ - || defined(powerpc) || defined(__powerpc__)) -# include -# if !defined(PCR) -# define NEED_FIND_LIMIT -# endif -#endif /* FREEBSD */ - -#if (defined(NETBSD) || defined(OPENBSD)) && defined(__ELF__) \ - && !defined(NEED_FIND_LIMIT) - /* Used by GC_init_netbsd_elf() in os_dep.c. */ -# define NEED_FIND_LIMIT -#endif - -#if defined(IA64) && !defined(NEED_FIND_LIMIT) -# define NEED_FIND_LIMIT - /* May be needed for register backing store base. */ -#endif - -#if defined(NEED_FIND_LIMIT) \ - || (defined(USE_PROC_FOR_LIBRARIES) && defined(THREADS)) - JMP_BUF GC_jmp_buf; - - /* Set up a handler for address faults which will longjmp to */ - /* GC_jmp_buf; */ - GC_INNER void GC_setup_temporary_fault_handler(void); - /* Undo the effect of GC_setup_temporary_fault_handler. */ - GC_INNER void GC_reset_fault_handler(void); -#endif /* NEED_FIND_LIMIT || USE_PROC_FOR_LIBRARIES */ - -/* Some convenience macros for cancellation support. */ -#if defined(CANCEL_SAFE) -# if defined(GC_ASSERTIONS) && (defined(USE_COMPILER_TLS) \ - || (defined(LINUX) && !defined(ARM32) \ - && (__GNUC__ > 3 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 3)) \ - || defined(HPUX) /* and probably others ... */)) - extern __thread unsigned char GC_cancel_disable_count; -# define NEED_CANCEL_DISABLE_COUNT -# define INCR_CANCEL_DISABLE() ++GC_cancel_disable_count -# define DECR_CANCEL_DISABLE() --GC_cancel_disable_count -# define ASSERT_CANCEL_DISABLED() GC_ASSERT(GC_cancel_disable_count > 0) -# else -# define INCR_CANCEL_DISABLE() -# define DECR_CANCEL_DISABLE() -# define ASSERT_CANCEL_DISABLED() (void)0 -# endif /* GC_ASSERTIONS & ... */ -# define DISABLE_CANCEL(state) \ - do { pthread_setcancelstate(PTHREAD_CANCEL_DISABLE, &state); \ - INCR_CANCEL_DISABLE(); } while (0) -# define RESTORE_CANCEL(state) \ - do { ASSERT_CANCEL_DISABLED(); \ - pthread_setcancelstate(state, NULL); \ - DECR_CANCEL_DISABLE(); } while (0) -#else /* !CANCEL_SAFE */ -# define DISABLE_CANCEL(state) (void)0 -# define RESTORE_CANCEL(state) (void)0 -# define ASSERT_CANCEL_DISABLED() (void)0 -#endif /* !CANCEL_SAFE */ - -#endif /* GC_PRIVATE_H */ diff -Nru ecl-16.1.2/src/bdwgc/include/private/msvc_dbg.h ecl-16.1.3+ds/src/bdwgc/include/private/msvc_dbg.h --- ecl-16.1.2/src/bdwgc/include/private/msvc_dbg.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/private/msvc_dbg.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,69 +0,0 @@ -/* - Copyright (c) 2004-2005 Andrei Polushin - - 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 - AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN - THE SOFTWARE. -*/ -#ifndef _MSVC_DBG_H -#define _MSVC_DBG_H - -#include - -#ifdef __cplusplus -extern "C" { -#endif - -#if !MSVC_DBG_DLL -#define MSVC_DBG_EXPORT -#elif MSVC_DBG_BUILD -#define MSVC_DBG_EXPORT __declspec(dllexport) -#else -#define MSVC_DBG_EXPORT __declspec(dllimport) -#endif - -#ifndef MAX_SYM_NAME -#define MAX_SYM_NAME 2000 -#endif - -typedef void* HANDLE; -typedef struct _CONTEXT CONTEXT; - -MSVC_DBG_EXPORT size_t GetStackFrames(size_t skip, void* frames[], size_t maxFrames); -MSVC_DBG_EXPORT size_t GetStackFramesFromContext(HANDLE hProcess, HANDLE hThread, CONTEXT* context, size_t skip, void* frames[], size_t maxFrames); - -MSVC_DBG_EXPORT size_t GetModuleNameFromAddress(void* address, char* moduleName, size_t size); -MSVC_DBG_EXPORT size_t GetModuleNameFromStack(size_t skip, char* moduleName, size_t size); - -MSVC_DBG_EXPORT size_t GetSymbolNameFromAddress(void* address, char* symbolName, size_t size, size_t* offsetBytes); -MSVC_DBG_EXPORT size_t GetSymbolNameFromStack(size_t skip, char* symbolName, size_t size, size_t* offsetBytes); - -MSVC_DBG_EXPORT size_t GetFileLineFromAddress(void* address, char* fileName, size_t size, size_t* lineNumber, size_t* offsetBytes); -MSVC_DBG_EXPORT size_t GetFileLineFromStack(size_t skip, char* fileName, size_t size, size_t* lineNumber, size_t* offsetBytes); - -MSVC_DBG_EXPORT size_t GetDescriptionFromAddress(void* address, const char* format, char* description, size_t size); -MSVC_DBG_EXPORT size_t GetDescriptionFromStack(void*const frames[], size_t count, const char* format, char* description[], size_t size); - -/* Compatibility with */ -MSVC_DBG_EXPORT int backtrace(void* addresses[], int count); -MSVC_DBG_EXPORT char** backtrace_symbols(void*const addresses[], int count); - -#ifdef __cplusplus -} -#endif - -#endif/*_MSVC_DBG_H*/ diff -Nru ecl-16.1.2/src/bdwgc/include/private/pthread_stop_world.h ecl-16.1.3+ds/src/bdwgc/include/private/pthread_stop_world.h --- ecl-16.1.2/src/bdwgc/include/private/pthread_stop_world.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/private/pthread_stop_world.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,44 +0,0 @@ -/* - * Copyright (c) 1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996 by Silicon Graphics. All rights reserved. - * Copyright (c) 1998 by Fergus Henderson. All rights reserved. - * Copyright (c) 2000-2009 by Hewlett-Packard Development Company. - * All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#ifndef GC_PTHREAD_STOP_WORLD_H -#define GC_PTHREAD_STOP_WORLD_H - -struct thread_stop_info { -# ifndef GC_OPENBSD_UTHREADS - word last_stop_count; /* GC_last_stop_count value when thread */ - /* last successfully handled a suspend */ - /* signal. */ -# endif - - ptr_t stack_ptr; /* Valid only when stopped. */ - -# ifdef NACL - /* Grab NACL_GC_REG_STORAGE_SIZE pointers off the stack when */ - /* going into a syscall. 20 is more than we need, but it's an */ - /* overestimate in case the instrumented function uses any callee */ - /* saved registers, they may be pushed to the stack much earlier. */ - /* Also, on amd64 'push' puts 8 bytes on the stack even though */ - /* our pointers are 4 bytes. */ -# define NACL_GC_REG_STORAGE_SIZE 20 - ptr_t reg_storage[NACL_GC_REG_STORAGE_SIZE]; -# endif -}; - -GC_INNER void GC_stop_init(void); - -#endif diff -Nru ecl-16.1.2/src/bdwgc/include/private/pthread_support.h ecl-16.1.3+ds/src/bdwgc/include/private/pthread_support.h --- ecl-16.1.2/src/bdwgc/include/private/pthread_support.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/private/pthread_support.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,153 +0,0 @@ -/* - * Copyright (c) 1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996 by Silicon Graphics. All rights reserved. - * Copyright (c) 1998 by Fergus Henderson. All rights reserved. - * Copyright (c) 2000-2009 by Hewlett-Packard Development Company. - * All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#ifndef GC_PTHREAD_SUPPORT_H -#define GC_PTHREAD_SUPPORT_H - -#include "private/gc_priv.h" - -#if defined(GC_PTHREADS) && !defined(GC_WIN32_THREADS) - -#if defined(GC_DARWIN_THREADS) -# include "private/darwin_stop_world.h" -#else -# include "private/pthread_stop_world.h" -#endif - -#ifdef THREAD_LOCAL_ALLOC -# include "thread_local_alloc.h" -#endif - -/* We use the allocation lock to protect thread-related data structures. */ - -/* The set of all known threads. We intercept thread creation and */ -/* joins. */ -/* Protected by allocation/GC lock. */ -/* Some of this should be declared volatile, but that's inconsistent */ -/* with some library routine declarations. */ -typedef struct GC_Thread_Rep { - struct GC_Thread_Rep * next; /* More recently allocated threads */ - /* with a given pthread id come */ - /* first. (All but the first are */ - /* guaranteed to be dead, but we may */ - /* not yet have registered the join.) */ - pthread_t id; -# ifdef PLATFORM_ANDROID - pid_t kernel_id; -# endif - /* Extra bookkeeping information the stopping code uses */ - struct thread_stop_info stop_info; - - unsigned char flags; -# define FINISHED 1 /* Thread has exited. */ -# define DETACHED 2 /* Thread is treated as detached. */ - /* Thread may really be detached, or */ - /* it may have been explicitly */ - /* registered, in which case we can */ - /* deallocate its GC_Thread_Rep once */ - /* it unregisters itself, since it */ - /* may not return a GC pointer. */ -# define MAIN_THREAD 4 /* True for the original thread only. */ -# define SUSPENDED_EXT 8 /* Thread was suspended externally */ - /* (this is not used by the unmodified */ - /* GC itself at present). */ -# define DISABLED_GC 0x10 /* Collections are disabled while the */ - /* thread is exiting. */ - - unsigned char thread_blocked; - /* Protected by GC lock. */ - /* Treated as a boolean value. If set, */ - /* thread will acquire GC lock before */ - /* doing any pointer manipulations, and */ - /* has set its SP value. Thus it does */ - /* not need to be sent a signal to stop */ - /* it. */ - - unsigned short finalizer_skipped; - unsigned char finalizer_nested; - /* Used by GC_check_finalizer_nested() */ - /* to minimize the level of recursion */ - /* when a client finalizer allocates */ - /* memory (initially both are 0). */ - - ptr_t stack_end; /* Cold end of the stack (except for */ - /* main thread). */ -# if defined(GC_DARWIN_THREADS) && !defined(DARWIN_DONT_PARSE_STACK) - ptr_t topOfStack; /* Result of GC_FindTopOfStack(0); */ - /* valid only if the thread is blocked; */ - /* non-NULL value means already set. */ -# endif -# ifdef IA64 - ptr_t backing_store_end; - ptr_t backing_store_ptr; -# endif - - struct GC_traced_stack_sect_s *traced_stack_sect; - /* Points to the "frame" data held in stack by */ - /* the innermost GC_call_with_gc_active() of */ - /* this thread. May be NULL. */ - - void * status; /* The value returned from the thread. */ - /* Used only to avoid premature */ - /* reclamation of any data it might */ - /* reference. */ - /* This is unfortunately also the */ - /* reason we need to intercept join */ - /* and detach. */ - -# ifdef THREAD_LOCAL_ALLOC - struct thread_local_freelists tlfs; -# endif -} * GC_thread; - -# define THREAD_TABLE_SZ 256 /* Must be power of 2 */ -GC_EXTERN volatile GC_thread GC_threads[THREAD_TABLE_SZ]; - -GC_EXTERN GC_bool GC_thr_initialized; - -GC_INNER GC_thread GC_lookup_thread(pthread_t id); - -GC_EXTERN GC_bool GC_in_thread_creation; - /* We may currently be in thread creation or destruction. */ - /* Only set to TRUE while allocation lock is held. */ - /* When set, it is OK to run GC from unknown thread. */ - -#ifdef NACL - GC_EXTERN __thread GC_thread GC_nacl_gc_thread_self; - GC_INNER void GC_nacl_initialize_gc_thread(void); - GC_INNER void GC_nacl_shutdown_gc_thread(void); -#endif - -#ifdef GC_EXPLICIT_SIGNALS_UNBLOCK - GC_INNER void GC_unblock_gc_signals(void); -#endif - -#ifdef GC_PTHREAD_START_STANDALONE -# define GC_INNER_PTHRSTART /* empty */ -#else -# define GC_INNER_PTHRSTART GC_INNER -#endif - -GC_INNER_PTHRSTART GC_thread GC_start_rtn_prepare_thread( - void *(**pstart)(void *), - void **pstart_arg, - struct GC_stack_base *sb, void *arg); -GC_INNER_PTHRSTART void GC_thread_exit_proc(void *); - -#endif /* GC_PTHREADS && !GC_WIN32_THREADS */ - -#endif /* GC_PTHREAD_SUPPORT_H */ diff -Nru ecl-16.1.2/src/bdwgc/include/private/specific.h ecl-16.1.3+ds/src/bdwgc/include/private/specific.h --- ecl-16.1.2/src/bdwgc/include/private/specific.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/private/specific.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,98 +0,0 @@ -/* - * This is a reimplementation of a subset of the pthread_getspecific/setspecific - * interface. This appears to outperform the standard linuxthreads one - * by a significant margin. - * The major restriction is that each thread may only make a single - * pthread_setspecific call on a single key. (The current data structure - * doesn't really require that. The restriction should be easily removable.) - * We don't currently support the destruction functions, though that - * could be done. - * We also currently assume that only one pthread_setspecific call - * can be executed at a time, though that assumption would be easy to remove - * by adding a lock. - */ - -#include -#include "atomic_ops.h" - -/* Called during key creation or setspecific. */ -/* For the GC we already hold lock. */ -/* Currently allocated objects leak on thread exit. */ -/* That's hard to fix, but OK if we allocate garbage */ -/* collected memory. */ -#define MALLOC_CLEAR(n) GC_INTERNAL_MALLOC(n, NORMAL) - -#define TS_CACHE_SIZE 1024 -#define CACHE_HASH(n) ((((n) >> 8) ^ (n)) & (TS_CACHE_SIZE - 1)) - -#define TS_HASH_SIZE 1024 -#define HASH(p) \ - ((unsigned)((((word)(p)) >> 8) ^ (word)(p)) & (TS_HASH_SIZE - 1)) - -/* An entry describing a thread-specific value for a given thread. */ -/* All such accessible structures preserve the invariant that if either */ -/* thread is a valid pthread id or qtid is a valid "quick tread id" */ -/* for a thread, then value holds the corresponding thread specific */ -/* value. This invariant must be preserved at ALL times, since */ -/* asynchronous reads are allowed. */ -typedef struct thread_specific_entry { - volatile AO_t qtid; /* quick thread id, only for cache */ - void * value; - struct thread_specific_entry *next; - pthread_t thread; -} tse; - -/* We represent each thread-specific datum as two tables. The first is */ -/* a cache, indexed by a "quick thread identifier". The "quick" thread */ -/* identifier is an easy to compute value, which is guaranteed to */ -/* determine the thread, though a thread may correspond to more than */ -/* one value. We typically use the address of a page in the stack. */ -/* The second is a hash table, indexed by pthread_self(). It is used */ -/* only as a backup. */ - -/* Return the "quick thread id". Default version. Assumes page size, */ -/* or at least thread stack separation, is at least 4K. */ -/* Must be defined so that it never returns 0. (Page 0 can't really be */ -/* part of any stack, since that would make 0 a valid stack pointer.) */ -#define quick_thread_id() (((word)GC_approx_sp()) >> 12) - -#define INVALID_QTID ((word)0) -#define INVALID_THREADID ((pthread_t)0) - -union ptse_ao_u { - tse *p; - volatile AO_t ao; -}; - -typedef struct thread_specific_data { - tse * volatile cache[TS_CACHE_SIZE]; - /* A faster index to the hash table */ - union ptse_ao_u hash[TS_HASH_SIZE]; - pthread_mutex_t lock; -} tsd; - -typedef tsd * GC_key_t; - -#define GC_key_create(key, d) GC_key_create_inner(key) -GC_INNER int GC_key_create_inner(tsd ** key_ptr); -GC_INNER int GC_setspecific(tsd * key, void * value); -GC_INNER void GC_remove_specific(tsd * key); - -/* An internal version of getspecific that assumes a cache miss. */ -GC_INNER void * GC_slow_getspecific(tsd * key, word qtid, - tse * volatile * cache_entry); - -/* GC_INLINE is defined in gc_priv.h. */ -GC_INLINE void * GC_getspecific(tsd * key) -{ - word qtid = quick_thread_id(); - tse * volatile * entry_ptr = &key->cache[CACHE_HASH(qtid)]; - tse * entry = *entry_ptr; /* Must be loaded only once. */ - - GC_ASSERT(qtid != INVALID_QTID); - if (EXPECT(entry -> qtid == qtid, TRUE)) { - GC_ASSERT(entry -> thread == pthread_self()); - return entry -> value; - } - return GC_slow_getspecific(key, qtid, entry_ptr); -} diff -Nru ecl-16.1.2/src/bdwgc/include/private/thread_local_alloc.h ecl-16.1.3+ds/src/bdwgc/include/private/thread_local_alloc.h --- ecl-16.1.2/src/bdwgc/include/private/thread_local_alloc.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/private/thread_local_alloc.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,175 +0,0 @@ -/* - * Copyright (c) 2000-2005 by Hewlett-Packard Company. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -/* Included indirectly from a thread-library-specific file. */ -/* This is the interface for thread-local allocation, whose */ -/* implementation is mostly thread-library-independent. */ -/* Here we describe only the interface that needs to be known */ -/* and invoked from the thread support layer; the actual */ -/* implementation also exports GC_malloc and friends, which */ -/* are declared in gc.h. */ - -#ifndef GC_THREAD_LOCAL_ALLOC_H -#define GC_THREAD_LOCAL_ALLOC_H - -#include "private/gc_priv.h" - -#ifdef THREAD_LOCAL_ALLOC - -#include "gc_inline.h" - -#if defined(USE_HPUX_TLS) -# error USE_HPUX_TLS macro was replaced by USE_COMPILER_TLS -#endif - -#if !defined(USE_PTHREAD_SPECIFIC) && !defined(USE_WIN32_SPECIFIC) \ - && !defined(USE_WIN32_COMPILER_TLS) && !defined(USE_COMPILER_TLS) \ - && !defined(USE_CUSTOM_SPECIFIC) -# if defined(MSWIN32) || defined(MSWINCE) || defined(CYGWIN32) -# if defined(CYGWIN32) && (__GNUC__ >= 4) -# if defined(__clang__) - /* As of Cygwin clang3.1, thread-local storage is unsupported. */ -# define USE_PTHREAD_SPECIFIC -# else -# define USE_COMPILER_TLS -# endif -# elif defined(__GNUC__) || defined(MSWINCE) -# define USE_WIN32_SPECIFIC -# else -# define USE_WIN32_COMPILER_TLS -# endif /* !GNU */ -# elif (defined(LINUX) && !defined(ARM32) && !defined(AVR32) \ - && (__GNUC__ > 3 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 3)) \ - && !(defined(__clang__) && defined(PLATFORM_ANDROID))) \ - || (defined(PLATFORM_ANDROID) && defined(ARM32) \ - && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 6))) - /* As of Android NDK r8e, Clang cannot find __tls_get_addr. */ -# define USE_COMPILER_TLS -# elif defined(GC_DGUX386_THREADS) || defined(GC_OSF1_THREADS) \ - || defined(GC_AIX_THREADS) || defined(GC_DARWIN_THREADS) \ - || defined(GC_FREEBSD_THREADS) || defined(GC_NETBSD_THREADS) \ - || defined(GC_LINUX_THREADS) || defined(GC_RTEMS_PTHREADS) -# define USE_PTHREAD_SPECIFIC -# elif defined(GC_HPUX_THREADS) -# ifdef __GNUC__ -# define USE_PTHREAD_SPECIFIC - /* Empirically, as of gcc 3.3, USE_COMPILER_TLS doesn't work. */ -# else -# define USE_COMPILER_TLS -# endif -# else -# define USE_CUSTOM_SPECIFIC /* Use our own. */ -# endif -#endif - -#include - -/* One of these should be declared as the tlfs field in the */ -/* structure pointed to by a GC_thread. */ -typedef struct thread_local_freelists { - void * ptrfree_freelists[TINY_FREELISTS]; - void * normal_freelists[TINY_FREELISTS]; -# ifdef GC_GCJ_SUPPORT - void * gcj_freelists[TINY_FREELISTS]; -# define ERROR_FL ((void *)(word)-1) - /* Value used for gcj_freelist[-1]; allocation is */ - /* erroneous. */ -# endif -# ifdef ENABLE_DISCLAIM - void * finalized_freelists[TINY_FREELISTS]; -# endif - /* Free lists contain either a pointer or a small count */ - /* reflecting the number of granules allocated at that */ - /* size. */ - /* 0 ==> thread-local allocation in use, free list */ - /* empty. */ - /* > 0, <= DIRECT_GRANULES ==> Using global allocation, */ - /* too few objects of this size have been */ - /* allocated by this thread. */ - /* >= HBLKSIZE => pointer to nonempty free list. */ - /* > DIRECT_GRANULES, < HBLKSIZE ==> transition to */ - /* local alloc, equivalent to 0. */ -# define DIRECT_GRANULES (HBLKSIZE/GRANULE_BYTES) - /* Don't use local free lists for up to this much */ - /* allocation. */ -} *GC_tlfs; - -#if defined(USE_PTHREAD_SPECIFIC) -# define GC_getspecific pthread_getspecific -# define GC_setspecific pthread_setspecific -# define GC_key_create pthread_key_create -# define GC_remove_specific(key) /* No need for cleanup on exit. */ - typedef pthread_key_t GC_key_t; -#elif defined(USE_COMPILER_TLS) || defined(USE_WIN32_COMPILER_TLS) -# define GC_getspecific(x) (x) -# define GC_setspecific(key, v) ((key) = (v), 0) -# define GC_key_create(key, d) 0 -# define GC_remove_specific(key) /* No need for cleanup on exit. */ - typedef void * GC_key_t; -#elif defined(USE_WIN32_SPECIFIC) -# ifndef WIN32_LEAN_AND_MEAN -# define WIN32_LEAN_AND_MEAN 1 -# endif -# define NOSERVICE -# include -# define GC_getspecific TlsGetValue -# define GC_setspecific(key, v) !TlsSetValue(key, v) - /* We assume 0 == success, msft does the opposite. */ -# ifndef TLS_OUT_OF_INDEXES - /* this is currently missing in WinCE */ -# define TLS_OUT_OF_INDEXES (DWORD)0xFFFFFFFF -# endif -# define GC_key_create(key, d) \ - ((d) != 0 || (*(key) = TlsAlloc()) == TLS_OUT_OF_INDEXES ? -1 : 0) -# define GC_remove_specific(key) /* No need for cleanup on exit. */ - /* Need TlsFree on process exit/detach? */ - typedef DWORD GC_key_t; -#elif defined(USE_CUSTOM_SPECIFIC) -# include "private/specific.h" -#else -# error implement me -#endif - -/* Each thread structure must be initialized. */ -/* This call must be made from the new thread. */ -/* Caller holds allocation lock. */ -GC_INNER void GC_init_thread_local(GC_tlfs p); - -/* Called when a thread is unregistered, or exits. */ -/* We hold the allocator lock. */ -GC_INNER void GC_destroy_thread_local(GC_tlfs p); - -/* The thread support layer must arrange to mark thread-local */ -/* free lists explicitly, since the link field is often */ -/* invisible to the marker. It knows how to find all threads; */ -/* we take care of an individual thread freelist structure. */ -GC_INNER void GC_mark_thread_local_fls_for(GC_tlfs p); - -#ifdef ENABLE_DISCLAIM - GC_EXTERN ptr_t * GC_finalized_objfreelist; -#endif - -extern -#if defined(USE_COMPILER_TLS) - __thread -#elif defined(USE_WIN32_COMPILER_TLS) - __declspec(thread) -#endif -GC_key_t GC_thread_key; -/* This is set up by the thread_local_alloc implementation. No need */ -/* for cleanup on thread exit. But the thread support layer makes sure */ -/* that GC_thread_key is traced, if necessary. */ - -#endif /* THREAD_LOCAL_ALLOC */ - -#endif /* GC_THREAD_LOCAL_ALLOC_H */ diff -Nru ecl-16.1.2/src/bdwgc/include/weakpointer.h ecl-16.1.3+ds/src/bdwgc/include/weakpointer.h --- ecl-16.1.2/src/bdwgc/include/weakpointer.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/include/weakpointer.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,217 +0,0 @@ -#ifndef _weakpointer_h_ -#define _weakpointer_h_ - -/**************************************************************************** - -WeakPointer and CleanUp - - Copyright (c) 1991 by Xerox Corporation. All rights reserved. - - THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - - Permission is hereby granted to copy this code for any purpose, - provided the above notices are retained on all copies. - -****************************************************************************/ - -/**************************************************************************** - -WeakPointer - -A weak pointer is a pointer to a heap-allocated object that doesn't -prevent the object from being garbage collected. Weak pointers can be -used to track which objects haven't yet been reclaimed by the -collector. A weak pointer is deactivated when the collector discovers -its referent object is unreachable by normal pointers (reachability -and deactivation are defined more precisely below). A deactivated weak -pointer remains deactivated forever. - -****************************************************************************/ - - -template< class T > class WeakPointer { -public: - -WeakPointer( T* t = 0 ) - /* Constructs a weak pointer for *t. t may be null. It is an error - if t is non-null and *t is not a collected object. */ - {impl = _WeakPointer_New( t );} - -T* Pointer() - /* wp.Pointer() returns a pointer to the referent object of wp or - null if wp has been deactivated (because its referent object - has been discovered unreachable by the collector). */ - {return (T*) _WeakPointer_Pointer( this->impl );} - -int operator==( WeakPointer< T > wp2 ) - /* Given weak pointers wp1 and wp2, if wp1 == wp2, then wp1 and - wp2 refer to the same object. If wp1 != wp2, then either wp1 - and wp2 don't refer to the same object, or if they do, one or - both of them has been deactivated. (Note: If objects t1 and t2 - are never made reachable by their clean-up functions, then - WeakPointer(t1) == WeakPointer(t2) if and only t1 == t2.) */ - {return _WeakPointer_Equal( this->impl, wp2.impl );} - -int Hash() - /* Returns a hash code suitable for use by multiplicative- and - division-based hash tables. If wp1 == wp2, then wp1.Hash() == - wp2.Hash(). */ - {return _WeakPointer_Hash( this->impl );} - -private: -void* impl; -}; - -/***************************************************************************** - -CleanUp - -A garbage-collected object can have an associated clean-up function -that will be invoked some time after the collector discovers the -object is unreachable via normal pointers. Clean-up functions can be -used to release resources such as open-file handles or window handles -when their containing objects become unreachable. If a C++ object has -a non-empty explicit destructor (i.e. it contains programmer-written -code), the destructor will be automatically registered as the object's -initial clean-up function. - -There is no guarantee that the collector will detect every unreachable -object (though it will find almost all of them). Clients should not -rely on clean-up to cause some action to occur immediately -- clean-up -is only a mechanism for improving resource usage. - -Every object with a clean-up function also has a clean-up queue. When -the collector finds the object is unreachable, it enqueues it on its -queue. The clean-up function is applied when the object is removed -from the queue. By default, objects are enqueued on the garbage -collector's queue, and the collector removes all objects from its -queue after each collection. If a client supplies another queue for -objects, it is his responsibility to remove objects (and cause their -functions to be called) by polling it periodically. - -Clean-up queues allow clean-up functions accessing global data to -synchronize with the main program. Garbage collection can occur at any -time, and clean-ups invoked by the collector might access data in an -inconsistent state. A client can control this by defining an explicit -queue for objects and polling it at safe points. - -The following definitions are used by the specification below: - -Given a pointer t to a collected object, the base object BO(t) is the -value returned by new when it created the object. (Because of multiple -inheritance, t and BO(t) may not be the same address.) - -A weak pointer wp references an object *t if BO(wp.Pointer()) == -BO(t). - -***************************************************************************/ - -template< class T, class Data > class CleanUp { -public: - -static void Set( T* t, void c( Data* d, T* t ), Data* d = 0 ) - /* Sets the clean-up function of object BO(t) to be , - replacing any previously defined clean-up function for BO(t); c - and d can be null, but t cannot. Sets the clean-up queue for - BO(t) to be the collector's queue. When t is removed from its - clean-up queue, its clean-up will be applied by calling c(d, - t). It is an error if *t is not a collected object. */ - {_CleanUp_Set( t, c, d );} - -static void Call( T* t ) - /* Sets the new clean-up function for BO(t) to be null and, if the - old one is non-null, calls it immediately, even if BO(t) is - still reachable. Deactivates any weak pointers to BO(t). */ - {_CleanUp_Call( t );} - -class Queue {public: - Queue() - /* Constructs a new queue. */ - {this->head = _CleanUp_Queue_NewHead();} - - void Set( T* t ) - /* q.Set(t) sets the clean-up queue of BO(t) to be q. */ - {_CleanUp_Queue_Set( this->head, t );} - - int Call() - /* If q is non-empty, q.Call() removes the first object and - calls its clean-up function; does nothing if q is - empty. Returns true if there are more objects in the - queue. */ - {return _CleanUp_Queue_Call( this->head );} - - private: - void* head; - }; -}; - -/********************************************************************** - -Reachability and Clean-up - -An object O is reachable if it can be reached via a non-empty path of -normal pointers from the registers, stacks, global variables, or an -object with a non-null clean-up function (including O itself), -ignoring pointers from an object to itself. - -This definition of reachability ensures that if object B is accessible -from object A (and not vice versa) and if both A and B have clean-up -functions, then A will always be cleaned up before B. Note that as -long as an object with a clean-up function is contained in a cycle of -pointers, it will always be reachable and will never be cleaned up or -collected. - -When the collector finds an unreachable object with a null clean-up -function, it atomically deactivates all weak pointers referencing the -object and recycles its storage. If object B is accessible from object -A via a path of normal pointers, A will be discovered unreachable no -later than B, and a weak pointer to A will be deactivated no later -than a weak pointer to B. - -When the collector finds an unreachable object with a non-null -clean-up function, the collector atomically deactivates all weak -pointers referencing the object, redefines its clean-up function to be -null, and enqueues it on its clean-up queue. The object then becomes -reachable again and remains reachable at least until its clean-up -function executes. - -The clean-up function is assured that its argument is the only -accessible pointer to the object. Nothing prevents the function from -redefining the object's clean-up function or making the object -reachable again (for example, by storing the pointer in a global -variable). - -If the clean-up function does not make its object reachable again and -does not redefine its clean-up function, then the object will be -collected by a subsequent collection (because the object remains -unreachable and now has a null clean-up function). If the clean-up -function does make its object reachable again and a clean-up function -is subsequently redefined for the object, then the new clean-up -function will be invoked the next time the collector finds the object -unreachable. - -Note that a destructor for a collected object cannot safely redefine a -clean-up function for its object, since after the destructor executes, -the object has been destroyed into "raw memory". (In most -implementations, destroying an object mutates its vtbl.) - -Finally, note that calling delete t on a collected object first -deactivates any weak pointers to t and then invokes its clean-up -function (destructor). - -**********************************************************************/ - -extern "C" { - void* _WeakPointer_New( void* t ); - void* _WeakPointer_Pointer( void* wp ); - int _WeakPointer_Equal( void* wp1, void* wp2 ); - int _WeakPointer_Hash( void* wp ); - void _CleanUp_Set( void* t, void (*c)( void* d, void* t ), void* d ); - void _CleanUp_Call( void* t ); - void* _CleanUp_Queue_NewHead (); - void _CleanUp_Queue_Set( void* h, void* t ); - int _CleanUp_Queue_Call( void* h ); -} - -#endif /* _weakpointer_h_ */ diff -Nru ecl-16.1.2/src/bdwgc/install-sh ecl-16.1.3+ds/src/bdwgc/install-sh --- ecl-16.1.2/src/bdwgc/install-sh 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/install-sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,501 +0,0 @@ -#!/bin/sh -# install - install a program, script, or datafile - -scriptversion=2013-12-25.23; # UTC - -# 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. - -tab=' ' -nl=' -' -IFS=" $tab$nl" - -# Set DOITPROG to "echo" to test this script. - -doit=${DOITPROG-} -doit_exec=${doit:-exec} - -# 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_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 -is_target_a_directory=possibly - -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 - *' '* | *"$tab"* | *"$nl"* | *'*'* | *'?'* | *'['*) - echo "$0: invalid mode: $mode" >&2 - exit 1;; - esac - shift;; - - -o) chowncmd="$chownprog $2" - shift;; - - -s) stripcmd=$stripprog;; - - -t) - is_target_a_directory=always - dst_arg=$2 - # Protect names problematic for 'test' and other utilities. - case $dst_arg in - -* | [=\(\)!]) dst_arg=./$dst_arg;; - esac - shift;; - - -T) is_target_a_directory=never;; - - --version) echo "$0 $scriptversion"; exit $?;; - - --) shift - break;; - - -*) echo "$0: invalid option: $1" >&2 - exit 1;; - - *) break;; - esac - shift -done - -# We allow the use of options -d and -T together, by making -d -# take the precedence; this is for compatibility with GNU install. - -if test -n "$dir_arg"; then - if test -n "$dst_arg"; then - echo "$0: target directory not allowed when installing a directory." >&2 - exit 1 - fi -fi - -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 - # Protect names problematic for 'test' and other utilities. - case $dst_arg in - -* | [=\(\)!]) dst_arg=./$dst_arg;; - esac - 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 - if test $# -gt 1 || test "$is_target_a_directory" = always; then - if test ! -d "$dst_arg"; then - echo "$0: $dst_arg: Is not a directory." >&2 - exit 1 - fi - fi -fi - -if test -z "$dir_arg"; then - do_exit='(exit $ret); exit $ret' - trap "ret=129; $do_exit" 1 - trap "ret=130; $do_exit" 2 - trap "ret=141; $do_exit" 13 - trap "ret=143; $do_exit" 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 problematic for 'test' and other utilities. - 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 - - # 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 "$is_target_a_directory" = never; then - echo "$0: $dst_arg: Is a directory" >&2 - exit 1 - fi - dstdir=$dst - dst=$dstdir/`basename "$src"` - dstdir_status=0 - else - dstdir=`dirname "$dst"` - 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-writable 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 - - oIFS=$IFS - IFS=/ - set -f - set fnord $dstdir - shift - set +f - IFS=$oIFS - - prefixes= - - for d - do - test X"$d" = X && 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` && - set -f && - set X $old && old=:$2:$4:$5:$6 && - set X $new && new=:$2:$4:$5:$6 && - 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-time-zone: "UTC" -# time-stamp-end: "; # UTC" -# End: diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/aclocal.m4 ecl-16.1.3+ds/src/bdwgc/libatomic_ops/aclocal.m4 --- ecl-16.1.2/src/bdwgc/libatomic_ops/aclocal.m4 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/aclocal.m4 1970-01-01 00:00:00.000000000 +0000 @@ -1,1213 +0,0 @@ -# generated automatically by aclocal 1.15 -*- Autoconf -*- - -# Copyright (C) 1996-2014 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. - -m4_ifndef([AC_CONFIG_MACRO_DIRS], [m4_defun([_AM_CONFIG_MACRO_DIRS], [])m4_defun([AC_CONFIG_MACRO_DIRS], [_AM_CONFIG_MACRO_DIRS($@)])]) -m4_ifndef([AC_AUTOCONF_VERSION], - [m4_copy([m4_PACKAGE_VERSION], [AC_AUTOCONF_VERSION])])dnl -m4_if(m4_defn([AC_AUTOCONF_VERSION]), [2.69],, -[m4_warning([this file was generated for autoconf 2.69. -You have another version of autoconf. It may work, but is not guaranteed to. -If you have problems, you may need to regenerate the build system entirely. -To do so, use the procedure documented by the package, typically 'autoreconf'.])]) - -# Copyright (C) 2002-2014 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. - -# AM_AUTOMAKE_VERSION(VERSION) -# ---------------------------- -# Automake X.Y traces this macro to ensure aclocal.m4 has been -# generated from the m4 files accompanying Automake X.Y. -# (This private macro should not be called outside this file.) -AC_DEFUN([AM_AUTOMAKE_VERSION], -[am__api_version='1.15' -dnl Some users find AM_AUTOMAKE_VERSION and mistake it for a way to -dnl require some minimum version. Point them to the right macro. -m4_if([$1], [1.15], [], - [AC_FATAL([Do not call $0, use AM_INIT_AUTOMAKE([$1]).])])dnl -]) - -# _AM_AUTOCONF_VERSION(VERSION) -# ----------------------------- -# aclocal traces this macro to find the Autoconf version. -# This is a private macro too. Using m4_define simplifies -# the logic in aclocal, which can simply ignore this definition. -m4_define([_AM_AUTOCONF_VERSION], []) - -# AM_SET_CURRENT_AUTOMAKE_VERSION -# ------------------------------- -# Call AM_AUTOMAKE_VERSION and AM_AUTOMAKE_VERSION so they can be traced. -# This function is AC_REQUIREd by AM_INIT_AUTOMAKE. -AC_DEFUN([AM_SET_CURRENT_AUTOMAKE_VERSION], -[AM_AUTOMAKE_VERSION([1.15])dnl -m4_ifndef([AC_AUTOCONF_VERSION], - [m4_copy([m4_PACKAGE_VERSION], [AC_AUTOCONF_VERSION])])dnl -_AM_AUTOCONF_VERSION(m4_defn([AC_AUTOCONF_VERSION]))]) - -# Figure out how to run the assembler. -*- Autoconf -*- - -# Copyright (C) 2001-2014 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. - -# AM_PROG_AS -# ---------- -AC_DEFUN([AM_PROG_AS], -[# By default we simply use the C compiler to build assembly code. -AC_REQUIRE([AC_PROG_CC]) -test "${CCAS+set}" = set || CCAS=$CC -test "${CCASFLAGS+set}" = set || CCASFLAGS=$CFLAGS -AC_ARG_VAR([CCAS], [assembler compiler command (defaults to CC)]) -AC_ARG_VAR([CCASFLAGS], [assembler compiler flags (defaults to CFLAGS)]) -_AM_IF_OPTION([no-dependencies],, [_AM_DEPENDENCIES([CCAS])])dnl -]) - -# AM_AUX_DIR_EXPAND -*- Autoconf -*- - -# Copyright (C) 2001-2014 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. - -# For projects using AC_CONFIG_AUX_DIR([foo]), Autoconf sets -# $ac_aux_dir to '$srcdir/foo'. In other projects, it is set to -# '$srcdir', '$srcdir/..', or '$srcdir/../..'. -# -# Of course, Automake must honor this variable whenever it calls a -# tool from the auxiliary directory. The problem is that $srcdir (and -# therefore $ac_aux_dir as well) can be either absolute or relative, -# depending on how configure is run. This is pretty annoying, since -# it makes $ac_aux_dir quite unusable in subdirectories: in the top -# source directory, any form will work fine, but in subdirectories a -# relative path needs to be adjusted first. -# -# $ac_aux_dir/missing -# fails when called from a subdirectory if $ac_aux_dir is relative -# $top_srcdir/$ac_aux_dir/missing -# fails if $ac_aux_dir is absolute, -# fails when called from a subdirectory in a VPATH build with -# a relative $ac_aux_dir -# -# The reason of the latter failure is that $top_srcdir and $ac_aux_dir -# are both prefixed by $srcdir. In an in-source build this is usually -# harmless because $srcdir is '.', but things will broke when you -# start a VPATH build or use an absolute $srcdir. -# -# So we could use something similar to $top_srcdir/$ac_aux_dir/missing, -# iff we strip the leading $srcdir from $ac_aux_dir. That would be: -# am_aux_dir='\$(top_srcdir)/'`expr "$ac_aux_dir" : "$srcdir//*\(.*\)"` -# and then we would define $MISSING as -# MISSING="\${SHELL} $am_aux_dir/missing" -# This will work as long as MISSING is not called from configure, because -# unfortunately $(top_srcdir) has no meaning in configure. -# However there are other variables, like CC, which are often used in -# configure, and could therefore not use this "fixed" $ac_aux_dir. -# -# Another solution, used here, is to always expand $ac_aux_dir to an -# absolute PATH. The drawback is that using absolute paths prevent a -# configured tree to be moved without reconfiguration. - -AC_DEFUN([AM_AUX_DIR_EXPAND], -[AC_REQUIRE([AC_CONFIG_AUX_DIR_DEFAULT])dnl -# Expand $ac_aux_dir to an absolute path. -am_aux_dir=`cd "$ac_aux_dir" && pwd` -]) - -# AM_CONDITIONAL -*- Autoconf -*- - -# Copyright (C) 1997-2014 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. - -# AM_CONDITIONAL(NAME, SHELL-CONDITION) -# ------------------------------------- -# Define a conditional. -AC_DEFUN([AM_CONDITIONAL], -[AC_PREREQ([2.52])dnl - m4_if([$1], [TRUE], [AC_FATAL([$0: invalid condition: $1])], - [$1], [FALSE], [AC_FATAL([$0: invalid condition: $1])])dnl -AC_SUBST([$1_TRUE])dnl -AC_SUBST([$1_FALSE])dnl -_AM_SUBST_NOTMAKE([$1_TRUE])dnl -_AM_SUBST_NOTMAKE([$1_FALSE])dnl -m4_define([_AM_COND_VALUE_$1], [$2])dnl -if $2; then - $1_TRUE= - $1_FALSE='#' -else - $1_TRUE='#' - $1_FALSE= -fi -AC_CONFIG_COMMANDS_PRE( -[if test -z "${$1_TRUE}" && test -z "${$1_FALSE}"; then - AC_MSG_ERROR([[conditional "$1" was never defined. -Usually this means the macro was only invoked conditionally.]]) -fi])]) - -# Copyright (C) 1999-2014 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. - - -# There are a few dirty hacks below to avoid letting 'AC_PROG_CC' be -# written in clear, in which case automake, when reading aclocal.m4, -# will think it sees a *use*, and therefore will trigger all it's -# C support machinery. Also note that it means that autoscan, seeing -# CC etc. in the Makefile, will ask for an AC_PROG_CC use... - - -# _AM_DEPENDENCIES(NAME) -# ---------------------- -# See how the compiler implements dependency checking. -# NAME is "CC", "CXX", "OBJC", "OBJCXX", "UPC", or "GJC". -# We try a few techniques and use that to set a single cache variable. -# -# We don't AC_REQUIRE the corresponding AC_PROG_CC since the latter was -# modified to invoke _AM_DEPENDENCIES(CC); we would have a circular -# dependency, and given that the user is not expected to run this macro, -# just rely on AC_PROG_CC. -AC_DEFUN([_AM_DEPENDENCIES], -[AC_REQUIRE([AM_SET_DEPDIR])dnl -AC_REQUIRE([AM_OUTPUT_DEPENDENCY_COMMANDS])dnl -AC_REQUIRE([AM_MAKE_INCLUDE])dnl -AC_REQUIRE([AM_DEP_TRACK])dnl - -m4_if([$1], [CC], [depcc="$CC" am_compiler_list=], - [$1], [CXX], [depcc="$CXX" am_compiler_list=], - [$1], [OBJC], [depcc="$OBJC" am_compiler_list='gcc3 gcc'], - [$1], [OBJCXX], [depcc="$OBJCXX" am_compiler_list='gcc3 gcc'], - [$1], [UPC], [depcc="$UPC" am_compiler_list=], - [$1], [GCJ], [depcc="$GCJ" am_compiler_list='gcc3 gcc'], - [depcc="$$1" am_compiler_list=]) - -AC_CACHE_CHECK([dependency style of $depcc], - [am_cv_$1_dependencies_compiler_type], -[if test -z "$AMDEP_TRUE" && test -f "$am_depcomp"; then - # We make a subdir and do the tests there. Otherwise we can end up - # making bogus files that we don't know about and never remove. For - # instance it was reported that on HP-UX the gcc test will end up - # making a dummy file named 'D' -- because '-MD' means "put the output - # in D". - rm -rf conftest.dir - mkdir conftest.dir - # Copy depcomp to subdir because otherwise we won't find it if we're - # using a relative directory. - cp "$am_depcomp" conftest.dir - cd conftest.dir - # We will build objects and dependencies in a subdirectory because - # it helps to detect inapplicable dependency modes. For instance - # both Tru64's cc and ICC support -MD to output dependencies as a - # side effect of compilation, but ICC will put the dependencies in - # the current directory while Tru64 will put them in the object - # directory. - mkdir sub - - am_cv_$1_dependencies_compiler_type=none - if test "$am_compiler_list" = ""; then - am_compiler_list=`sed -n ['s/^#*\([a-zA-Z0-9]*\))$/\1/p'] < ./depcomp` - fi - am__universal=false - m4_case([$1], [CC], - [case " $depcc " in #( - *\ -arch\ *\ -arch\ *) am__universal=true ;; - esac], - [CXX], - [case " $depcc " in #( - *\ -arch\ *\ -arch\ *) am__universal=true ;; - esac]) - - for depmode in $am_compiler_list; do - # Setup a source with many dependencies, because some compilers - # like to wrap large dependency lists on column 80 (with \), and - # we should not choose a depcomp mode which is confused by this. - # - # We need to recreate these files for each test, as the compiler may - # overwrite some of them when testing with obscure command lines. - # This happens at least with the AIX C compiler. - : > sub/conftest.c - for i in 1 2 3 4 5 6; do - echo '#include "conftst'$i'.h"' >> sub/conftest.c - # Using ": > sub/conftst$i.h" creates only sub/conftst1.h with - # Solaris 10 /bin/sh. - echo '/* dummy */' > sub/conftst$i.h - done - echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf - - # We check with '-c' and '-o' for the sake of the "dashmstdout" - # mode. It turns out that the SunPro C++ compiler does not properly - # handle '-M -o', and we need to detect this. Also, some Intel - # versions had trouble with output in subdirs. - am__obj=sub/conftest.${OBJEXT-o} - am__minus_obj="-o $am__obj" - case $depmode in - gcc) - # This depmode causes a compiler race in universal mode. - test "$am__universal" = false || continue - ;; - nosideeffect) - # After this tag, mechanisms are not by side-effect, so they'll - # only be used when explicitly requested. - if test "x$enable_dependency_tracking" = xyes; then - continue - else - break - fi - ;; - msvc7 | msvc7msys | msvisualcpp | msvcmsys) - # This compiler won't grok '-c -o', but also, the minuso test has - # not run yet. These depmodes are late enough in the game, and - # so weak that their functioning should not be impacted. - am__obj=conftest.${OBJEXT-o} - am__minus_obj= - ;; - none) break ;; - esac - if depmode=$depmode \ - source=sub/conftest.c object=$am__obj \ - depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \ - $SHELL ./depcomp $depcc -c $am__minus_obj sub/conftest.c \ - >/dev/null 2>conftest.err && - grep sub/conftst1.h sub/conftest.Po > /dev/null 2>&1 && - grep sub/conftst6.h sub/conftest.Po > /dev/null 2>&1 && - grep $am__obj sub/conftest.Po > /dev/null 2>&1 && - ${MAKE-make} -s -f confmf > /dev/null 2>&1; then - # icc doesn't choke on unknown options, it will just issue warnings - # or remarks (even with -Werror). So we grep stderr for any message - # that says an option was ignored or not supported. - # When given -MP, icc 7.0 and 7.1 complain thusly: - # icc: Command line warning: ignoring option '-M'; no argument required - # The diagnosis changed in icc 8.0: - # icc: Command line remark: option '-MP' not supported - if (grep 'ignoring option' conftest.err || - grep 'not supported' conftest.err) >/dev/null 2>&1; then :; else - am_cv_$1_dependencies_compiler_type=$depmode - break - fi - fi - done - - cd .. - rm -rf conftest.dir -else - am_cv_$1_dependencies_compiler_type=none -fi -]) -AC_SUBST([$1DEPMODE], [depmode=$am_cv_$1_dependencies_compiler_type]) -AM_CONDITIONAL([am__fastdep$1], [ - test "x$enable_dependency_tracking" != xno \ - && test "$am_cv_$1_dependencies_compiler_type" = gcc3]) -]) - - -# AM_SET_DEPDIR -# ------------- -# Choose a directory name for dependency files. -# This macro is AC_REQUIREd in _AM_DEPENDENCIES. -AC_DEFUN([AM_SET_DEPDIR], -[AC_REQUIRE([AM_SET_LEADING_DOT])dnl -AC_SUBST([DEPDIR], ["${am__leading_dot}deps"])dnl -]) - - -# AM_DEP_TRACK -# ------------ -AC_DEFUN([AM_DEP_TRACK], -[AC_ARG_ENABLE([dependency-tracking], [dnl -AS_HELP_STRING( - [--enable-dependency-tracking], - [do not reject slow dependency extractors]) -AS_HELP_STRING( - [--disable-dependency-tracking], - [speeds up one-time build])]) -if test "x$enable_dependency_tracking" != xno; then - am_depcomp="$ac_aux_dir/depcomp" - AMDEPBACKSLASH='\' - am__nodep='_no' -fi -AM_CONDITIONAL([AMDEP], [test "x$enable_dependency_tracking" != xno]) -AC_SUBST([AMDEPBACKSLASH])dnl -_AM_SUBST_NOTMAKE([AMDEPBACKSLASH])dnl -AC_SUBST([am__nodep])dnl -_AM_SUBST_NOTMAKE([am__nodep])dnl -]) - -# Generate code to set up dependency tracking. -*- Autoconf -*- - -# Copyright (C) 1999-2014 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. - - -# _AM_OUTPUT_DEPENDENCY_COMMANDS -# ------------------------------ -AC_DEFUN([_AM_OUTPUT_DEPENDENCY_COMMANDS], -[{ - # Older Autoconf quotes --file arguments for eval, but not when files - # are listed without --file. Let's play safe and only enable the eval - # if we detect the quoting. - case $CONFIG_FILES in - *\'*) eval set x "$CONFIG_FILES" ;; - *) set x $CONFIG_FILES ;; - esac - shift - for mf - do - # Strip MF so we end up with the name of the file. - mf=`echo "$mf" | sed -e 's/:.*$//'` - # Check whether this is an Automake generated Makefile or not. - # We used to match only the files named 'Makefile.in', but - # some people rename them; so instead we look at the file content. - # Grep'ing the first line is not enough: some people post-process - # each Makefile.in and add a new line on top of each file to say so. - # Grep'ing the whole file is not good either: AIX grep has a line - # limit of 2048, but all sed's we know have understand at least 4000. - if sed -n 's,^#.*generated by automake.*,X,p' "$mf" | grep X >/dev/null 2>&1; then - dirpart=`AS_DIRNAME("$mf")` - else - continue - fi - # Extract the definition of DEPDIR, am__include, and am__quote - # from the Makefile without running 'make'. - DEPDIR=`sed -n 's/^DEPDIR = //p' < "$mf"` - test -z "$DEPDIR" && continue - am__include=`sed -n 's/^am__include = //p' < "$mf"` - test -z "$am__include" && continue - am__quote=`sed -n 's/^am__quote = //p' < "$mf"` - # Find all dependency output files, they are included files with - # $(DEPDIR) in their names. We invoke sed twice because it is the - # simplest approach to changing $(DEPDIR) to its actual value in the - # expansion. - for file in `sed -n " - s/^$am__include $am__quote\(.*(DEPDIR).*\)$am__quote"'$/\1/p' <"$mf" | \ - sed -e 's/\$(DEPDIR)/'"$DEPDIR"'/g'`; do - # Make sure the directory exists. - test -f "$dirpart/$file" && continue - fdir=`AS_DIRNAME(["$file"])` - AS_MKDIR_P([$dirpart/$fdir]) - # echo "creating $dirpart/$file" - echo '# dummy' > "$dirpart/$file" - done - done -} -])# _AM_OUTPUT_DEPENDENCY_COMMANDS - - -# AM_OUTPUT_DEPENDENCY_COMMANDS -# ----------------------------- -# This macro should only be invoked once -- use via AC_REQUIRE. -# -# This code is only required when automatic dependency tracking -# is enabled. FIXME. This creates each '.P' file that we will -# need in order to bootstrap the dependency handling code. -AC_DEFUN([AM_OUTPUT_DEPENDENCY_COMMANDS], -[AC_CONFIG_COMMANDS([depfiles], - [test x"$AMDEP_TRUE" != x"" || _AM_OUTPUT_DEPENDENCY_COMMANDS], - [AMDEP_TRUE="$AMDEP_TRUE" ac_aux_dir="$ac_aux_dir"]) -]) - -# Do all the work for Automake. -*- Autoconf -*- - -# Copyright (C) 1996-2014 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 macro actually does too much. Some checks are only needed if -# your package does certain things. But this isn't really a big deal. - -dnl Redefine AC_PROG_CC to automatically invoke _AM_PROG_CC_C_O. -m4_define([AC_PROG_CC], -m4_defn([AC_PROG_CC]) -[_AM_PROG_CC_C_O -]) - -# AM_INIT_AUTOMAKE(PACKAGE, VERSION, [NO-DEFINE]) -# AM_INIT_AUTOMAKE([OPTIONS]) -# ----------------------------------------------- -# The call with PACKAGE and VERSION arguments is the old style -# call (pre autoconf-2.50), which is being phased out. PACKAGE -# and VERSION should now be passed to AC_INIT and removed from -# the call to AM_INIT_AUTOMAKE. -# We support both call styles for the transition. After -# the next Automake release, Autoconf can make the AC_INIT -# arguments mandatory, and then we can depend on a new Autoconf -# release and drop the old call support. -AC_DEFUN([AM_INIT_AUTOMAKE], -[AC_PREREQ([2.65])dnl -dnl Autoconf wants to disallow AM_ names. We explicitly allow -dnl the ones we care about. -m4_pattern_allow([^AM_[A-Z]+FLAGS$])dnl -AC_REQUIRE([AM_SET_CURRENT_AUTOMAKE_VERSION])dnl -AC_REQUIRE([AC_PROG_INSTALL])dnl -if test "`cd $srcdir && pwd`" != "`pwd`"; then - # Use -I$(srcdir) only when $(srcdir) != ., so that make's output - # is not polluted with repeated "-I." - AC_SUBST([am__isrc], [' -I$(srcdir)'])_AM_SUBST_NOTMAKE([am__isrc])dnl - # test to see if srcdir already configured - if test -f $srcdir/config.status; then - AC_MSG_ERROR([source directory already configured; run "make distclean" there first]) - fi -fi - -# test whether we have cygpath -if test -z "$CYGPATH_W"; then - if (cygpath --version) >/dev/null 2>/dev/null; then - CYGPATH_W='cygpath -w' - else - CYGPATH_W=echo - fi -fi -AC_SUBST([CYGPATH_W]) - -# Define the identity of the package. -dnl Distinguish between old-style and new-style calls. -m4_ifval([$2], -[AC_DIAGNOSE([obsolete], - [$0: two- and three-arguments forms are deprecated.]) -m4_ifval([$3], [_AM_SET_OPTION([no-define])])dnl - AC_SUBST([PACKAGE], [$1])dnl - AC_SUBST([VERSION], [$2])], -[_AM_SET_OPTIONS([$1])dnl -dnl Diagnose old-style AC_INIT with new-style AM_AUTOMAKE_INIT. -m4_if( - m4_ifdef([AC_PACKAGE_NAME], [ok]):m4_ifdef([AC_PACKAGE_VERSION], [ok]), - [ok:ok],, - [m4_fatal([AC_INIT should be called with package and version arguments])])dnl - AC_SUBST([PACKAGE], ['AC_PACKAGE_TARNAME'])dnl - AC_SUBST([VERSION], ['AC_PACKAGE_VERSION'])])dnl - -_AM_IF_OPTION([no-define],, -[AC_DEFINE_UNQUOTED([PACKAGE], ["$PACKAGE"], [Name of package]) - AC_DEFINE_UNQUOTED([VERSION], ["$VERSION"], [Version number of package])])dnl - -# Some tools Automake needs. -AC_REQUIRE([AM_SANITY_CHECK])dnl -AC_REQUIRE([AC_ARG_PROGRAM])dnl -AM_MISSING_PROG([ACLOCAL], [aclocal-${am__api_version}]) -AM_MISSING_PROG([AUTOCONF], [autoconf]) -AM_MISSING_PROG([AUTOMAKE], [automake-${am__api_version}]) -AM_MISSING_PROG([AUTOHEADER], [autoheader]) -AM_MISSING_PROG([MAKEINFO], [makeinfo]) -AC_REQUIRE([AM_PROG_INSTALL_SH])dnl -AC_REQUIRE([AM_PROG_INSTALL_STRIP])dnl -AC_REQUIRE([AC_PROG_MKDIR_P])dnl -# For better backward compatibility. To be removed once Automake 1.9.x -# dies out for good. For more background, see: -# -# -AC_SUBST([mkdir_p], ['$(MKDIR_P)']) -# We need awk for the "check" target (and possibly the TAP driver). The -# system "awk" is bad on some platforms. -AC_REQUIRE([AC_PROG_AWK])dnl -AC_REQUIRE([AC_PROG_MAKE_SET])dnl -AC_REQUIRE([AM_SET_LEADING_DOT])dnl -_AM_IF_OPTION([tar-ustar], [_AM_PROG_TAR([ustar])], - [_AM_IF_OPTION([tar-pax], [_AM_PROG_TAR([pax])], - [_AM_PROG_TAR([v7])])]) -_AM_IF_OPTION([no-dependencies],, -[AC_PROVIDE_IFELSE([AC_PROG_CC], - [_AM_DEPENDENCIES([CC])], - [m4_define([AC_PROG_CC], - m4_defn([AC_PROG_CC])[_AM_DEPENDENCIES([CC])])])dnl -AC_PROVIDE_IFELSE([AC_PROG_CXX], - [_AM_DEPENDENCIES([CXX])], - [m4_define([AC_PROG_CXX], - m4_defn([AC_PROG_CXX])[_AM_DEPENDENCIES([CXX])])])dnl -AC_PROVIDE_IFELSE([AC_PROG_OBJC], - [_AM_DEPENDENCIES([OBJC])], - [m4_define([AC_PROG_OBJC], - m4_defn([AC_PROG_OBJC])[_AM_DEPENDENCIES([OBJC])])])dnl -AC_PROVIDE_IFELSE([AC_PROG_OBJCXX], - [_AM_DEPENDENCIES([OBJCXX])], - [m4_define([AC_PROG_OBJCXX], - m4_defn([AC_PROG_OBJCXX])[_AM_DEPENDENCIES([OBJCXX])])])dnl -]) -AC_REQUIRE([AM_SILENT_RULES])dnl -dnl The testsuite driver may need to know about EXEEXT, so add the -dnl 'am__EXEEXT' conditional if _AM_COMPILER_EXEEXT was seen. This -dnl macro is hooked onto _AC_COMPILER_EXEEXT early, see below. -AC_CONFIG_COMMANDS_PRE(dnl -[m4_provide_if([_AM_COMPILER_EXEEXT], - [AM_CONDITIONAL([am__EXEEXT], [test -n "$EXEEXT"])])])dnl - -# POSIX will say in a future version that running "rm -f" with no argument -# is OK; and we want to be able to make that assumption in our Makefile -# recipes. So use an aggressive probe to check that the usage we want is -# actually supported "in the wild" to an acceptable degree. -# See automake bug#10828. -# To make any issue more visible, cause the running configure to be aborted -# by default if the 'rm' program in use doesn't match our expectations; the -# user can still override this though. -if rm -f && rm -fr && rm -rf; then : OK; else - cat >&2 <<'END' -Oops! - -Your 'rm' program seems unable to run without file operands specified -on the command line, even when the '-f' option is present. This is contrary -to the behaviour of most rm programs out there, and not conforming with -the upcoming POSIX standard: - -Please tell bug-automake@gnu.org about your system, including the value -of your $PATH and any error possibly output before this message. This -can help us improve future automake versions. - -END - if test x"$ACCEPT_INFERIOR_RM_PROGRAM" = x"yes"; then - echo 'Configuration will proceed anyway, since you have set the' >&2 - echo 'ACCEPT_INFERIOR_RM_PROGRAM variable to "yes"' >&2 - echo >&2 - else - cat >&2 <<'END' -Aborting the configuration process, to ensure you take notice of the issue. - -You can download and install GNU coreutils to get an 'rm' implementation -that behaves properly: . - -If you want to complete the configuration process using your problematic -'rm' anyway, export the environment variable ACCEPT_INFERIOR_RM_PROGRAM -to "yes", and re-run configure. - -END - AC_MSG_ERROR([Your 'rm' program is bad, sorry.]) - fi -fi -dnl The trailing newline in this macro's definition is deliberate, for -dnl backward compatibility and to allow trailing 'dnl'-style comments -dnl after the AM_INIT_AUTOMAKE invocation. See automake bug#16841. -]) - -dnl Hook into '_AC_COMPILER_EXEEXT' early to learn its expansion. Do not -dnl add the conditional right here, as _AC_COMPILER_EXEEXT may be further -dnl mangled by Autoconf and run in a shell conditional statement. -m4_define([_AC_COMPILER_EXEEXT], -m4_defn([_AC_COMPILER_EXEEXT])[m4_provide([_AM_COMPILER_EXEEXT])]) - -# When config.status generates a header, we must update the stamp-h file. -# This file resides in the same directory as the config header -# that is generated. The stamp files are numbered to have different names. - -# Autoconf calls _AC_AM_CONFIG_HEADER_HOOK (when defined) in the -# loop where config.status creates the headers, so we can generate -# our stamp files there. -AC_DEFUN([_AC_AM_CONFIG_HEADER_HOOK], -[# Compute $1's index in $config_headers. -_am_arg=$1 -_am_stamp_count=1 -for _am_header in $config_headers :; do - case $_am_header in - $_am_arg | $_am_arg:* ) - break ;; - * ) - _am_stamp_count=`expr $_am_stamp_count + 1` ;; - esac -done -echo "timestamp for $_am_arg" >`AS_DIRNAME(["$_am_arg"])`/stamp-h[]$_am_stamp_count]) - -# Copyright (C) 2001-2014 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. - -# AM_PROG_INSTALL_SH -# ------------------ -# Define $install_sh. -AC_DEFUN([AM_PROG_INSTALL_SH], -[AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl -if test x"${install_sh+set}" != xset; then - case $am_aux_dir in - *\ * | *\ *) - install_sh="\${SHELL} '$am_aux_dir/install-sh'" ;; - *) - install_sh="\${SHELL} $am_aux_dir/install-sh" - esac -fi -AC_SUBST([install_sh])]) - -# Copyright (C) 2003-2014 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. - -# Check whether the underlying file-system supports filenames -# with a leading dot. For instance MS-DOS doesn't. -AC_DEFUN([AM_SET_LEADING_DOT], -[rm -rf .tst 2>/dev/null -mkdir .tst 2>/dev/null -if test -d .tst; then - am__leading_dot=. -else - am__leading_dot=_ -fi -rmdir .tst 2>/dev/null -AC_SUBST([am__leading_dot])]) - -# Add --enable-maintainer-mode option to configure. -*- Autoconf -*- -# From Jim Meyering - -# Copyright (C) 1996-2014 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. - -# AM_MAINTAINER_MODE([DEFAULT-MODE]) -# ---------------------------------- -# Control maintainer-specific portions of Makefiles. -# Default is to disable them, unless 'enable' is passed literally. -# For symmetry, 'disable' may be passed as well. Anyway, the user -# can override the default with the --enable/--disable switch. -AC_DEFUN([AM_MAINTAINER_MODE], -[m4_case(m4_default([$1], [disable]), - [enable], [m4_define([am_maintainer_other], [disable])], - [disable], [m4_define([am_maintainer_other], [enable])], - [m4_define([am_maintainer_other], [enable]) - m4_warn([syntax], [unexpected argument to AM@&t@_MAINTAINER_MODE: $1])]) -AC_MSG_CHECKING([whether to enable maintainer-specific portions of Makefiles]) - dnl maintainer-mode's default is 'disable' unless 'enable' is passed - AC_ARG_ENABLE([maintainer-mode], - [AS_HELP_STRING([--]am_maintainer_other[-maintainer-mode], - am_maintainer_other[ make rules and dependencies not useful - (and sometimes confusing) to the casual installer])], - [USE_MAINTAINER_MODE=$enableval], - [USE_MAINTAINER_MODE=]m4_if(am_maintainer_other, [enable], [no], [yes])) - AC_MSG_RESULT([$USE_MAINTAINER_MODE]) - AM_CONDITIONAL([MAINTAINER_MODE], [test $USE_MAINTAINER_MODE = yes]) - MAINT=$MAINTAINER_MODE_TRUE - AC_SUBST([MAINT])dnl -] -) - -# Check to see how 'make' treats includes. -*- Autoconf -*- - -# Copyright (C) 2001-2014 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. - -# AM_MAKE_INCLUDE() -# ----------------- -# Check to see how make treats includes. -AC_DEFUN([AM_MAKE_INCLUDE], -[am_make=${MAKE-make} -cat > confinc << 'END' -am__doit: - @echo this is the am__doit target -.PHONY: am__doit -END -# If we don't find an include directive, just comment out the code. -AC_MSG_CHECKING([for style of include used by $am_make]) -am__include="#" -am__quote= -_am_result=none -# First try GNU make style include. -echo "include confinc" > confmf -# Ignore all kinds of additional output from 'make'. -case `$am_make -s -f confmf 2> /dev/null` in #( -*the\ am__doit\ target*) - am__include=include - am__quote= - _am_result=GNU - ;; -esac -# Now try BSD make style include. -if test "$am__include" = "#"; then - echo '.include "confinc"' > confmf - case `$am_make -s -f confmf 2> /dev/null` in #( - *the\ am__doit\ target*) - am__include=.include - am__quote="\"" - _am_result=BSD - ;; - esac -fi -AC_SUBST([am__include]) -AC_SUBST([am__quote]) -AC_MSG_RESULT([$_am_result]) -rm -f confinc confmf -]) - -# Fake the existence of programs that GNU maintainers use. -*- Autoconf -*- - -# Copyright (C) 1997-2014 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. - -# AM_MISSING_PROG(NAME, PROGRAM) -# ------------------------------ -AC_DEFUN([AM_MISSING_PROG], -[AC_REQUIRE([AM_MISSING_HAS_RUN]) -$1=${$1-"${am_missing_run}$2"} -AC_SUBST($1)]) - -# AM_MISSING_HAS_RUN -# ------------------ -# Define MISSING if not defined so far and test if it is modern enough. -# If it is, set am_missing_run to use it, otherwise, to nothing. -AC_DEFUN([AM_MISSING_HAS_RUN], -[AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl -AC_REQUIRE_AUX_FILE([missing])dnl -if test x"${MISSING+set}" != xset; then - case $am_aux_dir in - *\ * | *\ *) - MISSING="\${SHELL} \"$am_aux_dir/missing\"" ;; - *) - MISSING="\${SHELL} $am_aux_dir/missing" ;; - esac -fi -# Use eval to expand $SHELL -if eval "$MISSING --is-lightweight"; then - am_missing_run="$MISSING " -else - am_missing_run= - AC_MSG_WARN(['missing' script is too old or missing]) -fi -]) - -# Helper functions for option handling. -*- Autoconf -*- - -# Copyright (C) 2001-2014 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. - -# _AM_MANGLE_OPTION(NAME) -# ----------------------- -AC_DEFUN([_AM_MANGLE_OPTION], -[[_AM_OPTION_]m4_bpatsubst($1, [[^a-zA-Z0-9_]], [_])]) - -# _AM_SET_OPTION(NAME) -# -------------------- -# Set option NAME. Presently that only means defining a flag for this option. -AC_DEFUN([_AM_SET_OPTION], -[m4_define(_AM_MANGLE_OPTION([$1]), [1])]) - -# _AM_SET_OPTIONS(OPTIONS) -# ------------------------ -# OPTIONS is a space-separated list of Automake options. -AC_DEFUN([_AM_SET_OPTIONS], -[m4_foreach_w([_AM_Option], [$1], [_AM_SET_OPTION(_AM_Option)])]) - -# _AM_IF_OPTION(OPTION, IF-SET, [IF-NOT-SET]) -# ------------------------------------------- -# Execute IF-SET if OPTION is set, IF-NOT-SET otherwise. -AC_DEFUN([_AM_IF_OPTION], -[m4_ifset(_AM_MANGLE_OPTION([$1]), [$2], [$3])]) - -# Copyright (C) 1999-2014 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. - -# _AM_PROG_CC_C_O -# --------------- -# Like AC_PROG_CC_C_O, but changed for automake. We rewrite AC_PROG_CC -# to automatically call this. -AC_DEFUN([_AM_PROG_CC_C_O], -[AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl -AC_REQUIRE_AUX_FILE([compile])dnl -AC_LANG_PUSH([C])dnl -AC_CACHE_CHECK( - [whether $CC understands -c and -o together], - [am_cv_prog_cc_c_o], - [AC_LANG_CONFTEST([AC_LANG_PROGRAM([])]) - # Make sure it works both with $CC and with simple cc. - # Following AC_PROG_CC_C_O, we do the test twice because some - # compilers refuse to overwrite an existing .o file with -o, - # though they will create one. - am_cv_prog_cc_c_o=yes - for am_i in 1 2; do - if AM_RUN_LOG([$CC -c conftest.$ac_ext -o conftest2.$ac_objext]) \ - && test -f conftest2.$ac_objext; then - : OK - else - am_cv_prog_cc_c_o=no - break - fi - done - rm -f core conftest* - unset am_i]) -if test "$am_cv_prog_cc_c_o" != yes; then - # Losing compiler, so override with the script. - # FIXME: It is wrong to rewrite CC. - # But if we don't then we get into trouble of one sort or another. - # A longer-term fix would be to have automake use am__CC in this case, - # and then we could set am__CC="\$(top_srcdir)/compile \$(CC)" - CC="$am_aux_dir/compile $CC" -fi -AC_LANG_POP([C])]) - -# For backward compatibility. -AC_DEFUN_ONCE([AM_PROG_CC_C_O], [AC_REQUIRE([AC_PROG_CC])]) - -# Copyright (C) 2001-2014 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. - -# AM_RUN_LOG(COMMAND) -# ------------------- -# Run COMMAND, save the exit status in ac_status, and log it. -# (This has been adapted from Autoconf's _AC_RUN_LOG macro.) -AC_DEFUN([AM_RUN_LOG], -[{ echo "$as_me:$LINENO: $1" >&AS_MESSAGE_LOG_FD - ($1) >&AS_MESSAGE_LOG_FD 2>&AS_MESSAGE_LOG_FD - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&AS_MESSAGE_LOG_FD - (exit $ac_status); }]) - -# Check to make sure that the build environment is sane. -*- Autoconf -*- - -# Copyright (C) 1996-2014 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. - -# AM_SANITY_CHECK -# --------------- -AC_DEFUN([AM_SANITY_CHECK], -[AC_MSG_CHECKING([whether build environment is sane]) -# Reject unsafe characters in $srcdir or the absolute working directory -# name. Accept space and tab only in the latter. -am_lf=' -' -case `pwd` in - *[[\\\"\#\$\&\'\`$am_lf]]*) - AC_MSG_ERROR([unsafe absolute working directory name]);; -esac -case $srcdir in - *[[\\\"\#\$\&\'\`$am_lf\ \ ]]*) - AC_MSG_ERROR([unsafe srcdir value: '$srcdir']);; -esac - -# Do 'set' in a subshell so we don't clobber the current shell's -# arguments. Must try -L first in case configure is actually a -# symlink; some systems play weird games with the mod time of symlinks -# (eg FreeBSD returns the mod time of the symlink's containing -# directory). -if ( - am_has_slept=no - for am_try in 1 2; do - echo "timestamp, slept: $am_has_slept" > conftest.file - set X `ls -Lt "$srcdir/configure" conftest.file 2> /dev/null` - if test "$[*]" = "X"; then - # -L didn't work. - set X `ls -t "$srcdir/configure" conftest.file` - fi - if test "$[*]" != "X $srcdir/configure conftest.file" \ - && test "$[*]" != "X conftest.file $srcdir/configure"; then - - # If neither matched, then we have a broken ls. This can happen - # if, for instance, CONFIG_SHELL is bash and it inherits a - # broken ls alias from the environment. This has actually - # happened. Such a system could not be considered "sane". - AC_MSG_ERROR([ls -t appears to fail. Make sure there is not a broken - alias in your environment]) - fi - if test "$[2]" = conftest.file || test $am_try -eq 2; then - break - fi - # Just in case. - sleep 1 - am_has_slept=yes - done - test "$[2]" = conftest.file - ) -then - # Ok. - : -else - AC_MSG_ERROR([newly created file is older than distributed files! -Check your system clock]) -fi -AC_MSG_RESULT([yes]) -# If we didn't sleep, we still need to ensure time stamps of config.status and -# generated files are strictly newer. -am_sleep_pid= -if grep 'slept: no' conftest.file >/dev/null 2>&1; then - ( sleep 1 ) & - am_sleep_pid=$! -fi -AC_CONFIG_COMMANDS_PRE( - [AC_MSG_CHECKING([that generated files are newer than configure]) - if test -n "$am_sleep_pid"; then - # Hide warnings about reused PIDs. - wait $am_sleep_pid 2>/dev/null - fi - AC_MSG_RESULT([done])]) -rm -f conftest.file -]) - -# Copyright (C) 2009-2014 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. - -# AM_SILENT_RULES([DEFAULT]) -# -------------------------- -# Enable less verbose build rules; with the default set to DEFAULT -# ("yes" being less verbose, "no" or empty being verbose). -AC_DEFUN([AM_SILENT_RULES], -[AC_ARG_ENABLE([silent-rules], [dnl -AS_HELP_STRING( - [--enable-silent-rules], - [less verbose build output (undo: "make V=1")]) -AS_HELP_STRING( - [--disable-silent-rules], - [verbose build output (undo: "make V=0")])dnl -]) -case $enable_silent_rules in @%:@ ((( - yes) AM_DEFAULT_VERBOSITY=0;; - no) AM_DEFAULT_VERBOSITY=1;; - *) AM_DEFAULT_VERBOSITY=m4_if([$1], [yes], [0], [1]);; -esac -dnl -dnl A few 'make' implementations (e.g., NonStop OS and NextStep) -dnl do not support nested variable expansions. -dnl See automake bug#9928 and bug#10237. -am_make=${MAKE-make} -AC_CACHE_CHECK([whether $am_make supports nested variables], - [am_cv_make_support_nested_variables], - [if AS_ECHO([['TRUE=$(BAR$(V)) -BAR0=false -BAR1=true -V=1 -am__doit: - @$(TRUE) -.PHONY: am__doit']]) | $am_make -f - >/dev/null 2>&1; then - am_cv_make_support_nested_variables=yes -else - am_cv_make_support_nested_variables=no -fi]) -if test $am_cv_make_support_nested_variables = yes; then - dnl Using '$V' instead of '$(V)' breaks IRIX make. - AM_V='$(V)' - AM_DEFAULT_V='$(AM_DEFAULT_VERBOSITY)' -else - AM_V=$AM_DEFAULT_VERBOSITY - AM_DEFAULT_V=$AM_DEFAULT_VERBOSITY -fi -AC_SUBST([AM_V])dnl -AM_SUBST_NOTMAKE([AM_V])dnl -AC_SUBST([AM_DEFAULT_V])dnl -AM_SUBST_NOTMAKE([AM_DEFAULT_V])dnl -AC_SUBST([AM_DEFAULT_VERBOSITY])dnl -AM_BACKSLASH='\' -AC_SUBST([AM_BACKSLASH])dnl -_AM_SUBST_NOTMAKE([AM_BACKSLASH])dnl -]) - -# Copyright (C) 2001-2014 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. - -# AM_PROG_INSTALL_STRIP -# --------------------- -# One issue with vendor 'install' (even GNU) is that you can't -# specify the program used to strip binaries. This is especially -# annoying in cross-compiling environments, where the build's strip -# is unlikely to handle the host's binaries. -# Fortunately install-sh will honor a STRIPPROG variable, so we -# always use install-sh in "make install-strip", and initialize -# STRIPPROG with the value of the STRIP variable (set by the user). -AC_DEFUN([AM_PROG_INSTALL_STRIP], -[AC_REQUIRE([AM_PROG_INSTALL_SH])dnl -# Installed binaries are usually stripped using 'strip' when the user -# run "make install-strip". However 'strip' might not be the right -# tool to use in cross-compilation environments, therefore Automake -# will honor the 'STRIP' environment variable to overrule this program. -dnl Don't test for $cross_compiling = yes, because it might be 'maybe'. -if test "$cross_compiling" != no; then - AC_CHECK_TOOL([STRIP], [strip], :) -fi -INSTALL_STRIP_PROGRAM="\$(install_sh) -c -s" -AC_SUBST([INSTALL_STRIP_PROGRAM])]) - -# Copyright (C) 2006-2014 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. - -# _AM_SUBST_NOTMAKE(VARIABLE) -# --------------------------- -# Prevent Automake from outputting VARIABLE = @VARIABLE@ in Makefile.in. -# This macro is traced by Automake. -AC_DEFUN([_AM_SUBST_NOTMAKE]) - -# AM_SUBST_NOTMAKE(VARIABLE) -# -------------------------- -# Public sister of _AM_SUBST_NOTMAKE. -AC_DEFUN([AM_SUBST_NOTMAKE], [_AM_SUBST_NOTMAKE($@)]) - -# Check how to create a tarball. -*- Autoconf -*- - -# Copyright (C) 2004-2014 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. - -# _AM_PROG_TAR(FORMAT) -# -------------------- -# Check how to create a tarball in format FORMAT. -# FORMAT should be one of 'v7', 'ustar', or 'pax'. -# -# Substitute a variable $(am__tar) that is a command -# writing to stdout a FORMAT-tarball containing the directory -# $tardir. -# tardir=directory && $(am__tar) > result.tar -# -# Substitute a variable $(am__untar) that extract such -# a tarball read from stdin. -# $(am__untar) < result.tar -# -AC_DEFUN([_AM_PROG_TAR], -[# Always define AMTAR for backward compatibility. Yes, it's still used -# in the wild :-( We should find a proper way to deprecate it ... -AC_SUBST([AMTAR], ['$${TAR-tar}']) - -# We'll loop over all known methods to create a tar archive until one works. -_am_tools='gnutar m4_if([$1], [ustar], [plaintar]) pax cpio none' - -m4_if([$1], [v7], - [am__tar='$${TAR-tar} chof - "$$tardir"' am__untar='$${TAR-tar} xf -'], - - [m4_case([$1], - [ustar], - [# The POSIX 1988 'ustar' format is defined with fixed-size fields. - # There is notably a 21 bits limit for the UID and the GID. In fact, - # the 'pax' utility can hang on bigger UID/GID (see automake bug#8343 - # and bug#13588). - am_max_uid=2097151 # 2^21 - 1 - am_max_gid=$am_max_uid - # The $UID and $GID variables are not portable, so we need to resort - # to the POSIX-mandated id(1) utility. Errors in the 'id' calls - # below are definitely unexpected, so allow the users to see them - # (that is, avoid stderr redirection). - am_uid=`id -u || echo unknown` - am_gid=`id -g || echo unknown` - AC_MSG_CHECKING([whether UID '$am_uid' is supported by ustar format]) - if test $am_uid -le $am_max_uid; then - AC_MSG_RESULT([yes]) - else - AC_MSG_RESULT([no]) - _am_tools=none - fi - AC_MSG_CHECKING([whether GID '$am_gid' is supported by ustar format]) - if test $am_gid -le $am_max_gid; then - AC_MSG_RESULT([yes]) - else - AC_MSG_RESULT([no]) - _am_tools=none - fi], - - [pax], - [], - - [m4_fatal([Unknown tar format])]) - - AC_MSG_CHECKING([how to create a $1 tar archive]) - - # Go ahead even if we have the value already cached. We do so because we - # need to set the values for the 'am__tar' and 'am__untar' variables. - _am_tools=${am_cv_prog_tar_$1-$_am_tools} - - for _am_tool in $_am_tools; do - case $_am_tool in - gnutar) - for _am_tar in tar gnutar gtar; do - AM_RUN_LOG([$_am_tar --version]) && break - done - am__tar="$_am_tar --format=m4_if([$1], [pax], [posix], [$1]) -chf - "'"$$tardir"' - am__tar_="$_am_tar --format=m4_if([$1], [pax], [posix], [$1]) -chf - "'"$tardir"' - am__untar="$_am_tar -xf -" - ;; - plaintar) - # Must skip GNU tar: if it does not support --format= it doesn't create - # ustar tarball either. - (tar --version) >/dev/null 2>&1 && continue - am__tar='tar chf - "$$tardir"' - am__tar_='tar chf - "$tardir"' - am__untar='tar xf -' - ;; - pax) - am__tar='pax -L -x $1 -w "$$tardir"' - am__tar_='pax -L -x $1 -w "$tardir"' - am__untar='pax -r' - ;; - cpio) - am__tar='find "$$tardir" -print | cpio -o -H $1 -L' - am__tar_='find "$tardir" -print | cpio -o -H $1 -L' - am__untar='cpio -i -H $1 -d' - ;; - none) - am__tar=false - am__tar_=false - am__untar=false - ;; - esac - - # If the value was cached, stop now. We just wanted to have am__tar - # and am__untar set. - test -n "${am_cv_prog_tar_$1}" && break - - # tar/untar a dummy directory, and stop if the command works. - rm -rf conftest.dir - mkdir conftest.dir - echo GrepMe > conftest.dir/file - AM_RUN_LOG([tardir=conftest.dir && eval $am__tar_ >conftest.tar]) - rm -rf conftest.dir - if test -s conftest.tar; then - AM_RUN_LOG([$am__untar /dev/null 2>&1 && break - fi - done - rm -rf conftest.dir - - AC_CACHE_VAL([am_cv_prog_tar_$1], [am_cv_prog_tar_$1=$_am_tool]) - AC_MSG_RESULT([$am_cv_prog_tar_$1])]) - -AC_SUBST([am__tar]) -AC_SUBST([am__untar]) -]) # _AM_PROG_TAR - -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]) diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/AUTHORS ecl-16.1.3+ds/src/bdwgc/libatomic_ops/AUTHORS --- ecl-16.1.2/src/bdwgc/libatomic_ops/AUTHORS 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/AUTHORS 1970-01-01 00:00:00.000000000 +0000 @@ -1,45 +0,0 @@ -Originally written by Hans Boehm, with some platform-dependent code -imported from the Boehm-Demers-Weiser GC, where it was contributed -by many others. -Currently maintained by Ivan Maidanski. - -Andreas Tobler -Andrew Agno -Bradley Smith -Bruce Mitchener -Carlos O'Donell -Daniel Grayson -Doug Lea -Earl Chew -Emmanuel Stapf -Frank Schaefer -Gilles Talis -Gregory Farnum -H.J. Lu -Hans Boehm -Hans-Peter Nilsson -Ian Wienand -Ivan Maidanski -James Cowgill -Jeremy Huddleston -Jim Marshall -Joerg Wagner -Linas Vepstas -Luca Barbato -Kochin Chang -Maged Michael -Manuel Serrano -Michael Hope -Patrick Marlier -Pavel Raiskup -Petter Urkedal -Philipp Zambelli -Ranko Zivojnovic -Roger Hoover -Sebastian Siewior -Steve Capper -Takashi Yoshii -Thiemo Seufer -Thorsten Glaser -Tony Mantler -Yvan Roux diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/autogen.sh ecl-16.1.3+ds/src/bdwgc/libatomic_ops/autogen.sh --- ecl-16.1.2/src/bdwgc/libatomic_ops/autogen.sh 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/autogen.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,10 +0,0 @@ -#!/bin/sh -set -e - -# This script creates (or regenerates) configure (as well as aclocal.m4, -# config.h.in, Makefile.in, etc.) missing in the source repository. - -autoreconf -i - -echo -echo "Ready to run './configure'." diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/ChangeLog ecl-16.1.3+ds/src/bdwgc/libatomic_ops/ChangeLog --- ecl-16.1.2/src/bdwgc/libatomic_ops/ChangeLog 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/ChangeLog 1970-01-01 00:00:00.000000000 +0000 @@ -1,349 +0,0 @@ - -== [7.5.0] (development) == - -* Relax shareability domain for dmb st in AO_nop_write (ARM/AArch64). -* Use LLD and SCD instructions on mips64. - - -== [7.4.4] (unset) == - -* Eliminate 'variable set but not used' Cppcheck warnings in test_stack. -* Fix makefile preventing AO_pause undefined in libatomic_ops_gpl. -* Fix missing casts to match printf format specifier in test_atomic. -* Fix missing output folder on making auto-generated test files (Automake). -* Minor fix of code alignment in mips AO_compare_and_swap. -* Restore contribution info in ChangeLog for authors not listed in git log. - - -== [7.4.2] 2014-05-02 == - -* Fix a typo in doc/README.txt (remove redundant "an" article). -* Update emails/links due to project site transition. - - -== [7.4.0] 2013-11-17 == - -* Add and/or/xor entries to list_atomic (tests). -* Add char/short/int/AO_double_t and dd_acquire cases to list_atomic (tests). -* Add compile-time assertion for size of 'standard' AO_double_t. -* Add double_store pthread-based implementation and tests. -* Add generalized CAS primitives of char/short/int size. -* Add generalized atomic and/or/xor operations for char/short/int types. -* Add generalized fetch_and_add_acquire/release (for ARMv6+). -* Add generic implementation of double_load primitives. -* Add information about AO_ASSUME_VISTA to README_win32. -* Add internal header containing only char/short/int/AO_t atomic loads. -* Add load/store primitives generalization based on CAS. -* Add lock-based implementation of char/short/int_fetch_compare_and_swap. -* Add makefile rule to test list_atomic.template syntax (tests). -* Add missing 'const' in aligned-atomic XSIZE_load implementation. -* Add missing double_compare_and_swap to generalization. -* Add missing generalization of no-barrier CAS in template. -* Add negative double-CAS test cases to test_atomic_include (tests). -* Add test_stack to Makefile.msft (tests). -* Adjust fprintf arguments type matching specifier in test_stack (tests). -* Adjust included filenames in atomic_ops_malloc and test_stack. -* Adjust quotes in echo command of Makefile.msft (Win32). -* Always use 'mfence' for nop_full if target CPU supports SSE2 (gcc/x86). -* Better document configure THREADDLLIBS variable. -* Cast away volatile on dereference in CAS-based generalization primitives. -* Change policy regarding version numbers ("micro" part instead of "alpha"). -* Convert README to Markdown format. -* Define AO_NO_PTHREADS in configure if no pthreads (Win32 and VxWorks). -* Define AO_int_X operations for ARM and avr32. -* Define double-wide ordered loads/stores for x86. -* Define int_and/or/xor primitives in ao_t_is_int header. -* Define nop_full as compiler barrier for pre-ARMv6 single-core case. -* Do not duplicate BUILT_SOURCES entries in nobase_private_HEADERS (Makefile). -* Do not include standard_ao_double_t.h where double-CAS is unimplemented. -* Do not report absence of meaningless nop, load and store in test_atomic. -* Do not use deprecated AO_T and AO_TS_T (tests). -* Eliminate 'missing initializer' warning for AO_stack_t value initializer. -* Eliminate 64-bit compiler warnings in atomic_ops_malloc. -* Eliminate arithmetic shifts in double-CAS (gcc/arm, msftc/x86). -* Eliminate warning for fetch_and_add argument in test_atomic_include (tests). -* Enable Makefile.msft for Win64. -* Enable build using toolchain without pthreads. -* Enable double_compare_and_swap for non-cpp code (msftc/x86.h). -* Enable generalization of all variants of CAS via fetch_compare_and_swap. -* Enable test_stack for pthreads-w32 and Win32 with native threads. -* Fix generalized AO_char/short_compare_and_swap args (missing 'unsigned'). -* Fix makefile sed rule for list_atomic (tests). -* Fix missing abort() usage in atomic_ops_malloc and tests on WinCE. -* Generalize compare_double_and_swap_double using double_compare_and_swap. -* Generalize double_load/store for x86_64 (GCC). -* Generate ao_t_is_int, 'loadstore' headers from templates. -* Generate generalized AO_t load/store/fetch_and_add primitives from template. -* Generate ordered_loads/stores_only headers from templates. -* Group all X_acquire_release_volatile.h and X_[aligned_]atomic_load_store.h. -* Implement and/or/xor, AO_double_load for ARM. -* Implement atomic store using direct write by default on ARMv6+. -* Implement char/short/int-wide primitives using GCC built-in atomic/sync. -* Implement char/short/int_fetch_and_add for msftc/x86[_64] (Win32). -* Implement char/short_fetch_and_add, char/short_load for ARMv6+ (GCC). -* Implement char/short_store primitives at aligned addresses for ARM. -* Implement compare_double_and_swap_double for SunCC/x86. -* Implement double_load/store based on guaranteed x86 access atomicity. -* Implement double_store for ARMv7 using LDREXD/STREXD. -* Implement load/store via simple LDR/STR for ARMv6+ (msftc). -* Implement nop_full/write using 'dmb' instruction if available (gcc/arm). -* Improve debug printing in test_stack (tests). -* Log messages to stdout instead of stderr (tests). -* Make AO_ASSUME_VISTA also enables Win98 code in msftc/x86.h (Win32). -* Minimize gcc/generic-arithm template by factoring out barriers. -* Move 'unsigned' keyword to XCTYPE in generalize-small template. -* Move default compiler options to CFLAGS in Makefile.msft (Win32). -* Move definitions of ordered loads/stores to inner separate headers. -* Move gcc-generic AO_t-wide primitives to generic-small/arithm headers. -* Move generalized arithmetical primitives to 'generalize-arithm' template. -* Optimize AO_spin manually to minimize compiler influence on its duration. -* Parameterize list_atomic template with XSIZE (tests). -* Perform only few list reversals in test_malloc if AO based on pthreads. -* Put autogen.sh to 'dist' package (Automake). -* Remote duplicate definition of test_and_set_acquire in generalize.h. -* Remove X_aligned_atomic_load_store headers and template. -* Remove duplicate AO_spin and AO_pause definition in atomic_ops_stack. -* Remove gcc/x86_64.h eliminating code duplication of gcc/x86.h. -* Remove nested AO_USE_PTHREAD_DEFS macro check in atomic_ops.h (gcc/arm). -* Remove redundant 'cc' clobber for LDREXD instruction (gcc/arm). -* Remove store_full from msftc/arm.h in favor of generalized primitive. -* Remove sunc/x86_64.h eliminating code duplication of sunc/x86.h. -* Remove unsafe emulation-based implementation of double CAS (SunCC/x86_64). -* Remove useless 'perror' call in run_parallel.h (tests). -* Reorder AO_double_t union elements for AO_DOUBLE_T_INITIALIZER portability. -* Replace atomic_load_store.template with atomic_load and atomic_store ones. -* Replace some FIXME items with TODO in atomic_ops.c and sysdeps headers. -* Specify fetch_and_add/sub1 result as unused in test_atomic (tests). -* Support AArch64 (64-bit ARM) target (GCC). -* Support ARMv8 target (gcc/arm). -* Test double_compare_and_swap in test_atomic (tests). -* Use AO_ prefix for internal functions in arm_v6.h, hppa.h. -* Use __atomic GCC built-in to implement generic double-wide CAS. -* Use built-in __sync CAS for double-CAS if AO_USE_SYNC_CAS_BUILTIN for x86. -* Workaround GCC 4.4.3 warning reported for 'val' of list_atomic.c (tests). - - -== [7.3alpha2] 2012-05-11 == - -* Add '-no-undefined' to LDFLAGS in src/Makefile.am. -* Add AO_and, AO_xor atomic operations. -* Add AO_fetch_compare_and_swap primitives. -* Add and fill in AUTHORS, TODO files. -* Add autogen.sh file. -* Adjust AO_..._H macros in public headers. -* Code refactoring of gcc/arm.h by introducing AO_ARM_HAVE_x macros. -* Define AO macros for libatomic_ops version identification. -* Do not define NDEBUG if '--enable-assertions' passed to configure. -* Eliminate compiler warnings in various functions and macros. -* Generalize AO_compare_and_swap primitives via AO_fetch_compare_and_swap. -* Generalize acquire/release/full CAS primitives for MIPS -* Implement fetch_and_add, test_and_set primitives for MIPS. -* Improve Makefile for MS VC++; pass '-W3' option to MS compiler. -* Include ao_t_is_int.h from atomic_ops.h after first generalization pass -* Merge all Makefile.am files in src tree. -* Minor code refactoring of atomic_ops.c, generic_pthread.h. -* Minor configure build improvements (e.g., ensure proper autoconf version). -* Place only major per-release changes description to ChangeLog (this file). -* Recognize AO_PREFER_GENERALIZED macro to favor generalization over assembly. -* Remove all auto-generated files except for generalize-small.h from the repo. -* Remove duplicate doc/COPYING and empty NEWS files. -* Replace atomic_ops_malloc static mmap-related empty functions with macros. -* Replace pointer relational comparisons with non-pointer ones. -* Require autoconf 2.61 instead of v2.64. -* Show extra compiler warnings (GCC only). -* Turn off AO primitives inlining if AO_NO_INLINE defined. -* Use __builtin_expect in CAS failure loop condition checks (GCC only). - - -== [7.2g] (unset) == - -* Remove inclusion of acquire_release_volatile.h on MIPS. - - -== [7.2f] 2014-05-02 == - -* Fix a typo in doc/README.txt (remove redundant "an" article). -* Regenerate configure files by new automake (v1.14.1), libtool (v2.4.2.418). - - -== [7.2e] 2013-11-10 == - -* Fix (remove) invalid include of read_ordered.h for ARM. -* Fix AM_CONFIG_HEADER in configure for autoconf-2.69-1. -* Fix AO_pause sleep delay for particular argument values (Win32). -* Fix ARMv7 LDREXD/STREXD double-wide operand specification (GCC/Clang). -* Fix LDREXD/STREXD use for pre-Clang3.3/arm. -* Fix README regarding _acquire_read barrier. -* Fix XSIZE_load/store definition order in generalize-small template. -* Fix asm constraint of CAS memory operand for gcc/alpha, clang-3.1/mips. -* Fix asm constraints of primitives in sunc/x86.h. -* Fix cmpxchg16b-based compare_double_and_swap_double for SunCC/x86_64. -* Fix compare_double_and_swap_double and double_ptr_storage for gcc/x32. -* Fix compare_double_and_swap_double for clang3.0/x86 in PIC mode. -* Fix compare_double_and_swap_double_full definition condition in emul_cas. -* Fix generalize-small template adding missed CAS-based fetch_and_add. -* Fix generalized fetch_and_add function. -* Fix missing compiler barrier in nop_full for uniprocessor ARM. -* Fix ordered_except_wr header inclusion for s390. -* Fix return type of AO_int_X primitives defined in ao_t_is_int header. -* Fix return type of char/short/int_load_read() in read_ordered.h. -* Fix template-based headers regeneration order in src/Makefile. -* Fix typos in ao_t_is_int, atomic_ops.h, generalize.h, msftc/arm.h comments. -* Fix variable type to match printf format specifier in test_stack. -* Fix visibility and initial value of 'dummy' variable in atomic_ops_stack. -* Terminate tests with abort after error reported. - - -== [7.2d] 2012-08-09 == - -* Fix AO_compare_double_and_swap_double_full for gcc-4.2.1/x86 in PIC mode. -* Fix AO_compiler_barrier missing parentheses. -* Fix missing 'unsigned' for generalized AO_char/short_fetch_and_add result. - - -== [7.2] 2012-05-11 == - -* Add atomic_ops.pc.in and atomic_ops-uninstalled.pc.in to pkgconfig folder. -* Define and use AO_PTRDIFF_T in tests for casts between pointer and integer. -* Fix AO_compare_and_swap return type for s390 and PowerPC. -* Fix AO_compare_double_and_swap_double_full for gcc/x86 (PIC mode). -* Fix AO_stack_push_release to workaround bug in clang-1.1/x86 compiler. -* Fix AO_test_and_setXX in tests/list_atomic.template. -* Fix AO_test_and_set_full (gcc/x86[_64].h) to work-around a bug in LLVM v2.7. -* Fix AO_test_and_set_full on m68k. -* Fix __ARM_ARCH_5__ macro handling for Android NDK (ARMv7). -* Fix configure for Cygwin, mingw-w64/32. -* Fix configure to define __PIC__ macro explicitly if needed (GCC). -* Fix double_ptr_storage definition for GCC pre-v4 (x86_64). -* Fix for x32 by removing 'q' suffix in x86-64 instructions. -* Fix generalization for IA-64 (regarding AO_or, AO_..._read/write primitives) -* Fix generalized AO__fetch_and_add() return type. -* Fix test_atomic_include for the case of missing CAS primitive. -* Fix test_malloc - allocate less memory in case of missing mmap. -* Implement the basic atomic primitives for the hexagon CPU. - - -== [7.2alpha6] 2011-06-14 == - -* Add missing AO_HAVE_ macros. -* Add support of avr32 CPU. -* Better support of various models of ARM. -* Disable AO_compare_double_and_swap_double_full for SunCC x86 as not working. -* Enable ARM Thumb-2 mode. -* Fix AO_test_and_set_full for SunCC (x86). -* Fix bugs in tests. -* Fix clobbers in AO_compare_and_swap_full (x86.h). -* Fix typos in identifiers and comments. -* Improve AO_sync for PowerPC. -* Improve make scripts (configure.ac). -* Make get_mmaped() in atomic_ops_malloc.c more portable. -* Support Intel compiler. -* Support NaCl target. -* Suppress compiler warnings in various places. -* Test more predefined macros (ARM, PowerPC). -* Use assembly code only for MS VC if available (x86_64). -* Use built-in __sync_bool_compare_and_swap if available (x86_64). -* Workaround bugs in LLVM GCC and SunCC regarding XCHG (x86, x86_64). - - -== [7.2alpha4] 2009-12-02 == - -* Fix typos in comments, identifiers and documentation. -* Implement AO_compare_and_swap_full for SPARC. -* Refine ARM-specific code. -* Refine code and comments for MS VC. -* Regenerate make scripts. -* Share common code for all 32-bit CPUs (MS VC). -* Support DigitalMars and Watcom compilers. -* Support MS VC for ARM (WinCE). -* Support SH CPU. -* Support win32-pthreads. -* Support x86 and x86_64 for SunCC compiler. - - -== [7.2alpha2] 2009-05-27 == - -* Add MIPS support. -* Add better support for m68k. -* Add "const" to first parameter of load calls. -* Add parentheses around address argument for various macros. -* Add some platform-specific documentation to INSTALL. -* Add untested 64-bit support for PowerPC. -* Fix AO_compare_and_swap_double_acquire. -* Fix AO_int_fetch_and_add_full (x86_64). -* Fix comments. -* Fix s390 include paths. -* Fix use of lwz instruction (PowerPC). -* Refine clobbers (PowerPC). -* Remove outdated info about Windows support in README. -* Replace K&R-style function definition with ANSI C one. -* add AO_compare_double_and_swap_double for ARMv6. -* gcc/powerpc.h: Consider __NO_LWSYNC__. - - -== [7.1] 2008-02-11 == - -* Add test_and_set, AO_double_compare_and_swap generalizations. -* Conditionally add compare_double_and_swap_double (x86). -* Conditionally add compare_double_and_swap_double (x86). -* Fix AO_compare_double_and_swap_double_full (x86) for PIC mode. -* Fix AO_load_acquire for PowerPC. -* Fix double-width CAS (x86). -* Refine README (add more warnings about data dependencies). -* Refine double_ptr_storage type definition. -* Support ARMv6+ in GCC. -* Support ArmCC compiler. -* Use _InterlockedExchangeAdd for MS VC (x86). - - -== [7.0] 2007-06-28 == - -* Add 64-bit version of AO_load_acquire for PowerPC (by Luca Barbato). -* Add support of x86 and x86_64 for MS VC. -* Do not assume that "mfence" is always present (x86.h). -* Fix ARM AO_test_and_set_full. -* Include windows.h (MS VC). -* Update README to reflect C++0x effort. - - -== [1.2] 2006-07-11 == - -* Add prototypes to suppress compiler warnings. -* Add simple VxWorks support. -* Fix InterlockedCompareExchange proto usage. -* Fix typos (ia64). -* Include all_acquire_release_volatile.h and all_atomic_load_store.h (ia64). -* Initial support for 64-bit targets. -* Use "=q" for AO_test_and_set_full (x86). -* Use inline assembler to generate "mfence" and byte sized XCHG. -* Use new intrinsics available in MSVC 2003 and MSVC 2005. - - -== [1.1] 2005-09-27 == - -* Add and use read_ordered.h. -* Change function naming from "byte" to "char". -* Fix AO_test_and_set for ARM; define AO_CAN_EMUL_CAS. - - -== [1.0] 2005-03-21 == - -* Add atomic_ops primitives for different sized data. -* Add compare_double_and_swap_double and compare_and_swap_double. -* Add gcc/cris.h (originally comes from Hans-Peter Nilsson). -* Add gcc/m68k.h (contributed by Tony Mantler). -* Add gcc/powerpc.h (with help of Maged Michael, Doug Lea, Roger Hoover). -* Add initial support for atomic_ops for VC++/Windows/X86 and HP/UX. -* Add minimal support for the Sun SPARC compiler. -* Add support for platforms that require out-of-line assembly code. -* Add support of int-wide operations on platforms with int-sized pointers. -* Added libatomic_ops_gpl library with support for lock-free stack and malloc. -* Change atomic_ops include file structure. -* Change most platforms to use byte-wide test-and-set locations. -* Define AO_CLEAR, __ldcw[_align] macros in gcc/hppa.h (by Carlos O'Donell). -* Fix various bugs. -* Install under "atomic_ops" instead of "ao". -* Remove compiler_barrier workaround for gcc 3.4+. -* Renamed various types to end in _t. -* Replace AO_HAVE_NOP_FULL with AO_HAVE_nop_full (by Ranko Zivojnovic). -* Use autoconf, automake. diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/configure ecl-16.1.3+ds/src/bdwgc/libatomic_ops/configure --- ecl-16.1.2/src/bdwgc/libatomic_ops/configure 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/configure 1970-01-01 00:00:00.000000000 +0000 @@ -1,14848 +0,0 @@ -#! /bin/sh -# Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.69 for libatomic_ops 7.5.0. -# -# Report bugs to . -# -# -# Copyright (C) 1992-1996, 1998-2012 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. -as_myself= -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 - -# Use a proper internal environment variable to ensure we don't fall - # into an infinite loop, continuously re-executing ourselves. - if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then - _as_can_reexec=no; export _as_can_reexec; - # 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. -# Preserve -v and -x to the replacement shell. -BASH_ENV=/dev/null -ENV=/dev/null -(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV -case $- in # (((( - *v*x* | *x*v* ) as_opts=-vx ;; - *v* ) as_opts=-v ;; - *x* ) as_opts=-x ;; - * ) as_opts= ;; -esac -exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} -# Admittedly, this is quite paranoid, since all the known shells bail -# out after a failed `exec'. -$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 -as_fn_exit 255 - fi - # We don't want this to propagate to other subprocesses. - { _as_can_reexec=; unset _as_can_reexec;} -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 -test -x / || 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 -n \"\${ZSH_VERSION+set}\${BASH_VERSION+set}\" || ( - ECHO='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' - ECHO=\$ECHO\$ECHO\$ECHO\$ECHO\$ECHO - ECHO=\$ECHO\$ECHO\$ECHO\$ECHO\$ECHO\$ECHO - PATH=/empty FPATH=/empty; export PATH FPATH - test \"X\`printf %s \$ECHO\`\" = \"X\$ECHO\" \\ - || test \"X\`print -r -- \$ECHO\`\" = \"X\$ECHO\" ) || 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 : - export CONFIG_SHELL - # 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. -# Preserve -v and -x to the replacement shell. -BASH_ENV=/dev/null -ENV=/dev/null -(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV -case $- in # (((( - *v*x* | *x*v* ) as_opts=-vx ;; - *v* ) as_opts=-v ;; - *x* ) as_opts=-x ;; - * ) as_opts= ;; -esac -exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} -# Admittedly, this is quite paranoid, since all the known shells bail -# out after a failed `exec'. -$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 -exit 255 -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 and -$0: bdwgc@lists.opendylan.org about your system, including -$0: any error possibly output before this message. Then -$0: install a modern shell, or manually run the script -$0: 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_executable_p FILE -# ----------------------- -# Test if FILE is an executable regular file. -as_fn_executable_p () -{ - test -f "$1" && test -x "$1" -} # as_fn_executable_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 STATUS 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=$1; test $as_status -eq 0 && as_status=1 - if test "$4"; then - as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 - fi - $as_echo "$as_me: error: $2" >&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; } - - # If we had to re-execute with $CONFIG_SHELL, we're ensured to have - # already done that, so ensure we don't try to do so again and fall - # in an infinite loop. This has already happened in practice. - _as_can_reexec=no; export _as_can_reexec - # 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 -pR'. - ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || - as_ln_s='cp -pR' - elif ln conf$$.file conf$$ 2>/dev/null; then - as_ln_s=ln - else - as_ln_s='cp -pR' - fi -else - as_ln_s='cp -pR' -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 - -as_test_x='test -x' -as_executable_p=as_fn_executable_p - -# 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'" - -SHELL=${CONFIG_SHELL-/bin/sh} - - -test -n "$DJDIR" || exec 7<&0 &1 - -# Name of the host. -# hostname on some systems (SVR3.2, old GNU/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='libatomic_ops' -PACKAGE_TARNAME='libatomic_ops' -PACKAGE_VERSION='7.5.0' -PACKAGE_STRING='libatomic_ops 7.5.0' -PACKAGE_BUGREPORT='bdwgc@lists.opendylan.org' -PACKAGE_URL='' - -ac_unique_file="src/atomic_ops.c" -# 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_header_list= -ac_subst_vars='am__EXEEXT_FALSE -am__EXEEXT_TRUE -LTLIBOBJS -LIBOBJS -NEED_ASM_FALSE -NEED_ASM_TRUE -HAVE_PTHREAD_H_FALSE -HAVE_PTHREAD_H_TRUE -THREADDLLIBS -PICFLAG -CPP -LT_SYS_LIBRARY_PATH -OTOOL64 -OTOOL -LIPO -NMEDIT -DSYMUTIL -MANIFEST_TOOL -RANLIB -ac_ct_AR -AR -DLLTOOL -OBJDUMP -LN_S -NM -ac_ct_DUMPBIN -DUMPBIN -LD -FGREP -EGREP -GREP -SED -LIBTOOL -am__fastdepCCAS_FALSE -am__fastdepCCAS_TRUE -CCASDEPMODE -CCASFLAGS -CCAS -am__fastdepCC_FALSE -am__fastdepCC_TRUE -CCDEPMODE -am__nodep -AMDEPBACKSLASH -AMDEP_FALSE -AMDEP_TRUE -am__quote -am__include -DEPDIR -OBJEXT -EXEEXT -ac_ct_CC -CPPFLAGS -LDFLAGS -CFLAGS -CC -MAINT -MAINTAINER_MODE_FALSE -MAINTAINER_MODE_TRUE -AM_BACKSLASH -AM_DEFAULT_VERBOSITY -AM_DEFAULT_V -AM_V -am__untar -am__tar -AMTAR -am__leading_dot -SET_MAKE -AWK -mkdir_p -MKDIR_P -INSTALL_STRIP_PROGRAM -STRIP -install_sh -MAKEINFO -AUTOHEADER -AUTOMAKE -AUTOCONF -ACLOCAL -VERSION -PACKAGE -CYGPATH_W -am__isrc -INSTALL_DATA -INSTALL_SCRIPT -INSTALL_PROGRAM -target_os -target_vendor -target_cpu -target -host_os -host_vendor -host_cpu -host -build_os -build_vendor -build_cpu -build -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_silent_rules -enable_maintainer_mode -enable_dependency_tracking -enable_shared -enable_static -with_pic -enable_fast_install -with_aix_soname -with_gnu_ld -with_sysroot -enable_libtool_lock -enable_werror -enable_assertions -' - ac_precious_vars='build_alias -host_alias -target_alias -CC -CFLAGS -LDFLAGS -LIBS -CPPFLAGS -CCAS -CCASFLAGS -LT_SYS_LIBRARY_PATH -CPP' - - -# 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_TARNAME}' -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= ;; - *) 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 - 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 libatomic_ops 7.5.0 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/libatomic_ops] - --htmldir=DIR html documentation [DOCDIR] - --dvidir=DIR dvi documentation [DOCDIR] - --pdfdir=DIR pdf documentation [DOCDIR] - --psdir=DIR ps documentation [DOCDIR] -_ACEOF - - cat <<\_ACEOF - -Program names: - --program-prefix=PREFIX prepend PREFIX to installed program names - --program-suffix=SUFFIX append SUFFIX to installed program names - --program-transform-name=PROGRAM run sed PROGRAM on installed program names - -System types: - --build=BUILD configure for building on BUILD [guessed] - --host=HOST cross-compile to build programs to run on HOST [BUILD] - --target=TARGET configure for building compilers for TARGET [HOST] -_ACEOF -fi - -if test -n "$ac_init_help"; then - case $ac_init_help in - short | recursive ) echo "Configuration of libatomic_ops 7.5.0:";; - esac - 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-silent-rules less verbose build output (undo: "make V=1") - --disable-silent-rules verbose build output (undo: "make V=0") - --enable-maintainer-mode - enable make rules and dependencies not useful (and - sometimes confusing) to the casual installer - --enable-dependency-tracking - do not reject slow dependency extractors - --disable-dependency-tracking - speeds up one-time build - --enable-shared[=PKGS] build shared libraries [default=no] - --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) - --enable-werror Pass -Werror to the C compiler - --enable-assertions Assertion checking - -Optional Packages: - --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] - --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) - --with-pic[=PKGS] try to use only PIC/non-PIC objects [default=use - both] - --with-aix-soname=aix|svr4|both - shared library versioning (aka "SONAME") variant to - provide on AIX, [default=aix]. - --with-gnu-ld assume the C compiler uses GNU ld [default=no] - --with-sysroot[=DIR] Search for dependent libraries within DIR (or the - compiler's sysroot if not specified). - -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 (Objective) C/C++ preprocessor flags, e.g. -I if - you have headers in a nonstandard directory - CCAS assembler compiler command (defaults to CC) - CCASFLAGS assembler compiler flags (defaults to CFLAGS) - LT_SYS_LIBRARY_PATH - User-defined run-time library search path. - CPP C preprocessor - -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 . -_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 -libatomic_ops configure 7.5.0 -generated by GNU Autoconf 2.69 - -Copyright (C) 2012 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; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $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 || - 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; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $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 eval \${$3+:} false; 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; ${as_lineno_stack:+:} 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; } > conftest.i && { - 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; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $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; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $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 eval \${$3+:} false; 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; ${as_lineno_stack:+:} unset as_lineno - -} # ac_fn_c_check_func -cat >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 libatomic_ops $as_me 7.5.0, which was -generated by GNU Autoconf 2.69. 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 - - $as_echo "## ---------------- ## -## Cache variables. ## -## ---------------- ##" - 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 - - $as_echo "## ----------------- ## -## Output variables. ## -## ----------------- ##" - 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 - $as_echo "## ------------------- ## -## File substitutions. ## -## ------------------- ##" - 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 - $as_echo "## ----------- ## -## confdefs.h. ## -## ----------- ##" - 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 - # We do not want a PATH search for config.site. - case $CONFIG_SITE in #(( - -*) ac_site_file1=./$CONFIG_SITE;; - */*) ac_site_file1=$CONFIG_SITE;; - *) ac_site_file1=./$CONFIG_SITE;; - esac -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 /dev/null != "$ac_site_file" && 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" \ - || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "failed to load site script $ac_site_file -See \`config.log' for more details" "$LINENO" 5; } - 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. DJGPP emulates it as a regular file. - if test /dev/null != "$cache_file" && 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 - -as_fn_append ac_header_list " stdlib.h" -as_fn_append ac_header_list " unistd.h" -as_fn_append ac_header_list " sys/param.h" -# 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_aux_dir= -for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do - if test -f "$ac_dir/install-sh"; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install-sh -c" - break - elif test -f "$ac_dir/install.sh"; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install.sh -c" - break - elif test -f "$ac_dir/shtool"; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/shtool install -c" - break - fi -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 ${ac_cv_build+:} false; 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 ${ac_cv_host+:} false; 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 - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking target system type" >&5 -$as_echo_n "checking target system type... " >&6; } -if ${ac_cv_target+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test "x$target_alias" = x; then - ac_cv_target=$ac_cv_host -else - ac_cv_target=`$SHELL "$ac_aux_dir/config.sub" $target_alias` || - as_fn_error $? "$SHELL $ac_aux_dir/config.sub $target_alias failed" "$LINENO" 5 -fi - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_target" >&5 -$as_echo "$ac_cv_target" >&6; } -case $ac_cv_target in -*-*-*) ;; -*) as_fn_error $? "invalid value of canonical target" "$LINENO" 5;; -esac -target=$ac_cv_target -ac_save_IFS=$IFS; IFS='-' -set x $ac_cv_target -shift -target_cpu=$1 -target_vendor=$2 -shift; shift -# Remember, the first character of IFS is used to create $*, -# except with old shells: -target_os=$* -IFS=$ac_save_IFS -case $target_os in *\ *) target_os=`echo "$target_os" | sed 's/ /-/g'`;; esac - - -# The aliases save the names the user supplied, while $host etc. -# will get canonicalized. -test -n "$target_alias" && - test "$program_prefix$program_suffix$program_transform_name" = \ - NONENONEs,x,x, && - program_prefix=${target_alias}- - - -am__api_version='1.15' - -# 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 ${ac_cv_path_install+:} false; 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 as_fn_executable_p "$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 build environment is sane" >&5 -$as_echo_n "checking whether build environment is sane... " >&6; } -# Reject unsafe characters in $srcdir or the absolute working directory -# name. Accept space and tab only in the latter. -am_lf=' -' -case `pwd` in - *[\\\"\#\$\&\'\`$am_lf]*) - as_fn_error $? "unsafe absolute working directory name" "$LINENO" 5;; -esac -case $srcdir in - *[\\\"\#\$\&\'\`$am_lf\ \ ]*) - as_fn_error $? "unsafe srcdir value: '$srcdir'" "$LINENO" 5;; -esac - -# Do 'set' in a subshell so we don't clobber the current shell's -# arguments. Must try -L first in case configure is actually a -# symlink; some systems play weird games with the mod time of symlinks -# (eg FreeBSD returns the mod time of the symlink's containing -# directory). -if ( - am_has_slept=no - for am_try in 1 2; do - echo "timestamp, slept: $am_has_slept" > conftest.file - set X `ls -Lt "$srcdir/configure" conftest.file 2> /dev/null` - if test "$*" = "X"; then - # -L didn't work. - set X `ls -t "$srcdir/configure" conftest.file` - fi - if test "$*" != "X $srcdir/configure conftest.file" \ - && test "$*" != "X conftest.file $srcdir/configure"; then - - # If neither matched, then we have a broken ls. This can happen - # if, for instance, CONFIG_SHELL is bash and it inherits a - # broken ls alias from the environment. This has actually - # happened. Such a system could not be considered "sane". - as_fn_error $? "ls -t appears to fail. Make sure there is not a broken - alias in your environment" "$LINENO" 5 - fi - if test "$2" = conftest.file || test $am_try -eq 2; then - break - fi - # Just in case. - sleep 1 - am_has_slept=yes - done - test "$2" = conftest.file - ) -then - # Ok. - : -else - as_fn_error $? "newly created file is older than distributed files! -Check your system clock" "$LINENO" 5 -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } -# If we didn't sleep, we still need to ensure time stamps of config.status and -# generated files are strictly newer. -am_sleep_pid= -if grep 'slept: no' conftest.file >/dev/null 2>&1; then - ( sleep 1 ) & - am_sleep_pid=$! -fi - -rm -f conftest.file - -test "$program_prefix" != NONE && - program_transform_name="s&^&$program_prefix&;$program_transform_name" -# Use a double $ so make ignores it. -test "$program_suffix" != NONE && - program_transform_name="s&\$&$program_suffix&;$program_transform_name" -# Double any \ or $. -# By default was `s,x,x', remove it if useless. -ac_script='s/[\\$]/&&/g;s/;s,x,x,$//' -program_transform_name=`$as_echo "$program_transform_name" | sed "$ac_script"` - -# Expand $ac_aux_dir to an absolute path. -am_aux_dir=`cd "$ac_aux_dir" && pwd` - -if test x"${MISSING+set}" != xset; then - case $am_aux_dir in - *\ * | *\ *) - MISSING="\${SHELL} \"$am_aux_dir/missing\"" ;; - *) - MISSING="\${SHELL} $am_aux_dir/missing" ;; - esac -fi -# Use eval to expand $SHELL -if eval "$MISSING --is-lightweight"; then - am_missing_run="$MISSING " -else - am_missing_run= - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: 'missing' script is too old or missing" >&5 -$as_echo "$as_me: WARNING: 'missing' script is too old or missing" >&2;} -fi - -if test x"${install_sh+set}" != xset; then - case $am_aux_dir in - *\ * | *\ *) - install_sh="\${SHELL} '$am_aux_dir/install-sh'" ;; - *) - install_sh="\${SHELL} $am_aux_dir/install-sh" - esac -fi - -# Installed binaries are usually stripped using 'strip' when the user -# run "make install-strip". However 'strip' might not be the right -# tool to use in cross-compilation environments, therefore Automake -# will honor the 'STRIP' environment variable to overrule this program. -if test "$cross_compiling" != no; then - 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 ${ac_cv_prog_STRIP+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_ac_ct_STRIP+:} false; 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 as_fn_executable_p "$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 - -fi -INSTALL_STRIP_PROGRAM="\$(install_sh) -c -s" - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for a thread-safe mkdir -p" >&5 -$as_echo_n "checking for a thread-safe mkdir -p... " >&6; } -if test -z "$MKDIR_P"; then - if ${ac_cv_path_mkdir+:} false; then : - $as_echo_n "(cached) " >&6 -else - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH$PATH_SEPARATOR/opt/sfw/bin -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_prog in mkdir gmkdir; do - for ac_exec_ext in '' $ac_executable_extensions; do - as_fn_executable_p "$as_dir/$ac_prog$ac_exec_ext" || continue - case `"$as_dir/$ac_prog$ac_exec_ext" --version 2>&1` in #( - 'mkdir (GNU coreutils) '* | \ - 'mkdir (coreutils) '* | \ - 'mkdir (fileutils) '4.1*) - ac_cv_path_mkdir=$as_dir/$ac_prog$ac_exec_ext - break 3;; - esac - done - done - done -IFS=$as_save_IFS - -fi - - test -d ./--version && rmdir ./--version - if test "${ac_cv_path_mkdir+set}" = set; then - MKDIR_P="$ac_cv_path_mkdir -p" - else - # As a last resort, use the slow shell script. Don't cache a - # value for MKDIR_P 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. - MKDIR_P="$ac_install_sh -d" - fi -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $MKDIR_P" >&5 -$as_echo "$MKDIR_P" >&6; } - -for ac_prog in gawk mawk nawk awk -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 ${ac_cv_prog_AWK+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$AWK"; then - ac_cv_prog_AWK="$AWK" # 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 as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_AWK="$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 -AWK=$ac_cv_prog_AWK -if test -n "$AWK"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $AWK" >&5 -$as_echo "$AWK" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - - test -n "$AWK" && break -done - -{ $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 eval \${ac_cv_prog_make_${ac_make}_set+:} false; 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 - -rm -rf .tst 2>/dev/null -mkdir .tst 2>/dev/null -if test -d .tst; then - am__leading_dot=. -else - am__leading_dot=_ -fi -rmdir .tst 2>/dev/null - -# Check whether --enable-silent-rules was given. -if test "${enable_silent_rules+set}" = set; then : - enableval=$enable_silent_rules; -fi - -case $enable_silent_rules in # ((( - yes) AM_DEFAULT_VERBOSITY=0;; - no) AM_DEFAULT_VERBOSITY=1;; - *) AM_DEFAULT_VERBOSITY=1;; -esac -am_make=${MAKE-make} -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $am_make supports nested variables" >&5 -$as_echo_n "checking whether $am_make supports nested variables... " >&6; } -if ${am_cv_make_support_nested_variables+:} false; then : - $as_echo_n "(cached) " >&6 -else - if $as_echo 'TRUE=$(BAR$(V)) -BAR0=false -BAR1=true -V=1 -am__doit: - @$(TRUE) -.PHONY: am__doit' | $am_make -f - >/dev/null 2>&1; then - am_cv_make_support_nested_variables=yes -else - am_cv_make_support_nested_variables=no -fi -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_make_support_nested_variables" >&5 -$as_echo "$am_cv_make_support_nested_variables" >&6; } -if test $am_cv_make_support_nested_variables = yes; then - AM_V='$(V)' - AM_DEFAULT_V='$(AM_DEFAULT_VERBOSITY)' -else - AM_V=$AM_DEFAULT_VERBOSITY - AM_DEFAULT_V=$AM_DEFAULT_VERBOSITY -fi -AM_BACKSLASH='\' - -if test "`cd $srcdir && pwd`" != "`pwd`"; then - # Use -I$(srcdir) only when $(srcdir) != ., so that make's output - # is not polluted with repeated "-I." - am__isrc=' -I$(srcdir)' - # test to see if srcdir already configured - if test -f $srcdir/config.status; then - as_fn_error $? "source directory already configured; run \"make distclean\" there first" "$LINENO" 5 - fi -fi - -# test whether we have cygpath -if test -z "$CYGPATH_W"; then - if (cygpath --version) >/dev/null 2>/dev/null; then - CYGPATH_W='cygpath -w' - else - CYGPATH_W=echo - fi -fi - - -# Define the identity of the package. - PACKAGE='libatomic_ops' - VERSION='7.5.0' - - -cat >>confdefs.h <<_ACEOF -#define PACKAGE "$PACKAGE" -_ACEOF - - -cat >>confdefs.h <<_ACEOF -#define VERSION "$VERSION" -_ACEOF - -# Some tools Automake needs. - -ACLOCAL=${ACLOCAL-"${am_missing_run}aclocal-${am__api_version}"} - - -AUTOCONF=${AUTOCONF-"${am_missing_run}autoconf"} - - -AUTOMAKE=${AUTOMAKE-"${am_missing_run}automake-${am__api_version}"} - - -AUTOHEADER=${AUTOHEADER-"${am_missing_run}autoheader"} - - -MAKEINFO=${MAKEINFO-"${am_missing_run}makeinfo"} - -# For better backward compatibility. To be removed once Automake 1.9.x -# dies out for good. For more background, see: -# -# -mkdir_p='$(MKDIR_P)' - -# We need awk for the "check" target (and possibly the TAP driver). The -# system "awk" is bad on some platforms. -# Always define AMTAR for backward compatibility. Yes, it's still used -# in the wild :-( We should find a proper way to deprecate it ... -AMTAR='$${TAR-tar}' - - -# We'll loop over all known methods to create a tar archive until one works. -_am_tools='gnutar pax cpio none' - -am__tar='$${TAR-tar} chof - "$$tardir"' am__untar='$${TAR-tar} xf -' - - - - - - -# POSIX will say in a future version that running "rm -f" with no argument -# is OK; and we want to be able to make that assumption in our Makefile -# recipes. So use an aggressive probe to check that the usage we want is -# actually supported "in the wild" to an acceptable degree. -# See automake bug#10828. -# To make any issue more visible, cause the running configure to be aborted -# by default if the 'rm' program in use doesn't match our expectations; the -# user can still override this though. -if rm -f && rm -fr && rm -rf; then : OK; else - cat >&2 <<'END' -Oops! - -Your 'rm' program seems unable to run without file operands specified -on the command line, even when the '-f' option is present. This is contrary -to the behaviour of most rm programs out there, and not conforming with -the upcoming POSIX standard: - -Please tell bug-automake@gnu.org about your system, including the value -of your $PATH and any error possibly output before this message. This -can help us improve future automake versions. - -END - if test x"$ACCEPT_INFERIOR_RM_PROGRAM" = x"yes"; then - echo 'Configuration will proceed anyway, since you have set the' >&2 - echo 'ACCEPT_INFERIOR_RM_PROGRAM variable to "yes"' >&2 - echo >&2 - else - cat >&2 <<'END' -Aborting the configuration process, to ensure you take notice of the issue. - -You can download and install GNU coreutils to get an 'rm' implementation -that behaves properly: . - -If you want to complete the configuration process using your problematic -'rm' anyway, export the environment variable ACCEPT_INFERIOR_RM_PROGRAM -to "yes", and re-run configure. - -END - as_fn_error $? "Your 'rm' program is bad, sorry." "$LINENO" 5 - fi -fi - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to enable maintainer-specific portions of Makefiles" >&5 -$as_echo_n "checking whether to enable maintainer-specific portions of Makefiles... " >&6; } - # Check whether --enable-maintainer-mode was given. -if test "${enable_maintainer_mode+set}" = set; then : - enableval=$enable_maintainer_mode; USE_MAINTAINER_MODE=$enableval -else - USE_MAINTAINER_MODE=no -fi - - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $USE_MAINTAINER_MODE" >&5 -$as_echo "$USE_MAINTAINER_MODE" >&6; } - if test $USE_MAINTAINER_MODE = yes; then - MAINTAINER_MODE_TRUE= - MAINTAINER_MODE_FALSE='#' -else - MAINTAINER_MODE_TRUE='#' - MAINTAINER_MODE_FALSE= -fi - - MAINT=$MAINTAINER_MODE_TRUE - - - -ac_config_headers="$ac_config_headers src/config.h" - - -# Checks for programs. -DEPDIR="${am__leading_dot}deps" - -ac_config_commands="$ac_config_commands depfiles" - - -am_make=${MAKE-make} -cat > confinc << 'END' -am__doit: - @echo this is the am__doit target -.PHONY: am__doit -END -# If we don't find an include directive, just comment out the code. -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for style of include used by $am_make" >&5 -$as_echo_n "checking for style of include used by $am_make... " >&6; } -am__include="#" -am__quote= -_am_result=none -# First try GNU make style include. -echo "include confinc" > confmf -# Ignore all kinds of additional output from 'make'. -case `$am_make -s -f confmf 2> /dev/null` in #( -*the\ am__doit\ target*) - am__include=include - am__quote= - _am_result=GNU - ;; -esac -# Now try BSD make style include. -if test "$am__include" = "#"; then - echo '.include "confinc"' > confmf - case `$am_make -s -f confmf 2> /dev/null` in #( - *the\ am__doit\ target*) - am__include=.include - am__quote="\"" - _am_result=BSD - ;; - esac -fi - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $_am_result" >&5 -$as_echo "$_am_result" >&6; } -rm -f confinc confmf - -# Check whether --enable-dependency-tracking was given. -if test "${enable_dependency_tracking+set}" = set; then : - enableval=$enable_dependency_tracking; -fi - -if test "x$enable_dependency_tracking" != xno; then - am_depcomp="$ac_aux_dir/depcomp" - AMDEPBACKSLASH='\' - am__nodep='_no' -fi - if test "x$enable_dependency_tracking" != xno; then - AMDEP_TRUE= - AMDEP_FALSE='#' -else - AMDEP_TRUE='#' - AMDEP_FALSE= -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 -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 ${ac_cv_prog_CC+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_ac_ct_CC+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_CC+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_CC+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_CC+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_ac_ct_CC+:} false; 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 as_fn_executable_p "$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 - fi - rm -f conftest.er1 conftest.err - $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. */ - -int -main () -{ - - ; - 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" -# 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 whether the C compiler works" >&5 -$as_echo_n "checking whether the C compiler works... " >&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 -if test -z "$ac_file"; then : - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -$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 77 "C compiler cannot create executables -See \`config.log' for more details" "$LINENO" 5; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } -fi -{ $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; } -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 -$as_echo "$ac_file" >&6; } -ac_exeext=$ac_cv_exeext - -rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out -ac_clean_files=$ac_clean_files_save -{ $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 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 -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="$ac_clean_files conftest.out" -# 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; } -if test "$cross_compiling" != yes; then - { { 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; } - if { ac_try='./conftest$ac_cv_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 - 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: $cross_compiling" >&5 -$as_echo "$cross_compiling" >&6; } - -rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out -ac_clean_files=$ac_clean_files_save -{ $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 ${ac_cv_objext+:} false; 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 ${ac_cv_c_compiler_gnu+:} false; 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 ${ac_cv_prog_cc_g+:} false; 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 ${ac_cv_prog_cc_c89+:} false; 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 -struct stat; -/* 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 - -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 whether $CC understands -c and -o together" >&5 -$as_echo_n "checking whether $CC understands -c and -o together... " >&6; } -if ${am_cv_prog_cc_c_o+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF - # Make sure it works both with $CC and with simple cc. - # Following AC_PROG_CC_C_O, we do the test twice because some - # compilers refuse to overwrite an existing .o file with -o, - # though they will create one. - am_cv_prog_cc_c_o=yes - for am_i in 1 2; do - if { echo "$as_me:$LINENO: $CC -c conftest.$ac_ext -o conftest2.$ac_objext" >&5 - ($CC -c conftest.$ac_ext -o conftest2.$ac_objext) >&5 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } \ - && test -f conftest2.$ac_objext; then - : OK - else - am_cv_prog_cc_c_o=no - break - fi - done - rm -f core conftest* - unset am_i -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_prog_cc_c_o" >&5 -$as_echo "$am_cv_prog_cc_c_o" >&6; } -if test "$am_cv_prog_cc_c_o" != yes; then - # Losing compiler, so override with the script. - # FIXME: It is wrong to rewrite CC. - # But if we don't then we get into trouble of one sort or another. - # A longer-term fix would be to have automake use am__CC in this case, - # and then we could set am__CC="\$(top_srcdir)/compile \$(CC)" - CC="$am_aux_dir/compile $CC" -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 - - -depcc="$CC" am_compiler_list= - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking dependency style of $depcc" >&5 -$as_echo_n "checking dependency style of $depcc... " >&6; } -if ${am_cv_CC_dependencies_compiler_type+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -z "$AMDEP_TRUE" && test -f "$am_depcomp"; then - # We make a subdir and do the tests there. Otherwise we can end up - # making bogus files that we don't know about and never remove. For - # instance it was reported that on HP-UX the gcc test will end up - # making a dummy file named 'D' -- because '-MD' means "put the output - # in D". - rm -rf conftest.dir - mkdir conftest.dir - # Copy depcomp to subdir because otherwise we won't find it if we're - # using a relative directory. - cp "$am_depcomp" conftest.dir - cd conftest.dir - # We will build objects and dependencies in a subdirectory because - # it helps to detect inapplicable dependency modes. For instance - # both Tru64's cc and ICC support -MD to output dependencies as a - # side effect of compilation, but ICC will put the dependencies in - # the current directory while Tru64 will put them in the object - # directory. - mkdir sub - - am_cv_CC_dependencies_compiler_type=none - if test "$am_compiler_list" = ""; then - am_compiler_list=`sed -n 's/^#*\([a-zA-Z0-9]*\))$/\1/p' < ./depcomp` - fi - am__universal=false - case " $depcc " in #( - *\ -arch\ *\ -arch\ *) am__universal=true ;; - esac - - for depmode in $am_compiler_list; do - # Setup a source with many dependencies, because some compilers - # like to wrap large dependency lists on column 80 (with \), and - # we should not choose a depcomp mode which is confused by this. - # - # We need to recreate these files for each test, as the compiler may - # overwrite some of them when testing with obscure command lines. - # This happens at least with the AIX C compiler. - : > sub/conftest.c - for i in 1 2 3 4 5 6; do - echo '#include "conftst'$i'.h"' >> sub/conftest.c - # Using ": > sub/conftst$i.h" creates only sub/conftst1.h with - # Solaris 10 /bin/sh. - echo '/* dummy */' > sub/conftst$i.h - done - echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf - - # We check with '-c' and '-o' for the sake of the "dashmstdout" - # mode. It turns out that the SunPro C++ compiler does not properly - # handle '-M -o', and we need to detect this. Also, some Intel - # versions had trouble with output in subdirs. - am__obj=sub/conftest.${OBJEXT-o} - am__minus_obj="-o $am__obj" - case $depmode in - gcc) - # This depmode causes a compiler race in universal mode. - test "$am__universal" = false || continue - ;; - nosideeffect) - # After this tag, mechanisms are not by side-effect, so they'll - # only be used when explicitly requested. - if test "x$enable_dependency_tracking" = xyes; then - continue - else - break - fi - ;; - msvc7 | msvc7msys | msvisualcpp | msvcmsys) - # This compiler won't grok '-c -o', but also, the minuso test has - # not run yet. These depmodes are late enough in the game, and - # so weak that their functioning should not be impacted. - am__obj=conftest.${OBJEXT-o} - am__minus_obj= - ;; - none) break ;; - esac - if depmode=$depmode \ - source=sub/conftest.c object=$am__obj \ - depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \ - $SHELL ./depcomp $depcc -c $am__minus_obj sub/conftest.c \ - >/dev/null 2>conftest.err && - grep sub/conftst1.h sub/conftest.Po > /dev/null 2>&1 && - grep sub/conftst6.h sub/conftest.Po > /dev/null 2>&1 && - grep $am__obj sub/conftest.Po > /dev/null 2>&1 && - ${MAKE-make} -s -f confmf > /dev/null 2>&1; then - # icc doesn't choke on unknown options, it will just issue warnings - # or remarks (even with -Werror). So we grep stderr for any message - # that says an option was ignored or not supported. - # When given -MP, icc 7.0 and 7.1 complain thusly: - # icc: Command line warning: ignoring option '-M'; no argument required - # The diagnosis changed in icc 8.0: - # icc: Command line remark: option '-MP' not supported - if (grep 'ignoring option' conftest.err || - grep 'not supported' conftest.err) >/dev/null 2>&1; then :; else - am_cv_CC_dependencies_compiler_type=$depmode - break - fi - fi - done - - cd .. - rm -rf conftest.dir -else - am_cv_CC_dependencies_compiler_type=none -fi - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_CC_dependencies_compiler_type" >&5 -$as_echo "$am_cv_CC_dependencies_compiler_type" >&6; } -CCDEPMODE=depmode=$am_cv_CC_dependencies_compiler_type - - if - test "x$enable_dependency_tracking" != xno \ - && test "$am_cv_CC_dependencies_compiler_type" = gcc3; then - am__fastdepCC_TRUE= - am__fastdepCC_FALSE='#' -else - am__fastdepCC_TRUE='#' - am__fastdepCC_FALSE= -fi - - - -# By default we simply use the C compiler to build assembly code. - -test "${CCAS+set}" = set || CCAS=$CC -test "${CCASFLAGS+set}" = set || CCASFLAGS=$CFLAGS - - - -depcc="$CCAS" am_compiler_list= - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking dependency style of $depcc" >&5 -$as_echo_n "checking dependency style of $depcc... " >&6; } -if ${am_cv_CCAS_dependencies_compiler_type+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -z "$AMDEP_TRUE" && test -f "$am_depcomp"; then - # We make a subdir and do the tests there. Otherwise we can end up - # making bogus files that we don't know about and never remove. For - # instance it was reported that on HP-UX the gcc test will end up - # making a dummy file named 'D' -- because '-MD' means "put the output - # in D". - rm -rf conftest.dir - mkdir conftest.dir - # Copy depcomp to subdir because otherwise we won't find it if we're - # using a relative directory. - cp "$am_depcomp" conftest.dir - cd conftest.dir - # We will build objects and dependencies in a subdirectory because - # it helps to detect inapplicable dependency modes. For instance - # both Tru64's cc and ICC support -MD to output dependencies as a - # side effect of compilation, but ICC will put the dependencies in - # the current directory while Tru64 will put them in the object - # directory. - mkdir sub - - am_cv_CCAS_dependencies_compiler_type=none - if test "$am_compiler_list" = ""; then - am_compiler_list=`sed -n 's/^#*\([a-zA-Z0-9]*\))$/\1/p' < ./depcomp` - fi - am__universal=false - - - for depmode in $am_compiler_list; do - # Setup a source with many dependencies, because some compilers - # like to wrap large dependency lists on column 80 (with \), and - # we should not choose a depcomp mode which is confused by this. - # - # We need to recreate these files for each test, as the compiler may - # overwrite some of them when testing with obscure command lines. - # This happens at least with the AIX C compiler. - : > sub/conftest.c - for i in 1 2 3 4 5 6; do - echo '#include "conftst'$i'.h"' >> sub/conftest.c - # Using ": > sub/conftst$i.h" creates only sub/conftst1.h with - # Solaris 10 /bin/sh. - echo '/* dummy */' > sub/conftst$i.h - done - echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf - - # We check with '-c' and '-o' for the sake of the "dashmstdout" - # mode. It turns out that the SunPro C++ compiler does not properly - # handle '-M -o', and we need to detect this. Also, some Intel - # versions had trouble with output in subdirs. - am__obj=sub/conftest.${OBJEXT-o} - am__minus_obj="-o $am__obj" - case $depmode in - gcc) - # This depmode causes a compiler race in universal mode. - test "$am__universal" = false || continue - ;; - nosideeffect) - # After this tag, mechanisms are not by side-effect, so they'll - # only be used when explicitly requested. - if test "x$enable_dependency_tracking" = xyes; then - continue - else - break - fi - ;; - msvc7 | msvc7msys | msvisualcpp | msvcmsys) - # This compiler won't grok '-c -o', but also, the minuso test has - # not run yet. These depmodes are late enough in the game, and - # so weak that their functioning should not be impacted. - am__obj=conftest.${OBJEXT-o} - am__minus_obj= - ;; - none) break ;; - esac - if depmode=$depmode \ - source=sub/conftest.c object=$am__obj \ - depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \ - $SHELL ./depcomp $depcc -c $am__minus_obj sub/conftest.c \ - >/dev/null 2>conftest.err && - grep sub/conftst1.h sub/conftest.Po > /dev/null 2>&1 && - grep sub/conftst6.h sub/conftest.Po > /dev/null 2>&1 && - grep $am__obj sub/conftest.Po > /dev/null 2>&1 && - ${MAKE-make} -s -f confmf > /dev/null 2>&1; then - # icc doesn't choke on unknown options, it will just issue warnings - # or remarks (even with -Werror). So we grep stderr for any message - # that says an option was ignored or not supported. - # When given -MP, icc 7.0 and 7.1 complain thusly: - # icc: Command line warning: ignoring option '-M'; no argument required - # The diagnosis changed in icc 8.0: - # icc: Command line remark: option '-MP' not supported - if (grep 'ignoring option' conftest.err || - grep 'not supported' conftest.err) >/dev/null 2>&1; then :; else - am_cv_CCAS_dependencies_compiler_type=$depmode - break - fi - fi - done - - cd .. - rm -rf conftest.dir -else - am_cv_CCAS_dependencies_compiler_type=none -fi - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_CCAS_dependencies_compiler_type" >&5 -$as_echo "$am_cv_CCAS_dependencies_compiler_type" >&6; } -CCASDEPMODE=depmode=$am_cv_CCAS_dependencies_compiler_type - - if - test "x$enable_dependency_tracking" != xno \ - && test "$am_cv_CCAS_dependencies_compiler_type" = gcc3; then - am__fastdepCCAS_TRUE= - am__fastdepCCAS_FALSE='#' -else - am__fastdepCCAS_TRUE='#' - am__fastdepCCAS_FALSE= -fi - - -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.4.6' -macro_revision='2.4.6' - - - - - - - - - - - - - -ltmain=$ac_aux_dir/ltmain.sh - -# Backslashify 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' - -ECHO='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' -ECHO=$ECHO$ECHO$ECHO$ECHO$ECHO -ECHO=$ECHO$ECHO$ECHO$ECHO$ECHO$ECHO - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to print strings" >&5 -$as_echo_n "checking how to print strings... " >&6; } -# Test print first, because it will be a builtin if present. -if test "X`( print -r -- -n ) 2>/dev/null`" = X-n && \ - test "X`print -r -- $ECHO 2>/dev/null`" = "X$ECHO"; then - ECHO='print -r --' -elif test "X`printf %s $ECHO 2>/dev/null`" = "X$ECHO"; then - ECHO='printf %s\n' -else - # Use this function as a fallback that always works. - func_fallback_echo () - { - eval 'cat <<_LTECHO_EOF -$1 -_LTECHO_EOF' - } - ECHO='func_fallback_echo' -fi - -# func_echo_all arg... -# Invoke $ECHO with all args, space-separated. -func_echo_all () -{ - $ECHO "" -} - -case $ECHO in - printf*) { $as_echo "$as_me:${as_lineno-$LINENO}: result: printf" >&5 -$as_echo "printf" >&6; } ;; - print*) { $as_echo "$as_me:${as_lineno-$LINENO}: result: print -r" >&5 -$as_echo "print -r" >&6; } ;; - *) { $as_echo "$as_me:${as_lineno-$LINENO}: result: cat" >&5 -$as_echo "cat" >&6; } ;; -esac - - - - - - - - - - - - - - -{ $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 ${ac_cv_path_SED+:} false; 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" - as_fn_executable_p "$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 ${ac_cv_path_GREP+:} false; 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" - as_fn_executable_p "$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 ${ac_cv_path_EGREP+:} false; 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" - as_fn_executable_p "$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 ${ac_cv_path_FGREP+:} false; 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" - as_fn_executable_p "$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 no = "$withval" || with_gnu_ld=yes -else - with_gnu_ld=no -fi - -ac_prog=ld -if test yes = "$GCC"; 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 yes = "$with_gnu_ld"; 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 ${lt_cv_path_LD+:} false; 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 ${lt_cv_prog_gnu_ld+:} false; 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 ${lt_cv_path_NM+:} false; 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 - # MSYS converts /dev/null to NUL, MinGW nm treats NUL as empty - case $build_os in - mingw*) lt_bad_file=conftest.nm/nofile ;; - *) lt_bad_file=/dev/null ;; - esac - case `"$tmp_nm" -B $lt_bad_file 2>&1 | sed '1q'` in - *$lt_bad_file* | *'Invalid file or object type'*) - lt_cv_path_NM="$tmp_nm -B" - break 2 - ;; - *) - case `"$tmp_nm" -p /dev/null 2>&1 | sed '1q'` in - */dev/null*) - lt_cv_path_NM="$tmp_nm -p" - break 2 - ;; - *) - 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 no != "$lt_cv_path_NM"; then - NM=$lt_cv_path_NM -else - # Didn't find any BSD compatible name lister, look for dumpbin. - if test -n "$DUMPBIN"; then : - # Let the user override the test. - else - if test -n "$ac_tool_prefix"; then - for ac_prog in dumpbin "link -dump" - 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 ${ac_cv_prog_DUMPBIN+:} false; 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 as_fn_executable_p "$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 "link -dump" -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 ${ac_cv_prog_ac_ct_DUMPBIN+:} false; 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 as_fn_executable_p "$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 - - case `$DUMPBIN -symbols -headers /dev/null 2>&1 | sed '1q'` in - *COFF*) - DUMPBIN="$DUMPBIN -symbols -headers" - ;; - *) - DUMPBIN=: - ;; - esac - 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 ${lt_cv_nm_interface+:} false; 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:$LINENO: $ac_compile\"" >&5) - (eval "$ac_compile" 2>conftest.err) - cat conftest.err >&5 - (eval echo "\"\$as_me:$LINENO: $NM \\\"conftest.$ac_objext\\\"\"" >&5) - (eval "$NM \"conftest.$ac_objext\"" 2>conftest.err > conftest.out) - cat conftest.err >&5 - (eval echo "\"\$as_me:$LINENO: 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 ${lt_cv_sys_max_cmd_len+:} false; 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; - ;; - - mint*) - # On MiNT this can take a long time and run out of memory. - 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; - ;; - - bitrig* | darwin* | dragonfly* | freebsd* | netbsd* | openbsd*) - # 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 - ;; - - os2*) - # The test takes a long time on OS/2. - lt_cv_sys_max_cmd_len=8192 - ;; - - 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" && \ - test undefined != "$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`env echo "$teststring$teststring" 2>/dev/null` \ - = "X$teststring$teststring"; } >/dev/null 2>&1 && - test 17 != "$i" # 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"} - -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 how to convert $build file names to $host format" >&5 -$as_echo_n "checking how to convert $build file names to $host format... " >&6; } -if ${lt_cv_to_host_file_cmd+:} false; then : - $as_echo_n "(cached) " >&6 -else - case $host in - *-*-mingw* ) - case $build in - *-*-mingw* ) # actually msys - lt_cv_to_host_file_cmd=func_convert_file_msys_to_w32 - ;; - *-*-cygwin* ) - lt_cv_to_host_file_cmd=func_convert_file_cygwin_to_w32 - ;; - * ) # otherwise, assume *nix - lt_cv_to_host_file_cmd=func_convert_file_nix_to_w32 - ;; - esac - ;; - *-*-cygwin* ) - case $build in - *-*-mingw* ) # actually msys - lt_cv_to_host_file_cmd=func_convert_file_msys_to_cygwin - ;; - *-*-cygwin* ) - lt_cv_to_host_file_cmd=func_convert_file_noop - ;; - * ) # otherwise, assume *nix - lt_cv_to_host_file_cmd=func_convert_file_nix_to_cygwin - ;; - esac - ;; - * ) # unhandled hosts (and "normal" native builds) - lt_cv_to_host_file_cmd=func_convert_file_noop - ;; -esac - -fi - -to_host_file_cmd=$lt_cv_to_host_file_cmd -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_to_host_file_cmd" >&5 -$as_echo "$lt_cv_to_host_file_cmd" >&6; } - - - - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to convert $build file names to toolchain format" >&5 -$as_echo_n "checking how to convert $build file names to toolchain format... " >&6; } -if ${lt_cv_to_tool_file_cmd+:} false; then : - $as_echo_n "(cached) " >&6 -else - #assume ordinary cross tools, or native build. -lt_cv_to_tool_file_cmd=func_convert_file_noop -case $host in - *-*-mingw* ) - case $build in - *-*-mingw* ) # actually msys - lt_cv_to_tool_file_cmd=func_convert_file_msys_to_w32 - ;; - esac - ;; -esac - -fi - -to_tool_file_cmd=$lt_cv_to_tool_file_cmd -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_to_tool_file_cmd" >&5 -$as_echo "$lt_cv_to_tool_file_cmd" >&6; } - - - - - -{ $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 ${lt_cv_ld_reload_flag+:} false; 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 - cygwin* | mingw* | pw32* | cegcc*) - if test yes != "$GCC"; then - reload_cmds=false - fi - ;; - darwin*) - if test yes = "$GCC"; 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 ${ac_cv_prog_OBJDUMP+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_ac_ct_OBJDUMP+:} false; 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 as_fn_executable_p "$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 ${lt_cv_deplibs_check_method+:} false; 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 -# that 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 - # Keep this pattern in sync with the one in func_win32_libid. - lt_cv_deplibs_check_method='file_magic file format (pei*-i386(.*architecture: i386)?|pe-arm-wince|pe-x86-64)' - 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 - ;; - -haiku*) - 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])(-bit)?( [LM]SB)? 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 glibc/ELF. -linux* | k*bsd*-gnu | kopensolaris*-gnu | gnu*) - lt_cv_deplibs_check_method=pass_all - ;; - -netbsd*) - 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* | bitrig*) - if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`"; 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 - ;; -os2*) - 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_glob= -want_nocaseglob=no -if test "$build" = "$host"; then - case $host_os in - mingw* | pw32*) - if ( shopt | grep nocaseglob ) >/dev/null 2>&1; then - want_nocaseglob=yes - else - file_magic_glob=`echo aAbBcCdDeEfFgGhHiIjJkKlLmMnNoOpPqQrRsStTuUvVwWxXyYzZ | $SED -e "s/\(..\)/s\/[\1]\/[\1]\/g;/g"` - fi - ;; - esac -fi - -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}dlltool", so it can be a program name with args. -set dummy ${ac_tool_prefix}dlltool; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_DLLTOOL+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$DLLTOOL"; then - ac_cv_prog_DLLTOOL="$DLLTOOL" # 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 as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_DLLTOOL="${ac_tool_prefix}dlltool" - $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 -DLLTOOL=$ac_cv_prog_DLLTOOL -if test -n "$DLLTOOL"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $DLLTOOL" >&5 -$as_echo "$DLLTOOL" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - -fi -if test -z "$ac_cv_prog_DLLTOOL"; then - ac_ct_DLLTOOL=$DLLTOOL - # Extract the first word of "dlltool", so it can be a program name with args. -set dummy dlltool; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_ac_ct_DLLTOOL+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$ac_ct_DLLTOOL"; then - ac_cv_prog_ac_ct_DLLTOOL="$ac_ct_DLLTOOL" # 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 as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_ac_ct_DLLTOOL="dlltool" - $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_DLLTOOL=$ac_cv_prog_ac_ct_DLLTOOL -if test -n "$ac_ct_DLLTOOL"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_DLLTOOL" >&5 -$as_echo "$ac_ct_DLLTOOL" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - if test "x$ac_ct_DLLTOOL" = x; then - DLLTOOL="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 - DLLTOOL=$ac_ct_DLLTOOL - fi -else - DLLTOOL="$ac_cv_prog_DLLTOOL" -fi - -test -z "$DLLTOOL" && DLLTOOL=dlltool - - - - - - - - - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to associate runtime and link libraries" >&5 -$as_echo_n "checking how to associate runtime and link libraries... " >&6; } -if ${lt_cv_sharedlib_from_linklib_cmd+:} false; then : - $as_echo_n "(cached) " >&6 -else - lt_cv_sharedlib_from_linklib_cmd='unknown' - -case $host_os in -cygwin* | mingw* | pw32* | cegcc*) - # two different shell functions defined in ltmain.sh; - # decide which one to use based on capabilities of $DLLTOOL - case `$DLLTOOL --help 2>&1` in - *--identify-strict*) - lt_cv_sharedlib_from_linklib_cmd=func_cygming_dll_for_implib - ;; - *) - lt_cv_sharedlib_from_linklib_cmd=func_cygming_dll_for_implib_fallback - ;; - esac - ;; -*) - # fallback: assume linklib IS sharedlib - lt_cv_sharedlib_from_linklib_cmd=$ECHO - ;; -esac - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_sharedlib_from_linklib_cmd" >&5 -$as_echo "$lt_cv_sharedlib_from_linklib_cmd" >&6; } -sharedlib_from_linklib_cmd=$lt_cv_sharedlib_from_linklib_cmd -test -z "$sharedlib_from_linklib_cmd" && sharedlib_from_linklib_cmd=$ECHO - - - - - - - - -if test -n "$ac_tool_prefix"; then - for ac_prog in ar - 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 ${ac_cv_prog_AR+:} false; 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 as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_AR="$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 -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 - - - test -n "$AR" && break - done -fi -if test -z "$AR"; then - ac_ct_AR=$AR - for ac_prog in ar -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 ${ac_cv_prog_ac_ct_AR+:} false; 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 as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_ac_ct_AR="$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_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 - - - test -n "$ac_ct_AR" && break -done - - 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 -fi - -: ${AR=ar} -: ${AR_FLAGS=cru} - - - - - - - - - - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for archiver @FILE support" >&5 -$as_echo_n "checking for archiver @FILE support... " >&6; } -if ${lt_cv_ar_at_file+:} false; then : - $as_echo_n "(cached) " >&6 -else - lt_cv_ar_at_file=no - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - echo conftest.$ac_objext > conftest.lst - lt_ar_try='$AR $AR_FLAGS libconftest.a @conftest.lst >&5' - { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$lt_ar_try\""; } >&5 - (eval $lt_ar_try) 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } - if test 0 -eq "$ac_status"; then - # Ensure the archiver fails upon bogus file names. - rm -f conftest.$ac_objext libconftest.a - { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$lt_ar_try\""; } >&5 - (eval $lt_ar_try) 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } - if test 0 -ne "$ac_status"; then - lt_cv_ar_at_file=@ - fi - fi - rm -f conftest.* libconftest.a - -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_ar_at_file" >&5 -$as_echo "$lt_cv_ar_at_file" >&6; } - -if test no = "$lt_cv_ar_at_file"; then - archiver_list_spec= -else - archiver_list_spec=$lt_cv_ar_at_file -fi - - - - - - - -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 ${ac_cv_prog_STRIP+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_ac_ct_STRIP+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_RANLIB+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_ac_ct_RANLIB+:} false; 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 as_fn_executable_p "$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 - bitrig* | openbsd*) - old_postinstall_cmds="$old_postinstall_cmds~\$RANLIB -t \$tool_oldlib" - ;; - *) - old_postinstall_cmds="$old_postinstall_cmds~\$RANLIB \$tool_oldlib" - ;; - esac - old_archive_cmds="$old_archive_cmds~\$RANLIB \$tool_oldlib" -fi - -case $host_os in - darwin*) - lock_old_archive_extraction=yes ;; - *) - lock_old_archive_extraction=no ;; -esac - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -# 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 ${lt_cv_sys_global_symbol_pipe+:} false; 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 ia64 = "$host_cpu"; 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 - -if test "$lt_cv_nm_interface" = "MS dumpbin"; then - # Gets list of data symbols to import. - lt_cv_sys_global_symbol_to_import="sed -n -e 's/^I .* \(.*\)$/\1/p'" - # Adjust the below global symbol transforms to fixup imported variables. - lt_cdecl_hook=" -e 's/^I .* \(.*\)$/extern __declspec(dllimport) char \1;/p'" - lt_c_name_hook=" -e 's/^I .* \(.*\)$/ {\"\1\", (void *) 0},/p'" - lt_c_name_lib_hook="\ - -e 's/^I .* \(lib.*\)$/ {\"\1\", (void *) 0},/p'\ - -e 's/^I .* \(.*\)$/ {\"lib\1\", (void *) 0},/p'" -else - # Disable hooks by default. - lt_cv_sys_global_symbol_to_import= - lt_cdecl_hook= - lt_c_name_hook= - lt_c_name_lib_hook= -fi - -# 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"\ -$lt_cdecl_hook\ -" -e 's/^T .* \(.*\)$/extern int \1();/p'"\ -" -e 's/^$symcode$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"\ -$lt_c_name_hook\ -" -e 's/^: \(.*\) .*$/ {\"\1\", (void *) 0},/p'"\ -" -e 's/^$symcode$symcode* .* \(.*\)$/ {\"\1\", (void *) \&\1},/p'" - -# Transform an extracted symbol line into symbol name with lib prefix and -# symbol address. -lt_cv_sys_global_symbol_to_c_name_address_lib_prefix="sed -n"\ -$lt_c_name_lib_hook\ -" -e 's/^: \(.*\) .*$/ {\"\1\", (void *) 0},/p'"\ -" -e 's/^$symcode$symcode* .* \(lib.*\)$/ {\"\1\", (void *) \&\1},/p'"\ -" -e 's/^$symcode$symcode* .* \(.*\)$/ {\"lib\1\", (void *) \&\1},/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, - # D for any global variable and I for any imported 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};"\ -" /^COFF SYMBOL TABLE/{for(i in hide) delete hide[i]};"\ -" /Section length .*#relocs.*(pick any)/{hide[last_section]=1};"\ -" /^ *Symbol name *: /{split(\$ 0,sn,\":\"); si=substr(sn[2],2)};"\ -" /^ *Type *: code/{print \"T\",si,substr(si,length(prfx))};"\ -" /^ *Type *: data/{print \"I\",si,substr(si,length(prfx))};"\ -" \$ 0!~/External *\|/{next};"\ -" / 0+ UNDEF /{next}; / UNDEF \([^|]\)*()/{next};"\ -" {if(hide[section]) next};"\ -" {f=\"D\"}; \$ 0~/\(\).*\|/{f=\"T\"};"\ -" {split(\$ 0,a,/\||\r/); split(a[2],s)};"\ -" s[1]~/^[@?]/{print f,s[1],s[1]; next};"\ -" s[1]~prfx {split(s[1],t,\"@\"); print f,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 - lt_cv_sys_global_symbol_pipe="$lt_cv_sys_global_symbol_pipe | sed '/ __gnu_lto/d'" - - # 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 -/* Keep this code in sync between libtool.m4, ltmain, lt_system.h, and tests. */ -#if defined _WIN32 || defined __CYGWIN__ || defined _WIN32_WCE -/* DATA imports from DLLs on WIN32 can't be const, because runtime - relocations are performed -- see ld's documentation on pseudo-relocs. */ -# define LT_DLSYM_CONST -#elif defined __osf__ -/* This system does not cope well with relocations in const data. */ -# define LT_DLSYM_CONST -#else -# define LT_DLSYM_CONST const -#endif - -#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. */ -LT_DLSYM_CONST struct { - const char *name; - void *address; -} -lt__PROGRAM__LTX_preloaded_symbols[] = -{ - { "@PROGRAM@", (void *) 0 }, -_LT_EOF - $SED "s/^$symcode$symcode* .* \(.*\)$/ {\"\1\", (void *) \&\1},/" < "$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_globsym_save_LIBS=$LIBS - lt_globsym_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_globsym_save_LIBS - CFLAGS=$lt_globsym_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 yes = "$pipe_works"; 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 - -# Response file support. -if test "$lt_cv_nm_interface" = "MS dumpbin"; then - nm_file_list_spec='@' -elif $NM --help 2>/dev/null | grep '[@]FILE' >/dev/null; then - nm_file_list_spec='@' -fi - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for sysroot" >&5 -$as_echo_n "checking for sysroot... " >&6; } - -# Check whether --with-sysroot was given. -if test "${with_sysroot+set}" = set; then : - withval=$with_sysroot; -else - with_sysroot=no -fi - - -lt_sysroot= -case $with_sysroot in #( - yes) - if test yes = "$GCC"; then - lt_sysroot=`$CC --print-sysroot 2>/dev/null` - fi - ;; #( - /*) - lt_sysroot=`echo "$with_sysroot" | sed -e "$sed_quote_subst"` - ;; #( - no|'') - ;; #( - *) - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $with_sysroot" >&5 -$as_echo "$with_sysroot" >&6; } - as_fn_error $? "The sysroot must be an absolute path." "$LINENO" 5 - ;; -esac - - { $as_echo "$as_me:${as_lineno-$LINENO}: result: ${lt_sysroot:-no}" >&5 -$as_echo "${lt_sysroot:-no}" >&6; } - - - - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for a working dd" >&5 -$as_echo_n "checking for a working dd... " >&6; } -if ${ac_cv_path_lt_DD+:} false; then : - $as_echo_n "(cached) " >&6 -else - printf 0123456789abcdef0123456789abcdef >conftest.i -cat conftest.i conftest.i >conftest2.i -: ${lt_DD:=$DD} -if test -z "$lt_DD"; then - ac_path_lt_DD_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 dd; do - for ac_exec_ext in '' $ac_executable_extensions; do - ac_path_lt_DD="$as_dir/$ac_prog$ac_exec_ext" - as_fn_executable_p "$ac_path_lt_DD" || continue -if "$ac_path_lt_DD" bs=32 count=1 conftest.out 2>/dev/null; then - cmp -s conftest.i conftest.out \ - && ac_cv_path_lt_DD="$ac_path_lt_DD" ac_path_lt_DD_found=: -fi - $ac_path_lt_DD_found && break 3 - done - done - done -IFS=$as_save_IFS - if test -z "$ac_cv_path_lt_DD"; then - : - fi -else - ac_cv_path_lt_DD=$lt_DD -fi - -rm -f conftest.i conftest2.i conftest.out -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_lt_DD" >&5 -$as_echo "$ac_cv_path_lt_DD" >&6; } - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to truncate binary pipes" >&5 -$as_echo_n "checking how to truncate binary pipes... " >&6; } -if ${lt_cv_truncate_bin+:} false; then : - $as_echo_n "(cached) " >&6 -else - printf 0123456789abcdef0123456789abcdef >conftest.i -cat conftest.i conftest.i >conftest2.i -lt_cv_truncate_bin= -if "$ac_cv_path_lt_DD" bs=32 count=1 conftest.out 2>/dev/null; then - cmp -s conftest.i conftest.out \ - && lt_cv_truncate_bin="$ac_cv_path_lt_DD bs=4096 count=1" -fi -rm -f conftest.i conftest2.i conftest.out -test -z "$lt_cv_truncate_bin" && lt_cv_truncate_bin="$SED -e 4q" -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_truncate_bin" >&5 -$as_echo "$lt_cv_truncate_bin" >&6; } - - - - - - - -# Calculate cc_basename. Skip known compiler wrappers and cross-prefix. -func_cc_basename () -{ - for cc_temp in $*""; do - case $cc_temp in - compile | *[\\/]compile | ccache | *[\\/]ccache ) ;; - distcc | *[\\/]distcc | purify | *[\\/]purify ) ;; - \-*) ;; - *) break;; - esac - done - func_cc_basename_result=`$ECHO "$cc_temp" | $SED "s%.*/%%; s%^$host_alias-%%"` -} - -# Check whether --enable-libtool-lock was given. -if test "${enable_libtool_lock+set}" = set; then : - enableval=$enable_libtool_lock; -fi - -test no = "$enable_libtool_lock" || 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 what ABI is being produced by ac_compile, and set mode - # options accordingly. - 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 what ABI is being produced by ac_compile, and set linker - # options accordingly. - echo '#line '$LINENO' "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 yes = "$lt_cv_prog_gnu_ld"; 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* - ;; - -mips64*-*linux*) - # Find out what ABI is being produced by ac_compile, and set linker - # options accordingly. - echo '#line '$LINENO' "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 - emul=elf - case `/usr/bin/file conftest.$ac_objext` in - *32-bit*) - emul="${emul}32" - ;; - *64-bit*) - emul="${emul}64" - ;; - esac - case `/usr/bin/file conftest.$ac_objext` in - *MSB*) - emul="${emul}btsmip" - ;; - *LSB*) - emul="${emul}ltsmip" - ;; - esac - case `/usr/bin/file conftest.$ac_objext` in - *N32*) - emul="${emul}n32" - ;; - esac - LD="${LD-ld} -m $emul" - fi - rm -rf conftest* - ;; - -x86_64-*kfreebsd*-gnu|x86_64-*linux*|powerpc*-*linux*| \ -s390*-*linux*|s390*-*tpf*|sparc*-*linux*) - # Find out what ABI is being produced by ac_compile, and set linker - # options accordingly. Note that the listed cases only cover the - # situations where additional linker options are needed (such as when - # doing 32-bit compilation for a host where ld defaults to 64-bit, or - # vice versa); the common cases where no linker options are needed do - # not appear in the list. - 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*) - case `/usr/bin/file conftest.o` in - *x86-64*) - LD="${LD-ld} -m elf32_x86_64" - ;; - *) - LD="${LD-ld} -m elf_i386" - ;; - esac - ;; - powerpc64le-*linux*) - LD="${LD-ld} -m elf32lppclinux" - ;; - 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" - ;; - powerpcle-*linux*) - LD="${LD-ld} -m elf64lppc" - ;; - 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 ${lt_cv_cc_needs_belf+:} false; 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 yes != "$lt_cv_cc_needs_belf"; then - # this is probably gcc 2.8.0, egcs 1.0 or newer; no need for -belf - CFLAGS=$SAVE_CFLAGS - fi - ;; -*-*solaris*) - # Find out what ABI is being produced by ac_compile, and set linker - # options accordingly. - 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*) - case $host in - i?86-*-solaris*|x86_64-*-solaris*) - LD="${LD-ld} -m elf_x86_64" - ;; - sparc*-*-solaris*) - LD="${LD-ld} -m elf64_sparc" - ;; - esac - # GNU ld 2.21 introduced _sol2 emulations. Use them if available. - if ${LD-ld} -V | grep _sol2 >/dev/null 2>&1; then - LD=${LD-ld}_sol2 - fi - ;; - *) - 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 - -if test -n "$ac_tool_prefix"; then - # Extract the first word of "${ac_tool_prefix}mt", so it can be a program name with args. -set dummy ${ac_tool_prefix}mt; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_MANIFEST_TOOL+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$MANIFEST_TOOL"; then - ac_cv_prog_MANIFEST_TOOL="$MANIFEST_TOOL" # 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 as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_MANIFEST_TOOL="${ac_tool_prefix}mt" - $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 -MANIFEST_TOOL=$ac_cv_prog_MANIFEST_TOOL -if test -n "$MANIFEST_TOOL"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $MANIFEST_TOOL" >&5 -$as_echo "$MANIFEST_TOOL" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - -fi -if test -z "$ac_cv_prog_MANIFEST_TOOL"; then - ac_ct_MANIFEST_TOOL=$MANIFEST_TOOL - # Extract the first word of "mt", so it can be a program name with args. -set dummy mt; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_ac_ct_MANIFEST_TOOL+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$ac_ct_MANIFEST_TOOL"; then - ac_cv_prog_ac_ct_MANIFEST_TOOL="$ac_ct_MANIFEST_TOOL" # 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 as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_ac_ct_MANIFEST_TOOL="mt" - $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_MANIFEST_TOOL=$ac_cv_prog_ac_ct_MANIFEST_TOOL -if test -n "$ac_ct_MANIFEST_TOOL"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_MANIFEST_TOOL" >&5 -$as_echo "$ac_ct_MANIFEST_TOOL" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - if test "x$ac_ct_MANIFEST_TOOL" = x; then - MANIFEST_TOOL=":" - 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 - MANIFEST_TOOL=$ac_ct_MANIFEST_TOOL - fi -else - MANIFEST_TOOL="$ac_cv_prog_MANIFEST_TOOL" -fi - -test -z "$MANIFEST_TOOL" && MANIFEST_TOOL=mt -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking if $MANIFEST_TOOL is a manifest tool" >&5 -$as_echo_n "checking if $MANIFEST_TOOL is a manifest tool... " >&6; } -if ${lt_cv_path_mainfest_tool+:} false; then : - $as_echo_n "(cached) " >&6 -else - lt_cv_path_mainfest_tool=no - echo "$as_me:$LINENO: $MANIFEST_TOOL '-?'" >&5 - $MANIFEST_TOOL '-?' 2>conftest.err > conftest.out - cat conftest.err >&5 - if $GREP 'Manifest Tool' conftest.out > /dev/null; then - lt_cv_path_mainfest_tool=yes - fi - rm -f conftest* -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_path_mainfest_tool" >&5 -$as_echo "$lt_cv_path_mainfest_tool" >&6; } -if test yes != "$lt_cv_path_mainfest_tool"; then - MANIFEST_TOOL=: -fi - - - - - - - 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 ${ac_cv_prog_DSYMUTIL+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_ac_ct_DSYMUTIL+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_NMEDIT+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_ac_ct_NMEDIT+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_LIPO+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_ac_ct_LIPO+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_OTOOL+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_ac_ct_OTOOL+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_OTOOL64+:} false; 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 as_fn_executable_p "$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 ${ac_cv_prog_ac_ct_OTOOL64+:} false; 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 as_fn_executable_p "$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 ${lt_cv_apple_cc_single_mod+:} false; 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 there is a non-empty error log, and "single_module" - # appears in it, assume the flag caused a linker warning - if test -s conftest.err && $GREP single_module conftest.err; then - cat conftest.err >&5 - # Otherwise, if the output was created with a 0 exit code from - # the compiler, it worked. - elif test -f libconftest.dylib && test 0 = "$_lt_result"; 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 ${lt_cv_ld_exported_symbols_list+:} false; 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; } - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for -force_load linker flag" >&5 -$as_echo_n "checking for -force_load linker flag... " >&6; } -if ${lt_cv_ld_force_load+:} false; then : - $as_echo_n "(cached) " >&6 -else - lt_cv_ld_force_load=no - cat > conftest.c << _LT_EOF -int forced_loaded() { return 2;} -_LT_EOF - echo "$LTCC $LTCFLAGS -c -o conftest.o conftest.c" >&5 - $LTCC $LTCFLAGS -c -o conftest.o conftest.c 2>&5 - echo "$AR cru libconftest.a conftest.o" >&5 - $AR cru libconftest.a conftest.o 2>&5 - echo "$RANLIB libconftest.a" >&5 - $RANLIB libconftest.a 2>&5 - cat > conftest.c << _LT_EOF -int main() { return 0;} -_LT_EOF - echo "$LTCC $LTCFLAGS $LDFLAGS -o conftest conftest.c -Wl,-force_load,./libconftest.a" >&5 - $LTCC $LTCFLAGS $LDFLAGS -o conftest conftest.c -Wl,-force_load,./libconftest.a 2>conftest.err - _lt_result=$? - if test -s conftest.err && $GREP force_load conftest.err; then - cat conftest.err >&5 - elif test -f conftest && test 0 = "$_lt_result" && $GREP forced_load conftest >/dev/null 2>&1; then - lt_cv_ld_force_load=yes - else - cat conftest.err >&5 - fi - rm -f conftest.err libconftest.a conftest conftest.c - rm -rf conftest.dSYM - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_ld_force_load" >&5 -$as_echo "$lt_cv_ld_force_load" >&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 yes = "$lt_cv_apple_cc_single_mod"; then - _lt_dar_single_mod='$single_module' - fi - if test yes = "$lt_cv_ld_exported_symbols_list"; 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" && test no = "$lt_cv_ld_force_load"; then - _lt_dsymutil='~$DSYMUTIL $lib || :' - else - _lt_dsymutil= - fi - ;; - esac - -# func_munge_path_list VARIABLE PATH -# ----------------------------------- -# VARIABLE is name of variable containing _space_ separated list of -# directories to be munged by the contents of PATH, which is string -# having a format: -# "DIR[:DIR]:" -# string "DIR[ DIR]" will be prepended to VARIABLE -# ":DIR[:DIR]" -# string "DIR[ DIR]" will be appended to VARIABLE -# "DIRP[:DIRP]::[DIRA:]DIRA" -# string "DIRP[ DIRP]" will be prepended to VARIABLE and string -# "DIRA[ DIRA]" will be appended to VARIABLE -# "DIR[:DIR]" -# VARIABLE will be replaced by "DIR[ DIR]" -func_munge_path_list () -{ - case x$2 in - x) - ;; - *:) - eval $1=\"`$ECHO $2 | $SED 's/:/ /g'` \$$1\" - ;; - x:*) - eval $1=\"\$$1 `$ECHO $2 | $SED 's/:/ /g'`\" - ;; - *::*) - eval $1=\"\$$1\ `$ECHO $2 | $SED -e 's/.*:://' -e 's/:/ /g'`\" - eval $1=\"`$ECHO $2 | $SED -e 's/::.*//' -e 's/:/ /g'`\ \$$1\" - ;; - *) - eval $1=\"`$ECHO $2 | $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 -{ $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 ${ac_cv_prog_CPP+:} false; 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.i 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.i conftest.$ac_ext - -done -# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. -rm -f conftest.i 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.i 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.i conftest.$ac_ext - -done -# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. -rm -f conftest.i 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 ${ac_cv_header_stdc+:} false; 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 -" -if eval test \"x\$"$as_ac_Header"\" = 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" = xyes; then : - cat >>confdefs.h <<_ACEOF -#define HAVE_DLFCN_H 1 -_ACEOF - -fi - -done - - - - - -# Set options -# 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=no -fi - - - - - - - - - - - enable_dlopen=no - - - enable_win32_dll=no - - - - # 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; lt_p=${PACKAGE-default} - case $withval in - yes|no) pic_mode=$withval ;; - *) - pic_mode=default - # Look at the argument we got. We use all the common list separators. - lt_save_ifs=$IFS; IFS=$IFS$PATH_SEPARATOR, - for lt_pkg in $withval; do - IFS=$lt_save_ifs - if test "X$lt_pkg" = "X$lt_p"; then - pic_mode=yes - fi - done - IFS=$lt_save_ifs - ;; - esac -else - pic_mode=default -fi - - - - - - - - - # 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 - - - - - - - - - shared_archive_member_spec= -case $host,$enable_shared in -power*-*-aix[5-9]*,yes) - { $as_echo "$as_me:${as_lineno-$LINENO}: checking which variant of shared library versioning to provide" >&5 -$as_echo_n "checking which variant of shared library versioning to provide... " >&6; } - -# Check whether --with-aix-soname was given. -if test "${with_aix_soname+set}" = set; then : - withval=$with_aix_soname; case $withval in - aix|svr4|both) - ;; - *) - as_fn_error $? "Unknown argument to --with-aix-soname" "$LINENO" 5 - ;; - esac - lt_cv_with_aix_soname=$with_aix_soname -else - if ${lt_cv_with_aix_soname+:} false; then : - $as_echo_n "(cached) " >&6 -else - lt_cv_with_aix_soname=aix -fi - - with_aix_soname=$lt_cv_with_aix_soname -fi - - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $with_aix_soname" >&5 -$as_echo "$with_aix_soname" >&6; } - if test aix != "$with_aix_soname"; then - # For the AIX way of multilib, we name the shared archive member - # based on the bitwidth used, traditionally 'shr.o' or 'shr_64.o', - # and 'shr.imp' or 'shr_64.imp', respectively, for the Import File. - # Even when GNU compilers ignore OBJECT_MODE but need '-maix64' flag, - # the AIX toolchain works better with OBJECT_MODE set (default 32). - if test 64 = "${OBJECT_MODE-32}"; then - shared_archive_member_spec=shr_64 - else - shared_archive_member_spec=shr - fi - fi - ;; -*) - with_aix_soname=aix - ;; -esac - - - - - - - - - - -# 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 ${lt_cv_objdir+:} false; 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 set != "${COLLECT_NAMES+set}"; then - COLLECT_NAMES= - export COLLECT_NAMES - fi - ;; -esac - -# 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 - -func_cc_basename $compiler -cc_basename=$func_cc_basename_result - - -# 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 ${lt_cv_path_MAGIC_CMD+:} false; 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 ${lt_cv_path_MAGIC_CMD+:} false; 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 yes = "$GCC"; then - case $cc_basename in - nvcc*) - lt_prog_compiler_no_builtin_flag=' -Xcompiler -fno-builtin' ;; - *) - lt_prog_compiler_no_builtin_flag=' -fno-builtin' ;; - esac - - { $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 ${lt_cv_prog_compiler_rtti_exceptions+:} false; 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" ## exclude from sc_useless_quotes_in_assignment - # 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:$LINENO: $lt_compile\"" >&5) - (eval "$lt_compile" 2>conftest.err) - ac_status=$? - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $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 "$_lt_compiler_boilerplate" | $SED '/^$/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 yes = "$lt_cv_prog_compiler_rtti_exceptions"; 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= - - - if test yes = "$GCC"; then - lt_prog_compiler_wl='-Wl,' - lt_prog_compiler_static='-static' - - case $host_os in - aix*) - # All AIX code is PIC. - if test ia64 = "$host_cpu"; then - # AIX 5 now supports IA64 processor - lt_prog_compiler_static='-Bstatic' - fi - lt_prog_compiler_pic='-fPIC' - ;; - - 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' - case $host_os in - os2*) - lt_prog_compiler_static='$wl-static' - ;; - esac - ;; - - darwin* | rhapsody*) - # PIC is the default on this platform - # Common symbols not allowed in MH_DYLIB files - lt_prog_compiler_pic='-fno-common' - ;; - - haiku*) - # PIC is the default for Haiku. - # The "-static" flag exists, but is broken. - lt_prog_compiler_static= - ;; - - 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 - - case $cc_basename in - nvcc*) # Cuda Compiler Driver 2.2 - lt_prog_compiler_wl='-Xlinker ' - if test -n "$lt_prog_compiler_pic"; then - lt_prog_compiler_pic="-Xcompiler $lt_prog_compiler_pic" - fi - ;; - 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 ia64 = "$host_cpu"; then - # AIX 5 now supports IA64 processor - lt_prog_compiler_static='-Bstatic' - else - lt_prog_compiler_static='-bnso -bI:/lib/syscalls.exp' - fi - ;; - - darwin* | rhapsody*) - # PIC is the default on this platform - # Common symbols not allowed in MH_DYLIB files - lt_prog_compiler_pic='-fno-common' - case $cc_basename in - nagfor*) - # NAG Fortran compiler - lt_prog_compiler_wl='-Wl,-Wl,,' - lt_prog_compiler_pic='-PIC' - lt_prog_compiler_static='-Bstatic' - ;; - esac - ;; - - 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' - case $host_os in - os2*) - lt_prog_compiler_static='$wl-static' - ;; - esac - ;; - - 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 | kopensolaris*-gnu | 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' - ;; - nagfor*) - # NAG Fortran compiler - lt_prog_compiler_wl='-Wl,-Wl,,' - lt_prog_compiler_pic='-PIC' - lt_prog_compiler_static='-Bstatic' - ;; - tcc*) - # Fabrice Bellard et al's Tiny C Compiler - lt_prog_compiler_wl='-Wl,' - lt_prog_compiler_pic='-fPIC' - lt_prog_compiler_static='-static' - ;; - pgcc* | pgf77* | pgf90* | pgf95* | pgfortran*) - # 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* | bgxl* | bgf* | mpixl*) - # IBM XL C 8.0/Fortran 10.1, 11.1 on PPC and BlueGene - lt_prog_compiler_wl='-Wl,' - lt_prog_compiler_pic='-qpic' - lt_prog_compiler_static='-qstaticlink' - ;; - *) - case `$CC -V 2>&1 | sed 5q` in - *Sun\ Ceres\ Fortran* | *Sun*Fortran*\ [1-7].* | *Sun*Fortran*\ 8.[0-3]*) - # 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='' - ;; - *Sun\ F* | *Sun*Fortran*) - lt_prog_compiler_pic='-KPIC' - lt_prog_compiler_static='-Bstatic' - lt_prog_compiler_wl='-Qoption ld ' - ;; - *Sun\ C*) - # Sun C 5.9 - lt_prog_compiler_pic='-KPIC' - lt_prog_compiler_static='-Bstatic' - lt_prog_compiler_wl='-Wl,' - ;; - *Intel*\ [CF]*Compiler*) - lt_prog_compiler_wl='-Wl,' - lt_prog_compiler_pic='-fPIC' - lt_prog_compiler_static='-static' - ;; - *Portland\ Group*) - lt_prog_compiler_wl='-Wl,' - lt_prog_compiler_pic='-fpic' - lt_prog_compiler_static='-Bstatic' - ;; - 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* | sunf77* | sunf90* | sunf95*) - 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 that 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}: checking for $compiler option to produce PIC" >&5 -$as_echo_n "checking for $compiler option to produce PIC... " >&6; } -if ${lt_cv_prog_compiler_pic+:} false; then : - $as_echo_n "(cached) " >&6 -else - lt_cv_prog_compiler_pic=$lt_prog_compiler_pic -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_pic" >&5 -$as_echo "$lt_cv_prog_compiler_pic" >&6; } -lt_prog_compiler_pic=$lt_cv_prog_compiler_pic - -# -# 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 ${lt_cv_prog_compiler_pic_works+:} false; 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" ## exclude from sc_useless_quotes_in_assignment - # 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:$LINENO: $lt_compile\"" >&5) - (eval "$lt_compile" 2>conftest.err) - ac_status=$? - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $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 "$_lt_compiler_boilerplate" | $SED '/^$/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 yes = "$lt_cv_prog_compiler_pic_works"; 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 ${lt_cv_prog_compiler_static_works+:} false; 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 "$_lt_linker_boilerplate" | $SED '/^$/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 yes = "$lt_cv_prog_compiler_static_works"; 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 ${lt_cv_prog_compiler_c_o+:} false; 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:$LINENO: $lt_compile\"" >&5) - (eval "$lt_compile" 2>out/conftest.err) - ac_status=$? - cat out/conftest.err >&5 - echo "$as_me:$LINENO: \$? = $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 "$_lt_compiler_boilerplate" | $SED '/^$/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 ${lt_cv_prog_compiler_c_o+:} false; 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:$LINENO: $lt_compile\"" >&5) - (eval "$lt_compile" 2>out/conftest.err) - ac_status=$? - cat out/conftest.err >&5 - echo "$as_me:$LINENO: \$? = $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 "$_lt_compiler_boilerplate" | $SED '/^$/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 no = "$lt_cv_prog_compiler_c_o" && test no != "$need_locks"; 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 no = "$hard_links"; 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_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 yes != "$GCC"; then - with_gnu_ld=no - fi - ;; - interix*) - # we just hope/assume this is gcc and not c89 (= MSVC++) - with_gnu_ld=yes - ;; - openbsd* | bitrig*) - with_gnu_ld=no - ;; - esac - - ld_shlibs=yes - - # On some targets, GNU ld is compatible enough with the native linker - # that we're better off using the native interface for both. - lt_use_gnu_ld_interface=no - if test yes = "$with_gnu_ld"; then - case $host_os in - aix*) - # The AIX port of GNU ld has always aspired to compatibility - # with the native linker. However, as the warning in the GNU ld - # block says, versions before 2.19.5* couldn't really create working - # shared libraries, regardless of the interface used. - case `$LD -v 2>&1` in - *\ \(GNU\ Binutils\)\ 2.19.5*) ;; - *\ \(GNU\ Binutils\)\ 2.[2-9]*) ;; - *\ \(GNU\ Binutils\)\ [3-9]*) ;; - *) - lt_use_gnu_ld_interface=yes - ;; - esac - ;; - *) - lt_use_gnu_ld_interface=yes - ;; - esac - fi - - if test yes = "$lt_use_gnu_ld_interface"; 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 | $SED -e 's/(^)\+)\s\+//' 2>&1` in - *GNU\ gold*) supports_anon_versioning=yes ;; - *\ [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 ia64 != "$host_cpu"; then - ld_shlibs=no - cat <<_LT_EOF 1>&2 - -*** Warning: the GNU linker, at least up to release 2.19, 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 install binutils -*** 2.20 or above, or modify your PATH so that a non-GNU linker is found. -*** You will then need to restart the configuration process. - -_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' - export_dynamic_flag_spec='$wl--export-all-symbols' - 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/;s/^.*[ ]__nm__\([^ ]*\)[ ][^ ]*/\1 DATA/;/^I[ ]/d;/^[AITW][ ]/s/.* //'\'' | sort | uniq > $export_symbols' - exclude_expsyms='[_]+GLOBAL_OFFSET_TABLE_|[_]+GLOBAL__[FID]_.*|[_]+head_[A-Za-z0-9_]+_dll|[A-Za-z0-9_]+_dll_iname' - - 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, use it as - # is; otherwise, prepend EXPORTS... - archive_expsym_cmds='if test DEF = "`$SED -n -e '\''s/^[ ]*//'\'' -e '\''/^\(;.*\)*$/d'\'' -e '\''s/^\(EXPORTS\|LIBRARY\)\([ ].*\)*$/DEF/p'\'' -e q $export_symbols`" ; 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 - ;; - - haiku*) - archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' - link_all_deplibs=yes - ;; - - os2*) - hardcode_libdir_flag_spec='-L$libdir' - hardcode_minus_L=yes - allow_undefined_flag=unsupported - shrext_cmds=.dll - archive_cmds='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ - $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ - $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ - $ECHO EXPORTS >> $output_objdir/$libname.def~ - emxexp $libobjs | $SED /"_DLL_InitTerm"/d >> $output_objdir/$libname.def~ - $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ - emximp -o $lib $output_objdir/$libname.def' - archive_expsym_cmds='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ - $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ - $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ - $ECHO EXPORTS >> $output_objdir/$libname.def~ - prefix_cmds="$SED"~ - if test EXPORTS = "`$SED 1q $export_symbols`"; then - prefix_cmds="$prefix_cmds -e 1d"; - fi~ - prefix_cmds="$prefix_cmds -e \"s/^\(.*\)$/_\1/g\""~ - cat $export_symbols | $prefix_cmds >> $output_objdir/$libname.def~ - $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ - emximp -o $lib $output_objdir/$libname.def' - old_archive_From_new_cmds='emximp -o $output_objdir/${libname}_dll.a $output_objdir/$libname.def' - enable_shared_with_static_runtimes=yes - ;; - - 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 | kopensolaris*-gnu) - tmp_diet=no - if test linux-dietlibc = "$host_os"; 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 no = "$tmp_diet" - then - tmp_addflag=' $pic_flag' - 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; func_echo_all \"$new_convenience\"` $wl--no-whole-archive' - tmp_addflag=' $pic_flag' - ;; - pgf77* | pgf90* | pgf95* | pgfortran*) - # 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; func_echo_all \"$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' ;; - nagfor*) # NAGFOR 5.3 - tmp_sharedflag='-Wl,-shared' ;; - xl[cC]* | bgxl[cC]* | mpixl[cC]*) # IBM XL C 8.0 on PPC (deal with xlf below) - tmp_sharedflag='-qmkshrobj' - tmp_addflag= ;; - nvcc*) # Cuda Compiler Driver 2.2 - whole_archive_flag_spec='$wl--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` $wl--no-whole-archive' - compiler_needs_object=yes - ;; - 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; func_echo_all \"$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 yes = "$supports_anon_versioning"; 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 - tcc*) - export_dynamic_flag_spec='-rdynamic' - ;; - xlf* | bgf* | bgxlf* | mpixlf*) - # 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='$wl-rpath $wl$libdir' - archive_cmds='$LD -shared $libobjs $deplibs $linker_flags -soname $soname -o $lib' - if test yes = "$supports_anon_versioning"; 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 $linker_flags -soname $soname -version-script $output_objdir/$libname.ver -o $lib' - fi - ;; - esac - else - ld_shlibs=no - fi - ;; - - netbsd*) - 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 $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' - archive_expsym_cmds='$CC -shared $pic_flag $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 $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' - archive_expsym_cmds='$CC -shared $pic_flag $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 cannot -*** 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 $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' - archive_expsym_cmds='$CC -shared $pic_flag $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 no = "$ld_shlibs"; 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 yes = "$GCC" && 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 ia64 = "$host_cpu"; 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 GNU nm, but means don't demangle to AIX nm. - # Without the "-l" option, or with the "-B" option, AIX nm treats - # weak defined symbols like other global defined symbols, whereas - # GNU nm marks them as "W". - # While the 'weak' keyword is ignored in the Export File, we need - # it in the Import File for the 'aix-soname' feature, so we have - # to replace the "-B" option with "-P" for AIX 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") || (\$ 2 == "W")) && (substr(\$ 3,1,1) != ".")) { if (\$ 2 == "W") { print \$ 3 " weak" } else { print \$ 3 } } }'\'' | sort -u > $export_symbols' - else - export_symbols_cmds='`func_echo_all $NM | $SED -e '\''s/B\([^B]*\)$/P\1/'\''` -PCpgl $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B") || (\$ 2 == "W") || (\$ 2 == "V") || (\$ 2 == "Z")) && (substr(\$ 1,1,1) != ".")) { if ((\$ 2 == "W") || (\$ 2 == "V") || (\$ 2 == "Z")) { print \$ 1 " weak" } else { print \$ 1 } } }'\'' | 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 - # have runtime linking enabled, and use it for executables. - # For shared libraries, we enable/disable runtime linking - # depending on the kind of the shared library created - - # when "with_aix_soname,aix_use_runtimelinking" is: - # "aix,no" lib.a(lib.so.V) shared, rtl:no, for executables - # "aix,yes" lib.so shared, rtl:yes, for executables - # lib.a static archive - # "both,no" lib.so.V(shr.o) shared, rtl:yes - # lib.a(lib.so.V) shared, rtl:no, for executables - # "both,yes" lib.so.V(shr.o) shared, rtl:yes, for executables - # lib.a(lib.so.V) shared, rtl:no - # "svr4,*" lib.so.V(shr.o) shared, rtl:yes, for executables - # lib.a static archive - case $host_os in aix4.[23]|aix4.[23].*|aix[5-9]*) - for ld_flag in $LDFLAGS; do - if (test x-brtl = "x$ld_flag" || test x-Wl,-brtl = "x$ld_flag"); then - aix_use_runtimelinking=yes - break - fi - done - if test svr4,no = "$with_aix_soname,$aix_use_runtimelinking"; then - # With aix-soname=svr4, we create the lib.so.V shared archives only, - # so we don't have lib.a shared libs to link our executables. - # We have to force runtime linking in this case. - aix_use_runtimelinking=yes - LDFLAGS="$LDFLAGS -Wl,-brtl" - fi - ;; - 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,' - case $with_aix_soname,$aix_use_runtimelinking in - aix,*) ;; # traditional, no import file - svr4,* | *,yes) # use import file - # The Import File defines what to hardcode. - hardcode_direct=no - hardcode_direct_absolute=no - ;; - esac - - if test yes = "$GCC"; 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 yes = "$aix_use_runtimelinking"; then - shared_flag="$shared_flag "'$wl-G' - fi - # Need to ensure runtime linking is disabled for the traditional - # shared library, or the linker may eventually find shared libraries - # /with/ Import File - we do not want to mix them. - shared_flag_aix='-shared' - shared_flag_svr4='-shared $wl-G' - else - # not using gcc - if test ia64 = "$host_cpu"; 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 yes = "$aix_use_runtimelinking"; then - shared_flag='$wl-G' - else - shared_flag='$wl-bM:SRE' - fi - shared_flag_aix='$wl-bM:SRE' - shared_flag_svr4='$wl-G' - 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,yes = "$with_aix_soname,$aix_use_runtimelinking"; 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. - if test set = "${lt_cv_aix_libpath+set}"; then - aix_libpath=$lt_cv_aix_libpath -else - if ${lt_cv_aix_libpath_+:} false; then : - $as_echo_n "(cached) " >&6 -else - 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 - } - }' - lt_cv_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 "$lt_cv_aix_libpath_"; then - lt_cv_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 "$lt_cv_aix_libpath_"; then - lt_cv_aix_libpath_=/usr/lib:/lib - fi - -fi - - aix_libpath=$lt_cv_aix_libpath_ -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 -n "$allow_undefined_flag"; then func_echo_all "$wl$allow_undefined_flag"; else :; fi` $wl'$exp_sym_flag:\$export_symbols' '$shared_flag - else - if test ia64 = "$host_cpu"; 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. - if test set = "${lt_cv_aix_libpath+set}"; then - aix_libpath=$lt_cv_aix_libpath -else - if ${lt_cv_aix_libpath_+:} false; then : - $as_echo_n "(cached) " >&6 -else - 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 - } - }' - lt_cv_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 "$lt_cv_aix_libpath_"; then - lt_cv_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 "$lt_cv_aix_libpath_"; then - lt_cv_aix_libpath_=/usr/lib:/lib - fi - -fi - - aix_libpath=$lt_cv_aix_libpath_ -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' - if test yes = "$with_gnu_ld"; then - # We only use this code for GNU lds that support --whole-archive. - whole_archive_flag_spec='$wl--whole-archive$convenience $wl--no-whole-archive' - else - # Exported symbols can be pulled into shared objects from archives - whole_archive_flag_spec='$convenience' - fi - archive_cmds_need_lc=yes - archive_expsym_cmds='$RM -r $output_objdir/$realname.d~$MKDIR $output_objdir/$realname.d' - # -brtl affects multiple linker settings, -berok does not and is overridden later - compiler_flags_filtered='`func_echo_all "$compiler_flags " | $SED -e "s%-brtl\\([, ]\\)%-berok\\1%g"`' - if test svr4 != "$with_aix_soname"; then - # This is similar to how AIX traditionally builds its shared libraries. - archive_expsym_cmds="$archive_expsym_cmds"'~$CC '$shared_flag_aix' -o $output_objdir/$realname.d/$soname $libobjs $deplibs $wl-bnoentry '$compiler_flags_filtered'$wl-bE:$export_symbols$allow_undefined_flag~$AR $AR_FLAGS $output_objdir/$libname$release.a $output_objdir/$realname.d/$soname' - fi - if test aix != "$with_aix_soname"; then - archive_expsym_cmds="$archive_expsym_cmds"'~$CC '$shared_flag_svr4' -o $output_objdir/$realname.d/$shared_archive_member_spec.o $libobjs $deplibs $wl-bnoentry '$compiler_flags_filtered'$wl-bE:$export_symbols$allow_undefined_flag~$STRIP -e $output_objdir/$realname.d/$shared_archive_member_spec.o~( func_echo_all "#! $soname($shared_archive_member_spec.o)"; if test shr_64 = "$shared_archive_member_spec"; then func_echo_all "# 64"; else func_echo_all "# 32"; fi; cat $export_symbols ) > $output_objdir/$realname.d/$shared_archive_member_spec.imp~$AR $AR_FLAGS $output_objdir/$soname $output_objdir/$realname.d/$shared_archive_member_spec.o $output_objdir/$realname.d/$shared_archive_member_spec.imp' - else - # used by -dlpreopen to get the symbols - archive_expsym_cmds="$archive_expsym_cmds"'~$MV $output_objdir/$realname.d/$soname $output_objdir' - fi - archive_expsym_cmds="$archive_expsym_cmds"'~$RM -r $output_objdir/$realname.d' - 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. - case $cc_basename in - cl*) - # Native MSVC - hardcode_libdir_flag_spec=' ' - allow_undefined_flag=unsupported - always_export_symbols=yes - file_list_spec='@' - # 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 $output_objdir/$soname $libobjs $compiler_flags $deplibs -Wl,-DLL,-IMPLIB:"$tool_output_objdir$libname.dll.lib"~linknames=' - archive_expsym_cmds='if test DEF = "`$SED -n -e '\''s/^[ ]*//'\'' -e '\''/^\(;.*\)*$/d'\'' -e '\''s/^\(EXPORTS\|LIBRARY\)\([ ].*\)*$/DEF/p'\'' -e q $export_symbols`" ; then - cp "$export_symbols" "$output_objdir/$soname.def"; - echo "$tool_output_objdir$soname.def" > "$output_objdir/$soname.exp"; - else - $SED -e '\''s/^/-link -EXPORT:/'\'' < $export_symbols > $output_objdir/$soname.exp; - fi~ - $CC -o $tool_output_objdir$soname $libobjs $compiler_flags $deplibs "@$tool_output_objdir$soname.exp" -Wl,-DLL,-IMPLIB:"$tool_output_objdir$libname.dll.lib"~ - linknames=' - # The linker will not automatically build a static lib if we build a DLL. - # _LT_TAGVAR(old_archive_from_new_cmds, )='true' - enable_shared_with_static_runtimes=yes - exclude_expsyms='_NULL_IMPORT_DESCRIPTOR|_IMPORT_DESCRIPTOR_.*' - export_symbols_cmds='$NM $libobjs $convenience | $global_symbol_pipe | $SED -e '\''/^[BCDGRS][ ]/s/.*[ ]\([^ ]*\)/\1,DATA/'\'' | $SED -e '\''/^[AITW][ ]/s/.*[ ]//'\'' | sort | uniq > $export_symbols' - # Don't use ranlib - old_postinstall_cmds='chmod 644 $oldlib' - postlink_cmds='lt_outputfile="@OUTPUT@"~ - lt_tool_outputfile="@TOOL_OUTPUT@"~ - case $lt_outputfile in - *.exe|*.EXE) ;; - *) - lt_outputfile=$lt_outputfile.exe - lt_tool_outputfile=$lt_tool_outputfile.exe - ;; - esac~ - if test : != "$MANIFEST_TOOL" && test -f "$lt_outputfile.manifest"; then - $MANIFEST_TOOL -manifest "$lt_tool_outputfile.manifest" -outputresource:"$lt_tool_outputfile" || exit 1; - $RM "$lt_outputfile.manifest"; - fi' - ;; - *) - # Assume MSVC wrapper - 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 `func_echo_all "$deplibs" | $SED '\''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' - enable_shared_with_static_runtimes=yes - ;; - esac - ;; - - darwin* | rhapsody*) - - - archive_cmds_need_lc=no - hardcode_direct=no - hardcode_automatic=yes - hardcode_shlibpath_var=unsupported - if test yes = "$lt_cv_ld_force_load"; then - whole_archive_flag_spec='`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience $wl-force_load,$conv\"; done; func_echo_all \"$new_convenience\"`' - - else - whole_archive_flag_spec='' - fi - link_all_deplibs=yes - allow_undefined_flag=$_lt_dar_allow_undefined - case $cc_basename in - ifort*|nagfor*) _lt_dar_can_shared=yes ;; - *) _lt_dar_can_shared=$GCC ;; - esac - if test yes = "$_lt_dar_can_shared"; then - output_verbose_link_cmd=func_echo_all - 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 - ;; - - # 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 $pic_flag -o $lib $libobjs $deplibs $compiler_flags' - hardcode_libdir_flag_spec='-R$libdir' - hardcode_direct=yes - hardcode_shlibpath_var=no - ;; - - hpux9*) - if test yes = "$GCC"; then - archive_cmds='$RM $output_objdir/$soname~$CC -shared $pic_flag $wl+b $wl$install_libdir -o $output_objdir/$soname $libobjs $deplibs $compiler_flags~test "x$output_objdir/$soname" = "x$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 "x$output_objdir/$soname" = "x$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 yes,no = "$GCC,$with_gnu_ld"; then - archive_cmds='$CC -shared $pic_flag $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 no = "$with_gnu_ld"; then - hardcode_libdir_flag_spec='$wl+b $wl$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 yes,no = "$GCC,$with_gnu_ld"; 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 $pic_flag $wl+h $wl$soname $wl+nodefaultrpath -o $lib $libobjs $deplibs $compiler_flags' - ;; - *) - archive_cmds='$CC -shared $pic_flag $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' - ;; - *) - - # Older versions of the 11.00 compiler do not understand -b yet - # (HP92453-01 A.11.01.20 doesn't, HP92453-01 B.11.X.35175-35176.GP does) - { $as_echo "$as_me:${as_lineno-$LINENO}: checking if $CC understands -b" >&5 -$as_echo_n "checking if $CC understands -b... " >&6; } -if ${lt_cv_prog_compiler__b+:} false; then : - $as_echo_n "(cached) " >&6 -else - lt_cv_prog_compiler__b=no - save_LDFLAGS=$LDFLAGS - LDFLAGS="$LDFLAGS -b" - 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 "$_lt_linker_boilerplate" | $SED '/^$/d' > conftest.exp - $SED '/^$/d; /^ *+/d' conftest.err >conftest.er2 - if diff conftest.exp conftest.er2 >/dev/null; then - lt_cv_prog_compiler__b=yes - fi - else - lt_cv_prog_compiler__b=yes - fi - fi - $RM -r conftest* - LDFLAGS=$save_LDFLAGS - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler__b" >&5 -$as_echo "$lt_cv_prog_compiler__b" >&6; } - -if test yes = "$lt_cv_prog_compiler__b"; then - archive_cmds='$CC -b $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 - - ;; - esac - fi - if test no = "$with_gnu_ld"; 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 yes = "$GCC"; then - archive_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $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. - # This should be the same for all languages, so no per-tag cache variable. - { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the $host_os linker accepts -exported_symbol" >&5 -$as_echo_n "checking whether the $host_os linker accepts -exported_symbol... " >&6; } -if ${lt_cv_irix_exported_symbol+:} false; then : - $as_echo_n "(cached) " >&6 -else - 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) { return 0; } -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - lt_cv_irix_exported_symbol=yes -else - lt_cv_irix_exported_symbol=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_irix_exported_symbol" >&5 -$as_echo "$lt_cv_irix_exported_symbol" >&6; } - if test yes = "$lt_cv_irix_exported_symbol"; then - archive_expsym_cmds='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $wl-update_registry $wl$output_objdir/so_locations $wl-exports_file $wl$export_symbols -o $lib' - fi - else - archive_cmds='$CC -shared $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -update_registry $output_objdir/so_locations -o $lib' - archive_expsym_cmds='$CC -shared $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -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 - ;; - - linux*) - case $cc_basename in - tcc*) - # Fabrice Bellard et al's Tiny C Compiler - ld_shlibs=yes - archive_cmds='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags' - ;; - esac - ;; - - netbsd*) - 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* | bitrig*) - 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__`"; 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 - archive_cmds='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags' - hardcode_libdir_flag_spec='$wl-rpath,$libdir' - fi - else - ld_shlibs=no - fi - ;; - - os2*) - hardcode_libdir_flag_spec='-L$libdir' - hardcode_minus_L=yes - allow_undefined_flag=unsupported - shrext_cmds=.dll - archive_cmds='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ - $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ - $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ - $ECHO EXPORTS >> $output_objdir/$libname.def~ - emxexp $libobjs | $SED /"_DLL_InitTerm"/d >> $output_objdir/$libname.def~ - $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ - emximp -o $lib $output_objdir/$libname.def' - archive_expsym_cmds='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ - $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ - $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ - $ECHO EXPORTS >> $output_objdir/$libname.def~ - prefix_cmds="$SED"~ - if test EXPORTS = "`$SED 1q $export_symbols`"; then - prefix_cmds="$prefix_cmds -e 1d"; - fi~ - prefix_cmds="$prefix_cmds -e \"s/^\(.*\)$/_\1/g\""~ - cat $export_symbols | $prefix_cmds >> $output_objdir/$libname.def~ - $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ - emximp -o $lib $output_objdir/$libname.def' - old_archive_From_new_cmds='emximp -o $output_objdir/${libname}_dll.a $output_objdir/$libname.def' - enable_shared_with_static_runtimes=yes - ;; - - osf3*) - if test yes = "$GCC"; 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" && func_echo_all "$wl-set_version $wl$verstring"` $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" && func_echo_all "-set_version $verstring"` -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 yes = "$GCC"; then - allow_undefined_flag=' $wl-expect_unresolved $wl\*' - archive_cmds='$CC -shared$allow_undefined_flag $pic_flag $libobjs $deplibs $compiler_flags $wl-msym $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $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" && func_echo_all "-set_version $verstring"` -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 "-set_version $verstring"` -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 yes = "$GCC"; then - wlarc='$wl' - archive_cmds='$CC -shared $pic_flag $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 $pic_flag $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 yes = "$GCC"; 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 sequent = "$host_vendor"; 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 yes = "$GCC"; 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 CANNOT 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 yes = "$GCC"; 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 sni = "$host_vendor"; 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 no = "$ld_shlibs" && 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 yes,yes = "$GCC,$enable_shared"; 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; } -if ${lt_cv_archive_cmds_need_lc+:} false; then : - $as_echo_n "(cached) " >&6 -else - $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 - lt_cv_archive_cmds_need_lc=no - else - lt_cv_archive_cmds_need_lc=yes - fi - allow_undefined_flag=$lt_save_allow_undefined_flag - else - cat conftest.err 1>&5 - fi - $RM conftest* - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $lt_cv_archive_cmds_need_lc" >&5 -$as_echo "$lt_cv_archive_cmds_need_lc" >&6; } - archive_cmds_need_lc=$lt_cv_archive_cmds_need_lc - ;; - 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 yes = "$GCC"; then - case $host_os in - darwin*) lt_awk_arg='/^libraries:/,/LR/' ;; - *) lt_awk_arg='/^libraries:/' ;; - esac - case $host_os in - mingw* | cegcc*) lt_sed_strip_eq='s|=\([A-Za-z]:\)|\1|g' ;; - *) lt_sed_strip_eq='s|=/|/|g' ;; - esac - lt_search_path_spec=`$CC -print-search-dirs | awk $lt_awk_arg | $SED -e "s/^libraries://" -e $lt_sed_strip_eq` - case $lt_search_path_spec in - *\;*) - # 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 's/;/ /g'` - ;; - *) - lt_search_path_spec=`$ECHO "$lt_search_path_spec" | $SED "s/$PATH_SEPARATOR/ /g"` - ;; - esac - # 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` - # ...but if some path component already ends with the multilib dir we assume - # that all is fine and trust -print-search-dirs as is (GCC 4.2? or newer). - case "$lt_multi_os_dir; $lt_search_path_spec " in - "/; "* | "/.; "* | "/./; "* | *"$lt_multi_os_dir "* | *"$lt_multi_os_dir/ "*) - lt_multi_os_dir= - ;; - esac - 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" - elif test -n "$lt_multi_os_dir"; then - 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; } -}'` - # AWK program above erroneously prepends '/' to C:/dos/paths - # for these hosts. - case $host_os in - mingw* | cegcc*) lt_search_path_spec=`$ECHO "$lt_search_path_spec" |\ - $SED 's|/\([A-Za-z]:\)|\1|g'` ;; - esac - sys_lib_search_path_spec=`$ECHO "$lt_search_path_spec" | $lt_NL2SP` -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 # correct to gnu/linux during the next big refactor - 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 # correct to gnu/linux during the next big refactor - need_lib_prefix=no - need_version=no - hardcode_into_libs=yes - if test ia64 = "$host_cpu"; 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 - # Using Import Files as archive members, it is possible to support - # filename-based versioning of shared library archives on AIX. While - # this would work for both with and without runtime linking, it will - # prevent static linking of such archives. So we do filename-based - # shared library versioning with .so extension only, which is used - # when both runtime linking and shared linking is enabled. - # Unfortunately, runtime linking may impact performance, so we do - # not want this to be the default eventually. Also, we use the - # versioned .so libs for executables only if there is the -brtl - # linker flag in LDFLAGS as well, or --with-aix-soname=svr4 only. - # To allow for filename-based versioning support, we need to create - # libNAME.so.V as an archive file, containing: - # *) an Import File, referring to the versioned filename of the - # archive as well as the shared archive member, telling the - # bitwidth (32 or 64) of that shared object, and providing the - # list of exported symbols of that shared object, eventually - # decorated with the 'weak' keyword - # *) the shared object with the F_LOADONLY flag set, to really avoid - # it being seen by the linker. - # At run time we better use the real file rather than another symlink, - # but for link time we create the symlink libNAME.so -> libNAME.so.V - - case $with_aix_soname,$aix_use_runtimelinking in - # AIX (on Power*) has no versioning support, so currently we cannot hardcode correct - # soname into executable. Probably we can add versioning support to - # collect2, so additional links can be useful in future. - aix,yes) # traditional libtool - dynamic_linker='AIX unversionable lib.so' - # 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' - ;; - aix,no) # traditional AIX only - dynamic_linker='AIX lib.a(lib.so.V)' - # 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' - ;; - svr4,*) # full svr4 only - dynamic_linker="AIX lib.so.V($shared_archive_member_spec.o)" - library_names_spec='$libname$release$shared_ext$major $libname$shared_ext' - # We do not specify a path in Import Files, so LIBPATH fires. - shlibpath_overrides_runpath=yes - ;; - *,yes) # both, prefer svr4 - dynamic_linker="AIX lib.so.V($shared_archive_member_spec.o), lib.a(lib.so.V)" - library_names_spec='$libname$release$shared_ext$major $libname$shared_ext' - # unpreferred sharedlib libNAME.a needs extra handling - postinstall_cmds='test -n "$linkname" || linkname="$realname"~func_stripname "" ".so" "$linkname"~$install_shared_prog "$dir/$func_stripname_result.$libext" "$destdir/$func_stripname_result.$libext"~test -z "$tstripme" || test -z "$striplib" || $striplib "$destdir/$func_stripname_result.$libext"' - postuninstall_cmds='for n in $library_names $old_library; do :; done~func_stripname "" ".so" "$n"~test "$func_stripname_result" = "$n" || func_append rmfiles " $odir/$func_stripname_result.$libext"' - # We do not specify a path in Import Files, so LIBPATH fires. - shlibpath_overrides_runpath=yes - ;; - *,no) # both, prefer aix - dynamic_linker="AIX lib.a(lib.so.V), lib.so.V($shared_archive_member_spec.o)" - library_names_spec='$libname$release.a $libname.a' - soname_spec='$libname$release$shared_ext$major' - # unpreferred sharedlib libNAME.so.V and symlink libNAME.so need extra handling - postinstall_cmds='test -z "$dlname" || $install_shared_prog $dir/$dlname $destdir/$dlname~test -z "$tstripme" || test -z "$striplib" || $striplib $destdir/$dlname~test -n "$linkname" || linkname=$realname~func_stripname "" ".a" "$linkname"~(cd "$destdir" && $LN_S -f $dlname $func_stripname_result.so)' - postuninstall_cmds='test -z "$dlname" || func_append rmfiles " $odir/$dlname"~for n in $old_library $library_names; do :; done~func_stripname "" ".a" "$n"~func_append rmfiles " $odir/$func_stripname_result.so"' - ;; - esac - 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=`func_echo_all "$lib" | $SED '\''s%^.*/\([^/]*\)\.ixlibrary$%\1%'\''`; $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 # correct to gnu/linux during the next big refactor - 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,$cc_basename in - yes,*) - # gcc - 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="$sys_lib_search_path_spec /usr/lib/w32api" - ;; - mingw* | cegcc*) - # MinGW DLLs use traditional 'lib' prefix - soname_spec='$libname`echo $release | $SED -e 's/[.]/-/g'`$versuffix$shared_ext' - ;; - 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 - dynamic_linker='Win32 ld.exe' - ;; - - *,cl*) - # Native MSVC - libname_spec='$name' - soname_spec='$libname`echo $release | $SED -e 's/[.]/-/g'`$versuffix$shared_ext' - library_names_spec='$libname.dll.lib' - - case $build_os in - mingw*) - sys_lib_search_path_spec= - lt_save_ifs=$IFS - IFS=';' - for lt_path in $LIB - do - IFS=$lt_save_ifs - # Let DOS variable expansion print the short 8.3 style file name. - lt_path=`cd "$lt_path" 2>/dev/null && cmd //C "for %i in (".") do @echo %~si"` - sys_lib_search_path_spec="$sys_lib_search_path_spec $lt_path" - done - IFS=$lt_save_ifs - # Convert to MSYS style. - sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | sed -e 's|\\\\|/|g' -e 's| \\([a-zA-Z]\\):| /\\1|g' -e 's|^ ||'` - ;; - cygwin*) - # Convert to unix form, then to dos form, then back to unix form - # but this time dos style (no spaces!) so that the unix form looks - # like /cygdrive/c/PROGRA~1:/cygdr... - sys_lib_search_path_spec=`cygpath --path --unix "$LIB"` - sys_lib_search_path_spec=`cygpath --path --dos "$sys_lib_search_path_spec" 2>/dev/null` - sys_lib_search_path_spec=`cygpath --path --unix "$sys_lib_search_path_spec" | $SED -e "s/$PATH_SEPARATOR/ /g"` - ;; - *) - sys_lib_search_path_spec=$LIB - if $ECHO "$sys_lib_search_path_spec" | $GREP ';[c-zC-Z]:/' >/dev/null; then - # It is most probably a Windows format PATH. - 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 - # FIXME: find the short name or the path components, as spaces are - # common. (e.g. "Program Files" -> "PROGRA~1") - ;; - esac - - # 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' - postuninstall_cmds='dldll=`$SHELL 2>&1 -c '\''. $file; echo \$dlname'\''`~ - dlpath=$dir/\$dldll~ - $RM \$dlpath' - shlibpath_overrides_runpath=yes - dynamic_linker='Win32 link.exe' - ;; - - *) - # Assume MSVC wrapper - library_names_spec='$libname`echo $release | $SED -e 's/[.]/-/g'`$versuffix$shared_ext $libname.lib' - dynamic_linker='Win32 ld.exe' - ;; - esac - # 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 # correct to gnu/linux during the next big refactor - 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 - ;; - -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[23].*) 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$major $libname$shared_ext' - soname_spec='$libname$release$shared_ext$major' - 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 - ;; - -haiku*) - version_type=linux # correct to gnu/linux during the next big refactor - need_lib_prefix=no - need_version=no - dynamic_linker="$host_os runtime_loader" - 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=LIBRARY_PATH - shlibpath_overrides_runpath=no - sys_lib_dlsearch_path_spec='/boot/home/config/lib /boot/common/lib /boot/system/lib' - 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 32 = "$HPUX_IA64_MODE"; then - sys_lib_search_path_spec="/usr/lib/hpux32 /usr/local/lib/hpux32 /usr/local/lib" - sys_lib_dlsearch_path_spec=/usr/lib/hpux32 - else - sys_lib_search_path_spec="/usr/lib/hpux64 /usr/local/lib/hpux64" - sys_lib_dlsearch_path_spec=/usr/lib/hpux64 - fi - ;; - 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' - # or fails outright, so override atomically: - install_override_mode=555 - ;; - -interix[3-9]*) - version_type=linux # correct to gnu/linux during the next big refactor - 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 yes = "$lt_cv_prog_gnu_ld"; then - version_type=linux # correct to gnu/linux during the next big refactor - 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 - ;; - -linux*android*) - version_type=none # Android doesn't support versioned libraries. - need_lib_prefix=no - need_version=no - library_names_spec='$libname$release$shared_ext' - soname_spec='$libname$release$shared_ext' - finish_cmds= - shlibpath_var=LD_LIBRARY_PATH - shlibpath_overrides_runpath=yes - - # 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 - - dynamic_linker='Android linker' - # Don't embed -rpath directories since the linker doesn't support them. - hardcode_libdir_flag_spec='-L$libdir' - ;; - -# This must be glibc/ELF. -linux* | k*bsd*-gnu | kopensolaris*-gnu | gnu*) - version_type=linux # correct to gnu/linux during the next big refactor - 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 - if ${lt_cv_shlibpath_overrides_runpath+:} false; then : - $as_echo_n "(cached) " >&6 -else - lt_cv_shlibpath_overrides_runpath=no - 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 : - lt_cv_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 - -fi - - shlibpath_overrides_runpath=$lt_cv_shlibpath_overrides_runpath - - # 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 - - # Ideally, we could use ldconfig to report *all* directores which are - # searched for libraries, however this is still not possible. Aside from not - # being certain /sbin/ldconfig is available, command - # 'ldconfig -N -X -v | grep ^/' on 64bit Fedora does not report /usr/lib64, - # even though it is searched at run-time. Try to do the best guess by - # appending ld.so.conf contents (and includes) 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;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' - ;; - -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 # correct to gnu/linux during the next big refactor - 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* | bitrig*) - version_type=sunos - sys_lib_dlsearch_path_spec=/usr/lib - need_lib_prefix=no - if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`"; then - need_version=no - else - need_version=yes - fi - 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 - shlibpath_overrides_runpath=yes - ;; - -os2*) - libname_spec='$name' - version_type=windows - shrext_cmds=.dll - need_version=no - need_lib_prefix=no - # OS/2 can only load a DLL with a base name of 8 characters or less. - soname_spec='`test -n "$os2dllname" && libname="$os2dllname"; - v=$($ECHO $release$versuffix | tr -d .-); - n=$($ECHO $libname | cut -b -$((8 - ${#v})) | tr . _); - $ECHO $n$v`$shared_ext' - library_names_spec='${libname}_dll.$libext' - dynamic_linker='OS/2 ld.exe' - shlibpath_var=BEGINLIBPATH - sys_lib_search_path_spec="/lib /usr/lib /usr/local/lib" - sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec - 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' - ;; - -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 # correct to gnu/linux during the next big refactor - 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 yes = "$with_gnu_ld"; then - need_lib_prefix=no - fi - need_version=yes - ;; - -sysv4 | sysv4.3*) - version_type=linux # correct to gnu/linux during the next big refactor - 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 # correct to gnu/linux during the next big refactor - 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=sco - 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 yes = "$with_gnu_ld"; 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 # correct to gnu/linux during the next big refactor - 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 # correct to gnu/linux during the next big refactor - 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 no = "$dynamic_linker" && can_build_shared=no - -variables_saved_for_relink="PATH $shlibpath_var $runpath_var" -if test yes = "$GCC"; then - variables_saved_for_relink="$variables_saved_for_relink GCC_EXEC_PREFIX COMPILER_PATH LIBRARY_PATH" -fi - -if test set = "${lt_cv_sys_lib_search_path_spec+set}"; then - sys_lib_search_path_spec=$lt_cv_sys_lib_search_path_spec -fi - -if test set = "${lt_cv_sys_lib_dlsearch_path_spec+set}"; then - sys_lib_dlsearch_path_spec=$lt_cv_sys_lib_dlsearch_path_spec -fi - -# remember unaugmented sys_lib_dlsearch_path content for libtool script decls... -configure_time_dlsearch_path=$sys_lib_dlsearch_path_spec - -# ... but it needs LT_SYS_LIBRARY_PATH munging for other configure-time code -func_munge_path_list sys_lib_dlsearch_path_spec "$LT_SYS_LIBRARY_PATH" - -# to be used as default LT_SYS_LIBRARY_PATH value in generated libtool -configure_time_lt_sys_library_path=$LT_SYS_LIBRARY_PATH - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - { $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 yes = "$hardcode_automatic"; then - - # We can hardcode non-existent directories. - if test no != "$hardcode_direct" && - # 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 no != "$_LT_TAGVAR(hardcode_shlibpath_var, )" && - test no != "$hardcode_minus_L"; 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 relink = "$hardcode_action" || - test yes = "$inherit_rpath"; then - # Fast installation is not supported - enable_fast_install=no -elif test yes = "$shlibpath_overrides_runpath" || - test no = "$enable_shared"; then - # Fast installation is not necessary - enable_fast_install=needless -fi - - - - - - - if test yes != "$enable_dlopen"; 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 ${ac_cv_lib_dl_dlopen+:} false; 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" = xyes; 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 - - ;; - - tpf*) - # Don't try to run any link tests for TPF. We know it's impossible - # because TPF is a cross-compiler, and we know how we open DSOs. - lt_cv_dlopen=dlopen - lt_cv_dlopen_libs= - lt_cv_dlopen_self=no - ;; - - *) - ac_fn_c_check_func "$LINENO" "shl_load" "ac_cv_func_shl_load" -if test "x$ac_cv_func_shl_load" = xyes; 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 ${ac_cv_lib_dld_shl_load+:} false; 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" = xyes; 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" = xyes; 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 ${ac_cv_lib_dl_dlopen+:} false; 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" = xyes; 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 ${ac_cv_lib_svld_dlopen+:} false; 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" = xyes; 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 ${ac_cv_lib_dld_dld_link+:} false; 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" = xyes; then : - lt_cv_dlopen=dld_link lt_cv_dlopen_libs=-ldld -fi - - -fi - - -fi - - -fi - - -fi - - -fi - - ;; - esac - - if test no = "$lt_cv_dlopen"; then - enable_dlopen=no - else - enable_dlopen=yes - fi - - case $lt_cv_dlopen in - dlopen) - save_CPPFLAGS=$CPPFLAGS - test yes = "$ac_cv_header_dlfcn_h" && 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 ${lt_cv_dlopen_self+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test yes = "$cross_compiling"; 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 $LINENO "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 - -/* When -fvisibility=hidden is used, assume the code has been annotated - correspondingly for the symbols needed. */ -#if defined __GNUC__ && (((__GNUC__ == 3) && (__GNUC_MINOR__ >= 3)) || (__GNUC__ > 3)) -int fnord () __attribute__((visibility("default"))); -#endif - -int fnord () { return 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; - else puts (dlerror ()); - } - /* 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 yes = "$lt_cv_dlopen_self"; 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 ${lt_cv_dlopen_self_static+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test yes = "$cross_compiling"; 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 $LINENO "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 - -/* When -fvisibility=hidden is used, assume the code has been annotated - correspondingly for the symbols needed. */ -#if defined __GNUC__ && (((__GNUC__ == 3) && (__GNUC_MINOR__ >= 3)) || (__GNUC__ > 3)) -int fnord () __attribute__((visibility("default"))); -#endif - -int fnord () { return 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; - else puts (dlerror ()); - } - /* 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 what 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 no = "$can_build_shared" && 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 yes = "$enable_shared" && enable_static=no - if test -n "$RANLIB"; then - archive_cmds="$archive_cmds~\$RANLIB \$lib" - postinstall_cmds='$RANLIB $lib' - fi - ;; - - aix[4-9]*) - if test ia64 != "$host_cpu"; then - case $enable_shared,$with_aix_soname,$aix_use_runtimelinking in - yes,aix,yes) ;; # shared object as lib.so file only - yes,svr4,*) ;; # shared object as lib.so archive member only - yes,*) enable_static=no ;; # shared object in lib.a archive as well - esac - 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 yes = "$enable_shared" || 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: - - - -# Checks for functions. - - - - for ac_header in $ac_header_list -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 -" -if eval test \"x\$"$as_ac_Header"\" = 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" = xyes; 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 ${ac_cv_func_mmap_fixed_mapped+:} false; 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 -# 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; - const char *cdata2; - int i, pagesize; - int fd, fd2; - - 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 2; - if (write (fd, data, pagesize) != pagesize) - return 3; - close (fd); - - /* Next, check that the tail of a page is zero-filled. File must have - non-zero length, otherwise we risk SIGBUS for entire page. */ - fd2 = open ("conftest.txt", O_RDWR | O_CREAT | O_TRUNC, 0600); - if (fd2 < 0) - return 4; - cdata2 = ""; - if (write (fd2, cdata2, 1) != 1) - return 5; - data2 = (char *) mmap (0, pagesize, PROT_READ | PROT_WRITE, MAP_SHARED, fd2, 0L); - if (data2 == MAP_FAILED) - return 6; - for (i = 0; i < pagesize; ++i) - if (*(data2 + i)) - return 7; - close (fd2); - if (munmap (data2, pagesize)) - return 8; - - /* 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 9; - if (data2 != mmap (data2, pagesize, PROT_READ | PROT_WRITE, - MAP_PRIVATE | MAP_FIXED, fd, 0L)) - return 10; - for (i = 0; i < pagesize; ++i) - if (*(data + i) != *(data2 + i)) - return 11; - - /* 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 12; - if (read (fd, data3, pagesize) != pagesize) - return 13; - for (i = 0; i < pagesize; ++i) - if (*(data + i) != *(data3 + i)) - return 14; - 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 conftest.txt - - -# Determine PIC flag. -need_asm=false -PICFLAG= -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for PIC compiler flag" >&5 -$as_echo_n "checking for PIC compiler flag... " >&6; } -if test "$GCC" = yes; then - case "$host" in - *-*-cygwin* | *-*-mingw*) - # Cygwin and Mingw[-w32/64] do not need -fPIC. - { $as_echo "$as_me:${as_lineno-$LINENO}: result: \"\"" >&5 -$as_echo "\"\"" >&6; } - ;; - *) - { $as_echo "$as_me:${as_lineno-$LINENO}: result: -fPIC" >&5 -$as_echo "-fPIC" >&6; } - PICFLAG=-fPIC - { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether gcc -fPIC causes __PIC__ definition" >&5 -$as_echo_n "checking whether gcc -fPIC causes __PIC__ definition... " >&6; } - # Workaround: at least GCC 3.4.6 (Solaris) does not define this macro. - old_CFLAGS="$CFLAGS" - CFLAGS="$PICFLAG $CFLAGS" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - #ifndef __PIC__ - # error - #endif - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_cv_pic_macro=yes -else - ac_cv_pic_macro=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - CFLAGS="$old_CFLAGS" - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_pic_macro" >&5 -$as_echo "$ac_cv_pic_macro" >&6; } - if test "$ac_cv_pic_macro" = yes; then : - -else - PICFLAG="-D__PIC__=1 $PICFLAG" -fi - ;; - esac - - # Output all warnings. - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for gcc -Wextra" >&5 -$as_echo_n "checking for gcc -Wextra... " >&6; } - old_CFLAGS="$CFLAGS" - CFLAGS="-Wextra $CFLAGS" - 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_cc_wextra=yes -else - ac_cv_cc_wextra=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - CFLAGS="$old_CFLAGS" - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_cc_wextra" >&5 -$as_echo "$ac_cv_cc_wextra" >&6; } - if test "$ac_cv_cc_wextra" = yes; then : - WEXTRA="-Wextra" -else - WEXTRA="-W" -fi - CFLAGS="-Wall $WEXTRA $CFLAGS" - - # Check whether --enable-werror was given. -if test "${enable_werror+set}" = set; then : - enableval=$enable_werror; -fi - - if test "$enable_werror" = yes; then - CFLAGS="-Werror $CFLAGS" - fi -else - case "$host" in - *-*-hpux*) - { $as_echo "$as_me:${as_lineno-$LINENO}: result: \"+Z\"" >&5 -$as_echo "\"+Z\"" >&6; } - PICFLAG="+Z" - CFLAGS="+O2 -mt $CFLAGS" - ;; - *-*-solaris*) - { $as_echo "$as_me:${as_lineno-$LINENO}: result: -Kpic" >&5 -$as_echo "-Kpic" >&6; } - PICFLAG=-Kpic - CFLAGS="-O $CFLAGS" - need_asm=true - ;; - *-*-linux*) - { $as_echo "$as_me:${as_lineno-$LINENO}: result: -fPIC" >&5 -$as_echo "-fPIC" >&6; } - PICFLAG=-fPIC - # Any Linux compiler had better be gcc compatible. - ;; - *) - { $as_echo "$as_me:${as_lineno-$LINENO}: result: \"\"" >&5 -$as_echo "\"\"" >&6; } - ;; - esac -fi - -# Check whether --enable-assertions was given. -if test "${enable_assertions+set}" = set; then : - enableval=$enable_assertions; -fi - -if test "$enable_assertions" != yes; then - -$as_echo "#define NDEBUG 1" >>confdefs.h - -fi - - - - - - - - - - - -# These macros are tested in public headers - - - - - - - - - - - - - - - - - -$as_echo "#define _REENTRANT 1" >>confdefs.h - - -# Libraries needed to support threads (if any). -have_pthreads=false -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for pthread_self in -lpthread" >&5 -$as_echo_n "checking for pthread_self in -lpthread... " >&6; } -if ${ac_cv_lib_pthread_pthread_self+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_check_lib_save_LIBS=$LIBS -LIBS="-lpthread $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 pthread_self (); -int -main () -{ -return pthread_self (); - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - ac_cv_lib_pthread_pthread_self=yes -else - ac_cv_lib_pthread_pthread_self=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_pthread_pthread_self" >&5 -$as_echo "$ac_cv_lib_pthread_pthread_self" >&6; } -if test "x$ac_cv_lib_pthread_pthread_self" = xyes; then : - have_pthreads=true -fi - -if test x$have_pthreads = xtrue; then - THREADDLLIBS=-lpthread - case "$host" in - *-*-netbsd*) - # Indicates the use of pthreads. - $as_echo "#define _PTHREADS 1" >>confdefs.h - - ;; - *-*-openbsd* | *-*-kfreebsd*-gnu | *-*-dgux*) - THREADDLLIBS=-pthread - ;; - *-*-cygwin* | *-*-darwin*) - # Cygwin does not have a real libpthread, so Libtool cannot link - # against it. - THREADDLLIBS= - ;; - *-*-mingw*) - # Use Win32 threads for tests anyway. - THREADDLLIBS= - # Skip test_atomic_pthreads. - have_pthreads=false - ;; - esac -else - -$as_echo "#define AO_NO_PTHREADS 1" >>confdefs.h - - # Assume VxWorks or Win32. - THREADDLLIBS= -fi - - - if test x$have_pthreads = xtrue; then - HAVE_PTHREAD_H_TRUE= - HAVE_PTHREAD_H_FALSE='#' -else - HAVE_PTHREAD_H_TRUE='#' - HAVE_PTHREAD_H_FALSE= -fi - - if test x$need_asm = xtrue; then - NEED_ASM_TRUE= - NEED_ASM_FALSE='#' -else - NEED_ASM_TRUE='#' - NEED_ASM_FALSE= -fi - - -ac_config_files="$ac_config_files Makefile doc/Makefile src/Makefile tests/Makefile pkgconfig/atomic_ops.pc pkgconfig/atomic_ops-uninstalled.pc" - - -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 - if test "x$cache_file" != "x/dev/null"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 -$as_echo "$as_me: updating cache $cache_file" >&6;} - if test ! -f "$cache_file" || test -h "$cache_file"; then - cat confcache >"$cache_file" - else - case $cache_file in #( - */* | ?:*) - mv -f confcache "$cache_file"$$ && - mv -f "$cache_file"$$ "$cache_file" ;; #( - *) - mv -f confcache "$cache_file" ;; - esac - fi - fi - 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= -U= -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 - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking that generated files are newer than configure" >&5 -$as_echo_n "checking that generated files are newer than configure... " >&6; } - if test -n "$am_sleep_pid"; then - # Hide warnings about reused PIDs. - wait $am_sleep_pid 2>/dev/null - fi - { $as_echo "$as_me:${as_lineno-$LINENO}: result: done" >&5 -$as_echo "done" >&6; } - if test -n "$EXEEXT"; then - am__EXEEXT_TRUE= - am__EXEEXT_FALSE='#' -else - am__EXEEXT_TRUE='#' - am__EXEEXT_FALSE= -fi - -if test -z "${MAINTAINER_MODE_TRUE}" && test -z "${MAINTAINER_MODE_FALSE}"; then - as_fn_error $? "conditional \"MAINTAINER_MODE\" was never defined. -Usually this means the macro was only invoked conditionally." "$LINENO" 5 -fi -if test -z "${AMDEP_TRUE}" && test -z "${AMDEP_FALSE}"; then - as_fn_error $? "conditional \"AMDEP\" was never defined. -Usually this means the macro was only invoked conditionally." "$LINENO" 5 -fi -if test -z "${am__fastdepCC_TRUE}" && test -z "${am__fastdepCC_FALSE}"; then - as_fn_error $? "conditional \"am__fastdepCC\" was never defined. -Usually this means the macro was only invoked conditionally." "$LINENO" 5 -fi -if test -z "${am__fastdepCCAS_TRUE}" && test -z "${am__fastdepCCAS_FALSE}"; then - as_fn_error $? "conditional \"am__fastdepCCAS\" was never defined. -Usually this means the macro was only invoked conditionally." "$LINENO" 5 -fi -if test -z "${HAVE_PTHREAD_H_TRUE}" && test -z "${HAVE_PTHREAD_H_FALSE}"; then - as_fn_error $? "conditional \"HAVE_PTHREAD_H\" was never defined. -Usually this means the macro was only invoked conditionally." "$LINENO" 5 -fi -if test -z "${NEED_ASM_TRUE}" && test -z "${NEED_ASM_FALSE}"; then - as_fn_error $? "conditional \"NEED_ASM\" was never defined. -Usually this means the macro was only invoked conditionally." "$LINENO" 5 -fi - -: "${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. -as_myself= -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 STATUS 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=$1; test $as_status -eq 0 && as_status=1 - if test "$4"; then - as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 - fi - $as_echo "$as_me: error: $2" >&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 -pR'. - ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || - as_ln_s='cp -pR' - elif ln conf$$.file conf$$ 2>/dev/null; then - as_ln_s=ln - else - as_ln_s='cp -pR' - fi -else - as_ln_s='cp -pR' -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 - - -# as_fn_executable_p FILE -# ----------------------- -# Test if FILE is an executable regular file. -as_fn_executable_p () -{ - test -f "$1" && test -x "$1" -} # as_fn_executable_p -as_test_x='test -x' -as_executable_p=as_fn_executable_p - -# 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 libatomic_ops $as_me 7.5.0, which was -generated by GNU Autoconf 2.69. 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 - --config print configuration, 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 ." - -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" -ac_cs_version="\\ -libatomic_ops config.status 7.5.0 -configured by $0, generated by GNU Autoconf 2.69, - with options \\"\$ac_cs_config\\" - -Copyright (C) 2012 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' -MKDIR_P='$MKDIR_P' -AWK='$AWK' -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=`expr "X$1" : 'X\([^=]*\)='` - ac_optarg= - 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 ;; - --config | --confi | --conf | --con | --co | --c ) - $as_echo "$ac_cs_config"; 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"` ;; - '') as_fn_error $? "missing file argument" ;; - 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 -# -AMDEP_TRUE="$AMDEP_TRUE" ac_aux_dir="$ac_aux_dir" - - -# 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 "$macro_version" | $SED "$delay_single_quote_subst"`' -macro_revision='`$ECHO "$macro_revision" | $SED "$delay_single_quote_subst"`' -enable_shared='`$ECHO "$enable_shared" | $SED "$delay_single_quote_subst"`' -enable_static='`$ECHO "$enable_static" | $SED "$delay_single_quote_subst"`' -pic_mode='`$ECHO "$pic_mode" | $SED "$delay_single_quote_subst"`' -enable_fast_install='`$ECHO "$enable_fast_install" | $SED "$delay_single_quote_subst"`' -shared_archive_member_spec='`$ECHO "$shared_archive_member_spec" | $SED "$delay_single_quote_subst"`' -SHELL='`$ECHO "$SHELL" | $SED "$delay_single_quote_subst"`' -ECHO='`$ECHO "$ECHO" | $SED "$delay_single_quote_subst"`' -PATH_SEPARATOR='`$ECHO "$PATH_SEPARATOR" | $SED "$delay_single_quote_subst"`' -host_alias='`$ECHO "$host_alias" | $SED "$delay_single_quote_subst"`' -host='`$ECHO "$host" | $SED "$delay_single_quote_subst"`' -host_os='`$ECHO "$host_os" | $SED "$delay_single_quote_subst"`' -build_alias='`$ECHO "$build_alias" | $SED "$delay_single_quote_subst"`' -build='`$ECHO "$build" | $SED "$delay_single_quote_subst"`' -build_os='`$ECHO "$build_os" | $SED "$delay_single_quote_subst"`' -SED='`$ECHO "$SED" | $SED "$delay_single_quote_subst"`' -Xsed='`$ECHO "$Xsed" | $SED "$delay_single_quote_subst"`' -GREP='`$ECHO "$GREP" | $SED "$delay_single_quote_subst"`' -EGREP='`$ECHO "$EGREP" | $SED "$delay_single_quote_subst"`' -FGREP='`$ECHO "$FGREP" | $SED "$delay_single_quote_subst"`' -LD='`$ECHO "$LD" | $SED "$delay_single_quote_subst"`' -NM='`$ECHO "$NM" | $SED "$delay_single_quote_subst"`' -LN_S='`$ECHO "$LN_S" | $SED "$delay_single_quote_subst"`' -max_cmd_len='`$ECHO "$max_cmd_len" | $SED "$delay_single_quote_subst"`' -ac_objext='`$ECHO "$ac_objext" | $SED "$delay_single_quote_subst"`' -exeext='`$ECHO "$exeext" | $SED "$delay_single_quote_subst"`' -lt_unset='`$ECHO "$lt_unset" | $SED "$delay_single_quote_subst"`' -lt_SP2NL='`$ECHO "$lt_SP2NL" | $SED "$delay_single_quote_subst"`' -lt_NL2SP='`$ECHO "$lt_NL2SP" | $SED "$delay_single_quote_subst"`' -lt_cv_to_host_file_cmd='`$ECHO "$lt_cv_to_host_file_cmd" | $SED "$delay_single_quote_subst"`' -lt_cv_to_tool_file_cmd='`$ECHO "$lt_cv_to_tool_file_cmd" | $SED "$delay_single_quote_subst"`' -reload_flag='`$ECHO "$reload_flag" | $SED "$delay_single_quote_subst"`' -reload_cmds='`$ECHO "$reload_cmds" | $SED "$delay_single_quote_subst"`' -OBJDUMP='`$ECHO "$OBJDUMP" | $SED "$delay_single_quote_subst"`' -deplibs_check_method='`$ECHO "$deplibs_check_method" | $SED "$delay_single_quote_subst"`' -file_magic_cmd='`$ECHO "$file_magic_cmd" | $SED "$delay_single_quote_subst"`' -file_magic_glob='`$ECHO "$file_magic_glob" | $SED "$delay_single_quote_subst"`' -want_nocaseglob='`$ECHO "$want_nocaseglob" | $SED "$delay_single_quote_subst"`' -DLLTOOL='`$ECHO "$DLLTOOL" | $SED "$delay_single_quote_subst"`' -sharedlib_from_linklib_cmd='`$ECHO "$sharedlib_from_linklib_cmd" | $SED "$delay_single_quote_subst"`' -AR='`$ECHO "$AR" | $SED "$delay_single_quote_subst"`' -AR_FLAGS='`$ECHO "$AR_FLAGS" | $SED "$delay_single_quote_subst"`' -archiver_list_spec='`$ECHO "$archiver_list_spec" | $SED "$delay_single_quote_subst"`' -STRIP='`$ECHO "$STRIP" | $SED "$delay_single_quote_subst"`' -RANLIB='`$ECHO "$RANLIB" | $SED "$delay_single_quote_subst"`' -old_postinstall_cmds='`$ECHO "$old_postinstall_cmds" | $SED "$delay_single_quote_subst"`' -old_postuninstall_cmds='`$ECHO "$old_postuninstall_cmds" | $SED "$delay_single_quote_subst"`' -old_archive_cmds='`$ECHO "$old_archive_cmds" | $SED "$delay_single_quote_subst"`' -lock_old_archive_extraction='`$ECHO "$lock_old_archive_extraction" | $SED "$delay_single_quote_subst"`' -CC='`$ECHO "$CC" | $SED "$delay_single_quote_subst"`' -CFLAGS='`$ECHO "$CFLAGS" | $SED "$delay_single_quote_subst"`' -compiler='`$ECHO "$compiler" | $SED "$delay_single_quote_subst"`' -GCC='`$ECHO "$GCC" | $SED "$delay_single_quote_subst"`' -lt_cv_sys_global_symbol_pipe='`$ECHO "$lt_cv_sys_global_symbol_pipe" | $SED "$delay_single_quote_subst"`' -lt_cv_sys_global_symbol_to_cdecl='`$ECHO "$lt_cv_sys_global_symbol_to_cdecl" | $SED "$delay_single_quote_subst"`' -lt_cv_sys_global_symbol_to_import='`$ECHO "$lt_cv_sys_global_symbol_to_import" | $SED "$delay_single_quote_subst"`' -lt_cv_sys_global_symbol_to_c_name_address='`$ECHO "$lt_cv_sys_global_symbol_to_c_name_address" | $SED "$delay_single_quote_subst"`' -lt_cv_sys_global_symbol_to_c_name_address_lib_prefix='`$ECHO "$lt_cv_sys_global_symbol_to_c_name_address_lib_prefix" | $SED "$delay_single_quote_subst"`' -lt_cv_nm_interface='`$ECHO "$lt_cv_nm_interface" | $SED "$delay_single_quote_subst"`' -nm_file_list_spec='`$ECHO "$nm_file_list_spec" | $SED "$delay_single_quote_subst"`' -lt_sysroot='`$ECHO "$lt_sysroot" | $SED "$delay_single_quote_subst"`' -lt_cv_truncate_bin='`$ECHO "$lt_cv_truncate_bin" | $SED "$delay_single_quote_subst"`' -objdir='`$ECHO "$objdir" | $SED "$delay_single_quote_subst"`' -MAGIC_CMD='`$ECHO "$MAGIC_CMD" | $SED "$delay_single_quote_subst"`' -lt_prog_compiler_no_builtin_flag='`$ECHO "$lt_prog_compiler_no_builtin_flag" | $SED "$delay_single_quote_subst"`' -lt_prog_compiler_pic='`$ECHO "$lt_prog_compiler_pic" | $SED "$delay_single_quote_subst"`' -lt_prog_compiler_wl='`$ECHO "$lt_prog_compiler_wl" | $SED "$delay_single_quote_subst"`' -lt_prog_compiler_static='`$ECHO "$lt_prog_compiler_static" | $SED "$delay_single_quote_subst"`' -lt_cv_prog_compiler_c_o='`$ECHO "$lt_cv_prog_compiler_c_o" | $SED "$delay_single_quote_subst"`' -need_locks='`$ECHO "$need_locks" | $SED "$delay_single_quote_subst"`' -MANIFEST_TOOL='`$ECHO "$MANIFEST_TOOL" | $SED "$delay_single_quote_subst"`' -DSYMUTIL='`$ECHO "$DSYMUTIL" | $SED "$delay_single_quote_subst"`' -NMEDIT='`$ECHO "$NMEDIT" | $SED "$delay_single_quote_subst"`' -LIPO='`$ECHO "$LIPO" | $SED "$delay_single_quote_subst"`' -OTOOL='`$ECHO "$OTOOL" | $SED "$delay_single_quote_subst"`' -OTOOL64='`$ECHO "$OTOOL64" | $SED "$delay_single_quote_subst"`' -libext='`$ECHO "$libext" | $SED "$delay_single_quote_subst"`' -shrext_cmds='`$ECHO "$shrext_cmds" | $SED "$delay_single_quote_subst"`' -extract_expsyms_cmds='`$ECHO "$extract_expsyms_cmds" | $SED "$delay_single_quote_subst"`' -archive_cmds_need_lc='`$ECHO "$archive_cmds_need_lc" | $SED "$delay_single_quote_subst"`' -enable_shared_with_static_runtimes='`$ECHO "$enable_shared_with_static_runtimes" | $SED "$delay_single_quote_subst"`' -export_dynamic_flag_spec='`$ECHO "$export_dynamic_flag_spec" | $SED "$delay_single_quote_subst"`' -whole_archive_flag_spec='`$ECHO "$whole_archive_flag_spec" | $SED "$delay_single_quote_subst"`' -compiler_needs_object='`$ECHO "$compiler_needs_object" | $SED "$delay_single_quote_subst"`' -old_archive_from_new_cmds='`$ECHO "$old_archive_from_new_cmds" | $SED "$delay_single_quote_subst"`' -old_archive_from_expsyms_cmds='`$ECHO "$old_archive_from_expsyms_cmds" | $SED "$delay_single_quote_subst"`' -archive_cmds='`$ECHO "$archive_cmds" | $SED "$delay_single_quote_subst"`' -archive_expsym_cmds='`$ECHO "$archive_expsym_cmds" | $SED "$delay_single_quote_subst"`' -module_cmds='`$ECHO "$module_cmds" | $SED "$delay_single_quote_subst"`' -module_expsym_cmds='`$ECHO "$module_expsym_cmds" | $SED "$delay_single_quote_subst"`' -with_gnu_ld='`$ECHO "$with_gnu_ld" | $SED "$delay_single_quote_subst"`' -allow_undefined_flag='`$ECHO "$allow_undefined_flag" | $SED "$delay_single_quote_subst"`' -no_undefined_flag='`$ECHO "$no_undefined_flag" | $SED "$delay_single_quote_subst"`' -hardcode_libdir_flag_spec='`$ECHO "$hardcode_libdir_flag_spec" | $SED "$delay_single_quote_subst"`' -hardcode_libdir_separator='`$ECHO "$hardcode_libdir_separator" | $SED "$delay_single_quote_subst"`' -hardcode_direct='`$ECHO "$hardcode_direct" | $SED "$delay_single_quote_subst"`' -hardcode_direct_absolute='`$ECHO "$hardcode_direct_absolute" | $SED "$delay_single_quote_subst"`' -hardcode_minus_L='`$ECHO "$hardcode_minus_L" | $SED "$delay_single_quote_subst"`' -hardcode_shlibpath_var='`$ECHO "$hardcode_shlibpath_var" | $SED "$delay_single_quote_subst"`' -hardcode_automatic='`$ECHO "$hardcode_automatic" | $SED "$delay_single_quote_subst"`' -inherit_rpath='`$ECHO "$inherit_rpath" | $SED "$delay_single_quote_subst"`' -link_all_deplibs='`$ECHO "$link_all_deplibs" | $SED "$delay_single_quote_subst"`' -always_export_symbols='`$ECHO "$always_export_symbols" | $SED "$delay_single_quote_subst"`' -export_symbols_cmds='`$ECHO "$export_symbols_cmds" | $SED "$delay_single_quote_subst"`' -exclude_expsyms='`$ECHO "$exclude_expsyms" | $SED "$delay_single_quote_subst"`' -include_expsyms='`$ECHO "$include_expsyms" | $SED "$delay_single_quote_subst"`' -prelink_cmds='`$ECHO "$prelink_cmds" | $SED "$delay_single_quote_subst"`' -postlink_cmds='`$ECHO "$postlink_cmds" | $SED "$delay_single_quote_subst"`' -file_list_spec='`$ECHO "$file_list_spec" | $SED "$delay_single_quote_subst"`' -variables_saved_for_relink='`$ECHO "$variables_saved_for_relink" | $SED "$delay_single_quote_subst"`' -need_lib_prefix='`$ECHO "$need_lib_prefix" | $SED "$delay_single_quote_subst"`' -need_version='`$ECHO "$need_version" | $SED "$delay_single_quote_subst"`' -version_type='`$ECHO "$version_type" | $SED "$delay_single_quote_subst"`' -runpath_var='`$ECHO "$runpath_var" | $SED "$delay_single_quote_subst"`' -shlibpath_var='`$ECHO "$shlibpath_var" | $SED "$delay_single_quote_subst"`' -shlibpath_overrides_runpath='`$ECHO "$shlibpath_overrides_runpath" | $SED "$delay_single_quote_subst"`' -libname_spec='`$ECHO "$libname_spec" | $SED "$delay_single_quote_subst"`' -library_names_spec='`$ECHO "$library_names_spec" | $SED "$delay_single_quote_subst"`' -soname_spec='`$ECHO "$soname_spec" | $SED "$delay_single_quote_subst"`' -install_override_mode='`$ECHO "$install_override_mode" | $SED "$delay_single_quote_subst"`' -postinstall_cmds='`$ECHO "$postinstall_cmds" | $SED "$delay_single_quote_subst"`' -postuninstall_cmds='`$ECHO "$postuninstall_cmds" | $SED "$delay_single_quote_subst"`' -finish_cmds='`$ECHO "$finish_cmds" | $SED "$delay_single_quote_subst"`' -finish_eval='`$ECHO "$finish_eval" | $SED "$delay_single_quote_subst"`' -hardcode_into_libs='`$ECHO "$hardcode_into_libs" | $SED "$delay_single_quote_subst"`' -sys_lib_search_path_spec='`$ECHO "$sys_lib_search_path_spec" | $SED "$delay_single_quote_subst"`' -configure_time_dlsearch_path='`$ECHO "$configure_time_dlsearch_path" | $SED "$delay_single_quote_subst"`' -configure_time_lt_sys_library_path='`$ECHO "$configure_time_lt_sys_library_path" | $SED "$delay_single_quote_subst"`' -hardcode_action='`$ECHO "$hardcode_action" | $SED "$delay_single_quote_subst"`' -enable_dlopen='`$ECHO "$enable_dlopen" | $SED "$delay_single_quote_subst"`' -enable_dlopen_self='`$ECHO "$enable_dlopen_self" | $SED "$delay_single_quote_subst"`' -enable_dlopen_self_static='`$ECHO "$enable_dlopen_self_static" | $SED "$delay_single_quote_subst"`' -old_striplib='`$ECHO "$old_striplib" | $SED "$delay_single_quote_subst"`' -striplib='`$ECHO "$striplib" | $SED "$delay_single_quote_subst"`' - -LTCC='$LTCC' -LTCFLAGS='$LTCFLAGS' -compiler='$compiler_DEFAULT' - -# A function that is used when there is no print builtin or printf. -func_fallback_echo () -{ - eval 'cat <<_LTECHO_EOF -\$1 -_LTECHO_EOF' -} - -# Quote evaled strings. -for var in SHELL \ -ECHO \ -PATH_SEPARATOR \ -SED \ -GREP \ -EGREP \ -FGREP \ -LD \ -NM \ -LN_S \ -lt_SP2NL \ -lt_NL2SP \ -reload_flag \ -OBJDUMP \ -deplibs_check_method \ -file_magic_cmd \ -file_magic_glob \ -want_nocaseglob \ -DLLTOOL \ -sharedlib_from_linklib_cmd \ -AR \ -AR_FLAGS \ -archiver_list_spec \ -STRIP \ -RANLIB \ -CC \ -CFLAGS \ -compiler \ -lt_cv_sys_global_symbol_pipe \ -lt_cv_sys_global_symbol_to_cdecl \ -lt_cv_sys_global_symbol_to_import \ -lt_cv_sys_global_symbol_to_c_name_address \ -lt_cv_sys_global_symbol_to_c_name_address_lib_prefix \ -lt_cv_nm_interface \ -nm_file_list_spec \ -lt_cv_truncate_bin \ -lt_prog_compiler_no_builtin_flag \ -lt_prog_compiler_pic \ -lt_prog_compiler_wl \ -lt_prog_compiler_static \ -lt_cv_prog_compiler_c_o \ -need_locks \ -MANIFEST_TOOL \ -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_separator \ -exclude_expsyms \ -include_expsyms \ -file_list_spec \ -variables_saved_for_relink \ -libname_spec \ -library_names_spec \ -soname_spec \ -install_override_mode \ -finish_eval \ -old_striplib \ -striplib; do - case \`eval \\\\\$ECHO \\\\""\\\\\$\$var"\\\\"\` in - *[\\\\\\\`\\"\\\$]*) - eval "lt_\$var=\\\\\\"\\\`\\\$ECHO \\"\\\$\$var\\" | \\\$SED \\"\\\$sed_quote_subst\\"\\\`\\\\\\"" ## exclude from sc_prohibit_nested_quotes - ;; - *) - 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 \ -postlink_cmds \ -postinstall_cmds \ -postuninstall_cmds \ -finish_cmds \ -sys_lib_search_path_spec \ -configure_time_dlsearch_path \ -configure_time_lt_sys_library_path; do - case \`eval \\\\\$ECHO \\\\""\\\\\$\$var"\\\\"\` in - *[\\\\\\\`\\"\\\$]*) - eval "lt_\$var=\\\\\\"\\\`\\\$ECHO \\"\\\$\$var\\" | \\\$SED -e \\"\\\$double_quote_subst\\" -e \\"\\\$sed_quote_subst\\" -e \\"\\\$delay_variable_subst\\"\\\`\\\\\\"" ## exclude from sc_prohibit_nested_quotes - ;; - *) - eval "lt_\$var=\\\\\\"\\\$\$var\\\\\\"" - ;; - esac -done - -ac_aux_dir='$ac_aux_dir' - -# See if we are running on zsh, and set the options that 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' - RM='$RM' - ofile='$ofile' - - - - -PICFLAG="${PICFLAG}" -CC="${CC}" -DEFS="${DEFS}" - - -_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 - "src/config.h") CONFIG_HEADERS="$CONFIG_HEADERS src/config.h" ;; - "depfiles") CONFIG_COMMANDS="$CONFIG_COMMANDS depfiles" ;; - "libtool") CONFIG_COMMANDS="$CONFIG_COMMANDS libtool" ;; - "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; - "doc/Makefile") CONFIG_FILES="$CONFIG_FILES doc/Makefile" ;; - "src/Makefile") CONFIG_FILES="$CONFIG_FILES src/Makefile" ;; - "tests/Makefile") CONFIG_FILES="$CONFIG_FILES tests/Makefile" ;; - "pkgconfig/atomic_ops.pc") CONFIG_FILES="$CONFIG_FILES pkgconfig/atomic_ops.pc" ;; - "pkgconfig/atomic_ops-uninstalled.pc") CONFIG_FILES="$CONFIG_FILES pkgconfig/atomic_ops-uninstalled.pc" ;; - "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= ac_tmp= - trap 'exit_status=$? - : "${ac_tmp:=$tmp}" - { test ! -d "$ac_tmp" || rm -fr "$ac_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 -d "$tmp" -} || -{ - tmp=./conf$$-$RANDOM - (umask 077 && mkdir "$tmp") -} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 -ac_tmp=$tmp - -# 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 {' >"$ac_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 >>"\$ac_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 >>"\$ac_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 < "$ac_tmp/subs1.awk" > "$ac_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 sole $(srcdir), -# ${srcdir} and @srcdir@ entries 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[ ]*=[ ]*/{ -h -s/// -s/^/:/ -s/[ ]*$/:/ -s/:\$(srcdir):/:/g -s/:\${srcdir}:/:/g -s/:@srcdir@:/:/g -s/^:*// -s/:*$// -x -s/\(=[ ]*\).*/\1/ -G -s/\n// -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 >"$ac_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_tt=`sed -n "/$ac_delim/p" confdefs.h` - if test -z "$ac_tt"; 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="$ac_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 1 "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 >"$ac_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 - ac_MKDIR_P=$MKDIR_P - case $MKDIR_P in - [\\/$]* | ?:[\\/]* ) ;; - */*) ac_MKDIR_P=$ac_top_build_prefix$MKDIR_P ;; - 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 -s&@MKDIR_P@&$ac_MKDIR_P&;t t -$ac_datarootdir_hack -" -eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ - >$ac_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' "$ac_tmp/out"`; test -n "$ac_out"; } && - { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ - "$ac_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 "$ac_tmp/stdin" - case $ac_file in - -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; - *) rm -f "$ac_file" && mv "$ac_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 "$ac_tmp/defines.awk"' "$ac_file_inputs" - } >"$ac_tmp/config.h" \ - || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - if diff "$ac_file" "$ac_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 "$ac_tmp/config.h" "$ac_file" \ - || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - fi - else - $as_echo "/* $configure_input */" \ - && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" \ - || as_fn_error $? "could not create -" "$LINENO" 5 - fi -# Compute "$ac_file"'s index in $config_headers. -_am_arg="$ac_file" -_am_stamp_count=1 -for _am_header in $config_headers :; do - case $_am_header in - $_am_arg | $_am_arg:* ) - break ;; - * ) - _am_stamp_count=`expr $_am_stamp_count + 1` ;; - esac -done -echo "timestamp for $_am_arg" >`$as_dirname -- "$_am_arg" || -$as_expr X"$_am_arg" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$_am_arg" : 'X\(//\)[^/]' \| \ - X"$_am_arg" : 'X\(//\)$' \| \ - X"$_am_arg" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$_am_arg" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'`/stamp-h$_am_stamp_count - ;; - - :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 - "depfiles":C) test x"$AMDEP_TRUE" != x"" || { - # Older Autoconf quotes --file arguments for eval, but not when files - # are listed without --file. Let's play safe and only enable the eval - # if we detect the quoting. - case $CONFIG_FILES in - *\'*) eval set x "$CONFIG_FILES" ;; - *) set x $CONFIG_FILES ;; - esac - shift - for mf - do - # Strip MF so we end up with the name of the file. - mf=`echo "$mf" | sed -e 's/:.*$//'` - # Check whether this is an Automake generated Makefile or not. - # We used to match only the files named 'Makefile.in', but - # some people rename them; so instead we look at the file content. - # Grep'ing the first line is not enough: some people post-process - # each Makefile.in and add a new line on top of each file to say so. - # Grep'ing the whole file is not good either: AIX grep has a line - # limit of 2048, but all sed's we know have understand at least 4000. - if sed -n 's,^#.*generated by automake.*,X,p' "$mf" | grep X >/dev/null 2>&1; then - dirpart=`$as_dirname -- "$mf" || -$as_expr X"$mf" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$mf" : 'X\(//\)[^/]' \| \ - X"$mf" : 'X\(//\)$' \| \ - X"$mf" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$mf" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - else - continue - fi - # Extract the definition of DEPDIR, am__include, and am__quote - # from the Makefile without running 'make'. - DEPDIR=`sed -n 's/^DEPDIR = //p' < "$mf"` - test -z "$DEPDIR" && continue - am__include=`sed -n 's/^am__include = //p' < "$mf"` - test -z "$am__include" && continue - am__quote=`sed -n 's/^am__quote = //p' < "$mf"` - # Find all dependency output files, they are included files with - # $(DEPDIR) in their names. We invoke sed twice because it is the - # simplest approach to changing $(DEPDIR) to its actual value in the - # expansion. - for file in `sed -n " - s/^$am__include $am__quote\(.*(DEPDIR).*\)$am__quote"'$/\1/p' <"$mf" | \ - sed -e 's/\$(DEPDIR)/'"$DEPDIR"'/g'`; do - # Make sure the directory exists. - test -f "$dirpart/$file" && continue - fdir=`$as_dirname -- "$file" || -$as_expr X"$file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$file" : 'X\(//\)[^/]' \| \ - X"$file" : 'X\(//\)$' \| \ - X"$file" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$file" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - as_dir=$dirpart/$fdir; as_fn_mkdir_p - # echo "creating $dirpart/$file" - echo '# dummy' > "$dirpart/$file" - done - done -} - ;; - "libtool":C) - - # See if we are running on zsh, and set the options that 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 -# Generated automatically by $as_me ($PACKAGE) $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. - -# Provide generalized library-building support services. -# Written by Gordon Matzigkeit, 1996 - -# Copyright (C) 2014 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 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 this program. If not, see . - - -# The names of the tagged configurations supported by this script. -available_tags='' - -# Configured defaults for sys_lib_dlsearch_path munging. -: \${LT_SYS_LIBRARY_PATH="$configure_time_lt_sys_library_path"} - -# ### 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 - -# Shared archive member basename,for filename based shared library versioning on AIX. -shared_archive_member_spec=$shared_archive_member_spec - -# Shell to use when invoking shell scripts. -SHELL=$lt_SHELL - -# An echo program that protects backslashes. -ECHO=$lt_ECHO - -# The PATH separator for the build system. -PATH_SEPARATOR=$lt_PATH_SEPARATOR - -# 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 - -# convert \$build file names to \$host format. -to_host_file_cmd=$lt_cv_to_host_file_cmd - -# convert \$build files to toolchain format. -to_tool_file_cmd=$lt_cv_to_tool_file_cmd - -# 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 - -# How to find potential files when deplibs_check_method = "file_magic". -file_magic_glob=$lt_file_magic_glob - -# Find potential files using nocaseglob when deplibs_check_method = "file_magic". -want_nocaseglob=$lt_want_nocaseglob - -# DLL creation program. -DLLTOOL=$lt_DLLTOOL - -# Command to associate shared and link libraries. -sharedlib_from_linklib_cmd=$lt_sharedlib_from_linklib_cmd - -# The archiver. -AR=$lt_AR - -# Flags to create an archive. -AR_FLAGS=$lt_AR_FLAGS - -# How to feed a file listing to the archiver. -archiver_list_spec=$lt_archiver_list_spec - -# 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 - -# Whether to use a lock for old archive extraction. -lock_old_archive_extraction=$lock_old_archive_extraction - -# 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 into a list of symbols to manually relocate. -global_symbol_to_import=$lt_lt_cv_sys_global_symbol_to_import - -# 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 lister interface. -nm_interface=$lt_lt_cv_nm_interface - -# Specify filename containing input files for \$NM. -nm_file_list_spec=$lt_nm_file_list_spec - -# The root where to search for dependent libraries,and where our libraries should be installed. -lt_sysroot=$lt_sysroot - -# Command to truncate a binary pipe. -lt_truncate_bin=$lt_lt_cv_truncate_bin - -# The name of the directory that contains temporary libtool files. -objdir=$objdir - -# 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 - -# Manifest tool. -MANIFEST_TOOL=$lt_MANIFEST_TOOL - -# 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 - -# Permission mode override for installation of shared libraries. -install_override_mode=$lt_install_override_mode - -# 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 - -# Detected run-time system search path for libraries. -sys_lib_dlsearch_path_spec=$lt_configure_time_dlsearch_path - -# Explicit LT_SYS_LIBRARY_PATH set during ./configure time. -configure_time_lt_sys_library_path=$lt_configure_time_lt_sys_library_path - -# 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 - -# How to create reloadable object files. -reload_flag=$lt_reload_flag -reload_cmds=$lt_reload_cmds - -# 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 - -# Additional compiler flags for building library objects. -pic_flag=$lt_lt_prog_compiler_pic - -# How to pass a linker flag through the compiler. -wl=$lt_lt_prog_compiler_wl - -# 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 - -# 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 - -# 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 - -# Commands necessary for finishing linking programs. -postlink_cmds=$lt_postlink_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 - - cat <<'_LT_EOF' >> "$cfgfile" - -# ### BEGIN FUNCTIONS SHARED WITH CONFIGURE - -# func_munge_path_list VARIABLE PATH -# ----------------------------------- -# VARIABLE is name of variable containing _space_ separated list of -# directories to be munged by the contents of PATH, which is string -# having a format: -# "DIR[:DIR]:" -# string "DIR[ DIR]" will be prepended to VARIABLE -# ":DIR[:DIR]" -# string "DIR[ DIR]" will be appended to VARIABLE -# "DIRP[:DIRP]::[DIRA:]DIRA" -# string "DIRP[ DIRP]" will be prepended to VARIABLE and string -# "DIRA[ DIRA]" will be appended to VARIABLE -# "DIR[:DIR]" -# VARIABLE will be replaced by "DIR[ DIR]" -func_munge_path_list () -{ - case x$2 in - x) - ;; - *:) - eval $1=\"`$ECHO $2 | $SED 's/:/ /g'` \$$1\" - ;; - x:*) - eval $1=\"\$$1 `$ECHO $2 | $SED 's/:/ /g'`\" - ;; - *::*) - eval $1=\"\$$1\ `$ECHO $2 | $SED -e 's/.*:://' -e 's/:/ /g'`\" - eval $1=\"`$ECHO $2 | $SED -e 's/::.*//' -e 's/:/ /g'`\ \$$1\" - ;; - *) - eval $1=\"`$ECHO $2 | $SED 's/:/ /g'`\" - ;; - esac -} - - -# Calculate cc_basename. Skip known compiler wrappers and cross-prefix. -func_cc_basename () -{ - for cc_temp in $*""; do - case $cc_temp in - compile | *[\\/]compile | ccache | *[\\/]ccache ) ;; - distcc | *[\\/]distcc | purify | *[\\/]purify ) ;; - \-*) ;; - *) break;; - esac - done - func_cc_basename_result=`$ECHO "$cc_temp" | $SED "s%.*/%%; s%^$host_alias-%%"` -} - - -# ### END FUNCTIONS SHARED WITH CONFIGURE - -_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 set != "${COLLECT_NAMES+set}"; 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 '$q' "$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) ;; - - 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 1 -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 - diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/configure.ac ecl-16.1.3+ds/src/bdwgc/libatomic_ops/configure.ac --- ecl-16.1.2/src/bdwgc/libatomic_ops/configure.ac 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/configure.ac 1970-01-01 00:00:00.000000000 +0000 @@ -1,197 +0,0 @@ -# Process this file with autoconf to produce a configure script. -AC_INIT([libatomic_ops],[7.5.0],bdwgc@lists.opendylan.org) - -AC_PREREQ(2.61) -AC_CANONICAL_TARGET([]) -AC_CONFIG_SRCDIR(src/atomic_ops.c) -AC_CONFIG_MACRO_DIR([m4]) -AM_INIT_AUTOMAKE([foreign dist-bzip2 nostdinc]) -AM_MAINTAINER_MODE - -AC_CONFIG_HEADERS([src/config.h]) - -# Checks for programs. -AM_PROG_CC_C_O -AM_PROG_AS -LT_INIT([disable-shared]) - -# Checks for functions. -AC_FUNC_MMAP - -# Determine PIC flag. -need_asm=false -PICFLAG= -AC_MSG_CHECKING(for PIC compiler flag) -if test "$GCC" = yes; then - case "$host" in - *-*-cygwin* | *-*-mingw*) - # Cygwin and Mingw[-w32/64] do not need -fPIC. - AC_MSG_RESULT("") - ;; - *) - AC_MSG_RESULT(-fPIC) - PICFLAG=-fPIC - AC_MSG_CHECKING(whether gcc -fPIC causes __PIC__ definition) - # Workaround: at least GCC 3.4.6 (Solaris) does not define this macro. - old_CFLAGS="$CFLAGS" - CFLAGS="$PICFLAG $CFLAGS" - AC_TRY_COMPILE([],[ - #ifndef __PIC__ - # error - #endif - ], [ac_cv_pic_macro=yes], [ac_cv_pic_macro=no]) - CFLAGS="$old_CFLAGS" - AC_MSG_RESULT($ac_cv_pic_macro) - AS_IF([test "$ac_cv_pic_macro" = yes], [], - [PICFLAG="-D__PIC__=1 $PICFLAG"]) - ;; - esac - - # Output all warnings. - AC_MSG_CHECKING(for gcc -Wextra) - old_CFLAGS="$CFLAGS" - CFLAGS="-Wextra $CFLAGS" - AC_TRY_COMPILE([],[], [ac_cv_cc_wextra=yes], [ac_cv_cc_wextra=no]) - CFLAGS="$old_CFLAGS" - AC_MSG_RESULT($ac_cv_cc_wextra) - AS_IF([test "$ac_cv_cc_wextra" = yes], [WEXTRA="-Wextra"], [WEXTRA="-W"]) - CFLAGS="-Wall $WEXTRA $CFLAGS" - - AC_ARG_ENABLE(werror, [AC_HELP_STRING([--enable-werror], - [Pass -Werror to the C compiler])]) - if test "$enable_werror" = yes; then - CFLAGS="-Werror $CFLAGS" - fi -else - case "$host" in - *-*-hpux*) - AC_MSG_RESULT("+Z") - PICFLAG="+Z" - CFLAGS="+O2 -mt $CFLAGS" - ;; - *-*-solaris*) - AC_MSG_RESULT(-Kpic) - PICFLAG=-Kpic - CFLAGS="-O $CFLAGS" - need_asm=true - ;; - *-*-linux*) - AC_MSG_RESULT(-fPIC) - PICFLAG=-fPIC - # Any Linux compiler had better be gcc compatible. - ;; - *) - AC_MSG_RESULT("") - ;; - esac -fi - -AC_ARG_ENABLE(assertions, - [AC_HELP_STRING([--enable-assertions], [Assertion checking])]) -if test "$enable_assertions" != yes; then - AC_DEFINE([NDEBUG], 1, [Define to disable assertion checking.]) -fi - -AC_SUBST(PICFLAG) -AC_SUBST(DEFS) - -AH_TEMPLATE([_PTHREADS], [Indicates the use of pthreads (NetBSD).]) - -AH_TEMPLATE([AO_USE_NANOSLEEP], - [Use nanosleep() instead of select() (only if atomic operations \ - are emulated)]) -AH_TEMPLATE([AO_USE_NO_SIGNALS], - [Do not block signals in compare_and_swap (only if atomic operations \ - are emulated)]) -AH_TEMPLATE([AO_USE_WIN32_PTHREADS], - [Use Win32 Sleep() instead of select() (only if atomic operations \ - are emulated)]) -AH_TEMPLATE([AO_TRACE_MALLOC], [Trace AO_malloc/free calls (for debug only)]) - -# These macros are tested in public headers -AH_TEMPLATE([AO_GENERALIZE_ASM_BOOL_CAS], - [Force compare_and_swap definition via fetch_compare_and_swap]) -AH_TEMPLATE([AO_PREFER_GENERALIZED], - [Prefer generalized definitions to direct assembly-based ones]) -AH_TEMPLATE([AO_USE_PTHREAD_DEFS], - [Emulate atomic operations via slow and async-signal-unsafe \ - pthread locking]) -AH_TEMPLATE([AO_ASM_X64_AVAILABLE], - [Inline assembly avalable (only VC/x86_64)]) -AH_TEMPLATE([AO_ASSUME_VISTA], - [Assume Windows Server 2003, Vista or later target (only VC/x86)]) -AH_TEMPLATE([AO_ASSUME_WINDOWS98], - [Assume hardware compare-and-swap functionality available \ - on target (only VC/x86)]) -AH_TEMPLATE([AO_CMPXCHG16B_AVAILABLE], - [Assume target is not old AMD Opteron chip (only x86_64)]) -AH_TEMPLATE([AO_FORCE_USE_SWP], - [Force test_and_set to use SWP instruction instead of LDREX/STREX \ - (only arm v6+)]) -AH_TEMPLATE([AO_NO_SPARC_V9], [Assume target is not sparc v9+ (only sparc)]) -AH_TEMPLATE([AO_OLD_STYLE_INTERLOCKED_COMPARE_EXCHANGE], - [Assume ancient MS VS Win32 headers (only VC/arm v6+, VC/x86)]) -AH_TEMPLATE([AO_UNIPROCESSOR], [Assume single-core target (only arm v6+)]) -AH_TEMPLATE([AO_USE_INTERLOCKED_INTRINSICS], - [Assume Win32 _Interlocked primitives available as intrinsics \ - (only VC/arm)]) -AH_TEMPLATE([AO_USE_PENTIUM4_INSTRS], - [Use Pentium 4 'mfence' instruction (only x86)]) -AH_TEMPLATE([AO_USE_SYNC_CAS_BUILTIN], - [Prefer GCC built-in CAS intrinsics in favor of inline assembly \ - (only gcc/x86, gcc/x86_64)]) -AH_TEMPLATE([AO_WEAK_DOUBLE_CAS_EMULATION], - [Emulate double-width CAS via pthread locking in case of no hardware \ - support (only gcc/x86_64, the emulation is unsafe)]) - -AC_DEFINE(_REENTRANT, 1, [Required define if using POSIX threads.]) - -# Libraries needed to support threads (if any). -have_pthreads=false -AC_CHECK_LIB(pthread, pthread_self, have_pthreads=true) -if test x$have_pthreads = xtrue; then - THREADDLLIBS=-lpthread - case "$host" in - *-*-netbsd*) - # Indicates the use of pthreads. - AC_DEFINE(_PTHREADS) - ;; - *-*-openbsd* | *-*-kfreebsd*-gnu | *-*-dgux*) - THREADDLLIBS=-pthread - ;; - *-*-cygwin* | *-*-darwin*) - # Cygwin does not have a real libpthread, so Libtool cannot link - # against it. - THREADDLLIBS= - ;; - *-*-mingw*) - # Use Win32 threads for tests anyway. - THREADDLLIBS= - # Skip test_atomic_pthreads. - have_pthreads=false - ;; - esac -else - AC_DEFINE([AO_NO_PTHREADS], 1, [No pthreads library available]) - # Assume VxWorks or Win32. - THREADDLLIBS= -fi -AC_SUBST(THREADDLLIBS) - -AM_CONDITIONAL(HAVE_PTHREAD_H, test x$have_pthreads = xtrue) -AM_CONDITIONAL(NEED_ASM, test x$need_asm = xtrue) - -AC_CONFIG_FILES([ - Makefile - doc/Makefile - src/Makefile - tests/Makefile - pkgconfig/atomic_ops.pc - pkgconfig/atomic_ops-uninstalled.pc ]) - -AC_CONFIG_COMMANDS([default],[[]],[[ -PICFLAG="${PICFLAG}" -CC="${CC}" -DEFS="${DEFS}" -]]) -AC_OUTPUT diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/COPYING ecl-16.1.3+ds/src/bdwgc/libatomic_ops/COPYING --- ecl-16.1.2/src/bdwgc/libatomic_ops/COPYING 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/COPYING 1970-01-01 00:00:00.000000000 +0000 @@ -1,340 +0,0 @@ - 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) - - 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) year 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. diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/doc/LICENSING.txt ecl-16.1.3+ds/src/bdwgc/libatomic_ops/doc/LICENSING.txt --- ecl-16.1.2/src/bdwgc/libatomic_ops/doc/LICENSING.txt 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/doc/LICENSING.txt 1970-01-01 00:00:00.000000000 +0000 @@ -1,63 +0,0 @@ -Our intent is to make it easy to use libatomic_ops, in -both free and proprietary software. Hence most code that we expect to be -linked into a client application is covered by an MIT-style license. - -A few library routines are covered by the GNU General Public License. -These are put into a separate library, libatomic_ops_gpl.a . - -The low-level part of the library is mostly covered by the following -license: - ----------------------------------------- - -Copyright (c) ... - -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 -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -SOFTWARE. - --------------------------------- - -A few files in the sysdeps directory were inherited in part from the -Boehm-Demers-Weiser conservative garbage collector, and are covered by -its license, which is similar in spirit: - --------------------------------- - -Copyright (c) ... - -THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED -OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - -Permission is hereby granted to use or copy this program -for any purpose, provided the above notices are retained on all copies. -Permission to modify the code and to distribute modified code is granted, -provided the above notices are retained, and a notice that the code was -modified is included with the above copyright notice. - ----------------------------------- - -A few files are covered by the GNU General Public License. (See file -"COPYING".) This applies only to test code, sample applications, -and the libatomic_ops_gpl portion of the library. -Thus libatomic_ops_gpl should generally not be linked into proprietary code. -(This distinction was motivated by patent considerations.) - -It is possible that the license of the GPL pieces may be changed for -future versions to make them more consistent with the rest of the package. -If you submit patches, and have strong preferences about licensing, please -express them. diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/doc/Makefile.am ecl-16.1.3+ds/src/bdwgc/libatomic_ops/doc/Makefile.am --- ecl-16.1.2/src/bdwgc/libatomic_ops/doc/Makefile.am 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/doc/Makefile.am 1970-01-01 00:00:00.000000000 +0000 @@ -1,4 +0,0 @@ -# installed documentation -# -dist_pkgdata_DATA=LICENSING.txt README.txt README_stack.txt \ - README_malloc.txt README_win32.txt diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/doc/Makefile.in ecl-16.1.3+ds/src/bdwgc/libatomic_ops/doc/Makefile.in --- ecl-16.1.2/src/bdwgc/libatomic_ops/doc/Makefile.in 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/doc/Makefile.in 1970-01-01 00:00:00.000000000 +0000 @@ -1,507 +0,0 @@ -# Makefile.in generated by automake 1.15 from Makefile.am. -# @configure_input@ - -# Copyright (C) 1994-2014 Free Software Foundation, Inc. - -# This Makefile.in 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. - -@SET_MAKE@ - -VPATH = @srcdir@ -am__is_gnu_make = { \ - if test -z '$(MAKELEVEL)'; then \ - false; \ - elif test -n '$(MAKE_HOST)'; then \ - true; \ - elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ - true; \ - else \ - false; \ - fi; \ -} -am__make_running_with_option = \ - case $${target_option-} in \ - ?) ;; \ - *) echo "am__make_running_with_option: internal error: invalid" \ - "target option '$${target_option-}' specified" >&2; \ - exit 1;; \ - esac; \ - has_opt=no; \ - sane_makeflags=$$MAKEFLAGS; \ - if $(am__is_gnu_make); then \ - sane_makeflags=$$MFLAGS; \ - else \ - case $$MAKEFLAGS in \ - *\\[\ \ ]*) \ - bs=\\; \ - sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ - | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ - esac; \ - fi; \ - skip_next=no; \ - strip_trailopt () \ - { \ - flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ - }; \ - for flg in $$sane_makeflags; do \ - test $$skip_next = yes && { skip_next=no; continue; }; \ - case $$flg in \ - *=*|--*) continue;; \ - -*I) strip_trailopt 'I'; skip_next=yes;; \ - -*I?*) strip_trailopt 'I';; \ - -*O) strip_trailopt 'O'; skip_next=yes;; \ - -*O?*) strip_trailopt 'O';; \ - -*l) strip_trailopt 'l'; skip_next=yes;; \ - -*l?*) strip_trailopt 'l';; \ - -[dEDm]) skip_next=yes;; \ - -[JT]) skip_next=yes;; \ - esac; \ - case $$flg in \ - *$$target_option*) has_opt=yes; break;; \ - esac; \ - done; \ - test $$has_opt = yes -am__make_dryrun = (target_option=n; $(am__make_running_with_option)) -am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) -pkgdatadir = $(datadir)/@PACKAGE@ -pkgincludedir = $(includedir)/@PACKAGE@ -pkglibdir = $(libdir)/@PACKAGE@ -pkglibexecdir = $(libexecdir)/@PACKAGE@ -am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd -install_sh_DATA = $(install_sh) -c -m 644 -install_sh_PROGRAM = $(install_sh) -c -install_sh_SCRIPT = $(install_sh) -c -INSTALL_HEADER = $(INSTALL_DATA) -transform = $(program_transform_name) -NORMAL_INSTALL = : -PRE_INSTALL = : -POST_INSTALL = : -NORMAL_UNINSTALL = : -PRE_UNINSTALL = : -POST_UNINSTALL = : -build_triplet = @build@ -host_triplet = @host@ -target_triplet = @target@ -subdir = doc -ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 -am__aclocal_m4_deps = $(top_srcdir)/m4/libtool.m4 \ - $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \ - $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \ - $(top_srcdir)/configure.ac -am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ - $(ACLOCAL_M4) -DIST_COMMON = $(srcdir)/Makefile.am $(dist_pkgdata_DATA) \ - $(am__DIST_COMMON) -mkinstalldirs = $(install_sh) -d -CONFIG_HEADER = $(top_builddir)/src/config.h -CONFIG_CLEAN_FILES = -CONFIG_CLEAN_VPATH_FILES = -AM_V_P = $(am__v_P_@AM_V@) -am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) -am__v_P_0 = false -am__v_P_1 = : -AM_V_GEN = $(am__v_GEN_@AM_V@) -am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) -am__v_GEN_0 = @echo " GEN " $@; -am__v_GEN_1 = -AM_V_at = $(am__v_at_@AM_V@) -am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) -am__v_at_0 = @ -am__v_at_1 = -SOURCES = -DIST_SOURCES = -am__can_run_installinfo = \ - case $$AM_UPDATE_INFO_DIR in \ - n|no|NO) false;; \ - *) (install-info --version) >/dev/null 2>&1;; \ - esac -am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; -am__vpath_adj = case $$p in \ - $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ - *) f=$$p;; \ - esac; -am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`; -am__install_max = 40 -am__nobase_strip_setup = \ - srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'` -am__nobase_strip = \ - for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||" -am__nobase_list = $(am__nobase_strip_setup); \ - for p in $$list; do echo "$$p $$p"; done | \ - sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \ - $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \ - if (++n[$$2] == $(am__install_max)) \ - { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \ - END { for (dir in files) print dir, files[dir] }' -am__base_list = \ - sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \ - sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g' -am__uninstall_files_from_dir = { \ - test -z "$$files" \ - || { test ! -d "$$dir" && test ! -f "$$dir" && test ! -r "$$dir"; } \ - || { echo " ( cd '$$dir' && rm -f" $$files ")"; \ - $(am__cd) "$$dir" && rm -f $$files; }; \ - } -am__installdirs = "$(DESTDIR)$(pkgdatadir)" -DATA = $(dist_pkgdata_DATA) -am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP) -am__DIST_COMMON = $(srcdir)/Makefile.in -DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) -ACLOCAL = @ACLOCAL@ -AMTAR = @AMTAR@ -AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ -AR = @AR@ -AUTOCONF = @AUTOCONF@ -AUTOHEADER = @AUTOHEADER@ -AUTOMAKE = @AUTOMAKE@ -AWK = @AWK@ -CC = @CC@ -CCAS = @CCAS@ -CCASDEPMODE = @CCASDEPMODE@ -CCASFLAGS = @CCASFLAGS@ -CCDEPMODE = @CCDEPMODE@ -CFLAGS = @CFLAGS@ -CPP = @CPP@ -CPPFLAGS = @CPPFLAGS@ -CYGPATH_W = @CYGPATH_W@ -DEFS = @DEFS@ -DEPDIR = @DEPDIR@ -DLLTOOL = @DLLTOOL@ -DSYMUTIL = @DSYMUTIL@ -DUMPBIN = @DUMPBIN@ -ECHO_C = @ECHO_C@ -ECHO_N = @ECHO_N@ -ECHO_T = @ECHO_T@ -EGREP = @EGREP@ -EXEEXT = @EXEEXT@ -FGREP = @FGREP@ -GREP = @GREP@ -INSTALL = @INSTALL@ -INSTALL_DATA = @INSTALL_DATA@ -INSTALL_PROGRAM = @INSTALL_PROGRAM@ -INSTALL_SCRIPT = @INSTALL_SCRIPT@ -INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ -LD = @LD@ -LDFLAGS = @LDFLAGS@ -LIBOBJS = @LIBOBJS@ -LIBS = @LIBS@ -LIBTOOL = @LIBTOOL@ -LIPO = @LIPO@ -LN_S = @LN_S@ -LTLIBOBJS = @LTLIBOBJS@ -LT_SYS_LIBRARY_PATH = @LT_SYS_LIBRARY_PATH@ -MAINT = @MAINT@ -MAKEINFO = @MAKEINFO@ -MANIFEST_TOOL = @MANIFEST_TOOL@ -MKDIR_P = @MKDIR_P@ -NM = @NM@ -NMEDIT = @NMEDIT@ -OBJDUMP = @OBJDUMP@ -OBJEXT = @OBJEXT@ -OTOOL = @OTOOL@ -OTOOL64 = @OTOOL64@ -PACKAGE = @PACKAGE@ -PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ -PACKAGE_NAME = @PACKAGE_NAME@ -PACKAGE_STRING = @PACKAGE_STRING@ -PACKAGE_TARNAME = @PACKAGE_TARNAME@ -PACKAGE_URL = @PACKAGE_URL@ -PACKAGE_VERSION = @PACKAGE_VERSION@ -PATH_SEPARATOR = @PATH_SEPARATOR@ -PICFLAG = @PICFLAG@ -RANLIB = @RANLIB@ -SED = @SED@ -SET_MAKE = @SET_MAKE@ -SHELL = @SHELL@ -STRIP = @STRIP@ -THREADDLLIBS = @THREADDLLIBS@ -VERSION = @VERSION@ -abs_builddir = @abs_builddir@ -abs_srcdir = @abs_srcdir@ -abs_top_builddir = @abs_top_builddir@ -abs_top_srcdir = @abs_top_srcdir@ -ac_ct_AR = @ac_ct_AR@ -ac_ct_CC = @ac_ct_CC@ -ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ -am__include = @am__include@ -am__leading_dot = @am__leading_dot@ -am__quote = @am__quote@ -am__tar = @am__tar@ -am__untar = @am__untar@ -bindir = @bindir@ -build = @build@ -build_alias = @build_alias@ -build_cpu = @build_cpu@ -build_os = @build_os@ -build_vendor = @build_vendor@ -builddir = @builddir@ -datadir = @datadir@ -datarootdir = @datarootdir@ -docdir = @docdir@ -dvidir = @dvidir@ -exec_prefix = @exec_prefix@ -host = @host@ -host_alias = @host_alias@ -host_cpu = @host_cpu@ -host_os = @host_os@ -host_vendor = @host_vendor@ -htmldir = @htmldir@ -includedir = @includedir@ -infodir = @infodir@ -install_sh = @install_sh@ -libdir = @libdir@ -libexecdir = @libexecdir@ -localedir = @localedir@ -localstatedir = @localstatedir@ -mandir = @mandir@ -mkdir_p = @mkdir_p@ -oldincludedir = @oldincludedir@ -pdfdir = @pdfdir@ -prefix = @prefix@ -program_transform_name = @program_transform_name@ -psdir = @psdir@ -sbindir = @sbindir@ -sharedstatedir = @sharedstatedir@ -srcdir = @srcdir@ -sysconfdir = @sysconfdir@ -target = @target@ -target_alias = @target_alias@ -target_cpu = @target_cpu@ -target_os = @target_os@ -target_vendor = @target_vendor@ -top_build_prefix = @top_build_prefix@ -top_builddir = @top_builddir@ -top_srcdir = @top_srcdir@ - -# installed documentation -# -dist_pkgdata_DATA = LICENSING.txt README.txt README_stack.txt \ - README_malloc.txt README_win32.txt - -all: all-am - -.SUFFIXES: -$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) - @for dep in $?; do \ - case '$(am__configure_deps)' in \ - *$$dep*) \ - ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ - && { if test -f $@; then exit 0; else break; fi; }; \ - exit 1;; \ - esac; \ - done; \ - echo ' cd $(top_srcdir) && $(AUTOMAKE) --foreign doc/Makefile'; \ - $(am__cd) $(top_srcdir) && \ - $(AUTOMAKE) --foreign doc/Makefile -Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status - @case '$?' in \ - *config.status*) \ - cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ - *) \ - echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ - cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ - esac; - -$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) - cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh - -$(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) - cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh -$(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) - cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh -$(am__aclocal_m4_deps): - -mostlyclean-libtool: - -rm -f *.lo - -clean-libtool: - -rm -rf .libs _libs -install-dist_pkgdataDATA: $(dist_pkgdata_DATA) - @$(NORMAL_INSTALL) - @list='$(dist_pkgdata_DATA)'; test -n "$(pkgdatadir)" || list=; \ - if test -n "$$list"; then \ - echo " $(MKDIR_P) '$(DESTDIR)$(pkgdatadir)'"; \ - $(MKDIR_P) "$(DESTDIR)$(pkgdatadir)" || exit 1; \ - fi; \ - for p in $$list; do \ - if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ - echo "$$d$$p"; \ - done | $(am__base_list) | \ - while read files; do \ - echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(pkgdatadir)'"; \ - $(INSTALL_DATA) $$files "$(DESTDIR)$(pkgdatadir)" || exit $$?; \ - done - -uninstall-dist_pkgdataDATA: - @$(NORMAL_UNINSTALL) - @list='$(dist_pkgdata_DATA)'; test -n "$(pkgdatadir)" || list=; \ - files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ - dir='$(DESTDIR)$(pkgdatadir)'; $(am__uninstall_files_from_dir) -tags TAGS: - -ctags CTAGS: - -cscope cscopelist: - - -distdir: $(DISTFILES) - @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ - topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ - list='$(DISTFILES)'; \ - dist_files=`for file in $$list; do echo $$file; done | \ - sed -e "s|^$$srcdirstrip/||;t" \ - -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ - case $$dist_files in \ - */*) $(MKDIR_P) `echo "$$dist_files" | \ - sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ - sort -u` ;; \ - esac; \ - for file in $$dist_files; do \ - if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ - if test -d $$d/$$file; then \ - dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ - if test -d "$(distdir)/$$file"; then \ - find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ - fi; \ - if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ - cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ - find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ - fi; \ - cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ - else \ - test -f "$(distdir)/$$file" \ - || cp -p $$d/$$file "$(distdir)/$$file" \ - || exit 1; \ - fi; \ - done -check-am: all-am -check: check-am -all-am: Makefile $(DATA) -installdirs: - for dir in "$(DESTDIR)$(pkgdatadir)"; do \ - test -z "$$dir" || $(MKDIR_P) "$$dir"; \ - done -install: install-am -install-exec: install-exec-am -install-data: install-data-am -uninstall: uninstall-am - -install-am: all-am - @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am - -installcheck: installcheck-am -install-strip: - if test -z '$(STRIP)'; then \ - $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ - install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ - install; \ - else \ - $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ - install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ - "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ - fi -mostlyclean-generic: - -clean-generic: - -distclean-generic: - -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) - -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) - -maintainer-clean-generic: - @echo "This command is intended for maintainers to use" - @echo "it deletes files that may require special tools to rebuild." -clean: clean-am - -clean-am: clean-generic clean-libtool mostlyclean-am - -distclean: distclean-am - -rm -f Makefile -distclean-am: clean-am distclean-generic - -dvi: dvi-am - -dvi-am: - -html: html-am - -html-am: - -info: info-am - -info-am: - -install-data-am: install-dist_pkgdataDATA - -install-dvi: install-dvi-am - -install-dvi-am: - -install-exec-am: - -install-html: install-html-am - -install-html-am: - -install-info: install-info-am - -install-info-am: - -install-man: - -install-pdf: install-pdf-am - -install-pdf-am: - -install-ps: install-ps-am - -install-ps-am: - -installcheck-am: - -maintainer-clean: maintainer-clean-am - -rm -f Makefile -maintainer-clean-am: distclean-am maintainer-clean-generic - -mostlyclean: mostlyclean-am - -mostlyclean-am: mostlyclean-generic mostlyclean-libtool - -pdf: pdf-am - -pdf-am: - -ps: ps-am - -ps-am: - -uninstall-am: uninstall-dist_pkgdataDATA - -.MAKE: install-am install-strip - -.PHONY: all all-am check check-am clean clean-generic clean-libtool \ - cscopelist-am ctags-am distclean distclean-generic \ - distclean-libtool distdir dvi dvi-am html html-am info info-am \ - install install-am install-data install-data-am \ - install-dist_pkgdataDATA install-dvi install-dvi-am \ - install-exec install-exec-am install-html install-html-am \ - install-info install-info-am install-man install-pdf \ - install-pdf-am install-ps install-ps-am install-strip \ - installcheck installcheck-am installdirs maintainer-clean \ - maintainer-clean-generic mostlyclean mostlyclean-generic \ - mostlyclean-libtool pdf pdf-am ps ps-am tags-am uninstall \ - uninstall-am uninstall-dist_pkgdataDATA - -.PRECIOUS: Makefile - - -# Tell versions [3.59,3.63) of GNU make to not export all variables. -# Otherwise a system limit (for SysV at least) may be exceeded. -.NOEXPORT: diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/doc/README_malloc.txt ecl-16.1.3+ds/src/bdwgc/libatomic_ops/doc/README_malloc.txt --- ecl-16.1.2/src/bdwgc/libatomic_ops/doc/README_malloc.txt 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/doc/README_malloc.txt 1970-01-01 00:00:00.000000000 +0000 @@ -1,57 +0,0 @@ -The libatomic_ops_gpl includes a simple almost-lock-free malloc implementation. - -This is intended as a safe way to allocate memory from a signal handler, -or to allocate memory in the context of a library that does not know what -thread library it will be used with. In either case locking is impossible. - -Note that the operations are only guaranteed to be 1-lock-free, i.e. a -single blocked thread will not prevent progress, but multiple blocked -threads may. To safely use these operations in a signal handler, -the handler should be non-reentrant, i.e. it should not be interruptable -by another handler using these operations. Furthermore use outside -of signal handlers in a multithreaded application should be protected -by a lock, so that at most one invocation may be interrupted by a signal. -The header will define the macro "AO_MALLOC_IS_LOCK_FREE" on platforms -on which malloc is completely lock-free, and hence these restrictions -do not apply. - -In the presence of threads, but absence of contention, the time performance -of this package should be as good, or slightly better than, most system -malloc implementations. Its space performance -is theoretically optimal (to within a constant factor), but probably -quite poor in practice. In particular, no attempt is made to -coalesce free small memory blocks. Something like Doug Lea's malloc is -likely to use significantly less memory for complex applications. - -Performance on platforms without an efficient compare-and-swap implementation -will be poor. - -This package was not designed for processor-scalability in the face of -high allocation rates. If all threads happen to allocate different-sized -objects, you might get lucky. Otherwise expect contention and false-sharing -problems. If this is an issue, something like Maged Michael's algorithm -(PLDI 2004) would be technically a far better choice. If you are concerned -only with scalability, and not signal-safety, you might also consider -using Hoard instead. We have seen a factor of 3 to 4 slowdown from the -standard glibc malloc implementation with contention, even when the -performance without contention was faster. (To make the implementation -more scalable, one would need to replicate at least the free list headers, -so that concurrent access is possible without cache conflicts.) - -Unfortunately there is no portable async-signal-safe way to obtain large -chunks of memory from the OS. Based on reading of the source code, -mmap-based allocation appears safe under Linux, and probably BSD variants. -It is probably unsafe for operating systems built on Mach, such as -Apple's Darwin. Without use of mmap, the allocator is -limited to a fixed size, statically preallocated heap (2MB by default), -and will fail to allocate objects above a certain size (just under 64K -by default). Use of mmap to circumvent these limitations requires an -explicit call. - -The entire interface to the AO_malloc package currently consists of: - -#include /* includes atomic_ops.h */ - -void *AO_malloc(size_t sz); -void AO_free(void *p); -void AO_malloc_enable_mmap(void); diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/doc/README_stack.txt ecl-16.1.3+ds/src/bdwgc/libatomic_ops/doc/README_stack.txt --- ecl-16.1.2/src/bdwgc/libatomic_ops/doc/README_stack.txt 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/doc/README_stack.txt 1970-01-01 00:00:00.000000000 +0000 @@ -1,77 +0,0 @@ -Note that the AO_stack implementation is licensed under the GPL, -unlike the lower level routines. - -The header file atomic_ops_stack.h defines a linked stack abstraction. -Stacks may be accessed by multiple concurrent threads. The implementation -is 1-lock-free, i.e. it will continue to make progress if at most one -thread becomes inactive while operating on the data structure. - -(The implementation can be built to be N-lock-free for any given N. But that -seems to rarely be useful, especially since larger N involve some slowdown.) - -This makes it safe to access these data structures from non-reentrant -signal handlers, provided at most one non-signal-handler thread is -accessing the data structure at once. This latter condition can be -ensured by acquiring an ordinary lock around the non-handler accesses -to the data structure. - -For details see: - -Hans-J. Boehm, "An Almost Non-Blocking Stack", PODC 2004, -http://portal.acm.org/citation.cfm?doid=1011767.1011774 -(This is not exactly the implementation described there, since the -interface was cleaned up in the interim. But it should perform -very similarly.) - -We use a fully lock-free implementation when the underlying hardware -makes that less expensive, i.e. when we have a double-wide compare-and-swap -operation available. (The fully lock-free implementation uses an AO_t- -sized version count, and assumes it does not wrap during the time any -given operation is active. This seems reasonably safe on 32-bit hardware, -and very safe on 64-bit hardware.) If a fully lock-free implementation -is used, the macro AO_STACK_IS_LOCK_FREE will be defined. - -The implementation is interesting only because it allows reuse of -existing nodes. This is necessary, for example, to implement a memory -allocator. - -Since we want to leave the precise stack node type up to the client, -we insist only that each stack node contains a link field of type AO_t. -When a new node is pushed on the stack, the push operation expects to be -passed the pointer to this link field, which will then be overwritten by -this link field. Similarly, the pop operation returns a pointer to the -link field of the object that previously was on the top of the stack. - -The cleanest way to use these routines is probably to define the stack node -type with an initial AO_t link field, so that the conversion between the -link-field pointer and the stack element pointer is just a compile-time -cast. But other possibilities exist. (This would be cleaner in C++ with -templates.) - -A stack is represented by an AO_stack_t structure. (This is normally -2 or 3 times the size of a pointer.) It may be statically initialized -by setting it to AO_STACK_INITIALIZER, or dynamically initialized to -an empty stack with AO_stack_init. There are only three operations for -accessing stacks: - -void AO_stack_init(AO_stack_t *list); -void AO_stack_push_release(AO_stack_t *list, AO_t *new_element); -AO_t * AO_stack_pop_acquire(volatile AO_stack_t *list); - -We require that the objects pushed as list elements remain addressable -as long as any push or pop operation are in progress. (It is OK for an object -to be "pop"ped off a stack and "deallocated" with a concurrent "pop" on -the same stack still in progress, but only if "deallocation" leaves the -object addressable. The second "pop" may still read the object, but -the value it reads will not matter.) - -We require that the headers (AO_stack objects) remain allocated and -valid as long as any operations on them are still in-flight. - -We also provide macros AO_REAL_HEAD_PTR that converts an AO_stack_t -to a pointer to the link field in the next element, and AO_REAL_NEXT_PTR -that converts a link field to a real, dereferencable, pointer to the link field -in the next element. This is intended only for debugging, or to traverse -the list after modification has ceased. There is otherwise no guarantee that -walking a stack using this macro will produce any kind of consistent -picture of the data structure. diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/doc/README.txt ecl-16.1.3+ds/src/bdwgc/libatomic_ops/doc/README.txt --- ecl-16.1.2/src/bdwgc/libatomic_ops/doc/README.txt 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/doc/README.txt 1970-01-01 00:00:00.000000000 +0000 @@ -1,246 +0,0 @@ -Usage: - -0) If possible, do this on a multiprocessor, especially if you are planning -on modifying or enhancing the package. It will work on a uniprocessor, -but the tests are much more likely to pass in the presence of serious problems. - -1) Type ./configure --prefix=; make; make check -in the directory containing unpacked source. The usual GNU build machinery -is used, except that only static, but position-independent, libraries -are normally built. On Windows, read README_win32.txt instead. - -2) Applications should include atomic_ops.h. Nearly all operations -are implemented by header files included from it. It is sometimes -necessary, and always recommended to also link against libatomic_ops.a. -To use the almost non-blocking stack or malloc implementations, -see the corresponding README files, and also link against libatomic_gpl.a -before linking against libatomic_ops.a. - -OVERVIEW: -Atomic_ops.h defines a large collection of operations, each one of which is -a combination of an (optional) atomic memory operation, and a memory barrier. -Also defines associated feature-test macros to determine whether a particular -operation is available on the current target hardware (either directly or -by synthesis). This is an attempt to replace various existing files with -similar goals, since they usually do not handle differences in memory -barrier styles with sufficient generality. - -If this is included after defining AO_REQUIRE_CAS, then the package -will make an attempt to emulate compare-and-swap in a way that (at least -on Linux) should still be async-signal-safe. As a result, most other -atomic operations will then be defined using the compare-and-swap -emulation. This emulation is slow, since it needs to disable signals. -And it needs to block in case of contention. If you care about performance -on a platform that can't directly provide compare-and-swap, there are -probably better alternatives. But this allows easy ports to some such -platforms (e.g. PA_RISC). The option is ignored if compare-and-swap -can be implemented directly. - -If atomic_ops.h is included after defining AO_USE_PTHREAD_DEFS, then all -atomic operations will be emulated with pthread locking. This is NOT -async-signal-safe. And it is slow. It is intended primarily for debugging -of the atomic_ops package itself. - -Note that the implementation reflects our understanding of real processor -behavior. This occasionally diverges from the documented behavior. (E.g. -the documented X86 behavior seems to be weak enough that it is impractical -to use. Current real implementations appear to be much better behaved.) -We of course are in no position to guarantee that future processors -(even HPs) will continue to behave this way, though we hope they will. - -This is a work in progress. Corrections/additions for other platforms are -greatly appreciated. It passes rudimentary tests on X86, Itanium, and -Alpha. - -OPERATIONS: - -Most operations operate on values of type AO_t, which are unsigned integers -whose size matches that of pointers on the given architecture. Exceptions -are: - -- AO_test_and_set operates on AO_TS_t, which is whatever size the hardware -supports with good performance. In some cases this is the length of a cache -line. In some cases it is a byte. In many cases it is equivalent to AO_t. - -- A few operations are implemented on smaller or larger size integers. -Such operations are indicated by the appropriate prefix: - -AO_char_... Operates on unsigned char values. -AO_short_... Operates on unsigned short values. -AO_int_... Operates on unsigned int values. - -(Currently a very limited selection of these is implemented. We're -working on it.) - -The defined operations are all of the form AO_[_](). - -The component specifies an atomic memory operation. It may be -one of the following, where the corresponding argument and result types -are also specified: - -void nop() - No atomic operation. The barrier may still be useful. -AO_t load(const volatile AO_t * addr) - Atomic load of *addr. -void store(volatile AO_t * addr, AO_t new_val) - Atomically store new_val to *addr. -AO_t fetch_and_add(volatile AO_t *addr, AO_t incr) - Atomically add incr to *addr, and return the original value of *addr. -AO_t fetch_and_add1(volatile AO_t *addr) - Equivalent to AO_fetch_and_add(addr, 1). -AO_t fetch_and_sub1(volatile AO_t *addr) - Equivalent to AO_fetch_and_add(addr, (AO_t)(-1)). -void and(volatile AO_t *addr, AO_t value) - Atomically 'and' value into *addr. -void or(volatile AO_t *addr, AO_t value) - Atomically 'or' value into *addr. -void xor(volatile AO_t *addr, AO_t value) - Atomically 'xor' value into *addr. -int compare_and_swap(volatile AO_t * addr, AO_t old_val, AO_t new_val) - Atomically compare *addr to old_val, and replace *addr by new_val - if the first comparison succeeds. Returns nonzero if the comparison - succeeded and *addr was updated. -AO_t fetch_compare_and_swap(volatile AO_t * addr, AO_t old_val, AO_t new_val) - Atomically compare *addr to old_val, and replace *addr by new_val - if the first comparison succeeds; returns the original value of *addr. -AO_TS_VAL_t test_and_set(volatile AO_TS_t * addr) - Atomically read the binary value at *addr, and set it. AO_TS_VAL_t - is an enumeration type which includes two values AO_TS_SET and - AO_TS_CLEAR. An AO_TS_t location is capable of holding an - AO_TS_VAL_t, but may be much larger, as dictated by hardware - constraints. Test_and_set logically sets the value to AO_TS_SET. - It may be reset to AO_TS_CLEAR with the AO_CLEAR(AO_TS_t *) macro. - AO_TS_t locations should be initialized to AO_TS_INITIALIZER. - The values of AO_TS_SET and AO_TS_CLEAR are hardware dependent. - (On PA-RISC, AO_TS_SET is zero!) - -Test_and_set is a more limited version of compare_and_swap. Its only -advantage is that it is more easily implementable on some hardware. It -should thus be used if only binary test-and-set functionality is needed. - -If available, we also provide compare_and_swap operations that operate -on wider values. Since standard data types for double width values -may not be available, these explicitly take pairs of arguments for the -new and/or old value. Unfortunately, there are two common variants, -neither of which can easily and efficiently emulate the other. -The first performs a comparison against the entire value being replaced, -where the second replaces a double-width replacement, but performs -a single-width comparison: - -int compare_double_and_swap_double(volatile AO_double_t * addr, - AO_t old_val1, AO_t old_val2, - AO_t new_val1, AO_t new_val2); - -int compare_and_swap_double(volatile AO_double_t * addr, - AO_t old_val1, - AO_t new_val1, AO_t new_val2); - -where AO_double_t is a structure containing AO_val1 and AO_val2 fields, -both of type AO_t. For compare_and_swap_double, we compare against -the val1 field. AO_double_t exists only if AO_HAVE_double_t -is defined. - -ORDERING CONSTRAINTS: - -Each operation name also includes a suffix that specifies the associated -ordering semantics. The ordering constraint limits reordering of this -operation with respect to other atomic operations and ordinary memory -references. The current implementation assumes that all memory references -are to ordinary cacheable memory; the ordering guarantee is with respect -to other threads or processes, not I/O devices. (Whether or not this -distinction is important is platform-dependent.) - -Ordering suffixes are one of the following: - -: No memory barrier. A plain AO_nop() really does nothing. -_release: Earlier operations must become visible to other threads - before the atomic operation. -_acquire: Later operations must become visible after this operation. -_read: Subsequent reads must become visible after reads included in - the atomic operation or preceding it. Rarely useful for clients? -_write: Earlier writes become visible before writes during or after - the atomic operation. Rarely useful for clients? -_full: Ordered with respect to both earlier and later memory ops. - AO_store_full or AO_nop_full are the normal ways to force a store - to be ordered with respect to a later load. -_release_write: Ordered with respect to earlier writes. This is - normally implemented as either a _write or _release - barrier. -_acquire_read: Ordered with respect to later reads. This is - normally implemented as either a _read or _acquire barrier. -_dd_acquire_read: Ordered with respect to later reads that are data - dependent on this one. This is needed on - a pointer read, which is later dereferenced to read a - second value, with the expectation that the second - read is ordered after the first one. On most architectures, - this is equivalent to no barrier. (This is very - hard to define precisely. It should probably be avoided. - A major problem is that optimizers tend to try to - eliminate dependencies from the generated code, since - dependencies force the hardware to execute the code - serially.) - -We assume that if a store is data-dependent on a previous load, then -the two are always implicitly ordered. - -It is possible to test whether AO_ is available on the -current platform by checking whether AO_HAVE__ is defined -as a macro. - -Note that we generally don't implement operations that are either -meaningless (e.g. AO_nop_acquire, AO_nop_release) or which appear to -have no clear use (e.g. AO_load_release, AO_store_acquire, AO_load_write, -AO_store_read). On some platforms (e.g. PA-RISC) many operations -will remain undefined unless AO_REQUIRE_CAS is defined before including -the package. - -When typed in the package build directory, the following command -will print operations that are unimplemented on the platform: - -make test_atomic; ./test_atomic - -The following command generates a file "list_atomic.i" containing the -macro expansions of all implemented operations on the platform: - -make list_atomic.i - -Future directions: - -It currently appears that something roughly analogous to this is very likely -to become part of the C++0x standard. That effort has pointed out a number -of issues that we expect to address there. Since some of the solutions -really require compiler support, they may not be completely addressed here. - -Known issues include: - -We should be more precise in defining the semantics of the ordering -constraints, and if and how we can guarantee sequential consistency. - -Dd_acquire_read is very hard or impossible to define in a way that cannot -be invalidated by reasonably standard compiler transformations. - -There is probably no good reason to provide operations on standard -integer types, since those may have the wrong alignment constraints. - - -Example: - -If you want to initialize an object, and then "publish" a pointer to it -in a global location p, such that other threads reading the new value of -p are guaranteed to see an initialized object, it suffices to use -AO_release_write(p, ...) to write the pointer to the object, and to -retrieve it in other threads with AO_acquire_read(p). - -Platform notes: - -All X86: We quietly assume 486 or better. - -Microsoft compilers: -Define AO_ASSUME_WINDOWS98 to get access to hardware compare-and-swap -functionality. This relies on the InterlockedCompareExchange() function -which was apparently not supported in Windows95. (There may be a better -way to get access to this.) - -Gcc on x86: -Define AO_USE_PENTIUM4_INSTRS to use the Pentium 4 mfence instruction. -Currently this is appears to be of marginal benefit. diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/doc/README_win32.txt ecl-16.1.3+ds/src/bdwgc/libatomic_ops/doc/README_win32.txt --- ecl-16.1.2/src/bdwgc/libatomic_ops/doc/README_win32.txt 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/doc/README_win32.txt 1970-01-01 00:00:00.000000000 +0000 @@ -1,31 +0,0 @@ -Most of the atomic_ops functionality is available under Win32 with -the Microsoft tools, but the build process currently is considerably more -primitive than on Linux/Unix platforms. - -To build: - -1) Go to the src directory in the distribution. -2) Make sure the Microsoft command-line tools (e.g. nmake) are available. -3) Run "nmake -f Makefile.msft". This should run some tests, which -may print warnings about the types of the "Interlocked" functions. -I haven't been able to make all versions of VC++ happy. If you know -how to, please send a patch. -4) To compile applications, you will need to retain or copy the following -pieces from the resulting src directory contents: - "atomic_ops.h" - Header file defining low-level primitives. This - includes files from: - "atomic_ops"- Subdirectory containing implementation header files. - "atomic_ops_stack.h" - Header file describing almost lock-free stack. - "atomic_ops_malloc.h" - Header file describing almost lock-free malloc. - "libatomic_ops_gpl.lib" - Library containing implementation of the - above two (plus AO_pause() defined in atomic_ops.c). - The atomic_ops.h implementation is entirely in the - header files in Win32. - -Most clients of atomic_ops.h will need to define AO_ASSUME_WINDOWS98 before -including it. Compare_and_swap is otherwise not available. -Defining AO_ASSUME_VISTA will make compare_double_and_swap_double available -as well. - -Note that the library is covered by the GNU General Public License, while -the top 2 of these pieces allow use in proprietary code. diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/.gitattributes ecl-16.1.3+ds/src/bdwgc/libatomic_ops/.gitattributes --- ecl-16.1.2/src/bdwgc/libatomic_ops/.gitattributes 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/.gitattributes 1970-01-01 00:00:00.000000000 +0000 @@ -1,7 +0,0 @@ -# Git repo attributes. - -# Ensure all text files have normalized (LF) line endings in the repository. -* text=auto - -# Note: "core.eol" configuration variable controls which line endings to use -# for the normalized files in the working directory (the default is native). diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/.gitignore ecl-16.1.3+ds/src/bdwgc/libatomic_ops/.gitignore --- ecl-16.1.2/src/bdwgc/libatomic_ops/.gitignore 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/.gitignore 1970-01-01 00:00:00.000000000 +0000 @@ -1,69 +0,0 @@ -# Ignored files in libatomic_ops Git repo. - -Makefile - -/pkgconfig/atomic_ops.pc -/pkgconfig/atomic_ops-uninstalled.pc -/autom4te.cache/ -/config.cache -/config.log -/config.status -/libatomic_ops-* - -*.a -*.dll -*.exe -*.gcda -*.gch -*.gcno -*.la -*.lib -*.lo -*.o -*.obj -*.so - -/src/.deps/ -/src/.dirstamp -/src/.libs/ -/src/config.h -/src/config.h.in~ -/src/stamp-h1 - -/tests/.deps/ -/tests/.dirstamp -/tests/.libs/ -/tests/core -/tests/list_atomic.i -/tests/test_atomic -/tests/test_atomic_pthreads -/tests/test_malloc -/tests/test_stack - -# External library (without trailing slash to allow symlinks): -/pthreads-w32* - -# These files are generated by autoreconf: -/aclocal.m4 -/compile -/config.guess -/config.sub -/configure -/depcomp -/install-sh -/missing -/mkinstalldirs -/src/config.h.in -/test-driver -Makefile.in - -# Generated by libtoolize: -/libtool -/ltmain.sh -/m4/*.m4 - -# These files are generated by make check: -/tests/list_atomic.c -/tests/test_atomic_include.h -/tests/test*.log -/tests/test*.trs diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/Makefile.am ecl-16.1.3+ds/src/bdwgc/libatomic_ops/Makefile.am --- ecl-16.1.2/src/bdwgc/libatomic_ops/Makefile.am 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/Makefile.am 1970-01-01 00:00:00.000000000 +0000 @@ -1,13 +0,0 @@ -SUBDIRS = src doc tests - -ACLOCAL_AMFLAGS = -I m4 - -pkgconfigdir = $(libdir)/pkgconfig -pkgconfig_DATA = pkgconfig/atomic_ops.pc -noinst_DATA = pkgconfig/atomic_ops-uninstalled.pc - -dist_pkgdata_DATA = COPYING README.md - -EXTRA_DIST = autogen.sh - -#distclean-local: diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/Makefile.in ecl-16.1.3+ds/src/bdwgc/libatomic_ops/Makefile.in --- ecl-16.1.2/src/bdwgc/libatomic_ops/Makefile.in 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/Makefile.in 1970-01-01 00:00:00.000000000 +0000 @@ -1,896 +0,0 @@ -# Makefile.in generated by automake 1.15 from Makefile.am. -# @configure_input@ - -# Copyright (C) 1994-2014 Free Software Foundation, Inc. - -# This Makefile.in 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. - -@SET_MAKE@ - -VPATH = @srcdir@ -am__is_gnu_make = { \ - if test -z '$(MAKELEVEL)'; then \ - false; \ - elif test -n '$(MAKE_HOST)'; then \ - true; \ - elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ - true; \ - else \ - false; \ - fi; \ -} -am__make_running_with_option = \ - case $${target_option-} in \ - ?) ;; \ - *) echo "am__make_running_with_option: internal error: invalid" \ - "target option '$${target_option-}' specified" >&2; \ - exit 1;; \ - esac; \ - has_opt=no; \ - sane_makeflags=$$MAKEFLAGS; \ - if $(am__is_gnu_make); then \ - sane_makeflags=$$MFLAGS; \ - else \ - case $$MAKEFLAGS in \ - *\\[\ \ ]*) \ - bs=\\; \ - sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ - | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ - esac; \ - fi; \ - skip_next=no; \ - strip_trailopt () \ - { \ - flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ - }; \ - for flg in $$sane_makeflags; do \ - test $$skip_next = yes && { skip_next=no; continue; }; \ - case $$flg in \ - *=*|--*) continue;; \ - -*I) strip_trailopt 'I'; skip_next=yes;; \ - -*I?*) strip_trailopt 'I';; \ - -*O) strip_trailopt 'O'; skip_next=yes;; \ - -*O?*) strip_trailopt 'O';; \ - -*l) strip_trailopt 'l'; skip_next=yes;; \ - -*l?*) strip_trailopt 'l';; \ - -[dEDm]) skip_next=yes;; \ - -[JT]) skip_next=yes;; \ - esac; \ - case $$flg in \ - *$$target_option*) has_opt=yes; break;; \ - esac; \ - done; \ - test $$has_opt = yes -am__make_dryrun = (target_option=n; $(am__make_running_with_option)) -am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) -pkgdatadir = $(datadir)/@PACKAGE@ -pkgincludedir = $(includedir)/@PACKAGE@ -pkglibdir = $(libdir)/@PACKAGE@ -pkglibexecdir = $(libexecdir)/@PACKAGE@ -am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd -install_sh_DATA = $(install_sh) -c -m 644 -install_sh_PROGRAM = $(install_sh) -c -install_sh_SCRIPT = $(install_sh) -c -INSTALL_HEADER = $(INSTALL_DATA) -transform = $(program_transform_name) -NORMAL_INSTALL = : -PRE_INSTALL = : -POST_INSTALL = : -NORMAL_UNINSTALL = : -PRE_UNINSTALL = : -POST_UNINSTALL = : -build_triplet = @build@ -host_triplet = @host@ -target_triplet = @target@ -subdir = . -ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 -am__aclocal_m4_deps = $(top_srcdir)/m4/libtool.m4 \ - $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \ - $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \ - $(top_srcdir)/configure.ac -am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ - $(ACLOCAL_M4) -DIST_COMMON = $(srcdir)/Makefile.am $(top_srcdir)/configure \ - $(am__configure_deps) $(dist_pkgdata_DATA) $(am__DIST_COMMON) -am__CONFIG_DISTCLEAN_FILES = config.status config.cache config.log \ - configure.lineno config.status.lineno -mkinstalldirs = $(install_sh) -d -CONFIG_HEADER = $(top_builddir)/src/config.h -CONFIG_CLEAN_FILES = pkgconfig/atomic_ops.pc \ - pkgconfig/atomic_ops-uninstalled.pc -CONFIG_CLEAN_VPATH_FILES = -AM_V_P = $(am__v_P_@AM_V@) -am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) -am__v_P_0 = false -am__v_P_1 = : -AM_V_GEN = $(am__v_GEN_@AM_V@) -am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) -am__v_GEN_0 = @echo " GEN " $@; -am__v_GEN_1 = -AM_V_at = $(am__v_at_@AM_V@) -am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) -am__v_at_0 = @ -am__v_at_1 = -SOURCES = -DIST_SOURCES = -RECURSIVE_TARGETS = all-recursive check-recursive cscopelist-recursive \ - ctags-recursive dvi-recursive html-recursive info-recursive \ - install-data-recursive install-dvi-recursive \ - install-exec-recursive install-html-recursive \ - install-info-recursive install-pdf-recursive \ - install-ps-recursive install-recursive installcheck-recursive \ - installdirs-recursive pdf-recursive ps-recursive \ - tags-recursive uninstall-recursive -am__can_run_installinfo = \ - case $$AM_UPDATE_INFO_DIR in \ - n|no|NO) false;; \ - *) (install-info --version) >/dev/null 2>&1;; \ - esac -am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; -am__vpath_adj = case $$p in \ - $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ - *) f=$$p;; \ - esac; -am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`; -am__install_max = 40 -am__nobase_strip_setup = \ - srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'` -am__nobase_strip = \ - for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||" -am__nobase_list = $(am__nobase_strip_setup); \ - for p in $$list; do echo "$$p $$p"; done | \ - sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \ - $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \ - if (++n[$$2] == $(am__install_max)) \ - { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \ - END { for (dir in files) print dir, files[dir] }' -am__base_list = \ - sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \ - sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g' -am__uninstall_files_from_dir = { \ - test -z "$$files" \ - || { test ! -d "$$dir" && test ! -f "$$dir" && test ! -r "$$dir"; } \ - || { echo " ( cd '$$dir' && rm -f" $$files ")"; \ - $(am__cd) "$$dir" && rm -f $$files; }; \ - } -am__installdirs = "$(DESTDIR)$(pkgdatadir)" \ - "$(DESTDIR)$(pkgconfigdir)" -DATA = $(dist_pkgdata_DATA) $(noinst_DATA) $(pkgconfig_DATA) -RECURSIVE_CLEAN_TARGETS = mostlyclean-recursive clean-recursive \ - distclean-recursive maintainer-clean-recursive -am__recursive_targets = \ - $(RECURSIVE_TARGETS) \ - $(RECURSIVE_CLEAN_TARGETS) \ - $(am__extra_recursive_targets) -AM_RECURSIVE_TARGETS = $(am__recursive_targets:-recursive=) TAGS CTAGS \ - cscope distdir dist dist-all distcheck -am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP) -# Read a list of newline-separated strings from the standard input, -# and print each of them once, without duplicates. Input order is -# *not* preserved. -am__uniquify_input = $(AWK) '\ - BEGIN { nonempty = 0; } \ - { items[$$0] = 1; nonempty = 1; } \ - END { if (nonempty) { for (i in items) print i; }; } \ -' -# Make sure the list of sources is unique. This is necessary because, -# e.g., the same source file might be shared among _SOURCES variables -# for different programs/libraries. -am__define_uniq_tagged_files = \ - list='$(am__tagged_files)'; \ - unique=`for i in $$list; do \ - if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ - done | $(am__uniquify_input)` -ETAGS = etags -CTAGS = ctags -CSCOPE = cscope -DIST_SUBDIRS = $(SUBDIRS) -am__DIST_COMMON = $(srcdir)/Makefile.in $(top_srcdir)/../compile \ - $(top_srcdir)/../config.guess $(top_srcdir)/../config.sub \ - $(top_srcdir)/../install-sh $(top_srcdir)/../ltmain.sh \ - $(top_srcdir)/../missing \ - $(top_srcdir)/pkgconfig/atomic_ops-uninstalled.pc.in \ - $(top_srcdir)/pkgconfig/atomic_ops.pc.in AUTHORS COPYING \ - ChangeLog TODO -DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) -distdir = $(PACKAGE)-$(VERSION) -top_distdir = $(distdir) -am__remove_distdir = \ - if test -d "$(distdir)"; then \ - find "$(distdir)" -type d ! -perm -200 -exec chmod u+w {} ';' \ - && rm -rf "$(distdir)" \ - || { sleep 5 && rm -rf "$(distdir)"; }; \ - else :; fi -am__post_remove_distdir = $(am__remove_distdir) -am__relativize = \ - dir0=`pwd`; \ - sed_first='s,^\([^/]*\)/.*$$,\1,'; \ - sed_rest='s,^[^/]*/*,,'; \ - sed_last='s,^.*/\([^/]*\)$$,\1,'; \ - sed_butlast='s,/*[^/]*$$,,'; \ - while test -n "$$dir1"; do \ - first=`echo "$$dir1" | sed -e "$$sed_first"`; \ - if test "$$first" != "."; then \ - if test "$$first" = ".."; then \ - dir2=`echo "$$dir0" | sed -e "$$sed_last"`/"$$dir2"; \ - dir0=`echo "$$dir0" | sed -e "$$sed_butlast"`; \ - else \ - first2=`echo "$$dir2" | sed -e "$$sed_first"`; \ - if test "$$first2" = "$$first"; then \ - dir2=`echo "$$dir2" | sed -e "$$sed_rest"`; \ - else \ - dir2="../$$dir2"; \ - fi; \ - dir0="$$dir0"/"$$first"; \ - fi; \ - fi; \ - dir1=`echo "$$dir1" | sed -e "$$sed_rest"`; \ - done; \ - reldir="$$dir2" -DIST_ARCHIVES = $(distdir).tar.gz $(distdir).tar.bz2 -GZIP_ENV = --best -DIST_TARGETS = dist-bzip2 dist-gzip -distuninstallcheck_listfiles = find . -type f -print -am__distuninstallcheck_listfiles = $(distuninstallcheck_listfiles) \ - | sed 's|^\./|$(prefix)/|' | grep -v '$(infodir)/dir$$' -distcleancheck_listfiles = find . -type f -print -ACLOCAL = @ACLOCAL@ -AMTAR = @AMTAR@ -AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ -AR = @AR@ -AUTOCONF = @AUTOCONF@ -AUTOHEADER = @AUTOHEADER@ -AUTOMAKE = @AUTOMAKE@ -AWK = @AWK@ -CC = @CC@ -CCAS = @CCAS@ -CCASDEPMODE = @CCASDEPMODE@ -CCASFLAGS = @CCASFLAGS@ -CCDEPMODE = @CCDEPMODE@ -CFLAGS = @CFLAGS@ -CPP = @CPP@ -CPPFLAGS = @CPPFLAGS@ -CYGPATH_W = @CYGPATH_W@ -DEFS = @DEFS@ -DEPDIR = @DEPDIR@ -DLLTOOL = @DLLTOOL@ -DSYMUTIL = @DSYMUTIL@ -DUMPBIN = @DUMPBIN@ -ECHO_C = @ECHO_C@ -ECHO_N = @ECHO_N@ -ECHO_T = @ECHO_T@ -EGREP = @EGREP@ -EXEEXT = @EXEEXT@ -FGREP = @FGREP@ -GREP = @GREP@ -INSTALL = @INSTALL@ -INSTALL_DATA = @INSTALL_DATA@ -INSTALL_PROGRAM = @INSTALL_PROGRAM@ -INSTALL_SCRIPT = @INSTALL_SCRIPT@ -INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ -LD = @LD@ -LDFLAGS = @LDFLAGS@ -LIBOBJS = @LIBOBJS@ -LIBS = @LIBS@ -LIBTOOL = @LIBTOOL@ -LIPO = @LIPO@ -LN_S = @LN_S@ -LTLIBOBJS = @LTLIBOBJS@ -LT_SYS_LIBRARY_PATH = @LT_SYS_LIBRARY_PATH@ -MAINT = @MAINT@ -MAKEINFO = @MAKEINFO@ -MANIFEST_TOOL = @MANIFEST_TOOL@ -MKDIR_P = @MKDIR_P@ -NM = @NM@ -NMEDIT = @NMEDIT@ -OBJDUMP = @OBJDUMP@ -OBJEXT = @OBJEXT@ -OTOOL = @OTOOL@ -OTOOL64 = @OTOOL64@ -PACKAGE = @PACKAGE@ -PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ -PACKAGE_NAME = @PACKAGE_NAME@ -PACKAGE_STRING = @PACKAGE_STRING@ -PACKAGE_TARNAME = @PACKAGE_TARNAME@ -PACKAGE_URL = @PACKAGE_URL@ -PACKAGE_VERSION = @PACKAGE_VERSION@ -PATH_SEPARATOR = @PATH_SEPARATOR@ -PICFLAG = @PICFLAG@ -RANLIB = @RANLIB@ -SED = @SED@ -SET_MAKE = @SET_MAKE@ -SHELL = @SHELL@ -STRIP = @STRIP@ -THREADDLLIBS = @THREADDLLIBS@ -VERSION = @VERSION@ -abs_builddir = @abs_builddir@ -abs_srcdir = @abs_srcdir@ -abs_top_builddir = @abs_top_builddir@ -abs_top_srcdir = @abs_top_srcdir@ -ac_ct_AR = @ac_ct_AR@ -ac_ct_CC = @ac_ct_CC@ -ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ -am__include = @am__include@ -am__leading_dot = @am__leading_dot@ -am__quote = @am__quote@ -am__tar = @am__tar@ -am__untar = @am__untar@ -bindir = @bindir@ -build = @build@ -build_alias = @build_alias@ -build_cpu = @build_cpu@ -build_os = @build_os@ -build_vendor = @build_vendor@ -builddir = @builddir@ -datadir = @datadir@ -datarootdir = @datarootdir@ -docdir = @docdir@ -dvidir = @dvidir@ -exec_prefix = @exec_prefix@ -host = @host@ -host_alias = @host_alias@ -host_cpu = @host_cpu@ -host_os = @host_os@ -host_vendor = @host_vendor@ -htmldir = @htmldir@ -includedir = @includedir@ -infodir = @infodir@ -install_sh = @install_sh@ -libdir = @libdir@ -libexecdir = @libexecdir@ -localedir = @localedir@ -localstatedir = @localstatedir@ -mandir = @mandir@ -mkdir_p = @mkdir_p@ -oldincludedir = @oldincludedir@ -pdfdir = @pdfdir@ -prefix = @prefix@ -program_transform_name = @program_transform_name@ -psdir = @psdir@ -sbindir = @sbindir@ -sharedstatedir = @sharedstatedir@ -srcdir = @srcdir@ -sysconfdir = @sysconfdir@ -target = @target@ -target_alias = @target_alias@ -target_cpu = @target_cpu@ -target_os = @target_os@ -target_vendor = @target_vendor@ -top_build_prefix = @top_build_prefix@ -top_builddir = @top_builddir@ -top_srcdir = @top_srcdir@ -SUBDIRS = src doc tests -ACLOCAL_AMFLAGS = -I m4 -pkgconfigdir = $(libdir)/pkgconfig -pkgconfig_DATA = pkgconfig/atomic_ops.pc -noinst_DATA = pkgconfig/atomic_ops-uninstalled.pc -dist_pkgdata_DATA = COPYING README.md -EXTRA_DIST = autogen.sh -all: all-recursive - -.SUFFIXES: -am--refresh: Makefile - @: -$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) - @for dep in $?; do \ - case '$(am__configure_deps)' in \ - *$$dep*) \ - echo ' cd $(srcdir) && $(AUTOMAKE) --foreign'; \ - $(am__cd) $(srcdir) && $(AUTOMAKE) --foreign \ - && exit 0; \ - exit 1;; \ - esac; \ - done; \ - echo ' cd $(top_srcdir) && $(AUTOMAKE) --foreign Makefile'; \ - $(am__cd) $(top_srcdir) && \ - $(AUTOMAKE) --foreign Makefile -Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status - @case '$?' in \ - *config.status*) \ - echo ' $(SHELL) ./config.status'; \ - $(SHELL) ./config.status;; \ - *) \ - echo ' cd $(top_builddir) && $(SHELL) ./config.status $@ $(am__depfiles_maybe)'; \ - cd $(top_builddir) && $(SHELL) ./config.status $@ $(am__depfiles_maybe);; \ - esac; - -$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) - $(SHELL) ./config.status --recheck - -$(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) - $(am__cd) $(srcdir) && $(AUTOCONF) -$(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) - $(am__cd) $(srcdir) && $(ACLOCAL) $(ACLOCAL_AMFLAGS) -$(am__aclocal_m4_deps): -pkgconfig/atomic_ops.pc: $(top_builddir)/config.status $(top_srcdir)/pkgconfig/atomic_ops.pc.in - cd $(top_builddir) && $(SHELL) ./config.status $@ -pkgconfig/atomic_ops-uninstalled.pc: $(top_builddir)/config.status $(top_srcdir)/pkgconfig/atomic_ops-uninstalled.pc.in - cd $(top_builddir) && $(SHELL) ./config.status $@ - -mostlyclean-libtool: - -rm -f *.lo - -clean-libtool: - -rm -rf .libs _libs - -distclean-libtool: - -rm -f libtool config.lt -install-dist_pkgdataDATA: $(dist_pkgdata_DATA) - @$(NORMAL_INSTALL) - @list='$(dist_pkgdata_DATA)'; test -n "$(pkgdatadir)" || list=; \ - if test -n "$$list"; then \ - echo " $(MKDIR_P) '$(DESTDIR)$(pkgdatadir)'"; \ - $(MKDIR_P) "$(DESTDIR)$(pkgdatadir)" || exit 1; \ - fi; \ - for p in $$list; do \ - if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ - echo "$$d$$p"; \ - done | $(am__base_list) | \ - while read files; do \ - echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(pkgdatadir)'"; \ - $(INSTALL_DATA) $$files "$(DESTDIR)$(pkgdatadir)" || exit $$?; \ - done - -uninstall-dist_pkgdataDATA: - @$(NORMAL_UNINSTALL) - @list='$(dist_pkgdata_DATA)'; test -n "$(pkgdatadir)" || list=; \ - files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ - dir='$(DESTDIR)$(pkgdatadir)'; $(am__uninstall_files_from_dir) -install-pkgconfigDATA: $(pkgconfig_DATA) - @$(NORMAL_INSTALL) - @list='$(pkgconfig_DATA)'; test -n "$(pkgconfigdir)" || list=; \ - if test -n "$$list"; then \ - echo " $(MKDIR_P) '$(DESTDIR)$(pkgconfigdir)'"; \ - $(MKDIR_P) "$(DESTDIR)$(pkgconfigdir)" || exit 1; \ - fi; \ - for p in $$list; do \ - if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ - echo "$$d$$p"; \ - done | $(am__base_list) | \ - while read files; do \ - echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(pkgconfigdir)'"; \ - $(INSTALL_DATA) $$files "$(DESTDIR)$(pkgconfigdir)" || exit $$?; \ - done - -uninstall-pkgconfigDATA: - @$(NORMAL_UNINSTALL) - @list='$(pkgconfig_DATA)'; test -n "$(pkgconfigdir)" || list=; \ - files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ - dir='$(DESTDIR)$(pkgconfigdir)'; $(am__uninstall_files_from_dir) - -# This directory's subdirectories are mostly independent; you can cd -# into them and run 'make' without going through this Makefile. -# To change the values of 'make' variables: instead of editing Makefiles, -# (1) if the variable is set in 'config.status', edit 'config.status' -# (which will cause the Makefiles to be regenerated when you run 'make'); -# (2) otherwise, pass the desired values on the 'make' command line. -$(am__recursive_targets): - @fail=; \ - if $(am__make_keepgoing); then \ - failcom='fail=yes'; \ - else \ - failcom='exit 1'; \ - fi; \ - dot_seen=no; \ - target=`echo $@ | sed s/-recursive//`; \ - case "$@" in \ - distclean-* | maintainer-clean-*) list='$(DIST_SUBDIRS)' ;; \ - *) list='$(SUBDIRS)' ;; \ - esac; \ - for subdir in $$list; do \ - echo "Making $$target in $$subdir"; \ - if test "$$subdir" = "."; then \ - dot_seen=yes; \ - local_target="$$target-am"; \ - else \ - local_target="$$target"; \ - fi; \ - ($(am__cd) $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \ - || eval $$failcom; \ - done; \ - if test "$$dot_seen" = "no"; then \ - $(MAKE) $(AM_MAKEFLAGS) "$$target-am" || exit 1; \ - fi; test -z "$$fail" - -ID: $(am__tagged_files) - $(am__define_uniq_tagged_files); mkid -fID $$unique -tags: tags-recursive -TAGS: tags - -tags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) - set x; \ - here=`pwd`; \ - if ($(ETAGS) --etags-include --version) >/dev/null 2>&1; then \ - include_option=--etags-include; \ - empty_fix=.; \ - else \ - include_option=--include; \ - empty_fix=; \ - fi; \ - list='$(SUBDIRS)'; for subdir in $$list; do \ - if test "$$subdir" = .; then :; else \ - test ! -f $$subdir/TAGS || \ - set "$$@" "$$include_option=$$here/$$subdir/TAGS"; \ - fi; \ - done; \ - $(am__define_uniq_tagged_files); \ - shift; \ - if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \ - test -n "$$unique" || unique=$$empty_fix; \ - if test $$# -gt 0; then \ - $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ - "$$@" $$unique; \ - else \ - $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ - $$unique; \ - fi; \ - fi -ctags: ctags-recursive - -CTAGS: ctags -ctags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) - $(am__define_uniq_tagged_files); \ - test -z "$(CTAGS_ARGS)$$unique" \ - || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ - $$unique - -GTAGS: - here=`$(am__cd) $(top_builddir) && pwd` \ - && $(am__cd) $(top_srcdir) \ - && gtags -i $(GTAGS_ARGS) "$$here" -cscope: cscope.files - test ! -s cscope.files \ - || $(CSCOPE) -b -q $(AM_CSCOPEFLAGS) $(CSCOPEFLAGS) -i cscope.files $(CSCOPE_ARGS) -clean-cscope: - -rm -f cscope.files -cscope.files: clean-cscope cscopelist -cscopelist: cscopelist-recursive - -cscopelist-am: $(am__tagged_files) - list='$(am__tagged_files)'; \ - case "$(srcdir)" in \ - [\\/]* | ?:[\\/]*) sdir="$(srcdir)" ;; \ - *) sdir=$(subdir)/$(srcdir) ;; \ - esac; \ - for i in $$list; do \ - if test -f "$$i"; then \ - echo "$(subdir)/$$i"; \ - else \ - echo "$$sdir/$$i"; \ - fi; \ - done >> $(top_builddir)/cscope.files - -distclean-tags: - -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags - -rm -f cscope.out cscope.in.out cscope.po.out cscope.files - -distdir: $(DISTFILES) - $(am__remove_distdir) - test -d "$(distdir)" || mkdir "$(distdir)" - @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ - topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ - list='$(DISTFILES)'; \ - dist_files=`for file in $$list; do echo $$file; done | \ - sed -e "s|^$$srcdirstrip/||;t" \ - -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ - case $$dist_files in \ - */*) $(MKDIR_P) `echo "$$dist_files" | \ - sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ - sort -u` ;; \ - esac; \ - for file in $$dist_files; do \ - if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ - if test -d $$d/$$file; then \ - dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ - if test -d "$(distdir)/$$file"; then \ - find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ - fi; \ - if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ - cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ - find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ - fi; \ - cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ - else \ - test -f "$(distdir)/$$file" \ - || cp -p $$d/$$file "$(distdir)/$$file" \ - || exit 1; \ - fi; \ - done - @list='$(DIST_SUBDIRS)'; for subdir in $$list; do \ - if test "$$subdir" = .; then :; else \ - $(am__make_dryrun) \ - || test -d "$(distdir)/$$subdir" \ - || $(MKDIR_P) "$(distdir)/$$subdir" \ - || exit 1; \ - dir1=$$subdir; dir2="$(distdir)/$$subdir"; \ - $(am__relativize); \ - new_distdir=$$reldir; \ - dir1=$$subdir; dir2="$(top_distdir)"; \ - $(am__relativize); \ - new_top_distdir=$$reldir; \ - echo " (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) top_distdir="$$new_top_distdir" distdir="$$new_distdir" \\"; \ - echo " am__remove_distdir=: am__skip_length_check=: am__skip_mode_fix=: distdir)"; \ - ($(am__cd) $$subdir && \ - $(MAKE) $(AM_MAKEFLAGS) \ - top_distdir="$$new_top_distdir" \ - distdir="$$new_distdir" \ - am__remove_distdir=: \ - am__skip_length_check=: \ - am__skip_mode_fix=: \ - distdir) \ - || exit 1; \ - fi; \ - done - -test -n "$(am__skip_mode_fix)" \ - || find "$(distdir)" -type d ! -perm -755 \ - -exec chmod u+rwx,go+rx {} \; -o \ - ! -type d ! -perm -444 -links 1 -exec chmod a+r {} \; -o \ - ! -type d ! -perm -400 -exec chmod a+r {} \; -o \ - ! -type d ! -perm -444 -exec $(install_sh) -c -m a+r {} {} \; \ - || chmod -R a+r "$(distdir)" -dist-gzip: distdir - tardir=$(distdir) && $(am__tar) | GZIP=$(GZIP_ENV) gzip -c >$(distdir).tar.gz - $(am__post_remove_distdir) -dist-bzip2: distdir - tardir=$(distdir) && $(am__tar) | BZIP2=$${BZIP2--9} bzip2 -c >$(distdir).tar.bz2 - $(am__post_remove_distdir) - -dist-lzip: distdir - tardir=$(distdir) && $(am__tar) | lzip -c $${LZIP_OPT--9} >$(distdir).tar.lz - $(am__post_remove_distdir) - -dist-xz: distdir - tardir=$(distdir) && $(am__tar) | XZ_OPT=$${XZ_OPT--e} xz -c >$(distdir).tar.xz - $(am__post_remove_distdir) - -dist-tarZ: distdir - @echo WARNING: "Support for distribution archives compressed with" \ - "legacy program 'compress' is deprecated." >&2 - @echo WARNING: "It will be removed altogether in Automake 2.0" >&2 - tardir=$(distdir) && $(am__tar) | compress -c >$(distdir).tar.Z - $(am__post_remove_distdir) - -dist-shar: distdir - @echo WARNING: "Support for shar distribution archives is" \ - "deprecated." >&2 - @echo WARNING: "It will be removed altogether in Automake 2.0" >&2 - shar $(distdir) | GZIP=$(GZIP_ENV) gzip -c >$(distdir).shar.gz - $(am__post_remove_distdir) - -dist-zip: distdir - -rm -f $(distdir).zip - zip -rq $(distdir).zip $(distdir) - $(am__post_remove_distdir) - -dist dist-all: - $(MAKE) $(AM_MAKEFLAGS) $(DIST_TARGETS) am__post_remove_distdir='@:' - $(am__post_remove_distdir) - -# This target untars the dist file and tries a VPATH configuration. Then -# it guarantees that the distribution is self-contained by making another -# tarfile. -distcheck: dist - case '$(DIST_ARCHIVES)' in \ - *.tar.gz*) \ - GZIP=$(GZIP_ENV) gzip -dc $(distdir).tar.gz | $(am__untar) ;;\ - *.tar.bz2*) \ - bzip2 -dc $(distdir).tar.bz2 | $(am__untar) ;;\ - *.tar.lz*) \ - lzip -dc $(distdir).tar.lz | $(am__untar) ;;\ - *.tar.xz*) \ - xz -dc $(distdir).tar.xz | $(am__untar) ;;\ - *.tar.Z*) \ - uncompress -c $(distdir).tar.Z | $(am__untar) ;;\ - *.shar.gz*) \ - GZIP=$(GZIP_ENV) gzip -dc $(distdir).shar.gz | unshar ;;\ - *.zip*) \ - unzip $(distdir).zip ;;\ - esac - chmod -R a-w $(distdir) - chmod u+w $(distdir) - mkdir $(distdir)/_build $(distdir)/_build/sub $(distdir)/_inst - chmod a-w $(distdir) - test -d $(distdir)/_build || exit 0; \ - dc_install_base=`$(am__cd) $(distdir)/_inst && pwd | sed -e 's,^[^:\\/]:[\\/],/,'` \ - && dc_destdir="$${TMPDIR-/tmp}/am-dc-$$$$/" \ - && am__cwd=`pwd` \ - && $(am__cd) $(distdir)/_build/sub \ - && ../../configure \ - $(AM_DISTCHECK_CONFIGURE_FLAGS) \ - $(DISTCHECK_CONFIGURE_FLAGS) \ - --srcdir=../.. --prefix="$$dc_install_base" \ - && $(MAKE) $(AM_MAKEFLAGS) \ - && $(MAKE) $(AM_MAKEFLAGS) dvi \ - && $(MAKE) $(AM_MAKEFLAGS) check \ - && $(MAKE) $(AM_MAKEFLAGS) install \ - && $(MAKE) $(AM_MAKEFLAGS) installcheck \ - && $(MAKE) $(AM_MAKEFLAGS) uninstall \ - && $(MAKE) $(AM_MAKEFLAGS) distuninstallcheck_dir="$$dc_install_base" \ - distuninstallcheck \ - && chmod -R a-w "$$dc_install_base" \ - && ({ \ - (cd ../.. && umask 077 && mkdir "$$dc_destdir") \ - && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" install \ - && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" uninstall \ - && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" \ - distuninstallcheck_dir="$$dc_destdir" distuninstallcheck; \ - } || { rm -rf "$$dc_destdir"; exit 1; }) \ - && rm -rf "$$dc_destdir" \ - && $(MAKE) $(AM_MAKEFLAGS) dist \ - && rm -rf $(DIST_ARCHIVES) \ - && $(MAKE) $(AM_MAKEFLAGS) distcleancheck \ - && cd "$$am__cwd" \ - || exit 1 - $(am__post_remove_distdir) - @(echo "$(distdir) archives ready for distribution: "; \ - list='$(DIST_ARCHIVES)'; for i in $$list; do echo $$i; done) | \ - sed -e 1h -e 1s/./=/g -e 1p -e 1x -e '$$p' -e '$$x' -distuninstallcheck: - @test -n '$(distuninstallcheck_dir)' || { \ - echo 'ERROR: trying to run $@ with an empty' \ - '$$(distuninstallcheck_dir)' >&2; \ - exit 1; \ - }; \ - $(am__cd) '$(distuninstallcheck_dir)' || { \ - echo 'ERROR: cannot chdir into $(distuninstallcheck_dir)' >&2; \ - exit 1; \ - }; \ - test `$(am__distuninstallcheck_listfiles) | wc -l` -eq 0 \ - || { echo "ERROR: files left after uninstall:" ; \ - if test -n "$(DESTDIR)"; then \ - echo " (check DESTDIR support)"; \ - fi ; \ - $(distuninstallcheck_listfiles) ; \ - exit 1; } >&2 -distcleancheck: distclean - @if test '$(srcdir)' = . ; then \ - echo "ERROR: distcleancheck can only run from a VPATH build" ; \ - exit 1 ; \ - fi - @test `$(distcleancheck_listfiles) | wc -l` -eq 0 \ - || { echo "ERROR: files left in build directory after distclean:" ; \ - $(distcleancheck_listfiles) ; \ - exit 1; } >&2 -check-am: all-am -check: check-recursive -all-am: Makefile $(DATA) -installdirs: installdirs-recursive -installdirs-am: - for dir in "$(DESTDIR)$(pkgdatadir)" "$(DESTDIR)$(pkgconfigdir)"; do \ - test -z "$$dir" || $(MKDIR_P) "$$dir"; \ - done -install: install-recursive -install-exec: install-exec-recursive -install-data: install-data-recursive -uninstall: uninstall-recursive - -install-am: all-am - @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am - -installcheck: installcheck-recursive -install-strip: - if test -z '$(STRIP)'; then \ - $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ - install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ - install; \ - else \ - $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ - install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ - "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ - fi -mostlyclean-generic: - -clean-generic: - -distclean-generic: - -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) - -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) - -maintainer-clean-generic: - @echo "This command is intended for maintainers to use" - @echo "it deletes files that may require special tools to rebuild." -clean: clean-recursive - -clean-am: clean-generic clean-libtool mostlyclean-am - -distclean: distclean-recursive - -rm -f $(am__CONFIG_DISTCLEAN_FILES) - -rm -f Makefile -distclean-am: clean-am distclean-generic distclean-libtool \ - distclean-tags - -dvi: dvi-recursive - -dvi-am: - -html: html-recursive - -html-am: - -info: info-recursive - -info-am: - -install-data-am: install-dist_pkgdataDATA install-pkgconfigDATA - -install-dvi: install-dvi-recursive - -install-dvi-am: - -install-exec-am: - -install-html: install-html-recursive - -install-html-am: - -install-info: install-info-recursive - -install-info-am: - -install-man: - -install-pdf: install-pdf-recursive - -install-pdf-am: - -install-ps: install-ps-recursive - -install-ps-am: - -installcheck-am: - -maintainer-clean: maintainer-clean-recursive - -rm -f $(am__CONFIG_DISTCLEAN_FILES) - -rm -rf $(top_srcdir)/autom4te.cache - -rm -f Makefile -maintainer-clean-am: distclean-am maintainer-clean-generic - -mostlyclean: mostlyclean-recursive - -mostlyclean-am: mostlyclean-generic mostlyclean-libtool - -pdf: pdf-recursive - -pdf-am: - -ps: ps-recursive - -ps-am: - -uninstall-am: uninstall-dist_pkgdataDATA uninstall-pkgconfigDATA - -.MAKE: $(am__recursive_targets) install-am install-strip - -.PHONY: $(am__recursive_targets) CTAGS GTAGS TAGS all all-am \ - am--refresh check check-am clean clean-cscope clean-generic \ - clean-libtool cscope cscopelist-am ctags ctags-am dist \ - dist-all dist-bzip2 dist-gzip dist-lzip dist-shar dist-tarZ \ - dist-xz dist-zip distcheck distclean distclean-generic \ - distclean-libtool distclean-tags distcleancheck distdir \ - distuninstallcheck dvi dvi-am html html-am info info-am \ - install install-am install-data install-data-am \ - install-dist_pkgdataDATA install-dvi install-dvi-am \ - install-exec install-exec-am install-html install-html-am \ - install-info install-info-am install-man install-pdf \ - install-pdf-am install-pkgconfigDATA install-ps install-ps-am \ - install-strip installcheck installcheck-am installdirs \ - installdirs-am maintainer-clean maintainer-clean-generic \ - mostlyclean mostlyclean-generic mostlyclean-libtool pdf pdf-am \ - ps ps-am tags tags-am uninstall uninstall-am \ - uninstall-dist_pkgdataDATA uninstall-pkgconfigDATA - -.PRECIOUS: Makefile - - -#distclean-local: - -# Tell versions [3.59,3.63) of GNU make to not export all variables. -# Otherwise a system limit (for SysV at least) may be exceeded. -.NOEXPORT: diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/pkgconfig/atomic_ops.pc.in ecl-16.1.3+ds/src/bdwgc/libatomic_ops/pkgconfig/atomic_ops.pc.in --- ecl-16.1.2/src/bdwgc/libatomic_ops/pkgconfig/atomic_ops.pc.in 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/pkgconfig/atomic_ops.pc.in 1970-01-01 00:00:00.000000000 +0000 @@ -1,10 +0,0 @@ -prefix=@prefix@ -exec_prefix=@exec_prefix@ -libdir=@libdir@ -includedir=@includedir@ - -Name: The atomic_ops library -Description: Atomic memory update operations portable implementation -Version: @PACKAGE_VERSION@ -Libs: -L${libdir} -latomic_ops -Cflags: -I${includedir} diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/pkgconfig/atomic_ops-uninstalled.pc.in ecl-16.1.3+ds/src/bdwgc/libatomic_ops/pkgconfig/atomic_ops-uninstalled.pc.in --- ecl-16.1.2/src/bdwgc/libatomic_ops/pkgconfig/atomic_ops-uninstalled.pc.in 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/pkgconfig/atomic_ops-uninstalled.pc.in 1970-01-01 00:00:00.000000000 +0000 @@ -1,10 +0,0 @@ -prefix=@prefix@ -exec_prefix=@exec_prefix@ -top_builddir=@abs_top_builddir@ -top_srcdir=@abs_top_srcdir@ - -Name: The atomic_ops library (uninstalled) -Description: Atomic memory update operations -Version: @PACKAGE_VERSION@ -Libs: ${top_builddir}/src/libatomic_ops.la -Cflags: -I${top_builddir}/src -I${top_srcdir}/src diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/README.md ecl-16.1.3+ds/src/bdwgc/libatomic_ops/README.md --- ecl-16.1.2/src/bdwgc/libatomic_ops/README.md 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/README.md 1970-01-01 00:00:00.000000000 +0000 @@ -1,63 +0,0 @@ -# The atomic_ops library (libatomic_ops) - -This is version 7.5.0 of libatomic_ops. - -You might find a more recent version -[here](http://www.hboehm.info/gc/), or -[here](https://github.com/ivmai/libatomic_ops). - - -## Overview - -This package provides semi-portable access to hardware-provided -atomic memory update operations on a number architectures. These might -allow you to write code: - -* That does more interesting things in signal handlers. - -* Makes more effective use of multiprocessors by allowing you to write - clever lock-free code. Note that such code is very difficult to get - right, and will unavoidably be less portable than lock-based code. It - is also not always faster than lock-based code. But it may occasionally - be a large performance win. - -* To experiment with new and much better thread programming paradigms, etc. - -For details and licensing restrictions see the files in the "doc" -subdirectory. - -Please address bug reports to [mailing list](mailto:bdwgc@lists.opendylan.org). - - -## Installation and Usage - -The configuration and build scripts for this package were generated by -Automake/Autoconf. "./configure; make; sudo make install" in this -directory should work. For a more customized build, see the output of -"./configure --help". - -Note that much of the content of this library is in the header files. -However, two small libraries are built and installed: - -* libatomic_ops.a is a support library, which is not needed on some platforms. - This is intended to be usable, under some mild restrictions, in free or - proprietary code, as are all the header files. See doc/LICENSING.txt. - -* libatomic_ops_gpl.a contains some higher level facilities. This code is - currently covered by the GPL. The contents currently correspond to - the headers atomic_ops_stack.h and atomic_ops_malloc.h. - - -## Platform Specific Notes - -Win32/64: src/Makefile.msft contains a very simple Makefile for building -and running tests and building the gpl library. The core atomic_ops -implementation is entirely in header files. - -HP-UX/PA-RISC: aCC -Ae won't work as a C compiler, since it doesn't support -inline assembly code. Use cc. - - -## Copyright & Warranty - -See doc/LICENSING.txt file. diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/ao_version.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/ao_version.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/ao_version.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/ao_version.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,37 +0,0 @@ -/* - * Copyright (c) 2003-2004 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -#ifndef AO_ATOMIC_OPS_H -# error This file should not be included directly. -#endif - -/* The policy regarding version numbers: development code has odd */ -/* "minor" number (and "micro" part is 0); when development is finished */ -/* and a release is prepared, "minor" number is incremented (keeping */ -/* "micro" number still zero), whenever a defect is fixed a new release */ -/* is prepared incrementing "micro" part to odd value (the most stable */ -/* release has the biggest "micro" number). */ - -/* The version here should match that in configure.ac and README. */ -#define AO_VERSION_MAJOR 7 -#define AO_VERSION_MINOR 5 -#define AO_VERSION_MICRO 0 /* 7.5.0 */ diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/generalize-arithm.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/generalize-arithm.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/generalize-arithm.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/generalize-arithm.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,3380 +0,0 @@ -/* - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* char_compare_and_swap (based on fetch_compare_and_swap) */ -#if defined(AO_HAVE_char_fetch_compare_and_swap_full) \ - && !defined(AO_HAVE_char_compare_and_swap_full) - AO_INLINE int - AO_char_compare_and_swap_full(volatile unsigned/**/char *addr, unsigned/**/char old_val, - unsigned/**/char new_val) - { - return AO_char_fetch_compare_and_swap_full(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_char_compare_and_swap_full -#endif - -#if defined(AO_HAVE_char_fetch_compare_and_swap_acquire) \ - && !defined(AO_HAVE_char_compare_and_swap_acquire) - AO_INLINE int - AO_char_compare_and_swap_acquire(volatile unsigned/**/char *addr, unsigned/**/char old_val, - unsigned/**/char new_val) - { - return AO_char_fetch_compare_and_swap_acquire(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_char_compare_and_swap_acquire -#endif - -#if defined(AO_HAVE_char_fetch_compare_and_swap_release) \ - && !defined(AO_HAVE_char_compare_and_swap_release) - AO_INLINE int - AO_char_compare_and_swap_release(volatile unsigned/**/char *addr, unsigned/**/char old_val, - unsigned/**/char new_val) - { - return AO_char_fetch_compare_and_swap_release(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_char_compare_and_swap_release -#endif - -#if defined(AO_HAVE_char_fetch_compare_and_swap_write) \ - && !defined(AO_HAVE_char_compare_and_swap_write) - AO_INLINE int - AO_char_compare_and_swap_write(volatile unsigned/**/char *addr, unsigned/**/char old_val, - unsigned/**/char new_val) - { - return AO_char_fetch_compare_and_swap_write(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_char_compare_and_swap_write -#endif - -#if defined(AO_HAVE_char_fetch_compare_and_swap_read) \ - && !defined(AO_HAVE_char_compare_and_swap_read) - AO_INLINE int - AO_char_compare_and_swap_read(volatile unsigned/**/char *addr, unsigned/**/char old_val, - unsigned/**/char new_val) - { - return AO_char_fetch_compare_and_swap_read(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_char_compare_and_swap_read -#endif - -#if defined(AO_HAVE_char_fetch_compare_and_swap) \ - && !defined(AO_HAVE_char_compare_and_swap) - AO_INLINE int - AO_char_compare_and_swap(volatile unsigned/**/char *addr, unsigned/**/char old_val, - unsigned/**/char new_val) - { - return AO_char_fetch_compare_and_swap(addr, old_val, new_val) == old_val; - } -# define AO_HAVE_char_compare_and_swap -#endif - -#if defined(AO_HAVE_char_fetch_compare_and_swap_release_write) \ - && !defined(AO_HAVE_char_compare_and_swap_release_write) - AO_INLINE int - AO_char_compare_and_swap_release_write(volatile unsigned/**/char *addr, - unsigned/**/char old_val, unsigned/**/char new_val) - { - return AO_char_fetch_compare_and_swap_release_write(addr, old_val, - new_val) == old_val; - } -# define AO_HAVE_char_compare_and_swap_release_write -#endif - -#if defined(AO_HAVE_char_fetch_compare_and_swap_acquire_read) \ - && !defined(AO_HAVE_char_compare_and_swap_acquire_read) - AO_INLINE int - AO_char_compare_and_swap_acquire_read(volatile unsigned/**/char *addr, - unsigned/**/char old_val, unsigned/**/char new_val) - { - return AO_char_fetch_compare_and_swap_acquire_read(addr, old_val, - new_val) == old_val; - } -# define AO_HAVE_char_compare_and_swap_acquire_read -#endif - -#if defined(AO_HAVE_char_fetch_compare_and_swap_dd_acquire_read) \ - && !defined(AO_HAVE_char_compare_and_swap_dd_acquire_read) - AO_INLINE int - AO_char_compare_and_swap_dd_acquire_read(volatile unsigned/**/char *addr, - unsigned/**/char old_val, unsigned/**/char new_val) - { - return AO_char_fetch_compare_and_swap_dd_acquire_read(addr, old_val, - new_val) == old_val; - } -# define AO_HAVE_char_compare_and_swap_dd_acquire_read -#endif - -/* char_fetch_and_add */ -/* We first try to implement fetch_and_add variants in terms of the */ -/* corresponding compare_and_swap variants to minimize adding barriers. */ -#if defined(AO_HAVE_char_compare_and_swap_full) \ - && !defined(AO_HAVE_char_fetch_and_add_full) - AO_INLINE unsigned/**/char - AO_char_fetch_and_add_full(volatile unsigned/**/char *addr, unsigned/**/char incr) - { - unsigned/**/char old; - - do - { - old = *(unsigned/**/char *)addr; - } - while (AO_EXPECT_FALSE(!AO_char_compare_and_swap_full(addr, old, - old + incr))); - return old; - } -# define AO_HAVE_char_fetch_and_add_full -#endif - -#if defined(AO_HAVE_char_compare_and_swap_acquire) \ - && !defined(AO_HAVE_char_fetch_and_add_acquire) - AO_INLINE unsigned/**/char - AO_char_fetch_and_add_acquire(volatile unsigned/**/char *addr, unsigned/**/char incr) - { - unsigned/**/char old; - - do - { - old = *(unsigned/**/char *)addr; - } - while (AO_EXPECT_FALSE(!AO_char_compare_and_swap_acquire(addr, old, - old + incr))); - return old; - } -# define AO_HAVE_char_fetch_and_add_acquire -#endif - -#if defined(AO_HAVE_char_compare_and_swap_release) \ - && !defined(AO_HAVE_char_fetch_and_add_release) - AO_INLINE unsigned/**/char - AO_char_fetch_and_add_release(volatile unsigned/**/char *addr, unsigned/**/char incr) - { - unsigned/**/char old; - - do - { - old = *(unsigned/**/char *)addr; - } - while (AO_EXPECT_FALSE(!AO_char_compare_and_swap_release(addr, old, - old + incr))); - return old; - } -# define AO_HAVE_char_fetch_and_add_release -#endif - -#if defined(AO_HAVE_char_compare_and_swap) \ - && !defined(AO_HAVE_char_fetch_and_add) - AO_INLINE unsigned/**/char - AO_char_fetch_and_add(volatile unsigned/**/char *addr, unsigned/**/char incr) - { - unsigned/**/char old; - - do - { - old = *(unsigned/**/char *)addr; - } - while (AO_EXPECT_FALSE(!AO_char_compare_and_swap(addr, old, - old + incr))); - return old; - } -# define AO_HAVE_char_fetch_and_add -#endif - -#if defined(AO_HAVE_char_fetch_and_add_full) -# if !defined(AO_HAVE_char_fetch_and_add_release) -# define AO_char_fetch_and_add_release(addr, val) \ - AO_char_fetch_and_add_full(addr, val) -# define AO_HAVE_char_fetch_and_add_release -# endif -# if !defined(AO_HAVE_char_fetch_and_add_acquire) -# define AO_char_fetch_and_add_acquire(addr, val) \ - AO_char_fetch_and_add_full(addr, val) -# define AO_HAVE_char_fetch_and_add_acquire -# endif -# if !defined(AO_HAVE_char_fetch_and_add_write) -# define AO_char_fetch_and_add_write(addr, val) \ - AO_char_fetch_and_add_full(addr, val) -# define AO_HAVE_char_fetch_and_add_write -# endif -# if !defined(AO_HAVE_char_fetch_and_add_read) -# define AO_char_fetch_and_add_read(addr, val) \ - AO_char_fetch_and_add_full(addr, val) -# define AO_HAVE_char_fetch_and_add_read -# endif -#endif /* AO_HAVE_char_fetch_and_add_full */ - -#if defined(AO_HAVE_char_fetch_and_add) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_char_fetch_and_add_acquire) - AO_INLINE unsigned/**/char - AO_char_fetch_and_add_acquire(volatile unsigned/**/char *addr, unsigned/**/char incr) - { - unsigned/**/char result = AO_char_fetch_and_add(addr, incr); - AO_nop_full(); - return result; - } -# define AO_HAVE_char_fetch_and_add_acquire -#endif -#if defined(AO_HAVE_char_fetch_and_add) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_char_fetch_and_add_release) -# define AO_char_fetch_and_add_release(addr, incr) \ - (AO_nop_full(), AO_char_fetch_and_add(addr, incr)) -# define AO_HAVE_char_fetch_and_add_release -#endif - -#if !defined(AO_HAVE_char_fetch_and_add) \ - && defined(AO_HAVE_char_fetch_and_add_release) -# define AO_char_fetch_and_add(addr, val) \ - AO_char_fetch_and_add_release(addr, val) -# define AO_HAVE_char_fetch_and_add -#endif -#if !defined(AO_HAVE_char_fetch_and_add) \ - && defined(AO_HAVE_char_fetch_and_add_acquire) -# define AO_char_fetch_and_add(addr, val) \ - AO_char_fetch_and_add_acquire(addr, val) -# define AO_HAVE_char_fetch_and_add -#endif -#if !defined(AO_HAVE_char_fetch_and_add) \ - && defined(AO_HAVE_char_fetch_and_add_write) -# define AO_char_fetch_and_add(addr, val) \ - AO_char_fetch_and_add_write(addr, val) -# define AO_HAVE_char_fetch_and_add -#endif -#if !defined(AO_HAVE_char_fetch_and_add) \ - && defined(AO_HAVE_char_fetch_and_add_read) -# define AO_char_fetch_and_add(addr, val) \ - AO_char_fetch_and_add_read(addr, val) -# define AO_HAVE_char_fetch_and_add -#endif - -#if defined(AO_HAVE_char_fetch_and_add_acquire) \ - && defined(AO_HAVE_nop_full) && !defined(AO_HAVE_char_fetch_and_add_full) -# define AO_char_fetch_and_add_full(addr, val) \ - (AO_nop_full(), AO_char_fetch_and_add_acquire(addr, val)) -# define AO_HAVE_char_fetch_and_add_full -#endif - -#if !defined(AO_HAVE_char_fetch_and_add_release_write) \ - && defined(AO_HAVE_char_fetch_and_add_write) -# define AO_char_fetch_and_add_release_write(addr, val) \ - AO_char_fetch_and_add_write(addr, val) -# define AO_HAVE_char_fetch_and_add_release_write -#endif -#if !defined(AO_HAVE_char_fetch_and_add_release_write) \ - && defined(AO_HAVE_char_fetch_and_add_release) -# define AO_char_fetch_and_add_release_write(addr, val) \ - AO_char_fetch_and_add_release(addr, val) -# define AO_HAVE_char_fetch_and_add_release_write -#endif - -#if !defined(AO_HAVE_char_fetch_and_add_acquire_read) \ - && defined(AO_HAVE_char_fetch_and_add_read) -# define AO_char_fetch_and_add_acquire_read(addr, val) \ - AO_char_fetch_and_add_read(addr, val) -# define AO_HAVE_char_fetch_and_add_acquire_read -#endif -#if !defined(AO_HAVE_char_fetch_and_add_acquire_read) \ - && defined(AO_HAVE_char_fetch_and_add_acquire) -# define AO_char_fetch_and_add_acquire_read(addr, val) \ - AO_char_fetch_and_add_acquire(addr, val) -# define AO_HAVE_char_fetch_and_add_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_char_fetch_and_add_acquire_read) -# define AO_char_fetch_and_add_dd_acquire_read(addr, val) \ - AO_char_fetch_and_add_acquire_read(addr, val) -# define AO_HAVE_char_fetch_and_add_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_char_fetch_and_add) -# define AO_char_fetch_and_add_dd_acquire_read(addr, val) \ - AO_char_fetch_and_add(addr, val) -# define AO_HAVE_char_fetch_and_add_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* char_fetch_and_add1 */ -#if defined(AO_HAVE_char_fetch_and_add_full) \ - && !defined(AO_HAVE_char_fetch_and_add1_full) -# define AO_char_fetch_and_add1_full(addr) \ - AO_char_fetch_and_add_full(addr, 1) -# define AO_HAVE_char_fetch_and_add1_full -#endif -#if defined(AO_HAVE_char_fetch_and_add_release) \ - && !defined(AO_HAVE_char_fetch_and_add1_release) -# define AO_char_fetch_and_add1_release(addr) \ - AO_char_fetch_and_add_release(addr, 1) -# define AO_HAVE_char_fetch_and_add1_release -#endif -#if defined(AO_HAVE_char_fetch_and_add_acquire) \ - && !defined(AO_HAVE_char_fetch_and_add1_acquire) -# define AO_char_fetch_and_add1_acquire(addr) \ - AO_char_fetch_and_add_acquire(addr, 1) -# define AO_HAVE_char_fetch_and_add1_acquire -#endif -#if defined(AO_HAVE_char_fetch_and_add_write) \ - && !defined(AO_HAVE_char_fetch_and_add1_write) -# define AO_char_fetch_and_add1_write(addr) \ - AO_char_fetch_and_add_write(addr, 1) -# define AO_HAVE_char_fetch_and_add1_write -#endif -#if defined(AO_HAVE_char_fetch_and_add_read) \ - && !defined(AO_HAVE_char_fetch_and_add1_read) -# define AO_char_fetch_and_add1_read(addr) \ - AO_char_fetch_and_add_read(addr, 1) -# define AO_HAVE_char_fetch_and_add1_read -#endif -#if defined(AO_HAVE_char_fetch_and_add_release_write) \ - && !defined(AO_HAVE_char_fetch_and_add1_release_write) -# define AO_char_fetch_and_add1_release_write(addr) \ - AO_char_fetch_and_add_release_write(addr, 1) -# define AO_HAVE_char_fetch_and_add1_release_write -#endif -#if defined(AO_HAVE_char_fetch_and_add_acquire_read) \ - && !defined(AO_HAVE_char_fetch_and_add1_acquire_read) -# define AO_char_fetch_and_add1_acquire_read(addr) \ - AO_char_fetch_and_add_acquire_read(addr, 1) -# define AO_HAVE_char_fetch_and_add1_acquire_read -#endif -#if defined(AO_HAVE_char_fetch_and_add) \ - && !defined(AO_HAVE_char_fetch_and_add1) -# define AO_char_fetch_and_add1(addr) AO_char_fetch_and_add(addr, 1) -# define AO_HAVE_char_fetch_and_add1 -#endif - -#if defined(AO_HAVE_char_fetch_and_add1_full) -# if !defined(AO_HAVE_char_fetch_and_add1_release) -# define AO_char_fetch_and_add1_release(addr) \ - AO_char_fetch_and_add1_full(addr) -# define AO_HAVE_char_fetch_and_add1_release -# endif -# if !defined(AO_HAVE_char_fetch_and_add1_acquire) -# define AO_char_fetch_and_add1_acquire(addr) \ - AO_char_fetch_and_add1_full(addr) -# define AO_HAVE_char_fetch_and_add1_acquire -# endif -# if !defined(AO_HAVE_char_fetch_and_add1_write) -# define AO_char_fetch_and_add1_write(addr) \ - AO_char_fetch_and_add1_full(addr) -# define AO_HAVE_char_fetch_and_add1_write -# endif -# if !defined(AO_HAVE_char_fetch_and_add1_read) -# define AO_char_fetch_and_add1_read(addr) \ - AO_char_fetch_and_add1_full(addr) -# define AO_HAVE_char_fetch_and_add1_read -# endif -#endif /* AO_HAVE_char_fetch_and_add1_full */ - -#if !defined(AO_HAVE_char_fetch_and_add1) \ - && defined(AO_HAVE_char_fetch_and_add1_release) -# define AO_char_fetch_and_add1(addr) AO_char_fetch_and_add1_release(addr) -# define AO_HAVE_char_fetch_and_add1 -#endif -#if !defined(AO_HAVE_char_fetch_and_add1) \ - && defined(AO_HAVE_char_fetch_and_add1_acquire) -# define AO_char_fetch_and_add1(addr) AO_char_fetch_and_add1_acquire(addr) -# define AO_HAVE_char_fetch_and_add1 -#endif -#if !defined(AO_HAVE_char_fetch_and_add1) \ - && defined(AO_HAVE_char_fetch_and_add1_write) -# define AO_char_fetch_and_add1(addr) AO_char_fetch_and_add1_write(addr) -# define AO_HAVE_char_fetch_and_add1 -#endif -#if !defined(AO_HAVE_char_fetch_and_add1) \ - && defined(AO_HAVE_char_fetch_and_add1_read) -# define AO_char_fetch_and_add1(addr) AO_char_fetch_and_add1_read(addr) -# define AO_HAVE_char_fetch_and_add1 -#endif - -#if defined(AO_HAVE_char_fetch_and_add1_acquire) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_char_fetch_and_add1_full) -# define AO_char_fetch_and_add1_full(addr) \ - (AO_nop_full(), AO_char_fetch_and_add1_acquire(addr)) -# define AO_HAVE_char_fetch_and_add1_full -#endif - -#if !defined(AO_HAVE_char_fetch_and_add1_release_write) \ - && defined(AO_HAVE_char_fetch_and_add1_write) -# define AO_char_fetch_and_add1_release_write(addr) \ - AO_char_fetch_and_add1_write(addr) -# define AO_HAVE_char_fetch_and_add1_release_write -#endif -#if !defined(AO_HAVE_char_fetch_and_add1_release_write) \ - && defined(AO_HAVE_char_fetch_and_add1_release) -# define AO_char_fetch_and_add1_release_write(addr) \ - AO_char_fetch_and_add1_release(addr) -# define AO_HAVE_char_fetch_and_add1_release_write -#endif -#if !defined(AO_HAVE_char_fetch_and_add1_acquire_read) \ - && defined(AO_HAVE_char_fetch_and_add1_read) -# define AO_char_fetch_and_add1_acquire_read(addr) \ - AO_char_fetch_and_add1_read(addr) -# define AO_HAVE_char_fetch_and_add1_acquire_read -#endif -#if !defined(AO_HAVE_char_fetch_and_add1_acquire_read) \ - && defined(AO_HAVE_char_fetch_and_add1_acquire) -# define AO_char_fetch_and_add1_acquire_read(addr) \ - AO_char_fetch_and_add1_acquire(addr) -# define AO_HAVE_char_fetch_and_add1_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_char_fetch_and_add1_acquire_read) -# define AO_char_fetch_and_add1_dd_acquire_read(addr) \ - AO_char_fetch_and_add1_acquire_read(addr) -# define AO_HAVE_char_fetch_and_add1_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_char_fetch_and_add1) -# define AO_char_fetch_and_add1_dd_acquire_read(addr) \ - AO_char_fetch_and_add1(addr) -# define AO_HAVE_char_fetch_and_add1_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* char_fetch_and_sub1 */ -#if defined(AO_HAVE_char_fetch_and_add_full) \ - && !defined(AO_HAVE_char_fetch_and_sub1_full) -# define AO_char_fetch_and_sub1_full(addr) \ - AO_char_fetch_and_add_full(addr, (unsigned/**/char)(-1)) -# define AO_HAVE_char_fetch_and_sub1_full -#endif -#if defined(AO_HAVE_char_fetch_and_add_release) \ - && !defined(AO_HAVE_char_fetch_and_sub1_release) -# define AO_char_fetch_and_sub1_release(addr) \ - AO_char_fetch_and_add_release(addr, (unsigned/**/char)(-1)) -# define AO_HAVE_char_fetch_and_sub1_release -#endif -#if defined(AO_HAVE_char_fetch_and_add_acquire) \ - && !defined(AO_HAVE_char_fetch_and_sub1_acquire) -# define AO_char_fetch_and_sub1_acquire(addr) \ - AO_char_fetch_and_add_acquire(addr, (unsigned/**/char)(-1)) -# define AO_HAVE_char_fetch_and_sub1_acquire -#endif -#if defined(AO_HAVE_char_fetch_and_add_write) \ - && !defined(AO_HAVE_char_fetch_and_sub1_write) -# define AO_char_fetch_and_sub1_write(addr) \ - AO_char_fetch_and_add_write(addr, (unsigned/**/char)(-1)) -# define AO_HAVE_char_fetch_and_sub1_write -#endif -#if defined(AO_HAVE_char_fetch_and_add_read) \ - && !defined(AO_HAVE_char_fetch_and_sub1_read) -# define AO_char_fetch_and_sub1_read(addr) \ - AO_char_fetch_and_add_read(addr, (unsigned/**/char)(-1)) -# define AO_HAVE_char_fetch_and_sub1_read -#endif -#if defined(AO_HAVE_char_fetch_and_add_release_write) \ - && !defined(AO_HAVE_char_fetch_and_sub1_release_write) -# define AO_char_fetch_and_sub1_release_write(addr) \ - AO_char_fetch_and_add_release_write(addr, (unsigned/**/char)(-1)) -# define AO_HAVE_char_fetch_and_sub1_release_write -#endif -#if defined(AO_HAVE_char_fetch_and_add_acquire_read) \ - && !defined(AO_HAVE_char_fetch_and_sub1_acquire_read) -# define AO_char_fetch_and_sub1_acquire_read(addr) \ - AO_char_fetch_and_add_acquire_read(addr, (unsigned/**/char)(-1)) -# define AO_HAVE_char_fetch_and_sub1_acquire_read -#endif -#if defined(AO_HAVE_char_fetch_and_add) \ - && !defined(AO_HAVE_char_fetch_and_sub1) -# define AO_char_fetch_and_sub1(addr) \ - AO_char_fetch_and_add(addr, (unsigned/**/char)(-1)) -# define AO_HAVE_char_fetch_and_sub1 -#endif - -#if defined(AO_HAVE_char_fetch_and_sub1_full) -# if !defined(AO_HAVE_char_fetch_and_sub1_release) -# define AO_char_fetch_and_sub1_release(addr) \ - AO_char_fetch_and_sub1_full(addr) -# define AO_HAVE_char_fetch_and_sub1_release -# endif -# if !defined(AO_HAVE_char_fetch_and_sub1_acquire) -# define AO_char_fetch_and_sub1_acquire(addr) \ - AO_char_fetch_and_sub1_full(addr) -# define AO_HAVE_char_fetch_and_sub1_acquire -# endif -# if !defined(AO_HAVE_char_fetch_and_sub1_write) -# define AO_char_fetch_and_sub1_write(addr) \ - AO_char_fetch_and_sub1_full(addr) -# define AO_HAVE_char_fetch_and_sub1_write -# endif -# if !defined(AO_HAVE_char_fetch_and_sub1_read) -# define AO_char_fetch_and_sub1_read(addr) \ - AO_char_fetch_and_sub1_full(addr) -# define AO_HAVE_char_fetch_and_sub1_read -# endif -#endif /* AO_HAVE_char_fetch_and_sub1_full */ - -#if !defined(AO_HAVE_char_fetch_and_sub1) \ - && defined(AO_HAVE_char_fetch_and_sub1_release) -# define AO_char_fetch_and_sub1(addr) AO_char_fetch_and_sub1_release(addr) -# define AO_HAVE_char_fetch_and_sub1 -#endif -#if !defined(AO_HAVE_char_fetch_and_sub1) \ - && defined(AO_HAVE_char_fetch_and_sub1_acquire) -# define AO_char_fetch_and_sub1(addr) AO_char_fetch_and_sub1_acquire(addr) -# define AO_HAVE_char_fetch_and_sub1 -#endif -#if !defined(AO_HAVE_char_fetch_and_sub1) \ - && defined(AO_HAVE_char_fetch_and_sub1_write) -# define AO_char_fetch_and_sub1(addr) AO_char_fetch_and_sub1_write(addr) -# define AO_HAVE_char_fetch_and_sub1 -#endif -#if !defined(AO_HAVE_char_fetch_and_sub1) \ - && defined(AO_HAVE_char_fetch_and_sub1_read) -# define AO_char_fetch_and_sub1(addr) AO_char_fetch_and_sub1_read(addr) -# define AO_HAVE_char_fetch_and_sub1 -#endif - -#if defined(AO_HAVE_char_fetch_and_sub1_acquire) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_char_fetch_and_sub1_full) -# define AO_char_fetch_and_sub1_full(addr) \ - (AO_nop_full(), AO_char_fetch_and_sub1_acquire(addr)) -# define AO_HAVE_char_fetch_and_sub1_full -#endif - -#if !defined(AO_HAVE_char_fetch_and_sub1_release_write) \ - && defined(AO_HAVE_char_fetch_and_sub1_write) -# define AO_char_fetch_and_sub1_release_write(addr) \ - AO_char_fetch_and_sub1_write(addr) -# define AO_HAVE_char_fetch_and_sub1_release_write -#endif -#if !defined(AO_HAVE_char_fetch_and_sub1_release_write) \ - && defined(AO_HAVE_char_fetch_and_sub1_release) -# define AO_char_fetch_and_sub1_release_write(addr) \ - AO_char_fetch_and_sub1_release(addr) -# define AO_HAVE_char_fetch_and_sub1_release_write -#endif -#if !defined(AO_HAVE_char_fetch_and_sub1_acquire_read) \ - && defined(AO_HAVE_char_fetch_and_sub1_read) -# define AO_char_fetch_and_sub1_acquire_read(addr) \ - AO_char_fetch_and_sub1_read(addr) -# define AO_HAVE_char_fetch_and_sub1_acquire_read -#endif -#if !defined(AO_HAVE_char_fetch_and_sub1_acquire_read) \ - && defined(AO_HAVE_char_fetch_and_sub1_acquire) -# define AO_char_fetch_and_sub1_acquire_read(addr) \ - AO_char_fetch_and_sub1_acquire(addr) -# define AO_HAVE_char_fetch_and_sub1_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_char_fetch_and_sub1_acquire_read) -# define AO_char_fetch_and_sub1_dd_acquire_read(addr) \ - AO_char_fetch_and_sub1_acquire_read(addr) -# define AO_HAVE_char_fetch_and_sub1_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_char_fetch_and_sub1) -# define AO_char_fetch_and_sub1_dd_acquire_read(addr) \ - AO_char_fetch_and_sub1(addr) -# define AO_HAVE_char_fetch_and_sub1_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* char_and */ -#if defined(AO_HAVE_char_compare_and_swap_full) \ - && !defined(AO_HAVE_char_and_full) - AO_INLINE void - AO_char_and_full(volatile unsigned/**/char *addr, unsigned/**/char value) - { - unsigned/**/char old; - - do - { - old = *(unsigned/**/char *)addr; - } - while (AO_EXPECT_FALSE(!AO_char_compare_and_swap_full(addr, old, - old & value))); - } -# define AO_HAVE_char_and_full -#endif - -#if defined(AO_HAVE_char_and_full) -# if !defined(AO_HAVE_char_and_release) -# define AO_char_and_release(addr, val) AO_char_and_full(addr, val) -# define AO_HAVE_char_and_release -# endif -# if !defined(AO_HAVE_char_and_acquire) -# define AO_char_and_acquire(addr, val) AO_char_and_full(addr, val) -# define AO_HAVE_char_and_acquire -# endif -# if !defined(AO_HAVE_char_and_write) -# define AO_char_and_write(addr, val) AO_char_and_full(addr, val) -# define AO_HAVE_char_and_write -# endif -# if !defined(AO_HAVE_char_and_read) -# define AO_char_and_read(addr, val) AO_char_and_full(addr, val) -# define AO_HAVE_char_and_read -# endif -#endif /* AO_HAVE_char_and_full */ - -#if !defined(AO_HAVE_char_and) && defined(AO_HAVE_char_and_release) -# define AO_char_and(addr, val) AO_char_and_release(addr, val) -# define AO_HAVE_char_and -#endif -#if !defined(AO_HAVE_char_and) && defined(AO_HAVE_char_and_acquire) -# define AO_char_and(addr, val) AO_char_and_acquire(addr, val) -# define AO_HAVE_char_and -#endif -#if !defined(AO_HAVE_char_and) && defined(AO_HAVE_char_and_write) -# define AO_char_and(addr, val) AO_char_and_write(addr, val) -# define AO_HAVE_char_and -#endif -#if !defined(AO_HAVE_char_and) && defined(AO_HAVE_char_and_read) -# define AO_char_and(addr, val) AO_char_and_read(addr, val) -# define AO_HAVE_char_and -#endif - -#if defined(AO_HAVE_char_and_acquire) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_char_and_full) -# define AO_char_and_full(addr, val) \ - (AO_nop_full(), AO_char_and_acquire(addr, val)) -# define AO_HAVE_char_and_full -#endif - -#if !defined(AO_HAVE_char_and_release_write) \ - && defined(AO_HAVE_char_and_write) -# define AO_char_and_release_write(addr, val) AO_char_and_write(addr, val) -# define AO_HAVE_char_and_release_write -#endif -#if !defined(AO_HAVE_char_and_release_write) \ - && defined(AO_HAVE_char_and_release) -# define AO_char_and_release_write(addr, val) AO_char_and_release(addr, val) -# define AO_HAVE_char_and_release_write -#endif -#if !defined(AO_HAVE_char_and_acquire_read) \ - && defined(AO_HAVE_char_and_read) -# define AO_char_and_acquire_read(addr, val) AO_char_and_read(addr, val) -# define AO_HAVE_char_and_acquire_read -#endif -#if !defined(AO_HAVE_char_and_acquire_read) \ - && defined(AO_HAVE_char_and_acquire) -# define AO_char_and_acquire_read(addr, val) AO_char_and_acquire(addr, val) -# define AO_HAVE_char_and_acquire_read -#endif - -/* char_or */ -#if defined(AO_HAVE_char_compare_and_swap_full) \ - && !defined(AO_HAVE_char_or_full) - AO_INLINE void - AO_char_or_full(volatile unsigned/**/char *addr, unsigned/**/char value) - { - unsigned/**/char old; - - do - { - old = *(unsigned/**/char *)addr; - } - while (AO_EXPECT_FALSE(!AO_char_compare_and_swap_full(addr, old, - old | value))); - } -# define AO_HAVE_char_or_full -#endif - -#if defined(AO_HAVE_char_or_full) -# if !defined(AO_HAVE_char_or_release) -# define AO_char_or_release(addr, val) AO_char_or_full(addr, val) -# define AO_HAVE_char_or_release -# endif -# if !defined(AO_HAVE_char_or_acquire) -# define AO_char_or_acquire(addr, val) AO_char_or_full(addr, val) -# define AO_HAVE_char_or_acquire -# endif -# if !defined(AO_HAVE_char_or_write) -# define AO_char_or_write(addr, val) AO_char_or_full(addr, val) -# define AO_HAVE_char_or_write -# endif -# if !defined(AO_HAVE_char_or_read) -# define AO_char_or_read(addr, val) AO_char_or_full(addr, val) -# define AO_HAVE_char_or_read -# endif -#endif /* AO_HAVE_char_or_full */ - -#if !defined(AO_HAVE_char_or) && defined(AO_HAVE_char_or_release) -# define AO_char_or(addr, val) AO_char_or_release(addr, val) -# define AO_HAVE_char_or -#endif -#if !defined(AO_HAVE_char_or) && defined(AO_HAVE_char_or_acquire) -# define AO_char_or(addr, val) AO_char_or_acquire(addr, val) -# define AO_HAVE_char_or -#endif -#if !defined(AO_HAVE_char_or) && defined(AO_HAVE_char_or_write) -# define AO_char_or(addr, val) AO_char_or_write(addr, val) -# define AO_HAVE_char_or -#endif -#if !defined(AO_HAVE_char_or) && defined(AO_HAVE_char_or_read) -# define AO_char_or(addr, val) AO_char_or_read(addr, val) -# define AO_HAVE_char_or -#endif - -#if defined(AO_HAVE_char_or_acquire) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_char_or_full) -# define AO_char_or_full(addr, val) \ - (AO_nop_full(), AO_char_or_acquire(addr, val)) -# define AO_HAVE_char_or_full -#endif - -#if !defined(AO_HAVE_char_or_release_write) \ - && defined(AO_HAVE_char_or_write) -# define AO_char_or_release_write(addr, val) AO_char_or_write(addr, val) -# define AO_HAVE_char_or_release_write -#endif -#if !defined(AO_HAVE_char_or_release_write) \ - && defined(AO_HAVE_char_or_release) -# define AO_char_or_release_write(addr, val) AO_char_or_release(addr, val) -# define AO_HAVE_char_or_release_write -#endif -#if !defined(AO_HAVE_char_or_acquire_read) && defined(AO_HAVE_char_or_read) -# define AO_char_or_acquire_read(addr, val) AO_char_or_read(addr, val) -# define AO_HAVE_char_or_acquire_read -#endif -#if !defined(AO_HAVE_char_or_acquire_read) \ - && defined(AO_HAVE_char_or_acquire) -# define AO_char_or_acquire_read(addr, val) AO_char_or_acquire(addr, val) -# define AO_HAVE_char_or_acquire_read -#endif - -/* char_xor */ -#if defined(AO_HAVE_char_compare_and_swap_full) \ - && !defined(AO_HAVE_char_xor_full) - AO_INLINE void - AO_char_xor_full(volatile unsigned/**/char *addr, unsigned/**/char value) - { - unsigned/**/char old; - - do - { - old = *(unsigned/**/char *)addr; - } - while (AO_EXPECT_FALSE(!AO_char_compare_and_swap_full(addr, old, - old ^ value))); - } -# define AO_HAVE_char_xor_full -#endif - -#if defined(AO_HAVE_char_xor_full) -# if !defined(AO_HAVE_char_xor_release) -# define AO_char_xor_release(addr, val) AO_char_xor_full(addr, val) -# define AO_HAVE_char_xor_release -# endif -# if !defined(AO_HAVE_char_xor_acquire) -# define AO_char_xor_acquire(addr, val) AO_char_xor_full(addr, val) -# define AO_HAVE_char_xor_acquire -# endif -# if !defined(AO_HAVE_char_xor_write) -# define AO_char_xor_write(addr, val) AO_char_xor_full(addr, val) -# define AO_HAVE_char_xor_write -# endif -# if !defined(AO_HAVE_char_xor_read) -# define AO_char_xor_read(addr, val) AO_char_xor_full(addr, val) -# define AO_HAVE_char_xor_read -# endif -#endif /* AO_HAVE_char_xor_full */ - -#if !defined(AO_HAVE_char_xor) && defined(AO_HAVE_char_xor_release) -# define AO_char_xor(addr, val) AO_char_xor_release(addr, val) -# define AO_HAVE_char_xor -#endif -#if !defined(AO_HAVE_char_xor) && defined(AO_HAVE_char_xor_acquire) -# define AO_char_xor(addr, val) AO_char_xor_acquire(addr, val) -# define AO_HAVE_char_xor -#endif -#if !defined(AO_HAVE_char_xor) && defined(AO_HAVE_char_xor_write) -# define AO_char_xor(addr, val) AO_char_xor_write(addr, val) -# define AO_HAVE_char_xor -#endif -#if !defined(AO_HAVE_char_xor) && defined(AO_HAVE_char_xor_read) -# define AO_char_xor(addr, val) AO_char_xor_read(addr, val) -# define AO_HAVE_char_xor -#endif - -#if defined(AO_HAVE_char_xor_acquire) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_char_xor_full) -# define AO_char_xor_full(addr, val) \ - (AO_nop_full(), AO_char_xor_acquire(addr, val)) -# define AO_HAVE_char_xor_full -#endif - -#if !defined(AO_HAVE_char_xor_release_write) \ - && defined(AO_HAVE_char_xor_write) -# define AO_char_xor_release_write(addr, val) AO_char_xor_write(addr, val) -# define AO_HAVE_char_xor_release_write -#endif -#if !defined(AO_HAVE_char_xor_release_write) \ - && defined(AO_HAVE_char_xor_release) -# define AO_char_xor_release_write(addr, val) AO_char_xor_release(addr, val) -# define AO_HAVE_char_xor_release_write -#endif -#if !defined(AO_HAVE_char_xor_acquire_read) \ - && defined(AO_HAVE_char_xor_read) -# define AO_char_xor_acquire_read(addr, val) AO_char_xor_read(addr, val) -# define AO_HAVE_char_xor_acquire_read -#endif -#if !defined(AO_HAVE_char_xor_acquire_read) \ - && defined(AO_HAVE_char_xor_acquire) -# define AO_char_xor_acquire_read(addr, val) AO_char_xor_acquire(addr, val) -# define AO_HAVE_char_xor_acquire_read -#endif - -/* char_and/or/xor_dd_acquire_read are meaningless. */ -/* - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* short_compare_and_swap (based on fetch_compare_and_swap) */ -#if defined(AO_HAVE_short_fetch_compare_and_swap_full) \ - && !defined(AO_HAVE_short_compare_and_swap_full) - AO_INLINE int - AO_short_compare_and_swap_full(volatile unsigned/**/short *addr, unsigned/**/short old_val, - unsigned/**/short new_val) - { - return AO_short_fetch_compare_and_swap_full(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_short_compare_and_swap_full -#endif - -#if defined(AO_HAVE_short_fetch_compare_and_swap_acquire) \ - && !defined(AO_HAVE_short_compare_and_swap_acquire) - AO_INLINE int - AO_short_compare_and_swap_acquire(volatile unsigned/**/short *addr, unsigned/**/short old_val, - unsigned/**/short new_val) - { - return AO_short_fetch_compare_and_swap_acquire(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_short_compare_and_swap_acquire -#endif - -#if defined(AO_HAVE_short_fetch_compare_and_swap_release) \ - && !defined(AO_HAVE_short_compare_and_swap_release) - AO_INLINE int - AO_short_compare_and_swap_release(volatile unsigned/**/short *addr, unsigned/**/short old_val, - unsigned/**/short new_val) - { - return AO_short_fetch_compare_and_swap_release(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_short_compare_and_swap_release -#endif - -#if defined(AO_HAVE_short_fetch_compare_and_swap_write) \ - && !defined(AO_HAVE_short_compare_and_swap_write) - AO_INLINE int - AO_short_compare_and_swap_write(volatile unsigned/**/short *addr, unsigned/**/short old_val, - unsigned/**/short new_val) - { - return AO_short_fetch_compare_and_swap_write(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_short_compare_and_swap_write -#endif - -#if defined(AO_HAVE_short_fetch_compare_and_swap_read) \ - && !defined(AO_HAVE_short_compare_and_swap_read) - AO_INLINE int - AO_short_compare_and_swap_read(volatile unsigned/**/short *addr, unsigned/**/short old_val, - unsigned/**/short new_val) - { - return AO_short_fetch_compare_and_swap_read(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_short_compare_and_swap_read -#endif - -#if defined(AO_HAVE_short_fetch_compare_and_swap) \ - && !defined(AO_HAVE_short_compare_and_swap) - AO_INLINE int - AO_short_compare_and_swap(volatile unsigned/**/short *addr, unsigned/**/short old_val, - unsigned/**/short new_val) - { - return AO_short_fetch_compare_and_swap(addr, old_val, new_val) == old_val; - } -# define AO_HAVE_short_compare_and_swap -#endif - -#if defined(AO_HAVE_short_fetch_compare_and_swap_release_write) \ - && !defined(AO_HAVE_short_compare_and_swap_release_write) - AO_INLINE int - AO_short_compare_and_swap_release_write(volatile unsigned/**/short *addr, - unsigned/**/short old_val, unsigned/**/short new_val) - { - return AO_short_fetch_compare_and_swap_release_write(addr, old_val, - new_val) == old_val; - } -# define AO_HAVE_short_compare_and_swap_release_write -#endif - -#if defined(AO_HAVE_short_fetch_compare_and_swap_acquire_read) \ - && !defined(AO_HAVE_short_compare_and_swap_acquire_read) - AO_INLINE int - AO_short_compare_and_swap_acquire_read(volatile unsigned/**/short *addr, - unsigned/**/short old_val, unsigned/**/short new_val) - { - return AO_short_fetch_compare_and_swap_acquire_read(addr, old_val, - new_val) == old_val; - } -# define AO_HAVE_short_compare_and_swap_acquire_read -#endif - -#if defined(AO_HAVE_short_fetch_compare_and_swap_dd_acquire_read) \ - && !defined(AO_HAVE_short_compare_and_swap_dd_acquire_read) - AO_INLINE int - AO_short_compare_and_swap_dd_acquire_read(volatile unsigned/**/short *addr, - unsigned/**/short old_val, unsigned/**/short new_val) - { - return AO_short_fetch_compare_and_swap_dd_acquire_read(addr, old_val, - new_val) == old_val; - } -# define AO_HAVE_short_compare_and_swap_dd_acquire_read -#endif - -/* short_fetch_and_add */ -/* We first try to implement fetch_and_add variants in terms of the */ -/* corresponding compare_and_swap variants to minimize adding barriers. */ -#if defined(AO_HAVE_short_compare_and_swap_full) \ - && !defined(AO_HAVE_short_fetch_and_add_full) - AO_INLINE unsigned/**/short - AO_short_fetch_and_add_full(volatile unsigned/**/short *addr, unsigned/**/short incr) - { - unsigned/**/short old; - - do - { - old = *(unsigned/**/short *)addr; - } - while (AO_EXPECT_FALSE(!AO_short_compare_and_swap_full(addr, old, - old + incr))); - return old; - } -# define AO_HAVE_short_fetch_and_add_full -#endif - -#if defined(AO_HAVE_short_compare_and_swap_acquire) \ - && !defined(AO_HAVE_short_fetch_and_add_acquire) - AO_INLINE unsigned/**/short - AO_short_fetch_and_add_acquire(volatile unsigned/**/short *addr, unsigned/**/short incr) - { - unsigned/**/short old; - - do - { - old = *(unsigned/**/short *)addr; - } - while (AO_EXPECT_FALSE(!AO_short_compare_and_swap_acquire(addr, old, - old + incr))); - return old; - } -# define AO_HAVE_short_fetch_and_add_acquire -#endif - -#if defined(AO_HAVE_short_compare_and_swap_release) \ - && !defined(AO_HAVE_short_fetch_and_add_release) - AO_INLINE unsigned/**/short - AO_short_fetch_and_add_release(volatile unsigned/**/short *addr, unsigned/**/short incr) - { - unsigned/**/short old; - - do - { - old = *(unsigned/**/short *)addr; - } - while (AO_EXPECT_FALSE(!AO_short_compare_and_swap_release(addr, old, - old + incr))); - return old; - } -# define AO_HAVE_short_fetch_and_add_release -#endif - -#if defined(AO_HAVE_short_compare_and_swap) \ - && !defined(AO_HAVE_short_fetch_and_add) - AO_INLINE unsigned/**/short - AO_short_fetch_and_add(volatile unsigned/**/short *addr, unsigned/**/short incr) - { - unsigned/**/short old; - - do - { - old = *(unsigned/**/short *)addr; - } - while (AO_EXPECT_FALSE(!AO_short_compare_and_swap(addr, old, - old + incr))); - return old; - } -# define AO_HAVE_short_fetch_and_add -#endif - -#if defined(AO_HAVE_short_fetch_and_add_full) -# if !defined(AO_HAVE_short_fetch_and_add_release) -# define AO_short_fetch_and_add_release(addr, val) \ - AO_short_fetch_and_add_full(addr, val) -# define AO_HAVE_short_fetch_and_add_release -# endif -# if !defined(AO_HAVE_short_fetch_and_add_acquire) -# define AO_short_fetch_and_add_acquire(addr, val) \ - AO_short_fetch_and_add_full(addr, val) -# define AO_HAVE_short_fetch_and_add_acquire -# endif -# if !defined(AO_HAVE_short_fetch_and_add_write) -# define AO_short_fetch_and_add_write(addr, val) \ - AO_short_fetch_and_add_full(addr, val) -# define AO_HAVE_short_fetch_and_add_write -# endif -# if !defined(AO_HAVE_short_fetch_and_add_read) -# define AO_short_fetch_and_add_read(addr, val) \ - AO_short_fetch_and_add_full(addr, val) -# define AO_HAVE_short_fetch_and_add_read -# endif -#endif /* AO_HAVE_short_fetch_and_add_full */ - -#if defined(AO_HAVE_short_fetch_and_add) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_short_fetch_and_add_acquire) - AO_INLINE unsigned/**/short - AO_short_fetch_and_add_acquire(volatile unsigned/**/short *addr, unsigned/**/short incr) - { - unsigned/**/short result = AO_short_fetch_and_add(addr, incr); - AO_nop_full(); - return result; - } -# define AO_HAVE_short_fetch_and_add_acquire -#endif -#if defined(AO_HAVE_short_fetch_and_add) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_short_fetch_and_add_release) -# define AO_short_fetch_and_add_release(addr, incr) \ - (AO_nop_full(), AO_short_fetch_and_add(addr, incr)) -# define AO_HAVE_short_fetch_and_add_release -#endif - -#if !defined(AO_HAVE_short_fetch_and_add) \ - && defined(AO_HAVE_short_fetch_and_add_release) -# define AO_short_fetch_and_add(addr, val) \ - AO_short_fetch_and_add_release(addr, val) -# define AO_HAVE_short_fetch_and_add -#endif -#if !defined(AO_HAVE_short_fetch_and_add) \ - && defined(AO_HAVE_short_fetch_and_add_acquire) -# define AO_short_fetch_and_add(addr, val) \ - AO_short_fetch_and_add_acquire(addr, val) -# define AO_HAVE_short_fetch_and_add -#endif -#if !defined(AO_HAVE_short_fetch_and_add) \ - && defined(AO_HAVE_short_fetch_and_add_write) -# define AO_short_fetch_and_add(addr, val) \ - AO_short_fetch_and_add_write(addr, val) -# define AO_HAVE_short_fetch_and_add -#endif -#if !defined(AO_HAVE_short_fetch_and_add) \ - && defined(AO_HAVE_short_fetch_and_add_read) -# define AO_short_fetch_and_add(addr, val) \ - AO_short_fetch_and_add_read(addr, val) -# define AO_HAVE_short_fetch_and_add -#endif - -#if defined(AO_HAVE_short_fetch_and_add_acquire) \ - && defined(AO_HAVE_nop_full) && !defined(AO_HAVE_short_fetch_and_add_full) -# define AO_short_fetch_and_add_full(addr, val) \ - (AO_nop_full(), AO_short_fetch_and_add_acquire(addr, val)) -# define AO_HAVE_short_fetch_and_add_full -#endif - -#if !defined(AO_HAVE_short_fetch_and_add_release_write) \ - && defined(AO_HAVE_short_fetch_and_add_write) -# define AO_short_fetch_and_add_release_write(addr, val) \ - AO_short_fetch_and_add_write(addr, val) -# define AO_HAVE_short_fetch_and_add_release_write -#endif -#if !defined(AO_HAVE_short_fetch_and_add_release_write) \ - && defined(AO_HAVE_short_fetch_and_add_release) -# define AO_short_fetch_and_add_release_write(addr, val) \ - AO_short_fetch_and_add_release(addr, val) -# define AO_HAVE_short_fetch_and_add_release_write -#endif - -#if !defined(AO_HAVE_short_fetch_and_add_acquire_read) \ - && defined(AO_HAVE_short_fetch_and_add_read) -# define AO_short_fetch_and_add_acquire_read(addr, val) \ - AO_short_fetch_and_add_read(addr, val) -# define AO_HAVE_short_fetch_and_add_acquire_read -#endif -#if !defined(AO_HAVE_short_fetch_and_add_acquire_read) \ - && defined(AO_HAVE_short_fetch_and_add_acquire) -# define AO_short_fetch_and_add_acquire_read(addr, val) \ - AO_short_fetch_and_add_acquire(addr, val) -# define AO_HAVE_short_fetch_and_add_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_short_fetch_and_add_acquire_read) -# define AO_short_fetch_and_add_dd_acquire_read(addr, val) \ - AO_short_fetch_and_add_acquire_read(addr, val) -# define AO_HAVE_short_fetch_and_add_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_short_fetch_and_add) -# define AO_short_fetch_and_add_dd_acquire_read(addr, val) \ - AO_short_fetch_and_add(addr, val) -# define AO_HAVE_short_fetch_and_add_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* short_fetch_and_add1 */ -#if defined(AO_HAVE_short_fetch_and_add_full) \ - && !defined(AO_HAVE_short_fetch_and_add1_full) -# define AO_short_fetch_and_add1_full(addr) \ - AO_short_fetch_and_add_full(addr, 1) -# define AO_HAVE_short_fetch_and_add1_full -#endif -#if defined(AO_HAVE_short_fetch_and_add_release) \ - && !defined(AO_HAVE_short_fetch_and_add1_release) -# define AO_short_fetch_and_add1_release(addr) \ - AO_short_fetch_and_add_release(addr, 1) -# define AO_HAVE_short_fetch_and_add1_release -#endif -#if defined(AO_HAVE_short_fetch_and_add_acquire) \ - && !defined(AO_HAVE_short_fetch_and_add1_acquire) -# define AO_short_fetch_and_add1_acquire(addr) \ - AO_short_fetch_and_add_acquire(addr, 1) -# define AO_HAVE_short_fetch_and_add1_acquire -#endif -#if defined(AO_HAVE_short_fetch_and_add_write) \ - && !defined(AO_HAVE_short_fetch_and_add1_write) -# define AO_short_fetch_and_add1_write(addr) \ - AO_short_fetch_and_add_write(addr, 1) -# define AO_HAVE_short_fetch_and_add1_write -#endif -#if defined(AO_HAVE_short_fetch_and_add_read) \ - && !defined(AO_HAVE_short_fetch_and_add1_read) -# define AO_short_fetch_and_add1_read(addr) \ - AO_short_fetch_and_add_read(addr, 1) -# define AO_HAVE_short_fetch_and_add1_read -#endif -#if defined(AO_HAVE_short_fetch_and_add_release_write) \ - && !defined(AO_HAVE_short_fetch_and_add1_release_write) -# define AO_short_fetch_and_add1_release_write(addr) \ - AO_short_fetch_and_add_release_write(addr, 1) -# define AO_HAVE_short_fetch_and_add1_release_write -#endif -#if defined(AO_HAVE_short_fetch_and_add_acquire_read) \ - && !defined(AO_HAVE_short_fetch_and_add1_acquire_read) -# define AO_short_fetch_and_add1_acquire_read(addr) \ - AO_short_fetch_and_add_acquire_read(addr, 1) -# define AO_HAVE_short_fetch_and_add1_acquire_read -#endif -#if defined(AO_HAVE_short_fetch_and_add) \ - && !defined(AO_HAVE_short_fetch_and_add1) -# define AO_short_fetch_and_add1(addr) AO_short_fetch_and_add(addr, 1) -# define AO_HAVE_short_fetch_and_add1 -#endif - -#if defined(AO_HAVE_short_fetch_and_add1_full) -# if !defined(AO_HAVE_short_fetch_and_add1_release) -# define AO_short_fetch_and_add1_release(addr) \ - AO_short_fetch_and_add1_full(addr) -# define AO_HAVE_short_fetch_and_add1_release -# endif -# if !defined(AO_HAVE_short_fetch_and_add1_acquire) -# define AO_short_fetch_and_add1_acquire(addr) \ - AO_short_fetch_and_add1_full(addr) -# define AO_HAVE_short_fetch_and_add1_acquire -# endif -# if !defined(AO_HAVE_short_fetch_and_add1_write) -# define AO_short_fetch_and_add1_write(addr) \ - AO_short_fetch_and_add1_full(addr) -# define AO_HAVE_short_fetch_and_add1_write -# endif -# if !defined(AO_HAVE_short_fetch_and_add1_read) -# define AO_short_fetch_and_add1_read(addr) \ - AO_short_fetch_and_add1_full(addr) -# define AO_HAVE_short_fetch_and_add1_read -# endif -#endif /* AO_HAVE_short_fetch_and_add1_full */ - -#if !defined(AO_HAVE_short_fetch_and_add1) \ - && defined(AO_HAVE_short_fetch_and_add1_release) -# define AO_short_fetch_and_add1(addr) AO_short_fetch_and_add1_release(addr) -# define AO_HAVE_short_fetch_and_add1 -#endif -#if !defined(AO_HAVE_short_fetch_and_add1) \ - && defined(AO_HAVE_short_fetch_and_add1_acquire) -# define AO_short_fetch_and_add1(addr) AO_short_fetch_and_add1_acquire(addr) -# define AO_HAVE_short_fetch_and_add1 -#endif -#if !defined(AO_HAVE_short_fetch_and_add1) \ - && defined(AO_HAVE_short_fetch_and_add1_write) -# define AO_short_fetch_and_add1(addr) AO_short_fetch_and_add1_write(addr) -# define AO_HAVE_short_fetch_and_add1 -#endif -#if !defined(AO_HAVE_short_fetch_and_add1) \ - && defined(AO_HAVE_short_fetch_and_add1_read) -# define AO_short_fetch_and_add1(addr) AO_short_fetch_and_add1_read(addr) -# define AO_HAVE_short_fetch_and_add1 -#endif - -#if defined(AO_HAVE_short_fetch_and_add1_acquire) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_short_fetch_and_add1_full) -# define AO_short_fetch_and_add1_full(addr) \ - (AO_nop_full(), AO_short_fetch_and_add1_acquire(addr)) -# define AO_HAVE_short_fetch_and_add1_full -#endif - -#if !defined(AO_HAVE_short_fetch_and_add1_release_write) \ - && defined(AO_HAVE_short_fetch_and_add1_write) -# define AO_short_fetch_and_add1_release_write(addr) \ - AO_short_fetch_and_add1_write(addr) -# define AO_HAVE_short_fetch_and_add1_release_write -#endif -#if !defined(AO_HAVE_short_fetch_and_add1_release_write) \ - && defined(AO_HAVE_short_fetch_and_add1_release) -# define AO_short_fetch_and_add1_release_write(addr) \ - AO_short_fetch_and_add1_release(addr) -# define AO_HAVE_short_fetch_and_add1_release_write -#endif -#if !defined(AO_HAVE_short_fetch_and_add1_acquire_read) \ - && defined(AO_HAVE_short_fetch_and_add1_read) -# define AO_short_fetch_and_add1_acquire_read(addr) \ - AO_short_fetch_and_add1_read(addr) -# define AO_HAVE_short_fetch_and_add1_acquire_read -#endif -#if !defined(AO_HAVE_short_fetch_and_add1_acquire_read) \ - && defined(AO_HAVE_short_fetch_and_add1_acquire) -# define AO_short_fetch_and_add1_acquire_read(addr) \ - AO_short_fetch_and_add1_acquire(addr) -# define AO_HAVE_short_fetch_and_add1_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_short_fetch_and_add1_acquire_read) -# define AO_short_fetch_and_add1_dd_acquire_read(addr) \ - AO_short_fetch_and_add1_acquire_read(addr) -# define AO_HAVE_short_fetch_and_add1_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_short_fetch_and_add1) -# define AO_short_fetch_and_add1_dd_acquire_read(addr) \ - AO_short_fetch_and_add1(addr) -# define AO_HAVE_short_fetch_and_add1_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* short_fetch_and_sub1 */ -#if defined(AO_HAVE_short_fetch_and_add_full) \ - && !defined(AO_HAVE_short_fetch_and_sub1_full) -# define AO_short_fetch_and_sub1_full(addr) \ - AO_short_fetch_and_add_full(addr, (unsigned/**/short)(-1)) -# define AO_HAVE_short_fetch_and_sub1_full -#endif -#if defined(AO_HAVE_short_fetch_and_add_release) \ - && !defined(AO_HAVE_short_fetch_and_sub1_release) -# define AO_short_fetch_and_sub1_release(addr) \ - AO_short_fetch_and_add_release(addr, (unsigned/**/short)(-1)) -# define AO_HAVE_short_fetch_and_sub1_release -#endif -#if defined(AO_HAVE_short_fetch_and_add_acquire) \ - && !defined(AO_HAVE_short_fetch_and_sub1_acquire) -# define AO_short_fetch_and_sub1_acquire(addr) \ - AO_short_fetch_and_add_acquire(addr, (unsigned/**/short)(-1)) -# define AO_HAVE_short_fetch_and_sub1_acquire -#endif -#if defined(AO_HAVE_short_fetch_and_add_write) \ - && !defined(AO_HAVE_short_fetch_and_sub1_write) -# define AO_short_fetch_and_sub1_write(addr) \ - AO_short_fetch_and_add_write(addr, (unsigned/**/short)(-1)) -# define AO_HAVE_short_fetch_and_sub1_write -#endif -#if defined(AO_HAVE_short_fetch_and_add_read) \ - && !defined(AO_HAVE_short_fetch_and_sub1_read) -# define AO_short_fetch_and_sub1_read(addr) \ - AO_short_fetch_and_add_read(addr, (unsigned/**/short)(-1)) -# define AO_HAVE_short_fetch_and_sub1_read -#endif -#if defined(AO_HAVE_short_fetch_and_add_release_write) \ - && !defined(AO_HAVE_short_fetch_and_sub1_release_write) -# define AO_short_fetch_and_sub1_release_write(addr) \ - AO_short_fetch_and_add_release_write(addr, (unsigned/**/short)(-1)) -# define AO_HAVE_short_fetch_and_sub1_release_write -#endif -#if defined(AO_HAVE_short_fetch_and_add_acquire_read) \ - && !defined(AO_HAVE_short_fetch_and_sub1_acquire_read) -# define AO_short_fetch_and_sub1_acquire_read(addr) \ - AO_short_fetch_and_add_acquire_read(addr, (unsigned/**/short)(-1)) -# define AO_HAVE_short_fetch_and_sub1_acquire_read -#endif -#if defined(AO_HAVE_short_fetch_and_add) \ - && !defined(AO_HAVE_short_fetch_and_sub1) -# define AO_short_fetch_and_sub1(addr) \ - AO_short_fetch_and_add(addr, (unsigned/**/short)(-1)) -# define AO_HAVE_short_fetch_and_sub1 -#endif - -#if defined(AO_HAVE_short_fetch_and_sub1_full) -# if !defined(AO_HAVE_short_fetch_and_sub1_release) -# define AO_short_fetch_and_sub1_release(addr) \ - AO_short_fetch_and_sub1_full(addr) -# define AO_HAVE_short_fetch_and_sub1_release -# endif -# if !defined(AO_HAVE_short_fetch_and_sub1_acquire) -# define AO_short_fetch_and_sub1_acquire(addr) \ - AO_short_fetch_and_sub1_full(addr) -# define AO_HAVE_short_fetch_and_sub1_acquire -# endif -# if !defined(AO_HAVE_short_fetch_and_sub1_write) -# define AO_short_fetch_and_sub1_write(addr) \ - AO_short_fetch_and_sub1_full(addr) -# define AO_HAVE_short_fetch_and_sub1_write -# endif -# if !defined(AO_HAVE_short_fetch_and_sub1_read) -# define AO_short_fetch_and_sub1_read(addr) \ - AO_short_fetch_and_sub1_full(addr) -# define AO_HAVE_short_fetch_and_sub1_read -# endif -#endif /* AO_HAVE_short_fetch_and_sub1_full */ - -#if !defined(AO_HAVE_short_fetch_and_sub1) \ - && defined(AO_HAVE_short_fetch_and_sub1_release) -# define AO_short_fetch_and_sub1(addr) AO_short_fetch_and_sub1_release(addr) -# define AO_HAVE_short_fetch_and_sub1 -#endif -#if !defined(AO_HAVE_short_fetch_and_sub1) \ - && defined(AO_HAVE_short_fetch_and_sub1_acquire) -# define AO_short_fetch_and_sub1(addr) AO_short_fetch_and_sub1_acquire(addr) -# define AO_HAVE_short_fetch_and_sub1 -#endif -#if !defined(AO_HAVE_short_fetch_and_sub1) \ - && defined(AO_HAVE_short_fetch_and_sub1_write) -# define AO_short_fetch_and_sub1(addr) AO_short_fetch_and_sub1_write(addr) -# define AO_HAVE_short_fetch_and_sub1 -#endif -#if !defined(AO_HAVE_short_fetch_and_sub1) \ - && defined(AO_HAVE_short_fetch_and_sub1_read) -# define AO_short_fetch_and_sub1(addr) AO_short_fetch_and_sub1_read(addr) -# define AO_HAVE_short_fetch_and_sub1 -#endif - -#if defined(AO_HAVE_short_fetch_and_sub1_acquire) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_short_fetch_and_sub1_full) -# define AO_short_fetch_and_sub1_full(addr) \ - (AO_nop_full(), AO_short_fetch_and_sub1_acquire(addr)) -# define AO_HAVE_short_fetch_and_sub1_full -#endif - -#if !defined(AO_HAVE_short_fetch_and_sub1_release_write) \ - && defined(AO_HAVE_short_fetch_and_sub1_write) -# define AO_short_fetch_and_sub1_release_write(addr) \ - AO_short_fetch_and_sub1_write(addr) -# define AO_HAVE_short_fetch_and_sub1_release_write -#endif -#if !defined(AO_HAVE_short_fetch_and_sub1_release_write) \ - && defined(AO_HAVE_short_fetch_and_sub1_release) -# define AO_short_fetch_and_sub1_release_write(addr) \ - AO_short_fetch_and_sub1_release(addr) -# define AO_HAVE_short_fetch_and_sub1_release_write -#endif -#if !defined(AO_HAVE_short_fetch_and_sub1_acquire_read) \ - && defined(AO_HAVE_short_fetch_and_sub1_read) -# define AO_short_fetch_and_sub1_acquire_read(addr) \ - AO_short_fetch_and_sub1_read(addr) -# define AO_HAVE_short_fetch_and_sub1_acquire_read -#endif -#if !defined(AO_HAVE_short_fetch_and_sub1_acquire_read) \ - && defined(AO_HAVE_short_fetch_and_sub1_acquire) -# define AO_short_fetch_and_sub1_acquire_read(addr) \ - AO_short_fetch_and_sub1_acquire(addr) -# define AO_HAVE_short_fetch_and_sub1_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_short_fetch_and_sub1_acquire_read) -# define AO_short_fetch_and_sub1_dd_acquire_read(addr) \ - AO_short_fetch_and_sub1_acquire_read(addr) -# define AO_HAVE_short_fetch_and_sub1_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_short_fetch_and_sub1) -# define AO_short_fetch_and_sub1_dd_acquire_read(addr) \ - AO_short_fetch_and_sub1(addr) -# define AO_HAVE_short_fetch_and_sub1_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* short_and */ -#if defined(AO_HAVE_short_compare_and_swap_full) \ - && !defined(AO_HAVE_short_and_full) - AO_INLINE void - AO_short_and_full(volatile unsigned/**/short *addr, unsigned/**/short value) - { - unsigned/**/short old; - - do - { - old = *(unsigned/**/short *)addr; - } - while (AO_EXPECT_FALSE(!AO_short_compare_and_swap_full(addr, old, - old & value))); - } -# define AO_HAVE_short_and_full -#endif - -#if defined(AO_HAVE_short_and_full) -# if !defined(AO_HAVE_short_and_release) -# define AO_short_and_release(addr, val) AO_short_and_full(addr, val) -# define AO_HAVE_short_and_release -# endif -# if !defined(AO_HAVE_short_and_acquire) -# define AO_short_and_acquire(addr, val) AO_short_and_full(addr, val) -# define AO_HAVE_short_and_acquire -# endif -# if !defined(AO_HAVE_short_and_write) -# define AO_short_and_write(addr, val) AO_short_and_full(addr, val) -# define AO_HAVE_short_and_write -# endif -# if !defined(AO_HAVE_short_and_read) -# define AO_short_and_read(addr, val) AO_short_and_full(addr, val) -# define AO_HAVE_short_and_read -# endif -#endif /* AO_HAVE_short_and_full */ - -#if !defined(AO_HAVE_short_and) && defined(AO_HAVE_short_and_release) -# define AO_short_and(addr, val) AO_short_and_release(addr, val) -# define AO_HAVE_short_and -#endif -#if !defined(AO_HAVE_short_and) && defined(AO_HAVE_short_and_acquire) -# define AO_short_and(addr, val) AO_short_and_acquire(addr, val) -# define AO_HAVE_short_and -#endif -#if !defined(AO_HAVE_short_and) && defined(AO_HAVE_short_and_write) -# define AO_short_and(addr, val) AO_short_and_write(addr, val) -# define AO_HAVE_short_and -#endif -#if !defined(AO_HAVE_short_and) && defined(AO_HAVE_short_and_read) -# define AO_short_and(addr, val) AO_short_and_read(addr, val) -# define AO_HAVE_short_and -#endif - -#if defined(AO_HAVE_short_and_acquire) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_short_and_full) -# define AO_short_and_full(addr, val) \ - (AO_nop_full(), AO_short_and_acquire(addr, val)) -# define AO_HAVE_short_and_full -#endif - -#if !defined(AO_HAVE_short_and_release_write) \ - && defined(AO_HAVE_short_and_write) -# define AO_short_and_release_write(addr, val) AO_short_and_write(addr, val) -# define AO_HAVE_short_and_release_write -#endif -#if !defined(AO_HAVE_short_and_release_write) \ - && defined(AO_HAVE_short_and_release) -# define AO_short_and_release_write(addr, val) AO_short_and_release(addr, val) -# define AO_HAVE_short_and_release_write -#endif -#if !defined(AO_HAVE_short_and_acquire_read) \ - && defined(AO_HAVE_short_and_read) -# define AO_short_and_acquire_read(addr, val) AO_short_and_read(addr, val) -# define AO_HAVE_short_and_acquire_read -#endif -#if !defined(AO_HAVE_short_and_acquire_read) \ - && defined(AO_HAVE_short_and_acquire) -# define AO_short_and_acquire_read(addr, val) AO_short_and_acquire(addr, val) -# define AO_HAVE_short_and_acquire_read -#endif - -/* short_or */ -#if defined(AO_HAVE_short_compare_and_swap_full) \ - && !defined(AO_HAVE_short_or_full) - AO_INLINE void - AO_short_or_full(volatile unsigned/**/short *addr, unsigned/**/short value) - { - unsigned/**/short old; - - do - { - old = *(unsigned/**/short *)addr; - } - while (AO_EXPECT_FALSE(!AO_short_compare_and_swap_full(addr, old, - old | value))); - } -# define AO_HAVE_short_or_full -#endif - -#if defined(AO_HAVE_short_or_full) -# if !defined(AO_HAVE_short_or_release) -# define AO_short_or_release(addr, val) AO_short_or_full(addr, val) -# define AO_HAVE_short_or_release -# endif -# if !defined(AO_HAVE_short_or_acquire) -# define AO_short_or_acquire(addr, val) AO_short_or_full(addr, val) -# define AO_HAVE_short_or_acquire -# endif -# if !defined(AO_HAVE_short_or_write) -# define AO_short_or_write(addr, val) AO_short_or_full(addr, val) -# define AO_HAVE_short_or_write -# endif -# if !defined(AO_HAVE_short_or_read) -# define AO_short_or_read(addr, val) AO_short_or_full(addr, val) -# define AO_HAVE_short_or_read -# endif -#endif /* AO_HAVE_short_or_full */ - -#if !defined(AO_HAVE_short_or) && defined(AO_HAVE_short_or_release) -# define AO_short_or(addr, val) AO_short_or_release(addr, val) -# define AO_HAVE_short_or -#endif -#if !defined(AO_HAVE_short_or) && defined(AO_HAVE_short_or_acquire) -# define AO_short_or(addr, val) AO_short_or_acquire(addr, val) -# define AO_HAVE_short_or -#endif -#if !defined(AO_HAVE_short_or) && defined(AO_HAVE_short_or_write) -# define AO_short_or(addr, val) AO_short_or_write(addr, val) -# define AO_HAVE_short_or -#endif -#if !defined(AO_HAVE_short_or) && defined(AO_HAVE_short_or_read) -# define AO_short_or(addr, val) AO_short_or_read(addr, val) -# define AO_HAVE_short_or -#endif - -#if defined(AO_HAVE_short_or_acquire) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_short_or_full) -# define AO_short_or_full(addr, val) \ - (AO_nop_full(), AO_short_or_acquire(addr, val)) -# define AO_HAVE_short_or_full -#endif - -#if !defined(AO_HAVE_short_or_release_write) \ - && defined(AO_HAVE_short_or_write) -# define AO_short_or_release_write(addr, val) AO_short_or_write(addr, val) -# define AO_HAVE_short_or_release_write -#endif -#if !defined(AO_HAVE_short_or_release_write) \ - && defined(AO_HAVE_short_or_release) -# define AO_short_or_release_write(addr, val) AO_short_or_release(addr, val) -# define AO_HAVE_short_or_release_write -#endif -#if !defined(AO_HAVE_short_or_acquire_read) && defined(AO_HAVE_short_or_read) -# define AO_short_or_acquire_read(addr, val) AO_short_or_read(addr, val) -# define AO_HAVE_short_or_acquire_read -#endif -#if !defined(AO_HAVE_short_or_acquire_read) \ - && defined(AO_HAVE_short_or_acquire) -# define AO_short_or_acquire_read(addr, val) AO_short_or_acquire(addr, val) -# define AO_HAVE_short_or_acquire_read -#endif - -/* short_xor */ -#if defined(AO_HAVE_short_compare_and_swap_full) \ - && !defined(AO_HAVE_short_xor_full) - AO_INLINE void - AO_short_xor_full(volatile unsigned/**/short *addr, unsigned/**/short value) - { - unsigned/**/short old; - - do - { - old = *(unsigned/**/short *)addr; - } - while (AO_EXPECT_FALSE(!AO_short_compare_and_swap_full(addr, old, - old ^ value))); - } -# define AO_HAVE_short_xor_full -#endif - -#if defined(AO_HAVE_short_xor_full) -# if !defined(AO_HAVE_short_xor_release) -# define AO_short_xor_release(addr, val) AO_short_xor_full(addr, val) -# define AO_HAVE_short_xor_release -# endif -# if !defined(AO_HAVE_short_xor_acquire) -# define AO_short_xor_acquire(addr, val) AO_short_xor_full(addr, val) -# define AO_HAVE_short_xor_acquire -# endif -# if !defined(AO_HAVE_short_xor_write) -# define AO_short_xor_write(addr, val) AO_short_xor_full(addr, val) -# define AO_HAVE_short_xor_write -# endif -# if !defined(AO_HAVE_short_xor_read) -# define AO_short_xor_read(addr, val) AO_short_xor_full(addr, val) -# define AO_HAVE_short_xor_read -# endif -#endif /* AO_HAVE_short_xor_full */ - -#if !defined(AO_HAVE_short_xor) && defined(AO_HAVE_short_xor_release) -# define AO_short_xor(addr, val) AO_short_xor_release(addr, val) -# define AO_HAVE_short_xor -#endif -#if !defined(AO_HAVE_short_xor) && defined(AO_HAVE_short_xor_acquire) -# define AO_short_xor(addr, val) AO_short_xor_acquire(addr, val) -# define AO_HAVE_short_xor -#endif -#if !defined(AO_HAVE_short_xor) && defined(AO_HAVE_short_xor_write) -# define AO_short_xor(addr, val) AO_short_xor_write(addr, val) -# define AO_HAVE_short_xor -#endif -#if !defined(AO_HAVE_short_xor) && defined(AO_HAVE_short_xor_read) -# define AO_short_xor(addr, val) AO_short_xor_read(addr, val) -# define AO_HAVE_short_xor -#endif - -#if defined(AO_HAVE_short_xor_acquire) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_short_xor_full) -# define AO_short_xor_full(addr, val) \ - (AO_nop_full(), AO_short_xor_acquire(addr, val)) -# define AO_HAVE_short_xor_full -#endif - -#if !defined(AO_HAVE_short_xor_release_write) \ - && defined(AO_HAVE_short_xor_write) -# define AO_short_xor_release_write(addr, val) AO_short_xor_write(addr, val) -# define AO_HAVE_short_xor_release_write -#endif -#if !defined(AO_HAVE_short_xor_release_write) \ - && defined(AO_HAVE_short_xor_release) -# define AO_short_xor_release_write(addr, val) AO_short_xor_release(addr, val) -# define AO_HAVE_short_xor_release_write -#endif -#if !defined(AO_HAVE_short_xor_acquire_read) \ - && defined(AO_HAVE_short_xor_read) -# define AO_short_xor_acquire_read(addr, val) AO_short_xor_read(addr, val) -# define AO_HAVE_short_xor_acquire_read -#endif -#if !defined(AO_HAVE_short_xor_acquire_read) \ - && defined(AO_HAVE_short_xor_acquire) -# define AO_short_xor_acquire_read(addr, val) AO_short_xor_acquire(addr, val) -# define AO_HAVE_short_xor_acquire_read -#endif - -/* short_and/or/xor_dd_acquire_read are meaningless. */ -/* - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* int_compare_and_swap (based on fetch_compare_and_swap) */ -#if defined(AO_HAVE_int_fetch_compare_and_swap_full) \ - && !defined(AO_HAVE_int_compare_and_swap_full) - AO_INLINE int - AO_int_compare_and_swap_full(volatile unsigned *addr, unsigned old_val, - unsigned new_val) - { - return AO_int_fetch_compare_and_swap_full(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_int_compare_and_swap_full -#endif - -#if defined(AO_HAVE_int_fetch_compare_and_swap_acquire) \ - && !defined(AO_HAVE_int_compare_and_swap_acquire) - AO_INLINE int - AO_int_compare_and_swap_acquire(volatile unsigned *addr, unsigned old_val, - unsigned new_val) - { - return AO_int_fetch_compare_and_swap_acquire(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_int_compare_and_swap_acquire -#endif - -#if defined(AO_HAVE_int_fetch_compare_and_swap_release) \ - && !defined(AO_HAVE_int_compare_and_swap_release) - AO_INLINE int - AO_int_compare_and_swap_release(volatile unsigned *addr, unsigned old_val, - unsigned new_val) - { - return AO_int_fetch_compare_and_swap_release(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_int_compare_and_swap_release -#endif - -#if defined(AO_HAVE_int_fetch_compare_and_swap_write) \ - && !defined(AO_HAVE_int_compare_and_swap_write) - AO_INLINE int - AO_int_compare_and_swap_write(volatile unsigned *addr, unsigned old_val, - unsigned new_val) - { - return AO_int_fetch_compare_and_swap_write(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_int_compare_and_swap_write -#endif - -#if defined(AO_HAVE_int_fetch_compare_and_swap_read) \ - && !defined(AO_HAVE_int_compare_and_swap_read) - AO_INLINE int - AO_int_compare_and_swap_read(volatile unsigned *addr, unsigned old_val, - unsigned new_val) - { - return AO_int_fetch_compare_and_swap_read(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_int_compare_and_swap_read -#endif - -#if defined(AO_HAVE_int_fetch_compare_and_swap) \ - && !defined(AO_HAVE_int_compare_and_swap) - AO_INLINE int - AO_int_compare_and_swap(volatile unsigned *addr, unsigned old_val, - unsigned new_val) - { - return AO_int_fetch_compare_and_swap(addr, old_val, new_val) == old_val; - } -# define AO_HAVE_int_compare_and_swap -#endif - -#if defined(AO_HAVE_int_fetch_compare_and_swap_release_write) \ - && !defined(AO_HAVE_int_compare_and_swap_release_write) - AO_INLINE int - AO_int_compare_and_swap_release_write(volatile unsigned *addr, - unsigned old_val, unsigned new_val) - { - return AO_int_fetch_compare_and_swap_release_write(addr, old_val, - new_val) == old_val; - } -# define AO_HAVE_int_compare_and_swap_release_write -#endif - -#if defined(AO_HAVE_int_fetch_compare_and_swap_acquire_read) \ - && !defined(AO_HAVE_int_compare_and_swap_acquire_read) - AO_INLINE int - AO_int_compare_and_swap_acquire_read(volatile unsigned *addr, - unsigned old_val, unsigned new_val) - { - return AO_int_fetch_compare_and_swap_acquire_read(addr, old_val, - new_val) == old_val; - } -# define AO_HAVE_int_compare_and_swap_acquire_read -#endif - -#if defined(AO_HAVE_int_fetch_compare_and_swap_dd_acquire_read) \ - && !defined(AO_HAVE_int_compare_and_swap_dd_acquire_read) - AO_INLINE int - AO_int_compare_and_swap_dd_acquire_read(volatile unsigned *addr, - unsigned old_val, unsigned new_val) - { - return AO_int_fetch_compare_and_swap_dd_acquire_read(addr, old_val, - new_val) == old_val; - } -# define AO_HAVE_int_compare_and_swap_dd_acquire_read -#endif - -/* int_fetch_and_add */ -/* We first try to implement fetch_and_add variants in terms of the */ -/* corresponding compare_and_swap variants to minimize adding barriers. */ -#if defined(AO_HAVE_int_compare_and_swap_full) \ - && !defined(AO_HAVE_int_fetch_and_add_full) - AO_INLINE unsigned - AO_int_fetch_and_add_full(volatile unsigned *addr, unsigned incr) - { - unsigned old; - - do - { - old = *(unsigned *)addr; - } - while (AO_EXPECT_FALSE(!AO_int_compare_and_swap_full(addr, old, - old + incr))); - return old; - } -# define AO_HAVE_int_fetch_and_add_full -#endif - -#if defined(AO_HAVE_int_compare_and_swap_acquire) \ - && !defined(AO_HAVE_int_fetch_and_add_acquire) - AO_INLINE unsigned - AO_int_fetch_and_add_acquire(volatile unsigned *addr, unsigned incr) - { - unsigned old; - - do - { - old = *(unsigned *)addr; - } - while (AO_EXPECT_FALSE(!AO_int_compare_and_swap_acquire(addr, old, - old + incr))); - return old; - } -# define AO_HAVE_int_fetch_and_add_acquire -#endif - -#if defined(AO_HAVE_int_compare_and_swap_release) \ - && !defined(AO_HAVE_int_fetch_and_add_release) - AO_INLINE unsigned - AO_int_fetch_and_add_release(volatile unsigned *addr, unsigned incr) - { - unsigned old; - - do - { - old = *(unsigned *)addr; - } - while (AO_EXPECT_FALSE(!AO_int_compare_and_swap_release(addr, old, - old + incr))); - return old; - } -# define AO_HAVE_int_fetch_and_add_release -#endif - -#if defined(AO_HAVE_int_compare_and_swap) \ - && !defined(AO_HAVE_int_fetch_and_add) - AO_INLINE unsigned - AO_int_fetch_and_add(volatile unsigned *addr, unsigned incr) - { - unsigned old; - - do - { - old = *(unsigned *)addr; - } - while (AO_EXPECT_FALSE(!AO_int_compare_and_swap(addr, old, - old + incr))); - return old; - } -# define AO_HAVE_int_fetch_and_add -#endif - -#if defined(AO_HAVE_int_fetch_and_add_full) -# if !defined(AO_HAVE_int_fetch_and_add_release) -# define AO_int_fetch_and_add_release(addr, val) \ - AO_int_fetch_and_add_full(addr, val) -# define AO_HAVE_int_fetch_and_add_release -# endif -# if !defined(AO_HAVE_int_fetch_and_add_acquire) -# define AO_int_fetch_and_add_acquire(addr, val) \ - AO_int_fetch_and_add_full(addr, val) -# define AO_HAVE_int_fetch_and_add_acquire -# endif -# if !defined(AO_HAVE_int_fetch_and_add_write) -# define AO_int_fetch_and_add_write(addr, val) \ - AO_int_fetch_and_add_full(addr, val) -# define AO_HAVE_int_fetch_and_add_write -# endif -# if !defined(AO_HAVE_int_fetch_and_add_read) -# define AO_int_fetch_and_add_read(addr, val) \ - AO_int_fetch_and_add_full(addr, val) -# define AO_HAVE_int_fetch_and_add_read -# endif -#endif /* AO_HAVE_int_fetch_and_add_full */ - -#if defined(AO_HAVE_int_fetch_and_add) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_int_fetch_and_add_acquire) - AO_INLINE unsigned - AO_int_fetch_and_add_acquire(volatile unsigned *addr, unsigned incr) - { - unsigned result = AO_int_fetch_and_add(addr, incr); - AO_nop_full(); - return result; - } -# define AO_HAVE_int_fetch_and_add_acquire -#endif -#if defined(AO_HAVE_int_fetch_and_add) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_int_fetch_and_add_release) -# define AO_int_fetch_and_add_release(addr, incr) \ - (AO_nop_full(), AO_int_fetch_and_add(addr, incr)) -# define AO_HAVE_int_fetch_and_add_release -#endif - -#if !defined(AO_HAVE_int_fetch_and_add) \ - && defined(AO_HAVE_int_fetch_and_add_release) -# define AO_int_fetch_and_add(addr, val) \ - AO_int_fetch_and_add_release(addr, val) -# define AO_HAVE_int_fetch_and_add -#endif -#if !defined(AO_HAVE_int_fetch_and_add) \ - && defined(AO_HAVE_int_fetch_and_add_acquire) -# define AO_int_fetch_and_add(addr, val) \ - AO_int_fetch_and_add_acquire(addr, val) -# define AO_HAVE_int_fetch_and_add -#endif -#if !defined(AO_HAVE_int_fetch_and_add) \ - && defined(AO_HAVE_int_fetch_and_add_write) -# define AO_int_fetch_and_add(addr, val) \ - AO_int_fetch_and_add_write(addr, val) -# define AO_HAVE_int_fetch_and_add -#endif -#if !defined(AO_HAVE_int_fetch_and_add) \ - && defined(AO_HAVE_int_fetch_and_add_read) -# define AO_int_fetch_and_add(addr, val) \ - AO_int_fetch_and_add_read(addr, val) -# define AO_HAVE_int_fetch_and_add -#endif - -#if defined(AO_HAVE_int_fetch_and_add_acquire) \ - && defined(AO_HAVE_nop_full) && !defined(AO_HAVE_int_fetch_and_add_full) -# define AO_int_fetch_and_add_full(addr, val) \ - (AO_nop_full(), AO_int_fetch_and_add_acquire(addr, val)) -# define AO_HAVE_int_fetch_and_add_full -#endif - -#if !defined(AO_HAVE_int_fetch_and_add_release_write) \ - && defined(AO_HAVE_int_fetch_and_add_write) -# define AO_int_fetch_and_add_release_write(addr, val) \ - AO_int_fetch_and_add_write(addr, val) -# define AO_HAVE_int_fetch_and_add_release_write -#endif -#if !defined(AO_HAVE_int_fetch_and_add_release_write) \ - && defined(AO_HAVE_int_fetch_and_add_release) -# define AO_int_fetch_and_add_release_write(addr, val) \ - AO_int_fetch_and_add_release(addr, val) -# define AO_HAVE_int_fetch_and_add_release_write -#endif - -#if !defined(AO_HAVE_int_fetch_and_add_acquire_read) \ - && defined(AO_HAVE_int_fetch_and_add_read) -# define AO_int_fetch_and_add_acquire_read(addr, val) \ - AO_int_fetch_and_add_read(addr, val) -# define AO_HAVE_int_fetch_and_add_acquire_read -#endif -#if !defined(AO_HAVE_int_fetch_and_add_acquire_read) \ - && defined(AO_HAVE_int_fetch_and_add_acquire) -# define AO_int_fetch_and_add_acquire_read(addr, val) \ - AO_int_fetch_and_add_acquire(addr, val) -# define AO_HAVE_int_fetch_and_add_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_int_fetch_and_add_acquire_read) -# define AO_int_fetch_and_add_dd_acquire_read(addr, val) \ - AO_int_fetch_and_add_acquire_read(addr, val) -# define AO_HAVE_int_fetch_and_add_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_int_fetch_and_add) -# define AO_int_fetch_and_add_dd_acquire_read(addr, val) \ - AO_int_fetch_and_add(addr, val) -# define AO_HAVE_int_fetch_and_add_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* int_fetch_and_add1 */ -#if defined(AO_HAVE_int_fetch_and_add_full) \ - && !defined(AO_HAVE_int_fetch_and_add1_full) -# define AO_int_fetch_and_add1_full(addr) \ - AO_int_fetch_and_add_full(addr, 1) -# define AO_HAVE_int_fetch_and_add1_full -#endif -#if defined(AO_HAVE_int_fetch_and_add_release) \ - && !defined(AO_HAVE_int_fetch_and_add1_release) -# define AO_int_fetch_and_add1_release(addr) \ - AO_int_fetch_and_add_release(addr, 1) -# define AO_HAVE_int_fetch_and_add1_release -#endif -#if defined(AO_HAVE_int_fetch_and_add_acquire) \ - && !defined(AO_HAVE_int_fetch_and_add1_acquire) -# define AO_int_fetch_and_add1_acquire(addr) \ - AO_int_fetch_and_add_acquire(addr, 1) -# define AO_HAVE_int_fetch_and_add1_acquire -#endif -#if defined(AO_HAVE_int_fetch_and_add_write) \ - && !defined(AO_HAVE_int_fetch_and_add1_write) -# define AO_int_fetch_and_add1_write(addr) \ - AO_int_fetch_and_add_write(addr, 1) -# define AO_HAVE_int_fetch_and_add1_write -#endif -#if defined(AO_HAVE_int_fetch_and_add_read) \ - && !defined(AO_HAVE_int_fetch_and_add1_read) -# define AO_int_fetch_and_add1_read(addr) \ - AO_int_fetch_and_add_read(addr, 1) -# define AO_HAVE_int_fetch_and_add1_read -#endif -#if defined(AO_HAVE_int_fetch_and_add_release_write) \ - && !defined(AO_HAVE_int_fetch_and_add1_release_write) -# define AO_int_fetch_and_add1_release_write(addr) \ - AO_int_fetch_and_add_release_write(addr, 1) -# define AO_HAVE_int_fetch_and_add1_release_write -#endif -#if defined(AO_HAVE_int_fetch_and_add_acquire_read) \ - && !defined(AO_HAVE_int_fetch_and_add1_acquire_read) -# define AO_int_fetch_and_add1_acquire_read(addr) \ - AO_int_fetch_and_add_acquire_read(addr, 1) -# define AO_HAVE_int_fetch_and_add1_acquire_read -#endif -#if defined(AO_HAVE_int_fetch_and_add) \ - && !defined(AO_HAVE_int_fetch_and_add1) -# define AO_int_fetch_and_add1(addr) AO_int_fetch_and_add(addr, 1) -# define AO_HAVE_int_fetch_and_add1 -#endif - -#if defined(AO_HAVE_int_fetch_and_add1_full) -# if !defined(AO_HAVE_int_fetch_and_add1_release) -# define AO_int_fetch_and_add1_release(addr) \ - AO_int_fetch_and_add1_full(addr) -# define AO_HAVE_int_fetch_and_add1_release -# endif -# if !defined(AO_HAVE_int_fetch_and_add1_acquire) -# define AO_int_fetch_and_add1_acquire(addr) \ - AO_int_fetch_and_add1_full(addr) -# define AO_HAVE_int_fetch_and_add1_acquire -# endif -# if !defined(AO_HAVE_int_fetch_and_add1_write) -# define AO_int_fetch_and_add1_write(addr) \ - AO_int_fetch_and_add1_full(addr) -# define AO_HAVE_int_fetch_and_add1_write -# endif -# if !defined(AO_HAVE_int_fetch_and_add1_read) -# define AO_int_fetch_and_add1_read(addr) \ - AO_int_fetch_and_add1_full(addr) -# define AO_HAVE_int_fetch_and_add1_read -# endif -#endif /* AO_HAVE_int_fetch_and_add1_full */ - -#if !defined(AO_HAVE_int_fetch_and_add1) \ - && defined(AO_HAVE_int_fetch_and_add1_release) -# define AO_int_fetch_and_add1(addr) AO_int_fetch_and_add1_release(addr) -# define AO_HAVE_int_fetch_and_add1 -#endif -#if !defined(AO_HAVE_int_fetch_and_add1) \ - && defined(AO_HAVE_int_fetch_and_add1_acquire) -# define AO_int_fetch_and_add1(addr) AO_int_fetch_and_add1_acquire(addr) -# define AO_HAVE_int_fetch_and_add1 -#endif -#if !defined(AO_HAVE_int_fetch_and_add1) \ - && defined(AO_HAVE_int_fetch_and_add1_write) -# define AO_int_fetch_and_add1(addr) AO_int_fetch_and_add1_write(addr) -# define AO_HAVE_int_fetch_and_add1 -#endif -#if !defined(AO_HAVE_int_fetch_and_add1) \ - && defined(AO_HAVE_int_fetch_and_add1_read) -# define AO_int_fetch_and_add1(addr) AO_int_fetch_and_add1_read(addr) -# define AO_HAVE_int_fetch_and_add1 -#endif - -#if defined(AO_HAVE_int_fetch_and_add1_acquire) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_int_fetch_and_add1_full) -# define AO_int_fetch_and_add1_full(addr) \ - (AO_nop_full(), AO_int_fetch_and_add1_acquire(addr)) -# define AO_HAVE_int_fetch_and_add1_full -#endif - -#if !defined(AO_HAVE_int_fetch_and_add1_release_write) \ - && defined(AO_HAVE_int_fetch_and_add1_write) -# define AO_int_fetch_and_add1_release_write(addr) \ - AO_int_fetch_and_add1_write(addr) -# define AO_HAVE_int_fetch_and_add1_release_write -#endif -#if !defined(AO_HAVE_int_fetch_and_add1_release_write) \ - && defined(AO_HAVE_int_fetch_and_add1_release) -# define AO_int_fetch_and_add1_release_write(addr) \ - AO_int_fetch_and_add1_release(addr) -# define AO_HAVE_int_fetch_and_add1_release_write -#endif -#if !defined(AO_HAVE_int_fetch_and_add1_acquire_read) \ - && defined(AO_HAVE_int_fetch_and_add1_read) -# define AO_int_fetch_and_add1_acquire_read(addr) \ - AO_int_fetch_and_add1_read(addr) -# define AO_HAVE_int_fetch_and_add1_acquire_read -#endif -#if !defined(AO_HAVE_int_fetch_and_add1_acquire_read) \ - && defined(AO_HAVE_int_fetch_and_add1_acquire) -# define AO_int_fetch_and_add1_acquire_read(addr) \ - AO_int_fetch_and_add1_acquire(addr) -# define AO_HAVE_int_fetch_and_add1_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_int_fetch_and_add1_acquire_read) -# define AO_int_fetch_and_add1_dd_acquire_read(addr) \ - AO_int_fetch_and_add1_acquire_read(addr) -# define AO_HAVE_int_fetch_and_add1_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_int_fetch_and_add1) -# define AO_int_fetch_and_add1_dd_acquire_read(addr) \ - AO_int_fetch_and_add1(addr) -# define AO_HAVE_int_fetch_and_add1_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* int_fetch_and_sub1 */ -#if defined(AO_HAVE_int_fetch_and_add_full) \ - && !defined(AO_HAVE_int_fetch_and_sub1_full) -# define AO_int_fetch_and_sub1_full(addr) \ - AO_int_fetch_and_add_full(addr, (unsigned)(-1)) -# define AO_HAVE_int_fetch_and_sub1_full -#endif -#if defined(AO_HAVE_int_fetch_and_add_release) \ - && !defined(AO_HAVE_int_fetch_and_sub1_release) -# define AO_int_fetch_and_sub1_release(addr) \ - AO_int_fetch_and_add_release(addr, (unsigned)(-1)) -# define AO_HAVE_int_fetch_and_sub1_release -#endif -#if defined(AO_HAVE_int_fetch_and_add_acquire) \ - && !defined(AO_HAVE_int_fetch_and_sub1_acquire) -# define AO_int_fetch_and_sub1_acquire(addr) \ - AO_int_fetch_and_add_acquire(addr, (unsigned)(-1)) -# define AO_HAVE_int_fetch_and_sub1_acquire -#endif -#if defined(AO_HAVE_int_fetch_and_add_write) \ - && !defined(AO_HAVE_int_fetch_and_sub1_write) -# define AO_int_fetch_and_sub1_write(addr) \ - AO_int_fetch_and_add_write(addr, (unsigned)(-1)) -# define AO_HAVE_int_fetch_and_sub1_write -#endif -#if defined(AO_HAVE_int_fetch_and_add_read) \ - && !defined(AO_HAVE_int_fetch_and_sub1_read) -# define AO_int_fetch_and_sub1_read(addr) \ - AO_int_fetch_and_add_read(addr, (unsigned)(-1)) -# define AO_HAVE_int_fetch_and_sub1_read -#endif -#if defined(AO_HAVE_int_fetch_and_add_release_write) \ - && !defined(AO_HAVE_int_fetch_and_sub1_release_write) -# define AO_int_fetch_and_sub1_release_write(addr) \ - AO_int_fetch_and_add_release_write(addr, (unsigned)(-1)) -# define AO_HAVE_int_fetch_and_sub1_release_write -#endif -#if defined(AO_HAVE_int_fetch_and_add_acquire_read) \ - && !defined(AO_HAVE_int_fetch_and_sub1_acquire_read) -# define AO_int_fetch_and_sub1_acquire_read(addr) \ - AO_int_fetch_and_add_acquire_read(addr, (unsigned)(-1)) -# define AO_HAVE_int_fetch_and_sub1_acquire_read -#endif -#if defined(AO_HAVE_int_fetch_and_add) \ - && !defined(AO_HAVE_int_fetch_and_sub1) -# define AO_int_fetch_and_sub1(addr) \ - AO_int_fetch_and_add(addr, (unsigned)(-1)) -# define AO_HAVE_int_fetch_and_sub1 -#endif - -#if defined(AO_HAVE_int_fetch_and_sub1_full) -# if !defined(AO_HAVE_int_fetch_and_sub1_release) -# define AO_int_fetch_and_sub1_release(addr) \ - AO_int_fetch_and_sub1_full(addr) -# define AO_HAVE_int_fetch_and_sub1_release -# endif -# if !defined(AO_HAVE_int_fetch_and_sub1_acquire) -# define AO_int_fetch_and_sub1_acquire(addr) \ - AO_int_fetch_and_sub1_full(addr) -# define AO_HAVE_int_fetch_and_sub1_acquire -# endif -# if !defined(AO_HAVE_int_fetch_and_sub1_write) -# define AO_int_fetch_and_sub1_write(addr) \ - AO_int_fetch_and_sub1_full(addr) -# define AO_HAVE_int_fetch_and_sub1_write -# endif -# if !defined(AO_HAVE_int_fetch_and_sub1_read) -# define AO_int_fetch_and_sub1_read(addr) \ - AO_int_fetch_and_sub1_full(addr) -# define AO_HAVE_int_fetch_and_sub1_read -# endif -#endif /* AO_HAVE_int_fetch_and_sub1_full */ - -#if !defined(AO_HAVE_int_fetch_and_sub1) \ - && defined(AO_HAVE_int_fetch_and_sub1_release) -# define AO_int_fetch_and_sub1(addr) AO_int_fetch_and_sub1_release(addr) -# define AO_HAVE_int_fetch_and_sub1 -#endif -#if !defined(AO_HAVE_int_fetch_and_sub1) \ - && defined(AO_HAVE_int_fetch_and_sub1_acquire) -# define AO_int_fetch_and_sub1(addr) AO_int_fetch_and_sub1_acquire(addr) -# define AO_HAVE_int_fetch_and_sub1 -#endif -#if !defined(AO_HAVE_int_fetch_and_sub1) \ - && defined(AO_HAVE_int_fetch_and_sub1_write) -# define AO_int_fetch_and_sub1(addr) AO_int_fetch_and_sub1_write(addr) -# define AO_HAVE_int_fetch_and_sub1 -#endif -#if !defined(AO_HAVE_int_fetch_and_sub1) \ - && defined(AO_HAVE_int_fetch_and_sub1_read) -# define AO_int_fetch_and_sub1(addr) AO_int_fetch_and_sub1_read(addr) -# define AO_HAVE_int_fetch_and_sub1 -#endif - -#if defined(AO_HAVE_int_fetch_and_sub1_acquire) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_int_fetch_and_sub1_full) -# define AO_int_fetch_and_sub1_full(addr) \ - (AO_nop_full(), AO_int_fetch_and_sub1_acquire(addr)) -# define AO_HAVE_int_fetch_and_sub1_full -#endif - -#if !defined(AO_HAVE_int_fetch_and_sub1_release_write) \ - && defined(AO_HAVE_int_fetch_and_sub1_write) -# define AO_int_fetch_and_sub1_release_write(addr) \ - AO_int_fetch_and_sub1_write(addr) -# define AO_HAVE_int_fetch_and_sub1_release_write -#endif -#if !defined(AO_HAVE_int_fetch_and_sub1_release_write) \ - && defined(AO_HAVE_int_fetch_and_sub1_release) -# define AO_int_fetch_and_sub1_release_write(addr) \ - AO_int_fetch_and_sub1_release(addr) -# define AO_HAVE_int_fetch_and_sub1_release_write -#endif -#if !defined(AO_HAVE_int_fetch_and_sub1_acquire_read) \ - && defined(AO_HAVE_int_fetch_and_sub1_read) -# define AO_int_fetch_and_sub1_acquire_read(addr) \ - AO_int_fetch_and_sub1_read(addr) -# define AO_HAVE_int_fetch_and_sub1_acquire_read -#endif -#if !defined(AO_HAVE_int_fetch_and_sub1_acquire_read) \ - && defined(AO_HAVE_int_fetch_and_sub1_acquire) -# define AO_int_fetch_and_sub1_acquire_read(addr) \ - AO_int_fetch_and_sub1_acquire(addr) -# define AO_HAVE_int_fetch_and_sub1_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_int_fetch_and_sub1_acquire_read) -# define AO_int_fetch_and_sub1_dd_acquire_read(addr) \ - AO_int_fetch_and_sub1_acquire_read(addr) -# define AO_HAVE_int_fetch_and_sub1_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_int_fetch_and_sub1) -# define AO_int_fetch_and_sub1_dd_acquire_read(addr) \ - AO_int_fetch_and_sub1(addr) -# define AO_HAVE_int_fetch_and_sub1_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* int_and */ -#if defined(AO_HAVE_int_compare_and_swap_full) \ - && !defined(AO_HAVE_int_and_full) - AO_INLINE void - AO_int_and_full(volatile unsigned *addr, unsigned value) - { - unsigned old; - - do - { - old = *(unsigned *)addr; - } - while (AO_EXPECT_FALSE(!AO_int_compare_and_swap_full(addr, old, - old & value))); - } -# define AO_HAVE_int_and_full -#endif - -#if defined(AO_HAVE_int_and_full) -# if !defined(AO_HAVE_int_and_release) -# define AO_int_and_release(addr, val) AO_int_and_full(addr, val) -# define AO_HAVE_int_and_release -# endif -# if !defined(AO_HAVE_int_and_acquire) -# define AO_int_and_acquire(addr, val) AO_int_and_full(addr, val) -# define AO_HAVE_int_and_acquire -# endif -# if !defined(AO_HAVE_int_and_write) -# define AO_int_and_write(addr, val) AO_int_and_full(addr, val) -# define AO_HAVE_int_and_write -# endif -# if !defined(AO_HAVE_int_and_read) -# define AO_int_and_read(addr, val) AO_int_and_full(addr, val) -# define AO_HAVE_int_and_read -# endif -#endif /* AO_HAVE_int_and_full */ - -#if !defined(AO_HAVE_int_and) && defined(AO_HAVE_int_and_release) -# define AO_int_and(addr, val) AO_int_and_release(addr, val) -# define AO_HAVE_int_and -#endif -#if !defined(AO_HAVE_int_and) && defined(AO_HAVE_int_and_acquire) -# define AO_int_and(addr, val) AO_int_and_acquire(addr, val) -# define AO_HAVE_int_and -#endif -#if !defined(AO_HAVE_int_and) && defined(AO_HAVE_int_and_write) -# define AO_int_and(addr, val) AO_int_and_write(addr, val) -# define AO_HAVE_int_and -#endif -#if !defined(AO_HAVE_int_and) && defined(AO_HAVE_int_and_read) -# define AO_int_and(addr, val) AO_int_and_read(addr, val) -# define AO_HAVE_int_and -#endif - -#if defined(AO_HAVE_int_and_acquire) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_int_and_full) -# define AO_int_and_full(addr, val) \ - (AO_nop_full(), AO_int_and_acquire(addr, val)) -# define AO_HAVE_int_and_full -#endif - -#if !defined(AO_HAVE_int_and_release_write) \ - && defined(AO_HAVE_int_and_write) -# define AO_int_and_release_write(addr, val) AO_int_and_write(addr, val) -# define AO_HAVE_int_and_release_write -#endif -#if !defined(AO_HAVE_int_and_release_write) \ - && defined(AO_HAVE_int_and_release) -# define AO_int_and_release_write(addr, val) AO_int_and_release(addr, val) -# define AO_HAVE_int_and_release_write -#endif -#if !defined(AO_HAVE_int_and_acquire_read) \ - && defined(AO_HAVE_int_and_read) -# define AO_int_and_acquire_read(addr, val) AO_int_and_read(addr, val) -# define AO_HAVE_int_and_acquire_read -#endif -#if !defined(AO_HAVE_int_and_acquire_read) \ - && defined(AO_HAVE_int_and_acquire) -# define AO_int_and_acquire_read(addr, val) AO_int_and_acquire(addr, val) -# define AO_HAVE_int_and_acquire_read -#endif - -/* int_or */ -#if defined(AO_HAVE_int_compare_and_swap_full) \ - && !defined(AO_HAVE_int_or_full) - AO_INLINE void - AO_int_or_full(volatile unsigned *addr, unsigned value) - { - unsigned old; - - do - { - old = *(unsigned *)addr; - } - while (AO_EXPECT_FALSE(!AO_int_compare_and_swap_full(addr, old, - old | value))); - } -# define AO_HAVE_int_or_full -#endif - -#if defined(AO_HAVE_int_or_full) -# if !defined(AO_HAVE_int_or_release) -# define AO_int_or_release(addr, val) AO_int_or_full(addr, val) -# define AO_HAVE_int_or_release -# endif -# if !defined(AO_HAVE_int_or_acquire) -# define AO_int_or_acquire(addr, val) AO_int_or_full(addr, val) -# define AO_HAVE_int_or_acquire -# endif -# if !defined(AO_HAVE_int_or_write) -# define AO_int_or_write(addr, val) AO_int_or_full(addr, val) -# define AO_HAVE_int_or_write -# endif -# if !defined(AO_HAVE_int_or_read) -# define AO_int_or_read(addr, val) AO_int_or_full(addr, val) -# define AO_HAVE_int_or_read -# endif -#endif /* AO_HAVE_int_or_full */ - -#if !defined(AO_HAVE_int_or) && defined(AO_HAVE_int_or_release) -# define AO_int_or(addr, val) AO_int_or_release(addr, val) -# define AO_HAVE_int_or -#endif -#if !defined(AO_HAVE_int_or) && defined(AO_HAVE_int_or_acquire) -# define AO_int_or(addr, val) AO_int_or_acquire(addr, val) -# define AO_HAVE_int_or -#endif -#if !defined(AO_HAVE_int_or) && defined(AO_HAVE_int_or_write) -# define AO_int_or(addr, val) AO_int_or_write(addr, val) -# define AO_HAVE_int_or -#endif -#if !defined(AO_HAVE_int_or) && defined(AO_HAVE_int_or_read) -# define AO_int_or(addr, val) AO_int_or_read(addr, val) -# define AO_HAVE_int_or -#endif - -#if defined(AO_HAVE_int_or_acquire) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_int_or_full) -# define AO_int_or_full(addr, val) \ - (AO_nop_full(), AO_int_or_acquire(addr, val)) -# define AO_HAVE_int_or_full -#endif - -#if !defined(AO_HAVE_int_or_release_write) \ - && defined(AO_HAVE_int_or_write) -# define AO_int_or_release_write(addr, val) AO_int_or_write(addr, val) -# define AO_HAVE_int_or_release_write -#endif -#if !defined(AO_HAVE_int_or_release_write) \ - && defined(AO_HAVE_int_or_release) -# define AO_int_or_release_write(addr, val) AO_int_or_release(addr, val) -# define AO_HAVE_int_or_release_write -#endif -#if !defined(AO_HAVE_int_or_acquire_read) && defined(AO_HAVE_int_or_read) -# define AO_int_or_acquire_read(addr, val) AO_int_or_read(addr, val) -# define AO_HAVE_int_or_acquire_read -#endif -#if !defined(AO_HAVE_int_or_acquire_read) \ - && defined(AO_HAVE_int_or_acquire) -# define AO_int_or_acquire_read(addr, val) AO_int_or_acquire(addr, val) -# define AO_HAVE_int_or_acquire_read -#endif - -/* int_xor */ -#if defined(AO_HAVE_int_compare_and_swap_full) \ - && !defined(AO_HAVE_int_xor_full) - AO_INLINE void - AO_int_xor_full(volatile unsigned *addr, unsigned value) - { - unsigned old; - - do - { - old = *(unsigned *)addr; - } - while (AO_EXPECT_FALSE(!AO_int_compare_and_swap_full(addr, old, - old ^ value))); - } -# define AO_HAVE_int_xor_full -#endif - -#if defined(AO_HAVE_int_xor_full) -# if !defined(AO_HAVE_int_xor_release) -# define AO_int_xor_release(addr, val) AO_int_xor_full(addr, val) -# define AO_HAVE_int_xor_release -# endif -# if !defined(AO_HAVE_int_xor_acquire) -# define AO_int_xor_acquire(addr, val) AO_int_xor_full(addr, val) -# define AO_HAVE_int_xor_acquire -# endif -# if !defined(AO_HAVE_int_xor_write) -# define AO_int_xor_write(addr, val) AO_int_xor_full(addr, val) -# define AO_HAVE_int_xor_write -# endif -# if !defined(AO_HAVE_int_xor_read) -# define AO_int_xor_read(addr, val) AO_int_xor_full(addr, val) -# define AO_HAVE_int_xor_read -# endif -#endif /* AO_HAVE_int_xor_full */ - -#if !defined(AO_HAVE_int_xor) && defined(AO_HAVE_int_xor_release) -# define AO_int_xor(addr, val) AO_int_xor_release(addr, val) -# define AO_HAVE_int_xor -#endif -#if !defined(AO_HAVE_int_xor) && defined(AO_HAVE_int_xor_acquire) -# define AO_int_xor(addr, val) AO_int_xor_acquire(addr, val) -# define AO_HAVE_int_xor -#endif -#if !defined(AO_HAVE_int_xor) && defined(AO_HAVE_int_xor_write) -# define AO_int_xor(addr, val) AO_int_xor_write(addr, val) -# define AO_HAVE_int_xor -#endif -#if !defined(AO_HAVE_int_xor) && defined(AO_HAVE_int_xor_read) -# define AO_int_xor(addr, val) AO_int_xor_read(addr, val) -# define AO_HAVE_int_xor -#endif - -#if defined(AO_HAVE_int_xor_acquire) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_int_xor_full) -# define AO_int_xor_full(addr, val) \ - (AO_nop_full(), AO_int_xor_acquire(addr, val)) -# define AO_HAVE_int_xor_full -#endif - -#if !defined(AO_HAVE_int_xor_release_write) \ - && defined(AO_HAVE_int_xor_write) -# define AO_int_xor_release_write(addr, val) AO_int_xor_write(addr, val) -# define AO_HAVE_int_xor_release_write -#endif -#if !defined(AO_HAVE_int_xor_release_write) \ - && defined(AO_HAVE_int_xor_release) -# define AO_int_xor_release_write(addr, val) AO_int_xor_release(addr, val) -# define AO_HAVE_int_xor_release_write -#endif -#if !defined(AO_HAVE_int_xor_acquire_read) \ - && defined(AO_HAVE_int_xor_read) -# define AO_int_xor_acquire_read(addr, val) AO_int_xor_read(addr, val) -# define AO_HAVE_int_xor_acquire_read -#endif -#if !defined(AO_HAVE_int_xor_acquire_read) \ - && defined(AO_HAVE_int_xor_acquire) -# define AO_int_xor_acquire_read(addr, val) AO_int_xor_acquire(addr, val) -# define AO_HAVE_int_xor_acquire_read -#endif - -/* int_and/or/xor_dd_acquire_read are meaningless. */ -/* - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* compare_and_swap (based on fetch_compare_and_swap) */ -#if defined(AO_HAVE_fetch_compare_and_swap_full) \ - && !defined(AO_HAVE_compare_and_swap_full) - AO_INLINE int - AO_compare_and_swap_full(volatile AO_t *addr, AO_t old_val, - AO_t new_val) - { - return AO_fetch_compare_and_swap_full(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_compare_and_swap_full -#endif - -#if defined(AO_HAVE_fetch_compare_and_swap_acquire) \ - && !defined(AO_HAVE_compare_and_swap_acquire) - AO_INLINE int - AO_compare_and_swap_acquire(volatile AO_t *addr, AO_t old_val, - AO_t new_val) - { - return AO_fetch_compare_and_swap_acquire(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_compare_and_swap_acquire -#endif - -#if defined(AO_HAVE_fetch_compare_and_swap_release) \ - && !defined(AO_HAVE_compare_and_swap_release) - AO_INLINE int - AO_compare_and_swap_release(volatile AO_t *addr, AO_t old_val, - AO_t new_val) - { - return AO_fetch_compare_and_swap_release(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_compare_and_swap_release -#endif - -#if defined(AO_HAVE_fetch_compare_and_swap_write) \ - && !defined(AO_HAVE_compare_and_swap_write) - AO_INLINE int - AO_compare_and_swap_write(volatile AO_t *addr, AO_t old_val, - AO_t new_val) - { - return AO_fetch_compare_and_swap_write(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_compare_and_swap_write -#endif - -#if defined(AO_HAVE_fetch_compare_and_swap_read) \ - && !defined(AO_HAVE_compare_and_swap_read) - AO_INLINE int - AO_compare_and_swap_read(volatile AO_t *addr, AO_t old_val, - AO_t new_val) - { - return AO_fetch_compare_and_swap_read(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_compare_and_swap_read -#endif - -#if defined(AO_HAVE_fetch_compare_and_swap) \ - && !defined(AO_HAVE_compare_and_swap) - AO_INLINE int - AO_compare_and_swap(volatile AO_t *addr, AO_t old_val, - AO_t new_val) - { - return AO_fetch_compare_and_swap(addr, old_val, new_val) == old_val; - } -# define AO_HAVE_compare_and_swap -#endif - -#if defined(AO_HAVE_fetch_compare_and_swap_release_write) \ - && !defined(AO_HAVE_compare_and_swap_release_write) - AO_INLINE int - AO_compare_and_swap_release_write(volatile AO_t *addr, - AO_t old_val, AO_t new_val) - { - return AO_fetch_compare_and_swap_release_write(addr, old_val, - new_val) == old_val; - } -# define AO_HAVE_compare_and_swap_release_write -#endif - -#if defined(AO_HAVE_fetch_compare_and_swap_acquire_read) \ - && !defined(AO_HAVE_compare_and_swap_acquire_read) - AO_INLINE int - AO_compare_and_swap_acquire_read(volatile AO_t *addr, - AO_t old_val, AO_t new_val) - { - return AO_fetch_compare_and_swap_acquire_read(addr, old_val, - new_val) == old_val; - } -# define AO_HAVE_compare_and_swap_acquire_read -#endif - -#if defined(AO_HAVE_fetch_compare_and_swap_dd_acquire_read) \ - && !defined(AO_HAVE_compare_and_swap_dd_acquire_read) - AO_INLINE int - AO_compare_and_swap_dd_acquire_read(volatile AO_t *addr, - AO_t old_val, AO_t new_val) - { - return AO_fetch_compare_and_swap_dd_acquire_read(addr, old_val, - new_val) == old_val; - } -# define AO_HAVE_compare_and_swap_dd_acquire_read -#endif - -/* fetch_and_add */ -/* We first try to implement fetch_and_add variants in terms of the */ -/* corresponding compare_and_swap variants to minimize adding barriers. */ -#if defined(AO_HAVE_compare_and_swap_full) \ - && !defined(AO_HAVE_fetch_and_add_full) - AO_INLINE AO_t - AO_fetch_and_add_full(volatile AO_t *addr, AO_t incr) - { - AO_t old; - - do - { - old = *(AO_t *)addr; - } - while (AO_EXPECT_FALSE(!AO_compare_and_swap_full(addr, old, - old + incr))); - return old; - } -# define AO_HAVE_fetch_and_add_full -#endif - -#if defined(AO_HAVE_compare_and_swap_acquire) \ - && !defined(AO_HAVE_fetch_and_add_acquire) - AO_INLINE AO_t - AO_fetch_and_add_acquire(volatile AO_t *addr, AO_t incr) - { - AO_t old; - - do - { - old = *(AO_t *)addr; - } - while (AO_EXPECT_FALSE(!AO_compare_and_swap_acquire(addr, old, - old + incr))); - return old; - } -# define AO_HAVE_fetch_and_add_acquire -#endif - -#if defined(AO_HAVE_compare_and_swap_release) \ - && !defined(AO_HAVE_fetch_and_add_release) - AO_INLINE AO_t - AO_fetch_and_add_release(volatile AO_t *addr, AO_t incr) - { - AO_t old; - - do - { - old = *(AO_t *)addr; - } - while (AO_EXPECT_FALSE(!AO_compare_and_swap_release(addr, old, - old + incr))); - return old; - } -# define AO_HAVE_fetch_and_add_release -#endif - -#if defined(AO_HAVE_compare_and_swap) \ - && !defined(AO_HAVE_fetch_and_add) - AO_INLINE AO_t - AO_fetch_and_add(volatile AO_t *addr, AO_t incr) - { - AO_t old; - - do - { - old = *(AO_t *)addr; - } - while (AO_EXPECT_FALSE(!AO_compare_and_swap(addr, old, - old + incr))); - return old; - } -# define AO_HAVE_fetch_and_add -#endif - -#if defined(AO_HAVE_fetch_and_add_full) -# if !defined(AO_HAVE_fetch_and_add_release) -# define AO_fetch_and_add_release(addr, val) \ - AO_fetch_and_add_full(addr, val) -# define AO_HAVE_fetch_and_add_release -# endif -# if !defined(AO_HAVE_fetch_and_add_acquire) -# define AO_fetch_and_add_acquire(addr, val) \ - AO_fetch_and_add_full(addr, val) -# define AO_HAVE_fetch_and_add_acquire -# endif -# if !defined(AO_HAVE_fetch_and_add_write) -# define AO_fetch_and_add_write(addr, val) \ - AO_fetch_and_add_full(addr, val) -# define AO_HAVE_fetch_and_add_write -# endif -# if !defined(AO_HAVE_fetch_and_add_read) -# define AO_fetch_and_add_read(addr, val) \ - AO_fetch_and_add_full(addr, val) -# define AO_HAVE_fetch_and_add_read -# endif -#endif /* AO_HAVE_fetch_and_add_full */ - -#if defined(AO_HAVE_fetch_and_add) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_fetch_and_add_acquire) - AO_INLINE AO_t - AO_fetch_and_add_acquire(volatile AO_t *addr, AO_t incr) - { - AO_t result = AO_fetch_and_add(addr, incr); - AO_nop_full(); - return result; - } -# define AO_HAVE_fetch_and_add_acquire -#endif -#if defined(AO_HAVE_fetch_and_add) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_fetch_and_add_release) -# define AO_fetch_and_add_release(addr, incr) \ - (AO_nop_full(), AO_fetch_and_add(addr, incr)) -# define AO_HAVE_fetch_and_add_release -#endif - -#if !defined(AO_HAVE_fetch_and_add) \ - && defined(AO_HAVE_fetch_and_add_release) -# define AO_fetch_and_add(addr, val) \ - AO_fetch_and_add_release(addr, val) -# define AO_HAVE_fetch_and_add -#endif -#if !defined(AO_HAVE_fetch_and_add) \ - && defined(AO_HAVE_fetch_and_add_acquire) -# define AO_fetch_and_add(addr, val) \ - AO_fetch_and_add_acquire(addr, val) -# define AO_HAVE_fetch_and_add -#endif -#if !defined(AO_HAVE_fetch_and_add) \ - && defined(AO_HAVE_fetch_and_add_write) -# define AO_fetch_and_add(addr, val) \ - AO_fetch_and_add_write(addr, val) -# define AO_HAVE_fetch_and_add -#endif -#if !defined(AO_HAVE_fetch_and_add) \ - && defined(AO_HAVE_fetch_and_add_read) -# define AO_fetch_and_add(addr, val) \ - AO_fetch_and_add_read(addr, val) -# define AO_HAVE_fetch_and_add -#endif - -#if defined(AO_HAVE_fetch_and_add_acquire) \ - && defined(AO_HAVE_nop_full) && !defined(AO_HAVE_fetch_and_add_full) -# define AO_fetch_and_add_full(addr, val) \ - (AO_nop_full(), AO_fetch_and_add_acquire(addr, val)) -# define AO_HAVE_fetch_and_add_full -#endif - -#if !defined(AO_HAVE_fetch_and_add_release_write) \ - && defined(AO_HAVE_fetch_and_add_write) -# define AO_fetch_and_add_release_write(addr, val) \ - AO_fetch_and_add_write(addr, val) -# define AO_HAVE_fetch_and_add_release_write -#endif -#if !defined(AO_HAVE_fetch_and_add_release_write) \ - && defined(AO_HAVE_fetch_and_add_release) -# define AO_fetch_and_add_release_write(addr, val) \ - AO_fetch_and_add_release(addr, val) -# define AO_HAVE_fetch_and_add_release_write -#endif - -#if !defined(AO_HAVE_fetch_and_add_acquire_read) \ - && defined(AO_HAVE_fetch_and_add_read) -# define AO_fetch_and_add_acquire_read(addr, val) \ - AO_fetch_and_add_read(addr, val) -# define AO_HAVE_fetch_and_add_acquire_read -#endif -#if !defined(AO_HAVE_fetch_and_add_acquire_read) \ - && defined(AO_HAVE_fetch_and_add_acquire) -# define AO_fetch_and_add_acquire_read(addr, val) \ - AO_fetch_and_add_acquire(addr, val) -# define AO_HAVE_fetch_and_add_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_fetch_and_add_acquire_read) -# define AO_fetch_and_add_dd_acquire_read(addr, val) \ - AO_fetch_and_add_acquire_read(addr, val) -# define AO_HAVE_fetch_and_add_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_fetch_and_add) -# define AO_fetch_and_add_dd_acquire_read(addr, val) \ - AO_fetch_and_add(addr, val) -# define AO_HAVE_fetch_and_add_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* fetch_and_add1 */ -#if defined(AO_HAVE_fetch_and_add_full) \ - && !defined(AO_HAVE_fetch_and_add1_full) -# define AO_fetch_and_add1_full(addr) \ - AO_fetch_and_add_full(addr, 1) -# define AO_HAVE_fetch_and_add1_full -#endif -#if defined(AO_HAVE_fetch_and_add_release) \ - && !defined(AO_HAVE_fetch_and_add1_release) -# define AO_fetch_and_add1_release(addr) \ - AO_fetch_and_add_release(addr, 1) -# define AO_HAVE_fetch_and_add1_release -#endif -#if defined(AO_HAVE_fetch_and_add_acquire) \ - && !defined(AO_HAVE_fetch_and_add1_acquire) -# define AO_fetch_and_add1_acquire(addr) \ - AO_fetch_and_add_acquire(addr, 1) -# define AO_HAVE_fetch_and_add1_acquire -#endif -#if defined(AO_HAVE_fetch_and_add_write) \ - && !defined(AO_HAVE_fetch_and_add1_write) -# define AO_fetch_and_add1_write(addr) \ - AO_fetch_and_add_write(addr, 1) -# define AO_HAVE_fetch_and_add1_write -#endif -#if defined(AO_HAVE_fetch_and_add_read) \ - && !defined(AO_HAVE_fetch_and_add1_read) -# define AO_fetch_and_add1_read(addr) \ - AO_fetch_and_add_read(addr, 1) -# define AO_HAVE_fetch_and_add1_read -#endif -#if defined(AO_HAVE_fetch_and_add_release_write) \ - && !defined(AO_HAVE_fetch_and_add1_release_write) -# define AO_fetch_and_add1_release_write(addr) \ - AO_fetch_and_add_release_write(addr, 1) -# define AO_HAVE_fetch_and_add1_release_write -#endif -#if defined(AO_HAVE_fetch_and_add_acquire_read) \ - && !defined(AO_HAVE_fetch_and_add1_acquire_read) -# define AO_fetch_and_add1_acquire_read(addr) \ - AO_fetch_and_add_acquire_read(addr, 1) -# define AO_HAVE_fetch_and_add1_acquire_read -#endif -#if defined(AO_HAVE_fetch_and_add) \ - && !defined(AO_HAVE_fetch_and_add1) -# define AO_fetch_and_add1(addr) AO_fetch_and_add(addr, 1) -# define AO_HAVE_fetch_and_add1 -#endif - -#if defined(AO_HAVE_fetch_and_add1_full) -# if !defined(AO_HAVE_fetch_and_add1_release) -# define AO_fetch_and_add1_release(addr) \ - AO_fetch_and_add1_full(addr) -# define AO_HAVE_fetch_and_add1_release -# endif -# if !defined(AO_HAVE_fetch_and_add1_acquire) -# define AO_fetch_and_add1_acquire(addr) \ - AO_fetch_and_add1_full(addr) -# define AO_HAVE_fetch_and_add1_acquire -# endif -# if !defined(AO_HAVE_fetch_and_add1_write) -# define AO_fetch_and_add1_write(addr) \ - AO_fetch_and_add1_full(addr) -# define AO_HAVE_fetch_and_add1_write -# endif -# if !defined(AO_HAVE_fetch_and_add1_read) -# define AO_fetch_and_add1_read(addr) \ - AO_fetch_and_add1_full(addr) -# define AO_HAVE_fetch_and_add1_read -# endif -#endif /* AO_HAVE_fetch_and_add1_full */ - -#if !defined(AO_HAVE_fetch_and_add1) \ - && defined(AO_HAVE_fetch_and_add1_release) -# define AO_fetch_and_add1(addr) AO_fetch_and_add1_release(addr) -# define AO_HAVE_fetch_and_add1 -#endif -#if !defined(AO_HAVE_fetch_and_add1) \ - && defined(AO_HAVE_fetch_and_add1_acquire) -# define AO_fetch_and_add1(addr) AO_fetch_and_add1_acquire(addr) -# define AO_HAVE_fetch_and_add1 -#endif -#if !defined(AO_HAVE_fetch_and_add1) \ - && defined(AO_HAVE_fetch_and_add1_write) -# define AO_fetch_and_add1(addr) AO_fetch_and_add1_write(addr) -# define AO_HAVE_fetch_and_add1 -#endif -#if !defined(AO_HAVE_fetch_and_add1) \ - && defined(AO_HAVE_fetch_and_add1_read) -# define AO_fetch_and_add1(addr) AO_fetch_and_add1_read(addr) -# define AO_HAVE_fetch_and_add1 -#endif - -#if defined(AO_HAVE_fetch_and_add1_acquire) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_fetch_and_add1_full) -# define AO_fetch_and_add1_full(addr) \ - (AO_nop_full(), AO_fetch_and_add1_acquire(addr)) -# define AO_HAVE_fetch_and_add1_full -#endif - -#if !defined(AO_HAVE_fetch_and_add1_release_write) \ - && defined(AO_HAVE_fetch_and_add1_write) -# define AO_fetch_and_add1_release_write(addr) \ - AO_fetch_and_add1_write(addr) -# define AO_HAVE_fetch_and_add1_release_write -#endif -#if !defined(AO_HAVE_fetch_and_add1_release_write) \ - && defined(AO_HAVE_fetch_and_add1_release) -# define AO_fetch_and_add1_release_write(addr) \ - AO_fetch_and_add1_release(addr) -# define AO_HAVE_fetch_and_add1_release_write -#endif -#if !defined(AO_HAVE_fetch_and_add1_acquire_read) \ - && defined(AO_HAVE_fetch_and_add1_read) -# define AO_fetch_and_add1_acquire_read(addr) \ - AO_fetch_and_add1_read(addr) -# define AO_HAVE_fetch_and_add1_acquire_read -#endif -#if !defined(AO_HAVE_fetch_and_add1_acquire_read) \ - && defined(AO_HAVE_fetch_and_add1_acquire) -# define AO_fetch_and_add1_acquire_read(addr) \ - AO_fetch_and_add1_acquire(addr) -# define AO_HAVE_fetch_and_add1_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_fetch_and_add1_acquire_read) -# define AO_fetch_and_add1_dd_acquire_read(addr) \ - AO_fetch_and_add1_acquire_read(addr) -# define AO_HAVE_fetch_and_add1_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_fetch_and_add1) -# define AO_fetch_and_add1_dd_acquire_read(addr) \ - AO_fetch_and_add1(addr) -# define AO_HAVE_fetch_and_add1_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* fetch_and_sub1 */ -#if defined(AO_HAVE_fetch_and_add_full) \ - && !defined(AO_HAVE_fetch_and_sub1_full) -# define AO_fetch_and_sub1_full(addr) \ - AO_fetch_and_add_full(addr, (AO_t)(-1)) -# define AO_HAVE_fetch_and_sub1_full -#endif -#if defined(AO_HAVE_fetch_and_add_release) \ - && !defined(AO_HAVE_fetch_and_sub1_release) -# define AO_fetch_and_sub1_release(addr) \ - AO_fetch_and_add_release(addr, (AO_t)(-1)) -# define AO_HAVE_fetch_and_sub1_release -#endif -#if defined(AO_HAVE_fetch_and_add_acquire) \ - && !defined(AO_HAVE_fetch_and_sub1_acquire) -# define AO_fetch_and_sub1_acquire(addr) \ - AO_fetch_and_add_acquire(addr, (AO_t)(-1)) -# define AO_HAVE_fetch_and_sub1_acquire -#endif -#if defined(AO_HAVE_fetch_and_add_write) \ - && !defined(AO_HAVE_fetch_and_sub1_write) -# define AO_fetch_and_sub1_write(addr) \ - AO_fetch_and_add_write(addr, (AO_t)(-1)) -# define AO_HAVE_fetch_and_sub1_write -#endif -#if defined(AO_HAVE_fetch_and_add_read) \ - && !defined(AO_HAVE_fetch_and_sub1_read) -# define AO_fetch_and_sub1_read(addr) \ - AO_fetch_and_add_read(addr, (AO_t)(-1)) -# define AO_HAVE_fetch_and_sub1_read -#endif -#if defined(AO_HAVE_fetch_and_add_release_write) \ - && !defined(AO_HAVE_fetch_and_sub1_release_write) -# define AO_fetch_and_sub1_release_write(addr) \ - AO_fetch_and_add_release_write(addr, (AO_t)(-1)) -# define AO_HAVE_fetch_and_sub1_release_write -#endif -#if defined(AO_HAVE_fetch_and_add_acquire_read) \ - && !defined(AO_HAVE_fetch_and_sub1_acquire_read) -# define AO_fetch_and_sub1_acquire_read(addr) \ - AO_fetch_and_add_acquire_read(addr, (AO_t)(-1)) -# define AO_HAVE_fetch_and_sub1_acquire_read -#endif -#if defined(AO_HAVE_fetch_and_add) \ - && !defined(AO_HAVE_fetch_and_sub1) -# define AO_fetch_and_sub1(addr) \ - AO_fetch_and_add(addr, (AO_t)(-1)) -# define AO_HAVE_fetch_and_sub1 -#endif - -#if defined(AO_HAVE_fetch_and_sub1_full) -# if !defined(AO_HAVE_fetch_and_sub1_release) -# define AO_fetch_and_sub1_release(addr) \ - AO_fetch_and_sub1_full(addr) -# define AO_HAVE_fetch_and_sub1_release -# endif -# if !defined(AO_HAVE_fetch_and_sub1_acquire) -# define AO_fetch_and_sub1_acquire(addr) \ - AO_fetch_and_sub1_full(addr) -# define AO_HAVE_fetch_and_sub1_acquire -# endif -# if !defined(AO_HAVE_fetch_and_sub1_write) -# define AO_fetch_and_sub1_write(addr) \ - AO_fetch_and_sub1_full(addr) -# define AO_HAVE_fetch_and_sub1_write -# endif -# if !defined(AO_HAVE_fetch_and_sub1_read) -# define AO_fetch_and_sub1_read(addr) \ - AO_fetch_and_sub1_full(addr) -# define AO_HAVE_fetch_and_sub1_read -# endif -#endif /* AO_HAVE_fetch_and_sub1_full */ - -#if !defined(AO_HAVE_fetch_and_sub1) \ - && defined(AO_HAVE_fetch_and_sub1_release) -# define AO_fetch_and_sub1(addr) AO_fetch_and_sub1_release(addr) -# define AO_HAVE_fetch_and_sub1 -#endif -#if !defined(AO_HAVE_fetch_and_sub1) \ - && defined(AO_HAVE_fetch_and_sub1_acquire) -# define AO_fetch_and_sub1(addr) AO_fetch_and_sub1_acquire(addr) -# define AO_HAVE_fetch_and_sub1 -#endif -#if !defined(AO_HAVE_fetch_and_sub1) \ - && defined(AO_HAVE_fetch_and_sub1_write) -# define AO_fetch_and_sub1(addr) AO_fetch_and_sub1_write(addr) -# define AO_HAVE_fetch_and_sub1 -#endif -#if !defined(AO_HAVE_fetch_and_sub1) \ - && defined(AO_HAVE_fetch_and_sub1_read) -# define AO_fetch_and_sub1(addr) AO_fetch_and_sub1_read(addr) -# define AO_HAVE_fetch_and_sub1 -#endif - -#if defined(AO_HAVE_fetch_and_sub1_acquire) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_fetch_and_sub1_full) -# define AO_fetch_and_sub1_full(addr) \ - (AO_nop_full(), AO_fetch_and_sub1_acquire(addr)) -# define AO_HAVE_fetch_and_sub1_full -#endif - -#if !defined(AO_HAVE_fetch_and_sub1_release_write) \ - && defined(AO_HAVE_fetch_and_sub1_write) -# define AO_fetch_and_sub1_release_write(addr) \ - AO_fetch_and_sub1_write(addr) -# define AO_HAVE_fetch_and_sub1_release_write -#endif -#if !defined(AO_HAVE_fetch_and_sub1_release_write) \ - && defined(AO_HAVE_fetch_and_sub1_release) -# define AO_fetch_and_sub1_release_write(addr) \ - AO_fetch_and_sub1_release(addr) -# define AO_HAVE_fetch_and_sub1_release_write -#endif -#if !defined(AO_HAVE_fetch_and_sub1_acquire_read) \ - && defined(AO_HAVE_fetch_and_sub1_read) -# define AO_fetch_and_sub1_acquire_read(addr) \ - AO_fetch_and_sub1_read(addr) -# define AO_HAVE_fetch_and_sub1_acquire_read -#endif -#if !defined(AO_HAVE_fetch_and_sub1_acquire_read) \ - && defined(AO_HAVE_fetch_and_sub1_acquire) -# define AO_fetch_and_sub1_acquire_read(addr) \ - AO_fetch_and_sub1_acquire(addr) -# define AO_HAVE_fetch_and_sub1_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_fetch_and_sub1_acquire_read) -# define AO_fetch_and_sub1_dd_acquire_read(addr) \ - AO_fetch_and_sub1_acquire_read(addr) -# define AO_HAVE_fetch_and_sub1_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_fetch_and_sub1) -# define AO_fetch_and_sub1_dd_acquire_read(addr) \ - AO_fetch_and_sub1(addr) -# define AO_HAVE_fetch_and_sub1_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* and */ -#if defined(AO_HAVE_compare_and_swap_full) \ - && !defined(AO_HAVE_and_full) - AO_INLINE void - AO_and_full(volatile AO_t *addr, AO_t value) - { - AO_t old; - - do - { - old = *(AO_t *)addr; - } - while (AO_EXPECT_FALSE(!AO_compare_and_swap_full(addr, old, - old & value))); - } -# define AO_HAVE_and_full -#endif - -#if defined(AO_HAVE_and_full) -# if !defined(AO_HAVE_and_release) -# define AO_and_release(addr, val) AO_and_full(addr, val) -# define AO_HAVE_and_release -# endif -# if !defined(AO_HAVE_and_acquire) -# define AO_and_acquire(addr, val) AO_and_full(addr, val) -# define AO_HAVE_and_acquire -# endif -# if !defined(AO_HAVE_and_write) -# define AO_and_write(addr, val) AO_and_full(addr, val) -# define AO_HAVE_and_write -# endif -# if !defined(AO_HAVE_and_read) -# define AO_and_read(addr, val) AO_and_full(addr, val) -# define AO_HAVE_and_read -# endif -#endif /* AO_HAVE_and_full */ - -#if !defined(AO_HAVE_and) && defined(AO_HAVE_and_release) -# define AO_and(addr, val) AO_and_release(addr, val) -# define AO_HAVE_and -#endif -#if !defined(AO_HAVE_and) && defined(AO_HAVE_and_acquire) -# define AO_and(addr, val) AO_and_acquire(addr, val) -# define AO_HAVE_and -#endif -#if !defined(AO_HAVE_and) && defined(AO_HAVE_and_write) -# define AO_and(addr, val) AO_and_write(addr, val) -# define AO_HAVE_and -#endif -#if !defined(AO_HAVE_and) && defined(AO_HAVE_and_read) -# define AO_and(addr, val) AO_and_read(addr, val) -# define AO_HAVE_and -#endif - -#if defined(AO_HAVE_and_acquire) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_and_full) -# define AO_and_full(addr, val) \ - (AO_nop_full(), AO_and_acquire(addr, val)) -# define AO_HAVE_and_full -#endif - -#if !defined(AO_HAVE_and_release_write) \ - && defined(AO_HAVE_and_write) -# define AO_and_release_write(addr, val) AO_and_write(addr, val) -# define AO_HAVE_and_release_write -#endif -#if !defined(AO_HAVE_and_release_write) \ - && defined(AO_HAVE_and_release) -# define AO_and_release_write(addr, val) AO_and_release(addr, val) -# define AO_HAVE_and_release_write -#endif -#if !defined(AO_HAVE_and_acquire_read) \ - && defined(AO_HAVE_and_read) -# define AO_and_acquire_read(addr, val) AO_and_read(addr, val) -# define AO_HAVE_and_acquire_read -#endif -#if !defined(AO_HAVE_and_acquire_read) \ - && defined(AO_HAVE_and_acquire) -# define AO_and_acquire_read(addr, val) AO_and_acquire(addr, val) -# define AO_HAVE_and_acquire_read -#endif - -/* or */ -#if defined(AO_HAVE_compare_and_swap_full) \ - && !defined(AO_HAVE_or_full) - AO_INLINE void - AO_or_full(volatile AO_t *addr, AO_t value) - { - AO_t old; - - do - { - old = *(AO_t *)addr; - } - while (AO_EXPECT_FALSE(!AO_compare_and_swap_full(addr, old, - old | value))); - } -# define AO_HAVE_or_full -#endif - -#if defined(AO_HAVE_or_full) -# if !defined(AO_HAVE_or_release) -# define AO_or_release(addr, val) AO_or_full(addr, val) -# define AO_HAVE_or_release -# endif -# if !defined(AO_HAVE_or_acquire) -# define AO_or_acquire(addr, val) AO_or_full(addr, val) -# define AO_HAVE_or_acquire -# endif -# if !defined(AO_HAVE_or_write) -# define AO_or_write(addr, val) AO_or_full(addr, val) -# define AO_HAVE_or_write -# endif -# if !defined(AO_HAVE_or_read) -# define AO_or_read(addr, val) AO_or_full(addr, val) -# define AO_HAVE_or_read -# endif -#endif /* AO_HAVE_or_full */ - -#if !defined(AO_HAVE_or) && defined(AO_HAVE_or_release) -# define AO_or(addr, val) AO_or_release(addr, val) -# define AO_HAVE_or -#endif -#if !defined(AO_HAVE_or) && defined(AO_HAVE_or_acquire) -# define AO_or(addr, val) AO_or_acquire(addr, val) -# define AO_HAVE_or -#endif -#if !defined(AO_HAVE_or) && defined(AO_HAVE_or_write) -# define AO_or(addr, val) AO_or_write(addr, val) -# define AO_HAVE_or -#endif -#if !defined(AO_HAVE_or) && defined(AO_HAVE_or_read) -# define AO_or(addr, val) AO_or_read(addr, val) -# define AO_HAVE_or -#endif - -#if defined(AO_HAVE_or_acquire) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_or_full) -# define AO_or_full(addr, val) \ - (AO_nop_full(), AO_or_acquire(addr, val)) -# define AO_HAVE_or_full -#endif - -#if !defined(AO_HAVE_or_release_write) \ - && defined(AO_HAVE_or_write) -# define AO_or_release_write(addr, val) AO_or_write(addr, val) -# define AO_HAVE_or_release_write -#endif -#if !defined(AO_HAVE_or_release_write) \ - && defined(AO_HAVE_or_release) -# define AO_or_release_write(addr, val) AO_or_release(addr, val) -# define AO_HAVE_or_release_write -#endif -#if !defined(AO_HAVE_or_acquire_read) && defined(AO_HAVE_or_read) -# define AO_or_acquire_read(addr, val) AO_or_read(addr, val) -# define AO_HAVE_or_acquire_read -#endif -#if !defined(AO_HAVE_or_acquire_read) \ - && defined(AO_HAVE_or_acquire) -# define AO_or_acquire_read(addr, val) AO_or_acquire(addr, val) -# define AO_HAVE_or_acquire_read -#endif - -/* xor */ -#if defined(AO_HAVE_compare_and_swap_full) \ - && !defined(AO_HAVE_xor_full) - AO_INLINE void - AO_xor_full(volatile AO_t *addr, AO_t value) - { - AO_t old; - - do - { - old = *(AO_t *)addr; - } - while (AO_EXPECT_FALSE(!AO_compare_and_swap_full(addr, old, - old ^ value))); - } -# define AO_HAVE_xor_full -#endif - -#if defined(AO_HAVE_xor_full) -# if !defined(AO_HAVE_xor_release) -# define AO_xor_release(addr, val) AO_xor_full(addr, val) -# define AO_HAVE_xor_release -# endif -# if !defined(AO_HAVE_xor_acquire) -# define AO_xor_acquire(addr, val) AO_xor_full(addr, val) -# define AO_HAVE_xor_acquire -# endif -# if !defined(AO_HAVE_xor_write) -# define AO_xor_write(addr, val) AO_xor_full(addr, val) -# define AO_HAVE_xor_write -# endif -# if !defined(AO_HAVE_xor_read) -# define AO_xor_read(addr, val) AO_xor_full(addr, val) -# define AO_HAVE_xor_read -# endif -#endif /* AO_HAVE_xor_full */ - -#if !defined(AO_HAVE_xor) && defined(AO_HAVE_xor_release) -# define AO_xor(addr, val) AO_xor_release(addr, val) -# define AO_HAVE_xor -#endif -#if !defined(AO_HAVE_xor) && defined(AO_HAVE_xor_acquire) -# define AO_xor(addr, val) AO_xor_acquire(addr, val) -# define AO_HAVE_xor -#endif -#if !defined(AO_HAVE_xor) && defined(AO_HAVE_xor_write) -# define AO_xor(addr, val) AO_xor_write(addr, val) -# define AO_HAVE_xor -#endif -#if !defined(AO_HAVE_xor) && defined(AO_HAVE_xor_read) -# define AO_xor(addr, val) AO_xor_read(addr, val) -# define AO_HAVE_xor -#endif - -#if defined(AO_HAVE_xor_acquire) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_xor_full) -# define AO_xor_full(addr, val) \ - (AO_nop_full(), AO_xor_acquire(addr, val)) -# define AO_HAVE_xor_full -#endif - -#if !defined(AO_HAVE_xor_release_write) \ - && defined(AO_HAVE_xor_write) -# define AO_xor_release_write(addr, val) AO_xor_write(addr, val) -# define AO_HAVE_xor_release_write -#endif -#if !defined(AO_HAVE_xor_release_write) \ - && defined(AO_HAVE_xor_release) -# define AO_xor_release_write(addr, val) AO_xor_release(addr, val) -# define AO_HAVE_xor_release_write -#endif -#if !defined(AO_HAVE_xor_acquire_read) \ - && defined(AO_HAVE_xor_read) -# define AO_xor_acquire_read(addr, val) AO_xor_read(addr, val) -# define AO_HAVE_xor_acquire_read -#endif -#if !defined(AO_HAVE_xor_acquire_read) \ - && defined(AO_HAVE_xor_acquire) -# define AO_xor_acquire_read(addr, val) AO_xor_acquire(addr, val) -# define AO_HAVE_xor_acquire_read -#endif - -/* and/or/xor_dd_acquire_read are meaningless. */ diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/generalize-arithm.template ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/generalize-arithm.template --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/generalize-arithm.template 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/generalize-arithm.template 1970-01-01 00:00:00.000000000 +0000 @@ -1,845 +0,0 @@ -/* - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* XSIZE_compare_and_swap (based on fetch_compare_and_swap) */ -#if defined(AO_HAVE_XSIZE_fetch_compare_and_swap_full) \ - && !defined(AO_HAVE_XSIZE_compare_and_swap_full) - AO_INLINE int - AO_XSIZE_compare_and_swap_full(volatile XCTYPE *addr, XCTYPE old_val, - XCTYPE new_val) - { - return AO_XSIZE_fetch_compare_and_swap_full(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_XSIZE_compare_and_swap_full -#endif - -#if defined(AO_HAVE_XSIZE_fetch_compare_and_swap_acquire) \ - && !defined(AO_HAVE_XSIZE_compare_and_swap_acquire) - AO_INLINE int - AO_XSIZE_compare_and_swap_acquire(volatile XCTYPE *addr, XCTYPE old_val, - XCTYPE new_val) - { - return AO_XSIZE_fetch_compare_and_swap_acquire(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_XSIZE_compare_and_swap_acquire -#endif - -#if defined(AO_HAVE_XSIZE_fetch_compare_and_swap_release) \ - && !defined(AO_HAVE_XSIZE_compare_and_swap_release) - AO_INLINE int - AO_XSIZE_compare_and_swap_release(volatile XCTYPE *addr, XCTYPE old_val, - XCTYPE new_val) - { - return AO_XSIZE_fetch_compare_and_swap_release(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_XSIZE_compare_and_swap_release -#endif - -#if defined(AO_HAVE_XSIZE_fetch_compare_and_swap_write) \ - && !defined(AO_HAVE_XSIZE_compare_and_swap_write) - AO_INLINE int - AO_XSIZE_compare_and_swap_write(volatile XCTYPE *addr, XCTYPE old_val, - XCTYPE new_val) - { - return AO_XSIZE_fetch_compare_and_swap_write(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_XSIZE_compare_and_swap_write -#endif - -#if defined(AO_HAVE_XSIZE_fetch_compare_and_swap_read) \ - && !defined(AO_HAVE_XSIZE_compare_and_swap_read) - AO_INLINE int - AO_XSIZE_compare_and_swap_read(volatile XCTYPE *addr, XCTYPE old_val, - XCTYPE new_val) - { - return AO_XSIZE_fetch_compare_and_swap_read(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_XSIZE_compare_and_swap_read -#endif - -#if defined(AO_HAVE_XSIZE_fetch_compare_and_swap) \ - && !defined(AO_HAVE_XSIZE_compare_and_swap) - AO_INLINE int - AO_XSIZE_compare_and_swap(volatile XCTYPE *addr, XCTYPE old_val, - XCTYPE new_val) - { - return AO_XSIZE_fetch_compare_and_swap(addr, old_val, new_val) == old_val; - } -# define AO_HAVE_XSIZE_compare_and_swap -#endif - -#if defined(AO_HAVE_XSIZE_fetch_compare_and_swap_release_write) \ - && !defined(AO_HAVE_XSIZE_compare_and_swap_release_write) - AO_INLINE int - AO_XSIZE_compare_and_swap_release_write(volatile XCTYPE *addr, - XCTYPE old_val, XCTYPE new_val) - { - return AO_XSIZE_fetch_compare_and_swap_release_write(addr, old_val, - new_val) == old_val; - } -# define AO_HAVE_XSIZE_compare_and_swap_release_write -#endif - -#if defined(AO_HAVE_XSIZE_fetch_compare_and_swap_acquire_read) \ - && !defined(AO_HAVE_XSIZE_compare_and_swap_acquire_read) - AO_INLINE int - AO_XSIZE_compare_and_swap_acquire_read(volatile XCTYPE *addr, - XCTYPE old_val, XCTYPE new_val) - { - return AO_XSIZE_fetch_compare_and_swap_acquire_read(addr, old_val, - new_val) == old_val; - } -# define AO_HAVE_XSIZE_compare_and_swap_acquire_read -#endif - -#if defined(AO_HAVE_XSIZE_fetch_compare_and_swap_dd_acquire_read) \ - && !defined(AO_HAVE_XSIZE_compare_and_swap_dd_acquire_read) - AO_INLINE int - AO_XSIZE_compare_and_swap_dd_acquire_read(volatile XCTYPE *addr, - XCTYPE old_val, XCTYPE new_val) - { - return AO_XSIZE_fetch_compare_and_swap_dd_acquire_read(addr, old_val, - new_val) == old_val; - } -# define AO_HAVE_XSIZE_compare_and_swap_dd_acquire_read -#endif - -/* XSIZE_fetch_and_add */ -/* We first try to implement fetch_and_add variants in terms of the */ -/* corresponding compare_and_swap variants to minimize adding barriers. */ -#if defined(AO_HAVE_XSIZE_compare_and_swap_full) \ - && !defined(AO_HAVE_XSIZE_fetch_and_add_full) - AO_INLINE XCTYPE - AO_XSIZE_fetch_and_add_full(volatile XCTYPE *addr, XCTYPE incr) - { - XCTYPE old; - - do - { - old = *(XCTYPE *)addr; - } - while (AO_EXPECT_FALSE(!AO_XSIZE_compare_and_swap_full(addr, old, - old + incr))); - return old; - } -# define AO_HAVE_XSIZE_fetch_and_add_full -#endif - -#if defined(AO_HAVE_XSIZE_compare_and_swap_acquire) \ - && !defined(AO_HAVE_XSIZE_fetch_and_add_acquire) - AO_INLINE XCTYPE - AO_XSIZE_fetch_and_add_acquire(volatile XCTYPE *addr, XCTYPE incr) - { - XCTYPE old; - - do - { - old = *(XCTYPE *)addr; - } - while (AO_EXPECT_FALSE(!AO_XSIZE_compare_and_swap_acquire(addr, old, - old + incr))); - return old; - } -# define AO_HAVE_XSIZE_fetch_and_add_acquire -#endif - -#if defined(AO_HAVE_XSIZE_compare_and_swap_release) \ - && !defined(AO_HAVE_XSIZE_fetch_and_add_release) - AO_INLINE XCTYPE - AO_XSIZE_fetch_and_add_release(volatile XCTYPE *addr, XCTYPE incr) - { - XCTYPE old; - - do - { - old = *(XCTYPE *)addr; - } - while (AO_EXPECT_FALSE(!AO_XSIZE_compare_and_swap_release(addr, old, - old + incr))); - return old; - } -# define AO_HAVE_XSIZE_fetch_and_add_release -#endif - -#if defined(AO_HAVE_XSIZE_compare_and_swap) \ - && !defined(AO_HAVE_XSIZE_fetch_and_add) - AO_INLINE XCTYPE - AO_XSIZE_fetch_and_add(volatile XCTYPE *addr, XCTYPE incr) - { - XCTYPE old; - - do - { - old = *(XCTYPE *)addr; - } - while (AO_EXPECT_FALSE(!AO_XSIZE_compare_and_swap(addr, old, - old + incr))); - return old; - } -# define AO_HAVE_XSIZE_fetch_and_add -#endif - -#if defined(AO_HAVE_XSIZE_fetch_and_add_full) -# if !defined(AO_HAVE_XSIZE_fetch_and_add_release) -# define AO_XSIZE_fetch_and_add_release(addr, val) \ - AO_XSIZE_fetch_and_add_full(addr, val) -# define AO_HAVE_XSIZE_fetch_and_add_release -# endif -# if !defined(AO_HAVE_XSIZE_fetch_and_add_acquire) -# define AO_XSIZE_fetch_and_add_acquire(addr, val) \ - AO_XSIZE_fetch_and_add_full(addr, val) -# define AO_HAVE_XSIZE_fetch_and_add_acquire -# endif -# if !defined(AO_HAVE_XSIZE_fetch_and_add_write) -# define AO_XSIZE_fetch_and_add_write(addr, val) \ - AO_XSIZE_fetch_and_add_full(addr, val) -# define AO_HAVE_XSIZE_fetch_and_add_write -# endif -# if !defined(AO_HAVE_XSIZE_fetch_and_add_read) -# define AO_XSIZE_fetch_and_add_read(addr, val) \ - AO_XSIZE_fetch_and_add_full(addr, val) -# define AO_HAVE_XSIZE_fetch_and_add_read -# endif -#endif /* AO_HAVE_XSIZE_fetch_and_add_full */ - -#if defined(AO_HAVE_XSIZE_fetch_and_add) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_XSIZE_fetch_and_add_acquire) - AO_INLINE XCTYPE - AO_XSIZE_fetch_and_add_acquire(volatile XCTYPE *addr, XCTYPE incr) - { - XCTYPE result = AO_XSIZE_fetch_and_add(addr, incr); - AO_nop_full(); - return result; - } -# define AO_HAVE_XSIZE_fetch_and_add_acquire -#endif -#if defined(AO_HAVE_XSIZE_fetch_and_add) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_XSIZE_fetch_and_add_release) -# define AO_XSIZE_fetch_and_add_release(addr, incr) \ - (AO_nop_full(), AO_XSIZE_fetch_and_add(addr, incr)) -# define AO_HAVE_XSIZE_fetch_and_add_release -#endif - -#if !defined(AO_HAVE_XSIZE_fetch_and_add) \ - && defined(AO_HAVE_XSIZE_fetch_and_add_release) -# define AO_XSIZE_fetch_and_add(addr, val) \ - AO_XSIZE_fetch_and_add_release(addr, val) -# define AO_HAVE_XSIZE_fetch_and_add -#endif -#if !defined(AO_HAVE_XSIZE_fetch_and_add) \ - && defined(AO_HAVE_XSIZE_fetch_and_add_acquire) -# define AO_XSIZE_fetch_and_add(addr, val) \ - AO_XSIZE_fetch_and_add_acquire(addr, val) -# define AO_HAVE_XSIZE_fetch_and_add -#endif -#if !defined(AO_HAVE_XSIZE_fetch_and_add) \ - && defined(AO_HAVE_XSIZE_fetch_and_add_write) -# define AO_XSIZE_fetch_and_add(addr, val) \ - AO_XSIZE_fetch_and_add_write(addr, val) -# define AO_HAVE_XSIZE_fetch_and_add -#endif -#if !defined(AO_HAVE_XSIZE_fetch_and_add) \ - && defined(AO_HAVE_XSIZE_fetch_and_add_read) -# define AO_XSIZE_fetch_and_add(addr, val) \ - AO_XSIZE_fetch_and_add_read(addr, val) -# define AO_HAVE_XSIZE_fetch_and_add -#endif - -#if defined(AO_HAVE_XSIZE_fetch_and_add_acquire) \ - && defined(AO_HAVE_nop_full) && !defined(AO_HAVE_XSIZE_fetch_and_add_full) -# define AO_XSIZE_fetch_and_add_full(addr, val) \ - (AO_nop_full(), AO_XSIZE_fetch_and_add_acquire(addr, val)) -# define AO_HAVE_XSIZE_fetch_and_add_full -#endif - -#if !defined(AO_HAVE_XSIZE_fetch_and_add_release_write) \ - && defined(AO_HAVE_XSIZE_fetch_and_add_write) -# define AO_XSIZE_fetch_and_add_release_write(addr, val) \ - AO_XSIZE_fetch_and_add_write(addr, val) -# define AO_HAVE_XSIZE_fetch_and_add_release_write -#endif -#if !defined(AO_HAVE_XSIZE_fetch_and_add_release_write) \ - && defined(AO_HAVE_XSIZE_fetch_and_add_release) -# define AO_XSIZE_fetch_and_add_release_write(addr, val) \ - AO_XSIZE_fetch_and_add_release(addr, val) -# define AO_HAVE_XSIZE_fetch_and_add_release_write -#endif - -#if !defined(AO_HAVE_XSIZE_fetch_and_add_acquire_read) \ - && defined(AO_HAVE_XSIZE_fetch_and_add_read) -# define AO_XSIZE_fetch_and_add_acquire_read(addr, val) \ - AO_XSIZE_fetch_and_add_read(addr, val) -# define AO_HAVE_XSIZE_fetch_and_add_acquire_read -#endif -#if !defined(AO_HAVE_XSIZE_fetch_and_add_acquire_read) \ - && defined(AO_HAVE_XSIZE_fetch_and_add_acquire) -# define AO_XSIZE_fetch_and_add_acquire_read(addr, val) \ - AO_XSIZE_fetch_and_add_acquire(addr, val) -# define AO_HAVE_XSIZE_fetch_and_add_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_XSIZE_fetch_and_add_acquire_read) -# define AO_XSIZE_fetch_and_add_dd_acquire_read(addr, val) \ - AO_XSIZE_fetch_and_add_acquire_read(addr, val) -# define AO_HAVE_XSIZE_fetch_and_add_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_XSIZE_fetch_and_add) -# define AO_XSIZE_fetch_and_add_dd_acquire_read(addr, val) \ - AO_XSIZE_fetch_and_add(addr, val) -# define AO_HAVE_XSIZE_fetch_and_add_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* XSIZE_fetch_and_add1 */ -#if defined(AO_HAVE_XSIZE_fetch_and_add_full) \ - && !defined(AO_HAVE_XSIZE_fetch_and_add1_full) -# define AO_XSIZE_fetch_and_add1_full(addr) \ - AO_XSIZE_fetch_and_add_full(addr, 1) -# define AO_HAVE_XSIZE_fetch_and_add1_full -#endif -#if defined(AO_HAVE_XSIZE_fetch_and_add_release) \ - && !defined(AO_HAVE_XSIZE_fetch_and_add1_release) -# define AO_XSIZE_fetch_and_add1_release(addr) \ - AO_XSIZE_fetch_and_add_release(addr, 1) -# define AO_HAVE_XSIZE_fetch_and_add1_release -#endif -#if defined(AO_HAVE_XSIZE_fetch_and_add_acquire) \ - && !defined(AO_HAVE_XSIZE_fetch_and_add1_acquire) -# define AO_XSIZE_fetch_and_add1_acquire(addr) \ - AO_XSIZE_fetch_and_add_acquire(addr, 1) -# define AO_HAVE_XSIZE_fetch_and_add1_acquire -#endif -#if defined(AO_HAVE_XSIZE_fetch_and_add_write) \ - && !defined(AO_HAVE_XSIZE_fetch_and_add1_write) -# define AO_XSIZE_fetch_and_add1_write(addr) \ - AO_XSIZE_fetch_and_add_write(addr, 1) -# define AO_HAVE_XSIZE_fetch_and_add1_write -#endif -#if defined(AO_HAVE_XSIZE_fetch_and_add_read) \ - && !defined(AO_HAVE_XSIZE_fetch_and_add1_read) -# define AO_XSIZE_fetch_and_add1_read(addr) \ - AO_XSIZE_fetch_and_add_read(addr, 1) -# define AO_HAVE_XSIZE_fetch_and_add1_read -#endif -#if defined(AO_HAVE_XSIZE_fetch_and_add_release_write) \ - && !defined(AO_HAVE_XSIZE_fetch_and_add1_release_write) -# define AO_XSIZE_fetch_and_add1_release_write(addr) \ - AO_XSIZE_fetch_and_add_release_write(addr, 1) -# define AO_HAVE_XSIZE_fetch_and_add1_release_write -#endif -#if defined(AO_HAVE_XSIZE_fetch_and_add_acquire_read) \ - && !defined(AO_HAVE_XSIZE_fetch_and_add1_acquire_read) -# define AO_XSIZE_fetch_and_add1_acquire_read(addr) \ - AO_XSIZE_fetch_and_add_acquire_read(addr, 1) -# define AO_HAVE_XSIZE_fetch_and_add1_acquire_read -#endif -#if defined(AO_HAVE_XSIZE_fetch_and_add) \ - && !defined(AO_HAVE_XSIZE_fetch_and_add1) -# define AO_XSIZE_fetch_and_add1(addr) AO_XSIZE_fetch_and_add(addr, 1) -# define AO_HAVE_XSIZE_fetch_and_add1 -#endif - -#if defined(AO_HAVE_XSIZE_fetch_and_add1_full) -# if !defined(AO_HAVE_XSIZE_fetch_and_add1_release) -# define AO_XSIZE_fetch_and_add1_release(addr) \ - AO_XSIZE_fetch_and_add1_full(addr) -# define AO_HAVE_XSIZE_fetch_and_add1_release -# endif -# if !defined(AO_HAVE_XSIZE_fetch_and_add1_acquire) -# define AO_XSIZE_fetch_and_add1_acquire(addr) \ - AO_XSIZE_fetch_and_add1_full(addr) -# define AO_HAVE_XSIZE_fetch_and_add1_acquire -# endif -# if !defined(AO_HAVE_XSIZE_fetch_and_add1_write) -# define AO_XSIZE_fetch_and_add1_write(addr) \ - AO_XSIZE_fetch_and_add1_full(addr) -# define AO_HAVE_XSIZE_fetch_and_add1_write -# endif -# if !defined(AO_HAVE_XSIZE_fetch_and_add1_read) -# define AO_XSIZE_fetch_and_add1_read(addr) \ - AO_XSIZE_fetch_and_add1_full(addr) -# define AO_HAVE_XSIZE_fetch_and_add1_read -# endif -#endif /* AO_HAVE_XSIZE_fetch_and_add1_full */ - -#if !defined(AO_HAVE_XSIZE_fetch_and_add1) \ - && defined(AO_HAVE_XSIZE_fetch_and_add1_release) -# define AO_XSIZE_fetch_and_add1(addr) AO_XSIZE_fetch_and_add1_release(addr) -# define AO_HAVE_XSIZE_fetch_and_add1 -#endif -#if !defined(AO_HAVE_XSIZE_fetch_and_add1) \ - && defined(AO_HAVE_XSIZE_fetch_and_add1_acquire) -# define AO_XSIZE_fetch_and_add1(addr) AO_XSIZE_fetch_and_add1_acquire(addr) -# define AO_HAVE_XSIZE_fetch_and_add1 -#endif -#if !defined(AO_HAVE_XSIZE_fetch_and_add1) \ - && defined(AO_HAVE_XSIZE_fetch_and_add1_write) -# define AO_XSIZE_fetch_and_add1(addr) AO_XSIZE_fetch_and_add1_write(addr) -# define AO_HAVE_XSIZE_fetch_and_add1 -#endif -#if !defined(AO_HAVE_XSIZE_fetch_and_add1) \ - && defined(AO_HAVE_XSIZE_fetch_and_add1_read) -# define AO_XSIZE_fetch_and_add1(addr) AO_XSIZE_fetch_and_add1_read(addr) -# define AO_HAVE_XSIZE_fetch_and_add1 -#endif - -#if defined(AO_HAVE_XSIZE_fetch_and_add1_acquire) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_XSIZE_fetch_and_add1_full) -# define AO_XSIZE_fetch_and_add1_full(addr) \ - (AO_nop_full(), AO_XSIZE_fetch_and_add1_acquire(addr)) -# define AO_HAVE_XSIZE_fetch_and_add1_full -#endif - -#if !defined(AO_HAVE_XSIZE_fetch_and_add1_release_write) \ - && defined(AO_HAVE_XSIZE_fetch_and_add1_write) -# define AO_XSIZE_fetch_and_add1_release_write(addr) \ - AO_XSIZE_fetch_and_add1_write(addr) -# define AO_HAVE_XSIZE_fetch_and_add1_release_write -#endif -#if !defined(AO_HAVE_XSIZE_fetch_and_add1_release_write) \ - && defined(AO_HAVE_XSIZE_fetch_and_add1_release) -# define AO_XSIZE_fetch_and_add1_release_write(addr) \ - AO_XSIZE_fetch_and_add1_release(addr) -# define AO_HAVE_XSIZE_fetch_and_add1_release_write -#endif -#if !defined(AO_HAVE_XSIZE_fetch_and_add1_acquire_read) \ - && defined(AO_HAVE_XSIZE_fetch_and_add1_read) -# define AO_XSIZE_fetch_and_add1_acquire_read(addr) \ - AO_XSIZE_fetch_and_add1_read(addr) -# define AO_HAVE_XSIZE_fetch_and_add1_acquire_read -#endif -#if !defined(AO_HAVE_XSIZE_fetch_and_add1_acquire_read) \ - && defined(AO_HAVE_XSIZE_fetch_and_add1_acquire) -# define AO_XSIZE_fetch_and_add1_acquire_read(addr) \ - AO_XSIZE_fetch_and_add1_acquire(addr) -# define AO_HAVE_XSIZE_fetch_and_add1_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_XSIZE_fetch_and_add1_acquire_read) -# define AO_XSIZE_fetch_and_add1_dd_acquire_read(addr) \ - AO_XSIZE_fetch_and_add1_acquire_read(addr) -# define AO_HAVE_XSIZE_fetch_and_add1_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_XSIZE_fetch_and_add1) -# define AO_XSIZE_fetch_and_add1_dd_acquire_read(addr) \ - AO_XSIZE_fetch_and_add1(addr) -# define AO_HAVE_XSIZE_fetch_and_add1_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* XSIZE_fetch_and_sub1 */ -#if defined(AO_HAVE_XSIZE_fetch_and_add_full) \ - && !defined(AO_HAVE_XSIZE_fetch_and_sub1_full) -# define AO_XSIZE_fetch_and_sub1_full(addr) \ - AO_XSIZE_fetch_and_add_full(addr, (XCTYPE)(-1)) -# define AO_HAVE_XSIZE_fetch_and_sub1_full -#endif -#if defined(AO_HAVE_XSIZE_fetch_and_add_release) \ - && !defined(AO_HAVE_XSIZE_fetch_and_sub1_release) -# define AO_XSIZE_fetch_and_sub1_release(addr) \ - AO_XSIZE_fetch_and_add_release(addr, (XCTYPE)(-1)) -# define AO_HAVE_XSIZE_fetch_and_sub1_release -#endif -#if defined(AO_HAVE_XSIZE_fetch_and_add_acquire) \ - && !defined(AO_HAVE_XSIZE_fetch_and_sub1_acquire) -# define AO_XSIZE_fetch_and_sub1_acquire(addr) \ - AO_XSIZE_fetch_and_add_acquire(addr, (XCTYPE)(-1)) -# define AO_HAVE_XSIZE_fetch_and_sub1_acquire -#endif -#if defined(AO_HAVE_XSIZE_fetch_and_add_write) \ - && !defined(AO_HAVE_XSIZE_fetch_and_sub1_write) -# define AO_XSIZE_fetch_and_sub1_write(addr) \ - AO_XSIZE_fetch_and_add_write(addr, (XCTYPE)(-1)) -# define AO_HAVE_XSIZE_fetch_and_sub1_write -#endif -#if defined(AO_HAVE_XSIZE_fetch_and_add_read) \ - && !defined(AO_HAVE_XSIZE_fetch_and_sub1_read) -# define AO_XSIZE_fetch_and_sub1_read(addr) \ - AO_XSIZE_fetch_and_add_read(addr, (XCTYPE)(-1)) -# define AO_HAVE_XSIZE_fetch_and_sub1_read -#endif -#if defined(AO_HAVE_XSIZE_fetch_and_add_release_write) \ - && !defined(AO_HAVE_XSIZE_fetch_and_sub1_release_write) -# define AO_XSIZE_fetch_and_sub1_release_write(addr) \ - AO_XSIZE_fetch_and_add_release_write(addr, (XCTYPE)(-1)) -# define AO_HAVE_XSIZE_fetch_and_sub1_release_write -#endif -#if defined(AO_HAVE_XSIZE_fetch_and_add_acquire_read) \ - && !defined(AO_HAVE_XSIZE_fetch_and_sub1_acquire_read) -# define AO_XSIZE_fetch_and_sub1_acquire_read(addr) \ - AO_XSIZE_fetch_and_add_acquire_read(addr, (XCTYPE)(-1)) -# define AO_HAVE_XSIZE_fetch_and_sub1_acquire_read -#endif -#if defined(AO_HAVE_XSIZE_fetch_and_add) \ - && !defined(AO_HAVE_XSIZE_fetch_and_sub1) -# define AO_XSIZE_fetch_and_sub1(addr) \ - AO_XSIZE_fetch_and_add(addr, (XCTYPE)(-1)) -# define AO_HAVE_XSIZE_fetch_and_sub1 -#endif - -#if defined(AO_HAVE_XSIZE_fetch_and_sub1_full) -# if !defined(AO_HAVE_XSIZE_fetch_and_sub1_release) -# define AO_XSIZE_fetch_and_sub1_release(addr) \ - AO_XSIZE_fetch_and_sub1_full(addr) -# define AO_HAVE_XSIZE_fetch_and_sub1_release -# endif -# if !defined(AO_HAVE_XSIZE_fetch_and_sub1_acquire) -# define AO_XSIZE_fetch_and_sub1_acquire(addr) \ - AO_XSIZE_fetch_and_sub1_full(addr) -# define AO_HAVE_XSIZE_fetch_and_sub1_acquire -# endif -# if !defined(AO_HAVE_XSIZE_fetch_and_sub1_write) -# define AO_XSIZE_fetch_and_sub1_write(addr) \ - AO_XSIZE_fetch_and_sub1_full(addr) -# define AO_HAVE_XSIZE_fetch_and_sub1_write -# endif -# if !defined(AO_HAVE_XSIZE_fetch_and_sub1_read) -# define AO_XSIZE_fetch_and_sub1_read(addr) \ - AO_XSIZE_fetch_and_sub1_full(addr) -# define AO_HAVE_XSIZE_fetch_and_sub1_read -# endif -#endif /* AO_HAVE_XSIZE_fetch_and_sub1_full */ - -#if !defined(AO_HAVE_XSIZE_fetch_and_sub1) \ - && defined(AO_HAVE_XSIZE_fetch_and_sub1_release) -# define AO_XSIZE_fetch_and_sub1(addr) AO_XSIZE_fetch_and_sub1_release(addr) -# define AO_HAVE_XSIZE_fetch_and_sub1 -#endif -#if !defined(AO_HAVE_XSIZE_fetch_and_sub1) \ - && defined(AO_HAVE_XSIZE_fetch_and_sub1_acquire) -# define AO_XSIZE_fetch_and_sub1(addr) AO_XSIZE_fetch_and_sub1_acquire(addr) -# define AO_HAVE_XSIZE_fetch_and_sub1 -#endif -#if !defined(AO_HAVE_XSIZE_fetch_and_sub1) \ - && defined(AO_HAVE_XSIZE_fetch_and_sub1_write) -# define AO_XSIZE_fetch_and_sub1(addr) AO_XSIZE_fetch_and_sub1_write(addr) -# define AO_HAVE_XSIZE_fetch_and_sub1 -#endif -#if !defined(AO_HAVE_XSIZE_fetch_and_sub1) \ - && defined(AO_HAVE_XSIZE_fetch_and_sub1_read) -# define AO_XSIZE_fetch_and_sub1(addr) AO_XSIZE_fetch_and_sub1_read(addr) -# define AO_HAVE_XSIZE_fetch_and_sub1 -#endif - -#if defined(AO_HAVE_XSIZE_fetch_and_sub1_acquire) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_XSIZE_fetch_and_sub1_full) -# define AO_XSIZE_fetch_and_sub1_full(addr) \ - (AO_nop_full(), AO_XSIZE_fetch_and_sub1_acquire(addr)) -# define AO_HAVE_XSIZE_fetch_and_sub1_full -#endif - -#if !defined(AO_HAVE_XSIZE_fetch_and_sub1_release_write) \ - && defined(AO_HAVE_XSIZE_fetch_and_sub1_write) -# define AO_XSIZE_fetch_and_sub1_release_write(addr) \ - AO_XSIZE_fetch_and_sub1_write(addr) -# define AO_HAVE_XSIZE_fetch_and_sub1_release_write -#endif -#if !defined(AO_HAVE_XSIZE_fetch_and_sub1_release_write) \ - && defined(AO_HAVE_XSIZE_fetch_and_sub1_release) -# define AO_XSIZE_fetch_and_sub1_release_write(addr) \ - AO_XSIZE_fetch_and_sub1_release(addr) -# define AO_HAVE_XSIZE_fetch_and_sub1_release_write -#endif -#if !defined(AO_HAVE_XSIZE_fetch_and_sub1_acquire_read) \ - && defined(AO_HAVE_XSIZE_fetch_and_sub1_read) -# define AO_XSIZE_fetch_and_sub1_acquire_read(addr) \ - AO_XSIZE_fetch_and_sub1_read(addr) -# define AO_HAVE_XSIZE_fetch_and_sub1_acquire_read -#endif -#if !defined(AO_HAVE_XSIZE_fetch_and_sub1_acquire_read) \ - && defined(AO_HAVE_XSIZE_fetch_and_sub1_acquire) -# define AO_XSIZE_fetch_and_sub1_acquire_read(addr) \ - AO_XSIZE_fetch_and_sub1_acquire(addr) -# define AO_HAVE_XSIZE_fetch_and_sub1_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_XSIZE_fetch_and_sub1_acquire_read) -# define AO_XSIZE_fetch_and_sub1_dd_acquire_read(addr) \ - AO_XSIZE_fetch_and_sub1_acquire_read(addr) -# define AO_HAVE_XSIZE_fetch_and_sub1_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_XSIZE_fetch_and_sub1) -# define AO_XSIZE_fetch_and_sub1_dd_acquire_read(addr) \ - AO_XSIZE_fetch_and_sub1(addr) -# define AO_HAVE_XSIZE_fetch_and_sub1_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* XSIZE_and */ -#if defined(AO_HAVE_XSIZE_compare_and_swap_full) \ - && !defined(AO_HAVE_XSIZE_and_full) - AO_INLINE void - AO_XSIZE_and_full(volatile XCTYPE *addr, XCTYPE value) - { - XCTYPE old; - - do - { - old = *(XCTYPE *)addr; - } - while (AO_EXPECT_FALSE(!AO_XSIZE_compare_and_swap_full(addr, old, - old & value))); - } -# define AO_HAVE_XSIZE_and_full -#endif - -#if defined(AO_HAVE_XSIZE_and_full) -# if !defined(AO_HAVE_XSIZE_and_release) -# define AO_XSIZE_and_release(addr, val) AO_XSIZE_and_full(addr, val) -# define AO_HAVE_XSIZE_and_release -# endif -# if !defined(AO_HAVE_XSIZE_and_acquire) -# define AO_XSIZE_and_acquire(addr, val) AO_XSIZE_and_full(addr, val) -# define AO_HAVE_XSIZE_and_acquire -# endif -# if !defined(AO_HAVE_XSIZE_and_write) -# define AO_XSIZE_and_write(addr, val) AO_XSIZE_and_full(addr, val) -# define AO_HAVE_XSIZE_and_write -# endif -# if !defined(AO_HAVE_XSIZE_and_read) -# define AO_XSIZE_and_read(addr, val) AO_XSIZE_and_full(addr, val) -# define AO_HAVE_XSIZE_and_read -# endif -#endif /* AO_HAVE_XSIZE_and_full */ - -#if !defined(AO_HAVE_XSIZE_and) && defined(AO_HAVE_XSIZE_and_release) -# define AO_XSIZE_and(addr, val) AO_XSIZE_and_release(addr, val) -# define AO_HAVE_XSIZE_and -#endif -#if !defined(AO_HAVE_XSIZE_and) && defined(AO_HAVE_XSIZE_and_acquire) -# define AO_XSIZE_and(addr, val) AO_XSIZE_and_acquire(addr, val) -# define AO_HAVE_XSIZE_and -#endif -#if !defined(AO_HAVE_XSIZE_and) && defined(AO_HAVE_XSIZE_and_write) -# define AO_XSIZE_and(addr, val) AO_XSIZE_and_write(addr, val) -# define AO_HAVE_XSIZE_and -#endif -#if !defined(AO_HAVE_XSIZE_and) && defined(AO_HAVE_XSIZE_and_read) -# define AO_XSIZE_and(addr, val) AO_XSIZE_and_read(addr, val) -# define AO_HAVE_XSIZE_and -#endif - -#if defined(AO_HAVE_XSIZE_and_acquire) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_XSIZE_and_full) -# define AO_XSIZE_and_full(addr, val) \ - (AO_nop_full(), AO_XSIZE_and_acquire(addr, val)) -# define AO_HAVE_XSIZE_and_full -#endif - -#if !defined(AO_HAVE_XSIZE_and_release_write) \ - && defined(AO_HAVE_XSIZE_and_write) -# define AO_XSIZE_and_release_write(addr, val) AO_XSIZE_and_write(addr, val) -# define AO_HAVE_XSIZE_and_release_write -#endif -#if !defined(AO_HAVE_XSIZE_and_release_write) \ - && defined(AO_HAVE_XSIZE_and_release) -# define AO_XSIZE_and_release_write(addr, val) AO_XSIZE_and_release(addr, val) -# define AO_HAVE_XSIZE_and_release_write -#endif -#if !defined(AO_HAVE_XSIZE_and_acquire_read) \ - && defined(AO_HAVE_XSIZE_and_read) -# define AO_XSIZE_and_acquire_read(addr, val) AO_XSIZE_and_read(addr, val) -# define AO_HAVE_XSIZE_and_acquire_read -#endif -#if !defined(AO_HAVE_XSIZE_and_acquire_read) \ - && defined(AO_HAVE_XSIZE_and_acquire) -# define AO_XSIZE_and_acquire_read(addr, val) AO_XSIZE_and_acquire(addr, val) -# define AO_HAVE_XSIZE_and_acquire_read -#endif - -/* XSIZE_or */ -#if defined(AO_HAVE_XSIZE_compare_and_swap_full) \ - && !defined(AO_HAVE_XSIZE_or_full) - AO_INLINE void - AO_XSIZE_or_full(volatile XCTYPE *addr, XCTYPE value) - { - XCTYPE old; - - do - { - old = *(XCTYPE *)addr; - } - while (AO_EXPECT_FALSE(!AO_XSIZE_compare_and_swap_full(addr, old, - old | value))); - } -# define AO_HAVE_XSIZE_or_full -#endif - -#if defined(AO_HAVE_XSIZE_or_full) -# if !defined(AO_HAVE_XSIZE_or_release) -# define AO_XSIZE_or_release(addr, val) AO_XSIZE_or_full(addr, val) -# define AO_HAVE_XSIZE_or_release -# endif -# if !defined(AO_HAVE_XSIZE_or_acquire) -# define AO_XSIZE_or_acquire(addr, val) AO_XSIZE_or_full(addr, val) -# define AO_HAVE_XSIZE_or_acquire -# endif -# if !defined(AO_HAVE_XSIZE_or_write) -# define AO_XSIZE_or_write(addr, val) AO_XSIZE_or_full(addr, val) -# define AO_HAVE_XSIZE_or_write -# endif -# if !defined(AO_HAVE_XSIZE_or_read) -# define AO_XSIZE_or_read(addr, val) AO_XSIZE_or_full(addr, val) -# define AO_HAVE_XSIZE_or_read -# endif -#endif /* AO_HAVE_XSIZE_or_full */ - -#if !defined(AO_HAVE_XSIZE_or) && defined(AO_HAVE_XSIZE_or_release) -# define AO_XSIZE_or(addr, val) AO_XSIZE_or_release(addr, val) -# define AO_HAVE_XSIZE_or -#endif -#if !defined(AO_HAVE_XSIZE_or) && defined(AO_HAVE_XSIZE_or_acquire) -# define AO_XSIZE_or(addr, val) AO_XSIZE_or_acquire(addr, val) -# define AO_HAVE_XSIZE_or -#endif -#if !defined(AO_HAVE_XSIZE_or) && defined(AO_HAVE_XSIZE_or_write) -# define AO_XSIZE_or(addr, val) AO_XSIZE_or_write(addr, val) -# define AO_HAVE_XSIZE_or -#endif -#if !defined(AO_HAVE_XSIZE_or) && defined(AO_HAVE_XSIZE_or_read) -# define AO_XSIZE_or(addr, val) AO_XSIZE_or_read(addr, val) -# define AO_HAVE_XSIZE_or -#endif - -#if defined(AO_HAVE_XSIZE_or_acquire) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_XSIZE_or_full) -# define AO_XSIZE_or_full(addr, val) \ - (AO_nop_full(), AO_XSIZE_or_acquire(addr, val)) -# define AO_HAVE_XSIZE_or_full -#endif - -#if !defined(AO_HAVE_XSIZE_or_release_write) \ - && defined(AO_HAVE_XSIZE_or_write) -# define AO_XSIZE_or_release_write(addr, val) AO_XSIZE_or_write(addr, val) -# define AO_HAVE_XSIZE_or_release_write -#endif -#if !defined(AO_HAVE_XSIZE_or_release_write) \ - && defined(AO_HAVE_XSIZE_or_release) -# define AO_XSIZE_or_release_write(addr, val) AO_XSIZE_or_release(addr, val) -# define AO_HAVE_XSIZE_or_release_write -#endif -#if !defined(AO_HAVE_XSIZE_or_acquire_read) && defined(AO_HAVE_XSIZE_or_read) -# define AO_XSIZE_or_acquire_read(addr, val) AO_XSIZE_or_read(addr, val) -# define AO_HAVE_XSIZE_or_acquire_read -#endif -#if !defined(AO_HAVE_XSIZE_or_acquire_read) \ - && defined(AO_HAVE_XSIZE_or_acquire) -# define AO_XSIZE_or_acquire_read(addr, val) AO_XSIZE_or_acquire(addr, val) -# define AO_HAVE_XSIZE_or_acquire_read -#endif - -/* XSIZE_xor */ -#if defined(AO_HAVE_XSIZE_compare_and_swap_full) \ - && !defined(AO_HAVE_XSIZE_xor_full) - AO_INLINE void - AO_XSIZE_xor_full(volatile XCTYPE *addr, XCTYPE value) - { - XCTYPE old; - - do - { - old = *(XCTYPE *)addr; - } - while (AO_EXPECT_FALSE(!AO_XSIZE_compare_and_swap_full(addr, old, - old ^ value))); - } -# define AO_HAVE_XSIZE_xor_full -#endif - -#if defined(AO_HAVE_XSIZE_xor_full) -# if !defined(AO_HAVE_XSIZE_xor_release) -# define AO_XSIZE_xor_release(addr, val) AO_XSIZE_xor_full(addr, val) -# define AO_HAVE_XSIZE_xor_release -# endif -# if !defined(AO_HAVE_XSIZE_xor_acquire) -# define AO_XSIZE_xor_acquire(addr, val) AO_XSIZE_xor_full(addr, val) -# define AO_HAVE_XSIZE_xor_acquire -# endif -# if !defined(AO_HAVE_XSIZE_xor_write) -# define AO_XSIZE_xor_write(addr, val) AO_XSIZE_xor_full(addr, val) -# define AO_HAVE_XSIZE_xor_write -# endif -# if !defined(AO_HAVE_XSIZE_xor_read) -# define AO_XSIZE_xor_read(addr, val) AO_XSIZE_xor_full(addr, val) -# define AO_HAVE_XSIZE_xor_read -# endif -#endif /* AO_HAVE_XSIZE_xor_full */ - -#if !defined(AO_HAVE_XSIZE_xor) && defined(AO_HAVE_XSIZE_xor_release) -# define AO_XSIZE_xor(addr, val) AO_XSIZE_xor_release(addr, val) -# define AO_HAVE_XSIZE_xor -#endif -#if !defined(AO_HAVE_XSIZE_xor) && defined(AO_HAVE_XSIZE_xor_acquire) -# define AO_XSIZE_xor(addr, val) AO_XSIZE_xor_acquire(addr, val) -# define AO_HAVE_XSIZE_xor -#endif -#if !defined(AO_HAVE_XSIZE_xor) && defined(AO_HAVE_XSIZE_xor_write) -# define AO_XSIZE_xor(addr, val) AO_XSIZE_xor_write(addr, val) -# define AO_HAVE_XSIZE_xor -#endif -#if !defined(AO_HAVE_XSIZE_xor) && defined(AO_HAVE_XSIZE_xor_read) -# define AO_XSIZE_xor(addr, val) AO_XSIZE_xor_read(addr, val) -# define AO_HAVE_XSIZE_xor -#endif - -#if defined(AO_HAVE_XSIZE_xor_acquire) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_XSIZE_xor_full) -# define AO_XSIZE_xor_full(addr, val) \ - (AO_nop_full(), AO_XSIZE_xor_acquire(addr, val)) -# define AO_HAVE_XSIZE_xor_full -#endif - -#if !defined(AO_HAVE_XSIZE_xor_release_write) \ - && defined(AO_HAVE_XSIZE_xor_write) -# define AO_XSIZE_xor_release_write(addr, val) AO_XSIZE_xor_write(addr, val) -# define AO_HAVE_XSIZE_xor_release_write -#endif -#if !defined(AO_HAVE_XSIZE_xor_release_write) \ - && defined(AO_HAVE_XSIZE_xor_release) -# define AO_XSIZE_xor_release_write(addr, val) AO_XSIZE_xor_release(addr, val) -# define AO_HAVE_XSIZE_xor_release_write -#endif -#if !defined(AO_HAVE_XSIZE_xor_acquire_read) \ - && defined(AO_HAVE_XSIZE_xor_read) -# define AO_XSIZE_xor_acquire_read(addr, val) AO_XSIZE_xor_read(addr, val) -# define AO_HAVE_XSIZE_xor_acquire_read -#endif -#if !defined(AO_HAVE_XSIZE_xor_acquire_read) \ - && defined(AO_HAVE_XSIZE_xor_acquire) -# define AO_XSIZE_xor_acquire_read(addr, val) AO_XSIZE_xor_acquire(addr, val) -# define AO_HAVE_XSIZE_xor_acquire_read -#endif - -/* XSIZE_and/or/xor_dd_acquire_read are meaningless. */ diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/generalize.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/generalize.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/generalize.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/generalize.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,676 +0,0 @@ -/* - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* - * Generalize atomic operations for atomic_ops.h. - * Should not be included directly. - * - * We make no attempt to define useless operations, such as - * AO_nop_acquire - * AO_nop_release - * - * We have also so far neglected to define some others, which - * do not appear likely to be useful, e.g. stores with acquire - * or read barriers. - * - * This file is sometimes included twice by atomic_ops.h. - * All definitions include explicit checks that we are not replacing - * an earlier definition. In general, more desirable expansions - * appear earlier so that we are more likely to use them. - * - * We only make safe generalizations, except that by default we define - * the ...dd_acquire_read operations to be equivalent to those without - * a barrier. On platforms for which this is unsafe, the platform-specific - * file must define AO_NO_DD_ORDERING. - */ - -#ifndef AO_ATOMIC_OPS_H -# error This file should not be included directly. -#endif - -/* Generate test_and_set_full, if necessary and possible. */ -#if !defined(AO_HAVE_test_and_set) && !defined(AO_HAVE_test_and_set_release) \ - && !defined(AO_HAVE_test_and_set_acquire) \ - && !defined(AO_HAVE_test_and_set_read) \ - && !defined(AO_HAVE_test_and_set_full) - - /* Emulate AO_compare_and_swap() via AO_fetch_compare_and_swap(). */ -# if defined(AO_HAVE_fetch_compare_and_swap) \ - && !defined(AO_HAVE_compare_and_swap) - AO_INLINE int - AO_compare_and_swap(volatile AO_t *addr, AO_t old_val, AO_t new_val) - { - return AO_fetch_compare_and_swap(addr, old_val, new_val) == old_val; - } -# define AO_HAVE_compare_and_swap -# endif - -# if defined(AO_HAVE_fetch_compare_and_swap_full) \ - && !defined(AO_HAVE_compare_and_swap_full) - AO_INLINE int - AO_compare_and_swap_full(volatile AO_t *addr, AO_t old_val, AO_t new_val) - { - return AO_fetch_compare_and_swap_full(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_compare_and_swap_full -# endif - -# if defined(AO_HAVE_fetch_compare_and_swap_acquire) \ - && !defined(AO_HAVE_compare_and_swap_acquire) - AO_INLINE int - AO_compare_and_swap_acquire(volatile AO_t *addr, AO_t old_val, - AO_t new_val) - { - return AO_fetch_compare_and_swap_acquire(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_compare_and_swap_acquire -# endif - -# if defined(AO_HAVE_fetch_compare_and_swap_release) \ - && !defined(AO_HAVE_compare_and_swap_release) - AO_INLINE int - AO_compare_and_swap_release(volatile AO_t *addr, AO_t old_val, - AO_t new_val) - { - return AO_fetch_compare_and_swap_release(addr, old_val, new_val) - == old_val; - } -# define AO_HAVE_compare_and_swap_release -# endif - -# if AO_CHAR_TS_T -# define AO_TS_COMPARE_AND_SWAP_FULL(a,o,n) \ - AO_char_compare_and_swap_full(a,o,n) -# define AO_TS_COMPARE_AND_SWAP_ACQUIRE(a,o,n) \ - AO_char_compare_and_swap_acquire(a,o,n) -# define AO_TS_COMPARE_AND_SWAP_RELEASE(a,o,n) \ - AO_char_compare_and_swap_release(a,o,n) -# define AO_TS_COMPARE_AND_SWAP(a,o,n) AO_char_compare_and_swap(a,o,n) -# endif - -# if AO_AO_TS_T -# define AO_TS_COMPARE_AND_SWAP_FULL(a,o,n) AO_compare_and_swap_full(a,o,n) -# define AO_TS_COMPARE_AND_SWAP_ACQUIRE(a,o,n) \ - AO_compare_and_swap_acquire(a,o,n) -# define AO_TS_COMPARE_AND_SWAP_RELEASE(a,o,n) \ - AO_compare_and_swap_release(a,o,n) -# define AO_TS_COMPARE_AND_SWAP(a,o,n) AO_compare_and_swap(a,o,n) -# endif - -# if (AO_AO_TS_T && defined(AO_HAVE_compare_and_swap_full)) \ - || (AO_CHAR_TS_T && defined(AO_HAVE_char_compare_and_swap_full)) - AO_INLINE AO_TS_VAL_t - AO_test_and_set_full(volatile AO_TS_t *addr) - { - if (AO_TS_COMPARE_AND_SWAP_FULL(addr, AO_TS_CLEAR, AO_TS_SET)) - return AO_TS_CLEAR; - else - return AO_TS_SET; - } -# define AO_HAVE_test_and_set_full -# endif /* AO_HAVE_compare_and_swap_full */ - -# if (AO_AO_TS_T && defined(AO_HAVE_compare_and_swap_acquire)) \ - || (AO_CHAR_TS_T && defined(AO_HAVE_char_compare_and_swap_acquire)) - AO_INLINE AO_TS_VAL_t - AO_test_and_set_acquire(volatile AO_TS_t *addr) - { - if (AO_TS_COMPARE_AND_SWAP_ACQUIRE(addr, AO_TS_CLEAR, AO_TS_SET)) - return AO_TS_CLEAR; - else - return AO_TS_SET; - } -# define AO_HAVE_test_and_set_acquire -# endif /* AO_HAVE_compare_and_swap_acquire */ - -# if (AO_AO_TS_T && defined(AO_HAVE_compare_and_swap_release)) \ - || (AO_CHAR_TS_T && defined(AO_HAVE_char_compare_and_swap_release)) - AO_INLINE AO_TS_VAL_t - AO_test_and_set_release(volatile AO_TS_t *addr) - { - if (AO_TS_COMPARE_AND_SWAP_RELEASE(addr, AO_TS_CLEAR, AO_TS_SET)) - return AO_TS_CLEAR; - else - return AO_TS_SET; - } -# define AO_HAVE_test_and_set_release -# endif /* AO_HAVE_compare_and_swap_release */ - -# if (AO_AO_TS_T && defined(AO_HAVE_compare_and_swap)) \ - || (AO_CHAR_TS_T && defined(AO_HAVE_char_compare_and_swap)) - AO_INLINE AO_TS_VAL_t - AO_test_and_set(volatile AO_TS_t *addr) - { - if (AO_TS_COMPARE_AND_SWAP(addr, AO_TS_CLEAR, AO_TS_SET)) - return AO_TS_CLEAR; - else - return AO_TS_SET; - } -# define AO_HAVE_test_and_set -# endif /* AO_HAVE_compare_and_swap */ -#endif /* No prior test and set */ - -/* Nop */ -#if !defined(AO_HAVE_nop) - AO_INLINE void AO_nop(void) {} -# define AO_HAVE_nop -#endif - -#if defined(AO_HAVE_test_and_set_full) && !defined(AO_HAVE_nop_full) - AO_INLINE void - AO_nop_full(void) - { - AO_TS_t dummy = AO_TS_INITIALIZER; - AO_test_and_set_full(&dummy); - } -# define AO_HAVE_nop_full -#endif - -#if defined(AO_HAVE_nop_acquire) -# error AO_nop_acquire is useless: dont define. -#endif -#if defined(AO_HAVE_nop_release) -# error AO_nop_release is useless: dont define. -#endif - -#if defined(AO_HAVE_nop_full) && !defined(AO_HAVE_nop_read) -# define AO_nop_read() AO_nop_full() -# define AO_HAVE_nop_read -#endif - -#if defined(AO_HAVE_nop_full) && !defined(AO_HAVE_nop_write) -# define AO_nop_write() AO_nop_full() -# define AO_HAVE_nop_write -#endif - -/* Test_and_set */ -#if defined(AO_HAVE_test_and_set) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_test_and_set_release) -# define AO_test_and_set_release(addr) (AO_nop_full(), AO_test_and_set(addr)) -# define AO_HAVE_test_and_set_release -#endif - -#if defined(AO_HAVE_test_and_set) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_test_and_set_acquire) - AO_INLINE AO_TS_VAL_t - AO_test_and_set_acquire(volatile AO_TS_t *addr) - { - AO_TS_VAL_t result = AO_test_and_set(addr); - AO_nop_full(); - return result; - } -# define AO_HAVE_test_and_set_acquire -#endif - -#if defined(AO_HAVE_test_and_set_full) -# if !defined(AO_HAVE_test_and_set_release) -# define AO_test_and_set_release(addr) AO_test_and_set_full(addr) -# define AO_HAVE_test_and_set_release -# endif -# if !defined(AO_HAVE_test_and_set_acquire) -# define AO_test_and_set_acquire(addr) AO_test_and_set_full(addr) -# define AO_HAVE_test_and_set_acquire -# endif -# if !defined(AO_HAVE_test_and_set_write) -# define AO_test_and_set_write(addr) AO_test_and_set_full(addr) -# define AO_HAVE_test_and_set_write -# endif -# if !defined(AO_HAVE_test_and_set_read) -# define AO_test_and_set_read(addr) AO_test_and_set_full(addr) -# define AO_HAVE_test_and_set_read -# endif -#endif /* AO_HAVE_test_and_set_full */ - -#if !defined(AO_HAVE_test_and_set) && defined(AO_HAVE_test_and_set_release) -# define AO_test_and_set(addr) AO_test_and_set_release(addr) -# define AO_HAVE_test_and_set -#endif -#if !defined(AO_HAVE_test_and_set) && defined(AO_HAVE_test_and_set_acquire) -# define AO_test_and_set(addr) AO_test_and_set_acquire(addr) -# define AO_HAVE_test_and_set -#endif -#if !defined(AO_HAVE_test_and_set) && defined(AO_HAVE_test_and_set_write) -# define AO_test_and_set(addr) AO_test_and_set_write(addr) -# define AO_HAVE_test_and_set -#endif -#if !defined(AO_HAVE_test_and_set) && defined(AO_HAVE_test_and_set_read) -# define AO_test_and_set(addr) AO_test_and_set_read(addr) -# define AO_HAVE_test_and_set -#endif - -#if defined(AO_HAVE_test_and_set_acquire) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_test_and_set_full) -# define AO_test_and_set_full(addr) \ - (AO_nop_full(), AO_test_and_set_acquire(addr)) -# define AO_HAVE_test_and_set_full -#endif - -#if !defined(AO_HAVE_test_and_set_release_write) \ - && defined(AO_HAVE_test_and_set_write) -# define AO_test_and_set_release_write(addr) AO_test_and_set_write(addr) -# define AO_HAVE_test_and_set_release_write -#endif -#if !defined(AO_HAVE_test_and_set_release_write) \ - && defined(AO_HAVE_test_and_set_release) -# define AO_test_and_set_release_write(addr) AO_test_and_set_release(addr) -# define AO_HAVE_test_and_set_release_write -#endif -#if !defined(AO_HAVE_test_and_set_acquire_read) \ - && defined(AO_HAVE_test_and_set_read) -# define AO_test_and_set_acquire_read(addr) AO_test_and_set_read(addr) -# define AO_HAVE_test_and_set_acquire_read -#endif -#if !defined(AO_HAVE_test_and_set_acquire_read) \ - && defined(AO_HAVE_test_and_set_acquire) -# define AO_test_and_set_acquire_read(addr) AO_test_and_set_acquire(addr) -# define AO_HAVE_test_and_set_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_test_and_set_acquire_read) -# define AO_test_and_set_dd_acquire_read(addr) \ - AO_test_and_set_acquire_read(addr) -# define AO_HAVE_test_and_set_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_test_and_set) -# define AO_test_and_set_dd_acquire_read(addr) AO_test_and_set(addr) -# define AO_HAVE_test_and_set_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -#include "generalize-small.h" - -#include "generalize-arithm.h" - -/* Compare_double_and_swap_double based on double_compare_and_swap. */ -#ifdef AO_HAVE_DOUBLE_PTR_STORAGE -# if defined(AO_HAVE_double_compare_and_swap) \ - && !defined(AO_HAVE_compare_double_and_swap_double) - AO_INLINE int - AO_compare_double_and_swap_double(volatile AO_double_t *addr, - AO_t old_val1, AO_t old_val2, - AO_t new_val1, AO_t new_val2) - { - AO_double_t old_w; - AO_double_t new_w; - old_w.AO_val1 = old_val1; - old_w.AO_val2 = old_val2; - new_w.AO_val1 = new_val1; - new_w.AO_val2 = new_val2; - return AO_double_compare_and_swap(addr, old_w, new_w); - } -# define AO_HAVE_compare_double_and_swap_double -# endif -# if defined(AO_HAVE_double_compare_and_swap_full) \ - && !defined(AO_HAVE_compare_double_and_swap_double_full) - AO_INLINE int - AO_compare_double_and_swap_double_full(volatile AO_double_t *addr, - AO_t old_val1, AO_t old_val2, - AO_t new_val1, AO_t new_val2) - { - AO_double_t old_w; - AO_double_t new_w; - old_w.AO_val1 = old_val1; - old_w.AO_val2 = old_val2; - new_w.AO_val1 = new_val1; - new_w.AO_val2 = new_val2; - return AO_double_compare_and_swap_full(addr, old_w, new_w); - } -# define AO_HAVE_compare_double_and_swap_double_full -# endif -#endif /* AO_HAVE_DOUBLE_PTR_STORAGE */ - -/* Compare_double_and_swap_double */ -#if defined(AO_HAVE_compare_double_and_swap_double) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_compare_double_and_swap_double_acquire) - AO_INLINE int - AO_compare_double_and_swap_double_acquire(volatile AO_double_t *addr, - AO_t o1, AO_t o2, - AO_t n1, AO_t n2) - { - int result = AO_compare_double_and_swap_double(addr, o1, o2, n1, n2); - AO_nop_full(); - return result; - } -# define AO_HAVE_compare_double_and_swap_double_acquire -#endif -#if defined(AO_HAVE_compare_double_and_swap_double) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_compare_double_and_swap_double_release) -# define AO_compare_double_and_swap_double_release(addr,o1,o2,n1,n2) \ - (AO_nop_full(), AO_compare_double_and_swap_double(addr,o1,o2,n1,n2)) -# define AO_HAVE_compare_double_and_swap_double_release -#endif -#if defined(AO_HAVE_compare_double_and_swap_double_full) -# if !defined(AO_HAVE_compare_double_and_swap_double_release) -# define AO_compare_double_and_swap_double_release(addr,o1,o2,n1,n2) \ - AO_compare_double_and_swap_double_full(addr,o1,o2,n1,n2) -# define AO_HAVE_compare_double_and_swap_double_release -# endif -# if !defined(AO_HAVE_compare_double_and_swap_double_acquire) -# define AO_compare_double_and_swap_double_acquire(addr,o1,o2,n1,n2) \ - AO_compare_double_and_swap_double_full(addr,o1,o2,n1,n2) -# define AO_HAVE_compare_double_and_swap_double_acquire -# endif -# if !defined(AO_HAVE_compare_double_and_swap_double_write) -# define AO_compare_double_and_swap_double_write(addr,o1,o2,n1,n2) \ - AO_compare_double_and_swap_double_full(addr,o1,o2,n1,n2) -# define AO_HAVE_compare_double_and_swap_double_write -# endif -# if !defined(AO_HAVE_compare_double_and_swap_double_read) -# define AO_compare_double_and_swap_double_read(addr,o1,o2,n1,n2) \ - AO_compare_double_and_swap_double_full(addr,o1,o2,n1,n2) -# define AO_HAVE_compare_double_and_swap_double_read -# endif -#endif /* AO_HAVE_compare_double_and_swap_double_full */ - -#if !defined(AO_HAVE_compare_double_and_swap_double) \ - && defined(AO_HAVE_compare_double_and_swap_double_release) -# define AO_compare_double_and_swap_double(addr,o1,o2,n1,n2) \ - AO_compare_double_and_swap_double_release(addr,o1,o2,n1,n2) -# define AO_HAVE_compare_double_and_swap_double -#endif -#if !defined(AO_HAVE_compare_double_and_swap_double) \ - && defined(AO_HAVE_compare_double_and_swap_double_acquire) -# define AO_compare_double_and_swap_double(addr,o1,o2,n1,n2) \ - AO_compare_double_and_swap_double_acquire(addr,o1,o2,n1,n2) -# define AO_HAVE_compare_double_and_swap_double -#endif -#if !defined(AO_HAVE_compare_double_and_swap_double) \ - && defined(AO_HAVE_compare_double_and_swap_double_write) -# define AO_compare_double_and_swap_double(addr,o1,o2,n1,n2) \ - AO_compare_double_and_swap_double_write(addr,o1,o2,n1,n2) -# define AO_HAVE_compare_double_and_swap_double -#endif -#if !defined(AO_HAVE_compare_double_and_swap_double) \ - && defined(AO_HAVE_compare_double_and_swap_double_read) -# define AO_compare_double_and_swap_double(addr,o1,o2,n1,n2) \ - AO_compare_double_and_swap_double_read(addr,o1,o2,n1,n2) -# define AO_HAVE_compare_double_and_swap_double -#endif - -#if defined(AO_HAVE_compare_double_and_swap_double_acquire) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_compare_double_and_swap_double_full) -# define AO_compare_double_and_swap_double_full(addr,o1,o2,n1,n2) \ - (AO_nop_full(), \ - AO_compare_double_and_swap_double_acquire(addr,o1,o2,n1,n2)) -# define AO_HAVE_compare_double_and_swap_double_full -#endif - -#if !defined(AO_HAVE_compare_double_and_swap_double_release_write) \ - && defined(AO_HAVE_compare_double_and_swap_double_write) -# define AO_compare_double_and_swap_double_release_write(addr,o1,o2,n1,n2) \ - AO_compare_double_and_swap_double_write(addr,o1,o2,n1,n2) -# define AO_HAVE_compare_double_and_swap_double_release_write -#endif -#if !defined(AO_HAVE_compare_double_and_swap_double_release_write) \ - && defined(AO_HAVE_compare_double_and_swap_double_release) -# define AO_compare_double_and_swap_double_release_write(addr,o1,o2,n1,n2) \ - AO_compare_double_and_swap_double_release(addr,o1,o2,n1,n2) -# define AO_HAVE_compare_double_and_swap_double_release_write -#endif -#if !defined(AO_HAVE_compare_double_and_swap_double_acquire_read) \ - && defined(AO_HAVE_compare_double_and_swap_double_read) -# define AO_compare_double_and_swap_double_acquire_read(addr,o1,o2,n1,n2) \ - AO_compare_double_and_swap_double_read(addr,o1,o2,n1,n2) -# define AO_HAVE_compare_double_and_swap_double_acquire_read -#endif -#if !defined(AO_HAVE_compare_double_and_swap_double_acquire_read) \ - && defined(AO_HAVE_compare_double_and_swap_double_acquire) -# define AO_compare_double_and_swap_double_acquire_read(addr,o1,o2,n1,n2) \ - AO_compare_double_and_swap_double_acquire(addr,o1,o2,n1,n2) -# define AO_HAVE_compare_double_and_swap_double_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_compare_double_and_swap_double_acquire_read) -# define AO_compare_double_and_swap_double_dd_acquire_read(addr,o1,o2,n1,n2) \ - AO_compare_double_and_swap_double_acquire_read(addr,o1,o2,n1,n2) -# define AO_HAVE_compare_double_and_swap_double_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_compare_double_and_swap_double) -# define AO_compare_double_and_swap_double_dd_acquire_read(addr,o1,o2,n1,n2) \ - AO_compare_double_and_swap_double(addr,o1,o2,n1,n2) -# define AO_HAVE_compare_double_and_swap_double_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* Compare_and_swap_double */ -#if defined(AO_HAVE_compare_and_swap_double) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_compare_and_swap_double_acquire) - AO_INLINE int - AO_compare_and_swap_double_acquire(volatile AO_double_t *addr, - AO_t o1, - AO_t n1, AO_t n2) - { - int result = AO_compare_and_swap_double(addr, o1, n1, n2); - AO_nop_full(); - return result; - } -# define AO_HAVE_compare_and_swap_double_acquire -#endif -#if defined(AO_HAVE_compare_and_swap_double) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_compare_and_swap_double_release) -# define AO_compare_and_swap_double_release(addr,o1,n1,n2) \ - (AO_nop_full(), AO_compare_and_swap_double(addr,o1,n1,n2)) -# define AO_HAVE_compare_and_swap_double_release -#endif -#if defined(AO_HAVE_compare_and_swap_double_full) -# if !defined(AO_HAVE_compare_and_swap_double_release) -# define AO_compare_and_swap_double_release(addr,o1,n1,n2) \ - AO_compare_and_swap_double_full(addr,o1,n1,n2) -# define AO_HAVE_compare_and_swap_double_release -# endif -# if !defined(AO_HAVE_compare_and_swap_double_acquire) -# define AO_compare_and_swap_double_acquire(addr,o1,n1,n2) \ - AO_compare_and_swap_double_full(addr,o1,n1,n2) -# define AO_HAVE_compare_and_swap_double_acquire -# endif -# if !defined(AO_HAVE_compare_and_swap_double_write) -# define AO_compare_and_swap_double_write(addr,o1,n1,n2) \ - AO_compare_and_swap_double_full(addr,o1,n1,n2) -# define AO_HAVE_compare_and_swap_double_write -# endif -# if !defined(AO_HAVE_compare_and_swap_double_read) -# define AO_compare_and_swap_double_read(addr,o1,n1,n2) \ - AO_compare_and_swap_double_full(addr,o1,n1,n2) -# define AO_HAVE_compare_and_swap_double_read -# endif -#endif /* AO_HAVE_compare_and_swap_double_full */ - -#if !defined(AO_HAVE_compare_and_swap_double) \ - && defined(AO_HAVE_compare_and_swap_double_release) -# define AO_compare_and_swap_double(addr,o1,n1,n2) \ - AO_compare_and_swap_double_release(addr,o1,n1,n2) -# define AO_HAVE_compare_and_swap_double -#endif -#if !defined(AO_HAVE_compare_and_swap_double) \ - && defined(AO_HAVE_compare_and_swap_double_acquire) -# define AO_compare_and_swap_double(addr,o1,n1,n2) \ - AO_compare_and_swap_double_acquire(addr,o1,n1,n2) -# define AO_HAVE_compare_and_swap_double -#endif -#if !defined(AO_HAVE_compare_and_swap_double) \ - && defined(AO_HAVE_compare_and_swap_double_write) -# define AO_compare_and_swap_double(addr,o1,n1,n2) \ - AO_compare_and_swap_double_write(addr,o1,n1,n2) -# define AO_HAVE_compare_and_swap_double -#endif -#if !defined(AO_HAVE_compare_and_swap_double) \ - && defined(AO_HAVE_compare_and_swap_double_read) -# define AO_compare_and_swap_double(addr,o1,n1,n2) \ - AO_compare_and_swap_double_read(addr,o1,n1,n2) -# define AO_HAVE_compare_and_swap_double -#endif - -#if defined(AO_HAVE_compare_and_swap_double_acquire) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_compare_and_swap_double_full) -# define AO_compare_and_swap_double_full(addr,o1,n1,n2) \ - (AO_nop_full(), AO_compare_and_swap_double_acquire(addr,o1,n1,n2)) -# define AO_HAVE_compare_and_swap_double_full -#endif - -#if !defined(AO_HAVE_compare_and_swap_double_release_write) \ - && defined(AO_HAVE_compare_and_swap_double_write) -# define AO_compare_and_swap_double_release_write(addr,o1,n1,n2) \ - AO_compare_and_swap_double_write(addr,o1,n1,n2) -# define AO_HAVE_compare_and_swap_double_release_write -#endif -#if !defined(AO_HAVE_compare_and_swap_double_release_write) \ - && defined(AO_HAVE_compare_and_swap_double_release) -# define AO_compare_and_swap_double_release_write(addr,o1,n1,n2) \ - AO_compare_and_swap_double_release(addr,o1,n1,n2) -# define AO_HAVE_compare_and_swap_double_release_write -#endif -#if !defined(AO_HAVE_compare_and_swap_double_acquire_read) \ - && defined(AO_HAVE_compare_and_swap_double_read) -# define AO_compare_and_swap_double_acquire_read(addr,o1,n1,n2) \ - AO_compare_and_swap_double_read(addr,o1,n1,n2) -# define AO_HAVE_compare_and_swap_double_acquire_read -#endif -#if !defined(AO_HAVE_compare_and_swap_double_acquire_read) \ - && defined(AO_HAVE_compare_and_swap_double_acquire) -# define AO_compare_and_swap_double_acquire_read(addr,o1,n1,n2) \ - AO_compare_and_swap_double_acquire(addr,o1,n1,n2) -# define AO_HAVE_compare_and_swap_double_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_compare_and_swap_double_acquire_read) -# define AO_compare_and_swap_double_dd_acquire_read(addr,o1,n1,n2) \ - AO_compare_and_swap_double_acquire_read(addr,o1,n1,n2) -# define AO_HAVE_compare_and_swap_double_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_compare_and_swap_double) -# define AO_compare_and_swap_double_dd_acquire_read(addr,o1,n1,n2) \ - AO_compare_and_swap_double(addr,o1,n1,n2) -# define AO_HAVE_compare_and_swap_double_dd_acquire_read -# endif -#endif - -/* Convenience functions for AO_double compare-and-swap which types and */ -/* reads easier in code. */ -#if defined(AO_HAVE_compare_double_and_swap_double) \ - && !defined(AO_HAVE_double_compare_and_swap) - AO_INLINE int - AO_double_compare_and_swap(volatile AO_double_t *addr, - AO_double_t old_val, AO_double_t new_val) - { - return AO_compare_double_and_swap_double(addr, - old_val.AO_val1, old_val.AO_val2, - new_val.AO_val1, new_val.AO_val2); - } -# define AO_HAVE_double_compare_and_swap -#endif -#if defined(AO_HAVE_compare_double_and_swap_double_release) \ - && !defined(AO_HAVE_double_compare_and_swap_release) - AO_INLINE int - AO_double_compare_and_swap_release(volatile AO_double_t *addr, - AO_double_t old_val, AO_double_t new_val) - { - return AO_compare_double_and_swap_double_release(addr, - old_val.AO_val1, old_val.AO_val2, - new_val.AO_val1, new_val.AO_val2); - } -# define AO_HAVE_double_compare_and_swap_release -#endif -#if defined(AO_HAVE_compare_double_and_swap_double_acquire) \ - && !defined(AO_HAVE_double_compare_and_swap_acquire) - AO_INLINE int - AO_double_compare_and_swap_acquire(volatile AO_double_t *addr, - AO_double_t old_val, AO_double_t new_val) - { - return AO_compare_double_and_swap_double_acquire(addr, - old_val.AO_val1, old_val.AO_val2, - new_val.AO_val1, new_val.AO_val2); - } -# define AO_HAVE_double_compare_and_swap_acquire -#endif -#if defined(AO_HAVE_compare_double_and_swap_double_read) \ - && !defined(AO_HAVE_double_compare_and_swap_read) - AO_INLINE int - AO_double_compare_and_swap_read(volatile AO_double_t *addr, - AO_double_t old_val, AO_double_t new_val) - { - return AO_compare_double_and_swap_double_read(addr, - old_val.AO_val1, old_val.AO_val2, - new_val.AO_val1, new_val.AO_val2); - } -# define AO_HAVE_double_compare_and_swap_read -#endif -#if defined(AO_HAVE_compare_double_and_swap_double_write) \ - && !defined(AO_HAVE_double_compare_and_swap_write) - AO_INLINE int - AO_double_compare_and_swap_write(volatile AO_double_t *addr, - AO_double_t old_val, AO_double_t new_val) - { - return AO_compare_double_and_swap_double_write(addr, - old_val.AO_val1, old_val.AO_val2, - new_val.AO_val1, new_val.AO_val2); - } -# define AO_HAVE_double_compare_and_swap_write -#endif -#if defined(AO_HAVE_compare_double_and_swap_double_release_write) \ - && !defined(AO_HAVE_double_compare_and_swap_release_write) - AO_INLINE int - AO_double_compare_and_swap_release_write(volatile AO_double_t *addr, - AO_double_t old_val, AO_double_t new_val) - { - return AO_compare_double_and_swap_double_release_write(addr, - old_val.AO_val1, old_val.AO_val2, - new_val.AO_val1, new_val.AO_val2); - } -# define AO_HAVE_double_compare_and_swap_release_write -#endif -#if defined(AO_HAVE_compare_double_and_swap_double_acquire_read) \ - && !defined(AO_HAVE_double_compare_and_swap_acquire_read) - AO_INLINE int - AO_double_compare_and_swap_acquire_read(volatile AO_double_t *addr, - AO_double_t old_val, AO_double_t new_val) - { - return AO_compare_double_and_swap_double_acquire_read(addr, - old_val.AO_val1, old_val.AO_val2, - new_val.AO_val1, new_val.AO_val2); - } -# define AO_HAVE_double_compare_and_swap_acquire_read -#endif -#if defined(AO_HAVE_compare_double_and_swap_double_full) \ - && !defined(AO_HAVE_double_compare_and_swap_full) - AO_INLINE int - AO_double_compare_and_swap_full(volatile AO_double_t *addr, - AO_double_t old_val, AO_double_t new_val) - { - return AO_compare_double_and_swap_double_full(addr, - old_val.AO_val1, old_val.AO_val2, - new_val.AO_val1, new_val.AO_val2); - } -# define AO_HAVE_double_compare_and_swap_full -#endif diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/generalize-small.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/generalize-small.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/generalize-small.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/generalize-small.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,2600 +0,0 @@ -/* - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* char_fetch_compare_and_swap */ -#if defined(AO_HAVE_char_fetch_compare_and_swap) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_char_fetch_compare_and_swap_acquire) - AO_INLINE unsigned/**/char - AO_char_fetch_compare_and_swap_acquire(volatile unsigned/**/char *addr, - unsigned/**/char old_val, unsigned/**/char new_val) - { - unsigned/**/char result = AO_char_fetch_compare_and_swap(addr, old_val, new_val); - AO_nop_full(); - return result; - } -# define AO_HAVE_char_fetch_compare_and_swap_acquire -#endif -#if defined(AO_HAVE_char_fetch_compare_and_swap) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_char_fetch_compare_and_swap_release) -# define AO_char_fetch_compare_and_swap_release(addr, old_val, new_val) \ - (AO_nop_full(), \ - AO_char_fetch_compare_and_swap(addr, old_val, new_val)) -# define AO_HAVE_char_fetch_compare_and_swap_release -#endif -#if defined(AO_HAVE_char_fetch_compare_and_swap_full) -# if !defined(AO_HAVE_char_fetch_compare_and_swap_release) -# define AO_char_fetch_compare_and_swap_release(addr, old_val, new_val) \ - AO_char_fetch_compare_and_swap_full(addr, old_val, new_val) -# define AO_HAVE_char_fetch_compare_and_swap_release -# endif -# if !defined(AO_HAVE_char_fetch_compare_and_swap_acquire) -# define AO_char_fetch_compare_and_swap_acquire(addr, old_val, new_val) \ - AO_char_fetch_compare_and_swap_full(addr, old_val, new_val) -# define AO_HAVE_char_fetch_compare_and_swap_acquire -# endif -# if !defined(AO_HAVE_char_fetch_compare_and_swap_write) -# define AO_char_fetch_compare_and_swap_write(addr, old_val, new_val) \ - AO_char_fetch_compare_and_swap_full(addr, old_val, new_val) -# define AO_HAVE_char_fetch_compare_and_swap_write -# endif -# if !defined(AO_HAVE_char_fetch_compare_and_swap_read) -# define AO_char_fetch_compare_and_swap_read(addr, old_val, new_val) \ - AO_char_fetch_compare_and_swap_full(addr, old_val, new_val) -# define AO_HAVE_char_fetch_compare_and_swap_read -# endif -#endif /* AO_HAVE_char_fetch_compare_and_swap_full */ - -#if !defined(AO_HAVE_char_fetch_compare_and_swap) \ - && defined(AO_HAVE_char_fetch_compare_and_swap_release) -# define AO_char_fetch_compare_and_swap(addr, old_val, new_val) \ - AO_char_fetch_compare_and_swap_release(addr, old_val, new_val) -# define AO_HAVE_char_fetch_compare_and_swap -#endif -#if !defined(AO_HAVE_char_fetch_compare_and_swap) \ - && defined(AO_HAVE_char_fetch_compare_and_swap_acquire) -# define AO_char_fetch_compare_and_swap(addr, old_val, new_val) \ - AO_char_fetch_compare_and_swap_acquire(addr, old_val, new_val) -# define AO_HAVE_char_fetch_compare_and_swap -#endif -#if !defined(AO_HAVE_char_fetch_compare_and_swap) \ - && defined(AO_HAVE_char_fetch_compare_and_swap_write) -# define AO_char_fetch_compare_and_swap(addr, old_val, new_val) \ - AO_char_fetch_compare_and_swap_write(addr, old_val, new_val) -# define AO_HAVE_char_fetch_compare_and_swap -#endif -#if !defined(AO_HAVE_char_fetch_compare_and_swap) \ - && defined(AO_HAVE_char_fetch_compare_and_swap_read) -# define AO_char_fetch_compare_and_swap(addr, old_val, new_val) \ - AO_char_fetch_compare_and_swap_read(addr, old_val, new_val) -# define AO_HAVE_char_fetch_compare_and_swap -#endif - -#if defined(AO_HAVE_char_fetch_compare_and_swap_acquire) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_char_fetch_compare_and_swap_full) -# define AO_char_fetch_compare_and_swap_full(addr, old_val, new_val) \ - (AO_nop_full(), \ - AO_char_fetch_compare_and_swap_acquire(addr, old_val, new_val)) -# define AO_HAVE_char_fetch_compare_and_swap_full -#endif - -#if !defined(AO_HAVE_char_fetch_compare_and_swap_release_write) \ - && defined(AO_HAVE_char_fetch_compare_and_swap_write) -# define AO_char_fetch_compare_and_swap_release_write(addr,old_val,new_val) \ - AO_char_fetch_compare_and_swap_write(addr, old_val, new_val) -# define AO_HAVE_char_fetch_compare_and_swap_release_write -#endif -#if !defined(AO_HAVE_char_fetch_compare_and_swap_release_write) \ - && defined(AO_HAVE_char_fetch_compare_and_swap_release) -# define AO_char_fetch_compare_and_swap_release_write(addr,old_val,new_val) \ - AO_char_fetch_compare_and_swap_release(addr, old_val, new_val) -# define AO_HAVE_char_fetch_compare_and_swap_release_write -#endif -#if !defined(AO_HAVE_char_fetch_compare_and_swap_acquire_read) \ - && defined(AO_HAVE_char_fetch_compare_and_swap_read) -# define AO_char_fetch_compare_and_swap_acquire_read(addr,old_val,new_val) \ - AO_char_fetch_compare_and_swap_read(addr, old_val, new_val) -# define AO_HAVE_char_fetch_compare_and_swap_acquire_read -#endif -#if !defined(AO_HAVE_char_fetch_compare_and_swap_acquire_read) \ - && defined(AO_HAVE_char_fetch_compare_and_swap_acquire) -# define AO_char_fetch_compare_and_swap_acquire_read(addr,old_val,new_val) \ - AO_char_fetch_compare_and_swap_acquire(addr, old_val, new_val) -# define AO_HAVE_char_fetch_compare_and_swap_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_char_fetch_compare_and_swap_acquire_read) -# define AO_char_fetch_compare_and_swap_dd_acquire_read(addr,old_val,new_val) \ - AO_char_fetch_compare_and_swap_acquire_read(addr, old_val, new_val) -# define AO_HAVE_char_fetch_compare_and_swap_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_char_fetch_compare_and_swap) -# define AO_char_fetch_compare_and_swap_dd_acquire_read(addr,old_val,new_val) \ - AO_char_fetch_compare_and_swap(addr, old_val, new_val) -# define AO_HAVE_char_fetch_compare_and_swap_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* char_compare_and_swap */ -#if defined(AO_HAVE_char_compare_and_swap) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_char_compare_and_swap_acquire) - AO_INLINE int - AO_char_compare_and_swap_acquire(volatile unsigned/**/char *addr, unsigned/**/char old, - unsigned/**/char new_val) - { - int result = AO_char_compare_and_swap(addr, old, new_val); - AO_nop_full(); - return result; - } -# define AO_HAVE_char_compare_and_swap_acquire -#endif -#if defined(AO_HAVE_char_compare_and_swap) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_char_compare_and_swap_release) -# define AO_char_compare_and_swap_release(addr, old, new_val) \ - (AO_nop_full(), AO_char_compare_and_swap(addr, old, new_val)) -# define AO_HAVE_char_compare_and_swap_release -#endif -#if defined(AO_HAVE_char_compare_and_swap_full) -# if !defined(AO_HAVE_char_compare_and_swap_release) -# define AO_char_compare_and_swap_release(addr, old, new_val) \ - AO_char_compare_and_swap_full(addr, old, new_val) -# define AO_HAVE_char_compare_and_swap_release -# endif -# if !defined(AO_HAVE_char_compare_and_swap_acquire) -# define AO_char_compare_and_swap_acquire(addr, old, new_val) \ - AO_char_compare_and_swap_full(addr, old, new_val) -# define AO_HAVE_char_compare_and_swap_acquire -# endif -# if !defined(AO_HAVE_char_compare_and_swap_write) -# define AO_char_compare_and_swap_write(addr, old, new_val) \ - AO_char_compare_and_swap_full(addr, old, new_val) -# define AO_HAVE_char_compare_and_swap_write -# endif -# if !defined(AO_HAVE_char_compare_and_swap_read) -# define AO_char_compare_and_swap_read(addr, old, new_val) \ - AO_char_compare_and_swap_full(addr, old, new_val) -# define AO_HAVE_char_compare_and_swap_read -# endif -#endif /* AO_HAVE_char_compare_and_swap_full */ - -#if !defined(AO_HAVE_char_compare_and_swap) \ - && defined(AO_HAVE_char_compare_and_swap_release) -# define AO_char_compare_and_swap(addr, old, new_val) \ - AO_char_compare_and_swap_release(addr, old, new_val) -# define AO_HAVE_char_compare_and_swap -#endif -#if !defined(AO_HAVE_char_compare_and_swap) \ - && defined(AO_HAVE_char_compare_and_swap_acquire) -# define AO_char_compare_and_swap(addr, old, new_val) \ - AO_char_compare_and_swap_acquire(addr, old, new_val) -# define AO_HAVE_char_compare_and_swap -#endif -#if !defined(AO_HAVE_char_compare_and_swap) \ - && defined(AO_HAVE_char_compare_and_swap_write) -# define AO_char_compare_and_swap(addr, old, new_val) \ - AO_char_compare_and_swap_write(addr, old, new_val) -# define AO_HAVE_char_compare_and_swap -#endif -#if !defined(AO_HAVE_char_compare_and_swap) \ - && defined(AO_HAVE_char_compare_and_swap_read) -# define AO_char_compare_and_swap(addr, old, new_val) \ - AO_char_compare_and_swap_read(addr, old, new_val) -# define AO_HAVE_char_compare_and_swap -#endif - -#if defined(AO_HAVE_char_compare_and_swap_acquire) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_char_compare_and_swap_full) -# define AO_char_compare_and_swap_full(addr, old, new_val) \ - (AO_nop_full(), \ - AO_char_compare_and_swap_acquire(addr, old, new_val)) -# define AO_HAVE_char_compare_and_swap_full -#endif - -#if !defined(AO_HAVE_char_compare_and_swap_release_write) \ - && defined(AO_HAVE_char_compare_and_swap_write) -# define AO_char_compare_and_swap_release_write(addr, old, new_val) \ - AO_char_compare_and_swap_write(addr, old, new_val) -# define AO_HAVE_char_compare_and_swap_release_write -#endif -#if !defined(AO_HAVE_char_compare_and_swap_release_write) \ - && defined(AO_HAVE_char_compare_and_swap_release) -# define AO_char_compare_and_swap_release_write(addr, old, new_val) \ - AO_char_compare_and_swap_release(addr, old, new_val) -# define AO_HAVE_char_compare_and_swap_release_write -#endif -#if !defined(AO_HAVE_char_compare_and_swap_acquire_read) \ - && defined(AO_HAVE_char_compare_and_swap_read) -# define AO_char_compare_and_swap_acquire_read(addr, old, new_val) \ - AO_char_compare_and_swap_read(addr, old, new_val) -# define AO_HAVE_char_compare_and_swap_acquire_read -#endif -#if !defined(AO_HAVE_char_compare_and_swap_acquire_read) \ - && defined(AO_HAVE_char_compare_and_swap_acquire) -# define AO_char_compare_and_swap_acquire_read(addr, old, new_val) \ - AO_char_compare_and_swap_acquire(addr, old, new_val) -# define AO_HAVE_char_compare_and_swap_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_char_compare_and_swap_acquire_read) -# define AO_char_compare_and_swap_dd_acquire_read(addr, old, new_val) \ - AO_char_compare_and_swap_acquire_read(addr, old, new_val) -# define AO_HAVE_char_compare_and_swap_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_char_compare_and_swap) -# define AO_char_compare_and_swap_dd_acquire_read(addr, old, new_val) \ - AO_char_compare_and_swap(addr, old, new_val) -# define AO_HAVE_char_compare_and_swap_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* char_load */ -#if defined(AO_HAVE_char_load_full) && !defined(AO_HAVE_char_load_acquire) -# define AO_char_load_acquire(addr) AO_char_load_full(addr) -# define AO_HAVE_char_load_acquire -#endif - -#if defined(AO_HAVE_char_load_acquire) && !defined(AO_HAVE_char_load) -# define AO_char_load(addr) AO_char_load_acquire(addr) -# define AO_HAVE_char_load -#endif - -#if defined(AO_HAVE_char_load_full) && !defined(AO_HAVE_char_load_read) -# define AO_char_load_read(addr) AO_char_load_full(addr) -# define AO_HAVE_char_load_read -#endif - -#if !defined(AO_HAVE_char_load_acquire_read) \ - && defined(AO_HAVE_char_load_acquire) -# define AO_char_load_acquire_read(addr) AO_char_load_acquire(addr) -# define AO_HAVE_char_load_acquire_read -#endif - -#if defined(AO_HAVE_char_load) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_char_load_acquire) - AO_INLINE unsigned/**/char - AO_char_load_acquire(const volatile unsigned/**/char *addr) - { - unsigned/**/char result = AO_char_load(addr); - - /* Acquire barrier would be useless, since the load could be delayed */ - /* beyond it. */ - AO_nop_full(); - return result; - } -# define AO_HAVE_char_load_acquire -#endif - -#if defined(AO_HAVE_char_load) && defined(AO_HAVE_nop_read) \ - && !defined(AO_HAVE_char_load_read) - AO_INLINE unsigned/**/char - AO_char_load_read(const volatile unsigned/**/char *addr) - { - unsigned/**/char result = AO_char_load(addr); - - AO_nop_read(); - return result; - } -# define AO_HAVE_char_load_read -#endif - -#if defined(AO_HAVE_char_load_acquire) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_char_load_full) -# define AO_char_load_full(addr) (AO_nop_full(), AO_char_load_acquire(addr)) -# define AO_HAVE_char_load_full -#endif - -#if defined(AO_HAVE_char_compare_and_swap_read) \ - && !defined(AO_HAVE_char_load_read) -# define AO_char_CAS_BASED_LOAD_READ - AO_INLINE unsigned/**/char - AO_char_load_read(const volatile unsigned/**/char *addr) - { - unsigned/**/char result; - - do { - result = *(const unsigned/**/char *)addr; - } while (AO_EXPECT_FALSE(!AO_char_compare_and_swap_read( - (volatile unsigned/**/char *)addr, - result, result))); - return result; - } -# define AO_HAVE_char_load_read -#endif - -#if !defined(AO_HAVE_char_load_acquire_read) \ - && defined(AO_HAVE_char_load_read) -# define AO_char_load_acquire_read(addr) AO_char_load_read(addr) -# define AO_HAVE_char_load_acquire_read -#endif - -#if defined(AO_HAVE_char_load_acquire_read) && !defined(AO_HAVE_char_load) \ - && (!defined(AO_char_CAS_BASED_LOAD_READ) \ - || !defined(AO_HAVE_char_compare_and_swap)) -# define AO_char_load(addr) AO_char_load_acquire_read(addr) -# define AO_HAVE_char_load -#endif - -#if defined(AO_HAVE_char_compare_and_swap_full) \ - && !defined(AO_HAVE_char_load_full) - AO_INLINE unsigned/**/char - AO_char_load_full(const volatile unsigned/**/char *addr) - { - unsigned/**/char result; - - do { - result = *(const unsigned/**/char *)addr; - } while (AO_EXPECT_FALSE(!AO_char_compare_and_swap_full( - (volatile unsigned/**/char *)addr, - result, result))); - return result; - } -# define AO_HAVE_char_load_full -#endif - -#if defined(AO_HAVE_char_compare_and_swap_acquire) \ - && !defined(AO_HAVE_char_load_acquire) - AO_INLINE unsigned/**/char - AO_char_load_acquire(const volatile unsigned/**/char *addr) - { - unsigned/**/char result; - - do { - result = *(const unsigned/**/char *)addr; - } while (AO_EXPECT_FALSE(!AO_char_compare_and_swap_acquire( - (volatile unsigned/**/char *)addr, - result, result))); - return result; - } -# define AO_HAVE_char_load_acquire -#endif - -#if defined(AO_HAVE_char_compare_and_swap) && !defined(AO_HAVE_char_load) - AO_INLINE unsigned/**/char - AO_char_load(const volatile unsigned/**/char *addr) - { - unsigned/**/char result; - - do { - result = *(const unsigned/**/char *)addr; - } while (AO_EXPECT_FALSE(!AO_char_compare_and_swap( - (volatile unsigned/**/char *)addr, - result, result))); - return result; - } -# define AO_HAVE_char_load -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_char_load_acquire_read) -# define AO_char_load_dd_acquire_read(addr) \ - AO_char_load_acquire_read(addr) -# define AO_HAVE_char_load_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_char_load) -# define AO_char_load_dd_acquire_read(addr) AO_char_load(addr) -# define AO_HAVE_char_load_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* char_store */ -#if defined(AO_HAVE_char_store_full) && !defined(AO_HAVE_char_store_release) -# define AO_char_store_release(addr, val) AO_char_store_full(addr, val) -# define AO_HAVE_char_store_release -#endif - -#if defined(AO_HAVE_char_store_release) && !defined(AO_HAVE_char_store) -# define AO_char_store(addr, val) AO_char_store_release(addr, val) -# define AO_HAVE_char_store -#endif - -#if defined(AO_HAVE_char_store_full) && !defined(AO_HAVE_char_store_write) -# define AO_char_store_write(addr, val) AO_char_store_full(addr, val) -# define AO_HAVE_char_store_write -#endif - -#if defined(AO_HAVE_char_store_release) \ - && !defined(AO_HAVE_char_store_release_write) -# define AO_char_store_release_write(addr, val) \ - AO_char_store_release(addr, val) -# define AO_HAVE_char_store_release_write -#endif - -#if defined(AO_HAVE_char_store_write) && !defined(AO_HAVE_char_store) -# define AO_char_store(addr, val) AO_char_store_write(addr, val) -# define AO_HAVE_char_store -#endif - -#if defined(AO_HAVE_char_store) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_char_store_release) -# define AO_char_store_release(addr, val) \ - (AO_nop_full(), AO_char_store(addr, val)) -# define AO_HAVE_char_store_release -#endif - -#if defined(AO_HAVE_char_store) && defined(AO_HAVE_nop_write) \ - && !defined(AO_HAVE_char_store_write) -# define AO_char_store_write(addr, val) \ - (AO_nop_write(), AO_char_store(addr, val)) -# define AO_HAVE_char_store_write -#endif - -#if defined(AO_HAVE_char_compare_and_swap_write) \ - && !defined(AO_HAVE_char_store_write) - AO_INLINE void - AO_char_store_write(volatile unsigned/**/char *addr, unsigned/**/char new_val) - { - unsigned/**/char old_val; - - do { - old_val = *(unsigned/**/char *)addr; - } while (AO_EXPECT_FALSE(!AO_char_compare_and_swap_write(addr, old_val, - new_val))); - } -# define AO_HAVE_char_store_write -#endif - -#if defined(AO_HAVE_char_store_write) \ - && !defined(AO_HAVE_char_store_release_write) -# define AO_char_store_release_write(addr, val) \ - AO_char_store_write(addr, val) -# define AO_HAVE_char_store_release_write -#endif - -#if defined(AO_HAVE_char_store_release) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_char_store_full) -# define AO_char_store_full(addr, val) \ - (AO_char_store_release(addr, val), \ - AO_nop_full()) -# define AO_HAVE_char_store_full -#endif - -#if defined(AO_HAVE_char_compare_and_swap) && !defined(AO_HAVE_char_store) - AO_INLINE void - AO_char_store(volatile unsigned/**/char *addr, unsigned/**/char new_val) - { - unsigned/**/char old_val; - - do { - old_val = *(unsigned/**/char *)addr; - } while (AO_EXPECT_FALSE(!AO_char_compare_and_swap(addr, - old_val, new_val))); - } -# define AO_HAVE_char_store -#endif - -#if defined(AO_HAVE_char_compare_and_swap_release) \ - && !defined(AO_HAVE_char_store_release) - AO_INLINE void - AO_char_store_release(volatile unsigned/**/char *addr, unsigned/**/char new_val) - { - unsigned/**/char old_val; - - do { - old_val = *(unsigned/**/char *)addr; - } while (AO_EXPECT_FALSE(!AO_char_compare_and_swap_release(addr, old_val, - new_val))); - } -# define AO_HAVE_char_store_release -#endif - -#if defined(AO_HAVE_char_compare_and_swap_full) \ - && !defined(AO_HAVE_char_store_full) - AO_INLINE void - AO_char_store_full(volatile unsigned/**/char *addr, unsigned/**/char new_val) - { - unsigned/**/char old_val; - - do { - old_val = *(unsigned/**/char *)addr; - } while (AO_EXPECT_FALSE(!AO_char_compare_and_swap_full(addr, old_val, - new_val))); - } -# define AO_HAVE_char_store_full -#endif -/* - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* short_fetch_compare_and_swap */ -#if defined(AO_HAVE_short_fetch_compare_and_swap) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_short_fetch_compare_and_swap_acquire) - AO_INLINE unsigned/**/short - AO_short_fetch_compare_and_swap_acquire(volatile unsigned/**/short *addr, - unsigned/**/short old_val, unsigned/**/short new_val) - { - unsigned/**/short result = AO_short_fetch_compare_and_swap(addr, old_val, new_val); - AO_nop_full(); - return result; - } -# define AO_HAVE_short_fetch_compare_and_swap_acquire -#endif -#if defined(AO_HAVE_short_fetch_compare_and_swap) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_short_fetch_compare_and_swap_release) -# define AO_short_fetch_compare_and_swap_release(addr, old_val, new_val) \ - (AO_nop_full(), \ - AO_short_fetch_compare_and_swap(addr, old_val, new_val)) -# define AO_HAVE_short_fetch_compare_and_swap_release -#endif -#if defined(AO_HAVE_short_fetch_compare_and_swap_full) -# if !defined(AO_HAVE_short_fetch_compare_and_swap_release) -# define AO_short_fetch_compare_and_swap_release(addr, old_val, new_val) \ - AO_short_fetch_compare_and_swap_full(addr, old_val, new_val) -# define AO_HAVE_short_fetch_compare_and_swap_release -# endif -# if !defined(AO_HAVE_short_fetch_compare_and_swap_acquire) -# define AO_short_fetch_compare_and_swap_acquire(addr, old_val, new_val) \ - AO_short_fetch_compare_and_swap_full(addr, old_val, new_val) -# define AO_HAVE_short_fetch_compare_and_swap_acquire -# endif -# if !defined(AO_HAVE_short_fetch_compare_and_swap_write) -# define AO_short_fetch_compare_and_swap_write(addr, old_val, new_val) \ - AO_short_fetch_compare_and_swap_full(addr, old_val, new_val) -# define AO_HAVE_short_fetch_compare_and_swap_write -# endif -# if !defined(AO_HAVE_short_fetch_compare_and_swap_read) -# define AO_short_fetch_compare_and_swap_read(addr, old_val, new_val) \ - AO_short_fetch_compare_and_swap_full(addr, old_val, new_val) -# define AO_HAVE_short_fetch_compare_and_swap_read -# endif -#endif /* AO_HAVE_short_fetch_compare_and_swap_full */ - -#if !defined(AO_HAVE_short_fetch_compare_and_swap) \ - && defined(AO_HAVE_short_fetch_compare_and_swap_release) -# define AO_short_fetch_compare_and_swap(addr, old_val, new_val) \ - AO_short_fetch_compare_and_swap_release(addr, old_val, new_val) -# define AO_HAVE_short_fetch_compare_and_swap -#endif -#if !defined(AO_HAVE_short_fetch_compare_and_swap) \ - && defined(AO_HAVE_short_fetch_compare_and_swap_acquire) -# define AO_short_fetch_compare_and_swap(addr, old_val, new_val) \ - AO_short_fetch_compare_and_swap_acquire(addr, old_val, new_val) -# define AO_HAVE_short_fetch_compare_and_swap -#endif -#if !defined(AO_HAVE_short_fetch_compare_and_swap) \ - && defined(AO_HAVE_short_fetch_compare_and_swap_write) -# define AO_short_fetch_compare_and_swap(addr, old_val, new_val) \ - AO_short_fetch_compare_and_swap_write(addr, old_val, new_val) -# define AO_HAVE_short_fetch_compare_and_swap -#endif -#if !defined(AO_HAVE_short_fetch_compare_and_swap) \ - && defined(AO_HAVE_short_fetch_compare_and_swap_read) -# define AO_short_fetch_compare_and_swap(addr, old_val, new_val) \ - AO_short_fetch_compare_and_swap_read(addr, old_val, new_val) -# define AO_HAVE_short_fetch_compare_and_swap -#endif - -#if defined(AO_HAVE_short_fetch_compare_and_swap_acquire) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_short_fetch_compare_and_swap_full) -# define AO_short_fetch_compare_and_swap_full(addr, old_val, new_val) \ - (AO_nop_full(), \ - AO_short_fetch_compare_and_swap_acquire(addr, old_val, new_val)) -# define AO_HAVE_short_fetch_compare_and_swap_full -#endif - -#if !defined(AO_HAVE_short_fetch_compare_and_swap_release_write) \ - && defined(AO_HAVE_short_fetch_compare_and_swap_write) -# define AO_short_fetch_compare_and_swap_release_write(addr,old_val,new_val) \ - AO_short_fetch_compare_and_swap_write(addr, old_val, new_val) -# define AO_HAVE_short_fetch_compare_and_swap_release_write -#endif -#if !defined(AO_HAVE_short_fetch_compare_and_swap_release_write) \ - && defined(AO_HAVE_short_fetch_compare_and_swap_release) -# define AO_short_fetch_compare_and_swap_release_write(addr,old_val,new_val) \ - AO_short_fetch_compare_and_swap_release(addr, old_val, new_val) -# define AO_HAVE_short_fetch_compare_and_swap_release_write -#endif -#if !defined(AO_HAVE_short_fetch_compare_and_swap_acquire_read) \ - && defined(AO_HAVE_short_fetch_compare_and_swap_read) -# define AO_short_fetch_compare_and_swap_acquire_read(addr,old_val,new_val) \ - AO_short_fetch_compare_and_swap_read(addr, old_val, new_val) -# define AO_HAVE_short_fetch_compare_and_swap_acquire_read -#endif -#if !defined(AO_HAVE_short_fetch_compare_and_swap_acquire_read) \ - && defined(AO_HAVE_short_fetch_compare_and_swap_acquire) -# define AO_short_fetch_compare_and_swap_acquire_read(addr,old_val,new_val) \ - AO_short_fetch_compare_and_swap_acquire(addr, old_val, new_val) -# define AO_HAVE_short_fetch_compare_and_swap_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_short_fetch_compare_and_swap_acquire_read) -# define AO_short_fetch_compare_and_swap_dd_acquire_read(addr,old_val,new_val) \ - AO_short_fetch_compare_and_swap_acquire_read(addr, old_val, new_val) -# define AO_HAVE_short_fetch_compare_and_swap_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_short_fetch_compare_and_swap) -# define AO_short_fetch_compare_and_swap_dd_acquire_read(addr,old_val,new_val) \ - AO_short_fetch_compare_and_swap(addr, old_val, new_val) -# define AO_HAVE_short_fetch_compare_and_swap_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* short_compare_and_swap */ -#if defined(AO_HAVE_short_compare_and_swap) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_short_compare_and_swap_acquire) - AO_INLINE int - AO_short_compare_and_swap_acquire(volatile unsigned/**/short *addr, unsigned/**/short old, - unsigned/**/short new_val) - { - int result = AO_short_compare_and_swap(addr, old, new_val); - AO_nop_full(); - return result; - } -# define AO_HAVE_short_compare_and_swap_acquire -#endif -#if defined(AO_HAVE_short_compare_and_swap) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_short_compare_and_swap_release) -# define AO_short_compare_and_swap_release(addr, old, new_val) \ - (AO_nop_full(), AO_short_compare_and_swap(addr, old, new_val)) -# define AO_HAVE_short_compare_and_swap_release -#endif -#if defined(AO_HAVE_short_compare_and_swap_full) -# if !defined(AO_HAVE_short_compare_and_swap_release) -# define AO_short_compare_and_swap_release(addr, old, new_val) \ - AO_short_compare_and_swap_full(addr, old, new_val) -# define AO_HAVE_short_compare_and_swap_release -# endif -# if !defined(AO_HAVE_short_compare_and_swap_acquire) -# define AO_short_compare_and_swap_acquire(addr, old, new_val) \ - AO_short_compare_and_swap_full(addr, old, new_val) -# define AO_HAVE_short_compare_and_swap_acquire -# endif -# if !defined(AO_HAVE_short_compare_and_swap_write) -# define AO_short_compare_and_swap_write(addr, old, new_val) \ - AO_short_compare_and_swap_full(addr, old, new_val) -# define AO_HAVE_short_compare_and_swap_write -# endif -# if !defined(AO_HAVE_short_compare_and_swap_read) -# define AO_short_compare_and_swap_read(addr, old, new_val) \ - AO_short_compare_and_swap_full(addr, old, new_val) -# define AO_HAVE_short_compare_and_swap_read -# endif -#endif /* AO_HAVE_short_compare_and_swap_full */ - -#if !defined(AO_HAVE_short_compare_and_swap) \ - && defined(AO_HAVE_short_compare_and_swap_release) -# define AO_short_compare_and_swap(addr, old, new_val) \ - AO_short_compare_and_swap_release(addr, old, new_val) -# define AO_HAVE_short_compare_and_swap -#endif -#if !defined(AO_HAVE_short_compare_and_swap) \ - && defined(AO_HAVE_short_compare_and_swap_acquire) -# define AO_short_compare_and_swap(addr, old, new_val) \ - AO_short_compare_and_swap_acquire(addr, old, new_val) -# define AO_HAVE_short_compare_and_swap -#endif -#if !defined(AO_HAVE_short_compare_and_swap) \ - && defined(AO_HAVE_short_compare_and_swap_write) -# define AO_short_compare_and_swap(addr, old, new_val) \ - AO_short_compare_and_swap_write(addr, old, new_val) -# define AO_HAVE_short_compare_and_swap -#endif -#if !defined(AO_HAVE_short_compare_and_swap) \ - && defined(AO_HAVE_short_compare_and_swap_read) -# define AO_short_compare_and_swap(addr, old, new_val) \ - AO_short_compare_and_swap_read(addr, old, new_val) -# define AO_HAVE_short_compare_and_swap -#endif - -#if defined(AO_HAVE_short_compare_and_swap_acquire) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_short_compare_and_swap_full) -# define AO_short_compare_and_swap_full(addr, old, new_val) \ - (AO_nop_full(), \ - AO_short_compare_and_swap_acquire(addr, old, new_val)) -# define AO_HAVE_short_compare_and_swap_full -#endif - -#if !defined(AO_HAVE_short_compare_and_swap_release_write) \ - && defined(AO_HAVE_short_compare_and_swap_write) -# define AO_short_compare_and_swap_release_write(addr, old, new_val) \ - AO_short_compare_and_swap_write(addr, old, new_val) -# define AO_HAVE_short_compare_and_swap_release_write -#endif -#if !defined(AO_HAVE_short_compare_and_swap_release_write) \ - && defined(AO_HAVE_short_compare_and_swap_release) -# define AO_short_compare_and_swap_release_write(addr, old, new_val) \ - AO_short_compare_and_swap_release(addr, old, new_val) -# define AO_HAVE_short_compare_and_swap_release_write -#endif -#if !defined(AO_HAVE_short_compare_and_swap_acquire_read) \ - && defined(AO_HAVE_short_compare_and_swap_read) -# define AO_short_compare_and_swap_acquire_read(addr, old, new_val) \ - AO_short_compare_and_swap_read(addr, old, new_val) -# define AO_HAVE_short_compare_and_swap_acquire_read -#endif -#if !defined(AO_HAVE_short_compare_and_swap_acquire_read) \ - && defined(AO_HAVE_short_compare_and_swap_acquire) -# define AO_short_compare_and_swap_acquire_read(addr, old, new_val) \ - AO_short_compare_and_swap_acquire(addr, old, new_val) -# define AO_HAVE_short_compare_and_swap_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_short_compare_and_swap_acquire_read) -# define AO_short_compare_and_swap_dd_acquire_read(addr, old, new_val) \ - AO_short_compare_and_swap_acquire_read(addr, old, new_val) -# define AO_HAVE_short_compare_and_swap_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_short_compare_and_swap) -# define AO_short_compare_and_swap_dd_acquire_read(addr, old, new_val) \ - AO_short_compare_and_swap(addr, old, new_val) -# define AO_HAVE_short_compare_and_swap_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* short_load */ -#if defined(AO_HAVE_short_load_full) && !defined(AO_HAVE_short_load_acquire) -# define AO_short_load_acquire(addr) AO_short_load_full(addr) -# define AO_HAVE_short_load_acquire -#endif - -#if defined(AO_HAVE_short_load_acquire) && !defined(AO_HAVE_short_load) -# define AO_short_load(addr) AO_short_load_acquire(addr) -# define AO_HAVE_short_load -#endif - -#if defined(AO_HAVE_short_load_full) && !defined(AO_HAVE_short_load_read) -# define AO_short_load_read(addr) AO_short_load_full(addr) -# define AO_HAVE_short_load_read -#endif - -#if !defined(AO_HAVE_short_load_acquire_read) \ - && defined(AO_HAVE_short_load_acquire) -# define AO_short_load_acquire_read(addr) AO_short_load_acquire(addr) -# define AO_HAVE_short_load_acquire_read -#endif - -#if defined(AO_HAVE_short_load) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_short_load_acquire) - AO_INLINE unsigned/**/short - AO_short_load_acquire(const volatile unsigned/**/short *addr) - { - unsigned/**/short result = AO_short_load(addr); - - /* Acquire barrier would be useless, since the load could be delayed */ - /* beyond it. */ - AO_nop_full(); - return result; - } -# define AO_HAVE_short_load_acquire -#endif - -#if defined(AO_HAVE_short_load) && defined(AO_HAVE_nop_read) \ - && !defined(AO_HAVE_short_load_read) - AO_INLINE unsigned/**/short - AO_short_load_read(const volatile unsigned/**/short *addr) - { - unsigned/**/short result = AO_short_load(addr); - - AO_nop_read(); - return result; - } -# define AO_HAVE_short_load_read -#endif - -#if defined(AO_HAVE_short_load_acquire) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_short_load_full) -# define AO_short_load_full(addr) (AO_nop_full(), AO_short_load_acquire(addr)) -# define AO_HAVE_short_load_full -#endif - -#if defined(AO_HAVE_short_compare_and_swap_read) \ - && !defined(AO_HAVE_short_load_read) -# define AO_short_CAS_BASED_LOAD_READ - AO_INLINE unsigned/**/short - AO_short_load_read(const volatile unsigned/**/short *addr) - { - unsigned/**/short result; - - do { - result = *(const unsigned/**/short *)addr; - } while (AO_EXPECT_FALSE(!AO_short_compare_and_swap_read( - (volatile unsigned/**/short *)addr, - result, result))); - return result; - } -# define AO_HAVE_short_load_read -#endif - -#if !defined(AO_HAVE_short_load_acquire_read) \ - && defined(AO_HAVE_short_load_read) -# define AO_short_load_acquire_read(addr) AO_short_load_read(addr) -# define AO_HAVE_short_load_acquire_read -#endif - -#if defined(AO_HAVE_short_load_acquire_read) && !defined(AO_HAVE_short_load) \ - && (!defined(AO_short_CAS_BASED_LOAD_READ) \ - || !defined(AO_HAVE_short_compare_and_swap)) -# define AO_short_load(addr) AO_short_load_acquire_read(addr) -# define AO_HAVE_short_load -#endif - -#if defined(AO_HAVE_short_compare_and_swap_full) \ - && !defined(AO_HAVE_short_load_full) - AO_INLINE unsigned/**/short - AO_short_load_full(const volatile unsigned/**/short *addr) - { - unsigned/**/short result; - - do { - result = *(const unsigned/**/short *)addr; - } while (AO_EXPECT_FALSE(!AO_short_compare_and_swap_full( - (volatile unsigned/**/short *)addr, - result, result))); - return result; - } -# define AO_HAVE_short_load_full -#endif - -#if defined(AO_HAVE_short_compare_and_swap_acquire) \ - && !defined(AO_HAVE_short_load_acquire) - AO_INLINE unsigned/**/short - AO_short_load_acquire(const volatile unsigned/**/short *addr) - { - unsigned/**/short result; - - do { - result = *(const unsigned/**/short *)addr; - } while (AO_EXPECT_FALSE(!AO_short_compare_and_swap_acquire( - (volatile unsigned/**/short *)addr, - result, result))); - return result; - } -# define AO_HAVE_short_load_acquire -#endif - -#if defined(AO_HAVE_short_compare_and_swap) && !defined(AO_HAVE_short_load) - AO_INLINE unsigned/**/short - AO_short_load(const volatile unsigned/**/short *addr) - { - unsigned/**/short result; - - do { - result = *(const unsigned/**/short *)addr; - } while (AO_EXPECT_FALSE(!AO_short_compare_and_swap( - (volatile unsigned/**/short *)addr, - result, result))); - return result; - } -# define AO_HAVE_short_load -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_short_load_acquire_read) -# define AO_short_load_dd_acquire_read(addr) \ - AO_short_load_acquire_read(addr) -# define AO_HAVE_short_load_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_short_load) -# define AO_short_load_dd_acquire_read(addr) AO_short_load(addr) -# define AO_HAVE_short_load_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* short_store */ -#if defined(AO_HAVE_short_store_full) && !defined(AO_HAVE_short_store_release) -# define AO_short_store_release(addr, val) AO_short_store_full(addr, val) -# define AO_HAVE_short_store_release -#endif - -#if defined(AO_HAVE_short_store_release) && !defined(AO_HAVE_short_store) -# define AO_short_store(addr, val) AO_short_store_release(addr, val) -# define AO_HAVE_short_store -#endif - -#if defined(AO_HAVE_short_store_full) && !defined(AO_HAVE_short_store_write) -# define AO_short_store_write(addr, val) AO_short_store_full(addr, val) -# define AO_HAVE_short_store_write -#endif - -#if defined(AO_HAVE_short_store_release) \ - && !defined(AO_HAVE_short_store_release_write) -# define AO_short_store_release_write(addr, val) \ - AO_short_store_release(addr, val) -# define AO_HAVE_short_store_release_write -#endif - -#if defined(AO_HAVE_short_store_write) && !defined(AO_HAVE_short_store) -# define AO_short_store(addr, val) AO_short_store_write(addr, val) -# define AO_HAVE_short_store -#endif - -#if defined(AO_HAVE_short_store) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_short_store_release) -# define AO_short_store_release(addr, val) \ - (AO_nop_full(), AO_short_store(addr, val)) -# define AO_HAVE_short_store_release -#endif - -#if defined(AO_HAVE_short_store) && defined(AO_HAVE_nop_write) \ - && !defined(AO_HAVE_short_store_write) -# define AO_short_store_write(addr, val) \ - (AO_nop_write(), AO_short_store(addr, val)) -# define AO_HAVE_short_store_write -#endif - -#if defined(AO_HAVE_short_compare_and_swap_write) \ - && !defined(AO_HAVE_short_store_write) - AO_INLINE void - AO_short_store_write(volatile unsigned/**/short *addr, unsigned/**/short new_val) - { - unsigned/**/short old_val; - - do { - old_val = *(unsigned/**/short *)addr; - } while (AO_EXPECT_FALSE(!AO_short_compare_and_swap_write(addr, old_val, - new_val))); - } -# define AO_HAVE_short_store_write -#endif - -#if defined(AO_HAVE_short_store_write) \ - && !defined(AO_HAVE_short_store_release_write) -# define AO_short_store_release_write(addr, val) \ - AO_short_store_write(addr, val) -# define AO_HAVE_short_store_release_write -#endif - -#if defined(AO_HAVE_short_store_release) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_short_store_full) -# define AO_short_store_full(addr, val) \ - (AO_short_store_release(addr, val), \ - AO_nop_full()) -# define AO_HAVE_short_store_full -#endif - -#if defined(AO_HAVE_short_compare_and_swap) && !defined(AO_HAVE_short_store) - AO_INLINE void - AO_short_store(volatile unsigned/**/short *addr, unsigned/**/short new_val) - { - unsigned/**/short old_val; - - do { - old_val = *(unsigned/**/short *)addr; - } while (AO_EXPECT_FALSE(!AO_short_compare_and_swap(addr, - old_val, new_val))); - } -# define AO_HAVE_short_store -#endif - -#if defined(AO_HAVE_short_compare_and_swap_release) \ - && !defined(AO_HAVE_short_store_release) - AO_INLINE void - AO_short_store_release(volatile unsigned/**/short *addr, unsigned/**/short new_val) - { - unsigned/**/short old_val; - - do { - old_val = *(unsigned/**/short *)addr; - } while (AO_EXPECT_FALSE(!AO_short_compare_and_swap_release(addr, old_val, - new_val))); - } -# define AO_HAVE_short_store_release -#endif - -#if defined(AO_HAVE_short_compare_and_swap_full) \ - && !defined(AO_HAVE_short_store_full) - AO_INLINE void - AO_short_store_full(volatile unsigned/**/short *addr, unsigned/**/short new_val) - { - unsigned/**/short old_val; - - do { - old_val = *(unsigned/**/short *)addr; - } while (AO_EXPECT_FALSE(!AO_short_compare_and_swap_full(addr, old_val, - new_val))); - } -# define AO_HAVE_short_store_full -#endif -/* - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* int_fetch_compare_and_swap */ -#if defined(AO_HAVE_int_fetch_compare_and_swap) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_int_fetch_compare_and_swap_acquire) - AO_INLINE unsigned - AO_int_fetch_compare_and_swap_acquire(volatile unsigned *addr, - unsigned old_val, unsigned new_val) - { - unsigned result = AO_int_fetch_compare_and_swap(addr, old_val, new_val); - AO_nop_full(); - return result; - } -# define AO_HAVE_int_fetch_compare_and_swap_acquire -#endif -#if defined(AO_HAVE_int_fetch_compare_and_swap) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_int_fetch_compare_and_swap_release) -# define AO_int_fetch_compare_and_swap_release(addr, old_val, new_val) \ - (AO_nop_full(), \ - AO_int_fetch_compare_and_swap(addr, old_val, new_val)) -# define AO_HAVE_int_fetch_compare_and_swap_release -#endif -#if defined(AO_HAVE_int_fetch_compare_and_swap_full) -# if !defined(AO_HAVE_int_fetch_compare_and_swap_release) -# define AO_int_fetch_compare_and_swap_release(addr, old_val, new_val) \ - AO_int_fetch_compare_and_swap_full(addr, old_val, new_val) -# define AO_HAVE_int_fetch_compare_and_swap_release -# endif -# if !defined(AO_HAVE_int_fetch_compare_and_swap_acquire) -# define AO_int_fetch_compare_and_swap_acquire(addr, old_val, new_val) \ - AO_int_fetch_compare_and_swap_full(addr, old_val, new_val) -# define AO_HAVE_int_fetch_compare_and_swap_acquire -# endif -# if !defined(AO_HAVE_int_fetch_compare_and_swap_write) -# define AO_int_fetch_compare_and_swap_write(addr, old_val, new_val) \ - AO_int_fetch_compare_and_swap_full(addr, old_val, new_val) -# define AO_HAVE_int_fetch_compare_and_swap_write -# endif -# if !defined(AO_HAVE_int_fetch_compare_and_swap_read) -# define AO_int_fetch_compare_and_swap_read(addr, old_val, new_val) \ - AO_int_fetch_compare_and_swap_full(addr, old_val, new_val) -# define AO_HAVE_int_fetch_compare_and_swap_read -# endif -#endif /* AO_HAVE_int_fetch_compare_and_swap_full */ - -#if !defined(AO_HAVE_int_fetch_compare_and_swap) \ - && defined(AO_HAVE_int_fetch_compare_and_swap_release) -# define AO_int_fetch_compare_and_swap(addr, old_val, new_val) \ - AO_int_fetch_compare_and_swap_release(addr, old_val, new_val) -# define AO_HAVE_int_fetch_compare_and_swap -#endif -#if !defined(AO_HAVE_int_fetch_compare_and_swap) \ - && defined(AO_HAVE_int_fetch_compare_and_swap_acquire) -# define AO_int_fetch_compare_and_swap(addr, old_val, new_val) \ - AO_int_fetch_compare_and_swap_acquire(addr, old_val, new_val) -# define AO_HAVE_int_fetch_compare_and_swap -#endif -#if !defined(AO_HAVE_int_fetch_compare_and_swap) \ - && defined(AO_HAVE_int_fetch_compare_and_swap_write) -# define AO_int_fetch_compare_and_swap(addr, old_val, new_val) \ - AO_int_fetch_compare_and_swap_write(addr, old_val, new_val) -# define AO_HAVE_int_fetch_compare_and_swap -#endif -#if !defined(AO_HAVE_int_fetch_compare_and_swap) \ - && defined(AO_HAVE_int_fetch_compare_and_swap_read) -# define AO_int_fetch_compare_and_swap(addr, old_val, new_val) \ - AO_int_fetch_compare_and_swap_read(addr, old_val, new_val) -# define AO_HAVE_int_fetch_compare_and_swap -#endif - -#if defined(AO_HAVE_int_fetch_compare_and_swap_acquire) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_int_fetch_compare_and_swap_full) -# define AO_int_fetch_compare_and_swap_full(addr, old_val, new_val) \ - (AO_nop_full(), \ - AO_int_fetch_compare_and_swap_acquire(addr, old_val, new_val)) -# define AO_HAVE_int_fetch_compare_and_swap_full -#endif - -#if !defined(AO_HAVE_int_fetch_compare_and_swap_release_write) \ - && defined(AO_HAVE_int_fetch_compare_and_swap_write) -# define AO_int_fetch_compare_and_swap_release_write(addr,old_val,new_val) \ - AO_int_fetch_compare_and_swap_write(addr, old_val, new_val) -# define AO_HAVE_int_fetch_compare_and_swap_release_write -#endif -#if !defined(AO_HAVE_int_fetch_compare_and_swap_release_write) \ - && defined(AO_HAVE_int_fetch_compare_and_swap_release) -# define AO_int_fetch_compare_and_swap_release_write(addr,old_val,new_val) \ - AO_int_fetch_compare_and_swap_release(addr, old_val, new_val) -# define AO_HAVE_int_fetch_compare_and_swap_release_write -#endif -#if !defined(AO_HAVE_int_fetch_compare_and_swap_acquire_read) \ - && defined(AO_HAVE_int_fetch_compare_and_swap_read) -# define AO_int_fetch_compare_and_swap_acquire_read(addr,old_val,new_val) \ - AO_int_fetch_compare_and_swap_read(addr, old_val, new_val) -# define AO_HAVE_int_fetch_compare_and_swap_acquire_read -#endif -#if !defined(AO_HAVE_int_fetch_compare_and_swap_acquire_read) \ - && defined(AO_HAVE_int_fetch_compare_and_swap_acquire) -# define AO_int_fetch_compare_and_swap_acquire_read(addr,old_val,new_val) \ - AO_int_fetch_compare_and_swap_acquire(addr, old_val, new_val) -# define AO_HAVE_int_fetch_compare_and_swap_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_int_fetch_compare_and_swap_acquire_read) -# define AO_int_fetch_compare_and_swap_dd_acquire_read(addr,old_val,new_val) \ - AO_int_fetch_compare_and_swap_acquire_read(addr, old_val, new_val) -# define AO_HAVE_int_fetch_compare_and_swap_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_int_fetch_compare_and_swap) -# define AO_int_fetch_compare_and_swap_dd_acquire_read(addr,old_val,new_val) \ - AO_int_fetch_compare_and_swap(addr, old_val, new_val) -# define AO_HAVE_int_fetch_compare_and_swap_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* int_compare_and_swap */ -#if defined(AO_HAVE_int_compare_and_swap) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_int_compare_and_swap_acquire) - AO_INLINE int - AO_int_compare_and_swap_acquire(volatile unsigned *addr, unsigned old, - unsigned new_val) - { - int result = AO_int_compare_and_swap(addr, old, new_val); - AO_nop_full(); - return result; - } -# define AO_HAVE_int_compare_and_swap_acquire -#endif -#if defined(AO_HAVE_int_compare_and_swap) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_int_compare_and_swap_release) -# define AO_int_compare_and_swap_release(addr, old, new_val) \ - (AO_nop_full(), AO_int_compare_and_swap(addr, old, new_val)) -# define AO_HAVE_int_compare_and_swap_release -#endif -#if defined(AO_HAVE_int_compare_and_swap_full) -# if !defined(AO_HAVE_int_compare_and_swap_release) -# define AO_int_compare_and_swap_release(addr, old, new_val) \ - AO_int_compare_and_swap_full(addr, old, new_val) -# define AO_HAVE_int_compare_and_swap_release -# endif -# if !defined(AO_HAVE_int_compare_and_swap_acquire) -# define AO_int_compare_and_swap_acquire(addr, old, new_val) \ - AO_int_compare_and_swap_full(addr, old, new_val) -# define AO_HAVE_int_compare_and_swap_acquire -# endif -# if !defined(AO_HAVE_int_compare_and_swap_write) -# define AO_int_compare_and_swap_write(addr, old, new_val) \ - AO_int_compare_and_swap_full(addr, old, new_val) -# define AO_HAVE_int_compare_and_swap_write -# endif -# if !defined(AO_HAVE_int_compare_and_swap_read) -# define AO_int_compare_and_swap_read(addr, old, new_val) \ - AO_int_compare_and_swap_full(addr, old, new_val) -# define AO_HAVE_int_compare_and_swap_read -# endif -#endif /* AO_HAVE_int_compare_and_swap_full */ - -#if !defined(AO_HAVE_int_compare_and_swap) \ - && defined(AO_HAVE_int_compare_and_swap_release) -# define AO_int_compare_and_swap(addr, old, new_val) \ - AO_int_compare_and_swap_release(addr, old, new_val) -# define AO_HAVE_int_compare_and_swap -#endif -#if !defined(AO_HAVE_int_compare_and_swap) \ - && defined(AO_HAVE_int_compare_and_swap_acquire) -# define AO_int_compare_and_swap(addr, old, new_val) \ - AO_int_compare_and_swap_acquire(addr, old, new_val) -# define AO_HAVE_int_compare_and_swap -#endif -#if !defined(AO_HAVE_int_compare_and_swap) \ - && defined(AO_HAVE_int_compare_and_swap_write) -# define AO_int_compare_and_swap(addr, old, new_val) \ - AO_int_compare_and_swap_write(addr, old, new_val) -# define AO_HAVE_int_compare_and_swap -#endif -#if !defined(AO_HAVE_int_compare_and_swap) \ - && defined(AO_HAVE_int_compare_and_swap_read) -# define AO_int_compare_and_swap(addr, old, new_val) \ - AO_int_compare_and_swap_read(addr, old, new_val) -# define AO_HAVE_int_compare_and_swap -#endif - -#if defined(AO_HAVE_int_compare_and_swap_acquire) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_int_compare_and_swap_full) -# define AO_int_compare_and_swap_full(addr, old, new_val) \ - (AO_nop_full(), \ - AO_int_compare_and_swap_acquire(addr, old, new_val)) -# define AO_HAVE_int_compare_and_swap_full -#endif - -#if !defined(AO_HAVE_int_compare_and_swap_release_write) \ - && defined(AO_HAVE_int_compare_and_swap_write) -# define AO_int_compare_and_swap_release_write(addr, old, new_val) \ - AO_int_compare_and_swap_write(addr, old, new_val) -# define AO_HAVE_int_compare_and_swap_release_write -#endif -#if !defined(AO_HAVE_int_compare_and_swap_release_write) \ - && defined(AO_HAVE_int_compare_and_swap_release) -# define AO_int_compare_and_swap_release_write(addr, old, new_val) \ - AO_int_compare_and_swap_release(addr, old, new_val) -# define AO_HAVE_int_compare_and_swap_release_write -#endif -#if !defined(AO_HAVE_int_compare_and_swap_acquire_read) \ - && defined(AO_HAVE_int_compare_and_swap_read) -# define AO_int_compare_and_swap_acquire_read(addr, old, new_val) \ - AO_int_compare_and_swap_read(addr, old, new_val) -# define AO_HAVE_int_compare_and_swap_acquire_read -#endif -#if !defined(AO_HAVE_int_compare_and_swap_acquire_read) \ - && defined(AO_HAVE_int_compare_and_swap_acquire) -# define AO_int_compare_and_swap_acquire_read(addr, old, new_val) \ - AO_int_compare_and_swap_acquire(addr, old, new_val) -# define AO_HAVE_int_compare_and_swap_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_int_compare_and_swap_acquire_read) -# define AO_int_compare_and_swap_dd_acquire_read(addr, old, new_val) \ - AO_int_compare_and_swap_acquire_read(addr, old, new_val) -# define AO_HAVE_int_compare_and_swap_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_int_compare_and_swap) -# define AO_int_compare_and_swap_dd_acquire_read(addr, old, new_val) \ - AO_int_compare_and_swap(addr, old, new_val) -# define AO_HAVE_int_compare_and_swap_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* int_load */ -#if defined(AO_HAVE_int_load_full) && !defined(AO_HAVE_int_load_acquire) -# define AO_int_load_acquire(addr) AO_int_load_full(addr) -# define AO_HAVE_int_load_acquire -#endif - -#if defined(AO_HAVE_int_load_acquire) && !defined(AO_HAVE_int_load) -# define AO_int_load(addr) AO_int_load_acquire(addr) -# define AO_HAVE_int_load -#endif - -#if defined(AO_HAVE_int_load_full) && !defined(AO_HAVE_int_load_read) -# define AO_int_load_read(addr) AO_int_load_full(addr) -# define AO_HAVE_int_load_read -#endif - -#if !defined(AO_HAVE_int_load_acquire_read) \ - && defined(AO_HAVE_int_load_acquire) -# define AO_int_load_acquire_read(addr) AO_int_load_acquire(addr) -# define AO_HAVE_int_load_acquire_read -#endif - -#if defined(AO_HAVE_int_load) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_int_load_acquire) - AO_INLINE unsigned - AO_int_load_acquire(const volatile unsigned *addr) - { - unsigned result = AO_int_load(addr); - - /* Acquire barrier would be useless, since the load could be delayed */ - /* beyond it. */ - AO_nop_full(); - return result; - } -# define AO_HAVE_int_load_acquire -#endif - -#if defined(AO_HAVE_int_load) && defined(AO_HAVE_nop_read) \ - && !defined(AO_HAVE_int_load_read) - AO_INLINE unsigned - AO_int_load_read(const volatile unsigned *addr) - { - unsigned result = AO_int_load(addr); - - AO_nop_read(); - return result; - } -# define AO_HAVE_int_load_read -#endif - -#if defined(AO_HAVE_int_load_acquire) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_int_load_full) -# define AO_int_load_full(addr) (AO_nop_full(), AO_int_load_acquire(addr)) -# define AO_HAVE_int_load_full -#endif - -#if defined(AO_HAVE_int_compare_and_swap_read) \ - && !defined(AO_HAVE_int_load_read) -# define AO_int_CAS_BASED_LOAD_READ - AO_INLINE unsigned - AO_int_load_read(const volatile unsigned *addr) - { - unsigned result; - - do { - result = *(const unsigned *)addr; - } while (AO_EXPECT_FALSE(!AO_int_compare_and_swap_read( - (volatile unsigned *)addr, - result, result))); - return result; - } -# define AO_HAVE_int_load_read -#endif - -#if !defined(AO_HAVE_int_load_acquire_read) \ - && defined(AO_HAVE_int_load_read) -# define AO_int_load_acquire_read(addr) AO_int_load_read(addr) -# define AO_HAVE_int_load_acquire_read -#endif - -#if defined(AO_HAVE_int_load_acquire_read) && !defined(AO_HAVE_int_load) \ - && (!defined(AO_int_CAS_BASED_LOAD_READ) \ - || !defined(AO_HAVE_int_compare_and_swap)) -# define AO_int_load(addr) AO_int_load_acquire_read(addr) -# define AO_HAVE_int_load -#endif - -#if defined(AO_HAVE_int_compare_and_swap_full) \ - && !defined(AO_HAVE_int_load_full) - AO_INLINE unsigned - AO_int_load_full(const volatile unsigned *addr) - { - unsigned result; - - do { - result = *(const unsigned *)addr; - } while (AO_EXPECT_FALSE(!AO_int_compare_and_swap_full( - (volatile unsigned *)addr, - result, result))); - return result; - } -# define AO_HAVE_int_load_full -#endif - -#if defined(AO_HAVE_int_compare_and_swap_acquire) \ - && !defined(AO_HAVE_int_load_acquire) - AO_INLINE unsigned - AO_int_load_acquire(const volatile unsigned *addr) - { - unsigned result; - - do { - result = *(const unsigned *)addr; - } while (AO_EXPECT_FALSE(!AO_int_compare_and_swap_acquire( - (volatile unsigned *)addr, - result, result))); - return result; - } -# define AO_HAVE_int_load_acquire -#endif - -#if defined(AO_HAVE_int_compare_and_swap) && !defined(AO_HAVE_int_load) - AO_INLINE unsigned - AO_int_load(const volatile unsigned *addr) - { - unsigned result; - - do { - result = *(const unsigned *)addr; - } while (AO_EXPECT_FALSE(!AO_int_compare_and_swap( - (volatile unsigned *)addr, - result, result))); - return result; - } -# define AO_HAVE_int_load -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_int_load_acquire_read) -# define AO_int_load_dd_acquire_read(addr) \ - AO_int_load_acquire_read(addr) -# define AO_HAVE_int_load_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_int_load) -# define AO_int_load_dd_acquire_read(addr) AO_int_load(addr) -# define AO_HAVE_int_load_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* int_store */ -#if defined(AO_HAVE_int_store_full) && !defined(AO_HAVE_int_store_release) -# define AO_int_store_release(addr, val) AO_int_store_full(addr, val) -# define AO_HAVE_int_store_release -#endif - -#if defined(AO_HAVE_int_store_release) && !defined(AO_HAVE_int_store) -# define AO_int_store(addr, val) AO_int_store_release(addr, val) -# define AO_HAVE_int_store -#endif - -#if defined(AO_HAVE_int_store_full) && !defined(AO_HAVE_int_store_write) -# define AO_int_store_write(addr, val) AO_int_store_full(addr, val) -# define AO_HAVE_int_store_write -#endif - -#if defined(AO_HAVE_int_store_release) \ - && !defined(AO_HAVE_int_store_release_write) -# define AO_int_store_release_write(addr, val) \ - AO_int_store_release(addr, val) -# define AO_HAVE_int_store_release_write -#endif - -#if defined(AO_HAVE_int_store_write) && !defined(AO_HAVE_int_store) -# define AO_int_store(addr, val) AO_int_store_write(addr, val) -# define AO_HAVE_int_store -#endif - -#if defined(AO_HAVE_int_store) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_int_store_release) -# define AO_int_store_release(addr, val) \ - (AO_nop_full(), AO_int_store(addr, val)) -# define AO_HAVE_int_store_release -#endif - -#if defined(AO_HAVE_int_store) && defined(AO_HAVE_nop_write) \ - && !defined(AO_HAVE_int_store_write) -# define AO_int_store_write(addr, val) \ - (AO_nop_write(), AO_int_store(addr, val)) -# define AO_HAVE_int_store_write -#endif - -#if defined(AO_HAVE_int_compare_and_swap_write) \ - && !defined(AO_HAVE_int_store_write) - AO_INLINE void - AO_int_store_write(volatile unsigned *addr, unsigned new_val) - { - unsigned old_val; - - do { - old_val = *(unsigned *)addr; - } while (AO_EXPECT_FALSE(!AO_int_compare_and_swap_write(addr, old_val, - new_val))); - } -# define AO_HAVE_int_store_write -#endif - -#if defined(AO_HAVE_int_store_write) \ - && !defined(AO_HAVE_int_store_release_write) -# define AO_int_store_release_write(addr, val) \ - AO_int_store_write(addr, val) -# define AO_HAVE_int_store_release_write -#endif - -#if defined(AO_HAVE_int_store_release) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_int_store_full) -# define AO_int_store_full(addr, val) \ - (AO_int_store_release(addr, val), \ - AO_nop_full()) -# define AO_HAVE_int_store_full -#endif - -#if defined(AO_HAVE_int_compare_and_swap) && !defined(AO_HAVE_int_store) - AO_INLINE void - AO_int_store(volatile unsigned *addr, unsigned new_val) - { - unsigned old_val; - - do { - old_val = *(unsigned *)addr; - } while (AO_EXPECT_FALSE(!AO_int_compare_and_swap(addr, - old_val, new_val))); - } -# define AO_HAVE_int_store -#endif - -#if defined(AO_HAVE_int_compare_and_swap_release) \ - && !defined(AO_HAVE_int_store_release) - AO_INLINE void - AO_int_store_release(volatile unsigned *addr, unsigned new_val) - { - unsigned old_val; - - do { - old_val = *(unsigned *)addr; - } while (AO_EXPECT_FALSE(!AO_int_compare_and_swap_release(addr, old_val, - new_val))); - } -# define AO_HAVE_int_store_release -#endif - -#if defined(AO_HAVE_int_compare_and_swap_full) \ - && !defined(AO_HAVE_int_store_full) - AO_INLINE void - AO_int_store_full(volatile unsigned *addr, unsigned new_val) - { - unsigned old_val; - - do { - old_val = *(unsigned *)addr; - } while (AO_EXPECT_FALSE(!AO_int_compare_and_swap_full(addr, old_val, - new_val))); - } -# define AO_HAVE_int_store_full -#endif -/* - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* fetch_compare_and_swap */ -#if defined(AO_HAVE_fetch_compare_and_swap) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_fetch_compare_and_swap_acquire) - AO_INLINE AO_t - AO_fetch_compare_and_swap_acquire(volatile AO_t *addr, - AO_t old_val, AO_t new_val) - { - AO_t result = AO_fetch_compare_and_swap(addr, old_val, new_val); - AO_nop_full(); - return result; - } -# define AO_HAVE_fetch_compare_and_swap_acquire -#endif -#if defined(AO_HAVE_fetch_compare_and_swap) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_fetch_compare_and_swap_release) -# define AO_fetch_compare_and_swap_release(addr, old_val, new_val) \ - (AO_nop_full(), \ - AO_fetch_compare_and_swap(addr, old_val, new_val)) -# define AO_HAVE_fetch_compare_and_swap_release -#endif -#if defined(AO_HAVE_fetch_compare_and_swap_full) -# if !defined(AO_HAVE_fetch_compare_and_swap_release) -# define AO_fetch_compare_and_swap_release(addr, old_val, new_val) \ - AO_fetch_compare_and_swap_full(addr, old_val, new_val) -# define AO_HAVE_fetch_compare_and_swap_release -# endif -# if !defined(AO_HAVE_fetch_compare_and_swap_acquire) -# define AO_fetch_compare_and_swap_acquire(addr, old_val, new_val) \ - AO_fetch_compare_and_swap_full(addr, old_val, new_val) -# define AO_HAVE_fetch_compare_and_swap_acquire -# endif -# if !defined(AO_HAVE_fetch_compare_and_swap_write) -# define AO_fetch_compare_and_swap_write(addr, old_val, new_val) \ - AO_fetch_compare_and_swap_full(addr, old_val, new_val) -# define AO_HAVE_fetch_compare_and_swap_write -# endif -# if !defined(AO_HAVE_fetch_compare_and_swap_read) -# define AO_fetch_compare_and_swap_read(addr, old_val, new_val) \ - AO_fetch_compare_and_swap_full(addr, old_val, new_val) -# define AO_HAVE_fetch_compare_and_swap_read -# endif -#endif /* AO_HAVE_fetch_compare_and_swap_full */ - -#if !defined(AO_HAVE_fetch_compare_and_swap) \ - && defined(AO_HAVE_fetch_compare_and_swap_release) -# define AO_fetch_compare_and_swap(addr, old_val, new_val) \ - AO_fetch_compare_and_swap_release(addr, old_val, new_val) -# define AO_HAVE_fetch_compare_and_swap -#endif -#if !defined(AO_HAVE_fetch_compare_and_swap) \ - && defined(AO_HAVE_fetch_compare_and_swap_acquire) -# define AO_fetch_compare_and_swap(addr, old_val, new_val) \ - AO_fetch_compare_and_swap_acquire(addr, old_val, new_val) -# define AO_HAVE_fetch_compare_and_swap -#endif -#if !defined(AO_HAVE_fetch_compare_and_swap) \ - && defined(AO_HAVE_fetch_compare_and_swap_write) -# define AO_fetch_compare_and_swap(addr, old_val, new_val) \ - AO_fetch_compare_and_swap_write(addr, old_val, new_val) -# define AO_HAVE_fetch_compare_and_swap -#endif -#if !defined(AO_HAVE_fetch_compare_and_swap) \ - && defined(AO_HAVE_fetch_compare_and_swap_read) -# define AO_fetch_compare_and_swap(addr, old_val, new_val) \ - AO_fetch_compare_and_swap_read(addr, old_val, new_val) -# define AO_HAVE_fetch_compare_and_swap -#endif - -#if defined(AO_HAVE_fetch_compare_and_swap_acquire) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_fetch_compare_and_swap_full) -# define AO_fetch_compare_and_swap_full(addr, old_val, new_val) \ - (AO_nop_full(), \ - AO_fetch_compare_and_swap_acquire(addr, old_val, new_val)) -# define AO_HAVE_fetch_compare_and_swap_full -#endif - -#if !defined(AO_HAVE_fetch_compare_and_swap_release_write) \ - && defined(AO_HAVE_fetch_compare_and_swap_write) -# define AO_fetch_compare_and_swap_release_write(addr,old_val,new_val) \ - AO_fetch_compare_and_swap_write(addr, old_val, new_val) -# define AO_HAVE_fetch_compare_and_swap_release_write -#endif -#if !defined(AO_HAVE_fetch_compare_and_swap_release_write) \ - && defined(AO_HAVE_fetch_compare_and_swap_release) -# define AO_fetch_compare_and_swap_release_write(addr,old_val,new_val) \ - AO_fetch_compare_and_swap_release(addr, old_val, new_val) -# define AO_HAVE_fetch_compare_and_swap_release_write -#endif -#if !defined(AO_HAVE_fetch_compare_and_swap_acquire_read) \ - && defined(AO_HAVE_fetch_compare_and_swap_read) -# define AO_fetch_compare_and_swap_acquire_read(addr,old_val,new_val) \ - AO_fetch_compare_and_swap_read(addr, old_val, new_val) -# define AO_HAVE_fetch_compare_and_swap_acquire_read -#endif -#if !defined(AO_HAVE_fetch_compare_and_swap_acquire_read) \ - && defined(AO_HAVE_fetch_compare_and_swap_acquire) -# define AO_fetch_compare_and_swap_acquire_read(addr,old_val,new_val) \ - AO_fetch_compare_and_swap_acquire(addr, old_val, new_val) -# define AO_HAVE_fetch_compare_and_swap_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_fetch_compare_and_swap_acquire_read) -# define AO_fetch_compare_and_swap_dd_acquire_read(addr,old_val,new_val) \ - AO_fetch_compare_and_swap_acquire_read(addr, old_val, new_val) -# define AO_HAVE_fetch_compare_and_swap_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_fetch_compare_and_swap) -# define AO_fetch_compare_and_swap_dd_acquire_read(addr,old_val,new_val) \ - AO_fetch_compare_and_swap(addr, old_val, new_val) -# define AO_HAVE_fetch_compare_and_swap_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* compare_and_swap */ -#if defined(AO_HAVE_compare_and_swap) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_compare_and_swap_acquire) - AO_INLINE int - AO_compare_and_swap_acquire(volatile AO_t *addr, AO_t old, - AO_t new_val) - { - int result = AO_compare_and_swap(addr, old, new_val); - AO_nop_full(); - return result; - } -# define AO_HAVE_compare_and_swap_acquire -#endif -#if defined(AO_HAVE_compare_and_swap) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_compare_and_swap_release) -# define AO_compare_and_swap_release(addr, old, new_val) \ - (AO_nop_full(), AO_compare_and_swap(addr, old, new_val)) -# define AO_HAVE_compare_and_swap_release -#endif -#if defined(AO_HAVE_compare_and_swap_full) -# if !defined(AO_HAVE_compare_and_swap_release) -# define AO_compare_and_swap_release(addr, old, new_val) \ - AO_compare_and_swap_full(addr, old, new_val) -# define AO_HAVE_compare_and_swap_release -# endif -# if !defined(AO_HAVE_compare_and_swap_acquire) -# define AO_compare_and_swap_acquire(addr, old, new_val) \ - AO_compare_and_swap_full(addr, old, new_val) -# define AO_HAVE_compare_and_swap_acquire -# endif -# if !defined(AO_HAVE_compare_and_swap_write) -# define AO_compare_and_swap_write(addr, old, new_val) \ - AO_compare_and_swap_full(addr, old, new_val) -# define AO_HAVE_compare_and_swap_write -# endif -# if !defined(AO_HAVE_compare_and_swap_read) -# define AO_compare_and_swap_read(addr, old, new_val) \ - AO_compare_and_swap_full(addr, old, new_val) -# define AO_HAVE_compare_and_swap_read -# endif -#endif /* AO_HAVE_compare_and_swap_full */ - -#if !defined(AO_HAVE_compare_and_swap) \ - && defined(AO_HAVE_compare_and_swap_release) -# define AO_compare_and_swap(addr, old, new_val) \ - AO_compare_and_swap_release(addr, old, new_val) -# define AO_HAVE_compare_and_swap -#endif -#if !defined(AO_HAVE_compare_and_swap) \ - && defined(AO_HAVE_compare_and_swap_acquire) -# define AO_compare_and_swap(addr, old, new_val) \ - AO_compare_and_swap_acquire(addr, old, new_val) -# define AO_HAVE_compare_and_swap -#endif -#if !defined(AO_HAVE_compare_and_swap) \ - && defined(AO_HAVE_compare_and_swap_write) -# define AO_compare_and_swap(addr, old, new_val) \ - AO_compare_and_swap_write(addr, old, new_val) -# define AO_HAVE_compare_and_swap -#endif -#if !defined(AO_HAVE_compare_and_swap) \ - && defined(AO_HAVE_compare_and_swap_read) -# define AO_compare_and_swap(addr, old, new_val) \ - AO_compare_and_swap_read(addr, old, new_val) -# define AO_HAVE_compare_and_swap -#endif - -#if defined(AO_HAVE_compare_and_swap_acquire) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_compare_and_swap_full) -# define AO_compare_and_swap_full(addr, old, new_val) \ - (AO_nop_full(), \ - AO_compare_and_swap_acquire(addr, old, new_val)) -# define AO_HAVE_compare_and_swap_full -#endif - -#if !defined(AO_HAVE_compare_and_swap_release_write) \ - && defined(AO_HAVE_compare_and_swap_write) -# define AO_compare_and_swap_release_write(addr, old, new_val) \ - AO_compare_and_swap_write(addr, old, new_val) -# define AO_HAVE_compare_and_swap_release_write -#endif -#if !defined(AO_HAVE_compare_and_swap_release_write) \ - && defined(AO_HAVE_compare_and_swap_release) -# define AO_compare_and_swap_release_write(addr, old, new_val) \ - AO_compare_and_swap_release(addr, old, new_val) -# define AO_HAVE_compare_and_swap_release_write -#endif -#if !defined(AO_HAVE_compare_and_swap_acquire_read) \ - && defined(AO_HAVE_compare_and_swap_read) -# define AO_compare_and_swap_acquire_read(addr, old, new_val) \ - AO_compare_and_swap_read(addr, old, new_val) -# define AO_HAVE_compare_and_swap_acquire_read -#endif -#if !defined(AO_HAVE_compare_and_swap_acquire_read) \ - && defined(AO_HAVE_compare_and_swap_acquire) -# define AO_compare_and_swap_acquire_read(addr, old, new_val) \ - AO_compare_and_swap_acquire(addr, old, new_val) -# define AO_HAVE_compare_and_swap_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_compare_and_swap_acquire_read) -# define AO_compare_and_swap_dd_acquire_read(addr, old, new_val) \ - AO_compare_and_swap_acquire_read(addr, old, new_val) -# define AO_HAVE_compare_and_swap_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_compare_and_swap) -# define AO_compare_and_swap_dd_acquire_read(addr, old, new_val) \ - AO_compare_and_swap(addr, old, new_val) -# define AO_HAVE_compare_and_swap_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* load */ -#if defined(AO_HAVE_load_full) && !defined(AO_HAVE_load_acquire) -# define AO_load_acquire(addr) AO_load_full(addr) -# define AO_HAVE_load_acquire -#endif - -#if defined(AO_HAVE_load_acquire) && !defined(AO_HAVE_load) -# define AO_load(addr) AO_load_acquire(addr) -# define AO_HAVE_load -#endif - -#if defined(AO_HAVE_load_full) && !defined(AO_HAVE_load_read) -# define AO_load_read(addr) AO_load_full(addr) -# define AO_HAVE_load_read -#endif - -#if !defined(AO_HAVE_load_acquire_read) \ - && defined(AO_HAVE_load_acquire) -# define AO_load_acquire_read(addr) AO_load_acquire(addr) -# define AO_HAVE_load_acquire_read -#endif - -#if defined(AO_HAVE_load) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_load_acquire) - AO_INLINE AO_t - AO_load_acquire(const volatile AO_t *addr) - { - AO_t result = AO_load(addr); - - /* Acquire barrier would be useless, since the load could be delayed */ - /* beyond it. */ - AO_nop_full(); - return result; - } -# define AO_HAVE_load_acquire -#endif - -#if defined(AO_HAVE_load) && defined(AO_HAVE_nop_read) \ - && !defined(AO_HAVE_load_read) - AO_INLINE AO_t - AO_load_read(const volatile AO_t *addr) - { - AO_t result = AO_load(addr); - - AO_nop_read(); - return result; - } -# define AO_HAVE_load_read -#endif - -#if defined(AO_HAVE_load_acquire) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_load_full) -# define AO_load_full(addr) (AO_nop_full(), AO_load_acquire(addr)) -# define AO_HAVE_load_full -#endif - -#if defined(AO_HAVE_compare_and_swap_read) \ - && !defined(AO_HAVE_load_read) -# define AO_CAS_BASED_LOAD_READ - AO_INLINE AO_t - AO_load_read(const volatile AO_t *addr) - { - AO_t result; - - do { - result = *(const AO_t *)addr; - } while (AO_EXPECT_FALSE(!AO_compare_and_swap_read( - (volatile AO_t *)addr, - result, result))); - return result; - } -# define AO_HAVE_load_read -#endif - -#if !defined(AO_HAVE_load_acquire_read) \ - && defined(AO_HAVE_load_read) -# define AO_load_acquire_read(addr) AO_load_read(addr) -# define AO_HAVE_load_acquire_read -#endif - -#if defined(AO_HAVE_load_acquire_read) && !defined(AO_HAVE_load) \ - && (!defined(AO_CAS_BASED_LOAD_READ) \ - || !defined(AO_HAVE_compare_and_swap)) -# define AO_load(addr) AO_load_acquire_read(addr) -# define AO_HAVE_load -#endif - -#if defined(AO_HAVE_compare_and_swap_full) \ - && !defined(AO_HAVE_load_full) - AO_INLINE AO_t - AO_load_full(const volatile AO_t *addr) - { - AO_t result; - - do { - result = *(const AO_t *)addr; - } while (AO_EXPECT_FALSE(!AO_compare_and_swap_full( - (volatile AO_t *)addr, - result, result))); - return result; - } -# define AO_HAVE_load_full -#endif - -#if defined(AO_HAVE_compare_and_swap_acquire) \ - && !defined(AO_HAVE_load_acquire) - AO_INLINE AO_t - AO_load_acquire(const volatile AO_t *addr) - { - AO_t result; - - do { - result = *(const AO_t *)addr; - } while (AO_EXPECT_FALSE(!AO_compare_and_swap_acquire( - (volatile AO_t *)addr, - result, result))); - return result; - } -# define AO_HAVE_load_acquire -#endif - -#if defined(AO_HAVE_compare_and_swap) && !defined(AO_HAVE_load) - AO_INLINE AO_t - AO_load(const volatile AO_t *addr) - { - AO_t result; - - do { - result = *(const AO_t *)addr; - } while (AO_EXPECT_FALSE(!AO_compare_and_swap( - (volatile AO_t *)addr, - result, result))); - return result; - } -# define AO_HAVE_load -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_load_acquire_read) -# define AO_load_dd_acquire_read(addr) \ - AO_load_acquire_read(addr) -# define AO_HAVE_load_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_load) -# define AO_load_dd_acquire_read(addr) AO_load(addr) -# define AO_HAVE_load_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* store */ -#if defined(AO_HAVE_store_full) && !defined(AO_HAVE_store_release) -# define AO_store_release(addr, val) AO_store_full(addr, val) -# define AO_HAVE_store_release -#endif - -#if defined(AO_HAVE_store_release) && !defined(AO_HAVE_store) -# define AO_store(addr, val) AO_store_release(addr, val) -# define AO_HAVE_store -#endif - -#if defined(AO_HAVE_store_full) && !defined(AO_HAVE_store_write) -# define AO_store_write(addr, val) AO_store_full(addr, val) -# define AO_HAVE_store_write -#endif - -#if defined(AO_HAVE_store_release) \ - && !defined(AO_HAVE_store_release_write) -# define AO_store_release_write(addr, val) \ - AO_store_release(addr, val) -# define AO_HAVE_store_release_write -#endif - -#if defined(AO_HAVE_store_write) && !defined(AO_HAVE_store) -# define AO_store(addr, val) AO_store_write(addr, val) -# define AO_HAVE_store -#endif - -#if defined(AO_HAVE_store) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_store_release) -# define AO_store_release(addr, val) \ - (AO_nop_full(), AO_store(addr, val)) -# define AO_HAVE_store_release -#endif - -#if defined(AO_HAVE_store) && defined(AO_HAVE_nop_write) \ - && !defined(AO_HAVE_store_write) -# define AO_store_write(addr, val) \ - (AO_nop_write(), AO_store(addr, val)) -# define AO_HAVE_store_write -#endif - -#if defined(AO_HAVE_compare_and_swap_write) \ - && !defined(AO_HAVE_store_write) - AO_INLINE void - AO_store_write(volatile AO_t *addr, AO_t new_val) - { - AO_t old_val; - - do { - old_val = *(AO_t *)addr; - } while (AO_EXPECT_FALSE(!AO_compare_and_swap_write(addr, old_val, - new_val))); - } -# define AO_HAVE_store_write -#endif - -#if defined(AO_HAVE_store_write) \ - && !defined(AO_HAVE_store_release_write) -# define AO_store_release_write(addr, val) \ - AO_store_write(addr, val) -# define AO_HAVE_store_release_write -#endif - -#if defined(AO_HAVE_store_release) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_store_full) -# define AO_store_full(addr, val) \ - (AO_store_release(addr, val), \ - AO_nop_full()) -# define AO_HAVE_store_full -#endif - -#if defined(AO_HAVE_compare_and_swap) && !defined(AO_HAVE_store) - AO_INLINE void - AO_store(volatile AO_t *addr, AO_t new_val) - { - AO_t old_val; - - do { - old_val = *(AO_t *)addr; - } while (AO_EXPECT_FALSE(!AO_compare_and_swap(addr, - old_val, new_val))); - } -# define AO_HAVE_store -#endif - -#if defined(AO_HAVE_compare_and_swap_release) \ - && !defined(AO_HAVE_store_release) - AO_INLINE void - AO_store_release(volatile AO_t *addr, AO_t new_val) - { - AO_t old_val; - - do { - old_val = *(AO_t *)addr; - } while (AO_EXPECT_FALSE(!AO_compare_and_swap_release(addr, old_val, - new_val))); - } -# define AO_HAVE_store_release -#endif - -#if defined(AO_HAVE_compare_and_swap_full) \ - && !defined(AO_HAVE_store_full) - AO_INLINE void - AO_store_full(volatile AO_t *addr, AO_t new_val) - { - AO_t old_val; - - do { - old_val = *(AO_t *)addr; - } while (AO_EXPECT_FALSE(!AO_compare_and_swap_full(addr, old_val, - new_val))); - } -# define AO_HAVE_store_full -#endif -/* - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* double_fetch_compare_and_swap */ -#if defined(AO_HAVE_double_fetch_compare_and_swap) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_double_fetch_compare_and_swap_acquire) - AO_INLINE AO_double_t - AO_double_fetch_compare_and_swap_acquire(volatile AO_double_t *addr, - AO_double_t old_val, AO_double_t new_val) - { - AO_double_t result = AO_double_fetch_compare_and_swap(addr, old_val, new_val); - AO_nop_full(); - return result; - } -# define AO_HAVE_double_fetch_compare_and_swap_acquire -#endif -#if defined(AO_HAVE_double_fetch_compare_and_swap) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_double_fetch_compare_and_swap_release) -# define AO_double_fetch_compare_and_swap_release(addr, old_val, new_val) \ - (AO_nop_full(), \ - AO_double_fetch_compare_and_swap(addr, old_val, new_val)) -# define AO_HAVE_double_fetch_compare_and_swap_release -#endif -#if defined(AO_HAVE_double_fetch_compare_and_swap_full) -# if !defined(AO_HAVE_double_fetch_compare_and_swap_release) -# define AO_double_fetch_compare_and_swap_release(addr, old_val, new_val) \ - AO_double_fetch_compare_and_swap_full(addr, old_val, new_val) -# define AO_HAVE_double_fetch_compare_and_swap_release -# endif -# if !defined(AO_HAVE_double_fetch_compare_and_swap_acquire) -# define AO_double_fetch_compare_and_swap_acquire(addr, old_val, new_val) \ - AO_double_fetch_compare_and_swap_full(addr, old_val, new_val) -# define AO_HAVE_double_fetch_compare_and_swap_acquire -# endif -# if !defined(AO_HAVE_double_fetch_compare_and_swap_write) -# define AO_double_fetch_compare_and_swap_write(addr, old_val, new_val) \ - AO_double_fetch_compare_and_swap_full(addr, old_val, new_val) -# define AO_HAVE_double_fetch_compare_and_swap_write -# endif -# if !defined(AO_HAVE_double_fetch_compare_and_swap_read) -# define AO_double_fetch_compare_and_swap_read(addr, old_val, new_val) \ - AO_double_fetch_compare_and_swap_full(addr, old_val, new_val) -# define AO_HAVE_double_fetch_compare_and_swap_read -# endif -#endif /* AO_HAVE_double_fetch_compare_and_swap_full */ - -#if !defined(AO_HAVE_double_fetch_compare_and_swap) \ - && defined(AO_HAVE_double_fetch_compare_and_swap_release) -# define AO_double_fetch_compare_and_swap(addr, old_val, new_val) \ - AO_double_fetch_compare_and_swap_release(addr, old_val, new_val) -# define AO_HAVE_double_fetch_compare_and_swap -#endif -#if !defined(AO_HAVE_double_fetch_compare_and_swap) \ - && defined(AO_HAVE_double_fetch_compare_and_swap_acquire) -# define AO_double_fetch_compare_and_swap(addr, old_val, new_val) \ - AO_double_fetch_compare_and_swap_acquire(addr, old_val, new_val) -# define AO_HAVE_double_fetch_compare_and_swap -#endif -#if !defined(AO_HAVE_double_fetch_compare_and_swap) \ - && defined(AO_HAVE_double_fetch_compare_and_swap_write) -# define AO_double_fetch_compare_and_swap(addr, old_val, new_val) \ - AO_double_fetch_compare_and_swap_write(addr, old_val, new_val) -# define AO_HAVE_double_fetch_compare_and_swap -#endif -#if !defined(AO_HAVE_double_fetch_compare_and_swap) \ - && defined(AO_HAVE_double_fetch_compare_and_swap_read) -# define AO_double_fetch_compare_and_swap(addr, old_val, new_val) \ - AO_double_fetch_compare_and_swap_read(addr, old_val, new_val) -# define AO_HAVE_double_fetch_compare_and_swap -#endif - -#if defined(AO_HAVE_double_fetch_compare_and_swap_acquire) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_double_fetch_compare_and_swap_full) -# define AO_double_fetch_compare_and_swap_full(addr, old_val, new_val) \ - (AO_nop_full(), \ - AO_double_fetch_compare_and_swap_acquire(addr, old_val, new_val)) -# define AO_HAVE_double_fetch_compare_and_swap_full -#endif - -#if !defined(AO_HAVE_double_fetch_compare_and_swap_release_write) \ - && defined(AO_HAVE_double_fetch_compare_and_swap_write) -# define AO_double_fetch_compare_and_swap_release_write(addr,old_val,new_val) \ - AO_double_fetch_compare_and_swap_write(addr, old_val, new_val) -# define AO_HAVE_double_fetch_compare_and_swap_release_write -#endif -#if !defined(AO_HAVE_double_fetch_compare_and_swap_release_write) \ - && defined(AO_HAVE_double_fetch_compare_and_swap_release) -# define AO_double_fetch_compare_and_swap_release_write(addr,old_val,new_val) \ - AO_double_fetch_compare_and_swap_release(addr, old_val, new_val) -# define AO_HAVE_double_fetch_compare_and_swap_release_write -#endif -#if !defined(AO_HAVE_double_fetch_compare_and_swap_acquire_read) \ - && defined(AO_HAVE_double_fetch_compare_and_swap_read) -# define AO_double_fetch_compare_and_swap_acquire_read(addr,old_val,new_val) \ - AO_double_fetch_compare_and_swap_read(addr, old_val, new_val) -# define AO_HAVE_double_fetch_compare_and_swap_acquire_read -#endif -#if !defined(AO_HAVE_double_fetch_compare_and_swap_acquire_read) \ - && defined(AO_HAVE_double_fetch_compare_and_swap_acquire) -# define AO_double_fetch_compare_and_swap_acquire_read(addr,old_val,new_val) \ - AO_double_fetch_compare_and_swap_acquire(addr, old_val, new_val) -# define AO_HAVE_double_fetch_compare_and_swap_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_double_fetch_compare_and_swap_acquire_read) -# define AO_double_fetch_compare_and_swap_dd_acquire_read(addr,old_val,new_val) \ - AO_double_fetch_compare_and_swap_acquire_read(addr, old_val, new_val) -# define AO_HAVE_double_fetch_compare_and_swap_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_double_fetch_compare_and_swap) -# define AO_double_fetch_compare_and_swap_dd_acquire_read(addr,old_val,new_val) \ - AO_double_fetch_compare_and_swap(addr, old_val, new_val) -# define AO_HAVE_double_fetch_compare_and_swap_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* double_compare_and_swap */ -#if defined(AO_HAVE_double_compare_and_swap) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_double_compare_and_swap_acquire) - AO_INLINE int - AO_double_compare_and_swap_acquire(volatile AO_double_t *addr, AO_double_t old, - AO_double_t new_val) - { - int result = AO_double_compare_and_swap(addr, old, new_val); - AO_nop_full(); - return result; - } -# define AO_HAVE_double_compare_and_swap_acquire -#endif -#if defined(AO_HAVE_double_compare_and_swap) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_double_compare_and_swap_release) -# define AO_double_compare_and_swap_release(addr, old, new_val) \ - (AO_nop_full(), AO_double_compare_and_swap(addr, old, new_val)) -# define AO_HAVE_double_compare_and_swap_release -#endif -#if defined(AO_HAVE_double_compare_and_swap_full) -# if !defined(AO_HAVE_double_compare_and_swap_release) -# define AO_double_compare_and_swap_release(addr, old, new_val) \ - AO_double_compare_and_swap_full(addr, old, new_val) -# define AO_HAVE_double_compare_and_swap_release -# endif -# if !defined(AO_HAVE_double_compare_and_swap_acquire) -# define AO_double_compare_and_swap_acquire(addr, old, new_val) \ - AO_double_compare_and_swap_full(addr, old, new_val) -# define AO_HAVE_double_compare_and_swap_acquire -# endif -# if !defined(AO_HAVE_double_compare_and_swap_write) -# define AO_double_compare_and_swap_write(addr, old, new_val) \ - AO_double_compare_and_swap_full(addr, old, new_val) -# define AO_HAVE_double_compare_and_swap_write -# endif -# if !defined(AO_HAVE_double_compare_and_swap_read) -# define AO_double_compare_and_swap_read(addr, old, new_val) \ - AO_double_compare_and_swap_full(addr, old, new_val) -# define AO_HAVE_double_compare_and_swap_read -# endif -#endif /* AO_HAVE_double_compare_and_swap_full */ - -#if !defined(AO_HAVE_double_compare_and_swap) \ - && defined(AO_HAVE_double_compare_and_swap_release) -# define AO_double_compare_and_swap(addr, old, new_val) \ - AO_double_compare_and_swap_release(addr, old, new_val) -# define AO_HAVE_double_compare_and_swap -#endif -#if !defined(AO_HAVE_double_compare_and_swap) \ - && defined(AO_HAVE_double_compare_and_swap_acquire) -# define AO_double_compare_and_swap(addr, old, new_val) \ - AO_double_compare_and_swap_acquire(addr, old, new_val) -# define AO_HAVE_double_compare_and_swap -#endif -#if !defined(AO_HAVE_double_compare_and_swap) \ - && defined(AO_HAVE_double_compare_and_swap_write) -# define AO_double_compare_and_swap(addr, old, new_val) \ - AO_double_compare_and_swap_write(addr, old, new_val) -# define AO_HAVE_double_compare_and_swap -#endif -#if !defined(AO_HAVE_double_compare_and_swap) \ - && defined(AO_HAVE_double_compare_and_swap_read) -# define AO_double_compare_and_swap(addr, old, new_val) \ - AO_double_compare_and_swap_read(addr, old, new_val) -# define AO_HAVE_double_compare_and_swap -#endif - -#if defined(AO_HAVE_double_compare_and_swap_acquire) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_double_compare_and_swap_full) -# define AO_double_compare_and_swap_full(addr, old, new_val) \ - (AO_nop_full(), \ - AO_double_compare_and_swap_acquire(addr, old, new_val)) -# define AO_HAVE_double_compare_and_swap_full -#endif - -#if !defined(AO_HAVE_double_compare_and_swap_release_write) \ - && defined(AO_HAVE_double_compare_and_swap_write) -# define AO_double_compare_and_swap_release_write(addr, old, new_val) \ - AO_double_compare_and_swap_write(addr, old, new_val) -# define AO_HAVE_double_compare_and_swap_release_write -#endif -#if !defined(AO_HAVE_double_compare_and_swap_release_write) \ - && defined(AO_HAVE_double_compare_and_swap_release) -# define AO_double_compare_and_swap_release_write(addr, old, new_val) \ - AO_double_compare_and_swap_release(addr, old, new_val) -# define AO_HAVE_double_compare_and_swap_release_write -#endif -#if !defined(AO_HAVE_double_compare_and_swap_acquire_read) \ - && defined(AO_HAVE_double_compare_and_swap_read) -# define AO_double_compare_and_swap_acquire_read(addr, old, new_val) \ - AO_double_compare_and_swap_read(addr, old, new_val) -# define AO_HAVE_double_compare_and_swap_acquire_read -#endif -#if !defined(AO_HAVE_double_compare_and_swap_acquire_read) \ - && defined(AO_HAVE_double_compare_and_swap_acquire) -# define AO_double_compare_and_swap_acquire_read(addr, old, new_val) \ - AO_double_compare_and_swap_acquire(addr, old, new_val) -# define AO_HAVE_double_compare_and_swap_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_double_compare_and_swap_acquire_read) -# define AO_double_compare_and_swap_dd_acquire_read(addr, old, new_val) \ - AO_double_compare_and_swap_acquire_read(addr, old, new_val) -# define AO_HAVE_double_compare_and_swap_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_double_compare_and_swap) -# define AO_double_compare_and_swap_dd_acquire_read(addr, old, new_val) \ - AO_double_compare_and_swap(addr, old, new_val) -# define AO_HAVE_double_compare_and_swap_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* double_load */ -#if defined(AO_HAVE_double_load_full) && !defined(AO_HAVE_double_load_acquire) -# define AO_double_load_acquire(addr) AO_double_load_full(addr) -# define AO_HAVE_double_load_acquire -#endif - -#if defined(AO_HAVE_double_load_acquire) && !defined(AO_HAVE_double_load) -# define AO_double_load(addr) AO_double_load_acquire(addr) -# define AO_HAVE_double_load -#endif - -#if defined(AO_HAVE_double_load_full) && !defined(AO_HAVE_double_load_read) -# define AO_double_load_read(addr) AO_double_load_full(addr) -# define AO_HAVE_double_load_read -#endif - -#if !defined(AO_HAVE_double_load_acquire_read) \ - && defined(AO_HAVE_double_load_acquire) -# define AO_double_load_acquire_read(addr) AO_double_load_acquire(addr) -# define AO_HAVE_double_load_acquire_read -#endif - -#if defined(AO_HAVE_double_load) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_double_load_acquire) - AO_INLINE AO_double_t - AO_double_load_acquire(const volatile AO_double_t *addr) - { - AO_double_t result = AO_double_load(addr); - - /* Acquire barrier would be useless, since the load could be delayed */ - /* beyond it. */ - AO_nop_full(); - return result; - } -# define AO_HAVE_double_load_acquire -#endif - -#if defined(AO_HAVE_double_load) && defined(AO_HAVE_nop_read) \ - && !defined(AO_HAVE_double_load_read) - AO_INLINE AO_double_t - AO_double_load_read(const volatile AO_double_t *addr) - { - AO_double_t result = AO_double_load(addr); - - AO_nop_read(); - return result; - } -# define AO_HAVE_double_load_read -#endif - -#if defined(AO_HAVE_double_load_acquire) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_double_load_full) -# define AO_double_load_full(addr) (AO_nop_full(), AO_double_load_acquire(addr)) -# define AO_HAVE_double_load_full -#endif - -#if defined(AO_HAVE_double_compare_and_swap_read) \ - && !defined(AO_HAVE_double_load_read) -# define AO_double_CAS_BASED_LOAD_READ - AO_INLINE AO_double_t - AO_double_load_read(const volatile AO_double_t *addr) - { - AO_double_t result; - - do { - result = *(const AO_double_t *)addr; - } while (AO_EXPECT_FALSE(!AO_double_compare_and_swap_read( - (volatile AO_double_t *)addr, - result, result))); - return result; - } -# define AO_HAVE_double_load_read -#endif - -#if !defined(AO_HAVE_double_load_acquire_read) \ - && defined(AO_HAVE_double_load_read) -# define AO_double_load_acquire_read(addr) AO_double_load_read(addr) -# define AO_HAVE_double_load_acquire_read -#endif - -#if defined(AO_HAVE_double_load_acquire_read) && !defined(AO_HAVE_double_load) \ - && (!defined(AO_double_CAS_BASED_LOAD_READ) \ - || !defined(AO_HAVE_double_compare_and_swap)) -# define AO_double_load(addr) AO_double_load_acquire_read(addr) -# define AO_HAVE_double_load -#endif - -#if defined(AO_HAVE_double_compare_and_swap_full) \ - && !defined(AO_HAVE_double_load_full) - AO_INLINE AO_double_t - AO_double_load_full(const volatile AO_double_t *addr) - { - AO_double_t result; - - do { - result = *(const AO_double_t *)addr; - } while (AO_EXPECT_FALSE(!AO_double_compare_and_swap_full( - (volatile AO_double_t *)addr, - result, result))); - return result; - } -# define AO_HAVE_double_load_full -#endif - -#if defined(AO_HAVE_double_compare_and_swap_acquire) \ - && !defined(AO_HAVE_double_load_acquire) - AO_INLINE AO_double_t - AO_double_load_acquire(const volatile AO_double_t *addr) - { - AO_double_t result; - - do { - result = *(const AO_double_t *)addr; - } while (AO_EXPECT_FALSE(!AO_double_compare_and_swap_acquire( - (volatile AO_double_t *)addr, - result, result))); - return result; - } -# define AO_HAVE_double_load_acquire -#endif - -#if defined(AO_HAVE_double_compare_and_swap) && !defined(AO_HAVE_double_load) - AO_INLINE AO_double_t - AO_double_load(const volatile AO_double_t *addr) - { - AO_double_t result; - - do { - result = *(const AO_double_t *)addr; - } while (AO_EXPECT_FALSE(!AO_double_compare_and_swap( - (volatile AO_double_t *)addr, - result, result))); - return result; - } -# define AO_HAVE_double_load -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_double_load_acquire_read) -# define AO_double_load_dd_acquire_read(addr) \ - AO_double_load_acquire_read(addr) -# define AO_HAVE_double_load_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_double_load) -# define AO_double_load_dd_acquire_read(addr) AO_double_load(addr) -# define AO_HAVE_double_load_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* double_store */ -#if defined(AO_HAVE_double_store_full) && !defined(AO_HAVE_double_store_release) -# define AO_double_store_release(addr, val) AO_double_store_full(addr, val) -# define AO_HAVE_double_store_release -#endif - -#if defined(AO_HAVE_double_store_release) && !defined(AO_HAVE_double_store) -# define AO_double_store(addr, val) AO_double_store_release(addr, val) -# define AO_HAVE_double_store -#endif - -#if defined(AO_HAVE_double_store_full) && !defined(AO_HAVE_double_store_write) -# define AO_double_store_write(addr, val) AO_double_store_full(addr, val) -# define AO_HAVE_double_store_write -#endif - -#if defined(AO_HAVE_double_store_release) \ - && !defined(AO_HAVE_double_store_release_write) -# define AO_double_store_release_write(addr, val) \ - AO_double_store_release(addr, val) -# define AO_HAVE_double_store_release_write -#endif - -#if defined(AO_HAVE_double_store_write) && !defined(AO_HAVE_double_store) -# define AO_double_store(addr, val) AO_double_store_write(addr, val) -# define AO_HAVE_double_store -#endif - -#if defined(AO_HAVE_double_store) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_double_store_release) -# define AO_double_store_release(addr, val) \ - (AO_nop_full(), AO_double_store(addr, val)) -# define AO_HAVE_double_store_release -#endif - -#if defined(AO_HAVE_double_store) && defined(AO_HAVE_nop_write) \ - && !defined(AO_HAVE_double_store_write) -# define AO_double_store_write(addr, val) \ - (AO_nop_write(), AO_double_store(addr, val)) -# define AO_HAVE_double_store_write -#endif - -#if defined(AO_HAVE_double_compare_and_swap_write) \ - && !defined(AO_HAVE_double_store_write) - AO_INLINE void - AO_double_store_write(volatile AO_double_t *addr, AO_double_t new_val) - { - AO_double_t old_val; - - do { - old_val = *(AO_double_t *)addr; - } while (AO_EXPECT_FALSE(!AO_double_compare_and_swap_write(addr, old_val, - new_val))); - } -# define AO_HAVE_double_store_write -#endif - -#if defined(AO_HAVE_double_store_write) \ - && !defined(AO_HAVE_double_store_release_write) -# define AO_double_store_release_write(addr, val) \ - AO_double_store_write(addr, val) -# define AO_HAVE_double_store_release_write -#endif - -#if defined(AO_HAVE_double_store_release) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_double_store_full) -# define AO_double_store_full(addr, val) \ - (AO_double_store_release(addr, val), \ - AO_nop_full()) -# define AO_HAVE_double_store_full -#endif - -#if defined(AO_HAVE_double_compare_and_swap) && !defined(AO_HAVE_double_store) - AO_INLINE void - AO_double_store(volatile AO_double_t *addr, AO_double_t new_val) - { - AO_double_t old_val; - - do { - old_val = *(AO_double_t *)addr; - } while (AO_EXPECT_FALSE(!AO_double_compare_and_swap(addr, - old_val, new_val))); - } -# define AO_HAVE_double_store -#endif - -#if defined(AO_HAVE_double_compare_and_swap_release) \ - && !defined(AO_HAVE_double_store_release) - AO_INLINE void - AO_double_store_release(volatile AO_double_t *addr, AO_double_t new_val) - { - AO_double_t old_val; - - do { - old_val = *(AO_double_t *)addr; - } while (AO_EXPECT_FALSE(!AO_double_compare_and_swap_release(addr, old_val, - new_val))); - } -# define AO_HAVE_double_store_release -#endif - -#if defined(AO_HAVE_double_compare_and_swap_full) \ - && !defined(AO_HAVE_double_store_full) - AO_INLINE void - AO_double_store_full(volatile AO_double_t *addr, AO_double_t new_val) - { - AO_double_t old_val; - - do { - old_val = *(AO_double_t *)addr; - } while (AO_EXPECT_FALSE(!AO_double_compare_and_swap_full(addr, old_val, - new_val))); - } -# define AO_HAVE_double_store_full -#endif diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/generalize-small.template ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/generalize-small.template --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/generalize-small.template 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/generalize-small.template 1970-01-01 00:00:00.000000000 +0000 @@ -1,520 +0,0 @@ -/* - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* XSIZE_fetch_compare_and_swap */ -#if defined(AO_HAVE_XSIZE_fetch_compare_and_swap) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_XSIZE_fetch_compare_and_swap_acquire) - AO_INLINE XCTYPE - AO_XSIZE_fetch_compare_and_swap_acquire(volatile XCTYPE *addr, - XCTYPE old_val, XCTYPE new_val) - { - XCTYPE result = AO_XSIZE_fetch_compare_and_swap(addr, old_val, new_val); - AO_nop_full(); - return result; - } -# define AO_HAVE_XSIZE_fetch_compare_and_swap_acquire -#endif -#if defined(AO_HAVE_XSIZE_fetch_compare_and_swap) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_XSIZE_fetch_compare_and_swap_release) -# define AO_XSIZE_fetch_compare_and_swap_release(addr, old_val, new_val) \ - (AO_nop_full(), \ - AO_XSIZE_fetch_compare_and_swap(addr, old_val, new_val)) -# define AO_HAVE_XSIZE_fetch_compare_and_swap_release -#endif -#if defined(AO_HAVE_XSIZE_fetch_compare_and_swap_full) -# if !defined(AO_HAVE_XSIZE_fetch_compare_and_swap_release) -# define AO_XSIZE_fetch_compare_and_swap_release(addr, old_val, new_val) \ - AO_XSIZE_fetch_compare_and_swap_full(addr, old_val, new_val) -# define AO_HAVE_XSIZE_fetch_compare_and_swap_release -# endif -# if !defined(AO_HAVE_XSIZE_fetch_compare_and_swap_acquire) -# define AO_XSIZE_fetch_compare_and_swap_acquire(addr, old_val, new_val) \ - AO_XSIZE_fetch_compare_and_swap_full(addr, old_val, new_val) -# define AO_HAVE_XSIZE_fetch_compare_and_swap_acquire -# endif -# if !defined(AO_HAVE_XSIZE_fetch_compare_and_swap_write) -# define AO_XSIZE_fetch_compare_and_swap_write(addr, old_val, new_val) \ - AO_XSIZE_fetch_compare_and_swap_full(addr, old_val, new_val) -# define AO_HAVE_XSIZE_fetch_compare_and_swap_write -# endif -# if !defined(AO_HAVE_XSIZE_fetch_compare_and_swap_read) -# define AO_XSIZE_fetch_compare_and_swap_read(addr, old_val, new_val) \ - AO_XSIZE_fetch_compare_and_swap_full(addr, old_val, new_val) -# define AO_HAVE_XSIZE_fetch_compare_and_swap_read -# endif -#endif /* AO_HAVE_XSIZE_fetch_compare_and_swap_full */ - -#if !defined(AO_HAVE_XSIZE_fetch_compare_and_swap) \ - && defined(AO_HAVE_XSIZE_fetch_compare_and_swap_release) -# define AO_XSIZE_fetch_compare_and_swap(addr, old_val, new_val) \ - AO_XSIZE_fetch_compare_and_swap_release(addr, old_val, new_val) -# define AO_HAVE_XSIZE_fetch_compare_and_swap -#endif -#if !defined(AO_HAVE_XSIZE_fetch_compare_and_swap) \ - && defined(AO_HAVE_XSIZE_fetch_compare_and_swap_acquire) -# define AO_XSIZE_fetch_compare_and_swap(addr, old_val, new_val) \ - AO_XSIZE_fetch_compare_and_swap_acquire(addr, old_val, new_val) -# define AO_HAVE_XSIZE_fetch_compare_and_swap -#endif -#if !defined(AO_HAVE_XSIZE_fetch_compare_and_swap) \ - && defined(AO_HAVE_XSIZE_fetch_compare_and_swap_write) -# define AO_XSIZE_fetch_compare_and_swap(addr, old_val, new_val) \ - AO_XSIZE_fetch_compare_and_swap_write(addr, old_val, new_val) -# define AO_HAVE_XSIZE_fetch_compare_and_swap -#endif -#if !defined(AO_HAVE_XSIZE_fetch_compare_and_swap) \ - && defined(AO_HAVE_XSIZE_fetch_compare_and_swap_read) -# define AO_XSIZE_fetch_compare_and_swap(addr, old_val, new_val) \ - AO_XSIZE_fetch_compare_and_swap_read(addr, old_val, new_val) -# define AO_HAVE_XSIZE_fetch_compare_and_swap -#endif - -#if defined(AO_HAVE_XSIZE_fetch_compare_and_swap_acquire) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_XSIZE_fetch_compare_and_swap_full) -# define AO_XSIZE_fetch_compare_and_swap_full(addr, old_val, new_val) \ - (AO_nop_full(), \ - AO_XSIZE_fetch_compare_and_swap_acquire(addr, old_val, new_val)) -# define AO_HAVE_XSIZE_fetch_compare_and_swap_full -#endif - -#if !defined(AO_HAVE_XSIZE_fetch_compare_and_swap_release_write) \ - && defined(AO_HAVE_XSIZE_fetch_compare_and_swap_write) -# define AO_XSIZE_fetch_compare_and_swap_release_write(addr,old_val,new_val) \ - AO_XSIZE_fetch_compare_and_swap_write(addr, old_val, new_val) -# define AO_HAVE_XSIZE_fetch_compare_and_swap_release_write -#endif -#if !defined(AO_HAVE_XSIZE_fetch_compare_and_swap_release_write) \ - && defined(AO_HAVE_XSIZE_fetch_compare_and_swap_release) -# define AO_XSIZE_fetch_compare_and_swap_release_write(addr,old_val,new_val) \ - AO_XSIZE_fetch_compare_and_swap_release(addr, old_val, new_val) -# define AO_HAVE_XSIZE_fetch_compare_and_swap_release_write -#endif -#if !defined(AO_HAVE_XSIZE_fetch_compare_and_swap_acquire_read) \ - && defined(AO_HAVE_XSIZE_fetch_compare_and_swap_read) -# define AO_XSIZE_fetch_compare_and_swap_acquire_read(addr,old_val,new_val) \ - AO_XSIZE_fetch_compare_and_swap_read(addr, old_val, new_val) -# define AO_HAVE_XSIZE_fetch_compare_and_swap_acquire_read -#endif -#if !defined(AO_HAVE_XSIZE_fetch_compare_and_swap_acquire_read) \ - && defined(AO_HAVE_XSIZE_fetch_compare_and_swap_acquire) -# define AO_XSIZE_fetch_compare_and_swap_acquire_read(addr,old_val,new_val) \ - AO_XSIZE_fetch_compare_and_swap_acquire(addr, old_val, new_val) -# define AO_HAVE_XSIZE_fetch_compare_and_swap_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_XSIZE_fetch_compare_and_swap_acquire_read) -# define AO_XSIZE_fetch_compare_and_swap_dd_acquire_read(addr,old_val,new_val) \ - AO_XSIZE_fetch_compare_and_swap_acquire_read(addr, old_val, new_val) -# define AO_HAVE_XSIZE_fetch_compare_and_swap_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_XSIZE_fetch_compare_and_swap) -# define AO_XSIZE_fetch_compare_and_swap_dd_acquire_read(addr,old_val,new_val) \ - AO_XSIZE_fetch_compare_and_swap(addr, old_val, new_val) -# define AO_HAVE_XSIZE_fetch_compare_and_swap_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* XSIZE_compare_and_swap */ -#if defined(AO_HAVE_XSIZE_compare_and_swap) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_XSIZE_compare_and_swap_acquire) - AO_INLINE int - AO_XSIZE_compare_and_swap_acquire(volatile XCTYPE *addr, XCTYPE old, - XCTYPE new_val) - { - int result = AO_XSIZE_compare_and_swap(addr, old, new_val); - AO_nop_full(); - return result; - } -# define AO_HAVE_XSIZE_compare_and_swap_acquire -#endif -#if defined(AO_HAVE_XSIZE_compare_and_swap) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_XSIZE_compare_and_swap_release) -# define AO_XSIZE_compare_and_swap_release(addr, old, new_val) \ - (AO_nop_full(), AO_XSIZE_compare_and_swap(addr, old, new_val)) -# define AO_HAVE_XSIZE_compare_and_swap_release -#endif -#if defined(AO_HAVE_XSIZE_compare_and_swap_full) -# if !defined(AO_HAVE_XSIZE_compare_and_swap_release) -# define AO_XSIZE_compare_and_swap_release(addr, old, new_val) \ - AO_XSIZE_compare_and_swap_full(addr, old, new_val) -# define AO_HAVE_XSIZE_compare_and_swap_release -# endif -# if !defined(AO_HAVE_XSIZE_compare_and_swap_acquire) -# define AO_XSIZE_compare_and_swap_acquire(addr, old, new_val) \ - AO_XSIZE_compare_and_swap_full(addr, old, new_val) -# define AO_HAVE_XSIZE_compare_and_swap_acquire -# endif -# if !defined(AO_HAVE_XSIZE_compare_and_swap_write) -# define AO_XSIZE_compare_and_swap_write(addr, old, new_val) \ - AO_XSIZE_compare_and_swap_full(addr, old, new_val) -# define AO_HAVE_XSIZE_compare_and_swap_write -# endif -# if !defined(AO_HAVE_XSIZE_compare_and_swap_read) -# define AO_XSIZE_compare_and_swap_read(addr, old, new_val) \ - AO_XSIZE_compare_and_swap_full(addr, old, new_val) -# define AO_HAVE_XSIZE_compare_and_swap_read -# endif -#endif /* AO_HAVE_XSIZE_compare_and_swap_full */ - -#if !defined(AO_HAVE_XSIZE_compare_and_swap) \ - && defined(AO_HAVE_XSIZE_compare_and_swap_release) -# define AO_XSIZE_compare_and_swap(addr, old, new_val) \ - AO_XSIZE_compare_and_swap_release(addr, old, new_val) -# define AO_HAVE_XSIZE_compare_and_swap -#endif -#if !defined(AO_HAVE_XSIZE_compare_and_swap) \ - && defined(AO_HAVE_XSIZE_compare_and_swap_acquire) -# define AO_XSIZE_compare_and_swap(addr, old, new_val) \ - AO_XSIZE_compare_and_swap_acquire(addr, old, new_val) -# define AO_HAVE_XSIZE_compare_and_swap -#endif -#if !defined(AO_HAVE_XSIZE_compare_and_swap) \ - && defined(AO_HAVE_XSIZE_compare_and_swap_write) -# define AO_XSIZE_compare_and_swap(addr, old, new_val) \ - AO_XSIZE_compare_and_swap_write(addr, old, new_val) -# define AO_HAVE_XSIZE_compare_and_swap -#endif -#if !defined(AO_HAVE_XSIZE_compare_and_swap) \ - && defined(AO_HAVE_XSIZE_compare_and_swap_read) -# define AO_XSIZE_compare_and_swap(addr, old, new_val) \ - AO_XSIZE_compare_and_swap_read(addr, old, new_val) -# define AO_HAVE_XSIZE_compare_and_swap -#endif - -#if defined(AO_HAVE_XSIZE_compare_and_swap_acquire) \ - && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_XSIZE_compare_and_swap_full) -# define AO_XSIZE_compare_and_swap_full(addr, old, new_val) \ - (AO_nop_full(), \ - AO_XSIZE_compare_and_swap_acquire(addr, old, new_val)) -# define AO_HAVE_XSIZE_compare_and_swap_full -#endif - -#if !defined(AO_HAVE_XSIZE_compare_and_swap_release_write) \ - && defined(AO_HAVE_XSIZE_compare_and_swap_write) -# define AO_XSIZE_compare_and_swap_release_write(addr, old, new_val) \ - AO_XSIZE_compare_and_swap_write(addr, old, new_val) -# define AO_HAVE_XSIZE_compare_and_swap_release_write -#endif -#if !defined(AO_HAVE_XSIZE_compare_and_swap_release_write) \ - && defined(AO_HAVE_XSIZE_compare_and_swap_release) -# define AO_XSIZE_compare_and_swap_release_write(addr, old, new_val) \ - AO_XSIZE_compare_and_swap_release(addr, old, new_val) -# define AO_HAVE_XSIZE_compare_and_swap_release_write -#endif -#if !defined(AO_HAVE_XSIZE_compare_and_swap_acquire_read) \ - && defined(AO_HAVE_XSIZE_compare_and_swap_read) -# define AO_XSIZE_compare_and_swap_acquire_read(addr, old, new_val) \ - AO_XSIZE_compare_and_swap_read(addr, old, new_val) -# define AO_HAVE_XSIZE_compare_and_swap_acquire_read -#endif -#if !defined(AO_HAVE_XSIZE_compare_and_swap_acquire_read) \ - && defined(AO_HAVE_XSIZE_compare_and_swap_acquire) -# define AO_XSIZE_compare_and_swap_acquire_read(addr, old, new_val) \ - AO_XSIZE_compare_and_swap_acquire(addr, old, new_val) -# define AO_HAVE_XSIZE_compare_and_swap_acquire_read -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_XSIZE_compare_and_swap_acquire_read) -# define AO_XSIZE_compare_and_swap_dd_acquire_read(addr, old, new_val) \ - AO_XSIZE_compare_and_swap_acquire_read(addr, old, new_val) -# define AO_HAVE_XSIZE_compare_and_swap_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_XSIZE_compare_and_swap) -# define AO_XSIZE_compare_and_swap_dd_acquire_read(addr, old, new_val) \ - AO_XSIZE_compare_and_swap(addr, old, new_val) -# define AO_HAVE_XSIZE_compare_and_swap_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* XSIZE_load */ -#if defined(AO_HAVE_XSIZE_load_full) && !defined(AO_HAVE_XSIZE_load_acquire) -# define AO_XSIZE_load_acquire(addr) AO_XSIZE_load_full(addr) -# define AO_HAVE_XSIZE_load_acquire -#endif - -#if defined(AO_HAVE_XSIZE_load_acquire) && !defined(AO_HAVE_XSIZE_load) -# define AO_XSIZE_load(addr) AO_XSIZE_load_acquire(addr) -# define AO_HAVE_XSIZE_load -#endif - -#if defined(AO_HAVE_XSIZE_load_full) && !defined(AO_HAVE_XSIZE_load_read) -# define AO_XSIZE_load_read(addr) AO_XSIZE_load_full(addr) -# define AO_HAVE_XSIZE_load_read -#endif - -#if !defined(AO_HAVE_XSIZE_load_acquire_read) \ - && defined(AO_HAVE_XSIZE_load_acquire) -# define AO_XSIZE_load_acquire_read(addr) AO_XSIZE_load_acquire(addr) -# define AO_HAVE_XSIZE_load_acquire_read -#endif - -#if defined(AO_HAVE_XSIZE_load) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_XSIZE_load_acquire) - AO_INLINE XCTYPE - AO_XSIZE_load_acquire(const volatile XCTYPE *addr) - { - XCTYPE result = AO_XSIZE_load(addr); - - /* Acquire barrier would be useless, since the load could be delayed */ - /* beyond it. */ - AO_nop_full(); - return result; - } -# define AO_HAVE_XSIZE_load_acquire -#endif - -#if defined(AO_HAVE_XSIZE_load) && defined(AO_HAVE_nop_read) \ - && !defined(AO_HAVE_XSIZE_load_read) - AO_INLINE XCTYPE - AO_XSIZE_load_read(const volatile XCTYPE *addr) - { - XCTYPE result = AO_XSIZE_load(addr); - - AO_nop_read(); - return result; - } -# define AO_HAVE_XSIZE_load_read -#endif - -#if defined(AO_HAVE_XSIZE_load_acquire) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_XSIZE_load_full) -# define AO_XSIZE_load_full(addr) (AO_nop_full(), AO_XSIZE_load_acquire(addr)) -# define AO_HAVE_XSIZE_load_full -#endif - -#if defined(AO_HAVE_XSIZE_compare_and_swap_read) \ - && !defined(AO_HAVE_XSIZE_load_read) -# define AO_XSIZE_CAS_BASED_LOAD_READ - AO_INLINE XCTYPE - AO_XSIZE_load_read(const volatile XCTYPE *addr) - { - XCTYPE result; - - do { - result = *(const XCTYPE *)addr; - } while (AO_EXPECT_FALSE(!AO_XSIZE_compare_and_swap_read( - (volatile XCTYPE *)addr, - result, result))); - return result; - } -# define AO_HAVE_XSIZE_load_read -#endif - -#if !defined(AO_HAVE_XSIZE_load_acquire_read) \ - && defined(AO_HAVE_XSIZE_load_read) -# define AO_XSIZE_load_acquire_read(addr) AO_XSIZE_load_read(addr) -# define AO_HAVE_XSIZE_load_acquire_read -#endif - -#if defined(AO_HAVE_XSIZE_load_acquire_read) && !defined(AO_HAVE_XSIZE_load) \ - && (!defined(AO_XSIZE_CAS_BASED_LOAD_READ) \ - || !defined(AO_HAVE_XSIZE_compare_and_swap)) -# define AO_XSIZE_load(addr) AO_XSIZE_load_acquire_read(addr) -# define AO_HAVE_XSIZE_load -#endif - -#if defined(AO_HAVE_XSIZE_compare_and_swap_full) \ - && !defined(AO_HAVE_XSIZE_load_full) - AO_INLINE XCTYPE - AO_XSIZE_load_full(const volatile XCTYPE *addr) - { - XCTYPE result; - - do { - result = *(const XCTYPE *)addr; - } while (AO_EXPECT_FALSE(!AO_XSIZE_compare_and_swap_full( - (volatile XCTYPE *)addr, - result, result))); - return result; - } -# define AO_HAVE_XSIZE_load_full -#endif - -#if defined(AO_HAVE_XSIZE_compare_and_swap_acquire) \ - && !defined(AO_HAVE_XSIZE_load_acquire) - AO_INLINE XCTYPE - AO_XSIZE_load_acquire(const volatile XCTYPE *addr) - { - XCTYPE result; - - do { - result = *(const XCTYPE *)addr; - } while (AO_EXPECT_FALSE(!AO_XSIZE_compare_and_swap_acquire( - (volatile XCTYPE *)addr, - result, result))); - return result; - } -# define AO_HAVE_XSIZE_load_acquire -#endif - -#if defined(AO_HAVE_XSIZE_compare_and_swap) && !defined(AO_HAVE_XSIZE_load) - AO_INLINE XCTYPE - AO_XSIZE_load(const volatile XCTYPE *addr) - { - XCTYPE result; - - do { - result = *(const XCTYPE *)addr; - } while (AO_EXPECT_FALSE(!AO_XSIZE_compare_and_swap( - (volatile XCTYPE *)addr, - result, result))); - return result; - } -# define AO_HAVE_XSIZE_load -#endif - -#ifdef AO_NO_DD_ORDERING -# if defined(AO_HAVE_XSIZE_load_acquire_read) -# define AO_XSIZE_load_dd_acquire_read(addr) \ - AO_XSIZE_load_acquire_read(addr) -# define AO_HAVE_XSIZE_load_dd_acquire_read -# endif -#else -# if defined(AO_HAVE_XSIZE_load) -# define AO_XSIZE_load_dd_acquire_read(addr) AO_XSIZE_load(addr) -# define AO_HAVE_XSIZE_load_dd_acquire_read -# endif -#endif /* !AO_NO_DD_ORDERING */ - -/* XSIZE_store */ -#if defined(AO_HAVE_XSIZE_store_full) && !defined(AO_HAVE_XSIZE_store_release) -# define AO_XSIZE_store_release(addr, val) AO_XSIZE_store_full(addr, val) -# define AO_HAVE_XSIZE_store_release -#endif - -#if defined(AO_HAVE_XSIZE_store_release) && !defined(AO_HAVE_XSIZE_store) -# define AO_XSIZE_store(addr, val) AO_XSIZE_store_release(addr, val) -# define AO_HAVE_XSIZE_store -#endif - -#if defined(AO_HAVE_XSIZE_store_full) && !defined(AO_HAVE_XSIZE_store_write) -# define AO_XSIZE_store_write(addr, val) AO_XSIZE_store_full(addr, val) -# define AO_HAVE_XSIZE_store_write -#endif - -#if defined(AO_HAVE_XSIZE_store_release) \ - && !defined(AO_HAVE_XSIZE_store_release_write) -# define AO_XSIZE_store_release_write(addr, val) \ - AO_XSIZE_store_release(addr, val) -# define AO_HAVE_XSIZE_store_release_write -#endif - -#if defined(AO_HAVE_XSIZE_store_write) && !defined(AO_HAVE_XSIZE_store) -# define AO_XSIZE_store(addr, val) AO_XSIZE_store_write(addr, val) -# define AO_HAVE_XSIZE_store -#endif - -#if defined(AO_HAVE_XSIZE_store) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_XSIZE_store_release) -# define AO_XSIZE_store_release(addr, val) \ - (AO_nop_full(), AO_XSIZE_store(addr, val)) -# define AO_HAVE_XSIZE_store_release -#endif - -#if defined(AO_HAVE_XSIZE_store) && defined(AO_HAVE_nop_write) \ - && !defined(AO_HAVE_XSIZE_store_write) -# define AO_XSIZE_store_write(addr, val) \ - (AO_nop_write(), AO_XSIZE_store(addr, val)) -# define AO_HAVE_XSIZE_store_write -#endif - -#if defined(AO_HAVE_XSIZE_compare_and_swap_write) \ - && !defined(AO_HAVE_XSIZE_store_write) - AO_INLINE void - AO_XSIZE_store_write(volatile XCTYPE *addr, XCTYPE new_val) - { - XCTYPE old_val; - - do { - old_val = *(XCTYPE *)addr; - } while (AO_EXPECT_FALSE(!AO_XSIZE_compare_and_swap_write(addr, old_val, - new_val))); - } -# define AO_HAVE_XSIZE_store_write -#endif - -#if defined(AO_HAVE_XSIZE_store_write) \ - && !defined(AO_HAVE_XSIZE_store_release_write) -# define AO_XSIZE_store_release_write(addr, val) \ - AO_XSIZE_store_write(addr, val) -# define AO_HAVE_XSIZE_store_release_write -#endif - -#if defined(AO_HAVE_XSIZE_store_release) && defined(AO_HAVE_nop_full) \ - && !defined(AO_HAVE_XSIZE_store_full) -# define AO_XSIZE_store_full(addr, val) \ - (AO_XSIZE_store_release(addr, val), \ - AO_nop_full()) -# define AO_HAVE_XSIZE_store_full -#endif - -#if defined(AO_HAVE_XSIZE_compare_and_swap) && !defined(AO_HAVE_XSIZE_store) - AO_INLINE void - AO_XSIZE_store(volatile XCTYPE *addr, XCTYPE new_val) - { - XCTYPE old_val; - - do { - old_val = *(XCTYPE *)addr; - } while (AO_EXPECT_FALSE(!AO_XSIZE_compare_and_swap(addr, - old_val, new_val))); - } -# define AO_HAVE_XSIZE_store -#endif - -#if defined(AO_HAVE_XSIZE_compare_and_swap_release) \ - && !defined(AO_HAVE_XSIZE_store_release) - AO_INLINE void - AO_XSIZE_store_release(volatile XCTYPE *addr, XCTYPE new_val) - { - XCTYPE old_val; - - do { - old_val = *(XCTYPE *)addr; - } while (AO_EXPECT_FALSE(!AO_XSIZE_compare_and_swap_release(addr, old_val, - new_val))); - } -# define AO_HAVE_XSIZE_store_release -#endif - -#if defined(AO_HAVE_XSIZE_compare_and_swap_full) \ - && !defined(AO_HAVE_XSIZE_store_full) - AO_INLINE void - AO_XSIZE_store_full(volatile XCTYPE *addr, XCTYPE new_val) - { - XCTYPE old_val; - - do { - old_val = *(XCTYPE *)addr; - } while (AO_EXPECT_FALSE(!AO_XSIZE_compare_and_swap_full(addr, old_val, - new_val))); - } -# define AO_HAVE_XSIZE_store_full -#endif diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/all_acquire_release_volatile.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/all_acquire_release_volatile.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/all_acquire_release_volatile.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/all_acquire_release_volatile.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,30 +0,0 @@ -/* - * Copyright (c) 2004 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* Describes architectures on which volatile AO_t, unsigned char, */ -/* unsigned short, and unsigned int loads and stores have */ -/* acquire/release semantics for all normally legal alignments. */ - -#include "loadstore/acquire_release_volatile.h" -#include "loadstore/char_acquire_release_volatile.h" -#include "loadstore/short_acquire_release_volatile.h" -#include "loadstore/int_acquire_release_volatile.h" diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/all_aligned_atomic_load_store.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/all_aligned_atomic_load_store.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/all_aligned_atomic_load_store.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/all_aligned_atomic_load_store.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,31 +0,0 @@ -/* - * Copyright (c) 2004 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* Describes architectures on which AO_t, unsigned char, unsigned */ -/* short, and unsigned int loads and stores are atomic but only if data */ -/* is suitably aligned. */ - -#define AO_ACCESS_CHECK_ALIGNED -/* Check for char type is a misnomer. */ -#define AO_ACCESS_short_CHECK_ALIGNED -#define AO_ACCESS_int_CHECK_ALIGNED -#include "all_atomic_load_store.h" diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/all_atomic_load_store.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/all_atomic_load_store.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/all_atomic_load_store.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/all_atomic_load_store.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -/* - * Copyright (c) 2004 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* Describes architectures on which AO_t, unsigned char, unsigned */ -/* short, and unsigned int loads and stores are atomic for all normally */ -/* legal alignments. */ - -#include "all_atomic_only_load.h" - -#include "loadstore/atomic_store.h" -#include "loadstore/char_atomic_store.h" -#include "loadstore/short_atomic_store.h" -#include "loadstore/int_atomic_store.h" diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/all_atomic_only_load.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/all_atomic_only_load.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/all_atomic_only_load.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/all_atomic_only_load.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,30 +0,0 @@ -/* - * Copyright (c) 2004 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* Describes architectures on which AO_t, unsigned char, unsigned */ -/* short, and unsigned int loads are atomic for all normally legal */ -/* alignments. */ - -#include "loadstore/atomic_load.h" -#include "loadstore/char_atomic_load.h" -#include "loadstore/short_atomic_load.h" -#include "loadstore/int_atomic_load.h" diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/ao_t_is_int.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/ao_t_is_int.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/ao_t_is_int.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/ao_t_is_int.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,552 +0,0 @@ -/* - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* Inclusion of this file signifies that AO_t is in fact int. */ -/* Hence any AO_... operation can also serve as AO_int_... operation. */ - -#if defined(AO_HAVE_load) && !defined(AO_HAVE_int_load) -# define AO_int_load(addr) \ - (unsigned)AO_load((const volatile AO_t *)(addr)) -# define AO_HAVE_int_load -#endif - -#if defined(AO_HAVE_store) && !defined(AO_HAVE_int_store) -# define AO_int_store(addr, val) \ - AO_store((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_store -#endif - -#if defined(AO_HAVE_fetch_and_add) \ - && !defined(AO_HAVE_int_fetch_and_add) -# define AO_int_fetch_and_add(addr, incr) \ - (unsigned)AO_fetch_and_add((volatile AO_t *)(addr), \ - (AO_t)(incr)) -# define AO_HAVE_int_fetch_and_add -#endif - -#if defined(AO_HAVE_fetch_and_add1) \ - && !defined(AO_HAVE_int_fetch_and_add1) -# define AO_int_fetch_and_add1(addr) \ - (unsigned)AO_fetch_and_add1((volatile AO_t *)(addr)) -# define AO_HAVE_int_fetch_and_add1 -#endif - -#if defined(AO_HAVE_fetch_and_sub1) \ - && !defined(AO_HAVE_int_fetch_and_sub1) -# define AO_int_fetch_and_sub1(addr) \ - (unsigned)AO_fetch_and_sub1((volatile AO_t *)(addr)) -# define AO_HAVE_int_fetch_and_sub1 -#endif - -#if defined(AO_HAVE_and) && !defined(AO_HAVE_int_and) -# define AO_int_and(addr, val) \ - AO_and((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_and -#endif - -#if defined(AO_HAVE_or) && !defined(AO_HAVE_int_or) -# define AO_int_or(addr, val) \ - AO_or((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_or -#endif - -#if defined(AO_HAVE_xor) && !defined(AO_HAVE_int_xor) -# define AO_int_xor(addr, val) \ - AO_xor((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_xor -#endif - -#if defined(AO_HAVE_fetch_compare_and_swap) \ - && !defined(AO_HAVE_int_fetch_compare_and_swap) -# define AO_int_fetch_compare_and_swap(addr, old, new_val) \ - (unsigned)AO_fetch_compare_and_swap((volatile AO_t *)(addr), \ - (AO_t)(old), (AO_t)(new_val)) -# define AO_HAVE_int_fetch_compare_and_swap -#endif - -#if defined(AO_HAVE_compare_and_swap) \ - && !defined(AO_HAVE_int_compare_and_swap) -# define AO_int_compare_and_swap(addr, old, new_val) \ - AO_compare_and_swap((volatile AO_t *)(addr), \ - (AO_t)(old), (AO_t)(new_val)) -# define AO_HAVE_int_compare_and_swap -#endif -/* - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* Inclusion of this file signifies that AO_t is in fact int. */ -/* Hence any AO_... operation can also serve as AO_int_... operation. */ - -#if defined(AO_HAVE_load_full) && !defined(AO_HAVE_int_load_full) -# define AO_int_load_full(addr) \ - (unsigned)AO_load_full((const volatile AO_t *)(addr)) -# define AO_HAVE_int_load_full -#endif - -#if defined(AO_HAVE_store_full) && !defined(AO_HAVE_int_store_full) -# define AO_int_store_full(addr, val) \ - AO_store_full((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_store_full -#endif - -#if defined(AO_HAVE_fetch_and_add_full) \ - && !defined(AO_HAVE_int_fetch_and_add_full) -# define AO_int_fetch_and_add_full(addr, incr) \ - (unsigned)AO_fetch_and_add_full((volatile AO_t *)(addr), \ - (AO_t)(incr)) -# define AO_HAVE_int_fetch_and_add_full -#endif - -#if defined(AO_HAVE_fetch_and_add1_full) \ - && !defined(AO_HAVE_int_fetch_and_add1_full) -# define AO_int_fetch_and_add1_full(addr) \ - (unsigned)AO_fetch_and_add1_full((volatile AO_t *)(addr)) -# define AO_HAVE_int_fetch_and_add1_full -#endif - -#if defined(AO_HAVE_fetch_and_sub1_full) \ - && !defined(AO_HAVE_int_fetch_and_sub1_full) -# define AO_int_fetch_and_sub1_full(addr) \ - (unsigned)AO_fetch_and_sub1_full((volatile AO_t *)(addr)) -# define AO_HAVE_int_fetch_and_sub1_full -#endif - -#if defined(AO_HAVE_and_full) && !defined(AO_HAVE_int_and_full) -# define AO_int_and_full(addr, val) \ - AO_and_full((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_and_full -#endif - -#if defined(AO_HAVE_or_full) && !defined(AO_HAVE_int_or_full) -# define AO_int_or_full(addr, val) \ - AO_or_full((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_or_full -#endif - -#if defined(AO_HAVE_xor_full) && !defined(AO_HAVE_int_xor_full) -# define AO_int_xor_full(addr, val) \ - AO_xor_full((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_xor_full -#endif - -#if defined(AO_HAVE_fetch_compare_and_swap_full) \ - && !defined(AO_HAVE_int_fetch_compare_and_swap_full) -# define AO_int_fetch_compare_and_swap_full(addr, old, new_val) \ - (unsigned)AO_fetch_compare_and_swap_full((volatile AO_t *)(addr), \ - (AO_t)(old), (AO_t)(new_val)) -# define AO_HAVE_int_fetch_compare_and_swap_full -#endif - -#if defined(AO_HAVE_compare_and_swap_full) \ - && !defined(AO_HAVE_int_compare_and_swap_full) -# define AO_int_compare_and_swap_full(addr, old, new_val) \ - AO_compare_and_swap_full((volatile AO_t *)(addr), \ - (AO_t)(old), (AO_t)(new_val)) -# define AO_HAVE_int_compare_and_swap_full -#endif -/* - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* Inclusion of this file signifies that AO_t is in fact int. */ -/* Hence any AO_... operation can also serve as AO_int_... operation. */ - -#if defined(AO_HAVE_load_acquire) && !defined(AO_HAVE_int_load_acquire) -# define AO_int_load_acquire(addr) \ - (unsigned)AO_load_acquire((const volatile AO_t *)(addr)) -# define AO_HAVE_int_load_acquire -#endif - -#if defined(AO_HAVE_store_acquire) && !defined(AO_HAVE_int_store_acquire) -# define AO_int_store_acquire(addr, val) \ - AO_store_acquire((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_store_acquire -#endif - -#if defined(AO_HAVE_fetch_and_add_acquire) \ - && !defined(AO_HAVE_int_fetch_and_add_acquire) -# define AO_int_fetch_and_add_acquire(addr, incr) \ - (unsigned)AO_fetch_and_add_acquire((volatile AO_t *)(addr), \ - (AO_t)(incr)) -# define AO_HAVE_int_fetch_and_add_acquire -#endif - -#if defined(AO_HAVE_fetch_and_add1_acquire) \ - && !defined(AO_HAVE_int_fetch_and_add1_acquire) -# define AO_int_fetch_and_add1_acquire(addr) \ - (unsigned)AO_fetch_and_add1_acquire((volatile AO_t *)(addr)) -# define AO_HAVE_int_fetch_and_add1_acquire -#endif - -#if defined(AO_HAVE_fetch_and_sub1_acquire) \ - && !defined(AO_HAVE_int_fetch_and_sub1_acquire) -# define AO_int_fetch_and_sub1_acquire(addr) \ - (unsigned)AO_fetch_and_sub1_acquire((volatile AO_t *)(addr)) -# define AO_HAVE_int_fetch_and_sub1_acquire -#endif - -#if defined(AO_HAVE_and_acquire) && !defined(AO_HAVE_int_and_acquire) -# define AO_int_and_acquire(addr, val) \ - AO_and_acquire((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_and_acquire -#endif - -#if defined(AO_HAVE_or_acquire) && !defined(AO_HAVE_int_or_acquire) -# define AO_int_or_acquire(addr, val) \ - AO_or_acquire((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_or_acquire -#endif - -#if defined(AO_HAVE_xor_acquire) && !defined(AO_HAVE_int_xor_acquire) -# define AO_int_xor_acquire(addr, val) \ - AO_xor_acquire((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_xor_acquire -#endif - -#if defined(AO_HAVE_fetch_compare_and_swap_acquire) \ - && !defined(AO_HAVE_int_fetch_compare_and_swap_acquire) -# define AO_int_fetch_compare_and_swap_acquire(addr, old, new_val) \ - (unsigned)AO_fetch_compare_and_swap_acquire((volatile AO_t *)(addr), \ - (AO_t)(old), (AO_t)(new_val)) -# define AO_HAVE_int_fetch_compare_and_swap_acquire -#endif - -#if defined(AO_HAVE_compare_and_swap_acquire) \ - && !defined(AO_HAVE_int_compare_and_swap_acquire) -# define AO_int_compare_and_swap_acquire(addr, old, new_val) \ - AO_compare_and_swap_acquire((volatile AO_t *)(addr), \ - (AO_t)(old), (AO_t)(new_val)) -# define AO_HAVE_int_compare_and_swap_acquire -#endif -/* - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* Inclusion of this file signifies that AO_t is in fact int. */ -/* Hence any AO_... operation can also serve as AO_int_... operation. */ - -#if defined(AO_HAVE_load_release) && !defined(AO_HAVE_int_load_release) -# define AO_int_load_release(addr) \ - (unsigned)AO_load_release((const volatile AO_t *)(addr)) -# define AO_HAVE_int_load_release -#endif - -#if defined(AO_HAVE_store_release) && !defined(AO_HAVE_int_store_release) -# define AO_int_store_release(addr, val) \ - AO_store_release((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_store_release -#endif - -#if defined(AO_HAVE_fetch_and_add_release) \ - && !defined(AO_HAVE_int_fetch_and_add_release) -# define AO_int_fetch_and_add_release(addr, incr) \ - (unsigned)AO_fetch_and_add_release((volatile AO_t *)(addr), \ - (AO_t)(incr)) -# define AO_HAVE_int_fetch_and_add_release -#endif - -#if defined(AO_HAVE_fetch_and_add1_release) \ - && !defined(AO_HAVE_int_fetch_and_add1_release) -# define AO_int_fetch_and_add1_release(addr) \ - (unsigned)AO_fetch_and_add1_release((volatile AO_t *)(addr)) -# define AO_HAVE_int_fetch_and_add1_release -#endif - -#if defined(AO_HAVE_fetch_and_sub1_release) \ - && !defined(AO_HAVE_int_fetch_and_sub1_release) -# define AO_int_fetch_and_sub1_release(addr) \ - (unsigned)AO_fetch_and_sub1_release((volatile AO_t *)(addr)) -# define AO_HAVE_int_fetch_and_sub1_release -#endif - -#if defined(AO_HAVE_and_release) && !defined(AO_HAVE_int_and_release) -# define AO_int_and_release(addr, val) \ - AO_and_release((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_and_release -#endif - -#if defined(AO_HAVE_or_release) && !defined(AO_HAVE_int_or_release) -# define AO_int_or_release(addr, val) \ - AO_or_release((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_or_release -#endif - -#if defined(AO_HAVE_xor_release) && !defined(AO_HAVE_int_xor_release) -# define AO_int_xor_release(addr, val) \ - AO_xor_release((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_xor_release -#endif - -#if defined(AO_HAVE_fetch_compare_and_swap_release) \ - && !defined(AO_HAVE_int_fetch_compare_and_swap_release) -# define AO_int_fetch_compare_and_swap_release(addr, old, new_val) \ - (unsigned)AO_fetch_compare_and_swap_release((volatile AO_t *)(addr), \ - (AO_t)(old), (AO_t)(new_val)) -# define AO_HAVE_int_fetch_compare_and_swap_release -#endif - -#if defined(AO_HAVE_compare_and_swap_release) \ - && !defined(AO_HAVE_int_compare_and_swap_release) -# define AO_int_compare_and_swap_release(addr, old, new_val) \ - AO_compare_and_swap_release((volatile AO_t *)(addr), \ - (AO_t)(old), (AO_t)(new_val)) -# define AO_HAVE_int_compare_and_swap_release -#endif -/* - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* Inclusion of this file signifies that AO_t is in fact int. */ -/* Hence any AO_... operation can also serve as AO_int_... operation. */ - -#if defined(AO_HAVE_load_write) && !defined(AO_HAVE_int_load_write) -# define AO_int_load_write(addr) \ - (unsigned)AO_load_write((const volatile AO_t *)(addr)) -# define AO_HAVE_int_load_write -#endif - -#if defined(AO_HAVE_store_write) && !defined(AO_HAVE_int_store_write) -# define AO_int_store_write(addr, val) \ - AO_store_write((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_store_write -#endif - -#if defined(AO_HAVE_fetch_and_add_write) \ - && !defined(AO_HAVE_int_fetch_and_add_write) -# define AO_int_fetch_and_add_write(addr, incr) \ - (unsigned)AO_fetch_and_add_write((volatile AO_t *)(addr), \ - (AO_t)(incr)) -# define AO_HAVE_int_fetch_and_add_write -#endif - -#if defined(AO_HAVE_fetch_and_add1_write) \ - && !defined(AO_HAVE_int_fetch_and_add1_write) -# define AO_int_fetch_and_add1_write(addr) \ - (unsigned)AO_fetch_and_add1_write((volatile AO_t *)(addr)) -# define AO_HAVE_int_fetch_and_add1_write -#endif - -#if defined(AO_HAVE_fetch_and_sub1_write) \ - && !defined(AO_HAVE_int_fetch_and_sub1_write) -# define AO_int_fetch_and_sub1_write(addr) \ - (unsigned)AO_fetch_and_sub1_write((volatile AO_t *)(addr)) -# define AO_HAVE_int_fetch_and_sub1_write -#endif - -#if defined(AO_HAVE_and_write) && !defined(AO_HAVE_int_and_write) -# define AO_int_and_write(addr, val) \ - AO_and_write((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_and_write -#endif - -#if defined(AO_HAVE_or_write) && !defined(AO_HAVE_int_or_write) -# define AO_int_or_write(addr, val) \ - AO_or_write((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_or_write -#endif - -#if defined(AO_HAVE_xor_write) && !defined(AO_HAVE_int_xor_write) -# define AO_int_xor_write(addr, val) \ - AO_xor_write((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_xor_write -#endif - -#if defined(AO_HAVE_fetch_compare_and_swap_write) \ - && !defined(AO_HAVE_int_fetch_compare_and_swap_write) -# define AO_int_fetch_compare_and_swap_write(addr, old, new_val) \ - (unsigned)AO_fetch_compare_and_swap_write((volatile AO_t *)(addr), \ - (AO_t)(old), (AO_t)(new_val)) -# define AO_HAVE_int_fetch_compare_and_swap_write -#endif - -#if defined(AO_HAVE_compare_and_swap_write) \ - && !defined(AO_HAVE_int_compare_and_swap_write) -# define AO_int_compare_and_swap_write(addr, old, new_val) \ - AO_compare_and_swap_write((volatile AO_t *)(addr), \ - (AO_t)(old), (AO_t)(new_val)) -# define AO_HAVE_int_compare_and_swap_write -#endif -/* - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* Inclusion of this file signifies that AO_t is in fact int. */ -/* Hence any AO_... operation can also serve as AO_int_... operation. */ - -#if defined(AO_HAVE_load_read) && !defined(AO_HAVE_int_load_read) -# define AO_int_load_read(addr) \ - (unsigned)AO_load_read((const volatile AO_t *)(addr)) -# define AO_HAVE_int_load_read -#endif - -#if defined(AO_HAVE_store_read) && !defined(AO_HAVE_int_store_read) -# define AO_int_store_read(addr, val) \ - AO_store_read((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_store_read -#endif - -#if defined(AO_HAVE_fetch_and_add_read) \ - && !defined(AO_HAVE_int_fetch_and_add_read) -# define AO_int_fetch_and_add_read(addr, incr) \ - (unsigned)AO_fetch_and_add_read((volatile AO_t *)(addr), \ - (AO_t)(incr)) -# define AO_HAVE_int_fetch_and_add_read -#endif - -#if defined(AO_HAVE_fetch_and_add1_read) \ - && !defined(AO_HAVE_int_fetch_and_add1_read) -# define AO_int_fetch_and_add1_read(addr) \ - (unsigned)AO_fetch_and_add1_read((volatile AO_t *)(addr)) -# define AO_HAVE_int_fetch_and_add1_read -#endif - -#if defined(AO_HAVE_fetch_and_sub1_read) \ - && !defined(AO_HAVE_int_fetch_and_sub1_read) -# define AO_int_fetch_and_sub1_read(addr) \ - (unsigned)AO_fetch_and_sub1_read((volatile AO_t *)(addr)) -# define AO_HAVE_int_fetch_and_sub1_read -#endif - -#if defined(AO_HAVE_and_read) && !defined(AO_HAVE_int_and_read) -# define AO_int_and_read(addr, val) \ - AO_and_read((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_and_read -#endif - -#if defined(AO_HAVE_or_read) && !defined(AO_HAVE_int_or_read) -# define AO_int_or_read(addr, val) \ - AO_or_read((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_or_read -#endif - -#if defined(AO_HAVE_xor_read) && !defined(AO_HAVE_int_xor_read) -# define AO_int_xor_read(addr, val) \ - AO_xor_read((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_xor_read -#endif - -#if defined(AO_HAVE_fetch_compare_and_swap_read) \ - && !defined(AO_HAVE_int_fetch_compare_and_swap_read) -# define AO_int_fetch_compare_and_swap_read(addr, old, new_val) \ - (unsigned)AO_fetch_compare_and_swap_read((volatile AO_t *)(addr), \ - (AO_t)(old), (AO_t)(new_val)) -# define AO_HAVE_int_fetch_compare_and_swap_read -#endif - -#if defined(AO_HAVE_compare_and_swap_read) \ - && !defined(AO_HAVE_int_compare_and_swap_read) -# define AO_int_compare_and_swap_read(addr, old, new_val) \ - AO_compare_and_swap_read((volatile AO_t *)(addr), \ - (AO_t)(old), (AO_t)(new_val)) -# define AO_HAVE_int_compare_and_swap_read -#endif diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/ao_t_is_int.template ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/ao_t_is_int.template --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/ao_t_is_int.template 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/ao_t_is_int.template 1970-01-01 00:00:00.000000000 +0000 @@ -1,92 +0,0 @@ -/* - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* Inclusion of this file signifies that AO_t is in fact int. */ -/* Hence any AO_... operation can also serve as AO_int_... operation. */ - -#if defined(AO_HAVE_load_XBAR) && !defined(AO_HAVE_int_load_XBAR) -# define AO_int_load_XBAR(addr) \ - (unsigned)AO_load_XBAR((const volatile AO_t *)(addr)) -# define AO_HAVE_int_load_XBAR -#endif - -#if defined(AO_HAVE_store_XBAR) && !defined(AO_HAVE_int_store_XBAR) -# define AO_int_store_XBAR(addr, val) \ - AO_store_XBAR((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_store_XBAR -#endif - -#if defined(AO_HAVE_fetch_and_add_XBAR) \ - && !defined(AO_HAVE_int_fetch_and_add_XBAR) -# define AO_int_fetch_and_add_XBAR(addr, incr) \ - (unsigned)AO_fetch_and_add_XBAR((volatile AO_t *)(addr), \ - (AO_t)(incr)) -# define AO_HAVE_int_fetch_and_add_XBAR -#endif - -#if defined(AO_HAVE_fetch_and_add1_XBAR) \ - && !defined(AO_HAVE_int_fetch_and_add1_XBAR) -# define AO_int_fetch_and_add1_XBAR(addr) \ - (unsigned)AO_fetch_and_add1_XBAR((volatile AO_t *)(addr)) -# define AO_HAVE_int_fetch_and_add1_XBAR -#endif - -#if defined(AO_HAVE_fetch_and_sub1_XBAR) \ - && !defined(AO_HAVE_int_fetch_and_sub1_XBAR) -# define AO_int_fetch_and_sub1_XBAR(addr) \ - (unsigned)AO_fetch_and_sub1_XBAR((volatile AO_t *)(addr)) -# define AO_HAVE_int_fetch_and_sub1_XBAR -#endif - -#if defined(AO_HAVE_and_XBAR) && !defined(AO_HAVE_int_and_XBAR) -# define AO_int_and_XBAR(addr, val) \ - AO_and_XBAR((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_and_XBAR -#endif - -#if defined(AO_HAVE_or_XBAR) && !defined(AO_HAVE_int_or_XBAR) -# define AO_int_or_XBAR(addr, val) \ - AO_or_XBAR((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_or_XBAR -#endif - -#if defined(AO_HAVE_xor_XBAR) && !defined(AO_HAVE_int_xor_XBAR) -# define AO_int_xor_XBAR(addr, val) \ - AO_xor_XBAR((volatile AO_t *)(addr), (AO_t)(val)) -# define AO_HAVE_int_xor_XBAR -#endif - -#if defined(AO_HAVE_fetch_compare_and_swap_XBAR) \ - && !defined(AO_HAVE_int_fetch_compare_and_swap_XBAR) -# define AO_int_fetch_compare_and_swap_XBAR(addr, old, new_val) \ - (unsigned)AO_fetch_compare_and_swap_XBAR((volatile AO_t *)(addr), \ - (AO_t)(old), (AO_t)(new_val)) -# define AO_HAVE_int_fetch_compare_and_swap_XBAR -#endif - -#if defined(AO_HAVE_compare_and_swap_XBAR) \ - && !defined(AO_HAVE_int_compare_and_swap_XBAR) -# define AO_int_compare_and_swap_XBAR(addr, old, new_val) \ - AO_compare_and_swap_XBAR((volatile AO_t *)(addr), \ - (AO_t)(old), (AO_t)(new_val)) -# define AO_HAVE_int_compare_and_swap_XBAR -#endif diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/armcc/arm_v6.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/armcc/arm_v6.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/armcc/arm_v6.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/armcc/arm_v6.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,263 +0,0 @@ -/* - * Copyright (c) 2007 by NEC LE-IT: All rights reserved. - * A transcription of ARMv6 atomic operations for the ARM Realview Toolchain. - * This code works with armcc from RVDS 3.1 - * This is based on work in gcc/arm.h by - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 1999-2003 by Hewlett-Packard Company. All rights reserved. - * - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -#include "../test_and_set_t_is_ao_t.h" /* Probably suboptimal */ - -#if __TARGET_ARCH_ARM < 6 -Dont use with ARM instruction sets lower than v6 -#else - -#define AO_ACCESS_CHECK_ALIGNED -#define AO_ACCESS_short_CHECK_ALIGNED -#define AO_ACCESS_int_CHECK_ALIGNED -#include "../all_atomic_only_load.h" - -#include "../standard_ao_double_t.h" - -/* NEC LE-IT: ARMv6 is the first architecture providing support for simple LL/SC - * A data memory barrier must be raised via CP15 command (see documentation). - * - * ARMv7 is compatible to ARMv6 but has a simpler command for issuing a - * memory barrier (DMB). Raising it via CP15 should still work as told me by the - * support engineers. If it turns out to be much quicker than we should implement - * custom code for ARMv7 using the asm { dmb } command. - * - * If only a single processor is used, we can define AO_UNIPROCESSOR - * and do not need to access CP15 for ensuring a DMB at all. -*/ - -AO_INLINE void -AO_nop_full(void) -{ -# ifndef AO_UNIPROCESSOR - unsigned int dest=0; - /* issue an data memory barrier (keeps ordering of memory transactions */ - /* before and after this operation) */ - __asm { - mcr p15,0,dest,c7,c10,5 - }; -# else - AO_compiler_barrier(); -# endif -} -#define AO_HAVE_nop_full - -/* NEC LE-IT: atomic "store" - according to ARM documentation this is - * the only safe way to set variables also used in LL/SC environment. - * A direct write won't be recognized by the LL/SC construct in other CPUs. - * - * HB: Based on subsequent discussion, I think it would be OK to use an - * ordinary store here if we knew that interrupt handlers always cleared - * the reservation. They should, but there is some doubt that this is - * currently always the case for e.g. Linux. -*/ -AO_INLINE void AO_store(volatile AO_t *addr, AO_t value) -{ - unsigned long tmp; - -retry: -__asm { - ldrex tmp, [addr] - strex tmp, value, [addr] - teq tmp, #0 - bne retry - }; -} -#define AO_HAVE_store - -/* NEC LE-IT: replace the SWAP as recommended by ARM: - - "Applies to: ARM11 Cores - Though the SWP instruction will still work with ARM V6 cores, it is recommended - to use the new V6 synchronization instructions. The SWP instruction produces - locked read and write accesses which are atomic, i.e. another operation cannot - be done between these locked accesses which ties up external bus (AHB,AXI) - bandwidth and can increase worst case interrupt latencies. LDREX,STREX are - more flexible, other instructions can be done between the LDREX and STREX accesses. - " -*/ -#ifndef AO_PREFER_GENERALIZED -AO_INLINE AO_TS_VAL_t -AO_test_and_set(volatile AO_TS_t *addr) { - - AO_TS_VAL_t oldval; - unsigned long tmp; - unsigned long one = 1; -retry: -__asm { - ldrex oldval, [addr] - strex tmp, one, [addr] - teq tmp, #0 - bne retry - } - - return oldval; -} -#define AO_HAVE_test_and_set - -AO_INLINE AO_t -AO_fetch_and_add(volatile AO_t *p, AO_t incr) -{ - unsigned long tmp,tmp2; - AO_t result; - -retry: -__asm { - ldrex result, [p] - add tmp, incr, result - strex tmp2, tmp, [p] - teq tmp2, #0 - bne retry - } - - return result; -} -#define AO_HAVE_fetch_and_add - -AO_INLINE AO_t -AO_fetch_and_add1(volatile AO_t *p) -{ - unsigned long tmp,tmp2; - AO_t result; - -retry: -__asm { - ldrex result, [p] - add tmp, result, #1 - strex tmp2, tmp, [p] - teq tmp2, #0 - bne retry - } - - return result; -} -#define AO_HAVE_fetch_and_add1 - -AO_INLINE AO_t -AO_fetch_and_sub1(volatile AO_t *p) -{ - unsigned long tmp,tmp2; - AO_t result; - -retry: -__asm { - ldrex result, [p] - sub tmp, result, #1 - strex tmp2, tmp, [p] - teq tmp2, #0 - bne retry - } - - return result; -} -#define AO_HAVE_fetch_and_sub1 -#endif /* !AO_PREFER_GENERALIZED */ - -#ifndef AO_GENERALIZE_ASM_BOOL_CAS - /* Returns nonzero if the comparison succeeded. */ - AO_INLINE int - AO_compare_and_swap(volatile AO_t *addr, AO_t old_val, AO_t new_val) - { - AO_t result, tmp; - - retry: - __asm__ { - mov result, #2 - ldrex tmp, [addr] - teq tmp, old_val -# ifdef __thumb__ - it eq -# endif - strexeq result, new_val, [addr] - teq result, #1 - beq retry - } - return !(result&2); - } -# define AO_HAVE_compare_and_swap -#endif /* !AO_GENERALIZE_ASM_BOOL_CAS */ - -AO_INLINE AO_t -AO_fetch_compare_and_swap(volatile AO_t *addr, AO_t old_val, AO_t new_val) -{ - AO_t fetched_val, tmp; - -retry: -__asm__ { - mov tmp, #2 - ldrex fetched_val, [addr] - teq fetched_val, old_val -# ifdef __thumb__ - it eq -# endif - strexeq tmp, new_val, [addr] - teq tmp, #1 - beq retry - } - return fetched_val; -} -#define AO_HAVE_fetch_compare_and_swap - -/* helper functions for the Realview compiler: LDREXD is not usable - * with inline assembler, so use the "embedded" assembler as - * suggested by ARM Dev. support (June 2008). */ -__asm inline double_ptr_storage AO_load_ex(const volatile AO_double_t *addr) { - LDREXD r0,r1,[r0] -} - -__asm inline int AO_store_ex(AO_t val1, AO_t val2, volatile AO_double_t *addr) { - STREXD r3,r0,r1,[r2] - MOV r0,r3 -} - -AO_INLINE AO_double_t -AO_double_load(const volatile AO_double_t *addr) -{ - AO_double_t result; - - result.AO_whole = AO_load_ex(addr); - return result; -} -#define AO_HAVE_double_load - -AO_INLINE int -AO_compare_double_and_swap_double(volatile AO_double_t *addr, - AO_t old_val1, AO_t old_val2, - AO_t new_val1, AO_t new_val2) -{ - double_ptr_storage old_val = - ((double_ptr_storage)old_val2 << 32) | old_val1; - double_ptr_storage tmp; - int result; - - while(1) { - tmp = AO_load_ex(addr); - if(tmp != old_val) return 0; - result = AO_store_ex(new_val1, new_val2, addr); - if(!result) return 1; - } -} -#define AO_HAVE_compare_double_and_swap_double - -#endif /* __TARGET_ARCH_ARM >= 6 */ - -#define AO_T_IS_INT diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/emul_cas.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/emul_cas.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/emul_cas.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/emul_cas.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,78 +0,0 @@ -/* - * Copyright (c) 2003 by Hewlett-Packard Company. All rights reserved. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* - * Ensure, if at all possible, that AO_compare_and_swap_full() is - * available. The emulation should be brute-force signal-safe, even - * though it actually blocks. - * Including this file will generate an error if AO_compare_and_swap_full() - * cannot be made available. - * This will be included from platform-specific atomic_ops files - * if appropriate, and if AO_REQUIRE_CAS is defined. It should not be - * included directly, especially since it affects the implementation - * of other atomic update primitives. - * The implementation assumes that only AO_store_XXX and AO_test_and_set_XXX - * variants are defined, and that AO_test_and_set_XXX is not used to - * operate on compare_and_swap locations. - */ - -#ifndef AO_ATOMIC_OPS_H -# error This file should not be included directly. -#endif - -#ifndef AO_HAVE_double_t -# include "standard_ao_double_t.h" -#endif - -AO_t AO_fetch_compare_and_swap_emulation(volatile AO_t *addr, AO_t old_val, - AO_t new_val); - -int AO_compare_double_and_swap_double_emulation(volatile AO_double_t *addr, - AO_t old_val1, AO_t old_val2, - AO_t new_val1, AO_t new_val2); - -void AO_store_full_emulation(volatile AO_t *addr, AO_t val); - -#ifndef AO_HAVE_fetch_compare_and_swap_full -# define AO_fetch_compare_and_swap_full(addr, old, newval) \ - AO_fetch_compare_and_swap_emulation(addr, old, newval) -# define AO_HAVE_fetch_compare_and_swap_full -#endif - -#ifndef AO_HAVE_compare_double_and_swap_double_full -# define AO_compare_double_and_swap_double_full(addr, old1, old2, \ - newval1, newval2) \ - AO_compare_double_and_swap_double_emulation(addr, old1, old2, \ - newval1, newval2) -# define AO_HAVE_compare_double_and_swap_double_full -#endif - -#undef AO_store -#undef AO_HAVE_store -#undef AO_store_write -#undef AO_HAVE_store_write -#undef AO_store_release -#undef AO_HAVE_store_release -#undef AO_store_full -#undef AO_HAVE_store_full -#define AO_store_full(addr, val) AO_store_full_emulation(addr, val) -#define AO_HAVE_store_full diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/aarch64.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/aarch64.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/aarch64.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/aarch64.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,200 +0,0 @@ -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 1999-2003 by Hewlett-Packard Company. All rights reserved. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -#include "../test_and_set_t_is_ao_t.h" - -#include "../standard_ao_double_t.h" - -#ifndef AO_UNIPROCESSOR - AO_INLINE void - AO_nop_write(void) - { - /* TODO: Use C++11 primitive. */ - __asm__ __volatile__("dmb ishst" : : : "memory"); - } -# define AO_HAVE_nop_write -#endif - -/* TODO: Adjust version check on fixing double-wide AO support in GCC. */ -#if __GNUC__ >= 4 - - AO_INLINE AO_double_t - AO_double_load(const volatile AO_double_t *addr) - { - AO_double_t result; - int status; - - /* Note that STXP cannot be discarded because LD[A]XP is not */ - /* single-copy atomic (unlike LDREXD for 32-bit ARM). */ - do { - __asm__ __volatile__("//AO_double_load\n" - " ldxp %0, %1, %3\n" - " stxp %w2, %0, %1, %3" - : "=&r" (result.AO_val1), "=&r" (result.AO_val2), "=&r" (status) - : "Q" (*addr)); - } while (AO_EXPECT_FALSE(status)); - return result; - } -# define AO_HAVE_double_load - - AO_INLINE AO_double_t - AO_double_load_acquire(const volatile AO_double_t *addr) - { - AO_double_t result; - int status; - - do { - __asm__ __volatile__("//AO_double_load_acquire\n" - " ldaxp %0, %1, %3\n" - " stxp %w2, %0, %1, %3" - : "=&r" (result.AO_val1), "=&r" (result.AO_val2), "=&r" (status) - : "Q" (*addr)); - } while (AO_EXPECT_FALSE(status)); - return result; - } -# define AO_HAVE_double_load_acquire - - AO_INLINE void - AO_double_store(volatile AO_double_t *addr, AO_double_t value) - { - AO_double_t old_val; - int status; - - do { - __asm__ __volatile__("//AO_double_store\n" - " ldxp %0, %1, %3\n" - " stxp %w2, %4, %5, %3" - : "=&r" (old_val.AO_val1), "=&r" (old_val.AO_val2), "=&r" (status), - "=Q" (*addr) - : "r" (value.AO_val1), "r" (value.AO_val2)); - /* Compared to the arm.h implementation, the 'cc' (flags) are not */ - /* clobbered because A64 has no concept of conditional execution. */ - } while (AO_EXPECT_FALSE(status)); - } -# define AO_HAVE_double_store - - AO_INLINE void - AO_double_store_release(volatile AO_double_t *addr, AO_double_t value) - { - AO_double_t old_val; - int status; - - do { - __asm__ __volatile__("//AO_double_store_release\n" - " ldxp %0, %1, %3\n" - " stlxp %w2, %4, %5, %3" - : "=&r" (old_val.AO_val1), "=&r" (old_val.AO_val2), "=&r" (status), - "=Q" (*addr) - : "r" (value.AO_val1), "r" (value.AO_val2)); - } while (AO_EXPECT_FALSE(status)); - } -# define AO_HAVE_double_store_release - - AO_INLINE int - AO_double_compare_and_swap(volatile AO_double_t *addr, - AO_double_t old_val, AO_double_t new_val) - { - AO_double_t tmp; - int result = 1; - - do { - __asm__ __volatile__("//AO_double_compare_and_swap\n" - " ldxp %0, %1, %2\n" - : "=&r" (tmp.AO_val1), "=&r" (tmp.AO_val2) - : "Q" (*addr)); - if (tmp.AO_val1 != old_val.AO_val1 || tmp.AO_val2 != old_val.AO_val2) - break; - __asm__ __volatile__( - " stxp %w0, %2, %3, %1\n" - : "=&r" (result), "=Q" (*addr) - : "r" (new_val.AO_val1), "r" (new_val.AO_val2)); - } while (AO_EXPECT_FALSE(result)); - return !result; - } -# define AO_HAVE_double_compare_and_swap - - AO_INLINE int - AO_double_compare_and_swap_acquire(volatile AO_double_t *addr, - AO_double_t old_val, AO_double_t new_val) - { - AO_double_t tmp; - int result = 1; - - do { - __asm__ __volatile__("//AO_double_compare_and_swap_acquire\n" - " ldaxp %0, %1, %2\n" - : "=&r" (tmp.AO_val1), "=&r" (tmp.AO_val2) - : "Q" (*addr)); - if (tmp.AO_val1 != old_val.AO_val1 || tmp.AO_val2 != old_val.AO_val2) - break; - __asm__ __volatile__( - " stxp %w0, %2, %3, %1\n" - : "=&r" (result), "=Q" (*addr) - : "r" (new_val.AO_val1), "r" (new_val.AO_val2)); - } while (AO_EXPECT_FALSE(result)); - return !result; - } -# define AO_HAVE_double_compare_and_swap_acquire - - AO_INLINE int - AO_double_compare_and_swap_release(volatile AO_double_t *addr, - AO_double_t old_val, AO_double_t new_val) - { - AO_double_t tmp; - int result = 1; - - do { - __asm__ __volatile__("//AO_double_compare_and_swap_release\n" - " ldxp %0, %1, %2\n" - : "=&r" (tmp.AO_val1), "=&r" (tmp.AO_val2) - : "Q" (*addr)); - if (tmp.AO_val1 != old_val.AO_val1 || tmp.AO_val2 != old_val.AO_val2) - break; - __asm__ __volatile__( - " stlxp %w0, %2, %3, %1\n" - : "=&r" (result), "=Q" (*addr) - : "r" (new_val.AO_val1), "r" (new_val.AO_val2)); - } while (AO_EXPECT_FALSE(result)); - return !result; - } -# define AO_HAVE_double_compare_and_swap_release - - AO_INLINE int - AO_double_compare_and_swap_full(volatile AO_double_t *addr, - AO_double_t old_val, AO_double_t new_val) - { - AO_double_t tmp; - int result = 1; - - do { - __asm__ __volatile__("//AO_double_compare_and_swap_full\n" - " ldaxp %0, %1, %2\n" - : "=&r" (tmp.AO_val1), "=&r" (tmp.AO_val2) - : "Q" (*addr)); - if (tmp.AO_val1 != old_val.AO_val1 || tmp.AO_val2 != old_val.AO_val2) - break; - __asm__ __volatile__( - " stlxp %w0, %2, %3, %1\n" - : "=&r" (result), "=Q" (*addr) - : "r" (new_val.AO_val1), "r" (new_val.AO_val2)); - } while (AO_EXPECT_FALSE(result)); - return !result; - } -# define AO_HAVE_double_compare_and_swap_full -#endif /* __GNUC__ >= 4 */ - -#include "generic.h" diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/alpha.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/alpha.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/alpha.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/alpha.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,67 +0,0 @@ -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 1999-2003 by Hewlett-Packard Company. All rights reserved. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -#include "../loadstore/atomic_load.h" -#include "../loadstore/atomic_store.h" - -#include "../test_and_set_t_is_ao_t.h" - -#define AO_NO_DD_ORDERING - /* Data dependence does not imply read ordering. */ - -AO_INLINE void -AO_nop_full(void) -{ - __asm__ __volatile__("mb" : : : "memory"); -} -#define AO_HAVE_nop_full - -AO_INLINE void -AO_nop_write(void) -{ - __asm__ __volatile__("wmb" : : : "memory"); -} -#define AO_HAVE_nop_write - -/* mb should be used for AO_nop_read(). That's the default. */ - -/* TODO: implement AO_fetch_and_add explicitly. */ - -/* We believe that ldq_l ... stq_c does not imply any memory barrier. */ -AO_INLINE int -AO_compare_and_swap(volatile AO_t *addr, - AO_t old, AO_t new_val) -{ - unsigned long was_equal; - unsigned long temp; - - __asm__ __volatile__( - "1: ldq_l %0,%1\n" - " cmpeq %0,%4,%2\n" - " mov %3,%0\n" - " beq %2,2f\n" - " stq_c %0,%1\n" - " beq %0,1b\n" - "2:\n" - : "=&r" (temp), "+m" (*addr), "=&r" (was_equal) - : "r" (new_val), "Ir" (old) - :"memory"); - return (int)was_equal; -} -#define AO_HAVE_compare_and_swap - -/* TODO: implement AO_fetch_compare_and_swap */ diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/arm.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/arm.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/arm.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/arm.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,610 +0,0 @@ -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 1999-2003 by Hewlett-Packard Company. All rights reserved. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -#include "../test_and_set_t_is_ao_t.h" /* Probably suboptimal */ - -#if defined(__thumb__) && !defined(__thumb2__) - /* Thumb One mode does not have ARM "mcr", "swp" and some load/store */ - /* instructions, so we temporarily switch to ARM mode and go back */ - /* afterwards (clobbering "r3" register). */ -# define AO_THUMB_GO_ARM \ - " adr r3, 4f\n" \ - " bx r3\n" \ - " .align\n" \ - " .arm\n" \ - "4:\n" -# define AO_THUMB_RESTORE_MODE \ - " adr r3, 5f + 1\n" \ - " bx r3\n" \ - " .thumb\n" \ - "5:\n" -# define AO_THUMB_SWITCH_CLOBBERS "r3", -#else -# define AO_THUMB_GO_ARM /* empty */ -# define AO_THUMB_RESTORE_MODE /* empty */ -# define AO_THUMB_SWITCH_CLOBBERS /* empty */ -#endif /* !__thumb__ */ - -/* NEC LE-IT: gcc has no way to easily check the arm architecture */ -/* but it defines only one (or several) of __ARM_ARCH_x__ to be true. */ -#if !defined(__ARM_ARCH_2__) && !defined(__ARM_ARCH_3__) \ - && !defined(__ARM_ARCH_3M__) && !defined(__ARM_ARCH_4__) \ - && !defined(__ARM_ARCH_4T__) \ - && ((!defined(__ARM_ARCH_5__) && !defined(__ARM_ARCH_5E__) \ - && !defined(__ARM_ARCH_5T__) && !defined(__ARM_ARCH_5TE__) \ - && !defined(__ARM_ARCH_5TEJ__) && !defined(__ARM_ARCH_6M__)) \ - || defined(__ARM_ARCH_7__) || defined(__ARM_ARCH_7A__) \ - || defined(__ARM_ARCH_8A__)) -# define AO_ARM_HAVE_LDREX -# if !defined(__ARM_ARCH_6__) && !defined(__ARM_ARCH_6J__) \ - && !defined(__ARM_ARCH_6T2__) - /* LDREXB/STREXB and LDREXH/STREXH are present in ARMv6K/Z+. */ -# define AO_ARM_HAVE_LDREXBH -# endif -# if !defined(__ARM_ARCH_6__) && !defined(__ARM_ARCH_6J__) \ - && !defined(__ARM_ARCH_6T2__) && !defined(__ARM_ARCH_6Z__) \ - && !defined(__ARM_ARCH_6ZT2__) -# if !defined(__ARM_ARCH_6K__) && !defined(__ARM_ARCH_6ZK__) - /* DMB is present in ARMv6M and ARMv7+. */ -# define AO_ARM_HAVE_DMB -# endif -# if (!defined(__thumb__) \ - || (defined(__thumb2__) && !defined(__ARM_ARCH_7__) \ - && !defined(__ARM_ARCH_7M__) && !defined(__ARM_ARCH_7EM__))) \ - && (!defined(__clang__) || (__clang_major__ > 3) \ - || (__clang_major__ == 3 && __clang_minor__ >= 3)) - /* LDREXD/STREXD present in ARMv6K/M+ (see gas/config/tc-arm.c). */ - /* In the Thumb mode, this works only starting from ARMv7 (except */ - /* for the base and 'M' models). Clang3.2 (and earlier) does not */ - /* allocate register pairs for LDREXD/STREXD properly (besides, */ - /* Clang3.1 does not support "%H" operand specification). */ -# define AO_ARM_HAVE_LDREXD -# endif /* !thumb || ARMv7A || ARMv7R+ */ -# endif /* ARMv7+ */ -#endif /* ARMv6+ */ - -#if !defined(__ARM_ARCH_2__) && !defined(__ARM_ARCH_6M__) \ - && !defined(__ARM_ARCH_8A__) && !defined(__thumb2__) -# define AO_ARM_HAVE_SWP - /* Note: ARMv6M is excluded due to no ARM mode support. */ - /* Also, SWP is obsoleted for ARMv8+. */ -#endif /* !__thumb2__ */ - -#ifdef AO_UNIPROCESSOR - /* If only a single processor (core) is used, AO_UNIPROCESSOR could */ - /* be defined by the client to avoid unnecessary memory barrier. */ - AO_INLINE void - AO_nop_full(void) - { - AO_compiler_barrier(); - } -# define AO_HAVE_nop_full - -#elif defined(AO_ARM_HAVE_DMB) - /* ARMv7 is compatible to ARMv6 but has a simpler command for issuing */ - /* a memory barrier (DMB). Raising it via CP15 should still work */ - /* (but slightly less efficient because it requires the use of */ - /* a general-purpose register). */ - AO_INLINE void - AO_nop_full(void) - { - /* AO_THUMB_GO_ARM is empty. */ - __asm__ __volatile__("dmb" : : : "memory"); - } -# define AO_HAVE_nop_full - - AO_INLINE void - AO_nop_write(void) - { - /* AO_THUMB_GO_ARM is empty. */ - /* This will target the system domain and thus be overly */ - /* conservative as the CPUs will occupy the inner shareable domain. */ - /* The plain variant (dmb st) is theoretically slower, and should */ - /* not be needed. That said, with limited experimentation, a CPU */ - /* implementation for which it actually matters has not been found */ - /* yet, though they should already exist. */ - /* Anyway, note that the "st" and "ishst" barriers are actually */ - /* quite weak and, as the libatomic_ops documentation states, */ - /* usually not what you really want. */ - __asm__ __volatile__("dmb ishst" : : : "memory"); - } -# define AO_HAVE_nop_write - -#elif defined(AO_ARM_HAVE_LDREX) - /* ARMv6 is the first architecture providing support for a simple */ - /* LL/SC. A data memory barrier must be raised via CP15 command. */ - AO_INLINE void - AO_nop_full(void) - { - unsigned dest = 0; - - /* Issue a data memory barrier (keeps ordering of memory */ - /* transactions before and after this operation). */ - __asm__ __volatile__("@AO_nop_full\n" - AO_THUMB_GO_ARM - " mcr p15,0,%0,c7,c10,5\n" - AO_THUMB_RESTORE_MODE - : "=&r"(dest) - : /* empty */ - : AO_THUMB_SWITCH_CLOBBERS "memory"); - } -# define AO_HAVE_nop_full - -#else - /* AO_nop_full() is emulated using AO_test_and_set_full(). */ -#endif /* !AO_UNIPROCESSOR && !AO_ARM_HAVE_LDREX */ - -#ifdef AO_ARM_HAVE_LDREX - - /* AO_t/char/short/int load is simple reading. */ - /* Unaligned accesses are not guaranteed to be atomic. */ -# define AO_ACCESS_CHECK_ALIGNED -# define AO_ACCESS_short_CHECK_ALIGNED -# define AO_ACCESS_int_CHECK_ALIGNED -# include "../all_atomic_only_load.h" - - /* "ARM Architecture Reference Manual" (chapter A3.5.3) says that the */ - /* single-copy atomic processor accesses are all byte accesses, all */ - /* halfword accesses to halfword-aligned locations, all word accesses */ - /* to word-aligned locations. */ - /* There is only a single concern related to AO store operations: */ - /* a direct write (by STR[B/H] instruction) will not be recognized */ - /* by the LL/SC construct on the same CPU (i.e., according to ARM */ - /* documentation, e.g., see CortexA8 TRM reference, point 8.5, */ - /* atomic "store" (using LDREX/STREX[B/H]) is the only safe way to */ - /* set variables also used in LL/SC environment). */ - /* This is only a problem if interrupt handlers do not clear the */ - /* reservation (by CLREX instruction or a dummy STREX one), as they */ - /* almost certainly should (e.g., see restore_user_regs defined in */ - /* arch/arm/kernel/entry-header.S of Linux. Nonetheless, there is */ - /* a doubt this was properly implemented in some ancient OS releases. */ -# ifdef AO_BROKEN_TASKSWITCH_CLREX - AO_INLINE void AO_store(volatile AO_t *addr, AO_t value) - { - int flag; - - __asm__ __volatile__("@AO_store\n" - AO_THUMB_GO_ARM - "1: ldrex %0, [%2]\n" - " strex %0, %3, [%2]\n" - " teq %0, #0\n" - " bne 1b\n" - AO_THUMB_RESTORE_MODE - : "=&r" (flag), "+m" (*addr) - : "r" (addr), "r" (value) - : AO_THUMB_SWITCH_CLOBBERS "cc"); - } -# define AO_HAVE_store - -# ifdef AO_ARM_HAVE_LDREXBH - AO_INLINE void AO_char_store(volatile unsigned char *addr, - unsigned char value) - { - int flag; - - __asm__ __volatile__("@AO_char_store\n" - AO_THUMB_GO_ARM - "1: ldrexb %0, [%2]\n" - " strexb %0, %3, [%2]\n" - " teq %0, #0\n" - " bne 1b\n" - AO_THUMB_RESTORE_MODE - : "=&r" (flag), "+m" (*addr) - : "r" (addr), "r" (value) - : AO_THUMB_SWITCH_CLOBBERS "cc"); - } -# define AO_HAVE_char_store - - AO_INLINE void AO_short_store(volatile unsigned short *addr, - unsigned short value) - { - int flag; - - __asm__ __volatile__("@AO_short_store\n" - AO_THUMB_GO_ARM - "1: ldrexh %0, [%2]\n" - " strexh %0, %3, [%2]\n" - " teq %0, #0\n" - " bne 1b\n" - AO_THUMB_RESTORE_MODE - : "=&r" (flag), "+m" (*addr) - : "r" (addr), "r" (value) - : AO_THUMB_SWITCH_CLOBBERS "cc"); - } -# define AO_HAVE_short_store -# endif /* AO_ARM_HAVE_LDREXBH */ - -# else -# include "../loadstore/atomic_store.h" - /* AO_int_store is defined in ao_t_is_int.h. */ -# endif /* !AO_BROKEN_TASKSWITCH_CLREX */ - -# ifndef AO_HAVE_char_store -# include "../loadstore/char_atomic_store.h" -# include "../loadstore/short_atomic_store.h" -# endif - -/* NEC LE-IT: replace the SWAP as recommended by ARM: - "Applies to: ARM11 Cores - Though the SWP instruction will still work with ARM V6 cores, it is - recommended to use the new V6 synchronization instructions. The SWP - instruction produces 'locked' read and write accesses which are atomic, - i.e. another operation cannot be done between these locked accesses which - ties up external bus (AHB, AXI) bandwidth and can increase worst case - interrupt latencies. LDREX, STREX are more flexible, other instructions - can be done between the LDREX and STREX accesses." -*/ -#ifndef AO_PREFER_GENERALIZED -#if !defined(AO_FORCE_USE_SWP) || !defined(AO_ARM_HAVE_SWP) - /* But, on the other hand, there could be a considerable performance */ - /* degradation in case of a race. Eg., test_atomic.c executing */ - /* test_and_set test on a dual-core ARMv7 processor using LDREX/STREX */ - /* showed around 35 times lower performance than that using SWP. */ - /* To force use of SWP instruction, use -D AO_FORCE_USE_SWP option */ - /* (the latter is ignored if SWP instruction is unsupported). */ - AO_INLINE AO_TS_VAL_t - AO_test_and_set(volatile AO_TS_t *addr) - { - AO_TS_VAL_t oldval; - int flag; - - __asm__ __volatile__("@AO_test_and_set\n" - AO_THUMB_GO_ARM - "1: ldrex %0, [%3]\n" - " strex %1, %4, [%3]\n" - " teq %1, #0\n" - " bne 1b\n" - AO_THUMB_RESTORE_MODE - : "=&r"(oldval), "=&r"(flag), "+m"(*addr) - : "r"(addr), "r"(1) - : AO_THUMB_SWITCH_CLOBBERS "cc"); - return oldval; - } -# define AO_HAVE_test_and_set -#endif /* !AO_FORCE_USE_SWP */ - -AO_INLINE AO_t -AO_fetch_and_add(volatile AO_t *p, AO_t incr) -{ - AO_t result, tmp; - int flag; - - __asm__ __volatile__("@AO_fetch_and_add\n" - AO_THUMB_GO_ARM - "1: ldrex %0, [%5]\n" /* get original */ - " add %2, %0, %4\n" /* sum up in incr */ - " strex %1, %2, [%5]\n" /* store them */ - " teq %1, #0\n" - " bne 1b\n" - AO_THUMB_RESTORE_MODE - : "=&r"(result), "=&r"(flag), "=&r"(tmp), "+m"(*p) /* 0..3 */ - : "r"(incr), "r"(p) /* 4..5 */ - : AO_THUMB_SWITCH_CLOBBERS "cc"); - return result; -} -#define AO_HAVE_fetch_and_add - -AO_INLINE AO_t -AO_fetch_and_add1(volatile AO_t *p) -{ - AO_t result, tmp; - int flag; - - __asm__ __volatile__("@AO_fetch_and_add1\n" - AO_THUMB_GO_ARM - "1: ldrex %0, [%4]\n" /* get original */ - " add %1, %0, #1\n" /* increment */ - " strex %2, %1, [%4]\n" /* store them */ - " teq %2, #0\n" - " bne 1b\n" - AO_THUMB_RESTORE_MODE - : "=&r"(result), "=&r"(tmp), "=&r"(flag), "+m"(*p) - : "r"(p) - : AO_THUMB_SWITCH_CLOBBERS "cc"); - return result; -} -#define AO_HAVE_fetch_and_add1 - -AO_INLINE AO_t -AO_fetch_and_sub1(volatile AO_t *p) -{ - AO_t result, tmp; - int flag; - - __asm__ __volatile__("@AO_fetch_and_sub1\n" - AO_THUMB_GO_ARM - "1: ldrex %0, [%4]\n" /* get original */ - " sub %1, %0, #1\n" /* decrement */ - " strex %2, %1, [%4]\n" /* store them */ - " teq %2, #0\n" - " bne 1b\n" - AO_THUMB_RESTORE_MODE - : "=&r"(result), "=&r"(tmp), "=&r"(flag), "+m"(*p) - : "r"(p) - : AO_THUMB_SWITCH_CLOBBERS "cc"); - return result; -} -#define AO_HAVE_fetch_and_sub1 - -AO_INLINE void -AO_and(volatile AO_t *p, AO_t value) -{ - AO_t tmp, result; - - __asm__ __volatile__("@AO_and\n" - AO_THUMB_GO_ARM - "1: ldrex %0, [%4]\n" - " and %1, %0, %3\n" - " strex %0, %1, [%4]\n" - " teq %0, #0\n" - " bne 1b\n" - AO_THUMB_RESTORE_MODE - : "=&r" (tmp), "=&r" (result), "+m" (*p) - : "r" (value), "r" (p) - : AO_THUMB_SWITCH_CLOBBERS "cc"); -} -#define AO_HAVE_and - -AO_INLINE void -AO_or(volatile AO_t *p, AO_t value) -{ - AO_t tmp, result; - - __asm__ __volatile__("@AO_or\n" - AO_THUMB_GO_ARM - "1: ldrex %0, [%4]\n" - " orr %1, %0, %3\n" - " strex %0, %1, [%4]\n" - " teq %0, #0\n" - " bne 1b\n" - AO_THUMB_RESTORE_MODE - : "=&r" (tmp), "=&r" (result), "+m" (*p) - : "r" (value), "r" (p) - : AO_THUMB_SWITCH_CLOBBERS "cc"); -} -#define AO_HAVE_or - -AO_INLINE void -AO_xor(volatile AO_t *p, AO_t value) -{ - AO_t tmp, result; - - __asm__ __volatile__("@AO_xor\n" - AO_THUMB_GO_ARM - "1: ldrex %0, [%4]\n" - " eor %1, %0, %3\n" - " strex %0, %1, [%4]\n" - " teq %0, #0\n" - " bne 1b\n" - AO_THUMB_RESTORE_MODE - : "=&r" (tmp), "=&r" (result), "+m" (*p) - : "r" (value), "r" (p) - : AO_THUMB_SWITCH_CLOBBERS "cc"); -} -#define AO_HAVE_xor -#endif /* !AO_PREFER_GENERALIZED */ - -#ifdef AO_ARM_HAVE_LDREXBH - AO_INLINE unsigned char - AO_char_fetch_and_add(volatile unsigned char *p, unsigned char incr) - { - unsigned result, tmp; - int flag; - - __asm__ __volatile__("@AO_char_fetch_and_add\n" - AO_THUMB_GO_ARM - "1: ldrexb %0, [%5]\n" - " add %2, %0, %4\n" - " strexb %1, %2, [%5]\n" - " teq %1, #0\n" - " bne 1b\n" - AO_THUMB_RESTORE_MODE - : "=&r" (result), "=&r" (flag), "=&r" (tmp), "+m" (*p) - : "r" ((unsigned)incr), "r" (p) - : AO_THUMB_SWITCH_CLOBBERS "cc"); - return (unsigned char)result; - } -# define AO_HAVE_char_fetch_and_add - - AO_INLINE unsigned short - AO_short_fetch_and_add(volatile unsigned short *p, unsigned short incr) - { - unsigned result, tmp; - int flag; - - __asm__ __volatile__("@AO_short_fetch_and_add\n" - AO_THUMB_GO_ARM - "1: ldrexh %0, [%5]\n" - " add %2, %0, %4\n" - " strexh %1, %2, [%5]\n" - " teq %1, #0\n" - " bne 1b\n" - AO_THUMB_RESTORE_MODE - : "=&r" (result), "=&r" (flag), "=&r" (tmp), "+m" (*p) - : "r" ((unsigned)incr), "r" (p) - : AO_THUMB_SWITCH_CLOBBERS "cc"); - return (unsigned short)result; - } -# define AO_HAVE_short_fetch_and_add -#endif /* AO_ARM_HAVE_LDREXBH */ - -#ifndef AO_GENERALIZE_ASM_BOOL_CAS - /* Returns nonzero if the comparison succeeded. */ - AO_INLINE int - AO_compare_and_swap(volatile AO_t *addr, AO_t old_val, AO_t new_val) - { - AO_t result, tmp; - - __asm__ __volatile__("@AO_compare_and_swap\n" - AO_THUMB_GO_ARM - "1: mov %0, #2\n" /* store a flag */ - " ldrex %1, [%3]\n" /* get original */ - " teq %1, %4\n" /* see if match */ -# ifdef __thumb2__ - /* TODO: Eliminate warning: it blocks containing wide Thumb */ - /* instructions are deprecated in ARMv8. */ - " it eq\n" -# endif - " strexeq %0, %5, [%3]\n" /* store new one if matched */ - " teq %0, #1\n" - " beq 1b\n" /* if update failed, repeat */ - AO_THUMB_RESTORE_MODE - : "=&r"(result), "=&r"(tmp), "+m"(*addr) - : "r"(addr), "r"(old_val), "r"(new_val) - : AO_THUMB_SWITCH_CLOBBERS "cc"); - return !(result&2); /* if succeded, return 1, else 0 */ - } -# define AO_HAVE_compare_and_swap -#endif /* !AO_GENERALIZE_ASM_BOOL_CAS */ - -AO_INLINE AO_t -AO_fetch_compare_and_swap(volatile AO_t *addr, AO_t old_val, AO_t new_val) -{ - AO_t fetched_val; - int flag; - - __asm__ __volatile__("@AO_fetch_compare_and_swap\n" - AO_THUMB_GO_ARM - "1: mov %0, #2\n" /* store a flag */ - " ldrex %1, [%3]\n" /* get original */ - " teq %1, %4\n" /* see if match */ -# ifdef __thumb2__ - " it eq\n" -# endif - " strexeq %0, %5, [%3]\n" /* store new one if matched */ - " teq %0, #1\n" - " beq 1b\n" /* if update failed, repeat */ - AO_THUMB_RESTORE_MODE - : "=&r"(flag), "=&r"(fetched_val), "+m"(*addr) - : "r"(addr), "r"(old_val), "r"(new_val) - : AO_THUMB_SWITCH_CLOBBERS "cc"); - return fetched_val; -} -#define AO_HAVE_fetch_compare_and_swap - -#ifdef AO_ARM_HAVE_LDREXD -# include "../standard_ao_double_t.h" - - /* "ARM Architecture Reference Manual ARMv7-A/R edition" (chapter */ - /* A3.5.3) says that memory accesses caused by LDREXD and STREXD */ - /* instructions to doubleword-aligned locations are single-copy */ - /* atomic; accesses to 64-bit elements by other instructions might */ - /* not be single-copy atomic as they are executed as a sequence of */ - /* 32-bit accesses. */ - AO_INLINE AO_double_t - AO_double_load(const volatile AO_double_t *addr) - { - AO_double_t result; - - /* AO_THUMB_GO_ARM is empty. */ - __asm__ __volatile__("@AO_double_load\n" - " ldrexd %0, %H0, [%1]" - : "=&r" (result.AO_whole) - : "r" (addr) - /* : no clobber */); - return result; - } -# define AO_HAVE_double_load - - AO_INLINE void - AO_double_store(volatile AO_double_t *addr, AO_double_t new_val) - { - AO_double_t old_val; - int status; - - do { - /* AO_THUMB_GO_ARM is empty. */ - __asm__ __volatile__("@AO_double_store\n" - " ldrexd %0, %H0, [%3]\n" - " strexd %1, %4, %H4, [%3]" - : "=&r" (old_val.AO_whole), "=&r" (status), "+m" (*addr) - : "r" (addr), "r" (new_val.AO_whole) - : "cc"); - } while (AO_EXPECT_FALSE(status)); - } -# define AO_HAVE_double_store - - AO_INLINE int - AO_double_compare_and_swap(volatile AO_double_t *addr, - AO_double_t old_val, AO_double_t new_val) - { - double_ptr_storage tmp; - int result = 1; - - do { - /* AO_THUMB_GO_ARM is empty. */ - __asm__ __volatile__("@AO_double_compare_and_swap\n" - " ldrexd %0, %H0, [%1]\n" /* get original to r1 & r2 */ - : "=&r"(tmp) - : "r"(addr) - /* : no clobber */); - if (tmp != old_val.AO_whole) - break; - __asm__ __volatile__( - " strexd %0, %3, %H3, [%2]\n" /* store new one if matched */ - : "=&r"(result), "+m"(*addr) - : "r" (addr), "r" (new_val.AO_whole) - : "cc"); - } while (AO_EXPECT_FALSE(result)); - return !result; /* if succeded, return 1 else 0 */ - } -# define AO_HAVE_double_compare_and_swap -#endif /* AO_ARM_HAVE_LDREXD */ - -#else -/* pre ARMv6 architectures ... */ - -/* I found a slide set that, if I read it correctly, claims that */ -/* Loads followed by either a Load or Store are ordered, but nothing */ -/* else is. */ -/* It appears that SWP is the only simple memory barrier. */ -#include "../all_aligned_atomic_load_store.h" - -/* The code should run correctly on a multi-core ARMv6+ as well. */ - -#endif /* !AO_ARM_HAVE_LDREX */ - -#if !defined(AO_HAVE_test_and_set_full) && !defined(AO_HAVE_test_and_set) \ - && defined (AO_ARM_HAVE_SWP) && (!defined(AO_PREFER_GENERALIZED) \ - || !defined(AO_HAVE_fetch_compare_and_swap)) - AO_INLINE AO_TS_VAL_t - AO_test_and_set_full(volatile AO_TS_t *addr) - { - AO_TS_VAL_t oldval; - /* SWP on ARM is very similar to XCHG on x86. */ - /* The first operand is the result, the second the value */ - /* to be stored. Both registers must be different from addr. */ - /* Make the address operand an early clobber output so it */ - /* doesn't overlap with the other operands. The early clobber */ - /* on oldval is necessary to prevent the compiler allocating */ - /* them to the same register if they are both unused. */ - - __asm__ __volatile__("@AO_test_and_set_full\n" - AO_THUMB_GO_ARM - " swp %0, %2, [%3]\n" - /* Ignore GCC "SWP is deprecated for this architecture" */ - /* warning here (for ARMv6+). */ - AO_THUMB_RESTORE_MODE - : "=&r"(oldval), "=&r"(addr) - : "r"(1), "1"(addr) - : AO_THUMB_SWITCH_CLOBBERS "memory"); - return oldval; - } -# define AO_HAVE_test_and_set_full -#endif /* !AO_HAVE_test_and_set[_full] && AO_ARM_HAVE_SWP */ - -#define AO_T_IS_INT diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/avr32.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/avr32.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/avr32.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/avr32.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,71 +0,0 @@ -/* - * Copyright (C) 2009 Bradley Smith - * - * 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 AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY - * CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, - * TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE - * SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - */ - -#include "../all_atomic_load_store.h" - -#include "../ordered.h" /* There are no multiprocessor implementations. */ - -#include "../test_and_set_t_is_ao_t.h" - -#ifndef AO_PREFER_GENERALIZED - AO_INLINE AO_TS_VAL_t - AO_test_and_set_full(volatile AO_TS_t *addr) - { - register long ret; - - __asm__ __volatile__( - "xchg %[oldval], %[mem], %[newval]" - : [oldval] "=&r"(ret) - : [mem] "r"(addr), [newval] "r"(1) - : "memory"); - - return (AO_TS_VAL_t)ret; - } -# define AO_HAVE_test_and_set_full -#endif /* !AO_PREFER_GENERALIZED */ - -AO_INLINE int -AO_compare_and_swap_full(volatile AO_t *addr, AO_t old, AO_t new_val) -{ - register long ret; - - __asm__ __volatile__( - "1: ssrf 5\n" - " ld.w %[res], %[mem]\n" - " eor %[res], %[oldval]\n" - " brne 2f\n" - " stcond %[mem], %[newval]\n" - " brne 1b\n" - "2:\n" - : [res] "=&r"(ret), [mem] "=m"(*addr) - : "m"(*addr), [newval] "r"(new_val), [oldval] "r"(old) - : "cc", "memory"); - - return (int)ret; -} -#define AO_HAVE_compare_and_swap_full - -/* TODO: implement AO_fetch_compare_and_swap. */ - -#define AO_T_IS_INT diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/cris.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/cris.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/cris.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/cris.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,65 +0,0 @@ -/* - * Copyright (c) 2004 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* FIXME: seems to be untested. */ - -#include "../all_atomic_load_store.h" - -#include "../ordered.h" /* There are no multiprocessor implementations. */ - -#include "../test_and_set_t_is_ao_t.h" - -/* - * The architecture apparently supports an "f" flag which is - * set on preemption. This essentially gives us load-locked, - * store-conditional primitives, though I'm not quite sure how - * this would work on a hypothetical multiprocessor. -HB - * - * For details, see - * http://developer.axis.com/doc/hardware/etrax100lx/prog_man/ - * 1_architectural_description.pdf - * - * Presumably many other primitives (notably CAS, including the double- - * width versions) could be implemented in this manner, if someone got - * around to it. - */ - -AO_INLINE AO_TS_VAL_t -AO_test_and_set_full(volatile AO_TS_t *addr) { - /* Ripped from linuxthreads/sysdeps/cris/pt-machine.h */ - register unsigned long int ret; - - /* Note the use of a dummy output of *addr to expose the write. The - memory barrier is to stop *other* writes being moved past this code. */ - __asm__ __volatile__("clearf\n" - "0:\n\t" - "movu.b [%2],%0\n\t" - "ax\n\t" - "move.b %3,[%2]\n\t" - "bwf 0b\n\t" - "clearf" - : "=&r" (ret), "=m" (*addr) - : "r" (addr), "r" ((int) 1), "m" (*addr) - : "memory"); - return ret; -} -#define AO_HAVE_test_and_set_full diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/generic-arithm.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/generic-arithm.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/generic-arithm.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/generic-arithm.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,704 +0,0 @@ -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -AO_INLINE unsigned/**/char -AO_char_fetch_and_add(volatile unsigned/**/char *addr, unsigned/**/char incr) -{ - return __atomic_fetch_add(addr, incr, __ATOMIC_RELAXED); -} -#define AO_HAVE_char_fetch_and_add - -AO_INLINE void -AO_char_and(volatile unsigned/**/char *addr, unsigned/**/char value) -{ - (void)__atomic_and_fetch(addr, value, __ATOMIC_RELAXED); -} -#define AO_HAVE_char_and - -AO_INLINE void -AO_char_or(volatile unsigned/**/char *addr, unsigned/**/char value) -{ - (void)__atomic_or_fetch(addr, value, __ATOMIC_RELAXED); -} -#define AO_HAVE_char_or - -AO_INLINE void -AO_char_xor(volatile unsigned/**/char *addr, unsigned/**/char value) -{ - (void)__atomic_xor_fetch(addr, value, __ATOMIC_RELAXED); -} -#define AO_HAVE_char_xor -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -AO_INLINE unsigned/**/short -AO_short_fetch_and_add(volatile unsigned/**/short *addr, unsigned/**/short incr) -{ - return __atomic_fetch_add(addr, incr, __ATOMIC_RELAXED); -} -#define AO_HAVE_short_fetch_and_add - -AO_INLINE void -AO_short_and(volatile unsigned/**/short *addr, unsigned/**/short value) -{ - (void)__atomic_and_fetch(addr, value, __ATOMIC_RELAXED); -} -#define AO_HAVE_short_and - -AO_INLINE void -AO_short_or(volatile unsigned/**/short *addr, unsigned/**/short value) -{ - (void)__atomic_or_fetch(addr, value, __ATOMIC_RELAXED); -} -#define AO_HAVE_short_or - -AO_INLINE void -AO_short_xor(volatile unsigned/**/short *addr, unsigned/**/short value) -{ - (void)__atomic_xor_fetch(addr, value, __ATOMIC_RELAXED); -} -#define AO_HAVE_short_xor -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -AO_INLINE unsigned -AO_int_fetch_and_add(volatile unsigned *addr, unsigned incr) -{ - return __atomic_fetch_add(addr, incr, __ATOMIC_RELAXED); -} -#define AO_HAVE_int_fetch_and_add - -AO_INLINE void -AO_int_and(volatile unsigned *addr, unsigned value) -{ - (void)__atomic_and_fetch(addr, value, __ATOMIC_RELAXED); -} -#define AO_HAVE_int_and - -AO_INLINE void -AO_int_or(volatile unsigned *addr, unsigned value) -{ - (void)__atomic_or_fetch(addr, value, __ATOMIC_RELAXED); -} -#define AO_HAVE_int_or - -AO_INLINE void -AO_int_xor(volatile unsigned *addr, unsigned value) -{ - (void)__atomic_xor_fetch(addr, value, __ATOMIC_RELAXED); -} -#define AO_HAVE_int_xor -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -AO_INLINE AO_t -AO_fetch_and_add(volatile AO_t *addr, AO_t incr) -{ - return __atomic_fetch_add(addr, incr, __ATOMIC_RELAXED); -} -#define AO_HAVE_fetch_and_add - -AO_INLINE void -AO_and(volatile AO_t *addr, AO_t value) -{ - (void)__atomic_and_fetch(addr, value, __ATOMIC_RELAXED); -} -#define AO_HAVE_and - -AO_INLINE void -AO_or(volatile AO_t *addr, AO_t value) -{ - (void)__atomic_or_fetch(addr, value, __ATOMIC_RELAXED); -} -#define AO_HAVE_or - -AO_INLINE void -AO_xor(volatile AO_t *addr, AO_t value) -{ - (void)__atomic_xor_fetch(addr, value, __ATOMIC_RELAXED); -} -#define AO_HAVE_xor -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -AO_INLINE unsigned/**/char -AO_char_fetch_and_add_acquire(volatile unsigned/**/char *addr, unsigned/**/char incr) -{ - return __atomic_fetch_add(addr, incr, __ATOMIC_ACQUIRE); -} -#define AO_HAVE_char_fetch_and_add_acquire - -AO_INLINE void -AO_char_and_acquire(volatile unsigned/**/char *addr, unsigned/**/char value) -{ - (void)__atomic_and_fetch(addr, value, __ATOMIC_ACQUIRE); -} -#define AO_HAVE_char_and_acquire - -AO_INLINE void -AO_char_or_acquire(volatile unsigned/**/char *addr, unsigned/**/char value) -{ - (void)__atomic_or_fetch(addr, value, __ATOMIC_ACQUIRE); -} -#define AO_HAVE_char_or_acquire - -AO_INLINE void -AO_char_xor_acquire(volatile unsigned/**/char *addr, unsigned/**/char value) -{ - (void)__atomic_xor_fetch(addr, value, __ATOMIC_ACQUIRE); -} -#define AO_HAVE_char_xor_acquire -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -AO_INLINE unsigned/**/short -AO_short_fetch_and_add_acquire(volatile unsigned/**/short *addr, unsigned/**/short incr) -{ - return __atomic_fetch_add(addr, incr, __ATOMIC_ACQUIRE); -} -#define AO_HAVE_short_fetch_and_add_acquire - -AO_INLINE void -AO_short_and_acquire(volatile unsigned/**/short *addr, unsigned/**/short value) -{ - (void)__atomic_and_fetch(addr, value, __ATOMIC_ACQUIRE); -} -#define AO_HAVE_short_and_acquire - -AO_INLINE void -AO_short_or_acquire(volatile unsigned/**/short *addr, unsigned/**/short value) -{ - (void)__atomic_or_fetch(addr, value, __ATOMIC_ACQUIRE); -} -#define AO_HAVE_short_or_acquire - -AO_INLINE void -AO_short_xor_acquire(volatile unsigned/**/short *addr, unsigned/**/short value) -{ - (void)__atomic_xor_fetch(addr, value, __ATOMIC_ACQUIRE); -} -#define AO_HAVE_short_xor_acquire -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -AO_INLINE unsigned -AO_int_fetch_and_add_acquire(volatile unsigned *addr, unsigned incr) -{ - return __atomic_fetch_add(addr, incr, __ATOMIC_ACQUIRE); -} -#define AO_HAVE_int_fetch_and_add_acquire - -AO_INLINE void -AO_int_and_acquire(volatile unsigned *addr, unsigned value) -{ - (void)__atomic_and_fetch(addr, value, __ATOMIC_ACQUIRE); -} -#define AO_HAVE_int_and_acquire - -AO_INLINE void -AO_int_or_acquire(volatile unsigned *addr, unsigned value) -{ - (void)__atomic_or_fetch(addr, value, __ATOMIC_ACQUIRE); -} -#define AO_HAVE_int_or_acquire - -AO_INLINE void -AO_int_xor_acquire(volatile unsigned *addr, unsigned value) -{ - (void)__atomic_xor_fetch(addr, value, __ATOMIC_ACQUIRE); -} -#define AO_HAVE_int_xor_acquire -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -AO_INLINE AO_t -AO_fetch_and_add_acquire(volatile AO_t *addr, AO_t incr) -{ - return __atomic_fetch_add(addr, incr, __ATOMIC_ACQUIRE); -} -#define AO_HAVE_fetch_and_add_acquire - -AO_INLINE void -AO_and_acquire(volatile AO_t *addr, AO_t value) -{ - (void)__atomic_and_fetch(addr, value, __ATOMIC_ACQUIRE); -} -#define AO_HAVE_and_acquire - -AO_INLINE void -AO_or_acquire(volatile AO_t *addr, AO_t value) -{ - (void)__atomic_or_fetch(addr, value, __ATOMIC_ACQUIRE); -} -#define AO_HAVE_or_acquire - -AO_INLINE void -AO_xor_acquire(volatile AO_t *addr, AO_t value) -{ - (void)__atomic_xor_fetch(addr, value, __ATOMIC_ACQUIRE); -} -#define AO_HAVE_xor_acquire -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -AO_INLINE unsigned/**/char -AO_char_fetch_and_add_release(volatile unsigned/**/char *addr, unsigned/**/char incr) -{ - return __atomic_fetch_add(addr, incr, __ATOMIC_RELEASE); -} -#define AO_HAVE_char_fetch_and_add_release - -AO_INLINE void -AO_char_and_release(volatile unsigned/**/char *addr, unsigned/**/char value) -{ - (void)__atomic_and_fetch(addr, value, __ATOMIC_RELEASE); -} -#define AO_HAVE_char_and_release - -AO_INLINE void -AO_char_or_release(volatile unsigned/**/char *addr, unsigned/**/char value) -{ - (void)__atomic_or_fetch(addr, value, __ATOMIC_RELEASE); -} -#define AO_HAVE_char_or_release - -AO_INLINE void -AO_char_xor_release(volatile unsigned/**/char *addr, unsigned/**/char value) -{ - (void)__atomic_xor_fetch(addr, value, __ATOMIC_RELEASE); -} -#define AO_HAVE_char_xor_release -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -AO_INLINE unsigned/**/short -AO_short_fetch_and_add_release(volatile unsigned/**/short *addr, unsigned/**/short incr) -{ - return __atomic_fetch_add(addr, incr, __ATOMIC_RELEASE); -} -#define AO_HAVE_short_fetch_and_add_release - -AO_INLINE void -AO_short_and_release(volatile unsigned/**/short *addr, unsigned/**/short value) -{ - (void)__atomic_and_fetch(addr, value, __ATOMIC_RELEASE); -} -#define AO_HAVE_short_and_release - -AO_INLINE void -AO_short_or_release(volatile unsigned/**/short *addr, unsigned/**/short value) -{ - (void)__atomic_or_fetch(addr, value, __ATOMIC_RELEASE); -} -#define AO_HAVE_short_or_release - -AO_INLINE void -AO_short_xor_release(volatile unsigned/**/short *addr, unsigned/**/short value) -{ - (void)__atomic_xor_fetch(addr, value, __ATOMIC_RELEASE); -} -#define AO_HAVE_short_xor_release -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -AO_INLINE unsigned -AO_int_fetch_and_add_release(volatile unsigned *addr, unsigned incr) -{ - return __atomic_fetch_add(addr, incr, __ATOMIC_RELEASE); -} -#define AO_HAVE_int_fetch_and_add_release - -AO_INLINE void -AO_int_and_release(volatile unsigned *addr, unsigned value) -{ - (void)__atomic_and_fetch(addr, value, __ATOMIC_RELEASE); -} -#define AO_HAVE_int_and_release - -AO_INLINE void -AO_int_or_release(volatile unsigned *addr, unsigned value) -{ - (void)__atomic_or_fetch(addr, value, __ATOMIC_RELEASE); -} -#define AO_HAVE_int_or_release - -AO_INLINE void -AO_int_xor_release(volatile unsigned *addr, unsigned value) -{ - (void)__atomic_xor_fetch(addr, value, __ATOMIC_RELEASE); -} -#define AO_HAVE_int_xor_release -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -AO_INLINE AO_t -AO_fetch_and_add_release(volatile AO_t *addr, AO_t incr) -{ - return __atomic_fetch_add(addr, incr, __ATOMIC_RELEASE); -} -#define AO_HAVE_fetch_and_add_release - -AO_INLINE void -AO_and_release(volatile AO_t *addr, AO_t value) -{ - (void)__atomic_and_fetch(addr, value, __ATOMIC_RELEASE); -} -#define AO_HAVE_and_release - -AO_INLINE void -AO_or_release(volatile AO_t *addr, AO_t value) -{ - (void)__atomic_or_fetch(addr, value, __ATOMIC_RELEASE); -} -#define AO_HAVE_or_release - -AO_INLINE void -AO_xor_release(volatile AO_t *addr, AO_t value) -{ - (void)__atomic_xor_fetch(addr, value, __ATOMIC_RELEASE); -} -#define AO_HAVE_xor_release -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -AO_INLINE unsigned/**/char -AO_char_fetch_and_add_full(volatile unsigned/**/char *addr, unsigned/**/char incr) -{ - return __atomic_fetch_add(addr, incr, __ATOMIC_SEQ_CST); -} -#define AO_HAVE_char_fetch_and_add_full - -AO_INLINE void -AO_char_and_full(volatile unsigned/**/char *addr, unsigned/**/char value) -{ - (void)__atomic_and_fetch(addr, value, __ATOMIC_SEQ_CST); -} -#define AO_HAVE_char_and_full - -AO_INLINE void -AO_char_or_full(volatile unsigned/**/char *addr, unsigned/**/char value) -{ - (void)__atomic_or_fetch(addr, value, __ATOMIC_SEQ_CST); -} -#define AO_HAVE_char_or_full - -AO_INLINE void -AO_char_xor_full(volatile unsigned/**/char *addr, unsigned/**/char value) -{ - (void)__atomic_xor_fetch(addr, value, __ATOMIC_SEQ_CST); -} -#define AO_HAVE_char_xor_full -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -AO_INLINE unsigned/**/short -AO_short_fetch_and_add_full(volatile unsigned/**/short *addr, unsigned/**/short incr) -{ - return __atomic_fetch_add(addr, incr, __ATOMIC_SEQ_CST); -} -#define AO_HAVE_short_fetch_and_add_full - -AO_INLINE void -AO_short_and_full(volatile unsigned/**/short *addr, unsigned/**/short value) -{ - (void)__atomic_and_fetch(addr, value, __ATOMIC_SEQ_CST); -} -#define AO_HAVE_short_and_full - -AO_INLINE void -AO_short_or_full(volatile unsigned/**/short *addr, unsigned/**/short value) -{ - (void)__atomic_or_fetch(addr, value, __ATOMIC_SEQ_CST); -} -#define AO_HAVE_short_or_full - -AO_INLINE void -AO_short_xor_full(volatile unsigned/**/short *addr, unsigned/**/short value) -{ - (void)__atomic_xor_fetch(addr, value, __ATOMIC_SEQ_CST); -} -#define AO_HAVE_short_xor_full -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -AO_INLINE unsigned -AO_int_fetch_and_add_full(volatile unsigned *addr, unsigned incr) -{ - return __atomic_fetch_add(addr, incr, __ATOMIC_SEQ_CST); -} -#define AO_HAVE_int_fetch_and_add_full - -AO_INLINE void -AO_int_and_full(volatile unsigned *addr, unsigned value) -{ - (void)__atomic_and_fetch(addr, value, __ATOMIC_SEQ_CST); -} -#define AO_HAVE_int_and_full - -AO_INLINE void -AO_int_or_full(volatile unsigned *addr, unsigned value) -{ - (void)__atomic_or_fetch(addr, value, __ATOMIC_SEQ_CST); -} -#define AO_HAVE_int_or_full - -AO_INLINE void -AO_int_xor_full(volatile unsigned *addr, unsigned value) -{ - (void)__atomic_xor_fetch(addr, value, __ATOMIC_SEQ_CST); -} -#define AO_HAVE_int_xor_full -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -AO_INLINE AO_t -AO_fetch_and_add_full(volatile AO_t *addr, AO_t incr) -{ - return __atomic_fetch_add(addr, incr, __ATOMIC_SEQ_CST); -} -#define AO_HAVE_fetch_and_add_full - -AO_INLINE void -AO_and_full(volatile AO_t *addr, AO_t value) -{ - (void)__atomic_and_fetch(addr, value, __ATOMIC_SEQ_CST); -} -#define AO_HAVE_and_full - -AO_INLINE void -AO_or_full(volatile AO_t *addr, AO_t value) -{ - (void)__atomic_or_fetch(addr, value, __ATOMIC_SEQ_CST); -} -#define AO_HAVE_or_full - -AO_INLINE void -AO_xor_full(volatile AO_t *addr, AO_t value) -{ - (void)__atomic_xor_fetch(addr, value, __ATOMIC_SEQ_CST); -} -#define AO_HAVE_xor_full diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/generic-arithm.template ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/generic-arithm.template --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/generic-arithm.template 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/generic-arithm.template 1970-01-01 00:00:00.000000000 +0000 @@ -1,44 +0,0 @@ -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -AO_INLINE XCTYPE -AO_XSIZE_fetch_and_add_XBAR(volatile XCTYPE *addr, XCTYPE incr) -{ - return __atomic_fetch_add(addr, incr, __ATOMIC_XGCCBAR); -} -#define AO_HAVE_XSIZE_fetch_and_add_XBAR - -AO_INLINE void -AO_XSIZE_and_XBAR(volatile XCTYPE *addr, XCTYPE value) -{ - (void)__atomic_and_fetch(addr, value, __ATOMIC_XGCCBAR); -} -#define AO_HAVE_XSIZE_and_XBAR - -AO_INLINE void -AO_XSIZE_or_XBAR(volatile XCTYPE *addr, XCTYPE value) -{ - (void)__atomic_or_fetch(addr, value, __ATOMIC_XGCCBAR); -} -#define AO_HAVE_XSIZE_or_XBAR - -AO_INLINE void -AO_XSIZE_xor_XBAR(volatile XCTYPE *addr, XCTYPE value) -{ - (void)__atomic_xor_fetch(addr, value, __ATOMIC_XGCCBAR); -} -#define AO_HAVE_XSIZE_xor_XBAR diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/generic.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/generic.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/generic.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/generic.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,154 +0,0 @@ -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -/* The following implementation assumes GCC 4.7 or later. */ -/* For the details, see GNU Manual, chapter 6.52 (Built-in functions */ -/* for memory model aware atomic operations). */ - -/* TODO: Include this file for other targets if gcc 4.7+ */ - -#ifdef AO_UNIPROCESSOR - /* If only a single processor (core) is used, AO_UNIPROCESSOR could */ - /* be defined by the client to avoid unnecessary memory barrier. */ - AO_INLINE void - AO_nop_full(void) - { - AO_compiler_barrier(); - } -# define AO_HAVE_nop_full - -#else - AO_INLINE void - AO_nop_read(void) - { - __atomic_thread_fence(__ATOMIC_ACQUIRE); - } -# define AO_HAVE_nop_read - -# ifndef AO_HAVE_nop_write - AO_INLINE void - AO_nop_write(void) - { - __atomic_thread_fence(__ATOMIC_RELEASE); - } -# define AO_HAVE_nop_write -# endif - - AO_INLINE void - AO_nop_full(void) - { - /* __sync_synchronize() could be used instead. */ - __atomic_thread_fence(__ATOMIC_SEQ_CST); - } -# define AO_HAVE_nop_full -#endif /* !AO_UNIPROCESSOR */ - -#include "generic-small.h" - -#ifndef AO_PREFER_GENERALIZED -# include "generic-arithm.h" - - AO_INLINE AO_TS_VAL_t - AO_test_and_set(volatile AO_TS_t *addr) - { - return (AO_TS_VAL_t)__atomic_test_and_set(addr, __ATOMIC_RELAXED); - } -# define AO_HAVE_test_and_set - - AO_INLINE AO_TS_VAL_t - AO_test_and_set_acquire(volatile AO_TS_t *addr) - { - return (AO_TS_VAL_t)__atomic_test_and_set(addr, __ATOMIC_ACQUIRE); - } -# define AO_HAVE_test_and_set_acquire - - AO_INLINE AO_TS_VAL_t - AO_test_and_set_release(volatile AO_TS_t *addr) - { - return (AO_TS_VAL_t)__atomic_test_and_set(addr, __ATOMIC_RELEASE); - } -# define AO_HAVE_test_and_set_release - - AO_INLINE AO_TS_VAL_t - AO_test_and_set_full(volatile AO_TS_t *addr) - { - return (AO_TS_VAL_t)__atomic_test_and_set(addr, __ATOMIC_SEQ_CST); - } -# define AO_HAVE_test_and_set_full -#endif /* !AO_PREFER_GENERALIZED */ - -#ifdef AO_HAVE_DOUBLE_PTR_STORAGE - -# ifndef AO_HAVE_double_load - AO_INLINE AO_double_t - AO_double_load(const volatile AO_double_t *addr) - { - AO_double_t result; - - result.AO_whole = __atomic_load_n(&addr->AO_whole, __ATOMIC_RELAXED); - return result; - } -# define AO_HAVE_double_load -# endif - -# ifndef AO_HAVE_double_load_acquire - AO_INLINE AO_double_t - AO_double_load_acquire(const volatile AO_double_t *addr) - { - AO_double_t result; - - result.AO_whole = __atomic_load_n(&addr->AO_whole, __ATOMIC_ACQUIRE); - return result; - } -# define AO_HAVE_double_load_acquire -# endif - -# ifndef AO_HAVE_double_store - AO_INLINE void - AO_double_store(volatile AO_double_t *addr, AO_double_t value) - { - __atomic_store_n(&addr->AO_whole, value.AO_whole, __ATOMIC_RELAXED); - } -# define AO_HAVE_double_store -# endif - -# ifndef AO_HAVE_double_store_release - AO_INLINE void - AO_double_store_release(volatile AO_double_t *addr, AO_double_t value) - { - __atomic_store_n(&addr->AO_whole, value.AO_whole, __ATOMIC_RELEASE); - } -# define AO_HAVE_double_store_release -# endif - -# ifndef AO_HAVE_double_compare_and_swap - AO_INLINE int - AO_double_compare_and_swap(volatile AO_double_t *addr, - AO_double_t old_val, AO_double_t new_val) - { - return (int)__atomic_compare_exchange_n(&addr->AO_whole, - &old_val.AO_whole /* p_expected */, - new_val.AO_whole /* desired */, - 0 /* is_weak: false */, - __ATOMIC_RELAXED /* success */, - __ATOMIC_RELAXED /* failure */); - } -# define AO_HAVE_double_compare_and_swap -# endif - - /* TODO: Add double CAS _acquire/release/full primitives. */ -#endif /* AO_HAVE_DOUBLE_PTR_STORAGE */ diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/generic-small.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/generic-small.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/generic-small.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/generic-small.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,280 +0,0 @@ -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -AO_INLINE unsigned/**/char -AO_char_load(const volatile unsigned/**/char *addr) -{ - return __atomic_load_n(addr, __ATOMIC_RELAXED); -} -#define AO_HAVE_char_load - -AO_INLINE unsigned/**/char -AO_char_load_acquire(const volatile unsigned/**/char *addr) -{ - return __atomic_load_n(addr, __ATOMIC_ACQUIRE); -} -#define AO_HAVE_char_load_acquire - -/* char_load_full is generalized using load and nop_full, so that */ -/* char_load_read is defined using load and nop_read. */ -/* char_store_full definition is omitted similar to load_full reason. */ - -AO_INLINE void -AO_char_store(volatile unsigned/**/char *addr, unsigned/**/char value) -{ - __atomic_store_n(addr, value, __ATOMIC_RELAXED); -} -#define AO_HAVE_char_store - -AO_INLINE void -AO_char_store_release(volatile unsigned/**/char *addr, unsigned/**/char value) -{ - __atomic_store_n(addr, value, __ATOMIC_RELEASE); -} -#define AO_HAVE_char_store_release - -AO_INLINE unsigned/**/char -AO_char_fetch_compare_and_swap(volatile unsigned/**/char *addr, - unsigned/**/char old_val, unsigned/**/char new_val) -{ - return __sync_val_compare_and_swap(addr, old_val, new_val - /* empty protection list */); -} -#define AO_HAVE_char_fetch_compare_and_swap - -/* TODO: Add CAS _acquire/release/full primitives. */ - -#ifndef AO_GENERALIZE_ASM_BOOL_CAS - AO_INLINE int - AO_char_compare_and_swap(volatile unsigned/**/char *addr, - unsigned/**/char old_val, unsigned/**/char new_val) - { - return __sync_bool_compare_and_swap(addr, old_val, new_val - /* empty protection list */); - } -# define AO_HAVE_char_compare_and_swap -#endif /* !AO_GENERALIZE_ASM_BOOL_CAS */ -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -AO_INLINE unsigned/**/short -AO_short_load(const volatile unsigned/**/short *addr) -{ - return __atomic_load_n(addr, __ATOMIC_RELAXED); -} -#define AO_HAVE_short_load - -AO_INLINE unsigned/**/short -AO_short_load_acquire(const volatile unsigned/**/short *addr) -{ - return __atomic_load_n(addr, __ATOMIC_ACQUIRE); -} -#define AO_HAVE_short_load_acquire - -/* short_load_full is generalized using load and nop_full, so that */ -/* short_load_read is defined using load and nop_read. */ -/* short_store_full definition is omitted similar to load_full reason. */ - -AO_INLINE void -AO_short_store(volatile unsigned/**/short *addr, unsigned/**/short value) -{ - __atomic_store_n(addr, value, __ATOMIC_RELAXED); -} -#define AO_HAVE_short_store - -AO_INLINE void -AO_short_store_release(volatile unsigned/**/short *addr, unsigned/**/short value) -{ - __atomic_store_n(addr, value, __ATOMIC_RELEASE); -} -#define AO_HAVE_short_store_release - -AO_INLINE unsigned/**/short -AO_short_fetch_compare_and_swap(volatile unsigned/**/short *addr, - unsigned/**/short old_val, unsigned/**/short new_val) -{ - return __sync_val_compare_and_swap(addr, old_val, new_val - /* empty protection list */); -} -#define AO_HAVE_short_fetch_compare_and_swap - -/* TODO: Add CAS _acquire/release/full primitives. */ - -#ifndef AO_GENERALIZE_ASM_BOOL_CAS - AO_INLINE int - AO_short_compare_and_swap(volatile unsigned/**/short *addr, - unsigned/**/short old_val, unsigned/**/short new_val) - { - return __sync_bool_compare_and_swap(addr, old_val, new_val - /* empty protection list */); - } -# define AO_HAVE_short_compare_and_swap -#endif /* !AO_GENERALIZE_ASM_BOOL_CAS */ -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -AO_INLINE unsigned -AO_int_load(const volatile unsigned *addr) -{ - return __atomic_load_n(addr, __ATOMIC_RELAXED); -} -#define AO_HAVE_int_load - -AO_INLINE unsigned -AO_int_load_acquire(const volatile unsigned *addr) -{ - return __atomic_load_n(addr, __ATOMIC_ACQUIRE); -} -#define AO_HAVE_int_load_acquire - -/* int_load_full is generalized using load and nop_full, so that */ -/* int_load_read is defined using load and nop_read. */ -/* int_store_full definition is omitted similar to load_full reason. */ - -AO_INLINE void -AO_int_store(volatile unsigned *addr, unsigned value) -{ - __atomic_store_n(addr, value, __ATOMIC_RELAXED); -} -#define AO_HAVE_int_store - -AO_INLINE void -AO_int_store_release(volatile unsigned *addr, unsigned value) -{ - __atomic_store_n(addr, value, __ATOMIC_RELEASE); -} -#define AO_HAVE_int_store_release - -AO_INLINE unsigned -AO_int_fetch_compare_and_swap(volatile unsigned *addr, - unsigned old_val, unsigned new_val) -{ - return __sync_val_compare_and_swap(addr, old_val, new_val - /* empty protection list */); -} -#define AO_HAVE_int_fetch_compare_and_swap - -/* TODO: Add CAS _acquire/release/full primitives. */ - -#ifndef AO_GENERALIZE_ASM_BOOL_CAS - AO_INLINE int - AO_int_compare_and_swap(volatile unsigned *addr, - unsigned old_val, unsigned new_val) - { - return __sync_bool_compare_and_swap(addr, old_val, new_val - /* empty protection list */); - } -# define AO_HAVE_int_compare_and_swap -#endif /* !AO_GENERALIZE_ASM_BOOL_CAS */ -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -AO_INLINE AO_t -AO_load(const volatile AO_t *addr) -{ - return __atomic_load_n(addr, __ATOMIC_RELAXED); -} -#define AO_HAVE_load - -AO_INLINE AO_t -AO_load_acquire(const volatile AO_t *addr) -{ - return __atomic_load_n(addr, __ATOMIC_ACQUIRE); -} -#define AO_HAVE_load_acquire - -/* load_full is generalized using load and nop_full, so that */ -/* load_read is defined using load and nop_read. */ -/* store_full definition is omitted similar to load_full reason. */ - -AO_INLINE void -AO_store(volatile AO_t *addr, AO_t value) -{ - __atomic_store_n(addr, value, __ATOMIC_RELAXED); -} -#define AO_HAVE_store - -AO_INLINE void -AO_store_release(volatile AO_t *addr, AO_t value) -{ - __atomic_store_n(addr, value, __ATOMIC_RELEASE); -} -#define AO_HAVE_store_release - -AO_INLINE AO_t -AO_fetch_compare_and_swap(volatile AO_t *addr, - AO_t old_val, AO_t new_val) -{ - return __sync_val_compare_and_swap(addr, old_val, new_val - /* empty protection list */); -} -#define AO_HAVE_fetch_compare_and_swap - -/* TODO: Add CAS _acquire/release/full primitives. */ - -#ifndef AO_GENERALIZE_ASM_BOOL_CAS - AO_INLINE int - AO_compare_and_swap(volatile AO_t *addr, - AO_t old_val, AO_t new_val) - { - return __sync_bool_compare_and_swap(addr, old_val, new_val - /* empty protection list */); - } -# define AO_HAVE_compare_and_swap -#endif /* !AO_GENERALIZE_ASM_BOOL_CAS */ diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/generic-small.template ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/generic-small.template --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/generic-small.template 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/generic-small.template 1970-01-01 00:00:00.000000000 +0000 @@ -1,70 +0,0 @@ -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -AO_INLINE XCTYPE -AO_XSIZE_load(const volatile XCTYPE *addr) -{ - return __atomic_load_n(addr, __ATOMIC_RELAXED); -} -#define AO_HAVE_XSIZE_load - -AO_INLINE XCTYPE -AO_XSIZE_load_acquire(const volatile XCTYPE *addr) -{ - return __atomic_load_n(addr, __ATOMIC_ACQUIRE); -} -#define AO_HAVE_XSIZE_load_acquire - -/* XSIZE_load_full is generalized using load and nop_full, so that */ -/* XSIZE_load_read is defined using load and nop_read. */ -/* XSIZE_store_full definition is omitted similar to load_full reason. */ - -AO_INLINE void -AO_XSIZE_store(volatile XCTYPE *addr, XCTYPE value) -{ - __atomic_store_n(addr, value, __ATOMIC_RELAXED); -} -#define AO_HAVE_XSIZE_store - -AO_INLINE void -AO_XSIZE_store_release(volatile XCTYPE *addr, XCTYPE value) -{ - __atomic_store_n(addr, value, __ATOMIC_RELEASE); -} -#define AO_HAVE_XSIZE_store_release - -AO_INLINE XCTYPE -AO_XSIZE_fetch_compare_and_swap(volatile XCTYPE *addr, - XCTYPE old_val, XCTYPE new_val) -{ - return __sync_val_compare_and_swap(addr, old_val, new_val - /* empty protection list */); -} -#define AO_HAVE_XSIZE_fetch_compare_and_swap - -/* TODO: Add CAS _acquire/release/full primitives. */ - -#ifndef AO_GENERALIZE_ASM_BOOL_CAS - AO_INLINE int - AO_XSIZE_compare_and_swap(volatile XCTYPE *addr, - XCTYPE old_val, XCTYPE new_val) - { - return __sync_bool_compare_and_swap(addr, old_val, new_val - /* empty protection list */); - } -# define AO_HAVE_XSIZE_compare_and_swap -#endif /* !AO_GENERALIZE_ASM_BOOL_CAS */ diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/hexagon.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/hexagon.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/hexagon.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/hexagon.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,122 +0,0 @@ -/* - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#include "../all_aligned_atomic_load_store.h" - -#include "../test_and_set_t_is_ao_t.h" - -/* There's also "isync" and "barrier"; however, for all current CPU */ -/* versions, "syncht" should suffice. Likewise, it seems that the */ -/* auto-defined versions of *_acquire, *_release or *_full suffice for */ -/* all current ISA implementations. */ -AO_INLINE void -AO_nop_full(void) -{ - __asm__ __volatile__("syncht" : : : "memory"); -} -#define AO_HAVE_nop_full - -/* The Hexagon has load-locked, store-conditional primitives, and so */ -/* resulting code is very nearly identical to that of PowerPC. */ - -#ifndef AO_PREFER_GENERALIZED -AO_INLINE AO_t -AO_fetch_and_add(volatile AO_t *addr, AO_t incr) -{ - AO_t oldval; - AO_t newval; - __asm__ __volatile__( - "1:\n" - " %0 = memw_locked(%3);\n" /* load and reserve */ - " %1 = add (%0,%4);\n" /* increment */ - " memw_locked(%3,p1) = %1;\n" /* store conditional */ - " if (!p1) jump 1b;\n" /* retry if lost reservation */ - : "=&r"(oldval), "=&r"(newval), "+m"(*addr) - : "r"(addr), "r"(incr) - : "memory", "p1"); - return oldval; -} -#define AO_HAVE_fetch_and_add - -AO_INLINE AO_TS_VAL_t -AO_test_and_set(volatile AO_TS_t *addr) -{ - int oldval; - int locked_value = 1; - - __asm__ __volatile__( - "1:\n" - " %0 = memw_locked(%2);\n" /* load and reserve */ - " {\n" - " p2 = cmp.eq(%0,#0);\n" /* if load is not zero, */ - " if (!p2.new) jump:nt 2f; \n" /* we are done */ - " }\n" - " memw_locked(%2,p1) = %3;\n" /* else store conditional */ - " if (!p1) jump 1b;\n" /* retry if lost reservation */ - "2:\n" /* oldval is zero if we set */ - : "=&r"(oldval), "+m"(*addr) - : "r"(addr), "r"(locked_value) - : "memory", "p1", "p2"); - return (AO_TS_VAL_t)oldval; -} -#define AO_HAVE_test_and_set -#endif /* !AO_PREFER_GENERALIZED */ - -#ifndef AO_GENERALIZE_ASM_BOOL_CAS - AO_INLINE int - AO_compare_and_swap(volatile AO_t *addr, AO_t old, AO_t new_val) - { - AO_t __oldval; - int result = 0; - __asm__ __volatile__( - "1:\n" - " %0 = memw_locked(%3);\n" /* load and reserve */ - " {\n" - " p2 = cmp.eq(%0,%4);\n" /* if load is not equal to */ - " if (!p2.new) jump:nt 2f; \n" /* old, fail */ - " }\n" - " memw_locked(%3,p1) = %5;\n" /* else store conditional */ - " if (!p1) jump 1b;\n" /* retry if lost reservation */ - " %1 = #1\n" /* success, result = 1 */ - "2:\n" - : "=&r" (__oldval), "+r" (result), "+m"(*addr) - : "r" (addr), "r" (old), "r" (new_val) - : "p1", "p2", "memory" - ); - return result; - } -# define AO_HAVE_compare_and_swap -#endif /* !AO_GENERALIZE_ASM_BOOL_CAS */ - -AO_INLINE AO_t -AO_fetch_compare_and_swap(volatile AO_t *addr, AO_t old_val, AO_t new_val) -{ - AO_t __oldval; - - __asm__ __volatile__( - "1:\n" - " %0 = memw_locked(%2);\n" /* load and reserve */ - " {\n" - " p2 = cmp.eq(%0,%3);\n" /* if load is not equal to */ - " if (!p2.new) jump:nt 2f; \n" /* old_val, fail */ - " }\n" - " memw_locked(%2,p1) = %4;\n" /* else store conditional */ - " if (!p1) jump 1b;\n" /* retry if lost reservation */ - "2:\n" - : "=&r" (__oldval), "+m"(*addr) - : "r" (addr), "r" (old_val), "r" (new_val) - : "p1", "p2", "memory" - ); - return __oldval; -} -#define AO_HAVE_fetch_compare_and_swap - -#define AO_T_IS_INT diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/hppa.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/hppa.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/hppa.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/hppa.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,89 +0,0 @@ -/* - * Copyright (c) 2003 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -#include "../all_atomic_load_store.h" - -/* Some architecture set descriptions include special "ordered" memory */ -/* operations. As far as we can tell, no existing processors actually */ -/* require those. Nor does it appear likely that future processors */ -/* will. */ -#include "../ordered.h" - -/* GCC will not guarantee the alignment we need, use four lock words */ -/* and select the correctly aligned datum. See the glibc 2.3.2 */ -/* linuxthread port for the original implementation. */ -struct AO_pa_clearable_loc { - int data[4]; -}; - -#undef AO_TS_INITIALIZER -#define AO_TS_t struct AO_pa_clearable_loc -#define AO_TS_INITIALIZER {1,1,1,1} -/* Switch meaning of set and clear, since we only have an atomic clear */ -/* instruction. */ -typedef enum {AO_PA_TS_set = 0, AO_PA_TS_clear = 1} AO_PA_TS_val; -#define AO_TS_VAL_t AO_PA_TS_val -#define AO_TS_CLEAR AO_PA_TS_clear -#define AO_TS_SET AO_PA_TS_set - -/* The hppa only has one atomic read and modify memory operation, */ -/* load and clear, so hppa spinlocks must use zero to signify that */ -/* someone is holding the lock. The address used for the ldcw */ -/* semaphore must be 16-byte aligned. */ -#define AO_ldcw(a, ret) \ - __asm__ __volatile__("ldcw 0(%2), %0" \ - : "=r" (ret), "=m" (*(a)) : "r" (a)) - -/* Because malloc only guarantees 8-byte alignment for malloc'd data, */ -/* and GCC only guarantees 8-byte alignment for stack locals, we can't */ -/* be assured of 16-byte alignment for atomic lock data even if we */ -/* specify "__attribute ((aligned(16)))" in the type declaration. So, */ -/* we use a struct containing an array of four ints for the atomic lock */ -/* type and dynamically select the 16-byte aligned int from the array */ -/* for the semaphore. */ -#define AO_PA_LDCW_ALIGNMENT 16 -#define AO_ldcw_align(addr) \ - ((volatile unsigned *)(((unsigned long)(addr) \ - + (AO_PA_LDCW_ALIGNMENT - 1)) \ - & ~(AO_PA_LDCW_ALIGNMENT - 1))) - -/* Works on PA 1.1 and PA 2.0 systems */ -AO_INLINE AO_TS_VAL_t -AO_test_and_set_full(volatile AO_TS_t * addr) -{ - volatile unsigned int ret; - volatile unsigned *a = AO_ldcw_align(addr); - - AO_ldcw(a, ret); - return (AO_TS_VAL_t)ret; -} -#define AO_HAVE_test_and_set_full - -AO_INLINE void -AO_pa_clear(volatile AO_TS_t * addr) -{ - volatile unsigned *a = AO_ldcw_align(addr); - - AO_compiler_barrier(); - *a = 1; -} -#define AO_CLEAR(addr) AO_pa_clear(addr) diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/ia64.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/ia64.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/ia64.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/ia64.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,281 +0,0 @@ -/* - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -#include "../all_atomic_load_store.h" - -#include "../all_acquire_release_volatile.h" - -#include "../test_and_set_t_is_char.h" - -#ifdef _ILP32 - /* 32-bit HP/UX code. */ - /* This requires pointer "swizzling". Pointers need to be expanded */ - /* to 64 bits using the addp4 instruction before use. This makes it */ - /* hard to share code, but we try anyway. */ -# define AO_LEN "4" - /* We assume that addr always appears in argument position 1 in asm */ - /* code. If it is clobbered due to swizzling, we also need it in */ - /* second position. Any later arguments are referenced symbolically, */ - /* so that we don't have to worry about their position. This requires*/ - /* gcc 3.1, but you shouldn't be using anything older than that on */ - /* IA64 anyway. */ - /* The AO_MASK macro is a workaround for the fact that HP/UX gcc */ - /* appears to otherwise store 64-bit pointers in ar.ccv, i.e. it */ - /* doesn't appear to clear high bits in a pointer value we pass into */ - /* assembly code, even if it is supposedly of type AO_t. */ -# define AO_IN_ADDR "1"(addr) -# define AO_OUT_ADDR , "=r"(addr) -# define AO_SWIZZLE "addp4 %1=0,%1;;\n" -# define AO_MASK(ptr) __asm__ __volatile__("zxt4 %1=%1": "=r"(ptr) : "0"(ptr)) -#else -# define AO_LEN "8" -# define AO_IN_ADDR "r"(addr) -# define AO_OUT_ADDR -# define AO_SWIZZLE -# define AO_MASK(ptr) /* empty */ -#endif /* !_ILP32 */ - -AO_INLINE void -AO_nop_full(void) -{ - __asm__ __volatile__("mf" : : : "memory"); -} -#define AO_HAVE_nop_full - -#ifndef AO_PREFER_GENERALIZED -AO_INLINE AO_t -AO_fetch_and_add1_acquire (volatile AO_t *addr) -{ - AO_t result; - - __asm__ __volatile__ (AO_SWIZZLE - "fetchadd" AO_LEN ".acq %0=[%1],1": - "=r" (result) AO_OUT_ADDR: AO_IN_ADDR :"memory"); - return result; -} -#define AO_HAVE_fetch_and_add1_acquire - -AO_INLINE AO_t -AO_fetch_and_add1_release (volatile AO_t *addr) -{ - AO_t result; - - __asm__ __volatile__ (AO_SWIZZLE - "fetchadd" AO_LEN ".rel %0=[%1],1": - "=r" (result) AO_OUT_ADDR: AO_IN_ADDR :"memory"); - return result; -} -#define AO_HAVE_fetch_and_add1_release - -AO_INLINE AO_t -AO_fetch_and_sub1_acquire (volatile AO_t *addr) -{ - AO_t result; - - __asm__ __volatile__ (AO_SWIZZLE - "fetchadd" AO_LEN ".acq %0=[%1],-1": - "=r" (result) AO_OUT_ADDR: AO_IN_ADDR :"memory"); - return result; -} -#define AO_HAVE_fetch_and_sub1_acquire - -AO_INLINE AO_t -AO_fetch_and_sub1_release (volatile AO_t *addr) -{ - AO_t result; - - __asm__ __volatile__ (AO_SWIZZLE - "fetchadd" AO_LEN ".rel %0=[%1],-1": - "=r" (result) AO_OUT_ADDR: AO_IN_ADDR :"memory"); - return result; -} -#define AO_HAVE_fetch_and_sub1_release -#endif /* !AO_PREFER_GENERALIZED */ - -AO_INLINE AO_t -AO_fetch_compare_and_swap_acquire(volatile AO_t *addr, AO_t old, AO_t new_val) -{ - AO_t fetched_val; - AO_MASK(old); - __asm__ __volatile__(AO_SWIZZLE - "mov ar.ccv=%[old] ;; cmpxchg" AO_LEN - ".acq %0=[%1],%[new_val],ar.ccv" - : "=r"(fetched_val) AO_OUT_ADDR - : AO_IN_ADDR, [new_val]"r"(new_val), [old]"r"(old) - : "memory"); - return fetched_val; -} -#define AO_HAVE_fetch_compare_and_swap_acquire - -AO_INLINE AO_t -AO_fetch_compare_and_swap_release(volatile AO_t *addr, AO_t old, AO_t new_val) -{ - AO_t fetched_val; - AO_MASK(old); - __asm__ __volatile__(AO_SWIZZLE - "mov ar.ccv=%[old] ;; cmpxchg" AO_LEN - ".rel %0=[%1],%[new_val],ar.ccv" - : "=r"(fetched_val) AO_OUT_ADDR - : AO_IN_ADDR, [new_val]"r"(new_val), [old]"r"(old) - : "memory"); - return fetched_val; -} -#define AO_HAVE_fetch_compare_and_swap_release - -AO_INLINE unsigned char -AO_char_fetch_compare_and_swap_acquire(volatile unsigned char *addr, - unsigned char old, unsigned char new_val) -{ - unsigned char fetched_val; - __asm__ __volatile__(AO_SWIZZLE - "mov ar.ccv=%[old] ;; cmpxchg1.acq %0=[%1],%[new_val],ar.ccv" - : "=r"(fetched_val) AO_OUT_ADDR - : AO_IN_ADDR, [new_val]"r"(new_val), [old]"r"((AO_t)old) - : "memory"); - return fetched_val; -} -#define AO_HAVE_char_fetch_compare_and_swap_acquire - -AO_INLINE unsigned char -AO_char_fetch_compare_and_swap_release(volatile unsigned char *addr, - unsigned char old, unsigned char new_val) -{ - unsigned char fetched_val; - __asm__ __volatile__(AO_SWIZZLE - "mov ar.ccv=%[old] ;; cmpxchg1.rel %0=[%1],%[new_val],ar.ccv" - : "=r"(fetched_val) AO_OUT_ADDR - : AO_IN_ADDR, [new_val]"r"(new_val), [old]"r"((AO_t)old) - : "memory"); - return fetched_val; -} -#define AO_HAVE_char_fetch_compare_and_swap_release - -AO_INLINE unsigned short -AO_short_fetch_compare_and_swap_acquire(volatile unsigned short *addr, - unsigned short old, unsigned short new_val) -{ - unsigned short fetched_val; - __asm__ __volatile__(AO_SWIZZLE - "mov ar.ccv=%[old] ;; cmpxchg2.acq %0=[%1],%[new_val],ar.ccv" - : "=r"(fetched_val) AO_OUT_ADDR - : AO_IN_ADDR, [new_val]"r"(new_val), [old]"r"((AO_t)old) - : "memory"); - return fetched_val; -} -#define AO_HAVE_short_fetch_compare_and_swap_acquire - -AO_INLINE unsigned short -AO_short_fetch_compare_and_swap_release(volatile unsigned short *addr, - unsigned short old, unsigned short new_val) -{ - unsigned short fetched_val; - __asm__ __volatile__(AO_SWIZZLE - "mov ar.ccv=%[old] ;; cmpxchg2.rel %0=[%1],%[new_val],ar.ccv" - : "=r"(fetched_val) AO_OUT_ADDR - : AO_IN_ADDR, [new_val]"r"(new_val), [old]"r"((AO_t)old) - : "memory"); - return fetched_val; -} -#define AO_HAVE_short_fetch_compare_and_swap_release - -#ifdef _ILP32 - -# define AO_T_IS_INT - - /* TODO: Add compare_double_and_swap_double for the _ILP32 case. */ -#else - -# ifndef AO_PREFER_GENERALIZED - AO_INLINE unsigned int - AO_int_fetch_and_add1_acquire(volatile unsigned int *addr) - { - unsigned int result; - __asm__ __volatile__("fetchadd4.acq %0=[%1],1" - : "=r" (result) : AO_IN_ADDR - : "memory"); - return result; - } -# define AO_HAVE_int_fetch_and_add1_acquire - - AO_INLINE unsigned int - AO_int_fetch_and_add1_release(volatile unsigned int *addr) - { - unsigned int result; - __asm__ __volatile__("fetchadd4.rel %0=[%1],1" - : "=r" (result) : AO_IN_ADDR - : "memory"); - return result; - } -# define AO_HAVE_int_fetch_and_add1_release - - AO_INLINE unsigned int - AO_int_fetch_and_sub1_acquire(volatile unsigned int *addr) - { - unsigned int result; - __asm__ __volatile__("fetchadd4.acq %0=[%1],-1" - : "=r" (result) : AO_IN_ADDR - : "memory"); - return result; - } -# define AO_HAVE_int_fetch_and_sub1_acquire - - AO_INLINE unsigned int - AO_int_fetch_and_sub1_release(volatile unsigned int *addr) - { - unsigned int result; - __asm__ __volatile__("fetchadd4.rel %0=[%1],-1" - : "=r" (result) : AO_IN_ADDR - : "memory"); - return result; - } -# define AO_HAVE_int_fetch_and_sub1_release -# endif /* !AO_PREFER_GENERALIZED */ - - AO_INLINE unsigned int - AO_int_fetch_compare_and_swap_acquire(volatile unsigned int *addr, - unsigned int old, unsigned int new_val) - { - unsigned int fetched_val; - __asm__ __volatile__("mov ar.ccv=%3 ;; cmpxchg4.acq %0=[%1],%2,ar.ccv" - : "=r"(fetched_val) - : AO_IN_ADDR, "r"(new_val), "r"((AO_t)old) - : "memory"); - return fetched_val; - } -# define AO_HAVE_int_fetch_compare_and_swap_acquire - - AO_INLINE unsigned int - AO_int_fetch_compare_and_swap_release(volatile unsigned int *addr, - unsigned int old, unsigned int new_val) - { - unsigned int fetched_val; - __asm__ __volatile__("mov ar.ccv=%3 ;; cmpxchg4.rel %0=[%1],%2,ar.ccv" - : "=r"(fetched_val) - : AO_IN_ADDR, "r"(new_val), "r"((AO_t)old) - : "memory"); - return fetched_val; - } -# define AO_HAVE_int_fetch_compare_and_swap_release -#endif /* !_ILP32 */ - -/* TODO: Add compare_and_swap_double as soon as there is widely */ -/* available hardware that implements it. */ diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/m68k.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/m68k.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/m68k.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/m68k.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,68 +0,0 @@ -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 1999-2003 by Hewlett-Packard Company. All rights reserved. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -/* The cas instruction causes an emulation trap for the */ -/* 060 with a misaligned pointer, so let's avoid this. */ -#undef AO_t -typedef unsigned long AO_t __attribute__ ((aligned (4))); - -/* FIXME. Very incomplete. */ -#include "../all_aligned_atomic_load_store.h" - -/* Are there any m68k multiprocessors still around? */ -/* AFAIK, Alliants were sequentially consistent. */ -#include "../ordered.h" - -#include "../test_and_set_t_is_char.h" - -AO_INLINE AO_TS_VAL_t -AO_test_and_set_full(volatile AO_TS_t *addr) { - AO_TS_t oldval; - - /* The value at addr is semi-phony. */ - /* 'tas' sets bit 7 while the return */ - /* value pretends all bits were set, */ - /* which at least matches AO_TS_SET. */ - __asm__ __volatile__( - "tas %1; sne %0" - : "=d" (oldval), "=m" (*addr) - : "m" (*addr) - : "memory"); - /* This cast works due to the above. */ - return (AO_TS_VAL_t)oldval; -} -#define AO_HAVE_test_and_set_full - -/* Returns nonzero if the comparison succeeded. */ -AO_INLINE int -AO_compare_and_swap_full(volatile AO_t *addr, - AO_t old, AO_t new_val) -{ - char result; - - __asm__ __volatile__( - "cas.l %3,%4,%1; seq %0" - : "=d" (result), "=m" (*addr) - : "m" (*addr), "d" (old), "d" (new_val) - : "memory"); - return -result; -} -#define AO_HAVE_compare_and_swap_full - -/* TODO: implement AO_fetch_compare_and_swap. */ - -#define AO_T_IS_INT diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/mips.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/mips.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/mips.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/mips.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,176 +0,0 @@ -/* - * Copyright (c) 2005,2007 Thiemo Seufer - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -/* - * FIXME: This should probably make finer distinctions. SGI MIPS is - * much more strongly ordered, and in fact closer to sequentially - * consistent. This is really aimed at modern embedded implementations. - */ - -#include "../all_aligned_atomic_load_store.h" - -#include "../test_and_set_t_is_ao_t.h" - -/* Data dependence does not imply read ordering. */ -#define AO_NO_DD_ORDERING - -#if defined(_ABI64) && (_MIPS_SIM == _ABI64) -# define AO_MIPS_SET_ISA " .set mips3\n" -# define AO_MIPS_LL_1(args) " lld " args "\n" -# define AO_MIPS_SC(args) " scd " args "\n" -#else -# define AO_MIPS_SET_ISA " .set mips2\n" -# define AO_MIPS_LL_1(args) " ll " args "\n" -# define AO_MIPS_SC(args) " sc " args "\n" -# define AO_T_IS_INT -#endif - -#ifdef AO_ICE9A1_LLSC_WAR - /* ICE9 rev A1 chip (used in very few systems) is reported to */ - /* have a low-frequency bug that causes LL to fail. */ - /* To workaround, just issue the second 'LL'. */ -# define AO_MIPS_LL(args) AO_MIPS_LL_1(args) AO_MIPS_LL_1(args) -#else -# define AO_MIPS_LL(args) AO_MIPS_LL_1(args) -#endif - -AO_INLINE void -AO_nop_full(void) -{ - __asm__ __volatile__( - " .set push \n" - AO_MIPS_SET_ISA - " .set noreorder \n" - " .set nomacro \n" - " sync \n" - " .set pop " - : : : "memory"); -} -#define AO_HAVE_nop_full - -#ifndef AO_PREFER_GENERALIZED -AO_INLINE AO_t -AO_fetch_and_add(volatile AO_t *addr, AO_t incr) -{ - register int result; - register int temp; - - __asm__ __volatile__( - " .set push\n" - AO_MIPS_SET_ISA - " .set noreorder\n" - " .set nomacro\n" - "1: " - AO_MIPS_LL("%0, %2") - " addu %1, %0, %3\n" - AO_MIPS_SC("%1, %2") - " beqz %1, 1b\n" - " nop\n" - " .set pop " - : "=&r" (result), "=&r" (temp), "+m" (*addr) - : "Ir" (incr) - : "memory"); - return (AO_t)result; -} -#define AO_HAVE_fetch_and_add - -AO_INLINE AO_TS_VAL_t -AO_test_and_set(volatile AO_TS_t *addr) -{ - register int oldval; - register int temp; - - __asm__ __volatile__( - " .set push\n" - AO_MIPS_SET_ISA - " .set noreorder\n" - " .set nomacro\n" - "1: " - AO_MIPS_LL("%0, %2") - " move %1, %3\n" - AO_MIPS_SC("%1, %2") - " beqz %1, 1b\n" - " nop\n" - " .set pop " - : "=&r" (oldval), "=&r" (temp), "+m" (*addr) - : "r" (1) - : "memory"); - return (AO_TS_VAL_t)oldval; -} -#define AO_HAVE_test_and_set - - /* TODO: Implement AO_and/or/xor primitives directly. */ -#endif /* !AO_PREFER_GENERALIZED */ - -#ifndef AO_GENERALIZE_ASM_BOOL_CAS - AO_INLINE int - AO_compare_and_swap(volatile AO_t *addr, AO_t old, AO_t new_val) - { - register int was_equal = 0; - register int temp; - - __asm__ __volatile__( - " .set push \n" - AO_MIPS_SET_ISA - " .set noreorder \n" - " .set nomacro \n" - "1: " - AO_MIPS_LL("%0, %1") - " bne %0, %4, 2f \n" - " move %0, %3 \n" - AO_MIPS_SC("%0, %1") - " .set pop \n" - " beqz %0, 1b \n" - " li %2, 1 \n" - "2: " - : "=&r" (temp), "+m" (*addr), "+r" (was_equal) - : "r" (new_val), "r" (old) - : "memory"); - return was_equal; - } -# define AO_HAVE_compare_and_swap -#endif /* !AO_GENERALIZE_ASM_BOOL_CAS */ - -AO_INLINE AO_t -AO_fetch_compare_and_swap(volatile AO_t *addr, AO_t old, AO_t new_val) -{ - register int fetched_val; - register int temp; - - __asm__ __volatile__( - " .set push\n" - AO_MIPS_SET_ISA - " .set noreorder\n" - " .set nomacro\n" - "1: " - AO_MIPS_LL("%0, %2") - " bne %0, %4, 2f\n" - " move %1, %3\n" - AO_MIPS_SC("%1, %2") - " beqz %1, 1b\n" - " nop\n" - " .set pop\n" - "2:" - : "=&r" (fetched_val), "=&r" (temp), "+m" (*addr) - : "r" (new_val), "Jr" (old) - : "memory"); - return (AO_t)fetched_val; -} -#define AO_HAVE_fetch_compare_and_swap - -/* #include "../standard_ao_double_t.h" */ -/* TODO: Implement double-wide operations if available. */ - -/* CAS primitives with acquire, release and full semantics are */ -/* generated automatically (and AO_int_... primitives are */ -/* defined properly after the first generalization pass). */ diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/powerpc.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/powerpc.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/powerpc.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/powerpc.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,359 +0,0 @@ -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -/* Memory model documented at http://www-106.ibm.com/developerworks/ */ -/* eserver/articles/archguide.html and (clearer) */ -/* http://www-106.ibm.com/developerworks/eserver/articles/powerpc.html. */ -/* There appears to be no implicit ordering between any kind of */ -/* independent memory references. */ -/* Architecture enforces some ordering based on control dependence. */ -/* I don't know if that could help. */ -/* Data-dependent loads are always ordered. */ -/* Based on the above references, eieio is intended for use on */ -/* uncached memory, which we don't support. It does not order loads */ -/* from cached memory. */ - -#include "../all_aligned_atomic_load_store.h" - -#include "../test_and_set_t_is_ao_t.h" - /* There seems to be no byte equivalent of lwarx, so this */ - /* may really be what we want, at least in the 32-bit case. */ - -AO_INLINE void -AO_nop_full(void) -{ - __asm__ __volatile__("sync" : : : "memory"); -} -#define AO_HAVE_nop_full - -/* lwsync apparently works for everything but a StoreLoad barrier. */ -AO_INLINE void -AO_lwsync(void) -{ -#ifdef __NO_LWSYNC__ - __asm__ __volatile__("sync" : : : "memory"); -#else - __asm__ __volatile__("lwsync" : : : "memory"); -#endif -} - -#define AO_nop_write() AO_lwsync() -#define AO_HAVE_nop_write - -#define AO_nop_read() AO_lwsync() -#define AO_HAVE_nop_read - -/* We explicitly specify load_acquire, since it is important, and can */ -/* be implemented relatively cheaply. It could be implemented */ -/* with an ordinary load followed by a lwsync. But the general wisdom */ -/* seems to be that a data dependent branch followed by an isync is */ -/* cheaper. And the documentation is fairly explicit that this also */ -/* has acquire semantics. */ -/* ppc64 uses ld not lwz */ -AO_INLINE AO_t -AO_load_acquire(const volatile AO_t *addr) -{ - AO_t result; -#if defined(__powerpc64__) || defined(__ppc64__) || defined(__64BIT__) - __asm__ __volatile__ ( - "ld%U1%X1 %0,%1\n" - "cmpw %0,%0\n" - "bne- 1f\n" - "1: isync\n" - : "=r" (result) - : "m"(*addr) : "memory", "cr0"); -#else - /* FIXME: We should get gcc to allocate one of the condition */ - /* registers. I always got "impossible constraint" when I */ - /* tried the "y" constraint. */ - __asm__ __volatile__ ( - "lwz%U1%X1 %0,%1\n" - "cmpw %0,%0\n" - "bne- 1f\n" - "1: isync\n" - : "=r" (result) - : "m"(*addr) : "memory", "cc"); -#endif - return result; -} -#define AO_HAVE_load_acquire - -/* We explicitly specify store_release, since it relies */ -/* on the fact that lwsync is also a LoadStore barrier. */ -AO_INLINE void -AO_store_release(volatile AO_t *addr, AO_t value) -{ - AO_lwsync(); - *addr = value; -} -#define AO_HAVE_store_release - -#ifndef AO_PREFER_GENERALIZED -/* This is similar to the code in the garbage collector. Deleting */ -/* this and having it synthesized from compare_and_swap would probably */ -/* only cost us a load immediate instruction. */ -AO_INLINE AO_TS_VAL_t -AO_test_and_set(volatile AO_TS_t *addr) { -#if defined(__powerpc64__) || defined(__ppc64__) || defined(__64BIT__) -/* Completely untested. And we should be using smaller objects anyway. */ - unsigned long oldval; - unsigned long temp = 1; /* locked value */ - - __asm__ __volatile__( - "1:ldarx %0,0,%1\n" /* load and reserve */ - "cmpdi %0, 0\n" /* if load is */ - "bne 2f\n" /* non-zero, return already set */ - "stdcx. %2,0,%1\n" /* else store conditional */ - "bne- 1b\n" /* retry if lost reservation */ - "2:\n" /* oldval is zero if we set */ - : "=&r"(oldval) - : "r"(addr), "r"(temp) - : "memory", "cr0"); -#else - int oldval; - int temp = 1; /* locked value */ - - __asm__ __volatile__( - "1:lwarx %0,0,%1\n" /* load and reserve */ - "cmpwi %0, 0\n" /* if load is */ - "bne 2f\n" /* non-zero, return already set */ - "stwcx. %2,0,%1\n" /* else store conditional */ - "bne- 1b\n" /* retry if lost reservation */ - "2:\n" /* oldval is zero if we set */ - : "=&r"(oldval) - : "r"(addr), "r"(temp) - : "memory", "cr0"); -#endif - return (AO_TS_VAL_t)oldval; -} -#define AO_HAVE_test_and_set - -AO_INLINE AO_TS_VAL_t -AO_test_and_set_acquire(volatile AO_TS_t *addr) { - AO_TS_VAL_t result = AO_test_and_set(addr); - AO_lwsync(); - return result; -} -#define AO_HAVE_test_and_set_acquire - -AO_INLINE AO_TS_VAL_t -AO_test_and_set_release(volatile AO_TS_t *addr) { - AO_lwsync(); - return AO_test_and_set(addr); -} -#define AO_HAVE_test_and_set_release - -AO_INLINE AO_TS_VAL_t -AO_test_and_set_full(volatile AO_TS_t *addr) { - AO_TS_VAL_t result; - AO_lwsync(); - result = AO_test_and_set(addr); - AO_lwsync(); - return result; -} -#define AO_HAVE_test_and_set_full -#endif /* !AO_PREFER_GENERALIZED */ - -#ifndef AO_GENERALIZE_ASM_BOOL_CAS - - AO_INLINE int - AO_compare_and_swap(volatile AO_t *addr, AO_t old, AO_t new_val) - { - AO_t oldval; - int result = 0; -# if defined(__powerpc64__) || defined(__ppc64__) || defined(__64BIT__) - __asm__ __volatile__( - "1:ldarx %0,0,%2\n" /* load and reserve */ - "cmpd %0, %4\n" /* if load is not equal to */ - "bne 2f\n" /* old, fail */ - "stdcx. %3,0,%2\n" /* else store conditional */ - "bne- 1b\n" /* retry if lost reservation */ - "li %1,1\n" /* result = 1; */ - "2:\n" - : "=&r"(oldval), "=&r"(result) - : "r"(addr), "r"(new_val), "r"(old), "1"(result) - : "memory", "cr0"); -# else - __asm__ __volatile__( - "1:lwarx %0,0,%2\n" /* load and reserve */ - "cmpw %0, %4\n" /* if load is not equal to */ - "bne 2f\n" /* old, fail */ - "stwcx. %3,0,%2\n" /* else store conditional */ - "bne- 1b\n" /* retry if lost reservation */ - "li %1,1\n" /* result = 1; */ - "2:\n" - : "=&r"(oldval), "=&r"(result) - : "r"(addr), "r"(new_val), "r"(old), "1"(result) - : "memory", "cr0"); -# endif - return result; - } -# define AO_HAVE_compare_and_swap - - AO_INLINE int - AO_compare_and_swap_acquire(volatile AO_t *addr, AO_t old, AO_t new_val) - { - int result = AO_compare_and_swap(addr, old, new_val); - AO_lwsync(); - return result; - } -# define AO_HAVE_compare_and_swap_acquire - - AO_INLINE int - AO_compare_and_swap_release(volatile AO_t *addr, AO_t old, AO_t new_val) - { - AO_lwsync(); - return AO_compare_and_swap(addr, old, new_val); - } -# define AO_HAVE_compare_and_swap_release - - AO_INLINE int - AO_compare_and_swap_full(volatile AO_t *addr, AO_t old, AO_t new_val) - { - int result; - AO_lwsync(); - result = AO_compare_and_swap(addr, old, new_val); - AO_lwsync(); - return result; - } -# define AO_HAVE_compare_and_swap_full - -#endif /* !AO_GENERALIZE_ASM_BOOL_CAS */ - -AO_INLINE AO_t -AO_fetch_compare_and_swap(volatile AO_t *addr, AO_t old_val, AO_t new_val) -{ - AO_t fetched_val; -# if defined(__powerpc64__) || defined(__ppc64__) || defined(__64BIT__) - __asm__ __volatile__( - "1:ldarx %0,0,%1\n" /* load and reserve */ - "cmpd %0, %3\n" /* if load is not equal to */ - "bne 2f\n" /* old_val, fail */ - "stdcx. %2,0,%1\n" /* else store conditional */ - "bne- 1b\n" /* retry if lost reservation */ - "2:\n" - : "=&r"(fetched_val) - : "r"(addr), "r"(new_val), "r"(old_val) - : "memory", "cr0"); -# else - __asm__ __volatile__( - "1:lwarx %0,0,%1\n" /* load and reserve */ - "cmpw %0, %3\n" /* if load is not equal to */ - "bne 2f\n" /* old_val, fail */ - "stwcx. %2,0,%1\n" /* else store conditional */ - "bne- 1b\n" /* retry if lost reservation */ - "2:\n" - : "=&r"(fetched_val) - : "r"(addr), "r"(new_val), "r"(old_val) - : "memory", "cr0"); -# endif - return fetched_val; -} -#define AO_HAVE_fetch_compare_and_swap - -AO_INLINE AO_t -AO_fetch_compare_and_swap_acquire(volatile AO_t *addr, AO_t old_val, - AO_t new_val) -{ - AO_t result = AO_fetch_compare_and_swap(addr, old_val, new_val); - AO_lwsync(); - return result; -} -#define AO_HAVE_fetch_compare_and_swap_acquire - -AO_INLINE AO_t -AO_fetch_compare_and_swap_release(volatile AO_t *addr, AO_t old_val, - AO_t new_val) -{ - AO_lwsync(); - return AO_fetch_compare_and_swap(addr, old_val, new_val); -} -#define AO_HAVE_fetch_compare_and_swap_release - -AO_INLINE AO_t -AO_fetch_compare_and_swap_full(volatile AO_t *addr, AO_t old_val, - AO_t new_val) -{ - AO_t result; - AO_lwsync(); - result = AO_fetch_compare_and_swap(addr, old_val, new_val); - AO_lwsync(); - return result; -} -#define AO_HAVE_fetch_compare_and_swap_full - -#ifndef AO_PREFER_GENERALIZED -AO_INLINE AO_t -AO_fetch_and_add(volatile AO_t *addr, AO_t incr) { - AO_t oldval; - AO_t newval; -#if defined(__powerpc64__) || defined(__ppc64__) || defined(__64BIT__) - __asm__ __volatile__( - "1:ldarx %0,0,%2\n" /* load and reserve */ - "add %1,%0,%3\n" /* increment */ - "stdcx. %1,0,%2\n" /* store conditional */ - "bne- 1b\n" /* retry if lost reservation */ - : "=&r"(oldval), "=&r"(newval) - : "r"(addr), "r"(incr) - : "memory", "cr0"); -#else - __asm__ __volatile__( - "1:lwarx %0,0,%2\n" /* load and reserve */ - "add %1,%0,%3\n" /* increment */ - "stwcx. %1,0,%2\n" /* store conditional */ - "bne- 1b\n" /* retry if lost reservation */ - : "=&r"(oldval), "=&r"(newval) - : "r"(addr), "r"(incr) - : "memory", "cr0"); -#endif - return oldval; -} -#define AO_HAVE_fetch_and_add - -AO_INLINE AO_t -AO_fetch_and_add_acquire(volatile AO_t *addr, AO_t incr) { - AO_t result = AO_fetch_and_add(addr, incr); - AO_lwsync(); - return result; -} -#define AO_HAVE_fetch_and_add_acquire - -AO_INLINE AO_t -AO_fetch_and_add_release(volatile AO_t *addr, AO_t incr) { - AO_lwsync(); - return AO_fetch_and_add(addr, incr); -} -#define AO_HAVE_fetch_and_add_release - -AO_INLINE AO_t -AO_fetch_and_add_full(volatile AO_t *addr, AO_t incr) { - AO_t result; - AO_lwsync(); - result = AO_fetch_and_add(addr, incr); - AO_lwsync(); - return result; -} -#define AO_HAVE_fetch_and_add_full -#endif /* !AO_PREFER_GENERALIZED */ - -#if defined(__powerpc64__) || defined(__ppc64__) || defined(__64BIT__) - /* Empty */ -#else -# define AO_T_IS_INT -#endif - -/* TODO: Implement double-wide operations if available. */ diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/s390.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/s390.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/s390.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/s390.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,65 +0,0 @@ -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 1999-2003 by Hewlett-Packard Company. All rights reserved. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -/* FIXME: untested. */ -/* The relevant documentation appears to be at */ -/* http://publibz.boulder.ibm.com/epubs/pdf/dz9zr003.pdf */ -/* around page 5-96. Apparently: */ -/* - Memory references in general are atomic only for a single */ -/* byte. But it appears that the most common load/store */ -/* instructions also guarantee atomicity for aligned */ -/* operands of standard types. WE FOOLISHLY ASSUME that */ -/* compilers only generate those. If that turns out to be */ -/* wrong, we need inline assembly code for AO_load and */ -/* AO_store. */ -/* - A store followed by a load is unordered since the store */ -/* may be delayed. Otherwise everything is ordered. */ -/* - There is a hardware compare-and-swap (CS) instruction. */ - -#include "../all_aligned_atomic_load_store.h" - -#include "../ordered_except_wr.h" - -#include "../test_and_set_t_is_ao_t.h" -/* FIXME: Is there a way to do byte-sized test-and-set? */ - -/* TODO: AO_nop_full should probably be implemented directly. */ -/* It appears that certain BCR instructions have that effect. */ -/* Presumably they're cheaper than CS? */ - -AO_INLINE int AO_compare_and_swap_full(volatile AO_t *addr, - AO_t old, AO_t new_val) -{ - int retval; - __asm__ __volatile__ ( -# ifndef __s390x__ - " cs %1,%2,0(%3)\n" -# else - " csg %1,%2,0(%3)\n" -# endif - " ipm %0\n" - " srl %0,28\n" - : "=&d" (retval), "+d" (old) - : "d" (new_val), "a" (addr) - : "cc", "memory"); - return retval == 0; -} -#define AO_HAVE_compare_and_swap_full - -/* TODO: implement AO_fetch_compare_and_swap. */ - -/* TODO: Add double-wide operations for 32-bit executables. */ diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/sh.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/sh.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/sh.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/sh.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,34 +0,0 @@ -/* - * Copyright (c) 2009 by Takashi YOSHII. All rights reserved. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#include "../all_atomic_load_store.h" -#include "../ordered.h" - -/* sh has tas.b(byte) only */ -#include "../test_and_set_t_is_char.h" - -AO_INLINE AO_TS_VAL_t -AO_test_and_set_full(volatile AO_TS_t *addr) -{ - int oldval; - __asm__ __volatile__( - "tas.b @%1; movt %0" - : "=r" (oldval) - : "r" (addr) - : "t", "memory"); - return oldval? AO_TS_CLEAR : AO_TS_SET; -} -#define AO_HAVE_test_and_set_full - -/* TODO: Very incomplete. */ diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/sparc.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/sparc.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/sparc.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/sparc.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,69 +0,0 @@ -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 1999-2003 by Hewlett-Packard Company. All rights reserved. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -/* TODO: Very incomplete; Add support for sparc64. */ -/* Non-ancient SPARCs provide compare-and-swap (casa). */ - -#include "../all_atomic_load_store.h" - -/* Real SPARC code uses TSO: */ -#include "../ordered_except_wr.h" - -/* Test_and_set location is just a byte. */ -#include "../test_and_set_t_is_char.h" - -AO_INLINE AO_TS_VAL_t -AO_test_and_set_full(volatile AO_TS_t *addr) { - AO_TS_VAL_t oldval; - - __asm__ __volatile__("ldstub %1,%0" - : "=r"(oldval), "=m"(*addr) - : "m"(*addr) : "memory"); - return oldval; -} -#define AO_HAVE_test_and_set_full - -#ifndef AO_NO_SPARC_V9 -/* Returns nonzero if the comparison succeeded. */ -AO_INLINE int -AO_compare_and_swap_full(volatile AO_t *addr, AO_t old, AO_t new_val) { - char ret; - __asm__ __volatile__ ("membar #StoreLoad | #LoadLoad\n\t" -# if defined(__arch64__) - "casx [%2],%0,%1\n\t" -# else - "cas [%2],%0,%1\n\t" /* 32-bit version */ -# endif - "membar #StoreLoad | #StoreStore\n\t" - "cmp %0,%1\n\t" - "be,a 0f\n\t" - "mov 1,%0\n\t"/* one insn after branch always executed */ - "clr %0\n\t" - "0:\n\t" - : "=r" (ret), "+r" (new_val) - : "r" (addr), "0" (old) - : "memory", "cc"); - return (int)ret; -} -#define AO_HAVE_compare_and_swap_full - -/* TODO: implement AO_fetch_compare_and_swap. */ -#endif /* !AO_NO_SPARC_V9 */ - -/* TODO: Extend this for SPARC v8 and v9 (V8 also has swap, V9 has CAS, */ -/* there are barriers like membar #LoadStore, CASA (32-bit) and */ -/* CASXA (64-bit) instructions added in V9). */ diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/x86.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/x86.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/x86.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/gcc/x86.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,360 +0,0 @@ -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 1999-2003 by Hewlett-Packard Company. All rights reserved. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - * Some of the machine specific code was borrowed from our GC distribution. - */ - -/* The following really assume we have a 486 or better. Unfortunately */ -/* gcc doesn't define a suitable feature test macro based on command */ -/* line options. */ -/* We should perhaps test dynamically. */ - -#include "../all_aligned_atomic_load_store.h" - -#include "../test_and_set_t_is_char.h" - -#if defined(__SSE2__) && !defined(AO_USE_PENTIUM4_INSTRS) - /* "mfence" is a part of SSE2 set (introduced on Intel Pentium 4). */ -# define AO_USE_PENTIUM4_INSTRS -#endif - -#if defined(AO_USE_PENTIUM4_INSTRS) - AO_INLINE void - AO_nop_full(void) - { - __asm__ __volatile__("mfence" : : : "memory"); - } -# define AO_HAVE_nop_full - -#else - /* We could use the cpuid instruction. But that seems to be slower */ - /* than the default implementation based on test_and_set_full. Thus */ - /* we omit that bit of misinformation here. */ -#endif /* !AO_USE_PENTIUM4_INSTRS */ - -/* As far as we can tell, the lfence and sfence instructions are not */ -/* currently needed or useful for cached memory accesses. */ - -/* Really only works for 486 and later */ -#ifndef AO_PREFER_GENERALIZED - AO_INLINE AO_t - AO_fetch_and_add_full (volatile AO_t *p, AO_t incr) - { - AO_t result; - - __asm__ __volatile__ ("lock; xadd %0, %1" : - "=r" (result), "=m" (*p) : "0" (incr), "m" (*p) - : "memory"); - return result; - } -# define AO_HAVE_fetch_and_add_full -#endif /* !AO_PREFER_GENERALIZED */ - -AO_INLINE unsigned char -AO_char_fetch_and_add_full (volatile unsigned char *p, unsigned char incr) -{ - unsigned char result; - - __asm__ __volatile__ ("lock; xaddb %0, %1" : - "=q" (result), "=m" (*p) : "0" (incr), "m" (*p) - : "memory"); - return result; -} -#define AO_HAVE_char_fetch_and_add_full - -AO_INLINE unsigned short -AO_short_fetch_and_add_full (volatile unsigned short *p, unsigned short incr) -{ - unsigned short result; - - __asm__ __volatile__ ("lock; xaddw %0, %1" : - "=r" (result), "=m" (*p) : "0" (incr), "m" (*p) - : "memory"); - return result; -} -#define AO_HAVE_short_fetch_and_add_full - -#ifndef AO_PREFER_GENERALIZED - /* Really only works for 486 and later */ - AO_INLINE void - AO_and_full (volatile AO_t *p, AO_t value) - { - __asm__ __volatile__ ("lock; and %1, %0" : - "=m" (*p) : "r" (value), "m" (*p) - : "memory"); - } -# define AO_HAVE_and_full - - AO_INLINE void - AO_or_full (volatile AO_t *p, AO_t value) - { - __asm__ __volatile__ ("lock; or %1, %0" : - "=m" (*p) : "r" (value), "m" (*p) - : "memory"); - } -# define AO_HAVE_or_full - - AO_INLINE void - AO_xor_full (volatile AO_t *p, AO_t value) - { - __asm__ __volatile__ ("lock; xor %1, %0" : - "=m" (*p) : "r" (value), "m" (*p) - : "memory"); - } -# define AO_HAVE_xor_full - - /* AO_store_full could be implemented directly using "xchg" but it */ - /* could be generalized efficiently as an ordinary store accomplished */ - /* with AO_nop_full ("mfence" instruction). */ -#endif /* !AO_PREFER_GENERALIZED */ - -AO_INLINE AO_TS_VAL_t -AO_test_and_set_full(volatile AO_TS_t *addr) -{ - unsigned char oldval; - /* Note: the "xchg" instruction does not need a "lock" prefix */ - __asm__ __volatile__ ("xchgb %0, %1" - : "=q" (oldval), "=m" (*addr) - : "0" ((unsigned char)0xff), "m" (*addr) - : "memory"); - return (AO_TS_VAL_t)oldval; -} -#define AO_HAVE_test_and_set_full - -#ifndef AO_GENERALIZE_ASM_BOOL_CAS - /* Returns nonzero if the comparison succeeded. */ - AO_INLINE int - AO_compare_and_swap_full(volatile AO_t *addr, AO_t old, AO_t new_val) - { -# ifdef AO_USE_SYNC_CAS_BUILTIN - return (int)__sync_bool_compare_and_swap(addr, old, new_val - /* empty protection list */); - /* Note: an empty list of variables protected by the */ - /* memory barrier should mean all globally accessible */ - /* variables are protected. */ -# else - char result; - __asm__ __volatile__ ("lock; cmpxchg %3, %0; setz %1" - : "=m" (*addr), "=a" (result) - : "m" (*addr), "r" (new_val), "a" (old) - : "memory"); - return (int)result; -# endif - } -# define AO_HAVE_compare_and_swap_full -#endif /* !AO_GENERALIZE_ASM_BOOL_CAS */ - -AO_INLINE AO_t -AO_fetch_compare_and_swap_full(volatile AO_t *addr, AO_t old_val, - AO_t new_val) -{ -# ifdef AO_USE_SYNC_CAS_BUILTIN - return __sync_val_compare_and_swap(addr, old_val, new_val - /* empty protection list */); -# else - AO_t fetched_val; - __asm__ __volatile__ ("lock; cmpxchg %3, %4" - : "=a" (fetched_val), "=m" (*addr) - : "a" (old_val), "r" (new_val), "m" (*addr) - : "memory"); - return fetched_val; -# endif -} -#define AO_HAVE_fetch_compare_and_swap_full - -#if !defined(__x86_64__) && !defined(AO_USE_SYNC_CAS_BUILTIN) -# include "../standard_ao_double_t.h" - - /* Reading or writing a quadword aligned on a 64-bit boundary is */ - /* always carried out atomically on at least a Pentium according to */ - /* Chapter 8.1.1 of Volume 3A Part 1 of Intel processor manuals. */ -# define AO_ACCESS_double_CHECK_ALIGNED -# include "../loadstore/double_atomic_load_store.h" - - /* Returns nonzero if the comparison succeeded. */ - /* Really requires at least a Pentium. */ - AO_INLINE int - AO_compare_double_and_swap_double_full(volatile AO_double_t *addr, - AO_t old_val1, AO_t old_val2, - AO_t new_val1, AO_t new_val2) - { - char result; -# ifdef __PIC__ - AO_t saved_ebx; - - /* If PIC is turned on, we cannot use ebx as it is reserved for the */ - /* GOT pointer. We should save and restore ebx. The proposed */ - /* solution is not so efficient as the older alternatives using */ - /* push ebx or edi as new_val1 (w/o clobbering edi and temporary */ - /* local variable usage) but it is more portable (it works even if */ - /* ebx is not used as GOT pointer, and it works for the buggy GCC */ - /* releases that incorrectly evaluate memory operands offset in the */ - /* inline assembly after push). */ -# ifdef __OPTIMIZE__ - __asm__ __volatile__("mov %%ebx, %2\n\t" /* save ebx */ - "lea %0, %%edi\n\t" /* in case addr is in ebx */ - "mov %7, %%ebx\n\t" /* load new_val1 */ - "lock; cmpxchg8b (%%edi)\n\t" - "mov %2, %%ebx\n\t" /* restore ebx */ - "setz %1" - : "=m" (*addr), "=a" (result), "=m" (saved_ebx) - : "m" (*addr), "d" (old_val2), "a" (old_val1), - "c" (new_val2), "m" (new_val1) - : "%edi", "memory"); -# else - /* A less-efficient code manually preserving edi if GCC invoked */ - /* with -O0 option (otherwise it fails while finding a register */ - /* in class 'GENERAL_REGS'). */ - AO_t saved_edi; - __asm__ __volatile__("mov %%edi, %3\n\t" /* save edi */ - "mov %%ebx, %2\n\t" /* save ebx */ - "lea %0, %%edi\n\t" /* in case addr is in ebx */ - "mov %8, %%ebx\n\t" /* load new_val1 */ - "lock; cmpxchg8b (%%edi)\n\t" - "mov %2, %%ebx\n\t" /* restore ebx */ - "mov %3, %%edi\n\t" /* restore edi */ - "setz %1" - : "=m" (*addr), "=a" (result), - "=m" (saved_ebx), "=m" (saved_edi) - : "m" (*addr), "d" (old_val2), "a" (old_val1), - "c" (new_val2), "m" (new_val1) : "memory"); -# endif -# else - /* For non-PIC mode, this operation could be simplified (and be */ - /* faster) by using ebx as new_val1 (GCC would refuse to compile */ - /* such code for PIC mode). */ - __asm__ __volatile__ ("lock; cmpxchg8b %0; setz %1" - : "=m" (*addr), "=a" (result) - : "m" (*addr), "d" (old_val2), "a" (old_val1), - "c" (new_val2), "b" (new_val1) - : "memory"); -# endif - return (int) result; - } -# define AO_HAVE_compare_double_and_swap_double_full - -# define AO_T_IS_INT - -#elif defined(__ILP32__) || !defined(__x86_64__) -# include "../standard_ao_double_t.h" - - /* Reading or writing a quadword aligned on a 64-bit boundary is */ - /* always carried out atomically (requires at least a Pentium). */ -# define AO_ACCESS_double_CHECK_ALIGNED -# include "../loadstore/double_atomic_load_store.h" - - /* X32 has native support for 64-bit integer operations (AO_double_t */ - /* is a 64-bit integer and we could use 64-bit cmpxchg). */ - /* This primitive is used by compare_double_and_swap_double_full. */ - AO_INLINE int - AO_double_compare_and_swap_full(volatile AO_double_t *addr, - AO_double_t old_val, AO_double_t new_val) - { - /* It is safe to use __sync CAS built-in here. */ - return __sync_bool_compare_and_swap(&addr->AO_whole, - old_val.AO_whole, new_val.AO_whole - /* empty protection list */); - } -# define AO_HAVE_double_compare_and_swap_full - -# define AO_T_IS_INT - -#else /* 64-bit */ - - AO_INLINE unsigned int - AO_int_fetch_and_add_full (volatile unsigned int *p, unsigned int incr) - { - unsigned int result; - - __asm__ __volatile__ ("lock; xaddl %0, %1" - : "=r" (result), "=m" (*p) - : "0" (incr), "m" (*p) - : "memory"); - return result; - } -# define AO_HAVE_int_fetch_and_add_full - - /* The Intel and AMD Architecture Programmer Manuals state roughly */ - /* the following: */ - /* - CMPXCHG16B (with a LOCK prefix) can be used to perform 16-byte */ - /* atomic accesses in 64-bit mode (with certain alignment */ - /* restrictions); */ - /* - SSE instructions that access data larger than a quadword (like */ - /* MOVDQA) may be implemented using multiple memory accesses; */ - /* - LOCK prefix causes an invalid-opcode exception when used with */ - /* 128-bit media (SSE) instructions. */ - /* Thus, currently, the only way to implement lock-free double_load */ - /* and double_store on x86_64 is to use CMPXCHG16B (if available). */ - -/* TODO: Test some gcc macro to detect presence of cmpxchg16b. */ - -# ifdef AO_CMPXCHG16B_AVAILABLE -# include "../standard_ao_double_t.h" - - /* NEC LE-IT: older AMD Opterons are missing this instruction. */ - /* On these machines SIGILL will be thrown. */ - /* Define AO_WEAK_DOUBLE_CAS_EMULATION to have an emulated (lock */ - /* based) version available. */ - /* HB: Changed this to not define either by default. There are */ - /* enough machines and tool chains around on which cmpxchg16b */ - /* doesn't work. And the emulation is unsafe by our usual rules. */ - /* However both are clearly useful in certain cases. */ - AO_INLINE int - AO_compare_double_and_swap_double_full(volatile AO_double_t *addr, - AO_t old_val1, AO_t old_val2, - AO_t new_val1, AO_t new_val2) - { - char result; - __asm__ __volatile__("lock; cmpxchg16b %0; setz %1" - : "=m"(*addr), "=a"(result) - : "m"(*addr), "d" (old_val2), "a" (old_val1), - "c" (new_val2), "b" (new_val1) - : "memory"); - return (int) result; - } -# define AO_HAVE_compare_double_and_swap_double_full - -# elif defined(AO_WEAK_DOUBLE_CAS_EMULATION) -# include "../standard_ao_double_t.h" - - /* This one provides spinlock based emulation of CAS implemented in */ - /* atomic_ops.c. We probably do not want to do this here, since it */ - /* is not atomic with respect to other kinds of updates of *addr. */ - /* On the other hand, this may be a useful facility on occasion. */ - int AO_compare_double_and_swap_double_emulation( - volatile AO_double_t *addr, - AO_t old_val1, AO_t old_val2, - AO_t new_val1, AO_t new_val2); - - AO_INLINE int - AO_compare_double_and_swap_double_full(volatile AO_double_t *addr, - AO_t old_val1, AO_t old_val2, - AO_t new_val1, AO_t new_val2) - { - return AO_compare_double_and_swap_double_emulation(addr, - old_val1, old_val2, new_val1, new_val2); - } -# define AO_HAVE_compare_double_and_swap_double_full -# endif /* AO_WEAK_DOUBLE_CAS_EMULATION && !AO_CMPXCHG16B_AVAILABLE */ - -#endif /* x86_64 && !ILP32 */ - -/* Real X86 implementations, except for some old 32-bit WinChips, */ -/* appear to enforce ordering between memory operations, EXCEPT that */ -/* a later read can pass earlier writes, presumably due to the visible */ -/* presence of store buffers. */ -/* We ignore both the WinChips and the fact that the official specs */ -/* seem to be much weaker (and arguably too weak to be usable). */ -#include "../ordered_except_wr.h" diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/generic_pthread.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/generic_pthread.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/generic_pthread.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/generic_pthread.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,434 +0,0 @@ -/* - * Copyright (c) 2003 by Hewlett-Packard Company. All rights reserved. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* The following is useful primarily for debugging and documentation. */ -/* We define various atomic operations by acquiring a global pthread */ -/* lock. The resulting implementation will perform poorly, but should */ -/* be correct unless it is used from signal handlers. */ -/* We assume that all pthread operations act like full memory barriers. */ -/* (We believe that is the intent of the specification.) */ - -#include - -#include "test_and_set_t_is_ao_t.h" - /* This is not necessarily compatible with the native */ - /* implementation. But those can't be safely mixed anyway. */ - -/* We define only the full barrier variants, and count on the */ -/* generalization section below to fill in the rest. */ -extern pthread_mutex_t AO_pt_lock; - -AO_INLINE void -AO_nop_full(void) -{ - pthread_mutex_lock(&AO_pt_lock); - pthread_mutex_unlock(&AO_pt_lock); -} -#define AO_HAVE_nop_full - -AO_INLINE AO_t -AO_load_full(const volatile AO_t *addr) -{ - AO_t result; - pthread_mutex_lock(&AO_pt_lock); - result = *addr; - pthread_mutex_unlock(&AO_pt_lock); - return result; -} -#define AO_HAVE_load_full - -AO_INLINE void -AO_store_full(volatile AO_t *addr, AO_t val) -{ - pthread_mutex_lock(&AO_pt_lock); - *addr = val; - pthread_mutex_unlock(&AO_pt_lock); -} -#define AO_HAVE_store_full - -AO_INLINE unsigned char -AO_char_load_full(const volatile unsigned char *addr) -{ - unsigned char result; - pthread_mutex_lock(&AO_pt_lock); - result = *addr; - pthread_mutex_unlock(&AO_pt_lock); - return result; -} -#define AO_HAVE_char_load_full - -AO_INLINE void -AO_char_store_full(volatile unsigned char *addr, unsigned char val) -{ - pthread_mutex_lock(&AO_pt_lock); - *addr = val; - pthread_mutex_unlock(&AO_pt_lock); -} -#define AO_HAVE_char_store_full - -AO_INLINE unsigned short -AO_short_load_full(const volatile unsigned short *addr) -{ - unsigned short result; - pthread_mutex_lock(&AO_pt_lock); - result = *addr; - pthread_mutex_unlock(&AO_pt_lock); - return result; -} -#define AO_HAVE_short_load_full - -AO_INLINE void -AO_short_store_full(volatile unsigned short *addr, unsigned short val) -{ - pthread_mutex_lock(&AO_pt_lock); - *addr = val; - pthread_mutex_unlock(&AO_pt_lock); -} -#define AO_HAVE_short_store_full - -AO_INLINE unsigned int -AO_int_load_full(const volatile unsigned int *addr) -{ - unsigned int result; - pthread_mutex_lock(&AO_pt_lock); - result = *addr; - pthread_mutex_unlock(&AO_pt_lock); - return result; -} -#define AO_HAVE_int_load_full - -AO_INLINE void -AO_int_store_full(volatile unsigned int *addr, unsigned int val) -{ - pthread_mutex_lock(&AO_pt_lock); - *addr = val; - pthread_mutex_unlock(&AO_pt_lock); -} -#define AO_HAVE_int_store_full - -AO_INLINE AO_TS_VAL_t -AO_test_and_set_full(volatile AO_TS_t *addr) -{ - AO_TS_VAL_t result; - pthread_mutex_lock(&AO_pt_lock); - result = (AO_TS_VAL_t)(*addr); - *addr = AO_TS_SET; - pthread_mutex_unlock(&AO_pt_lock); - assert(result == AO_TS_SET || result == AO_TS_CLEAR); - return result; -} -#define AO_HAVE_test_and_set_full - -AO_INLINE AO_t -AO_fetch_and_add_full(volatile AO_t *p, AO_t incr) -{ - AO_t old_val; - - pthread_mutex_lock(&AO_pt_lock); - old_val = *p; - *p = old_val + incr; - pthread_mutex_unlock(&AO_pt_lock); - return old_val; -} -#define AO_HAVE_fetch_and_add_full - -AO_INLINE unsigned char -AO_char_fetch_and_add_full(volatile unsigned char *p, unsigned char incr) -{ - unsigned char old_val; - - pthread_mutex_lock(&AO_pt_lock); - old_val = *p; - *p = old_val + incr; - pthread_mutex_unlock(&AO_pt_lock); - return old_val; -} -#define AO_HAVE_char_fetch_and_add_full - -AO_INLINE unsigned short -AO_short_fetch_and_add_full(volatile unsigned short *p, unsigned short incr) -{ - unsigned short old_val; - - pthread_mutex_lock(&AO_pt_lock); - old_val = *p; - *p = old_val + incr; - pthread_mutex_unlock(&AO_pt_lock); - return old_val; -} -#define AO_HAVE_short_fetch_and_add_full - -AO_INLINE unsigned int -AO_int_fetch_and_add_full(volatile unsigned int *p, unsigned int incr) -{ - unsigned int old_val; - - pthread_mutex_lock(&AO_pt_lock); - old_val = *p; - *p = old_val + incr; - pthread_mutex_unlock(&AO_pt_lock); - return old_val; -} -#define AO_HAVE_int_fetch_and_add_full - -AO_INLINE void -AO_and_full(volatile AO_t *p, AO_t value) -{ - pthread_mutex_lock(&AO_pt_lock); - *p &= value; - pthread_mutex_unlock(&AO_pt_lock); -} -#define AO_HAVE_and_full - -AO_INLINE void -AO_or_full(volatile AO_t *p, AO_t value) -{ - pthread_mutex_lock(&AO_pt_lock); - *p |= value; - pthread_mutex_unlock(&AO_pt_lock); -} -#define AO_HAVE_or_full - -AO_INLINE void -AO_xor_full(volatile AO_t *p, AO_t value) -{ - pthread_mutex_lock(&AO_pt_lock); - *p ^= value; - pthread_mutex_unlock(&AO_pt_lock); -} -#define AO_HAVE_xor_full - -AO_INLINE void -AO_char_and_full(volatile unsigned char *p, unsigned char value) -{ - pthread_mutex_lock(&AO_pt_lock); - *p &= value; - pthread_mutex_unlock(&AO_pt_lock); -} -#define AO_HAVE_char_and_full - -AO_INLINE void -AO_char_or_full(volatile unsigned char *p, unsigned char value) -{ - pthread_mutex_lock(&AO_pt_lock); - *p |= value; - pthread_mutex_unlock(&AO_pt_lock); -} -#define AO_HAVE_char_or_full - -AO_INLINE void -AO_char_xor_full(volatile unsigned char *p, unsigned char value) -{ - pthread_mutex_lock(&AO_pt_lock); - *p ^= value; - pthread_mutex_unlock(&AO_pt_lock); -} -#define AO_HAVE_char_xor_full - -AO_INLINE void -AO_short_and_full(volatile unsigned short *p, unsigned short value) -{ - pthread_mutex_lock(&AO_pt_lock); - *p &= value; - pthread_mutex_unlock(&AO_pt_lock); -} -#define AO_HAVE_short_and_full - -AO_INLINE void -AO_short_or_full(volatile unsigned short *p, unsigned short value) -{ - pthread_mutex_lock(&AO_pt_lock); - *p |= value; - pthread_mutex_unlock(&AO_pt_lock); -} -#define AO_HAVE_short_or_full - -AO_INLINE void -AO_short_xor_full(volatile unsigned short *p, unsigned short value) -{ - pthread_mutex_lock(&AO_pt_lock); - *p ^= value; - pthread_mutex_unlock(&AO_pt_lock); -} -#define AO_HAVE_short_xor_full - -AO_INLINE void -AO_int_and_full(volatile unsigned *p, unsigned value) -{ - pthread_mutex_lock(&AO_pt_lock); - *p &= value; - pthread_mutex_unlock(&AO_pt_lock); -} -#define AO_HAVE_int_and_full - -AO_INLINE void -AO_int_or_full(volatile unsigned *p, unsigned value) -{ - pthread_mutex_lock(&AO_pt_lock); - *p |= value; - pthread_mutex_unlock(&AO_pt_lock); -} -#define AO_HAVE_int_or_full - -AO_INLINE void -AO_int_xor_full(volatile unsigned *p, unsigned value) -{ - pthread_mutex_lock(&AO_pt_lock); - *p ^= value; - pthread_mutex_unlock(&AO_pt_lock); -} -#define AO_HAVE_int_xor_full - -AO_INLINE AO_t -AO_fetch_compare_and_swap_full(volatile AO_t *addr, AO_t old_val, - AO_t new_val) -{ - AO_t fetched_val; - - pthread_mutex_lock(&AO_pt_lock); - fetched_val = *addr; - if (fetched_val == old_val) - *addr = new_val; - pthread_mutex_unlock(&AO_pt_lock); - return fetched_val; -} -#define AO_HAVE_fetch_compare_and_swap_full - -AO_INLINE unsigned char -AO_char_fetch_compare_and_swap_full(volatile unsigned char *addr, - unsigned char old_val, - unsigned char new_val) -{ - unsigned char fetched_val; - - pthread_mutex_lock(&AO_pt_lock); - fetched_val = *addr; - if (fetched_val == old_val) - *addr = new_val; - pthread_mutex_unlock(&AO_pt_lock); - return fetched_val; -} -#define AO_HAVE_char_fetch_compare_and_swap_full - -AO_INLINE unsigned short -AO_short_fetch_compare_and_swap_full(volatile unsigned short *addr, - unsigned short old_val, - unsigned short new_val) -{ - unsigned short fetched_val; - - pthread_mutex_lock(&AO_pt_lock); - fetched_val = *addr; - if (fetched_val == old_val) - *addr = new_val; - pthread_mutex_unlock(&AO_pt_lock); - return fetched_val; -} -#define AO_HAVE_short_fetch_compare_and_swap_full - -AO_INLINE unsigned -AO_int_fetch_compare_and_swap_full(volatile unsigned *addr, unsigned old_val, - unsigned new_val) -{ - unsigned fetched_val; - - pthread_mutex_lock(&AO_pt_lock); - fetched_val = *addr; - if (fetched_val == old_val) - *addr = new_val; - pthread_mutex_unlock(&AO_pt_lock); - return fetched_val; -} -#define AO_HAVE_int_fetch_compare_and_swap_full - -/* Unlike real architectures, we define both double-width CAS variants. */ - -typedef struct { - AO_t AO_val1; - AO_t AO_val2; -} AO_double_t; -#define AO_HAVE_double_t - -#define AO_DOUBLE_T_INITIALIZER { (AO_t)0, (AO_t)0 } - -AO_INLINE AO_double_t -AO_double_load_full(const volatile AO_double_t *addr) -{ - AO_double_t result; - - pthread_mutex_lock(&AO_pt_lock); - result.AO_val1 = addr->AO_val1; - result.AO_val2 = addr->AO_val2; - pthread_mutex_unlock(&AO_pt_lock); - return result; -} -#define AO_HAVE_double_load_full - -AO_INLINE void -AO_double_store_full(volatile AO_double_t *addr, AO_double_t value) -{ - pthread_mutex_lock(&AO_pt_lock); - addr->AO_val1 = value.AO_val1; - addr->AO_val2 = value.AO_val2; - pthread_mutex_unlock(&AO_pt_lock); -} -#define AO_HAVE_double_store_full - -AO_INLINE int -AO_compare_double_and_swap_double_full(volatile AO_double_t *addr, - AO_t old1, AO_t old2, - AO_t new1, AO_t new2) -{ - pthread_mutex_lock(&AO_pt_lock); - if (addr -> AO_val1 == old1 && addr -> AO_val2 == old2) - { - addr -> AO_val1 = new1; - addr -> AO_val2 = new2; - pthread_mutex_unlock(&AO_pt_lock); - return 1; - } - else - pthread_mutex_unlock(&AO_pt_lock); - return 0; -} -#define AO_HAVE_compare_double_and_swap_double_full - -AO_INLINE int -AO_compare_and_swap_double_full(volatile AO_double_t *addr, - AO_t old1, AO_t new1, AO_t new2) -{ - pthread_mutex_lock(&AO_pt_lock); - if (addr -> AO_val1 == old1) - { - addr -> AO_val1 = new1; - addr -> AO_val2 = new2; - pthread_mutex_unlock(&AO_pt_lock); - return 1; - } - else - pthread_mutex_unlock(&AO_pt_lock); - return 0; -} -#define AO_HAVE_compare_and_swap_double_full - -/* We can't use hardware loads and stores, since they don't */ -/* interact correctly with atomic updates. */ diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/hpc/hppa.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/hpc/hppa.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/hpc/hppa.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/hpc/hppa.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,96 +0,0 @@ -/* - * Copyright (c) 2003 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - * - * Derived from the corresponding header file for gcc. - */ - -#include "../loadstore/atomic_load.h" -#include "../loadstore/atomic_store.h" - -/* Some architecture set descriptions include special "ordered" memory */ -/* operations. As far as we can tell, no existing processors actually */ -/* require those. Nor does it appear likely that future processors */ -/* will. */ -/* FIXME: The PA emulator on Itanium may obey weaker restrictions. */ -/* There should be a mode in which we don't assume sequential */ -/* consistency here. */ -#include "../ordered.h" - -#include - -/* GCC will not guarantee the alignment we need, use four lock words */ -/* and select the correctly aligned datum. See the glibc 2.3.2 */ -/* linuxthread port for the original implementation. */ -struct AO_pa_clearable_loc { - int data[4]; -}; - -#undef AO_TS_INITIALIZER -#define AO_TS_t struct AO_pa_clearable_loc -#define AO_TS_INITIALIZER {1,1,1,1} -/* Switch meaning of set and clear, since we only have an atomic clear */ -/* instruction. */ -typedef enum {AO_PA_TS_set = 0, AO_PA_TS_clear = 1} AO_PA_TS_val; -#define AO_TS_VAL_t AO_PA_TS_val -#define AO_TS_CLEAR AO_PA_TS_clear -#define AO_TS_SET AO_PA_TS_set - -/* The hppa only has one atomic read and modify memory operation, */ -/* load and clear, so hppa spinlocks must use zero to signify that */ -/* someone is holding the lock. The address used for the ldcw */ -/* semaphore must be 16-byte aligned. */ -#define AO_ldcw(a, ret) \ - _LDCWX(0 /* index */, 0 /* s */, a /* base */, ret) - -/* Because malloc only guarantees 8-byte alignment for malloc'd data, */ -/* and GCC only guarantees 8-byte alignment for stack locals, we can't */ -/* be assured of 16-byte alignment for atomic lock data even if we */ -/* specify "__attribute ((aligned(16)))" in the type declaration. So, */ -/* we use a struct containing an array of four ints for the atomic lock */ -/* type and dynamically select the 16-byte aligned int from the array */ -/* for the semaphore. */ -#define AO_PA_LDCW_ALIGNMENT 16 -#define AO_ldcw_align(addr) \ - ((volatile unsigned *)(((unsigned long)(addr) \ - + (AO_PA_LDCW_ALIGNMENT - 1)) \ - & ~(AO_PA_LDCW_ALIGNMENT - 1))) - -/* Works on PA 1.1 and PA 2.0 systems */ -AO_INLINE AO_TS_VAL_t -AO_test_and_set_full(volatile AO_TS_t * addr) -{ - register unsigned int ret; - register unsigned long a = (unsigned long)AO_ldcw_align(addr); - - AO_ldcw(a, ret); - return (AO_TS_VAL_t)ret; -} -#define AO_HAVE_test_and_set_full - -AO_INLINE void -AO_pa_clear(volatile AO_TS_t * addr) -{ - volatile unsigned *a = AO_ldcw_align(addr); - - AO_compiler_barrier(); - *a = 1; -} -#define AO_CLEAR(addr) AO_pa_clear(addr) diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/hpc/ia64.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/hpc/ia64.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/hpc/ia64.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/hpc/ia64.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,155 +0,0 @@ -/* - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* - * This file specifies Itanimum primitives for use with the HP compiler - * under HP/UX. We use intrinsics instead of the inline assembly code in the - * gcc file. - */ - -#include "../all_atomic_load_store.h" - -#include "../all_acquire_release_volatile.h" - -#include "../test_and_set_t_is_char.h" - -#include - -#ifdef __LP64__ -# define AO_T_FASIZE _FASZ_D -# define AO_T_SIZE _SZ_D -#else -# define AO_T_FASIZE _FASZ_W -# define AO_T_SIZE _SZ_W -#endif - -AO_INLINE void -AO_nop_full(void) -{ - _Asm_mf(); -} -#define AO_HAVE_nop_full - -#ifndef AO_PREFER_GENERALIZED -AO_INLINE AO_t -AO_fetch_and_add1_acquire (volatile AO_t *p) -{ - return _Asm_fetchadd(AO_T_FASIZE, _SEM_ACQ, p, 1, - _LDHINT_NONE, _DOWN_MEM_FENCE); -} -#define AO_HAVE_fetch_and_add1_acquire - -AO_INLINE AO_t -AO_fetch_and_add1_release (volatile AO_t *p) -{ - return _Asm_fetchadd(AO_T_FASIZE, _SEM_REL, p, 1, - _LDHINT_NONE, _UP_MEM_FENCE); -} -#define AO_HAVE_fetch_and_add1_release - -AO_INLINE AO_t -AO_fetch_and_sub1_acquire (volatile AO_t *p) -{ - return _Asm_fetchadd(AO_T_FASIZE, _SEM_ACQ, p, -1, - _LDHINT_NONE, _DOWN_MEM_FENCE); -} -#define AO_HAVE_fetch_and_sub1_acquire - -AO_INLINE AO_t -AO_fetch_and_sub1_release (volatile AO_t *p) -{ - return _Asm_fetchadd(AO_T_FASIZE, _SEM_REL, p, -1, - _LDHINT_NONE, _UP_MEM_FENCE); -} -#define AO_HAVE_fetch_and_sub1_release -#endif /* !AO_PREFER_GENERALIZED */ - -AO_INLINE AO_t -AO_fetch_compare_and_swap_acquire(volatile AO_t *addr, AO_t old_val, - AO_t new_val) -{ - _Asm_mov_to_ar(_AREG_CCV, old_val, _DOWN_MEM_FENCE); - return _Asm_cmpxchg(AO_T_SIZE, _SEM_ACQ, addr, - new_val, _LDHINT_NONE, _DOWN_MEM_FENCE); -} -#define AO_HAVE_fetch_compare_and_swap_acquire - -AO_INLINE AO_t -AO_fetch_compare_and_swap_release(volatile AO_t *addr, AO_t old_val, - AO_t new_val) -{ - _Asm_mov_to_ar(_AREG_CCV, old_val, _UP_MEM_FENCE); - return _Asm_cmpxchg(AO_T_SIZE, _SEM_REL, addr, - new_val, _LDHINT_NONE, _UP_MEM_FENCE); - -} -#define AO_HAVE_fetch_compare_and_swap_release - -AO_INLINE unsigned char -AO_char_fetch_compare_and_swap_acquire(volatile unsigned char *addr, - unsigned char old_val, unsigned char new_val) -{ - _Asm_mov_to_ar(_AREG_CCV, old_val, _DOWN_MEM_FENCE); - return _Asm_cmpxchg(_SZ_B, _SEM_ACQ, addr, - new_val, _LDHINT_NONE, _DOWN_MEM_FENCE); - -} -#define AO_HAVE_char_fetch_compare_and_swap_acquire - -AO_INLINE unsigned char -AO_char_fetch_compare_and_swap_release(volatile unsigned char *addr, - unsigned char old_val, unsigned char new_val) -{ - _Asm_mov_to_ar(_AREG_CCV, old_val, _UP_MEM_FENCE); - return _Asm_cmpxchg(_SZ_B, _SEM_REL, addr, - new_val, _LDHINT_NONE, _UP_MEM_FENCE); - -} -#define AO_HAVE_char_fetch_compare_and_swap_release - -AO_INLINE unsigned short -AO_short_fetch_compare_and_swap_acquire(volatile unsigned short *addr, - unsigned short old_val, - unsigned short new_val) -{ - _Asm_mov_to_ar(_AREG_CCV, old_val, _DOWN_MEM_FENCE); - return _Asm_cmpxchg(_SZ_B, _SEM_ACQ, addr, - new_val, _LDHINT_NONE, _DOWN_MEM_FENCE); - -} -#define AO_HAVE_short_fetch_compare_and_swap_acquire - -AO_INLINE unsigned short -AO_short_fetch_compare_and_swap_release(volatile unsigned short *addr, - unsigned short old_val, - unsigned short new_val) -{ - _Asm_mov_to_ar(_AREG_CCV, old_val, _UP_MEM_FENCE); - return _Asm_cmpxchg(_SZ_B, _SEM_REL, addr, - new_val, _LDHINT_NONE, _UP_MEM_FENCE); - -} -#define AO_HAVE_short_fetch_compare_and_swap_release - -#ifndef __LP64__ -# define AO_T_IS_INT -#endif diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/ibmc/powerpc.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/ibmc/powerpc.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/ibmc/powerpc.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/ibmc/powerpc.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,128 +0,0 @@ -/* FIXME. This is only a placeholder for the AIX compiler. */ -/* It doesn't work. Please send a patch. */ -/* Memory model documented at http://www-106.ibm.com/developerworks/ */ -/* eserver/articles/archguide.html and (clearer) */ -/* http://www-106.ibm.com/developerworks/eserver/articles/powerpc.html. */ -/* There appears to be no implicit ordering between any kind of */ -/* independent memory references. */ -/* Architecture enforces some ordering based on control dependence. */ -/* I don't know if that could help. */ -/* Data-dependent loads are always ordered. */ -/* Based on the above references, eieio is intended for use on */ -/* uncached memory, which we don't support. It does not order loads */ -/* from cached memory. */ -/* Thanks to Maged Michael, Doug Lea, and Roger Hoover for helping to */ -/* track some of this down and correcting my misunderstandings. -HB */ - -#include "../all_aligned_atomic_load_store.h" - -void AO_sync(void); -#pragma mc_func AO_sync { "7c0004ac" } - -#ifdef __NO_LWSYNC__ -# define AO_lwsync AO_sync -#else - void AO_lwsync(void); -#pragma mc_func AO_lwsync { "7c2004ac" } -#endif - -#define AO_nop_write() AO_lwsync() -#define AO_HAVE_nop_write - -#define AO_nop_read() AO_lwsync() -#define AO_HAVE_nop_read - -/* We explicitly specify load_acquire and store_release, since these */ -/* rely on the fact that lwsync is also a LoadStore barrier. */ -AO_INLINE AO_t -AO_load_acquire(const volatile AO_t *addr) -{ - AO_t result = *addr; - AO_lwsync(); - return result; -} -#define AO_HAVE_load_acquire - -AO_INLINE void -AO_store_release(volatile AO_t *addr, AO_t value) -{ - AO_lwsync(); - *addr = value; -} -#define AO_HAVE_store_release - -#ifndef AO_PREFER_GENERALIZED -/* This is similar to the code in the garbage collector. Deleting */ -/* this and having it synthesized from compare_and_swap would probably */ -/* only cost us a load immediate instruction. */ -/*AO_INLINE AO_TS_VAL_t -AO_test_and_set(volatile AO_TS_t *addr) { -# error FIXME Implement me -} -#define AO_HAVE_test_and_set*/ - -AO_INLINE AO_TS_VAL_t -AO_test_and_set_acquire(volatile AO_TS_t *addr) { - AO_TS_VAL_t result = AO_test_and_set(addr); - AO_lwsync(); - return result; -} -#define AO_HAVE_test_and_set_acquire - -AO_INLINE AO_TS_VAL_t -AO_test_and_set_release(volatile AO_TS_t *addr) { - AO_lwsync(); - return AO_test_and_set(addr); -} -#define AO_HAVE_test_and_set_release - -AO_INLINE AO_TS_VAL_t -AO_test_and_set_full(volatile AO_TS_t *addr) { - AO_TS_VAL_t result; - AO_lwsync(); - result = AO_test_and_set(addr); - AO_lwsync(); - return result; -} -#define AO_HAVE_test_and_set_full -#endif /* !AO_PREFER_GENERALIZED */ - -/*AO_INLINE AO_t -AO_fetch_compare_and_swap(volatile AO_t *addr, AO_t old_val, AO_t new_val) -{ -# error FIXME Implement me -} -#define AO_HAVE_fetch_compare_and_swap*/ - -AO_INLINE AO_t -AO_fetch_compare_and_swap_acquire(volatile AO_t *addr, AO_t old_val, - AO_t new_val) -{ - AO_t result = AO_fetch_compare_and_swap(addr, old_val, new_val); - AO_lwsync(); - return result; -} -#define AO_HAVE_fetch_compare_and_swap_acquire - -AO_INLINE AO_t -AO_fetch_compare_and_swap_release(volatile AO_t *addr, AO_t old_val, - AO_t new_val) -{ - AO_lwsync(); - return AO_fetch_compare_and_swap(addr, old_val, new_val); -} -#define AO_HAVE_fetch_compare_and_swap_release - -AO_INLINE AO_t -AO_fetch_compare_and_swap_full(volatile AO_t *addr, AO_t old_val, - AO_t new_val) -{ - AO_t result; - AO_lwsync(); - result = AO_fetch_compare_and_swap(addr, old_val, new_val); - AO_lwsync(); - return result; -} -#define AO_HAVE_fetch_compare_and_swap_full - -/* TODO: Implement AO_fetch_and_add, AO_and/or/xor directly. */ diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/icc/ia64.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/icc/ia64.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/icc/ia64.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/icc/ia64.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,205 +0,0 @@ -/* - * Copyright (c) 2003 by Hewlett-Packard Company. All rights reserved. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* - * This file specifies Itanimum primitives for use with the Intel (ecc) - * compiler. We use intrinsics instead of the inline assembly code in the - * gcc file. - */ - -#include "../all_atomic_load_store.h" - -#include "../test_and_set_t_is_char.h" - -#include - -/* The acquire release semantics of volatile can be turned off. And volatile */ -/* operations in icc9 don't imply ordering with respect to other nonvolatile */ -/* operations. */ - -#define AO_INTEL_PTR_t void * - -AO_INLINE AO_t -AO_load_acquire(const volatile AO_t *p) -{ - return (AO_t)(__ld8_acq((AO_INTEL_PTR_t)p)); -} -#define AO_HAVE_load_acquire - -AO_INLINE void -AO_store_release(volatile AO_t *p, AO_t val) -{ - __st8_rel((AO_INTEL_PTR_t)p, (__int64)val); -} -#define AO_HAVE_store_release - -AO_INLINE unsigned char -AO_char_load_acquire(const volatile unsigned char *p) -{ - /* A normal volatile load generates an ld.acq */ - return (__ld1_acq((AO_INTEL_PTR_t)p)); -} -#define AO_HAVE_char_load_acquire - -AO_INLINE void -AO_char_store_release(volatile unsigned char *p, unsigned char val) -{ - __st1_rel((AO_INTEL_PTR_t)p, val); -} -#define AO_HAVE_char_store_release - -AO_INLINE unsigned short -AO_short_load_acquire(const volatile unsigned short *p) -{ - /* A normal volatile load generates an ld.acq */ - return (__ld2_acq((AO_INTEL_PTR_t)p)); -} -#define AO_HAVE_short_load_acquire - -AO_INLINE void -AO_short_store_release(volatile unsigned short *p, unsigned short val) -{ - __st2_rel((AO_INTEL_PTR_t)p, val); -} -#define AO_HAVE_short_store_release - -AO_INLINE unsigned int -AO_int_load_acquire(const volatile unsigned int *p) -{ - /* A normal volatile load generates an ld.acq */ - return (__ld4_acq((AO_INTEL_PTR_t)p)); -} -#define AO_HAVE_int_load_acquire - -AO_INLINE void -AO_int_store_release(volatile unsigned int *p, unsigned int val) -{ - __st4_rel((AO_INTEL_PTR_t)p, val); -} -#define AO_HAVE_int_store_release - -AO_INLINE void -AO_nop_full(void) -{ - __mf(); -} -#define AO_HAVE_nop_full - -#ifndef AO_PREFER_GENERALIZED -AO_INLINE AO_t -AO_fetch_and_add1_acquire(volatile AO_t *p) -{ - return __fetchadd8_acq((unsigned __int64 *)p, 1); -} -#define AO_HAVE_fetch_and_add1_acquire - -AO_INLINE AO_t -AO_fetch_and_add1_release(volatile AO_t *p) -{ - return __fetchadd8_rel((unsigned __int64 *)p, 1); -} -#define AO_HAVE_fetch_and_add1_release - -AO_INLINE AO_t -AO_fetch_and_sub1_acquire(volatile AO_t *p) -{ - return __fetchadd8_acq((unsigned __int64 *)p, -1); -} -#define AO_HAVE_fetch_and_sub1_acquire - -AO_INLINE AO_t -AO_fetch_and_sub1_release(volatile AO_t *p) -{ - return __fetchadd8_rel((unsigned __int64 *)p, -1); -} -#define AO_HAVE_fetch_and_sub1_release -#endif /* !AO_PREFER_GENERALIZED */ - -AO_INLINE AO_t -AO_fetch_compare_and_swap_acquire(volatile AO_t *addr, AO_t old_val, - AO_t new_val) -{ - return _InterlockedCompareExchange64_acq(addr, new_val, old_val); -} -#define AO_HAVE_fetch_compare_and_swap_acquire - -AO_INLINE AO_t -AO_fetch_compare_and_swap_release(volatile AO_t *addr, AO_t old_val, - AO_t new_val) -{ - return _InterlockedCompareExchange64_rel(addr, new_val, old_val); -} -#define AO_HAVE_fetch_compare_and_swap_release - -AO_INLINE unsigned char -AO_char_fetch_compare_and_swap_acquire(volatile unsigned char *addr, - unsigned char old_val, - unsigned char new_val) -{ - return _InterlockedCompareExchange8_acq(addr, new_val, old_val); -} -#define AO_HAVE_char_fetch_compare_and_swap_acquire - -AO_INLINE unsigned char -AO_char_fetch_compare_and_swap_release(volatile unsigned char *addr, - unsigned char old_val, - unsigned char new_val) -{ - return _InterlockedCompareExchange8_rel(addr, new_val, old_val); -} -#define AO_HAVE_char_fetch_compare_and_swap_release - -AO_INLINE unsigned short -AO_short_fetch_compare_and_swap_acquire(volatile unsigned short *addr, - unsigned short old_val, - unsigned short new_val) -{ - return _InterlockedCompareExchange16_acq(addr, new_val, old_val); -} -#define AO_HAVE_short_fetch_compare_and_swap_acquire - -AO_INLINE unsigned short -AO_short_fetch_compare_and_swap_release(volatile unsigned short *addr, - unsigned short old_val, - unsigned short new_val) -{ - return _InterlockedCompareExchange16_rel(addr, new_val, old_val); -} -#define AO_HAVE_short_fetch_compare_and_swap_release - -AO_INLINE unsigned int -AO_int_fetch_compare_and_swap_acquire(volatile unsigned int *addr, - unsigned int old_val, - unsigned int new_val) -{ - return _InterlockedCompareExchange_acq(addr, new_val, old_val); -} -#define AO_HAVE_int_fetch_compare_and_swap_acquire - -AO_INLINE unsigned int -AO_int_fetch_compare_and_swap_release(volatile unsigned int *addr, - unsigned int old_val, - unsigned int new_val) -{ - return _InterlockedCompareExchange_rel(addr, new_val, old_val); -} -#define AO_HAVE_int_fetch_compare_and_swap_release diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/acquire_release_volatile.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/acquire_release_volatile.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/acquire_release_volatile.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/acquire_release_volatile.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,61 +0,0 @@ -/* - * Copyright (c) 2003-2004 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* This file adds definitions appropriate for environments in which */ -/* volatile load of a given type has acquire semantics, and volatile */ -/* store of a given type has release semantics. This is arguably */ -/* supposed to be true with the standard Itanium software conventions. */ -/* Empirically gcc/ia64 does some reordering of ordinary operations */ -/* around volatiles even when we think it should not. GCC v3.3 and */ -/* earlier could reorder a volatile store with another store. As of */ -/* March 2005, gcc pre-4 reuses some previously computed common */ -/* subexpressions across a volatile load; hence, we now add compiler */ -/* barriers for gcc. */ - -#ifndef AO_GCC_BARRIER - /* TODO: Check GCC version (if workaround not needed for modern GCC). */ -# if defined(__GNUC__) -# define AO_GCC_BARRIER() AO_compiler_barrier() -# else -# define AO_GCC_BARRIER() (void)0 -# endif -#endif - -AO_INLINE AO_t -AO_load_acquire(const volatile AO_t *addr) -{ - AO_t result = *addr; - - /* A normal volatile load generates an ld.acq (on IA-64). */ - AO_GCC_BARRIER(); - return result; -} -#define AO_HAVE_load_acquire - -AO_INLINE void -AO_store_release(volatile AO_t *addr, AO_t new_val) -{ - AO_GCC_BARRIER(); - /* A normal volatile store generates an st.rel (on IA-64). */ - *addr = new_val; -} -#define AO_HAVE_store_release diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/acquire_release_volatile.template ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/acquire_release_volatile.template --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/acquire_release_volatile.template 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/acquire_release_volatile.template 1970-01-01 00:00:00.000000000 +0000 @@ -1,61 +0,0 @@ -/* - * Copyright (c) 2003-2004 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* This file adds definitions appropriate for environments in which */ -/* volatile load of a given type has acquire semantics, and volatile */ -/* store of a given type has release semantics. This is arguably */ -/* supposed to be true with the standard Itanium software conventions. */ -/* Empirically gcc/ia64 does some reordering of ordinary operations */ -/* around volatiles even when we think it should not. GCC v3.3 and */ -/* earlier could reorder a volatile store with another store. As of */ -/* March 2005, gcc pre-4 reuses some previously computed common */ -/* subexpressions across a volatile load; hence, we now add compiler */ -/* barriers for gcc. */ - -#ifndef AO_GCC_BARRIER - /* TODO: Check GCC version (if workaround not needed for modern GCC). */ -# if defined(__GNUC__) -# define AO_GCC_BARRIER() AO_compiler_barrier() -# else -# define AO_GCC_BARRIER() (void)0 -# endif -#endif - -AO_INLINE XCTYPE -AO_XSIZE_load_acquire(const volatile XCTYPE *addr) -{ - XCTYPE result = *addr; - - /* A normal volatile load generates an ld.acq (on IA-64). */ - AO_GCC_BARRIER(); - return result; -} -#define AO_HAVE_XSIZE_load_acquire - -AO_INLINE void -AO_XSIZE_store_release(volatile XCTYPE *addr, XCTYPE new_val) -{ - AO_GCC_BARRIER(); - /* A normal volatile store generates an st.rel (on IA-64). */ - *addr = new_val; -} -#define AO_HAVE_XSIZE_store_release diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/atomic_load.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/atomic_load.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/atomic_load.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/atomic_load.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,37 +0,0 @@ -/* - * Copyright (c) 2004 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* Definitions for architectures on which loads of given type are */ -/* atomic (either for suitably aligned data only or for any legal */ -/* alignment). */ - -AO_INLINE AO_t -AO_load(const volatile AO_t *addr) -{ -# ifdef AO_ACCESS_CHECK_ALIGNED - assert(((size_t)addr & (sizeof(*addr) - 1)) == 0); -# endif - /* Cast away the volatile for architectures like IA64 where */ - /* volatile adds barrier (fence) semantics. */ - return *(const AO_t *)addr; -} -#define AO_HAVE_load diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/atomic_load.template ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/atomic_load.template --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/atomic_load.template 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/atomic_load.template 1970-01-01 00:00:00.000000000 +0000 @@ -1,37 +0,0 @@ -/* - * Copyright (c) 2004 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* Definitions for architectures on which loads of given type are */ -/* atomic (either for suitably aligned data only or for any legal */ -/* alignment). */ - -AO_INLINE XCTYPE -AO_XSIZE_load(const volatile XCTYPE *addr) -{ -# ifdef AO_ACCESS_XSIZE_CHECK_ALIGNED - assert(((size_t)addr & (sizeof(*addr) - 1)) == 0); -# endif - /* Cast away the volatile for architectures like IA64 where */ - /* volatile adds barrier (fence) semantics. */ - return *(const XCTYPE *)addr; -} -#define AO_HAVE_XSIZE_load diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/atomic_store.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/atomic_store.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/atomic_store.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/atomic_store.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -/* - * Copyright (c) 2004 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* Definitions for architectures on which stores of given type are */ -/* atomic (either for suitably aligned data only or for any legal */ -/* alignment). */ - -AO_INLINE void -AO_store(volatile AO_t *addr, AO_t new_val) -{ -# ifdef AO_ACCESS_CHECK_ALIGNED - assert(((size_t)addr & (sizeof(*addr) - 1)) == 0); -# endif - *(AO_t *)addr = new_val; -} -#define AO_HAVE_store diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/atomic_store.template ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/atomic_store.template --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/atomic_store.template 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/atomic_store.template 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -/* - * Copyright (c) 2004 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* Definitions for architectures on which stores of given type are */ -/* atomic (either for suitably aligned data only or for any legal */ -/* alignment). */ - -AO_INLINE void -AO_XSIZE_store(volatile XCTYPE *addr, XCTYPE new_val) -{ -# ifdef AO_ACCESS_XSIZE_CHECK_ALIGNED - assert(((size_t)addr & (sizeof(*addr) - 1)) == 0); -# endif - *(XCTYPE *)addr = new_val; -} -#define AO_HAVE_XSIZE_store diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/char_acquire_release_volatile.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/char_acquire_release_volatile.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/char_acquire_release_volatile.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/char_acquire_release_volatile.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,61 +0,0 @@ -/* - * Copyright (c) 2003-2004 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* This file adds definitions appropriate for environments in which */ -/* volatile load of a given type has acquire semantics, and volatile */ -/* store of a given type has release semantics. This is arguably */ -/* supposed to be true with the standard Itanium software conventions. */ -/* Empirically gcc/ia64 does some reordering of ordinary operations */ -/* around volatiles even when we think it should not. GCC v3.3 and */ -/* earlier could reorder a volatile store with another store. As of */ -/* March 2005, gcc pre-4 reuses some previously computed common */ -/* subexpressions across a volatile load; hence, we now add compiler */ -/* barriers for gcc. */ - -#ifndef AO_GCC_BARRIER - /* TODO: Check GCC version (if workaround not needed for modern GCC). */ -# if defined(__GNUC__) -# define AO_GCC_BARRIER() AO_compiler_barrier() -# else -# define AO_GCC_BARRIER() (void)0 -# endif -#endif - -AO_INLINE unsigned/**/char -AO_char_load_acquire(const volatile unsigned/**/char *addr) -{ - unsigned/**/char result = *addr; - - /* A normal volatile load generates an ld.acq (on IA-64). */ - AO_GCC_BARRIER(); - return result; -} -#define AO_HAVE_char_load_acquire - -AO_INLINE void -AO_char_store_release(volatile unsigned/**/char *addr, unsigned/**/char new_val) -{ - AO_GCC_BARRIER(); - /* A normal volatile store generates an st.rel (on IA-64). */ - *addr = new_val; -} -#define AO_HAVE_char_store_release diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/char_atomic_load.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/char_atomic_load.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/char_atomic_load.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/char_atomic_load.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,37 +0,0 @@ -/* - * Copyright (c) 2004 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* Definitions for architectures on which loads of given type are */ -/* atomic (either for suitably aligned data only or for any legal */ -/* alignment). */ - -AO_INLINE unsigned/**/char -AO_char_load(const volatile unsigned/**/char *addr) -{ -# ifdef AO_ACCESS_char_CHECK_ALIGNED - assert(((size_t)addr & (sizeof(*addr) - 1)) == 0); -# endif - /* Cast away the volatile for architectures like IA64 where */ - /* volatile adds barrier (fence) semantics. */ - return *(const unsigned/**/char *)addr; -} -#define AO_HAVE_char_load diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/char_atomic_store.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/char_atomic_store.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/char_atomic_store.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/char_atomic_store.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -/* - * Copyright (c) 2004 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* Definitions for architectures on which stores of given type are */ -/* atomic (either for suitably aligned data only or for any legal */ -/* alignment). */ - -AO_INLINE void -AO_char_store(volatile unsigned/**/char *addr, unsigned/**/char new_val) -{ -# ifdef AO_ACCESS_char_CHECK_ALIGNED - assert(((size_t)addr & (sizeof(*addr) - 1)) == 0); -# endif - *(unsigned/**/char *)addr = new_val; -} -#define AO_HAVE_char_store diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/double_atomic_load_store.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/double_atomic_load_store.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/double_atomic_load_store.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/double_atomic_load_store.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,49 +0,0 @@ -/* - * Copyright (c) 2004 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* Definitions for architectures on which AO_double_t loads and stores */ -/* are atomic (either for suitably aligned data only or for any legal */ -/* alignment). */ - -AO_INLINE AO_double_t -AO_double_load(const volatile AO_double_t *addr) -{ - AO_double_t result; - -# ifdef AO_ACCESS_double_CHECK_ALIGNED - assert(((size_t)addr & (sizeof(AO_double_t) - 1)) == 0); -# endif - /* Cast away the volatile in case it adds fence semantics. */ - result.AO_whole = ((const AO_double_t *)addr)->AO_whole; - return result; -} -#define AO_HAVE_double_load - -AO_INLINE void -AO_double_store(volatile AO_double_t *addr, AO_double_t new_val) -{ -# ifdef AO_ACCESS_double_CHECK_ALIGNED - assert(((size_t)addr & (sizeof(AO_double_t) - 1)) == 0); -# endif - ((AO_double_t *)addr)->AO_whole = new_val.AO_whole; -} -#define AO_HAVE_double_store diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/int_acquire_release_volatile.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/int_acquire_release_volatile.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/int_acquire_release_volatile.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/int_acquire_release_volatile.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,61 +0,0 @@ -/* - * Copyright (c) 2003-2004 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* This file adds definitions appropriate for environments in which */ -/* volatile load of a given type has acquire semantics, and volatile */ -/* store of a given type has release semantics. This is arguably */ -/* supposed to be true with the standard Itanium software conventions. */ -/* Empirically gcc/ia64 does some reordering of ordinary operations */ -/* around volatiles even when we think it should not. GCC v3.3 and */ -/* earlier could reorder a volatile store with another store. As of */ -/* March 2005, gcc pre-4 reuses some previously computed common */ -/* subexpressions across a volatile load; hence, we now add compiler */ -/* barriers for gcc. */ - -#ifndef AO_GCC_BARRIER - /* TODO: Check GCC version (if workaround not needed for modern GCC). */ -# if defined(__GNUC__) -# define AO_GCC_BARRIER() AO_compiler_barrier() -# else -# define AO_GCC_BARRIER() (void)0 -# endif -#endif - -AO_INLINE unsigned -AO_int_load_acquire(const volatile unsigned *addr) -{ - unsigned result = *addr; - - /* A normal volatile load generates an ld.acq (on IA-64). */ - AO_GCC_BARRIER(); - return result; -} -#define AO_HAVE_int_load_acquire - -AO_INLINE void -AO_int_store_release(volatile unsigned *addr, unsigned new_val) -{ - AO_GCC_BARRIER(); - /* A normal volatile store generates an st.rel (on IA-64). */ - *addr = new_val; -} -#define AO_HAVE_int_store_release diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/int_atomic_load.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/int_atomic_load.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/int_atomic_load.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/int_atomic_load.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,37 +0,0 @@ -/* - * Copyright (c) 2004 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* Definitions for architectures on which loads of given type are */ -/* atomic (either for suitably aligned data only or for any legal */ -/* alignment). */ - -AO_INLINE unsigned -AO_int_load(const volatile unsigned *addr) -{ -# ifdef AO_ACCESS_int_CHECK_ALIGNED - assert(((size_t)addr & (sizeof(*addr) - 1)) == 0); -# endif - /* Cast away the volatile for architectures like IA64 where */ - /* volatile adds barrier (fence) semantics. */ - return *(const unsigned *)addr; -} -#define AO_HAVE_int_load diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/int_atomic_store.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/int_atomic_store.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/int_atomic_store.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/int_atomic_store.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -/* - * Copyright (c) 2004 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* Definitions for architectures on which stores of given type are */ -/* atomic (either for suitably aligned data only or for any legal */ -/* alignment). */ - -AO_INLINE void -AO_int_store(volatile unsigned *addr, unsigned new_val) -{ -# ifdef AO_ACCESS_int_CHECK_ALIGNED - assert(((size_t)addr & (sizeof(*addr) - 1)) == 0); -# endif - *(unsigned *)addr = new_val; -} -#define AO_HAVE_int_store diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/ordered_loads_only.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/ordered_loads_only.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/ordered_loads_only.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/ordered_loads_only.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,135 +0,0 @@ -/* - * Copyright (c) 2003 by Hewlett-Packard Company. All rights reserved. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -#ifdef AO_HAVE_char_load - /* char_load_read is defined in generalize-small. */ -# define AO_char_load_acquire(addr) AO_char_load_read(addr) -# define AO_HAVE_char_load_acquire -#endif -/* - * Copyright (c) 2003 by Hewlett-Packard Company. All rights reserved. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -#ifdef AO_HAVE_short_load - /* short_load_read is defined in generalize-small. */ -# define AO_short_load_acquire(addr) AO_short_load_read(addr) -# define AO_HAVE_short_load_acquire -#endif -/* - * Copyright (c) 2003 by Hewlett-Packard Company. All rights reserved. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -#ifdef AO_HAVE_int_load - /* int_load_read is defined in generalize-small. */ -# define AO_int_load_acquire(addr) AO_int_load_read(addr) -# define AO_HAVE_int_load_acquire -#endif -/* - * Copyright (c) 2003 by Hewlett-Packard Company. All rights reserved. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -#ifdef AO_HAVE_load - /* load_read is defined in generalize-small. */ -# define AO_load_acquire(addr) AO_load_read(addr) -# define AO_HAVE_load_acquire -#endif -/* - * Copyright (c) 2003 by Hewlett-Packard Company. All rights reserved. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -#ifdef AO_HAVE_double_load - /* double_load_read is defined in generalize-small. */ -# define AO_double_load_acquire(addr) AO_double_load_read(addr) -# define AO_HAVE_double_load_acquire -#endif diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/ordered_loads_only.template ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/ordered_loads_only.template --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/ordered_loads_only.template 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/ordered_loads_only.template 1970-01-01 00:00:00.000000000 +0000 @@ -1,27 +0,0 @@ -/* - * Copyright (c) 2003 by Hewlett-Packard Company. All rights reserved. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -#ifdef AO_HAVE_XSIZE_load - /* XSIZE_load_read is defined in generalize-small. */ -# define AO_XSIZE_load_acquire(addr) AO_XSIZE_load_read(addr) -# define AO_HAVE_XSIZE_load_acquire -#endif diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/ordered_stores_only.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/ordered_stores_only.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/ordered_stores_only.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/ordered_stores_only.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,135 +0,0 @@ -/* - * Copyright (c) 2003 by Hewlett-Packard Company. All rights reserved. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -#ifdef AO_HAVE_char_store -# define AO_char_store_release(addr, val) \ - (AO_nop_write(), AO_char_store(addr, val)) -# define AO_HAVE_char_store_release -#endif -/* - * Copyright (c) 2003 by Hewlett-Packard Company. All rights reserved. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -#ifdef AO_HAVE_short_store -# define AO_short_store_release(addr, val) \ - (AO_nop_write(), AO_short_store(addr, val)) -# define AO_HAVE_short_store_release -#endif -/* - * Copyright (c) 2003 by Hewlett-Packard Company. All rights reserved. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -#ifdef AO_HAVE_int_store -# define AO_int_store_release(addr, val) \ - (AO_nop_write(), AO_int_store(addr, val)) -# define AO_HAVE_int_store_release -#endif -/* - * Copyright (c) 2003 by Hewlett-Packard Company. All rights reserved. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -#ifdef AO_HAVE_store -# define AO_store_release(addr, val) \ - (AO_nop_write(), AO_store(addr, val)) -# define AO_HAVE_store_release -#endif -/* - * Copyright (c) 2003 by Hewlett-Packard Company. All rights reserved. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -#ifdef AO_HAVE_double_store -# define AO_double_store_release(addr, val) \ - (AO_nop_write(), AO_double_store(addr, val)) -# define AO_HAVE_double_store_release -#endif diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/ordered_stores_only.template ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/ordered_stores_only.template --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/ordered_stores_only.template 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/ordered_stores_only.template 1970-01-01 00:00:00.000000000 +0000 @@ -1,27 +0,0 @@ -/* - * Copyright (c) 2003 by Hewlett-Packard Company. All rights reserved. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -#ifdef AO_HAVE_XSIZE_store -# define AO_XSIZE_store_release(addr, val) \ - (AO_nop_write(), AO_XSIZE_store(addr, val)) -# define AO_HAVE_XSIZE_store_release -#endif diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/short_acquire_release_volatile.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/short_acquire_release_volatile.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/short_acquire_release_volatile.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/short_acquire_release_volatile.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,61 +0,0 @@ -/* - * Copyright (c) 2003-2004 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* This file adds definitions appropriate for environments in which */ -/* volatile load of a given type has acquire semantics, and volatile */ -/* store of a given type has release semantics. This is arguably */ -/* supposed to be true with the standard Itanium software conventions. */ -/* Empirically gcc/ia64 does some reordering of ordinary operations */ -/* around volatiles even when we think it should not. GCC v3.3 and */ -/* earlier could reorder a volatile store with another store. As of */ -/* March 2005, gcc pre-4 reuses some previously computed common */ -/* subexpressions across a volatile load; hence, we now add compiler */ -/* barriers for gcc. */ - -#ifndef AO_GCC_BARRIER - /* TODO: Check GCC version (if workaround not needed for modern GCC). */ -# if defined(__GNUC__) -# define AO_GCC_BARRIER() AO_compiler_barrier() -# else -# define AO_GCC_BARRIER() (void)0 -# endif -#endif - -AO_INLINE unsigned/**/short -AO_short_load_acquire(const volatile unsigned/**/short *addr) -{ - unsigned/**/short result = *addr; - - /* A normal volatile load generates an ld.acq (on IA-64). */ - AO_GCC_BARRIER(); - return result; -} -#define AO_HAVE_short_load_acquire - -AO_INLINE void -AO_short_store_release(volatile unsigned/**/short *addr, unsigned/**/short new_val) -{ - AO_GCC_BARRIER(); - /* A normal volatile store generates an st.rel (on IA-64). */ - *addr = new_val; -} -#define AO_HAVE_short_store_release diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/short_atomic_load.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/short_atomic_load.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/short_atomic_load.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/short_atomic_load.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,37 +0,0 @@ -/* - * Copyright (c) 2004 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* Definitions for architectures on which loads of given type are */ -/* atomic (either for suitably aligned data only or for any legal */ -/* alignment). */ - -AO_INLINE unsigned/**/short -AO_short_load(const volatile unsigned/**/short *addr) -{ -# ifdef AO_ACCESS_short_CHECK_ALIGNED - assert(((size_t)addr & (sizeof(*addr) - 1)) == 0); -# endif - /* Cast away the volatile for architectures like IA64 where */ - /* volatile adds barrier (fence) semantics. */ - return *(const unsigned/**/short *)addr; -} -#define AO_HAVE_short_load diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/short_atomic_store.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/short_atomic_store.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/short_atomic_store.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/loadstore/short_atomic_store.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -/* - * Copyright (c) 2004 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* Definitions for architectures on which stores of given type are */ -/* atomic (either for suitably aligned data only or for any legal */ -/* alignment). */ - -AO_INLINE void -AO_short_store(volatile unsigned/**/short *addr, unsigned/**/short new_val) -{ -# ifdef AO_ACCESS_short_CHECK_ALIGNED - assert(((size_t)addr & (sizeof(*addr) - 1)) == 0); -# endif - *(unsigned/**/short *)addr = new_val; -} -#define AO_HAVE_short_store diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/msftc/arm.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/msftc/arm.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/msftc/arm.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/msftc/arm.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,63 +0,0 @@ -/* - * Copyright (c) 2003 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -#ifndef AO_ASSUME_WINDOWS98 - /* CAS is always available */ -# define AO_ASSUME_WINDOWS98 -#endif -#include "common32_defs.h" -/* FIXME: Do _InterlockedOps really have a full memory barrier? */ -/* (MSDN WinCE docs say nothing about it.) */ - -#include "../test_and_set_t_is_ao_t.h" -/* AO_test_and_set_full() is emulated using CAS. */ - -/* Some ARM slide set, if it has been read correctly, claims that Loads */ -/* followed by either a Load or a Store are ordered, but nothing else. */ -/* It is assumed that Windows interrupt handlers clear the LL/SC flag. */ -/* Unaligned accesses are not guaranteed to be atomic. */ -#include "../all_aligned_atomic_load_store.h" - -/* If only a single processor is used, we can define AO_UNIPROCESSOR. */ -#ifdef AO_UNIPROCESSOR - AO_INLINE void AO_nop_full(void) - { - AO_compiler_barrier(); - } -# define AO_HAVE_nop_full -#else - /* AO_nop_full() is emulated using AO_test_and_set_full(). */ -#endif - -#if _M_ARM >= 6 -/* ARMv6 is the first architecture providing support for simple LL/SC. */ - -/* #include "../standard_ao_double_t.h" */ -/* TODO: implement double-wide operations (similar to x86). */ - -#else /* _M_ARM < 6 */ - -/* TODO: implement AO_test_and_set_full using SWP. */ - -#endif /* _M_ARM < 6 */ - -#define AO_T_IS_INT diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/msftc/common32_defs.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/msftc/common32_defs.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/msftc/common32_defs.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/msftc/common32_defs.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,117 +0,0 @@ -/* - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* This file contains AO primitives based on VC++ built-in intrinsic */ -/* functions commonly available across 32-bit architectures. */ - -/* This file should be included from arch-specific header files. */ -/* Define AO_USE_INTERLOCKED_INTRINSICS if _Interlocked primitives */ -/* (used below) are available as intrinsic ones for a target arch */ -/* (otherwise "Interlocked" functions family is used instead). */ -/* Define AO_ASSUME_WINDOWS98 if CAS is available. */ - -#include - /* Seems like over-kill, but that's what MSDN recommends. */ - /* And apparently winbase.h is not always self-contained. */ - -#if _MSC_VER < 1310 || !defined(AO_USE_INTERLOCKED_INTRINSICS) - -# define _InterlockedIncrement InterlockedIncrement -# define _InterlockedDecrement InterlockedDecrement -# define _InterlockedExchangeAdd InterlockedExchangeAdd -# define _InterlockedCompareExchange InterlockedCompareExchange - -# define AO_INTERLOCKED_VOLATILE /**/ - -#else /* elif _MSC_VER >= 1310 */ - -# if _MSC_VER >= 1400 -# ifndef _WIN32_WCE -# include -# endif - -# else /* elif _MSC_VER < 1400 */ -# ifdef __cplusplus - extern "C" { -# endif - LONG __cdecl _InterlockedIncrement(LONG volatile *); - LONG __cdecl _InterlockedDecrement(LONG volatile *); - LONG __cdecl _InterlockedExchangeAdd(LONG volatile *, LONG); - LONG __cdecl _InterlockedCompareExchange(LONG volatile *, - LONG /* Exchange */, LONG /* Comp */); -# ifdef __cplusplus - } -# endif -# endif /* _MSC_VER < 1400 */ - -# if !defined(AO_PREFER_GENERALIZED) || !defined(AO_ASSUME_WINDOWS98) -# pragma intrinsic (_InterlockedIncrement) -# pragma intrinsic (_InterlockedDecrement) -# pragma intrinsic (_InterlockedExchangeAdd) -# endif /* !AO_PREFER_GENERALIZED */ -# pragma intrinsic (_InterlockedCompareExchange) - -# define AO_INTERLOCKED_VOLATILE volatile - -#endif /* _MSC_VER >= 1310 */ - -#if !defined(AO_PREFER_GENERALIZED) || !defined(AO_ASSUME_WINDOWS98) -AO_INLINE AO_t -AO_fetch_and_add_full(volatile AO_t *p, AO_t incr) -{ - return _InterlockedExchangeAdd((LONG AO_INTERLOCKED_VOLATILE *)p, - (LONG)incr); -} -#define AO_HAVE_fetch_and_add_full - -AO_INLINE AO_t -AO_fetch_and_add1_full(volatile AO_t *p) -{ - return _InterlockedIncrement((LONG AO_INTERLOCKED_VOLATILE *)p) - 1; -} -#define AO_HAVE_fetch_and_add1_full - -AO_INLINE AO_t -AO_fetch_and_sub1_full(volatile AO_t *p) -{ - return _InterlockedDecrement((LONG AO_INTERLOCKED_VOLATILE *)p) + 1; -} -#define AO_HAVE_fetch_and_sub1_full -#endif /* !AO_PREFER_GENERALIZED */ - -#ifdef AO_ASSUME_WINDOWS98 - AO_INLINE AO_t - AO_fetch_compare_and_swap_full(volatile AO_t *addr, AO_t old_val, - AO_t new_val) - { -# ifdef AO_OLD_STYLE_INTERLOCKED_COMPARE_EXCHANGE - return (AO_t)_InterlockedCompareExchange( - (PVOID AO_INTERLOCKED_VOLATILE *)addr, - (PVOID)new_val, (PVOID)old_val); -# else - return (AO_t)_InterlockedCompareExchange( - (LONG AO_INTERLOCKED_VOLATILE *)addr, - (LONG)new_val, (LONG)old_val); -# endif - } -# define AO_HAVE_fetch_compare_and_swap_full -#endif /* AO_ASSUME_WINDOWS98 */ diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/msftc/x86_64.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/msftc/x86_64.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/msftc/x86_64.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/msftc/x86_64.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,193 +0,0 @@ -/* - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -#include "../all_aligned_atomic_load_store.h" - -/* Real X86 implementations appear */ -/* to enforce ordering between memory operations, EXCEPT that a later */ -/* read can pass earlier writes, presumably due to the visible */ -/* presence of store buffers. */ -/* We ignore the fact that the official specs */ -/* seem to be much weaker (and arguably too weak to be usable). */ - -#include "../ordered_except_wr.h" - -#ifdef AO_ASM_X64_AVAILABLE -# include "../test_and_set_t_is_char.h" -#else -# include "../test_and_set_t_is_ao_t.h" -#endif - -#include - /* Seems like over-kill, but that's what MSDN recommends. */ - /* And apparently winbase.h is not always self-contained. */ - -/* Assume _MSC_VER >= 1400 */ -#include - -#pragma intrinsic (_InterlockedExchangeAdd) -#pragma intrinsic (_InterlockedCompareExchange64) - -#ifndef AO_PREFER_GENERALIZED - -# pragma intrinsic (_InterlockedIncrement64) -# pragma intrinsic (_InterlockedDecrement64) -# pragma intrinsic (_InterlockedExchangeAdd64) - -AO_INLINE AO_t -AO_fetch_and_add_full (volatile AO_t *p, AO_t incr) -{ - return _InterlockedExchangeAdd64((LONGLONG volatile *)p, (LONGLONG)incr); -} -#define AO_HAVE_fetch_and_add_full - -AO_INLINE AO_t -AO_fetch_and_add1_full (volatile AO_t *p) -{ - return _InterlockedIncrement64((LONGLONG volatile *)p) - 1; -} -#define AO_HAVE_fetch_and_add1_full - -AO_INLINE AO_t -AO_fetch_and_sub1_full (volatile AO_t *p) -{ - return _InterlockedDecrement64((LONGLONG volatile *)p) + 1; -} -#define AO_HAVE_fetch_and_sub1_full -#endif /* !AO_PREFER_GENERALIZED */ - -AO_INLINE AO_t -AO_fetch_compare_and_swap_full(volatile AO_t *addr, AO_t old_val, - AO_t new_val) -{ - return (AO_t)_InterlockedCompareExchange64((LONGLONG volatile *)addr, - (LONGLONG)new_val, (LONGLONG)old_val); -} -#define AO_HAVE_fetch_compare_and_swap_full - -AO_INLINE unsigned int -AO_int_fetch_and_add_full(volatile unsigned int *p, unsigned int incr) -{ - return _InterlockedExchangeAdd((LONG volatile *)p, incr); -} -#define AO_HAVE_int_fetch_and_add_full - -#ifdef AO_ASM_X64_AVAILABLE - - AO_INLINE unsigned char - AO_char_fetch_and_add_full(volatile unsigned char *p, unsigned char incr) - { - __asm - { - mov al, incr - mov rbx, p - lock xadd byte ptr [rbx], al - } - } -# define AO_HAVE_char_fetch_and_add_full - - AO_INLINE unsigned short - AO_short_fetch_and_add_full(volatile unsigned short *p, unsigned short incr) - { - __asm - { - mov ax, incr - mov rbx, p - lock xadd word ptr [rbx], ax - } - } -# define AO_HAVE_short_fetch_and_add_full - -/* As far as we can tell, the lfence and sfence instructions are not */ -/* currently needed or useful for cached memory accesses. */ - - AO_INLINE void - AO_nop_full(void) - { - /* Note: "mfence" (SSE2) is supported on all x86_64/amd64 chips. */ - __asm { mfence } - } -# define AO_HAVE_nop_full - - AO_INLINE AO_TS_VAL_t - AO_test_and_set_full(volatile AO_TS_t *addr) - { - __asm - { - mov rax,AO_TS_SET ; - mov rbx,addr ; - xchg byte ptr [rbx],al ; - } - } -# define AO_HAVE_test_and_set_full - -#endif /* AO_ASM_X64_AVAILABLE */ - -#ifdef AO_CMPXCHG16B_AVAILABLE -/* AO_compare_double_and_swap_double_full needs implementation for Win64. - * Also see ../gcc/x86.h for partial old Opteron workaround. - */ - -# if _MSC_VER >= 1500 - -# include "../standard_ao_double_t.h" - -# pragma intrinsic (_InterlockedCompareExchange128) - -AO_INLINE int -AO_compare_double_and_swap_double_full(volatile AO_double_t *addr, - AO_t old_val1, AO_t old_val2, - AO_t new_val1, AO_t new_val2) -{ - __int64 comparandResult[2]; - comparandResult[0] = old_val1; /* low */ - comparandResult[1] = old_val2; /* high */ - return _InterlockedCompareExchange128((volatile __int64 *)addr, - new_val2 /* high */, new_val1 /* low */, comparandResult); -} -# define AO_HAVE_compare_double_and_swap_double_full - -# elif defined(AO_ASM_X64_AVAILABLE) - -# include "../standard_ao_double_t.h" - - /* If there is no intrinsic _InterlockedCompareExchange128 then we */ - /* need basically what's given below. */ -AO_INLINE int -AO_compare_double_and_swap_double_full(volatile AO_double_t *addr, - AO_t old_val1, AO_t old_val2, - AO_t new_val1, AO_t new_val2) -{ - __asm - { - mov rdx,QWORD PTR [old_val2] ; - mov rax,QWORD PTR [old_val1] ; - mov rcx,QWORD PTR [new_val2] ; - mov rbx,QWORD PTR [new_val1] ; - lock cmpxchg16b [addr] ; - setz rax ; - } -} -# define AO_HAVE_compare_double_and_swap_double_full -# endif /* AO_ASM_X64_AVAILABLE && (_MSC_VER < 1500) */ - -#endif /* AO_CMPXCHG16B_AVAILABLE */ diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/msftc/x86.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/msftc/x86.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/msftc/x86.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/msftc/x86.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,143 +0,0 @@ -/* - * Copyright (c) 2003 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* If AO_ASSUME_WINDOWS98 is defined, we assume Windows 98 or newer. */ -/* If AO_ASSUME_VISTA is defined, we assume Windows Server 2003, Vista */ -/* or later. */ - -#include "../all_aligned_atomic_load_store.h" - -#include "../test_and_set_t_is_char.h" - -#if defined(AO_ASSUME_VISTA) && !defined(AO_ASSUME_WINDOWS98) -# define AO_ASSUME_WINDOWS98 -#endif - -#ifndef AO_USE_INTERLOCKED_INTRINSICS - /* _Interlocked primitives (Inc, Dec, Xchg, Add) are always available */ -# define AO_USE_INTERLOCKED_INTRINSICS -#endif -#include "common32_defs.h" - -/* As far as we can tell, the lfence and sfence instructions are not */ -/* currently needed or useful for cached memory accesses. */ - -/* Unfortunately mfence doesn't exist everywhere. */ -/* IsProcessorFeaturePresent(PF_COMPARE_EXCHANGE128) is */ -/* probably a conservative test for it? */ - -#if defined(AO_USE_PENTIUM4_INSTRS) - -AO_INLINE void -AO_nop_full(void) -{ - __asm { mfence } -} -#define AO_HAVE_nop_full - -#else - -/* We could use the cpuid instruction. But that seems to be slower */ -/* than the default implementation based on test_and_set_full. Thus */ -/* we omit that bit of misinformation here. */ - -#endif - -#ifndef AO_NO_ASM_XADD - AO_INLINE unsigned char - AO_char_fetch_and_add_full(volatile unsigned char *p, unsigned char incr) - { - __asm - { - mov al, incr - mov ebx, p - lock xadd byte ptr [ebx], al - } - /* Ignore possible "missing return value" warning here. */ - } -# define AO_HAVE_char_fetch_and_add_full - - AO_INLINE unsigned short - AO_short_fetch_and_add_full(volatile unsigned short *p, unsigned short incr) - { - __asm - { - mov ax, incr - mov ebx, p - lock xadd word ptr [ebx], ax - } - /* Ignore possible "missing return value" warning here. */ - } -# define AO_HAVE_short_fetch_and_add_full -#endif /* !AO_NO_ASM_XADD */ - -AO_INLINE AO_TS_VAL_t -AO_test_and_set_full(volatile AO_TS_t *addr) -{ - __asm - { - mov eax,0xff ; /* AO_TS_SET */ - mov ebx,addr ; - xchg byte ptr [ebx],al ; - } - /* Ignore possible "missing return value" warning here. */ -} -#define AO_HAVE_test_and_set_full - -#ifdef _WIN64 -# error wrong architecture -#endif - -#ifdef AO_ASSUME_VISTA -# include "../standard_ao_double_t.h" - - /* Reading or writing a quadword aligned on a 64-bit boundary is */ - /* always carried out atomically (requires at least a Pentium). */ -# define AO_ACCESS_double_CHECK_ALIGNED -# include "../loadstore/double_atomic_load_store.h" - - /* Whenever we run on a Pentium class machine, we have that certain */ - /* function. */ -# pragma intrinsic (_InterlockedCompareExchange64) - - /* Returns nonzero if the comparison succeeded. */ - AO_INLINE int - AO_double_compare_and_swap_full(volatile AO_double_t *addr, - AO_double_t old_val, AO_double_t new_val) - { - return (double_ptr_storage)_InterlockedCompareExchange64( - (__int64 volatile *)addr, - new_val.AO_whole /* exchange */, - old_val.AO_whole) == old_val.AO_whole; - } -# define AO_HAVE_double_compare_and_swap_full -#endif /* AO_ASSUME_VISTA */ - -#define AO_T_IS_INT - -/* Real X86 implementations, except for some old WinChips, appear */ -/* to enforce ordering between memory operations, EXCEPT that a later */ -/* read can pass earlier writes, presumably due to the visible */ -/* presence of store buffers. */ -/* We ignore both the WinChips, and the fact that the official specs */ -/* seem to be much weaker (and arguably too weak to be usable). */ -#include "../ordered_except_wr.h" diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/ordered_except_wr.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/ordered_except_wr.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/ordered_except_wr.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/ordered_except_wr.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,42 +0,0 @@ -/* - * Copyright (c) 2003 by Hewlett-Packard Company. All rights reserved. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* - * These are common definitions for architectures that provide processor - * ordered memory operations except that a later read may pass an - * earlier write. Real x86 implementations seem to be in this category, - * except apparently for some IDT WinChips, which we ignore. - */ - -#include "read_ordered.h" - -AO_INLINE void -AO_nop_write(void) -{ - /* AO_nop_write implementation is the same as of AO_nop_read. */ - AO_compiler_barrier(); - /* sfence according to Intel docs. Pentium 3 and up. */ - /* Unnecessary for cached accesses? */ -} -#define AO_HAVE_nop_write - -#include "loadstore/ordered_stores_only.h" diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/ordered.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/ordered.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/ordered.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/ordered.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -/* - * Copyright (c) 2003 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* These are common definitions for architectures that provide */ -/* processor ordered memory operations. */ - -#include "ordered_except_wr.h" - -AO_INLINE void -AO_nop_full(void) -{ - AO_compiler_barrier(); -} -#define AO_HAVE_nop_full diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/README ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/README --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/README 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/README 1970-01-01 00:00:00.000000000 +0000 @@ -1,7 +0,0 @@ -There are two kinds of entities in this directory: - -- Subdirectories corresponding to specific compilers (or compiler/OS combinations). - Each of these includes one or more architecture-specific headers. - -- More generic header files corresponding to a particular ordering and/or - atomicity property that might be shared by multiple hardware platforms. diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/read_ordered.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/read_ordered.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/read_ordered.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/read_ordered.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,37 +0,0 @@ -/* - * Copyright (c) 2003 by Hewlett-Packard Company. All rights reserved. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* - * These are common definitions for architectures that provide processor - * ordered memory operations except that a later read may pass an - * earlier write. Real x86 implementations seem to be in this category, - * except apparently for some IDT WinChips, which we ignore. - */ - -AO_INLINE void -AO_nop_read(void) -{ - AO_compiler_barrier(); -} -#define AO_HAVE_nop_read - -#include "loadstore/ordered_loads_only.h" diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/standard_ao_double_t.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/standard_ao_double_t.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/standard_ao_double_t.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/standard_ao_double_t.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,62 +0,0 @@ -/* - * Copyright (c) 2004-2011 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* For 64-bit systems, we extend the double type to hold two int64's. */ -/* x86-64 (except for x32): __m128 serves as a placeholder which also */ -/* requires the compiler to align it on 16-byte boundary (as required */ -/* by cmpxchg16). */ -/* Similar things could be done for PPC 64-bit using a VMX data type. */ - -#if ((defined(__x86_64__) && __GNUC__ >= 4) || defined(_WIN64)) \ - && !defined(__ILP32__) -# include - typedef __m128 double_ptr_storage; -#elif defined(_WIN32) && !defined(__GNUC__) - typedef unsigned __int64 double_ptr_storage; -#elif defined(__aarch64__) - typedef unsigned __int128 double_ptr_storage; -#else - typedef unsigned long long double_ptr_storage; -#endif -# define AO_HAVE_DOUBLE_PTR_STORAGE - -typedef union { - struct { AO_t AO_v1; AO_t AO_v2; } AO_parts; - /* Note that AO_v1 corresponds to the low or the high part of */ - /* AO_whole depending on the machine endianness. */ - double_ptr_storage AO_whole; - /* AO_whole is now (starting from v7.3alpha3) the 2nd element */ - /* of this union to make AO_DOUBLE_T_INITIALIZER portable */ - /* (because __m128 definition could vary from a primitive type */ - /* to a structure or array/vector). */ -} AO_double_t; -#define AO_HAVE_double_t - -/* Dummy declaration as a compile-time assertion for AO_double_t size. */ -struct AO_double_t_size_static_assert { - char dummy[sizeof(AO_double_t) == 2 * sizeof(AO_t) ? 1 : -1]; -}; - -#define AO_DOUBLE_T_INITIALIZER { { (AO_t)0, (AO_t)0 } } - -#define AO_val1 AO_parts.AO_v1 -#define AO_val2 AO_parts.AO_v2 diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/sunc/sparc.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/sunc/sparc.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/sunc/sparc.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/sunc/sparc.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,36 +0,0 @@ -/* - * Copyright (c) 2004 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -#include "../all_atomic_load_store.h" - -/* Real SPARC code uses TSO: */ -#include "../ordered_except_wr.h" - -/* Test_and_set location is just a byte. */ -#include "../test_and_set_t_is_char.h" - -extern AO_TS_VAL_t -AO_test_and_set_full(volatile AO_TS_t *addr); -/* Implemented in separate .S file, for now. */ -#define AO_HAVE_test_and_set_full - -/* TODO: Like the gcc version, extend this for V8 and V9. */ diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/sunc/sparc.S ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/sunc/sparc.S --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/sunc/sparc.S 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/sunc/sparc.S 1970-01-01 00:00:00.000000000 +0000 @@ -1,5 +0,0 @@ - .seg "text" - .globl AO_test_and_set_full -AO_test_and_set_full: - retl - ldstub [%o0],%o0 diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/sunc/x86.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/sunc/x86.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/sunc/x86.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/sunc/x86.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,238 +0,0 @@ -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 1999-2003 by Hewlett-Packard Company. All rights reserved. - * - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - * Some of the machine specific code was borrowed from our GC distribution. - */ - -/* The following really assume we have a 486 or better. */ - -#include "../all_aligned_atomic_load_store.h" - -#include "../test_and_set_t_is_char.h" - -#if !defined(AO_USE_PENTIUM4_INSTRS) && !defined(__i386) - /* "mfence" (SSE2) is supported on all x86_64/amd64 chips. */ -# define AO_USE_PENTIUM4_INSTRS -#endif - -#if defined(AO_USE_PENTIUM4_INSTRS) - AO_INLINE void - AO_nop_full(void) - { - __asm__ __volatile__ ("mfence" : : : "memory"); - } -# define AO_HAVE_nop_full - -#else - /* We could use the cpuid instruction. But that seems to be slower */ - /* than the default implementation based on test_and_set_full. Thus */ - /* we omit that bit of misinformation here. */ -#endif /* !AO_USE_PENTIUM4_INSTRS */ - -/* As far as we can tell, the lfence and sfence instructions are not */ -/* currently needed or useful for cached memory accesses. */ - -/* Really only works for 486 and later */ -#ifndef AO_PREFER_GENERALIZED - AO_INLINE AO_t - AO_fetch_and_add_full (volatile AO_t *p, AO_t incr) - { - AO_t result; - - __asm__ __volatile__ ("lock; xadd %0, %1" - : "=r" (result), "+m" (*p) - : "0" (incr) - : "memory"); - return result; - } -# define AO_HAVE_fetch_and_add_full -#endif /* !AO_PREFER_GENERALIZED */ - -AO_INLINE unsigned char -AO_char_fetch_and_add_full (volatile unsigned char *p, unsigned char incr) -{ - unsigned char result; - - __asm__ __volatile__ ("lock; xaddb %0, %1" - : "=q" (result), "+m" (*p) - : "0" (incr) - : "memory"); - return result; -} -#define AO_HAVE_char_fetch_and_add_full - -AO_INLINE unsigned short -AO_short_fetch_and_add_full (volatile unsigned short *p, unsigned short incr) -{ - unsigned short result; - - __asm__ __volatile__ ("lock; xaddw %0, %1" - : "=r" (result), "+m" (*p) - : "0" (incr) - : "memory"); - return result; -} -#define AO_HAVE_short_fetch_and_add_full - -#ifndef AO_PREFER_GENERALIZED - /* Really only works for 486 and later */ - AO_INLINE void - AO_and_full (volatile AO_t *p, AO_t value) - { - __asm__ __volatile__ ("lock; and %1, %0" - : "+m" (*p) - : "r" (value) - : "memory"); - } -# define AO_HAVE_and_full - - AO_INLINE void - AO_or_full (volatile AO_t *p, AO_t value) - { - __asm__ __volatile__ ("lock; or %1, %0" - : "+m" (*p) - : "r" (value) - : "memory"); - } -# define AO_HAVE_or_full - - AO_INLINE void - AO_xor_full (volatile AO_t *p, AO_t value) - { - __asm__ __volatile__ ("lock; xor %1, %0" - : "+m" (*p) - : "r" (value) - : "memory"); - } -# define AO_HAVE_xor_full -#endif /* !AO_PREFER_GENERALIZED */ - -AO_INLINE AO_TS_VAL_t -AO_test_and_set_full (volatile AO_TS_t *addr) -{ - AO_TS_t oldval; - /* Note: the "xchg" instruction does not need a "lock" prefix */ - __asm__ __volatile__ ("xchg %b0, %1" - : "=q" (oldval), "+m" (*addr) - : "0" (0xff) - : "memory"); - return (AO_TS_VAL_t)oldval; -} -#define AO_HAVE_test_and_set_full - -#ifndef AO_GENERALIZE_ASM_BOOL_CAS - /* Returns nonzero if the comparison succeeded. */ - AO_INLINE int - AO_compare_and_swap_full(volatile AO_t *addr, AO_t old, AO_t new_val) - { - char result; - __asm__ __volatile__ ("lock; cmpxchg %2, %0; setz %1" - : "+m" (*addr), "=a" (result) - : "r" (new_val), "a" (old) - : "memory"); - return (int) result; - } -# define AO_HAVE_compare_and_swap_full -#endif /* !AO_GENERALIZE_ASM_BOOL_CAS */ - -AO_INLINE AO_t -AO_fetch_compare_and_swap_full(volatile AO_t *addr, AO_t old_val, - AO_t new_val) -{ - AO_t fetched_val; - __asm__ __volatile__ ("lock; cmpxchg %2, %0" - : "+m" (*addr), "=a" (fetched_val) - : "r" (new_val), "a" (old_val) - : "memory"); - return fetched_val; -} -#define AO_HAVE_fetch_compare_and_swap_full - -#if defined(__i386) - -# ifndef AO_NO_CMPXCHG8B -# include "../standard_ao_double_t.h" - - /* Reading or writing a quadword aligned on a 64-bit boundary is */ - /* always carried out atomically (requires at least a Pentium). */ -# define AO_ACCESS_double_CHECK_ALIGNED -# include "../loadstore/double_atomic_load_store.h" - - /* Returns nonzero if the comparison succeeded. */ - /* Really requires at least a Pentium. */ - AO_INLINE int - AO_compare_double_and_swap_double_full(volatile AO_double_t *addr, - AO_t old_val1, AO_t old_val2, - AO_t new_val1, AO_t new_val2) - { - char result; - - __asm__ __volatile__ ("lock; cmpxchg8b %0; setz %1" - : "+m" (*addr), "=a" (result) - : "d" (old_val2), "a" (old_val1), - "c" (new_val2), "b" (new_val1) - : "memory"); - return (int) result; - } -# define AO_HAVE_compare_double_and_swap_double_full -# endif /* !AO_NO_CMPXCHG8B */ - -# define AO_T_IS_INT - -#else /* x64 */ - - AO_INLINE unsigned int - AO_int_fetch_and_add_full (volatile unsigned int *p, unsigned int incr) - { - unsigned int result; - - __asm__ __volatile__ ("lock; xaddl %0, %1" - : "=r" (result), "+m" (*p) - : "0" (incr) - : "memory"); - return result; - } -# define AO_HAVE_int_fetch_and_add_full - -# ifdef AO_CMPXCHG16B_AVAILABLE -# include "../standard_ao_double_t.h" - - /* Older AMD Opterons are missing this instruction (SIGILL should */ - /* be thrown in this case). */ - AO_INLINE int - AO_compare_double_and_swap_double_full (volatile AO_double_t *addr, - AO_t old_val1, AO_t old_val2, - AO_t new_val1, AO_t new_val2) - { - char result; - __asm__ __volatile__ ("lock; cmpxchg16b %0; setz %1" - : "+m" (*addr), "=a" (result) - : "d" (old_val2), "a" (old_val1), - "c" (new_val2), "b" (new_val1) - : "memory"); - return (int) result; - } -# define AO_HAVE_compare_double_and_swap_double_full -# endif /* !AO_CMPXCHG16B_AVAILABLE */ - -#endif /* x64 */ - -/* Real X86 implementations, except for some old 32-bit WinChips, */ -/* appear to enforce ordering between memory operations, EXCEPT that */ -/* a later read can pass earlier writes, presumably due to the visible */ -/* presence of store buffers. */ -/* We ignore both the WinChips and the fact that the official specs */ -/* seem to be much weaker (and arguably too weak to be usable). */ -#include "../ordered_except_wr.h" diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/test_and_set_t_is_ao_t.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/test_and_set_t_is_ao_t.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/test_and_set_t_is_ao_t.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/test_and_set_t_is_ao_t.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,36 +0,0 @@ -/* - * Copyright (c) 2004 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* - * These are common definitions for architectures on which test_and_set - * operates on pointer-sized quantities, the "clear" value contains - * all zeroes, and the "set" value contains only one lowest bit set. - * This can be used if test_and_set is synthesized from compare_and_swap. - */ -typedef enum {AO_TS_clear = 0, AO_TS_set = 1} AO_TS_val; -#define AO_TS_VAL_t AO_TS_val -#define AO_TS_CLEAR AO_TS_clear -#define AO_TS_SET AO_TS_set - -#define AO_TS_t AO_t - -#define AO_AO_TS_T 1 diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/test_and_set_t_is_char.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/test_and_set_t_is_char.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/test_and_set_t_is_char.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops/sysdeps/test_and_set_t_is_char.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -/* - * Copyright (c) 2004 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* - * These are common definitions for architectures on which test_and_set - * operates on byte sized quantities, the "clear" value contains - * all zeroes, and the "set" value contains all ones. - */ - -#define AO_TS_t unsigned char -typedef enum {AO_BYTE_TS_clear = 0, AO_BYTE_TS_set = 0xff} AO_BYTE_TS_val; -#define AO_TS_VAL_t AO_BYTE_TS_val -#define AO_TS_CLEAR AO_BYTE_TS_clear -#define AO_TS_SET AO_BYTE_TS_set - -#define AO_CHAR_TS_T 1 diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops.c ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops.c --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,253 +0,0 @@ -/* - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* - * Initialized data and out-of-line functions to support atomic_ops.h - * go here. Currently this is needed only for pthread-based atomics - * emulation, or for compare-and-swap emulation. - * Pthreads emulation isn't useful on a native Windows platform, and - * cas emulation is not needed. Thus we skip this on Windows. - */ - -#if defined(HAVE_CONFIG_H) -# include "config.h" -#endif - -#if defined(__native_client__) && !defined(AO_USE_NO_SIGNALS) \ - && !defined(AO_USE_NANOSLEEP) - /* Since NaCl is not recognized by configure yet, we do it here. */ -# define AO_USE_NO_SIGNALS -# define AO_USE_NANOSLEEP -#endif - -#if defined(AO_USE_WIN32_PTHREADS) && !defined(AO_USE_NO_SIGNALS) -# define AO_USE_NO_SIGNALS -#endif - -#undef AO_REQUIRE_CAS -#include "atomic_ops.h" /* Without cas emulation! */ - -#if !defined(_MSC_VER) && !defined(__MINGW32__) && !defined(__BORLANDC__) \ - || defined(AO_USE_NO_SIGNALS) - -#ifndef AO_NO_PTHREADS -# include -#endif - -#ifndef AO_USE_NO_SIGNALS -# include -#endif - -#ifdef AO_USE_NANOSLEEP - /* This requires _POSIX_TIMERS feature. */ -# include -# include -#elif defined(AO_USE_WIN32_PTHREADS) -# include /* for Sleep() */ -#elif defined(_HPUX_SOURCE) -# include -#else -# include -#endif - -#ifndef AO_HAVE_double_t -# include "atomic_ops/sysdeps/standard_ao_double_t.h" -#endif - -/* Lock for pthreads-based implementation. */ -#ifndef AO_NO_PTHREADS - pthread_mutex_t AO_pt_lock = PTHREAD_MUTEX_INITIALIZER; -#endif - -/* - * Out of line compare-and-swap emulation based on test and set. - * - * We use a small table of locks for different compare_and_swap locations. - * Before we update perform a compare-and-swap, we grab the corresponding - * lock. Different locations may hash to the same lock, but since we - * never acquire more than one lock at a time, this can't deadlock. - * We explicitly disable signals while we perform this operation. - * - * TODO: Probably also support emulation based on Lamport - * locks, since we may not have test_and_set either. - */ -#define AO_HASH_SIZE 16 - -#define AO_HASH(x) (((unsigned long)(x) >> 12) & (AO_HASH_SIZE-1)) - -AO_TS_t AO_locks[AO_HASH_SIZE] = { - AO_TS_INITIALIZER, AO_TS_INITIALIZER, AO_TS_INITIALIZER, AO_TS_INITIALIZER, - AO_TS_INITIALIZER, AO_TS_INITIALIZER, AO_TS_INITIALIZER, AO_TS_INITIALIZER, - AO_TS_INITIALIZER, AO_TS_INITIALIZER, AO_TS_INITIALIZER, AO_TS_INITIALIZER, - AO_TS_INITIALIZER, AO_TS_INITIALIZER, AO_TS_INITIALIZER, AO_TS_INITIALIZER, -}; - -void AO_pause(int); /* defined below */ - -static void lock_ool(volatile AO_TS_t *l) -{ - int i = 0; - - while (AO_test_and_set_acquire(l) == AO_TS_SET) - AO_pause(++i); -} - -AO_INLINE void lock(volatile AO_TS_t *l) -{ - if (AO_EXPECT_FALSE(AO_test_and_set_acquire(l) == AO_TS_SET)) - lock_ool(l); -} - -AO_INLINE void unlock(volatile AO_TS_t *l) -{ - AO_CLEAR(l); -} - -#ifndef AO_USE_NO_SIGNALS - static sigset_t all_sigs; - static volatile AO_t initialized = 0; - static volatile AO_TS_t init_lock = AO_TS_INITIALIZER; - - AO_INLINE void block_all_signals(sigset_t *old_sigs_ptr) - { - if (AO_EXPECT_FALSE(!AO_load_acquire(&initialized))) - { - lock(&init_lock); - if (!initialized) - sigfillset(&all_sigs); - unlock(&init_lock); - AO_store_release(&initialized, 1); - } - sigprocmask(SIG_BLOCK, &all_sigs, old_sigs_ptr); - /* Neither sigprocmask nor pthread_sigmask is 100% */ - /* guaranteed to work here. Sigprocmask is not */ - /* guaranteed be thread safe, and pthread_sigmask */ - /* is not async-signal-safe. Under linuxthreads, */ - /* sigprocmask may block some pthreads-internal */ - /* signals. So long as we do that for short periods, */ - /* we should be OK. */ - } -#endif /* !AO_USE_NO_SIGNALS */ - -AO_t AO_fetch_compare_and_swap_emulation(volatile AO_t *addr, AO_t old_val, - AO_t new_val) -{ - AO_TS_t *my_lock = AO_locks + AO_HASH(addr); - AO_t fetched_val; - -# ifndef AO_USE_NO_SIGNALS - sigset_t old_sigs; - block_all_signals(&old_sigs); -# endif - lock(my_lock); - fetched_val = *addr; - if (fetched_val == old_val) - *addr = new_val; - unlock(my_lock); -# ifndef AO_USE_NO_SIGNALS - sigprocmask(SIG_SETMASK, &old_sigs, NULL); -# endif - return fetched_val; -} - -int AO_compare_double_and_swap_double_emulation(volatile AO_double_t *addr, - AO_t old_val1, AO_t old_val2, - AO_t new_val1, AO_t new_val2) -{ - AO_TS_t *my_lock = AO_locks + AO_HASH(addr); - int result; - -# ifndef AO_USE_NO_SIGNALS - sigset_t old_sigs; - block_all_signals(&old_sigs); -# endif - lock(my_lock); - if (addr -> AO_val1 == old_val1 && addr -> AO_val2 == old_val2) - { - addr -> AO_val1 = new_val1; - addr -> AO_val2 = new_val2; - result = 1; - } - else - result = 0; - unlock(my_lock); -# ifndef AO_USE_NO_SIGNALS - sigprocmask(SIG_SETMASK, &old_sigs, NULL); -# endif - return result; -} - -void AO_store_full_emulation(volatile AO_t *addr, AO_t val) -{ - AO_TS_t *my_lock = AO_locks + AO_HASH(addr); - lock(my_lock); - *addr = val; - unlock(my_lock); -} - -#else /* Non-posix platform */ - -# include - -# define AO_USE_WIN32_PTHREADS - /* define to use Sleep() */ - - extern int AO_non_posix_implementation_is_entirely_in_headers; - -#endif - -static AO_t spin_dummy = 1; - -/* Spin for 2**n units. */ -static void AO_spin(int n) -{ - AO_t j = AO_load(&spin_dummy); - int i = 2 << n; - - while (i-- > 0) - j += (j - 1) << 2; - /* Given 'spin_dummy' is initialized to 1, j is 1 after the loop. */ - AO_store(&spin_dummy, j); -} - -void AO_pause(int n) -{ - if (n < 12) - AO_spin(n); - else - { -# ifdef AO_USE_NANOSLEEP - struct timespec ts; - ts.tv_sec = 0; - ts.tv_nsec = (n > 28 ? 100000 * 1000 : 1 << (n - 2)); - nanosleep(&ts, 0); -# elif defined(AO_USE_WIN32_PTHREADS) - Sleep(n > 28 ? 100 : n < 22 ? 1 : 1 << (n - 22)); /* in millis */ -# else - struct timeval tv; - /* Short async-signal-safe sleep. */ - tv.tv_sec = 0; - tv.tv_usec = n > 28 ? 100000 : 1 << (n - 12); - select(0, 0, 0, 0, &tv); -# endif - } -} diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,418 +0,0 @@ -/* - * Copyright (c) 2003-2011 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -#ifndef AO_ATOMIC_OPS_H -#define AO_ATOMIC_OPS_H - -#include "atomic_ops/ao_version.h" - /* Define version numbers here to allow */ - /* test on build machines for cross-builds. */ - -#include -#include - -/* We define various atomic operations on memory in a */ -/* machine-specific way. Unfortunately, this is complicated */ -/* by the fact that these may or may not be combined with */ -/* various memory barriers. Thus the actual operations we */ -/* define have the form AO__, for all */ -/* plausible combinations of and . */ -/* This of course results in a mild combinatorial explosion. */ -/* To deal with it, we try to generate derived */ -/* definitions for as many of the combinations as we can, as */ -/* automatically as possible. */ -/* */ -/* Our assumption throughout is that the programmer will */ -/* specify the least demanding operation and memory barrier */ -/* that will guarantee correctness for the implementation. */ -/* Our job is to find the least expensive way to implement it */ -/* on the applicable hardware. In many cases that will */ -/* involve, for example, a stronger memory barrier, or a */ -/* combination of hardware primitives. */ -/* */ -/* Conventions: */ -/* "plain" atomic operations are not guaranteed to include */ -/* a barrier. The suffix in the name specifies the barrier */ -/* type. Suffixes are: */ -/* _release: Earlier operations may not be delayed past it. */ -/* _acquire: Later operations may not move ahead of it. */ -/* _read: Subsequent reads must follow this operation and */ -/* preceding reads. */ -/* _write: Earlier writes precede both this operation and */ -/* later writes. */ -/* _full: Ordered with respect to both earlier and later memory */ -/* operations. */ -/* _release_write: Ordered with respect to earlier writes. */ -/* _acquire_read: Ordered with respect to later reads. */ -/* */ -/* Currently we try to define the following atomic memory */ -/* operations, in combination with the above barriers: */ -/* AO_nop */ -/* AO_load */ -/* AO_store */ -/* AO_test_and_set (binary) */ -/* AO_fetch_and_add */ -/* AO_fetch_and_add1 */ -/* AO_fetch_and_sub1 */ -/* AO_and */ -/* AO_or */ -/* AO_xor */ -/* AO_compare_and_swap */ -/* AO_fetch_compare_and_swap */ -/* */ -/* Note that atomicity guarantees are valid only if both */ -/* readers and writers use AO_ operations to access the */ -/* shared value, while ordering constraints are intended to */ -/* apply all memory operations. If a location can potentially */ -/* be accessed simultaneously from multiple threads, and one of */ -/* those accesses may be a write access, then all such */ -/* accesses to that location should be through AO_ primitives. */ -/* However if AO_ operations enforce sufficient ordering to */ -/* ensure that a location x cannot be accessed concurrently, */ -/* or can only be read concurrently, then x can be accessed */ -/* via ordinary references and assignments. */ -/* */ -/* AO_compare_and_swap takes an address and an expected old */ -/* value and a new value, and returns an int. Non-zero result */ -/* indicates that it succeeded. */ -/* AO_fetch_compare_and_swap takes an address and an expected */ -/* old value and a new value, and returns the real old value. */ -/* The operation succeeded if and only if the expected old */ -/* value matches the old value returned. */ -/* */ -/* Test_and_set takes an address, atomically replaces it by */ -/* AO_TS_SET, and returns the prior value. */ -/* An AO_TS_t location can be reset with the */ -/* AO_CLEAR macro, which normally uses AO_store_release. */ -/* AO_fetch_and_add takes an address and an AO_t increment */ -/* value. The AO_fetch_and_add1 and AO_fetch_and_sub1 variants */ -/* are provided, since they allow faster implementations on */ -/* some hardware. AO_and, AO_or, AO_xor do atomically and, or, */ -/* xor (respectively) an AO_t value into a memory location, */ -/* but do not provide access to the original. */ -/* */ -/* We expect this list to grow slowly over time. */ -/* */ -/* Note that AO_nop_full is a full memory barrier. */ -/* */ -/* Note that if some data is initialized with */ -/* data.x = ...; data.y = ...; ... */ -/* AO_store_release_write(&data_is_initialized, 1) */ -/* then data is guaranteed to be initialized after the test */ -/* if (AO_load_acquire_read(&data_is_initialized)) ... */ -/* succeeds. Furthermore, this should generate near-optimal */ -/* code on all common platforms. */ -/* */ -/* All operations operate on unsigned AO_t, which */ -/* is the natural word size, and usually unsigned long. */ -/* It is possible to check whether a particular operation op */ -/* is available on a particular platform by checking whether */ -/* AO_HAVE_op is defined. We make heavy use of these macros */ -/* internally. */ - -/* The rest of this file basically has three sections: */ -/* */ -/* Some utility and default definitions. */ -/* */ -/* The architecture dependent section: */ -/* This defines atomic operations that have direct hardware */ -/* support on a particular platform, mostly by including the */ -/* appropriate compiler- and hardware-dependent file. */ -/* */ -/* The synthesis section: */ -/* This tries to define other atomic operations in terms of */ -/* those that are explicitly available on the platform. */ -/* This section is hardware independent. */ -/* We make no attempt to synthesize operations in ways that */ -/* effectively introduce locks, except for the debugging/demo */ -/* pthread-based implementation at the beginning. A more */ -/* realistic implementation that falls back to locks could be */ -/* added as a higher layer. But that would sacrifice */ -/* usability from signal handlers. */ -/* The synthesis section is implemented almost entirely in */ -/* atomic_ops/generalize.h. */ - -/* Some common defaults. Overridden for some architectures. */ -#define AO_t size_t - -/* The test_and_set primitive returns an AO_TS_VAL_t value. */ -/* AO_TS_t is the type of an in-memory test-and-set location. */ - -#define AO_TS_INITIALIZER (AO_t)AO_TS_CLEAR - -/* Platform-dependent stuff: */ -#if (defined(__GNUC__) || defined(_MSC_VER) || defined(__INTEL_COMPILER) \ - || defined(__DMC__) || defined(__WATCOMC__)) && !defined(AO_NO_INLINE) -# define AO_INLINE static __inline -#elif defined(__sun) && !defined(AO_NO_INLINE) -# define AO_INLINE static inline -#else -# define AO_INLINE static -#endif - -#if __GNUC__ >= 3 && !defined(LINT2) -# define AO_EXPECT_FALSE(expr) __builtin_expect(expr, 0) - /* Equivalent to (expr) but predict that usually (expr) == 0. */ -#else -# define AO_EXPECT_FALSE(expr) (expr) -#endif /* !__GNUC__ */ - -#if defined(__GNUC__) && !defined(__INTEL_COMPILER) -# define AO_compiler_barrier() __asm__ __volatile__("" : : : "memory") -#elif defined(_MSC_VER) || defined(__DMC__) || defined(__BORLANDC__) \ - || defined(__WATCOMC__) -# if defined(_AMD64_) || defined(_M_X64) || _MSC_VER >= 1400 -# if defined(_WIN32_WCE) -/* # include */ -# elif defined(_MSC_VER) -# include -# endif -# pragma intrinsic(_ReadWriteBarrier) -# define AO_compiler_barrier() _ReadWriteBarrier() - /* We assume this does not generate a fence instruction. */ - /* The documentation is a bit unclear. */ -# else -# define AO_compiler_barrier() __asm { } - /* The preceding implementation may be preferable here too. */ - /* But the documentation warns about VC++ 2003 and earlier. */ -# endif -#elif defined(__INTEL_COMPILER) -# define AO_compiler_barrier() __memory_barrier() - /* FIXME: Too strong? IA64-only? */ -#elif defined(_HPUX_SOURCE) -# if defined(__ia64) -# include -# define AO_compiler_barrier() _Asm_sched_fence() -# else - /* FIXME - We dont know how to do this. This is a guess. */ - /* And probably a bad one. */ - static volatile int AO_barrier_dummy; -# define AO_compiler_barrier() (void)(AO_barrier_dummy = AO_barrier_dummy) -# endif -#else - /* We conjecture that the following usually gives us the right */ - /* semantics or an error. */ -# define AO_compiler_barrier() asm("") -#endif - -#if defined(AO_USE_PTHREAD_DEFS) -# include "atomic_ops/sysdeps/generic_pthread.h" -#endif /* AO_USE_PTHREAD_DEFS */ - -#if (defined(__CC_ARM) || defined(__ARMCC__)) && !defined(__GNUC__) \ - && !defined(AO_USE_PTHREAD_DEFS) -# include "atomic_ops/sysdeps/armcc/arm_v6.h" -# define AO_GENERALIZE_TWICE -#endif - -#if defined(__GNUC__) && !defined(AO_USE_PTHREAD_DEFS) \ - && !defined(__INTEL_COMPILER) -# if defined(__i386__) - /* We don't define AO_USE_SYNC_CAS_BUILTIN for x86 here because */ - /* it might require specifying additional options (like -march) */ - /* or additional link libraries (if -march is not specified). */ -# include "atomic_ops/sysdeps/gcc/x86.h" -# endif /* __i386__ */ -# if defined(__x86_64__) -# if (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 2)) \ - && !defined(AO_USE_SYNC_CAS_BUILTIN) - /* It is safe to use __sync CAS built-in on this architecture. */ -# define AO_USE_SYNC_CAS_BUILTIN -# endif -# include "atomic_ops/sysdeps/gcc/x86.h" -# endif /* __x86_64__ */ -# if defined(__ia64__) -# include "atomic_ops/sysdeps/gcc/ia64.h" -# define AO_GENERALIZE_TWICE -# endif /* __ia64__ */ -# if defined(__hppa__) -# include "atomic_ops/sysdeps/gcc/hppa.h" -# define AO_CAN_EMUL_CAS -# endif /* __hppa__ */ -# if defined(__alpha__) -# include "atomic_ops/sysdeps/gcc/alpha.h" -# define AO_GENERALIZE_TWICE -# endif /* __alpha__ */ -# if defined(__s390__) -# include "atomic_ops/sysdeps/gcc/s390.h" -# endif /* __s390__ */ -# if defined(__sparc__) -# include "atomic_ops/sysdeps/gcc/sparc.h" -# define AO_CAN_EMUL_CAS -# endif /* __sparc__ */ -# if defined(__m68k__) -# include "atomic_ops/sysdeps/gcc/m68k.h" -# endif /* __m68k__ */ -# if defined(__powerpc__) || defined(__ppc__) || defined(__PPC__) \ - || defined(__powerpc64__) || defined(__ppc64__) -# include "atomic_ops/sysdeps/gcc/powerpc.h" -# endif /* __powerpc__ */ -# if defined(__aarch64__) -# include "atomic_ops/sysdeps/gcc/aarch64.h" -# define AO_CAN_EMUL_CAS -# endif /* __aarch64__ */ -# if defined(__arm__) -# include "atomic_ops/sysdeps/gcc/arm.h" -# define AO_CAN_EMUL_CAS -# endif /* __arm__ */ -# if defined(__cris__) || defined(CRIS) -# include "atomic_ops/sysdeps/gcc/cris.h" -# define AO_GENERALIZE_TWICE -# endif -# if defined(__mips__) -# include "atomic_ops/sysdeps/gcc/mips.h" -# endif /* __mips__ */ -# if defined(__sh__) || defined(SH4) -# include "atomic_ops/sysdeps/gcc/sh.h" -# define AO_CAN_EMUL_CAS -# endif /* __sh__ */ -# if defined(__avr32__) -# include "atomic_ops/sysdeps/gcc/avr32.h" -# endif -# if defined(__hexagon__) -# include "atomic_ops/sysdeps/gcc/hexagon.h" -# endif -#endif /* __GNUC__ && !AO_USE_PTHREAD_DEFS */ - -#if (defined(__IBMC__) || defined(__IBMCPP__)) && !defined(__GNUC__) \ - && !defined(AO_USE_PTHREAD_DEFS) -# if defined(__powerpc__) || defined(__powerpc) || defined(__ppc__) \ - || defined(__PPC__) || defined(_M_PPC) || defined(_ARCH_PPC) \ - || defined(_ARCH_PWR) -# include "atomic_ops/sysdeps/ibmc/powerpc.h" -# define AO_GENERALIZE_TWICE -# endif -#endif - -#if defined(__INTEL_COMPILER) && !defined(AO_USE_PTHREAD_DEFS) -# if defined(__ia64__) -# include "atomic_ops/sysdeps/icc/ia64.h" -# define AO_GENERALIZE_TWICE -# endif -# if defined(__GNUC__) - /* Intel Compiler in GCC compatible mode */ -# if defined(__i386__) -# include "atomic_ops/sysdeps/gcc/x86.h" -# endif /* __i386__ */ -# if defined(__x86_64__) -# if (__INTEL_COMPILER > 1110) && !defined(AO_USE_SYNC_CAS_BUILTIN) -# define AO_USE_SYNC_CAS_BUILTIN -# endif -# include "atomic_ops/sysdeps/gcc/x86.h" -# endif /* __x86_64__ */ -# endif -#endif - -#if defined(_HPUX_SOURCE) && !defined(__GNUC__) && !defined(AO_USE_PTHREAD_DEFS) -# if defined(__ia64) -# include "atomic_ops/sysdeps/hpc/ia64.h" -# define AO_GENERALIZE_TWICE -# else -# include "atomic_ops/sysdeps/hpc/hppa.h" -# define AO_CAN_EMUL_CAS -# endif -#endif - -#if defined(_MSC_VER) || defined(__DMC__) || defined(__BORLANDC__) \ - || (defined(__WATCOMC__) && defined(__NT__)) -# if defined(_AMD64_) || defined(_M_X64) -# include "atomic_ops/sysdeps/msftc/x86_64.h" -# elif defined(_M_IX86) || defined(x86) -# include "atomic_ops/sysdeps/msftc/x86.h" -# elif defined(_M_ARM) || defined(ARM) || defined(_ARM_) -# include "atomic_ops/sysdeps/msftc/arm.h" -# define AO_GENERALIZE_TWICE -# endif -#endif - -#if defined(__sun) && !defined(__GNUC__) && !defined(AO_USE_PTHREAD_DEFS) - /* Note: use -DAO_USE_PTHREAD_DEFS if Sun CC does not handle inline asm. */ -# if defined(__i386) || defined(__x86_64) || defined(__amd64) -# include "atomic_ops/sysdeps/sunc/x86.h" -# endif -#endif - -#if !defined(__GNUC__) && (defined(sparc) || defined(__sparc)) \ - && !defined(AO_USE_PTHREAD_DEFS) -# include "atomic_ops/sysdeps/sunc/sparc.h" -# define AO_CAN_EMUL_CAS -#endif - -#if defined(AO_REQUIRE_CAS) && !defined(AO_HAVE_compare_and_swap) \ - && !defined(AO_HAVE_fetch_compare_and_swap) \ - && !defined(AO_HAVE_compare_and_swap_full) \ - && !defined(AO_HAVE_fetch_compare_and_swap_full) \ - && !defined(AO_HAVE_compare_and_swap_acquire) \ - && !defined(AO_HAVE_fetch_compare_and_swap_acquire) -# if defined(AO_CAN_EMUL_CAS) -# include "atomic_ops/sysdeps/emul_cas.h" -# else -# error Cannot implement AO_compare_and_swap_full on this architecture. -# endif -#endif /* AO_REQUIRE_CAS && !AO_HAVE_compare_and_swap ... */ - -/* The most common way to clear a test-and-set location */ -/* at the end of a critical section. */ -#if AO_AO_TS_T && !defined(AO_CLEAR) -# define AO_CLEAR(addr) AO_store_release((AO_TS_t *)(addr), AO_TS_CLEAR) -#endif -#if AO_CHAR_TS_T && !defined(AO_CLEAR) -# define AO_CLEAR(addr) AO_char_store_release((AO_TS_t *)(addr), AO_TS_CLEAR) -#endif - -/* The generalization section. */ -#if !defined(AO_GENERALIZE_TWICE) && defined(AO_CAN_EMUL_CAS) \ - && !defined(AO_HAVE_compare_and_swap_full) \ - && !defined(AO_HAVE_fetch_compare_and_swap_full) -# define AO_GENERALIZE_TWICE -#endif - -/* Theoretically we should repeatedly include atomic_ops/generalize.h. */ -/* In fact, we observe that this converges after a small fixed number */ -/* of iterations, usually one. */ -#include "atomic_ops/generalize.h" - -#if !defined(AO_GENERALIZE_TWICE) \ - && defined(AO_HAVE_compare_double_and_swap_double) \ - && (!defined(AO_HAVE_double_load) || !defined(AO_HAVE_double_store)) -# define AO_GENERALIZE_TWICE -#endif - -#ifdef AO_T_IS_INT - /* Included after the first generalization pass. */ -# include "atomic_ops/sysdeps/ao_t_is_int.h" -# ifndef AO_GENERALIZE_TWICE - /* Always generalize again. */ -# define AO_GENERALIZE_TWICE -# endif -#endif /* AO_T_IS_INT */ - -#ifdef AO_GENERALIZE_TWICE -# include "atomic_ops/generalize.h" -#endif - -/* For compatibility with version 0.4 and earlier */ -#define AO_TS_T AO_TS_t -#define AO_T AO_t -#define AO_TS_VAL AO_TS_VAL_t - -#endif /* !AO_ATOMIC_OPS_H */ diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops_malloc.c ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops_malloc.c --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops_malloc.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops_malloc.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,305 +0,0 @@ -/* - * Copyright (c) 2005 Hewlett-Packard Development Company, L.P. - * - * This file may be redistributed and/or modified 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. - * - * It 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 in the - * file COPYING for more details. - */ - -#if defined(HAVE_CONFIG_H) -# include "config.h" -#endif - -#define AO_REQUIRE_CAS -#include "atomic_ops_malloc.h" - -#include /* for ffs, which is assumed reentrant. */ -#include -#include - -#ifdef AO_TRACE_MALLOC -# include -# include -#endif - -#if (defined(_WIN32_WCE) || defined(__MINGW32CE__)) && !defined(abort) -# define abort() _exit(-1) /* there is no abort() in WinCE */ -#endif - -/* - * We round up each allocation request to the next power of two - * minus one word. - * We keep one stack of free objects for each size. Each object - * has an initial word (offset -sizeof(AO_t) from the visible pointer) - * which contains either - * The binary log of the object size in bytes (small objects) - * The object size (a multiple of CHUNK_SIZE) for large objects. - * The second case only arises if mmap-based allocation is supported. - * We align the user-visible part of each object on a GRANULARITY - * byte boundary. That means that the actual (hidden) start of - * the object starts a word before this boundary. - */ - -#ifndef LOG_MAX_SIZE -# define LOG_MAX_SIZE 16 - /* We assume that 2**LOG_MAX_SIZE is a multiple of page size. */ -#endif - -#ifndef ALIGNMENT -# define ALIGNMENT 16 - /* Assumed to be at least sizeof(AO_t). */ -#endif - -#define CHUNK_SIZE (1 << LOG_MAX_SIZE) - -#ifndef AO_INITIAL_HEAP_SIZE -# define AO_INITIAL_HEAP_SIZE (2*(LOG_MAX_SIZE+1)*CHUNK_SIZE) -#endif - -char AO_initial_heap[AO_INITIAL_HEAP_SIZE]; - -static volatile AO_t initial_heap_ptr = (AO_t)AO_initial_heap; - -#if defined(HAVE_MMAP) - -#include -#include -#include -#include - -#if defined(MAP_ANONYMOUS) || defined(MAP_ANON) -# define USE_MMAP_ANON -#endif - -#ifdef USE_MMAP_FIXED -# define GC_MMAP_FLAGS (MAP_FIXED | MAP_PRIVATE) - /* Seems to yield better performance on Solaris 2, but can */ - /* be unreliable if something is already mapped at the address. */ -#else -# define GC_MMAP_FLAGS MAP_PRIVATE -#endif - -#ifdef USE_MMAP_ANON -# ifdef MAP_ANONYMOUS -# define OPT_MAP_ANON MAP_ANONYMOUS -# else -# define OPT_MAP_ANON MAP_ANON -# endif -#else -# define OPT_MAP_ANON 0 -#endif - -static volatile AO_t mmap_enabled = 0; - -void -AO_malloc_enable_mmap(void) -{ -# if defined(__sun) - AO_store_release(&mmap_enabled, 1); - /* Workaround for Sun CC */ -# else - AO_store(&mmap_enabled, 1); -# endif -} - -static char *get_mmaped(size_t sz) -{ - char * result; -# ifdef USE_MMAP_ANON -# define zero_fd -1 -# else - int zero_fd; -# endif - - assert(!(sz & (CHUNK_SIZE - 1))); - if (!mmap_enabled) - return 0; - -# ifndef USE_MMAP_ANON - zero_fd = open("/dev/zero", O_RDONLY); - if (zero_fd == -1) - return 0; -# endif - result = mmap(0, sz, PROT_READ | PROT_WRITE, - GC_MMAP_FLAGS | OPT_MAP_ANON, zero_fd, 0/* offset */); -# ifndef USE_MMAP_ANON - close(zero_fd); -# endif - if (result == MAP_FAILED) - result = 0; - return result; -} - -/* Allocate an object of size (incl. header) of size > CHUNK_SIZE. */ -/* sz includes space for an AO_t-sized header. */ -static char * -AO_malloc_large(size_t sz) -{ - char * result; - /* The header will force us to waste ALIGNMENT bytes, incl. header. */ - sz += ALIGNMENT; - /* Round to multiple of CHUNK_SIZE. */ - sz = (sz + CHUNK_SIZE - 1) & ~(CHUNK_SIZE - 1); - result = get_mmaped(sz); - if (result == 0) return 0; - result += ALIGNMENT; - ((AO_t *)result)[-1] = (AO_t)sz; - return result; -} - -static void -AO_free_large(char * p) -{ - AO_t sz = ((AO_t *)p)[-1]; - if (munmap(p - ALIGNMENT, (size_t)sz) != 0) - abort(); /* Programmer error. Not really async-signal-safe, but ... */ -} - - -#else /* No MMAP */ - -void -AO_malloc_enable_mmap(void) -{ -} - -#define get_mmaped(sz) ((char*)0) -#define AO_malloc_large(sz) ((char*)0) -#define AO_free_large(p) abort() - /* Programmer error. Not really async-signal-safe, but ... */ - -#endif /* No MMAP */ - -static char * -get_chunk(void) -{ - char *my_chunk_ptr; - - for (;;) { - char *initial_ptr = (char *)AO_load(&initial_heap_ptr); - - my_chunk_ptr = (char *)(((AO_t)initial_ptr + (ALIGNMENT - 1)) - & ~(ALIGNMENT - 1)); - if (initial_ptr != my_chunk_ptr) - { - /* Align correctly. If this fails, someone else did it for us. */ - (void)AO_compare_and_swap_acquire(&initial_heap_ptr, - (AO_t)initial_ptr, (AO_t)my_chunk_ptr); - } - - if (my_chunk_ptr - AO_initial_heap > AO_INITIAL_HEAP_SIZE - CHUNK_SIZE) - break; - if (AO_compare_and_swap(&initial_heap_ptr, (AO_t)my_chunk_ptr, - (AO_t)(my_chunk_ptr + CHUNK_SIZE))) { - return my_chunk_ptr; - } - } - - /* We failed. The initial heap is used up. */ - my_chunk_ptr = get_mmaped(CHUNK_SIZE); - assert (!((AO_t)my_chunk_ptr & (ALIGNMENT-1))); - return my_chunk_ptr; -} - -/* Object free lists. Ith entry corresponds to objects */ -/* of total size 2**i bytes. */ -AO_stack_t AO_free_list[LOG_MAX_SIZE+1]; - -/* Break up the chunk, and add it to the object free list for */ -/* the given size. We have exclusive access to chunk. */ -static void add_chunk_as(void * chunk, unsigned log_sz) -{ - size_t ofs, limit; - size_t sz = (size_t)1 << log_sz; - - assert (CHUNK_SIZE >= sz); - limit = (size_t)CHUNK_SIZE - sz; - for (ofs = ALIGNMENT - sizeof(AO_t); ofs <= limit; ofs += sz) { - AO_stack_push(&AO_free_list[log_sz], (AO_t *)((char *)chunk + ofs)); - } -} - -static const int msbs[16] = {0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4}; - -/* Return the position of the most significant set bit in the */ -/* argument. */ -/* We follow the conventions of ffs(), i.e. the least */ -/* significant bit is number one. */ -static int msb(size_t s) -{ - int result = 0; - int v; - if ((s & 0xff) != s) { - /* The following is a tricky code ought to be equivalent to */ - /* "(v = s >> 32) != 0" but suppresses warnings on 32-bit arch's. */ - if (sizeof(size_t) > 4 && (v = s >> (sizeof(size_t) > 4 ? 32 : 0)) != 0) - { - s = v; - result += 32; - } - if ((s >> 16) != 0) - { - s >>= 16; - result += 16; - } - if ((s >> 8) != 0) - { - s >>= 8; - result += 8; - } - } - if (s > 15) - { - s >>= 4; - result += 4; - } - result += msbs[s]; - return result; -} - -void * -AO_malloc(size_t sz) -{ - AO_t *result; - int log_sz; - - if (sz > CHUNK_SIZE) - return AO_malloc_large(sz); - log_sz = msb(sz + (sizeof(AO_t) - 1)); - result = AO_stack_pop(AO_free_list+log_sz); - while (0 == result) { - void * chunk = get_chunk(); - if (0 == chunk) return 0; - add_chunk_as(chunk, log_sz); - result = AO_stack_pop(AO_free_list+log_sz); - } - *result = log_sz; -# ifdef AO_TRACE_MALLOC - fprintf(stderr, "%x: AO_malloc(%lu) = %p\n", - (int)pthread_self(), (unsigned long)sz, result+1); -# endif - return result + 1; -} - -void -AO_free(void *p) -{ - char *base = (char *)p - sizeof(AO_t); - int log_sz; - - if (0 == p) return; - log_sz = (int)(*(AO_t *)base); -# ifdef AO_TRACE_MALLOC - fprintf(stderr, "%x: AO_free(%p sz:%lu)\n", (int)pthread_self(), p, - (unsigned long)(log_sz > LOG_MAX_SIZE? log_sz : (1 << log_sz))); -# endif - if (log_sz > LOG_MAX_SIZE) - AO_free_large(p); - else - AO_stack_push(AO_free_list+log_sz, (AO_t *)base); -} diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops_malloc.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops_malloc.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops_malloc.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops_malloc.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,44 +0,0 @@ -/* - * Copyright (c) 2005 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* Almost lock-free malloc implementation based on stack implementation. */ -/* See doc/README_malloc.txt file for detailed usage rules. */ - -#ifndef AO_MALLOC_H -#define AO_MALLOC_H - -#include "atomic_ops_stack.h" - -#include /* for size_t */ - -#ifdef AO_STACK_IS_LOCK_FREE -# define AO_MALLOC_IS_LOCK_FREE -#endif - -void AO_free(void *); - -void * AO_malloc(size_t); - -/* Allow use of mmap to grow the heap. No-op on some platforms. */ -void AO_malloc_enable_mmap(void); - -#endif /* !AO_MALLOC_H */ diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops_stack.c ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops_stack.c --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops_stack.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops_stack.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,281 +0,0 @@ -/* - * Copyright (c) 2005 Hewlett-Packard Development Company, L.P. - * - * This file may be redistributed and/or modified 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. - * - * It 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 in the - * file COPYING for more details. - */ - -#if defined(HAVE_CONFIG_H) -# include "config.h" -#endif - -#include -#include -#include - -#define AO_REQUIRE_CAS -#include "atomic_ops_stack.h" - -#ifdef AO_USE_ALMOST_LOCK_FREE - - void AO_pause(int); /* defined in atomic_ops.c */ - -/* LIFO linked lists based on compare-and-swap. We need to avoid */ -/* the case of a node deletion and reinsertion while I'm deleting */ -/* it, since that may cause my CAS to succeed eventhough the next */ -/* pointer is now wrong. Our solution is not fully lock-free, but it */ -/* is good enough for signal handlers, provided we have a suitably low */ -/* bound on the number of recursive signal handler reentries. */ -/* A list consists of a first pointer and a blacklist */ -/* of pointer values that are currently being removed. No list element */ -/* on the blacklist may be inserted. If we would otherwise do so, we */ -/* are allowed to insert a variant that differs only in the least */ -/* significant, ignored, bits. If the list is full, we wait. */ - -/* Crucial observation: A particular padded pointer x (i.e. pointer */ -/* plus arbitrary low order bits) can never be newly inserted into */ -/* a list while it's in the corresponding auxiliary data structure. */ - -/* The second argument is a pointer to the link field of the element */ -/* to be inserted. */ -/* Both list headers and link fields contain "perturbed" pointers, i.e. */ -/* pointers with extra bits "or"ed into the low order bits. */ -void -AO_stack_push_explicit_aux_release(volatile AO_t *list, AO_t *x, - AO_stack_aux *a) -{ - AO_t x_bits = (AO_t)x; - AO_t next; - - /* No deletions of x can start here, since x is not currently in the */ - /* list. */ - retry: -# if AO_BL_SIZE == 2 - { - /* Start all loads as close to concurrently as possible. */ - AO_t entry1 = AO_load(a -> AO_stack_bl); - AO_t entry2 = AO_load(a -> AO_stack_bl + 1); - if (entry1 == x_bits || entry2 == x_bits) - { - /* Entry is currently being removed. Change it a little. */ - ++x_bits; - if ((x_bits & AO_BIT_MASK) == 0) - /* Version count overflowed; */ - /* EXTREMELY unlikely, but possible. */ - x_bits = (AO_t)x; - goto retry; - } - } -# else - { - int i; - for (i = 0; i < AO_BL_SIZE; ++i) - { - if (AO_load(a -> AO_stack_bl + i) == x_bits) - { - /* Entry is currently being removed. Change it a little. */ - ++x_bits; - if ((x_bits & AO_BIT_MASK) == 0) - /* Version count overflowed; */ - /* EXTREMELY unlikely, but possible. */ - x_bits = (AO_t)x; - goto retry; - } - } - } -# endif - /* x_bits is not currently being deleted */ - do - { - next = AO_load(list); - *x = next; - } - while (AO_EXPECT_FALSE(!AO_compare_and_swap_release(list, next, x_bits))); -} - -/* - * I concluded experimentally that checking a value first before - * performing a compare-and-swap is usually beneficial on X86, but - * slows things down appreciably with contention on Itanium. - * Since the Itanium behavior makes more sense to me (more cache line - * movement unless we're mostly reading, but back-off should guard - * against that), we take Itanium as the default. Measurements on - * other multiprocessor architectures would be useful. (On a uniprocessor, - * the initial check is almost certainly a very small loss.) - HB - */ -#ifdef __i386__ -# define PRECHECK(a) (a) == 0 && -#else -# define PRECHECK(a) -#endif - -AO_t * -AO_stack_pop_explicit_aux_acquire(volatile AO_t *list, AO_stack_aux * a) -{ - unsigned i; - int j = 0; - AO_t first; - AO_t * first_ptr; - AO_t next; - - retry: - first = AO_load(list); - if (0 == first) return 0; - /* Insert first into aux black list. */ - /* This may spin if more than AO_BL_SIZE removals using auxiliary */ - /* structure a are currently in progress. */ - for (i = 0; ; ) - { - if (PRECHECK(a -> AO_stack_bl[i]) - AO_compare_and_swap_acquire(a->AO_stack_bl+i, 0, first)) - break; - ++i; - if ( i >= AO_BL_SIZE ) - { - i = 0; - AO_pause(++j); - } - } - assert(i < AO_BL_SIZE); - assert(a -> AO_stack_bl[i] == first); - /* First is on the auxiliary black list. It may be removed by */ - /* another thread before we get to it, but a new insertion of x */ - /* cannot be started here. */ - /* Only we can remove it from the black list. */ - /* We need to make sure that first is still the first entry on the */ - /* list. Otherwise it's possible that a reinsertion of it was */ - /* already started before we added the black list entry. */ -# if defined(__alpha__) && (__GNUC__ == 4) - if (first != AO_load(list)) - /* Workaround __builtin_expect bug found in */ - /* gcc-4.6.3/alpha causing test_stack failure. */ -# else - if (AO_EXPECT_FALSE(first != AO_load(list))) -# endif - { - AO_store_release(a->AO_stack_bl+i, 0); - goto retry; - } - first_ptr = AO_REAL_NEXT_PTR(first); - next = AO_load(first_ptr); -# if defined(__alpha__) && (__GNUC__ == 4) - if (!AO_compare_and_swap_release(list, first, next)) -# else - if (AO_EXPECT_FALSE(!AO_compare_and_swap_release(list, first, next))) -# endif - { - AO_store_release(a->AO_stack_bl+i, 0); - goto retry; - } - assert(*list != first); - /* Since we never insert an entry on the black list, this cannot have */ - /* succeeded unless first remained on the list while we were running. */ - /* Thus its next link cannot have changed out from under us, and we */ - /* removed exactly one entry and preserved the rest of the list. */ - /* Note that it is quite possible that an additional entry was */ - /* inserted and removed while we were running; this is OK since the */ - /* part of the list following first must have remained unchanged, and */ - /* first must again have been at the head of the list when the */ - /* compare_and_swap succeeded. */ - AO_store_release(a->AO_stack_bl+i, 0); - return first_ptr; -} - -#else /* ! USE_ALMOST_LOCK_FREE */ - -/* Better names for fields in AO_stack_t */ -#define ptr AO_val2 -#define version AO_val1 - -#if defined(AO_HAVE_compare_double_and_swap_double) - -void AO_stack_push_release(AO_stack_t *list, AO_t *element) -{ - AO_t next; - - do { - next = AO_load(&(list -> ptr)); - *element = next; - } while (AO_EXPECT_FALSE(!AO_compare_and_swap_release(&(list -> ptr), - next, (AO_t)element))); - /* This uses a narrow CAS here, an old optimization suggested */ - /* by Treiber. Pop is still safe, since we run into the ABA */ - /* problem only if there were both intervening "pop"s and "push"es. */ - /* In that case we still see a change in the version number. */ -} - -AO_t *AO_stack_pop_acquire(AO_stack_t *list) -{ -# ifdef __clang__ - AO_t *volatile cptr; - /* Use volatile to workaround a bug in */ - /* clang-1.1/x86 causing test_stack failure. */ -# else - AO_t *cptr; -# endif - AO_t next; - AO_t cversion; - - do { - /* Version must be loaded first. */ - cversion = AO_load_acquire(&(list -> version)); - cptr = (AO_t *)AO_load(&(list -> ptr)); - if (cptr == 0) return 0; - next = *cptr; - } while (AO_EXPECT_FALSE(!AO_compare_double_and_swap_double_release(list, - cversion, (AO_t)cptr, - cversion+1, (AO_t)next))); - return cptr; -} - - -#elif defined(AO_HAVE_compare_and_swap_double) - -/* Needed for future IA64 processors. No current clients? */ - -#error Untested! Probably doesnt work. - -/* We have a wide CAS, but only does an AO_t-wide comparison. */ -/* We can't use the Treiber optimization, since we only check */ -/* for an unchanged version number, not an unchanged pointer. */ -void AO_stack_push_release(AO_stack_t *list, AO_t *element) -{ - AO_t version; - AO_t next_ptr; - - do { - /* Again version must be loaded first, for different reason. */ - version = AO_load_acquire(&(list -> version)); - next_ptr = AO_load(&(list -> ptr)); - *element = next_ptr; - } while (!AO_compare_and_swap_double_release( - list, version, - version+1, (AO_t) element)); -} - -AO_t *AO_stack_pop_acquire(AO_stack_t *list) -{ - AO_t *cptr; - AO_t next; - AO_t cversion; - - do { - cversion = AO_load_acquire(&(list -> version)); - cptr = (AO_t *)AO_load(&(list -> ptr)); - if (cptr == 0) return 0; - next = *cptr; - } while (!AO_compare_double_and_swap_double_release - (list, cversion, (AO_t) cptr, cversion+1, next)); - return cptr; -} - - -#endif /* AO_HAVE_compare_and_swap_double */ - -#endif /* ! USE_ALMOST_LOCK_FREE */ diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops_stack.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops_stack.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops_stack.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops_stack.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,188 +0,0 @@ -/* - * The implementation of the routines described here is covered by the GPL. - * This header file is covered by the following license: - */ - -/* - * Copyright (c) 2005 Hewlett-Packard Development Company, L.P. - * - * 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 - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - * SOFTWARE. - */ - -/* Almost lock-free LIFO linked lists (linked stacks). */ -#ifndef AO_STACK_H -#define AO_STACK_H - -#include "atomic_ops.h" - -#if !defined(AO_HAVE_compare_double_and_swap_double) \ - && !defined(AO_HAVE_compare_double_and_swap) \ - && defined(AO_HAVE_compare_and_swap) -# define AO_USE_ALMOST_LOCK_FREE -#else - /* If we have no compare-and-swap operation defined, we assume */ - /* that we will actually be using CAS emulation. If we do that, */ - /* it's cheaper to use the version-based implementation. */ -# define AO_STACK_IS_LOCK_FREE -#endif - -/* - * These are not guaranteed to be completely lock-free. - * List insertion may spin under extremely unlikely conditions. - * It cannot deadlock due to recursive reentry unless AO_list_remove - * is called while at least AO_BL_SIZE activations of - * AO_list_remove are currently active in the same thread, i.e. - * we must have at least AO_BL_SIZE recursive signal handler - * invocations. - * - * All operations take an AO_list_aux argument. It is safe to - * share a single AO_list_aux structure among all lists, but that - * may increase contention. Any given list must always be accessed - * with the same AO_list_aux structure. - * - * We make some machine-dependent assumptions: - * - We have a compare-and-swap operation. - * - At least _AO_N_BITS low order bits in pointers are - * zero and normally unused. - * - size_t and pointers have the same size. - * - * We do use a fully lock-free implementation if double-width - * compare-and-swap operations are available. - */ - -#ifdef AO_USE_ALMOST_LOCK_FREE -/* The number of low order pointer bits we can use for a small */ -/* version number. */ -# if defined(__LP64__) || defined(_LP64) || defined(_WIN64) - /* WIN64 isn't really supported yet. */ -# define AO_N_BITS 3 -# else -# define AO_N_BITS 2 -# endif - -# define AO_BIT_MASK ((1 << AO_N_BITS) - 1) -/* - * AO_stack_aux should be treated as opaque. - * It is fully defined here, so it can be allocated, and to facilitate - * debugging. - */ -#ifndef AO_BL_SIZE -# define AO_BL_SIZE 2 -#endif - -#if AO_BL_SIZE > (1 << AO_N_BITS) -# error AO_BL_SIZE too big -#endif - -typedef struct AO__stack_aux { - volatile AO_t AO_stack_bl[AO_BL_SIZE]; -} AO_stack_aux; - -/* The stack implementation knows only about the location of */ -/* link fields in nodes, and nothing about the rest of the */ -/* stack elements. Link fields hold an AO_t, which is not */ -/* necessarily a real pointer. This converts the AO_t to a */ -/* real (AO_t *) which is either o, or points at the link */ -/* field in the next node. */ -#define AO_REAL_NEXT_PTR(x) (AO_t *)((x) & ~AO_BIT_MASK) - -/* The following two routines should not normally be used directly. */ -/* We make them visible here for the rare cases in which it makes sense */ -/* to share the an AO_stack_aux between stacks. */ -void -AO_stack_push_explicit_aux_release(volatile AO_t *list, AO_t *x, - AO_stack_aux *); - -AO_t * -AO_stack_pop_explicit_aux_acquire(volatile AO_t *list, AO_stack_aux *); - -/* And now AO_stack_t for the real interface: */ - -typedef struct AO__stack { - volatile AO_t AO_ptr; - AO_stack_aux AO_aux; -} AO_stack_t; - -#define AO_STACK_INITIALIZER {0,{{0}}} - -AO_INLINE void AO_stack_init(AO_stack_t *list) -{ -# if AO_BL_SIZE == 2 - list -> AO_aux.AO_stack_bl[0] = 0; - list -> AO_aux.AO_stack_bl[1] = 0; -# else - int i; - for (i = 0; i < AO_BL_SIZE; ++i) - list -> AO_aux.AO_stack_bl[i] = 0; -# endif - list -> AO_ptr = 0; -} - -/* Convert an AO_stack_t to a pointer to the link field in */ -/* the first element. */ -#define AO_REAL_HEAD_PTR(x) AO_REAL_NEXT_PTR((x).AO_ptr) - -#define AO_stack_push_release(l, e) \ - AO_stack_push_explicit_aux_release(&((l)->AO_ptr), e, &((l)->AO_aux)) -#define AO_HAVE_stack_push_release - -#define AO_stack_pop_acquire(l) \ - AO_stack_pop_explicit_aux_acquire(&((l)->AO_ptr), &((l)->AO_aux)) -#define AO_HAVE_stack_pop_acquire - -# else /* Use fully non-blocking data structure, wide CAS */ - -#ifndef AO_HAVE_double_t - /* Can happen if we're using CAS emulation, since we don't want to */ - /* force that here, in case other atomic_ops clients don't want it. */ -# include "atomic_ops/sysdeps/standard_ao_double_t.h" -#endif - -typedef volatile AO_double_t AO_stack_t; -/* AO_val1 is version, AO_val2 is pointer. */ - -#define AO_STACK_INITIALIZER AO_DOUBLE_T_INITIALIZER - -AO_INLINE void AO_stack_init(AO_stack_t *list) -{ - list -> AO_val1 = 0; - list -> AO_val2 = 0; -} - -#define AO_REAL_HEAD_PTR(x) (AO_t *)((x).AO_val2) -#define AO_REAL_NEXT_PTR(x) (AO_t *)(x) - -void AO_stack_push_release(AO_stack_t *list, AO_t *new_element); -#define AO_HAVE_stack_push_release -AO_t * AO_stack_pop_acquire(AO_stack_t *list); -#define AO_HAVE_stack_pop_acquire - -#endif /* Wide CAS case */ - -#if defined(AO_HAVE_stack_push_release) && !defined(AO_HAVE_stack_push) -# define AO_stack_push(l, e) AO_stack_push_release(l, e) -# define AO_HAVE_stack_push -#endif - -#if defined(AO_HAVE_stack_pop_acquire) && !defined(AO_HAVE_stack_pop) -# define AO_stack_pop(l) AO_stack_pop_acquire(l) -# define AO_HAVE_stack_pop -#endif - -#endif /* !AO_STACK_H */ diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops_sysdeps.S ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops_sysdeps.S --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/atomic_ops_sysdeps.S 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/atomic_ops_sysdeps.S 1970-01-01 00:00:00.000000000 +0000 @@ -1,9 +0,0 @@ -/* - * Include the appropriate system-dependent assembly file, if any. - * This is used only if the platform supports neither inline assembly - * code, nor appropriate compiler intrinsics. - */ - -#if !defined(__GNUC__) && (defined(sparc) || defined(__sparc)) -# include "atomic_ops/sysdeps/sunc/sparc.S" -#endif diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/config.h.in ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/config.h.in --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/config.h.in 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/config.h.in 1970-01-01 00:00:00.000000000 +0000 @@ -1,148 +0,0 @@ -/* src/config.h.in. Generated from configure.ac by autoheader. */ - -/* Inline assembly avalable (only VC/x86_64) */ -#undef AO_ASM_X64_AVAILABLE - -/* Assume Windows Server 2003, Vista or later target (only VC/x86) */ -#undef AO_ASSUME_VISTA - -/* Assume hardware compare-and-swap functionality available on target (only - VC/x86) */ -#undef AO_ASSUME_WINDOWS98 - -/* Assume target is not old AMD Opteron chip (only x86_64) */ -#undef AO_CMPXCHG16B_AVAILABLE - -/* Force test_and_set to use SWP instruction instead of LDREX/STREX (only arm - v6+) */ -#undef AO_FORCE_USE_SWP - -/* Force compare_and_swap definition via fetch_compare_and_swap */ -#undef AO_GENERALIZE_ASM_BOOL_CAS - -/* No pthreads library available */ -#undef AO_NO_PTHREADS - -/* Assume target is not sparc v9+ (only sparc) */ -#undef AO_NO_SPARC_V9 - -/* Assume ancient MS VS Win32 headers (only VC/arm v6+, VC/x86) */ -#undef AO_OLD_STYLE_INTERLOCKED_COMPARE_EXCHANGE - -/* Prefer generalized definitions to direct assembly-based ones */ -#undef AO_PREFER_GENERALIZED - -/* Trace AO_malloc/free calls (for debug only) */ -#undef AO_TRACE_MALLOC - -/* Assume single-core target (only arm v6+) */ -#undef AO_UNIPROCESSOR - -/* Assume Win32 _Interlocked primitives available as intrinsics (only VC/arm) - */ -#undef AO_USE_INTERLOCKED_INTRINSICS - -/* Use nanosleep() instead of select() (only if atomic operations are - emulated) */ -#undef AO_USE_NANOSLEEP - -/* Do not block signals in compare_and_swap (only if atomic operations are - emulated) */ -#undef AO_USE_NO_SIGNALS - -/* Use Pentium 4 'mfence' instruction (only x86) */ -#undef AO_USE_PENTIUM4_INSTRS - -/* Emulate atomic operations via slow and async-signal-unsafe pthread locking - */ -#undef AO_USE_PTHREAD_DEFS - -/* Prefer GCC built-in CAS intrinsics in favor of inline assembly (only - gcc/x86, gcc/x86_64) */ -#undef AO_USE_SYNC_CAS_BUILTIN - -/* Use Win32 Sleep() instead of select() (only if atomic operations are - emulated) */ -#undef AO_USE_WIN32_PTHREADS - -/* Emulate double-width CAS via pthread locking in case of no hardware support - (only gcc/x86_64, the emulation is unsafe) */ -#undef AO_WEAK_DOUBLE_CAS_EMULATION - -/* Define to 1 if you have the header file. */ -#undef HAVE_DLFCN_H - -/* Define to 1 if you have the `getpagesize' function. */ -#undef HAVE_GETPAGESIZE - -/* Define to 1 if you have the header file. */ -#undef HAVE_INTTYPES_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 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 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 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_TYPES_H - -/* Define to 1 if you have the header file. */ -#undef HAVE_UNISTD_H - -/* Define to the sub-directory where libtool stores uninstalled libraries. */ -#undef LT_OBJDIR - -/* Define to disable assertion checking. */ -#undef NDEBUG - -/* Name of package */ -#undef PACKAGE - -/* 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 to 1 if you have the ANSI C header files. */ -#undef STDC_HEADERS - -/* Version number of package */ -#undef VERSION - -/* Indicates the use of pthreads (NetBSD). */ -#undef _PTHREADS - -/* Required define if using POSIX threads. */ -#undef _REENTRANT diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/Makefile.am ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/Makefile.am --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/Makefile.am 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/Makefile.am 1970-01-01 00:00:00.000000000 +0000 @@ -1,249 +0,0 @@ -AM_CFLAGS=@PICFLAG@ -AM_CPPFLAGS = -I$(top_builddir)/src -I$(top_srcdir)/src - -include_HEADERS = atomic_ops.h atomic_ops_stack.h atomic_ops_malloc.h -lib_LTLIBRARIES = libatomic_ops.la libatomic_ops_gpl.la -if NEED_ASM -libatomic_ops_la_SOURCES = atomic_ops.c atomic_ops_sysdeps.S -else -libatomic_ops_la_SOURCES = atomic_ops.c -endif -libatomic_ops_la_LDFLAGS = -version-info 1:3:0 -no-undefined - -libatomic_ops_gpl_la_SOURCES = atomic_ops_stack.c atomic_ops_malloc.c -libatomic_ops_gpl_la_LDFLAGS = -version-info 1:3:0 -no-undefined -libatomic_ops_gpl_la_LIBADD = libatomic_ops.la - -EXTRA_DIST = Makefile.msft atomic_ops/sysdeps/README \ - atomic_ops/generalize-arithm.template \ - atomic_ops/generalize-small.template \ - atomic_ops/sysdeps/ao_t_is_int.template \ - atomic_ops/sysdeps/gcc/generic-arithm.template \ - atomic_ops/sysdeps/gcc/generic-small.template \ - atomic_ops/sysdeps/loadstore/acquire_release_volatile.template \ - atomic_ops/sysdeps/loadstore/atomic_load.template \ - atomic_ops/sysdeps/loadstore/atomic_store.template \ - atomic_ops/sysdeps/loadstore/ordered_loads_only.template \ - atomic_ops/sysdeps/loadstore/ordered_stores_only.template \ - atomic_ops/sysdeps/sunc/sparc.S - -BUILT_SOURCES = atomic_ops/generalize-arithm.h \ - atomic_ops/generalize-small.h \ - atomic_ops/sysdeps/ao_t_is_int.h \ - atomic_ops/sysdeps/gcc/generic-arithm.h \ - atomic_ops/sysdeps/gcc/generic-small.h \ - atomic_ops/sysdeps/loadstore/acquire_release_volatile.h \ - atomic_ops/sysdeps/loadstore/atomic_load.h \ - atomic_ops/sysdeps/loadstore/atomic_store.h \ - atomic_ops/sysdeps/loadstore/char_acquire_release_volatile.h \ - atomic_ops/sysdeps/loadstore/char_atomic_load.h \ - atomic_ops/sysdeps/loadstore/char_atomic_store.h \ - atomic_ops/sysdeps/loadstore/int_acquire_release_volatile.h \ - atomic_ops/sysdeps/loadstore/int_atomic_load.h \ - atomic_ops/sysdeps/loadstore/int_atomic_store.h \ - atomic_ops/sysdeps/loadstore/ordered_loads_only.h \ - atomic_ops/sysdeps/loadstore/ordered_stores_only.h \ - atomic_ops/sysdeps/loadstore/short_acquire_release_volatile.h \ - atomic_ops/sysdeps/loadstore/short_atomic_load.h \ - atomic_ops/sysdeps/loadstore/short_atomic_store.h - -#Private Headers -privatedir=${includedir}/ -nobase_private_HEADERS = atomic_ops/ao_version.h \ - atomic_ops/generalize.h \ - $(BUILT_SOURCES) \ - \ - atomic_ops/sysdeps/all_acquire_release_volatile.h \ - atomic_ops/sysdeps/all_aligned_atomic_load_store.h \ - atomic_ops/sysdeps/all_atomic_load_store.h \ - atomic_ops/sysdeps/all_atomic_only_load.h \ - atomic_ops/sysdeps/emul_cas.h \ - atomic_ops/sysdeps/generic_pthread.h \ - atomic_ops/sysdeps/ordered.h \ - atomic_ops/sysdeps/ordered_except_wr.h \ - atomic_ops/sysdeps/read_ordered.h \ - atomic_ops/sysdeps/standard_ao_double_t.h \ - atomic_ops/sysdeps/test_and_set_t_is_ao_t.h \ - atomic_ops/sysdeps/test_and_set_t_is_char.h \ - \ - atomic_ops/sysdeps/armcc/arm_v6.h \ - \ - atomic_ops/sysdeps/gcc/aarch64.h \ - atomic_ops/sysdeps/gcc/alpha.h \ - atomic_ops/sysdeps/gcc/arm.h \ - atomic_ops/sysdeps/gcc/avr32.h \ - atomic_ops/sysdeps/gcc/cris.h \ - atomic_ops/sysdeps/gcc/generic.h \ - atomic_ops/sysdeps/gcc/hexagon.h \ - atomic_ops/sysdeps/gcc/hppa.h \ - atomic_ops/sysdeps/gcc/ia64.h \ - atomic_ops/sysdeps/gcc/m68k.h \ - atomic_ops/sysdeps/gcc/mips.h \ - atomic_ops/sysdeps/gcc/powerpc.h \ - atomic_ops/sysdeps/gcc/s390.h \ - atomic_ops/sysdeps/gcc/sh.h \ - atomic_ops/sysdeps/gcc/sparc.h \ - atomic_ops/sysdeps/gcc/x86.h \ - \ - atomic_ops/sysdeps/hpc/hppa.h \ - atomic_ops/sysdeps/hpc/ia64.h \ - \ - atomic_ops/sysdeps/ibmc/powerpc.h \ - \ - atomic_ops/sysdeps/icc/ia64.h \ - \ - atomic_ops/sysdeps/loadstore/double_atomic_load_store.h \ - \ - atomic_ops/sysdeps/msftc/arm.h \ - atomic_ops/sysdeps/msftc/common32_defs.h \ - atomic_ops/sysdeps/msftc/x86.h \ - atomic_ops/sysdeps/msftc/x86_64.h \ - \ - atomic_ops/sysdeps/sunc/sparc.h \ - atomic_ops/sysdeps/sunc/x86.h - -atomic_ops/generalize-small.h: atomic_ops/generalize-small.template - mkdir -p `dirname $@` - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g $? > $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g $? >> $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g $? >> $@ - sed -e s:XSIZE:double:g -e s:XCTYPE:AO_double_t:g $? >> $@ - -atomic_ops/generalize-arithm.h: atomic_ops/generalize-arithm.template - mkdir -p `dirname $@` - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g $? > $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g $? >> $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g $? >> $@ - -atomic_ops/sysdeps/ao_t_is_int.h: atomic_ops/sysdeps/ao_t_is_int.template - mkdir -p `dirname $@` - sed -e s:_XBAR::g $? > $@ - sed -e s:XBAR:full:g $? >> $@ - sed -e s:XBAR:acquire:g $? >> $@ - sed -e s:XBAR:release:g $? >> $@ - sed -e s:XBAR:write:g $? >> $@ - sed -e s:XBAR:read:g $? >> $@ - -atomic_ops/sysdeps/gcc/generic-arithm.h: \ - atomic_ops/sysdeps/gcc/generic-arithm.template - mkdir -p `dirname $@` - sed -e s:_XBAR::g -e s:XGCCBAR:RELAXED:g \ - -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g $? > $@ - sed -e s:_XBAR::g -e s:XGCCBAR:RELAXED:g \ - -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g $? >> $@ - sed -e s:_XBAR::g -e s:XGCCBAR:RELAXED:g \ - -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g $? >> $@ - sed -e s:_XBAR::g -e s:XGCCBAR:RELAXED:g \ - -e s:XSIZE_::g -e s:XCTYPE:AO_t:g $? >> $@ - sed -e s:XBAR:acquire:g -e s:XGCCBAR:ACQUIRE:g \ - -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g $? >> $@ - sed -e s:XBAR:acquire:g -e s:XGCCBAR:ACQUIRE:g \ - -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g $? >> $@ - sed -e s:XBAR:acquire:g -e s:XGCCBAR:ACQUIRE:g \ - -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g $? >> $@ - sed -e s:XBAR:acquire:g -e s:XGCCBAR:ACQUIRE:g \ - -e s:XSIZE_::g -e s:XCTYPE:AO_t:g $? >> $@ - sed -e s:XBAR:release:g -e s:XGCCBAR:RELEASE:g \ - -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g $? >> $@ - sed -e s:XBAR:release:g -e s:XGCCBAR:RELEASE:g \ - -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g $? >> $@ - sed -e s:XBAR:release:g -e s:XGCCBAR:RELEASE:g \ - -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g $? >> $@ - sed -e s:XBAR:release:g -e s:XGCCBAR:RELEASE:g \ - -e s:XSIZE_::g -e s:XCTYPE:AO_t:g $? >> $@ - sed -e s:XBAR:full:g -e s:XGCCBAR:SEQ_CST:g \ - -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g $? >> $@ - sed -e s:XBAR:full:g -e s:XGCCBAR:SEQ_CST:g \ - -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g $? >> $@ - sed -e s:XBAR:full:g -e s:XGCCBAR:SEQ_CST:g \ - -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g $? >> $@ - sed -e s:XBAR:full:g -e s:XGCCBAR:SEQ_CST:g \ - -e s:XSIZE_::g -e s:XCTYPE:AO_t:g $? >> $@ - -atomic_ops/sysdeps/gcc/generic-small.h: \ - atomic_ops/sysdeps/gcc/generic-small.template - mkdir -p `dirname $@` - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g $? > $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g $? >> $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g $? >> $@ - -atomic_ops/sysdeps/loadstore/ordered_loads_only.h: \ - atomic_ops/sysdeps/loadstore/ordered_loads_only.template - mkdir -p `dirname $@` - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g $? > $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g $? >> $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g $? >> $@ - sed -e s:XSIZE:double:g -e s:XCTYPE:AO_double_t:g $? >> $@ - -atomic_ops/sysdeps/loadstore/ordered_stores_only.h: \ - atomic_ops/sysdeps/loadstore/ordered_stores_only.template - mkdir -p `dirname $@` - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g $? > $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g $? >> $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g $? >> $@ - sed -e s:XSIZE:double:g -e s:XCTYPE:AO_double_t:g $? >> $@ - -atomic_ops/sysdeps/loadstore/acquire_release_volatile.h: \ - atomic_ops/sysdeps/loadstore/acquire_release_volatile.template - mkdir -p `dirname $@` - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g $? > $@ - -atomic_ops/sysdeps/loadstore/char_acquire_release_volatile.h: \ - atomic_ops/sysdeps/loadstore/acquire_release_volatile.template - mkdir -p `dirname $@` - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g $? > $@ - -atomic_ops/sysdeps/loadstore/int_acquire_release_volatile.h: \ - atomic_ops/sysdeps/loadstore/acquire_release_volatile.template - mkdir -p `dirname $@` - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g $? > $@ - -atomic_ops/sysdeps/loadstore/short_acquire_release_volatile.h: \ - atomic_ops/sysdeps/loadstore/acquire_release_volatile.template - mkdir -p `dirname $@` - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g $? > $@ - -atomic_ops/sysdeps/loadstore/atomic_load.h: \ - atomic_ops/sysdeps/loadstore/atomic_load.template - mkdir -p `dirname $@` - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g $? > $@ - -atomic_ops/sysdeps/loadstore/char_atomic_load.h: \ - atomic_ops/sysdeps/loadstore/atomic_load.template - mkdir -p `dirname $@` - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g $? > $@ - -atomic_ops/sysdeps/loadstore/int_atomic_load.h: \ - atomic_ops/sysdeps/loadstore/atomic_load.template - mkdir -p `dirname $@` - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g $? > $@ - -atomic_ops/sysdeps/loadstore/short_atomic_load.h: \ - atomic_ops/sysdeps/loadstore/atomic_load.template - mkdir -p `dirname $@` - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g $? > $@ - -atomic_ops/sysdeps/loadstore/atomic_store.h: \ - atomic_ops/sysdeps/loadstore/atomic_store.template - mkdir -p `dirname $@` - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g $? > $@ - -atomic_ops/sysdeps/loadstore/char_atomic_store.h: \ - atomic_ops/sysdeps/loadstore/atomic_store.template - mkdir -p `dirname $@` - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g $? > $@ - -atomic_ops/sysdeps/loadstore/int_atomic_store.h: \ - atomic_ops/sysdeps/loadstore/atomic_store.template - mkdir -p `dirname $@` - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g $? > $@ - -atomic_ops/sysdeps/loadstore/short_atomic_store.h: \ - atomic_ops/sysdeps/loadstore/atomic_store.template - mkdir -p `dirname $@` - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g $? > $@ diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/Makefile.in ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/Makefile.in --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/Makefile.in 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/Makefile.in 1970-01-01 00:00:00.000000000 +0000 @@ -1,1018 +0,0 @@ -# Makefile.in generated by automake 1.15 from Makefile.am. -# @configure_input@ - -# Copyright (C) 1994-2014 Free Software Foundation, Inc. - -# This Makefile.in 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. - -@SET_MAKE@ - - -VPATH = @srcdir@ -am__is_gnu_make = { \ - if test -z '$(MAKELEVEL)'; then \ - false; \ - elif test -n '$(MAKE_HOST)'; then \ - true; \ - elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ - true; \ - else \ - false; \ - fi; \ -} -am__make_running_with_option = \ - case $${target_option-} in \ - ?) ;; \ - *) echo "am__make_running_with_option: internal error: invalid" \ - "target option '$${target_option-}' specified" >&2; \ - exit 1;; \ - esac; \ - has_opt=no; \ - sane_makeflags=$$MAKEFLAGS; \ - if $(am__is_gnu_make); then \ - sane_makeflags=$$MFLAGS; \ - else \ - case $$MAKEFLAGS in \ - *\\[\ \ ]*) \ - bs=\\; \ - sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ - | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ - esac; \ - fi; \ - skip_next=no; \ - strip_trailopt () \ - { \ - flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ - }; \ - for flg in $$sane_makeflags; do \ - test $$skip_next = yes && { skip_next=no; continue; }; \ - case $$flg in \ - *=*|--*) continue;; \ - -*I) strip_trailopt 'I'; skip_next=yes;; \ - -*I?*) strip_trailopt 'I';; \ - -*O) strip_trailopt 'O'; skip_next=yes;; \ - -*O?*) strip_trailopt 'O';; \ - -*l) strip_trailopt 'l'; skip_next=yes;; \ - -*l?*) strip_trailopt 'l';; \ - -[dEDm]) skip_next=yes;; \ - -[JT]) skip_next=yes;; \ - esac; \ - case $$flg in \ - *$$target_option*) has_opt=yes; break;; \ - esac; \ - done; \ - test $$has_opt = yes -am__make_dryrun = (target_option=n; $(am__make_running_with_option)) -am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) -pkgdatadir = $(datadir)/@PACKAGE@ -pkgincludedir = $(includedir)/@PACKAGE@ -pkglibdir = $(libdir)/@PACKAGE@ -pkglibexecdir = $(libexecdir)/@PACKAGE@ -am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd -install_sh_DATA = $(install_sh) -c -m 644 -install_sh_PROGRAM = $(install_sh) -c -install_sh_SCRIPT = $(install_sh) -c -INSTALL_HEADER = $(INSTALL_DATA) -transform = $(program_transform_name) -NORMAL_INSTALL = : -PRE_INSTALL = : -POST_INSTALL = : -NORMAL_UNINSTALL = : -PRE_UNINSTALL = : -POST_UNINSTALL = : -build_triplet = @build@ -host_triplet = @host@ -target_triplet = @target@ -subdir = src -ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 -am__aclocal_m4_deps = $(top_srcdir)/m4/libtool.m4 \ - $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \ - $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \ - $(top_srcdir)/configure.ac -am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ - $(ACLOCAL_M4) -DIST_COMMON = $(srcdir)/Makefile.am $(include_HEADERS) \ - $(nobase_private_HEADERS) $(am__DIST_COMMON) -mkinstalldirs = $(install_sh) -d -CONFIG_HEADER = config.h -CONFIG_CLEAN_FILES = -CONFIG_CLEAN_VPATH_FILES = -am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; -am__vpath_adj = case $$p in \ - $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ - *) f=$$p;; \ - esac; -am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`; -am__install_max = 40 -am__nobase_strip_setup = \ - srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'` -am__nobase_strip = \ - for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||" -am__nobase_list = $(am__nobase_strip_setup); \ - for p in $$list; do echo "$$p $$p"; done | \ - sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \ - $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \ - if (++n[$$2] == $(am__install_max)) \ - { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \ - END { for (dir in files) print dir, files[dir] }' -am__base_list = \ - sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \ - sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g' -am__uninstall_files_from_dir = { \ - test -z "$$files" \ - || { test ! -d "$$dir" && test ! -f "$$dir" && test ! -r "$$dir"; } \ - || { echo " ( cd '$$dir' && rm -f" $$files ")"; \ - $(am__cd) "$$dir" && rm -f $$files; }; \ - } -am__installdirs = "$(DESTDIR)$(libdir)" "$(DESTDIR)$(includedir)" \ - "$(DESTDIR)$(privatedir)" -LTLIBRARIES = $(lib_LTLIBRARIES) -libatomic_ops_la_LIBADD = -am__libatomic_ops_la_SOURCES_DIST = atomic_ops.c atomic_ops_sysdeps.S -@NEED_ASM_FALSE@am_libatomic_ops_la_OBJECTS = atomic_ops.lo -@NEED_ASM_TRUE@am_libatomic_ops_la_OBJECTS = atomic_ops.lo \ -@NEED_ASM_TRUE@ atomic_ops_sysdeps.lo -libatomic_ops_la_OBJECTS = $(am_libatomic_ops_la_OBJECTS) -AM_V_lt = $(am__v_lt_@AM_V@) -am__v_lt_ = $(am__v_lt_@AM_DEFAULT_V@) -am__v_lt_0 = --silent -am__v_lt_1 = -libatomic_ops_la_LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC \ - $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=link $(CCLD) \ - $(AM_CFLAGS) $(CFLAGS) $(libatomic_ops_la_LDFLAGS) $(LDFLAGS) \ - -o $@ -libatomic_ops_gpl_la_DEPENDENCIES = libatomic_ops.la -am_libatomic_ops_gpl_la_OBJECTS = atomic_ops_stack.lo \ - atomic_ops_malloc.lo -libatomic_ops_gpl_la_OBJECTS = $(am_libatomic_ops_gpl_la_OBJECTS) -libatomic_ops_gpl_la_LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC \ - $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=link $(CCLD) \ - $(AM_CFLAGS) $(CFLAGS) $(libatomic_ops_gpl_la_LDFLAGS) \ - $(LDFLAGS) -o $@ -AM_V_P = $(am__v_P_@AM_V@) -am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) -am__v_P_0 = false -am__v_P_1 = : -AM_V_GEN = $(am__v_GEN_@AM_V@) -am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) -am__v_GEN_0 = @echo " GEN " $@; -am__v_GEN_1 = -AM_V_at = $(am__v_at_@AM_V@) -am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) -am__v_at_0 = @ -am__v_at_1 = -DEFAULT_INCLUDES = -depcomp = $(SHELL) $(top_srcdir)/../depcomp -am__depfiles_maybe = depfiles -am__mv = mv -f -CPPASCOMPILE = $(CCAS) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) \ - $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CCASFLAGS) $(CCASFLAGS) -LTCPPASCOMPILE = $(LIBTOOL) $(AM_V_lt) $(AM_LIBTOOLFLAGS) \ - $(LIBTOOLFLAGS) --mode=compile $(CCAS) $(DEFS) \ - $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \ - $(AM_CCASFLAGS) $(CCASFLAGS) -AM_V_CPPAS = $(am__v_CPPAS_@AM_V@) -am__v_CPPAS_ = $(am__v_CPPAS_@AM_DEFAULT_V@) -am__v_CPPAS_0 = @echo " CPPAS " $@; -am__v_CPPAS_1 = -COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \ - $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -LTCOMPILE = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ - $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) \ - $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \ - $(AM_CFLAGS) $(CFLAGS) -AM_V_CC = $(am__v_CC_@AM_V@) -am__v_CC_ = $(am__v_CC_@AM_DEFAULT_V@) -am__v_CC_0 = @echo " CC " $@; -am__v_CC_1 = -CCLD = $(CC) -LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ - $(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \ - $(AM_LDFLAGS) $(LDFLAGS) -o $@ -AM_V_CCLD = $(am__v_CCLD_@AM_V@) -am__v_CCLD_ = $(am__v_CCLD_@AM_DEFAULT_V@) -am__v_CCLD_0 = @echo " CCLD " $@; -am__v_CCLD_1 = -SOURCES = $(libatomic_ops_la_SOURCES) $(libatomic_ops_gpl_la_SOURCES) -DIST_SOURCES = $(am__libatomic_ops_la_SOURCES_DIST) \ - $(libatomic_ops_gpl_la_SOURCES) -am__can_run_installinfo = \ - case $$AM_UPDATE_INFO_DIR in \ - n|no|NO) false;; \ - *) (install-info --version) >/dev/null 2>&1;; \ - esac -HEADERS = $(include_HEADERS) $(nobase_private_HEADERS) -am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) \ - $(LISP)config.h.in -# Read a list of newline-separated strings from the standard input, -# and print each of them once, without duplicates. Input order is -# *not* preserved. -am__uniquify_input = $(AWK) '\ - BEGIN { nonempty = 0; } \ - { items[$$0] = 1; nonempty = 1; } \ - END { if (nonempty) { for (i in items) print i; }; } \ -' -# Make sure the list of sources is unique. This is necessary because, -# e.g., the same source file might be shared among _SOURCES variables -# for different programs/libraries. -am__define_uniq_tagged_files = \ - list='$(am__tagged_files)'; \ - unique=`for i in $$list; do \ - if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ - done | $(am__uniquify_input)` -ETAGS = etags -CTAGS = ctags -am__DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/config.h.in \ - $(top_srcdir)/../depcomp -DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) -ACLOCAL = @ACLOCAL@ -AMTAR = @AMTAR@ -AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ -AR = @AR@ -AUTOCONF = @AUTOCONF@ -AUTOHEADER = @AUTOHEADER@ -AUTOMAKE = @AUTOMAKE@ -AWK = @AWK@ -CC = @CC@ -CCAS = @CCAS@ -CCASDEPMODE = @CCASDEPMODE@ -CCASFLAGS = @CCASFLAGS@ -CCDEPMODE = @CCDEPMODE@ -CFLAGS = @CFLAGS@ -CPP = @CPP@ -CPPFLAGS = @CPPFLAGS@ -CYGPATH_W = @CYGPATH_W@ -DEFS = @DEFS@ -DEPDIR = @DEPDIR@ -DLLTOOL = @DLLTOOL@ -DSYMUTIL = @DSYMUTIL@ -DUMPBIN = @DUMPBIN@ -ECHO_C = @ECHO_C@ -ECHO_N = @ECHO_N@ -ECHO_T = @ECHO_T@ -EGREP = @EGREP@ -EXEEXT = @EXEEXT@ -FGREP = @FGREP@ -GREP = @GREP@ -INSTALL = @INSTALL@ -INSTALL_DATA = @INSTALL_DATA@ -INSTALL_PROGRAM = @INSTALL_PROGRAM@ -INSTALL_SCRIPT = @INSTALL_SCRIPT@ -INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ -LD = @LD@ -LDFLAGS = @LDFLAGS@ -LIBOBJS = @LIBOBJS@ -LIBS = @LIBS@ -LIBTOOL = @LIBTOOL@ -LIPO = @LIPO@ -LN_S = @LN_S@ -LTLIBOBJS = @LTLIBOBJS@ -LT_SYS_LIBRARY_PATH = @LT_SYS_LIBRARY_PATH@ -MAINT = @MAINT@ -MAKEINFO = @MAKEINFO@ -MANIFEST_TOOL = @MANIFEST_TOOL@ -MKDIR_P = @MKDIR_P@ -NM = @NM@ -NMEDIT = @NMEDIT@ -OBJDUMP = @OBJDUMP@ -OBJEXT = @OBJEXT@ -OTOOL = @OTOOL@ -OTOOL64 = @OTOOL64@ -PACKAGE = @PACKAGE@ -PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ -PACKAGE_NAME = @PACKAGE_NAME@ -PACKAGE_STRING = @PACKAGE_STRING@ -PACKAGE_TARNAME = @PACKAGE_TARNAME@ -PACKAGE_URL = @PACKAGE_URL@ -PACKAGE_VERSION = @PACKAGE_VERSION@ -PATH_SEPARATOR = @PATH_SEPARATOR@ -PICFLAG = @PICFLAG@ -RANLIB = @RANLIB@ -SED = @SED@ -SET_MAKE = @SET_MAKE@ -SHELL = @SHELL@ -STRIP = @STRIP@ -THREADDLLIBS = @THREADDLLIBS@ -VERSION = @VERSION@ -abs_builddir = @abs_builddir@ -abs_srcdir = @abs_srcdir@ -abs_top_builddir = @abs_top_builddir@ -abs_top_srcdir = @abs_top_srcdir@ -ac_ct_AR = @ac_ct_AR@ -ac_ct_CC = @ac_ct_CC@ -ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ -am__include = @am__include@ -am__leading_dot = @am__leading_dot@ -am__quote = @am__quote@ -am__tar = @am__tar@ -am__untar = @am__untar@ -bindir = @bindir@ -build = @build@ -build_alias = @build_alias@ -build_cpu = @build_cpu@ -build_os = @build_os@ -build_vendor = @build_vendor@ -builddir = @builddir@ -datadir = @datadir@ -datarootdir = @datarootdir@ -docdir = @docdir@ -dvidir = @dvidir@ -exec_prefix = @exec_prefix@ -host = @host@ -host_alias = @host_alias@ -host_cpu = @host_cpu@ -host_os = @host_os@ -host_vendor = @host_vendor@ -htmldir = @htmldir@ -includedir = @includedir@ -infodir = @infodir@ -install_sh = @install_sh@ -libdir = @libdir@ -libexecdir = @libexecdir@ -localedir = @localedir@ -localstatedir = @localstatedir@ -mandir = @mandir@ -mkdir_p = @mkdir_p@ -oldincludedir = @oldincludedir@ -pdfdir = @pdfdir@ -prefix = @prefix@ -program_transform_name = @program_transform_name@ -psdir = @psdir@ -sbindir = @sbindir@ -sharedstatedir = @sharedstatedir@ -srcdir = @srcdir@ -sysconfdir = @sysconfdir@ -target = @target@ -target_alias = @target_alias@ -target_cpu = @target_cpu@ -target_os = @target_os@ -target_vendor = @target_vendor@ -top_build_prefix = @top_build_prefix@ -top_builddir = @top_builddir@ -top_srcdir = @top_srcdir@ -AM_CFLAGS = @PICFLAG@ -AM_CPPFLAGS = -I$(top_builddir)/src -I$(top_srcdir)/src -include_HEADERS = atomic_ops.h atomic_ops_stack.h atomic_ops_malloc.h -lib_LTLIBRARIES = libatomic_ops.la libatomic_ops_gpl.la -@NEED_ASM_FALSE@libatomic_ops_la_SOURCES = atomic_ops.c -@NEED_ASM_TRUE@libatomic_ops_la_SOURCES = atomic_ops.c atomic_ops_sysdeps.S -libatomic_ops_la_LDFLAGS = -version-info 1:3:0 -no-undefined -libatomic_ops_gpl_la_SOURCES = atomic_ops_stack.c atomic_ops_malloc.c -libatomic_ops_gpl_la_LDFLAGS = -version-info 1:3:0 -no-undefined -libatomic_ops_gpl_la_LIBADD = libatomic_ops.la -EXTRA_DIST = Makefile.msft atomic_ops/sysdeps/README \ - atomic_ops/generalize-arithm.template \ - atomic_ops/generalize-small.template \ - atomic_ops/sysdeps/ao_t_is_int.template \ - atomic_ops/sysdeps/gcc/generic-arithm.template \ - atomic_ops/sysdeps/gcc/generic-small.template \ - atomic_ops/sysdeps/loadstore/acquire_release_volatile.template \ - atomic_ops/sysdeps/loadstore/atomic_load.template \ - atomic_ops/sysdeps/loadstore/atomic_store.template \ - atomic_ops/sysdeps/loadstore/ordered_loads_only.template \ - atomic_ops/sysdeps/loadstore/ordered_stores_only.template \ - atomic_ops/sysdeps/sunc/sparc.S - -BUILT_SOURCES = atomic_ops/generalize-arithm.h \ - atomic_ops/generalize-small.h \ - atomic_ops/sysdeps/ao_t_is_int.h \ - atomic_ops/sysdeps/gcc/generic-arithm.h \ - atomic_ops/sysdeps/gcc/generic-small.h \ - atomic_ops/sysdeps/loadstore/acquire_release_volatile.h \ - atomic_ops/sysdeps/loadstore/atomic_load.h \ - atomic_ops/sysdeps/loadstore/atomic_store.h \ - atomic_ops/sysdeps/loadstore/char_acquire_release_volatile.h \ - atomic_ops/sysdeps/loadstore/char_atomic_load.h \ - atomic_ops/sysdeps/loadstore/char_atomic_store.h \ - atomic_ops/sysdeps/loadstore/int_acquire_release_volatile.h \ - atomic_ops/sysdeps/loadstore/int_atomic_load.h \ - atomic_ops/sysdeps/loadstore/int_atomic_store.h \ - atomic_ops/sysdeps/loadstore/ordered_loads_only.h \ - atomic_ops/sysdeps/loadstore/ordered_stores_only.h \ - atomic_ops/sysdeps/loadstore/short_acquire_release_volatile.h \ - atomic_ops/sysdeps/loadstore/short_atomic_load.h \ - atomic_ops/sysdeps/loadstore/short_atomic_store.h - - -#Private Headers -privatedir = ${includedir}/ -nobase_private_HEADERS = atomic_ops/ao_version.h \ - atomic_ops/generalize.h \ - $(BUILT_SOURCES) \ - \ - atomic_ops/sysdeps/all_acquire_release_volatile.h \ - atomic_ops/sysdeps/all_aligned_atomic_load_store.h \ - atomic_ops/sysdeps/all_atomic_load_store.h \ - atomic_ops/sysdeps/all_atomic_only_load.h \ - atomic_ops/sysdeps/emul_cas.h \ - atomic_ops/sysdeps/generic_pthread.h \ - atomic_ops/sysdeps/ordered.h \ - atomic_ops/sysdeps/ordered_except_wr.h \ - atomic_ops/sysdeps/read_ordered.h \ - atomic_ops/sysdeps/standard_ao_double_t.h \ - atomic_ops/sysdeps/test_and_set_t_is_ao_t.h \ - atomic_ops/sysdeps/test_and_set_t_is_char.h \ - \ - atomic_ops/sysdeps/armcc/arm_v6.h \ - \ - atomic_ops/sysdeps/gcc/aarch64.h \ - atomic_ops/sysdeps/gcc/alpha.h \ - atomic_ops/sysdeps/gcc/arm.h \ - atomic_ops/sysdeps/gcc/avr32.h \ - atomic_ops/sysdeps/gcc/cris.h \ - atomic_ops/sysdeps/gcc/generic.h \ - atomic_ops/sysdeps/gcc/hexagon.h \ - atomic_ops/sysdeps/gcc/hppa.h \ - atomic_ops/sysdeps/gcc/ia64.h \ - atomic_ops/sysdeps/gcc/m68k.h \ - atomic_ops/sysdeps/gcc/mips.h \ - atomic_ops/sysdeps/gcc/powerpc.h \ - atomic_ops/sysdeps/gcc/s390.h \ - atomic_ops/sysdeps/gcc/sh.h \ - atomic_ops/sysdeps/gcc/sparc.h \ - atomic_ops/sysdeps/gcc/x86.h \ - \ - atomic_ops/sysdeps/hpc/hppa.h \ - atomic_ops/sysdeps/hpc/ia64.h \ - \ - atomic_ops/sysdeps/ibmc/powerpc.h \ - \ - atomic_ops/sysdeps/icc/ia64.h \ - \ - atomic_ops/sysdeps/loadstore/double_atomic_load_store.h \ - \ - atomic_ops/sysdeps/msftc/arm.h \ - atomic_ops/sysdeps/msftc/common32_defs.h \ - atomic_ops/sysdeps/msftc/x86.h \ - atomic_ops/sysdeps/msftc/x86_64.h \ - \ - atomic_ops/sysdeps/sunc/sparc.h \ - atomic_ops/sysdeps/sunc/x86.h - -all: $(BUILT_SOURCES) config.h - $(MAKE) $(AM_MAKEFLAGS) all-am - -.SUFFIXES: -.SUFFIXES: .S .c .lo .o .obj -$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) - @for dep in $?; do \ - case '$(am__configure_deps)' in \ - *$$dep*) \ - ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ - && { if test -f $@; then exit 0; else break; fi; }; \ - exit 1;; \ - esac; \ - done; \ - echo ' cd $(top_srcdir) && $(AUTOMAKE) --foreign src/Makefile'; \ - $(am__cd) $(top_srcdir) && \ - $(AUTOMAKE) --foreign src/Makefile -Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status - @case '$?' in \ - *config.status*) \ - cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ - *) \ - echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ - cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ - esac; - -$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) - cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh - -$(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) - cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh -$(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) - cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh -$(am__aclocal_m4_deps): - -config.h: stamp-h1 - @test -f $@ || rm -f stamp-h1 - @test -f $@ || $(MAKE) $(AM_MAKEFLAGS) stamp-h1 - -stamp-h1: $(srcdir)/config.h.in $(top_builddir)/config.status - @rm -f stamp-h1 - cd $(top_builddir) && $(SHELL) ./config.status src/config.h -$(srcdir)/config.h.in: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) - ($(am__cd) $(top_srcdir) && $(AUTOHEADER)) - rm -f stamp-h1 - touch $@ - -distclean-hdr: - -rm -f config.h stamp-h1 - -install-libLTLIBRARIES: $(lib_LTLIBRARIES) - @$(NORMAL_INSTALL) - @list='$(lib_LTLIBRARIES)'; test -n "$(libdir)" || list=; \ - list2=; for p in $$list; do \ - if test -f $$p; then \ - list2="$$list2 $$p"; \ - else :; fi; \ - done; \ - test -z "$$list2" || { \ - echo " $(MKDIR_P) '$(DESTDIR)$(libdir)'"; \ - $(MKDIR_P) "$(DESTDIR)$(libdir)" || exit 1; \ - echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL) $(INSTALL_STRIP_FLAG) $$list2 '$(DESTDIR)$(libdir)'"; \ - $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL) $(INSTALL_STRIP_FLAG) $$list2 "$(DESTDIR)$(libdir)"; \ - } - -uninstall-libLTLIBRARIES: - @$(NORMAL_UNINSTALL) - @list='$(lib_LTLIBRARIES)'; test -n "$(libdir)" || list=; \ - for p in $$list; do \ - $(am__strip_dir) \ - echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f '$(DESTDIR)$(libdir)/$$f'"; \ - $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f "$(DESTDIR)$(libdir)/$$f"; \ - done - -clean-libLTLIBRARIES: - -test -z "$(lib_LTLIBRARIES)" || rm -f $(lib_LTLIBRARIES) - @list='$(lib_LTLIBRARIES)'; \ - locs=`for p in $$list; do echo $$p; done | \ - sed 's|^[^/]*$$|.|; s|/[^/]*$$||; s|$$|/so_locations|' | \ - sort -u`; \ - test -z "$$locs" || { \ - echo rm -f $${locs}; \ - rm -f $${locs}; \ - } - -libatomic_ops.la: $(libatomic_ops_la_OBJECTS) $(libatomic_ops_la_DEPENDENCIES) $(EXTRA_libatomic_ops_la_DEPENDENCIES) - $(AM_V_CCLD)$(libatomic_ops_la_LINK) -rpath $(libdir) $(libatomic_ops_la_OBJECTS) $(libatomic_ops_la_LIBADD) $(LIBS) - -libatomic_ops_gpl.la: $(libatomic_ops_gpl_la_OBJECTS) $(libatomic_ops_gpl_la_DEPENDENCIES) $(EXTRA_libatomic_ops_gpl_la_DEPENDENCIES) - $(AM_V_CCLD)$(libatomic_ops_gpl_la_LINK) -rpath $(libdir) $(libatomic_ops_gpl_la_OBJECTS) $(libatomic_ops_gpl_la_LIBADD) $(LIBS) - -mostlyclean-compile: - -rm -f *.$(OBJEXT) - -distclean-compile: - -rm -f *.tab.c - -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/atomic_ops.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/atomic_ops_malloc.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/atomic_ops_stack.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/atomic_ops_sysdeps.Plo@am__quote@ - -.S.o: -@am__fastdepCCAS_TRUE@ $(AM_V_CPPAS)$(CPPASCOMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ $< -@am__fastdepCCAS_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Po -@AMDEP_TRUE@@am__fastdepCCAS_FALSE@ $(AM_V_CPPAS)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ -@AMDEP_TRUE@@am__fastdepCCAS_FALSE@ DEPDIR=$(DEPDIR) $(CCASDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCCAS_FALSE@ $(AM_V_CPPAS@am__nodep@)$(CPPASCOMPILE) -c -o $@ $< - -.S.obj: -@am__fastdepCCAS_TRUE@ $(AM_V_CPPAS)$(CPPASCOMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ `$(CYGPATH_W) '$<'` -@am__fastdepCCAS_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Po -@AMDEP_TRUE@@am__fastdepCCAS_FALSE@ $(AM_V_CPPAS)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ -@AMDEP_TRUE@@am__fastdepCCAS_FALSE@ DEPDIR=$(DEPDIR) $(CCASDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCCAS_FALSE@ $(AM_V_CPPAS@am__nodep@)$(CPPASCOMPILE) -c -o $@ `$(CYGPATH_W) '$<'` - -.S.lo: -@am__fastdepCCAS_TRUE@ $(AM_V_CPPAS)$(LTCPPASCOMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ $< -@am__fastdepCCAS_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Plo -@AMDEP_TRUE@@am__fastdepCCAS_FALSE@ $(AM_V_CPPAS)source='$<' object='$@' libtool=yes @AMDEPBACKSLASH@ -@AMDEP_TRUE@@am__fastdepCCAS_FALSE@ DEPDIR=$(DEPDIR) $(CCASDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCCAS_FALSE@ $(AM_V_CPPAS@am__nodep@)$(LTCPPASCOMPILE) -c -o $@ $< - -.c.o: -@am__fastdepCC_TRUE@ $(AM_V_CC)$(COMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ $< -@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Po -@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ -@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(COMPILE) -c -o $@ $< - -.c.obj: -@am__fastdepCC_TRUE@ $(AM_V_CC)$(COMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ `$(CYGPATH_W) '$<'` -@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Po -@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ -@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(COMPILE) -c -o $@ `$(CYGPATH_W) '$<'` - -.c.lo: -@am__fastdepCC_TRUE@ $(AM_V_CC)$(LTCOMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ $< -@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Plo -@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$<' object='$@' libtool=yes @AMDEPBACKSLASH@ -@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LTCOMPILE) -c -o $@ $< - -mostlyclean-libtool: - -rm -f *.lo - -clean-libtool: - -rm -rf .libs _libs -install-includeHEADERS: $(include_HEADERS) - @$(NORMAL_INSTALL) - @list='$(include_HEADERS)'; test -n "$(includedir)" || list=; \ - if test -n "$$list"; then \ - echo " $(MKDIR_P) '$(DESTDIR)$(includedir)'"; \ - $(MKDIR_P) "$(DESTDIR)$(includedir)" || exit 1; \ - fi; \ - for p in $$list; do \ - if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ - echo "$$d$$p"; \ - done | $(am__base_list) | \ - while read files; do \ - echo " $(INSTALL_HEADER) $$files '$(DESTDIR)$(includedir)'"; \ - $(INSTALL_HEADER) $$files "$(DESTDIR)$(includedir)" || exit $$?; \ - done - -uninstall-includeHEADERS: - @$(NORMAL_UNINSTALL) - @list='$(include_HEADERS)'; test -n "$(includedir)" || list=; \ - files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ - dir='$(DESTDIR)$(includedir)'; $(am__uninstall_files_from_dir) -install-nobase_privateHEADERS: $(nobase_private_HEADERS) - @$(NORMAL_INSTALL) - @list='$(nobase_private_HEADERS)'; test -n "$(privatedir)" || list=; \ - if test -n "$$list"; then \ - echo " $(MKDIR_P) '$(DESTDIR)$(privatedir)'"; \ - $(MKDIR_P) "$(DESTDIR)$(privatedir)" || exit 1; \ - fi; \ - $(am__nobase_list) | while read dir files; do \ - xfiles=; for file in $$files; do \ - if test -f "$$file"; then xfiles="$$xfiles $$file"; \ - else xfiles="$$xfiles $(srcdir)/$$file"; fi; done; \ - test -z "$$xfiles" || { \ - test "x$$dir" = x. || { \ - echo " $(MKDIR_P) '$(DESTDIR)$(privatedir)/$$dir'"; \ - $(MKDIR_P) "$(DESTDIR)$(privatedir)/$$dir"; }; \ - echo " $(INSTALL_HEADER) $$xfiles '$(DESTDIR)$(privatedir)/$$dir'"; \ - $(INSTALL_HEADER) $$xfiles "$(DESTDIR)$(privatedir)/$$dir" || exit $$?; }; \ - done - -uninstall-nobase_privateHEADERS: - @$(NORMAL_UNINSTALL) - @list='$(nobase_private_HEADERS)'; test -n "$(privatedir)" || list=; \ - $(am__nobase_strip_setup); files=`$(am__nobase_strip)`; \ - dir='$(DESTDIR)$(privatedir)'; $(am__uninstall_files_from_dir) - -ID: $(am__tagged_files) - $(am__define_uniq_tagged_files); mkid -fID $$unique -tags: tags-am -TAGS: tags - -tags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) - set x; \ - here=`pwd`; \ - $(am__define_uniq_tagged_files); \ - shift; \ - if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \ - test -n "$$unique" || unique=$$empty_fix; \ - if test $$# -gt 0; then \ - $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ - "$$@" $$unique; \ - else \ - $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ - $$unique; \ - fi; \ - fi -ctags: ctags-am - -CTAGS: ctags -ctags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) - $(am__define_uniq_tagged_files); \ - test -z "$(CTAGS_ARGS)$$unique" \ - || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ - $$unique - -GTAGS: - here=`$(am__cd) $(top_builddir) && pwd` \ - && $(am__cd) $(top_srcdir) \ - && gtags -i $(GTAGS_ARGS) "$$here" -cscopelist: cscopelist-am - -cscopelist-am: $(am__tagged_files) - list='$(am__tagged_files)'; \ - case "$(srcdir)" in \ - [\\/]* | ?:[\\/]*) sdir="$(srcdir)" ;; \ - *) sdir=$(subdir)/$(srcdir) ;; \ - esac; \ - for i in $$list; do \ - if test -f "$$i"; then \ - echo "$(subdir)/$$i"; \ - else \ - echo "$$sdir/$$i"; \ - fi; \ - done >> $(top_builddir)/cscope.files - -distclean-tags: - -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags - -distdir: $(DISTFILES) - @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ - topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ - list='$(DISTFILES)'; \ - dist_files=`for file in $$list; do echo $$file; done | \ - sed -e "s|^$$srcdirstrip/||;t" \ - -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ - case $$dist_files in \ - */*) $(MKDIR_P) `echo "$$dist_files" | \ - sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ - sort -u` ;; \ - esac; \ - for file in $$dist_files; do \ - if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ - if test -d $$d/$$file; then \ - dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ - if test -d "$(distdir)/$$file"; then \ - find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ - fi; \ - if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ - cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ - find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ - fi; \ - cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ - else \ - test -f "$(distdir)/$$file" \ - || cp -p $$d/$$file "$(distdir)/$$file" \ - || exit 1; \ - fi; \ - done -check-am: all-am -check: $(BUILT_SOURCES) - $(MAKE) $(AM_MAKEFLAGS) check-am -all-am: Makefile $(LTLIBRARIES) $(HEADERS) config.h -installdirs: - for dir in "$(DESTDIR)$(libdir)" "$(DESTDIR)$(includedir)" "$(DESTDIR)$(privatedir)"; do \ - test -z "$$dir" || $(MKDIR_P) "$$dir"; \ - done -install: $(BUILT_SOURCES) - $(MAKE) $(AM_MAKEFLAGS) install-am -install-exec: install-exec-am -install-data: install-data-am -uninstall: uninstall-am - -install-am: all-am - @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am - -installcheck: installcheck-am -install-strip: - if test -z '$(STRIP)'; then \ - $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ - install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ - install; \ - else \ - $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ - install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ - "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ - fi -mostlyclean-generic: - -clean-generic: - -distclean-generic: - -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) - -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) - -maintainer-clean-generic: - @echo "This command is intended for maintainers to use" - @echo "it deletes files that may require special tools to rebuild." - -test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES) -clean: clean-am - -clean-am: clean-generic clean-libLTLIBRARIES clean-libtool \ - mostlyclean-am - -distclean: distclean-am - -rm -rf ./$(DEPDIR) - -rm -f Makefile -distclean-am: clean-am distclean-compile distclean-generic \ - distclean-hdr distclean-tags - -dvi: dvi-am - -dvi-am: - -html: html-am - -html-am: - -info: info-am - -info-am: - -install-data-am: install-includeHEADERS install-nobase_privateHEADERS - -install-dvi: install-dvi-am - -install-dvi-am: - -install-exec-am: install-libLTLIBRARIES - -install-html: install-html-am - -install-html-am: - -install-info: install-info-am - -install-info-am: - -install-man: - -install-pdf: install-pdf-am - -install-pdf-am: - -install-ps: install-ps-am - -install-ps-am: - -installcheck-am: - -maintainer-clean: maintainer-clean-am - -rm -rf ./$(DEPDIR) - -rm -f Makefile -maintainer-clean-am: distclean-am maintainer-clean-generic - -mostlyclean: mostlyclean-am - -mostlyclean-am: mostlyclean-compile mostlyclean-generic \ - mostlyclean-libtool - -pdf: pdf-am - -pdf-am: - -ps: ps-am - -ps-am: - -uninstall-am: uninstall-includeHEADERS uninstall-libLTLIBRARIES \ - uninstall-nobase_privateHEADERS - -.MAKE: all check install install-am install-strip - -.PHONY: CTAGS GTAGS TAGS all all-am check check-am clean clean-generic \ - clean-libLTLIBRARIES clean-libtool cscopelist-am ctags \ - ctags-am distclean distclean-compile distclean-generic \ - distclean-hdr distclean-libtool distclean-tags distdir dvi \ - dvi-am html html-am info info-am install install-am \ - install-data install-data-am install-dvi install-dvi-am \ - install-exec install-exec-am install-html install-html-am \ - install-includeHEADERS install-info install-info-am \ - install-libLTLIBRARIES install-man \ - install-nobase_privateHEADERS install-pdf install-pdf-am \ - install-ps install-ps-am install-strip installcheck \ - installcheck-am installdirs maintainer-clean \ - maintainer-clean-generic mostlyclean mostlyclean-compile \ - mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \ - tags tags-am uninstall uninstall-am uninstall-includeHEADERS \ - uninstall-libLTLIBRARIES uninstall-nobase_privateHEADERS - -.PRECIOUS: Makefile - - -atomic_ops/generalize-small.h: atomic_ops/generalize-small.template - mkdir -p `dirname $@` - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g $? > $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g $? >> $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g $? >> $@ - sed -e s:XSIZE:double:g -e s:XCTYPE:AO_double_t:g $? >> $@ - -atomic_ops/generalize-arithm.h: atomic_ops/generalize-arithm.template - mkdir -p `dirname $@` - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g $? > $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g $? >> $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g $? >> $@ - -atomic_ops/sysdeps/ao_t_is_int.h: atomic_ops/sysdeps/ao_t_is_int.template - mkdir -p `dirname $@` - sed -e s:_XBAR::g $? > $@ - sed -e s:XBAR:full:g $? >> $@ - sed -e s:XBAR:acquire:g $? >> $@ - sed -e s:XBAR:release:g $? >> $@ - sed -e s:XBAR:write:g $? >> $@ - sed -e s:XBAR:read:g $? >> $@ - -atomic_ops/sysdeps/gcc/generic-arithm.h: \ - atomic_ops/sysdeps/gcc/generic-arithm.template - mkdir -p `dirname $@` - sed -e s:_XBAR::g -e s:XGCCBAR:RELAXED:g \ - -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g $? > $@ - sed -e s:_XBAR::g -e s:XGCCBAR:RELAXED:g \ - -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g $? >> $@ - sed -e s:_XBAR::g -e s:XGCCBAR:RELAXED:g \ - -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g $? >> $@ - sed -e s:_XBAR::g -e s:XGCCBAR:RELAXED:g \ - -e s:XSIZE_::g -e s:XCTYPE:AO_t:g $? >> $@ - sed -e s:XBAR:acquire:g -e s:XGCCBAR:ACQUIRE:g \ - -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g $? >> $@ - sed -e s:XBAR:acquire:g -e s:XGCCBAR:ACQUIRE:g \ - -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g $? >> $@ - sed -e s:XBAR:acquire:g -e s:XGCCBAR:ACQUIRE:g \ - -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g $? >> $@ - sed -e s:XBAR:acquire:g -e s:XGCCBAR:ACQUIRE:g \ - -e s:XSIZE_::g -e s:XCTYPE:AO_t:g $? >> $@ - sed -e s:XBAR:release:g -e s:XGCCBAR:RELEASE:g \ - -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g $? >> $@ - sed -e s:XBAR:release:g -e s:XGCCBAR:RELEASE:g \ - -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g $? >> $@ - sed -e s:XBAR:release:g -e s:XGCCBAR:RELEASE:g \ - -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g $? >> $@ - sed -e s:XBAR:release:g -e s:XGCCBAR:RELEASE:g \ - -e s:XSIZE_::g -e s:XCTYPE:AO_t:g $? >> $@ - sed -e s:XBAR:full:g -e s:XGCCBAR:SEQ_CST:g \ - -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g $? >> $@ - sed -e s:XBAR:full:g -e s:XGCCBAR:SEQ_CST:g \ - -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g $? >> $@ - sed -e s:XBAR:full:g -e s:XGCCBAR:SEQ_CST:g \ - -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g $? >> $@ - sed -e s:XBAR:full:g -e s:XGCCBAR:SEQ_CST:g \ - -e s:XSIZE_::g -e s:XCTYPE:AO_t:g $? >> $@ - -atomic_ops/sysdeps/gcc/generic-small.h: \ - atomic_ops/sysdeps/gcc/generic-small.template - mkdir -p `dirname $@` - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g $? > $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g $? >> $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g $? >> $@ - -atomic_ops/sysdeps/loadstore/ordered_loads_only.h: \ - atomic_ops/sysdeps/loadstore/ordered_loads_only.template - mkdir -p `dirname $@` - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g $? > $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g $? >> $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g $? >> $@ - sed -e s:XSIZE:double:g -e s:XCTYPE:AO_double_t:g $? >> $@ - -atomic_ops/sysdeps/loadstore/ordered_stores_only.h: \ - atomic_ops/sysdeps/loadstore/ordered_stores_only.template - mkdir -p `dirname $@` - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g $? > $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g $? >> $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g $? >> $@ - sed -e s:XSIZE:double:g -e s:XCTYPE:AO_double_t:g $? >> $@ - -atomic_ops/sysdeps/loadstore/acquire_release_volatile.h: \ - atomic_ops/sysdeps/loadstore/acquire_release_volatile.template - mkdir -p `dirname $@` - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g $? > $@ - -atomic_ops/sysdeps/loadstore/char_acquire_release_volatile.h: \ - atomic_ops/sysdeps/loadstore/acquire_release_volatile.template - mkdir -p `dirname $@` - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g $? > $@ - -atomic_ops/sysdeps/loadstore/int_acquire_release_volatile.h: \ - atomic_ops/sysdeps/loadstore/acquire_release_volatile.template - mkdir -p `dirname $@` - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g $? > $@ - -atomic_ops/sysdeps/loadstore/short_acquire_release_volatile.h: \ - atomic_ops/sysdeps/loadstore/acquire_release_volatile.template - mkdir -p `dirname $@` - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g $? > $@ - -atomic_ops/sysdeps/loadstore/atomic_load.h: \ - atomic_ops/sysdeps/loadstore/atomic_load.template - mkdir -p `dirname $@` - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g $? > $@ - -atomic_ops/sysdeps/loadstore/char_atomic_load.h: \ - atomic_ops/sysdeps/loadstore/atomic_load.template - mkdir -p `dirname $@` - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g $? > $@ - -atomic_ops/sysdeps/loadstore/int_atomic_load.h: \ - atomic_ops/sysdeps/loadstore/atomic_load.template - mkdir -p `dirname $@` - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g $? > $@ - -atomic_ops/sysdeps/loadstore/short_atomic_load.h: \ - atomic_ops/sysdeps/loadstore/atomic_load.template - mkdir -p `dirname $@` - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g $? > $@ - -atomic_ops/sysdeps/loadstore/atomic_store.h: \ - atomic_ops/sysdeps/loadstore/atomic_store.template - mkdir -p `dirname $@` - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g $? > $@ - -atomic_ops/sysdeps/loadstore/char_atomic_store.h: \ - atomic_ops/sysdeps/loadstore/atomic_store.template - mkdir -p `dirname $@` - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g $? > $@ - -atomic_ops/sysdeps/loadstore/int_atomic_store.h: \ - atomic_ops/sysdeps/loadstore/atomic_store.template - mkdir -p `dirname $@` - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g $? > $@ - -atomic_ops/sysdeps/loadstore/short_atomic_store.h: \ - atomic_ops/sysdeps/loadstore/atomic_store.template - mkdir -p `dirname $@` - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g $? > $@ - -# Tell versions [3.59,3.63) of GNU make to not export all variables. -# Otherwise a system limit (for SysV at least) may be exceeded. -.NOEXPORT: diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/src/Makefile.msft ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/Makefile.msft --- ecl-16.1.2/src/bdwgc/libatomic_ops/src/Makefile.msft 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/src/Makefile.msft 1970-01-01 00:00:00.000000000 +0000 @@ -1,60 +0,0 @@ -# -# Copyright (c) 2003-2005 Hewlett-Packard Development Company, L.P. -# -# The really trivial win32/VC++ Makefile. Note that atomic_ops.c defines -# only AO_pause (used by atomic_ops_stack). -# And we rely on a pre-built test_atomic_include.h and generalize-small.h, -# since we can't rely on sed. But we don't keep test_atomic_include.h in -# the development repository any longer, so if you want to do "make check" -# for the sources obtained from the repository then -# do "autoreconf -vif; ./configure; make check" in Cygwin first. -# Win32 clients only need to include the header files. -# To install, copy atomic_ops.h and the atomic_ops/... tree to your favorite -# include directory. - -#MY_CPU=X86 -#CPU=$(MY_CPU) -#!include - -CFLAGS=-O2 -W3 -DAO_ASSUME_WINDOWS98 - -LIB_OBJS=atomic_ops.obj atomic_ops_malloc.obj atomic_ops_stack.obj - -all: libatomic_ops_gpl.lib - -atomic_ops.obj: - cl $(CFLAGS) -c atomic_ops.c - -atomic_ops_stack.obj: - cl $(CFLAGS) -c atomic_ops_stack.c - -atomic_ops_malloc.obj: - cl $(CFLAGS) -c atomic_ops_malloc.c - -libatomic_ops_gpl.lib: $(LIB_OBJS) - lib /out:libatomic_ops_gpl.lib $(LIB_OBJS) - -test_atomic: ..\tests\test_atomic.c ..\tests\test_atomic_include.h - cl $(CFLAGS) -I. ..\tests\test_atomic.c /Fo.\test_atomic - -test_atomic_w95: ..\tests\test_atomic.c ..\tests\test_atomic_include.h - cl -W3 -O2 -I. ..\tests\test_atomic.c /Fo.\test_atomic_w95 - -test_malloc: ..\tests\test_malloc.c libatomic_ops_gpl.lib - cl $(CFLAGS) -I. ..\tests\test_malloc.c /Fo.\test_malloc \ - libatomic_ops_gpl.lib - -test_stack: ..\tests\test_stack.c libatomic_ops_gpl.lib - cl $(CFLAGS) -I. ..\tests\test_stack.c /Fo.\test_stack \ - libatomic_ops_gpl.lib - -check: test_atomic test_atomic_w95 test_malloc test_stack - @echo "The following will print lots of 'Missing ...' messages" - test_atomic_w95 - @echo "The following will print some 'Missing ...' messages" - test_atomic - test_malloc - test_stack - -clean: - del *.exe *.obj libatomic_ops_gpl.lib diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/tests/list_atomic.template ecl-16.1.3+ds/src/bdwgc/libatomic_ops/tests/list_atomic.template --- ecl-16.1.2/src/bdwgc/libatomic_ops/tests/list_atomic.template 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/tests/list_atomic.template 1970-01-01 00:00:00.000000000 +0000 @@ -1,117 +0,0 @@ -/* - * Copyright (c) 2003 by Hewlett-Packard Company. All rights reserved. - * - * This file is covered by the GNU general public license, version 2. - * see COPYING for details. - */ - -/* This generates a compilable program. But it is really meant to be */ -/* be used only with cc -E, to inspect the expensions generated by */ -/* primitives. */ - -/* The result will not link or run. */ - -void XSIZE_list_atomicXX(void) -{ -# if defined(AO_HAVE_XSIZE_loadXX) || defined(AO_HAVE_XSIZE_storeXX) \ - || defined(AO_HAVE_XSIZE_fetch_and_addXX) \ - || defined(AO_HAVE_XSIZE_fetch_and_add1XX) \ - || defined(AO_HAVE_XSIZE_andXX) \ - || defined(AO_HAVE_XSIZE_compare_and_swapXX) \ - || defined(AO_HAVE_XSIZE_fetch_compare_and_swapXX) - static volatile XCTYPE val /* = 0 */; -# endif -# if defined(AO_HAVE_XSIZE_compare_and_swapXX) \ - || defined(AO_HAVE_XSIZE_fetch_compare_and_swapXX) - static XCTYPE oldval /* = 0 */; -# endif -# if defined(AO_HAVE_XSIZE_storeXX) \ - || defined(AO_HAVE_XSIZE_compare_and_swapXX) \ - || defined(AO_HAVE_XSIZE_fetch_compare_and_swapXX) - static XCTYPE newval /* = 0 */; -# endif -# if defined(AO_HAVE_test_and_setXX) - AO_TS_t ts; -# endif -# if defined(AO_HAVE_XSIZE_fetch_and_addXX) || defined(AO_HAVE_XSIZE_andXX) \ - || defined(AO_HAVE_XSIZE_orXX) || defined(AO_HAVE_XSIZE_xorXX) - static XCTYPE incr /* = 0 */; -# endif - -# if defined(AO_HAVE_nopXX) - (void)"AO_nopXX(): "; - AO_nopXX(); -# else - (void)"No AO_nopXX"; -# endif - -# ifdef AO_HAVE_XSIZE_loadXX - (void)"AO_XSIZE_loadXX(&val):"; - AO_XSIZE_loadXX(&val); -# else - (void)"No AO_XSIZE_loadXX"; -# endif -# ifdef AO_HAVE_XSIZE_storeXX - (void)"AO_XSIZE_storeXX(&val, newval):"; - AO_XSIZE_storeXX(&val, newval); -# else - (void)"No AO_XSIZE_storeXX"; -# endif -# ifdef AO_HAVE_XSIZE_fetch_and_addXX - (void)"AO_XSIZE_fetch_and_addXX(&val, incr):"; - AO_XSIZE_fetch_and_addXX(&val, incr); -# else - (void)"No AO_XSIZE_fetch_and_addXX"; -# endif -# ifdef AO_HAVE_XSIZE_fetch_and_add1XX - (void)"AO_XSIZE_fetch_and_add1XX(&val):"; - AO_XSIZE_fetch_and_add1XX(&val); -# else - (void)"No AO_XSIZE_fetch_and_add1XX"; -# endif -# ifdef AO_HAVE_XSIZE_fetch_and_sub1XX - (void)"AO_XSIZE_fetch_and_sub1XX(&val):"; - AO_XSIZE_fetch_and_sub1XX(&val); -# else - (void)"No AO_XSIZE_fetch_and_sub1XX"; -# endif -# ifdef AO_HAVE_XSIZE_andXX - (void)"AO_XSIZE_andXX(&val, incr):"; - AO_XSIZE_andXX(&val, incr); -# else - (void)"No AO_XSIZE_andXX"; -# endif -# ifdef AO_HAVE_XSIZE_orXX - (void)"AO_XSIZE_orXX(&val, incr):"; - AO_XSIZE_orXX(&val, incr); -# else - (void)"No AO_XSIZE_orXX"; -# endif -# ifdef AO_HAVE_XSIZE_xorXX - (void)"AO_XSIZE_xorXX(&val, incr):"; - AO_XSIZE_xorXX(&val, incr); -# else - (void)"No AO_XSIZE_xorXX"; -# endif -# ifdef AO_HAVE_XSIZE_compare_and_swapXX - (void)"AO_XSIZE_compare_and_swapXX(&val, oldval, newval):"; - AO_XSIZE_compare_and_swapXX(&val, oldval, newval); -# else - (void)"No AO_XSIZE_compare_and_swapXX"; -# endif - /* TODO: Add AO_compare_double_and_swap_doubleXX */ - /* TODO: Add AO_compare_and_swap_doubleXX */ -# ifdef AO_HAVE_XSIZE_fetch_compare_and_swapXX - (void)"AO_XSIZE_fetch_compare_and_swapXX(&val, oldval, newval):"; - AO_XSIZE_fetch_compare_and_swapXX(&val, oldval, newval); -# else - (void)"No AO_XSIZE_fetch_compare_and_swapXX"; -# endif - -# if defined(AO_HAVE_test_and_setXX) - (void)"AO_test_and_setXX(&ts):"; - AO_test_and_setXX(&ts); -# else - (void)"No AO_test_and_setXX"; -# endif -} diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/tests/Makefile.am ecl-16.1.3+ds/src/bdwgc/libatomic_ops/tests/Makefile.am --- ecl-16.1.2/src/bdwgc/libatomic_ops/tests/Makefile.am 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/tests/Makefile.am 1970-01-01 00:00:00.000000000 +0000 @@ -1,103 +0,0 @@ -EXTRA_DIST=test_atomic_include.template list_atomic.template run_parallel.h \ - test_atomic_include.h list_atomic.c -# We distribute test_atomic_include.h and list_atomic.c, since it is hard -# to regenerate them on Windows without sed. - -BUILT_SOURCES = test_atomic_include.h list_atomic.i list_atomic.o -CLEANFILES = list_atomic.i list_atomic.o - -AM_CPPFLAGS = \ - -I$(top_builddir)/src -I$(top_srcdir)/src \ - -I$(top_builddir)/tests -I$(top_srcdir)/tests - -if HAVE_PTHREAD_H -TESTS=test_atomic test_atomic_pthreads test_stack test_malloc -test_atomic_pthreads_SOURCES=$(test_atomic_SOURCES) -test_atomic_pthreads_CPPFLAGS=-DAO_USE_PTHREAD_DEFS $(AM_CPPFLAGS) -test_atomic_pthreads_LDADD=$(test_atomic_LDADD) -else -TESTS=test_atomic test_stack test_malloc -endif - -check_PROGRAMS=$(TESTS) - -test_atomic_SOURCES=test_atomic.c -test_atomic_LDADD = $(THREADDLLIBS) $(top_builddir)/src/libatomic_ops.la - -test_stack_SOURCES=test_stack.c -test_stack_LDADD = $(THREADDLLIBS) \ - $(top_builddir)/src/libatomic_ops_gpl.la \ - $(top_builddir)/src/libatomic_ops.la - -test_malloc_SOURCES=test_malloc.c -test_malloc_LDADD = $(THREADDLLIBS) \ - $(top_builddir)/src/libatomic_ops_gpl.la \ - $(top_builddir)/src/libatomic_ops.la - -test_atomic_include.h: test_atomic_include.template - mkdir -p `dirname $@` - sed -e s:XX::g $? > $@ - sed -e s:XX:_release:g $? >> $@ - sed -e s:XX:_acquire:g $? >> $@ - sed -e s:XX:_read:g $? >> $@ - sed -e s:XX:_write:g $? >> $@ - sed -e s:XX:_full:g $? >> $@ - sed -e s:XX:_release_write:g $? >> $@ - sed -e s:XX:_acquire_read:g $? >> $@ - -list_atomic.c: list_atomic.template - mkdir -p `dirname $@` - echo "#include \"atomic_ops.h\"" > $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g -e s:XX::g $? >> $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g -e s:XX:_release:g $? >> $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g -e s:XX:_acquire:g $? >> $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g -e s:XX:_read:g $? >> $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g -e s:XX:_write:g $? >> $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g -e s:XX:_full:g $? >> $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g -e s:XX:_release_write:g $? >> $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g -e s:XX:_acquire_read:g $? >> $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g -e s:XX:_dd_acquire_read:g $? >> $@ - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g -e s:XX::g $? >> $@ - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g -e s:XX:_release:g $? >> $@ - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g -e s:XX:_acquire:g $? >> $@ - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g -e s:XX:_read:g $? >> $@ - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g -e s:XX:_write:g $? >> $@ - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g -e s:XX:_full:g $? >> $@ - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g -e s:XX:_release_write:g $? >> $@ - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g -e s:XX:_acquire_read:g $? >> $@ - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g -e s:XX:_dd_acquire_read:g $? >> $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g -e s:XX::g $? >> $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g -e s:XX:_release:g $? >> $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g -e s:XX:_acquire:g $? >> $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g -e s:XX:_read:g $? >> $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g -e s:XX:_write:g $? >> $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g -e s:XX:_full:g $? >> $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g -e s:XX:_release_write:g $? >> $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g -e s:XX:_acquire_read:g $? >> $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g -e s:XX:_dd_acquire_read:g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g -e s:XX::g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g -e s:XX:_release:g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g -e s:XX:_acquire:g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g -e s:XX:_read:g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g -e s:XX:_write:g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g -e s:XX:_full:g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g -e s:XX:_release_write:g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g -e s:XX:_acquire_read:g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g -e s:XX:_dd_acquire_read:g $? >> $@ - sed -e s:XSIZE:double:g -e s:XCTYPE:AO_double_t:g -e s:XX::g $? >> $@ - sed -e s:XSIZE:double:g -e s:XCTYPE:AO_double_t:g -e s:XX:_release:g $? >> $@ - sed -e s:XSIZE:double:g -e s:XCTYPE:AO_double_t:g -e s:XX:_acquire:g $? >> $@ - sed -e s:XSIZE:double:g -e s:XCTYPE:AO_double_t:g -e s:XX:_read:g $? >> $@ - sed -e s:XSIZE:double:g -e s:XCTYPE:AO_double_t:g -e s:XX:_write:g $? >> $@ - sed -e s:XSIZE:double:g -e s:XCTYPE:AO_double_t:g -e s:XX:_full:g $? >> $@ - sed -e s:XSIZE:double:g -e s:XCTYPE:AO_double_t:g -e s:XX:_release_write:g $? >> $@ - sed -e s:XSIZE:double:g -e s:XCTYPE:AO_double_t:g -e s:XX:_acquire_read:g $? >> $@ - sed -e s:XSIZE:double:g -e s:XCTYPE:AO_double_t:g -e s:XX:_dd_acquire_read:g $? >> $@ - -list_atomic.i: list_atomic.c - mkdir -p `dirname $@` - $(COMPILE) $? -E > $@ - -# Verify list_atomic.c syntax: -list_atomic.o: list_atomic.c - $(COMPILE) -c -o $@ $? diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/tests/Makefile.in ecl-16.1.3+ds/src/bdwgc/libatomic_ops/tests/Makefile.in --- ecl-16.1.2/src/bdwgc/libatomic_ops/tests/Makefile.in 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/tests/Makefile.in 1970-01-01 00:00:00.000000000 +0000 @@ -1,1145 +0,0 @@ -# Makefile.in generated by automake 1.15 from Makefile.am. -# @configure_input@ - -# Copyright (C) 1994-2014 Free Software Foundation, Inc. - -# This Makefile.in 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. - -@SET_MAKE@ -VPATH = @srcdir@ -am__is_gnu_make = { \ - if test -z '$(MAKELEVEL)'; then \ - false; \ - elif test -n '$(MAKE_HOST)'; then \ - true; \ - elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ - true; \ - else \ - false; \ - fi; \ -} -am__make_running_with_option = \ - case $${target_option-} in \ - ?) ;; \ - *) echo "am__make_running_with_option: internal error: invalid" \ - "target option '$${target_option-}' specified" >&2; \ - exit 1;; \ - esac; \ - has_opt=no; \ - sane_makeflags=$$MAKEFLAGS; \ - if $(am__is_gnu_make); then \ - sane_makeflags=$$MFLAGS; \ - else \ - case $$MAKEFLAGS in \ - *\\[\ \ ]*) \ - bs=\\; \ - sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ - | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ - esac; \ - fi; \ - skip_next=no; \ - strip_trailopt () \ - { \ - flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ - }; \ - for flg in $$sane_makeflags; do \ - test $$skip_next = yes && { skip_next=no; continue; }; \ - case $$flg in \ - *=*|--*) continue;; \ - -*I) strip_trailopt 'I'; skip_next=yes;; \ - -*I?*) strip_trailopt 'I';; \ - -*O) strip_trailopt 'O'; skip_next=yes;; \ - -*O?*) strip_trailopt 'O';; \ - -*l) strip_trailopt 'l'; skip_next=yes;; \ - -*l?*) strip_trailopt 'l';; \ - -[dEDm]) skip_next=yes;; \ - -[JT]) skip_next=yes;; \ - esac; \ - case $$flg in \ - *$$target_option*) has_opt=yes; break;; \ - esac; \ - done; \ - test $$has_opt = yes -am__make_dryrun = (target_option=n; $(am__make_running_with_option)) -am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) -pkgdatadir = $(datadir)/@PACKAGE@ -pkgincludedir = $(includedir)/@PACKAGE@ -pkglibdir = $(libdir)/@PACKAGE@ -pkglibexecdir = $(libexecdir)/@PACKAGE@ -am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd -install_sh_DATA = $(install_sh) -c -m 644 -install_sh_PROGRAM = $(install_sh) -c -install_sh_SCRIPT = $(install_sh) -c -INSTALL_HEADER = $(INSTALL_DATA) -transform = $(program_transform_name) -NORMAL_INSTALL = : -PRE_INSTALL = : -POST_INSTALL = : -NORMAL_UNINSTALL = : -PRE_UNINSTALL = : -POST_UNINSTALL = : -build_triplet = @build@ -host_triplet = @host@ -target_triplet = @target@ -@HAVE_PTHREAD_H_FALSE@TESTS = test_atomic$(EXEEXT) test_stack$(EXEEXT) \ -@HAVE_PTHREAD_H_FALSE@ test_malloc$(EXEEXT) -@HAVE_PTHREAD_H_TRUE@TESTS = test_atomic$(EXEEXT) \ -@HAVE_PTHREAD_H_TRUE@ test_atomic_pthreads$(EXEEXT) \ -@HAVE_PTHREAD_H_TRUE@ test_stack$(EXEEXT) test_malloc$(EXEEXT) -check_PROGRAMS = $(am__EXEEXT_1) -subdir = tests -ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 -am__aclocal_m4_deps = $(top_srcdir)/m4/libtool.m4 \ - $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \ - $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \ - $(top_srcdir)/configure.ac -am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ - $(ACLOCAL_M4) -DIST_COMMON = $(srcdir)/Makefile.am $(am__DIST_COMMON) -mkinstalldirs = $(install_sh) -d -CONFIG_HEADER = $(top_builddir)/src/config.h -CONFIG_CLEAN_FILES = -CONFIG_CLEAN_VPATH_FILES = -@HAVE_PTHREAD_H_FALSE@am__EXEEXT_1 = test_atomic$(EXEEXT) \ -@HAVE_PTHREAD_H_FALSE@ test_stack$(EXEEXT) test_malloc$(EXEEXT) -@HAVE_PTHREAD_H_TRUE@am__EXEEXT_1 = test_atomic$(EXEEXT) \ -@HAVE_PTHREAD_H_TRUE@ test_atomic_pthreads$(EXEEXT) \ -@HAVE_PTHREAD_H_TRUE@ test_stack$(EXEEXT) test_malloc$(EXEEXT) -am_test_atomic_OBJECTS = test_atomic.$(OBJEXT) -test_atomic_OBJECTS = $(am_test_atomic_OBJECTS) -am__DEPENDENCIES_1 = -test_atomic_DEPENDENCIES = $(am__DEPENDENCIES_1) \ - $(top_builddir)/src/libatomic_ops.la -AM_V_lt = $(am__v_lt_@AM_V@) -am__v_lt_ = $(am__v_lt_@AM_DEFAULT_V@) -am__v_lt_0 = --silent -am__v_lt_1 = -am__test_atomic_pthreads_SOURCES_DIST = test_atomic.c -am__objects_1 = test_atomic_pthreads-test_atomic.$(OBJEXT) -@HAVE_PTHREAD_H_TRUE@am_test_atomic_pthreads_OBJECTS = \ -@HAVE_PTHREAD_H_TRUE@ $(am__objects_1) -test_atomic_pthreads_OBJECTS = $(am_test_atomic_pthreads_OBJECTS) -am__DEPENDENCIES_2 = $(am__DEPENDENCIES_1) \ - $(top_builddir)/src/libatomic_ops.la -@HAVE_PTHREAD_H_TRUE@test_atomic_pthreads_DEPENDENCIES = \ -@HAVE_PTHREAD_H_TRUE@ $(am__DEPENDENCIES_2) -am_test_malloc_OBJECTS = test_malloc.$(OBJEXT) -test_malloc_OBJECTS = $(am_test_malloc_OBJECTS) -test_malloc_DEPENDENCIES = $(am__DEPENDENCIES_1) \ - $(top_builddir)/src/libatomic_ops_gpl.la \ - $(top_builddir)/src/libatomic_ops.la -am_test_stack_OBJECTS = test_stack.$(OBJEXT) -test_stack_OBJECTS = $(am_test_stack_OBJECTS) -test_stack_DEPENDENCIES = $(am__DEPENDENCIES_1) \ - $(top_builddir)/src/libatomic_ops_gpl.la \ - $(top_builddir)/src/libatomic_ops.la -AM_V_P = $(am__v_P_@AM_V@) -am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) -am__v_P_0 = false -am__v_P_1 = : -AM_V_GEN = $(am__v_GEN_@AM_V@) -am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) -am__v_GEN_0 = @echo " GEN " $@; -am__v_GEN_1 = -AM_V_at = $(am__v_at_@AM_V@) -am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) -am__v_at_0 = @ -am__v_at_1 = -DEFAULT_INCLUDES = -depcomp = $(SHELL) $(top_srcdir)/../depcomp -am__depfiles_maybe = depfiles -am__mv = mv -f -COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \ - $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -LTCOMPILE = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ - $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) \ - $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \ - $(AM_CFLAGS) $(CFLAGS) -AM_V_CC = $(am__v_CC_@AM_V@) -am__v_CC_ = $(am__v_CC_@AM_DEFAULT_V@) -am__v_CC_0 = @echo " CC " $@; -am__v_CC_1 = -CCLD = $(CC) -LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ - $(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \ - $(AM_LDFLAGS) $(LDFLAGS) -o $@ -AM_V_CCLD = $(am__v_CCLD_@AM_V@) -am__v_CCLD_ = $(am__v_CCLD_@AM_DEFAULT_V@) -am__v_CCLD_0 = @echo " CCLD " $@; -am__v_CCLD_1 = -SOURCES = $(test_atomic_SOURCES) $(test_atomic_pthreads_SOURCES) \ - $(test_malloc_SOURCES) $(test_stack_SOURCES) -DIST_SOURCES = $(test_atomic_SOURCES) \ - $(am__test_atomic_pthreads_SOURCES_DIST) \ - $(test_malloc_SOURCES) $(test_stack_SOURCES) -am__can_run_installinfo = \ - case $$AM_UPDATE_INFO_DIR in \ - n|no|NO) false;; \ - *) (install-info --version) >/dev/null 2>&1;; \ - esac -am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP) -# Read a list of newline-separated strings from the standard input, -# and print each of them once, without duplicates. Input order is -# *not* preserved. -am__uniquify_input = $(AWK) '\ - BEGIN { nonempty = 0; } \ - { items[$$0] = 1; nonempty = 1; } \ - END { if (nonempty) { for (i in items) print i; }; } \ -' -# Make sure the list of sources is unique. This is necessary because, -# e.g., the same source file might be shared among _SOURCES variables -# for different programs/libraries. -am__define_uniq_tagged_files = \ - list='$(am__tagged_files)'; \ - unique=`for i in $$list; do \ - if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ - done | $(am__uniquify_input)` -ETAGS = etags -CTAGS = ctags -am__tty_colors_dummy = \ - mgn= red= grn= lgn= blu= brg= std=; \ - am__color_tests=no -am__tty_colors = { \ - $(am__tty_colors_dummy); \ - if test "X$(AM_COLOR_TESTS)" = Xno; then \ - am__color_tests=no; \ - elif test "X$(AM_COLOR_TESTS)" = Xalways; then \ - am__color_tests=yes; \ - elif test "X$$TERM" != Xdumb && { test -t 1; } 2>/dev/null; then \ - am__color_tests=yes; \ - fi; \ - if test $$am__color_tests = yes; then \ - red=''; \ - grn=''; \ - lgn=''; \ - blu=''; \ - mgn=''; \ - brg=''; \ - std=''; \ - fi; \ -} -am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; -am__vpath_adj = case $$p in \ - $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ - *) f=$$p;; \ - esac; -am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`; -am__install_max = 40 -am__nobase_strip_setup = \ - srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'` -am__nobase_strip = \ - for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||" -am__nobase_list = $(am__nobase_strip_setup); \ - for p in $$list; do echo "$$p $$p"; done | \ - sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \ - $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \ - if (++n[$$2] == $(am__install_max)) \ - { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \ - END { for (dir in files) print dir, files[dir] }' -am__base_list = \ - sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \ - sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g' -am__uninstall_files_from_dir = { \ - test -z "$$files" \ - || { test ! -d "$$dir" && test ! -f "$$dir" && test ! -r "$$dir"; } \ - || { echo " ( cd '$$dir' && rm -f" $$files ")"; \ - $(am__cd) "$$dir" && rm -f $$files; }; \ - } -am__recheck_rx = ^[ ]*:recheck:[ ]* -am__global_test_result_rx = ^[ ]*:global-test-result:[ ]* -am__copy_in_global_log_rx = ^[ ]*:copy-in-global-log:[ ]* -# A command that, given a newline-separated list of test names on the -# standard input, print the name of the tests that are to be re-run -# upon "make recheck". -am__list_recheck_tests = $(AWK) '{ \ - recheck = 1; \ - while ((rc = (getline line < ($$0 ".trs"))) != 0) \ - { \ - if (rc < 0) \ - { \ - if ((getline line2 < ($$0 ".log")) < 0) \ - recheck = 0; \ - break; \ - } \ - else if (line ~ /$(am__recheck_rx)[nN][Oo]/) \ - { \ - recheck = 0; \ - break; \ - } \ - else if (line ~ /$(am__recheck_rx)[yY][eE][sS]/) \ - { \ - break; \ - } \ - }; \ - if (recheck) \ - print $$0; \ - close ($$0 ".trs"); \ - close ($$0 ".log"); \ -}' -# A command that, given a newline-separated list of test names on the -# standard input, create the global log from their .trs and .log files. -am__create_global_log = $(AWK) ' \ -function fatal(msg) \ -{ \ - print "fatal: making $@: " msg | "cat >&2"; \ - exit 1; \ -} \ -function rst_section(header) \ -{ \ - print header; \ - len = length(header); \ - for (i = 1; i <= len; i = i + 1) \ - printf "="; \ - printf "\n\n"; \ -} \ -{ \ - copy_in_global_log = 1; \ - global_test_result = "RUN"; \ - while ((rc = (getline line < ($$0 ".trs"))) != 0) \ - { \ - if (rc < 0) \ - fatal("failed to read from " $$0 ".trs"); \ - if (line ~ /$(am__global_test_result_rx)/) \ - { \ - sub("$(am__global_test_result_rx)", "", line); \ - sub("[ ]*$$", "", line); \ - global_test_result = line; \ - } \ - else if (line ~ /$(am__copy_in_global_log_rx)[nN][oO]/) \ - copy_in_global_log = 0; \ - }; \ - if (copy_in_global_log) \ - { \ - rst_section(global_test_result ": " $$0); \ - while ((rc = (getline line < ($$0 ".log"))) != 0) \ - { \ - if (rc < 0) \ - fatal("failed to read from " $$0 ".log"); \ - print line; \ - }; \ - printf "\n"; \ - }; \ - close ($$0 ".trs"); \ - close ($$0 ".log"); \ -}' -# Restructured Text title. -am__rst_title = { sed 's/.*/ & /;h;s/./=/g;p;x;s/ *$$//;p;g' && echo; } -# Solaris 10 'make', and several other traditional 'make' implementations, -# pass "-e" to $(SHELL), and POSIX 2008 even requires this. Work around it -# by disabling -e (using the XSI extension "set +e") if it's set. -am__sh_e_setup = case $$- in *e*) set +e;; esac -# Default flags passed to test drivers. -am__common_driver_flags = \ - --color-tests "$$am__color_tests" \ - --enable-hard-errors "$$am__enable_hard_errors" \ - --expect-failure "$$am__expect_failure" -# To be inserted before the command running the test. Creates the -# directory for the log if needed. Stores in $dir the directory -# containing $f, in $tst the test, in $log the log. Executes the -# developer- defined test setup AM_TESTS_ENVIRONMENT (if any), and -# passes TESTS_ENVIRONMENT. Set up options for the wrapper that -# will run the test scripts (or their associated LOG_COMPILER, if -# thy have one). -am__check_pre = \ -$(am__sh_e_setup); \ -$(am__vpath_adj_setup) $(am__vpath_adj) \ -$(am__tty_colors); \ -srcdir=$(srcdir); export srcdir; \ -case "$@" in \ - */*) am__odir=`echo "./$@" | sed 's|/[^/]*$$||'`;; \ - *) am__odir=.;; \ -esac; \ -test "x$$am__odir" = x"." || test -d "$$am__odir" \ - || $(MKDIR_P) "$$am__odir" || exit $$?; \ -if test -f "./$$f"; then dir=./; \ -elif test -f "$$f"; then dir=; \ -else dir="$(srcdir)/"; fi; \ -tst=$$dir$$f; log='$@'; \ -if test -n '$(DISABLE_HARD_ERRORS)'; then \ - am__enable_hard_errors=no; \ -else \ - am__enable_hard_errors=yes; \ -fi; \ -case " $(XFAIL_TESTS) " in \ - *[\ \ ]$$f[\ \ ]* | *[\ \ ]$$dir$$f[\ \ ]*) \ - am__expect_failure=yes;; \ - *) \ - am__expect_failure=no;; \ -esac; \ -$(AM_TESTS_ENVIRONMENT) $(TESTS_ENVIRONMENT) -# A shell command to get the names of the tests scripts with any registered -# extension removed (i.e., equivalently, the names of the test logs, with -# the '.log' extension removed). The result is saved in the shell variable -# '$bases'. This honors runtime overriding of TESTS and TEST_LOGS. Sadly, -# we cannot use something simpler, involving e.g., "$(TEST_LOGS:.log=)", -# since that might cause problem with VPATH rewrites for suffix-less tests. -# See also 'test-harness-vpath-rewrite.sh' and 'test-trs-basic.sh'. -am__set_TESTS_bases = \ - bases='$(TEST_LOGS)'; \ - bases=`for i in $$bases; do echo $$i; done | sed 's/\.log$$//'`; \ - bases=`echo $$bases` -RECHECK_LOGS = $(TEST_LOGS) -AM_RECURSIVE_TARGETS = check recheck -TEST_SUITE_LOG = test-suite.log -TEST_EXTENSIONS = @EXEEXT@ .test -LOG_DRIVER = $(SHELL) $(top_srcdir)/../test-driver -LOG_COMPILE = $(LOG_COMPILER) $(AM_LOG_FLAGS) $(LOG_FLAGS) -am__set_b = \ - case '$@' in \ - */*) \ - case '$*' in \ - */*) b='$*';; \ - *) b=`echo '$@' | sed 's/\.log$$//'`; \ - esac;; \ - *) \ - b='$*';; \ - esac -am__test_logs1 = $(TESTS:=.log) -am__test_logs2 = $(am__test_logs1:@EXEEXT@.log=.log) -TEST_LOGS = $(am__test_logs2:.test.log=.log) -TEST_LOG_DRIVER = $(SHELL) $(top_srcdir)/../test-driver -TEST_LOG_COMPILE = $(TEST_LOG_COMPILER) $(AM_TEST_LOG_FLAGS) \ - $(TEST_LOG_FLAGS) -am__DIST_COMMON = $(srcdir)/Makefile.in $(top_srcdir)/../depcomp \ - $(top_srcdir)/../test-driver -DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) -ACLOCAL = @ACLOCAL@ -AMTAR = @AMTAR@ -AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ -AR = @AR@ -AUTOCONF = @AUTOCONF@ -AUTOHEADER = @AUTOHEADER@ -AUTOMAKE = @AUTOMAKE@ -AWK = @AWK@ -CC = @CC@ -CCAS = @CCAS@ -CCASDEPMODE = @CCASDEPMODE@ -CCASFLAGS = @CCASFLAGS@ -CCDEPMODE = @CCDEPMODE@ -CFLAGS = @CFLAGS@ -CPP = @CPP@ -CPPFLAGS = @CPPFLAGS@ -CYGPATH_W = @CYGPATH_W@ -DEFS = @DEFS@ -DEPDIR = @DEPDIR@ -DLLTOOL = @DLLTOOL@ -DSYMUTIL = @DSYMUTIL@ -DUMPBIN = @DUMPBIN@ -ECHO_C = @ECHO_C@ -ECHO_N = @ECHO_N@ -ECHO_T = @ECHO_T@ -EGREP = @EGREP@ -EXEEXT = @EXEEXT@ -FGREP = @FGREP@ -GREP = @GREP@ -INSTALL = @INSTALL@ -INSTALL_DATA = @INSTALL_DATA@ -INSTALL_PROGRAM = @INSTALL_PROGRAM@ -INSTALL_SCRIPT = @INSTALL_SCRIPT@ -INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ -LD = @LD@ -LDFLAGS = @LDFLAGS@ -LIBOBJS = @LIBOBJS@ -LIBS = @LIBS@ -LIBTOOL = @LIBTOOL@ -LIPO = @LIPO@ -LN_S = @LN_S@ -LTLIBOBJS = @LTLIBOBJS@ -LT_SYS_LIBRARY_PATH = @LT_SYS_LIBRARY_PATH@ -MAINT = @MAINT@ -MAKEINFO = @MAKEINFO@ -MANIFEST_TOOL = @MANIFEST_TOOL@ -MKDIR_P = @MKDIR_P@ -NM = @NM@ -NMEDIT = @NMEDIT@ -OBJDUMP = @OBJDUMP@ -OBJEXT = @OBJEXT@ -OTOOL = @OTOOL@ -OTOOL64 = @OTOOL64@ -PACKAGE = @PACKAGE@ -PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ -PACKAGE_NAME = @PACKAGE_NAME@ -PACKAGE_STRING = @PACKAGE_STRING@ -PACKAGE_TARNAME = @PACKAGE_TARNAME@ -PACKAGE_URL = @PACKAGE_URL@ -PACKAGE_VERSION = @PACKAGE_VERSION@ -PATH_SEPARATOR = @PATH_SEPARATOR@ -PICFLAG = @PICFLAG@ -RANLIB = @RANLIB@ -SED = @SED@ -SET_MAKE = @SET_MAKE@ -SHELL = @SHELL@ -STRIP = @STRIP@ -THREADDLLIBS = @THREADDLLIBS@ -VERSION = @VERSION@ -abs_builddir = @abs_builddir@ -abs_srcdir = @abs_srcdir@ -abs_top_builddir = @abs_top_builddir@ -abs_top_srcdir = @abs_top_srcdir@ -ac_ct_AR = @ac_ct_AR@ -ac_ct_CC = @ac_ct_CC@ -ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ -am__include = @am__include@ -am__leading_dot = @am__leading_dot@ -am__quote = @am__quote@ -am__tar = @am__tar@ -am__untar = @am__untar@ -bindir = @bindir@ -build = @build@ -build_alias = @build_alias@ -build_cpu = @build_cpu@ -build_os = @build_os@ -build_vendor = @build_vendor@ -builddir = @builddir@ -datadir = @datadir@ -datarootdir = @datarootdir@ -docdir = @docdir@ -dvidir = @dvidir@ -exec_prefix = @exec_prefix@ -host = @host@ -host_alias = @host_alias@ -host_cpu = @host_cpu@ -host_os = @host_os@ -host_vendor = @host_vendor@ -htmldir = @htmldir@ -includedir = @includedir@ -infodir = @infodir@ -install_sh = @install_sh@ -libdir = @libdir@ -libexecdir = @libexecdir@ -localedir = @localedir@ -localstatedir = @localstatedir@ -mandir = @mandir@ -mkdir_p = @mkdir_p@ -oldincludedir = @oldincludedir@ -pdfdir = @pdfdir@ -prefix = @prefix@ -program_transform_name = @program_transform_name@ -psdir = @psdir@ -sbindir = @sbindir@ -sharedstatedir = @sharedstatedir@ -srcdir = @srcdir@ -sysconfdir = @sysconfdir@ -target = @target@ -target_alias = @target_alias@ -target_cpu = @target_cpu@ -target_os = @target_os@ -target_vendor = @target_vendor@ -top_build_prefix = @top_build_prefix@ -top_builddir = @top_builddir@ -top_srcdir = @top_srcdir@ -EXTRA_DIST = test_atomic_include.template list_atomic.template run_parallel.h \ - test_atomic_include.h list_atomic.c - -# We distribute test_atomic_include.h and list_atomic.c, since it is hard -# to regenerate them on Windows without sed. -BUILT_SOURCES = test_atomic_include.h list_atomic.i list_atomic.o -CLEANFILES = list_atomic.i list_atomic.o -AM_CPPFLAGS = \ - -I$(top_builddir)/src -I$(top_srcdir)/src \ - -I$(top_builddir)/tests -I$(top_srcdir)/tests - -@HAVE_PTHREAD_H_TRUE@test_atomic_pthreads_SOURCES = $(test_atomic_SOURCES) -@HAVE_PTHREAD_H_TRUE@test_atomic_pthreads_CPPFLAGS = -DAO_USE_PTHREAD_DEFS $(AM_CPPFLAGS) -@HAVE_PTHREAD_H_TRUE@test_atomic_pthreads_LDADD = $(test_atomic_LDADD) -test_atomic_SOURCES = test_atomic.c -test_atomic_LDADD = $(THREADDLLIBS) $(top_builddir)/src/libatomic_ops.la -test_stack_SOURCES = test_stack.c -test_stack_LDADD = $(THREADDLLIBS) \ - $(top_builddir)/src/libatomic_ops_gpl.la \ - $(top_builddir)/src/libatomic_ops.la - -test_malloc_SOURCES = test_malloc.c -test_malloc_LDADD = $(THREADDLLIBS) \ - $(top_builddir)/src/libatomic_ops_gpl.la \ - $(top_builddir)/src/libatomic_ops.la - -all: $(BUILT_SOURCES) - $(MAKE) $(AM_MAKEFLAGS) all-am - -.SUFFIXES: -.SUFFIXES: .c .lo .log .o .obj .test .test$(EXEEXT) .trs -$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) - @for dep in $?; do \ - case '$(am__configure_deps)' in \ - *$$dep*) \ - ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ - && { if test -f $@; then exit 0; else break; fi; }; \ - exit 1;; \ - esac; \ - done; \ - echo ' cd $(top_srcdir) && $(AUTOMAKE) --foreign tests/Makefile'; \ - $(am__cd) $(top_srcdir) && \ - $(AUTOMAKE) --foreign tests/Makefile -Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status - @case '$?' in \ - *config.status*) \ - cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ - *) \ - echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ - cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ - esac; - -$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) - cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh - -$(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) - cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh -$(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) - cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh -$(am__aclocal_m4_deps): - -clean-checkPROGRAMS: - @list='$(check_PROGRAMS)'; test -n "$$list" || exit 0; \ - echo " rm -f" $$list; \ - rm -f $$list || exit $$?; \ - test -n "$(EXEEXT)" || exit 0; \ - list=`for p in $$list; do echo "$$p"; done | sed 's/$(EXEEXT)$$//'`; \ - echo " rm -f" $$list; \ - rm -f $$list - -test_atomic$(EXEEXT): $(test_atomic_OBJECTS) $(test_atomic_DEPENDENCIES) $(EXTRA_test_atomic_DEPENDENCIES) - @rm -f test_atomic$(EXEEXT) - $(AM_V_CCLD)$(LINK) $(test_atomic_OBJECTS) $(test_atomic_LDADD) $(LIBS) - -test_atomic_pthreads$(EXEEXT): $(test_atomic_pthreads_OBJECTS) $(test_atomic_pthreads_DEPENDENCIES) $(EXTRA_test_atomic_pthreads_DEPENDENCIES) - @rm -f test_atomic_pthreads$(EXEEXT) - $(AM_V_CCLD)$(LINK) $(test_atomic_pthreads_OBJECTS) $(test_atomic_pthreads_LDADD) $(LIBS) - -test_malloc$(EXEEXT): $(test_malloc_OBJECTS) $(test_malloc_DEPENDENCIES) $(EXTRA_test_malloc_DEPENDENCIES) - @rm -f test_malloc$(EXEEXT) - $(AM_V_CCLD)$(LINK) $(test_malloc_OBJECTS) $(test_malloc_LDADD) $(LIBS) - -test_stack$(EXEEXT): $(test_stack_OBJECTS) $(test_stack_DEPENDENCIES) $(EXTRA_test_stack_DEPENDENCIES) - @rm -f test_stack$(EXEEXT) - $(AM_V_CCLD)$(LINK) $(test_stack_OBJECTS) $(test_stack_LDADD) $(LIBS) - -mostlyclean-compile: - -rm -f *.$(OBJEXT) - -distclean-compile: - -rm -f *.tab.c - -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/test_atomic.Po@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/test_atomic_pthreads-test_atomic.Po@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/test_malloc.Po@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/test_stack.Po@am__quote@ - -.c.o: -@am__fastdepCC_TRUE@ $(AM_V_CC)$(COMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ $< -@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Po -@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ -@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(COMPILE) -c -o $@ $< - -.c.obj: -@am__fastdepCC_TRUE@ $(AM_V_CC)$(COMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ `$(CYGPATH_W) '$<'` -@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Po -@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ -@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(COMPILE) -c -o $@ `$(CYGPATH_W) '$<'` - -.c.lo: -@am__fastdepCC_TRUE@ $(AM_V_CC)$(LTCOMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ $< -@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Plo -@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$<' object='$@' libtool=yes @AMDEPBACKSLASH@ -@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LTCOMPILE) -c -o $@ $< - -test_atomic_pthreads-test_atomic.o: test_atomic.c -@am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(test_atomic_pthreads_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT test_atomic_pthreads-test_atomic.o -MD -MP -MF $(DEPDIR)/test_atomic_pthreads-test_atomic.Tpo -c -o test_atomic_pthreads-test_atomic.o `test -f 'test_atomic.c' || echo '$(srcdir)/'`test_atomic.c -@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/test_atomic_pthreads-test_atomic.Tpo $(DEPDIR)/test_atomic_pthreads-test_atomic.Po -@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='test_atomic.c' object='test_atomic_pthreads-test_atomic.o' libtool=no @AMDEPBACKSLASH@ -@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(test_atomic_pthreads_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o test_atomic_pthreads-test_atomic.o `test -f 'test_atomic.c' || echo '$(srcdir)/'`test_atomic.c - -test_atomic_pthreads-test_atomic.obj: test_atomic.c -@am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(test_atomic_pthreads_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT test_atomic_pthreads-test_atomic.obj -MD -MP -MF $(DEPDIR)/test_atomic_pthreads-test_atomic.Tpo -c -o test_atomic_pthreads-test_atomic.obj `if test -f 'test_atomic.c'; then $(CYGPATH_W) 'test_atomic.c'; else $(CYGPATH_W) '$(srcdir)/test_atomic.c'; fi` -@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/test_atomic_pthreads-test_atomic.Tpo $(DEPDIR)/test_atomic_pthreads-test_atomic.Po -@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='test_atomic.c' object='test_atomic_pthreads-test_atomic.obj' libtool=no @AMDEPBACKSLASH@ -@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(test_atomic_pthreads_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o test_atomic_pthreads-test_atomic.obj `if test -f 'test_atomic.c'; then $(CYGPATH_W) 'test_atomic.c'; else $(CYGPATH_W) '$(srcdir)/test_atomic.c'; fi` - -mostlyclean-libtool: - -rm -f *.lo - -clean-libtool: - -rm -rf .libs _libs - -ID: $(am__tagged_files) - $(am__define_uniq_tagged_files); mkid -fID $$unique -tags: tags-am -TAGS: tags - -tags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) - set x; \ - here=`pwd`; \ - $(am__define_uniq_tagged_files); \ - shift; \ - if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \ - test -n "$$unique" || unique=$$empty_fix; \ - if test $$# -gt 0; then \ - $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ - "$$@" $$unique; \ - else \ - $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ - $$unique; \ - fi; \ - fi -ctags: ctags-am - -CTAGS: ctags -ctags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) - $(am__define_uniq_tagged_files); \ - test -z "$(CTAGS_ARGS)$$unique" \ - || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ - $$unique - -GTAGS: - here=`$(am__cd) $(top_builddir) && pwd` \ - && $(am__cd) $(top_srcdir) \ - && gtags -i $(GTAGS_ARGS) "$$here" -cscopelist: cscopelist-am - -cscopelist-am: $(am__tagged_files) - list='$(am__tagged_files)'; \ - case "$(srcdir)" in \ - [\\/]* | ?:[\\/]*) sdir="$(srcdir)" ;; \ - *) sdir=$(subdir)/$(srcdir) ;; \ - esac; \ - for i in $$list; do \ - if test -f "$$i"; then \ - echo "$(subdir)/$$i"; \ - else \ - echo "$$sdir/$$i"; \ - fi; \ - done >> $(top_builddir)/cscope.files - -distclean-tags: - -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags - -# Recover from deleted '.trs' file; this should ensure that -# "rm -f foo.log; make foo.trs" re-run 'foo.test', and re-create -# both 'foo.log' and 'foo.trs'. Break the recipe in two subshells -# to avoid problems with "make -n". -.log.trs: - rm -f $< $@ - $(MAKE) $(AM_MAKEFLAGS) $< - -# Leading 'am--fnord' is there to ensure the list of targets does not -# expand to empty, as could happen e.g. with make check TESTS=''. -am--fnord $(TEST_LOGS) $(TEST_LOGS:.log=.trs): $(am__force_recheck) -am--force-recheck: - @: - -$(TEST_SUITE_LOG): $(TEST_LOGS) - @$(am__set_TESTS_bases); \ - am__f_ok () { test -f "$$1" && test -r "$$1"; }; \ - redo_bases=`for i in $$bases; do \ - am__f_ok $$i.trs && am__f_ok $$i.log || echo $$i; \ - done`; \ - if test -n "$$redo_bases"; then \ - redo_logs=`for i in $$redo_bases; do echo $$i.log; done`; \ - redo_results=`for i in $$redo_bases; do echo $$i.trs; done`; \ - if $(am__make_dryrun); then :; else \ - rm -f $$redo_logs && rm -f $$redo_results || exit 1; \ - fi; \ - fi; \ - if test -n "$$am__remaking_logs"; then \ - echo "fatal: making $(TEST_SUITE_LOG): possible infinite" \ - "recursion detected" >&2; \ - elif test -n "$$redo_logs"; then \ - am__remaking_logs=yes $(MAKE) $(AM_MAKEFLAGS) $$redo_logs; \ - fi; \ - if $(am__make_dryrun); then :; else \ - st=0; \ - errmsg="fatal: making $(TEST_SUITE_LOG): failed to create"; \ - for i in $$redo_bases; do \ - test -f $$i.trs && test -r $$i.trs \ - || { echo "$$errmsg $$i.trs" >&2; st=1; }; \ - test -f $$i.log && test -r $$i.log \ - || { echo "$$errmsg $$i.log" >&2; st=1; }; \ - done; \ - test $$st -eq 0 || exit 1; \ - fi - @$(am__sh_e_setup); $(am__tty_colors); $(am__set_TESTS_bases); \ - ws='[ ]'; \ - results=`for b in $$bases; do echo $$b.trs; done`; \ - test -n "$$results" || results=/dev/null; \ - all=` grep "^$$ws*:test-result:" $$results | wc -l`; \ - pass=` grep "^$$ws*:test-result:$$ws*PASS" $$results | wc -l`; \ - fail=` grep "^$$ws*:test-result:$$ws*FAIL" $$results | wc -l`; \ - skip=` grep "^$$ws*:test-result:$$ws*SKIP" $$results | wc -l`; \ - xfail=`grep "^$$ws*:test-result:$$ws*XFAIL" $$results | wc -l`; \ - xpass=`grep "^$$ws*:test-result:$$ws*XPASS" $$results | wc -l`; \ - error=`grep "^$$ws*:test-result:$$ws*ERROR" $$results | wc -l`; \ - if test `expr $$fail + $$xpass + $$error` -eq 0; then \ - success=true; \ - else \ - success=false; \ - fi; \ - br='==================='; br=$$br$$br$$br$$br; \ - result_count () \ - { \ - if test x"$$1" = x"--maybe-color"; then \ - maybe_colorize=yes; \ - elif test x"$$1" = x"--no-color"; then \ - maybe_colorize=no; \ - else \ - echo "$@: invalid 'result_count' usage" >&2; exit 4; \ - fi; \ - shift; \ - desc=$$1 count=$$2; \ - if test $$maybe_colorize = yes && test $$count -gt 0; then \ - color_start=$$3 color_end=$$std; \ - else \ - color_start= color_end=; \ - fi; \ - echo "$${color_start}# $$desc $$count$${color_end}"; \ - }; \ - create_testsuite_report () \ - { \ - result_count $$1 "TOTAL:" $$all "$$brg"; \ - result_count $$1 "PASS: " $$pass "$$grn"; \ - result_count $$1 "SKIP: " $$skip "$$blu"; \ - result_count $$1 "XFAIL:" $$xfail "$$lgn"; \ - result_count $$1 "FAIL: " $$fail "$$red"; \ - result_count $$1 "XPASS:" $$xpass "$$red"; \ - result_count $$1 "ERROR:" $$error "$$mgn"; \ - }; \ - { \ - echo "$(PACKAGE_STRING): $(subdir)/$(TEST_SUITE_LOG)" | \ - $(am__rst_title); \ - create_testsuite_report --no-color; \ - echo; \ - echo ".. contents:: :depth: 2"; \ - echo; \ - for b in $$bases; do echo $$b; done \ - | $(am__create_global_log); \ - } >$(TEST_SUITE_LOG).tmp || exit 1; \ - mv $(TEST_SUITE_LOG).tmp $(TEST_SUITE_LOG); \ - if $$success; then \ - col="$$grn"; \ - else \ - col="$$red"; \ - test x"$$VERBOSE" = x || cat $(TEST_SUITE_LOG); \ - fi; \ - echo "$${col}$$br$${std}"; \ - echo "$${col}Testsuite summary for $(PACKAGE_STRING)$${std}"; \ - echo "$${col}$$br$${std}"; \ - create_testsuite_report --maybe-color; \ - echo "$$col$$br$$std"; \ - if $$success; then :; else \ - echo "$${col}See $(subdir)/$(TEST_SUITE_LOG)$${std}"; \ - if test -n "$(PACKAGE_BUGREPORT)"; then \ - echo "$${col}Please report to $(PACKAGE_BUGREPORT)$${std}"; \ - fi; \ - echo "$$col$$br$$std"; \ - fi; \ - $$success || exit 1 - -check-TESTS: - @list='$(RECHECK_LOGS)'; test -z "$$list" || rm -f $$list - @list='$(RECHECK_LOGS:.log=.trs)'; test -z "$$list" || rm -f $$list - @test -z "$(TEST_SUITE_LOG)" || rm -f $(TEST_SUITE_LOG) - @set +e; $(am__set_TESTS_bases); \ - log_list=`for i in $$bases; do echo $$i.log; done`; \ - trs_list=`for i in $$bases; do echo $$i.trs; done`; \ - log_list=`echo $$log_list`; trs_list=`echo $$trs_list`; \ - $(MAKE) $(AM_MAKEFLAGS) $(TEST_SUITE_LOG) TEST_LOGS="$$log_list"; \ - exit $$?; -recheck: all $(check_PROGRAMS) - @test -z "$(TEST_SUITE_LOG)" || rm -f $(TEST_SUITE_LOG) - @set +e; $(am__set_TESTS_bases); \ - bases=`for i in $$bases; do echo $$i; done \ - | $(am__list_recheck_tests)` || exit 1; \ - log_list=`for i in $$bases; do echo $$i.log; done`; \ - log_list=`echo $$log_list`; \ - $(MAKE) $(AM_MAKEFLAGS) $(TEST_SUITE_LOG) \ - am__force_recheck=am--force-recheck \ - TEST_LOGS="$$log_list"; \ - exit $$? -test_atomic.log: test_atomic$(EXEEXT) - @p='test_atomic$(EXEEXT)'; \ - b='test_atomic'; \ - $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ - --log-file $$b.log --trs-file $$b.trs \ - $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ - "$$tst" $(AM_TESTS_FD_REDIRECT) -test_stack.log: test_stack$(EXEEXT) - @p='test_stack$(EXEEXT)'; \ - b='test_stack'; \ - $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ - --log-file $$b.log --trs-file $$b.trs \ - $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ - "$$tst" $(AM_TESTS_FD_REDIRECT) -test_malloc.log: test_malloc$(EXEEXT) - @p='test_malloc$(EXEEXT)'; \ - b='test_malloc'; \ - $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ - --log-file $$b.log --trs-file $$b.trs \ - $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ - "$$tst" $(AM_TESTS_FD_REDIRECT) -test_atomic_pthreads.log: test_atomic_pthreads$(EXEEXT) - @p='test_atomic_pthreads$(EXEEXT)'; \ - b='test_atomic_pthreads'; \ - $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ - --log-file $$b.log --trs-file $$b.trs \ - $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ - "$$tst" $(AM_TESTS_FD_REDIRECT) -.test.log: - @p='$<'; \ - $(am__set_b); \ - $(am__check_pre) $(TEST_LOG_DRIVER) --test-name "$$f" \ - --log-file $$b.log --trs-file $$b.trs \ - $(am__common_driver_flags) $(AM_TEST_LOG_DRIVER_FLAGS) $(TEST_LOG_DRIVER_FLAGS) -- $(TEST_LOG_COMPILE) \ - "$$tst" $(AM_TESTS_FD_REDIRECT) -@am__EXEEXT_TRUE@.test$(EXEEXT).log: -@am__EXEEXT_TRUE@ @p='$<'; \ -@am__EXEEXT_TRUE@ $(am__set_b); \ -@am__EXEEXT_TRUE@ $(am__check_pre) $(TEST_LOG_DRIVER) --test-name "$$f" \ -@am__EXEEXT_TRUE@ --log-file $$b.log --trs-file $$b.trs \ -@am__EXEEXT_TRUE@ $(am__common_driver_flags) $(AM_TEST_LOG_DRIVER_FLAGS) $(TEST_LOG_DRIVER_FLAGS) -- $(TEST_LOG_COMPILE) \ -@am__EXEEXT_TRUE@ "$$tst" $(AM_TESTS_FD_REDIRECT) - -distdir: $(DISTFILES) - @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ - topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ - list='$(DISTFILES)'; \ - dist_files=`for file in $$list; do echo $$file; done | \ - sed -e "s|^$$srcdirstrip/||;t" \ - -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ - case $$dist_files in \ - */*) $(MKDIR_P) `echo "$$dist_files" | \ - sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ - sort -u` ;; \ - esac; \ - for file in $$dist_files; do \ - if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ - if test -d $$d/$$file; then \ - dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ - if test -d "$(distdir)/$$file"; then \ - find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ - fi; \ - if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ - cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ - find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ - fi; \ - cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ - else \ - test -f "$(distdir)/$$file" \ - || cp -p $$d/$$file "$(distdir)/$$file" \ - || exit 1; \ - fi; \ - done -check-am: all-am - $(MAKE) $(AM_MAKEFLAGS) $(check_PROGRAMS) - $(MAKE) $(AM_MAKEFLAGS) check-TESTS -check: $(BUILT_SOURCES) - $(MAKE) $(AM_MAKEFLAGS) check-am -all-am: Makefile -installdirs: -install: $(BUILT_SOURCES) - $(MAKE) $(AM_MAKEFLAGS) install-am -install-exec: install-exec-am -install-data: install-data-am -uninstall: uninstall-am - -install-am: all-am - @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am - -installcheck: installcheck-am -install-strip: - if test -z '$(STRIP)'; then \ - $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ - install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ - install; \ - else \ - $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ - install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ - "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ - fi -mostlyclean-generic: - -test -z "$(TEST_LOGS)" || rm -f $(TEST_LOGS) - -test -z "$(TEST_LOGS:.log=.trs)" || rm -f $(TEST_LOGS:.log=.trs) - -test -z "$(TEST_SUITE_LOG)" || rm -f $(TEST_SUITE_LOG) - -clean-generic: - -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES) - -distclean-generic: - -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) - -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) - -maintainer-clean-generic: - @echo "This command is intended for maintainers to use" - @echo "it deletes files that may require special tools to rebuild." - -test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES) -clean: clean-am - -clean-am: clean-checkPROGRAMS clean-generic clean-libtool \ - mostlyclean-am - -distclean: distclean-am - -rm -rf ./$(DEPDIR) - -rm -f Makefile -distclean-am: clean-am distclean-compile distclean-generic \ - distclean-tags - -dvi: dvi-am - -dvi-am: - -html: html-am - -html-am: - -info: info-am - -info-am: - -install-data-am: - -install-dvi: install-dvi-am - -install-dvi-am: - -install-exec-am: - -install-html: install-html-am - -install-html-am: - -install-info: install-info-am - -install-info-am: - -install-man: - -install-pdf: install-pdf-am - -install-pdf-am: - -install-ps: install-ps-am - -install-ps-am: - -installcheck-am: - -maintainer-clean: maintainer-clean-am - -rm -rf ./$(DEPDIR) - -rm -f Makefile -maintainer-clean-am: distclean-am maintainer-clean-generic - -mostlyclean: mostlyclean-am - -mostlyclean-am: mostlyclean-compile mostlyclean-generic \ - mostlyclean-libtool - -pdf: pdf-am - -pdf-am: - -ps: ps-am - -ps-am: - -uninstall-am: - -.MAKE: all check check-am install install-am install-strip - -.PHONY: CTAGS GTAGS TAGS all all-am check check-TESTS check-am clean \ - clean-checkPROGRAMS clean-generic clean-libtool cscopelist-am \ - ctags ctags-am distclean distclean-compile distclean-generic \ - distclean-libtool distclean-tags distdir dvi dvi-am html \ - html-am info info-am install install-am install-data \ - install-data-am install-dvi install-dvi-am install-exec \ - install-exec-am install-html install-html-am install-info \ - install-info-am install-man install-pdf install-pdf-am \ - install-ps install-ps-am install-strip installcheck \ - installcheck-am installdirs maintainer-clean \ - maintainer-clean-generic mostlyclean mostlyclean-compile \ - mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \ - recheck tags tags-am uninstall uninstall-am - -.PRECIOUS: Makefile - - -test_atomic_include.h: test_atomic_include.template - mkdir -p `dirname $@` - sed -e s:XX::g $? > $@ - sed -e s:XX:_release:g $? >> $@ - sed -e s:XX:_acquire:g $? >> $@ - sed -e s:XX:_read:g $? >> $@ - sed -e s:XX:_write:g $? >> $@ - sed -e s:XX:_full:g $? >> $@ - sed -e s:XX:_release_write:g $? >> $@ - sed -e s:XX:_acquire_read:g $? >> $@ - -list_atomic.c: list_atomic.template - mkdir -p `dirname $@` - echo "#include \"atomic_ops.h\"" > $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g -e s:XX::g $? >> $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g -e s:XX:_release:g $? >> $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g -e s:XX:_acquire:g $? >> $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g -e s:XX:_read:g $? >> $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g -e s:XX:_write:g $? >> $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g -e s:XX:_full:g $? >> $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g -e s:XX:_release_write:g $? >> $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g -e s:XX:_acquire_read:g $? >> $@ - sed -e s:XSIZE_::g -e s:XCTYPE:AO_t:g -e s:XX:_dd_acquire_read:g $? >> $@ - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g -e s:XX::g $? >> $@ - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g -e s:XX:_release:g $? >> $@ - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g -e s:XX:_acquire:g $? >> $@ - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g -e s:XX:_read:g $? >> $@ - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g -e s:XX:_write:g $? >> $@ - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g -e s:XX:_full:g $? >> $@ - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g -e s:XX:_release_write:g $? >> $@ - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g -e s:XX:_acquire_read:g $? >> $@ - sed -e s:XSIZE:char:g -e s:XCTYPE:unsigned/**/char:g -e s:XX:_dd_acquire_read:g $? >> $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g -e s:XX::g $? >> $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g -e s:XX:_release:g $? >> $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g -e s:XX:_acquire:g $? >> $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g -e s:XX:_read:g $? >> $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g -e s:XX:_write:g $? >> $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g -e s:XX:_full:g $? >> $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g -e s:XX:_release_write:g $? >> $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g -e s:XX:_acquire_read:g $? >> $@ - sed -e s:XSIZE:short:g -e s:XCTYPE:unsigned/**/short:g -e s:XX:_dd_acquire_read:g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g -e s:XX::g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g -e s:XX:_release:g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g -e s:XX:_acquire:g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g -e s:XX:_read:g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g -e s:XX:_write:g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g -e s:XX:_full:g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g -e s:XX:_release_write:g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g -e s:XX:_acquire_read:g $? >> $@ - sed -e s:XSIZE:int:g -e s:XCTYPE:unsigned:g -e s:XX:_dd_acquire_read:g $? >> $@ - sed -e s:XSIZE:double:g -e s:XCTYPE:AO_double_t:g -e s:XX::g $? >> $@ - sed -e s:XSIZE:double:g -e s:XCTYPE:AO_double_t:g -e s:XX:_release:g $? >> $@ - sed -e s:XSIZE:double:g -e s:XCTYPE:AO_double_t:g -e s:XX:_acquire:g $? >> $@ - sed -e s:XSIZE:double:g -e s:XCTYPE:AO_double_t:g -e s:XX:_read:g $? >> $@ - sed -e s:XSIZE:double:g -e s:XCTYPE:AO_double_t:g -e s:XX:_write:g $? >> $@ - sed -e s:XSIZE:double:g -e s:XCTYPE:AO_double_t:g -e s:XX:_full:g $? >> $@ - sed -e s:XSIZE:double:g -e s:XCTYPE:AO_double_t:g -e s:XX:_release_write:g $? >> $@ - sed -e s:XSIZE:double:g -e s:XCTYPE:AO_double_t:g -e s:XX:_acquire_read:g $? >> $@ - sed -e s:XSIZE:double:g -e s:XCTYPE:AO_double_t:g -e s:XX:_dd_acquire_read:g $? >> $@ - -list_atomic.i: list_atomic.c - mkdir -p `dirname $@` - $(COMPILE) $? -E > $@ - -# Verify list_atomic.c syntax: -list_atomic.o: list_atomic.c - $(COMPILE) -c -o $@ $? - -# Tell versions [3.59,3.63) of GNU make to not export all variables. -# Otherwise a system limit (for SysV at least) may be exceeded. -.NOEXPORT: diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/tests/run_parallel.h ecl-16.1.3+ds/src/bdwgc/libatomic_ops/tests/run_parallel.h --- ecl-16.1.2/src/bdwgc/libatomic_ops/tests/run_parallel.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/tests/run_parallel.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,212 +0,0 @@ -/* - * Copyright (c) 2003-2005 Hewlett-Packard Development Company, L.P. - * - * This file is covered by the GNU general public license, version 2. - * see COPYING for details. - */ - -#if defined(_MSC_VER) || \ - defined(_WIN32) && !defined(__CYGWIN32__) && !defined(__CYGWIN__) || \ - defined(_WIN32_WINCE) -# define USE_WINTHREADS -#elif defined(__vxworks) -# define USE_VXTHREADS -#else -# define USE_PTHREADS -#endif - -#include -#include - -#ifdef USE_PTHREADS -# include -#endif - -#ifdef USE_VXTHREADS -# include -# include -#endif - -#ifdef USE_WINTHREADS -# include -#endif - -#include "atomic_ops.h" - -#if (defined(_WIN32_WCE) || defined(__MINGW32CE__)) && !defined(abort) -# define abort() _exit(-1) /* there is no abort() in WinCE */ -#endif - -#ifndef _WIN64 -# define AO_PTRDIFF_T long -#elif defined(__int64) -# define AO_PTRDIFF_T __int64 -#else -# define AO_PTRDIFF_T long long -#endif - -typedef void * (* thr_func)(void *); - -typedef int (* test_func)(void); /* Returns != 0 on success */ - -void * run_parallel(int nthreads, thr_func f1, test_func t, const char *name); - -#ifdef USE_PTHREADS -void * run_parallel(int nthreads, thr_func f1, test_func t, const char *name) -{ - pthread_attr_t attr; - pthread_t thr[100]; - int i; - int code; - - printf("Testing %s\n", name); - if (nthreads > 100) - { - fprintf(stderr, "run_parallel: requested too many threads\n"); - abort(); - } - -# ifdef _HPUX_SOURCE - /* Default stack size is too small, especially with the 64 bit ABI */ - /* Increase it. */ - if (pthread_default_stacksize_np(1024*1024, 0) != 0) - { - fprintf(stderr, "pthread_default_stacksize_np failed. " - "OK after first call.\n"); - } -# endif - - pthread_attr_init(&attr); - - for (i = 0; i < nthreads; ++i) - { - if ((code = pthread_create(thr + i, &attr, f1, (void *)(long)i)) != 0) - { - fprintf(stderr, "pthread_create returned %d, thread %d\n", code, i); - abort(); - } - } - for (i = 0; i < nthreads; ++i) - { - if ((code = pthread_join(thr[i], NULL)) != 0) - { - fprintf(stderr, "pthread_join returned %d, thread %d\n", code, i); - abort(); - } - } - if (t()) - { - printf("Succeeded\n"); - } - else - { - fprintf(stderr, "Failed\n"); - abort(); - } - return 0; -} -#endif /* USE_PTHREADS */ - -#ifdef USE_VXTHREADS -void * run_parallel(int nthreads, thr_func f1, test_func t, const char *name) -{ - int thr[100]; - int i; - - printf("Testing %s\n", name); - if (nthreads > 100) - { - fprintf(stderr, "run_parallel: requested too many threads\n"); - taskSuspend(0); - } - - for (i = 0; i < nthreads; ++i) - { - thr[i] = taskSpawn((char*) name, 180, 0, 32768, (FUNCPTR) f1, i, - 1, 2, 3, 4, 5, 6, 7, 8, 9); - if (thr[i] == ERROR) - { - fprintf(stderr, "taskSpawn failed with %d, thread %d\n", - errno, i); - taskSuspend(0); - } - } - for (i = 0; i < nthreads; ++i) - { - while (taskIdVerify(thr[i]) == OK) - taskDelay(60); - } - if (t()) - { - printf("Succeeded\n"); - } - else - { - fprintf(stderr, "Failed\n"); - taskSuspend(0); - } - return 0; -} -#endif /* USE_VXTHREADS */ - -#ifdef USE_WINTHREADS - -struct tramp_args { - thr_func fn; - long arg; -}; - -DWORD WINAPI tramp(LPVOID param) -{ - struct tramp_args *args = (struct tramp_args *)param; - - return (DWORD)(AO_PTRDIFF_T)(*args->fn)((LPVOID)(AO_PTRDIFF_T)args->arg); -} - -void * run_parallel(int nthreads, thr_func f1, test_func t, const char *name) -{ - HANDLE thr[100]; - struct tramp_args args[100]; - int i; - DWORD code; - - printf("Testing %s\n", name); - if (nthreads > 100) - { - fprintf(stderr, "run_parallel: requested too many threads\n"); - abort(); - } - - for (i = 0; i < nthreads; ++i) - { - args[i].fn = f1; - args[i].arg = i; - if ((thr[i] = CreateThread(NULL, 0, tramp, (LPVOID)(args+i), 0, NULL)) - == NULL) - { - fprintf(stderr, "CreateThread failed with %lu, thread %d\n", - (unsigned long)GetLastError(), i); - abort(); - } - } - for (i = 0; i < nthreads; ++i) - { - if ((code = WaitForSingleObject(thr[i], INFINITE)) != WAIT_OBJECT_0) - { - fprintf(stderr, "WaitForSingleObject returned %lu, thread %d\n", - (unsigned long)code, i); - abort(); - } - } - if (t()) - { - printf("Succeeded\n"); - } - else - { - fprintf(stderr, "Failed\n"); - abort(); - } - return 0; -} -#endif /* USE_WINTHREADS */ diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/tests/test_atomic.c ecl-16.1.3+ds/src/bdwgc/libatomic_ops/tests/test_atomic.c --- ecl-16.1.2/src/bdwgc/libatomic_ops/tests/test_atomic.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/tests/test_atomic.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,204 +0,0 @@ -/* - * Copyright (c) 2003-2005 Hewlett-Packard Development Company, L.P. - * - * This file may be redistributed and/or modified 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. - * - * It 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 in the - * file COPYING for more details. - */ - -#if defined(HAVE_CONFIG_H) -# include "config.h" -#endif - -#if defined(AO_NO_PTHREADS) && defined(AO_USE_PTHREAD_DEFS) -# include - - int main(void) - { - printf("test skipped\n"); - return 0; - } - -#else - -#include "run_parallel.h" - -#include "test_atomic_include.h" - -#ifdef AO_USE_PTHREAD_DEFS -# define NITERS 100000 -#else -# define NITERS 10000000 -#endif - -void * add1sub1_thr(void * id); -int add1sub1_test(void); -void * acqrel_thr(void *id); -int acqrel_test(void); -void * test_and_set_thr(void * id); -int test_and_set_test(void); - -#if defined(AO_HAVE_fetch_and_add1) && defined(AO_HAVE_fetch_and_sub1) - -AO_t counter = 0; - -void * add1sub1_thr(void * id) -{ - int me = (int)(AO_PTRDIFF_T)id; - - int i; - - for (i = 0; i < NITERS; ++i) - if ((me & 1) != 0) { - (void)AO_fetch_and_sub1(&counter); - } else { - (void)AO_fetch_and_add1(&counter); - } - return 0; -} - -int add1sub1_test(void) -{ - return counter == 0; -} - -#endif /* defined(AO_HAVE_fetch_and_add1) && defined(AO_HAVE_fetch_and_sub1) */ - -#if defined(AO_HAVE_store_release_write) && defined(AO_HAVE_load_acquire_read) - -/* Invariant: counter1 >= counter2 */ -AO_t counter1 = 0; -AO_t counter2 = 0; - -void * acqrel_thr(void *id) -{ - int me = (int)(AO_PTRDIFF_T)id; - - int i; - - for (i = 0; i < NITERS; ++i) - if (me & 1) - { - AO_t my_counter1; - if (me != 1) - { - fprintf(stderr, "acqrel test: too many threads\n"); - abort(); - } - my_counter1 = AO_load(&counter1); - AO_store(&counter1, my_counter1 + 1); - AO_store_release_write(&counter2, my_counter1 + 1); - } - else - { - AO_t my_counter1a, my_counter2a; - AO_t my_counter1b, my_counter2b; - - my_counter2a = AO_load_acquire_read(&counter2); - my_counter1a = AO_load(&counter1); - /* Redo this, to make sure that the second load of counter1 */ - /* is not viewed as a common subexpression. */ - my_counter2b = AO_load_acquire_read(&counter2); - my_counter1b = AO_load(&counter1); - if (my_counter1a < my_counter2a) - { - fprintf(stderr, "Saw release store out of order: %lu < %lu\n", - (unsigned long)my_counter1a, (unsigned long)my_counter2a); - abort(); - } - if (my_counter1b < my_counter2b) - { - fprintf(stderr, - "Saw release store out of order (bad CSE?): %lu < %lu\n", - (unsigned long)my_counter1b, (unsigned long)my_counter2b); - abort(); - } - } - - return 0; -} - -int acqrel_test(void) -{ - return counter1 == NITERS && counter2 == NITERS; -} - -#endif /* AO_HAVE_store_release_write && AO_HAVE_load_acquire_read */ - -#if defined(AO_HAVE_test_and_set_acquire) - -AO_TS_t lock = AO_TS_INITIALIZER; - -unsigned long locked_counter; -volatile unsigned long junk = 13; - -void * test_and_set_thr(void * id) -{ - unsigned long i; - - for (i = 0; i < NITERS/10; ++i) - { - while (AO_test_and_set_acquire(&lock) != AO_TS_CLEAR); - ++locked_counter; - if (locked_counter != 1) - { - fprintf(stderr, "Test and set failure 1, counter = %ld, id = %d\n", - (long)locked_counter, (int)(AO_PTRDIFF_T)id); - abort(); - } - locked_counter *= 2; - locked_counter -= 1; - locked_counter *= 5; - locked_counter -= 4; - if (locked_counter != 1) - { - fprintf(stderr, "Test and set failure 2, counter = %ld, id = %d\n", - (long)locked_counter, (int)(AO_PTRDIFF_T)id); - abort(); - } - --locked_counter; - AO_CLEAR(&lock); - /* Spend a bit of time outside the lock. */ - junk *= 17; - junk *= 17; - } - return 0; -} - -int test_and_set_test(void) -{ - return locked_counter == 0; -} - -#endif /* defined(AO_HAVE_test_and_set_acquire) */ - -int main(void) -{ - test_atomic(); - test_atomic_acquire(); - test_atomic_release(); - test_atomic_read(); - test_atomic_write(); - test_atomic_full(); - test_atomic_release_write(); - test_atomic_acquire_read(); -# if defined(AO_HAVE_fetch_and_add1) && defined(AO_HAVE_fetch_and_sub1) - run_parallel(4, add1sub1_thr, add1sub1_test, "add1/sub1"); -# endif -# if defined(AO_HAVE_store_release_write) && defined(AO_HAVE_load_acquire_read) - run_parallel(3, acqrel_thr, acqrel_test, - "store_release_write/load_acquire_read"); -# endif -# if defined(AO_HAVE_test_and_set_acquire) - run_parallel(5, test_and_set_thr, test_and_set_test, - "test_and_set"); -# endif - return 0; -} - -#endif /* !AO_NO_PTHREADS || !AO_USE_PTHREAD_DEFS */ diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/tests/test_atomic_include.template ecl-16.1.3+ds/src/bdwgc/libatomic_ops/tests/test_atomic_include.template --- ecl-16.1.2/src/bdwgc/libatomic_ops/tests/test_atomic_include.template 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/tests/test_atomic_include.template 1970-01-01 00:00:00.000000000 +0000 @@ -1,351 +0,0 @@ -/* - * Copyright (c) 2003 by Hewlett-Packard Company. All rights reserved. - * - * This file is covered by the GNU general public license, version 2. - * see COPYING for details. - */ - -/* Some basic sanity tests. These do not test the barrier semantics. */ - -#undef TA_assert -#define TA_assert(e) \ - if (!(e)) { fprintf(stderr, "Assertion failed %s:%d (barrier: XX)\n", \ - __FILE__, __LINE__), exit(1); } - -#undef MISSING -#define MISSING(name) \ - printf("Missing: %s\n", #name "XX") - -void test_atomicXX(void) -{ - AO_t x; - unsigned char b; - unsigned short s; - unsigned int zz; -# if defined(AO_HAVE_test_and_setXX) - AO_TS_t z = AO_TS_INITIALIZER; -# endif -# if defined(AO_HAVE_double_compare_and_swapXX) \ - || defined(AO_HAVE_double_loadXX) \ - || defined(AO_HAVE_double_storeXX) - AO_double_t old_w; - AO_double_t new_w; -# endif -# if defined(AO_HAVE_compare_and_swap_doubleXX) \ - || defined(AO_HAVE_compare_double_and_swap_doubleXX) \ - || defined(AO_HAVE_double_compare_and_swapXX) - AO_double_t w; - w.AO_val1 = 0; - w.AO_val2 = 0; -# endif - -# if defined(AO_HAVE_nopXX) - AO_nopXX(); -# elif !defined(AO_HAVE_nop) || !defined(AO_HAVE_nop_full) \ - || !defined(AO_HAVE_nop_read) || !defined(AO_HAVE_nop_write) - MISSING(AO_nop); -# endif -# if defined(AO_HAVE_storeXX) - AO_storeXX(&x, 13); - TA_assert (x == 13); -# else -# if !defined(AO_HAVE_store) || !defined(AO_HAVE_store_full) \ - || !defined(AO_HAVE_store_release) \ - || !defined(AO_HAVE_store_release_write) \ - || !defined(AO_HAVE_store_write) - MISSING(AO_store); -# endif - x = 13; -# endif -# if defined(AO_HAVE_loadXX) - TA_assert(AO_loadXX(&x) == 13); -# elif !defined(AO_HAVE_load) || !defined(AO_HAVE_load_acquire) \ - || !defined(AO_HAVE_load_acquire_read) \ - || !defined(AO_HAVE_load_dd_acquire_read) \ - || !defined(AO_HAVE_load_full) || !defined(AO_HAVE_load_read) - MISSING(AO_load); -# endif -# if defined(AO_HAVE_test_and_setXX) - assert(AO_test_and_setXX(&z) == AO_TS_CLEAR); - assert(AO_test_and_setXX(&z) == AO_TS_SET); - assert(AO_test_and_setXX(&z) == AO_TS_SET); - AO_CLEAR(&z); -# else - MISSING(AO_test_and_set); -# endif -# if defined(AO_HAVE_fetch_and_addXX) - TA_assert(AO_fetch_and_addXX(&x, 42) == 13); - TA_assert(AO_fetch_and_addXX(&x, (AO_t)(-42)) == 55); -# else - MISSING(AO_fetch_and_add); -# endif -# if defined(AO_HAVE_fetch_and_add1XX) - TA_assert(AO_fetch_and_add1XX(&x) == 13); -# else - MISSING(AO_fetch_and_add1); - ++x; -# endif -# if defined(AO_HAVE_fetch_and_sub1XX) - TA_assert(AO_fetch_and_sub1XX(&x) == 14); -# else - MISSING(AO_fetch_and_sub1); - --x; -# endif -# if defined(AO_HAVE_short_storeXX) - AO_short_storeXX(&s, 13); -# else -# if !defined(AO_HAVE_short_store) || !defined(AO_HAVE_short_store_full) \ - || !defined(AO_HAVE_short_store_release) \ - || !defined(AO_HAVE_short_store_release_write) \ - || !defined(AO_HAVE_short_store_write) - MISSING(AO_short_store); -# endif - s = 13; -# endif -# if defined(AO_HAVE_short_loadXX) - TA_assert(AO_short_load(&s) == 13); -# elif !defined(AO_HAVE_short_load) || !defined(AO_HAVE_short_load_acquire) \ - || !defined(AO_HAVE_short_load_acquire_read) \ - || !defined(AO_HAVE_short_load_dd_acquire_read) \ - || !defined(AO_HAVE_short_load_full) \ - || !defined(AO_HAVE_short_load_read) - MISSING(AO_short_load); -# endif -# if defined(AO_HAVE_short_fetch_and_addXX) - TA_assert(AO_short_fetch_and_addXX(&s, 42) == 13); - TA_assert(AO_short_fetch_and_addXX(&s, (unsigned short)-42) == 55); -# else - MISSING(AO_short_fetch_and_add); -# endif -# if defined(AO_HAVE_short_fetch_and_add1XX) - TA_assert(AO_short_fetch_and_add1XX(&s) == 13); -# else - MISSING(AO_short_fetch_and_add1); - ++s; -# endif -# if defined(AO_HAVE_short_fetch_and_sub1XX) - TA_assert(AO_short_fetch_and_sub1XX(&s) == 14); -# else - MISSING(AO_short_fetch_and_sub1); - --s; -# endif -# if defined(AO_HAVE_char_storeXX) - AO_char_storeXX(&b, 13); -# else -# if !defined(AO_HAVE_char_store) || !defined(AO_HAVE_char_store_full) \ - || !defined(AO_HAVE_char_store_release) \ - || !defined(AO_HAVE_char_store_release_write) \ - || !defined(AO_HAVE_char_store_write) - MISSING(AO_char_store); -# endif - b = 13; -# endif -# if defined(AO_HAVE_char_loadXX) - TA_assert(AO_char_load(&b) == 13); -# elif !defined(AO_HAVE_char_load) || !defined(AO_HAVE_char_load_acquire) \ - || !defined(AO_HAVE_char_load_acquire_read) \ - || !defined(AO_HAVE_char_load_dd_acquire_read) \ - || !defined(AO_HAVE_char_load_full) || !defined(AO_HAVE_char_load_read) - MISSING(AO_char_load); -# endif -# if defined(AO_HAVE_char_fetch_and_addXX) - TA_assert(AO_char_fetch_and_addXX(&b, 42) == 13); - TA_assert(AO_char_fetch_and_addXX(&b, (unsigned char)-42) == 55); -# else - MISSING(AO_char_fetch_and_add); -# endif -# if defined(AO_HAVE_char_fetch_and_add1XX) - TA_assert(AO_char_fetch_and_add1XX(&b) == 13); -# else - MISSING(AO_char_fetch_and_add1); - ++b; -# endif -# if defined(AO_HAVE_char_fetch_and_sub1XX) - TA_assert(AO_char_fetch_and_sub1XX(&b) == 14); -# else - MISSING(AO_char_fetch_and_sub1); - --b; -# endif -# if defined(AO_HAVE_int_storeXX) - AO_int_storeXX(&zz, 13); -# else -# if !defined(AO_HAVE_int_store) || !defined(AO_HAVE_int_store_full) \ - || !defined(AO_HAVE_int_store_release) \ - || !defined(AO_HAVE_int_store_release_write) \ - || !defined(AO_HAVE_int_store_write) - MISSING(AO_int_store); -# endif - zz = 13; -# endif -# if defined(AO_HAVE_int_loadXX) - TA_assert(AO_int_load(&zz) == 13); -# elif !defined(AO_HAVE_int_load) || !defined(AO_HAVE_int_load_acquire) \ - || !defined(AO_HAVE_int_load_acquire_read) \ - || !defined(AO_HAVE_int_load_dd_acquire_read) \ - || !defined(AO_HAVE_int_load_full) || !defined(AO_HAVE_int_load_read) - MISSING(AO_int_load); -# endif -# if defined(AO_HAVE_int_fetch_and_addXX) - TA_assert(AO_int_fetch_and_addXX(&zz, 42) == 13); - TA_assert(AO_int_fetch_and_addXX(&zz, (unsigned int)-42) == 55); -# else - MISSING(AO_int_fetch_and_add); -# endif -# if defined(AO_HAVE_int_fetch_and_add1XX) - TA_assert(AO_int_fetch_and_add1XX(&zz) == 13); -# else - MISSING(AO_int_fetch_and_add1); - ++zz; -# endif -# if defined(AO_HAVE_int_fetch_and_sub1XX) - TA_assert(AO_int_fetch_and_sub1XX(&zz) == 14); -# else - MISSING(AO_int_fetch_and_sub1); - --zz; -# endif -# if defined(AO_HAVE_compare_and_swapXX) - TA_assert(!AO_compare_and_swapXX(&x, 14, 42)); - TA_assert(x == 13); - TA_assert(AO_compare_and_swapXX(&x, 13, 42)); - TA_assert(x == 42); -# else - MISSING(AO_compare_and_swap); - if (x == 13) x = 42; -# endif -# if defined(AO_HAVE_orXX) - AO_orXX(&x, 66); - TA_assert(x == 106); -# else - MISSING(AO_or); - x |= 66; -# endif -# if defined(AO_HAVE_xorXX) - AO_xorXX(&x, 181); - TA_assert(x == 223); -# else - MISSING(AO_xor); - x ^= 181; -# endif -# if defined(AO_HAVE_andXX) - AO_andXX(&x, 57); - TA_assert(x == 25); -# else - MISSING(AO_and); - x &= 57; -# endif -# if defined(AO_HAVE_fetch_compare_and_swapXX) - TA_assert(AO_fetch_compare_and_swapXX(&x, 14, 117) == 25); - TA_assert(x == 25); - TA_assert(AO_fetch_compare_and_swapXX(&x, 25, 117) == 25); - TA_assert(x == 117); -# else - MISSING(AO_fetch_compare_and_swap); - if (x == 25) x = 117; -# endif -# if defined(AO_HAVE_double_loadXX) - old_w.AO_val1 = 3316; - old_w.AO_val2 = 2921; - new_w = AO_double_loadXX(&old_w); - TA_assert(new_w.AO_val1 == 3316 && new_w.AO_val2 == 2921); -# elif !defined(AO_HAVE_double_load) \ - || !defined(AO_HAVE_double_load_acquire) \ - || !defined(AO_HAVE_double_load_acquire_read) \ - || !defined(AO_HAVE_double_load_dd_acquire_read) \ - || !defined(AO_HAVE_double_load_full) \ - || !defined(AO_HAVE_double_load_read) - MISSING(AO_double_load); -# endif -# if defined(AO_HAVE_double_storeXX) - new_w.AO_val1 = 1375; - new_w.AO_val2 = 8243; - AO_double_storeXX(&old_w, new_w); - TA_assert(old_w.AO_val1 == 1375 && old_w.AO_val2 == 8243); - AO_double_storeXX(&old_w, new_w); - TA_assert(old_w.AO_val1 == 1375 && old_w.AO_val2 == 8243); - new_w.AO_val1 ^= old_w.AO_val1; - new_w.AO_val2 ^= old_w.AO_val2; - AO_double_storeXX(&old_w, new_w); - TA_assert(old_w.AO_val1 == 0 && old_w.AO_val2 == 0); -# elif !defined(AO_HAVE_double_store) \ - || !defined(AO_HAVE_double_store_full) \ - || !defined(AO_HAVE_double_store_release) \ - || !defined(AO_HAVE_double_store_release_write) \ - || !defined(AO_HAVE_double_store_write) - MISSING(AO_double_store); -# endif -# if defined(AO_HAVE_compare_double_and_swap_doubleXX) - TA_assert(!AO_compare_double_and_swap_doubleXX(&w, 17, 42, 12, 13)); - TA_assert(w.AO_val1 == 0 && w.AO_val2 == 0); - TA_assert(AO_compare_double_and_swap_doubleXX(&w, 0, 0, 12, 13)); - TA_assert(w.AO_val1 == 12 && w.AO_val2 == 13); - TA_assert(!AO_compare_double_and_swap_doubleXX(&w, 12, 14, 64, 33)); - TA_assert(w.AO_val1 == 12 && w.AO_val2 == 13); - TA_assert(!AO_compare_double_and_swap_doubleXX(&w, 11, 13, 85, 82)); - TA_assert(w.AO_val1 == 12 && w.AO_val2 == 13); - TA_assert(!AO_compare_double_and_swap_doubleXX(&w, 13, 12, 17, 42)); - TA_assert(w.AO_val1 == 12 && w.AO_val2 == 13); - TA_assert(AO_compare_double_and_swap_doubleXX(&w, 12, 13, 17, 42)); - TA_assert(w.AO_val1 == 17 && w.AO_val2 == 42); - TA_assert(AO_compare_double_and_swap_doubleXX(&w, 17, 42, 0, 0)); - TA_assert(w.AO_val1 == 0 && w.AO_val2 == 0); -# else - MISSING(AO_compare_double_and_swap_double); -# endif -# if defined(AO_HAVE_compare_and_swap_doubleXX) - TA_assert(!AO_compare_and_swap_doubleXX(&w, 17, 12, 13)); - TA_assert(w.AO_val1 == 0 && w.AO_val2 == 0); - TA_assert(AO_compare_and_swap_doubleXX(&w, 0, 12, 13)); - TA_assert(w.AO_val1 == 12 && w.AO_val2 == 13); - TA_assert(!AO_compare_and_swap_doubleXX(&w, 13, 12, 33)); - TA_assert(w.AO_val1 == 12 && w.AO_val2 == 13); - TA_assert(!AO_compare_and_swap_doubleXX(&w, 1213, 48, 86)); - TA_assert(w.AO_val1 == 12 && w.AO_val2 == 13); - TA_assert(AO_compare_and_swap_doubleXX(&w, 12, 17, 42)); - TA_assert(w.AO_val1 == 17 && w.AO_val2 == 42); - TA_assert(AO_compare_and_swap_doubleXX(&w, 17, 0, 0)); - TA_assert(w.AO_val1 == 0 && w.AO_val2 == 0); -# else - MISSING(AO_compare_and_swap_double); -# endif -# if defined(AO_HAVE_double_compare_and_swapXX) - old_w.AO_val1 = 4116; - old_w.AO_val2 = 2121; - new_w.AO_val1 = 8537; - new_w.AO_val2 = 6410; - TA_assert(!AO_double_compare_and_swapXX(&w, old_w, new_w)); - TA_assert(w.AO_val1 == 0 && w.AO_val2 == 0); - TA_assert(AO_double_compare_and_swapXX(&w, w, new_w)); - TA_assert(w.AO_val1 == 8537 && w.AO_val2 == 6410); - old_w.AO_val1 = new_w.AO_val1; - old_w.AO_val2 = 29; - new_w.AO_val1 = 820; - new_w.AO_val2 = 5917; - TA_assert(!AO_double_compare_and_swapXX(&w, old_w, new_w)); - TA_assert(w.AO_val1 == 8537 && w.AO_val2 == 6410); - old_w.AO_val1 = 11; - old_w.AO_val2 = 6410; - new_w.AO_val1 = 3552; - new_w.AO_val2 = 1746; - TA_assert(!AO_double_compare_and_swapXX(&w, old_w, new_w)); - TA_assert(w.AO_val1 == 8537 && w.AO_val2 == 6410); - old_w.AO_val1 = old_w.AO_val2; - old_w.AO_val2 = 8537; - new_w.AO_val1 = 4116; - new_w.AO_val2 = 2121; - TA_assert(!AO_double_compare_and_swapXX(&w, old_w, new_w)); - TA_assert(w.AO_val1 == 8537 && w.AO_val2 == 6410); - old_w.AO_val1 = old_w.AO_val2; - old_w.AO_val2 = 6410; - new_w.AO_val1 = 1; - TA_assert(AO_double_compare_and_swapXX(&w, old_w, new_w)); - TA_assert(w.AO_val1 == 1 && w.AO_val2 == 2121); - old_w.AO_val1 = new_w.AO_val1; - old_w.AO_val2 = w.AO_val2; - new_w.AO_val1--; - new_w.AO_val2 = 0; - TA_assert(AO_double_compare_and_swapXX(&w, old_w, new_w)); - TA_assert(w.AO_val1 == 0 && w.AO_val2 == 0); -# else - MISSING(AO_double_compare_and_swap); -# endif -} diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/tests/test_malloc.c ecl-16.1.3+ds/src/bdwgc/libatomic_ops/tests/test_malloc.c --- ecl-16.1.2/src/bdwgc/libatomic_ops/tests/test_malloc.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/tests/test_malloc.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,228 +0,0 @@ -/* - * Copyright (c) 2005 Hewlett-Packard Development Company, L.P. - * - * This file may be redistributed and/or modified 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. - * - * It 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 in the - * file COPYING for more details. - */ - -#if defined(HAVE_CONFIG_H) -# include "config.h" -#endif - -#include "run_parallel.h" - -#include -#include -#include "atomic_ops_malloc.h" - -#ifndef MAX_NTHREADS -# define MAX_NTHREADS 100 -#endif - -#ifndef DEFAULT_NTHREADS -# ifdef HAVE_MMAP -# define DEFAULT_NTHREADS 10 -# else -# define DEFAULT_NTHREADS 3 -# endif -#endif - -#ifndef N_REVERSALS -# ifdef AO_USE_PTHREAD_DEFS -# define N_REVERSALS 4 -# else -# define N_REVERSALS 1000 /* must be even */ -# endif -#endif - -#ifndef LIST_LENGTH -# ifdef HAVE_MMAP -# define LIST_LENGTH 1000 -# else -# define LIST_LENGTH 100 -# endif -#endif - -#ifndef LARGE_OBJ_SIZE -# ifdef HAVE_MMAP -# define LARGE_OBJ_SIZE 200000 -# else -# define LARGE_OBJ_SIZE 20000 -# endif -#endif - -#ifdef USE_STANDARD_MALLOC -# define AO_malloc(n) malloc(n) -# define AO_free(p) free(p) -# define AO_malloc_enable_mmap() -#endif - -typedef struct list_node { - struct list_node *next; - int data; -} ln; - -ln *cons(int d, ln *tail) -{ - static size_t extra = 0; - size_t my_extra = extra; - ln *result; - int * extras; - unsigned i; - - if (my_extra > 100) - extra = my_extra = 0; - else - ++extra; - result = AO_malloc(sizeof(ln) + sizeof(int)*my_extra); - if (result == 0) - { - fprintf(stderr, "Out of memory\n"); - /* Normal for more than about 10 threads without mmap? */ - exit(2); - } - - result -> data = d; - result -> next = tail; - extras = (int *)(result+1); - for (i = 0; i < my_extra; ++i) extras[i] = 42; - return result; -} - -void print_list(ln *l) -{ - ln *p; - - for (p = l; p != 0; p = p -> next) - { - printf("%d, ", p -> data); - } - printf("\n"); -} - -/* Check that l contains numbers from m to n inclusive in ascending order */ -void check_list(ln *l, int m, int n) -{ - ln *p; - int i; - - for (p = l, i = m; p != 0 && i <= n; p = p -> next, ++i) - { - if (i != p -> data) - { - fprintf(stderr, "Found %d, expected %d\n", p -> data, i); - abort(); - } - } - if (i <= n) - { - fprintf(stderr, "Number not found: %d\n", i); - abort(); - } - if (p != 0) - { - fprintf(stderr, "Found unexpected number: %d\n", i); - abort(); - } -} - -/* Create a list of integers from m to n */ -ln * -make_list(int m, int n) -{ - if (m > n) return 0; - return cons(m, make_list(m+1, n)); -} - -/* Reverse list x, and concatenate it to y, deallocating no longer needed */ -/* nodes in x. */ -ln * -reverse(ln *x, ln *y) -{ - ln * result; - - if (x == 0) return y; - result = reverse(x -> next, cons(x -> data, y)); - AO_free(x); - return result; -} - -int dummy_test(void) { return 1; } - -void * run_one_test(void * arg) { - ln * x = make_list(1, LIST_LENGTH); - int i; - char *p = AO_malloc(LARGE_OBJ_SIZE); - char *q; - - if (0 == p) { -# ifdef HAVE_MMAP - fprintf(stderr, "AO_malloc(%d) failed\n", LARGE_OBJ_SIZE); - abort(); -# else - fprintf(stderr, "AO_malloc(%d) failed: This is normal without mmap\n", - LARGE_OBJ_SIZE); -# endif - } else { - p[0] = p[LARGE_OBJ_SIZE/2] = p[LARGE_OBJ_SIZE-1] = 'a'; - q = AO_malloc(LARGE_OBJ_SIZE); - if (q == 0) - { - fprintf(stderr, "Out of memory\n"); - /* Normal for more than about 10 threads without mmap? */ - exit(2); - } - q[0] = q[LARGE_OBJ_SIZE/2] = q[LARGE_OBJ_SIZE-1] = 'b'; - if (p[0] != 'a' || p[LARGE_OBJ_SIZE/2] != 'a' - || p[LARGE_OBJ_SIZE-1] != 'a') { - fprintf(stderr, "First large allocation smashed\n"); - abort(); - } - AO_free(p); - if (q[0] != 'b' || q[LARGE_OBJ_SIZE/2] != 'b' - || q[LARGE_OBJ_SIZE-1] != 'b') { - fprintf(stderr, "Second large allocation smashed\n"); - abort(); - } - AO_free(q); - } -# ifdef DEBUG_RUN_ONE_TEST - x = reverse(x, 0); - print_list(x); - x = reverse(x, 0); - print_list(x); -# endif - for (i = 0; i < N_REVERSALS; ++i) { - x = reverse(x, 0); - } - check_list(x, 1, LIST_LENGTH); - return arg; /* use arg to suppress compiler warning */ -} - -int main(int argc, char **argv) { - int nthreads; - - if (1 == argc) { - nthreads = DEFAULT_NTHREADS; - } else if (2 == argc) { - nthreads = atoi(argv[1]); - if (nthreads < 1 || nthreads > MAX_NTHREADS) { - fprintf(stderr, "Invalid # of threads argument\n"); - exit(1); - } - } else { - fprintf(stderr, "Usage: %s [# of threads]\n", argv[0]); - exit(1); - } - printf("Performing %d reversals of %d element lists in %d threads\n", - N_REVERSALS, LIST_LENGTH, nthreads); - AO_malloc_enable_mmap(); - run_parallel(nthreads, run_one_test, dummy_test, "AO_malloc/AO_free"); - return 0; -} diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/tests/test_stack.c ecl-16.1.3+ds/src/bdwgc/libatomic_ops/tests/test_stack.c --- ecl-16.1.2/src/bdwgc/libatomic_ops/tests/test_stack.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/tests/test_stack.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,329 +0,0 @@ -/* - * Copyright (c) 2005 Hewlett-Packard Development Company, L.P. - * - * This file may be redistributed and/or modified 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. - * - * It 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 in the - * file COPYING for more details. - */ - -#if defined(HAVE_CONFIG_H) -# include "config.h" -#endif - -#include - -#if defined(__vxworks) - - int main(void) - { - printf("test skipped\n"); - return 0; - } - -#else - -#if ((defined(_WIN32) && !defined(__CYGWIN32__) && !defined(__CYGWIN__)) \ - || defined(_MSC_VER) || defined(_WIN32_WINCE)) \ - && !defined(AO_USE_WIN32_PTHREADS) -# define USE_WINTHREADS -#endif - -#ifdef USE_WINTHREADS -# include -#else -# include -#endif - -#include - -#include "atomic_ops_stack.h" /* includes atomic_ops.h as well */ - -#if (defined(_WIN32_WCE) || defined(__MINGW32CE__)) && !defined(abort) -# define abort() _exit(-1) /* there is no abort() in WinCE */ -#endif - -#ifndef MAX_NTHREADS -# define MAX_NTHREADS 100 -#endif - -#ifdef NO_TIMES -# define get_msecs() 0 -#elif defined(USE_WINTHREADS) || defined(AO_USE_WIN32_PTHREADS) -# include - long long get_msecs(void) - { - struct timeb tb; - - ftime(&tb); - return (long long)tb.time * 1000 + tb.millitm; - } -#else /* Unix */ -# include -# include - /* Need 64-bit long long support */ - long long get_msecs(void) - { - struct timeval tv; - - gettimeofday(&tv, 0); - return (long long)tv.tv_sec * 1000 + tv.tv_usec/1000; - } -#endif /* !NO_TIMES */ - -typedef struct le { - AO_t next; - int data; -} list_element; - -AO_stack_t the_list = AO_STACK_INITIALIZER; - -void add_elements(int n) -{ - list_element * le; - if (n == 0) return; - add_elements(n-1); - le = malloc(sizeof(list_element)); - if (le == 0) - { - fprintf(stderr, "Out of memory\n"); - exit(2); - } - le -> data = n; - AO_stack_push(&the_list, (AO_t *)le); -} - -void print_list(void) -{ - list_element *p; - - for (p = (list_element *)AO_REAL_HEAD_PTR(the_list); - p != 0; - p = (list_element *)AO_REAL_NEXT_PTR(p -> next)) - printf("%d\n", p -> data); -} - -static char marks[MAX_NTHREADS * (MAX_NTHREADS + 1) / 2 + 1]; - -void check_list(int n) -{ - list_element *p; - int i; - - for (i = 1; i <= n; ++i) marks[i] = 0; - - for (p = (list_element *)AO_REAL_HEAD_PTR(the_list); - p != 0; - p = (list_element *)AO_REAL_NEXT_PTR(p -> next)) - { - i = p -> data; - if (i > n || i <= 0) - { - fprintf(stderr, "Found erroneous list element %d\n", i); - abort(); - } - if (marks[i] != 0) - { - fprintf(stderr, "Found duplicate list element %d\n", i); - abort(); - } - marks[i] = 1; - } - - for (i = 1; i <= n; ++i) - if (marks[i] != 1) - { - fprintf(stderr, "Missing list element %d\n", i); - abort(); - } -} - -volatile AO_t ops_performed = 0; - -#ifndef LIMIT - /* Total number of push/pop ops in all threads per test. */ -# ifdef AO_USE_PTHREAD_DEFS -# define LIMIT 20000 -# else -# define LIMIT 1000000 -# endif -#endif - -#ifdef AO_HAVE_fetch_and_add -# define fetch_and_add(addr, val) AO_fetch_and_add(addr, val) -#else - /* Fake it. This is really quite unacceptable for timing */ - /* purposes. But as a correctness test, it should be OK. */ - AO_INLINE AO_t fetch_and_add(volatile AO_t * addr, AO_t val) - { - AO_t result = AO_load(addr); - AO_store(addr, result + val); - return result; - } -#endif - -#ifdef USE_WINTHREADS - DWORD WINAPI run_one_test(LPVOID arg) -#else - void * run_one_test(void * arg) -#endif -{ - list_element * t[MAX_NTHREADS + 1]; - int index = (int)(size_t)arg; - int i; -# ifdef VERBOSE - int j = 0; - - printf("starting thread %d\n", index); -# endif - while (fetch_and_add(&ops_performed, index + 1) + index + 1 < LIMIT) - { - for (i = 0; i < index + 1; ++i) - { - t[i] = (list_element *)AO_stack_pop(&the_list); - if (0 == t[i]) - { - fprintf(stderr, "FAILED\n"); - abort(); - } - } - for (i = 0; i < index + 1; ++i) - { - AO_stack_push(&the_list, (AO_t *)t[i]); - } -# ifdef VERBOSE - j += index + 1; -# endif - } -# ifdef VERBOSE - printf("finished thread %d: %d total ops\n", index, j); -# endif - return 0; -} - -#ifndef N_EXPERIMENTS -# define N_EXPERIMENTS 1 -#endif - -unsigned long times[MAX_NTHREADS + 1][N_EXPERIMENTS]; - -int main(int argc, char **argv) -{ - int nthreads; - int max_nthreads; - int exper_n; - - if (1 == argc) - max_nthreads = 4; - else if (2 == argc) - { - max_nthreads = atoi(argv[1]); - if (max_nthreads < 1 || max_nthreads > MAX_NTHREADS) - { - fprintf(stderr, "Invalid max # of threads argument\n"); - exit(1); - } - } - else - { - fprintf(stderr, "Usage: %s [max # of threads]\n", argv[0]); - exit(1); - } - for (exper_n = 0; exper_n < N_EXPERIMENTS; ++ exper_n) - for (nthreads = 1; nthreads <= max_nthreads; ++nthreads) - { - int i; -# ifdef USE_WINTHREADS - DWORD thread_id; - HANDLE thread[MAX_NTHREADS]; -# else - pthread_t thread[MAX_NTHREADS]; -# endif - int list_length = nthreads*(nthreads+1)/2; - long long start_time; - list_element * le; - -# ifdef VERBOSE - printf("Before add_elements: exper_n=%d, nthreads=%d," - " max_nthreads=%d, list_length=%d\n", - exper_n, nthreads, max_nthreads, list_length); -# endif - add_elements(list_length); -# ifdef VERBOSE - printf("Initial list (nthreads = %d):\n", nthreads); - print_list(); -# endif - ops_performed = 0; - start_time = get_msecs(); - for (i = 1; i < nthreads; ++i) { - int code; - -# ifdef USE_WINTHREADS - thread[i] = CreateThread(NULL, 0, run_one_test, (LPVOID)(size_t)i, - 0, &thread_id); - code = thread[i] != NULL ? 0 : (int)GetLastError(); -# else - code = pthread_create(&thread[i], 0, run_one_test, - (void *)(size_t)i); -# endif - if (code != 0) { - fprintf(stderr, "Thread creation failed %u\n", (unsigned)code); - exit(3); - } - } - /* We use the main thread to run one test. This allows gprof */ - /* profiling to work, for example. */ - run_one_test(0); - for (i = 1; i < nthreads; ++i) { - int code; - -# ifdef USE_WINTHREADS - code = WaitForSingleObject(thread[i], INFINITE) == WAIT_OBJECT_0 ? - 0 : (int)GetLastError(); -# else - code = pthread_join(thread[i], 0); -# endif - if (code != 0) { - fprintf(stderr, "Thread join failed %u\n", (unsigned)code); - abort(); - } - } - times[nthreads][exper_n] = (unsigned long)(get_msecs() - start_time); - # ifdef VERBOSE - printf("%d %lu\n", nthreads, - (unsigned long)(get_msecs() - start_time)); - printf("final list (should be reordered initial list):\n"); - print_list(); - # endif - check_list(list_length); - while ((le = (list_element *)AO_stack_pop(&the_list)) != 0) - free(le); - } - for (nthreads = 1; nthreads <= max_nthreads; ++nthreads) - { -# ifndef NO_TIMES - unsigned long sum = 0; -# endif - - printf("About %d pushes + %d pops in %d threads:", - LIMIT, LIMIT, nthreads); -# ifndef NO_TIMES - for (exper_n = 0; exper_n < N_EXPERIMENTS; ++exper_n) { -# if defined(VERBOSE) - printf(" [%lu]", times[nthreads][exper_n]); -# endif - sum += times[nthreads][exper_n]; - } - printf(" %lu msecs\n", (sum + N_EXPERIMENTS/2)/N_EXPERIMENTS); -# else - printf(" completed\n"); -# endif - } - return 0; -} - -#endif diff -Nru ecl-16.1.2/src/bdwgc/libatomic_ops/TODO ecl-16.1.3+ds/src/bdwgc/libatomic_ops/TODO --- ecl-16.1.2/src/bdwgc/libatomic_ops/TODO 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/libatomic_ops/TODO 1970-01-01 00:00:00.000000000 +0000 @@ -1,13 +0,0 @@ -== TODO tasks == - -Add C++0x ATM (atomic memory operations) layer. - - -== FIXME tasks == - -RHELinux6/POWER7 (gcc-4.4.7-3/ppc64), Fedora16/POWER7 (gcc-4.6.2-1/ppc64), -Debian/powerpc (gcc 4.6.3-7): -test_stack failed (Debian Bug #680100). - -Debian/m68k (Linux 3.2.0-2-atari): -test_stack failed (Bus error), regression (Debian Bug #680066). diff -Nru ecl-16.1.2/src/bdwgc/ltmain.sh ecl-16.1.3+ds/src/bdwgc/ltmain.sh --- ecl-16.1.2/src/bdwgc/ltmain.sh 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/ltmain.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,11147 +0,0 @@ -#! /bin/sh -## DO NOT EDIT - This file generated from ./build-aux/ltmain.in -## by inline-source v2014-01-03.01 - -# libtool (GNU libtool) 2.4.6 -# Provide generalized library-building support services. -# Written by Gordon Matzigkeit , 1996 - -# Copyright (C) 1996-2015 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 this program. If not, see . - - -PROGRAM=libtool -PACKAGE=libtool -VERSION=2.4.6 -package_revision=2.4.6 - - -## ------ ## -## Usage. ## -## ------ ## - -# Run './libtool --help' for help with using this script from the -# command line. - - -## ------------------------------- ## -## User overridable command paths. ## -## ------------------------------- ## - -# After configure completes, it has a better idea of some of the -# shell tools we need than the defaults used by the functions shared -# with bootstrap, so set those here where they can still be over- -# ridden by the user, but otherwise take precedence. - -: ${AUTOCONF="autoconf"} -: ${AUTOMAKE="automake"} - - -## -------------------------- ## -## Source external libraries. ## -## -------------------------- ## - -# Much of our low-level functionality needs to be sourced from external -# libraries, which are installed to $pkgauxdir. - -# Set a version string for this script. -scriptversion=2015-01-20.17; # UTC - -# General shell script boiler plate, and helper functions. -# Written by Gary V. Vaughan, 2004 - -# Copyright (C) 2004-2015 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. - -# 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 3 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. - -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNES 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, see . - -# Please report bugs or propose patches to gary@gnu.org. - - -## ------ ## -## Usage. ## -## ------ ## - -# Evaluate this file near the top of your script to gain access to -# the functions and variables defined here: -# -# . `echo "$0" | ${SED-sed} 's|[^/]*$||'`/build-aux/funclib.sh -# -# If you need to override any of the default environment variable -# settings, do that before evaluating this file. - - -## -------------------- ## -## Shell normalisation. ## -## -------------------- ## - -# Some shells need a little help to be as Bourne compatible as possible. -# Before doing anything else, make sure all that help has been provided! - -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 - -# NLS nuisances: We save the old values in case they are required later. -_G_user_locale= -_G_safe_locale= -for _G_var in LANG LANGUAGE LC_ALL LC_CTYPE LC_COLLATE LC_MESSAGES -do - eval "if test set = \"\${$_G_var+set}\"; then - save_$_G_var=\$$_G_var - $_G_var=C - export $_G_var - _G_user_locale=\"$_G_var=\\\$save_\$_G_var; \$_G_user_locale\" - _G_safe_locale=\"$_G_var=C; \$_G_safe_locale\" - fi" -done - -# CDPATH. -(unset CDPATH) >/dev/null 2>&1 && unset CDPATH - -# Make sure IFS has a sensible default -sp=' ' -nl=' -' -IFS="$sp $nl" - -# There are apparently some retarded systems that use ';' as a PATH separator! -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 - - - -## ------------------------- ## -## Locate command utilities. ## -## ------------------------- ## - - -# func_executable_p FILE -# ---------------------- -# Check that FILE is an executable regular file. -func_executable_p () -{ - test -f "$1" && test -x "$1" -} - - -# func_path_progs PROGS_LIST CHECK_FUNC [PATH] -# -------------------------------------------- -# Search for either a program that responds to --version with output -# containing "GNU", or else returned by CHECK_FUNC otherwise, by -# trying all the directories in PATH with each of the elements of -# PROGS_LIST. -# -# CHECK_FUNC should accept the path to a candidate program, and -# set $func_check_prog_result if it truncates its output less than -# $_G_path_prog_max characters. -func_path_progs () -{ - _G_progs_list=$1 - _G_check_func=$2 - _G_PATH=${3-"$PATH"} - - _G_path_prog_max=0 - _G_path_prog_found=false - _G_save_IFS=$IFS; IFS=${PATH_SEPARATOR-:} - for _G_dir in $_G_PATH; do - IFS=$_G_save_IFS - test -z "$_G_dir" && _G_dir=. - for _G_prog_name in $_G_progs_list; do - for _exeext in '' .EXE; do - _G_path_prog=$_G_dir/$_G_prog_name$_exeext - func_executable_p "$_G_path_prog" || continue - case `"$_G_path_prog" --version 2>&1` in - *GNU*) func_path_progs_result=$_G_path_prog _G_path_prog_found=: ;; - *) $_G_check_func $_G_path_prog - func_path_progs_result=$func_check_prog_result - ;; - esac - $_G_path_prog_found && break 3 - done - done - done - IFS=$_G_save_IFS - test -z "$func_path_progs_result" && { - echo "no acceptable sed could be found in \$PATH" >&2 - exit 1 - } -} - - -# We want to be able to use the functions in this file before configure -# has figured out where the best binaries are kept, which means we have -# to search for them ourselves - except when the results are already set -# where we skip the searches. - -# Unless the user overrides by setting SED, search the path for either GNU -# sed, or the sed that truncates its output the least. -test -z "$SED" && { - _G_sed_script=s/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa/bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb/ - for _G_i in 1 2 3 4 5 6 7; do - _G_sed_script=$_G_sed_script$nl$_G_sed_script - done - echo "$_G_sed_script" 2>/dev/null | sed 99q >conftest.sed - _G_sed_script= - - func_check_prog_sed () - { - _G_path_prog=$1 - - _G_count=0 - printf 0123456789 >conftest.in - while : - do - cat conftest.in conftest.in >conftest.tmp - mv conftest.tmp conftest.in - cp conftest.in conftest.nl - echo '' >> conftest.nl - "$_G_path_prog" -f conftest.sed conftest.out 2>/dev/null || break - diff conftest.out conftest.nl >/dev/null 2>&1 || break - _G_count=`expr $_G_count + 1` - if test "$_G_count" -gt "$_G_path_prog_max"; then - # Best one so far, save it but keep looking for a better one - func_check_prog_result=$_G_path_prog - _G_path_prog_max=$_G_count - fi - # 10*(2^10) chars as input seems more than enough - test 10 -lt "$_G_count" && break - done - rm -f conftest.in conftest.tmp conftest.nl conftest.out - } - - func_path_progs "sed gsed" func_check_prog_sed $PATH:/usr/xpg4/bin - rm -f conftest.sed - SED=$func_path_progs_result -} - - -# Unless the user overrides by setting GREP, search the path for either GNU -# grep, or the grep that truncates its output the least. -test -z "$GREP" && { - func_check_prog_grep () - { - _G_path_prog=$1 - - _G_count=0 - _G_path_prog_max=0 - printf 0123456789 >conftest.in - while : - do - cat conftest.in conftest.in >conftest.tmp - mv conftest.tmp conftest.in - cp conftest.in conftest.nl - echo 'GREP' >> conftest.nl - "$_G_path_prog" -e 'GREP$' -e '-(cannot match)-' conftest.out 2>/dev/null || break - diff conftest.out conftest.nl >/dev/null 2>&1 || break - _G_count=`expr $_G_count + 1` - if test "$_G_count" -gt "$_G_path_prog_max"; then - # Best one so far, save it but keep looking for a better one - func_check_prog_result=$_G_path_prog - _G_path_prog_max=$_G_count - fi - # 10*(2^10) chars as input seems more than enough - test 10 -lt "$_G_count" && break - done - rm -f conftest.in conftest.tmp conftest.nl conftest.out - } - - func_path_progs "grep ggrep" func_check_prog_grep $PATH:/usr/xpg4/bin - GREP=$func_path_progs_result -} - - -## ------------------------------- ## -## User overridable command paths. ## -## ------------------------------- ## - -# All uppercase variable names are used for environment variables. These -# variables can be overridden by the user before calling a script that -# uses them if a suitable command of that name is not already available -# in the command search PATH. - -: ${CP="cp -f"} -: ${ECHO="printf %s\n"} -: ${EGREP="$GREP -E"} -: ${FGREP="$GREP -F"} -: ${LN_S="ln -s"} -: ${MAKE="make"} -: ${MKDIR="mkdir"} -: ${MV="mv -f"} -: ${RM="rm -f"} -: ${SHELL="${CONFIG_SHELL-/bin/sh}"} - - -## -------------------- ## -## Useful sed snippets. ## -## -------------------- ## - -sed_dirname='s|/[^/]*$||' -sed_basename='s|^.*/||' - -# 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. -sed_double_quote_subst='s/\(["`\\]\)/\\\1/g' - -# Sed substitution that turns a string into a regex matching for the -# string literally. -sed_make_literal_regex='s|[].[^$\\*\/]|\\&|g' - -# Sed substitution that converts a w32 file name or path -# that contains forward slashes, into one that contains -# (escaped) backslashes. A very naive implementation. -sed_naive_backslashify='s|\\\\*|\\|g;s|/|\\|g;s|\\|\\\\|g' - -# Re-'\' parameter expansions in output of sed_double_quote_subst that -# were '\'-ed in input to the same. If an odd number of '\' preceded a -# '$' in input to sed_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 '$'. -_G_bs='\\' -_G_bs2='\\\\' -_G_bs4='\\\\\\\\' -_G_dollar='\$' -sed_double_backslash="\ - s/$_G_bs4/&\\ -/g - s/^$_G_bs2$_G_dollar/$_G_bs&/ - s/\\([^$_G_bs]\\)$_G_bs2$_G_dollar/\\1$_G_bs2$_G_bs$_G_dollar/g - s/\n//g" - - -## ----------------- ## -## Global variables. ## -## ----------------- ## - -# Except for the global variables explicitly listed below, the following -# functions in the '^func_' namespace, and the '^require_' namespace -# variables initialised in the 'Resource management' section, sourcing -# this file will not pollute your global namespace with anything -# else. There's no portable way to scope variables in Bourne shell -# though, so actually running these functions will sometimes place -# results into a variable named after the function, and often use -# temporary variables in the '^_G_' namespace. If you are careful to -# avoid using those namespaces casually in your sourcing script, things -# should continue to work as you expect. And, of course, you can freely -# overwrite any of the functions or variables defined here before -# calling anything to customize them. - -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. - -# Allow overriding, eg assuming that you follow the convention of -# putting '$debug_cmd' at the start of all your functions, you can get -# bash to show function call trace with: -# -# debug_cmd='eval echo "${FUNCNAME[0]} $*" >&2' bash your-script-name -debug_cmd=${debug_cmd-":"} -exit_cmd=: - -# By convention, finish your script with: -# -# exit $exit_status -# -# so that you can set exit_status to non-zero if you want to indicate -# something went wrong during execution without actually bailing out at -# the point of failure. -exit_status=$EXIT_SUCCESS - -# 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. -progname=`$ECHO "$progpath" |$SED "$sed_basename"` - -# Make sure we have an absolute progpath for reexecution: -case $progpath in - [\\/]*|[A-Za-z]:\\*) ;; - *[\\/]*) - progdir=`$ECHO "$progpath" |$SED "$sed_dirname"` - progdir=`cd "$progdir" && pwd` - progpath=$progdir/$progname - ;; - *) - _G_IFS=$IFS - IFS=${PATH_SEPARATOR-:} - for progdir in $PATH; do - IFS=$_G_IFS - test -x "$progdir/$progname" && break - done - IFS=$_G_IFS - test -n "$progdir" || progdir=`pwd` - progpath=$progdir/$progname - ;; -esac - - -## ----------------- ## -## Standard options. ## -## ----------------- ## - -# The following options affect the operation of the functions defined -# below, and should be set appropriately depending on run-time para- -# meters passed on the command line. - -opt_dry_run=false -opt_quiet=false -opt_verbose=false - -# Categories 'all' and 'none' are always available. Append any others -# you will pass as the first argument to func_warning from your own -# code. -warning_categories= - -# By default, display warnings according to 'opt_warning_types'. Set -# 'warning_func' to ':' to elide all warnings, or func_fatal_error to -# treat the next displayed warning as a fatal error. -warning_func=func_warn_and_continue - -# Set to 'all' to display all warnings, 'none' to suppress all -# warnings, or a space delimited list of some subset of -# 'warning_categories' to display only the listed warnings. -opt_warning_types=all - - -## -------------------- ## -## Resource management. ## -## -------------------- ## - -# This section contains definitions for functions that each ensure a -# particular resource (a file, or a non-empty configuration variable for -# example) is available, and if appropriate to extract default values -# from pertinent package files. Call them using their associated -# 'require_*' variable to ensure that they are executed, at most, once. -# -# It's entirely deliberate that calling these functions can set -# variables that don't obey the namespace limitations obeyed by the rest -# of this file, in order that that they be as useful as possible to -# callers. - - -# require_term_colors -# ------------------- -# Allow display of bold text on terminals that support it. -require_term_colors=func_require_term_colors -func_require_term_colors () -{ - $debug_cmd - - test -t 1 && { - # COLORTERM and USE_ANSI_COLORS environment variables take - # precedence, because most terminfo databases neglect to describe - # whether color sequences are supported. - test -n "${COLORTERM+set}" && : ${USE_ANSI_COLORS="1"} - - if test 1 = "$USE_ANSI_COLORS"; then - # Standard ANSI escape sequences - tc_reset='' - tc_bold=''; tc_standout='' - tc_red=''; tc_green='' - tc_blue=''; tc_cyan='' - else - # Otherwise trust the terminfo database after all. - test -n "`tput sgr0 2>/dev/null`" && { - tc_reset=`tput sgr0` - test -n "`tput bold 2>/dev/null`" && tc_bold=`tput bold` - tc_standout=$tc_bold - test -n "`tput smso 2>/dev/null`" && tc_standout=`tput smso` - test -n "`tput setaf 1 2>/dev/null`" && tc_red=`tput setaf 1` - test -n "`tput setaf 2 2>/dev/null`" && tc_green=`tput setaf 2` - test -n "`tput setaf 4 2>/dev/null`" && tc_blue=`tput setaf 4` - test -n "`tput setaf 5 2>/dev/null`" && tc_cyan=`tput setaf 5` - } - fi - } - - require_term_colors=: -} - - -## ----------------- ## -## Function library. ## -## ----------------- ## - -# This section contains a variety of useful functions to call in your -# scripts. Take note of the portable wrappers for features provided by -# some modern shells, which will fall back to slower equivalents on -# less featureful shells. - - -# func_append VAR VALUE -# --------------------- -# Append VALUE onto the existing contents of VAR. - - # We should try to minimise forks, especially on Windows where they are - # unreasonably slow, so skip the feature probes when bash or zsh are - # being used: - if test set = "${BASH_VERSION+set}${ZSH_VERSION+set}"; then - : ${_G_HAVE_ARITH_OP="yes"} - : ${_G_HAVE_XSI_OPS="yes"} - # The += operator was introduced in bash 3.1 - case $BASH_VERSION in - [12].* | 3.0 | 3.0*) ;; - *) - : ${_G_HAVE_PLUSEQ_OP="yes"} - ;; - esac - fi - - # _G_HAVE_PLUSEQ_OP - # Can be empty, in which case the shell is probed, "yes" if += is - # useable or anything else if it does not work. - test -z "$_G_HAVE_PLUSEQ_OP" \ - && (eval 'x=a; x+=" b"; test "a b" = "$x"') 2>/dev/null \ - && _G_HAVE_PLUSEQ_OP=yes - -if test yes = "$_G_HAVE_PLUSEQ_OP" -then - # This is an XSI compatible shell, allowing a faster implementation... - eval 'func_append () - { - $debug_cmd - - eval "$1+=\$2" - }' -else - # ...otherwise fall back to using expr, which is often a shell builtin. - func_append () - { - $debug_cmd - - eval "$1=\$$1\$2" - } -fi - - -# func_append_quoted VAR VALUE -# ---------------------------- -# Quote VALUE and append to the end of shell variable VAR, separated -# by a space. -if test yes = "$_G_HAVE_PLUSEQ_OP"; then - eval 'func_append_quoted () - { - $debug_cmd - - func_quote_for_eval "$2" - eval "$1+=\\ \$func_quote_for_eval_result" - }' -else - func_append_quoted () - { - $debug_cmd - - func_quote_for_eval "$2" - eval "$1=\$$1\\ \$func_quote_for_eval_result" - } -fi - - -# func_append_uniq VAR VALUE -# -------------------------- -# Append unique VALUE onto the existing contents of VAR, assuming -# entries are delimited by the first character of VALUE. For example: -# -# func_append_uniq options " --another-option option-argument" -# -# will only append to $options if " --another-option option-argument " -# is not already present somewhere in $options already (note spaces at -# each end implied by leading space in second argument). -func_append_uniq () -{ - $debug_cmd - - eval _G_current_value='`$ECHO $'$1'`' - _G_delim=`expr "$2" : '\(.\)'` - - case $_G_delim$_G_current_value$_G_delim in - *"$2$_G_delim"*) ;; - *) func_append "$@" ;; - esac -} - - -# func_arith TERM... -# ------------------ -# Set func_arith_result to the result of evaluating TERMs. - test -z "$_G_HAVE_ARITH_OP" \ - && (eval 'test 2 = $(( 1 + 1 ))') 2>/dev/null \ - && _G_HAVE_ARITH_OP=yes - -if test yes = "$_G_HAVE_ARITH_OP"; then - eval 'func_arith () - { - $debug_cmd - - func_arith_result=$(( $* )) - }' -else - func_arith () - { - $debug_cmd - - func_arith_result=`expr "$@"` - } -fi - - -# func_basename FILE -# ------------------ -# Set func_basename_result to FILE with everything up to and including -# the last / stripped. -if test yes = "$_G_HAVE_XSI_OPS"; then - # If this shell supports suffix pattern removal, then use it to avoid - # forking. Hide the definitions single quotes in case the shell chokes - # on unsupported syntax... - _b='func_basename_result=${1##*/}' - _d='case $1 in - */*) func_dirname_result=${1%/*}$2 ;; - * ) func_dirname_result=$3 ;; - esac' - -else - # ...otherwise fall back to using sed. - _b='func_basename_result=`$ECHO "$1" |$SED "$sed_basename"`' - _d='func_dirname_result=`$ECHO "$1" |$SED "$sed_dirname"` - if test "X$func_dirname_result" = "X$1"; then - func_dirname_result=$3 - else - func_append func_dirname_result "$2" - fi' -fi - -eval 'func_basename () -{ - $debug_cmd - - '"$_b"' -}' - - -# func_dirname FILE APPEND NONDIR_REPLACEMENT -# ------------------------------------------- -# Compute the dirname of FILE. If nonempty, add APPEND to the result, -# otherwise set result to NONDIR_REPLACEMENT. -eval 'func_dirname () -{ - $debug_cmd - - '"$_d"' -}' - - -# 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" -# For efficiency, we do not delegate to the functions above but instead -# duplicate the functionality here. -eval 'func_dirname_and_basename () -{ - $debug_cmd - - '"$_b"' - '"$_d"' -}' - - -# func_echo ARG... -# ---------------- -# Echo program name prefixed message. -func_echo () -{ - $debug_cmd - - _G_message=$* - - func_echo_IFS=$IFS - IFS=$nl - for _G_line in $_G_message; do - IFS=$func_echo_IFS - $ECHO "$progname: $_G_line" - done - IFS=$func_echo_IFS -} - - -# func_echo_all ARG... -# -------------------- -# Invoke $ECHO with all args, space-separated. -func_echo_all () -{ - $ECHO "$*" -} - - -# func_echo_infix_1 INFIX ARG... -# ------------------------------ -# Echo program name, followed by INFIX on the first line, with any -# additional lines not showing INFIX. -func_echo_infix_1 () -{ - $debug_cmd - - $require_term_colors - - _G_infix=$1; shift - _G_indent=$_G_infix - _G_prefix="$progname: $_G_infix: " - _G_message=$* - - # Strip color escape sequences before counting printable length - for _G_tc in "$tc_reset" "$tc_bold" "$tc_standout" "$tc_red" "$tc_green" "$tc_blue" "$tc_cyan" - do - test -n "$_G_tc" && { - _G_esc_tc=`$ECHO "$_G_tc" | $SED "$sed_make_literal_regex"` - _G_indent=`$ECHO "$_G_indent" | $SED "s|$_G_esc_tc||g"` - } - done - _G_indent="$progname: "`echo "$_G_indent" | $SED 's|.| |g'`" " ## exclude from sc_prohibit_nested_quotes - - func_echo_infix_1_IFS=$IFS - IFS=$nl - for _G_line in $_G_message; do - IFS=$func_echo_infix_1_IFS - $ECHO "$_G_prefix$tc_bold$_G_line$tc_reset" >&2 - _G_prefix=$_G_indent - done - IFS=$func_echo_infix_1_IFS -} - - -# func_error ARG... -# ----------------- -# Echo program name prefixed message to standard error. -func_error () -{ - $debug_cmd - - $require_term_colors - - func_echo_infix_1 " $tc_standout${tc_red}error$tc_reset" "$*" >&2 -} - - -# func_fatal_error ARG... -# ----------------------- -# Echo program name prefixed message to standard error, and exit. -func_fatal_error () -{ - $debug_cmd - - func_error "$*" - exit $EXIT_FAILURE -} - - -# func_grep EXPRESSION FILENAME -# ----------------------------- -# Check whether EXPRESSION matches any line of FILENAME, without output. -func_grep () -{ - $debug_cmd - - $GREP "$1" "$2" >/dev/null 2>&1 -} - - -# func_len STRING -# --------------- -# Set func_len_result to the length of STRING. STRING may not -# start with a hyphen. - test -z "$_G_HAVE_XSI_OPS" \ - && (eval 'x=a/b/c; - test 5aa/bb/cc = "${#x}${x%%/*}${x%/*}${x#*/}${x##*/}"') 2>/dev/null \ - && _G_HAVE_XSI_OPS=yes - -if test yes = "$_G_HAVE_XSI_OPS"; then - eval 'func_len () - { - $debug_cmd - - func_len_result=${#1} - }' -else - func_len () - { - $debug_cmd - - func_len_result=`expr "$1" : ".*" 2>/dev/null || echo $max_cmd_len` - } -fi - - -# func_mkdir_p DIRECTORY-PATH -# --------------------------- -# Make sure the entire path to DIRECTORY-PATH is available. -func_mkdir_p () -{ - $debug_cmd - - _G_directory_path=$1 - _G_dir_list= - - if test -n "$_G_directory_path" && test : != "$opt_dry_run"; then - - # Protect directory names starting with '-' - case $_G_directory_path in - -*) _G_directory_path=./$_G_directory_path ;; - esac - - # While some portion of DIR does not yet exist... - while test ! -d "$_G_directory_path"; do - # ...make a list in topmost first order. Use a colon delimited - # list incase some portion of path contains whitespace. - _G_dir_list=$_G_directory_path:$_G_dir_list - - # If the last portion added has no slash in it, the list is done - case $_G_directory_path in */*) ;; *) break ;; esac - - # ...otherwise throw away the child directory and loop - _G_directory_path=`$ECHO "$_G_directory_path" | $SED -e "$sed_dirname"` - done - _G_dir_list=`$ECHO "$_G_dir_list" | $SED 's|:*$||'` - - func_mkdir_p_IFS=$IFS; IFS=: - for _G_dir in $_G_dir_list; do - IFS=$func_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 "$_G_dir" 2>/dev/null || : - done - IFS=$func_mkdir_p_IFS - - # Bail out if we (or some other process) failed to create a directory. - test -d "$_G_directory_path" || \ - func_fatal_error "Failed to create '$1'" - fi -} - - -# func_mktempdir [BASENAME] -# ------------------------- -# Make a temporary directory that won't clash with other running -# libtool processes, and avoids race conditions if possible. If -# given, BASENAME is the basename for that directory. -func_mktempdir () -{ - $debug_cmd - - _G_template=${TMPDIR-/tmp}/${1-$progname} - - if test : = "$opt_dry_run"; then - # Return a directory name, but don't create it in dry-run mode - _G_tmpdir=$_G_template-$$ - else - - # If mktemp works, use that first and foremost - _G_tmpdir=`mktemp -d "$_G_template-XXXXXXXX" 2>/dev/null` - - if test ! -d "$_G_tmpdir"; then - # Failing that, at least try and use $RANDOM to avoid a race - _G_tmpdir=$_G_template-${RANDOM-0}$$ - - func_mktempdir_umask=`umask` - umask 0077 - $MKDIR "$_G_tmpdir" - umask $func_mktempdir_umask - fi - - # If we're not in dry-run mode, bomb out on failure - test -d "$_G_tmpdir" || \ - func_fatal_error "cannot create temporary directory '$_G_tmpdir'" - fi - - $ECHO "$_G_tmpdir" -} - - -# func_normal_abspath PATH -# ------------------------ -# Remove doubled-up and trailing slashes, "." path components, -# and cancel out any ".." path components in PATH after making -# it an absolute path. -func_normal_abspath () -{ - $debug_cmd - - # These SED scripts presuppose an absolute path with a trailing slash. - _G_pathcar='s|^/\([^/]*\).*$|\1|' - _G_pathcdr='s|^/[^/]*||' - _G_removedotparts=':dotsl - s|/\./|/|g - t dotsl - s|/\.$|/|' - _G_collapseslashes='s|/\{1,\}|/|g' - _G_finalslash='s|/*$|/|' - - # Start from root dir and reassemble the path. - func_normal_abspath_result= - func_normal_abspath_tpath=$1 - func_normal_abspath_altnamespace= - case $func_normal_abspath_tpath in - "") - # Empty path, that just means $cwd. - func_stripname '' '/' "`pwd`" - func_normal_abspath_result=$func_stripname_result - return - ;; - # The next three entries are used to spot a run of precisely - # two leading slashes without using negated character classes; - # we take advantage of case's first-match behaviour. - ///*) - # Unusual form of absolute path, do nothing. - ;; - //*) - # Not necessarily an ordinary path; POSIX reserves leading '//' - # and for example Cygwin uses it to access remote file shares - # over CIFS/SMB, so we conserve a leading double slash if found. - func_normal_abspath_altnamespace=/ - ;; - /*) - # Absolute path, do nothing. - ;; - *) - # Relative path, prepend $cwd. - func_normal_abspath_tpath=`pwd`/$func_normal_abspath_tpath - ;; - esac - - # Cancel out all the simple stuff to save iterations. We also want - # the path to end with a slash for ease of parsing, so make sure - # there is one (and only one) here. - func_normal_abspath_tpath=`$ECHO "$func_normal_abspath_tpath" | $SED \ - -e "$_G_removedotparts" -e "$_G_collapseslashes" -e "$_G_finalslash"` - while :; do - # Processed it all yet? - if test / = "$func_normal_abspath_tpath"; then - # If we ascended to the root using ".." the result may be empty now. - if test -z "$func_normal_abspath_result"; then - func_normal_abspath_result=/ - fi - break - fi - func_normal_abspath_tcomponent=`$ECHO "$func_normal_abspath_tpath" | $SED \ - -e "$_G_pathcar"` - func_normal_abspath_tpath=`$ECHO "$func_normal_abspath_tpath" | $SED \ - -e "$_G_pathcdr"` - # Figure out what to do with it - case $func_normal_abspath_tcomponent in - "") - # Trailing empty path component, ignore it. - ;; - ..) - # Parent dir; strip last assembled component from result. - func_dirname "$func_normal_abspath_result" - func_normal_abspath_result=$func_dirname_result - ;; - *) - # Actual path component, append it. - func_append func_normal_abspath_result "/$func_normal_abspath_tcomponent" - ;; - esac - done - # Restore leading double-slash if one was found on entry. - func_normal_abspath_result=$func_normal_abspath_altnamespace$func_normal_abspath_result -} - - -# func_notquiet ARG... -# -------------------- -# Echo program name prefixed message only when not in quiet mode. -func_notquiet () -{ - $debug_cmd - - $opt_quiet || 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_relative_path SRCDIR DSTDIR -# -------------------------------- -# Set func_relative_path_result to the relative path from SRCDIR to DSTDIR. -func_relative_path () -{ - $debug_cmd - - func_relative_path_result= - func_normal_abspath "$1" - func_relative_path_tlibdir=$func_normal_abspath_result - func_normal_abspath "$2" - func_relative_path_tbindir=$func_normal_abspath_result - - # Ascend the tree starting from libdir - while :; do - # check if we have found a prefix of bindir - case $func_relative_path_tbindir in - $func_relative_path_tlibdir) - # found an exact match - func_relative_path_tcancelled= - break - ;; - $func_relative_path_tlibdir*) - # found a matching prefix - func_stripname "$func_relative_path_tlibdir" '' "$func_relative_path_tbindir" - func_relative_path_tcancelled=$func_stripname_result - if test -z "$func_relative_path_result"; then - func_relative_path_result=. - fi - break - ;; - *) - func_dirname $func_relative_path_tlibdir - func_relative_path_tlibdir=$func_dirname_result - if test -z "$func_relative_path_tlibdir"; then - # Have to descend all the way to the root! - func_relative_path_result=../$func_relative_path_result - func_relative_path_tcancelled=$func_relative_path_tbindir - break - fi - func_relative_path_result=../$func_relative_path_result - ;; - esac - done - - # Now calculate path; take care to avoid doubling-up slashes. - func_stripname '' '/' "$func_relative_path_result" - func_relative_path_result=$func_stripname_result - func_stripname '/' '/' "$func_relative_path_tcancelled" - if test -n "$func_stripname_result"; then - func_append func_relative_path_result "/$func_stripname_result" - fi - - # Normalisation. If bindir is libdir, return '.' else relative path. - if test -n "$func_relative_path_result"; then - func_stripname './' '' "$func_relative_path_result" - func_relative_path_result=$func_stripname_result - fi - - test -n "$func_relative_path_result" || func_relative_path_result=. - - : -} - - -# func_quote_for_eval ARG... -# -------------------------- -# Aesthetically quote ARGs to be evaled later. -# This function returns two values: -# i) func_quote_for_eval_result -# double-quoted, suitable for a subsequent eval -# ii) func_quote_for_eval_unquoted_result -# has all characters that are still active within double -# quotes backslashified. -func_quote_for_eval () -{ - $debug_cmd - - func_quote_for_eval_unquoted_result= - func_quote_for_eval_result= - while test 0 -lt $#; do - case $1 in - *[\\\`\"\$]*) - _G_unquoted_arg=`printf '%s\n' "$1" |$SED "$sed_quote_subst"` ;; - *) - _G_unquoted_arg=$1 ;; - esac - if test -n "$func_quote_for_eval_unquoted_result"; then - func_append func_quote_for_eval_unquoted_result " $_G_unquoted_arg" - else - func_append func_quote_for_eval_unquoted_result "$_G_unquoted_arg" - fi - - case $_G_unquoted_arg in - # Double-quote args containing shell metacharacters to delay - # word splitting, command substitution and variable expansion - # for a subsequent eval. - # Many Bourne shells cannot handle close brackets correctly - # in scan sets, so we specify it separately. - *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") - _G_quoted_arg=\"$_G_unquoted_arg\" - ;; - *) - _G_quoted_arg=$_G_unquoted_arg - ;; - esac - - if test -n "$func_quote_for_eval_result"; then - func_append func_quote_for_eval_result " $_G_quoted_arg" - else - func_append func_quote_for_eval_result "$_G_quoted_arg" - fi - shift - done -} - - -# 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 () -{ - $debug_cmd - - case $1 in - *[\\\`\"]*) - _G_arg=`$ECHO "$1" | $SED \ - -e "$sed_double_quote_subst" -e "$sed_double_backslash"` ;; - *) - _G_arg=$1 ;; - esac - - case $_G_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. - *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") - _G_arg=\"$_G_arg\" - ;; - esac - - func_quote_for_expand_result=$_G_arg -} - - -# func_stripname PREFIX SUFFIX NAME -# --------------------------------- -# strip PREFIX and SUFFIX from NAME, and store in func_stripname_result. -# 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). -if test yes = "$_G_HAVE_XSI_OPS"; then - eval 'func_stripname () - { - $debug_cmd - - # pdksh 5.2.14 does not do ${X%$Y} correctly if both X and Y are - # positional parameters, so assign one to ordinary variable first. - func_stripname_result=$3 - func_stripname_result=${func_stripname_result#"$1"} - func_stripname_result=${func_stripname_result%"$2"} - }' -else - func_stripname () - { - $debug_cmd - - case $2 in - .*) func_stripname_result=`$ECHO "$3" | $SED -e "s%^$1%%" -e "s%\\\\$2\$%%"`;; - *) func_stripname_result=`$ECHO "$3" | $SED -e "s%^$1%%" -e "s%$2\$%%"`;; - esac - } -fi - - -# func_show_eval CMD [FAIL_EXP] -# ----------------------------- -# Unless opt_quiet 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 () -{ - $debug_cmd - - _G_cmd=$1 - _G_fail_exp=${2-':'} - - func_quote_for_expand "$_G_cmd" - eval "func_notquiet $func_quote_for_expand_result" - - $opt_dry_run || { - eval "$_G_cmd" - _G_status=$? - if test 0 -ne "$_G_status"; then - eval "(exit $_G_status); $_G_fail_exp" - fi - } -} - - -# func_show_eval_locale CMD [FAIL_EXP] -# ------------------------------------ -# Unless opt_quiet 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 () -{ - $debug_cmd - - _G_cmd=$1 - _G_fail_exp=${2-':'} - - $opt_quiet || { - func_quote_for_expand "$_G_cmd" - eval "func_echo $func_quote_for_expand_result" - } - - $opt_dry_run || { - eval "$_G_user_locale - $_G_cmd" - _G_status=$? - eval "$_G_safe_locale" - if test 0 -ne "$_G_status"; then - eval "(exit $_G_status); $_G_fail_exp" - fi - } -} - - -# func_tr_sh -# ---------- -# Turn $1 into a string suitable for a shell variable name. -# Result is stored in $func_tr_sh_result. All characters -# not in the set a-zA-Z0-9_ are replaced with '_'. Further, -# if $1 begins with a digit, a '_' is prepended as well. -func_tr_sh () -{ - $debug_cmd - - case $1 in - [0-9]* | *[!a-zA-Z0-9_]*) - func_tr_sh_result=`$ECHO "$1" | $SED -e 's/^\([0-9]\)/_\1/' -e 's/[^a-zA-Z0-9_]/_/g'` - ;; - * ) - func_tr_sh_result=$1 - ;; - esac -} - - -# func_verbose ARG... -# ------------------- -# Echo program name prefixed message in verbose mode only. -func_verbose () -{ - $debug_cmd - - $opt_verbose && func_echo "$*" - - : -} - - -# func_warn_and_continue ARG... -# ----------------------------- -# Echo program name prefixed warning message to standard error. -func_warn_and_continue () -{ - $debug_cmd - - $require_term_colors - - func_echo_infix_1 "${tc_red}warning$tc_reset" "$*" >&2 -} - - -# func_warning CATEGORY ARG... -# ---------------------------- -# Echo program name prefixed warning message to standard error. Warning -# messages can be filtered according to CATEGORY, where this function -# elides messages where CATEGORY is not listed in the global variable -# 'opt_warning_types'. -func_warning () -{ - $debug_cmd - - # CATEGORY must be in the warning_categories list! - case " $warning_categories " in - *" $1 "*) ;; - *) func_internal_error "invalid warning category '$1'" ;; - esac - - _G_category=$1 - shift - - case " $opt_warning_types " in - *" $_G_category "*) $warning_func ${1+"$@"} ;; - esac -} - - -# func_sort_ver VER1 VER2 -# ----------------------- -# 'sort -V' is not generally available. -# Note this deviates from the version comparison in automake -# in that it treats 1.5 < 1.5.0, and treats 1.4.4a < 1.4-p3a -# but this should suffice as we won't be specifying old -# version formats or redundant trailing .0 in bootstrap.conf. -# If we did want full compatibility then we should probably -# use m4_version_compare from autoconf. -func_sort_ver () -{ - $debug_cmd - - printf '%s\n%s\n' "$1" "$2" \ - | sort -t. -k 1,1n -k 2,2n -k 3,3n -k 4,4n -k 5,5n -k 6,6n -k 7,7n -k 8,8n -k 9,9n -} - -# func_lt_ver PREV CURR -# --------------------- -# Return true if PREV and CURR are in the correct order according to -# func_sort_ver, otherwise false. Use it like this: -# -# func_lt_ver "$prev_ver" "$proposed_ver" || func_fatal_error "..." -func_lt_ver () -{ - $debug_cmd - - test "x$1" = x`func_sort_ver "$1" "$2" | $SED 1q` -} - - -# Local variables: -# mode: shell-script -# sh-indentation: 2 -# eval: (add-hook 'before-save-hook 'time-stamp) -# time-stamp-pattern: "10/scriptversion=%:y-%02m-%02d.%02H; # UTC" -# time-stamp-time-zone: "UTC" -# End: -#! /bin/sh - -# Set a version string for this script. -scriptversion=2014-01-07.03; # UTC - -# A portable, pluggable option parser for Bourne shell. -# Written by Gary V. Vaughan, 2010 - -# Copyright (C) 2010-2015 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. - -# 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 3 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, see . - -# Please report bugs or propose patches to gary@gnu.org. - - -## ------ ## -## Usage. ## -## ------ ## - -# This file is a library for parsing options in your shell scripts along -# with assorted other useful supporting features that you can make use -# of too. -# -# For the simplest scripts you might need only: -# -# #!/bin/sh -# . relative/path/to/funclib.sh -# . relative/path/to/options-parser -# scriptversion=1.0 -# func_options ${1+"$@"} -# eval set dummy "$func_options_result"; shift -# ...rest of your script... -# -# In order for the '--version' option to work, you will need to have a -# suitably formatted comment like the one at the top of this file -# starting with '# Written by ' and ending with '# warranty; '. -# -# For '-h' and '--help' to work, you will also need a one line -# description of your script's purpose in a comment directly above the -# '# Written by ' line, like the one at the top of this file. -# -# The default options also support '--debug', which will turn on shell -# execution tracing (see the comment above debug_cmd below for another -# use), and '--verbose' and the func_verbose function to allow your script -# to display verbose messages only when your user has specified -# '--verbose'. -# -# After sourcing this file, you can plug processing for additional -# options by amending the variables from the 'Configuration' section -# below, and following the instructions in the 'Option parsing' -# section further down. - -## -------------- ## -## Configuration. ## -## -------------- ## - -# You should override these variables in your script after sourcing this -# file so that they reflect the customisations you have added to the -# option parser. - -# The usage line for option parsing errors and the start of '-h' and -# '--help' output messages. You can embed shell variables for delayed -# expansion at the time the message is displayed, but you will need to -# quote other shell meta-characters carefully to prevent them being -# expanded when the contents are evaled. -usage='$progpath [OPTION]...' - -# Short help message in response to '-h' and '--help'. Add to this or -# override it after sourcing this library to reflect the full set of -# options your script accepts. -usage_message="\ - --debug enable verbose shell tracing - -W, --warnings=CATEGORY - report the warnings falling in CATEGORY [all] - -v, --verbose verbosely report processing - --version print version information and exit - -h, --help print short or long help message and exit -" - -# Additional text appended to 'usage_message' in response to '--help'. -long_help_message=" -Warning categories include: - 'all' show all warnings - 'none' turn off all the warnings - 'error' warnings are treated as fatal errors" - -# Help message printed before fatal option parsing errors. -fatal_help="Try '\$progname --help' for more information." - - - -## ------------------------- ## -## Hook function management. ## -## ------------------------- ## - -# This section contains functions for adding, removing, and running hooks -# to the main code. A hook is just a named list of of function, that can -# be run in order later on. - -# func_hookable FUNC_NAME -# ----------------------- -# Declare that FUNC_NAME will run hooks added with -# 'func_add_hook FUNC_NAME ...'. -func_hookable () -{ - $debug_cmd - - func_append hookable_fns " $1" -} - - -# func_add_hook FUNC_NAME HOOK_FUNC -# --------------------------------- -# Request that FUNC_NAME call HOOK_FUNC before it returns. FUNC_NAME must -# first have been declared "hookable" by a call to 'func_hookable'. -func_add_hook () -{ - $debug_cmd - - case " $hookable_fns " in - *" $1 "*) ;; - *) func_fatal_error "'$1' does not accept hook functions." ;; - esac - - eval func_append ${1}_hooks '" $2"' -} - - -# func_remove_hook FUNC_NAME HOOK_FUNC -# ------------------------------------ -# Remove HOOK_FUNC from the list of functions called by FUNC_NAME. -func_remove_hook () -{ - $debug_cmd - - eval ${1}_hooks='`$ECHO "\$'$1'_hooks" |$SED "s| '$2'||"`' -} - - -# func_run_hooks FUNC_NAME [ARG]... -# --------------------------------- -# Run all hook functions registered to FUNC_NAME. -# It is assumed that the list of hook functions contains nothing more -# than a whitespace-delimited list of legal shell function names, and -# no effort is wasted trying to catch shell meta-characters or preserve -# whitespace. -func_run_hooks () -{ - $debug_cmd - - case " $hookable_fns " in - *" $1 "*) ;; - *) func_fatal_error "'$1' does not support hook funcions.n" ;; - esac - - eval _G_hook_fns=\$$1_hooks; shift - - for _G_hook in $_G_hook_fns; do - eval $_G_hook '"$@"' - - # store returned options list back into positional - # parameters for next 'cmd' execution. - eval _G_hook_result=\$${_G_hook}_result - eval set dummy "$_G_hook_result"; shift - done - - func_quote_for_eval ${1+"$@"} - func_run_hooks_result=$func_quote_for_eval_result -} - - - -## --------------- ## -## Option parsing. ## -## --------------- ## - -# In order to add your own option parsing hooks, you must accept the -# full positional parameter list in your hook function, remove any -# options that you action, and then pass back the remaining unprocessed -# options in '_result', escaped suitably for -# 'eval'. Like this: -# -# my_options_prep () -# { -# $debug_cmd -# -# # Extend the existing usage message. -# usage_message=$usage_message' -# -s, --silent don'\''t print informational messages -# ' -# -# func_quote_for_eval ${1+"$@"} -# my_options_prep_result=$func_quote_for_eval_result -# } -# func_add_hook func_options_prep my_options_prep -# -# -# my_silent_option () -# { -# $debug_cmd -# -# # Note that for efficiency, we parse as many options as we can -# # recognise in a loop before passing the remainder back to the -# # caller on the first unrecognised argument we encounter. -# while test $# -gt 0; do -# opt=$1; shift -# case $opt in -# --silent|-s) opt_silent=: ;; -# # Separate non-argument short options: -# -s*) func_split_short_opt "$_G_opt" -# set dummy "$func_split_short_opt_name" \ -# "-$func_split_short_opt_arg" ${1+"$@"} -# shift -# ;; -# *) set dummy "$_G_opt" "$*"; shift; break ;; -# esac -# done -# -# func_quote_for_eval ${1+"$@"} -# my_silent_option_result=$func_quote_for_eval_result -# } -# func_add_hook func_parse_options my_silent_option -# -# -# my_option_validation () -# { -# $debug_cmd -# -# $opt_silent && $opt_verbose && func_fatal_help "\ -# '--silent' and '--verbose' options are mutually exclusive." -# -# func_quote_for_eval ${1+"$@"} -# my_option_validation_result=$func_quote_for_eval_result -# } -# func_add_hook func_validate_options my_option_validation -# -# You'll alse need to manually amend $usage_message to reflect the extra -# options you parse. It's preferable to append if you can, so that -# multiple option parsing hooks can be added safely. - - -# func_options [ARG]... -# --------------------- -# All the functions called inside func_options are hookable. See the -# individual implementations for details. -func_hookable func_options -func_options () -{ - $debug_cmd - - func_options_prep ${1+"$@"} - eval func_parse_options \ - ${func_options_prep_result+"$func_options_prep_result"} - eval func_validate_options \ - ${func_parse_options_result+"$func_parse_options_result"} - - eval func_run_hooks func_options \ - ${func_validate_options_result+"$func_validate_options_result"} - - # save modified positional parameters for caller - func_options_result=$func_run_hooks_result -} - - -# func_options_prep [ARG]... -# -------------------------- -# All initialisations required before starting the option parse loop. -# Note that when calling hook functions, we pass through the list of -# positional parameters. If a hook function modifies that list, and -# needs to propogate that back to rest of this script, then the complete -# modified list must be put in 'func_run_hooks_result' before -# returning. -func_hookable func_options_prep -func_options_prep () -{ - $debug_cmd - - # Option defaults: - opt_verbose=false - opt_warning_types= - - func_run_hooks func_options_prep ${1+"$@"} - - # save modified positional parameters for caller - func_options_prep_result=$func_run_hooks_result -} - - -# func_parse_options [ARG]... -# --------------------------- -# The main option parsing loop. -func_hookable func_parse_options -func_parse_options () -{ - $debug_cmd - - func_parse_options_result= - - # this just eases exit handling - while test $# -gt 0; do - # Defer to hook functions for initial option parsing, so they - # get priority in the event of reusing an option name. - func_run_hooks func_parse_options ${1+"$@"} - - # Adjust func_parse_options positional parameters to match - eval set dummy "$func_run_hooks_result"; shift - - # Break out of the loop if we already parsed every option. - test $# -gt 0 || break - - _G_opt=$1 - shift - case $_G_opt in - --debug|-x) debug_cmd='set -x' - func_echo "enabling shell trace mode" - $debug_cmd - ;; - - --no-warnings|--no-warning|--no-warn) - set dummy --warnings none ${1+"$@"} - shift - ;; - - --warnings|--warning|-W) - test $# = 0 && func_missing_arg $_G_opt && break - case " $warning_categories $1" in - *" $1 "*) - # trailing space prevents matching last $1 above - func_append_uniq opt_warning_types " $1" - ;; - *all) - opt_warning_types=$warning_categories - ;; - *none) - opt_warning_types=none - warning_func=: - ;; - *error) - opt_warning_types=$warning_categories - warning_func=func_fatal_error - ;; - *) - func_fatal_error \ - "unsupported warning category: '$1'" - ;; - esac - shift - ;; - - --verbose|-v) opt_verbose=: ;; - --version) func_version ;; - -\?|-h) func_usage ;; - --help) func_help ;; - - # Separate optargs to long options (plugins may need this): - --*=*) func_split_equals "$_G_opt" - set dummy "$func_split_equals_lhs" \ - "$func_split_equals_rhs" ${1+"$@"} - shift - ;; - - # Separate optargs to short options: - -W*) - func_split_short_opt "$_G_opt" - set dummy "$func_split_short_opt_name" \ - "$func_split_short_opt_arg" ${1+"$@"} - shift - ;; - - # Separate non-argument short options: - -\?*|-h*|-v*|-x*) - func_split_short_opt "$_G_opt" - set dummy "$func_split_short_opt_name" \ - "-$func_split_short_opt_arg" ${1+"$@"} - shift - ;; - - --) break ;; - -*) func_fatal_help "unrecognised option: '$_G_opt'" ;; - *) set dummy "$_G_opt" ${1+"$@"}; shift; break ;; - esac - done - - # save modified positional parameters for caller - func_quote_for_eval ${1+"$@"} - func_parse_options_result=$func_quote_for_eval_result -} - - -# func_validate_options [ARG]... -# ------------------------------ -# Perform any sanity checks on option settings and/or unconsumed -# arguments. -func_hookable func_validate_options -func_validate_options () -{ - $debug_cmd - - # Display all warnings if -W was not given. - test -n "$opt_warning_types" || opt_warning_types=" $warning_categories" - - func_run_hooks func_validate_options ${1+"$@"} - - # Bail if the options were screwed! - $exit_cmd $EXIT_FAILURE - - # save modified positional parameters for caller - func_validate_options_result=$func_run_hooks_result -} - - - -## ----------------- ## -## Helper functions. ## -## ----------------- ## - -# This section contains the helper functions used by the rest of the -# hookable option parser framework in ascii-betical order. - - -# func_fatal_help ARG... -# ---------------------- -# Echo program name prefixed message to standard error, followed by -# a help hint, and exit. -func_fatal_help () -{ - $debug_cmd - - eval \$ECHO \""Usage: $usage"\" - eval \$ECHO \""$fatal_help"\" - func_error ${1+"$@"} - exit $EXIT_FAILURE -} - - -# func_help -# --------- -# Echo long help message to standard output and exit. -func_help () -{ - $debug_cmd - - func_usage_message - $ECHO "$long_help_message" - exit 0 -} - - -# func_missing_arg ARGNAME -# ------------------------ -# Echo program name prefixed message to standard error and set global -# exit_cmd. -func_missing_arg () -{ - $debug_cmd - - func_error "Missing argument for '$1'." - exit_cmd=exit -} - - -# func_split_equals STRING -# ------------------------ -# Set func_split_equals_lhs and func_split_equals_rhs shell variables after -# splitting STRING at the '=' sign. -test -z "$_G_HAVE_XSI_OPS" \ - && (eval 'x=a/b/c; - test 5aa/bb/cc = "${#x}${x%%/*}${x%/*}${x#*/}${x##*/}"') 2>/dev/null \ - && _G_HAVE_XSI_OPS=yes - -if test yes = "$_G_HAVE_XSI_OPS" -then - # This is an XSI compatible shell, allowing a faster implementation... - eval 'func_split_equals () - { - $debug_cmd - - func_split_equals_lhs=${1%%=*} - func_split_equals_rhs=${1#*=} - test "x$func_split_equals_lhs" = "x$1" \ - && func_split_equals_rhs= - }' -else - # ...otherwise fall back to using expr, which is often a shell builtin. - func_split_equals () - { - $debug_cmd - - func_split_equals_lhs=`expr "x$1" : 'x\([^=]*\)'` - func_split_equals_rhs= - test "x$func_split_equals_lhs" = "x$1" \ - || func_split_equals_rhs=`expr "x$1" : 'x[^=]*=\(.*\)$'` - } -fi #func_split_equals - - -# func_split_short_opt SHORTOPT -# ----------------------------- -# Set func_split_short_opt_name and func_split_short_opt_arg shell -# variables after splitting SHORTOPT after the 2nd character. -if test yes = "$_G_HAVE_XSI_OPS" -then - # This is an XSI compatible shell, allowing a faster implementation... - eval 'func_split_short_opt () - { - $debug_cmd - - func_split_short_opt_arg=${1#??} - func_split_short_opt_name=${1%"$func_split_short_opt_arg"} - }' -else - # ...otherwise fall back to using expr, which is often a shell builtin. - func_split_short_opt () - { - $debug_cmd - - func_split_short_opt_name=`expr "x$1" : 'x-\(.\)'` - func_split_short_opt_arg=`expr "x$1" : 'x-.\(.*\)$'` - } -fi #func_split_short_opt - - -# func_usage -# ---------- -# Echo short help message to standard output and exit. -func_usage () -{ - $debug_cmd - - func_usage_message - $ECHO "Run '$progname --help |${PAGER-more}' for full usage" - exit 0 -} - - -# func_usage_message -# ------------------ -# Echo short help message to standard output. -func_usage_message () -{ - $debug_cmd - - eval \$ECHO \""Usage: $usage"\" - echo - $SED -n 's|^# || - /^Written by/{ - x;p;x - } - h - /^Written by/q' < "$progpath" - echo - eval \$ECHO \""$usage_message"\" -} - - -# func_version -# ------------ -# Echo version message to standard output and exit. -func_version () -{ - $debug_cmd - - printf '%s\n' "$progname $scriptversion" - $SED -n ' - /(C)/!b go - :more - /\./!{ - N - s|\n# | | - b more - } - :go - /^# Written by /,/# warranty; / { - s|^# || - s|^# *$|| - s|\((C)\)[ 0-9,-]*[ ,-]\([1-9][0-9]* \)|\1 \2| - p - } - /^# Written by / { - s|^# || - p - } - /^warranty; /q' < "$progpath" - - exit $? -} - - -# Local variables: -# mode: shell-script -# sh-indentation: 2 -# eval: (add-hook 'before-save-hook 'time-stamp) -# time-stamp-pattern: "10/scriptversion=%:y-%02m-%02d.%02H; # UTC" -# time-stamp-time-zone: "UTC" -# End: - -# Set a version string. -scriptversion='(GNU libtool) 2.4.6' - - -# func_echo ARG... -# ---------------- -# Libtool also displays the current mode in messages, so override -# funclib.sh func_echo with this custom definition. -func_echo () -{ - $debug_cmd - - _G_message=$* - - func_echo_IFS=$IFS - IFS=$nl - for _G_line in $_G_message; do - IFS=$func_echo_IFS - $ECHO "$progname${opt_mode+: $opt_mode}: $_G_line" - done - IFS=$func_echo_IFS -} - - -# func_warning ARG... -# ------------------- -# Libtool warnings are not categorized, so override funclib.sh -# func_warning with this simpler definition. -func_warning () -{ - $debug_cmd - - $warning_func ${1+"$@"} -} - - -## ---------------- ## -## Options parsing. ## -## ---------------- ## - -# Hook in the functions to make sure our own options are parsed during -# the option parsing loop. - -usage='$progpath [OPTION]... [MODE-ARG]...' - -# Short help message in response to '-h'. -usage_message="Options: - --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 - --no-warnings equivalent to '-Wnone' - --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 more informational messages than default - --version print version information - -W, --warnings=CATEGORY report the warnings falling in CATEGORY [all] - -h, --help, --help-all print short, long, or detailed help message -" - -# Additional text appended to 'usage_message' in response to '--help'. -func_help () -{ - $debug_cmd - - func_usage_message - $ECHO "$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. When passed as first option, -'--mode=MODE' may be abbreviated as 'MODE' or a unique abbreviation of that. -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) - version: $progname (GNU libtool) 2.4.6 - automake: `($AUTOMAKE --version) 2>/dev/null |$SED 1q` - autoconf: `($AUTOCONF --version) 2>/dev/null |$SED 1q` - -Report bugs to . -GNU libtool home page: . -General help using GNU software: ." - exit 0 -} - - -# func_lo2o OBJECT-NAME -# --------------------- -# Transform OBJECT-NAME from a '.lo' suffix to the platform specific -# object suffix. - -lo2o=s/\\.lo\$/.$objext/ -o2lo=s/\\.$objext\$/.lo/ - -if test yes = "$_G_HAVE_XSI_OPS"; then - eval 'func_lo2o () - { - case $1 in - *.lo) func_lo2o_result=${1%.lo}.$objext ;; - * ) func_lo2o_result=$1 ;; - esac - }' - - # func_xform LIBOBJ-OR-SOURCE - # --------------------------- - # Transform LIBOBJ-OR-SOURCE from a '.o' or '.c' (or otherwise) - # suffix to a '.lo' libtool-object suffix. - eval 'func_xform () - { - func_xform_result=${1%.*}.lo - }' -else - # ...otherwise fall back to using sed. - func_lo2o () - { - func_lo2o_result=`$ECHO "$1" | $SED "$lo2o"` - } - - func_xform () - { - func_xform_result=`$ECHO "$1" | $SED 's|\.[^.]*$|.lo|'` - } -fi - - -# func_fatal_configuration ARG... -# ------------------------------- -# Echo program name prefixed message to standard error, followed by -# a configuration failure hint, and exit. -func_fatal_configuration () -{ - func__fatal_error ${1+"$@"} \ - "See the $PACKAGE documentation for more information." \ - "Fatal configuration error." -} - - -# func_config -# ----------- -# Display the configuration for all the tags in this script. -func_config () -{ - re_begincf='^# ### BEGIN LIBTOOL' - re_endcf='^# ### END LIBTOOL' - - # Default configuration. - $SED "1,/$re_begincf CONFIG/d;/$re_endcf CONFIG/,\$d" < "$progpath" - - # Now print the configurations for the tags. - for tagname in $taglist; do - $SED -n "/$re_begincf TAG CONFIG: $tagname\$/,/$re_endcf TAG CONFIG: $tagname\$/p" < "$progpath" - done - - exit $? -} - - -# func_features -# ------------- -# Display the features supported by this script. -func_features () -{ - echo "host: $host" - if test yes = "$build_libtool_libs"; then - echo "enable shared libraries" - else - echo "disable shared libraries" - fi - if test yes = "$build_old_libs"; then - echo "enable static libraries" - else - echo "disable static libraries" - fi - - exit $? -} - - -# func_enable_tag TAGNAME -# ----------------------- -# Verify that TAGNAME is valid, and either flag an error and exit, or -# enable the TAGNAME tag. We also add TAGNAME to the global $taglist -# variable here. -func_enable_tag () -{ - # Global variable: - tagname=$1 - - re_begincf="^# ### BEGIN LIBTOOL TAG CONFIG: $tagname\$" - re_endcf="^# ### END LIBTOOL TAG CONFIG: $tagname\$" - sed_extractcf=/$re_begincf/,/$re_endcf/p - - # Validate tagname. - case $tagname in - *[!-_A-Za-z0-9,/]*) - func_fatal_error "invalid tag name: $tagname" - ;; - esac - - # Don't test for the "default" C tag, as we know it's - # there but not specially marked. - case $tagname in - CC) ;; - *) - if $GREP "$re_begincf" "$progpath" >/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 -} - - -# 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 -} - - -# libtool_options_prep [ARG]... -# ----------------------------- -# Preparation for options parsed by libtool. -libtool_options_prep () -{ - $debug_mode - - # Option defaults: - opt_config=false - opt_dlopen= - opt_dry_run=false - opt_help=false - opt_mode= - opt_preserve_dup_deps=false - opt_quiet=false - - nonopt= - preserve_args= - - # 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 - - # Pass back the list of options. - func_quote_for_eval ${1+"$@"} - libtool_options_prep_result=$func_quote_for_eval_result -} -func_add_hook func_options_prep libtool_options_prep - - -# libtool_parse_options [ARG]... -# --------------------------------- -# Provide handling for libtool specific options. -libtool_parse_options () -{ - $debug_cmd - - # Perform our own loop to consume as many options as possible in - # each iteration. - while test $# -gt 0; do - _G_opt=$1 - shift - case $_G_opt in - --dry-run|--dryrun|-n) - opt_dry_run=: - ;; - - --config) func_config ;; - - --dlopen|-dlopen) - opt_dlopen="${opt_dlopen+$opt_dlopen -}$1" - shift - ;; - - --preserve-dup-deps) - opt_preserve_dup_deps=: ;; - - --features) func_features ;; - - --finish) set dummy --mode finish ${1+"$@"}; shift ;; - - --help) opt_help=: ;; - - --help-all) opt_help=': help-all' ;; - - --mode) test $# = 0 && func_missing_arg $_G_opt && break - opt_mode=$1 - 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 $_G_opt" - exit_cmd=exit - break - ;; - esac - shift - ;; - - --no-silent|--no-quiet) - opt_quiet=false - func_append preserve_args " $_G_opt" - ;; - - --no-warnings|--no-warning|--no-warn) - opt_warning=false - func_append preserve_args " $_G_opt" - ;; - - --no-verbose) - opt_verbose=false - func_append preserve_args " $_G_opt" - ;; - - --silent|--quiet) - opt_quiet=: - opt_verbose=false - func_append preserve_args " $_G_opt" - ;; - - --tag) test $# = 0 && func_missing_arg $_G_opt && break - opt_tag=$1 - func_append preserve_args " $_G_opt $1" - func_enable_tag "$1" - shift - ;; - - --verbose|-v) opt_quiet=false - opt_verbose=: - func_append preserve_args " $_G_opt" - ;; - - # An option not handled by this hook function: - *) set dummy "$_G_opt" ${1+"$@"}; shift; break ;; - esac - done - - - # save modified positional parameters for caller - func_quote_for_eval ${1+"$@"} - libtool_parse_options_result=$func_quote_for_eval_result -} -func_add_hook func_parse_options libtool_parse_options - - - -# libtool_validate_options [ARG]... -# --------------------------------- -# Perform any sanity checks on option settings and/or unconsumed -# arguments. -libtool_validate_options () -{ - # save first non-option argument - if test 0 -lt $#; then - nonopt=$1 - shift - fi - - # preserve --debug - test : = "$debug_cmd" || func_append preserve_args " --debug" - - case $host in - # Solaris2 added to fix http://debbugs.gnu.org/cgi/bugreport.cgi?bug=16452 - # see also: http://gcc.gnu.org/bugzilla/show_bug.cgi?id=59788 - *cygwin* | *mingw* | *pw32* | *cegcc* | *solaris2* | *os2*) - # don't eliminate duplications in $postdeps and $predeps - opt_duplicate_compiler_generated_deps=: - ;; - *) - opt_duplicate_compiler_generated_deps=$opt_preserve_dup_deps - ;; - esac - - $opt_help || { - # Sanity checks first: - func_check_version_match - - test yes != "$build_libtool_libs" \ - && test yes != "$build_old_libs" \ - && func_fatal_configuration "not configured to build any kind of library" - - # Darwin sucks - eval std_shrext=\"$shrext_cmds\" - - # Only execute mode is allowed to have -dlopen flags. - if test -n "$opt_dlopen" && test execute != "$opt_mode"; 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=$opt_mode' for more information." - } - - # Pass back the unparsed argument list - func_quote_for_eval ${1+"$@"} - libtool_validate_options_result=$func_quote_for_eval_result -} -func_add_hook func_validate_options libtool_validate_options - - -# Process options as early as possible so that --help and --version -# can return quickly. -func_options ${1+"$@"} -eval set dummy "$func_options_result"; shift - - - -## ----------- ## -## Main. ## -## ----------- ## - -magic='%%%MAGIC variable%%%' -magic_exe='%%%MAGIC EXE variable%%%' - -# Global variables. -extracted_archives= -extracted_serial=0 - -# If this variable is set in any of the actions, the command in it -# will be execed at the end. This prevents here-documents from being -# left over by shells. -exec_cmd= - - -# A function that is used when there is no print builtin or printf. -func_fallback_echo () -{ - eval 'cat <<_LTECHO_EOF -$1 -_LTECHO_EOF' -} - -# func_generated_by_libtool -# True iff stdin has been generated by Libtool. This function is only -# a basic sanity check; it will hardly flush out determined imposters. -func_generated_by_libtool_p () -{ - $GREP "^# Generated by .*$PACKAGE" > /dev/null 2>&1 -} - -# 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 | func_generated_by_libtool_p -} - -# 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 yes = "$lalib_p" -} - -# 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 () -{ - test -f "$1" && - $lt_truncate_bin < "$1" 2>/dev/null | func_generated_by_libtool_p -} - -# 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_dirname_and_basename "$1" "" "." - func_stripname '' '.exe' "$func_basename_result" - func_ltwrapper_scriptname_result=$func_dirname_result/$objdir/${func_stripname_result}_ltshwrapper -} - -# 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 () -{ - $debug_cmd - - save_ifs=$IFS; IFS='~' - for cmd in $1; do - IFS=$sp$nl - eval cmd=\"$cmd\" - IFS=$save_ifs - 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 () -{ - $debug_cmd - - case $1 in - */* | *\\*) . "$1" ;; - *) . "./$1" ;; - esac -} - - -# func_resolve_sysroot PATH -# Replace a leading = in PATH with a sysroot. Store the result into -# func_resolve_sysroot_result -func_resolve_sysroot () -{ - func_resolve_sysroot_result=$1 - case $func_resolve_sysroot_result in - =*) - func_stripname '=' '' "$func_resolve_sysroot_result" - func_resolve_sysroot_result=$lt_sysroot$func_stripname_result - ;; - esac -} - -# func_replace_sysroot PATH -# If PATH begins with the sysroot, replace it with = and -# store the result into func_replace_sysroot_result. -func_replace_sysroot () -{ - case $lt_sysroot:$1 in - ?*:"$lt_sysroot"*) - func_stripname "$lt_sysroot" '' "$1" - func_replace_sysroot_result='='$func_stripname_result - ;; - *) - # Including no sysroot. - func_replace_sysroot_result=$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 () -{ - $debug_cmd - - if test -n "$available_tags" && test -z "$tagname"; then - CC_quoted= - for arg in $CC; do - func_append_quoted CC_quoted "$arg" - done - CC_expanded=`func_echo_all $CC` - CC_quoted_expanded=`func_echo_all $CC_quoted` - 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 "* | " $CC_expanded "* | "$CC_expanded "* | \ - " $CC_quoted"* | "$CC_quoted "* | " $CC_quoted_expanded "* | "$CC_quoted_expanded "*) ;; - # 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_append_quoted CC_quoted "$arg" - done - CC_expanded=`func_echo_all $CC` - CC_quoted_expanded=`func_echo_all $CC_quoted` - case "$@ " in - " $CC "* | "$CC "* | " $CC_expanded "* | "$CC_expanded "* | \ - " $CC_quoted"* | "$CC_quoted "* | " $CC_quoted_expanded "* | "$CC_quoted_expanded "*) - # 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 yes = "$build_libtool_libs"; then - write_lobj=\'$2\' - else - write_lobj=none - fi - - if test yes = "$build_old_libs"; then - write_oldobj=\'$3\' - else - write_oldobj=none - fi - - $opt_dry_run || { - cat >${write_libobj}T </dev/null` - if test "$?" -eq 0 && test -n "$func_convert_core_file_wine_to_w32_tmp"; then - func_convert_core_file_wine_to_w32_result=`$ECHO "$func_convert_core_file_wine_to_w32_tmp" | - $SED -e "$sed_naive_backslashify"` - else - func_convert_core_file_wine_to_w32_result= - fi - fi -} -# end: func_convert_core_file_wine_to_w32 - - -# func_convert_core_path_wine_to_w32 ARG -# Helper function used by path conversion functions when $build is *nix, and -# $host is mingw, cygwin, or some other w32 environment. Relies on a correctly -# configured wine environment available, with the winepath program in $build's -# $PATH. Assumes ARG has no leading or trailing path separator characters. -# -# ARG is path to be converted from $build format to win32. -# Result is available in $func_convert_core_path_wine_to_w32_result. -# Unconvertible file (directory) names in ARG are skipped; if no directory names -# are convertible, then the result may be empty. -func_convert_core_path_wine_to_w32 () -{ - $debug_cmd - - # unfortunately, winepath doesn't convert paths, only file names - func_convert_core_path_wine_to_w32_result= - if test -n "$1"; then - oldIFS=$IFS - IFS=: - for func_convert_core_path_wine_to_w32_f in $1; do - IFS=$oldIFS - func_convert_core_file_wine_to_w32 "$func_convert_core_path_wine_to_w32_f" - if test -n "$func_convert_core_file_wine_to_w32_result"; then - if test -z "$func_convert_core_path_wine_to_w32_result"; then - func_convert_core_path_wine_to_w32_result=$func_convert_core_file_wine_to_w32_result - else - func_append func_convert_core_path_wine_to_w32_result ";$func_convert_core_file_wine_to_w32_result" - fi - fi - done - IFS=$oldIFS - fi -} -# end: func_convert_core_path_wine_to_w32 - - -# func_cygpath ARGS... -# Wrapper around calling the cygpath program via LT_CYGPATH. This is used when -# when (1) $build is *nix and Cygwin is hosted via a wine environment; or (2) -# $build is MSYS and $host is Cygwin, or (3) $build is Cygwin. In case (1) or -# (2), returns the Cygwin file name or path in func_cygpath_result (input -# file name or path is assumed to be in w32 format, as previously converted -# from $build's *nix or MSYS format). In case (3), returns the w32 file name -# or path in func_cygpath_result (input file name or path is assumed to be in -# Cygwin format). Returns an empty string on error. -# -# ARGS are passed to cygpath, with the last one being the file name or path to -# be converted. -# -# Specify the absolute *nix (or w32) name to cygpath in the LT_CYGPATH -# environment variable; do not put it in $PATH. -func_cygpath () -{ - $debug_cmd - - if test -n "$LT_CYGPATH" && test -f "$LT_CYGPATH"; then - func_cygpath_result=`$LT_CYGPATH "$@" 2>/dev/null` - if test "$?" -ne 0; then - # on failure, ensure result is empty - func_cygpath_result= - fi - else - func_cygpath_result= - func_error "LT_CYGPATH is empty or specifies non-existent file: '$LT_CYGPATH'" - fi -} -#end: func_cygpath - - -# func_convert_core_msys_to_w32 ARG -# Convert file name or path ARG from MSYS format to w32 format. Return -# result in func_convert_core_msys_to_w32_result. -func_convert_core_msys_to_w32 () -{ - $debug_cmd - - # awkward: cmd appends spaces to result - func_convert_core_msys_to_w32_result=`( cmd //c echo "$1" ) 2>/dev/null | - $SED -e 's/[ ]*$//' -e "$sed_naive_backslashify"` -} -#end: func_convert_core_msys_to_w32 - - -# func_convert_file_check ARG1 ARG2 -# Verify that ARG1 (a file name in $build format) was converted to $host -# format in ARG2. Otherwise, emit an error message, but continue (resetting -# func_to_host_file_result to ARG1). -func_convert_file_check () -{ - $debug_cmd - - if test -z "$2" && test -n "$1"; then - func_error "Could not determine host file name corresponding to" - func_error " '$1'" - func_error "Continuing, but uninstalled executables may not work." - # Fallback: - func_to_host_file_result=$1 - fi -} -# end func_convert_file_check - - -# func_convert_path_check FROM_PATHSEP TO_PATHSEP FROM_PATH TO_PATH -# Verify that FROM_PATH (a path in $build format) was converted to $host -# format in TO_PATH. Otherwise, emit an error message, but continue, resetting -# func_to_host_file_result to a simplistic fallback value (see below). -func_convert_path_check () -{ - $debug_cmd - - if test -z "$4" && test -n "$3"; then - func_error "Could not determine the host path corresponding to" - func_error " '$3'" - func_error "Continuing, but uninstalled executables may not work." - # Fallback. This is a deliberately simplistic "conversion" and - # should not be "improved". See libtool.info. - if test "x$1" != "x$2"; then - lt_replace_pathsep_chars="s|$1|$2|g" - func_to_host_path_result=`echo "$3" | - $SED -e "$lt_replace_pathsep_chars"` - else - func_to_host_path_result=$3 - fi - fi -} -# end func_convert_path_check - - -# func_convert_path_front_back_pathsep FRONTPAT BACKPAT REPL ORIG -# Modifies func_to_host_path_result by prepending REPL if ORIG matches FRONTPAT -# and appending REPL if ORIG matches BACKPAT. -func_convert_path_front_back_pathsep () -{ - $debug_cmd - - case $4 in - $1 ) func_to_host_path_result=$3$func_to_host_path_result - ;; - esac - case $4 in - $2 ) func_append func_to_host_path_result "$3" - ;; - esac -} -# end func_convert_path_front_back_pathsep - - -################################################## -# $build to $host FILE NAME CONVERSION FUNCTIONS # -################################################## -# invoked via '$to_host_file_cmd ARG' -# -# In each case, ARG is the path to be converted from $build to $host format. -# Result will be available in $func_to_host_file_result. - - -# func_to_host_file ARG -# Converts the file name ARG from $build format to $host format. Return result -# in func_to_host_file_result. -func_to_host_file () -{ - $debug_cmd - - $to_host_file_cmd "$1" -} -# end func_to_host_file - - -# func_to_tool_file ARG LAZY -# converts the file name ARG from $build format to toolchain format. Return -# result in func_to_tool_file_result. If the conversion in use is listed -# in (the comma separated) LAZY, no conversion takes place. -func_to_tool_file () -{ - $debug_cmd - - case ,$2, in - *,"$to_tool_file_cmd",*) - func_to_tool_file_result=$1 - ;; - *) - $to_tool_file_cmd "$1" - func_to_tool_file_result=$func_to_host_file_result - ;; - esac -} -# end func_to_tool_file - - -# func_convert_file_noop ARG -# Copy ARG to func_to_host_file_result. -func_convert_file_noop () -{ - func_to_host_file_result=$1 -} -# end func_convert_file_noop - - -# func_convert_file_msys_to_w32 ARG -# Convert file name ARG from (mingw) MSYS to (mingw) w32 format; automatic -# conversion to w32 is not available inside the cwrapper. Returns result in -# func_to_host_file_result. -func_convert_file_msys_to_w32 () -{ - $debug_cmd - - func_to_host_file_result=$1 - if test -n "$1"; then - func_convert_core_msys_to_w32 "$1" - func_to_host_file_result=$func_convert_core_msys_to_w32_result - fi - func_convert_file_check "$1" "$func_to_host_file_result" -} -# end func_convert_file_msys_to_w32 - - -# func_convert_file_cygwin_to_w32 ARG -# Convert file name ARG from Cygwin to w32 format. Returns result in -# func_to_host_file_result. -func_convert_file_cygwin_to_w32 () -{ - $debug_cmd - - func_to_host_file_result=$1 - if test -n "$1"; then - # because $build is cygwin, we call "the" cygpath in $PATH; no need to use - # LT_CYGPATH in this case. - func_to_host_file_result=`cygpath -m "$1"` - fi - func_convert_file_check "$1" "$func_to_host_file_result" -} -# end func_convert_file_cygwin_to_w32 - - -# func_convert_file_nix_to_w32 ARG -# Convert file name ARG from *nix to w32 format. Requires a wine environment -# and a working winepath. Returns result in func_to_host_file_result. -func_convert_file_nix_to_w32 () -{ - $debug_cmd - - func_to_host_file_result=$1 - if test -n "$1"; then - func_convert_core_file_wine_to_w32 "$1" - func_to_host_file_result=$func_convert_core_file_wine_to_w32_result - fi - func_convert_file_check "$1" "$func_to_host_file_result" -} -# end func_convert_file_nix_to_w32 - - -# func_convert_file_msys_to_cygwin ARG -# Convert file name ARG from MSYS to Cygwin format. Requires LT_CYGPATH set. -# Returns result in func_to_host_file_result. -func_convert_file_msys_to_cygwin () -{ - $debug_cmd - - func_to_host_file_result=$1 - if test -n "$1"; then - func_convert_core_msys_to_w32 "$1" - func_cygpath -u "$func_convert_core_msys_to_w32_result" - func_to_host_file_result=$func_cygpath_result - fi - func_convert_file_check "$1" "$func_to_host_file_result" -} -# end func_convert_file_msys_to_cygwin - - -# func_convert_file_nix_to_cygwin ARG -# Convert file name ARG from *nix to Cygwin format. Requires Cygwin installed -# in a wine environment, working winepath, and LT_CYGPATH set. Returns result -# in func_to_host_file_result. -func_convert_file_nix_to_cygwin () -{ - $debug_cmd - - func_to_host_file_result=$1 - if test -n "$1"; then - # convert from *nix to w32, then use cygpath to convert from w32 to cygwin. - func_convert_core_file_wine_to_w32 "$1" - func_cygpath -u "$func_convert_core_file_wine_to_w32_result" - func_to_host_file_result=$func_cygpath_result - fi - func_convert_file_check "$1" "$func_to_host_file_result" -} -# end func_convert_file_nix_to_cygwin - - -############################################# -# $build to $host PATH CONVERSION FUNCTIONS # -############################################# -# invoked via '$to_host_path_cmd ARG' -# -# In each case, ARG is the path to be converted from $build to $host format. -# The result will be available in $func_to_host_path_result. -# -# 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. -# -# All path conversion functions are named using the following convention: -# file name conversion function : func_convert_file_X_to_Y () -# path conversion function : func_convert_path_X_to_Y () -# where, for any given $build/$host combination the 'X_to_Y' value is the -# same. If conversion functions are added for new $build/$host combinations, -# the two new functions must follow this pattern, or func_init_to_host_path_cmd -# will break. - - -# func_init_to_host_path_cmd -# Ensures that function "pointer" variable $to_host_path_cmd is set to the -# appropriate value, based on the value of $to_host_file_cmd. -to_host_path_cmd= -func_init_to_host_path_cmd () -{ - $debug_cmd - - if test -z "$to_host_path_cmd"; then - func_stripname 'func_convert_file_' '' "$to_host_file_cmd" - to_host_path_cmd=func_convert_path_$func_stripname_result - fi -} - - -# func_to_host_path ARG -# Converts the path ARG from $build format to $host format. Return result -# in func_to_host_path_result. -func_to_host_path () -{ - $debug_cmd - - func_init_to_host_path_cmd - $to_host_path_cmd "$1" -} -# end func_to_host_path - - -# func_convert_path_noop ARG -# Copy ARG to func_to_host_path_result. -func_convert_path_noop () -{ - func_to_host_path_result=$1 -} -# end func_convert_path_noop - - -# func_convert_path_msys_to_w32 ARG -# Convert path ARG from (mingw) MSYS to (mingw) w32 format; automatic -# conversion to w32 is not available inside the cwrapper. Returns result in -# func_to_host_path_result. -func_convert_path_msys_to_w32 () -{ - $debug_cmd - - func_to_host_path_result=$1 - if test -n "$1"; then - # 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_stripname : : "$1" - func_to_host_path_tmp1=$func_stripname_result - func_convert_core_msys_to_w32 "$func_to_host_path_tmp1" - func_to_host_path_result=$func_convert_core_msys_to_w32_result - func_convert_path_check : ";" \ - "$func_to_host_path_tmp1" "$func_to_host_path_result" - func_convert_path_front_back_pathsep ":*" "*:" ";" "$1" - fi -} -# end func_convert_path_msys_to_w32 - - -# func_convert_path_cygwin_to_w32 ARG -# Convert path ARG from Cygwin to w32 format. Returns result in -# func_to_host_file_result. -func_convert_path_cygwin_to_w32 () -{ - $debug_cmd - - func_to_host_path_result=$1 - if test -n "$1"; then - # See func_convert_path_msys_to_w32: - func_stripname : : "$1" - func_to_host_path_tmp1=$func_stripname_result - func_to_host_path_result=`cygpath -m -p "$func_to_host_path_tmp1"` - func_convert_path_check : ";" \ - "$func_to_host_path_tmp1" "$func_to_host_path_result" - func_convert_path_front_back_pathsep ":*" "*:" ";" "$1" - fi -} -# end func_convert_path_cygwin_to_w32 - - -# func_convert_path_nix_to_w32 ARG -# Convert path ARG from *nix to w32 format. Requires a wine environment and -# a working winepath. Returns result in func_to_host_file_result. -func_convert_path_nix_to_w32 () -{ - $debug_cmd - - func_to_host_path_result=$1 - if test -n "$1"; then - # See func_convert_path_msys_to_w32: - func_stripname : : "$1" - func_to_host_path_tmp1=$func_stripname_result - func_convert_core_path_wine_to_w32 "$func_to_host_path_tmp1" - func_to_host_path_result=$func_convert_core_path_wine_to_w32_result - func_convert_path_check : ";" \ - "$func_to_host_path_tmp1" "$func_to_host_path_result" - func_convert_path_front_back_pathsep ":*" "*:" ";" "$1" - fi -} -# end func_convert_path_nix_to_w32 - - -# func_convert_path_msys_to_cygwin ARG -# Convert path ARG from MSYS to Cygwin format. Requires LT_CYGPATH set. -# Returns result in func_to_host_file_result. -func_convert_path_msys_to_cygwin () -{ - $debug_cmd - - func_to_host_path_result=$1 - if test -n "$1"; then - # See func_convert_path_msys_to_w32: - func_stripname : : "$1" - func_to_host_path_tmp1=$func_stripname_result - func_convert_core_msys_to_w32 "$func_to_host_path_tmp1" - func_cygpath -u -p "$func_convert_core_msys_to_w32_result" - func_to_host_path_result=$func_cygpath_result - func_convert_path_check : : \ - "$func_to_host_path_tmp1" "$func_to_host_path_result" - func_convert_path_front_back_pathsep ":*" "*:" : "$1" - fi -} -# end func_convert_path_msys_to_cygwin - - -# func_convert_path_nix_to_cygwin ARG -# Convert path ARG from *nix to Cygwin format. Requires Cygwin installed in a -# a wine environment, working winepath, and LT_CYGPATH set. Returns result in -# func_to_host_file_result. -func_convert_path_nix_to_cygwin () -{ - $debug_cmd - - func_to_host_path_result=$1 - if test -n "$1"; then - # 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_stripname : : "$1" - func_to_host_path_tmp1=$func_stripname_result - func_convert_core_path_wine_to_w32 "$func_to_host_path_tmp1" - func_cygpath -u -p "$func_convert_core_path_wine_to_w32_result" - func_to_host_path_result=$func_cygpath_result - func_convert_path_check : : \ - "$func_to_host_path_tmp1" "$func_to_host_path_result" - func_convert_path_front_back_pathsep ":*" "*:" : "$1" - fi -} -# end func_convert_path_nix_to_cygwin - - -# func_dll_def_p FILE -# True iff FILE is a Windows DLL '.def' file. -# Keep in sync with _LT_DLL_DEF_P in libtool.m4 -func_dll_def_p () -{ - $debug_cmd - - func_dll_def_p_tmp=`$SED -n \ - -e 's/^[ ]*//' \ - -e '/^\(;.*\)*$/d' \ - -e 's/^\(EXPORTS\|LIBRARY\)\([ ].*\)*$/DEF/p' \ - -e q \ - "$1"` - test DEF = "$func_dll_def_p_tmp" -} - - -# func_mode_compile arg... -func_mode_compile () -{ - $debug_cmd - - # Get the compilation command and the source file. - base_compile= - srcfile=$nonopt # always keep a non-empty value in "srcfile" - suppress_opt=yes - suppress_output= - arg_mode=normal - libobj= - later= - pie_flag= - - for arg - do - case $arg_mode in - arg ) - # do not "continue". Instead, add this to base_compile - lastarg=$arg - arg_mode=normal - ;; - - target ) - libobj=$arg - arg_mode=normal - continue - ;; - - normal ) - # Accept any command-line options. - case $arg in - -o) - test -n "$libobj" && \ - func_fatal_error "you cannot specify '-o' more than once" - arg_mode=target - continue - ;; - - -pie | -fpie | -fPIE) - func_append pie_flag " $arg" - continue - ;; - - -shared | -static | -prefer-pic | -prefer-non-pic) - func_append later " $arg" - continue - ;; - - -no-suppress) - suppress_opt=no - continue - ;; - - -Xcompiler) - arg_mode=arg # the next one goes into the "base_compile" arg list - continue # The current "srcfile" will either be retained or - ;; # replaced later. I would guess that would be a bug. - - -Wc,*) - func_stripname '-Wc,' '' "$arg" - args=$func_stripname_result - lastarg= - save_ifs=$IFS; IFS=, - for arg in $args; do - IFS=$save_ifs - func_append_quoted lastarg "$arg" - done - IFS=$save_ifs - func_stripname ' ' '' "$lastarg" - lastarg=$func_stripname_result - - # Add the arguments to base_compile. - func_append base_compile " $lastarg" - continue - ;; - - *) - # Accept the current argument as the source file. - # The previous "srcfile" becomes the current argument. - # - lastarg=$srcfile - srcfile=$arg - ;; - esac # case $arg - ;; - esac # case $arg_mode - - # Aesthetically quote the previous argument. - func_append_quoted base_compile "$lastarg" - done # for arg - - case $arg_mode in - arg) - func_fatal_error "you must specify an argument for -Xcompile" - ;; - target) - func_fatal_error "you must specify a target with '-o'" - ;; - *) - # Get the name of the library object. - test -z "$libobj" && { - func_basename "$srcfile" - libobj=$func_basename_result - } - ;; - esac - - # Recognize several different file suffixes. - # If the user specifies -o file.o, it is replaced with file.lo - case $libobj in - *.[cCFSifmso] | \ - *.ada | *.adb | *.ads | *.asm | \ - *.c++ | *.cc | *.ii | *.class | *.cpp | *.cxx | \ - *.[fF][09]? | *.for | *.java | *.go | *.obj | *.sx | *.cu | *.cup) - func_xform "$libobj" - libobj=$func_xform_result - ;; - esac - - case $libobj in - *.lo) func_lo2o "$libobj"; obj=$func_lo2o_result ;; - *) - func_fatal_error "cannot determine name of library object from '$libobj'" - ;; - esac - - func_infer_tag $base_compile - - for arg in $later; do - case $arg in - -shared) - test yes = "$build_libtool_libs" \ - || func_fatal_configuration "cannot build a shared library" - build_old_libs=no - continue - ;; - - -static) - build_libtool_libs=no - build_old_libs=yes - continue - ;; - - -prefer-pic) - pic_mode=yes - continue - ;; - - -prefer-non-pic) - pic_mode=no - continue - ;; - esac - done - - func_quote_for_eval "$libobj" - test "X$libobj" != "X$func_quote_for_eval_result" \ - && $ECHO "X$libobj" | $GREP '[]~#^*{};<>?"'"'"' &()|`$[]' \ - && 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 yes = "$build_old_libs"; 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 no = "$pic_mode" && test pass_all != "$deplibs_check_method"; 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 no = "$compiler_c_o"; then - output_obj=`$ECHO "$srcfile" | $SED 's%^.*/%%; 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 yes = "$need_locks"; 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 warn = "$need_locks"; 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 - func_append removelist " $output_obj" - $ECHO "$srcfile" > "$lockfile" - fi - - $opt_dry_run || $RM $removelist - func_append removelist " $lockfile" - trap '$opt_dry_run || $RM $removelist; exit $EXIT_FAILURE' 1 2 15 - - func_to_tool_file "$srcfile" func_convert_file_msys_to_w32 - srcfile=$func_to_tool_file_result - func_quote_for_eval "$srcfile" - qsrcfile=$func_quote_for_eval_result - - # Only build a PIC object if we are building libtool libraries. - if test yes = "$build_libtool_libs"; then - # Without this assignment, base_compile gets emptied. - fbsd_hideous_sh_bug=$base_compile - - if test no != "$pic_mode"; 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 - func_append command " -o $lobj" - fi - - func_show_eval_locale "$command" \ - 'test -n "$output_obj" && $RM $removelist; exit $EXIT_FAILURE' - - if test warn = "$need_locks" && - 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 yes = "$suppress_opt"; then - suppress_output=' >/dev/null 2>&1' - fi - fi - - # Only build a position-dependent object if we build old libraries. - if test yes = "$build_old_libs"; then - if test yes != "$pic_mode"; then - # Don't build PIC code - command="$base_compile $qsrcfile$pie_flag" - else - command="$base_compile $qsrcfile $pic_flag" - fi - if test yes = "$compiler_c_o"; then - func_append command " -o $obj" - fi - - # Suppress compiler output if we already did a PIC compilation. - func_append command "$suppress_output" - func_show_eval_locale "$command" \ - '$opt_dry_run || $RM $removelist; exit $EXIT_FAILURE' - - if test warn = "$need_locks" && - 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 no != "$need_locks"; then - removelist=$lockfile - $RM "$lockfile" - fi - } - - exit $EXIT_SUCCESS -} - -$opt_help || { - test compile = "$opt_mode" && func_mode_compile ${1+"$@"} -} - -func_mode_help () -{ - # We need to display help for each of the modes. - case $opt_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 build PIC objects only - -prefer-non-pic try to build 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 - -Wc,FLAG pass FLAG directly to the compiler - -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-dir 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 - -bindir BINDIR specify path to binaries directory (for systems where - libraries must be found in the PATH setting at runtime) - -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 - -os2dllname NAME force a short DLL name on OS/2 (no effect on other OSes) - -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 - -Wc,FLAG - -Xcompiler FLAG pass linker-specific FLAG directly to the compiler - -Wl,FLAG - -Xlinker FLAG pass linker-specific FLAG directly to the linker - -XCClinker FLAG pass link-specific FLAG to the compiler driver (CC) - -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 '$opt_mode'" - ;; - esac - - echo - $ECHO "Try '$progname --help' for more information about other modes." -} - -# Now that we've collected a possible --mode arg, show help if necessary -if $opt_help; then - if test : = "$opt_help"; then - func_mode_help - else - { - func_help noexit - for opt_mode in compile link execute install finish uninstall clean; do - func_mode_help - done - } | $SED -n '1p; 2,$s/^Usage:/ or: /p' - { - func_help noexit - for opt_mode in compile link execute install finish uninstall clean; do - echo - func_mode_help - done - } | - $SED '1d - /^When reporting/,/^Report/{ - H - d - } - $x - /information about other modes/d - /more detailed .*MODE/d - s/^Usage:.*--mode=\([^ ]*\) .*/Description of \1 mode:/' - fi - exit $? -fi - - -# func_mode_execute arg... -func_mode_execute () -{ - $debug_cmd - - # 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 $opt_dlopen; do - test -f "$file" \ - || func_fatal_help "'$file' is not a file" - - dir= - case $file in - *.la) - func_resolve_sysroot "$file" - file=$func_resolve_sysroot_result - - # 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 - func_append 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 - -* | *.la | *.lo ) ;; - *) - # 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_append_quoted args "$file" - done - - if $opt_dry_run; then - # 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 - else - 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 - fi -} - -test execute = "$opt_mode" && func_mode_execute ${1+"$@"} - - -# func_mode_finish arg... -func_mode_finish () -{ - $debug_cmd - - libs= - libdirs= - admincmds= - - for opt in "$nonopt" ${1+"$@"} - do - if test -d "$opt"; then - func_append libdirs " $opt" - - elif test -f "$opt"; then - if func_lalib_unsafe_p "$opt"; then - func_append libs " $opt" - else - func_warning "'$opt' is not a valid libtool archive" - fi - - else - func_fatal_error "invalid argument '$opt'" - fi - done - - if test -n "$libs"; then - if test -n "$lt_sysroot"; then - sysroot_regex=`$ECHO "$lt_sysroot" | $SED "$sed_make_literal_regex"` - sysroot_cmd="s/\([ ']\)$sysroot_regex/\1/g;" - else - sysroot_cmd= - fi - - # Remove sysroot references - if $opt_dry_run; then - for lib in $libs; do - echo "removing references to $lt_sysroot and '=' prefixes from $lib" - done - else - tmpdir=`func_mktempdir` - for lib in $libs; do - $SED -e "$sysroot_cmd s/\([ ']-[LR]\)=/\1/g; s/\([ ']\)=/\1/g" $lib \ - > $tmpdir/tmp-la - mv -f $tmpdir/tmp-la $lib - done - ${RM}r "$tmpdir" - fi - fi - - if test -n "$finish_cmds$finish_eval" && test -n "$libdirs"; then - 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" || func_append admincmds " - $cmds" - fi - done - fi - - # Exit here if they wanted silent mode. - $opt_quiet && exit $EXIT_SUCCESS - - if test -n "$finish_cmds$finish_eval" && test -n "$libdirs"; then - echo "----------------------------------------------------------------------" - 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 "----------------------------------------------------------------------" - fi - exit $EXIT_SUCCESS -} - -test finish = "$opt_mode" && func_mode_finish ${1+"$@"} - - -# func_mode_install arg... -func_mode_install () -{ - $debug_cmd - - # There may be an optional sh(1) argument at the beginning of - # install_prog (especially on Windows NT). - if test "$SHELL" = "$nonopt" || test /bin/sh = "$nonopt" || - # Allow the use of GNU shtool's install command. - case $nonopt in *shtool*) :;; *) false;; esac - 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" - func_append install_prog "$func_quote_for_eval_result" - install_shared_prog=$install_prog - case " $install_prog " in - *[\\\ /]cp\ *) install_cp=: ;; - *) install_cp=false ;; - esac - - # We need to accept at least all the BSD install flags. - dest= - files= - opts= - prev= - install_type= - isdir=false - stripme= - no_mode=: - for arg - do - arg2= - if test -n "$dest"; then - func_append files " $dest" - dest=$arg - continue - fi - - case $arg in - -d) isdir=: ;; - -f) - if $install_cp; then :; else - prev=$arg - fi - ;; - -g | -m | -o) - prev=$arg - ;; - -s) - stripme=" -s" - continue - ;; - -*) - ;; - *) - # If the previous option needed an argument, then skip it. - if test -n "$prev"; then - if test X-m = "X$prev" && test -n "$install_override_mode"; then - arg2=$install_override_mode - no_mode=false - fi - prev= - else - dest=$arg - continue - fi - ;; - esac - - # Aesthetically quote the argument. - func_quote_for_eval "$arg" - func_append install_prog " $func_quote_for_eval_result" - if test -n "$arg2"; then - func_quote_for_eval "$arg2" - fi - func_append install_shared_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 -n "$install_override_mode" && $no_mode; then - if $install_cp; then :; else - func_quote_for_eval "$install_override_mode" - func_append install_shared_prog " -m $func_quote_for_eval_result" - fi - fi - - 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=: - if $isdir; 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. - func_append staticlibs " $file" - ;; - - *.la) - func_resolve_sysroot "$file" - file=$func_resolve_sysroot_result - - # 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 "*) ;; - *) func_append current_libdirs " $libdir" ;; - esac - else - # Note the libdir as a future libdir. - case "$future_libdirs " in - *" $libdir "*) ;; - *) func_append future_libdirs " $libdir" ;; - esac - fi - - func_dirname "$file" "/" "" - dir=$func_dirname_result - func_append dir "$objdir" - - if test -n "$relink_command"; then - # Determine the prefix the user has applied to our future dir. - inst_prefix_dir=`$ECHO "$destdir" | $SED -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 "$relink_command" | $SED "s%@inst_prefix_dir@%-inst-prefix-dir $inst_prefix_dir%"` - else - relink_command=`$ECHO "$relink_command" | $SED "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_shared_prog $dir/$srcname $destdir/$realname" \ - 'exit $?' - tstripme=$stripme - case $host_os in - cygwin* | mingw* | pw32* | cegcc*) - case $realname in - *.dll.a) - tstripme= - ;; - esac - ;; - os2*) - 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" && func_append 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 yes = "$build_old_libs"; 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=: - 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 "$lib" | $SED 's%^.*/%%g'` - if test -n "$libdir" && test ! -f "$libfile"; then - func_warning "'$lib' has not been installed in '$libdir'" - finalize=false - fi - done - - relink_command= - func_source "$wrapper" - - outputname= - if test no = "$fast_install" && test -n "$relink_command"; then - $opt_dry_run || { - if $finalize; then - tmpdir=`func_mktempdir` - func_basename "$file$stripped_ext" - file=$func_basename_result - outputname=$tmpdir/$file - # Replace the output file specification. - relink_command=`$ECHO "$relink_command" | $SED 's%@OUTPUT@%'"$outputname"'%g'` - - $opt_quiet || { - 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 "$file$stripped_ext" | $SED "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_to_tool_file "$oldlib" func_convert_file_msys_to_w32 - tool_oldlib=$func_to_tool_file_result - - func_show_eval "$install_prog \$file \$oldlib" 'exit $?' - - if test -n "$stripme" && test -n "$old_striplib"; then - func_show_eval "$old_striplib $tool_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 install = "$opt_mode" && 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 () -{ - $debug_cmd - - my_outputname=$1 - my_originator=$2 - my_pic_p=${3-false} - my_prefix=`$ECHO "$my_originator" | $SED 's%[^a-zA-Z0-9]%_%g'` - my_dlsyms= - - if test -n "$dlfiles$dlprefiles" || test no != "$dlself"; 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) $VERSION */ - -#ifdef __cplusplus -extern \"C\" { -#endif - -#if defined __GNUC__ && (((__GNUC__ == 4) && (__GNUC_MINOR__ >= 4)) || (__GNUC__ > 4)) -#pragma GCC diagnostic ignored \"-Wstrict-prototypes\" -#endif - -/* Keep this code in sync between libtool.m4, ltmain, lt_system.h, and tests. */ -#if defined _WIN32 || defined __CYGWIN__ || defined _WIN32_WCE -/* DATA imports from DLLs on WIN32 can't be const, because runtime - relocations are performed -- see ld's documentation on pseudo-relocs. */ -# define LT_DLSYM_CONST -#elif defined __osf__ -/* This system does not cope well with relocations in const data. */ -# define LT_DLSYM_CONST -#else -# define LT_DLSYM_CONST const -#endif - -#define STREQ(s1, s2) (strcmp ((s1), (s2)) == 0) - -/* External symbol declarations for the compiler. */\ -" - - if test yes = "$dlself"; 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 "$objs$old_deplibs" | $SP2NL | $SED "$lo2o" | $NL2SP` - for progfile in $progfiles; do - func_to_tool_file "$progfile" func_convert_file_msys_to_w32 - func_verbose "extracting global C symbols from '$func_to_tool_file_result'" - $opt_dry_run || eval "$NM $func_to_tool_file_result | $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 - case $host in - *cygwin* | *mingw* | *cegcc* ) - # if an import library, we need to obtain dlname - if func_win32_import_lib_p "$dlprefile"; then - func_tr_sh "$dlprefile" - eval "curr_lafile=\$libfile_$func_tr_sh_result" - dlprefile_dlbasename= - if test -n "$curr_lafile" && func_lalib_p "$curr_lafile"; then - # Use subshell, to avoid clobbering current variable values - dlprefile_dlname=`source "$curr_lafile" && echo "$dlname"` - if test -n "$dlprefile_dlname"; then - func_basename "$dlprefile_dlname" - dlprefile_dlbasename=$func_basename_result - else - # no lafile. user explicitly requested -dlpreopen . - $sharedlib_from_linklib_cmd "$dlprefile" - dlprefile_dlbasename=$sharedlib_from_linklib_result - fi - fi - $opt_dry_run || { - if test -n "$dlprefile_dlbasename"; then - eval '$ECHO ": $dlprefile_dlbasename" >> "$nlist"' - else - func_warning "Could not compute DLL name from $name" - eval '$ECHO ": $name " >> "$nlist"' - fi - func_to_tool_file "$dlprefile" func_convert_file_msys_to_w32 - eval "$NM \"$func_to_tool_file_result\" 2>/dev/null | $global_symbol_pipe | - $SED -e '/I __imp/d' -e 's/I __nm_/D /;s/_nm__//' >> '$nlist'" - } - else # not an import lib - $opt_dry_run || { - eval '$ECHO ": $name " >> "$nlist"' - func_to_tool_file "$dlprefile" func_convert_file_msys_to_w32 - eval "$NM \"$func_to_tool_file_result\" 2>/dev/null | $global_symbol_pipe >> '$nlist'" - } - fi - ;; - *) - $opt_dry_run || { - eval '$ECHO ": $name " >> "$nlist"' - func_to_tool_file "$dlprefile" func_convert_file_msys_to_w32 - eval "$NM \"$func_to_tool_file_result\" 2>/dev/null | $global_symbol_pipe >> '$nlist'" - } - ;; - esac - 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 - - func_show_eval '$RM "${nlist}I"' - if test -n "$global_symbol_to_import"; then - eval "$global_symbol_to_import"' < "$nlist"S > "$nlist"I' - fi - - echo >> "$output_objdir/$my_dlsyms" "\ - -/* The mapping between symbol names and symbols. */ -typedef struct { - const char *name; - void *address; -} lt_dlsymlist; -extern LT_DLSYM_CONST lt_dlsymlist -lt_${my_prefix}_LTX_preloaded_symbols[];\ -" - - if test -s "$nlist"I; then - echo >> "$output_objdir/$my_dlsyms" "\ -static void lt_syminit(void) -{ - LT_DLSYM_CONST lt_dlsymlist *symbol = lt_${my_prefix}_LTX_preloaded_symbols; - for (; symbol->name; ++symbol) - {" - $SED 's/.*/ if (STREQ (symbol->name, \"&\")) symbol->address = (void *) \&&;/' < "$nlist"I >> "$output_objdir/$my_dlsyms" - echo >> "$output_objdir/$my_dlsyms" "\ - } -}" - fi - echo >> "$output_objdir/$my_dlsyms" "\ -LT_DLSYM_CONST lt_dlsymlist -lt_${my_prefix}_LTX_preloaded_symbols[] = -{ {\"$my_originator\", (void *) 0}," - - if test -s "$nlist"I; then - echo >> "$output_objdir/$my_dlsyms" "\ - {\"@INIT@\", (void *) <_syminit}," - fi - - 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" ;; - *) - $my_pic_p && pic_flag_for_symtable=" $pic_flag" - ;; - esac - ;; - esac - symtab_cflags= - for arg in $LTCFLAGS; do - case $arg in - -pie | -fpie | -fPIE) ;; - *) func_append 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" "${nlist}I"' - - # 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 "$compile_command" | $SED "s%@SYMFILE@%$output_objdir/$my_outputname.def $symfileobj%"` - finalize_command=`$ECHO "$finalize_command" | $SED "s%@SYMFILE@%$output_objdir/$my_outputname.def $symfileobj%"` - else - compile_command=`$ECHO "$compile_command" | $SED "s%@SYMFILE@%$symfileobj%"` - finalize_command=`$ECHO "$finalize_command" | $SED "s%@SYMFILE@%$symfileobj%"` - fi - ;; - *) - compile_command=`$ECHO "$compile_command" | $SED "s%@SYMFILE@%$symfileobj%"` - finalize_command=`$ECHO "$finalize_command" | $SED "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 "$compile_command" | $SED "s% @SYMFILE@%%"` - finalize_command=`$ECHO "$finalize_command" | $SED "s% @SYMFILE@%%"` - fi -} - -# func_cygming_gnu_implib_p ARG -# This predicate returns with zero status (TRUE) if -# ARG is a GNU/binutils-style import library. Returns -# with nonzero status (FALSE) otherwise. -func_cygming_gnu_implib_p () -{ - $debug_cmd - - func_to_tool_file "$1" func_convert_file_msys_to_w32 - func_cygming_gnu_implib_tmp=`$NM "$func_to_tool_file_result" | eval "$global_symbol_pipe" | $EGREP ' (_head_[A-Za-z0-9_]+_[ad]l*|[A-Za-z0-9_]+_[ad]l*_iname)$'` - test -n "$func_cygming_gnu_implib_tmp" -} - -# func_cygming_ms_implib_p ARG -# This predicate returns with zero status (TRUE) if -# ARG is an MS-style import library. Returns -# with nonzero status (FALSE) otherwise. -func_cygming_ms_implib_p () -{ - $debug_cmd - - func_to_tool_file "$1" func_convert_file_msys_to_w32 - func_cygming_ms_implib_tmp=`$NM "$func_to_tool_file_result" | eval "$global_symbol_pipe" | $GREP '_NULL_IMPORT_DESCRIPTOR'` - test -n "$func_cygming_ms_implib_tmp" -} - -# 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. -# Despite the name, also deal with 64 bit binaries. -func_win32_libid () -{ - $debug_cmd - - 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 - # Keep the egrep pattern in sync with the one in _LT_CHECK_MAGIC_METHOD. - if eval $OBJDUMP -f $1 | $SED -e '10q' 2>/dev/null | - $EGREP 'file format (pei*-i386(.*architecture: i386)?|pe-arm-wince|pe-x86-64)' >/dev/null; then - case $nm_interface in - "MS dumpbin") - if func_cygming_ms_implib_p "$1" || - func_cygming_gnu_implib_p "$1" - then - win32_nmres=import - else - win32_nmres= - fi - ;; - *) - func_to_tool_file "$1" func_convert_file_msys_to_w32 - win32_nmres=`eval $NM -f posix -A \"$func_to_tool_file_result\" | - $SED -n -e ' - 1,100{ - / I /{ - s|.*|import| - p - q - } - }'` - ;; - esac - 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_cygming_dll_for_implib ARG -# -# Platform-specific function to extract the -# name of the DLL associated with the specified -# import library ARG. -# Invoked by eval'ing the libtool variable -# $sharedlib_from_linklib_cmd -# Result is available in the variable -# $sharedlib_from_linklib_result -func_cygming_dll_for_implib () -{ - $debug_cmd - - sharedlib_from_linklib_result=`$DLLTOOL --identify-strict --identify "$1"` -} - -# func_cygming_dll_for_implib_fallback_core SECTION_NAME LIBNAMEs -# -# The is the core of a fallback implementation of a -# platform-specific function to extract the name of the -# DLL associated with the specified import library LIBNAME. -# -# SECTION_NAME is either .idata$6 or .idata$7, depending -# on the platform and compiler that created the implib. -# -# Echos the name of the DLL associated with the -# specified import library. -func_cygming_dll_for_implib_fallback_core () -{ - $debug_cmd - - match_literal=`$ECHO "$1" | $SED "$sed_make_literal_regex"` - $OBJDUMP -s --section "$1" "$2" 2>/dev/null | - $SED '/^Contents of section '"$match_literal"':/{ - # Place marker at beginning of archive member dllname section - s/.*/====MARK====/ - p - d - } - # These lines can sometimes be longer than 43 characters, but - # are always uninteresting - /:[ ]*file format pe[i]\{,1\}-/d - /^In archive [^:]*:/d - # Ensure marker is printed - /^====MARK====/p - # Remove all lines with less than 43 characters - /^.\{43\}/!d - # From remaining lines, remove first 43 characters - s/^.\{43\}//' | - $SED -n ' - # Join marker and all lines until next marker into a single line - /^====MARK====/ b para - H - $ b para - b - :para - x - s/\n//g - # Remove the marker - s/^====MARK====// - # Remove trailing dots and whitespace - s/[\. \t]*$// - # Print - /./p' | - # we now have a list, one entry per line, of the stringified - # contents of the appropriate section of all members of the - # archive that possess that section. Heuristic: eliminate - # all those that have a first or second character that is - # a '.' (that is, objdump's representation of an unprintable - # character.) This should work for all archives with less than - # 0x302f exports -- but will fail for DLLs whose name actually - # begins with a literal '.' or a single character followed by - # a '.'. - # - # Of those that remain, print the first one. - $SED -e '/^\./d;/^.\./d;q' -} - -# func_cygming_dll_for_implib_fallback ARG -# Platform-specific function to extract the -# name of the DLL associated with the specified -# import library ARG. -# -# This fallback implementation is for use when $DLLTOOL -# does not support the --identify-strict option. -# Invoked by eval'ing the libtool variable -# $sharedlib_from_linklib_cmd -# Result is available in the variable -# $sharedlib_from_linklib_result -func_cygming_dll_for_implib_fallback () -{ - $debug_cmd - - if func_cygming_gnu_implib_p "$1"; then - # binutils import library - sharedlib_from_linklib_result=`func_cygming_dll_for_implib_fallback_core '.idata$7' "$1"` - elif func_cygming_ms_implib_p "$1"; then - # ms-generated import library - sharedlib_from_linklib_result=`func_cygming_dll_for_implib_fallback_core '.idata$6' "$1"` - else - # unknown - sharedlib_from_linklib_result= - fi -} - - -# func_extract_an_archive dir oldlib -func_extract_an_archive () -{ - $debug_cmd - - f_ex_an_ar_dir=$1; shift - f_ex_an_ar_oldlib=$1 - if test yes = "$lock_old_archive_extraction"; then - lockfile=$f_ex_an_ar_oldlib.lock - until $opt_dry_run || ln "$progpath" "$lockfile" 2>/dev/null; do - func_echo "Waiting for $lockfile to be removed" - sleep 2 - done - fi - func_show_eval "(cd \$f_ex_an_ar_dir && $AR x \"\$f_ex_an_ar_oldlib\")" \ - 'stat=$?; rm -f "$lockfile"; exit $stat' - if test yes = "$lock_old_archive_extraction"; then - $opt_dry_run || rm -f "$lockfile" - fi - 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 () -{ - $debug_cmd - - 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` - func_basename "$darwin_archive" - darwin_base_archive=$func_basename_result - 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 "$sed_basename" | sort -u` - darwin_file= - darwin_files= - for darwin_file in $darwin_filelist; do - darwin_files=`find unfat-$$ -name $darwin_file -print | sort | $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 | sort | $NL2SP` - done - - func_extract_archives_result=$my_oldobjs -} - - -# 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 where it is stored is -# the $objdir directory. This is a cygwin/mingw-specific -# behavior. -func_emit_wrapper () -{ - func_emit_wrapper_arg1=${1-no} - - $ECHO "\ -#! $SHELL - -# $output - temporary wrapper script for $objdir/$outputname -# Generated by $PROGRAM (GNU $PACKAGE) $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. -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 - file=\"\$0\"" - - qECHO=`$ECHO "$ECHO" | $SED "$sed_quote_subst"` - $ECHO "\ - -# A function that is used when there is no print builtin or printf. -func_fallback_echo () -{ - eval 'cat <<_LTECHO_EOF -\$1 -_LTECHO_EOF' -} - ECHO=\"$qECHO\" - fi - -# Very basic option parsing. These options are (a) specific to -# the libtool wrapper, (b) are identical between the wrapper -# /script/ and the wrapper /executable/ that is used only on -# windows platforms, and (c) all begin with the string "--lt-" -# (application programs are unlikely to have options that match -# this pattern). -# -# There are only two supported options: --lt-debug and -# --lt-dump-script. There is, deliberately, no --lt-help. -# -# The first argument to this parsing function should be the -# script's $0 value, followed by "$@". -lt_option_debug= -func_parse_lt_options () -{ - lt_script_arg0=\$0 - shift - for lt_opt - do - case \"\$lt_opt\" in - --lt-debug) lt_option_debug=1 ;; - --lt-dump-script) - lt_dump_D=\`\$ECHO \"X\$lt_script_arg0\" | $SED -e 's/^X//' -e 's%/[^/]*$%%'\` - test \"X\$lt_dump_D\" = \"X\$lt_script_arg0\" && lt_dump_D=. - lt_dump_F=\`\$ECHO \"X\$lt_script_arg0\" | $SED -e 's/^X//' -e 's%^.*/%%'\` - cat \"\$lt_dump_D/\$lt_dump_F\" - exit 0 - ;; - --lt-*) - \$ECHO \"Unrecognized --lt- option: '\$lt_opt'\" 1>&2 - exit 1 - ;; - esac - done - - # Print the debug banner immediately: - if test -n \"\$lt_option_debug\"; then - echo \"$outputname:$output:\$LINENO: libtool wrapper (GNU $PACKAGE) $VERSION\" 1>&2 - fi -} - -# Used when --lt-debug. Prints its arguments to stdout -# (redirection is the responsibility of the caller) -func_lt_dump_args () -{ - lt_dump_args_N=1; - for lt_arg - do - \$ECHO \"$outputname:$output:\$LINENO: newargv[\$lt_dump_args_N]: \$lt_arg\" - lt_dump_args_N=\`expr \$lt_dump_args_N + 1\` - done -} - -# Core function for launching the target application -func_exec_program_core () -{ -" - case $host in - # Backslashes separate directories on plain windows - *-*-mingw | *-*-os2* | *-cegcc*) - $ECHO "\ - if test -n \"\$lt_option_debug\"; then - \$ECHO \"$outputname:$output:\$LINENO: newargv[0]: \$progdir\\\\\$program\" 1>&2 - func_lt_dump_args \${1+\"\$@\"} 1>&2 - fi - exec \"\$progdir\\\\\$program\" \${1+\"\$@\"} -" - ;; - - *) - $ECHO "\ - if test -n \"\$lt_option_debug\"; then - \$ECHO \"$outputname:$output:\$LINENO: newargv[0]: \$progdir/\$program\" 1>&2 - func_lt_dump_args \${1+\"\$@\"} 1>&2 - fi - exec \"\$progdir/\$program\" \${1+\"\$@\"} -" - ;; - esac - $ECHO "\ - \$ECHO \"\$0: cannot exec \$program \$*\" 1>&2 - exit 1 -} - -# A function to encapsulate launching the target application -# Strips options in the --lt-* namespace from \$@ and -# launches target application with the remaining arguments. -func_exec_program () -{ - case \" \$* \" in - *\\ --lt-*) - for lt_wr_arg - do - case \$lt_wr_arg in - --lt-*) ;; - *) set x \"\$@\" \"\$lt_wr_arg\"; shift;; - esac - shift - done ;; - esac - func_exec_program_core \${1+\"\$@\"} -} - - # Parse options - func_parse_lt_options \"\$0\" \${1+\"\$@\"} - - # Find the directory that this script lives in. - thisdir=\`\$ECHO \"\$file\" | $SED '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 \"\$file\" | $SED '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 \"\$file\" | $SED 's%^.*/%%'\` - file=\`ls -ld \"\$thisdir/\$file\" | $SED -n 's/.*-> //p'\` - done - - # Usually 'no', except on cygwin/mingw when embedded into - # the cwrapper. - WRAPPER_SCRIPT_BELONGS_IN_OBJDIR=$func_emit_wrapper_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 \"\$thisdir\" | $SED 's%[\\\\/][^\\\\/]*$%%'\` ;; - $objdir ) thisdir=. ;; - esac - fi - - # Try to get the absolute directory name. - absdir=\`cd \"\$thisdir\" && pwd\` - test -n \"\$absdir\" && thisdir=\"\$absdir\" -" - - if test yes = "$fast_install"; 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" - - # fixup the dll searchpath if we need to. - # - # Fix the DLL searchpath if we need to. Do this before prepending - # to shlibpath, because on Windows, both are PATH and uninstalled - # libraries must come first. - if test -n "$dllsearchpath"; then - $ECHO "\ - # Add the dll search path components to the executable PATH - PATH=$dllsearchpath:\$PATH -" - fi - - # Export our shlibpath_var if we have one. - if test yes = "$shlibpath_overrides_runpath" && 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 \"\$$shlibpath_var\" | $SED 's/::*\$//'\` - - export $shlibpath_var -" - fi - - $ECHO "\ - if test \"\$libtool_execute_magic\" != \"$magic\"; then - # Run the actual program with our arguments. - func_exec_program \${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\ -" -} - - -# 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 -#else -# include -# include -# ifdef __CYGWIN__ -# include -# endif -#endif -#include -#include -#include -#include -#include -#include -#include -#include - -#define STREQ(s1, s2) (strcmp ((s1), (s2)) == 0) - -/* declarations of non-ANSI functions */ -#if defined __MINGW32__ -# ifdef __STRICT_ANSI__ -int _putenv (const char *); -# endif -#elif defined __CYGWIN__ -# ifdef __STRICT_ANSI__ -char *realpath (const char *, char *); -int putenv (char *); -int setenv (const char *, const char *, int); -# endif -/* #elif defined other_platform || defined ... */ -#endif - -/* portability defines, excluding path handling macros */ -#if defined _MSC_VER -# define setmode _setmode -# define stat _stat -# define chmod _chmod -# define getcwd _getcwd -# define putenv _putenv -# define S_IXUSR _S_IEXEC -#elif defined __MINGW32__ -# define setmode _setmode -# define stat _stat -# define chmod _chmod -# define getcwd _getcwd -# define putenv _putenv -#elif defined __CYGWIN__ -# define HAVE_SETENV -# define FOPEN_WB "wb" -/* #elif defined other platforms ... */ -#endif - -#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 - -/* path handling portability macros */ -#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 */ - -#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 (stale); stale = 0; } \ -} while (0) - -#if defined LT_DEBUGWRAPPER -static int lt_debug = 1; -#else -static int lt_debug = 0; -#endif - -const char *program_name = "libtool-wrapper"; /* in case xstrdup fails */ - -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_debugprintf (const char *file, int line, const char *fmt, ...); -void lt_fatal (const char *file, int line, const char *message, ...); -static const char *nonnull (const char *s); -static const char *nonempty (const char *s); -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_update_exe_path (const char *name, const char *value); -void lt_update_lib_path (const char *name, const char *value); -char **prepare_spawn (char **argv); -void lt_dump_script (FILE *f); -EOF - - cat <= 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; - - lt_debugprintf (__FILE__, __LINE__, "(make_executable): %s\n", - nonempty (path)); - 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]; - size_t tmp_len; - char *concat_name; - - lt_debugprintf (__FILE__, __LINE__, "(find_executable): %s\n", - nonempty (wrapper)); - - 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 = (size_t) (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 (__FILE__, __LINE__, "getcwd failed: %s", - nonnull (strerror (errno))); - 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 (__FILE__, __LINE__, "getcwd failed: %s", - nonnull (strerror (errno))); - 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) - { - lt_debugprintf (__FILE__, __LINE__, - "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 - { - lt_fatal (__FILE__, __LINE__, - "error accessing file \"%s\": %s", - tmp_pathspec, nonnull (strerror (errno))); - } - } - XFREE (tmp_pathspec); - - if (!has_symlinks) - { - return xstrdup (pathspec); - } - - tmp_pathspec = realpath (pathspec, buf); - if (tmp_pathspec == 0) - { - lt_fatal (__FILE__, __LINE__, - "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 (STREQ (str, pat)) - *str = '\0'; - } - return str; -} - -void -lt_debugprintf (const char *file, int line, const char *fmt, ...) -{ - va_list args; - if (lt_debug) - { - (void) fprintf (stderr, "%s:%s:%d: ", program_name, file, line); - va_start (args, fmt); - (void) vfprintf (stderr, fmt, args); - va_end (args); - } -} - -static void -lt_error_core (int exit_status, const char *file, - int line, const char *mode, - const char *message, va_list ap) -{ - fprintf (stderr, "%s:%s:%d: %s: ", program_name, file, line, mode); - vfprintf (stderr, message, ap); - fprintf (stderr, ".\n"); - - if (exit_status >= 0) - exit (exit_status); -} - -void -lt_fatal (const char *file, int line, const char *message, ...) -{ - va_list ap; - va_start (ap, message); - lt_error_core (EXIT_FAILURE, file, line, "FATAL", message, ap); - va_end (ap); -} - -static const char * -nonnull (const char *s) -{ - return s ? s : "(null)"; -} - -static const char * -nonempty (const char *s) -{ - return (s && !*s) ? "(empty)" : nonnull (s); -} - -void -lt_setenv (const char *name, const char *value) -{ - lt_debugprintf (__FILE__, __LINE__, - "(lt_setenv) setting '%s' to '%s'\n", - nonnull (name), nonnull (value)); - { -#ifdef HAVE_SETENV - /* always make a copy, for consistency with !HAVE_SETENV */ - char *str = xstrdup (value); - setenv (name, str, 1); -#else - size_t 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) - { - size_t orig_value_len = strlen (orig_value); - size_t 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; -} - -void -lt_update_exe_path (const char *name, const char *value) -{ - lt_debugprintf (__FILE__, __LINE__, - "(lt_update_exe_path) modifying '%s' by prepending '%s'\n", - nonnull (name), nonnull (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 #' */ - size_t len = strlen (new_value); - while ((len > 0) && IS_PATH_SEPARATOR (new_value[len-1])) - { - new_value[--len] = '\0'; - } - lt_setenv (name, new_value); - XFREE (new_value); - } -} - -void -lt_update_lib_path (const char *name, const char *value) -{ - lt_debugprintf (__FILE__, __LINE__, - "(lt_update_lib_path) modifying '%s' by prepending '%s'\n", - nonnull (name), nonnull (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 - case $host_os in - mingw*) - cat <<"EOF" - -/* Prepares an argument vector before calling spawn(). - Note that spawn() does not by itself call the command interpreter - (getenv ("COMSPEC") != NULL ? getenv ("COMSPEC") : - ({ OSVERSIONINFO v; v.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); - GetVersionEx(&v); - v.dwPlatformId == VER_PLATFORM_WIN32_NT; - }) ? "cmd.exe" : "command.com"). - Instead it simply concatenates the arguments, separated by ' ', and calls - CreateProcess(). We must quote the arguments since Win32 CreateProcess() - interprets characters like ' ', '\t', '\\', '"' (but not '<' and '>') in a - special way: - - Space and tab are interpreted as delimiters. They are not treated as - delimiters if they are surrounded by double quotes: "...". - - Unescaped double quotes are removed from the input. Their only effect is - that within double quotes, space and tab are treated like normal - characters. - - Backslashes not followed by double quotes are not special. - - But 2*n+1 backslashes followed by a double quote become - n backslashes followed by a double quote (n >= 0): - \" -> " - \\\" -> \" - \\\\\" -> \\" - */ -#define SHELL_SPECIAL_CHARS "\"\\ \001\002\003\004\005\006\007\010\011\012\013\014\015\016\017\020\021\022\023\024\025\026\027\030\031\032\033\034\035\036\037" -#define SHELL_SPACE_CHARS " \001\002\003\004\005\006\007\010\011\012\013\014\015\016\017\020\021\022\023\024\025\026\027\030\031\032\033\034\035\036\037" -char ** -prepare_spawn (char **argv) -{ - size_t argc; - char **new_argv; - size_t i; - - /* Count number of arguments. */ - for (argc = 0; argv[argc] != NULL; argc++) - ; - - /* Allocate new argument vector. */ - new_argv = XMALLOC (char *, argc + 1); - - /* Put quoted arguments into the new argument vector. */ - for (i = 0; i < argc; i++) - { - const char *string = argv[i]; - - if (string[0] == '\0') - new_argv[i] = xstrdup ("\"\""); - else if (strpbrk (string, SHELL_SPECIAL_CHARS) != NULL) - { - int quote_around = (strpbrk (string, SHELL_SPACE_CHARS) != NULL); - size_t length; - unsigned int backslashes; - const char *s; - char *quoted_string; - char *p; - - length = 0; - backslashes = 0; - if (quote_around) - length++; - for (s = string; *s != '\0'; s++) - { - char c = *s; - if (c == '"') - length += backslashes + 1; - length++; - if (c == '\\') - backslashes++; - else - backslashes = 0; - } - if (quote_around) - length += backslashes + 1; - - quoted_string = XMALLOC (char, length + 1); - - p = quoted_string; - backslashes = 0; - if (quote_around) - *p++ = '"'; - for (s = string; *s != '\0'; s++) - { - char c = *s; - if (c == '"') - { - unsigned int j; - for (j = backslashes + 1; j > 0; j--) - *p++ = '\\'; - } - *p++ = c; - if (c == '\\') - backslashes++; - else - backslashes = 0; - } - if (quote_around) - { - unsigned int j; - for (j = backslashes; j > 0; j--) - *p++ = '\\'; - *p++ = '"'; - } - *p = '\0'; - - new_argv[i] = quoted_string; - } - else - new_argv[i] = (char *) string; - } - new_argv[argc] = NULL; - - return new_argv; -} -EOF - ;; - esac - - cat <<"EOF" -void lt_dump_script (FILE* f) -{ -EOF - func_emit_wrapper yes | - $SED -n -e ' -s/^\(.\{79\}\)\(..*\)/\1\ -\2/ -h -s/\([\\"]\)/\\\1/g -s/$/\\n/ -s/\([^\n]*\).*/ fputs ("\1", f);/p -g -D' - cat <<"EOF" -} -EOF -} -# end: func_emit_cwrapperexe_src - -# func_win32_import_lib_p ARG -# True if ARG is an import lib, as indicated by $file_magic_cmd -func_win32_import_lib_p () -{ - $debug_cmd - - case `eval $file_magic_cmd \"\$1\" 2>/dev/null | $SED -e 10q` in - *import*) : ;; - *) false ;; - esac -} - -# func_suncc_cstd_abi -# !!ONLY CALL THIS FOR SUN CC AFTER $compile_command IS FULLY EXPANDED!! -# Several compiler flags select an ABI that is incompatible with the -# Cstd library. Avoid specifying it if any are in CXXFLAGS. -func_suncc_cstd_abi () -{ - $debug_cmd - - case " $compile_command " in - *" -compat=g "*|*\ -std=c++[0-9][0-9]\ *|*" -library=stdcxx4 "*|*" -library=stlport4 "*) - suncc_use_cstd_abi=no - ;; - *) - suncc_use_cstd_abi=yes - ;; - esac -} - -# func_mode_link arg... -func_mode_link () -{ - $debug_cmd - - 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 - # what 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 that 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 - bindir= - dlfiles= - dlprefiles= - dlself=no - export_dynamic=no - export_symbols= - export_symbols_regex= - generated= - libobjs= - ltlibs= - module=no - no_install=no - objs= - os2dllname= - non_pic_objects= - precious_files_regex= - prefer_static_libs=no - preload=false - 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 yes != "$build_libtool_libs" \ - && func_fatal_configuration "cannot build a shared library" - build_old_libs=no - break - ;; - -all-static | -static | -static-libtool-libs) - case $arg in - -all-static) - if test yes = "$build_libtool_libs" && 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 - bindir) - bindir=$arg - prev= - continue - ;; - dlfiles|dlprefiles) - $preload || { - # Add the symbol object into the linking commands. - func_append compile_command " @SYMFILE@" - func_append finalize_command " @SYMFILE@" - preload=: - } - case $arg in - *.la | *.lo) ;; # We handle these cases below. - force) - if test no = "$dlself"; then - dlself=needless - export_dynamic=yes - fi - prev= - continue - ;; - self) - if test dlprefiles = "$prev"; then - dlself=yes - elif test dlfiles = "$prev" && test yes != "$dlopen_self"; then - dlself=yes - else - dlself=needless - export_dynamic=yes - fi - prev= - continue - ;; - *) - if test dlfiles = "$prev"; then - func_append dlfiles " $arg" - else - func_append 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 "*) ;; - *) func_append deplibs " $qarg.ltframework" # this is fixed later - ;; - esac - ;; - esac - prev= - continue - ;; - inst_prefix) - inst_prefix_dir=$arg - prev= - continue - ;; - mllvm) - # Clang does not use LLVM to link, so we can simply discard any - # '-mllvm $arg' options when doing the link step. - prev= - continue - ;; - objectlist) - if test -f "$arg"; then - save_arg=$arg - moreargs= - for fil in `cat "$save_arg"` - do -# func_append 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 none = "$pic_object" && - test none = "$non_pic_object"; 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 none != "$pic_object"; then - # Prepend the subdirectory the object is found in. - pic_object=$xdir$pic_object - - if test dlfiles = "$prev"; then - if test yes = "$build_libtool_libs" && test yes = "$dlopen_support"; then - func_append 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 dlprefiles = "$prev"; then - # Preload the old-style object. - func_append dlprefiles " $pic_object" - prev= - fi - - # A PIC object. - func_append libobjs " $pic_object" - arg=$pic_object - fi - - # Non-PIC object. - if test none != "$non_pic_object"; 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 none = "$pic_object"; 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 - ;; - os2dllname) - os2dllname=$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 rpath = "$prev"; then - case "$rpath " in - *" $arg "*) ;; - *) func_append rpath " $arg" ;; - esac - else - case "$xrpath " in - *" $arg "*) ;; - *) func_append xrpath " $arg" ;; - esac - fi - prev= - continue - ;; - shrext) - shrext_cmds=$arg - prev= - continue - ;; - weak) - func_append weak_libs " $arg" - prev= - continue - ;; - xcclinker) - func_append linker_flags " $qarg" - func_append compiler_flags " $qarg" - prev= - func_append compile_command " $qarg" - func_append finalize_command " $qarg" - continue - ;; - xcompiler) - func_append compiler_flags " $qarg" - prev= - func_append compile_command " $qarg" - func_append finalize_command " $qarg" - continue - ;; - xlinker) - func_append linker_flags " $qarg" - func_append 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 - ;; - - -bindir) - prev=bindir - 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-export-symbols = "X$arg"; 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" - if test -z "$func_stripname_result"; 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 - func_resolve_sysroot "$func_stripname_result" - dir=$func_resolve_sysroot_result - # 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 "* | *" $arg "*) - # Will only happen for absolute or sysroot arguments - ;; - *) - # Preserve sysroot, but never include relative directories - case $dir in - [\\/]* | [A-Za-z]:[\\/]* | =*) func_append deplibs " $arg" ;; - *) func_append deplibs " -L$dir" ;; - esac - func_append lib_search_path " $dir" - ;; - esac - case $host in - *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2* | *-cegcc*) - testbindir=`$ECHO "$dir" | $SED 's*/lib$*/bin*'` - case :$dllsearchpath: in - *":$dir:"*) ;; - ::) dllsearchpath=$dir;; - *) func_append dllsearchpath ":$dir";; - esac - case :$dllsearchpath: in - *":$testbindir:"*) ;; - ::) dllsearchpath=$testbindir;; - *) func_append dllsearchpath ":$testbindir";; - esac - ;; - esac - continue - ;; - - -l*) - if test X-lc = "X$arg" || test X-lm = "X$arg"; then - case $host in - *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-beos* | *-cegcc* | *-*-haiku*) - # 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-lc = "X$arg" && continue - ;; - *-*-openbsd* | *-*-freebsd* | *-*-dragonfly* | *-*-bitrig*) - # Do not include libc due to us having libc/libc_r. - test X-lc = "X$arg" && continue - ;; - *-*-rhapsody* | *-*-darwin1.[012]) - # Rhapsody C and math libraries are in the System framework - func_append deplibs " System.ltframework" - continue - ;; - *-*-sco3.2v5* | *-*-sco5v6*) - # Causes problems with __ctype - test X-lc = "X$arg" && continue - ;; - *-*-sysv4.2uw2* | *-*-sysv5* | *-*-unixware* | *-*-OpenUNIX*) - # Compiler inserts libc in the correct place for threads to work - test X-lc = "X$arg" && continue - ;; - esac - elif test X-lc_r = "X$arg"; then - case $host in - *-*-openbsd* | *-*-freebsd* | *-*-dragonfly* | *-*-bitrig*) - # Do not include libc_r directly, use -pthread flag. - continue - ;; - esac - fi - func_append deplibs " $arg" - continue - ;; - - -mllvm) - prev=mllvm - 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|--sysroot) - func_append 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|-fopenmp|-openmp|-mp|-xopenmp|-omp|-qsmp=*) - func_append compiler_flags " $arg" - func_append compile_command " $arg" - func_append finalize_command " $arg" - case "$new_inherited_linker_flags " in - *" $arg "*) ;; - * ) func_append 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 - ;; - - -os2dllname) - prev=os2dllname - 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_stripname '=' '' "$dir" - dir=$lt_sysroot$func_stripname_result - ;; - *) - func_fatal_error "only absolute run-paths are allowed" - ;; - esac - case "$xrpath " in - *" $dir "*) ;; - *) func_append 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" - func_append arg " $func_quote_for_eval_result" - func_append 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" - func_append arg " $wl$func_quote_for_eval_result" - func_append compiler_flags " $wl$func_quote_for_eval_result" - func_append 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 - ;; - - # Flags to be passed through unchanged, with rationale: - # -64, -mips[0-9] enable 64-bit mode for the SGI compiler - # -r[0-9][0-9]* specify processor for the SGI compiler - # -xarch=*, -xtarget=* enable 64-bit mode for the Sun compiler - # +DA*, +DD* enable 64-bit mode for the HP compiler - # -q* compiler args for the IBM compiler - # -m*, -t[45]*, -txscale* architecture-specific flags for GCC - # -F/path path to uninstalled frameworks, gcc on darwin - # -p, -pg, --coverage, -fprofile-* profiling flags for GCC - # -fstack-protector* stack protector flags for GCC - # @file GCC response files - # -tp=* Portland pgcc target processor selection - # --sysroot=* for sysroot support - # -O*, -g*, -flto*, -fwhopr*, -fuse-linker-plugin GCC link-time optimization - # -stdlib=* select c++ std lib with clang - -64|-mips[0-9]|-r[0-9][0-9]*|-xarch=*|-xtarget=*|+DA*|+DD*|-q*|-m*| \ - -t[45]*|-txscale*|-p|-pg|--coverage|-fprofile-*|-F*|@*|-tp=*|--sysroot=*| \ - -O*|-g*|-flto*|-fwhopr*|-fuse-linker-plugin|-fstack-protector*|-stdlib=*) - func_quote_for_eval "$arg" - arg=$func_quote_for_eval_result - func_append compile_command " $arg" - func_append finalize_command " $arg" - func_append compiler_flags " $arg" - continue - ;; - - -Z*) - if test os2 = "`expr $host : '.*\(os2\)'`"; then - # OS/2 uses -Zxxx to specify OS/2-specific options - compiler_flags="$compiler_flags $arg" - func_append compile_command " $arg" - func_append finalize_command " $arg" - case $arg in - -Zlinker | -Zstack) - prev=xcompiler - ;; - esac - continue - else - # Otherwise treat like 'Some other compiler flag' below - func_quote_for_eval "$arg" - arg=$func_quote_for_eval_result - fi - ;; - - # Some other compiler flag. - -* | +*) - func_quote_for_eval "$arg" - arg=$func_quote_for_eval_result - ;; - - *.$objext) - # A standard object. - func_append 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 none = "$pic_object" && - test none = "$non_pic_object"; then - func_fatal_error "cannot find name of object for '$arg'" - fi - - # Extract subdirectory from the argument. - func_dirname "$arg" "/" "" - xdir=$func_dirname_result - - test none = "$pic_object" || { - # Prepend the subdirectory the object is found in. - pic_object=$xdir$pic_object - - if test dlfiles = "$prev"; then - if test yes = "$build_libtool_libs" && test yes = "$dlopen_support"; then - func_append 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 dlprefiles = "$prev"; then - # Preload the old-style object. - func_append dlprefiles " $pic_object" - prev= - fi - - # A PIC object. - func_append libobjs " $pic_object" - arg=$pic_object - } - - # Non-PIC object. - if test none != "$non_pic_object"; 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 none = "$pic_object"; 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. - func_append deplibs " $arg" - func_append old_deplibs " $arg" - continue - ;; - - *.la) - # A libtool-controlled library. - - func_resolve_sysroot "$arg" - if test dlfiles = "$prev"; then - # This library was specified with -dlopen. - func_append dlfiles " $func_resolve_sysroot_result" - prev= - elif test dlprefiles = "$prev"; then - # The library was specified with -dlpreopen. - func_append dlprefiles " $func_resolve_sysroot_result" - prev= - else - func_append deplibs " $func_resolve_sysroot_result" - 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 yes = "$export_dynamic" && 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 \"\$$shlibpath_var\" \| \$SED \'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\" - - # Definition is injected by LT_CONFIG during libtool generation. - func_munge_path_list sys_lib_dlsearch_path "$LT_SYS_LIBRARY_PATH" - - func_dirname "$output" "/" "" - output_objdir=$func_dirname_result$objdir - func_to_tool_file "$output_objdir/" - tool_output_objdir=$func_to_tool_file_result - # 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_preserve_dup_deps; then - case "$libs " in - *" $deplib "*) func_append specialdeplibs " $deplib" ;; - esac - fi - func_append libs " $deplib" - done - - if test lib = "$linkmode"; 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 "*) func_append specialdeplibs " $pre_post_deps" ;; - esac - func_append 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=false - 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 lib,link = "$linkmode,$pass"; 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 lib,link = "$linkmode,$pass" || - test prog,scan = "$linkmode,$pass"; then - libs=$deplibs - deplibs= - fi - if test prog = "$linkmode"; then - case $pass in - dlopen) libs=$dlfiles ;; - dlpreopen) libs=$dlprefiles ;; - link) libs="$deplibs %DEPLIBS% $dependency_libs" ;; - esac - fi - if test lib,dlpreopen = "$linkmode,$pass"; then - # Collect and forward deplibs of preopened libtool libs - for lib in $dlprefiles; do - # Ignore non-libtool-libs - dependency_libs= - func_resolve_sysroot "$lib" - case $lib in - *.la) func_source "$func_resolve_sysroot_result" ;; - esac - - # Collect preopened libtool deplibs, except any this library - # has declared as weak libs - for deplib in $dependency_libs; do - func_basename "$deplib" - deplib_base=$func_basename_result - case " $weak_libs " in - *" $deplib_base "*) ;; - *) func_append deplibs " $deplib" ;; - esac - done - done - libs=$dlprefiles - fi - if test dlopen = "$pass"; then - # Collect dlpreopened libraries - save_deplibs=$deplibs - deplibs= - fi - - for deplib in $libs; do - lib= - found=false - case $deplib in - -mt|-mthreads|-kthread|-Kthread|-pthread|-pthreads|--thread-safe \ - |-threads|-fopenmp|-openmp|-mp|-xopenmp|-omp|-qsmp=*) - if test prog,link = "$linkmode,$pass"; then - compile_deplibs="$deplib $compile_deplibs" - finalize_deplibs="$deplib $finalize_deplibs" - else - func_append compiler_flags " $deplib" - if test lib = "$linkmode"; then - case "$new_inherited_linker_flags " in - *" $deplib "*) ;; - * ) func_append new_inherited_linker_flags " $deplib" ;; - esac - fi - fi - continue - ;; - -l*) - if test lib != "$linkmode" && test prog != "$linkmode"; then - func_warning "'-l' is ignored for archives/objects" - continue - fi - func_stripname '-l' '' "$deplib" - name=$func_stripname_result - if test lib = "$linkmode"; 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 .la = "$search_ext"; then - found=: - else - found=false - fi - break 2 - fi - done - done - if $found; then - # 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 yes = "$allow_libtool_libs_with_static_runtimes"; 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=false - func_dirname "$lib" "" "." - ladir=$func_dirname_result - lib=$ladir/$old_library - if test prog,link = "$linkmode,$pass"; then - compile_deplibs="$deplib $compile_deplibs" - finalize_deplibs="$deplib $finalize_deplibs" - else - deplibs="$deplib $deplibs" - test lib = "$linkmode" && newdependency_libs="$deplib $newdependency_libs" - fi - continue - fi - fi - ;; - *) ;; - esac - fi - else - # deplib doesn't seem to be a libtool library - if test prog,link = "$linkmode,$pass"; then - compile_deplibs="$deplib $compile_deplibs" - finalize_deplibs="$deplib $finalize_deplibs" - else - deplibs="$deplib $deplibs" - test lib = "$linkmode" && newdependency_libs="$deplib $newdependency_libs" - fi - continue - fi - ;; # -l - *.ltframework) - if test prog,link = "$linkmode,$pass"; then - compile_deplibs="$deplib $compile_deplibs" - finalize_deplibs="$deplib $finalize_deplibs" - else - deplibs="$deplib $deplibs" - if test lib = "$linkmode"; then - case "$new_inherited_linker_flags " in - *" $deplib "*) ;; - * ) func_append new_inherited_linker_flags " $deplib" ;; - esac - fi - fi - continue - ;; - -L*) - case $linkmode in - lib) - deplibs="$deplib $deplibs" - test conv = "$pass" && continue - newdependency_libs="$deplib $newdependency_libs" - func_stripname '-L' '' "$deplib" - func_resolve_sysroot "$func_stripname_result" - func_append newlib_search_path " $func_resolve_sysroot_result" - ;; - prog) - if test conv = "$pass"; then - deplibs="$deplib $deplibs" - continue - fi - if test scan = "$pass"; then - deplibs="$deplib $deplibs" - else - compile_deplibs="$deplib $compile_deplibs" - finalize_deplibs="$deplib $finalize_deplibs" - fi - func_stripname '-L' '' "$deplib" - func_resolve_sysroot "$func_stripname_result" - func_append newlib_search_path " $func_resolve_sysroot_result" - ;; - *) - func_warning "'-L' is ignored for archives/objects" - ;; - esac # linkmode - continue - ;; # -L - -R*) - if test link = "$pass"; then - func_stripname '-R' '' "$deplib" - func_resolve_sysroot "$func_stripname_result" - dir=$func_resolve_sysroot_result - # Make sure the xrpath contains only unique directories. - case "$xrpath " in - *" $dir "*) ;; - *) func_append xrpath " $dir" ;; - esac - fi - deplibs="$deplib $deplibs" - continue - ;; - *.la) - func_resolve_sysroot "$deplib" - lib=$func_resolve_sysroot_result - ;; - *.$libext) - if test conv = "$pass"; 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=false - case $deplibs_check_method in - match_pattern*) - set dummy $deplibs_check_method; shift - match_pattern_regex=`expr "$deplibs_check_method" : "$1 \(.*\)"` - if eval "\$ECHO \"$deplib\"" 2>/dev/null | $SED 10q \ - | $EGREP "$match_pattern_regex" > /dev/null; then - valid_a_lib=: - fi - ;; - pass_all) - valid_a_lib=: - ;; - esac - if $valid_a_lib; then - echo - $ECHO "*** Warning: Linking the shared library $output against the" - $ECHO "*** static library $deplib is not portable!" - deplibs="$deplib $deplibs" - else - 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." - fi - ;; - esac - continue - ;; - prog) - if test link != "$pass"; then - deplibs="$deplib $deplibs" - else - compile_deplibs="$deplib $compile_deplibs" - finalize_deplibs="$deplib $finalize_deplibs" - fi - continue - ;; - esac # linkmode - ;; # *.$libext - *.lo | *.$objext) - if test conv = "$pass"; then - deplibs="$deplib $deplibs" - elif test prog = "$linkmode"; then - if test dlpreopen = "$pass" || test yes != "$dlopen_support" || test no = "$build_libtool_libs"; then - # If there is no dlopen support or we're linking statically, - # we need to preload. - func_append newdlprefiles " $deplib" - compile_deplibs="$deplib $compile_deplibs" - finalize_deplibs="$deplib $finalize_deplibs" - else - func_append newdlfiles " $deplib" - fi - fi - continue - ;; - %DEPLIBS%) - alldeplibs=: - continue - ;; - esac # case $deplib - - $found || test -f "$lib" \ - || func_fatal_error "cannot find the library '$lib' or unhandled argument '$deplib'" - - # 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 "$inherited_linker_flags" | $SED '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 "*) ;; - *) func_append new_inherited_linker_flags " $tmp_inherited_linker_flag";; - esac - done - fi - dependency_libs=`$ECHO " $dependency_libs" | $SED 's% \([^ $]*\).ltframework% -framework \1%g'` - if test lib,link = "$linkmode,$pass" || - test prog,scan = "$linkmode,$pass" || - { test prog != "$linkmode" && test lib != "$linkmode"; }; then - test -n "$dlopen" && func_append dlfiles " $dlopen" - test -n "$dlpreopen" && func_append dlprefiles " $dlpreopen" - fi - - if test conv = "$pass"; 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. - func_append convenience " $ladir/$objdir/$old_library" - func_append old_convenience " $ladir/$objdir/$old_library" - elif test prog != "$linkmode" && test lib != "$linkmode"; then - func_fatal_error "'$lib' is not a convenience library" - fi - tmp_libs= - for deplib in $dependency_libs; do - deplibs="$deplib $deplibs" - if $opt_preserve_dup_deps; then - case "$tmp_libs " in - *" $deplib "*) func_append specialdeplibs " $deplib" ;; - esac - fi - func_append tmp_libs " $deplib" - done - continue - fi # $pass = conv - - - # Get the name of the library we link against. - linklib= - if test -n "$old_library" && - { test yes = "$prefer_static_libs" || - test built,no = "$prefer_static_libs,$installed"; }; then - linklib=$old_library - else - for l in $old_library $library_names; do - linklib=$l - done - fi - 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 dlopen = "$pass"; then - test -z "$libdir" \ - && func_fatal_error "cannot -dlopen a convenience library: '$lib'" - if test -z "$dlname" || - test yes != "$dlopen_support" || - test no = "$build_libtool_libs" - 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. - func_append dlprefiles " $lib $dependency_libs" - else - func_append 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 yes = "$installed"; then - if test ! -f "$lt_sysroot$libdir/$linklib" && test -f "$abs_ladir/$linklib"; then - func_warning "library '$lib' was moved." - dir=$ladir - absdir=$abs_ladir - libdir=$abs_ladir - else - dir=$lt_sysroot$libdir - absdir=$lt_sysroot$libdir - fi - test yes = "$hardcode_automatic" && 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 - func_append notinst_path " $abs_ladir" - else - dir=$ladir/$objdir - absdir=$abs_ladir/$objdir - # Remove this search path later - func_append 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 dlpreopen = "$pass"; then - if test -z "$libdir" && test prog = "$linkmode"; then - func_fatal_error "only libraries may -dlpreopen a convenience library: '$lib'" - fi - case $host in - # special handling for platforms with PE-DLLs. - *cygwin* | *mingw* | *cegcc* ) - # Linker will automatically link against shared library if both - # static and shared are present. Therefore, ensure we extract - # symbols from the import library if a shared library is present - # (otherwise, the dlopen module name will be incorrect). We do - # this by putting the import library name into $newdlprefiles. - # We recover the dlopen module name by 'saving' the la file - # name in a special purpose variable, and (later) extracting the - # dlname from the la file. - if test -n "$dlname"; then - func_tr_sh "$dir/$linklib" - eval "libfile_$func_tr_sh_result=\$abs_ladir/\$laname" - func_append newdlprefiles " $dir/$linklib" - else - func_append 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" && \ - func_append dlpreconveniencelibs " $dir/$old_library" - fi - ;; - * ) - # Prefer using a static library (so that no silly _DYNAMIC symbols - # are required to link). - if test -n "$old_library"; then - func_append 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" && \ - func_append dlpreconveniencelibs " $dir/$old_library" - # Otherwise, use the dlname, so that lt_dlopen finds it. - elif test -n "$dlname"; then - func_append newdlprefiles " $dir/$dlname" - else - func_append newdlprefiles " $dir/$linklib" - fi - ;; - esac - fi # $pass = dlpreopen - - if test -z "$libdir"; then - # Link the convenience library - if test lib = "$linkmode"; then - deplibs="$dir/$old_library $deplibs" - elif test prog,link = "$linkmode,$pass"; 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 prog = "$linkmode" && test link != "$pass"; then - func_append newlib_search_path " $ladir" - deplibs="$lib $deplibs" - - linkalldeplibs=false - if test no != "$link_all_deplibs" || test -z "$library_names" || - test no = "$build_libtool_libs"; then - linkalldeplibs=: - fi - - tmp_libs= - for deplib in $dependency_libs; do - case $deplib in - -L*) func_stripname '-L' '' "$deplib" - func_resolve_sysroot "$func_stripname_result" - func_append newlib_search_path " $func_resolve_sysroot_result" - ;; - esac - # Need to link against all dependency_libs? - if $linkalldeplibs; 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_preserve_dup_deps; then - case "$tmp_libs " in - *" $deplib "*) func_append specialdeplibs " $deplib" ;; - esac - fi - func_append tmp_libs " $deplib" - done # for deplib - continue - fi # $linkmode = prog... - - if test prog,link = "$linkmode,$pass"; then - if test -n "$library_names" && - { { test no = "$prefer_static_libs" || - test built,yes = "$prefer_static_libs,$installed"; } || - 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:"*) ;; - *) func_append 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 "*) ;; - *) func_append compile_rpath " $absdir" ;; - esac - ;; - esac - case " $sys_lib_dlsearch_path " in - *" $libdir "*) ;; - *) - case "$finalize_rpath " in - *" $libdir "*) ;; - *) func_append finalize_rpath " $libdir" ;; - esac - ;; - esac - fi # $linkmode,$pass = prog,link... - - if $alldeplibs && - { test pass_all = "$deplibs_check_method" || - { test yes = "$build_libtool_libs" && - 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 built = "$use_static_libs" && test yes = "$installed"; then - use_static_libs=no - fi - if test -n "$library_names" && - { test no = "$use_static_libs" || test -z "$old_library"; }; then - case $host in - *cygwin* | *mingw* | *cegcc* | *os2*) - # No point in relinking DLLs because paths are not encoded - func_append notinst_deplibs " $lib" - need_relink=no - ;; - *) - if test no = "$installed"; then - func_append 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 yes = "$shouldnotlink" && test link = "$pass"; then - echo - if test prog = "$linkmode"; 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 lib = "$linkmode" && - test yes = "$hardcode_into_libs"; 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 "*) ;; - *) func_append compile_rpath " $absdir" ;; - esac - ;; - esac - case " $sys_lib_dlsearch_path " in - *" $libdir "*) ;; - *) - case "$finalize_rpath " in - *" $libdir "*) ;; - *) func_append 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* | *os2*) - 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 prog = "$linkmode" || test relink != "$opt_mode"; then - add_shlibpath= - add_dir= - add= - lib_linked=yes - case $hardcode_action in - immediate | unsupported) - if test no = "$hardcode_direct"; 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 cannot - # 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 no = "$hardcode_minus_L"; then - case $host in - *-*-sunos*) add_shlibpath=$dir ;; - esac - add_dir=-L$dir - add=-l$name - elif test no = "$hardcode_shlibpath_var"; then - add_shlibpath=$dir - add=-l$name - else - lib_linked=no - fi - ;; - relink) - if test yes = "$hardcode_direct" && - test no = "$hardcode_direct_absolute"; then - add=$dir/$linklib - elif test yes = "$hardcode_minus_L"; then - add_dir=-L$absdir - # Try looking first in the location we're being installed to. - if test -n "$inst_prefix_dir"; then - case $libdir in - [\\/]*) - func_append add_dir " -L$inst_prefix_dir$libdir" - ;; - esac - fi - add=-l$name - elif test yes = "$hardcode_shlibpath_var"; then - add_shlibpath=$dir - add=-l$name - else - lib_linked=no - fi - ;; - *) lib_linked=no ;; - esac - - if test yes != "$lib_linked"; then - func_fatal_configuration "unsupported hardcode properties" - fi - - if test -n "$add_shlibpath"; then - case :$compile_shlibpath: in - *":$add_shlibpath:"*) ;; - *) func_append compile_shlibpath "$add_shlibpath:" ;; - esac - fi - if test prog = "$linkmode"; 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 yes != "$hardcode_direct" && - test yes != "$hardcode_minus_L" && - test yes = "$hardcode_shlibpath_var"; then - case :$finalize_shlibpath: in - *":$libdir:"*) ;; - *) func_append finalize_shlibpath "$libdir:" ;; - esac - fi - fi - fi - - if test prog = "$linkmode" || test relink = "$opt_mode"; then - add_shlibpath= - add_dir= - add= - # Finalize command for both is simple: just hardcode it. - if test yes = "$hardcode_direct" && - test no = "$hardcode_direct_absolute"; then - add=$libdir/$linklib - elif test yes = "$hardcode_minus_L"; then - add_dir=-L$libdir - add=-l$name - elif test yes = "$hardcode_shlibpath_var"; then - case :$finalize_shlibpath: in - *":$libdir:"*) ;; - *) func_append finalize_shlibpath "$libdir:" ;; - esac - add=-l$name - elif test yes = "$hardcode_automatic"; 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 - [\\/]*) - func_append add_dir " -L$inst_prefix_dir$libdir" - ;; - esac - fi - add=-l$name - fi - - if test prog = "$linkmode"; 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 prog = "$linkmode"; 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 unsupported != "$hardcode_direct"; 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 yes = "$build_libtool_libs"; then - # Not a shared library - if test pass_all != "$deplibs_check_method"; 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 cannot 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 yes = "$module"; 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 no = "$build_old_libs"; 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 lib = "$linkmode"; then - if test -n "$dependency_libs" && - { test yes != "$hardcode_into_libs" || - test yes = "$build_old_libs" || - test yes = "$link_static"; }; 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 "*) ;; - *) func_append xrpath " $temp_xrpath";; - esac;; - *) func_append temp_deplibs " $libdir";; - esac - done - dependency_libs=$temp_deplibs - fi - - func_append newlib_search_path " $absdir" - # Link against this library - test no = "$link_static" && newdependency_libs="$abs_ladir/$laname $newdependency_libs" - # ... and its dependency_libs - tmp_libs= - for deplib in $dependency_libs; do - newdependency_libs="$deplib $newdependency_libs" - case $deplib in - -L*) func_stripname '-L' '' "$deplib" - func_resolve_sysroot "$func_stripname_result";; - *) func_resolve_sysroot "$deplib" ;; - esac - if $opt_preserve_dup_deps; then - case "$tmp_libs " in - *" $func_resolve_sysroot_result "*) - func_append specialdeplibs " $func_resolve_sysroot_result" ;; - esac - fi - func_append tmp_libs " $func_resolve_sysroot_result" - done - - if test no != "$link_all_deplibs"; then - # Add the search paths of all dependency libraries - for deplib in $dependency_libs; do - path= - case $deplib in - -L*) path=$deplib ;; - *.la) - func_resolve_sysroot "$deplib" - deplib=$func_resolve_sysroot_result - 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 - func_append compiler_flags " $wl-dylib_file $wl$darwin_install_name:$depdepl" - func_append 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 link = "$pass"; then - if test prog = "$linkmode"; then - compile_deplibs="$new_inherited_linker_flags $compile_deplibs" - finalize_deplibs="$new_inherited_linker_flags $finalize_deplibs" - else - compiler_flags="$compiler_flags "`$ECHO " $new_inherited_linker_flags" | $SED 's% \([^ $]*\).ltframework% -framework \1%g'` - fi - fi - dependency_libs=$newdependency_libs - if test dlpreopen = "$pass"; then - # Link the dlpreopened libraries before other libraries - for deplib in $save_deplibs; do - deplibs="$deplib $deplibs" - done - fi - if test dlopen != "$pass"; then - test conv = "$pass" || { - # 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 "*) ;; - *) func_append lib_search_path " $dir" ;; - esac - done - newlib_search_path= - } - - if test prog,link = "$linkmode,$pass"; then - vars="compile_deplibs finalize_deplibs" - else - vars=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 "*) ;; - *) func_append tmp_libs " $deplib" ;; - esac - ;; - *) func_append tmp_libs " $deplib" ;; - esac - done - eval $var=\"$tmp_libs\" - done # for var - fi - - # Add Sun CC postdeps if required: - test CXX = "$tagname" && { - case $host_os in - linux*) - case `$CC -V 2>&1 | sed 5q` in - *Sun\ C*) # Sun C++ 5.9 - func_suncc_cstd_abi - - if test no != "$suncc_use_cstd_abi"; then - func_append postdeps ' -library=Cstd -library=Crun' - fi - ;; - esac - ;; - - solaris*) - func_cc_basename "$CC" - case $func_cc_basename_result in - CC* | sunCC*) - func_suncc_cstd_abi - - if test no != "$suncc_use_cstd_abi"; then - func_append postdeps ' -library=Cstd -library=Crun' - fi - ;; - esac - ;; - esac - } - - # 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 - func_append tmp_libs " $i" - fi - done - dependency_libs=$tmp_libs - done # for pass - if test prog = "$linkmode"; then - dlfiles=$newdlfiles - fi - if test prog = "$linkmode" || test lib = "$linkmode"; then - dlprefiles=$newdlprefiles - fi - - case $linkmode in - oldlib) - if test -n "$dlfiles$dlprefiles" || test no != "$dlself"; 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 - func_append 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 no = "$module" \ - && func_fatal_help "libtool library '$output' must begin with 'lib'" - - if test no != "$need_lib_prefix"; 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 pass_all != "$deplibs_check_method"; 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!" - func_append libobjs " $objs" - fi - fi - - test no = "$dlself" \ - || func_warning "'-dlopen self' is ignored for libtool libraries" - - set dummy $rpath - shift - test 1 -lt "$#" \ - && func_warning "ignoring multiple '-rpath's for a libtool library" - - install_libdir=$1 - - oldlibs= - if test -z "$rpath"; then - if test yes = "$build_libtool_libs"; 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 - # that has an extra 1 added just for fun - # - case $version_type in - # correct linux to gnu/linux during the next big refactor - darwin|freebsd-elf|linux|osf|windows|none) - func_arith $number_major + $number_minor - current=$func_arith_result - age=$number_minor - revision=$number_revision - ;; - freebsd-aout|qnx|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 - ;; - 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" - # On Darwin other compilers - case $CC in - nagfor*) - verstring="$wl-compatibility_version $wl$minor_current $wl-current_version $wl$minor_current.$revision" - ;; - *) - verstring="-compatibility_version $minor_current -current_version $minor_current.$revision" - ;; - esac - ;; - - freebsd-aout) - major=.$current - versuffix=.$current.$revision - ;; - - freebsd-elf) - func_arith $current - $age - major=.$func_arith_result - versuffix=$major.$age.$revision - ;; - - irix | nonstopux) - if test no = "$lt_irix_increment"; 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 0 -ne "$loop"; 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) # correct to gnu/linux during the next big refactor - 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 0 -ne "$loop"; 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. - func_append verstring ":$current.0" - ;; - - qnx) - major=.$current - versuffix=.$current - ;; - - sco) - major=.$current - versuffix=.$current - ;; - - sunos) - major=.$current - versuffix=.$current.$revision - ;; - - windows) - # Use '-' rather than '.', since we only want one - # extension on DOS 8.3 file systems. - 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 no = "$need_version"; then - versuffix= - else - versuffix=.0.0 - fi - fi - - # Remove version info from name if versioning should be avoided - if test yes,no = "$avoid_version,$need_version"; then - major= - versuffix= - verstring= - fi - - # Check to see if the archive will have undefined symbols. - if test yes = "$allow_undefined"; then - if test unsupported = "$allow_undefined_flag"; then - if test yes = "$build_old_libs"; then - func_warning "undefined symbols not allowed in $host shared libraries; building static only" - build_libtool_libs=no - else - func_fatal_error "can't build $host shared library unless -no-undefined is specified" - fi - fi - else - # Don't allow undefined symbols. - allow_undefined_flag=$no_undefined_flag - fi - - fi - - func_generate_dlsyms "$libname" "$libname" : - func_append libobjs " $symfileobj" - test " " = "$libobjs" && libobjs= - - if test relink != "$opt_mode"; 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 -n "$precious_files_regex"; then - if $ECHO "$p" | $EGREP -e "$precious_files_regex" >/dev/null 2>&1 - then - continue - fi - fi - func_append removelist " $p" - ;; - *) ;; - esac - done - test -n "$removelist" && \ - func_show_eval "${RM}r \$removelist" - fi - - # Now set the variables for building old libraries. - if test yes = "$build_old_libs" && test convenience != "$build_libtool_libs"; then - func_append oldlibs " $output_objdir/$libname.$libext" - - # Transform .lo files to .o files. - oldobjs="$objs "`$ECHO "$libobjs" | $SP2NL | $SED "/\.$libext$/d; $lo2o" | $NL2SP` - fi - - # Eliminate all temporary directories. - #for path in $notinst_path; do - # lib_search_path=`$ECHO "$lib_search_path " | $SED "s% $path % %g"` - # deplibs=`$ECHO "$deplibs " | $SED "s% -L$path % %g"` - # dependency_libs=`$ECHO "$dependency_libs " | $SED "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 - func_replace_sysroot "$libdir" - func_append temp_xrpath " -R$func_replace_sysroot_result" - case "$finalize_rpath " in - *" $libdir "*) ;; - *) func_append finalize_rpath " $libdir" ;; - esac - done - if test yes != "$hardcode_into_libs" || test yes = "$build_old_libs"; 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 "*) ;; - *) func_append 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 "*) ;; - *) func_append dlprefiles " $lib" ;; - esac - done - - if test yes = "$build_libtool_libs"; then - if test -n "$rpath"; then - case $host in - *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2* | *-*-beos* | *-cegcc* | *-*-haiku*) - # these systems don't actually have a c library (as such)! - ;; - *-*-rhapsody* | *-*-darwin1.[012]) - # Rhapsody C library is in the System framework - func_append 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 yes = "$build_libtool_need_lc"; then - func_append 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` - $nocaseglob - else - potential_libs=`ls $i/$libnameglob[.-]* 2>/dev/null` - fi - 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 "$potlib" | $SED 's|[^/]*$||'`"$potliblink";; - esac - done - if eval $file_magic_cmd \"\$potlib\" 2>/dev/null | - $SED -e 10q | - $EGREP "$file_magic_regex" > /dev/null; then - func_append 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. - func_append 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 yes = "$allow_libtool_libs_with_static_runtimes"; then - case " $predeps $postdeps " in - *" $a_deplib "*) - func_append 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 \"$potent_lib\"" 2>/dev/null | $SED 10q | \ - $EGREP "$match_pattern_regex" > /dev/null; then - func_append 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. - func_append newdeplibs " $a_deplib" - ;; - esac - done # Gone through all deplibs. - ;; - none | unknown | *) - newdeplibs= - tmp_deplibs=`$ECHO " $deplibs" | $SED 's/ -lc$//; s/ -[LR][^ ]*//g'` - if test yes = "$allow_libtool_libs_with_static_runtimes"; then - for i in $predeps $postdeps; do - # can't use Xsed below, because $i might contain '/' - tmp_deplibs=`$ECHO " $tmp_deplibs" | $SED "s|$i||"` - done - fi - case $tmp_deplibs in - *[!\ \ ]*) - echo - if test none = "$deplibs_check_method"; 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 - ;; - esac - ;; - 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 " $newdeplibs" | $SED 's/ -lc / System.ltframework /'` - ;; - esac - - if test yes = "$droppeddeps"; then - if test yes = "$module"; 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 no = "$build_old_libs"; 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 no = "$allow_undefined"; 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 no = "$build_old_libs"; 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 " $newdeplibs" | $SED 's% \([^ $]*\).ltframework% -framework \1%g'` - new_inherited_linker_flags=`$ECHO " $new_inherited_linker_flags" | $SED 's% \([^ $]*\).ltframework% -framework \1%g'` - deplibs=`$ECHO " $deplibs" | $SED '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 "*) - func_append new_libs " -L$path/$objdir" ;; - esac - ;; - esac - done - for deplib in $deplibs; do - case $deplib in - -L*) - case " $new_libs " in - *" $deplib "*) ;; - *) func_append new_libs " $deplib" ;; - esac - ;; - *) func_append 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 yes = "$build_libtool_libs"; then - # Remove $wl instances when linking with ld. - # FIXME: should test the right _cmds variable. - case $archive_cmds in - *\$LD\ *) wl= ;; - esac - if test yes = "$hardcode_into_libs"; then - # Hardcode the library paths - hardcode_libdirs= - dep_rpath= - rpath=$finalize_rpath - test relink = "$opt_mode" || rpath=$compile_rpath$rpath - for libdir in $rpath; do - if test -n "$hardcode_libdir_flag_spec"; then - if test -n "$hardcode_libdir_separator"; then - func_replace_sysroot "$libdir" - libdir=$func_replace_sysroot_result - 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"*) - ;; - *) - func_append hardcode_libdirs "$hardcode_libdir_separator$libdir" - ;; - esac - fi - else - eval flag=\"$hardcode_libdir_flag_spec\" - func_append dep_rpath " $flag" - fi - elif test -n "$runpath_var"; then - case "$perm_rpath " in - *" $libdir "*) ;; - *) func_append 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 "dep_rpath=\"$hardcode_libdir_flag_spec\"" - fi - if test -n "$runpath_var" && test -n "$perm_rpath"; then - # We should set the runpath_var. - rpath= - for dir in $perm_rpath; do - func_append 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 relink = "$opt_mode" || 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 - func_append linknames " $link" - done - - # Use standard objects if they are pic - test -z "$pic_flag" && libobjs=`$ECHO "$libobjs" | $SP2NL | $SED "$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 - func_append 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 - func_dll_def_p "$export_symbols" || { - # 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 - ;; - esac - - # Prepare the list of exported symbols - if test -z "$export_symbols"; then - if test yes = "$always_export_symbols" || 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 cmd1 in $cmds; do - IFS=$save_ifs - # Take the normal branch if the nm_file_list_spec branch - # doesn't work or if tool conversion is not needed. - case $nm_file_list_spec~$to_tool_file_cmd in - *~func_convert_file_noop | *~func_convert_file_msys_to_w32 | ~*) - try_normal_branch=yes - eval cmd=\"$cmd1\" - func_len " $cmd" - len=$func_len_result - ;; - *) - try_normal_branch=no - ;; - esac - if test yes = "$try_normal_branch" \ - && { test "$len" -lt "$max_cmd_len" \ - || test "$max_cmd_len" -le -1; } - then - func_show_eval "$cmd" 'exit $?' - skipped_export=false - elif test -n "$nm_file_list_spec"; then - func_basename "$output" - output_la=$func_basename_result - save_libobjs=$libobjs - save_output=$output - output=$output_objdir/$output_la.nm - func_to_tool_file "$output" - libobjs=$nm_file_list_spec$func_to_tool_file_result - func_append delfiles " $output" - func_verbose "creating $NM input file list: $output" - for obj in $save_libobjs; do - func_to_tool_file "$obj" - $ECHO "$func_to_tool_file_result" - done > "$output" - eval cmd=\"$cmd1\" - func_show_eval "$cmd" 'exit $?' - output=$save_output - libobjs=$save_libobjs - 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 : != "$skipped_export"; 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 "$include_expsyms" | $SP2NL >> "$tmp_export_symbols"' - fi - - if test : != "$skipped_export" && 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 - func_append 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 "*) ;; - *) - func_append tmp_deplibs " $test_deplib" - ;; - esac - done - deplibs=$tmp_deplibs - - if test -n "$convenience"; then - if test -n "$whole_archive_flag_spec" && - test yes = "$compiler_needs_object" && - 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 - func_append generated " $gentop" - - func_extract_archives $gentop $convenience - func_append libobjs " $func_extract_archives_result" - test "X$libobjs" = "X " && libobjs= - fi - fi - - if test yes = "$thread_safe" && test -n "$thread_safe_flag_spec"; then - eval flag=\"$thread_safe_flag_spec\" - func_append linker_flags " $flag" - fi - - # Make a backup of the uninstalled library when relinking - if test relink = "$opt_mode"; 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 yes = "$module" && 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 : != "$skipped_export" && - 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 - func_basename "$output" - output_la=$func_basename_result - - # 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 : != "$skipped_export" && test yes = "$with_gnu_ld"; then - output=$output_objdir/$output_la.lnkscript - func_verbose "creating GNU ld script: $output" - echo 'INPUT (' > $output - for obj in $save_libobjs - do - func_to_tool_file "$obj" - $ECHO "$func_to_tool_file_result" >> $output - done - echo ')' >> $output - func_append delfiles " $output" - func_to_tool_file "$output" - output=$func_to_tool_file_result - elif test -n "$save_libobjs" && test : != "$skipped_export" && test -n "$file_list_spec"; then - output=$output_objdir/$output_la.lnk - func_verbose "creating linker input file list: $output" - : > $output - set x $save_libobjs - shift - firstobj= - if test yes = "$compiler_needs_object"; then - firstobj="$1 " - shift - fi - for obj - do - func_to_tool_file "$obj" - $ECHO "$func_to_tool_file_result" >> $output - done - func_append delfiles " $output" - func_to_tool_file "$output" - output=$firstobj\"$file_list_spec$func_to_tool_file_result\" - 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 -z "$objlist" || - 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 1 -eq "$k"; then - # The first file doesn't have a previous command to add. - reload_objs=$objlist - eval concat_cmds=\"$reload_cmds\" - else - # All subsequent reloadable object files will link in - # the last one created. - reload_objs="$objlist $last_robj" - eval concat_cmds=\"\$concat_cmds~$reload_cmds~\$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~ - reload_objs="$objlist $last_robj" - eval concat_cmds=\"\$concat_cmds$reload_cmds\" - if test -n "$last_robj"; then - eval concat_cmds=\"\$concat_cmds~\$RM $last_robj\" - fi - func_append delfiles " $output" - - else - output= - fi - - ${skipped_export-false} && { - 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 - } - - 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_quiet || { - 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 relink = "$opt_mode"; 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 - - ${skipped_export-false} && { - 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 "$include_expsyms" | $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 - func_append 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 - } - - 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 yes = "$module" && 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 - func_append generated " $gentop" - - func_extract_archives $gentop $dlprefiles - func_append libobjs " $func_extract_archives_result" - test "X$libobjs" = "X " && libobjs= - fi - - save_ifs=$IFS; IFS='~' - for cmd in $cmds; do - IFS=$sp$nl - eval cmd=\"$cmd\" - IFS=$save_ifs - $opt_quiet || { - 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 relink = "$opt_mode"; 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 relink = "$opt_mode"; 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 yes = "$module" || test yes = "$export_dynamic"; then - # On all known operating systems, these are identical. - dlname=$soname - fi - fi - ;; - - obj) - if test -n "$dlfiles$dlprefiles" || test no != "$dlself"; 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= - # if reload_cmds runs $LD directly, get rid of -Wl from - # whole_archive_flag_spec and hope we can get by with turning comma - # into space. - case $reload_cmds in - *\$LD[\ \$]*) wl= ;; - esac - if test -n "$convenience"; then - if test -n "$whole_archive_flag_spec"; then - eval tmp_whole_archive_flags=\"$whole_archive_flag_spec\" - test -n "$wl" || tmp_whole_archive_flags=`$ECHO "$tmp_whole_archive_flags" | $SED 's|,| |g'` - reload_conv_objs=$reload_objs\ $tmp_whole_archive_flags - else - gentop=$output_objdir/${obj}x - func_append generated " $gentop" - - func_extract_archives $gentop $convenience - reload_conv_objs="$reload_objs $func_extract_archives_result" - fi - fi - - # If we're not building shared, we need to use non_pic_objs - test yes = "$build_libtool_libs" || libobjs=$non_pic_objects - - # Create the old-style object. - reload_objs=$objs$old_deplibs' '`$ECHO "$libobjs" | $SP2NL | $SED "/\.$libext$/d; /\.lib$/d; $lo2o" | $NL2SP`' '$reload_conv_objs - - 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 - - test yes = "$build_libtool_libs" || { - 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 - } - - if test -n "$pic_flag" || test default != "$pic_mode"; 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" - - $preload \ - && test unknown,unknown,unknown = "$dlopen_support,$dlopen_self,$dlopen_self_static" \ - && 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 " $compile_deplibs" | $SED 's/ -lc / System.ltframework /'` - finalize_deplibs=`$ECHO " $finalize_deplibs" | $SED '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 CXX = "$tagname"; then - case ${MACOSX_DEPLOYMENT_TARGET-10.0} in - 10.[0123]) - func_append compile_command " $wl-bind_at_load" - func_append finalize_command " $wl-bind_at_load" - ;; - esac - fi - # Time to change all our "foo.ltframework" stuff back to "-framework foo" - compile_deplibs=`$ECHO " $compile_deplibs" | $SED 's% \([^ $]*\).ltframework% -framework \1%g'` - finalize_deplibs=`$ECHO " $finalize_deplibs" | $SED '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 "*) - func_append new_libs " -L$path/$objdir" ;; - esac - ;; - esac - done - for deplib in $compile_deplibs; do - case $deplib in - -L*) - case " $new_libs " in - *" $deplib "*) ;; - *) func_append new_libs " $deplib" ;; - esac - ;; - *) func_append new_libs " $deplib" ;; - esac - done - compile_deplibs=$new_libs - - - func_append compile_command " $compile_deplibs" - func_append 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 "*) ;; - *) func_append 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"*) - ;; - *) - func_append hardcode_libdirs "$hardcode_libdir_separator$libdir" - ;; - esac - fi - else - eval flag=\"$hardcode_libdir_flag_spec\" - func_append rpath " $flag" - fi - elif test -n "$runpath_var"; then - case "$perm_rpath " in - *" $libdir "*) ;; - *) func_append 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;; - *) func_append dllsearchpath ":$libdir";; - esac - case :$dllsearchpath: in - *":$testbindir:"*) ;; - ::) dllsearchpath=$testbindir;; - *) func_append 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"*) - ;; - *) - func_append hardcode_libdirs "$hardcode_libdir_separator$libdir" - ;; - esac - fi - else - eval flag=\"$hardcode_libdir_flag_spec\" - func_append rpath " $flag" - fi - elif test -n "$runpath_var"; then - case "$finalize_perm_rpath " in - *" $libdir "*) ;; - *) func_append 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 yes = "$build_old_libs"; then - # Transform all the library objects into standard objects. - compile_command=`$ECHO "$compile_command" | $SP2NL | $SED "$lo2o" | $NL2SP` - finalize_command=`$ECHO "$finalize_command" | $SP2NL | $SED "$lo2o" | $NL2SP` - fi - - func_generate_dlsyms "$outputname" "@PROGRAM@" false - - # template prelinking step - if test -n "$prelink_cmds"; then - func_execute_cmds "$prelink_cmds" 'exit $?' - fi - - wrappers_required=: - case $host in - *cegcc* | *mingw32ce*) - # Disable wrappers for cegcc and mingw32ce hosts, we are cross compiling anyway. - wrappers_required=false - ;; - *cygwin* | *mingw* ) - test yes = "$build_libtool_libs" || wrappers_required=false - ;; - *) - if test no = "$need_relink" || test yes != "$build_libtool_libs"; then - wrappers_required=false - fi - ;; - esac - $wrappers_required || { - # Replace the output file specification. - compile_command=`$ECHO "$compile_command" | $SED '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=$?' - - if test -n "$postlink_cmds"; then - func_to_tool_file "$output" - postlink_cmds=`func_echo_all "$postlink_cmds" | $SED -e 's%@OUTPUT@%'"$output"'%g' -e 's%@TOOL_OUTPUT@%'"$func_to_tool_file_result"'%g'` - func_execute_cmds "$postlink_cmds" 'exit $?' - fi - - # 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 - } - - 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 - func_append 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 - func_append rpath "$dir:" - done - finalize_var="$runpath_var=\"$rpath\$$runpath_var\" " - fi - fi - - if test yes = "$no_install"; 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 "$link_command" | $SED '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 $?' - - if test -n "$postlink_cmds"; then - func_to_tool_file "$output" - postlink_cmds=`func_echo_all "$postlink_cmds" | $SED -e 's%@OUTPUT@%'"$output"'%g' -e 's%@TOOL_OUTPUT@%'"$func_to_tool_file_result"'%g'` - func_execute_cmds "$postlink_cmds" 'exit $?' - fi - - exit $EXIT_SUCCESS - fi - - case $hardcode_action,$fast_install in - relink,*) - # 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" - ;; - *,yes) - link_command=$finalize_var$compile_command$finalize_rpath - relink_command=`$ECHO "$compile_var$compile_command$compile_rpath" | $SED 's%@OUTPUT@%\$progdir/\$file%g'` - ;; - *,no) - link_command=$compile_var$compile_command$compile_rpath - relink_command=$finalize_var$finalize_command$finalize_rpath - ;; - *,needless) - link_command=$finalize_var$compile_command$finalize_rpath - relink_command= - ;; - esac - - # Replace the output file specification. - link_command=`$ECHO "$link_command" | $SED '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 $?' - - if test -n "$postlink_cmds"; then - func_to_tool_file "$output_objdir/$outputname" - postlink_cmds=`func_echo_all "$postlink_cmds" | $SED -e 's%@OUTPUT@%'"$output_objdir/$outputname"'%g' -e 's%@TOOL_OUTPUT@%'"$func_to_tool_file_result"'%g'` - func_execute_cmds "$postlink_cmds" 'exit $?' - fi - - # 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 "$relink_command" | $SED "$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 - - case $build_libtool_libs in - convenience) - oldobjs="$libobjs_save $symfileobj" - addlibs=$convenience - build_libtool_libs=no - ;; - module) - oldobjs=$libobjs_save - addlibs=$old_convenience - build_libtool_libs=no - ;; - *) - oldobjs="$old_deplibs $non_pic_objects" - $preload && test -f "$symfileobj" \ - && func_append oldobjs " $symfileobj" - addlibs=$old_convenience - ;; - esac - - if test -n "$addlibs"; then - gentop=$output_objdir/${outputname}x - func_append generated " $gentop" - - func_extract_archives $gentop $addlibs - func_append oldobjs " $func_extract_archives_result" - fi - - # Do each command in the archive commands. - if test -n "$old_archive_from_new_cmds" && test yes = "$build_libtool_libs"; 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 - func_append generated " $gentop" - - func_extract_archives $gentop $dlprefiles - func_append 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 - func_append 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" - func_append oldobjs " $gentop/$newobj" - ;; - *) func_append oldobjs " $obj" ;; - esac - done - fi - func_to_tool_file "$oldlib" func_convert_file_msys_to_w32 - tool_oldlib=$func_to_tool_file_result - 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 - elif test -n "$archiver_list_spec"; then - func_verbose "using command file archive linking..." - for obj in $oldobjs - do - func_to_tool_file "$obj" - $ECHO "$func_to_tool_file_result" - done > $output_objdir/$libname.libcmd - func_to_tool_file "$output_objdir/$libname.libcmd" - oldobjs=" $archiver_list_spec$func_to_tool_file_result" - 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 -z "$oldobjs"; 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 yes = "$build_old_libs" && 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 "$relink_command" | $SED "$sed_quote_subst"` - if test yes = "$hardcode_automatic"; then - relink_command= - fi - - # Only create the output if not a dry run. - $opt_dry_run || { - for installed in no yes; do - if test yes = "$installed"; 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 - func_resolve_sysroot "$deplib" - eval libdir=`$SED -n -e 's/^libdir=\(.*\)$/\1/p' $func_resolve_sysroot_result` - test -z "$libdir" && \ - func_fatal_error "'$deplib' is not a valid libtool archive" - func_append newdependency_libs " ${lt_sysroot:+=}$libdir/$name" - ;; - -L*) - func_stripname -L '' "$deplib" - func_replace_sysroot "$func_stripname_result" - func_append newdependency_libs " -L$func_replace_sysroot_result" - ;; - -R*) - func_stripname -R '' "$deplib" - func_replace_sysroot "$func_stripname_result" - func_append newdependency_libs " -R$func_replace_sysroot_result" - ;; - *) func_append 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" - func_append newdlfiles " ${lt_sysroot:+=}$libdir/$name" - ;; - *) func_append 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" - func_append newdlprefiles " ${lt_sysroot:+=}$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 - func_append newdlfiles " $abs" - done - dlfiles=$newdlfiles - newdlprefiles= - for lib in $dlprefiles; do - case $lib in - [\\/]* | [A-Za-z]:[\\/]*) abs=$lib ;; - *) abs=`pwd`"/$lib" ;; - esac - func_append newdlprefiles " $abs" - done - dlprefiles=$newdlprefiles - fi - $RM $output - # place dlname in correct position for cygwin - # In fact, it would be nice if we could use this code for all target - # systems that can't hard-code library paths into their executables - # and that have no shared library path variable independent of PATH, - # but it turns out we can't easily determine that from inspecting - # libtool variables, so we have to hard-code the OSs to which it - # applies here; at the moment, that means platforms that use the PE - # object format with DLL files. See the long comment at the top of - # tests/bindir.at for full details. - tdlname=$dlname - case $host,$output,$installed,$module,$dlname in - *cygwin*,*lai,yes,no,*.dll | *mingw*,*lai,yes,no,*.dll | *cegcc*,*lai,yes,no,*.dll) - # If a -bindir argument was supplied, place the dll there. - if test -n "$bindir"; then - func_relative_path "$install_libdir" "$bindir" - tdlname=$func_relative_path_result/$dlname - else - # Otherwise fall back on heuristic. - tdlname=../bin/$dlname - fi - ;; - esac - $ECHO > $output "\ -# $outputname - a libtool library file -# Generated by $PROGRAM (GNU $PACKAGE) $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 cannot 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 no,yes = "$installed,$need_relink"; 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 -} - -if test link = "$opt_mode" || test relink = "$opt_mode"; then - func_mode_link ${1+"$@"} -fi - - -# func_mode_uninstall arg... -func_mode_uninstall () -{ - $debug_cmd - - RM=$nonopt - files= - rmforce=false - 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) func_append RM " $arg"; rmforce=: ;; - -*) func_append RM " $arg" ;; - *) func_append files " $arg" ;; - esac - done - - test -z "$RM" && \ - func_fatal_help "you must specify an RM program" - - rmdirs= - - for file in $files; do - func_dirname "$file" "" "." - dir=$func_dirname_result - if test . = "$dir"; then - odir=$objdir - else - odir=$dir/$objdir - fi - func_basename "$file" - name=$func_basename_result - test uninstall = "$opt_mode" && odir=$dir - - # Remember odir for removal later, being careful to avoid duplicates - if test clean = "$opt_mode"; then - case " $rmdirs " in - *" $odir "*) ;; - *) func_append rmdirs " $odir" ;; - 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 $rmforce; 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 - func_append rmfiles " $odir/$n" - done - test -n "$old_library" && func_append rmfiles " $odir/$old_library" - - case $opt_mode in - clean) - case " $library_names " in - *" $dlname "*) ;; - *) test -n "$dlname" && func_append rmfiles " $odir/$dlname" ;; - esac - test -n "$libdir" && func_append rmfiles " $odir/$name $odir/${name}i" - ;; - uninstall) - if test -n "$library_names"; then - # Do each command in the postuninstall commands. - func_execute_cmds "$postuninstall_cmds" '$rmforce || exit_status=1' - fi - - if test -n "$old_library"; then - # Do each command in the old_postuninstall commands. - func_execute_cmds "$old_postuninstall_cmds" '$rmforce || 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 none != "$pic_object"; then - func_append rmfiles " $dir/$pic_object" - fi - - # Add non-PIC object to the list of files to remove. - if test -n "$non_pic_object" && test none != "$non_pic_object"; then - func_append rmfiles " $dir/$non_pic_object" - fi - fi - ;; - - *) - if test clean = "$opt_mode"; 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 - func_append 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 - func_append 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 - func_append rmfiles " $odir/$name $odir/${name}S.$objext" - if test yes = "$fast_install" && test -n "$relink_command"; then - func_append rmfiles " $odir/lt-$name" - fi - if test "X$noexename" != "X$name"; then - func_append rmfiles " $odir/lt-$noexename.c" - fi - fi - fi - ;; - esac - func_show_eval "$RM $rmfiles" 'exit_status=1' - done - - # 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 -} - -if test uninstall = "$opt_mode" || test clean = "$opt_mode"; then - func_mode_uninstall ${1+"$@"} -fi - -test -z "$opt_mode" && { - help=$generic_help - func_fatal_help "you must specify a MODE" -} - -test -z "$exec_cmd" && \ - func_fatal_help "invalid operation mode '$opt_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 -# where 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: diff -Nru ecl-16.1.2/src/bdwgc/m4/libtool.m4 ecl-16.1.3+ds/src/bdwgc/m4/libtool.m4 --- ecl-16.1.2/src/bdwgc/m4/libtool.m4 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/m4/libtool.m4 1970-01-01 00:00:00.000000000 +0000 @@ -1,8369 +0,0 @@ -# libtool.m4 - Configure libtool for the host system. -*-Autoconf-*- -# -# Copyright (C) 1996-2001, 2003-2015 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) 2014 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 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 this program. If not, see . -]) - -# serial 58 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.62])dnl We use AC_PATH_PROGS_FEATURE_CHECK -AC_REQUIRE([AC_CONFIG_AUX_DIR_DEFAULT])dnl -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 - -_LT_SHELL_INIT([SHELL=${CONFIG_SHELL-/bin/sh}]) - -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_PREPARE_CC_BASENAME -# ----------------------- -m4_defun([_LT_PREPARE_CC_BASENAME], [ -# Calculate cc_basename. Skip known compiler wrappers and cross-prefix. -func_cc_basename () -{ - for cc_temp in @S|@*""; do - case $cc_temp in - compile | *[[\\/]]compile | ccache | *[[\\/]]ccache ) ;; - distcc | *[[\\/]]distcc | purify | *[[\\/]]purify ) ;; - \-*) ;; - *) break;; - esac - done - func_cc_basename_result=`$ECHO "$cc_temp" | $SED "s%.*/%%; s%^$host_alias-%%"` -} -])# _LT_PREPARE_CC_BASENAME - - -# _LT_CC_BASENAME(CC) -# ------------------- -# It would be clearer to call AC_REQUIREs from _LT_PREPARE_CC_BASENAME, -# but that macro is also expanded into generated libtool script, which -# arranges for $SED and $ECHO to be set by different means. -m4_defun([_LT_CC_BASENAME], -[m4_require([_LT_PREPARE_CC_BASENAME])dnl -AC_REQUIRE([_LT_DECL_SED])dnl -AC_REQUIRE([_LT_PROG_ECHO_BACKSLASH])dnl -func_cc_basename $1 -cc_basename=$func_cc_basename_result -]) - - -# _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 -AC_REQUIRE([_LT_PREPARE_SED_QUOTE_VARS])dnl -AC_REQUIRE([_LT_PROG_ECHO_BACKSLASH])dnl - -_LT_DECL([], [PATH_SEPARATOR], [1], [The PATH separator for the build system])dnl -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_PATH_CONVERSION_FUNCTIONS])dnl -m4_require([_LT_CMD_RELOAD])dnl -m4_require([_LT_CHECK_MAGIC_METHOD])dnl -m4_require([_LT_CHECK_SHAREDLIB_FROM_LINKLIB])dnl -m4_require([_LT_CMD_OLD_ARCHIVE])dnl -m4_require([_LT_CMD_GLOBAL_SYMBOLS])dnl -m4_require([_LT_WITH_SYSROOT])dnl -m4_require([_LT_CMD_TRUNCATE])dnl - -_LT_CONFIG_LIBTOOL_INIT([ -# See if we are running on zsh, and set the options that 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 - -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 set != "${COLLECT_NAMES+set}"; then - COLLECT_NAMES= - export COLLECT_NAMES - fi - ;; -esac - -# 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_PREPARE_SED_QUOTE_VARS -# -------------------------- -# Define a few sed substitution that help us do robust quoting. -m4_defun([_LT_PREPARE_SED_QUOTE_VARS], -[# Backslashify 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' -]) - -# _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 "$][$1" | $SED "$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 "$" | $SED "$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' - -# A function that is used when there is no print builtin or printf. -func_fallback_echo () -{ - eval 'cat <<_LTECHO_EOF -\$[]1 -_LTECHO_EOF' -} - -# Quote evaled strings. -for var in lt_decl_all_varnames([[ \ -]], lt_decl_quote_varnames); do - case \`eval \\\\\$ECHO \\\\""\\\\\$\$var"\\\\"\` in - *[[\\\\\\\`\\"\\\$]]*) - eval "lt_\$var=\\\\\\"\\\`\\\$ECHO \\"\\\$\$var\\" | \\\$SED \\"\\\$sed_quote_subst\\"\\\`\\\\\\"" ## exclude from sc_prohibit_nested_quotes - ;; - *) - 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 \\\\""\\\\\$\$var"\\\\"\` in - *[[\\\\\\\`\\"\\\$]]*) - eval "lt_\$var=\\\\\\"\\\`\\\$ECHO \\"\\\$\$var\\" | \\\$SED -e \\"\\\$double_quote_subst\\" -e \\"\\\$sed_quote_subst\\" -e \\"\\\$delay_variable_subst\\"\\\`\\\\\\"" ## exclude from sc_prohibit_nested_quotes - ;; - *) - eval "lt_\$var=\\\\\\"\\\$\$var\\\\\\"" - ;; - esac -done - -_LT_OUTPUT_LIBTOOL_INIT -]) - -# _LT_GENERATED_FILE_INIT(FILE, [COMMENT]) -# ------------------------------------ -# Generate a child script FILE with all initialization necessary to -# reuse the environment learned by the parent script, and make the -# file executable. If COMMENT is supplied, it is inserted after the -# '#!' sequence but before initialization text begins. After this -# macro, additional text can be appended to FILE to form the body of -# the child script. The macro ends with non-zero status if the -# file could not be fully written (such as if the disk is full). -m4_ifdef([AS_INIT_GENERATED], -[m4_defun([_LT_GENERATED_FILE_INIT],[AS_INIT_GENERATED($@)])], -[m4_defun([_LT_GENERATED_FILE_INIT], -[m4_require([AS_PREPARE])]dnl -[m4_pushdef([AS_MESSAGE_LOG_FD])]dnl -[lt_write_fail=0 -cat >$1 <<_ASEOF || lt_write_fail=1 -#! $SHELL -# Generated by $as_me. -$2 -SHELL=\${CONFIG_SHELL-$SHELL} -export SHELL -_ASEOF -cat >>$1 <<\_ASEOF || lt_write_fail=1 -AS_SHELL_SANITIZE -_AS_PREPARE -exec AS_MESSAGE_FD>&1 -_ASEOF -test 0 = "$lt_write_fail" && chmod +x $1[]dnl -m4_popdef([AS_MESSAGE_LOG_FD])])])# _LT_GENERATED_FILE_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]) -_LT_GENERATED_FILE_INIT(["$CONFIG_LT"], -[# Run this file to recreate a libtool stub with the current configuration.]) - -cat >>"$CONFIG_LT" <<\_LTEOF -lt_cl_silent=false -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) 2011 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. -lt_cl_success=: -test yes = "$silent" && - 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) -])# 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 that 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 -# Generated automatically by $as_me ($PACKAGE) $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. - -# Provide generalized library-building support services. -# Written by Gordon Matzigkeit, 1996 - -_LT_COPYING -_LT_LIBTOOL_TAGS - -# Configured defaults for sys_lib_dlsearch_path munging. -: \${LT_SYS_LIBRARY_PATH="$configure_time_lt_sys_library_path"} - -# ### BEGIN LIBTOOL CONFIG -_LT_LIBTOOL_CONFIG_VARS -_LT_LIBTOOL_TAG_VARS -# ### END LIBTOOL CONFIG - -_LT_EOF - - cat <<'_LT_EOF' >> "$cfgfile" - -# ### BEGIN FUNCTIONS SHARED WITH CONFIGURE - -_LT_PREPARE_MUNGE_PATH_LIST -_LT_PREPARE_CC_BASENAME - -# ### END FUNCTIONS SHARED WITH CONFIGURE - -_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 set != "${COLLECT_NAMES+set}"; 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 '$q' "$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' - 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)], - [Go], [_LT_LANG(GO)], - [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 - - -m4_ifndef([AC_PROG_GO], [ -############################################################ -# NOTE: This macro has been submitted for inclusion into # -# GNU Autoconf as AC_PROG_GO. When it is available in # -# a released version of Autoconf we should remove this # -# macro and use it instead. # -############################################################ -m4_defun([AC_PROG_GO], -[AC_LANG_PUSH(Go)dnl -AC_ARG_VAR([GOC], [Go compiler command])dnl -AC_ARG_VAR([GOFLAGS], [Go compiler flags])dnl -_AC_ARG_VAR_LDFLAGS()dnl -AC_CHECK_TOOL(GOC, gccgo) -if test -z "$GOC"; then - if test -n "$ac_tool_prefix"; then - AC_CHECK_PROG(GOC, [${ac_tool_prefix}gccgo], [${ac_tool_prefix}gccgo]) - fi -fi -if test -z "$GOC"; then - AC_CHECK_PROG(GOC, gccgo, gccgo, false) -fi -])#m4_defun -])#m4_ifndef - - -# _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([AC_PROG_GO], - [LT_LANG(GO)], - [m4_define([AC_PROG_GO], defn([AC_PROG_GO])[LT_LANG(GO)])]) - -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)]) -AU_DEFUN([AC_LIBTOOL_RC], [LT_LANG(Windows Resource)]) -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], []) -dnl AC_DEFUN([AC_LIBTOOL_RC], []) - - -# _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 there is a non-empty error log, and "single_module" - # appears in it, assume the flag caused a linker warning - if test -s conftest.err && $GREP single_module conftest.err; then - cat conftest.err >&AS_MESSAGE_LOG_FD - # Otherwise, if the output was created with a 0 exit code from - # the compiler, it worked. - elif test -f libconftest.dylib && test 0 = "$_lt_result"; 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 - ]) - - AC_CACHE_CHECK([for -force_load linker flag],[lt_cv_ld_force_load], - [lt_cv_ld_force_load=no - cat > conftest.c << _LT_EOF -int forced_loaded() { return 2;} -_LT_EOF - echo "$LTCC $LTCFLAGS -c -o conftest.o conftest.c" >&AS_MESSAGE_LOG_FD - $LTCC $LTCFLAGS -c -o conftest.o conftest.c 2>&AS_MESSAGE_LOG_FD - echo "$AR cru libconftest.a conftest.o" >&AS_MESSAGE_LOG_FD - $AR cru libconftest.a conftest.o 2>&AS_MESSAGE_LOG_FD - echo "$RANLIB libconftest.a" >&AS_MESSAGE_LOG_FD - $RANLIB libconftest.a 2>&AS_MESSAGE_LOG_FD - cat > conftest.c << _LT_EOF -int main() { return 0;} -_LT_EOF - echo "$LTCC $LTCFLAGS $LDFLAGS -o conftest conftest.c -Wl,-force_load,./libconftest.a" >&AS_MESSAGE_LOG_FD - $LTCC $LTCFLAGS $LDFLAGS -o conftest conftest.c -Wl,-force_load,./libconftest.a 2>conftest.err - _lt_result=$? - if test -s conftest.err && $GREP force_load conftest.err; then - cat conftest.err >&AS_MESSAGE_LOG_FD - elif test -f conftest && test 0 = "$_lt_result" && $GREP forced_load conftest >/dev/null 2>&1; then - lt_cv_ld_force_load=yes - else - cat conftest.err >&AS_MESSAGE_LOG_FD - fi - rm -f conftest.err libconftest.a conftest conftest.c - rm -rf conftest.dSYM - ]) - 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 yes = "$lt_cv_apple_cc_single_mod"; then - _lt_dar_single_mod='$single_module' - fi - if test yes = "$lt_cv_ld_exported_symbols_list"; 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" && test no = "$lt_cv_ld_force_load"; then - _lt_dsymutil='~$DSYMUTIL $lib || :' - else - _lt_dsymutil= - fi - ;; - esac -]) - - -# _LT_DARWIN_LINKER_FEATURES([TAG]) -# --------------------------------- -# 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 - if test yes = "$lt_cv_ld_force_load"; then - _LT_TAGVAR(whole_archive_flag_spec, $1)='`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience $wl-force_load,$conv\"; done; func_echo_all \"$new_convenience\"`' - m4_case([$1], [F77], [_LT_TAGVAR(compiler_needs_object, $1)=yes], - [FC], [_LT_TAGVAR(compiler_needs_object, $1)=yes]) - else - _LT_TAGVAR(whole_archive_flag_spec, $1)='' - fi - _LT_TAGVAR(link_all_deplibs, $1)=yes - _LT_TAGVAR(allow_undefined_flag, $1)=$_lt_dar_allow_undefined - case $cc_basename in - ifort*|nagfor*) _lt_dar_can_shared=yes ;; - *) _lt_dar_can_shared=$GCC ;; - esac - if test yes = "$_lt_dar_can_shared"; then - output_verbose_link_cmd=func_echo_all - _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 yes != "$lt_cv_apple_cc_single_mod"; 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([TAGNAME]) -# ---------------------------------- -# 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. -# Store the results from the different compilers for each TAGNAME. -# Allow to override them for all tags through lt_cv_aix_libpath. -m4_defun([_LT_SYS_MODULE_PATH_AIX], -[m4_require([_LT_DECL_SED])dnl -if test set = "${lt_cv_aix_libpath+set}"; then - aix_libpath=$lt_cv_aix_libpath -else - AC_CACHE_VAL([_LT_TAGVAR([lt_cv_aix_libpath_], [$1])], - [AC_LINK_IFELSE([AC_LANG_PROGRAM],[ - lt_aix_libpath_sed='[ - /Import File Strings/,/^$/ { - /^0/ { - s/^0 *\([^ ]*\) *$/\1/ - p - } - }]' - _LT_TAGVAR([lt_cv_aix_libpath_], [$1])=`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 "$_LT_TAGVAR([lt_cv_aix_libpath_], [$1])"; then - _LT_TAGVAR([lt_cv_aix_libpath_], [$1])=`dump -HX64 conftest$ac_exeext 2>/dev/null | $SED -n -e "$lt_aix_libpath_sed"` - fi],[]) - if test -z "$_LT_TAGVAR([lt_cv_aix_libpath_], [$1])"; then - _LT_TAGVAR([lt_cv_aix_libpath_], [$1])=/usr/lib:/lib - fi - ]) - aix_libpath=$_LT_TAGVAR([lt_cv_aix_libpath_], [$1]) -fi -])# _LT_SYS_MODULE_PATH_AIX - - -# _LT_SHELL_INIT(ARG) -# ------------------- -m4_define([_LT_SHELL_INIT], -[m4_divert_text([M4SH-INIT], [$1 -])])# _LT_SHELL_INIT - - - -# _LT_PROG_ECHO_BACKSLASH -# ----------------------- -# Find how we can fake an echo command that does not interpret backslash. -# In particular, with Autoconf 2.60 or later we add some code to the start -# of the generated configure script that will find a shell with a builtin -# printf (that we can use as an echo command). -m4_defun([_LT_PROG_ECHO_BACKSLASH], -[ECHO='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' -ECHO=$ECHO$ECHO$ECHO$ECHO$ECHO -ECHO=$ECHO$ECHO$ECHO$ECHO$ECHO$ECHO - -AC_MSG_CHECKING([how to print strings]) -# Test print first, because it will be a builtin if present. -if test "X`( print -r -- -n ) 2>/dev/null`" = X-n && \ - test "X`print -r -- $ECHO 2>/dev/null`" = "X$ECHO"; then - ECHO='print -r --' -elif test "X`printf %s $ECHO 2>/dev/null`" = "X$ECHO"; then - ECHO='printf %s\n' -else - # Use this function as a fallback that always works. - func_fallback_echo () - { - eval 'cat <<_LTECHO_EOF -$[]1 -_LTECHO_EOF' - } - ECHO='func_fallback_echo' -fi - -# func_echo_all arg... -# Invoke $ECHO with all args, space-separated. -func_echo_all () -{ - $ECHO "$*" -} - -case $ECHO in - printf*) AC_MSG_RESULT([printf]) ;; - print*) AC_MSG_RESULT([print -r]) ;; - *) AC_MSG_RESULT([cat]) ;; -esac - -m4_ifdef([_AS_DETECT_SUGGESTED], -[_AS_DETECT_SUGGESTED([ - test -n "${ZSH_VERSION+set}${BASH_VERSION+set}" || ( - ECHO='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' - ECHO=$ECHO$ECHO$ECHO$ECHO$ECHO - ECHO=$ECHO$ECHO$ECHO$ECHO$ECHO$ECHO - PATH=/empty FPATH=/empty; export PATH FPATH - test "X`printf %s $ECHO`" = "X$ECHO" \ - || test "X`print -r -- $ECHO`" = "X$ECHO" )])]) - -_LT_DECL([], [SHELL], [1], [Shell to use when invoking shell scripts]) -_LT_DECL([], [ECHO], [1], [An echo program that protects backslashes]) -])# _LT_PROG_ECHO_BACKSLASH - - -# _LT_WITH_SYSROOT -# ---------------- -AC_DEFUN([_LT_WITH_SYSROOT], -[AC_MSG_CHECKING([for sysroot]) -AC_ARG_WITH([sysroot], -[AS_HELP_STRING([--with-sysroot@<:@=DIR@:>@], - [Search for dependent libraries within DIR (or the compiler's sysroot - if not specified).])], -[], [with_sysroot=no]) - -dnl lt_sysroot will always be passed unquoted. We quote it here -dnl in case the user passed a directory name. -lt_sysroot= -case $with_sysroot in #( - yes) - if test yes = "$GCC"; then - lt_sysroot=`$CC --print-sysroot 2>/dev/null` - fi - ;; #( - /*) - lt_sysroot=`echo "$with_sysroot" | sed -e "$sed_quote_subst"` - ;; #( - no|'') - ;; #( - *) - AC_MSG_RESULT([$with_sysroot]) - AC_MSG_ERROR([The sysroot must be an absolute path.]) - ;; -esac - - AC_MSG_RESULT([${lt_sysroot:-no}]) -_LT_DECL([], [lt_sysroot], [0], [The root where to search for ]dnl -[dependent libraries, and where our libraries should be installed.])]) - -# _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 no = "$enable_libtool_lock" || 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 what ABI is being produced by ac_compile, and set mode - # options accordingly. - 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 what ABI is being produced by ac_compile, and set linker - # options accordingly. - echo '[#]line '$LINENO' "configure"' > conftest.$ac_ext - if AC_TRY_EVAL(ac_compile); then - if test yes = "$lt_cv_prog_gnu_ld"; 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* - ;; - -mips64*-*linux*) - # Find out what ABI is being produced by ac_compile, and set linker - # options accordingly. - echo '[#]line '$LINENO' "configure"' > conftest.$ac_ext - if AC_TRY_EVAL(ac_compile); then - emul=elf - case `/usr/bin/file conftest.$ac_objext` in - *32-bit*) - emul="${emul}32" - ;; - *64-bit*) - emul="${emul}64" - ;; - esac - case `/usr/bin/file conftest.$ac_objext` in - *MSB*) - emul="${emul}btsmip" - ;; - *LSB*) - emul="${emul}ltsmip" - ;; - esac - case `/usr/bin/file conftest.$ac_objext` in - *N32*) - emul="${emul}n32" - ;; - esac - LD="${LD-ld} -m $emul" - fi - rm -rf conftest* - ;; - -x86_64-*kfreebsd*-gnu|x86_64-*linux*|powerpc*-*linux*| \ -s390*-*linux*|s390*-*tpf*|sparc*-*linux*) - # Find out what ABI is being produced by ac_compile, and set linker - # options accordingly. Note that the listed cases only cover the - # situations where additional linker options are needed (such as when - # doing 32-bit compilation for a host where ld defaults to 64-bit, or - # vice versa); the common cases where no linker options are needed do - # not appear in the list. - 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*) - case `/usr/bin/file conftest.o` in - *x86-64*) - LD="${LD-ld} -m elf32_x86_64" - ;; - *) - LD="${LD-ld} -m elf_i386" - ;; - esac - ;; - powerpc64le-*linux*) - LD="${LD-ld} -m elf32lppclinux" - ;; - 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" - ;; - powerpcle-*linux*) - LD="${LD-ld} -m elf64lppc" - ;; - 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 yes != "$lt_cv_cc_needs_belf"; then - # this is probably gcc 2.8.0, egcs 1.0 or newer; no need for -belf - CFLAGS=$SAVE_CFLAGS - fi - ;; -*-*solaris*) - # Find out what ABI is being produced by ac_compile, and set linker - # options accordingly. - 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*) - case $host in - i?86-*-solaris*|x86_64-*-solaris*) - LD="${LD-ld} -m elf_x86_64" - ;; - sparc*-*-solaris*) - LD="${LD-ld} -m elf64_sparc" - ;; - esac - # GNU ld 2.21 introduced _sol2 emulations. Use them if available. - if ${LD-ld} -V | grep _sol2 >/dev/null 2>&1; then - LD=${LD-ld}_sol2 - fi - ;; - *) - 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_PROG_AR -# ----------- -m4_defun([_LT_PROG_AR], -[AC_CHECK_TOOLS(AR, [ar], false) -: ${AR=ar} -: ${AR_FLAGS=cru} -_LT_DECL([], [AR], [1], [The archiver]) -_LT_DECL([], [AR_FLAGS], [1], [Flags to create an archive]) - -AC_CACHE_CHECK([for archiver @FILE support], [lt_cv_ar_at_file], - [lt_cv_ar_at_file=no - AC_COMPILE_IFELSE([AC_LANG_PROGRAM], - [echo conftest.$ac_objext > conftest.lst - lt_ar_try='$AR $AR_FLAGS libconftest.a @conftest.lst >&AS_MESSAGE_LOG_FD' - AC_TRY_EVAL([lt_ar_try]) - if test 0 -eq "$ac_status"; then - # Ensure the archiver fails upon bogus file names. - rm -f conftest.$ac_objext libconftest.a - AC_TRY_EVAL([lt_ar_try]) - if test 0 -ne "$ac_status"; then - lt_cv_ar_at_file=@ - fi - fi - rm -f conftest.* libconftest.a - ]) - ]) - -if test no = "$lt_cv_ar_at_file"; then - archiver_list_spec= -else - archiver_list_spec=$lt_cv_ar_at_file -fi -_LT_DECL([], [archiver_list_spec], [1], - [How to feed a file listing to the archiver]) -])# _LT_PROG_AR - - -# _LT_CMD_OLD_ARCHIVE -# ------------------- -m4_defun([_LT_CMD_OLD_ARCHIVE], -[_LT_PROG_AR - -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 - bitrig* | openbsd*) - old_postinstall_cmds="$old_postinstall_cmds~\$RANLIB -t \$tool_oldlib" - ;; - *) - old_postinstall_cmds="$old_postinstall_cmds~\$RANLIB \$tool_oldlib" - ;; - esac - old_archive_cmds="$old_archive_cmds~\$RANLIB \$tool_oldlib" -fi - -case $host_os in - darwin*) - lock_old_archive_extraction=yes ;; - *) - lock_old_archive_extraction=no ;; -esac -_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_DECL([], [lock_old_archive_extraction], [0], - [Whether to use a lock for old archive extraction]) -])# _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" ## exclude from sc_useless_quotes_in_assignment - # 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:$LINENO: $lt_compile\"" >&AS_MESSAGE_LOG_FD) - (eval "$lt_compile" 2>conftest.err) - ac_status=$? - cat conftest.err >&AS_MESSAGE_LOG_FD - echo "$as_me:$LINENO: \$? = $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 "$_lt_compiler_boilerplate" | $SED '/^$/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 yes = "[$]$2"; 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 "$_lt_linker_boilerplate" | $SED '/^$/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 yes = "[$]$2"; 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; - ;; - - mint*) - # On MiNT this can take a long time and run out of memory. - 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; - ;; - - bitrig* | darwin* | dragonfly* | freebsd* | netbsd* | openbsd*) - # 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 - ;; - - os2*) - # The test takes a long time on OS/2. - lt_cv_sys_max_cmd_len=8192 - ;; - - 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" && \ - test undefined != "$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`env echo "$teststring$teststring" 2>/dev/null` \ - = "X$teststring$teststring"; } >/dev/null 2>&1 && - test 17 != "$i" # 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 yes = "$cross_compiling"; 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 $LINENO "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 - -/* When -fvisibility=hidden is used, assume the code has been annotated - correspondingly for the symbols needed. */ -#if defined __GNUC__ && (((__GNUC__ == 3) && (__GNUC_MINOR__ >= 3)) || (__GNUC__ > 3)) -int fnord () __attribute__((visibility("default"))); -#endif - -int fnord () { return 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; - else puts (dlerror ()); - } - /* 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 yes != "$enable_dlopen"; 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 - ]) - ;; - - tpf*) - # Don't try to run any link tests for TPF. We know it's impossible - # because TPF is a cross-compiler, and we know how we open DSOs. - lt_cv_dlopen=dlopen - lt_cv_dlopen_libs= - lt_cv_dlopen_self=no - ;; - - *) - 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 no = "$lt_cv_dlopen"; then - enable_dlopen=no - else - enable_dlopen=yes - fi - - case $lt_cv_dlopen in - dlopen) - save_CPPFLAGS=$CPPFLAGS - test yes = "$ac_cv_header_dlfcn_h" && 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 yes = "$lt_cv_dlopen_self"; 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:$LINENO: $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:$LINENO: \$? = $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 "$_lt_compiler_boilerplate" | $SED '/^$/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 no = "$_LT_TAGVAR(lt_cv_prog_compiler_c_o, $1)" && test no != "$need_locks"; 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 no = "$hard_links"; 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 where 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 yes = "$_LT_TAGVAR(hardcode_automatic, $1)"; then - - # We can hardcode non-existent directories. - if test no != "$_LT_TAGVAR(hardcode_direct, $1)" && - # 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 no != "$_LT_TAGVAR(hardcode_shlibpath_var, $1)" && - test no != "$_LT_TAGVAR(hardcode_minus_L, $1)"; 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 relink = "$_LT_TAGVAR(hardcode_action, $1)" || - test yes = "$_LT_TAGVAR(inherit_rpath, $1)"; then - # Fast installation is not supported - enable_fast_install=no -elif test yes = "$shlibpath_overrides_runpath" || - test no = "$enable_shared"; 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_PREPARE_MUNGE_PATH_LIST -# --------------------------- -# Make sure func_munge_path_list() is defined correctly. -m4_defun([_LT_PREPARE_MUNGE_PATH_LIST], -[[# func_munge_path_list VARIABLE PATH -# ----------------------------------- -# VARIABLE is name of variable containing _space_ separated list of -# directories to be munged by the contents of PATH, which is string -# having a format: -# "DIR[:DIR]:" -# string "DIR[ DIR]" will be prepended to VARIABLE -# ":DIR[:DIR]" -# string "DIR[ DIR]" will be appended to VARIABLE -# "DIRP[:DIRP]::[DIRA:]DIRA" -# string "DIRP[ DIRP]" will be prepended to VARIABLE and string -# "DIRA[ DIRA]" will be appended to VARIABLE -# "DIR[:DIR]" -# VARIABLE will be replaced by "DIR[ DIR]" -func_munge_path_list () -{ - case x@S|@2 in - x) - ;; - *:) - eval @S|@1=\"`$ECHO @S|@2 | $SED 's/:/ /g'` \@S|@@S|@1\" - ;; - x:*) - eval @S|@1=\"\@S|@@S|@1 `$ECHO @S|@2 | $SED 's/:/ /g'`\" - ;; - *::*) - eval @S|@1=\"\@S|@@S|@1\ `$ECHO @S|@2 | $SED -e 's/.*:://' -e 's/:/ /g'`\" - eval @S|@1=\"`$ECHO @S|@2 | $SED -e 's/::.*//' -e 's/:/ /g'`\ \@S|@@S|@1\" - ;; - *) - eval @S|@1=\"`$ECHO @S|@2 | $SED 's/:/ /g'`\" - ;; - esac -} -]])# _LT_PREPARE_PATH_LIST - - -# _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 -m4_require([_LT_CHECK_SHELL_FEATURES])dnl -m4_require([_LT_PREPARE_MUNGE_PATH_LIST])dnl -AC_MSG_CHECKING([dynamic linker characteristics]) -m4_if([$1], - [], [ -if test yes = "$GCC"; then - case $host_os in - darwin*) lt_awk_arg='/^libraries:/,/LR/' ;; - *) lt_awk_arg='/^libraries:/' ;; - esac - case $host_os in - mingw* | cegcc*) lt_sed_strip_eq='s|=\([[A-Za-z]]:\)|\1|g' ;; - *) lt_sed_strip_eq='s|=/|/|g' ;; - esac - lt_search_path_spec=`$CC -print-search-dirs | awk $lt_awk_arg | $SED -e "s/^libraries://" -e $lt_sed_strip_eq` - case $lt_search_path_spec in - *\;*) - # 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 's/;/ /g'` - ;; - *) - lt_search_path_spec=`$ECHO "$lt_search_path_spec" | $SED "s/$PATH_SEPARATOR/ /g"` - ;; - esac - # 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` - # ...but if some path component already ends with the multilib dir we assume - # that all is fine and trust -print-search-dirs as is (GCC 4.2? or newer). - case "$lt_multi_os_dir; $lt_search_path_spec " in - "/; "* | "/.; "* | "/./; "* | *"$lt_multi_os_dir "* | *"$lt_multi_os_dir/ "*) - lt_multi_os_dir= - ;; - esac - 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" - elif test -n "$lt_multi_os_dir"; then - 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; } -}'` - # AWK program above erroneously prepends '/' to C:/dos/paths - # for these hosts. - case $host_os in - mingw* | cegcc*) lt_search_path_spec=`$ECHO "$lt_search_path_spec" |\ - $SED 's|/\([[A-Za-z]]:\)|\1|g'` ;; - esac - sys_lib_search_path_spec=`$ECHO "$lt_search_path_spec" | $lt_NL2SP` -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 - -AC_ARG_VAR([LT_SYS_LIBRARY_PATH], -[User-defined run-time library search path.]) - -case $host_os in -aix3*) - version_type=linux # correct to gnu/linux during the next big refactor - 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 # correct to gnu/linux during the next big refactor - need_lib_prefix=no - need_version=no - hardcode_into_libs=yes - if test ia64 = "$host_cpu"; 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 - # Using Import Files as archive members, it is possible to support - # filename-based versioning of shared library archives on AIX. While - # this would work for both with and without runtime linking, it will - # prevent static linking of such archives. So we do filename-based - # shared library versioning with .so extension only, which is used - # when both runtime linking and shared linking is enabled. - # Unfortunately, runtime linking may impact performance, so we do - # not want this to be the default eventually. Also, we use the - # versioned .so libs for executables only if there is the -brtl - # linker flag in LDFLAGS as well, or --with-aix-soname=svr4 only. - # To allow for filename-based versioning support, we need to create - # libNAME.so.V as an archive file, containing: - # *) an Import File, referring to the versioned filename of the - # archive as well as the shared archive member, telling the - # bitwidth (32 or 64) of that shared object, and providing the - # list of exported symbols of that shared object, eventually - # decorated with the 'weak' keyword - # *) the shared object with the F_LOADONLY flag set, to really avoid - # it being seen by the linker. - # At run time we better use the real file rather than another symlink, - # but for link time we create the symlink libNAME.so -> libNAME.so.V - - case $with_aix_soname,$aix_use_runtimelinking in - # AIX (on Power*) has no versioning support, so currently we cannot hardcode correct - # soname into executable. Probably we can add versioning support to - # collect2, so additional links can be useful in future. - aix,yes) # traditional libtool - dynamic_linker='AIX unversionable lib.so' - # 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' - ;; - aix,no) # traditional AIX only - dynamic_linker='AIX lib.a[(]lib.so.V[)]' - # 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' - ;; - svr4,*) # full svr4 only - dynamic_linker="AIX lib.so.V[(]$shared_archive_member_spec.o[)]" - library_names_spec='$libname$release$shared_ext$major $libname$shared_ext' - # We do not specify a path in Import Files, so LIBPATH fires. - shlibpath_overrides_runpath=yes - ;; - *,yes) # both, prefer svr4 - dynamic_linker="AIX lib.so.V[(]$shared_archive_member_spec.o[)], lib.a[(]lib.so.V[)]" - library_names_spec='$libname$release$shared_ext$major $libname$shared_ext' - # unpreferred sharedlib libNAME.a needs extra handling - postinstall_cmds='test -n "$linkname" || linkname="$realname"~func_stripname "" ".so" "$linkname"~$install_shared_prog "$dir/$func_stripname_result.$libext" "$destdir/$func_stripname_result.$libext"~test -z "$tstripme" || test -z "$striplib" || $striplib "$destdir/$func_stripname_result.$libext"' - postuninstall_cmds='for n in $library_names $old_library; do :; done~func_stripname "" ".so" "$n"~test "$func_stripname_result" = "$n" || func_append rmfiles " $odir/$func_stripname_result.$libext"' - # We do not specify a path in Import Files, so LIBPATH fires. - shlibpath_overrides_runpath=yes - ;; - *,no) # both, prefer aix - dynamic_linker="AIX lib.a[(]lib.so.V[)], lib.so.V[(]$shared_archive_member_spec.o[)]" - library_names_spec='$libname$release.a $libname.a' - soname_spec='$libname$release$shared_ext$major' - # unpreferred sharedlib libNAME.so.V and symlink libNAME.so need extra handling - postinstall_cmds='test -z "$dlname" || $install_shared_prog $dir/$dlname $destdir/$dlname~test -z "$tstripme" || test -z "$striplib" || $striplib $destdir/$dlname~test -n "$linkname" || linkname=$realname~func_stripname "" ".a" "$linkname"~(cd "$destdir" && $LN_S -f $dlname $func_stripname_result.so)' - postuninstall_cmds='test -z "$dlname" || func_append rmfiles " $odir/$dlname"~for n in $old_library $library_names; do :; done~func_stripname "" ".a" "$n"~func_append rmfiles " $odir/$func_stripname_result.so"' - ;; - esac - 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=`func_echo_all "$lib" | $SED '\''s%^.*/\([[^/]]*\)\.ixlibrary$%\1%'\''`; $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 # correct to gnu/linux during the next big refactor - 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,$cc_basename in - yes,*) - # gcc - 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' -m4_if([$1], [],[ - sys_lib_search_path_spec="$sys_lib_search_path_spec /usr/lib/w32api"]) - ;; - mingw* | cegcc*) - # MinGW DLLs use traditional 'lib' prefix - soname_spec='$libname`echo $release | $SED -e 's/[[.]]/-/g'`$versuffix$shared_ext' - ;; - 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 - dynamic_linker='Win32 ld.exe' - ;; - - *,cl*) - # Native MSVC - libname_spec='$name' - soname_spec='$libname`echo $release | $SED -e 's/[[.]]/-/g'`$versuffix$shared_ext' - library_names_spec='$libname.dll.lib' - - case $build_os in - mingw*) - sys_lib_search_path_spec= - lt_save_ifs=$IFS - IFS=';' - for lt_path in $LIB - do - IFS=$lt_save_ifs - # Let DOS variable expansion print the short 8.3 style file name. - lt_path=`cd "$lt_path" 2>/dev/null && cmd //C "for %i in (".") do @echo %~si"` - sys_lib_search_path_spec="$sys_lib_search_path_spec $lt_path" - done - IFS=$lt_save_ifs - # Convert to MSYS style. - sys_lib_search_path_spec=`$ECHO "$sys_lib_search_path_spec" | sed -e 's|\\\\|/|g' -e 's| \\([[a-zA-Z]]\\):| /\\1|g' -e 's|^ ||'` - ;; - cygwin*) - # Convert to unix form, then to dos form, then back to unix form - # but this time dos style (no spaces!) so that the unix form looks - # like /cygdrive/c/PROGRA~1:/cygdr... - sys_lib_search_path_spec=`cygpath --path --unix "$LIB"` - sys_lib_search_path_spec=`cygpath --path --dos "$sys_lib_search_path_spec" 2>/dev/null` - sys_lib_search_path_spec=`cygpath --path --unix "$sys_lib_search_path_spec" | $SED -e "s/$PATH_SEPARATOR/ /g"` - ;; - *) - sys_lib_search_path_spec=$LIB - if $ECHO "$sys_lib_search_path_spec" | [$GREP ';[c-zC-Z]:/' >/dev/null]; then - # It is most probably a Windows format PATH. - 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 - # FIXME: find the short name or the path components, as spaces are - # common. (e.g. "Program Files" -> "PROGRA~1") - ;; - esac - - # 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' - postuninstall_cmds='dldll=`$SHELL 2>&1 -c '\''. $file; echo \$dlname'\''`~ - dlpath=$dir/\$dldll~ - $RM \$dlpath' - shlibpath_overrides_runpath=yes - dynamic_linker='Win32 link.exe' - ;; - - *) - # Assume MSVC wrapper - library_names_spec='$libname`echo $release | $SED -e 's/[[.]]/-/g'`$versuffix$shared_ext $libname.lib' - dynamic_linker='Win32 ld.exe' - ;; - esac - # 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 # correct to gnu/linux during the next big refactor - 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 - ;; - -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[[23]].*) 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$major $libname$shared_ext' - soname_spec='$libname$release$shared_ext$major' - 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 - ;; - -haiku*) - version_type=linux # correct to gnu/linux during the next big refactor - need_lib_prefix=no - need_version=no - dynamic_linker="$host_os runtime_loader" - 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=LIBRARY_PATH - shlibpath_overrides_runpath=no - sys_lib_dlsearch_path_spec='/boot/home/config/lib /boot/common/lib /boot/system/lib' - 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 32 = "$HPUX_IA64_MODE"; then - sys_lib_search_path_spec="/usr/lib/hpux32 /usr/local/lib/hpux32 /usr/local/lib" - sys_lib_dlsearch_path_spec=/usr/lib/hpux32 - else - sys_lib_search_path_spec="/usr/lib/hpux64 /usr/local/lib/hpux64" - sys_lib_dlsearch_path_spec=/usr/lib/hpux64 - fi - ;; - 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' - # or fails outright, so override atomically: - install_override_mode=555 - ;; - -interix[[3-9]]*) - version_type=linux # correct to gnu/linux during the next big refactor - 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 yes = "$lt_cv_prog_gnu_ld"; then - version_type=linux # correct to gnu/linux during the next big refactor - 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 - ;; - -linux*android*) - version_type=none # Android doesn't support versioned libraries. - need_lib_prefix=no - need_version=no - library_names_spec='$libname$release$shared_ext' - soname_spec='$libname$release$shared_ext' - finish_cmds= - shlibpath_var=LD_LIBRARY_PATH - shlibpath_overrides_runpath=yes - - # 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 - - dynamic_linker='Android linker' - # Don't embed -rpath directories since the linker doesn't support them. - _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir' - ;; - -# This must be glibc/ELF. -linux* | k*bsd*-gnu | kopensolaris*-gnu | gnu*) - version_type=linux # correct to gnu/linux during the next big refactor - 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 - AC_CACHE_VAL([lt_cv_shlibpath_overrides_runpath], - [lt_cv_shlibpath_overrides_runpath=no - 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], - [lt_cv_shlibpath_overrides_runpath=yes])]) - LDFLAGS=$save_LDFLAGS - libdir=$save_libdir - ]) - shlibpath_overrides_runpath=$lt_cv_shlibpath_overrides_runpath - - # 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 - - # Ideally, we could use ldconfig to report *all* directores which are - # searched for libraries, however this is still not possible. Aside from not - # being certain /sbin/ldconfig is available, command - # 'ldconfig -N -X -v | grep ^/' on 64bit Fedora does not report /usr/lib64, - # even though it is searched at run-time. Try to do the best guess by - # appending ld.so.conf contents (and includes) 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;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' - ;; - -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 # correct to gnu/linux during the next big refactor - 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* | bitrig*) - version_type=sunos - sys_lib_dlsearch_path_spec=/usr/lib - need_lib_prefix=no - if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`"; then - need_version=no - else - need_version=yes - fi - 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 - shlibpath_overrides_runpath=yes - ;; - -os2*) - libname_spec='$name' - version_type=windows - shrext_cmds=.dll - need_version=no - need_lib_prefix=no - # OS/2 can only load a DLL with a base name of 8 characters or less. - soname_spec='`test -n "$os2dllname" && libname="$os2dllname"; - v=$($ECHO $release$versuffix | tr -d .-); - n=$($ECHO $libname | cut -b -$((8 - ${#v})) | tr . _); - $ECHO $n$v`$shared_ext' - library_names_spec='${libname}_dll.$libext' - dynamic_linker='OS/2 ld.exe' - shlibpath_var=BEGINLIBPATH - sys_lib_search_path_spec="/lib /usr/lib /usr/local/lib" - sys_lib_dlsearch_path_spec=$sys_lib_search_path_spec - 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' - ;; - -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 # correct to gnu/linux during the next big refactor - 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 yes = "$with_gnu_ld"; then - need_lib_prefix=no - fi - need_version=yes - ;; - -sysv4 | sysv4.3*) - version_type=linux # correct to gnu/linux during the next big refactor - 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 # correct to gnu/linux during the next big refactor - 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=sco - 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 yes = "$with_gnu_ld"; 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 # correct to gnu/linux during the next big refactor - 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 # correct to gnu/linux during the next big refactor - 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 no = "$dynamic_linker" && can_build_shared=no - -variables_saved_for_relink="PATH $shlibpath_var $runpath_var" -if test yes = "$GCC"; then - variables_saved_for_relink="$variables_saved_for_relink GCC_EXEC_PREFIX COMPILER_PATH LIBRARY_PATH" -fi - -if test set = "${lt_cv_sys_lib_search_path_spec+set}"; then - sys_lib_search_path_spec=$lt_cv_sys_lib_search_path_spec -fi - -if test set = "${lt_cv_sys_lib_dlsearch_path_spec+set}"; then - sys_lib_dlsearch_path_spec=$lt_cv_sys_lib_dlsearch_path_spec -fi - -# remember unaugmented sys_lib_dlsearch_path content for libtool script decls... -configure_time_dlsearch_path=$sys_lib_dlsearch_path_spec - -# ... but it needs LT_SYS_LIBRARY_PATH munging for other configure-time code -func_munge_path_list sys_lib_dlsearch_path_spec "$LT_SYS_LIBRARY_PATH" - -# to be used as default LT_SYS_LIBRARY_PATH value in generated libtool -configure_time_lt_sys_library_path=$LT_SYS_LIBRARY_PATH - -_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([], [install_override_mode], [1], - [Permission mode override for installation of shared libraries]) -_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], [configure_time_dlsearch_path], [2], - [Detected run-time system search path for libraries]) -_LT_DECL([], [configure_time_lt_sys_library_path], [2], - [Explicit LT_SYS_LIBRARY_PATH set during ./configure time]) -])# _LT_SYS_DYNAMIC_LINKER - - -# _LT_PATH_TOOL_PREFIX(TOOL) -# -------------------------- -# find a file program that 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 that 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 -m4_require([_LT_PROG_ECHO_BACKSLASH])dnl - -AC_ARG_WITH([gnu-ld], - [AS_HELP_STRING([--with-gnu-ld], - [assume the C compiler uses GNU ld @<:@default=no@:>@])], - [test no = "$withval" || with_gnu_ld=yes], - [with_gnu_ld=no])dnl - -ac_prog=ld -if test yes = "$GCC"; 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 yes = "$with_gnu_ld"; 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 conftest.i -cat conftest.i conftest.i >conftest2.i -: ${lt_DD:=$DD} -AC_PATH_PROGS_FEATURE_CHECK([lt_DD], [dd], -[if "$ac_path_lt_DD" bs=32 count=1 conftest.out 2>/dev/null; then - cmp -s conftest.i conftest.out \ - && ac_cv_path_lt_DD="$ac_path_lt_DD" ac_path_lt_DD_found=: -fi]) -rm -f conftest.i conftest2.i conftest.out]) -])# _LT_PATH_DD - - -# _LT_CMD_TRUNCATE -# ---------------- -# find command to truncate a binary pipe -m4_defun([_LT_CMD_TRUNCATE], -[m4_require([_LT_PATH_DD]) -AC_CACHE_CHECK([how to truncate binary pipes], [lt_cv_truncate_bin], -[printf 0123456789abcdef0123456789abcdef >conftest.i -cat conftest.i conftest.i >conftest2.i -lt_cv_truncate_bin= -if "$ac_cv_path_lt_DD" bs=32 count=1 conftest.out 2>/dev/null; then - cmp -s conftest.i conftest.out \ - && lt_cv_truncate_bin="$ac_cv_path_lt_DD bs=4096 count=1" -fi -rm -f conftest.i conftest2.i conftest.out -test -z "$lt_cv_truncate_bin" && lt_cv_truncate_bin="$SED -e 4q"]) -_LT_DECL([lt_truncate_bin], [lt_cv_truncate_bin], [1], - [Command to truncate a binary pipe]) -])# _LT_CMD_TRUNCATE - - -# _LT_CHECK_MAGIC_METHOD -# ---------------------- -# how to check for library dependencies -# -- PORTME fill in with the dynamic library characteristics -m4_defun([_LT_CHECK_MAGIC_METHOD], -[m4_require([_LT_DECL_EGREP]) -m4_require([_LT_DECL_OBJDUMP]) -AC_CACHE_CHECK([how to recognize dependent libraries], -lt_cv_deplibs_check_method, -[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 -# that 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 - # Keep this pattern in sync with the one in func_win32_libid. - lt_cv_deplibs_check_method='file_magic file format (pei*-i386(.*architecture: i386)?|pe-arm-wince|pe-x86-64)' - 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 - ;; - -haiku*) - 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])(-bit)?( [LM]SB)? 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 glibc/ELF. -linux* | k*bsd*-gnu | kopensolaris*-gnu | gnu*) - lt_cv_deplibs_check_method=pass_all - ;; - -netbsd*) - 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* | bitrig*) - if test -z "`echo __ELF__ | $CC -E - | $GREP __ELF__`"; 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 - ;; -os2*) - lt_cv_deplibs_check_method=pass_all - ;; -esac -]) - -file_magic_glob= -want_nocaseglob=no -if test "$build" = "$host"; then - case $host_os in - mingw* | pw32*) - if ( shopt | grep nocaseglob ) >/dev/null 2>&1; then - want_nocaseglob=yes - else - file_magic_glob=`echo aAbBcCdDeEfFgGhHiIjJkKlLmMnNoOpPqQrRsStTuUvVwWxXyYzZ | $SED -e "s/\(..\)/s\/[[\1]]\/[[\1]]\/g;/g"` - fi - ;; - esac -fi - -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_DECL([], [file_magic_glob], [1], - [How to find potential files when deplibs_check_method = "file_magic"]) -_LT_DECL([], [want_nocaseglob], [1], - [Find potential files using nocaseglob 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 - # MSYS converts /dev/null to NUL, MinGW nm treats NUL as empty - case $build_os in - mingw*) lt_bad_file=conftest.nm/nofile ;; - *) lt_bad_file=/dev/null ;; - esac - case `"$tmp_nm" -B $lt_bad_file 2>&1 | sed '1q'` in - *$lt_bad_file* | *'Invalid file or object type'*) - lt_cv_path_NM="$tmp_nm -B" - break 2 - ;; - *) - case `"$tmp_nm" -p /dev/null 2>&1 | sed '1q'` in - */dev/null*) - lt_cv_path_NM="$tmp_nm -p" - break 2 - ;; - *) - 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 no != "$lt_cv_path_NM"; then - NM=$lt_cv_path_NM -else - # Didn't find any BSD compatible name lister, look for dumpbin. - if test -n "$DUMPBIN"; then : - # Let the user override the test. - else - AC_CHECK_TOOLS(DUMPBIN, [dumpbin "link -dump"], :) - case `$DUMPBIN -symbols -headers /dev/null 2>&1 | sed '1q'` in - *COFF*) - DUMPBIN="$DUMPBIN -symbols -headers" - ;; - *) - DUMPBIN=: - ;; - esac - fi - 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:$LINENO: $ac_compile\"" >&AS_MESSAGE_LOG_FD) - (eval "$ac_compile" 2>conftest.err) - cat conftest.err >&AS_MESSAGE_LOG_FD - (eval echo "\"\$as_me:$LINENO: $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:$LINENO: 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_CHECK_SHAREDLIB_FROM_LINKLIB -# -------------------------------- -# how to determine the name of the shared library -# associated with a specific link library. -# -- PORTME fill in with the dynamic library characteristics -m4_defun([_LT_CHECK_SHAREDLIB_FROM_LINKLIB], -[m4_require([_LT_DECL_EGREP]) -m4_require([_LT_DECL_OBJDUMP]) -m4_require([_LT_DECL_DLLTOOL]) -AC_CACHE_CHECK([how to associate runtime and link libraries], -lt_cv_sharedlib_from_linklib_cmd, -[lt_cv_sharedlib_from_linklib_cmd='unknown' - -case $host_os in -cygwin* | mingw* | pw32* | cegcc*) - # two different shell functions defined in ltmain.sh; - # decide which one to use based on capabilities of $DLLTOOL - case `$DLLTOOL --help 2>&1` in - *--identify-strict*) - lt_cv_sharedlib_from_linklib_cmd=func_cygming_dll_for_implib - ;; - *) - lt_cv_sharedlib_from_linklib_cmd=func_cygming_dll_for_implib_fallback - ;; - esac - ;; -*) - # fallback: assume linklib IS sharedlib - lt_cv_sharedlib_from_linklib_cmd=$ECHO - ;; -esac -]) -sharedlib_from_linklib_cmd=$lt_cv_sharedlib_from_linklib_cmd -test -z "$sharedlib_from_linklib_cmd" && sharedlib_from_linklib_cmd=$ECHO - -_LT_DECL([], [sharedlib_from_linklib_cmd], [1], - [Command to associate shared and link libraries]) -])# _LT_CHECK_SHAREDLIB_FROM_LINKLIB - - -# _LT_PATH_MANIFEST_TOOL -# ---------------------- -# locate the manifest tool -m4_defun([_LT_PATH_MANIFEST_TOOL], -[AC_CHECK_TOOL(MANIFEST_TOOL, mt, :) -test -z "$MANIFEST_TOOL" && MANIFEST_TOOL=mt -AC_CACHE_CHECK([if $MANIFEST_TOOL is a manifest tool], [lt_cv_path_mainfest_tool], - [lt_cv_path_mainfest_tool=no - echo "$as_me:$LINENO: $MANIFEST_TOOL '-?'" >&AS_MESSAGE_LOG_FD - $MANIFEST_TOOL '-?' 2>conftest.err > conftest.out - cat conftest.err >&AS_MESSAGE_LOG_FD - if $GREP 'Manifest Tool' conftest.out > /dev/null; then - lt_cv_path_mainfest_tool=yes - fi - rm -f conftest*]) -if test yes != "$lt_cv_path_mainfest_tool"; then - MANIFEST_TOOL=: -fi -_LT_DECL([], [MANIFEST_TOOL], [1], [Manifest tool])dnl -])# _LT_PATH_MANIFEST_TOOL - - -# _LT_DLL_DEF_P([FILE]) -# --------------------- -# True iff FILE is a Windows DLL '.def' file. -# Keep in sync with func_dll_def_p in the libtool script -AC_DEFUN([_LT_DLL_DEF_P], -[dnl - test DEF = "`$SED -n dnl - -e '\''s/^[[ ]]*//'\'' dnl Strip leading whitespace - -e '\''/^\(;.*\)*$/d'\'' dnl Delete empty lines and comments - -e '\''s/^\(EXPORTS\|LIBRARY\)\([[ ]].*\)*$/DEF/p'\'' dnl - -e q dnl Only consider the first "real" line - $1`" dnl -])# _LT_DLL_DEF_P - - -# LT_LIB_M -# -------- -# check for math library -AC_DEFUN([LT_LIB_M], -[AC_REQUIRE([AC_CANONICAL_HOST])dnl -LIBM= -case $host in -*-*-beos* | *-*-cegcc* | *-*-cygwin* | *-*-haiku* | *-*-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 yes = "$GCC"; then - case $cc_basename in - nvcc*) - _LT_TAGVAR(lt_prog_compiler_no_builtin_flag, $1)=' -Xcompiler -fno-builtin' ;; - *) - _LT_TAGVAR(lt_prog_compiler_no_builtin_flag, $1)=' -fno-builtin' ;; - esac - - _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([AC_PROG_AWK])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 ia64 = "$host_cpu"; 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 - -if test "$lt_cv_nm_interface" = "MS dumpbin"; then - # Gets list of data symbols to import. - lt_cv_sys_global_symbol_to_import="sed -n -e 's/^I .* \(.*\)$/\1/p'" - # Adjust the below global symbol transforms to fixup imported variables. - lt_cdecl_hook=" -e 's/^I .* \(.*\)$/extern __declspec(dllimport) char \1;/p'" - lt_c_name_hook=" -e 's/^I .* \(.*\)$/ {\"\1\", (void *) 0},/p'" - lt_c_name_lib_hook="\ - -e 's/^I .* \(lib.*\)$/ {\"\1\", (void *) 0},/p'\ - -e 's/^I .* \(.*\)$/ {\"lib\1\", (void *) 0},/p'" -else - # Disable hooks by default. - lt_cv_sys_global_symbol_to_import= - lt_cdecl_hook= - lt_c_name_hook= - lt_c_name_lib_hook= -fi - -# 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"\ -$lt_cdecl_hook\ -" -e 's/^T .* \(.*\)$/extern int \1();/p'"\ -" -e 's/^$symcode$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"\ -$lt_c_name_hook\ -" -e 's/^: \(.*\) .*$/ {\"\1\", (void *) 0},/p'"\ -" -e 's/^$symcode$symcode* .* \(.*\)$/ {\"\1\", (void *) \&\1},/p'" - -# Transform an extracted symbol line into symbol name with lib prefix and -# symbol address. -lt_cv_sys_global_symbol_to_c_name_address_lib_prefix="sed -n"\ -$lt_c_name_lib_hook\ -" -e 's/^: \(.*\) .*$/ {\"\1\", (void *) 0},/p'"\ -" -e 's/^$symcode$symcode* .* \(lib.*\)$/ {\"\1\", (void *) \&\1},/p'"\ -" -e 's/^$symcode$symcode* .* \(.*\)$/ {\"lib\1\", (void *) \&\1},/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, - # D for any global variable and I for any imported 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};"\ -" /^COFF SYMBOL TABLE/{for(i in hide) delete hide[i]};"\ -" /Section length .*#relocs.*(pick any)/{hide[last_section]=1};"\ -" /^ *Symbol name *: /{split(\$ 0,sn,\":\"); si=substr(sn[2],2)};"\ -" /^ *Type *: code/{print \"T\",si,substr(si,length(prfx))};"\ -" /^ *Type *: data/{print \"I\",si,substr(si,length(prfx))};"\ -" \$ 0!~/External *\|/{next};"\ -" / 0+ UNDEF /{next}; / UNDEF \([^|]\)*()/{next};"\ -" {if(hide[section]) next};"\ -" {f=\"D\"}; \$ 0~/\(\).*\|/{f=\"T\"};"\ -" {split(\$ 0,a,/\||\r/); split(a[2],s)};"\ -" s[1]~/^[@?]/{print f,s[1],s[1]; next};"\ -" s[1]~prfx {split(s[1],t,\"@\"); print f,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 - lt_cv_sys_global_symbol_pipe="$lt_cv_sys_global_symbol_pipe | sed '/ __gnu_lto/d'" - - # 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 -/* Keep this code in sync between libtool.m4, ltmain, lt_system.h, and tests. */ -#if defined _WIN32 || defined __CYGWIN__ || defined _WIN32_WCE -/* DATA imports from DLLs on WIN32 can't be const, because runtime - relocations are performed -- see ld's documentation on pseudo-relocs. */ -# define LT@&t@_DLSYM_CONST -#elif defined __osf__ -/* This system does not cope well with relocations in const data. */ -# define LT@&t@_DLSYM_CONST -#else -# define LT@&t@_DLSYM_CONST const -#endif - -#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. */ -LT@&t@_DLSYM_CONST struct { - const char *name; - void *address; -} -lt__PROGRAM__LTX_preloaded_symbols[[]] = -{ - { "@PROGRAM@", (void *) 0 }, -_LT_EOF - $SED "s/^$symcode$symcode* .* \(.*\)$/ {\"\1\", (void *) \&\1},/" < "$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_globsym_save_LIBS=$LIBS - lt_globsym_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_globsym_save_LIBS - CFLAGS=$lt_globsym_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 yes = "$pipe_works"; 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 - -# Response file support. -if test "$lt_cv_nm_interface" = "MS dumpbin"; then - nm_file_list_spec='@' -elif $NM --help 2>/dev/null | grep '[[@]]FILE' >/dev/null; then - nm_file_list_spec='@' -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_import], [lt_cv_sys_global_symbol_to_import], [1], - [Transform the output of nm into a list of symbols to manually relocate]) -_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_DECL([nm_interface], [lt_cv_nm_interface], [1], - [The name lister interface]) -_LT_DECL([], [nm_file_list_spec], [1], - [Specify filename containing input files for $NM]) -]) # _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)= - -m4_if([$1], [CXX], [ - # C++ specific cases for pic, static, wl, etc. - if test yes = "$GXX"; 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 ia64 = "$host_cpu"; then - # AIX 5 now supports IA64 processor - _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' - fi - _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC' - ;; - - 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']) - case $host_os in - os2*) - _LT_TAGVAR(lt_prog_compiler_static, $1)='$wl-static' - ;; - esac - ;; - 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)= - ;; - haiku*) - # PIC is the default for Haiku. - # The "-static" flag exists, but is broken. - _LT_TAGVAR(lt_prog_compiler_static, $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 ia64 = "$host_cpu"; 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 - ;; - 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). - m4_if([$1], [GCJ], [], - [_LT_TAGVAR(lt_prog_compiler_pic, $1)='-DDLL_EXPORT']) - ;; - 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 ia64 != "$host_cpu"; 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 | kopensolaris*-gnu | 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* | bgxl[[cC]]* | mpixl[[cC]]*) - # IBM XL 8.0, 9.0 on PPC and BlueGene - _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*) - ;; - *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* | sunCC*) - # 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 yes = "$GCC"; 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 ia64 = "$host_cpu"; then - # AIX 5 now supports IA64 processor - _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' - fi - _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC' - ;; - - 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']) - case $host_os in - os2*) - _LT_TAGVAR(lt_prog_compiler_static, $1)='$wl-static' - ;; - esac - ;; - - 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' - ;; - - haiku*) - # PIC is the default for Haiku. - # The "-static" flag exists, but is broken. - _LT_TAGVAR(lt_prog_compiler_static, $1)= - ;; - - 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 - - case $cc_basename in - nvcc*) # Cuda Compiler Driver 2.2 - _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Xlinker ' - if test -n "$_LT_TAGVAR(lt_prog_compiler_pic, $1)"; then - _LT_TAGVAR(lt_prog_compiler_pic, $1)="-Xcompiler $_LT_TAGVAR(lt_prog_compiler_pic, $1)" - fi - ;; - 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 ia64 = "$host_cpu"; 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 - ;; - - 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' - case $cc_basename in - nagfor*) - # NAG Fortran compiler - _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,-Wl,,' - _LT_TAGVAR(lt_prog_compiler_pic, $1)='-PIC' - _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' - ;; - esac - ;; - - 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']) - case $host_os in - os2*) - _LT_TAGVAR(lt_prog_compiler_static, $1)='$wl-static' - ;; - esac - ;; - - 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 | kopensolaris*-gnu | 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' - ;; - nagfor*) - # NAG Fortran compiler - _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,-Wl,,' - _LT_TAGVAR(lt_prog_compiler_pic, $1)='-PIC' - _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' - ;; - tcc*) - # Fabrice Bellard et al's Tiny 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)='-static' - ;; - pgcc* | pgf77* | pgf90* | pgf95* | pgfortran*) - # 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* | bgxl* | bgf* | mpixl*) - # IBM XL C 8.0/Fortran 10.1, 11.1 on PPC and BlueGene - _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\ Ceres\ Fortran* | *Sun*Fortran*\ [[1-7]].* | *Sun*Fortran*\ 8.[[0-3]]*) - # 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)='' - ;; - *Sun\ F* | *Sun*Fortran*) - _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 ' - ;; - *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,' - ;; - *Intel*\ [[CF]]*Compiler*) - _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' - _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fPIC' - _LT_TAGVAR(lt_prog_compiler_static, $1)='-static' - ;; - *Portland\ Group*) - _LT_TAGVAR(lt_prog_compiler_wl, $1)='-Wl,' - _LT_TAGVAR(lt_prog_compiler_pic, $1)='-fpic' - _LT_TAGVAR(lt_prog_compiler_static, $1)='-Bstatic' - ;; - 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* | sunf77* | sunf90* | sunf95*) - _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 that 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_CACHE_CHECK([for $compiler option to produce PIC], - [_LT_TAGVAR(lt_cv_prog_compiler_pic, $1)], - [_LT_TAGVAR(lt_cv_prog_compiler_pic, $1)=$_LT_TAGVAR(lt_prog_compiler_pic, $1)]) -_LT_TAGVAR(lt_prog_compiler_pic, $1)=$_LT_TAGVAR(lt_cv_prog_compiler_pic, $1) - -# -# 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]) - -_LT_TAGDECL([wl], [lt_prog_compiler_wl], [1], - [How to pass a linker flag through the compiler]) -# -# 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_PATH_MANIFEST_TOOL])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' - _LT_TAGVAR(exclude_expsyms, $1)=['_GLOBAL_OFFSET_TABLE_|_GLOBAL__F[ID]_.*'] - 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 GNU nm, but means don't demangle to AIX nm. - # Without the "-l" option, or with the "-B" option, AIX nm treats - # weak defined symbols like other global defined symbols, whereas - # GNU nm marks them as "W". - # While the 'weak' keyword is ignored in the Export File, we need - # it in the Import File for the 'aix-soname' feature, so we have - # to replace the "-B" option with "-P" for AIX 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") || (\$ 2 == "W")) && ([substr](\$ 3,1,1) != ".")) { if (\$ 2 == "W") { print \$ 3 " weak" } else { print \$ 3 } } }'\'' | sort -u > $export_symbols' - else - _LT_TAGVAR(export_symbols_cmds, $1)='`func_echo_all $NM | $SED -e '\''s/B\([[^B]]*\)$/P\1/'\''` -PCpgl $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B") || (\$ 2 == "W") || (\$ 2 == "V") || (\$ 2 == "Z")) && ([substr](\$ 1,1,1) != ".")) { if ((\$ 2 == "W") || (\$ 2 == "V") || (\$ 2 == "Z")) { print \$ 1 " weak" } else { print \$ 1 } } }'\'' | sort -u > $export_symbols' - fi - ;; - pw32*) - _LT_TAGVAR(export_symbols_cmds, $1)=$ltdll_cmds - ;; - cygwin* | mingw* | cegcc*) - case $cc_basename in - cl*) - _LT_TAGVAR(exclude_expsyms, $1)='_NULL_IMPORT_DESCRIPTOR|_IMPORT_DESCRIPTOR_.*' - ;; - *) - _LT_TAGVAR(export_symbols_cmds, $1)='$NM $libobjs $convenience | $global_symbol_pipe | $SED -e '\''/^[[BCDGRS]][[ ]]/s/.*[[ ]]\([[^ ]]*\)/\1 DATA/;s/^.*[[ ]]__nm__\([[^ ]]*\)[[ ]][[^ ]]*/\1 DATA/;/^I[[ ]]/d;/^[[AITW]][[ ]]/s/.* //'\'' | sort | uniq > $export_symbols' - _LT_TAGVAR(exclude_expsyms, $1)=['[_]+GLOBAL_OFFSET_TABLE_|[_]+GLOBAL__[FID]_.*|[_]+head_[A-Za-z0-9_]+_dll|[A-Za-z0-9_]+_dll_iname'] - ;; - esac - ;; - *) - _LT_TAGVAR(export_symbols_cmds, $1)='$NM $libobjs $convenience | $global_symbol_pipe | $SED '\''s/.* //'\'' | sort | uniq > $export_symbols' - ;; - esac -], [ - 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_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 yes != "$GCC"; then - with_gnu_ld=no - fi - ;; - interix*) - # we just hope/assume this is gcc and not c89 (= MSVC++) - with_gnu_ld=yes - ;; - openbsd* | bitrig*) - with_gnu_ld=no - ;; - esac - - _LT_TAGVAR(ld_shlibs, $1)=yes - - # On some targets, GNU ld is compatible enough with the native linker - # that we're better off using the native interface for both. - lt_use_gnu_ld_interface=no - if test yes = "$with_gnu_ld"; then - case $host_os in - aix*) - # The AIX port of GNU ld has always aspired to compatibility - # with the native linker. However, as the warning in the GNU ld - # block says, versions before 2.19.5* couldn't really create working - # shared libraries, regardless of the interface used. - case `$LD -v 2>&1` in - *\ \(GNU\ Binutils\)\ 2.19.5*) ;; - *\ \(GNU\ Binutils\)\ 2.[[2-9]]*) ;; - *\ \(GNU\ Binutils\)\ [[3-9]]*) ;; - *) - lt_use_gnu_ld_interface=yes - ;; - esac - ;; - *) - lt_use_gnu_ld_interface=yes - ;; - esac - fi - - if test yes = "$lt_use_gnu_ld_interface"; 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 | $SED -e 's/([^)]\+)\s\+//' 2>&1` in - *GNU\ gold*) supports_anon_versioning=yes ;; - *\ [[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 ia64 != "$host_cpu"; then - _LT_TAGVAR(ld_shlibs, $1)=no - cat <<_LT_EOF 1>&2 - -*** Warning: the GNU linker, at least up to release 2.19, 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 install binutils -*** 2.20 or above, or modify your PATH so that a non-GNU linker is found. -*** You will then need to restart the configuration process. - -_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(export_dynamic_flag_spec, $1)='$wl--export-all-symbols' - _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/;s/^.*[[ ]]__nm__\([[^ ]]*\)[[ ]][[^ ]]*/\1 DATA/;/^I[[ ]]/d;/^[[AITW]][[ ]]/s/.* //'\'' | sort | uniq > $export_symbols' - _LT_TAGVAR(exclude_expsyms, $1)=['[_]+GLOBAL_OFFSET_TABLE_|[_]+GLOBAL__[FID]_.*|[_]+head_[A-Za-z0-9_]+_dll|[A-Za-z0-9_]+_dll_iname'] - - 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, use it as - # is; otherwise, prepend EXPORTS... - _LT_TAGVAR(archive_expsym_cmds, $1)='if _LT_DLL_DEF_P([$export_symbols]); 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 - ;; - - haiku*) - _LT_TAGVAR(archive_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' - _LT_TAGVAR(link_all_deplibs, $1)=yes - ;; - - os2*) - _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir' - _LT_TAGVAR(hardcode_minus_L, $1)=yes - _LT_TAGVAR(allow_undefined_flag, $1)=unsupported - shrext_cmds=.dll - _LT_TAGVAR(archive_cmds, $1)='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ - $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ - $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ - $ECHO EXPORTS >> $output_objdir/$libname.def~ - emxexp $libobjs | $SED /"_DLL_InitTerm"/d >> $output_objdir/$libname.def~ - $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ - emximp -o $lib $output_objdir/$libname.def' - _LT_TAGVAR(archive_expsym_cmds, $1)='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ - $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ - $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ - $ECHO EXPORTS >> $output_objdir/$libname.def~ - prefix_cmds="$SED"~ - if test EXPORTS = "`$SED 1q $export_symbols`"; then - prefix_cmds="$prefix_cmds -e 1d"; - fi~ - prefix_cmds="$prefix_cmds -e \"s/^\(.*\)$/_\1/g\""~ - cat $export_symbols | $prefix_cmds >> $output_objdir/$libname.def~ - $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ - emximp -o $lib $output_objdir/$libname.def' - _LT_TAGVAR(old_archive_From_new_cmds, $1)='emximp -o $output_objdir/${libname}_dll.a $output_objdir/$libname.def' - _LT_TAGVAR(enable_shared_with_static_runtimes, $1)=yes - ;; - - 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 | kopensolaris*-gnu) - tmp_diet=no - if test linux-dietlibc = "$host_os"; 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 no = "$tmp_diet" - then - tmp_addflag=' $pic_flag' - 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; func_echo_all \"$new_convenience\"` $wl--no-whole-archive' - tmp_addflag=' $pic_flag' - ;; - pgf77* | pgf90* | pgf95* | pgfortran*) - # 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; func_echo_all \"$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' ;; - nagfor*) # NAGFOR 5.3 - tmp_sharedflag='-Wl,-shared' ;; - xl[[cC]]* | bgxl[[cC]]* | mpixl[[cC]]*) # IBM XL C 8.0 on PPC (deal with xlf below) - tmp_sharedflag='-qmkshrobj' - tmp_addflag= ;; - nvcc*) # Cuda Compiler Driver 2.2 - _LT_TAGVAR(whole_archive_flag_spec, $1)='$wl--whole-archive`for conv in $convenience\"\"; do test -n \"$conv\" && new_convenience=\"$new_convenience,$conv\"; done; func_echo_all \"$new_convenience\"` $wl--no-whole-archive' - _LT_TAGVAR(compiler_needs_object, $1)=yes - ;; - 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; func_echo_all \"$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 yes = "$supports_anon_versioning"; 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 - tcc*) - _LT_TAGVAR(export_dynamic_flag_spec, $1)='-rdynamic' - ;; - xlf* | bgf* | bgxlf* | mpixlf*) - # 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)='$wl-rpath $wl$libdir' - _LT_TAGVAR(archive_cmds, $1)='$LD -shared $libobjs $deplibs $linker_flags -soname $soname -o $lib' - if test yes = "$supports_anon_versioning"; 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 $linker_flags -soname $soname -version-script $output_objdir/$libname.ver -o $lib' - fi - ;; - esac - else - _LT_TAGVAR(ld_shlibs, $1)=no - fi - ;; - - netbsd*) - 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 $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' - _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $pic_flag $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 $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' - _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $pic_flag $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 cannot -*** 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 $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' - _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $pic_flag $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 no = "$_LT_TAGVAR(ld_shlibs, $1)"; 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 yes = "$GCC" && 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 ia64 = "$host_cpu"; 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 GNU nm, but means don't demangle to AIX nm. - # Without the "-l" option, or with the "-B" option, AIX nm treats - # weak defined symbols like other global defined symbols, whereas - # GNU nm marks them as "W". - # While the 'weak' keyword is ignored in the Export File, we need - # it in the Import File for the 'aix-soname' feature, so we have - # to replace the "-B" option with "-P" for AIX 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") || (\$ 2 == "W")) && ([substr](\$ 3,1,1) != ".")) { if (\$ 2 == "W") { print \$ 3 " weak" } else { print \$ 3 } } }'\'' | sort -u > $export_symbols' - else - _LT_TAGVAR(export_symbols_cmds, $1)='`func_echo_all $NM | $SED -e '\''s/B\([[^B]]*\)$/P\1/'\''` -PCpgl $libobjs $convenience | awk '\''{ if (((\$ 2 == "T") || (\$ 2 == "D") || (\$ 2 == "B") || (\$ 2 == "W") || (\$ 2 == "V") || (\$ 2 == "Z")) && ([substr](\$ 1,1,1) != ".")) { if ((\$ 2 == "W") || (\$ 2 == "V") || (\$ 2 == "Z")) { print \$ 1 " weak" } else { print \$ 1 } } }'\'' | 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 - # have runtime linking enabled, and use it for executables. - # For shared libraries, we enable/disable runtime linking - # depending on the kind of the shared library created - - # when "with_aix_soname,aix_use_runtimelinking" is: - # "aix,no" lib.a(lib.so.V) shared, rtl:no, for executables - # "aix,yes" lib.so shared, rtl:yes, for executables - # lib.a static archive - # "both,no" lib.so.V(shr.o) shared, rtl:yes - # lib.a(lib.so.V) shared, rtl:no, for executables - # "both,yes" lib.so.V(shr.o) shared, rtl:yes, for executables - # lib.a(lib.so.V) shared, rtl:no - # "svr4,*" lib.so.V(shr.o) shared, rtl:yes, for executables - # lib.a static archive - case $host_os in aix4.[[23]]|aix4.[[23]].*|aix[[5-9]]*) - for ld_flag in $LDFLAGS; do - if (test x-brtl = "x$ld_flag" || test x-Wl,-brtl = "x$ld_flag"); then - aix_use_runtimelinking=yes - break - fi - done - if test svr4,no = "$with_aix_soname,$aix_use_runtimelinking"; then - # With aix-soname=svr4, we create the lib.so.V shared archives only, - # so we don't have lib.a shared libs to link our executables. - # We have to force runtime linking in this case. - aix_use_runtimelinking=yes - LDFLAGS="$LDFLAGS -Wl,-brtl" - fi - ;; - 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,' - case $with_aix_soname,$aix_use_runtimelinking in - aix,*) ;; # traditional, no import file - svr4,* | *,yes) # use import file - # The Import File defines what to hardcode. - _LT_TAGVAR(hardcode_direct, $1)=no - _LT_TAGVAR(hardcode_direct_absolute, $1)=no - ;; - esac - - if test yes = "$GCC"; 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 yes = "$aix_use_runtimelinking"; then - shared_flag="$shared_flag "'$wl-G' - fi - # Need to ensure runtime linking is disabled for the traditional - # shared library, or the linker may eventually find shared libraries - # /with/ Import File - we do not want to mix them. - shared_flag_aix='-shared' - shared_flag_svr4='-shared $wl-G' - else - # not using gcc - if test ia64 = "$host_cpu"; 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 yes = "$aix_use_runtimelinking"; then - shared_flag='$wl-G' - else - shared_flag='$wl-bM:SRE' - fi - shared_flag_aix='$wl-bM:SRE' - shared_flag_svr4='$wl-G' - 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,yes = "$with_aix_soname,$aix_use_runtimelinking"; 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([$1]) - _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 -n "$allow_undefined_flag"; then func_echo_all "$wl$allow_undefined_flag"; else :; fi` $wl'$exp_sym_flag:\$export_symbols' '$shared_flag - else - if test ia64 = "$host_cpu"; 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([$1]) - _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' - if test yes = "$with_gnu_ld"; then - # We only use this code for GNU lds that support --whole-archive. - _LT_TAGVAR(whole_archive_flag_spec, $1)='$wl--whole-archive$convenience $wl--no-whole-archive' - else - # Exported symbols can be pulled into shared objects from archives - _LT_TAGVAR(whole_archive_flag_spec, $1)='$convenience' - fi - _LT_TAGVAR(archive_cmds_need_lc, $1)=yes - _LT_TAGVAR(archive_expsym_cmds, $1)='$RM -r $output_objdir/$realname.d~$MKDIR $output_objdir/$realname.d' - # -brtl affects multiple linker settings, -berok does not and is overridden later - compiler_flags_filtered='`func_echo_all "$compiler_flags " | $SED -e "s%-brtl\\([[, ]]\\)%-berok\\1%g"`' - if test svr4 != "$with_aix_soname"; then - # This is similar to how AIX traditionally builds its shared libraries. - _LT_TAGVAR(archive_expsym_cmds, $1)="$_LT_TAGVAR(archive_expsym_cmds, $1)"'~$CC '$shared_flag_aix' -o $output_objdir/$realname.d/$soname $libobjs $deplibs $wl-bnoentry '$compiler_flags_filtered'$wl-bE:$export_symbols$allow_undefined_flag~$AR $AR_FLAGS $output_objdir/$libname$release.a $output_objdir/$realname.d/$soname' - fi - if test aix != "$with_aix_soname"; then - _LT_TAGVAR(archive_expsym_cmds, $1)="$_LT_TAGVAR(archive_expsym_cmds, $1)"'~$CC '$shared_flag_svr4' -o $output_objdir/$realname.d/$shared_archive_member_spec.o $libobjs $deplibs $wl-bnoentry '$compiler_flags_filtered'$wl-bE:$export_symbols$allow_undefined_flag~$STRIP -e $output_objdir/$realname.d/$shared_archive_member_spec.o~( func_echo_all "#! $soname($shared_archive_member_spec.o)"; if test shr_64 = "$shared_archive_member_spec"; then func_echo_all "# 64"; else func_echo_all "# 32"; fi; cat $export_symbols ) > $output_objdir/$realname.d/$shared_archive_member_spec.imp~$AR $AR_FLAGS $output_objdir/$soname $output_objdir/$realname.d/$shared_archive_member_spec.o $output_objdir/$realname.d/$shared_archive_member_spec.imp' - else - # used by -dlpreopen to get the symbols - _LT_TAGVAR(archive_expsym_cmds, $1)="$_LT_TAGVAR(archive_expsym_cmds, $1)"'~$MV $output_objdir/$realname.d/$soname $output_objdir' - fi - _LT_TAGVAR(archive_expsym_cmds, $1)="$_LT_TAGVAR(archive_expsym_cmds, $1)"'~$RM -r $output_objdir/$realname.d' - 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. - case $cc_basename in - cl*) - # Native MSVC - _LT_TAGVAR(hardcode_libdir_flag_spec, $1)=' ' - _LT_TAGVAR(allow_undefined_flag, $1)=unsupported - _LT_TAGVAR(always_export_symbols, $1)=yes - _LT_TAGVAR(file_list_spec, $1)='@' - # 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 $output_objdir/$soname $libobjs $compiler_flags $deplibs -Wl,-DLL,-IMPLIB:"$tool_output_objdir$libname.dll.lib"~linknames=' - _LT_TAGVAR(archive_expsym_cmds, $1)='if _LT_DLL_DEF_P([$export_symbols]); then - cp "$export_symbols" "$output_objdir/$soname.def"; - echo "$tool_output_objdir$soname.def" > "$output_objdir/$soname.exp"; - else - $SED -e '\''s/^/-link -EXPORT:/'\'' < $export_symbols > $output_objdir/$soname.exp; - fi~ - $CC -o $tool_output_objdir$soname $libobjs $compiler_flags $deplibs "@$tool_output_objdir$soname.exp" -Wl,-DLL,-IMPLIB:"$tool_output_objdir$libname.dll.lib"~ - linknames=' - # The linker will not automatically build a static lib if we build a DLL. - # _LT_TAGVAR(old_archive_from_new_cmds, $1)='true' - _LT_TAGVAR(enable_shared_with_static_runtimes, $1)=yes - _LT_TAGVAR(exclude_expsyms, $1)='_NULL_IMPORT_DESCRIPTOR|_IMPORT_DESCRIPTOR_.*' - _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' - # Don't use ranlib - _LT_TAGVAR(old_postinstall_cmds, $1)='chmod 644 $oldlib' - _LT_TAGVAR(postlink_cmds, $1)='lt_outputfile="@OUTPUT@"~ - lt_tool_outputfile="@TOOL_OUTPUT@"~ - case $lt_outputfile in - *.exe|*.EXE) ;; - *) - lt_outputfile=$lt_outputfile.exe - lt_tool_outputfile=$lt_tool_outputfile.exe - ;; - esac~ - if test : != "$MANIFEST_TOOL" && test -f "$lt_outputfile.manifest"; then - $MANIFEST_TOOL -manifest "$lt_tool_outputfile.manifest" -outputresource:"$lt_tool_outputfile" || exit 1; - $RM "$lt_outputfile.manifest"; - fi' - ;; - *) - # Assume MSVC wrapper - _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 `func_echo_all "$deplibs" | $SED '\''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(enable_shared_with_static_runtimes, $1)=yes - ;; - esac - ;; - - 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 - ;; - - # 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 $pic_flag -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 yes = "$GCC"; then - _LT_TAGVAR(archive_cmds, $1)='$RM $output_objdir/$soname~$CC -shared $pic_flag $wl+b $wl$install_libdir -o $output_objdir/$soname $libobjs $deplibs $compiler_flags~test "x$output_objdir/$soname" = "x$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 "x$output_objdir/$soname" = "x$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 yes,no = "$GCC,$with_gnu_ld"; then - _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $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 no = "$with_gnu_ld"; then - _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='$wl+b $wl$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 yes,no = "$GCC,$with_gnu_ld"; 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 $pic_flag $wl+h $wl$soname $wl+nodefaultrpath -o $lib $libobjs $deplibs $compiler_flags' - ;; - *) - _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $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' - ;; - *) - m4_if($1, [], [ - # Older versions of the 11.00 compiler do not understand -b yet - # (HP92453-01 A.11.01.20 doesn't, HP92453-01 B.11.X.35175-35176.GP does) - _LT_LINKER_OPTION([if $CC understands -b], - _LT_TAGVAR(lt_cv_prog_compiler__b, $1), [-b], - [_LT_TAGVAR(archive_cmds, $1)='$CC -b $wl+h $wl$soname $wl+b $wl$install_libdir -o $lib $libobjs $deplibs $compiler_flags'], - [_LT_TAGVAR(archive_cmds, $1)='$LD -b +h $soname +b $install_libdir -o $lib $libobjs $deplibs $linker_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 no = "$with_gnu_ld"; 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 yes = "$GCC"; then - _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $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. - # This should be the same for all languages, so no per-tag cache variable. - AC_CACHE_CHECK([whether the $host_os linker accepts -exported_symbol], - [lt_cv_irix_exported_symbol], - [save_LDFLAGS=$LDFLAGS - LDFLAGS="$LDFLAGS -shared $wl-exported_symbol ${wl}foo $wl-update_registry $wl/dev/null" - AC_LINK_IFELSE( - [AC_LANG_SOURCE( - [AC_LANG_CASE([C], [[int foo (void) { return 0; }]], - [C++], [[int foo (void) { return 0; }]], - [Fortran 77], [[ - subroutine foo - end]], - [Fortran], [[ - subroutine foo - end]])])], - [lt_cv_irix_exported_symbol=yes], - [lt_cv_irix_exported_symbol=no]) - LDFLAGS=$save_LDFLAGS]) - if test yes = "$lt_cv_irix_exported_symbol"; then - _LT_TAGVAR(archive_expsym_cmds, $1)='$CC -shared $pic_flag $libobjs $deplibs $compiler_flags $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $wl-update_registry $wl$output_objdir/so_locations $wl-exports_file $wl$export_symbols -o $lib' - fi - else - _LT_TAGVAR(archive_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags -soname $soname `test -n "$verstring" && func_echo_all "-set_version $verstring"` -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" && func_echo_all "-set_version $verstring"` -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 - ;; - - linux*) - case $cc_basename in - tcc*) - # Fabrice Bellard et al's Tiny C Compiler - _LT_TAGVAR(ld_shlibs, $1)=yes - _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag -o $lib $libobjs $deplibs $compiler_flags' - ;; - esac - ;; - - netbsd*) - 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* | bitrig*) - 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__`"; 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 - _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' - 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 - shrext_cmds=.dll - _LT_TAGVAR(archive_cmds, $1)='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ - $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ - $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ - $ECHO EXPORTS >> $output_objdir/$libname.def~ - emxexp $libobjs | $SED /"_DLL_InitTerm"/d >> $output_objdir/$libname.def~ - $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ - emximp -o $lib $output_objdir/$libname.def' - _LT_TAGVAR(archive_expsym_cmds, $1)='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ - $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ - $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ - $ECHO EXPORTS >> $output_objdir/$libname.def~ - prefix_cmds="$SED"~ - if test EXPORTS = "`$SED 1q $export_symbols`"; then - prefix_cmds="$prefix_cmds -e 1d"; - fi~ - prefix_cmds="$prefix_cmds -e \"s/^\(.*\)$/_\1/g\""~ - cat $export_symbols | $prefix_cmds >> $output_objdir/$libname.def~ - $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ - emximp -o $lib $output_objdir/$libname.def' - _LT_TAGVAR(old_archive_From_new_cmds, $1)='emximp -o $output_objdir/${libname}_dll.a $output_objdir/$libname.def' - _LT_TAGVAR(enable_shared_with_static_runtimes, $1)=yes - ;; - - osf3*) - if test yes = "$GCC"; 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" && func_echo_all "$wl-set_version $wl$verstring"` $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" && func_echo_all "-set_version $verstring"` -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 yes = "$GCC"; then - _LT_TAGVAR(allow_undefined_flag, $1)=' $wl-expect_unresolved $wl\*' - _LT_TAGVAR(archive_cmds, $1)='$CC -shared$allow_undefined_flag $pic_flag $libobjs $deplibs $compiler_flags $wl-msym $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $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" && func_echo_all "-set_version $verstring"` -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 "-set_version $verstring"` -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 yes = "$GCC"; then - wlarc='$wl' - _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag $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 $pic_flag $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 yes = "$GCC"; 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 sequent = "$host_vendor"; 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 yes = "$GCC"; 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 CANNOT 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 yes = "$GCC"; 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 sni = "$host_vendor"; 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 no = "$_LT_TAGVAR(ld_shlibs, $1)" && 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 yes,yes = "$GCC,$enable_shared"; 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_CACHE_CHECK([whether -lc should be explicitly linked in], - [lt_cv_]_LT_TAGVAR(archive_cmds_need_lc, $1), - [$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_cv_[]_LT_TAGVAR(archive_cmds_need_lc, $1)=no - else - lt_cv_[]_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* - ]) - _LT_TAGVAR(archive_cmds_need_lc, $1)=$lt_cv_[]_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_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([], [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([], [postlink_cmds], [2], - [Commands necessary for finishing linking programs]) -_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 what 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 no = "$can_build_shared" && 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 yes = "$enable_shared" && enable_static=no - if test -n "$RANLIB"; then - archive_cmds="$archive_cmds~\$RANLIB \$lib" - postinstall_cmds='$RANLIB $lib' - fi - ;; - - aix[[4-9]]*) - if test ia64 != "$host_cpu"; then - case $enable_shared,$with_aix_soname,$aix_use_runtimelinking in - yes,aix,yes) ;; # shared object as lib.so file only - yes,svr4,*) ;; # shared object as lib.so archive member only - yes,*) enable_static=no ;; # shared object in lib.a archive as well - esac - 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 yes = "$enable_shared" || enable_static=yes - AC_MSG_RESULT([$enable_static]) - - _LT_CONFIG($1) -fi -AC_LANG_POP -CC=$lt_save_CC -])# _LT_LANG_C_CONFIG - - -# _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], -[m4_require([_LT_FILEUTILS_DEFAULTS])dnl -m4_require([_LT_DECL_EGREP])dnl -m4_require([_LT_PATH_MANIFEST_TOOL])dnl -if test -n "$CXX" && ( test no != "$CXX" && - ( (test g++ = "$CXX" && `g++ -v >/dev/null 2>&1` ) || - (test g++ != "$CXX"))); then - AC_PROG_CXXCPP -else - _lt_caught_CXX_error=yes -fi - -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_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(reload_flag, $1)=$reload_flag -_LT_TAGVAR(reload_cmds, $1)=$reload_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 yes != "$_lt_caught_CXX_error"; 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_CFLAGS=$CFLAGS - 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++"} - CFLAGS=$CXXFLAGS - 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 yes = "$GXX"; 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 yes = "$GXX"; 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 yes = "$with_gnu_ld"; then - _LT_TAGVAR(archive_cmds, $1)='$CC $pic_flag -shared -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname -o $lib' - _LT_TAGVAR(archive_expsym_cmds, $1)='$CC $pic_flag -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 -v "^Configured with:" | $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 ia64 = "$host_cpu"; 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 - # have runtime linking enabled, and use it for executables. - # For shared libraries, we enable/disable runtime linking - # depending on the kind of the shared library created - - # when "with_aix_soname,aix_use_runtimelinking" is: - # "aix,no" lib.a(lib.so.V) shared, rtl:no, for executables - # "aix,yes" lib.so shared, rtl:yes, for executables - # lib.a static archive - # "both,no" lib.so.V(shr.o) shared, rtl:yes - # lib.a(lib.so.V) shared, rtl:no, for executables - # "both,yes" lib.so.V(shr.o) shared, rtl:yes, for executables - # lib.a(lib.so.V) shared, rtl:no - # "svr4,*" lib.so.V(shr.o) shared, rtl:yes, for executables - # lib.a static archive - 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 - if test svr4,no = "$with_aix_soname,$aix_use_runtimelinking"; then - # With aix-soname=svr4, we create the lib.so.V shared archives only, - # so we don't have lib.a shared libs to link our executables. - # We have to force runtime linking in this case. - aix_use_runtimelinking=yes - LDFLAGS="$LDFLAGS -Wl,-brtl" - fi - ;; - 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,' - case $with_aix_soname,$aix_use_runtimelinking in - aix,*) ;; # no import file - svr4,* | *,yes) # use import file - # The Import File defines what to hardcode. - _LT_TAGVAR(hardcode_direct, $1)=no - _LT_TAGVAR(hardcode_direct_absolute, $1)=no - ;; - esac - - if test yes = "$GXX"; 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 yes = "$aix_use_runtimelinking"; then - shared_flag=$shared_flag' $wl-G' - fi - # Need to ensure runtime linking is disabled for the traditional - # shared library, or the linker may eventually find shared libraries - # /with/ Import File - we do not want to mix them. - shared_flag_aix='-shared' - shared_flag_svr4='-shared $wl-G' - else - # not using gcc - if test ia64 = "$host_cpu"; 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 yes = "$aix_use_runtimelinking"; then - shared_flag='$wl-G' - else - shared_flag='$wl-bM:SRE' - fi - shared_flag_aix='$wl-bM:SRE' - shared_flag_svr4='$wl-G' - 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,yes = "$with_aix_soname,$aix_use_runtimelinking"; then - # Warning - without using the other runtime loading flags (-brtl), - # -berok will link without error, but may produce a broken library. - # The "-G" linker flag allows undefined symbols. - _LT_TAGVAR(no_undefined_flag, $1)='-bernotok' - # Determine the default libpath from the value encoded in an empty - # executable. - _LT_SYS_MODULE_PATH_AIX([$1]) - _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 -n "$allow_undefined_flag"; then func_echo_all "$wl$allow_undefined_flag"; else :; fi` $wl'$exp_sym_flag:\$export_symbols' '$shared_flag - else - if test ia64 = "$host_cpu"; 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([$1]) - _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' - if test yes = "$with_gnu_ld"; then - # We only use this code for GNU lds that support --whole-archive. - _LT_TAGVAR(whole_archive_flag_spec, $1)='$wl--whole-archive$convenience $wl--no-whole-archive' - else - # Exported symbols can be pulled into shared objects from archives - _LT_TAGVAR(whole_archive_flag_spec, $1)='$convenience' - fi - _LT_TAGVAR(archive_cmds_need_lc, $1)=yes - _LT_TAGVAR(archive_expsym_cmds, $1)='$RM -r $output_objdir/$realname.d~$MKDIR $output_objdir/$realname.d' - # -brtl affects multiple linker settings, -berok does not and is overridden later - compiler_flags_filtered='`func_echo_all "$compiler_flags " | $SED -e "s%-brtl\\([[, ]]\\)%-berok\\1%g"`' - if test svr4 != "$with_aix_soname"; then - # This is similar to how AIX traditionally builds its shared - # libraries. Need -bnortl late, we may have -brtl in LDFLAGS. - _LT_TAGVAR(archive_expsym_cmds, $1)="$_LT_TAGVAR(archive_expsym_cmds, $1)"'~$CC '$shared_flag_aix' -o $output_objdir/$realname.d/$soname $libobjs $deplibs $wl-bnoentry '$compiler_flags_filtered'$wl-bE:$export_symbols$allow_undefined_flag~$AR $AR_FLAGS $output_objdir/$libname$release.a $output_objdir/$realname.d/$soname' - fi - if test aix != "$with_aix_soname"; then - _LT_TAGVAR(archive_expsym_cmds, $1)="$_LT_TAGVAR(archive_expsym_cmds, $1)"'~$CC '$shared_flag_svr4' -o $output_objdir/$realname.d/$shared_archive_member_spec.o $libobjs $deplibs $wl-bnoentry '$compiler_flags_filtered'$wl-bE:$export_symbols$allow_undefined_flag~$STRIP -e $output_objdir/$realname.d/$shared_archive_member_spec.o~( func_echo_all "#! $soname($shared_archive_member_spec.o)"; if test shr_64 = "$shared_archive_member_spec"; then func_echo_all "# 64"; else func_echo_all "# 32"; fi; cat $export_symbols ) > $output_objdir/$realname.d/$shared_archive_member_spec.imp~$AR $AR_FLAGS $output_objdir/$soname $output_objdir/$realname.d/$shared_archive_member_spec.o $output_objdir/$realname.d/$shared_archive_member_spec.imp' - else - # used by -dlpreopen to get the symbols - _LT_TAGVAR(archive_expsym_cmds, $1)="$_LT_TAGVAR(archive_expsym_cmds, $1)"'~$MV $output_objdir/$realname.d/$soname $output_objdir' - fi - _LT_TAGVAR(archive_expsym_cmds, $1)="$_LT_TAGVAR(archive_expsym_cmds, $1)"'~$RM -r $output_objdir/$realname.d' - 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*) - case $GXX,$cc_basename in - ,cl* | no,cl*) - # Native MSVC - # 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 - _LT_TAGVAR(always_export_symbols, $1)=yes - _LT_TAGVAR(file_list_spec, $1)='@' - # 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 $output_objdir/$soname $libobjs $compiler_flags $deplibs -Wl,-DLL,-IMPLIB:"$tool_output_objdir$libname.dll.lib"~linknames=' - _LT_TAGVAR(archive_expsym_cmds, $1)='if _LT_DLL_DEF_P([$export_symbols]); then - cp "$export_symbols" "$output_objdir/$soname.def"; - echo "$tool_output_objdir$soname.def" > "$output_objdir/$soname.exp"; - else - $SED -e '\''s/^/-link -EXPORT:/'\'' < $export_symbols > $output_objdir/$soname.exp; - fi~ - $CC -o $tool_output_objdir$soname $libobjs $compiler_flags $deplibs "@$tool_output_objdir$soname.exp" -Wl,-DLL,-IMPLIB:"$tool_output_objdir$libname.dll.lib"~ - linknames=' - # The linker will not automatically build a static lib if we build a DLL. - # _LT_TAGVAR(old_archive_from_new_cmds, $1)='true' - _LT_TAGVAR(enable_shared_with_static_runtimes, $1)=yes - # Don't use ranlib - _LT_TAGVAR(old_postinstall_cmds, $1)='chmod 644 $oldlib' - _LT_TAGVAR(postlink_cmds, $1)='lt_outputfile="@OUTPUT@"~ - lt_tool_outputfile="@TOOL_OUTPUT@"~ - case $lt_outputfile in - *.exe|*.EXE) ;; - *) - lt_outputfile=$lt_outputfile.exe - lt_tool_outputfile=$lt_tool_outputfile.exe - ;; - esac~ - func_to_tool_file "$lt_outputfile"~ - if test : != "$MANIFEST_TOOL" && test -f "$lt_outputfile.manifest"; then - $MANIFEST_TOOL -manifest "$lt_tool_outputfile.manifest" -outputresource:"$lt_tool_outputfile" || exit 1; - $RM "$lt_outputfile.manifest"; - fi' - ;; - *) - # g++ - # _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(export_dynamic_flag_spec, $1)='$wl--export-all-symbols' - _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, use it as - # is; otherwise, prepend EXPORTS... - _LT_TAGVAR(archive_expsym_cmds, $1)='if _LT_DLL_DEF_P([$export_symbols]); 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 - ;; - esac - ;; - darwin* | rhapsody*) - _LT_DARWIN_LINKER_FEATURES($1) - ;; - - os2*) - _LT_TAGVAR(hardcode_libdir_flag_spec, $1)='-L$libdir' - _LT_TAGVAR(hardcode_minus_L, $1)=yes - _LT_TAGVAR(allow_undefined_flag, $1)=unsupported - shrext_cmds=.dll - _LT_TAGVAR(archive_cmds, $1)='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ - $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ - $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ - $ECHO EXPORTS >> $output_objdir/$libname.def~ - emxexp $libobjs | $SED /"_DLL_InitTerm"/d >> $output_objdir/$libname.def~ - $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ - emximp -o $lib $output_objdir/$libname.def' - _LT_TAGVAR(archive_expsym_cmds, $1)='$ECHO "LIBRARY ${soname%$shared_ext} INITINSTANCE TERMINSTANCE" > $output_objdir/$libname.def~ - $ECHO "DESCRIPTION \"$libname\"" >> $output_objdir/$libname.def~ - $ECHO "DATA MULTIPLE NONSHARED" >> $output_objdir/$libname.def~ - $ECHO EXPORTS >> $output_objdir/$libname.def~ - prefix_cmds="$SED"~ - if test EXPORTS = "`$SED 1q $export_symbols`"; then - prefix_cmds="$prefix_cmds -e 1d"; - fi~ - prefix_cmds="$prefix_cmds -e \"s/^\(.*\)$/_\1/g\""~ - cat $export_symbols | $prefix_cmds >> $output_objdir/$libname.def~ - $CC -Zdll -Zcrtdll -o $output_objdir/$soname $libobjs $deplibs $compiler_flags $output_objdir/$libname.def~ - emximp -o $lib $output_objdir/$libname.def' - _LT_TAGVAR(old_archive_From_new_cmds, $1)='emximp -o $output_objdir/${libname}_dll.a $output_objdir/$libname.def' - _LT_TAGVAR(enable_shared_with_static_runtimes, $1)=yes - ;; - - 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 - ;; - - freebsd2.*) - # 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 - ;; - - haiku*) - _LT_TAGVAR(archive_cmds, $1)='$CC -shared $libobjs $deplibs $compiler_flags $wl-soname $wl$soname -o $lib' - _LT_TAGVAR(link_all_deplibs, $1)=yes - ;; - - 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 "x$output_objdir/$soname" = "x$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; func_echo_all "$list"' - ;; - *) - if test yes = "$GXX"; then - _LT_TAGVAR(archive_cmds, $1)='$RM $output_objdir/$soname~$CC -shared -nostdlib $pic_flag $wl+b $wl$install_libdir -o $output_objdir/$soname $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags~test "x$output_objdir/$soname" = "x$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 no = "$with_gnu_ld"; 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; func_echo_all "$list"' - ;; - *) - if test yes = "$GXX"; then - if test no = "$with_gnu_ld"; 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 $pic_flag $wl+h $wl$soname $wl+nodefaultrpath -o $lib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags' - ;; - *) - _LT_TAGVAR(archive_cmds, $1)='$CC -shared -nostdlib $pic_flag $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" && func_echo_all "-set_version $verstring"` -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 yes = "$GXX"; then - if test no = "$with_gnu_ld"; then - _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $wl-update_registry $wl$output_objdir/so_locations -o $lib' - else - _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag -nostdlib $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` -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 | kopensolaris*-gnu | 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; func_echo_all "$list"' - - _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 | sort | $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 | sort | $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 | sort | $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 | sort | $NL2SP` $postdep_objects $compiler_flags $wl-soname $wl$soname $wl-retain-symbols-file $wl$export_symbols -o $lib' - ;; - *) # Version 6 and above 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; func_echo_all \"$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=`func_echo_all "$templist" | $SED "s/\(^.*ld.*\)\( .*ld .*$\)/\1/"`; list= ; for z in $templist; do case $z in conftest.$objext) list="$list $z";; *.$objext);; *) list="$list $z";;esac; done; func_echo_all "X$list" | $Xsed' - ;; - xl* | mpixl* | bgxl*) - # 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 yes = "$supports_anon_versioning"; 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; func_echo_all \"$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='func_echo_all' - - # 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 - ;; - - openbsd* | bitrig*) - 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__`"; 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=func_echo_all - 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" && func_echo_all "$wl-set_version $verstring"` -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" && func_echo_all "-set_version $verstring"` -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 "-set_version $verstring"` -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=`func_echo_all "$templist" | $SED "s/\(^.*ld.*\)\( .*ld.*$\)/\1/"`; list= ; for z in $templist; do case $z in conftest.$objext) list="$list $z";; *.$objext);; *) list="$list $z";;esac; done; func_echo_all "$list"' - ;; - *) - if test yes,no = "$GXX,$with_gnu_ld"; 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" && func_echo_all "$wl-set_version $wl$verstring"` $wl-update_registry $wl$output_objdir/so_locations -o $lib' - ;; - *) - _LT_TAGVAR(archive_cmds, $1)='$CC -shared $pic_flag -nostdlib $allow_undefined_flag $predep_objects $libobjs $deplibs $postdep_objects $compiler_flags $wl-msym $wl-soname $wl$soname `test -n "$verstring" && func_echo_all "$wl-set_version $wl$verstring"` $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 -v "^Configured with:" | $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* | sunCC*) - # 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='func_echo_all' - - # 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 yes,no = "$GXX,$with_gnu_ld"; 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 $pic_flag -nostdlib $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 $pic_flag -nostdlib $wl-M $wl$lib.exp $wl-h $wl$soname -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 -v "^Configured with:" | $GREP "\-L"' - else - # g++ 2.7 appears to require '-G' NOT '-shared' on this - # platform. - _LT_TAGVAR(archive_cmds, $1)='$CC -G -nostdlib $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 $wl-h $wl$soname -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 -v "^Configured with:" | $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 CANNOT 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(old_archive_cmds, $1)='$CC -Tprelink_objects $oldobjs~ - '"$_LT_TAGVAR(old_archive_cmds, $1)" - _LT_TAGVAR(reload_cmds, $1)='$CC -Tprelink_objects $reload_objs~ - '"$_LT_TAGVAR(reload_cmds, $1)" - ;; - *) - _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 no = "$_LT_TAGVAR(ld_shlibs, $1)" && 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 - CFLAGS=$lt_save_CFLAGS - 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 yes != "$_lt_caught_CXX_error" - -AC_LANG_POP -])# _LT_LANG_CXX_CONFIG - - -# _LT_FUNC_STRIPNAME_CNF -# ---------------------- -# func_stripname_cnf 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). -# -# This function is identical to the (non-XSI) version of func_stripname, -# except this one can be used by m4 code that may be executed by configure, -# rather than the libtool script. -m4_defun([_LT_FUNC_STRIPNAME_CNF],[dnl -AC_REQUIRE([_LT_DECL_SED]) -AC_REQUIRE([_LT_PROG_ECHO_BACKSLASH]) -func_stripname_cnf () -{ - case @S|@2 in - .*) func_stripname_result=`$ECHO "@S|@3" | $SED "s%^@S|@1%%; s%\\\\@S|@2\$%%"`;; - *) func_stripname_result=`$ECHO "@S|@3" | $SED "s%^@S|@1%%; s%@S|@2\$%%"`;; - esac -} # func_stripname_cnf -])# _LT_FUNC_STRIPNAME_CNF - - -# _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 -AC_REQUIRE([_LT_FUNC_STRIPNAME_CNF])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 -], [$1], [GO], [cat > conftest.$ac_ext <<_LT_EOF -package foo -func foo() { -} -_LT_EOF -]) - -_lt_libdeps_save_CFLAGS=$CFLAGS -case "$CC $CFLAGS " in #( -*\ -flto*\ *) CFLAGS="$CFLAGS -fno-lto" ;; -*\ -fwhopr*\ *) CFLAGS="$CFLAGS -fno-whopr" ;; -*\ -fuse-linker-plugin*\ *) CFLAGS="$CFLAGS -fno-use-linker-plugin" ;; -esac - -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 $prev$p in - - -L* | -R* | -l*) - # Some compilers place space between "-{L,R}" and the path. - # Remove the space. - if test x-L = "$p" || - test x-R = "$p"; then - prev=$p - continue - fi - - # Expand the sysroot to ease extracting the directories later. - if test -z "$prev"; then - case $p in - -L*) func_stripname_cnf '-L' '' "$p"; prev=-L; p=$func_stripname_result ;; - -R*) func_stripname_cnf '-R' '' "$p"; prev=-R; p=$func_stripname_result ;; - -l*) func_stripname_cnf '-l' '' "$p"; prev=-l; p=$func_stripname_result ;; - esac - fi - case $p in - =*) func_stripname_cnf '=' '' "$p"; p=$lt_sysroot$func_stripname_result ;; - esac - if test no = "$pre_test_object_deps_done"; then - case $prev 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 - prev= - ;; - - *.lto.$objext) ;; # Ignore GCC LTO objects - *.$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 no = "$pre_test_object_deps_done"; 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 -CFLAGS=$_lt_libdeps_save_CFLAGS - -# 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)= - ;; -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_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_LANG_PUSH(Fortran 77) -if test -z "$F77" || test no = "$F77"; then - _lt_disable_F77=yes -fi - -_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_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(reload_flag, $1)=$reload_flag -_LT_TAGVAR(reload_cmds, $1)=$reload_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 yes != "$_lt_disable_F77"; 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 - lt_save_CFLAGS=$CFLAGS - CC=${F77-"f77"} - CFLAGS=$FFLAGS - 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 no = "$can_build_shared" && 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 yes = "$enable_shared" && enable_static=no - if test -n "$RANLIB"; then - archive_cmds="$archive_cmds~\$RANLIB \$lib" - postinstall_cmds='$RANLIB $lib' - fi - ;; - aix[[4-9]]*) - if test ia64 != "$host_cpu"; then - case $enable_shared,$with_aix_soname,$aix_use_runtimelinking in - yes,aix,yes) ;; # shared object as lib.so file only - yes,svr4,*) ;; # shared object as lib.so archive member only - yes,*) enable_static=no ;; # shared object in lib.a archive as well - esac - 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 yes = "$enable_shared" || 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 - CFLAGS=$lt_save_CFLAGS -fi # test yes != "$_lt_disable_F77" - -AC_LANG_POP -])# _LT_LANG_F77_CONFIG - - -# _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_LANG_PUSH(Fortran) - -if test -z "$FC" || test no = "$FC"; then - _lt_disable_FC=yes -fi - -_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_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(reload_flag, $1)=$reload_flag -_LT_TAGVAR(reload_cmds, $1)=$reload_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 yes != "$_lt_disable_FC"; 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 - lt_save_CFLAGS=$CFLAGS - CC=${FC-"f95"} - CFLAGS=$FCFLAGS - 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 no = "$can_build_shared" && 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 yes = "$enable_shared" && enable_static=no - if test -n "$RANLIB"; then - archive_cmds="$archive_cmds~\$RANLIB \$lib" - postinstall_cmds='$RANLIB $lib' - fi - ;; - aix[[4-9]]*) - if test ia64 != "$host_cpu"; then - case $enable_shared,$with_aix_soname,$aix_use_runtimelinking in - yes,aix,yes) ;; # shared object as lib.so file only - yes,svr4,*) ;; # shared object as lib.so archive member only - yes,*) enable_static=no ;; # shared object in lib.a archive as well - esac - 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 yes = "$enable_shared" || 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 - CFLAGS=$lt_save_CFLAGS -fi # test yes != "$_lt_disable_FC" - -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_CFLAGS=$CFLAGS -lt_save_GCC=$GCC -GCC=yes -CC=${GCJ-"gcj"} -CFLAGS=$GCJFLAGS -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 -_LT_TAGVAR(reload_flag, $1)=$reload_flag -_LT_TAGVAR(reload_cmds, $1)=$reload_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 -CFLAGS=$lt_save_CFLAGS -])# _LT_LANG_GCJ_CONFIG - - -# _LT_LANG_GO_CONFIG([TAG]) -# -------------------------- -# Ensure that the configuration variables for the GNU Go compiler -# are suitably defined. These variables are subsequently used by _LT_CONFIG -# to write the compiler configuration to 'libtool'. -m4_defun([_LT_LANG_GO_CONFIG], -[AC_REQUIRE([LT_PROG_GO])dnl -AC_LANG_SAVE - -# Source file extension for Go test sources. -ac_ext=go - -# Object file extension for compiled Go test sources. -objext=o -_LT_TAGVAR(objext, $1)=$objext - -# Code to be used in simple compile tests -lt_simple_compile_test_code="package main; func main() { }" - -# Code to be used in simple link tests -lt_simple_link_test_code='package main; func main() { }' - -# 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_CFLAGS=$CFLAGS -lt_save_GCC=$GCC -GCC=yes -CC=${GOC-"gccgo"} -CFLAGS=$GOFLAGS -compiler=$CC -_LT_TAGVAR(compiler, $1)=$CC -_LT_TAGVAR(LD, $1)=$LD -_LT_CC_BASENAME([$compiler]) - -# Go 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 -_LT_TAGVAR(reload_flag, $1)=$reload_flag -_LT_TAGVAR(reload_cmds, $1)=$reload_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 -CFLAGS=$lt_save_CFLAGS -])# _LT_LANG_GO_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_CFLAGS=$CFLAGS -lt_save_GCC=$GCC -GCC= -CC=${RC-"windres"} -CFLAGS= -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 -CFLAGS=$lt_save_CFLAGS -])# _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 set = "${GCJFLAGS+set}" || 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_GO -# ---------- -AC_DEFUN([LT_PROG_GO], -[AC_CHECK_TOOL(GOC, gccgo,) -]) - - -# 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_DLLTOOL -# ---------------- -# Ensure DLLTOOL variable is set. -m4_defun([_LT_DECL_DLLTOOL], -[AC_CHECK_TOOL(DLLTOOL, dlltool, false) -test -z "$DLLTOOL" && DLLTOOL=dlltool -_LT_DECL([], [DLLTOOL], [1], [DLL creation program]) -AC_SUBST([DLLTOOL]) -]) - -# _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 10 -lt "$lt_ac_count" && 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], -[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_PATH_CONVERSION_FUNCTIONS -# ----------------------------- -# Determine what file name conversion functions should be used by -# func_to_host_file (and, implicitly, by func_to_host_path). These are needed -# for certain cross-compile configurations and native mingw. -m4_defun([_LT_PATH_CONVERSION_FUNCTIONS], -[AC_REQUIRE([AC_CANONICAL_HOST])dnl -AC_REQUIRE([AC_CANONICAL_BUILD])dnl -AC_MSG_CHECKING([how to convert $build file names to $host format]) -AC_CACHE_VAL(lt_cv_to_host_file_cmd, -[case $host in - *-*-mingw* ) - case $build in - *-*-mingw* ) # actually msys - lt_cv_to_host_file_cmd=func_convert_file_msys_to_w32 - ;; - *-*-cygwin* ) - lt_cv_to_host_file_cmd=func_convert_file_cygwin_to_w32 - ;; - * ) # otherwise, assume *nix - lt_cv_to_host_file_cmd=func_convert_file_nix_to_w32 - ;; - esac - ;; - *-*-cygwin* ) - case $build in - *-*-mingw* ) # actually msys - lt_cv_to_host_file_cmd=func_convert_file_msys_to_cygwin - ;; - *-*-cygwin* ) - lt_cv_to_host_file_cmd=func_convert_file_noop - ;; - * ) # otherwise, assume *nix - lt_cv_to_host_file_cmd=func_convert_file_nix_to_cygwin - ;; - esac - ;; - * ) # unhandled hosts (and "normal" native builds) - lt_cv_to_host_file_cmd=func_convert_file_noop - ;; -esac -]) -to_host_file_cmd=$lt_cv_to_host_file_cmd -AC_MSG_RESULT([$lt_cv_to_host_file_cmd]) -_LT_DECL([to_host_file_cmd], [lt_cv_to_host_file_cmd], - [0], [convert $build file names to $host format])dnl - -AC_MSG_CHECKING([how to convert $build file names to toolchain format]) -AC_CACHE_VAL(lt_cv_to_tool_file_cmd, -[#assume ordinary cross tools, or native build. -lt_cv_to_tool_file_cmd=func_convert_file_noop -case $host in - *-*-mingw* ) - case $build in - *-*-mingw* ) # actually msys - lt_cv_to_tool_file_cmd=func_convert_file_msys_to_w32 - ;; - esac - ;; -esac -]) -to_tool_file_cmd=$lt_cv_to_tool_file_cmd -AC_MSG_RESULT([$lt_cv_to_tool_file_cmd]) -_LT_DECL([to_tool_file_cmd], [lt_cv_to_tool_file_cmd], - [0], [convert $build files to toolchain format])dnl -])# _LT_PATH_CONVERSION_FUNCTIONS diff -Nru ecl-16.1.2/src/bdwgc/m4/lt~obsolete.m4 ecl-16.1.3+ds/src/bdwgc/m4/lt~obsolete.m4 --- ecl-16.1.2/src/bdwgc/m4/lt~obsolete.m4 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/m4/lt~obsolete.m4 1970-01-01 00:00:00.000000000 +0000 @@ -1,99 +0,0 @@ -# lt~obsolete.m4 -- aclocal satisfying obsolete definitions. -*-Autoconf-*- -# -# Copyright (C) 2004-2005, 2007, 2009, 2011-2015 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 5 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_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])]) -m4_ifndef([_LT_REQUIRED_DARWIN_CHECKS], [AC_DEFUN([_LT_REQUIRED_DARWIN_CHECKS])]) -m4_ifndef([_LT_AC_PROG_CXXCPP], [AC_DEFUN([_LT_AC_PROG_CXXCPP])]) -m4_ifndef([_LT_PREPARE_SED_QUOTE_VARS], [AC_DEFUN([_LT_PREPARE_SED_QUOTE_VARS])]) -m4_ifndef([_LT_PROG_ECHO_BACKSLASH], [AC_DEFUN([_LT_PROG_ECHO_BACKSLASH])]) -m4_ifndef([_LT_PROG_F77], [AC_DEFUN([_LT_PROG_F77])]) -m4_ifndef([_LT_PROG_FC], [AC_DEFUN([_LT_PROG_FC])]) -m4_ifndef([_LT_PROG_CXX], [AC_DEFUN([_LT_PROG_CXX])]) diff -Nru ecl-16.1.2/src/bdwgc/m4/ltoptions.m4 ecl-16.1.3+ds/src/bdwgc/m4/ltoptions.m4 --- ecl-16.1.2/src/bdwgc/m4/ltoptions.m4 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/m4/ltoptions.m4 1970-01-01 00:00:00.000000000 +0000 @@ -1,437 +0,0 @@ -# Helper functions for option handling. -*- Autoconf -*- -# -# Copyright (C) 2004-2005, 2007-2009, 2011-2015 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 8 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_UNLESS_OPTIONS([LT_INIT], [aix-soname=aix aix-soname=both aix-soname=svr4], - [_LT_WITH_AIX_SONAME([aix])]) - ]) -])# _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], [1], [Assembler program])dnl - -test -z "$DLLTOOL" && DLLTOOL=dlltool -_LT_DECL([], [DLLTOOL], [1], [DLL creation program])dnl - -test -z "$OBJDUMP" && OBJDUMP=objdump -_LT_DECL([], [OBJDUMP], [1], [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_AIX_SONAME([DEFAULT]) -# ---------------------------------- -# implement the --with-aix-soname flag, and support the `aix-soname=aix' -# and `aix-soname=both' and `aix-soname=svr4' LT_INIT options. DEFAULT -# is either `aix', `both' or `svr4'. If omitted, it defaults to `aix'. -m4_define([_LT_WITH_AIX_SONAME], -[m4_define([_LT_WITH_AIX_SONAME_DEFAULT], [m4_if($1, svr4, svr4, m4_if($1, both, both, aix))])dnl -shared_archive_member_spec= -case $host,$enable_shared in -power*-*-aix[[5-9]]*,yes) - AC_MSG_CHECKING([which variant of shared library versioning to provide]) - AC_ARG_WITH([aix-soname], - [AS_HELP_STRING([--with-aix-soname=aix|svr4|both], - [shared library versioning (aka "SONAME") variant to provide on AIX, @<:@default=]_LT_WITH_AIX_SONAME_DEFAULT[@:>@.])], - [case $withval in - aix|svr4|both) - ;; - *) - AC_MSG_ERROR([Unknown argument to --with-aix-soname]) - ;; - esac - lt_cv_with_aix_soname=$with_aix_soname], - [AC_CACHE_VAL([lt_cv_with_aix_soname], - [lt_cv_with_aix_soname=]_LT_WITH_AIX_SONAME_DEFAULT) - with_aix_soname=$lt_cv_with_aix_soname]) - AC_MSG_RESULT([$with_aix_soname]) - if test aix != "$with_aix_soname"; then - # For the AIX way of multilib, we name the shared archive member - # based on the bitwidth used, traditionally 'shr.o' or 'shr_64.o', - # and 'shr.imp' or 'shr_64.imp', respectively, for the Import File. - # Even when GNU compilers ignore OBJECT_MODE but need '-maix64' flag, - # the AIX toolchain works better with OBJECT_MODE set (default 32). - if test 64 = "${OBJECT_MODE-32}"; then - shared_archive_member_spec=shr_64 - else - shared_archive_member_spec=shr - fi - fi - ;; -*) - with_aix_soname=aix - ;; -esac - -_LT_DECL([], [shared_archive_member_spec], [0], - [Shared archive member basename, for filename based shared library versioning on AIX])dnl -])# _LT_WITH_AIX_SONAME - -LT_OPTION_DEFINE([LT_INIT], [aix-soname=aix], [_LT_WITH_AIX_SONAME([aix])]) -LT_OPTION_DEFINE([LT_INIT], [aix-soname=both], [_LT_WITH_AIX_SONAME([both])]) -LT_OPTION_DEFINE([LT_INIT], [aix-soname=svr4], [_LT_WITH_AIX_SONAME([svr4])]) - - -# _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@<:@=PKGS@:>@], - [try to use only PIC/non-PIC objects @<:@default=use both@:>@])], - [lt_p=${PACKAGE-default} - case $withval in - yes|no) pic_mode=$withval ;; - *) - pic_mode=default - # Look at the argument we got. We use all the common list separators. - lt_save_ifs=$IFS; IFS=$IFS$PATH_SEPARATOR, - for lt_pkg in $withval; do - IFS=$lt_save_ifs - if test "X$lt_pkg" = "X$lt_p"; then - pic_mode=yes - fi - done - IFS=$lt_save_ifs - ;; - esac], - [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])]) diff -Nru ecl-16.1.2/src/bdwgc/m4/ltsugar.m4 ecl-16.1.3+ds/src/bdwgc/m4/ltsugar.m4 --- ecl-16.1.2/src/bdwgc/m4/ltsugar.m4 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/m4/ltsugar.m4 1970-01-01 00:00:00.000000000 +0000 @@ -1,124 +0,0 @@ -# ltsugar.m4 -- libtool m4 base layer. -*-Autoconf-*- -# -# Copyright (C) 2004-2005, 2007-2008, 2011-2015 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 -]) diff -Nru ecl-16.1.2/src/bdwgc/m4/ltversion.m4 ecl-16.1.3+ds/src/bdwgc/m4/ltversion.m4 --- ecl-16.1.2/src/bdwgc/m4/ltversion.m4 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/m4/ltversion.m4 1970-01-01 00:00:00.000000000 +0000 @@ -1,23 +0,0 @@ -# ltversion.m4 -- version numbers -*- Autoconf -*- -# -# Copyright (C) 2004, 2011-2015 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. - -# @configure_input@ - -# serial 4179 ltversion.m4 -# This file is part of GNU Libtool - -m4_define([LT_PACKAGE_VERSION], [2.4.6]) -m4_define([LT_PACKAGE_REVISION], [2.4.6]) - -AC_DEFUN([LTVERSION_VERSION], -[macro_version='2.4.6' -macro_revision='2.4.6' -_LT_DECL(, macro_version, 0, [Which release of libtool.m4 was used?]) -_LT_DECL(, macro_revision, 0) -]) diff -Nru ecl-16.1.2/src/bdwgc/mach_dep.c ecl-16.1.3+ds/src/bdwgc/mach_dep.c --- ecl-16.1.2/src/bdwgc/mach_dep.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/mach_dep.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,318 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#include "private/gc_priv.h" - -#include - -#ifdef AMIGA -# ifndef __GNUC__ -# include -# else -# include -# endif -#endif - -#if defined(MACOS) && defined(__MWERKS__) - -#if defined(POWERPC) - -# define NONVOLATILE_GPR_COUNT 19 - struct ppc_registers { - unsigned long gprs[NONVOLATILE_GPR_COUNT]; /* R13-R31 */ - }; - typedef struct ppc_registers ppc_registers; - - asm static void getRegisters(register ppc_registers* regs) - { - stmw r13,regs->gprs /* save R13-R31 */ - blr - } - - static void PushMacRegisters(void) - { - ppc_registers regs; - int i; - getRegisters(®s); - for (i = 0; i < NONVOLATILE_GPR_COUNT; i++) - GC_push_one(regs.gprs[i]); - } - -#else /* M68K */ - - asm static void PushMacRegisters(void) - { - sub.w #4,sp /* reserve space for one parameter */ - move.l a2,(sp) - jsr GC_push_one - move.l a3,(sp) - jsr GC_push_one - move.l a4,(sp) - jsr GC_push_one -# if !__option(a6frames) - /* perhaps a6 should be pushed if stack frames are not being used */ - move.l a6,(sp) - jsr GC_push_one -# endif - /* skip a5 (globals), a6 (frame pointer), and a7 (stack pointer) */ - move.l d2,(sp) - jsr GC_push_one - move.l d3,(sp) - jsr GC_push_one - move.l d4,(sp) - jsr GC_push_one - move.l d5,(sp) - jsr GC_push_one - move.l d6,(sp) - jsr GC_push_one - move.l d7,(sp) - jsr GC_push_one - add.w #4,sp /* fix stack */ - rts - } - -#endif /* M68K */ - -#endif /* MACOS && __MWERKS__ */ - -# if defined(SPARC) || defined(IA64) - /* Value returned from register flushing routine; either sp (SPARC) */ - /* or ar.bsp (IA64). */ - GC_INNER ptr_t GC_save_regs_ret_val = NULL; -# endif - -/* Routine to mark from registers that are preserved by the C compiler. */ -/* This must be ported to every new architecture. It is not optional, */ -/* and should not be used on platforms that are either UNIX-like, or */ -/* require thread support. */ - -#undef HAVE_PUSH_REGS - -#if defined(USE_ASM_PUSH_REGS) -# define HAVE_PUSH_REGS -#else /* No asm implementation */ - -# ifdef STACK_NOT_SCANNED - void GC_push_regs(void) - { - /* empty */ - } -# define HAVE_PUSH_REGS - -# elif defined(M68K) && defined(AMIGA) - /* This function is not static because it could also be */ - /* erroneously defined in .S file, so this error would be caught */ - /* by the linker. */ - void GC_push_regs(void) - { - /* AMIGA - could be replaced by generic code */ - /* a0, a1, d0 and d1 are caller save */ - -# ifdef __GNUC__ - asm("subq.w &0x4,%sp"); /* allocate word on top of stack */ - - asm("mov.l %a2,(%sp)"); asm("jsr _GC_push_one"); - asm("mov.l %a3,(%sp)"); asm("jsr _GC_push_one"); - asm("mov.l %a4,(%sp)"); asm("jsr _GC_push_one"); - asm("mov.l %a5,(%sp)"); asm("jsr _GC_push_one"); - asm("mov.l %a6,(%sp)"); asm("jsr _GC_push_one"); - /* Skip frame pointer and stack pointer */ - asm("mov.l %d2,(%sp)"); asm("jsr _GC_push_one"); - asm("mov.l %d3,(%sp)"); asm("jsr _GC_push_one"); - asm("mov.l %d4,(%sp)"); asm("jsr _GC_push_one"); - asm("mov.l %d5,(%sp)"); asm("jsr _GC_push_one"); - asm("mov.l %d6,(%sp)"); asm("jsr _GC_push_one"); - asm("mov.l %d7,(%sp)"); asm("jsr _GC_push_one"); - - asm("addq.w &0x4,%sp"); /* put stack back where it was */ -# else /* !__GNUC__ */ - GC_push_one(getreg(REG_A2)); - GC_push_one(getreg(REG_A3)); -# ifndef __SASC - /* Can probably be changed to #if 0 -Kjetil M. (a4=globals) */ - GC_push_one(getreg(REG_A4)); -# endif - GC_push_one(getreg(REG_A5)); - GC_push_one(getreg(REG_A6)); - /* Skip stack pointer */ - GC_push_one(getreg(REG_D2)); - GC_push_one(getreg(REG_D3)); - GC_push_one(getreg(REG_D4)); - GC_push_one(getreg(REG_D5)); - GC_push_one(getreg(REG_D6)); - GC_push_one(getreg(REG_D7)); -# endif /* !__GNUC__ */ - } -# define HAVE_PUSH_REGS - -# elif defined(MACOS) - -# if defined(M68K) && defined(THINK_C) -# define PushMacReg(reg) \ - move.l reg,(sp) \ - jsr GC_push_one - void GC_push_regs(void) - { - asm { - sub.w #4,sp ; reserve space for one parameter. - PushMacReg(a2); - PushMacReg(a3); - PushMacReg(a4); - ; skip a5 (globals), a6 (frame pointer), and a7 (stack pointer) - PushMacReg(d2); - PushMacReg(d3); - PushMacReg(d4); - PushMacReg(d5); - PushMacReg(d6); - PushMacReg(d7); - add.w #4,sp ; fix stack. - } - } -# define HAVE_PUSH_REGS -# undef PushMacReg -# elif defined(__MWERKS__) - void GC_push_regs(void) - { - PushMacRegisters(); - } -# define HAVE_PUSH_REGS -# endif /* __MWERKS__ */ -# endif /* MACOS */ - -#endif /* !USE_ASM_PUSH_REGS */ - -#if defined(HAVE_PUSH_REGS) && defined(THREADS) -# error GC_push_regs cannot be used with threads - /* Would fail for GC_do_blocking. There are probably other safety */ - /* issues. */ -# undef HAVE_PUSH_REGS -#endif - -#if !defined(HAVE_PUSH_REGS) && defined(UNIX_LIKE) -# include -# ifndef NO_GETCONTEXT -# if defined(DARWIN) \ - && (MAC_OS_X_VERSION_MAX_ALLOWED >= 1060 /*MAC_OS_X_VERSION_10_6*/) -# include -# else -# include -# endif /* !DARWIN */ -# ifdef GETCONTEXT_FPU_EXCMASK_BUG -# include -# endif -# endif -#endif /* !HAVE_PUSH_REGS */ - -/* Ensure that either registers are pushed, or callee-save registers */ -/* are somewhere on the stack, and then call fn(arg, ctxt). */ -/* ctxt is either a pointer to a ucontext_t we generated, or NULL. */ -GC_INNER void GC_with_callee_saves_pushed(void (*fn)(ptr_t, void *), - ptr_t arg) -{ - volatile int dummy; - void * context = 0; - -# if defined(HAVE_PUSH_REGS) - GC_push_regs(); -# elif defined(UNIX_LIKE) && !defined(NO_GETCONTEXT) - /* Older versions of Darwin seem to lack getcontext(). */ - /* ARM and MIPS Linux often doesn't support a real */ - /* getcontext(). */ - ucontext_t ctxt; -# ifdef GETCONTEXT_FPU_EXCMASK_BUG - /* Workaround a bug (clearing the FPU exception mask) in */ - /* getcontext on Linux/x86_64. */ -# ifdef X86_64 - /* We manipulate FPU control word here just not to force the */ - /* client application to use -lm linker option. */ - unsigned short old_fcw; - __asm__ __volatile__ ("fstcw %0" : "=m" (*&old_fcw)); -# else - int except_mask = fegetexcept(); -# endif -# endif - if (getcontext(&ctxt) < 0) - ABORT ("getcontext failed: Use another register retrieval method?"); -# ifdef GETCONTEXT_FPU_EXCMASK_BUG -# ifdef X86_64 - __asm__ __volatile__ ("fldcw %0" : : "m" (*&old_fcw)); - { - unsigned mxcsr; - /* And now correct the exception mask in SSE MXCSR. */ - __asm__ __volatile__ ("stmxcsr %0" : "=m" (*&mxcsr)); - mxcsr = (mxcsr & ~(FE_ALL_EXCEPT << 7)) | - ((old_fcw & FE_ALL_EXCEPT) << 7); - __asm__ __volatile__ ("ldmxcsr %0" : : "m" (*&mxcsr)); - } -# else /* !X86_64 */ - if (feenableexcept(except_mask) < 0) - ABORT("feenableexcept failed"); -# endif -# endif - context = &ctxt; -# if defined(SPARC) || defined(IA64) - /* On a register window machine, we need to save register */ - /* contents on the stack for this to work. This may already be */ - /* subsumed by the getcontext() call. */ - GC_save_regs_ret_val = GC_save_regs_in_stack(); -# endif /* register windows. */ -# elif defined(HAVE_BUILTIN_UNWIND_INIT) - /* This was suggested by Richard Henderson as the way to */ - /* force callee-save registers and register windows onto */ - /* the stack. */ - __builtin_unwind_init(); -# else /* !HAVE_BUILTIN_UNWIND_INIT && !UNIX_LIKE */ - /* && !HAVE_PUSH_REGS */ - /* Generic code */ - /* The idea is due to Parag Patel at HP. */ - /* We're not sure whether he would like */ - /* to be acknowledged for it or not. */ - jmp_buf regs; - register word * i = (word *) regs; - register ptr_t lim = (ptr_t)(regs) + (sizeof regs); - - /* Setjmp doesn't always clear all of the buffer. */ - /* That tends to preserve garbage. Clear it. */ - for (; (word)i < (word)lim; i++) { - *i = 0; - } -# if defined(MSWIN32) || defined(MSWINCE) || defined(UTS4) \ - || defined(OS2) || defined(CX_UX) || defined(__CC_ARM) \ - || defined(LINUX) || defined(EWS4800) || defined(RTEMS) - (void) setjmp(regs); -# else - (void) _setjmp(regs); - /* We don't want to mess with signals. According to */ - /* SUSV3, setjmp() may or may not save signal mask. */ - /* _setjmp won't, but is less portable. */ -# endif -# endif /* !HAVE_PUSH_REGS ... */ - /* FIXME: context here is sometimes just zero. At the moment the */ - /* callees don't really need it. */ - fn(arg, context); - /* Strongly discourage the compiler from treating the above */ - /* as a tail-call, since that would pop the register */ - /* contents before we get a chance to look at them. */ - GC_noop1((word)(&dummy)); -} - -#if defined(ASM_CLEAR_CODE) -# ifdef LINT - ptr_t GC_clear_stack_inner(ptr_t arg, word limit) - { - return limit ? arg : 0; /* use both arguments */ - } - /* The real version is in a .S file */ -# endif -#endif /* ASM_CLEAR_CODE */ diff -Nru ecl-16.1.2/src/bdwgc/Makefile.am ecl-16.1.3+ds/src/bdwgc/Makefile.am --- ecl-16.1.2/src/bdwgc/Makefile.am 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/Makefile.am 1970-01-01 00:00:00.000000000 +0000 @@ -1,201 +0,0 @@ -# Copyright (c) 1999-2001 by Red Hat, Inc. All rights reserved. -# -# THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED -# OR IMPLIED. ANY USE IS AT YOUR OWN RISK. -# -# Permission is hereby granted to use or copy this program -# for any purpose, provided the above notices are retained on all copies. -# Permission to modify the code and to distribute modified code is granted, -# provided the above notices are retained, and a notice that the code was -# modified is included with the above copyright notice. - -## Process this file with automake to produce Makefile.in. - -## FIXME: `make distcheck' in this directory will not currently work. -## This is most likely to the explicit flags passed to submakes. - -# We currently use the source files directly from libatomic_ops, if we -# use the internal version. This is done since libatomic_ops doesn't -# use libtool, since it has no real use for it. But that seems to make -# it hard to use either the resulting object files or libraries. -# Thus there seems too be no real reason to recursively build in the -# libatomic_ops directory. -# if USE_INTERNAL_LIBATOMICS_OPS -# SUBDIRS = @maybe_libatomic_ops@ -# else -# SUBDIRS = -# endif -SUBDIRS = - -ACLOCAL_AMFLAGS = -I m4 -AM_CPPFLAGS = \ - -I$(top_builddir)/include -I$(top_srcdir)/include \ - $(ATOMIC_OPS_CFLAGS) - -# Initialize variables so that we can declare files locally. -EXTRA_DIST = -lib_LTLIBRARIES = -include_HEADERS = -pkginclude_HEADERS = -dist_noinst_HEADERS = -check_PROGRAMS = -check_LTLIBRARIES = -TESTS = - -pkgconfigdir = $(libdir)/pkgconfig -pkgconfig_DATA = bdw-gc.pc - -# C Library -# --------- - -lib_LTLIBRARIES += libgc.la -if SINGLE_GC_OBJ -libgc_la_SOURCES = extra/gc.c -else -EXTRA_DIST += extra/gc.c -libgc_la_SOURCES = \ - allchblk.c alloc.c blacklst.c checksums.c dbg_mlc.c \ - dyn_load.c finalize.c gc_dlopen.c gcj_mlc.c headers.c \ - mach_dep.c malloc.c mallocx.c mark.c mark_rts.c misc.c new_hblk.c \ - obj_map.c os_dep.c pcr_interface.c ptr_chck.c real_malloc.c reclaim.c \ - specific.c stubborn.c thread_local_alloc.c typd_mlc.c - -# C Library: Architecture Dependent -# --------------------------------- - -if WIN32_THREADS -libgc_la_SOURCES += win32_threads.c -else -if PTHREADS -libgc_la_SOURCES += pthread_start.c pthread_support.c -if DARWIN_THREADS -libgc_la_SOURCES += darwin_stop_world.c -else -libgc_la_SOURCES += pthread_stop_world.c -endif -endif -endif - -if MAKE_BACK_GRAPH -libgc_la_SOURCES += backgraph.c -endif - -if ENABLE_DISCLAIM -libgc_la_SOURCES += fnlz_mlc.c -endif - -endif - -if USE_INTERNAL_LIBATOMIC_OPS -nodist_libgc_la_SOURCES = libatomic_ops/src/atomic_ops.c -endif - -if NEED_ATOMIC_OPS_ASM -nodist_libgc_la_SOURCES = libatomic_ops/src/atomic_ops_sysdeps.S -endif - -# Include THREADDLLIBS here to ensure that the correct versions of -# linuxthread semaphore functions get linked: -libgc_la_LIBADD = @addobjs@ $(THREADDLLIBS) $(UNWINDLIBS) $(ATOMIC_OPS_LIBS) -libgc_la_DEPENDENCIES = @addobjs@ -libgc_la_LDFLAGS = $(extra_ldflags_libgc) -version-info 1:3:0 -no-undefined - -EXTRA_libgc_la_SOURCES = ia64_save_regs_in_stack.s sparc_mach_dep.S \ - sparc_netbsd_mach_dep.s sparc_sunos4_mach_dep.s - - -# C++ Interface -# ------------- - -if CPLUSPLUS -lib_LTLIBRARIES += libgccpp.la -pkginclude_HEADERS += include/gc_cpp.h -include_HEADERS += include/extra/gc_cpp.h -libgccpp_la_SOURCES = gc_cpp.cc -libgccpp_la_LIBADD = ./libgc.la -libgccpp_la_LDFLAGS = -version-info 1:3:0 -no-undefined -endif - -# FIXME: If Visual C++ users use Makefile.am, this should go into -# pkginclude_HEADERS with proper AM_CONDITIONALization. Otherwise -# delete this comment. -EXTRA_DIST += gc_cpp.cpp - - -# Misc -# ---- - -AM_CXXFLAGS = @GC_CFLAGS@ -AM_CFLAGS = @GC_CFLAGS@ - -## FIXME: relies on internal code generated by automake. -## FIXME: ./configure --enable-dependency-tracking should be used -#all_objs = @addobjs@ $(libgc_la_OBJECTS) -#$(all_objs) : include/private/gcconfig.h include/private/gc_priv.h \ -#include/private/gc_hdrs.h include/gc.h include/gc_gcj.h \ -#include/gc_pthread_redirects.h include/gc_config_macros.h \ -#include/private/thread_local_alloc.h include/private_support.h \ -#include/private/pthread_stop_world.h \ -#include/gc_mark.h @addincludes@ - -## FIXME: we shouldn't have to do this, but automake forces us to. -## We use -Wp,-P to strip #line directives. Irix `as' chokes on -## these. -if ASM_WITH_CPP_UNSUPPORTED - ASM_CPP_OPTIONS = -else - ASM_CPP_OPTIONS = -Wp,-P -x assembler-with-cpp -endif - -.s.lo: - $(LTCOMPILE) $(ASM_CPP_OPTIONS) -c $< - -.S.lo: - $(LTCOMPILE) $(ASM_CPP_OPTIONS) -c $< - -## We need to add DEFS to assembler flags -## :FIXME: what if assembler does not accept -D... ? -## (use Autoconf to prepare ASDEFS?) - -CCASFLAGS += $(DEFS) - -# headers which are not installed -# (see include/include.am for more) -# - -# documentation which is not installed -# -EXTRA_DIST += README.QUICK TODO - -# other makefiles -# :GOTCHA: deliberately we do not include 'Makefile' -EXTRA_DIST += BCC_MAKEFILE NT_MAKEFILE \ - OS2_MAKEFILE PCR-Makefile digimars.mak EMX_MAKEFILE \ - Makefile.direct SMakefile.amiga WCC_MAKEFILE autogen.sh \ - NT_STATIC_THREADS_MAKEFILE NT_X64_STATIC_THREADS_MAKEFILE \ - NT_X64_THREADS_MAKEFILE CMakeLists.txt tests/CMakeLists.txt - -# files used by makefiles other than Makefile.am -# -EXTRA_DIST += tools/add_gc_prefix.c tools/gcname.c tools/if_mach.c \ - tools/if_not_there.c tools/setjmp_t.c tools/threadlibs.c \ - gc.mak extra/MacOS.c extra/AmigaOS.c \ - extra/symbian/global_end.cpp extra/symbian/global_start.cpp \ - extra/symbian/init_global_static_roots.cpp extra/symbian.cpp \ - build/s60v3/bld.inf build/s60v3/libgc.mmp \ - extra/Mac_files/datastart.c extra/Mac_files/dataend.c \ - extra/Mac_files/MacOS_config.h \ - include/private/msvc_dbg.h extra/msvc_dbg.c tools/callprocs.sh - -# -# :GOTCHA: GNU make rule for making .s out of .S is flawed, -# it will not remove dest if building fails -.S.s: - if $(CPP) $< >$@ ; then :; else rm -f $@; fi - -include include/include.am -include cord/cord.am -include tests/tests.am -include doc/doc.am -# Putting these at the top causes cord to be built first, and not find libgc.a -# on HP/UX. There may be a better fix. diff -Nru ecl-16.1.2/src/bdwgc/Makefile.direct ecl-16.1.3+ds/src/bdwgc/Makefile.direct --- ecl-16.1.2/src/bdwgc/Makefile.direct 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/Makefile.direct 1970-01-01 00:00:00.000000000 +0000 @@ -1,454 +0,0 @@ -# This is the original manually generated Makefile. It may still be used -# to build the collector. -# -# Primary targets: -# gc.a - builds basic library -# c++ - adds C++ interface to library -# cords - adds cords (heavyweight strings) to library -# test - prints porting information, then builds basic version of gc.a, -# and runs some tests of collector and cords. Does not add cords or -# c++ interface to gc.a -# cord/de - builds dumb editor based on cords. - -ABI_FLAG= -# ABI_FLAG should be the cc flag that specifies the ABI. On most -# platforms this will be the empty string. Possible values: -# +DD64 for 64-bit executable on HP/UX. -# -n32, -n64, -o32 for SGI/MIPS ABIs. - -AS_ABI_FLAG=$(ABI_FLAG) -# ABI flag for assembler. On HP/UX this is +A64 for 64 bit -# executables. - -CC=cc $(ABI_FLAG) -CXX=g++ $(ABI_FLAG) -AS=as $(AS_ABI_FLAG) -# The above doesn't work with gas, which doesn't run cpp. -# Define AS as `gcc -c -x assembler-with-cpp' instead. - -# Redefining srcdir allows object code for the nonPCR version of the collector -# to be generated in different directories. -srcdir= . -VPATH= $(srcdir) - -# Path to atomic_ops source. -AO_SRC_DIR=$(srcdir)/libatomic_ops - -CFLAGS_EXTRA= -CFLAGS= -O -I$(srcdir)/include -I$(AO_SRC_DIR)/src \ - -DATOMIC_UNCOLLECTABLE -DNO_EXECUTE_PERMISSION -DALL_INTERIOR_POINTERS \ - $(CFLAGS_EXTRA) - -# To build the parallel collector on Linux, add to the above: -# -DGC_LINUX_THREADS -DPARALLEL_MARK -DTHREAD_LOCAL_ALLOC -# To build the thread-capable preload library that intercepts -# malloc, add -DGC_USE_DLOPEN_WRAP -DREDIRECT_MALLOC=GC_malloc -fpic -# To build the parallel collector in a static library on HP/UX, -# add to the above: -# -DGC_HPUX_THREADS -DTHREAD_LOCAL_ALLOC -D_POSIX_C_SOURCE=199506L -mt -# FIXME: PARALLEL_MARK currently broken on HP/UX. -# To build the thread-safe collector on Tru64, add to the above: -# -pthread -DGC_OSF1_THREADS - -# HOSTCC and HOSTCFLAGS are used to build executables that will be run as -# part of the build process, i.e. on the build machine. These will usually -# be the same as CC and CFLAGS, except in a cross-compilation environment. -# Note that HOSTCFLAGS should include any -D flags that affect thread support. -HOSTCC=$(CC) -HOSTCFLAGS=$(CFLAGS) - -# For dynamic library builds, it may be necessary to add flags to generate -# PIC code, e.g. -fPIC on Linux. - -# Setjmp_test may yield overly optimistic results when compiled -# without optimization. - -# Look into doc/README.macros for the description of the "define arguments" -# influencing the collector configuration. - -CXXFLAGS= $(CFLAGS) -AR= ar -RANLIB= ranlib - - -OBJS= alloc.o reclaim.o allchblk.o misc.o mach_dep.o os_dep.o mark_rts.o \ - headers.o mark.o obj_map.o blacklst.o finalize.o new_hblk.o dbg_mlc.o \ - malloc.o stubborn.o checksums.o pthread_support.o pthread_stop_world.o \ - darwin_stop_world.o typd_mlc.o ptr_chck.o mallocx.o gcj_mlc.o specific.o \ - gc_dlopen.o backgraph.o win32_threads.o pthread_start.o \ - thread_local_alloc.o fnlz_mlc.o atomic_ops.o atomic_ops_sysdeps.o - -CSRCS= reclaim.c allchblk.c misc.c alloc.c mach_dep.c os_dep.c mark_rts.c \ - headers.c mark.c obj_map.c pcr_interface.c blacklst.c finalize.c \ - new_hblk.c real_malloc.c dyn_load.c dbg_mlc.c malloc.c stubborn.c \ - checksums.c pthread_support.c pthread_stop_world.c darwin_stop_world.c \ - typd_mlc.c ptr_chck.c mallocx.c gcj_mlc.c specific.c gc_dlopen.c \ - backgraph.c win32_threads.c pthread_start.c thread_local_alloc.c fnlz_mlc.c - -CORD_SRCS= cord/cordbscs.c cord/cordxtra.c cord/cordprnt.c cord/tests/de.c \ - cord/tests/cordtest.c include/cord.h include/ec.h \ - include/cord_pos.h cord/tests/de_win.c cord/tests/de_win.h \ - cord/tests/de_cmds.h cord/tests/de_win.rc - -CORD_OBJS= cord/cordbscs.o cord/cordxtra.o cord/cordprnt.o - -SRCS= $(CSRCS) \ - include/gc.h include/gc_typed.h include/gc_tiny_fl.h \ - include/gc_version.h include/private/gc_hdrs.h include/private/gc_priv.h \ - include/private/gcconfig.h include/private/gc_pmark.h \ - include/gc_inline.h include/gc_mark.h include/gc_disclaim.h \ - tools/threadlibs.c \ - tools/if_mach.c tools/if_not_there.c gc_cpp.cc include/gc_cpp.h \ - tools/gcname.c include/weakpointer.h include/private/gc_locks.h \ - include/new_gc_alloc.h include/gc_allocator.h \ - include/javaxfc.h \ - include/gc_backptr.h include/gc_gcj.h include/private/dbg_mlc.h \ - include/private/specific.h include/leak_detector.h \ - include/gc_pthread_redirects.h \ - include/gc_config_macros.h include/private/pthread_support.h \ - include/private/pthread_stop_world.h include/private/darwin_semaphore.h \ - include/private/darwin_stop_world.h include/private/thread_local_alloc.h \ - ia64_save_regs_in_stack.s sparc_mach_dep.S \ - sparc_netbsd_mach_dep.s sparc_sunos4_mach_dep.s $(CORD_SRCS) - -DOC_FILES= README.QUICK TODO doc/README.Mac doc/README.OS2 \ - doc/README.amiga doc/README.cords doc/debugging.html \ - doc/finalization.html doc/porting.html doc/overview.html \ - doc/README.hp doc/README.linux doc/README.rs6000 \ - doc/README.sgi doc/README.solaris2 doc/README.uts \ - doc/README.symbian doc/README.win32 README.md AUTHORS doc/gc.man \ - doc/README.environment doc/tree.html doc/gcdescr.html \ - doc/README.autoconf doc/README.macros doc/README.ews4800 \ - doc/README.DGUX386 doc/README.arm.cross doc/leak.html \ - doc/scale.html doc/gcinterface.html doc/README.darwin \ - doc/simple_example.html doc/README.win64 - -TESTS= tests/test.c tests/test_cpp.cc tests/trace_test.c \ - tests/leak_test.c tests/thread_leak_test.c tests/middle.c \ - tests/smash_test.c tests/huge_test.c - -GNU_BUILD_FILES= configure.ac Makefile.am configure install-sh Makefile.in \ - aclocal.m4 config.sub config.guess \ - include/include.am doc/doc.am \ - ltmain.sh mkinstalldirs depcomp missing \ - cord/cord.am tests/tests.am autogen.sh \ - bdw-gc.pc.in compile - -OTHER_MAKEFILES= OS2_MAKEFILE NT_MAKEFILE gc.mak \ - BCC_MAKEFILE EMX_MAKEFILE WCC_MAKEFILE PCR-Makefile SMakefile.amiga \ - digimars.mak Makefile.direct NT_STATIC_THREADS_MAKEFILE \ - NT_X64_STATIC_THREADS_MAKEFILE NT_X64_THREADS_MAKEFILE - -OTHER_FILES= tools/setjmp_t.c tools/callprocs.sh extra/MacOS.c \ - extra/Mac_files/datastart.c extra/Mac_files/dataend.c \ - extra/Mac_files/MacOS_config.h tools/add_gc_prefix.c gc_cpp.cpp \ - extra/symbian/global_end.cpp extra/symbian/global_start.cpp \ - extra/symbian/init_global_static_roots.cpp extra/symbian.cpp \ - build/s60v3/bld.inf build/s60v3/libgc.mmp \ - extra/AmigaOS.c extra/msvc_dbg.c include/private/msvc_dbg.h \ - $(TESTS) $(GNU_BUILD_FILES) $(OTHER_MAKEFILES) - -CORD_INCLUDE_FILES= $(srcdir)/include/gc.h $(srcdir)/include/cord.h \ - $(srcdir)/include/ec.h $(srcdir)/include/cord_pos.h - -UTILS= if_mach if_not_there threadlibs - -# Libraries needed for curses applications. Only needed for de. -CURSES= -lcurses -ltermlib - -# The following is irrelevant on most systems. But a few -# versions of make otherwise fork the shell specified in -# the SHELL environment variable. -SHELL= /bin/sh - -SPECIALCFLAGS = -I$(srcdir)/include -I$(AO_SRC_DIR)/src -# Alternative flags to the C compiler for mach_dep.c. -# Mach_dep.c often doesn't like optimization, and it's -# not time-critical anyway. -# Set SPECIALCFLAGS to -q nodirect_code on Encore. - -all: gc.a gctest - -atomic_ops.o: $(AO_SRC_DIR)/src/atomic_ops.c - $(CC) $(CFLAGS) -c -o $@ $< - -atomic_ops_sysdeps.o: $(AO_SRC_DIR)/src/atomic_ops_sysdeps.S - $(CC) $(CFLAGS) -c -o $@ $< - -LEAKFLAGS=$(CFLAGS) -DFIND_LEAK - -BSD-pkg-all: bsd-libgc.a bsd-libleak.a - -bsd-libgc.a: - $(MAKE) CFLAGS="$(CFLAGS)" clean c++-t - mv gc.a bsd-libgc.a - -bsd-libleak.a: - $(MAKE) -f Makefile.direct CFLAGS="$(LEAKFLAGS)" clean c++-nt - mv gc.a bsd-libleak.a - -BSD-pkg-install: BSD-pkg-all - ${CP} bsd-libgc.a libgc.a - ${INSTALL_DATA} libgc.a ${PREFIX}/lib - ${INSTALL_DATA} gc.h gc_cpp.h ${PREFIX}/include - ${INSTALL_MAN} doc/gc.man ${PREFIX}/man/man3/gc.3 - -pcr: PCR-Makefile include/private/gc_private.h include/private/gc_hdrs.h \ -include/private/gc_locks.h include/gc.h include/private/gcconfig.h \ -mach_dep.o $(SRCS) - $(MAKE) -f PCR-Makefile depend - $(MAKE) -f PCR-Makefile - -$(OBJS) tests/test.o dyn_load.o dyn_load_sunos53.o: \ - $(srcdir)/include/private/gc_priv.h \ - $(srcdir)/include/private/gc_hdrs.h $(srcdir)/include/private/gc_locks.h \ - $(srcdir)/include/gc.h $(srcdir)/include/gc_pthread_redirects.h \ - $(srcdir)/include/private/gcconfig.h $(srcdir)/include/gc_typed.h \ - $(srcdir)/include/gc_config_macros.h - -mark.o typd_mlc.o finalize.o ptr_chck.o: $(srcdir)/include/gc_mark.h \ - $(srcdir)/include/private/gc_pmark.h - -specific.o pthread_support.o thread_local_alloc.o win32_threads.o: \ - $(srcdir)/include/private/specific.h $(srcdir)/include/gc_inline.h \ - $(srcdir)/include/private/thread_local_alloc.h - -dbg_mlc.o gcj_mlc.o: $(srcdir)/include/private/dbg_mlc.h - -tests/test.o: tests $(srcdir)/tests/test.c - $(CC) $(CFLAGS) -c $(srcdir)/tests/test.c - mv test.o tests/test.o - -tests: - mkdir tests - -base_lib gc.a: $(OBJS) dyn_load.o $(UTILS) - echo > base_lib - rm -f dont_ar_1 - ./if_mach SPARC SOLARIS touch dont_ar_1 - ./if_mach SPARC SOLARIS $(AR) rus gc.a $(OBJS) dyn_load.o - ./if_mach M68K AMIGA touch dont_ar_1 - ./if_mach M68K AMIGA $(AR) -vrus gc.a $(OBJS) dyn_load.o - ./if_not_there dont_ar_1 $(AR) ru gc.a $(OBJS) dyn_load.o - ./if_not_there dont_ar_1 $(RANLIB) gc.a || cat /dev/null -# ignore ranlib failure; that usually means it doesn't exist, and isn't needed - -cords: $(CORD_OBJS) cord/cordtest $(UTILS) - rm -f dont_ar_3 - ./if_mach SPARC SOLARIS touch dont_ar_3 - ./if_mach SPARC SOLARIS $(AR) rus gc.a $(CORD_OBJS) - ./if_mach M68K AMIGA touch dont_ar_3 - ./if_mach M68K AMIGA $(AR) -vrus gc.a $(CORD_OBJS) - ./if_not_there dont_ar_3 $(AR) ru gc.a $(CORD_OBJS) - ./if_not_there dont_ar_3 $(RANLIB) gc.a || cat /dev/null - -gc_cpp.o: $(srcdir)/gc_cpp.cc $(srcdir)/include/gc_cpp.h $(srcdir)/include/gc.h - $(CXX) -c $(CXXFLAGS) $(srcdir)/gc_cpp.cc - -test_cpp: $(srcdir)/tests/test_cpp.cc $(srcdir)/include/gc_cpp.h gc_cpp.o $(srcdir)/include/gc.h \ - base_lib $(UTILS) - rm -f test_cpp - ./if_mach HP_PA HPUX $(CXX) $(CXXFLAGS) -o test_cpp $(srcdir)/tests/test_cpp.cc gc_cpp.o gc.a -ldld `./threadlibs` - ./if_not_there test_cpp $(CXX) $(CXXFLAGS) -o test_cpp $(srcdir)/tests/test_cpp.cc gc_cpp.o gc.a `./threadlibs` - -c++-t: c++ - ./test_cpp 1 - -c++-nt: c++ - @echo "Use ./test_cpp 1 to test the leak library" - -c++: gc_cpp.o $(srcdir)/include/gc_cpp.h test_cpp - rm -f dont_ar_4 - ./if_mach SPARC SOLARIS touch dont_ar_4 - ./if_mach SPARC SOLARIS $(AR) rus gc.a gc_cpp.o - ./if_mach M68K AMIGA touch dont_ar_4 - ./if_mach M68K AMIGA $(AR) -vrus gc.a gc_cpp.o - ./if_not_there dont_ar_4 $(AR) ru gc.a gc_cpp.o - ./if_not_there dont_ar_4 $(RANLIB) gc.a || cat /dev/null - ./test_cpp 1 - echo > c++ - -dyn_load_sunos53.o: dyn_load.c - $(CC) $(CFLAGS) -DSUNOS53_SHARED_LIB -c $(srcdir)/dyn_load.c -o $@ - -# SunOS5 shared library version of the collector -sunos5gc.so: $(OBJS) dyn_load_sunos53.o - $(CC) -G -o sunos5gc.so $(OBJS) dyn_load_sunos53.o -ldl - ln sunos5gc.so libgc.so - -# Alpha/OSF shared library version of the collector -libalphagc.so: $(OBJS) - ld -shared -o libalphagc.so $(OBJS) dyn_load.o -lc - ln libalphagc.so libgc.so - -# IRIX shared library version of the collector -libirixgc.so: $(OBJS) dyn_load.o - ld -shared $(ABI_FLAG) -o libirixgc.so $(OBJS) dyn_load.o -lc - ln libirixgc.so libgc.so - -# Linux shared library version of the collector -liblinuxgc.so: $(OBJS) dyn_load.o - gcc -shared -o liblinuxgc.so $(OBJS) dyn_load.o - ln liblinuxgc.so libgc.so - -# Build gctest with dynamic library -dyn_test: - $(CC) $(CFLAGS) -o gctest tests/test.c libgc.so `./threadlibs` - ./gctest - -# Alternative Linux rule. This is preferable, but is likely to break the -# Makefile for some non-linux platforms. -# LIBOBJS= $(patsubst %.o, %.lo, $(OBJS)) -# -#.SUFFIXES: .lo $(SUFFIXES) -# -#.c.lo: -# $(CC) $(CFLAGS) $(CPPFLAGS) -fPIC -c $< -o $@ -# -# liblinuxgc.so: $(LIBOBJS) dyn_load.lo -# gcc -shared -Wl,-soname=libgc.so.0 -o libgc.so.0 $(LIBOBJS) dyn_load.lo -# touch liblinuxgc.so - -mach_dep.o: $(srcdir)/mach_dep.c $(srcdir)/sparc_mach_dep.S \ - $(srcdir)/sparc_sunos4_mach_dep.s \ - $(srcdir)/ia64_save_regs_in_stack.s \ - $(srcdir)/sparc_netbsd_mach_dep.s $(UTILS) - rm -f mach_dep.o - ./if_mach SPARC SOLARIS $(CC) -c -o mach_dep2.o $(srcdir)/sparc_mach_dep.S - ./if_mach SPARC OPENBSD $(AS) -o mach_dep2.o $(srcdir)/sparc_sunos4_mach_dep.s - ./if_mach SPARC NETBSD $(AS) -o mach_dep2.o $(srcdir)/sparc_netbsd_mach_dep.s - ./if_mach SPARC "" $(CC) -c -o mach_dep1.o $(SPECIALCFLAGS) $(srcdir)/mach_dep.c - ./if_mach SPARC "" ld -r -o mach_dep.o mach_dep1.o mach_dep2.o - ./if_mach IA64 "" as $(AS_ABI_FLAG) -o ia64_save_regs_in_stack.o $(srcdir)/ia64_save_regs_in_stack.s - ./if_mach IA64 "" $(CC) -c -o mach_dep1.o $(SPECIALCFLAGS) $(srcdir)/mach_dep.c - ./if_mach IA64 "" ld -r -o mach_dep.o mach_dep1.o ia64_save_regs_in_stack.o - ./if_not_there mach_dep.o $(CC) -c $(SPECIALCFLAGS) $(srcdir)/mach_dep.c - -mark_rts.o: $(srcdir)/mark_rts.c $(UTILS) - rm -f mark_rts.o - -./if_mach ALPHA OSF1 $(CC) -c $(CFLAGS) -Wo,-notail $(srcdir)/mark_rts.c - ./if_not_there mark_rts.o $(CC) -c $(CFLAGS) $(srcdir)/mark_rts.c -# Work-around for DEC optimizer tail recursion elimination bug. -# The ALPHA-specific line should be removed if gcc is used. - -alloc.o: include/gc_version.h - -cord: - mkdir cord - -cord/cordbscs.o: cord $(srcdir)/cord/cordbscs.c $(CORD_INCLUDE_FILES) - $(CC) $(CFLAGS) -c -I$(srcdir) $(srcdir)/cord/cordbscs.c - mv cordbscs.o cord/cordbscs.o -# not all compilers understand -o filename - -cord/cordxtra.o: cord $(srcdir)/cord/cordxtra.c $(CORD_INCLUDE_FILES) - $(CC) $(CFLAGS) -c -I$(srcdir) $(srcdir)/cord/cordxtra.c - mv cordxtra.o cord/cordxtra.o - -cord/cordprnt.o: cord $(srcdir)/cord/cordprnt.c $(CORD_INCLUDE_FILES) - $(CC) $(CFLAGS) -c -I$(srcdir) $(srcdir)/cord/cordprnt.c - mv cordprnt.o cord/cordprnt.o - -cord/cordtest: $(srcdir)/cord/tests/cordtest.c $(CORD_OBJS) gc.a $(UTILS) - rm -f cord/cordtest - ./if_mach SPARC DRSNX $(CC) $(CFLAGS) -o cord/cordtest $(srcdir)/cord/tests/cordtest.c $(CORD_OBJS) gc.a -lucb - ./if_mach HP_PA HPUX $(CC) $(CFLAGS) -o cord/cordtest $(srcdir)/cord/tests/cordtest.c $(CORD_OBJS) gc.a -ldld `./threadlibs` - ./if_mach M68K AMIGA $(CC) $(CFLAGS) -UGC_AMIGA_MAKINGLIB -o cord/cordtest $(srcdir)/cord/tests/cordtest.c $(CORD_OBJS) gc.a `./threadlibs` - ./if_not_there cord/cordtest $(CC) $(CFLAGS) -o cord/cordtest $(srcdir)/cord/tests/cordtest.c $(CORD_OBJS) gc.a `./threadlibs` - -cord/de: $(srcdir)/cord/tests/de.c cord/cordbscs.o cord/cordxtra.o gc.a $(UTILS) - rm -f cord/de - ./if_mach SPARC DRSNX $(CC) $(CFLAGS) -o cord/de $(srcdir)/cord/tests/de.c cord/cordbscs.o cord/cordxtra.o gc.a $(CURSES) -lucb `./threadlibs` - ./if_mach HP_PA HPUX $(CC) $(CFLAGS) -o cord/de $(srcdir)/cord/tests/de.c cord/cordbscs.o cord/cordxtra.o gc.a $(CURSES) -ldld `./threadlibs` - ./if_mach POWERPC AIX $(CC) $(CFLAGS) -o cord/de $(srcdir)/cord/tests/de.c cord/cordbscs.o cord/cordxtra.o gc.a -lcurses - ./if_mach POWERPC DARWIN $(CC) $(CFLAGS) -o cord/de $(srcdir)/cord/tests/de.c cord/cordbscs.o cord/cordxtra.o gc.a - ./if_mach I386 LINUX $(CC) $(CFLAGS) -o cord/de $(srcdir)/cord/tests/de.c cord/cordbscs.o cord/cordxtra.o gc.a -lcurses `./threadlibs` - ./if_mach ALPHA LINUX $(CC) $(CFLAGS) -o cord/de $(srcdir)/cord/tests/de.c cord/cordbscs.o cord/cordxtra.o gc.a -lcurses `./threadlibs` - ./if_mach IA64 LINUX $(CC) $(CFLAGS) -o cord/de $(srcdir)/cord/tests/de.c cord/cordbscs.o cord/cordxtra.o gc.a -lcurses `./threadlibs` - ./if_mach M68K AMIGA $(CC) $(CFLAGS) -UGC_AMIGA_MAKINGLIB -o cord/de $(srcdir)/cord/tests/de.c cord/cordbscs.o cord/cordxtra.o gc.a -lcurses - ./if_not_there cord/de $(CC) $(CFLAGS) -o cord/de $(srcdir)/cord/tests/de.c cord/cordbscs.o cord/cordxtra.o gc.a $(CURSES) `./threadlibs` - -if_mach: $(srcdir)/tools/if_mach.c $(srcdir)/include/private/gcconfig.h - $(HOSTCC) $(HOSTCFLAGS) -o if_mach $(srcdir)/tools/if_mach.c - -threadlibs: $(srcdir)/tools/threadlibs.c $(srcdir)/include/private/gcconfig.h - $(HOSTCC) $(HOSTCFLAGS) -o threadlibs $(srcdir)/tools/threadlibs.c - -if_not_there: $(srcdir)/tools/if_not_there.c - $(HOSTCC) $(HOSTCFLAGS) -o if_not_there $(srcdir)/tools/if_not_there.c - -clean: - rm -f gc.a *.o *.exe tests/*.o gctest gctest_dyn_link test_cpp \ - setjmp_test mon.out gmon.out a.out core if_not_there if_mach \ - base_lib c++ threadlibs $(CORD_OBJS) cord/cordtest cord/de - -rm -f *~ - -gctest: tests/test.o gc.a $(UTILS) - rm -f gctest - ./if_mach SPARC DRSNX $(CC) $(CFLAGS) -o gctest tests/test.o gc.a -lucb - ./if_mach HP_PA HPUX $(CC) $(CFLAGS) -o gctest tests/test.o gc.a -ldld `./threadlibs` - ./if_mach M68K AMIGA $(CC) $(CFLAGS) -UGC_AMIGA_MAKINGLIB -o gctest tests/test.o gc.a `./threadlibs` - ./if_not_there gctest $(CC) $(CFLAGS) -o gctest tests/test.o gc.a `./threadlibs` - -# If an optimized setjmp_test generates a segmentation fault, -# odds are your compiler is broken. Gctest may still work. -# Try compiling setjmp_t.c unoptimized. -setjmp_test: $(srcdir)/tools/setjmp_t.c $(srcdir)/include/gc.h $(UTILS) - $(CC) $(CFLAGS) -o setjmp_test $(srcdir)/tools/setjmp_t.c - -test: KandRtest cord/cordtest - cord/cordtest - -# Those tests that work even with a K&R C compiler: -KandRtest: setjmp_test gctest - ./setjmp_test - ./gctest - -add_gc_prefix: $(srcdir)/tools/add_gc_prefix.c $(srcdir)/include/gc_version.h - $(CC) -o add_gc_prefix $(srcdir)/tools/add_gc_prefix.c - -gcname: $(srcdir)/tools/gcname.c $(srcdir)/include/gc_version.h - $(CC) -o gcname $(srcdir)/tools/gcname.c - -#We assume this is being done from source directory. -dist gc.tar: $(SRCS) $(DOC_FILES) $(OTHER_FILES) add_gc_prefix gcname - rm -f `./gcname` - ln -s . `./gcname` - ./add_gc_prefix $(SRCS) $(DOC_FILES) $(OTHER_FILES) > /tmp/gc.tar-files - tar cvfh gc.tar `cat /tmp/gc.tar-files` - cp gc.tar `./gcname`.tar - gzip `./gcname`.tar - rm `./gcname` - -gc.tar.Z: gc.tar - compress gc.tar - -gc.tar.gz: gc.tar - gzip gc.tar - -lint: $(CSRCS) tests/test.c - lint -DLINT $(CSRCS) tests/test.c | egrep -v "possible pointer alignment problem|abort|exit|sbrk|mprotect|syscall|change in ANSI|improper alignment" - -# BTL: added to test shared library version of collector. -# Currently works only under SunOS5. Requires GC_INIT call from statically -# loaded client code. -ABSDIR = `pwd` -gctest_dyn_link: tests/test.o libgc.so - $(CC) -L$(ABSDIR) -R$(ABSDIR) -o gctest_dyn_link tests/test.o -lgc -ldl -lthread - -gctest_irix_dyn_link: tests/test.o libirixgc.so - $(CC) -L$(ABSDIR) -o gctest_irix_dyn_link tests/test.o -lirixgc - -SYM_PREFIX-libgc=GC - -reserved_namespace: $(SRCS) - for file in $(SRCS) tests/test.c tests/test_cpp.cc; do \ - sed s/GC_/_GC_/g < $$file > tmp; \ - cp tmp $$file; \ - done - -user_namespace: $(SRCS) - for file in $(SRCS) tests/test.c tests/test_cpp.cc; do \ - sed s/_GC_/GC_/g < $$file > tmp; \ - cp tmp $$file; \ - done diff -Nru ecl-16.1.2/src/bdwgc/Makefile.in ecl-16.1.3+ds/src/bdwgc/Makefile.in --- ecl-16.1.2/src/bdwgc/Makefile.in 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/Makefile.in 1970-01-01 00:00:00.000000000 +0000 @@ -1,2440 +0,0 @@ -# Makefile.in generated by automake 1.15 from Makefile.am. -# @configure_input@ - -# Copyright (C) 1994-2014 Free Software Foundation, Inc. - -# This Makefile.in 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. - -@SET_MAKE@ - -# Copyright (c) 1999-2001 by Red Hat, Inc. All rights reserved. -# -# THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED -# OR IMPLIED. ANY USE IS AT YOUR OWN RISK. -# -# Permission is hereby granted to use or copy this program -# for any purpose, provided the above notices are retained on all copies. -# Permission to modify the code and to distribute modified code is granted, -# provided the above notices are retained, and a notice that the code was -# modified is included with the above copyright notice. - -# -# THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED -# OR IMPLIED. ANY USE IS AT YOUR OWN RISK. -# -# Permission is hereby granted to use or copy this program -# for any purpose, provided the above notices are retained on all copies. -# Permission to modify the code and to distribute modified code is granted, -# provided the above notices are retained, and a notice that the code was -# modified is included with the above copyright notice. - -# -# THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED -# OR IMPLIED. ANY USE IS AT YOUR OWN RISK. -# -# Permission is hereby granted to use or copy this program -# for any purpose, provided the above notices are retained on all copies. -# Permission to modify the code and to distribute modified code is granted, -# provided the above notices are retained, and a notice that the code was -# modified is included with the above copyright notice. - -# -# THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED -# OR IMPLIED. ANY USE IS AT YOUR OWN RISK. -# -# Permission is hereby granted to use or copy this program -# for any purpose, provided the above notices are retained on all copies. -# Permission to modify the code and to distribute modified code is granted, -# provided the above notices are retained, and a notice that the code was -# modified is included with the above copyright notice. - - - -VPATH = @srcdir@ -am__is_gnu_make = { \ - if test -z '$(MAKELEVEL)'; then \ - false; \ - elif test -n '$(MAKE_HOST)'; then \ - true; \ - elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ - true; \ - else \ - false; \ - fi; \ -} -am__make_running_with_option = \ - case $${target_option-} in \ - ?) ;; \ - *) echo "am__make_running_with_option: internal error: invalid" \ - "target option '$${target_option-}' specified" >&2; \ - exit 1;; \ - esac; \ - has_opt=no; \ - sane_makeflags=$$MAKEFLAGS; \ - if $(am__is_gnu_make); then \ - sane_makeflags=$$MFLAGS; \ - else \ - case $$MAKEFLAGS in \ - *\\[\ \ ]*) \ - bs=\\; \ - sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ - | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ - esac; \ - fi; \ - skip_next=no; \ - strip_trailopt () \ - { \ - flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ - }; \ - for flg in $$sane_makeflags; do \ - test $$skip_next = yes && { skip_next=no; continue; }; \ - case $$flg in \ - *=*|--*) continue;; \ - -*I) strip_trailopt 'I'; skip_next=yes;; \ - -*I?*) strip_trailopt 'I';; \ - -*O) strip_trailopt 'O'; skip_next=yes;; \ - -*O?*) strip_trailopt 'O';; \ - -*l) strip_trailopt 'l'; skip_next=yes;; \ - -*l?*) strip_trailopt 'l';; \ - -[dEDm]) skip_next=yes;; \ - -[JT]) skip_next=yes;; \ - esac; \ - case $$flg in \ - *$$target_option*) has_opt=yes; break;; \ - esac; \ - done; \ - test $$has_opt = yes -am__make_dryrun = (target_option=n; $(am__make_running_with_option)) -am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) -pkgdatadir = $(datadir)/@PACKAGE@ -pkgincludedir = $(includedir)/@PACKAGE@ -pkglibdir = $(libdir)/@PACKAGE@ -pkglibexecdir = $(libexecdir)/@PACKAGE@ -am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd -install_sh_DATA = $(install_sh) -c -m 644 -install_sh_PROGRAM = $(install_sh) -c -install_sh_SCRIPT = $(install_sh) -c -INSTALL_HEADER = $(INSTALL_DATA) -transform = $(program_transform_name) -NORMAL_INSTALL = : -PRE_INSTALL = : -POST_INSTALL = : -NORMAL_UNINSTALL = : -PRE_UNINSTALL = : -POST_UNINSTALL = : -build_triplet = @build@ -host_triplet = @host@ -target_triplet = @target@ -check_PROGRAMS = cordtest$(EXEEXT) gctest$(EXEEXT) leaktest$(EXEEXT) \ - middletest$(EXEEXT) smashtest$(EXEEXT) hugetest$(EXEEXT) \ - realloc_test$(EXEEXT) staticrootstest$(EXEEXT) $(am__EXEEXT_1) \ - $(am__EXEEXT_2) $(am__EXEEXT_3) $(am__EXEEXT_4) -TESTS = cordtest$(EXEEXT) gctest$(EXEEXT) leaktest$(EXEEXT) \ - middletest$(EXEEXT) smashtest$(EXEEXT) hugetest$(EXEEXT) \ - realloc_test$(EXEEXT) staticrootstest$(EXEEXT) \ - $(am__append_12) $(am__append_14) $(am__append_16) \ - $(am__EXEEXT_4) -@SINGLE_GC_OBJ_FALSE@am__append_1 = extra/gc.c - -# C Library: Architecture Dependent -# --------------------------------- -@SINGLE_GC_OBJ_FALSE@@WIN32_THREADS_TRUE@am__append_2 = win32_threads.c -@PTHREADS_TRUE@@SINGLE_GC_OBJ_FALSE@@WIN32_THREADS_FALSE@am__append_3 = pthread_start.c pthread_support.c -@DARWIN_THREADS_TRUE@@PTHREADS_TRUE@@SINGLE_GC_OBJ_FALSE@@WIN32_THREADS_FALSE@am__append_4 = darwin_stop_world.c -@DARWIN_THREADS_FALSE@@PTHREADS_TRUE@@SINGLE_GC_OBJ_FALSE@@WIN32_THREADS_FALSE@am__append_5 = pthread_stop_world.c -@MAKE_BACK_GRAPH_TRUE@@SINGLE_GC_OBJ_FALSE@am__append_6 = backgraph.c -@ENABLE_DISCLAIM_TRUE@@SINGLE_GC_OBJ_FALSE@am__append_7 = fnlz_mlc.c - -# C++ Interface -# ------------- -@CPLUSPLUS_TRUE@am__append_8 = libgccpp.la -@CPLUSPLUS_TRUE@am__append_9 = include/gc_cpp.h -@CPLUSPLUS_TRUE@am__append_10 = include/extra/gc_cpp.h -@THREADS_TRUE@am__append_11 = $(THREADDLLIBS) -@KEEP_BACK_PTRS_TRUE@am__append_12 = tracetest$(EXEEXT) -@KEEP_BACK_PTRS_TRUE@am__append_13 = tracetest -@THREADS_TRUE@am__append_14 = threadleaktest$(EXEEXT) \ -@THREADS_TRUE@ threadkey_test$(EXEEXT) \ -@THREADS_TRUE@ subthreadcreate_test$(EXEEXT) \ -@THREADS_TRUE@ initsecondarythread_test$(EXEEXT) -@THREADS_TRUE@am__append_15 = threadleaktest threadkey_test \ -@THREADS_TRUE@ subthreadcreate_test initsecondarythread_test -@CPLUSPLUS_TRUE@am__append_16 = test_cpp$(EXEEXT) -@CPLUSPLUS_TRUE@am__append_17 = test_cpp -@ENABLE_DISCLAIM_TRUE@am__append_18 = disclaim_test disclaim_bench -@ENABLE_DISCLAIM_TRUE@am__append_19 = disclaim_test disclaim_bench -@ENABLE_DISCLAIM_TRUE@@THREADS_TRUE@am__append_20 = $(THREADDLLIBS) -subdir = . -ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 -am__aclocal_m4_deps = $(top_srcdir)/m4/libtool.m4 \ - $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \ - $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \ - $(top_srcdir)/configure.ac -am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ - $(ACLOCAL_M4) -DIST_COMMON = $(srcdir)/Makefile.am $(top_srcdir)/configure \ - $(am__configure_deps) $(dist_pkgdata_DATA) \ - $(dist_noinst_HEADERS) $(am__include_HEADERS_DIST) \ - $(am__pkginclude_HEADERS_DIST) $(am__DIST_COMMON) -am__CONFIG_DISTCLEAN_FILES = config.status config.cache config.log \ - configure.lineno config.status.lineno -mkinstalldirs = $(install_sh) -d -CONFIG_HEADER = $(top_builddir)/include/config.h -CONFIG_CLEAN_FILES = bdw-gc.pc -CONFIG_CLEAN_VPATH_FILES = -am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; -am__vpath_adj = case $$p in \ - $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ - *) f=$$p;; \ - esac; -am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`; -am__install_max = 40 -am__nobase_strip_setup = \ - srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'` -am__nobase_strip = \ - for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||" -am__nobase_list = $(am__nobase_strip_setup); \ - for p in $$list; do echo "$$p $$p"; done | \ - sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \ - $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \ - if (++n[$$2] == $(am__install_max)) \ - { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \ - END { for (dir in files) print dir, files[dir] }' -am__base_list = \ - sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \ - sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g' -am__uninstall_files_from_dir = { \ - test -z "$$files" \ - || { test ! -d "$$dir" && test ! -f "$$dir" && test ! -r "$$dir"; } \ - || { echo " ( cd '$$dir' && rm -f" $$files ")"; \ - $(am__cd) "$$dir" && rm -f $$files; }; \ - } -am__installdirs = "$(DESTDIR)$(libdir)" "$(DESTDIR)$(pkgdatadir)" \ - "$(DESTDIR)$(pkgconfigdir)" "$(DESTDIR)$(includedir)" \ - "$(DESTDIR)$(pkgincludedir)" -LTLIBRARIES = $(lib_LTLIBRARIES) -libcord_la_DEPENDENCIES = $(top_builddir)/libgc.la -am__dirstamp = $(am__leading_dot)dirstamp -am_libcord_la_OBJECTS = cord/libcord_la-cordbscs.lo \ - cord/libcord_la-cordprnt.lo cord/libcord_la-cordxtra.lo -libcord_la_OBJECTS = $(am_libcord_la_OBJECTS) -AM_V_lt = $(am__v_lt_@AM_V@) -am__v_lt_ = $(am__v_lt_@AM_DEFAULT_V@) -am__v_lt_0 = --silent -am__v_lt_1 = -libcord_la_LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ - $(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \ - $(libcord_la_LDFLAGS) $(LDFLAGS) -o $@ -am__DEPENDENCIES_1 = -am__libgc_la_SOURCES_DIST = allchblk.c alloc.c blacklst.c checksums.c \ - dbg_mlc.c dyn_load.c finalize.c gc_dlopen.c gcj_mlc.c \ - headers.c mach_dep.c malloc.c mallocx.c mark.c mark_rts.c \ - misc.c new_hblk.c obj_map.c os_dep.c pcr_interface.c \ - ptr_chck.c real_malloc.c reclaim.c specific.c stubborn.c \ - thread_local_alloc.c typd_mlc.c win32_threads.c \ - pthread_start.c pthread_support.c darwin_stop_world.c \ - pthread_stop_world.c backgraph.c fnlz_mlc.c extra/gc.c -@SINGLE_GC_OBJ_FALSE@@WIN32_THREADS_TRUE@am__objects_1 = \ -@SINGLE_GC_OBJ_FALSE@@WIN32_THREADS_TRUE@ win32_threads.lo -@PTHREADS_TRUE@@SINGLE_GC_OBJ_FALSE@@WIN32_THREADS_FALSE@am__objects_2 = pthread_start.lo \ -@PTHREADS_TRUE@@SINGLE_GC_OBJ_FALSE@@WIN32_THREADS_FALSE@ pthread_support.lo -@DARWIN_THREADS_TRUE@@PTHREADS_TRUE@@SINGLE_GC_OBJ_FALSE@@WIN32_THREADS_FALSE@am__objects_3 = darwin_stop_world.lo -@DARWIN_THREADS_FALSE@@PTHREADS_TRUE@@SINGLE_GC_OBJ_FALSE@@WIN32_THREADS_FALSE@am__objects_4 = pthread_stop_world.lo -@MAKE_BACK_GRAPH_TRUE@@SINGLE_GC_OBJ_FALSE@am__objects_5 = \ -@MAKE_BACK_GRAPH_TRUE@@SINGLE_GC_OBJ_FALSE@ backgraph.lo -@ENABLE_DISCLAIM_TRUE@@SINGLE_GC_OBJ_FALSE@am__objects_6 = \ -@ENABLE_DISCLAIM_TRUE@@SINGLE_GC_OBJ_FALSE@ fnlz_mlc.lo -@SINGLE_GC_OBJ_FALSE@am_libgc_la_OBJECTS = allchblk.lo alloc.lo \ -@SINGLE_GC_OBJ_FALSE@ blacklst.lo checksums.lo dbg_mlc.lo \ -@SINGLE_GC_OBJ_FALSE@ dyn_load.lo finalize.lo gc_dlopen.lo \ -@SINGLE_GC_OBJ_FALSE@ gcj_mlc.lo headers.lo mach_dep.lo \ -@SINGLE_GC_OBJ_FALSE@ malloc.lo mallocx.lo mark.lo mark_rts.lo \ -@SINGLE_GC_OBJ_FALSE@ misc.lo new_hblk.lo obj_map.lo os_dep.lo \ -@SINGLE_GC_OBJ_FALSE@ pcr_interface.lo ptr_chck.lo \ -@SINGLE_GC_OBJ_FALSE@ real_malloc.lo reclaim.lo specific.lo \ -@SINGLE_GC_OBJ_FALSE@ stubborn.lo thread_local_alloc.lo \ -@SINGLE_GC_OBJ_FALSE@ typd_mlc.lo $(am__objects_1) \ -@SINGLE_GC_OBJ_FALSE@ $(am__objects_2) $(am__objects_3) \ -@SINGLE_GC_OBJ_FALSE@ $(am__objects_4) $(am__objects_5) \ -@SINGLE_GC_OBJ_FALSE@ $(am__objects_6) -@SINGLE_GC_OBJ_TRUE@am_libgc_la_OBJECTS = extra/gc.lo $(am__objects_1) \ -@SINGLE_GC_OBJ_TRUE@ $(am__objects_2) $(am__objects_3) \ -@SINGLE_GC_OBJ_TRUE@ $(am__objects_4) $(am__objects_5) \ -@SINGLE_GC_OBJ_TRUE@ $(am__objects_6) -@NEED_ATOMIC_OPS_ASM_FALSE@@USE_INTERNAL_LIBATOMIC_OPS_TRUE@nodist_libgc_la_OBJECTS = libatomic_ops/src/atomic_ops.lo -@NEED_ATOMIC_OPS_ASM_TRUE@nodist_libgc_la_OBJECTS = libatomic_ops/src/atomic_ops_sysdeps.lo -libgc_la_OBJECTS = $(am_libgc_la_OBJECTS) $(nodist_libgc_la_OBJECTS) -libgc_la_LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ - $(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \ - $(libgc_la_LDFLAGS) $(LDFLAGS) -o $@ -@CPLUSPLUS_TRUE@libgccpp_la_DEPENDENCIES = ./libgc.la -am__libgccpp_la_SOURCES_DIST = gc_cpp.cc -@CPLUSPLUS_TRUE@am_libgccpp_la_OBJECTS = gc_cpp.lo -libgccpp_la_OBJECTS = $(am_libgccpp_la_OBJECTS) -libgccpp_la_LINK = $(LIBTOOL) $(AM_V_lt) --tag=CXX $(AM_LIBTOOLFLAGS) \ - $(LIBTOOLFLAGS) --mode=link $(CXXLD) $(AM_CXXFLAGS) \ - $(CXXFLAGS) $(libgccpp_la_LDFLAGS) $(LDFLAGS) -o $@ -@CPLUSPLUS_TRUE@am_libgccpp_la_rpath = -rpath $(libdir) -am__DEPENDENCIES_2 = $(top_builddir)/libgc.la $(am__DEPENDENCIES_1) -libstaticrootslib2_test_la_DEPENDENCIES = $(am__DEPENDENCIES_2) -am_libstaticrootslib2_test_la_OBJECTS = \ - tests/libstaticrootslib2_test_la-staticrootslib.lo -libstaticrootslib2_test_la_OBJECTS = \ - $(am_libstaticrootslib2_test_la_OBJECTS) -libstaticrootslib2_test_la_LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC \ - $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=link $(CCLD) \ - $(libstaticrootslib2_test_la_CFLAGS) $(CFLAGS) \ - $(libstaticrootslib2_test_la_LDFLAGS) $(LDFLAGS) -o $@ -am_libstaticrootslib_test_la_OBJECTS = tests/staticrootslib.lo -libstaticrootslib_test_la_OBJECTS = \ - $(am_libstaticrootslib_test_la_OBJECTS) -libstaticrootslib_test_la_LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC \ - $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=link $(CCLD) \ - $(AM_CFLAGS) $(CFLAGS) $(libstaticrootslib_test_la_LDFLAGS) \ - $(LDFLAGS) -o $@ -@KEEP_BACK_PTRS_TRUE@am__EXEEXT_1 = tracetest$(EXEEXT) -@THREADS_TRUE@am__EXEEXT_2 = threadleaktest$(EXEEXT) \ -@THREADS_TRUE@ threadkey_test$(EXEEXT) \ -@THREADS_TRUE@ subthreadcreate_test$(EXEEXT) \ -@THREADS_TRUE@ initsecondarythread_test$(EXEEXT) -@CPLUSPLUS_TRUE@am__EXEEXT_3 = test_cpp$(EXEEXT) -@ENABLE_DISCLAIM_TRUE@am__EXEEXT_4 = disclaim_test$(EXEEXT) \ -@ENABLE_DISCLAIM_TRUE@ disclaim_bench$(EXEEXT) -am_cordtest_OBJECTS = cord/tests/cordtest.$(OBJEXT) -cordtest_OBJECTS = $(am_cordtest_OBJECTS) -cordtest_DEPENDENCIES = $(top_builddir)/libgc.la \ - $(top_builddir)/libcord.la -am__disclaim_bench_SOURCES_DIST = tests/disclaim_bench.c -@ENABLE_DISCLAIM_TRUE@am_disclaim_bench_OBJECTS = \ -@ENABLE_DISCLAIM_TRUE@ tests/disclaim_bench.$(OBJEXT) -disclaim_bench_OBJECTS = $(am_disclaim_bench_OBJECTS) -@ENABLE_DISCLAIM_TRUE@disclaim_bench_DEPENDENCIES = \ -@ENABLE_DISCLAIM_TRUE@ $(am__DEPENDENCIES_2) -am__disclaim_test_SOURCES_DIST = tests/disclaim_test.c -@ENABLE_DISCLAIM_TRUE@am_disclaim_test_OBJECTS = \ -@ENABLE_DISCLAIM_TRUE@ tests/disclaim_test.$(OBJEXT) -disclaim_test_OBJECTS = $(am_disclaim_test_OBJECTS) -@ENABLE_DISCLAIM_TRUE@@THREADS_TRUE@am__DEPENDENCIES_3 = \ -@ENABLE_DISCLAIM_TRUE@@THREADS_TRUE@ $(am__DEPENDENCIES_1) -@ENABLE_DISCLAIM_TRUE@disclaim_test_DEPENDENCIES = \ -@ENABLE_DISCLAIM_TRUE@ $(am__DEPENDENCIES_2) \ -@ENABLE_DISCLAIM_TRUE@ $(am__DEPENDENCIES_3) -am_gctest_OBJECTS = tests/test.$(OBJEXT) -gctest_OBJECTS = $(am_gctest_OBJECTS) -@THREADS_TRUE@am__DEPENDENCIES_4 = $(am__DEPENDENCIES_1) -am_hugetest_OBJECTS = tests/huge_test.$(OBJEXT) -hugetest_OBJECTS = $(am_hugetest_OBJECTS) -hugetest_DEPENDENCIES = $(am__DEPENDENCIES_2) -am__initsecondarythread_test_SOURCES_DIST = \ - tests/initsecondarythread.c -@THREADS_TRUE@am_initsecondarythread_test_OBJECTS = \ -@THREADS_TRUE@ tests/initsecondarythread.$(OBJEXT) -initsecondarythread_test_OBJECTS = \ - $(am_initsecondarythread_test_OBJECTS) -@THREADS_TRUE@initsecondarythread_test_DEPENDENCIES = \ -@THREADS_TRUE@ $(am__DEPENDENCIES_2) $(am__DEPENDENCIES_1) -am_leaktest_OBJECTS = tests/leak_test.$(OBJEXT) -leaktest_OBJECTS = $(am_leaktest_OBJECTS) -leaktest_DEPENDENCIES = $(am__DEPENDENCIES_2) -am_middletest_OBJECTS = tests/middle.$(OBJEXT) -middletest_OBJECTS = $(am_middletest_OBJECTS) -middletest_DEPENDENCIES = $(am__DEPENDENCIES_2) -am_realloc_test_OBJECTS = tests/realloc_test.$(OBJEXT) -realloc_test_OBJECTS = $(am_realloc_test_OBJECTS) -realloc_test_DEPENDENCIES = $(am__DEPENDENCIES_2) -am_smashtest_OBJECTS = tests/smash_test.$(OBJEXT) -smashtest_OBJECTS = $(am_smashtest_OBJECTS) -smashtest_DEPENDENCIES = $(am__DEPENDENCIES_2) -am_staticrootstest_OBJECTS = \ - tests/staticrootstest-staticrootstest.$(OBJEXT) -staticrootstest_OBJECTS = $(am_staticrootstest_OBJECTS) -staticrootstest_DEPENDENCIES = $(am__DEPENDENCIES_2) \ - libstaticrootslib_test.la libstaticrootslib2_test.la -staticrootstest_LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC \ - $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=link $(CCLD) \ - $(staticrootstest_CFLAGS) $(CFLAGS) $(AM_LDFLAGS) $(LDFLAGS) \ - -o $@ -am__subthreadcreate_test_SOURCES_DIST = tests/subthread_create.c -@THREADS_TRUE@am_subthreadcreate_test_OBJECTS = \ -@THREADS_TRUE@ tests/subthread_create.$(OBJEXT) -subthreadcreate_test_OBJECTS = $(am_subthreadcreate_test_OBJECTS) -@THREADS_TRUE@subthreadcreate_test_DEPENDENCIES = \ -@THREADS_TRUE@ $(am__DEPENDENCIES_2) $(am__DEPENDENCIES_1) -am__test_cpp_SOURCES_DIST = tests/test_cpp.cc -@CPLUSPLUS_TRUE@am_test_cpp_OBJECTS = tests/test_cpp.$(OBJEXT) -test_cpp_OBJECTS = $(am_test_cpp_OBJECTS) -@AVOID_CPP_LIB_FALSE@@CPLUSPLUS_TRUE@test_cpp_DEPENDENCIES = \ -@AVOID_CPP_LIB_FALSE@@CPLUSPLUS_TRUE@ libgccpp.la \ -@AVOID_CPP_LIB_FALSE@@CPLUSPLUS_TRUE@ $(am__DEPENDENCIES_2) \ -@AVOID_CPP_LIB_FALSE@@CPLUSPLUS_TRUE@ $(am__DEPENDENCIES_1) -@AVOID_CPP_LIB_TRUE@@CPLUSPLUS_TRUE@test_cpp_DEPENDENCIES = gc_cpp.o \ -@AVOID_CPP_LIB_TRUE@@CPLUSPLUS_TRUE@ $(am__DEPENDENCIES_2) \ -@AVOID_CPP_LIB_TRUE@@CPLUSPLUS_TRUE@ $(am__DEPENDENCIES_1) -am__threadkey_test_SOURCES_DIST = tests/threadkey_test.c -@THREADS_TRUE@am_threadkey_test_OBJECTS = \ -@THREADS_TRUE@ tests/threadkey_test.$(OBJEXT) -threadkey_test_OBJECTS = $(am_threadkey_test_OBJECTS) -@THREADS_TRUE@threadkey_test_DEPENDENCIES = $(am__DEPENDENCIES_2) \ -@THREADS_TRUE@ $(am__DEPENDENCIES_1) -am__threadleaktest_SOURCES_DIST = tests/thread_leak_test.c -@THREADS_TRUE@am_threadleaktest_OBJECTS = \ -@THREADS_TRUE@ tests/thread_leak_test.$(OBJEXT) -threadleaktest_OBJECTS = $(am_threadleaktest_OBJECTS) -@THREADS_TRUE@threadleaktest_DEPENDENCIES = $(am__DEPENDENCIES_2) \ -@THREADS_TRUE@ $(am__DEPENDENCIES_1) -am__tracetest_SOURCES_DIST = tests/trace_test.c -@KEEP_BACK_PTRS_TRUE@am_tracetest_OBJECTS = \ -@KEEP_BACK_PTRS_TRUE@ tests/trace_test.$(OBJEXT) -tracetest_OBJECTS = $(am_tracetest_OBJECTS) -@KEEP_BACK_PTRS_TRUE@tracetest_DEPENDENCIES = $(am__DEPENDENCIES_2) -AM_V_P = $(am__v_P_@AM_V@) -am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) -am__v_P_0 = false -am__v_P_1 = : -AM_V_GEN = $(am__v_GEN_@AM_V@) -am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) -am__v_GEN_0 = @echo " GEN " $@; -am__v_GEN_1 = -AM_V_at = $(am__v_at_@AM_V@) -am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) -am__v_at_0 = @ -am__v_at_1 = -DEFAULT_INCLUDES = -depcomp = $(SHELL) $(top_srcdir)/depcomp -am__depfiles_maybe = depfiles -am__mv = mv -f -CPPASCOMPILE = $(CCAS) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) \ - $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CCASFLAGS) $(CCASFLAGS) -LTCPPASCOMPILE = $(LIBTOOL) $(AM_V_lt) $(AM_LIBTOOLFLAGS) \ - $(LIBTOOLFLAGS) --mode=compile $(CCAS) $(DEFS) \ - $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \ - $(AM_CCASFLAGS) $(CCASFLAGS) -AM_V_CPPAS = $(am__v_CPPAS_@AM_V@) -am__v_CPPAS_ = $(am__v_CPPAS_@AM_DEFAULT_V@) -am__v_CPPAS_0 = @echo " CPPAS " $@; -am__v_CPPAS_1 = -COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \ - $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -LTCOMPILE = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ - $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) \ - $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \ - $(AM_CFLAGS) $(CFLAGS) -AM_V_CC = $(am__v_CC_@AM_V@) -am__v_CC_ = $(am__v_CC_@AM_DEFAULT_V@) -am__v_CC_0 = @echo " CC " $@; -am__v_CC_1 = -CCLD = $(CC) -LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ - $(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \ - $(AM_LDFLAGS) $(LDFLAGS) -o $@ -AM_V_CCLD = $(am__v_CCLD_@AM_V@) -am__v_CCLD_ = $(am__v_CCLD_@AM_DEFAULT_V@) -am__v_CCLD_0 = @echo " CCLD " $@; -am__v_CCLD_1 = -CXXCOMPILE = $(CXX) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) \ - $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CXXFLAGS) $(CXXFLAGS) -LTCXXCOMPILE = $(LIBTOOL) $(AM_V_lt) --tag=CXX $(AM_LIBTOOLFLAGS) \ - $(LIBTOOLFLAGS) --mode=compile $(CXX) $(DEFS) \ - $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \ - $(AM_CXXFLAGS) $(CXXFLAGS) -AM_V_CXX = $(am__v_CXX_@AM_V@) -am__v_CXX_ = $(am__v_CXX_@AM_DEFAULT_V@) -am__v_CXX_0 = @echo " CXX " $@; -am__v_CXX_1 = -CXXLD = $(CXX) -CXXLINK = $(LIBTOOL) $(AM_V_lt) --tag=CXX $(AM_LIBTOOLFLAGS) \ - $(LIBTOOLFLAGS) --mode=link $(CXXLD) $(AM_CXXFLAGS) \ - $(CXXFLAGS) $(AM_LDFLAGS) $(LDFLAGS) -o $@ -AM_V_CXXLD = $(am__v_CXXLD_@AM_V@) -am__v_CXXLD_ = $(am__v_CXXLD_@AM_DEFAULT_V@) -am__v_CXXLD_0 = @echo " CXXLD " $@; -am__v_CXXLD_1 = -CCASCOMPILE = $(CCAS) $(AM_CCASFLAGS) $(CCASFLAGS) -LTCCASCOMPILE = $(LIBTOOL) $(AM_V_lt) $(AM_LIBTOOLFLAGS) \ - $(LIBTOOLFLAGS) --mode=compile $(CCAS) $(AM_CCASFLAGS) \ - $(CCASFLAGS) -AM_V_CCAS = $(am__v_CCAS_@AM_V@) -am__v_CCAS_ = $(am__v_CCAS_@AM_DEFAULT_V@) -am__v_CCAS_0 = @echo " CCAS " $@; -am__v_CCAS_1 = -SOURCES = $(libcord_la_SOURCES) $(libgc_la_SOURCES) \ - $(EXTRA_libgc_la_SOURCES) $(nodist_libgc_la_SOURCES) \ - $(libgccpp_la_SOURCES) $(libstaticrootslib2_test_la_SOURCES) \ - $(libstaticrootslib_test_la_SOURCES) $(cordtest_SOURCES) \ - $(disclaim_bench_SOURCES) $(disclaim_test_SOURCES) \ - $(gctest_SOURCES) $(hugetest_SOURCES) \ - $(initsecondarythread_test_SOURCES) $(leaktest_SOURCES) \ - $(middletest_SOURCES) $(realloc_test_SOURCES) \ - $(smashtest_SOURCES) $(staticrootstest_SOURCES) \ - $(subthreadcreate_test_SOURCES) $(test_cpp_SOURCES) \ - $(threadkey_test_SOURCES) $(threadleaktest_SOURCES) \ - $(tracetest_SOURCES) -DIST_SOURCES = $(libcord_la_SOURCES) $(am__libgc_la_SOURCES_DIST) \ - $(EXTRA_libgc_la_SOURCES) $(am__libgccpp_la_SOURCES_DIST) \ - $(libstaticrootslib2_test_la_SOURCES) \ - $(libstaticrootslib_test_la_SOURCES) $(cordtest_SOURCES) \ - $(am__disclaim_bench_SOURCES_DIST) \ - $(am__disclaim_test_SOURCES_DIST) $(gctest_SOURCES) \ - $(hugetest_SOURCES) \ - $(am__initsecondarythread_test_SOURCES_DIST) \ - $(leaktest_SOURCES) $(middletest_SOURCES) \ - $(realloc_test_SOURCES) $(smashtest_SOURCES) \ - $(staticrootstest_SOURCES) \ - $(am__subthreadcreate_test_SOURCES_DIST) \ - $(am__test_cpp_SOURCES_DIST) \ - $(am__threadkey_test_SOURCES_DIST) \ - $(am__threadleaktest_SOURCES_DIST) \ - $(am__tracetest_SOURCES_DIST) -RECURSIVE_TARGETS = all-recursive check-recursive cscopelist-recursive \ - ctags-recursive dvi-recursive html-recursive info-recursive \ - install-data-recursive install-dvi-recursive \ - install-exec-recursive install-html-recursive \ - install-info-recursive install-pdf-recursive \ - install-ps-recursive install-recursive installcheck-recursive \ - installdirs-recursive pdf-recursive ps-recursive \ - tags-recursive uninstall-recursive -am__can_run_installinfo = \ - case $$AM_UPDATE_INFO_DIR in \ - n|no|NO) false;; \ - *) (install-info --version) >/dev/null 2>&1;; \ - esac -DATA = $(dist_pkgdata_DATA) $(pkgconfig_DATA) -am__include_HEADERS_DIST = include/extra/gc_cpp.h include/extra/gc.h -am__pkginclude_HEADERS_DIST = include/gc_cpp.h include/gc.h \ - include/gc_allocator.h include/gc_backptr.h \ - include/gc_config_macros.h include/gc_disclaim.h \ - include/gc_gcj.h include/gc_inline.h include/gc_mark.h \ - include/gc_pthread_redirects.h include/gc_tiny_fl.h \ - include/gc_typed.h include/gc_version.h include/javaxfc.h \ - include/leak_detector.h include/weakpointer.h include/cord.h \ - include/cord_pos.h include/ec.h -HEADERS = $(dist_noinst_HEADERS) $(include_HEADERS) \ - $(pkginclude_HEADERS) -RECURSIVE_CLEAN_TARGETS = mostlyclean-recursive clean-recursive \ - distclean-recursive maintainer-clean-recursive -am__recursive_targets = \ - $(RECURSIVE_TARGETS) \ - $(RECURSIVE_CLEAN_TARGETS) \ - $(am__extra_recursive_targets) -AM_RECURSIVE_TARGETS = $(am__recursive_targets:-recursive=) TAGS CTAGS \ - cscope check recheck distdir dist dist-all distcheck -am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP) -# Read a list of newline-separated strings from the standard input, -# and print each of them once, without duplicates. Input order is -# *not* preserved. -am__uniquify_input = $(AWK) '\ - BEGIN { nonempty = 0; } \ - { items[$$0] = 1; nonempty = 1; } \ - END { if (nonempty) { for (i in items) print i; }; } \ -' -# Make sure the list of sources is unique. This is necessary because, -# e.g., the same source file might be shared among _SOURCES variables -# for different programs/libraries. -am__define_uniq_tagged_files = \ - list='$(am__tagged_files)'; \ - unique=`for i in $$list; do \ - if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ - done | $(am__uniquify_input)` -ETAGS = etags -CTAGS = ctags -CSCOPE = cscope -am__tty_colors_dummy = \ - mgn= red= grn= lgn= blu= brg= std=; \ - am__color_tests=no -am__tty_colors = { \ - $(am__tty_colors_dummy); \ - if test "X$(AM_COLOR_TESTS)" = Xno; then \ - am__color_tests=no; \ - elif test "X$(AM_COLOR_TESTS)" = Xalways; then \ - am__color_tests=yes; \ - elif test "X$$TERM" != Xdumb && { test -t 1; } 2>/dev/null; then \ - am__color_tests=yes; \ - fi; \ - if test $$am__color_tests = yes; then \ - red=''; \ - grn=''; \ - lgn=''; \ - blu=''; \ - mgn=''; \ - brg=''; \ - std=''; \ - fi; \ -} -am__recheck_rx = ^[ ]*:recheck:[ ]* -am__global_test_result_rx = ^[ ]*:global-test-result:[ ]* -am__copy_in_global_log_rx = ^[ ]*:copy-in-global-log:[ ]* -# A command that, given a newline-separated list of test names on the -# standard input, print the name of the tests that are to be re-run -# upon "make recheck". -am__list_recheck_tests = $(AWK) '{ \ - recheck = 1; \ - while ((rc = (getline line < ($$0 ".trs"))) != 0) \ - { \ - if (rc < 0) \ - { \ - if ((getline line2 < ($$0 ".log")) < 0) \ - recheck = 0; \ - break; \ - } \ - else if (line ~ /$(am__recheck_rx)[nN][Oo]/) \ - { \ - recheck = 0; \ - break; \ - } \ - else if (line ~ /$(am__recheck_rx)[yY][eE][sS]/) \ - { \ - break; \ - } \ - }; \ - if (recheck) \ - print $$0; \ - close ($$0 ".trs"); \ - close ($$0 ".log"); \ -}' -# A command that, given a newline-separated list of test names on the -# standard input, create the global log from their .trs and .log files. -am__create_global_log = $(AWK) ' \ -function fatal(msg) \ -{ \ - print "fatal: making $@: " msg | "cat >&2"; \ - exit 1; \ -} \ -function rst_section(header) \ -{ \ - print header; \ - len = length(header); \ - for (i = 1; i <= len; i = i + 1) \ - printf "="; \ - printf "\n\n"; \ -} \ -{ \ - copy_in_global_log = 1; \ - global_test_result = "RUN"; \ - while ((rc = (getline line < ($$0 ".trs"))) != 0) \ - { \ - if (rc < 0) \ - fatal("failed to read from " $$0 ".trs"); \ - if (line ~ /$(am__global_test_result_rx)/) \ - { \ - sub("$(am__global_test_result_rx)", "", line); \ - sub("[ ]*$$", "", line); \ - global_test_result = line; \ - } \ - else if (line ~ /$(am__copy_in_global_log_rx)[nN][oO]/) \ - copy_in_global_log = 0; \ - }; \ - if (copy_in_global_log) \ - { \ - rst_section(global_test_result ": " $$0); \ - while ((rc = (getline line < ($$0 ".log"))) != 0) \ - { \ - if (rc < 0) \ - fatal("failed to read from " $$0 ".log"); \ - print line; \ - }; \ - printf "\n"; \ - }; \ - close ($$0 ".trs"); \ - close ($$0 ".log"); \ -}' -# Restructured Text title. -am__rst_title = { sed 's/.*/ & /;h;s/./=/g;p;x;s/ *$$//;p;g' && echo; } -# Solaris 10 'make', and several other traditional 'make' implementations, -# pass "-e" to $(SHELL), and POSIX 2008 even requires this. Work around it -# by disabling -e (using the XSI extension "set +e") if it's set. -am__sh_e_setup = case $$- in *e*) set +e;; esac -# Default flags passed to test drivers. -am__common_driver_flags = \ - --color-tests "$$am__color_tests" \ - --enable-hard-errors "$$am__enable_hard_errors" \ - --expect-failure "$$am__expect_failure" -# To be inserted before the command running the test. Creates the -# directory for the log if needed. Stores in $dir the directory -# containing $f, in $tst the test, in $log the log. Executes the -# developer- defined test setup AM_TESTS_ENVIRONMENT (if any), and -# passes TESTS_ENVIRONMENT. Set up options for the wrapper that -# will run the test scripts (or their associated LOG_COMPILER, if -# thy have one). -am__check_pre = \ -$(am__sh_e_setup); \ -$(am__vpath_adj_setup) $(am__vpath_adj) \ -$(am__tty_colors); \ -srcdir=$(srcdir); export srcdir; \ -case "$@" in \ - */*) am__odir=`echo "./$@" | sed 's|/[^/]*$$||'`;; \ - *) am__odir=.;; \ -esac; \ -test "x$$am__odir" = x"." || test -d "$$am__odir" \ - || $(MKDIR_P) "$$am__odir" || exit $$?; \ -if test -f "./$$f"; then dir=./; \ -elif test -f "$$f"; then dir=; \ -else dir="$(srcdir)/"; fi; \ -tst=$$dir$$f; log='$@'; \ -if test -n '$(DISABLE_HARD_ERRORS)'; then \ - am__enable_hard_errors=no; \ -else \ - am__enable_hard_errors=yes; \ -fi; \ -case " $(XFAIL_TESTS) " in \ - *[\ \ ]$$f[\ \ ]* | *[\ \ ]$$dir$$f[\ \ ]*) \ - am__expect_failure=yes;; \ - *) \ - am__expect_failure=no;; \ -esac; \ -$(AM_TESTS_ENVIRONMENT) $(TESTS_ENVIRONMENT) -# A shell command to get the names of the tests scripts with any registered -# extension removed (i.e., equivalently, the names of the test logs, with -# the '.log' extension removed). The result is saved in the shell variable -# '$bases'. This honors runtime overriding of TESTS and TEST_LOGS. Sadly, -# we cannot use something simpler, involving e.g., "$(TEST_LOGS:.log=)", -# since that might cause problem with VPATH rewrites for suffix-less tests. -# See also 'test-harness-vpath-rewrite.sh' and 'test-trs-basic.sh'. -am__set_TESTS_bases = \ - bases='$(TEST_LOGS)'; \ - bases=`for i in $$bases; do echo $$i; done | sed 's/\.log$$//'`; \ - bases=`echo $$bases` -RECHECK_LOGS = $(TEST_LOGS) -TEST_SUITE_LOG = test-suite.log -TEST_EXTENSIONS = @EXEEXT@ .test -LOG_DRIVER = $(SHELL) $(top_srcdir)/test-driver -LOG_COMPILE = $(LOG_COMPILER) $(AM_LOG_FLAGS) $(LOG_FLAGS) -am__set_b = \ - case '$@' in \ - */*) \ - case '$*' in \ - */*) b='$*';; \ - *) b=`echo '$@' | sed 's/\.log$$//'`; \ - esac;; \ - *) \ - b='$*';; \ - esac -am__test_logs1 = $(TESTS:=.log) -am__test_logs2 = $(am__test_logs1:@EXEEXT@.log=.log) -TEST_LOGS = $(am__test_logs2:.test.log=.log) -TEST_LOG_DRIVER = $(SHELL) $(top_srcdir)/test-driver -TEST_LOG_COMPILE = $(TEST_LOG_COMPILER) $(AM_TEST_LOG_FLAGS) \ - $(TEST_LOG_FLAGS) -DIST_SUBDIRS = $(SUBDIRS) -am__DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/bdw-gc.pc.in \ - $(srcdir)/cord/cord.am $(srcdir)/doc/doc.am \ - $(srcdir)/include/include.am $(srcdir)/tests/tests.am \ - $(top_srcdir)/include/config.h.in AUTHORS ChangeLog TODO \ - compile config.guess config.sub depcomp install-sh ltmain.sh \ - missing test-driver -DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) -distdir = $(PACKAGE)-$(VERSION) -top_distdir = $(distdir) -am__remove_distdir = \ - if test -d "$(distdir)"; then \ - find "$(distdir)" -type d ! -perm -200 -exec chmod u+w {} ';' \ - && rm -rf "$(distdir)" \ - || { sleep 5 && rm -rf "$(distdir)"; }; \ - else :; fi -am__post_remove_distdir = $(am__remove_distdir) -am__relativize = \ - dir0=`pwd`; \ - sed_first='s,^\([^/]*\)/.*$$,\1,'; \ - sed_rest='s,^[^/]*/*,,'; \ - sed_last='s,^.*/\([^/]*\)$$,\1,'; \ - sed_butlast='s,/*[^/]*$$,,'; \ - while test -n "$$dir1"; do \ - first=`echo "$$dir1" | sed -e "$$sed_first"`; \ - if test "$$first" != "."; then \ - if test "$$first" = ".."; then \ - dir2=`echo "$$dir0" | sed -e "$$sed_last"`/"$$dir2"; \ - dir0=`echo "$$dir0" | sed -e "$$sed_butlast"`; \ - else \ - first2=`echo "$$dir2" | sed -e "$$sed_first"`; \ - if test "$$first2" = "$$first"; then \ - dir2=`echo "$$dir2" | sed -e "$$sed_rest"`; \ - else \ - dir2="../$$dir2"; \ - fi; \ - dir0="$$dir0"/"$$first"; \ - fi; \ - fi; \ - dir1=`echo "$$dir1" | sed -e "$$sed_rest"`; \ - done; \ - reldir="$$dir2" -DIST_ARCHIVES = $(distdir).tar.gz $(distdir).tar.bz2 -GZIP_ENV = --best -DIST_TARGETS = dist-bzip2 dist-gzip -distuninstallcheck_listfiles = find . -type f -print -am__distuninstallcheck_listfiles = $(distuninstallcheck_listfiles) \ - | sed 's|^\./|$(prefix)/|' | grep -v '$(infodir)/dir$$' -distcleancheck_listfiles = find . -type f -print -ACLOCAL = @ACLOCAL@ -AMTAR = @AMTAR@ -AM_CFLAGS = @GC_CFLAGS@ -AM_CPPFLAGS = \ - -I$(top_builddir)/include -I$(top_srcdir)/include \ - $(ATOMIC_OPS_CFLAGS) - -AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ -AR = @AR@ -ATOMIC_OPS_CFLAGS = @ATOMIC_OPS_CFLAGS@ -ATOMIC_OPS_LIBS = @ATOMIC_OPS_LIBS@ -AUTOCONF = @AUTOCONF@ -AUTOHEADER = @AUTOHEADER@ -AUTOMAKE = @AUTOMAKE@ -AWK = @AWK@ -CC = @CC@ -CCAS = @CCAS@ -CCASDEPMODE = @CCASDEPMODE@ -CCASFLAGS = @CCASFLAGS@ $(DEFS) -CCDEPMODE = @CCDEPMODE@ -CFLAGS = @CFLAGS@ -CPP = @CPP@ -CPPFLAGS = @CPPFLAGS@ -CXX = @CXX@ -CXXCPP = @CXXCPP@ -CXXDEPMODE = @CXXDEPMODE@ -CXXFLAGS = @CXXFLAGS@ -CXXLIBS = @CXXLIBS@ -CYGPATH_W = @CYGPATH_W@ -DEFS = @DEFS@ -DEPDIR = @DEPDIR@ -DLLTOOL = @DLLTOOL@ -DSYMUTIL = @DSYMUTIL@ -DUMPBIN = @DUMPBIN@ -ECHO_C = @ECHO_C@ -ECHO_N = @ECHO_N@ -ECHO_T = @ECHO_T@ -EGREP = @EGREP@ -EXEEXT = @EXEEXT@ -EXTRA_TEST_LIBS = @EXTRA_TEST_LIBS@ -FGREP = @FGREP@ -GC_CFLAGS = @GC_CFLAGS@ -GC_VERSION = @GC_VERSION@ -GREP = @GREP@ -INSTALL = @INSTALL@ -INSTALL_DATA = @INSTALL_DATA@ -INSTALL_PROGRAM = @INSTALL_PROGRAM@ -INSTALL_SCRIPT = @INSTALL_SCRIPT@ -INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ -LD = @LD@ -LDFLAGS = @LDFLAGS@ -LIBOBJS = @LIBOBJS@ -LIBS = @LIBS@ -LIBTOOL = @LIBTOOL@ -LIPO = @LIPO@ -LN_S = @LN_S@ -LTLIBOBJS = @LTLIBOBJS@ -LT_SYS_LIBRARY_PATH = @LT_SYS_LIBRARY_PATH@ -MAINT = @MAINT@ -MAKEINFO = @MAKEINFO@ -MANIFEST_TOOL = @MANIFEST_TOOL@ -MKDIR_P = @MKDIR_P@ -NM = @NM@ -NMEDIT = @NMEDIT@ -OBJDUMP = @OBJDUMP@ -OBJEXT = @OBJEXT@ -OTOOL = @OTOOL@ -OTOOL64 = @OTOOL64@ -PACKAGE = @PACKAGE@ -PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ -PACKAGE_NAME = @PACKAGE_NAME@ -PACKAGE_STRING = @PACKAGE_STRING@ -PACKAGE_TARNAME = @PACKAGE_TARNAME@ -PACKAGE_URL = @PACKAGE_URL@ -PACKAGE_VERSION = @PACKAGE_VERSION@ -PATH_SEPARATOR = @PATH_SEPARATOR@ -PKG_CONFIG = @PKG_CONFIG@ -PKG_CONFIG_LIBDIR = @PKG_CONFIG_LIBDIR@ -PKG_CONFIG_PATH = @PKG_CONFIG_PATH@ -RANLIB = @RANLIB@ -SED = @SED@ -SET_MAKE = @SET_MAKE@ -SHELL = @SHELL@ -STRIP = @STRIP@ -THREADDLLIBS = @THREADDLLIBS@ -UNWINDLIBS = @UNWINDLIBS@ -VERSION = @VERSION@ -abs_builddir = @abs_builddir@ -abs_srcdir = @abs_srcdir@ -abs_top_builddir = @abs_top_builddir@ -abs_top_srcdir = @abs_top_srcdir@ -ac_ct_AR = @ac_ct_AR@ -ac_ct_CC = @ac_ct_CC@ -ac_ct_CXX = @ac_ct_CXX@ -ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ -addlibs = @addlibs@ -addobjs = @addobjs@ -am__include = @am__include@ -am__leading_dot = @am__leading_dot@ -am__quote = @am__quote@ -am__tar = @am__tar@ -am__untar = @am__untar@ -bindir = @bindir@ -build = @build@ -build_alias = @build_alias@ -build_cpu = @build_cpu@ -build_os = @build_os@ -build_vendor = @build_vendor@ -builddir = @builddir@ -datadir = @datadir@ -datarootdir = @datarootdir@ -docdir = @docdir@ -dvidir = @dvidir@ -exec_prefix = @exec_prefix@ -extra_ldflags_libgc = @extra_ldflags_libgc@ -host = @host@ -host_alias = @host_alias@ -host_cpu = @host_cpu@ -host_os = @host_os@ -host_vendor = @host_vendor@ -htmldir = @htmldir@ -includedir = @includedir@ -infodir = @infodir@ -install_sh = @install_sh@ -libdir = @libdir@ -libexecdir = @libexecdir@ -localedir = @localedir@ -localstatedir = @localstatedir@ -mandir = @mandir@ -mkdir_p = @mkdir_p@ -oldincludedir = @oldincludedir@ -pdfdir = @pdfdir@ -prefix = @prefix@ -program_transform_name = @program_transform_name@ -psdir = @psdir@ -sbindir = @sbindir@ -sharedstatedir = @sharedstatedir@ -srcdir = @srcdir@ -subdirs = @subdirs@ -sysconfdir = @sysconfdir@ -target = @target@ -target_alias = @target_alias@ -target_all = @target_all@ -target_cpu = @target_cpu@ -target_os = @target_os@ -target_vendor = @target_vendor@ -top_build_prefix = @top_build_prefix@ -top_builddir = @top_builddir@ -top_srcdir = @top_srcdir@ - -# We currently use the source files directly from libatomic_ops, if we -# use the internal version. This is done since libatomic_ops doesn't -# use libtool, since it has no real use for it. But that seems to make -# it hard to use either the resulting object files or libraries. -# Thus there seems too be no real reason to recursively build in the -# libatomic_ops directory. -# if USE_INTERNAL_LIBATOMICS_OPS -# SUBDIRS = @maybe_libatomic_ops@ -# else -# SUBDIRS = -# endif -SUBDIRS = -ACLOCAL_AMFLAGS = -I m4 - -# Initialize variables so that we can declare files locally. - -# FIXME: If Visual C++ users use Makefile.am, this should go into -# pkginclude_HEADERS with proper AM_CONDITIONALization. Otherwise -# delete this comment. - -# headers which are not installed -# (see include/include.am for more) -# - -# documentation which is not installed -# - -# other makefiles -# :GOTCHA: deliberately we do not include 'Makefile' - -# files used by makefiles other than Makefile.am -# -EXTRA_DIST = $(am__append_1) gc_cpp.cpp README.QUICK TODO BCC_MAKEFILE \ - NT_MAKEFILE OS2_MAKEFILE PCR-Makefile digimars.mak \ - EMX_MAKEFILE Makefile.direct SMakefile.amiga WCC_MAKEFILE \ - autogen.sh NT_STATIC_THREADS_MAKEFILE \ - NT_X64_STATIC_THREADS_MAKEFILE NT_X64_THREADS_MAKEFILE \ - CMakeLists.txt tests/CMakeLists.txt tools/add_gc_prefix.c \ - tools/gcname.c tools/if_mach.c tools/if_not_there.c \ - tools/setjmp_t.c tools/threadlibs.c gc.mak extra/MacOS.c \ - extra/AmigaOS.c extra/symbian/global_end.cpp \ - extra/symbian/global_start.cpp \ - extra/symbian/init_global_static_roots.cpp extra/symbian.cpp \ - build/s60v3/bld.inf build/s60v3/libgc.mmp \ - extra/Mac_files/datastart.c extra/Mac_files/dataend.c \ - extra/Mac_files/MacOS_config.h include/private/msvc_dbg.h \ - extra/msvc_dbg.c tools/callprocs.sh cord/tests/de.c \ - cord/tests/de_cmds.h cord/tests/de_win.c cord/tests/de_win.h \ - cord/tests/de_win.rc - -# C Library -# --------- -lib_LTLIBRARIES = libgc.la $(am__append_8) libcord.la - -# unprefixed header -include_HEADERS = $(am__append_10) include/extra/gc.h - -# installed headers -# -pkginclude_HEADERS = $(am__append_9) include/gc.h \ - include/gc_allocator.h include/gc_backptr.h \ - include/gc_config_macros.h include/gc_disclaim.h \ - include/gc_gcj.h include/gc_inline.h include/gc_mark.h \ - include/gc_pthread_redirects.h include/gc_tiny_fl.h \ - include/gc_typed.h include/gc_version.h include/javaxfc.h \ - include/leak_detector.h include/weakpointer.h include/cord.h \ - include/cord_pos.h include/ec.h - -# headers which are not installed -# -dist_noinst_HEADERS = include/cord.h include/cord_pos.h include/ec.h \ - include/new_gc_alloc.h include/private/darwin_semaphore.h \ - include/private/darwin_stop_world.h include/private/dbg_mlc.h \ - include/private/gc_hdrs.h include/private/gc_locks.h \ - include/private/gc_pmark.h include/private/gc_priv.h \ - include/private/gcconfig.h include/private/msvc_dbg.h \ - include/private/pthread_stop_world.h \ - include/private/pthread_support.h include/private/specific.h \ - include/private/thread_local_alloc.h -check_LTLIBRARIES = libstaticrootslib_test.la \ - libstaticrootslib2_test.la -pkgconfigdir = $(libdir)/pkgconfig -pkgconfig_DATA = bdw-gc.pc -@SINGLE_GC_OBJ_FALSE@libgc_la_SOURCES = allchblk.c alloc.c blacklst.c \ -@SINGLE_GC_OBJ_FALSE@ checksums.c dbg_mlc.c dyn_load.c \ -@SINGLE_GC_OBJ_FALSE@ finalize.c gc_dlopen.c gcj_mlc.c \ -@SINGLE_GC_OBJ_FALSE@ headers.c mach_dep.c malloc.c mallocx.c \ -@SINGLE_GC_OBJ_FALSE@ mark.c mark_rts.c misc.c new_hblk.c \ -@SINGLE_GC_OBJ_FALSE@ obj_map.c os_dep.c pcr_interface.c \ -@SINGLE_GC_OBJ_FALSE@ ptr_chck.c real_malloc.c reclaim.c \ -@SINGLE_GC_OBJ_FALSE@ specific.c stubborn.c \ -@SINGLE_GC_OBJ_FALSE@ thread_local_alloc.c typd_mlc.c \ -@SINGLE_GC_OBJ_FALSE@ $(am__append_2) $(am__append_3) \ -@SINGLE_GC_OBJ_FALSE@ $(am__append_4) $(am__append_5) \ -@SINGLE_GC_OBJ_FALSE@ $(am__append_6) $(am__append_7) -@SINGLE_GC_OBJ_TRUE@libgc_la_SOURCES = extra/gc.c $(am__append_2) \ -@SINGLE_GC_OBJ_TRUE@ $(am__append_3) $(am__append_4) \ -@SINGLE_GC_OBJ_TRUE@ $(am__append_5) $(am__append_6) \ -@SINGLE_GC_OBJ_TRUE@ $(am__append_7) -@NEED_ATOMIC_OPS_ASM_TRUE@nodist_libgc_la_SOURCES = libatomic_ops/src/atomic_ops_sysdeps.S -@USE_INTERNAL_LIBATOMIC_OPS_TRUE@nodist_libgc_la_SOURCES = libatomic_ops/src/atomic_ops.c - -# Include THREADDLLIBS here to ensure that the correct versions of -# linuxthread semaphore functions get linked: -libgc_la_LIBADD = @addobjs@ $(THREADDLLIBS) $(UNWINDLIBS) $(ATOMIC_OPS_LIBS) -libgc_la_DEPENDENCIES = @addobjs@ -libgc_la_LDFLAGS = $(extra_ldflags_libgc) -version-info 1:3:0 -no-undefined -EXTRA_libgc_la_SOURCES = ia64_save_regs_in_stack.s sparc_mach_dep.S \ - sparc_netbsd_mach_dep.s sparc_sunos4_mach_dep.s - -@CPLUSPLUS_TRUE@libgccpp_la_SOURCES = gc_cpp.cc -@CPLUSPLUS_TRUE@libgccpp_la_LIBADD = ./libgc.la -@CPLUSPLUS_TRUE@libgccpp_la_LDFLAGS = -version-info 1:3:0 -no-undefined - -# Misc -# ---- -AM_CXXFLAGS = @GC_CFLAGS@ -@ASM_WITH_CPP_UNSUPPORTED_FALSE@ASM_CPP_OPTIONS = -Wp,-P -x assembler-with-cpp - -#all_objs = @addobjs@ $(libgc_la_OBJECTS) -#$(all_objs) : include/private/gcconfig.h include/private/gc_priv.h \ -#include/private/gc_hdrs.h include/gc.h include/gc_gcj.h \ -#include/gc_pthread_redirects.h include/gc_config_macros.h \ -#include/private/thread_local_alloc.h include/private_support.h \ -#include/private/pthread_stop_world.h \ -#include/gc_mark.h @addincludes@ -@ASM_WITH_CPP_UNSUPPORTED_TRUE@ASM_CPP_OPTIONS = -libcord_la_LIBADD = $(top_builddir)/libgc.la -libcord_la_LDFLAGS = -version-info 1:3:0 -no-undefined -libcord_la_CPPFLAGS = $(AM_CPPFLAGS) -libcord_la_SOURCES = \ - cord/cordbscs.c \ - cord/cordprnt.c \ - cord/cordxtra.c - -cordtest_SOURCES = cord/tests/cordtest.c -cordtest_LDADD = $(top_builddir)/libgc.la $(top_builddir)/libcord.la - -# Common libs to _LDADD for all tests. -test_ldadd = $(top_builddir)/libgc.la $(EXTRA_TEST_LIBS) -gctest_SOURCES = tests/test.c -gctest_LDADD = $(test_ldadd) $(am__append_11) -gctest_DEPENDENCIES = $(top_builddir)/libgc.la -leaktest_SOURCES = tests/leak_test.c -leaktest_LDADD = $(test_ldadd) -middletest_SOURCES = tests/middle.c -middletest_LDADD = $(test_ldadd) -smashtest_SOURCES = tests/smash_test.c -smashtest_LDADD = $(test_ldadd) -hugetest_SOURCES = tests/huge_test.c -hugetest_LDADD = $(test_ldadd) -realloc_test_SOURCES = tests/realloc_test.c -realloc_test_LDADD = $(test_ldadd) -staticrootstest_SOURCES = tests/staticrootstest.c -staticrootstest_CFLAGS = -DSTATICROOTSLIB2 -staticrootstest_LDADD = $(test_ldadd) libstaticrootslib_test.la \ - libstaticrootslib2_test.la - -libstaticrootslib_test_la_SOURCES = tests/staticrootslib.c -libstaticrootslib_test_la_LIBADD = $(test_ldadd) -libstaticrootslib_test_la_LDFLAGS = -version-info 1:3:0 -no-undefined \ - -rpath /nowhere - -libstaticrootslib_test_la_DEPENDENCIES = $(top_builddir)/libgc.la -libstaticrootslib2_test_la_SOURCES = tests/staticrootslib.c -libstaticrootslib2_test_la_LIBADD = $(test_ldadd) -libstaticrootslib2_test_la_CFLAGS = -DSTATICROOTSLIB2 -libstaticrootslib2_test_la_LDFLAGS = -version-info 1:3:0 -no-undefined \ - -rpath /nowhere - -@KEEP_BACK_PTRS_TRUE@tracetest_SOURCES = tests/trace_test.c -@KEEP_BACK_PTRS_TRUE@tracetest_LDADD = $(test_ldadd) -@THREADS_TRUE@threadleaktest_SOURCES = tests/thread_leak_test.c -@THREADS_TRUE@threadleaktest_LDADD = $(test_ldadd) $(THREADDLLIBS) -@THREADS_TRUE@threadkey_test_SOURCES = tests/threadkey_test.c -@THREADS_TRUE@threadkey_test_LDADD = $(test_ldadd) $(THREADDLLIBS) -@THREADS_TRUE@subthreadcreate_test_SOURCES = tests/subthread_create.c -@THREADS_TRUE@subthreadcreate_test_LDADD = $(test_ldadd) $(THREADDLLIBS) -@THREADS_TRUE@initsecondarythread_test_SOURCES = tests/initsecondarythread.c -@THREADS_TRUE@initsecondarythread_test_LDADD = $(test_ldadd) $(THREADDLLIBS) -@CPLUSPLUS_TRUE@test_cpp_SOURCES = tests/test_cpp.cc -@AVOID_CPP_LIB_FALSE@@CPLUSPLUS_TRUE@test_cpp_LDADD = libgccpp.la $(test_ldadd) $(CXXLIBS) -@AVOID_CPP_LIB_TRUE@@CPLUSPLUS_TRUE@test_cpp_LDADD = gc_cpp.o $(test_ldadd) $(CXXLIBS) -@ENABLE_DISCLAIM_TRUE@disclaim_test_SOURCES = tests/disclaim_test.c -@ENABLE_DISCLAIM_TRUE@disclaim_test_LDADD = $(test_ldadd) \ -@ENABLE_DISCLAIM_TRUE@ $(am__append_20) -@ENABLE_DISCLAIM_TRUE@disclaim_bench_SOURCES = tests/disclaim_bench.c -@ENABLE_DISCLAIM_TRUE@disclaim_bench_LDADD = $(test_ldadd) - -# installed documentation -# -dist_pkgdata_DATA = \ - AUTHORS \ - README.md \ - doc/README.DGUX386 \ - doc/README.Mac \ - doc/README.OS2 \ - doc/README.amiga \ - doc/README.arm.cross \ - doc/README.autoconf \ - doc/README.cmake \ - doc/README.cords \ - doc/README.darwin \ - doc/README.environment \ - doc/README.ews4800 \ - doc/README.hp \ - doc/README.linux \ - doc/README.macros \ - doc/README.rs6000 \ - doc/README.sgi \ - doc/README.solaris2 \ - doc/README.symbian \ - doc/README.uts \ - doc/README.win32 \ - doc/README.win64 \ - doc/debugging.html \ - doc/finalization.html \ - doc/gc.man \ - doc/gcdescr.html \ - doc/gcinterface.html \ - doc/leak.html \ - doc/overview.html \ - doc/porting.html \ - doc/scale.html \ - doc/simple_example.html \ - doc/tree.html - -all: all-recursive - -.SUFFIXES: -.SUFFIXES: .S .c .cc .lo .log .o .obj .s .test .test$(EXEEXT) .trs -am--refresh: Makefile - @: -$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(srcdir)/include/include.am $(srcdir)/cord/cord.am $(srcdir)/tests/tests.am $(srcdir)/doc/doc.am $(am__configure_deps) - @for dep in $?; do \ - case '$(am__configure_deps)' in \ - *$$dep*) \ - echo ' cd $(srcdir) && $(AUTOMAKE) --foreign'; \ - $(am__cd) $(srcdir) && $(AUTOMAKE) --foreign \ - && exit 0; \ - exit 1;; \ - esac; \ - done; \ - echo ' cd $(top_srcdir) && $(AUTOMAKE) --foreign Makefile'; \ - $(am__cd) $(top_srcdir) && \ - $(AUTOMAKE) --foreign Makefile -Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status - @case '$?' in \ - *config.status*) \ - echo ' $(SHELL) ./config.status'; \ - $(SHELL) ./config.status;; \ - *) \ - echo ' cd $(top_builddir) && $(SHELL) ./config.status $@ $(am__depfiles_maybe)'; \ - cd $(top_builddir) && $(SHELL) ./config.status $@ $(am__depfiles_maybe);; \ - esac; -$(srcdir)/include/include.am $(srcdir)/cord/cord.am $(srcdir)/tests/tests.am $(srcdir)/doc/doc.am $(am__empty): - -$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) - $(SHELL) ./config.status --recheck - -$(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) - $(am__cd) $(srcdir) && $(AUTOCONF) -$(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) - $(am__cd) $(srcdir) && $(ACLOCAL) $(ACLOCAL_AMFLAGS) -$(am__aclocal_m4_deps): - -include/config.h: include/stamp-h1 - @test -f $@ || rm -f include/stamp-h1 - @test -f $@ || $(MAKE) $(AM_MAKEFLAGS) include/stamp-h1 - -include/stamp-h1: $(top_srcdir)/include/config.h.in $(top_builddir)/config.status - @rm -f include/stamp-h1 - cd $(top_builddir) && $(SHELL) ./config.status include/config.h -$(top_srcdir)/include/config.h.in: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) - ($(am__cd) $(top_srcdir) && $(AUTOHEADER)) - rm -f include/stamp-h1 - touch $@ - -distclean-hdr: - -rm -f include/config.h include/stamp-h1 -bdw-gc.pc: $(top_builddir)/config.status $(srcdir)/bdw-gc.pc.in - cd $(top_builddir) && $(SHELL) ./config.status $@ - -clean-checkLTLIBRARIES: - -test -z "$(check_LTLIBRARIES)" || rm -f $(check_LTLIBRARIES) - @list='$(check_LTLIBRARIES)'; \ - locs=`for p in $$list; do echo $$p; done | \ - sed 's|^[^/]*$$|.|; s|/[^/]*$$||; s|$$|/so_locations|' | \ - sort -u`; \ - test -z "$$locs" || { \ - echo rm -f $${locs}; \ - rm -f $${locs}; \ - } - -install-libLTLIBRARIES: $(lib_LTLIBRARIES) - @$(NORMAL_INSTALL) - @list='$(lib_LTLIBRARIES)'; test -n "$(libdir)" || list=; \ - list2=; for p in $$list; do \ - if test -f $$p; then \ - list2="$$list2 $$p"; \ - else :; fi; \ - done; \ - test -z "$$list2" || { \ - echo " $(MKDIR_P) '$(DESTDIR)$(libdir)'"; \ - $(MKDIR_P) "$(DESTDIR)$(libdir)" || exit 1; \ - echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL) $(INSTALL_STRIP_FLAG) $$list2 '$(DESTDIR)$(libdir)'"; \ - $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL) $(INSTALL_STRIP_FLAG) $$list2 "$(DESTDIR)$(libdir)"; \ - } - -uninstall-libLTLIBRARIES: - @$(NORMAL_UNINSTALL) - @list='$(lib_LTLIBRARIES)'; test -n "$(libdir)" || list=; \ - for p in $$list; do \ - $(am__strip_dir) \ - echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f '$(DESTDIR)$(libdir)/$$f'"; \ - $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f "$(DESTDIR)$(libdir)/$$f"; \ - done - -clean-libLTLIBRARIES: - -test -z "$(lib_LTLIBRARIES)" || rm -f $(lib_LTLIBRARIES) - @list='$(lib_LTLIBRARIES)'; \ - locs=`for p in $$list; do echo $$p; done | \ - sed 's|^[^/]*$$|.|; s|/[^/]*$$||; s|$$|/so_locations|' | \ - sort -u`; \ - test -z "$$locs" || { \ - echo rm -f $${locs}; \ - rm -f $${locs}; \ - } -cord/$(am__dirstamp): - @$(MKDIR_P) cord - @: > cord/$(am__dirstamp) -cord/$(DEPDIR)/$(am__dirstamp): - @$(MKDIR_P) cord/$(DEPDIR) - @: > cord/$(DEPDIR)/$(am__dirstamp) -cord/libcord_la-cordbscs.lo: cord/$(am__dirstamp) \ - cord/$(DEPDIR)/$(am__dirstamp) -cord/libcord_la-cordprnt.lo: cord/$(am__dirstamp) \ - cord/$(DEPDIR)/$(am__dirstamp) -cord/libcord_la-cordxtra.lo: cord/$(am__dirstamp) \ - cord/$(DEPDIR)/$(am__dirstamp) - -libcord.la: $(libcord_la_OBJECTS) $(libcord_la_DEPENDENCIES) $(EXTRA_libcord_la_DEPENDENCIES) - $(AM_V_CCLD)$(libcord_la_LINK) -rpath $(libdir) $(libcord_la_OBJECTS) $(libcord_la_LIBADD) $(LIBS) -extra/$(am__dirstamp): - @$(MKDIR_P) extra - @: > extra/$(am__dirstamp) -extra/$(DEPDIR)/$(am__dirstamp): - @$(MKDIR_P) extra/$(DEPDIR) - @: > extra/$(DEPDIR)/$(am__dirstamp) -extra/gc.lo: extra/$(am__dirstamp) extra/$(DEPDIR)/$(am__dirstamp) -libatomic_ops/src/$(am__dirstamp): - @$(MKDIR_P) libatomic_ops/src - @: > libatomic_ops/src/$(am__dirstamp) -libatomic_ops/src/$(DEPDIR)/$(am__dirstamp): - @$(MKDIR_P) libatomic_ops/src/$(DEPDIR) - @: > libatomic_ops/src/$(DEPDIR)/$(am__dirstamp) -libatomic_ops/src/atomic_ops_sysdeps.lo: \ - libatomic_ops/src/$(am__dirstamp) \ - libatomic_ops/src/$(DEPDIR)/$(am__dirstamp) -libatomic_ops/src/atomic_ops.lo: libatomic_ops/src/$(am__dirstamp) \ - libatomic_ops/src/$(DEPDIR)/$(am__dirstamp) - -libgc.la: $(libgc_la_OBJECTS) $(libgc_la_DEPENDENCIES) $(EXTRA_libgc_la_DEPENDENCIES) - $(AM_V_CCLD)$(libgc_la_LINK) -rpath $(libdir) $(libgc_la_OBJECTS) $(libgc_la_LIBADD) $(LIBS) - -libgccpp.la: $(libgccpp_la_OBJECTS) $(libgccpp_la_DEPENDENCIES) $(EXTRA_libgccpp_la_DEPENDENCIES) - $(AM_V_CXXLD)$(libgccpp_la_LINK) $(am_libgccpp_la_rpath) $(libgccpp_la_OBJECTS) $(libgccpp_la_LIBADD) $(LIBS) -tests/$(am__dirstamp): - @$(MKDIR_P) tests - @: > tests/$(am__dirstamp) -tests/$(DEPDIR)/$(am__dirstamp): - @$(MKDIR_P) tests/$(DEPDIR) - @: > tests/$(DEPDIR)/$(am__dirstamp) -tests/libstaticrootslib2_test_la-staticrootslib.lo: \ - tests/$(am__dirstamp) tests/$(DEPDIR)/$(am__dirstamp) - -libstaticrootslib2_test.la: $(libstaticrootslib2_test_la_OBJECTS) $(libstaticrootslib2_test_la_DEPENDENCIES) $(EXTRA_libstaticrootslib2_test_la_DEPENDENCIES) - $(AM_V_CCLD)$(libstaticrootslib2_test_la_LINK) $(libstaticrootslib2_test_la_OBJECTS) $(libstaticrootslib2_test_la_LIBADD) $(LIBS) -tests/staticrootslib.lo: tests/$(am__dirstamp) \ - tests/$(DEPDIR)/$(am__dirstamp) - -libstaticrootslib_test.la: $(libstaticrootslib_test_la_OBJECTS) $(libstaticrootslib_test_la_DEPENDENCIES) $(EXTRA_libstaticrootslib_test_la_DEPENDENCIES) - $(AM_V_CCLD)$(libstaticrootslib_test_la_LINK) $(libstaticrootslib_test_la_OBJECTS) $(libstaticrootslib_test_la_LIBADD) $(LIBS) - -clean-checkPROGRAMS: - @list='$(check_PROGRAMS)'; test -n "$$list" || exit 0; \ - echo " rm -f" $$list; \ - rm -f $$list || exit $$?; \ - test -n "$(EXEEXT)" || exit 0; \ - list=`for p in $$list; do echo "$$p"; done | sed 's/$(EXEEXT)$$//'`; \ - echo " rm -f" $$list; \ - rm -f $$list -cord/tests/$(am__dirstamp): - @$(MKDIR_P) cord/tests - @: > cord/tests/$(am__dirstamp) -cord/tests/$(DEPDIR)/$(am__dirstamp): - @$(MKDIR_P) cord/tests/$(DEPDIR) - @: > cord/tests/$(DEPDIR)/$(am__dirstamp) -cord/tests/cordtest.$(OBJEXT): cord/tests/$(am__dirstamp) \ - cord/tests/$(DEPDIR)/$(am__dirstamp) - -cordtest$(EXEEXT): $(cordtest_OBJECTS) $(cordtest_DEPENDENCIES) $(EXTRA_cordtest_DEPENDENCIES) - @rm -f cordtest$(EXEEXT) - $(AM_V_CCLD)$(LINK) $(cordtest_OBJECTS) $(cordtest_LDADD) $(LIBS) -tests/disclaim_bench.$(OBJEXT): tests/$(am__dirstamp) \ - tests/$(DEPDIR)/$(am__dirstamp) - -disclaim_bench$(EXEEXT): $(disclaim_bench_OBJECTS) $(disclaim_bench_DEPENDENCIES) $(EXTRA_disclaim_bench_DEPENDENCIES) - @rm -f disclaim_bench$(EXEEXT) - $(AM_V_CCLD)$(LINK) $(disclaim_bench_OBJECTS) $(disclaim_bench_LDADD) $(LIBS) -tests/disclaim_test.$(OBJEXT): tests/$(am__dirstamp) \ - tests/$(DEPDIR)/$(am__dirstamp) - -disclaim_test$(EXEEXT): $(disclaim_test_OBJECTS) $(disclaim_test_DEPENDENCIES) $(EXTRA_disclaim_test_DEPENDENCIES) - @rm -f disclaim_test$(EXEEXT) - $(AM_V_CCLD)$(LINK) $(disclaim_test_OBJECTS) $(disclaim_test_LDADD) $(LIBS) -tests/test.$(OBJEXT): tests/$(am__dirstamp) \ - tests/$(DEPDIR)/$(am__dirstamp) - -gctest$(EXEEXT): $(gctest_OBJECTS) $(gctest_DEPENDENCIES) $(EXTRA_gctest_DEPENDENCIES) - @rm -f gctest$(EXEEXT) - $(AM_V_CCLD)$(LINK) $(gctest_OBJECTS) $(gctest_LDADD) $(LIBS) -tests/huge_test.$(OBJEXT): tests/$(am__dirstamp) \ - tests/$(DEPDIR)/$(am__dirstamp) - -hugetest$(EXEEXT): $(hugetest_OBJECTS) $(hugetest_DEPENDENCIES) $(EXTRA_hugetest_DEPENDENCIES) - @rm -f hugetest$(EXEEXT) - $(AM_V_CCLD)$(LINK) $(hugetest_OBJECTS) $(hugetest_LDADD) $(LIBS) -tests/initsecondarythread.$(OBJEXT): tests/$(am__dirstamp) \ - tests/$(DEPDIR)/$(am__dirstamp) - -initsecondarythread_test$(EXEEXT): $(initsecondarythread_test_OBJECTS) $(initsecondarythread_test_DEPENDENCIES) $(EXTRA_initsecondarythread_test_DEPENDENCIES) - @rm -f initsecondarythread_test$(EXEEXT) - $(AM_V_CCLD)$(LINK) $(initsecondarythread_test_OBJECTS) $(initsecondarythread_test_LDADD) $(LIBS) -tests/leak_test.$(OBJEXT): tests/$(am__dirstamp) \ - tests/$(DEPDIR)/$(am__dirstamp) - -leaktest$(EXEEXT): $(leaktest_OBJECTS) $(leaktest_DEPENDENCIES) $(EXTRA_leaktest_DEPENDENCIES) - @rm -f leaktest$(EXEEXT) - $(AM_V_CCLD)$(LINK) $(leaktest_OBJECTS) $(leaktest_LDADD) $(LIBS) -tests/middle.$(OBJEXT): tests/$(am__dirstamp) \ - tests/$(DEPDIR)/$(am__dirstamp) - -middletest$(EXEEXT): $(middletest_OBJECTS) $(middletest_DEPENDENCIES) $(EXTRA_middletest_DEPENDENCIES) - @rm -f middletest$(EXEEXT) - $(AM_V_CCLD)$(LINK) $(middletest_OBJECTS) $(middletest_LDADD) $(LIBS) -tests/realloc_test.$(OBJEXT): tests/$(am__dirstamp) \ - tests/$(DEPDIR)/$(am__dirstamp) - -realloc_test$(EXEEXT): $(realloc_test_OBJECTS) $(realloc_test_DEPENDENCIES) $(EXTRA_realloc_test_DEPENDENCIES) - @rm -f realloc_test$(EXEEXT) - $(AM_V_CCLD)$(LINK) $(realloc_test_OBJECTS) $(realloc_test_LDADD) $(LIBS) -tests/smash_test.$(OBJEXT): tests/$(am__dirstamp) \ - tests/$(DEPDIR)/$(am__dirstamp) - -smashtest$(EXEEXT): $(smashtest_OBJECTS) $(smashtest_DEPENDENCIES) $(EXTRA_smashtest_DEPENDENCIES) - @rm -f smashtest$(EXEEXT) - $(AM_V_CCLD)$(LINK) $(smashtest_OBJECTS) $(smashtest_LDADD) $(LIBS) -tests/staticrootstest-staticrootstest.$(OBJEXT): \ - tests/$(am__dirstamp) tests/$(DEPDIR)/$(am__dirstamp) - -staticrootstest$(EXEEXT): $(staticrootstest_OBJECTS) $(staticrootstest_DEPENDENCIES) $(EXTRA_staticrootstest_DEPENDENCIES) - @rm -f staticrootstest$(EXEEXT) - $(AM_V_CCLD)$(staticrootstest_LINK) $(staticrootstest_OBJECTS) $(staticrootstest_LDADD) $(LIBS) -tests/subthread_create.$(OBJEXT): tests/$(am__dirstamp) \ - tests/$(DEPDIR)/$(am__dirstamp) - -subthreadcreate_test$(EXEEXT): $(subthreadcreate_test_OBJECTS) $(subthreadcreate_test_DEPENDENCIES) $(EXTRA_subthreadcreate_test_DEPENDENCIES) - @rm -f subthreadcreate_test$(EXEEXT) - $(AM_V_CCLD)$(LINK) $(subthreadcreate_test_OBJECTS) $(subthreadcreate_test_LDADD) $(LIBS) -tests/test_cpp.$(OBJEXT): tests/$(am__dirstamp) \ - tests/$(DEPDIR)/$(am__dirstamp) - -test_cpp$(EXEEXT): $(test_cpp_OBJECTS) $(test_cpp_DEPENDENCIES) $(EXTRA_test_cpp_DEPENDENCIES) - @rm -f test_cpp$(EXEEXT) - $(AM_V_CXXLD)$(CXXLINK) $(test_cpp_OBJECTS) $(test_cpp_LDADD) $(LIBS) -tests/threadkey_test.$(OBJEXT): tests/$(am__dirstamp) \ - tests/$(DEPDIR)/$(am__dirstamp) - -threadkey_test$(EXEEXT): $(threadkey_test_OBJECTS) $(threadkey_test_DEPENDENCIES) $(EXTRA_threadkey_test_DEPENDENCIES) - @rm -f threadkey_test$(EXEEXT) - $(AM_V_CCLD)$(LINK) $(threadkey_test_OBJECTS) $(threadkey_test_LDADD) $(LIBS) -tests/thread_leak_test.$(OBJEXT): tests/$(am__dirstamp) \ - tests/$(DEPDIR)/$(am__dirstamp) - -threadleaktest$(EXEEXT): $(threadleaktest_OBJECTS) $(threadleaktest_DEPENDENCIES) $(EXTRA_threadleaktest_DEPENDENCIES) - @rm -f threadleaktest$(EXEEXT) - $(AM_V_CCLD)$(LINK) $(threadleaktest_OBJECTS) $(threadleaktest_LDADD) $(LIBS) -tests/trace_test.$(OBJEXT): tests/$(am__dirstamp) \ - tests/$(DEPDIR)/$(am__dirstamp) - -tracetest$(EXEEXT): $(tracetest_OBJECTS) $(tracetest_DEPENDENCIES) $(EXTRA_tracetest_DEPENDENCIES) - @rm -f tracetest$(EXEEXT) - $(AM_V_CCLD)$(LINK) $(tracetest_OBJECTS) $(tracetest_LDADD) $(LIBS) - -mostlyclean-compile: - -rm -f *.$(OBJEXT) - -rm -f cord/*.$(OBJEXT) - -rm -f cord/*.lo - -rm -f cord/tests/*.$(OBJEXT) - -rm -f extra/*.$(OBJEXT) - -rm -f extra/*.lo - -rm -f libatomic_ops/src/*.$(OBJEXT) - -rm -f libatomic_ops/src/*.lo - -rm -f tests/*.$(OBJEXT) - -rm -f tests/*.lo - -distclean-compile: - -rm -f *.tab.c - -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/allchblk.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/alloc.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/backgraph.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/blacklst.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/checksums.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/darwin_stop_world.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/dbg_mlc.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/dyn_load.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/finalize.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fnlz_mlc.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gc_cpp.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gc_dlopen.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gcj_mlc.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/headers.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/mach_dep.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/malloc.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/mallocx.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/mark.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/mark_rts.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/misc.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/new_hblk.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/obj_map.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/os_dep.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/pcr_interface.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/pthread_start.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/pthread_stop_world.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/pthread_support.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ptr_chck.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/real_malloc.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/reclaim.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/sparc_mach_dep.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/specific.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/stubborn.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/thread_local_alloc.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/typd_mlc.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/win32_threads.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@cord/$(DEPDIR)/libcord_la-cordbscs.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@cord/$(DEPDIR)/libcord_la-cordprnt.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@cord/$(DEPDIR)/libcord_la-cordxtra.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@cord/tests/$(DEPDIR)/cordtest.Po@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@extra/$(DEPDIR)/gc.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@libatomic_ops/src/$(DEPDIR)/atomic_ops.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@libatomic_ops/src/$(DEPDIR)/atomic_ops_sysdeps.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@tests/$(DEPDIR)/disclaim_bench.Po@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@tests/$(DEPDIR)/disclaim_test.Po@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@tests/$(DEPDIR)/huge_test.Po@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@tests/$(DEPDIR)/initsecondarythread.Po@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@tests/$(DEPDIR)/leak_test.Po@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@tests/$(DEPDIR)/libstaticrootslib2_test_la-staticrootslib.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@tests/$(DEPDIR)/middle.Po@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@tests/$(DEPDIR)/realloc_test.Po@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@tests/$(DEPDIR)/smash_test.Po@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@tests/$(DEPDIR)/staticrootslib.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@tests/$(DEPDIR)/staticrootstest-staticrootstest.Po@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@tests/$(DEPDIR)/subthread_create.Po@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@tests/$(DEPDIR)/test.Po@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@tests/$(DEPDIR)/test_cpp.Po@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@tests/$(DEPDIR)/thread_leak_test.Po@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@tests/$(DEPDIR)/threadkey_test.Po@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@tests/$(DEPDIR)/trace_test.Po@am__quote@ - -.S.o: -@am__fastdepCCAS_TRUE@ $(AM_V_CPPAS)depbase=`echo $@ | sed 's|[^/]*$$|$(DEPDIR)/&|;s|\.o$$||'`;\ -@am__fastdepCCAS_TRUE@ $(CPPASCOMPILE) -MT $@ -MD -MP -MF $$depbase.Tpo -c -o $@ $< &&\ -@am__fastdepCCAS_TRUE@ $(am__mv) $$depbase.Tpo $$depbase.Po -@AMDEP_TRUE@@am__fastdepCCAS_FALSE@ $(AM_V_CPPAS)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ -@AMDEP_TRUE@@am__fastdepCCAS_FALSE@ DEPDIR=$(DEPDIR) $(CCASDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCCAS_FALSE@ $(AM_V_CPPAS@am__nodep@)$(CPPASCOMPILE) -c -o $@ $< - -.S.obj: -@am__fastdepCCAS_TRUE@ $(AM_V_CPPAS)depbase=`echo $@ | sed 's|[^/]*$$|$(DEPDIR)/&|;s|\.obj$$||'`;\ -@am__fastdepCCAS_TRUE@ $(CPPASCOMPILE) -MT $@ -MD -MP -MF $$depbase.Tpo -c -o $@ `$(CYGPATH_W) '$<'` &&\ -@am__fastdepCCAS_TRUE@ $(am__mv) $$depbase.Tpo $$depbase.Po -@AMDEP_TRUE@@am__fastdepCCAS_FALSE@ $(AM_V_CPPAS)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ -@AMDEP_TRUE@@am__fastdepCCAS_FALSE@ DEPDIR=$(DEPDIR) $(CCASDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCCAS_FALSE@ $(AM_V_CPPAS@am__nodep@)$(CPPASCOMPILE) -c -o $@ `$(CYGPATH_W) '$<'` - -.c.o: -@am__fastdepCC_TRUE@ $(AM_V_CC)depbase=`echo $@ | sed 's|[^/]*$$|$(DEPDIR)/&|;s|\.o$$||'`;\ -@am__fastdepCC_TRUE@ $(COMPILE) -MT $@ -MD -MP -MF $$depbase.Tpo -c -o $@ $< &&\ -@am__fastdepCC_TRUE@ $(am__mv) $$depbase.Tpo $$depbase.Po -@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ -@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(COMPILE) -c -o $@ $< - -.c.obj: -@am__fastdepCC_TRUE@ $(AM_V_CC)depbase=`echo $@ | sed 's|[^/]*$$|$(DEPDIR)/&|;s|\.obj$$||'`;\ -@am__fastdepCC_TRUE@ $(COMPILE) -MT $@ -MD -MP -MF $$depbase.Tpo -c -o $@ `$(CYGPATH_W) '$<'` &&\ -@am__fastdepCC_TRUE@ $(am__mv) $$depbase.Tpo $$depbase.Po -@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ -@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(COMPILE) -c -o $@ `$(CYGPATH_W) '$<'` - -.c.lo: -@am__fastdepCC_TRUE@ $(AM_V_CC)depbase=`echo $@ | sed 's|[^/]*$$|$(DEPDIR)/&|;s|\.lo$$||'`;\ -@am__fastdepCC_TRUE@ $(LTCOMPILE) -MT $@ -MD -MP -MF $$depbase.Tpo -c -o $@ $< &&\ -@am__fastdepCC_TRUE@ $(am__mv) $$depbase.Tpo $$depbase.Plo -@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$<' object='$@' libtool=yes @AMDEPBACKSLASH@ -@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LTCOMPILE) -c -o $@ $< - -cord/libcord_la-cordbscs.lo: cord/cordbscs.c -@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcord_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT cord/libcord_la-cordbscs.lo -MD -MP -MF cord/$(DEPDIR)/libcord_la-cordbscs.Tpo -c -o cord/libcord_la-cordbscs.lo `test -f 'cord/cordbscs.c' || echo '$(srcdir)/'`cord/cordbscs.c -@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) cord/$(DEPDIR)/libcord_la-cordbscs.Tpo cord/$(DEPDIR)/libcord_la-cordbscs.Plo -@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cord/cordbscs.c' object='cord/libcord_la-cordbscs.lo' libtool=yes @AMDEPBACKSLASH@ -@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcord_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o cord/libcord_la-cordbscs.lo `test -f 'cord/cordbscs.c' || echo '$(srcdir)/'`cord/cordbscs.c - -cord/libcord_la-cordprnt.lo: cord/cordprnt.c -@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcord_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT cord/libcord_la-cordprnt.lo -MD -MP -MF cord/$(DEPDIR)/libcord_la-cordprnt.Tpo -c -o cord/libcord_la-cordprnt.lo `test -f 'cord/cordprnt.c' || echo '$(srcdir)/'`cord/cordprnt.c -@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) cord/$(DEPDIR)/libcord_la-cordprnt.Tpo cord/$(DEPDIR)/libcord_la-cordprnt.Plo -@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cord/cordprnt.c' object='cord/libcord_la-cordprnt.lo' libtool=yes @AMDEPBACKSLASH@ -@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcord_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o cord/libcord_la-cordprnt.lo `test -f 'cord/cordprnt.c' || echo '$(srcdir)/'`cord/cordprnt.c - -cord/libcord_la-cordxtra.lo: cord/cordxtra.c -@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcord_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT cord/libcord_la-cordxtra.lo -MD -MP -MF cord/$(DEPDIR)/libcord_la-cordxtra.Tpo -c -o cord/libcord_la-cordxtra.lo `test -f 'cord/cordxtra.c' || echo '$(srcdir)/'`cord/cordxtra.c -@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) cord/$(DEPDIR)/libcord_la-cordxtra.Tpo cord/$(DEPDIR)/libcord_la-cordxtra.Plo -@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='cord/cordxtra.c' object='cord/libcord_la-cordxtra.lo' libtool=yes @AMDEPBACKSLASH@ -@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libcord_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o cord/libcord_la-cordxtra.lo `test -f 'cord/cordxtra.c' || echo '$(srcdir)/'`cord/cordxtra.c - -tests/libstaticrootslib2_test_la-staticrootslib.lo: tests/staticrootslib.c -@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(libstaticrootslib2_test_la_CFLAGS) $(CFLAGS) -MT tests/libstaticrootslib2_test_la-staticrootslib.lo -MD -MP -MF tests/$(DEPDIR)/libstaticrootslib2_test_la-staticrootslib.Tpo -c -o tests/libstaticrootslib2_test_la-staticrootslib.lo `test -f 'tests/staticrootslib.c' || echo '$(srcdir)/'`tests/staticrootslib.c -@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) tests/$(DEPDIR)/libstaticrootslib2_test_la-staticrootslib.Tpo tests/$(DEPDIR)/libstaticrootslib2_test_la-staticrootslib.Plo -@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='tests/staticrootslib.c' object='tests/libstaticrootslib2_test_la-staticrootslib.lo' libtool=yes @AMDEPBACKSLASH@ -@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(libstaticrootslib2_test_la_CFLAGS) $(CFLAGS) -c -o tests/libstaticrootslib2_test_la-staticrootslib.lo `test -f 'tests/staticrootslib.c' || echo '$(srcdir)/'`tests/staticrootslib.c - -tests/staticrootstest-staticrootstest.o: tests/staticrootstest.c -@am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(staticrootstest_CFLAGS) $(CFLAGS) -MT tests/staticrootstest-staticrootstest.o -MD -MP -MF tests/$(DEPDIR)/staticrootstest-staticrootstest.Tpo -c -o tests/staticrootstest-staticrootstest.o `test -f 'tests/staticrootstest.c' || echo '$(srcdir)/'`tests/staticrootstest.c -@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) tests/$(DEPDIR)/staticrootstest-staticrootstest.Tpo tests/$(DEPDIR)/staticrootstest-staticrootstest.Po -@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='tests/staticrootstest.c' object='tests/staticrootstest-staticrootstest.o' libtool=no @AMDEPBACKSLASH@ -@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(staticrootstest_CFLAGS) $(CFLAGS) -c -o tests/staticrootstest-staticrootstest.o `test -f 'tests/staticrootstest.c' || echo '$(srcdir)/'`tests/staticrootstest.c - -tests/staticrootstest-staticrootstest.obj: tests/staticrootstest.c -@am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(staticrootstest_CFLAGS) $(CFLAGS) -MT tests/staticrootstest-staticrootstest.obj -MD -MP -MF tests/$(DEPDIR)/staticrootstest-staticrootstest.Tpo -c -o tests/staticrootstest-staticrootstest.obj `if test -f 'tests/staticrootstest.c'; then $(CYGPATH_W) 'tests/staticrootstest.c'; else $(CYGPATH_W) '$(srcdir)/tests/staticrootstest.c'; fi` -@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) tests/$(DEPDIR)/staticrootstest-staticrootstest.Tpo tests/$(DEPDIR)/staticrootstest-staticrootstest.Po -@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='tests/staticrootstest.c' object='tests/staticrootstest-staticrootstest.obj' libtool=no @AMDEPBACKSLASH@ -@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(staticrootstest_CFLAGS) $(CFLAGS) -c -o tests/staticrootstest-staticrootstest.obj `if test -f 'tests/staticrootstest.c'; then $(CYGPATH_W) 'tests/staticrootstest.c'; else $(CYGPATH_W) '$(srcdir)/tests/staticrootstest.c'; fi` - -.cc.o: -@am__fastdepCXX_TRUE@ $(AM_V_CXX)depbase=`echo $@ | sed 's|[^/]*$$|$(DEPDIR)/&|;s|\.o$$||'`;\ -@am__fastdepCXX_TRUE@ $(CXXCOMPILE) -MT $@ -MD -MP -MF $$depbase.Tpo -c -o $@ $< &&\ -@am__fastdepCXX_TRUE@ $(am__mv) $$depbase.Tpo $$depbase.Po -@AMDEP_TRUE@@am__fastdepCXX_FALSE@ $(AM_V_CXX)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ -@AMDEP_TRUE@@am__fastdepCXX_FALSE@ DEPDIR=$(DEPDIR) $(CXXDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCXX_FALSE@ $(AM_V_CXX@am__nodep@)$(CXXCOMPILE) -c -o $@ $< - -.cc.obj: -@am__fastdepCXX_TRUE@ $(AM_V_CXX)depbase=`echo $@ | sed 's|[^/]*$$|$(DEPDIR)/&|;s|\.obj$$||'`;\ -@am__fastdepCXX_TRUE@ $(CXXCOMPILE) -MT $@ -MD -MP -MF $$depbase.Tpo -c -o $@ `$(CYGPATH_W) '$<'` &&\ -@am__fastdepCXX_TRUE@ $(am__mv) $$depbase.Tpo $$depbase.Po -@AMDEP_TRUE@@am__fastdepCXX_FALSE@ $(AM_V_CXX)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ -@AMDEP_TRUE@@am__fastdepCXX_FALSE@ DEPDIR=$(DEPDIR) $(CXXDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCXX_FALSE@ $(AM_V_CXX@am__nodep@)$(CXXCOMPILE) -c -o $@ `$(CYGPATH_W) '$<'` - -.cc.lo: -@am__fastdepCXX_TRUE@ $(AM_V_CXX)depbase=`echo $@ | sed 's|[^/]*$$|$(DEPDIR)/&|;s|\.lo$$||'`;\ -@am__fastdepCXX_TRUE@ $(LTCXXCOMPILE) -MT $@ -MD -MP -MF $$depbase.Tpo -c -o $@ $< &&\ -@am__fastdepCXX_TRUE@ $(am__mv) $$depbase.Tpo $$depbase.Plo -@AMDEP_TRUE@@am__fastdepCXX_FALSE@ $(AM_V_CXX)source='$<' object='$@' libtool=yes @AMDEPBACKSLASH@ -@AMDEP_TRUE@@am__fastdepCXX_FALSE@ DEPDIR=$(DEPDIR) $(CXXDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCXX_FALSE@ $(AM_V_CXX@am__nodep@)$(LTCXXCOMPILE) -c -o $@ $< - -.s.o: - $(AM_V_CCAS)$(CCASCOMPILE) -c -o $@ $< - -.s.obj: - $(AM_V_CCAS)$(CCASCOMPILE) -c -o $@ `$(CYGPATH_W) '$<'` - -mostlyclean-libtool: - -rm -f *.lo - -clean-libtool: - -rm -rf .libs _libs - -rm -rf cord/.libs cord/_libs - -rm -rf extra/.libs extra/_libs - -rm -rf libatomic_ops/src/.libs libatomic_ops/src/_libs - -rm -rf tests/.libs tests/_libs - -distclean-libtool: - -rm -f libtool config.lt -install-dist_pkgdataDATA: $(dist_pkgdata_DATA) - @$(NORMAL_INSTALL) - @list='$(dist_pkgdata_DATA)'; test -n "$(pkgdatadir)" || list=; \ - if test -n "$$list"; then \ - echo " $(MKDIR_P) '$(DESTDIR)$(pkgdatadir)'"; \ - $(MKDIR_P) "$(DESTDIR)$(pkgdatadir)" || exit 1; \ - fi; \ - for p in $$list; do \ - if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ - echo "$$d$$p"; \ - done | $(am__base_list) | \ - while read files; do \ - echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(pkgdatadir)'"; \ - $(INSTALL_DATA) $$files "$(DESTDIR)$(pkgdatadir)" || exit $$?; \ - done - -uninstall-dist_pkgdataDATA: - @$(NORMAL_UNINSTALL) - @list='$(dist_pkgdata_DATA)'; test -n "$(pkgdatadir)" || list=; \ - files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ - dir='$(DESTDIR)$(pkgdatadir)'; $(am__uninstall_files_from_dir) -install-pkgconfigDATA: $(pkgconfig_DATA) - @$(NORMAL_INSTALL) - @list='$(pkgconfig_DATA)'; test -n "$(pkgconfigdir)" || list=; \ - if test -n "$$list"; then \ - echo " $(MKDIR_P) '$(DESTDIR)$(pkgconfigdir)'"; \ - $(MKDIR_P) "$(DESTDIR)$(pkgconfigdir)" || exit 1; \ - fi; \ - for p in $$list; do \ - if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ - echo "$$d$$p"; \ - done | $(am__base_list) | \ - while read files; do \ - echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(pkgconfigdir)'"; \ - $(INSTALL_DATA) $$files "$(DESTDIR)$(pkgconfigdir)" || exit $$?; \ - done - -uninstall-pkgconfigDATA: - @$(NORMAL_UNINSTALL) - @list='$(pkgconfig_DATA)'; test -n "$(pkgconfigdir)" || list=; \ - files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ - dir='$(DESTDIR)$(pkgconfigdir)'; $(am__uninstall_files_from_dir) -install-includeHEADERS: $(include_HEADERS) - @$(NORMAL_INSTALL) - @list='$(include_HEADERS)'; test -n "$(includedir)" || list=; \ - if test -n "$$list"; then \ - echo " $(MKDIR_P) '$(DESTDIR)$(includedir)'"; \ - $(MKDIR_P) "$(DESTDIR)$(includedir)" || exit 1; \ - fi; \ - for p in $$list; do \ - if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ - echo "$$d$$p"; \ - done | $(am__base_list) | \ - while read files; do \ - echo " $(INSTALL_HEADER) $$files '$(DESTDIR)$(includedir)'"; \ - $(INSTALL_HEADER) $$files "$(DESTDIR)$(includedir)" || exit $$?; \ - done - -uninstall-includeHEADERS: - @$(NORMAL_UNINSTALL) - @list='$(include_HEADERS)'; test -n "$(includedir)" || list=; \ - files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ - dir='$(DESTDIR)$(includedir)'; $(am__uninstall_files_from_dir) -install-pkgincludeHEADERS: $(pkginclude_HEADERS) - @$(NORMAL_INSTALL) - @list='$(pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \ - if test -n "$$list"; then \ - echo " $(MKDIR_P) '$(DESTDIR)$(pkgincludedir)'"; \ - $(MKDIR_P) "$(DESTDIR)$(pkgincludedir)" || exit 1; \ - fi; \ - for p in $$list; do \ - if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ - echo "$$d$$p"; \ - done | $(am__base_list) | \ - while read files; do \ - echo " $(INSTALL_HEADER) $$files '$(DESTDIR)$(pkgincludedir)'"; \ - $(INSTALL_HEADER) $$files "$(DESTDIR)$(pkgincludedir)" || exit $$?; \ - done - -uninstall-pkgincludeHEADERS: - @$(NORMAL_UNINSTALL) - @list='$(pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \ - files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ - dir='$(DESTDIR)$(pkgincludedir)'; $(am__uninstall_files_from_dir) - -# This directory's subdirectories are mostly independent; you can cd -# into them and run 'make' without going through this Makefile. -# To change the values of 'make' variables: instead of editing Makefiles, -# (1) if the variable is set in 'config.status', edit 'config.status' -# (which will cause the Makefiles to be regenerated when you run 'make'); -# (2) otherwise, pass the desired values on the 'make' command line. -$(am__recursive_targets): - @fail=; \ - if $(am__make_keepgoing); then \ - failcom='fail=yes'; \ - else \ - failcom='exit 1'; \ - fi; \ - dot_seen=no; \ - target=`echo $@ | sed s/-recursive//`; \ - case "$@" in \ - distclean-* | maintainer-clean-*) list='$(DIST_SUBDIRS)' ;; \ - *) list='$(SUBDIRS)' ;; \ - esac; \ - for subdir in $$list; do \ - echo "Making $$target in $$subdir"; \ - if test "$$subdir" = "."; then \ - dot_seen=yes; \ - local_target="$$target-am"; \ - else \ - local_target="$$target"; \ - fi; \ - ($(am__cd) $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \ - || eval $$failcom; \ - done; \ - if test "$$dot_seen" = "no"; then \ - $(MAKE) $(AM_MAKEFLAGS) "$$target-am" || exit 1; \ - fi; test -z "$$fail" - -ID: $(am__tagged_files) - $(am__define_uniq_tagged_files); mkid -fID $$unique -tags: tags-recursive -TAGS: tags - -tags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) - set x; \ - here=`pwd`; \ - if ($(ETAGS) --etags-include --version) >/dev/null 2>&1; then \ - include_option=--etags-include; \ - empty_fix=.; \ - else \ - include_option=--include; \ - empty_fix=; \ - fi; \ - list='$(SUBDIRS)'; for subdir in $$list; do \ - if test "$$subdir" = .; then :; else \ - test ! -f $$subdir/TAGS || \ - set "$$@" "$$include_option=$$here/$$subdir/TAGS"; \ - fi; \ - done; \ - $(am__define_uniq_tagged_files); \ - shift; \ - if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \ - test -n "$$unique" || unique=$$empty_fix; \ - if test $$# -gt 0; then \ - $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ - "$$@" $$unique; \ - else \ - $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ - $$unique; \ - fi; \ - fi -ctags: ctags-recursive - -CTAGS: ctags -ctags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) - $(am__define_uniq_tagged_files); \ - test -z "$(CTAGS_ARGS)$$unique" \ - || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ - $$unique - -GTAGS: - here=`$(am__cd) $(top_builddir) && pwd` \ - && $(am__cd) $(top_srcdir) \ - && gtags -i $(GTAGS_ARGS) "$$here" -cscope: cscope.files - test ! -s cscope.files \ - || $(CSCOPE) -b -q $(AM_CSCOPEFLAGS) $(CSCOPEFLAGS) -i cscope.files $(CSCOPE_ARGS) -clean-cscope: - -rm -f cscope.files -cscope.files: clean-cscope cscopelist -cscopelist: cscopelist-recursive - -cscopelist-am: $(am__tagged_files) - list='$(am__tagged_files)'; \ - case "$(srcdir)" in \ - [\\/]* | ?:[\\/]*) sdir="$(srcdir)" ;; \ - *) sdir=$(subdir)/$(srcdir) ;; \ - esac; \ - for i in $$list; do \ - if test -f "$$i"; then \ - echo "$(subdir)/$$i"; \ - else \ - echo "$$sdir/$$i"; \ - fi; \ - done >> $(top_builddir)/cscope.files - -distclean-tags: - -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags - -rm -f cscope.out cscope.in.out cscope.po.out cscope.files - -# Recover from deleted '.trs' file; this should ensure that -# "rm -f foo.log; make foo.trs" re-run 'foo.test', and re-create -# both 'foo.log' and 'foo.trs'. Break the recipe in two subshells -# to avoid problems with "make -n". -.log.trs: - rm -f $< $@ - $(MAKE) $(AM_MAKEFLAGS) $< - -# Leading 'am--fnord' is there to ensure the list of targets does not -# expand to empty, as could happen e.g. with make check TESTS=''. -am--fnord $(TEST_LOGS) $(TEST_LOGS:.log=.trs): $(am__force_recheck) -am--force-recheck: - @: - -$(TEST_SUITE_LOG): $(TEST_LOGS) - @$(am__set_TESTS_bases); \ - am__f_ok () { test -f "$$1" && test -r "$$1"; }; \ - redo_bases=`for i in $$bases; do \ - am__f_ok $$i.trs && am__f_ok $$i.log || echo $$i; \ - done`; \ - if test -n "$$redo_bases"; then \ - redo_logs=`for i in $$redo_bases; do echo $$i.log; done`; \ - redo_results=`for i in $$redo_bases; do echo $$i.trs; done`; \ - if $(am__make_dryrun); then :; else \ - rm -f $$redo_logs && rm -f $$redo_results || exit 1; \ - fi; \ - fi; \ - if test -n "$$am__remaking_logs"; then \ - echo "fatal: making $(TEST_SUITE_LOG): possible infinite" \ - "recursion detected" >&2; \ - elif test -n "$$redo_logs"; then \ - am__remaking_logs=yes $(MAKE) $(AM_MAKEFLAGS) $$redo_logs; \ - fi; \ - if $(am__make_dryrun); then :; else \ - st=0; \ - errmsg="fatal: making $(TEST_SUITE_LOG): failed to create"; \ - for i in $$redo_bases; do \ - test -f $$i.trs && test -r $$i.trs \ - || { echo "$$errmsg $$i.trs" >&2; st=1; }; \ - test -f $$i.log && test -r $$i.log \ - || { echo "$$errmsg $$i.log" >&2; st=1; }; \ - done; \ - test $$st -eq 0 || exit 1; \ - fi - @$(am__sh_e_setup); $(am__tty_colors); $(am__set_TESTS_bases); \ - ws='[ ]'; \ - results=`for b in $$bases; do echo $$b.trs; done`; \ - test -n "$$results" || results=/dev/null; \ - all=` grep "^$$ws*:test-result:" $$results | wc -l`; \ - pass=` grep "^$$ws*:test-result:$$ws*PASS" $$results | wc -l`; \ - fail=` grep "^$$ws*:test-result:$$ws*FAIL" $$results | wc -l`; \ - skip=` grep "^$$ws*:test-result:$$ws*SKIP" $$results | wc -l`; \ - xfail=`grep "^$$ws*:test-result:$$ws*XFAIL" $$results | wc -l`; \ - xpass=`grep "^$$ws*:test-result:$$ws*XPASS" $$results | wc -l`; \ - error=`grep "^$$ws*:test-result:$$ws*ERROR" $$results | wc -l`; \ - if test `expr $$fail + $$xpass + $$error` -eq 0; then \ - success=true; \ - else \ - success=false; \ - fi; \ - br='==================='; br=$$br$$br$$br$$br; \ - result_count () \ - { \ - if test x"$$1" = x"--maybe-color"; then \ - maybe_colorize=yes; \ - elif test x"$$1" = x"--no-color"; then \ - maybe_colorize=no; \ - else \ - echo "$@: invalid 'result_count' usage" >&2; exit 4; \ - fi; \ - shift; \ - desc=$$1 count=$$2; \ - if test $$maybe_colorize = yes && test $$count -gt 0; then \ - color_start=$$3 color_end=$$std; \ - else \ - color_start= color_end=; \ - fi; \ - echo "$${color_start}# $$desc $$count$${color_end}"; \ - }; \ - create_testsuite_report () \ - { \ - result_count $$1 "TOTAL:" $$all "$$brg"; \ - result_count $$1 "PASS: " $$pass "$$grn"; \ - result_count $$1 "SKIP: " $$skip "$$blu"; \ - result_count $$1 "XFAIL:" $$xfail "$$lgn"; \ - result_count $$1 "FAIL: " $$fail "$$red"; \ - result_count $$1 "XPASS:" $$xpass "$$red"; \ - result_count $$1 "ERROR:" $$error "$$mgn"; \ - }; \ - { \ - echo "$(PACKAGE_STRING): $(subdir)/$(TEST_SUITE_LOG)" | \ - $(am__rst_title); \ - create_testsuite_report --no-color; \ - echo; \ - echo ".. contents:: :depth: 2"; \ - echo; \ - for b in $$bases; do echo $$b; done \ - | $(am__create_global_log); \ - } >$(TEST_SUITE_LOG).tmp || exit 1; \ - mv $(TEST_SUITE_LOG).tmp $(TEST_SUITE_LOG); \ - if $$success; then \ - col="$$grn"; \ - else \ - col="$$red"; \ - test x"$$VERBOSE" = x || cat $(TEST_SUITE_LOG); \ - fi; \ - echo "$${col}$$br$${std}"; \ - echo "$${col}Testsuite summary for $(PACKAGE_STRING)$${std}"; \ - echo "$${col}$$br$${std}"; \ - create_testsuite_report --maybe-color; \ - echo "$$col$$br$$std"; \ - if $$success; then :; else \ - echo "$${col}See $(subdir)/$(TEST_SUITE_LOG)$${std}"; \ - if test -n "$(PACKAGE_BUGREPORT)"; then \ - echo "$${col}Please report to $(PACKAGE_BUGREPORT)$${std}"; \ - fi; \ - echo "$$col$$br$$std"; \ - fi; \ - $$success || exit 1 - -check-TESTS: - @list='$(RECHECK_LOGS)'; test -z "$$list" || rm -f $$list - @list='$(RECHECK_LOGS:.log=.trs)'; test -z "$$list" || rm -f $$list - @test -z "$(TEST_SUITE_LOG)" || rm -f $(TEST_SUITE_LOG) - @set +e; $(am__set_TESTS_bases); \ - log_list=`for i in $$bases; do echo $$i.log; done`; \ - trs_list=`for i in $$bases; do echo $$i.trs; done`; \ - log_list=`echo $$log_list`; trs_list=`echo $$trs_list`; \ - $(MAKE) $(AM_MAKEFLAGS) $(TEST_SUITE_LOG) TEST_LOGS="$$log_list"; \ - exit $$?; -recheck: all $(check_LTLIBRARIES) $(check_PROGRAMS) - @test -z "$(TEST_SUITE_LOG)" || rm -f $(TEST_SUITE_LOG) - @set +e; $(am__set_TESTS_bases); \ - bases=`for i in $$bases; do echo $$i; done \ - | $(am__list_recheck_tests)` || exit 1; \ - log_list=`for i in $$bases; do echo $$i.log; done`; \ - log_list=`echo $$log_list`; \ - $(MAKE) $(AM_MAKEFLAGS) $(TEST_SUITE_LOG) \ - am__force_recheck=am--force-recheck \ - TEST_LOGS="$$log_list"; \ - exit $$? -cordtest.log: cordtest$(EXEEXT) - @p='cordtest$(EXEEXT)'; \ - b='cordtest'; \ - $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ - --log-file $$b.log --trs-file $$b.trs \ - $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ - "$$tst" $(AM_TESTS_FD_REDIRECT) -gctest.log: gctest$(EXEEXT) - @p='gctest$(EXEEXT)'; \ - b='gctest'; \ - $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ - --log-file $$b.log --trs-file $$b.trs \ - $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ - "$$tst" $(AM_TESTS_FD_REDIRECT) -leaktest.log: leaktest$(EXEEXT) - @p='leaktest$(EXEEXT)'; \ - b='leaktest'; \ - $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ - --log-file $$b.log --trs-file $$b.trs \ - $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ - "$$tst" $(AM_TESTS_FD_REDIRECT) -middletest.log: middletest$(EXEEXT) - @p='middletest$(EXEEXT)'; \ - b='middletest'; \ - $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ - --log-file $$b.log --trs-file $$b.trs \ - $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ - "$$tst" $(AM_TESTS_FD_REDIRECT) -smashtest.log: smashtest$(EXEEXT) - @p='smashtest$(EXEEXT)'; \ - b='smashtest'; \ - $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ - --log-file $$b.log --trs-file $$b.trs \ - $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ - "$$tst" $(AM_TESTS_FD_REDIRECT) -hugetest.log: hugetest$(EXEEXT) - @p='hugetest$(EXEEXT)'; \ - b='hugetest'; \ - $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ - --log-file $$b.log --trs-file $$b.trs \ - $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ - "$$tst" $(AM_TESTS_FD_REDIRECT) -realloc_test.log: realloc_test$(EXEEXT) - @p='realloc_test$(EXEEXT)'; \ - b='realloc_test'; \ - $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ - --log-file $$b.log --trs-file $$b.trs \ - $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ - "$$tst" $(AM_TESTS_FD_REDIRECT) -staticrootstest.log: staticrootstest$(EXEEXT) - @p='staticrootstest$(EXEEXT)'; \ - b='staticrootstest'; \ - $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ - --log-file $$b.log --trs-file $$b.trs \ - $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ - "$$tst" $(AM_TESTS_FD_REDIRECT) -tracetest.log: tracetest$(EXEEXT) - @p='tracetest$(EXEEXT)'; \ - b='tracetest'; \ - $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ - --log-file $$b.log --trs-file $$b.trs \ - $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ - "$$tst" $(AM_TESTS_FD_REDIRECT) -threadleaktest.log: threadleaktest$(EXEEXT) - @p='threadleaktest$(EXEEXT)'; \ - b='threadleaktest'; \ - $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ - --log-file $$b.log --trs-file $$b.trs \ - $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ - "$$tst" $(AM_TESTS_FD_REDIRECT) -threadkey_test.log: threadkey_test$(EXEEXT) - @p='threadkey_test$(EXEEXT)'; \ - b='threadkey_test'; \ - $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ - --log-file $$b.log --trs-file $$b.trs \ - $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ - "$$tst" $(AM_TESTS_FD_REDIRECT) -subthreadcreate_test.log: subthreadcreate_test$(EXEEXT) - @p='subthreadcreate_test$(EXEEXT)'; \ - b='subthreadcreate_test'; \ - $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ - --log-file $$b.log --trs-file $$b.trs \ - $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ - "$$tst" $(AM_TESTS_FD_REDIRECT) -initsecondarythread_test.log: initsecondarythread_test$(EXEEXT) - @p='initsecondarythread_test$(EXEEXT)'; \ - b='initsecondarythread_test'; \ - $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ - --log-file $$b.log --trs-file $$b.trs \ - $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ - "$$tst" $(AM_TESTS_FD_REDIRECT) -test_cpp.log: test_cpp$(EXEEXT) - @p='test_cpp$(EXEEXT)'; \ - b='test_cpp'; \ - $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ - --log-file $$b.log --trs-file $$b.trs \ - $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ - "$$tst" $(AM_TESTS_FD_REDIRECT) -disclaim_test.log: disclaim_test$(EXEEXT) - @p='disclaim_test$(EXEEXT)'; \ - b='disclaim_test'; \ - $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ - --log-file $$b.log --trs-file $$b.trs \ - $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ - "$$tst" $(AM_TESTS_FD_REDIRECT) -disclaim_bench.log: disclaim_bench$(EXEEXT) - @p='disclaim_bench$(EXEEXT)'; \ - b='disclaim_bench'; \ - $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ - --log-file $$b.log --trs-file $$b.trs \ - $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ - "$$tst" $(AM_TESTS_FD_REDIRECT) -.test.log: - @p='$<'; \ - $(am__set_b); \ - $(am__check_pre) $(TEST_LOG_DRIVER) --test-name "$$f" \ - --log-file $$b.log --trs-file $$b.trs \ - $(am__common_driver_flags) $(AM_TEST_LOG_DRIVER_FLAGS) $(TEST_LOG_DRIVER_FLAGS) -- $(TEST_LOG_COMPILE) \ - "$$tst" $(AM_TESTS_FD_REDIRECT) -@am__EXEEXT_TRUE@.test$(EXEEXT).log: -@am__EXEEXT_TRUE@ @p='$<'; \ -@am__EXEEXT_TRUE@ $(am__set_b); \ -@am__EXEEXT_TRUE@ $(am__check_pre) $(TEST_LOG_DRIVER) --test-name "$$f" \ -@am__EXEEXT_TRUE@ --log-file $$b.log --trs-file $$b.trs \ -@am__EXEEXT_TRUE@ $(am__common_driver_flags) $(AM_TEST_LOG_DRIVER_FLAGS) $(TEST_LOG_DRIVER_FLAGS) -- $(TEST_LOG_COMPILE) \ -@am__EXEEXT_TRUE@ "$$tst" $(AM_TESTS_FD_REDIRECT) - -distdir: $(DISTFILES) - $(am__remove_distdir) - test -d "$(distdir)" || mkdir "$(distdir)" - @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ - topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ - list='$(DISTFILES)'; \ - dist_files=`for file in $$list; do echo $$file; done | \ - sed -e "s|^$$srcdirstrip/||;t" \ - -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ - case $$dist_files in \ - */*) $(MKDIR_P) `echo "$$dist_files" | \ - sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ - sort -u` ;; \ - esac; \ - for file in $$dist_files; do \ - if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ - if test -d $$d/$$file; then \ - dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ - if test -d "$(distdir)/$$file"; then \ - find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ - fi; \ - if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ - cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ - find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ - fi; \ - cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ - else \ - test -f "$(distdir)/$$file" \ - || cp -p $$d/$$file "$(distdir)/$$file" \ - || exit 1; \ - fi; \ - done - @list='$(DIST_SUBDIRS)'; for subdir in $$list; do \ - if test "$$subdir" = .; then :; else \ - $(am__make_dryrun) \ - || test -d "$(distdir)/$$subdir" \ - || $(MKDIR_P) "$(distdir)/$$subdir" \ - || exit 1; \ - dir1=$$subdir; dir2="$(distdir)/$$subdir"; \ - $(am__relativize); \ - new_distdir=$$reldir; \ - dir1=$$subdir; dir2="$(top_distdir)"; \ - $(am__relativize); \ - new_top_distdir=$$reldir; \ - echo " (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) top_distdir="$$new_top_distdir" distdir="$$new_distdir" \\"; \ - echo " am__remove_distdir=: am__skip_length_check=: am__skip_mode_fix=: distdir)"; \ - ($(am__cd) $$subdir && \ - $(MAKE) $(AM_MAKEFLAGS) \ - top_distdir="$$new_top_distdir" \ - distdir="$$new_distdir" \ - am__remove_distdir=: \ - am__skip_length_check=: \ - am__skip_mode_fix=: \ - distdir) \ - || exit 1; \ - fi; \ - done - -test -n "$(am__skip_mode_fix)" \ - || find "$(distdir)" -type d ! -perm -755 \ - -exec chmod u+rwx,go+rx {} \; -o \ - ! -type d ! -perm -444 -links 1 -exec chmod a+r {} \; -o \ - ! -type d ! -perm -400 -exec chmod a+r {} \; -o \ - ! -type d ! -perm -444 -exec $(install_sh) -c -m a+r {} {} \; \ - || chmod -R a+r "$(distdir)" -dist-gzip: distdir - tardir=$(distdir) && $(am__tar) | GZIP=$(GZIP_ENV) gzip -c >$(distdir).tar.gz - $(am__post_remove_distdir) -dist-bzip2: distdir - tardir=$(distdir) && $(am__tar) | BZIP2=$${BZIP2--9} bzip2 -c >$(distdir).tar.bz2 - $(am__post_remove_distdir) - -dist-lzip: distdir - tardir=$(distdir) && $(am__tar) | lzip -c $${LZIP_OPT--9} >$(distdir).tar.lz - $(am__post_remove_distdir) - -dist-xz: distdir - tardir=$(distdir) && $(am__tar) | XZ_OPT=$${XZ_OPT--e} xz -c >$(distdir).tar.xz - $(am__post_remove_distdir) - -dist-tarZ: distdir - @echo WARNING: "Support for distribution archives compressed with" \ - "legacy program 'compress' is deprecated." >&2 - @echo WARNING: "It will be removed altogether in Automake 2.0" >&2 - tardir=$(distdir) && $(am__tar) | compress -c >$(distdir).tar.Z - $(am__post_remove_distdir) - -dist-shar: distdir - @echo WARNING: "Support for shar distribution archives is" \ - "deprecated." >&2 - @echo WARNING: "It will be removed altogether in Automake 2.0" >&2 - shar $(distdir) | GZIP=$(GZIP_ENV) gzip -c >$(distdir).shar.gz - $(am__post_remove_distdir) - -dist-zip: distdir - -rm -f $(distdir).zip - zip -rq $(distdir).zip $(distdir) - $(am__post_remove_distdir) - -dist dist-all: - $(MAKE) $(AM_MAKEFLAGS) $(DIST_TARGETS) am__post_remove_distdir='@:' - $(am__post_remove_distdir) - -# This target untars the dist file and tries a VPATH configuration. Then -# it guarantees that the distribution is self-contained by making another -# tarfile. -distcheck: dist - case '$(DIST_ARCHIVES)' in \ - *.tar.gz*) \ - GZIP=$(GZIP_ENV) gzip -dc $(distdir).tar.gz | $(am__untar) ;;\ - *.tar.bz2*) \ - bzip2 -dc $(distdir).tar.bz2 | $(am__untar) ;;\ - *.tar.lz*) \ - lzip -dc $(distdir).tar.lz | $(am__untar) ;;\ - *.tar.xz*) \ - xz -dc $(distdir).tar.xz | $(am__untar) ;;\ - *.tar.Z*) \ - uncompress -c $(distdir).tar.Z | $(am__untar) ;;\ - *.shar.gz*) \ - GZIP=$(GZIP_ENV) gzip -dc $(distdir).shar.gz | unshar ;;\ - *.zip*) \ - unzip $(distdir).zip ;;\ - esac - chmod -R a-w $(distdir) - chmod u+w $(distdir) - mkdir $(distdir)/_build $(distdir)/_build/sub $(distdir)/_inst - chmod a-w $(distdir) - test -d $(distdir)/_build || exit 0; \ - dc_install_base=`$(am__cd) $(distdir)/_inst && pwd | sed -e 's,^[^:\\/]:[\\/],/,'` \ - && dc_destdir="$${TMPDIR-/tmp}/am-dc-$$$$/" \ - && am__cwd=`pwd` \ - && $(am__cd) $(distdir)/_build/sub \ - && ../../configure \ - $(AM_DISTCHECK_CONFIGURE_FLAGS) \ - $(DISTCHECK_CONFIGURE_FLAGS) \ - --srcdir=../.. --prefix="$$dc_install_base" \ - && $(MAKE) $(AM_MAKEFLAGS) \ - && $(MAKE) $(AM_MAKEFLAGS) dvi \ - && $(MAKE) $(AM_MAKEFLAGS) check \ - && $(MAKE) $(AM_MAKEFLAGS) install \ - && $(MAKE) $(AM_MAKEFLAGS) installcheck \ - && $(MAKE) $(AM_MAKEFLAGS) uninstall \ - && $(MAKE) $(AM_MAKEFLAGS) distuninstallcheck_dir="$$dc_install_base" \ - distuninstallcheck \ - && chmod -R a-w "$$dc_install_base" \ - && ({ \ - (cd ../.. && umask 077 && mkdir "$$dc_destdir") \ - && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" install \ - && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" uninstall \ - && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" \ - distuninstallcheck_dir="$$dc_destdir" distuninstallcheck; \ - } || { rm -rf "$$dc_destdir"; exit 1; }) \ - && rm -rf "$$dc_destdir" \ - && $(MAKE) $(AM_MAKEFLAGS) dist \ - && rm -rf $(DIST_ARCHIVES) \ - && $(MAKE) $(AM_MAKEFLAGS) distcleancheck \ - && cd "$$am__cwd" \ - || exit 1 - $(am__post_remove_distdir) - @(echo "$(distdir) archives ready for distribution: "; \ - list='$(DIST_ARCHIVES)'; for i in $$list; do echo $$i; done) | \ - sed -e 1h -e 1s/./=/g -e 1p -e 1x -e '$$p' -e '$$x' -distuninstallcheck: - @test -n '$(distuninstallcheck_dir)' || { \ - echo 'ERROR: trying to run $@ with an empty' \ - '$$(distuninstallcheck_dir)' >&2; \ - exit 1; \ - }; \ - $(am__cd) '$(distuninstallcheck_dir)' || { \ - echo 'ERROR: cannot chdir into $(distuninstallcheck_dir)' >&2; \ - exit 1; \ - }; \ - test `$(am__distuninstallcheck_listfiles) | wc -l` -eq 0 \ - || { echo "ERROR: files left after uninstall:" ; \ - if test -n "$(DESTDIR)"; then \ - echo " (check DESTDIR support)"; \ - fi ; \ - $(distuninstallcheck_listfiles) ; \ - exit 1; } >&2 -distcleancheck: distclean - @if test '$(srcdir)' = . ; then \ - echo "ERROR: distcleancheck can only run from a VPATH build" ; \ - exit 1 ; \ - fi - @test `$(distcleancheck_listfiles) | wc -l` -eq 0 \ - || { echo "ERROR: files left in build directory after distclean:" ; \ - $(distcleancheck_listfiles) ; \ - exit 1; } >&2 -check-am: all-am - $(MAKE) $(AM_MAKEFLAGS) $(check_LTLIBRARIES) $(check_PROGRAMS) - $(MAKE) $(AM_MAKEFLAGS) check-TESTS -check: check-recursive -all-am: Makefile $(LTLIBRARIES) $(DATA) $(HEADERS) -installdirs: installdirs-recursive -installdirs-am: - for dir in "$(DESTDIR)$(libdir)" "$(DESTDIR)$(pkgdatadir)" "$(DESTDIR)$(pkgconfigdir)" "$(DESTDIR)$(includedir)" "$(DESTDIR)$(pkgincludedir)"; do \ - test -z "$$dir" || $(MKDIR_P) "$$dir"; \ - done -install: install-recursive -install-exec: install-exec-recursive -install-data: install-data-recursive -uninstall: uninstall-recursive - -install-am: all-am - @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am - -installcheck: installcheck-recursive -install-strip: - if test -z '$(STRIP)'; then \ - $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ - install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ - install; \ - else \ - $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ - install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ - "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ - fi -mostlyclean-generic: - -test -z "$(TEST_LOGS)" || rm -f $(TEST_LOGS) - -test -z "$(TEST_LOGS:.log=.trs)" || rm -f $(TEST_LOGS:.log=.trs) - -test -z "$(TEST_SUITE_LOG)" || rm -f $(TEST_SUITE_LOG) - -clean-generic: - -distclean-generic: - -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) - -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) - -rm -f cord/$(DEPDIR)/$(am__dirstamp) - -rm -f cord/$(am__dirstamp) - -rm -f cord/tests/$(DEPDIR)/$(am__dirstamp) - -rm -f cord/tests/$(am__dirstamp) - -rm -f extra/$(DEPDIR)/$(am__dirstamp) - -rm -f extra/$(am__dirstamp) - -rm -f libatomic_ops/src/$(DEPDIR)/$(am__dirstamp) - -rm -f libatomic_ops/src/$(am__dirstamp) - -rm -f tests/$(DEPDIR)/$(am__dirstamp) - -rm -f tests/$(am__dirstamp) - -maintainer-clean-generic: - @echo "This command is intended for maintainers to use" - @echo "it deletes files that may require special tools to rebuild." -clean: clean-recursive - -clean-am: clean-checkLTLIBRARIES clean-checkPROGRAMS clean-generic \ - clean-libLTLIBRARIES clean-libtool mostlyclean-am - -distclean: distclean-recursive - -rm -f $(am__CONFIG_DISTCLEAN_FILES) - -rm -rf ./$(DEPDIR) cord/$(DEPDIR) cord/tests/$(DEPDIR) extra/$(DEPDIR) libatomic_ops/src/$(DEPDIR) tests/$(DEPDIR) - -rm -f Makefile -distclean-am: clean-am distclean-compile distclean-generic \ - distclean-hdr distclean-libtool distclean-tags - -dvi: dvi-recursive - -dvi-am: - -html: html-recursive - -html-am: - -info: info-recursive - -info-am: - -install-data-am: install-dist_pkgdataDATA install-includeHEADERS \ - install-pkgconfigDATA install-pkgincludeHEADERS - -install-dvi: install-dvi-recursive - -install-dvi-am: - -install-exec-am: install-libLTLIBRARIES - -install-html: install-html-recursive - -install-html-am: - -install-info: install-info-recursive - -install-info-am: - -install-man: - -install-pdf: install-pdf-recursive - -install-pdf-am: - -install-ps: install-ps-recursive - -install-ps-am: - -installcheck-am: - -maintainer-clean: maintainer-clean-recursive - -rm -f $(am__CONFIG_DISTCLEAN_FILES) - -rm -rf $(top_srcdir)/autom4te.cache - -rm -rf ./$(DEPDIR) cord/$(DEPDIR) cord/tests/$(DEPDIR) extra/$(DEPDIR) libatomic_ops/src/$(DEPDIR) tests/$(DEPDIR) - -rm -f Makefile -maintainer-clean-am: distclean-am maintainer-clean-generic - -mostlyclean: mostlyclean-recursive - -mostlyclean-am: mostlyclean-compile mostlyclean-generic \ - mostlyclean-libtool - -pdf: pdf-recursive - -pdf-am: - -ps: ps-recursive - -ps-am: - -uninstall-am: uninstall-dist_pkgdataDATA uninstall-includeHEADERS \ - uninstall-libLTLIBRARIES uninstall-pkgconfigDATA \ - uninstall-pkgincludeHEADERS - -.MAKE: $(am__recursive_targets) check-am install-am install-strip - -.PHONY: $(am__recursive_targets) CTAGS GTAGS TAGS all all-am \ - am--refresh check check-TESTS check-am clean \ - clean-checkLTLIBRARIES clean-checkPROGRAMS clean-cscope \ - clean-generic clean-libLTLIBRARIES clean-libtool cscope \ - cscopelist-am ctags ctags-am dist dist-all dist-bzip2 \ - dist-gzip dist-lzip dist-shar dist-tarZ dist-xz dist-zip \ - distcheck distclean distclean-compile distclean-generic \ - distclean-hdr distclean-libtool distclean-tags distcleancheck \ - distdir distuninstallcheck dvi dvi-am html html-am info \ - info-am install install-am install-data install-data-am \ - install-dist_pkgdataDATA install-dvi install-dvi-am \ - install-exec install-exec-am install-html install-html-am \ - install-includeHEADERS install-info install-info-am \ - install-libLTLIBRARIES install-man install-pdf install-pdf-am \ - install-pkgconfigDATA install-pkgincludeHEADERS install-ps \ - install-ps-am install-strip installcheck installcheck-am \ - installdirs installdirs-am maintainer-clean \ - maintainer-clean-generic mostlyclean mostlyclean-compile \ - mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \ - recheck tags tags-am uninstall uninstall-am \ - uninstall-dist_pkgdataDATA uninstall-includeHEADERS \ - uninstall-libLTLIBRARIES uninstall-pkgconfigDATA \ - uninstall-pkgincludeHEADERS - -.PRECIOUS: Makefile - - -.s.lo: - $(LTCOMPILE) $(ASM_CPP_OPTIONS) -c $< - -.S.lo: - $(LTCOMPILE) $(ASM_CPP_OPTIONS) -c $< - -# -# :GOTCHA: GNU make rule for making .s out of .S is flawed, -# it will not remove dest if building fails -.S.s: - if $(CPP) $< >$@ ; then :; else rm -f $@; fi - -# Putting these at the top causes cord to be built first, and not find libgc.a -# on HP/UX. There may be a better fix. - -# Tell versions [3.59,3.63) of GNU make to not export all variables. -# Otherwise a system limit (for SysV at least) may be exceeded. -.NOEXPORT: diff -Nru ecl-16.1.2/src/bdwgc/malloc.c ecl-16.1.3+ds/src/bdwgc/malloc.c --- ecl-16.1.2/src/bdwgc/malloc.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/malloc.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,601 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1999-2004 Hewlett-Packard Development Company, L.P. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#include "private/gc_priv.h" - -#include -#include - -/* Allocate reclaim list for kind: */ -/* Return TRUE on success */ -STATIC GC_bool GC_alloc_reclaim_list(struct obj_kind *kind) -{ - struct hblk ** result = (struct hblk **) - GC_scratch_alloc((MAXOBJGRANULES+1) * sizeof(struct hblk *)); - if (result == 0) return(FALSE); - BZERO(result, (MAXOBJGRANULES+1)*sizeof(struct hblk *)); - kind -> ok_reclaim_list = result; - return(TRUE); -} - -GC_INNER GC_bool GC_collect_or_expand(word needed_blocks, - GC_bool ignore_off_page, - GC_bool retry); /* from alloc.c */ - -/* Allocate a large block of size lb bytes. */ -/* The block is not cleared. */ -/* Flags is 0 or IGNORE_OFF_PAGE. */ -/* We hold the allocation lock. */ -/* EXTRA_BYTES were already added to lb. */ -GC_INNER ptr_t GC_alloc_large(size_t lb, int k, unsigned flags) -{ - struct hblk * h; - word n_blocks; - ptr_t result; - GC_bool retry = FALSE; - - lb = ROUNDUP_GRANULE_SIZE(lb); - n_blocks = OBJ_SZ_TO_BLOCKS(lb); - if (!EXPECT(GC_is_initialized, TRUE)) GC_init(); - /* Do our share of marking work */ - if (GC_incremental && !GC_dont_gc) - GC_collect_a_little_inner((int)n_blocks); - h = GC_allochblk(lb, k, flags); -# ifdef USE_MUNMAP - if (0 == h) { - GC_merge_unmapped(); - h = GC_allochblk(lb, k, flags); - } -# endif - while (0 == h && GC_collect_or_expand(n_blocks, flags != 0, retry)) { - h = GC_allochblk(lb, k, flags); - retry = TRUE; - } - if (h == 0) { - result = 0; - } else { - size_t total_bytes = n_blocks * HBLKSIZE; - if (n_blocks > 1) { - GC_large_allocd_bytes += total_bytes; - if (GC_large_allocd_bytes > GC_max_large_allocd_bytes) - GC_max_large_allocd_bytes = GC_large_allocd_bytes; - } - /* FIXME: Do we need some way to reset GC_max_large_allocd_bytes? */ - result = h -> hb_body; - } - return result; -} - -/* Allocate a large block of size lb bytes. Clear if appropriate. */ -/* We hold the allocation lock. */ -/* EXTRA_BYTES were already added to lb. */ -STATIC ptr_t GC_alloc_large_and_clear(size_t lb, int k, unsigned flags) -{ - ptr_t result = GC_alloc_large(lb, k, flags); - word n_blocks = OBJ_SZ_TO_BLOCKS(lb); - - if (0 == result) return 0; - if (GC_debugging_started || GC_obj_kinds[k].ok_init) { - /* Clear the whole block, in case of GC_realloc call. */ - BZERO(result, n_blocks * HBLKSIZE); - } - return result; -} - -/* allocate lb bytes for an object of kind k. */ -/* Should not be used to directly to allocate */ -/* objects such as STUBBORN objects that */ -/* require special handling on allocation. */ -/* First a version that assumes we already */ -/* hold lock: */ -GC_INNER void * GC_generic_malloc_inner(size_t lb, int k) -{ - void *op; - - if(SMALL_OBJ(lb)) { - struct obj_kind * kind = GC_obj_kinds + k; - size_t lg = GC_size_map[lb]; - void ** opp = &(kind -> ok_freelist[lg]); - - op = *opp; - if (EXPECT(0 == op, FALSE)) { - if (lg == 0) { - if (!EXPECT(GC_is_initialized, TRUE)) { - GC_init(); - lg = GC_size_map[lb]; - } - if (0 == lg) { - GC_extend_size_map(lb); - lg = GC_size_map[lb]; - GC_ASSERT(lg != 0); - } - /* Retry */ - opp = &(kind -> ok_freelist[lg]); - op = *opp; - } - if (0 == op) { - if (0 == kind -> ok_reclaim_list && - !GC_alloc_reclaim_list(kind)) - return NULL; - op = GC_allocobj(lg, k); - if (0 == op) - return NULL; - } - } - *opp = obj_link(op); - obj_link(op) = 0; - GC_bytes_allocd += GRANULES_TO_BYTES(lg); - } else { - op = (ptr_t)GC_alloc_large_and_clear(ADD_SLOP(lb), k, 0); - GC_bytes_allocd += lb; - } - - return op; -} - -/* Allocate a composite object of size n bytes. The caller guarantees */ -/* that pointers past the first page are not relevant. Caller holds */ -/* allocation lock. */ -GC_INNER void * GC_generic_malloc_inner_ignore_off_page(size_t lb, int k) -{ - word lb_adjusted; - void * op; - - if (lb <= HBLKSIZE) - return(GC_generic_malloc_inner(lb, k)); - lb_adjusted = ADD_SLOP(lb); - op = GC_alloc_large_and_clear(lb_adjusted, k, IGNORE_OFF_PAGE); - GC_bytes_allocd += lb_adjusted; - return op; -} - -#ifdef GC_COLLECT_AT_MALLOC - /* Parameter to force GC at every malloc of size greater or equal to */ - /* the given value. This might be handy during debugging. */ - size_t GC_dbg_collect_at_malloc_min_lb = (GC_COLLECT_AT_MALLOC); -#endif - -GC_API GC_ATTR_MALLOC void * GC_CALL GC_generic_malloc(size_t lb, int k) -{ - void * result; - DCL_LOCK_STATE; - - if (EXPECT(GC_have_errors, FALSE)) - GC_print_all_errors(); - GC_INVOKE_FINALIZERS(); - GC_DBG_COLLECT_AT_MALLOC(lb); - if (SMALL_OBJ(lb)) { - LOCK(); - result = GC_generic_malloc_inner(lb, k); - UNLOCK(); - } else { - size_t lg; - size_t lb_rounded; - word n_blocks; - GC_bool init; - - lg = ROUNDED_UP_GRANULES(lb); - lb_rounded = GRANULES_TO_BYTES(lg); - if (lb_rounded < lb) - return((*GC_get_oom_fn())(lb)); - n_blocks = OBJ_SZ_TO_BLOCKS(lb_rounded); - init = GC_obj_kinds[k].ok_init; - LOCK(); - result = (ptr_t)GC_alloc_large(lb_rounded, k, 0); - if (0 != result) { - if (GC_debugging_started) { - BZERO(result, n_blocks * HBLKSIZE); - } else { -# ifdef THREADS - /* Clear any memory that might be used for GC descriptors */ - /* before we release the lock. */ - ((word *)result)[0] = 0; - ((word *)result)[1] = 0; - ((word *)result)[GRANULES_TO_WORDS(lg)-1] = 0; - ((word *)result)[GRANULES_TO_WORDS(lg)-2] = 0; -# endif - } - } - GC_bytes_allocd += lb_rounded; - UNLOCK(); - if (init && !GC_debugging_started && 0 != result) { - BZERO(result, n_blocks * HBLKSIZE); - } - } - if (0 == result) { - return((*GC_get_oom_fn())(lb)); - } else { - return(result); - } -} - -/* Allocate lb bytes of atomic (pointer-free) data. */ -#ifdef THREAD_LOCAL_ALLOC - GC_INNER void * GC_core_malloc_atomic(size_t lb) -#else - GC_API GC_ATTR_MALLOC void * GC_CALL GC_malloc_atomic(size_t lb) -#endif -{ - void *op; - size_t lg; - DCL_LOCK_STATE; - - if(SMALL_OBJ(lb)) { - GC_DBG_COLLECT_AT_MALLOC(lb); - lg = GC_size_map[lb]; - LOCK(); - op = GC_aobjfreelist[lg]; - if (EXPECT(0 == op, FALSE)) { - UNLOCK(); - return(GENERAL_MALLOC((word)lb, PTRFREE)); - } - GC_aobjfreelist[lg] = obj_link(op); - GC_bytes_allocd += GRANULES_TO_BYTES(lg); - UNLOCK(); - return((void *) op); - } else { - return(GENERAL_MALLOC((word)lb, PTRFREE)); - } -} - -/* Allocate lb bytes of composite (pointerful) data */ -#ifdef THREAD_LOCAL_ALLOC - GC_INNER void * GC_core_malloc(size_t lb) -#else - GC_API GC_ATTR_MALLOC void * GC_CALL GC_malloc(size_t lb) -#endif -{ - void *op; - size_t lg; - DCL_LOCK_STATE; - - if(SMALL_OBJ(lb)) { - GC_DBG_COLLECT_AT_MALLOC(lb); - lg = GC_size_map[lb]; - LOCK(); - op = GC_objfreelist[lg]; - if (EXPECT(0 == op, FALSE)) { - UNLOCK(); - return (GENERAL_MALLOC((word)lb, NORMAL)); - } - GC_ASSERT(0 == obj_link(op) - || ((word)obj_link(op) - <= (word)GC_greatest_plausible_heap_addr - && (word)obj_link(op) - >= (word)GC_least_plausible_heap_addr)); - GC_objfreelist[lg] = obj_link(op); - obj_link(op) = 0; - GC_bytes_allocd += GRANULES_TO_BYTES(lg); - UNLOCK(); - return op; - } else { - return(GENERAL_MALLOC(lb, NORMAL)); - } -} - -/* Allocate lb bytes of pointerful, traced, but not collectible data. */ -GC_API GC_ATTR_MALLOC void * GC_CALL GC_malloc_uncollectable(size_t lb) -{ - void *op; - size_t lg; - DCL_LOCK_STATE; - - if (SMALL_OBJ(lb)) { - GC_DBG_COLLECT_AT_MALLOC(lb); - if (EXTRA_BYTES != 0 && lb != 0) lb--; - /* We don't need the extra byte, since this won't be */ - /* collected anyway. */ - lg = GC_size_map[lb]; - LOCK(); - op = GC_uobjfreelist[lg]; - if (EXPECT(op != 0, TRUE)) { - GC_uobjfreelist[lg] = obj_link(op); - obj_link(op) = 0; - GC_bytes_allocd += GRANULES_TO_BYTES(lg); - /* Mark bit ws already set on free list. It will be */ - /* cleared only temporarily during a collection, as a */ - /* result of the normal free list mark bit clearing. */ - GC_non_gc_bytes += GRANULES_TO_BYTES(lg); - UNLOCK(); - } else { - UNLOCK(); - op = GC_generic_malloc(lb, UNCOLLECTABLE); - /* For small objects, the free lists are completely marked. */ - } - GC_ASSERT(0 == op || GC_is_marked(op)); - } else { - hdr * hhdr; - - op = GC_generic_malloc(lb, UNCOLLECTABLE); - if (0 == op) return(0); - - GC_ASSERT(((word)op & (HBLKSIZE - 1)) == 0); /* large block */ - hhdr = HDR(op); - /* We don't need the lock here, since we have an undisguised */ - /* pointer. We do need to hold the lock while we adjust */ - /* mark bits. */ - LOCK(); - set_mark_bit_from_hdr(hhdr, 0); /* Only object. */ -# ifndef THREADS - GC_ASSERT(hhdr -> hb_n_marks == 0); - /* This is not guaranteed in the multi-threaded case */ - /* because the counter could be updated before locking. */ -# endif - hhdr -> hb_n_marks = 1; - UNLOCK(); - } - return op; -} - -#ifdef REDIRECT_MALLOC - -# ifndef MSWINCE -# include -# endif - -/* Avoid unnecessary nested procedure calls here, by #defining some */ -/* malloc replacements. Otherwise we end up saving a */ -/* meaningless return address in the object. It also speeds things up, */ -/* but it is admittedly quite ugly. */ -# define GC_debug_malloc_replacement(lb) GC_debug_malloc(lb, GC_DBG_EXTRAS) - -void * malloc(size_t lb) -{ - /* It might help to manually inline the GC_malloc call here. */ - /* But any decent compiler should reduce the extra procedure call */ - /* to at most a jump instruction in this case. */ -# if defined(I386) && defined(GC_SOLARIS_THREADS) - /* Thread initialization can call malloc before we're ready for. */ - /* It's not clear that this is enough to help matters. */ - /* The thread implementation may well call malloc at other */ - /* inopportune times. */ - if (!EXPECT(GC_is_initialized, TRUE)) return sbrk(lb); -# endif /* I386 && GC_SOLARIS_THREADS */ - return((void *)REDIRECT_MALLOC(lb)); -} - -#if defined(GC_LINUX_THREADS) /* && !defined(USE_PROC_FOR_LIBRARIES) */ - STATIC ptr_t GC_libpthread_start = 0; - STATIC ptr_t GC_libpthread_end = 0; - STATIC ptr_t GC_libld_start = 0; - STATIC ptr_t GC_libld_end = 0; - - STATIC void GC_init_lib_bounds(void) - { - if (GC_libpthread_start != 0) return; - GC_init(); /* if not called yet */ - if (!GC_text_mapping("libpthread-", - &GC_libpthread_start, &GC_libpthread_end)) { - WARN("Failed to find libpthread.so text mapping: Expect crash\n", 0); - /* This might still work with some versions of libpthread, */ - /* so we don't abort. Perhaps we should. */ - /* Generate message only once: */ - GC_libpthread_start = (ptr_t)1; - } - if (!GC_text_mapping("ld-", &GC_libld_start, &GC_libld_end)) { - WARN("Failed to find ld.so text mapping: Expect crash\n", 0); - } - } -#endif /* GC_LINUX_THREADS */ - -#include -#ifdef SIZE_MAX -# define GC_SIZE_MAX SIZE_MAX -#else -# define GC_SIZE_MAX (~(size_t)0) -#endif - -#define GC_SQRT_SIZE_MAX ((1U << (WORDSZ / 2)) - 1) - -void * calloc(size_t n, size_t lb) -{ - if ((lb | n) > GC_SQRT_SIZE_MAX /* fast initial test */ - && lb && n > GC_SIZE_MAX / lb) - return NULL; -# if defined(GC_LINUX_THREADS) /* && !defined(USE_PROC_FOR_LIBRARIES) */ - /* libpthread allocated some memory that is only pointed to by */ - /* mmapped thread stacks. Make sure it is not collectible. */ - { - static GC_bool lib_bounds_set = FALSE; - ptr_t caller = (ptr_t)__builtin_return_address(0); - /* This test does not need to ensure memory visibility, since */ - /* the bounds will be set when/if we create another thread. */ - if (!EXPECT(lib_bounds_set, TRUE)) { - GC_init_lib_bounds(); - lib_bounds_set = TRUE; - } - if (((word)caller >= (word)GC_libpthread_start - && (word)caller < (word)GC_libpthread_end) - || ((word)caller >= (word)GC_libld_start - && (word)caller < (word)GC_libld_end)) - return GC_malloc_uncollectable(n*lb); - /* The two ranges are actually usually adjacent, so there may */ - /* be a way to speed this up. */ - } -# endif - return((void *)REDIRECT_MALLOC(n*lb)); -} - -#ifndef strdup - char *strdup(const char *s) - { - size_t lb = strlen(s) + 1; - char *result = (char *)REDIRECT_MALLOC(lb); - if (result == 0) { - errno = ENOMEM; - return 0; - } - BCOPY(s, result, lb); - return result; - } -#endif /* !defined(strdup) */ - /* If strdup is macro defined, we assume that it actually calls malloc, */ - /* and thus the right thing will happen even without overriding it. */ - /* This seems to be true on most Linux systems. */ - -#ifndef strndup - /* This is similar to strdup(). */ - char *strndup(const char *str, size_t size) - { - char *copy; - size_t len = strlen(str); - if (len > size) - len = size; - copy = (char *)REDIRECT_MALLOC(len + 1); - if (copy == NULL) { - errno = ENOMEM; - return NULL; - } - BCOPY(str, copy, len); - copy[len] = '\0'; - return copy; - } -#endif /* !strndup */ - -#undef GC_debug_malloc_replacement - -#endif /* REDIRECT_MALLOC */ - -/* Explicitly deallocate an object p. */ -GC_API void GC_CALL GC_free(void * p) -{ - struct hblk *h; - hdr *hhdr; - size_t sz; /* In bytes */ - size_t ngranules; /* sz in granules */ - void **flh; - int knd; - struct obj_kind * ok; - DCL_LOCK_STATE; - - if (p == 0) return; - /* Required by ANSI. It's not my fault ... */ -# ifdef LOG_ALLOCS - GC_log_printf("GC_free(%p) after GC #%lu\n", - p, (unsigned long)GC_gc_no); -# endif - h = HBLKPTR(p); - hhdr = HDR(h); -# if defined(REDIRECT_MALLOC) && \ - (defined(GC_SOLARIS_THREADS) || defined(GC_LINUX_THREADS) \ - || defined(MSWIN32)) - /* For Solaris, we have to redirect malloc calls during */ - /* initialization. For the others, this seems to happen */ - /* implicitly. */ - /* Don't try to deallocate that memory. */ - if (0 == hhdr) return; -# endif - GC_ASSERT(GC_base(p) == p); - sz = hhdr -> hb_sz; - ngranules = BYTES_TO_GRANULES(sz); - knd = hhdr -> hb_obj_kind; - ok = &GC_obj_kinds[knd]; - if (EXPECT(ngranules <= MAXOBJGRANULES, TRUE)) { - LOCK(); - GC_bytes_freed += sz; - if (IS_UNCOLLECTABLE(knd)) GC_non_gc_bytes -= sz; - /* Its unnecessary to clear the mark bit. If the */ - /* object is reallocated, it doesn't matter. O.w. the */ - /* collector will do it, since it's on a free list. */ - if (ok -> ok_init) { - BZERO((word *)p + 1, sz-sizeof(word)); - } - flh = &(ok -> ok_freelist[ngranules]); - obj_link(p) = *flh; - *flh = (ptr_t)p; - UNLOCK(); - } else { - size_t nblocks = OBJ_SZ_TO_BLOCKS(sz); - LOCK(); - GC_bytes_freed += sz; - if (IS_UNCOLLECTABLE(knd)) GC_non_gc_bytes -= sz; - if (nblocks > 1) { - GC_large_allocd_bytes -= nblocks * HBLKSIZE; - } - GC_freehblk(h); - UNLOCK(); - } -} - -/* Explicitly deallocate an object p when we already hold lock. */ -/* Only used for internally allocated objects, so we can take some */ -/* shortcuts. */ -#ifdef THREADS - GC_INNER void GC_free_inner(void * p) - { - struct hblk *h; - hdr *hhdr; - size_t sz; /* bytes */ - size_t ngranules; /* sz in granules */ - void ** flh; - int knd; - struct obj_kind * ok; - - h = HBLKPTR(p); - hhdr = HDR(h); - knd = hhdr -> hb_obj_kind; - sz = hhdr -> hb_sz; - ngranules = BYTES_TO_GRANULES(sz); - ok = &GC_obj_kinds[knd]; - if (ngranules <= MAXOBJGRANULES) { - GC_bytes_freed += sz; - if (IS_UNCOLLECTABLE(knd)) GC_non_gc_bytes -= sz; - if (ok -> ok_init) { - BZERO((word *)p + 1, sz-sizeof(word)); - } - flh = &(ok -> ok_freelist[ngranules]); - obj_link(p) = *flh; - *flh = (ptr_t)p; - } else { - size_t nblocks = OBJ_SZ_TO_BLOCKS(sz); - GC_bytes_freed += sz; - if (IS_UNCOLLECTABLE(knd)) GC_non_gc_bytes -= sz; - if (nblocks > 1) { - GC_large_allocd_bytes -= nblocks * HBLKSIZE; - } - GC_freehblk(h); - } - } -#endif /* THREADS */ - -#if defined(REDIRECT_MALLOC) && !defined(REDIRECT_FREE) -# define REDIRECT_FREE GC_free -#endif - -#ifdef REDIRECT_FREE - void free(void * p) - { -# if defined(GC_LINUX_THREADS) && !defined(USE_PROC_FOR_LIBRARIES) - { - /* Don't bother with initialization checks. If nothing */ - /* has been initialized, the check fails, and that's safe, */ - /* since we have not allocated uncollectible objects neither. */ - ptr_t caller = (ptr_t)__builtin_return_address(0); - /* This test does not need to ensure memory visibility, since */ - /* the bounds will be set when/if we create another thread. */ - if (((word)caller >= (word)GC_libpthread_start - && (word)caller < (word)GC_libpthread_end) - || ((word)caller >= (word)GC_libld_start - && (word)caller < (word)GC_libld_end)) { - GC_free(p); - return; - } - } -# endif -# ifndef IGNORE_FREE - REDIRECT_FREE(p); -# endif - } -#endif /* REDIRECT_FREE */ diff -Nru ecl-16.1.2/src/bdwgc/mallocx.c ecl-16.1.3+ds/src/bdwgc/mallocx.c --- ecl-16.1.2/src/bdwgc/mallocx.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/mallocx.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,621 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996 by Silicon Graphics. All rights reserved. - * Copyright (c) 2000 by Hewlett-Packard Company. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#include "private/gc_priv.h" - -/* - * These are extra allocation routines which are likely to be less - * frequently used than those in malloc.c. They are separate in the - * hope that the .o file will be excluded from statically linked - * executables. We should probably break this up further. - */ - -#include -#include - -#ifdef MSWINCE -# ifndef WIN32_LEAN_AND_MEAN -# define WIN32_LEAN_AND_MEAN 1 -# endif -# define NOSERVICE -# include -#else -# include -#endif - -/* Some externally visible but unadvertised variables to allow access to */ -/* free lists from inlined allocators without including gc_priv.h */ -/* or introducing dependencies on internal data structure layouts. */ -void ** const GC_objfreelist_ptr = GC_objfreelist; -void ** const GC_aobjfreelist_ptr = GC_aobjfreelist; -void ** const GC_uobjfreelist_ptr = GC_uobjfreelist; -# ifdef ATOMIC_UNCOLLECTABLE - void ** const GC_auobjfreelist_ptr = GC_auobjfreelist; -# endif - -GC_API int GC_CALL GC_get_kind_and_size(const void * p, size_t * psize) -{ - hdr * hhdr = HDR(p); - - if (psize != NULL) { - *psize = hhdr -> hb_sz; - } - return hhdr -> hb_obj_kind; -} - -GC_API GC_ATTR_MALLOC void * GC_CALL GC_generic_or_special_malloc(size_t lb, - int knd) -{ - switch(knd) { -# ifdef STUBBORN_ALLOC - case STUBBORN: - return GC_malloc_stubborn(lb); -# endif - case PTRFREE: - return GC_malloc_atomic(lb); - case NORMAL: - return GC_malloc(lb); - case UNCOLLECTABLE: - return GC_malloc_uncollectable(lb); -# ifdef ATOMIC_UNCOLLECTABLE - case AUNCOLLECTABLE: - return GC_malloc_atomic_uncollectable(lb); -# endif /* ATOMIC_UNCOLLECTABLE */ - default: - return GC_generic_malloc(lb, knd); - } -} - -/* Change the size of the block pointed to by p to contain at least */ -/* lb bytes. The object may be (and quite likely will be) moved. */ -/* The kind (e.g. atomic) is the same as that of the old. */ -/* Shrinking of large blocks is not implemented well. */ -GC_API void * GC_CALL GC_realloc(void * p, size_t lb) -{ - struct hblk * h; - hdr * hhdr; - size_t sz; /* Current size in bytes */ - size_t orig_sz; /* Original sz in bytes */ - int obj_kind; - - if (p == 0) return(GC_malloc(lb)); /* Required by ANSI */ - h = HBLKPTR(p); - hhdr = HDR(h); - sz = hhdr -> hb_sz; - obj_kind = hhdr -> hb_obj_kind; - orig_sz = sz; - - if (sz > MAXOBJBYTES) { - /* Round it up to the next whole heap block */ - word descr; - - sz = (sz+HBLKSIZE-1) & (~HBLKMASK); - hhdr -> hb_sz = sz; - descr = GC_obj_kinds[obj_kind].ok_descriptor; - if (GC_obj_kinds[obj_kind].ok_relocate_descr) descr += sz; - hhdr -> hb_descr = descr; -# ifdef MARK_BIT_PER_OBJ - GC_ASSERT(hhdr -> hb_inv_sz == LARGE_INV_SZ); -# else - GC_ASSERT((hhdr -> hb_flags & LARGE_BLOCK) != 0 - && hhdr -> hb_map[ANY_INDEX] == 1); -# endif - if (IS_UNCOLLECTABLE(obj_kind)) GC_non_gc_bytes += (sz - orig_sz); - /* Extra area is already cleared by GC_alloc_large_and_clear. */ - } - if (ADD_SLOP(lb) <= sz) { - if (lb >= (sz >> 1)) { -# ifdef STUBBORN_ALLOC - if (obj_kind == STUBBORN) GC_change_stubborn(p); -# endif - if (orig_sz > lb) { - /* Clear unneeded part of object to avoid bogus pointer */ - /* tracing. */ - /* Safe for stubborn objects. */ - BZERO(((ptr_t)p) + lb, orig_sz - lb); - } - return(p); - } else { - /* shrink */ - void * result = - GC_generic_or_special_malloc((word)lb, obj_kind); - - if (result == 0) return(0); - /* Could also return original object. But this */ - /* gives the client warning of imminent disaster. */ - BCOPY(p, result, lb); -# ifndef IGNORE_FREE - GC_free(p); -# endif - return(result); - } - } else { - /* grow */ - void * result = GC_generic_or_special_malloc((word)lb, obj_kind); - - if (result == 0) return(0); - BCOPY(p, result, sz); -# ifndef IGNORE_FREE - GC_free(p); -# endif - return(result); - } -} - -# if defined(REDIRECT_MALLOC) && !defined(REDIRECT_REALLOC) -# define REDIRECT_REALLOC GC_realloc -# endif - -# ifdef REDIRECT_REALLOC - -/* As with malloc, avoid two levels of extra calls here. */ -# define GC_debug_realloc_replacement(p, lb) \ - GC_debug_realloc(p, lb, GC_DBG_EXTRAS) - -void * realloc(void * p, size_t lb) - { - return(REDIRECT_REALLOC(p, lb)); - } - -# undef GC_debug_realloc_replacement -# endif /* REDIRECT_REALLOC */ - -/* Allocate memory such that only pointers to near the */ -/* beginning of the object are considered. */ -/* We avoid holding allocation lock while we clear the memory. */ -GC_API GC_ATTR_MALLOC void * GC_CALL - GC_generic_malloc_ignore_off_page(size_t lb, int k) -{ - void *result; - size_t lg; - size_t lb_rounded; - word n_blocks; - GC_bool init; - DCL_LOCK_STATE; - - if (SMALL_OBJ(lb)) - return GC_generic_malloc(lb, k); - lg = ROUNDED_UP_GRANULES(lb); - lb_rounded = GRANULES_TO_BYTES(lg); - if (lb_rounded < lb) - return((*GC_get_oom_fn())(lb)); - n_blocks = OBJ_SZ_TO_BLOCKS(lb_rounded); - init = GC_obj_kinds[k].ok_init; - if (EXPECT(GC_have_errors, FALSE)) - GC_print_all_errors(); - GC_INVOKE_FINALIZERS(); - GC_DBG_COLLECT_AT_MALLOC(lb); - LOCK(); - result = (ptr_t)GC_alloc_large(ADD_SLOP(lb), k, IGNORE_OFF_PAGE); - if (0 != result) { - if (GC_debugging_started) { - BZERO(result, n_blocks * HBLKSIZE); - } else { -# ifdef THREADS - /* Clear any memory that might be used for GC descriptors */ - /* before we release the lock. */ - ((word *)result)[0] = 0; - ((word *)result)[1] = 0; - ((word *)result)[GRANULES_TO_WORDS(lg)-1] = 0; - ((word *)result)[GRANULES_TO_WORDS(lg)-2] = 0; -# endif - } - } - GC_bytes_allocd += lb_rounded; - if (0 == result) { - GC_oom_func oom_fn = GC_oom_fn; - UNLOCK(); - return((*oom_fn)(lb)); - } else { - UNLOCK(); - if (init && !GC_debugging_started) { - BZERO(result, n_blocks * HBLKSIZE); - } - return(result); - } -} - -GC_API GC_ATTR_MALLOC void * GC_CALL GC_malloc_ignore_off_page(size_t lb) -{ - return GC_generic_malloc_ignore_off_page(lb, NORMAL); -} - -GC_API GC_ATTR_MALLOC void * GC_CALL - GC_malloc_atomic_ignore_off_page(size_t lb) -{ - return GC_generic_malloc_ignore_off_page(lb, PTRFREE); -} - -/* Increment GC_bytes_allocd from code that doesn't have direct access */ -/* to GC_arrays. */ -GC_API void GC_CALL GC_incr_bytes_allocd(size_t n) -{ - GC_bytes_allocd += n; -} - -/* The same for GC_bytes_freed. */ -GC_API void GC_CALL GC_incr_bytes_freed(size_t n) -{ - GC_bytes_freed += n; -} - -# ifdef PARALLEL_MARK - STATIC volatile AO_t GC_bytes_allocd_tmp = 0; - /* Number of bytes of memory allocated since */ - /* we released the GC lock. Instead of */ - /* reacquiring the GC lock just to add this in, */ - /* we add it in the next time we reacquire */ - /* the lock. (Atomically adding it doesn't */ - /* work, since we would have to atomically */ - /* update it in GC_malloc, which is too */ - /* expensive.) */ -# endif /* PARALLEL_MARK */ - -/* Return a list of 1 or more objects of the indicated size, linked */ -/* through the first word in the object. This has the advantage that */ -/* it acquires the allocation lock only once, and may greatly reduce */ -/* time wasted contending for the allocation lock. Typical usage would */ -/* be in a thread that requires many items of the same size. It would */ -/* keep its own free list in thread-local storage, and call */ -/* GC_malloc_many or friends to replenish it. (We do not round up */ -/* object sizes, since a call indicates the intention to consume many */ -/* objects of exactly this size.) */ -/* We assume that the size is a multiple of GRANULE_BYTES. */ -/* We return the free-list by assigning it to *result, since it is */ -/* not safe to return, e.g. a linked list of pointer-free objects, */ -/* since the collector would not retain the entire list if it were */ -/* invoked just as we were returning. */ -/* Note that the client should usually clear the link field. */ -GC_API void GC_CALL GC_generic_malloc_many(size_t lb, int k, void **result) -{ - void *op; - void *p; - void **opp; - size_t lw; /* Length in words. */ - size_t lg; /* Length in granules. */ - signed_word my_bytes_allocd = 0; - struct obj_kind * ok = &(GC_obj_kinds[k]); - struct hblk ** rlh; - DCL_LOCK_STATE; - - GC_ASSERT(lb != 0 && (lb & (GRANULE_BYTES-1)) == 0); - if (!SMALL_OBJ(lb)) { - op = GC_generic_malloc(lb, k); - if (EXPECT(0 != op, TRUE)) - obj_link(op) = 0; - *result = op; - return; - } - lw = BYTES_TO_WORDS(lb); - lg = BYTES_TO_GRANULES(lb); - if (EXPECT(GC_have_errors, FALSE)) - GC_print_all_errors(); - GC_INVOKE_FINALIZERS(); - GC_DBG_COLLECT_AT_MALLOC(lb); - LOCK(); - if (!EXPECT(GC_is_initialized, TRUE)) GC_init(); - /* Do our share of marking work */ - if (GC_incremental && !GC_dont_gc) { - ENTER_GC(); - GC_collect_a_little_inner(1); - EXIT_GC(); - } - /* First see if we can reclaim a page of objects waiting to be */ - /* reclaimed. */ - rlh = ok -> ok_reclaim_list; - if (rlh != NULL) { - struct hblk * hbp; - hdr * hhdr; - - rlh += lg; - while ((hbp = *rlh) != 0) { - hhdr = HDR(hbp); - *rlh = hhdr -> hb_next; - GC_ASSERT(hhdr -> hb_sz == lb); - hhdr -> hb_last_reclaimed = (unsigned short) GC_gc_no; -# ifdef PARALLEL_MARK - if (GC_parallel) { - signed_word my_bytes_allocd_tmp = - (signed_word)AO_load(&GC_bytes_allocd_tmp); - GC_ASSERT(my_bytes_allocd_tmp >= 0); - /* We only decrement it while holding the GC lock. */ - /* Thus we can't accidentally adjust it down in more */ - /* than one thread simultaneously. */ - - if (my_bytes_allocd_tmp != 0) { - (void)AO_fetch_and_add(&GC_bytes_allocd_tmp, - (AO_t)(-my_bytes_allocd_tmp)); - GC_bytes_allocd += my_bytes_allocd_tmp; - } - GC_acquire_mark_lock(); - ++ GC_fl_builder_count; - UNLOCK(); - GC_release_mark_lock(); - } -# endif - op = GC_reclaim_generic(hbp, hhdr, lb, - ok -> ok_init, 0, &my_bytes_allocd); - if (op != 0) { - /* We also reclaimed memory, so we need to adjust */ - /* that count. */ - /* This should be atomic, so the results may be */ - /* inaccurate. */ - GC_bytes_found += my_bytes_allocd; -# ifdef PARALLEL_MARK - if (GC_parallel) { - *result = op; - (void)AO_fetch_and_add(&GC_bytes_allocd_tmp, - (AO_t)my_bytes_allocd); - GC_acquire_mark_lock(); - -- GC_fl_builder_count; - if (GC_fl_builder_count == 0) GC_notify_all_builder(); - GC_release_mark_lock(); - (void) GC_clear_stack(0); - return; - } -# endif - GC_bytes_allocd += my_bytes_allocd; - goto out; - } -# ifdef PARALLEL_MARK - if (GC_parallel) { - GC_acquire_mark_lock(); - -- GC_fl_builder_count; - if (GC_fl_builder_count == 0) GC_notify_all_builder(); - GC_release_mark_lock(); - LOCK(); - /* GC lock is needed for reclaim list access. We */ - /* must decrement fl_builder_count before reacquiring */ - /* the lock. Hopefully this path is rare. */ - } -# endif - } - } - /* Next try to use prefix of global free list if there is one. */ - /* We don't refill it, but we need to use it up before allocating */ - /* a new block ourselves. */ - opp = &(GC_obj_kinds[k].ok_freelist[lg]); - if ( (op = *opp) != 0 ) { - *opp = 0; - my_bytes_allocd = 0; - for (p = op; p != 0; p = obj_link(p)) { - my_bytes_allocd += lb; - if ((word)my_bytes_allocd >= HBLKSIZE) { - *opp = obj_link(p); - obj_link(p) = 0; - break; - } - } - GC_bytes_allocd += my_bytes_allocd; - goto out; - } - /* Next try to allocate a new block worth of objects of this size. */ - { - struct hblk *h = GC_allochblk(lb, k, 0); - if (h != 0) { - if (IS_UNCOLLECTABLE(k)) GC_set_hdr_marks(HDR(h)); - GC_bytes_allocd += HBLKSIZE - HBLKSIZE % lb; -# ifdef PARALLEL_MARK - if (GC_parallel) { - GC_acquire_mark_lock(); - ++ GC_fl_builder_count; - UNLOCK(); - GC_release_mark_lock(); - - op = GC_build_fl(h, lw, - (ok -> ok_init || GC_debugging_started), 0); - - *result = op; - GC_acquire_mark_lock(); - -- GC_fl_builder_count; - if (GC_fl_builder_count == 0) GC_notify_all_builder(); - GC_release_mark_lock(); - (void) GC_clear_stack(0); - return; - } -# endif - op = GC_build_fl(h, lw, (ok -> ok_init || GC_debugging_started), 0); - goto out; - } - } - - /* As a last attempt, try allocating a single object. Note that */ - /* this may trigger a collection or expand the heap. */ - op = GC_generic_malloc_inner(lb, k); - if (0 != op) obj_link(op) = 0; - - out: - *result = op; - UNLOCK(); - (void) GC_clear_stack(0); -} - -/* Note that the "atomic" version of this would be unsafe, since the */ -/* links would not be seen by the collector. */ -GC_API GC_ATTR_MALLOC void * GC_CALL GC_malloc_many(size_t lb) -{ - void *result; - - GC_generic_malloc_many(ROUNDUP_GRANULE_SIZE(lb + EXTRA_BYTES), - NORMAL, &result); - return result; -} - -/* Not well tested nor integrated. */ -/* Debug version is tricky and currently missing. */ -#include - -GC_API GC_ATTR_MALLOC void * GC_CALL GC_memalign(size_t align, size_t lb) -{ - size_t new_lb; - size_t offset; - ptr_t result; - - if (align <= GRANULE_BYTES) return GC_malloc(lb); - if (align >= HBLKSIZE/2 || lb >= HBLKSIZE/2) { - if (align > HBLKSIZE) { - return (*GC_get_oom_fn())(LONG_MAX-1024); /* Fail */ - } - return GC_malloc(lb <= HBLKSIZE? HBLKSIZE : lb); - /* Will be HBLKSIZE aligned. */ - } - /* We could also try to make sure that the real rounded-up object size */ - /* is a multiple of align. That would be correct up to HBLKSIZE. */ - new_lb = lb + align - 1; - result = GC_malloc(new_lb); - /* It is OK not to check result for NULL as in that case */ - /* GC_memalign returns NULL too since (0 + 0 % align) is 0. */ - offset = (word)result % align; - if (offset != 0) { - offset = align - offset; - if (!GC_all_interior_pointers) { - if (offset >= VALID_OFFSET_SZ) return GC_malloc(HBLKSIZE); - GC_register_displacement(offset); - } - } - result = (void *) ((ptr_t)result + offset); - GC_ASSERT((word)result % align == 0); - return result; -} - -/* This one exists largely to redirect posix_memalign for leaks finding. */ -GC_API int GC_CALL GC_posix_memalign(void **memptr, size_t align, size_t lb) -{ - /* Check alignment properly. */ - if (((align - 1) & align) != 0 || align < sizeof(void *)) { -# ifdef MSWINCE - return ERROR_INVALID_PARAMETER; -# else - return EINVAL; -# endif - } - - if ((*memptr = GC_memalign(align, lb)) == NULL) { -# ifdef MSWINCE - return ERROR_NOT_ENOUGH_MEMORY; -# else - return ENOMEM; -# endif - } - return 0; -} - -#ifdef ATOMIC_UNCOLLECTABLE - /* Allocate lb bytes of pointer-free, untraced, uncollectible data */ - /* This is normally roughly equivalent to the system malloc. */ - /* But it may be useful if malloc is redefined. */ - GC_API GC_ATTR_MALLOC void * GC_CALL - GC_malloc_atomic_uncollectable(size_t lb) - { - void *op; - size_t lg; - DCL_LOCK_STATE; - - if (SMALL_OBJ(lb)) { - GC_DBG_COLLECT_AT_MALLOC(lb); - if (EXTRA_BYTES != 0 && lb != 0) lb--; - /* We don't need the extra byte, since this won't be */ - /* collected anyway. */ - lg = GC_size_map[lb]; - LOCK(); - op = GC_auobjfreelist[lg]; - if (EXPECT(op != 0, TRUE)) { - GC_auobjfreelist[lg] = obj_link(op); - obj_link(op) = 0; - GC_bytes_allocd += GRANULES_TO_BYTES(lg); - /* Mark bit was already set while object was on free list. */ - GC_non_gc_bytes += GRANULES_TO_BYTES(lg); - UNLOCK(); - } else { - UNLOCK(); - op = (ptr_t)GC_generic_malloc(lb, AUNCOLLECTABLE); - } - GC_ASSERT(0 == op || GC_is_marked(op)); - return((void *) op); - } else { - hdr * hhdr; - - op = (ptr_t)GC_generic_malloc(lb, AUNCOLLECTABLE); - if (0 == op) return(0); - - GC_ASSERT(((word)op & (HBLKSIZE - 1)) == 0); - hhdr = HDR(op); - - LOCK(); - set_mark_bit_from_hdr(hhdr, 0); /* Only object. */ -# ifndef THREADS - GC_ASSERT(hhdr -> hb_n_marks == 0); -# endif - hhdr -> hb_n_marks = 1; - UNLOCK(); - return((void *) op); - } - } -#endif /* ATOMIC_UNCOLLECTABLE */ - -/* provide a version of strdup() that uses the collector to allocate the - copy of the string */ -GC_API GC_ATTR_MALLOC char * GC_CALL GC_strdup(const char *s) -{ - char *copy; - size_t lb; - if (s == NULL) return NULL; - lb = strlen(s) + 1; - if ((copy = GC_malloc_atomic(lb)) == NULL) { -# ifndef MSWINCE - errno = ENOMEM; -# endif - return NULL; - } - BCOPY(s, copy, lb); - return copy; -} - -GC_API GC_ATTR_MALLOC char * GC_CALL GC_strndup(const char *str, size_t size) -{ - char *copy; - size_t len = strlen(str); /* str is expected to be non-NULL */ - if (len > size) - len = size; - copy = GC_malloc_atomic(len + 1); - if (copy == NULL) { -# ifndef MSWINCE - errno = ENOMEM; -# endif - return NULL; - } - BCOPY(str, copy, len); - copy[len] = '\0'; - return copy; -} - -#ifdef GC_REQUIRE_WCSDUP -# include /* for wcslen() */ - - GC_API GC_ATTR_MALLOC wchar_t * GC_CALL GC_wcsdup(const wchar_t *str) - { - size_t lb = (wcslen(str) + 1) * sizeof(wchar_t); - wchar_t *copy = GC_malloc_atomic(lb); - if (copy == NULL) { -# ifndef MSWINCE - errno = ENOMEM; -# endif - return NULL; - } - BCOPY(str, copy, lb); - return copy; - } -#endif /* GC_REQUIRE_WCSDUP */ diff -Nru ecl-16.1.2/src/bdwgc/mark.c ecl-16.1.3+ds/src/bdwgc/mark.c --- ecl-16.1.2/src/bdwgc/mark.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/mark.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,1908 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1995 by Xerox Corporation. All rights reserved. - * Copyright (c) 2000 by Hewlett-Packard Company. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -#include "private/gc_pmark.h" - -#include - -#if defined(MSWIN32) && defined(__GNUC__) -# include -#endif - -/* Make arguments appear live to compiler. Put here to minimize the */ -/* risk of inlining. Used to minimize junk left in registers. */ -void GC_noop6(word arg1 GC_ATTR_UNUSED, word arg2 GC_ATTR_UNUSED, - word arg3 GC_ATTR_UNUSED, word arg4 GC_ATTR_UNUSED, - word arg5 GC_ATTR_UNUSED, word arg6 GC_ATTR_UNUSED) -{ - /* Empty */ -} - -/* Single argument version, robust against whole program analysis. */ -volatile word GC_noop_sink; -GC_API void GC_CALL GC_noop1(word x) -{ - GC_noop_sink = x; -} - -/* mark_proc GC_mark_procs[MAX_MARK_PROCS] = {0} -- declared in gc_priv.h */ - -GC_INNER unsigned GC_n_mark_procs = GC_RESERVED_MARK_PROCS; - -/* Initialize GC_obj_kinds properly and standard free lists properly. */ -/* This must be done statically since they may be accessed before */ -/* GC_init is called. */ -/* It's done here, since we need to deal with mark descriptors. */ -GC_INNER struct obj_kind GC_obj_kinds[MAXOBJKINDS] = { -/* PTRFREE */ { &GC_aobjfreelist[0], 0 /* filled in dynamically */, - 0 | GC_DS_LENGTH, FALSE, FALSE - /*, */ OK_DISCLAIM_INITZ }, -/* NORMAL */ { &GC_objfreelist[0], 0, - 0 | GC_DS_LENGTH, /* Adjusted in GC_init for EXTRA_BYTES */ - TRUE /* add length to descr */, TRUE - /*, */ OK_DISCLAIM_INITZ }, -/* UNCOLLECTABLE */ - { &GC_uobjfreelist[0], 0, - 0 | GC_DS_LENGTH, TRUE /* add length to descr */, TRUE - /*, */ OK_DISCLAIM_INITZ }, -# ifdef ATOMIC_UNCOLLECTABLE - /* AUNCOLLECTABLE */ - { &GC_auobjfreelist[0], 0, - 0 | GC_DS_LENGTH, FALSE /* add length to descr */, FALSE - /*, */ OK_DISCLAIM_INITZ }, -# endif -# ifdef STUBBORN_ALLOC -/*STUBBORN*/ { (void **)&GC_sobjfreelist[0], 0, - 0 | GC_DS_LENGTH, TRUE /* add length to descr */, TRUE - /*, */ OK_DISCLAIM_INITZ }, -# endif -}; - -# ifdef ATOMIC_UNCOLLECTABLE -# ifdef STUBBORN_ALLOC -# define GC_N_KINDS_INITIAL_VALUE 5 -# else -# define GC_N_KINDS_INITIAL_VALUE 4 -# endif -# else -# ifdef STUBBORN_ALLOC -# define GC_N_KINDS_INITIAL_VALUE 4 -# else -# define GC_N_KINDS_INITIAL_VALUE 3 -# endif -# endif - -GC_INNER unsigned GC_n_kinds = GC_N_KINDS_INITIAL_VALUE; - -# ifndef INITIAL_MARK_STACK_SIZE -# define INITIAL_MARK_STACK_SIZE (1*HBLKSIZE) - /* INITIAL_MARK_STACK_SIZE * sizeof(mse) should be a */ - /* multiple of HBLKSIZE. */ - /* The incremental collector actually likes a larger */ - /* size, since it want to push all marked dirty objs */ - /* before marking anything new. Currently we let it */ - /* grow dynamically. */ -# endif - -STATIC word GC_n_rescuing_pages = 0; - /* Number of dirty pages we marked from */ - /* excludes ptrfree pages, etc. */ - -GC_INNER size_t GC_mark_stack_size = 0; - -#ifdef PARALLEL_MARK - STATIC volatile AO_t GC_first_nonempty = 0; - /* Lowest entry on mark stack */ - /* that may be nonempty. */ - /* Updated only by initiating */ - /* thread. */ -#endif - -GC_INNER mark_state_t GC_mark_state = MS_NONE; - -GC_INNER GC_bool GC_mark_stack_too_small = FALSE; - -static struct hblk * scan_ptr; - -STATIC GC_bool GC_objects_are_marked = FALSE; - /* Are there collectible marked objects in the heap? */ - -/* Is a collection in progress? Note that this can return true in the */ -/* nonincremental case, if a collection has been abandoned and the */ -/* mark state is now MS_INVALID. */ -GC_INNER GC_bool GC_collection_in_progress(void) -{ - return(GC_mark_state != MS_NONE); -} - -/* clear all mark bits in the header */ -GC_INNER void GC_clear_hdr_marks(hdr *hhdr) -{ - size_t last_bit = FINAL_MARK_BIT(hhdr -> hb_sz); - BZERO(hhdr -> hb_marks, sizeof(hhdr->hb_marks)); - set_mark_bit_from_hdr(hhdr, last_bit); - hhdr -> hb_n_marks = 0; -} - -/* Set all mark bits in the header. Used for uncollectible blocks. */ -GC_INNER void GC_set_hdr_marks(hdr *hhdr) -{ - unsigned i; - size_t sz = hhdr -> hb_sz; - unsigned n_marks = (unsigned)FINAL_MARK_BIT(sz); - -# ifdef USE_MARK_BYTES - for (i = 0; i <= n_marks; i += (unsigned)MARK_BIT_OFFSET(sz)) { - hhdr -> hb_marks[i] = 1; - } -# else - for (i = 0; i < divWORDSZ(n_marks + WORDSZ); ++i) { - hhdr -> hb_marks[i] = ONES; - } -# endif -# ifdef MARK_BIT_PER_OBJ - hhdr -> hb_n_marks = n_marks - 1; -# else - hhdr -> hb_n_marks = HBLK_OBJS(sz); -# endif -} - -/* - * Clear all mark bits associated with block h. - */ -static void clear_marks_for_block(struct hblk *h, word dummy GC_ATTR_UNUSED) -{ - register hdr * hhdr = HDR(h); - - if (IS_UNCOLLECTABLE(hhdr -> hb_obj_kind)) return; - /* Mark bit for these is cleared only once the object is */ - /* explicitly deallocated. This either frees the block, or */ - /* the bit is cleared once the object is on the free list. */ - GC_clear_hdr_marks(hhdr); -} - -/* Slow but general routines for setting/clearing/asking about mark bits */ -GC_API void GC_CALL GC_set_mark_bit(const void *p) -{ - struct hblk *h = HBLKPTR(p); - hdr * hhdr = HDR(h); - word bit_no = MARK_BIT_NO((ptr_t)p - (ptr_t)h, hhdr -> hb_sz); - - if (!mark_bit_from_hdr(hhdr, bit_no)) { - set_mark_bit_from_hdr(hhdr, bit_no); - ++hhdr -> hb_n_marks; - } -} - -GC_API void GC_CALL GC_clear_mark_bit(const void *p) -{ - struct hblk *h = HBLKPTR(p); - hdr * hhdr = HDR(h); - word bit_no = MARK_BIT_NO((ptr_t)p - (ptr_t)h, hhdr -> hb_sz); - - if (mark_bit_from_hdr(hhdr, bit_no)) { - size_t n_marks; - clear_mark_bit_from_hdr(hhdr, bit_no); - n_marks = hhdr -> hb_n_marks - 1; -# ifdef PARALLEL_MARK - if (n_marks != 0 || !GC_parallel) - hhdr -> hb_n_marks = n_marks; - /* Don't decrement to zero. The counts are approximate due to */ - /* concurrency issues, but we need to ensure that a count of */ - /* zero implies an empty block. */ -# else - hhdr -> hb_n_marks = n_marks; -# endif - } -} - -GC_API int GC_CALL GC_is_marked(const void *p) -{ - struct hblk *h = HBLKPTR(p); - hdr * hhdr = HDR(h); - word bit_no = MARK_BIT_NO((ptr_t)p - (ptr_t)h, hhdr -> hb_sz); - - return (int)mark_bit_from_hdr(hhdr, bit_no); /* 0 or 1 */ -} - -/* - * Clear mark bits in all allocated heap blocks. This invalidates - * the marker invariant, and sets GC_mark_state to reflect this. - * (This implicitly starts marking to reestablish the invariant.) - */ -GC_INNER void GC_clear_marks(void) -{ - GC_apply_to_all_blocks(clear_marks_for_block, (word)0); - GC_objects_are_marked = FALSE; - GC_mark_state = MS_INVALID; - scan_ptr = 0; -} - -#ifdef CHECKSUMS - void GC_check_dirty(void); -#endif - -/* Initiate a garbage collection. Initiates a full collection if the */ -/* mark state is invalid. */ -GC_INNER void GC_initiate_gc(void) -{ -# ifndef GC_DISABLE_INCREMENTAL - if (GC_dirty_maintained) GC_read_dirty(); -# endif -# ifdef STUBBORN_ALLOC - GC_read_changed(); -# endif -# ifdef CHECKSUMS - if (GC_dirty_maintained) GC_check_dirty(); -# endif - GC_n_rescuing_pages = 0; - if (GC_mark_state == MS_NONE) { - GC_mark_state = MS_PUSH_RESCUERS; - } else if (GC_mark_state != MS_INVALID) { - ABORT("Unexpected state"); - } /* else this is really a full collection, and mark */ - /* bits are invalid. */ - scan_ptr = 0; -} - -#ifdef PARALLEL_MARK - STATIC void GC_do_parallel_mark(void); /* initiate parallel marking. */ -#endif /* PARALLEL_MARK */ - -#ifdef GC_DISABLE_INCREMENTAL -# define GC_push_next_marked_dirty(h) GC_push_next_marked(h) -#else - STATIC struct hblk * GC_push_next_marked_dirty(struct hblk *h); - /* Invoke GC_push_marked on next dirty block above h. */ - /* Return a pointer just past the end of this block. */ -#endif /* !GC_DISABLE_INCREMENTAL */ -STATIC struct hblk * GC_push_next_marked(struct hblk *h); - /* Ditto, but also mark from clean pages. */ -STATIC struct hblk * GC_push_next_marked_uncollectable(struct hblk *h); - /* Ditto, but mark only from uncollectible pages. */ - -static void alloc_mark_stack(size_t); - -# if (((defined(MSWIN32) || defined(MSWINCE)) && !defined(__GNUC__)) \ - || (defined(MSWIN32) && defined(I386)) /* for Win98 */ \ - || (defined(USE_PROC_FOR_LIBRARIES) && defined(THREADS))) \ - && !defined(NO_WRAP_MARK_SOME) - /* Under rare conditions, we may end up marking from nonexistent memory. */ - /* Hence we need to be prepared to recover by running GC_mark_some */ - /* with a suitable handler in place. */ - /* FIXME: Should we really need it for WinCE? If yes then */ - /* WRAP_MARK_SOME should be also defined for CeGCC which requires */ - /* CPU/OS-specific code in mark_ex_handler() and GC_mark_some() */ - /* (for manual stack unwinding and exception handler installation). */ -# define WRAP_MARK_SOME -# endif - -/* Perform a small amount of marking. */ -/* We try to touch roughly a page of memory. */ -/* Return TRUE if we just finished a mark phase. */ -/* Cold_gc_frame is an address inside a GC frame that */ -/* remains valid until all marking is complete. */ -/* A zero value indicates that it's OK to miss some */ -/* register values. */ -/* We hold the allocation lock. In the case of */ -/* incremental collection, the world may not be stopped.*/ -#ifdef WRAP_MARK_SOME - /* For win32, this is called after we establish a structured */ - /* exception handler, in case Windows unmaps one of our root */ - /* segments. See below. In either case, we acquire the */ - /* allocator lock long before we get here. */ - STATIC GC_bool GC_mark_some_inner(ptr_t cold_gc_frame) -#else - GC_INNER GC_bool GC_mark_some(ptr_t cold_gc_frame) -#endif -{ - switch(GC_mark_state) { - case MS_NONE: - break; - - case MS_PUSH_RESCUERS: - if ((word)GC_mark_stack_top - >= (word)(GC_mark_stack_limit - INITIAL_MARK_STACK_SIZE/2)) { - /* Go ahead and mark, even though that might cause us to */ - /* see more marked dirty objects later on. Avoid this */ - /* in the future. */ - GC_mark_stack_too_small = TRUE; - MARK_FROM_MARK_STACK(); - break; - } else { - scan_ptr = GC_push_next_marked_dirty(scan_ptr); - if (scan_ptr == 0) { - GC_COND_LOG_PRINTF("Marked from %lu dirty pages\n", - (unsigned long)GC_n_rescuing_pages); - GC_push_roots(FALSE, cold_gc_frame); - GC_objects_are_marked = TRUE; - if (GC_mark_state != MS_INVALID) { - GC_mark_state = MS_ROOTS_PUSHED; - } - } - } - break; - - case MS_PUSH_UNCOLLECTABLE: - if ((word)GC_mark_stack_top - >= (word)(GC_mark_stack + GC_mark_stack_size/4)) { -# ifdef PARALLEL_MARK - /* Avoid this, since we don't parallelize the marker */ - /* here. */ - if (GC_parallel) GC_mark_stack_too_small = TRUE; -# endif - MARK_FROM_MARK_STACK(); - break; - } else { - scan_ptr = GC_push_next_marked_uncollectable(scan_ptr); - if (scan_ptr == 0) { - GC_push_roots(TRUE, cold_gc_frame); - GC_objects_are_marked = TRUE; - if (GC_mark_state != MS_INVALID) { - GC_mark_state = MS_ROOTS_PUSHED; - } - } - } - break; - - case MS_ROOTS_PUSHED: -# ifdef PARALLEL_MARK - /* In the incremental GC case, this currently doesn't */ - /* quite do the right thing, since it runs to */ - /* completion. On the other hand, starting a */ - /* parallel marker is expensive, so perhaps it is */ - /* the right thing? */ - /* Eventually, incremental marking should run */ - /* asynchronously in multiple threads, without grabbing */ - /* the allocation lock. */ - if (GC_parallel) { - GC_do_parallel_mark(); - GC_ASSERT((word)GC_mark_stack_top < (word)GC_first_nonempty); - GC_mark_stack_top = GC_mark_stack - 1; - if (GC_mark_stack_too_small) { - alloc_mark_stack(2*GC_mark_stack_size); - } - if (GC_mark_state == MS_ROOTS_PUSHED) { - GC_mark_state = MS_NONE; - return(TRUE); - } - break; - } -# endif - if ((word)GC_mark_stack_top >= (word)GC_mark_stack) { - MARK_FROM_MARK_STACK(); - break; - } else { - GC_mark_state = MS_NONE; - if (GC_mark_stack_too_small) { - alloc_mark_stack(2*GC_mark_stack_size); - } - return(TRUE); - } - - case MS_INVALID: - case MS_PARTIALLY_INVALID: - if (!GC_objects_are_marked) { - GC_mark_state = MS_PUSH_UNCOLLECTABLE; - break; - } - if ((word)GC_mark_stack_top >= (word)GC_mark_stack) { - MARK_FROM_MARK_STACK(); - break; - } - if (scan_ptr == 0 && GC_mark_state == MS_INVALID) { - /* About to start a heap scan for marked objects. */ - /* Mark stack is empty. OK to reallocate. */ - if (GC_mark_stack_too_small) { - alloc_mark_stack(2*GC_mark_stack_size); - } - GC_mark_state = MS_PARTIALLY_INVALID; - } - scan_ptr = GC_push_next_marked(scan_ptr); - if (scan_ptr == 0 && GC_mark_state == MS_PARTIALLY_INVALID) { - GC_push_roots(TRUE, cold_gc_frame); - GC_objects_are_marked = TRUE; - if (GC_mark_state != MS_INVALID) { - GC_mark_state = MS_ROOTS_PUSHED; - } - } - break; - - default: - ABORT("GC_mark_some: bad state"); - } - return(FALSE); -} - -#ifdef WRAP_MARK_SOME - -# if (defined(MSWIN32) || defined(MSWINCE)) && defined(__GNUC__) - - typedef struct { - EXCEPTION_REGISTRATION ex_reg; - void *alt_path; - } ext_ex_regn; - - static EXCEPTION_DISPOSITION mark_ex_handler( - struct _EXCEPTION_RECORD *ex_rec, - void *est_frame, - struct _CONTEXT *context, - void *disp_ctxt GC_ATTR_UNUSED) - { - if (ex_rec->ExceptionCode == STATUS_ACCESS_VIOLATION) { - ext_ex_regn *xer = (ext_ex_regn *)est_frame; - - /* Unwind from the inner function assuming the standard */ - /* function prologue. */ - /* Assumes code has not been compiled with */ - /* -fomit-frame-pointer. */ - context->Esp = context->Ebp; - context->Ebp = *((DWORD *)context->Esp); - context->Esp = context->Esp - 8; - - /* Resume execution at the "real" handler within the */ - /* wrapper function. */ - context->Eip = (DWORD )(xer->alt_path); - - return ExceptionContinueExecution; - - } else { - return ExceptionContinueSearch; - } - } -# endif /* __GNUC__ && MSWIN32 */ - -#if defined(GC_WIN32_THREADS) && !defined(__GNUC__) - GC_INNER GC_bool GC_started_thread_while_stopped(void); - /* In win32_threads.c. Did we invalidate mark phase with an */ - /* unexpected thread start? */ -#endif - - GC_INNER GC_bool GC_mark_some(ptr_t cold_gc_frame) - { - GC_bool ret_val; - -# if defined(MSWIN32) || defined(MSWINCE) -# ifndef __GNUC__ - /* Windows 98 appears to asynchronously create and remove */ - /* writable memory mappings, for reasons we haven't yet */ - /* understood. Since we look for writable regions to */ - /* determine the root set, we may try to mark from an */ - /* address range that disappeared since we started the */ - /* collection. Thus we have to recover from faults here. */ - /* This code does not appear to be necessary for Windows */ - /* 95/NT/2000+. Note that this code should never generate */ - /* an incremental GC write fault. */ - /* This code seems to be necessary for WinCE (at least in */ - /* the case we'd decide to add MEM_PRIVATE sections to */ - /* data roots in GC_register_dynamic_libraries()). */ - /* It's conceivable that this is the same issue with */ - /* terminating threads that we see with Linux and */ - /* USE_PROC_FOR_LIBRARIES. */ - - __try { - ret_val = GC_mark_some_inner(cold_gc_frame); - } __except (GetExceptionCode() == EXCEPTION_ACCESS_VIOLATION ? - EXCEPTION_EXECUTE_HANDLER : EXCEPTION_CONTINUE_SEARCH) { - goto handle_ex; - } -# ifdef GC_WIN32_THREADS - /* With DllMain-based thread tracking, a thread may have */ - /* started while we were marking. This is logically equivalent */ - /* to the exception case; our results are invalid and we have */ - /* to start over. This cannot be prevented since we can't */ - /* block in DllMain. */ - if (GC_started_thread_while_stopped()) goto handle_ex; -# endif - rm_handler: - return ret_val; - -# else /* __GNUC__ */ - - /* Manually install an exception handler since GCC does */ - /* not yet support Structured Exception Handling (SEH) on */ - /* Win32. */ - - ext_ex_regn er; - - er.alt_path = &&handle_ex; - er.ex_reg.handler = mark_ex_handler; - __asm__ __volatile__ ("movl %%fs:0, %0" : "=r" (er.ex_reg.prev)); - __asm__ __volatile__ ("movl %0, %%fs:0" : : "r" (&er)); - ret_val = GC_mark_some_inner(cold_gc_frame); - /* Prevent GCC from considering the following code unreachable */ - /* and thus eliminating it. */ - if (er.alt_path == 0) - goto handle_ex; - rm_handler: - /* Uninstall the exception handler */ - __asm__ __volatile__ ("mov %0, %%fs:0" : : "r" (er.ex_reg.prev)); - return ret_val; - -# endif /* __GNUC__ */ -# else /* !MSWIN32 */ - /* Here we are handling the case in which /proc is used for root */ - /* finding, and we have threads. We may find a stack for a */ - /* thread that is in the process of exiting, and disappears */ - /* while we are marking it. This seems extremely difficult to */ - /* avoid otherwise. */ - if (GC_incremental) { - WARN("Incremental GC incompatible with /proc roots\n", 0); - /* I'm not sure if this could still work ... */ - } - GC_setup_temporary_fault_handler(); - if(SETJMP(GC_jmp_buf) != 0) goto handle_ex; - ret_val = GC_mark_some_inner(cold_gc_frame); - rm_handler: - GC_reset_fault_handler(); - return ret_val; - -# endif /* !MSWIN32 */ - -handle_ex: - /* Exception handler starts here for all cases. */ - WARN("Caught ACCESS_VIOLATION in marker;" - " memory mapping disappeared\n", 0); - - /* We have bad roots on the stack. Discard mark stack. */ - /* Rescan from marked objects. Redetermine roots. */ - GC_invalidate_mark_state(); - scan_ptr = 0; - - ret_val = FALSE; - goto rm_handler; /* Back to platform-specific code. */ - } -#endif /* WRAP_MARK_SOME */ - -GC_INNER void GC_invalidate_mark_state(void) -{ - GC_mark_state = MS_INVALID; - GC_mark_stack_top = GC_mark_stack-1; -} - -GC_INNER mse * GC_signal_mark_stack_overflow(mse *msp) -{ - GC_mark_state = MS_INVALID; -# ifdef PARALLEL_MARK - /* We are using a local_mark_stack in parallel mode, so */ - /* do not signal the global mark stack to be resized. */ - /* That will be done if required in GC_return_mark_stack. */ - if (!GC_parallel) - GC_mark_stack_too_small = TRUE; -# else - GC_mark_stack_too_small = TRUE; -# endif - GC_COND_LOG_PRINTF("Mark stack overflow; current size = %lu entries\n", - (unsigned long)GC_mark_stack_size); - return(msp - GC_MARK_STACK_DISCARDS); -} - -/* - * Mark objects pointed to by the regions described by - * mark stack entries between mark_stack and mark_stack_top, - * inclusive. Assumes the upper limit of a mark stack entry - * is never 0. A mark stack entry never has size 0. - * We try to traverse on the order of a hblk of memory before we return. - * Caller is responsible for calling this until the mark stack is empty. - * Note that this is the most performance critical routine in the - * collector. Hence it contains all sorts of ugly hacks to speed - * things up. In particular, we avoid procedure calls on the common - * path, we take advantage of peculiarities of the mark descriptor - * encoding, we optionally maintain a cache for the block address to - * header mapping, we prefetch when an object is "grayed", etc. - */ -GC_INNER mse * GC_mark_from(mse *mark_stack_top, mse *mark_stack, - mse *mark_stack_limit) -{ - signed_word credit = HBLKSIZE; /* Remaining credit for marking work */ - ptr_t current_p; /* Pointer to current candidate ptr. */ - word current; /* Candidate pointer. */ - ptr_t limit; /* (Incl) limit of current candidate range. */ - word descr; - ptr_t greatest_ha = GC_greatest_plausible_heap_addr; - ptr_t least_ha = GC_least_plausible_heap_addr; - DECLARE_HDR_CACHE; - -# define SPLIT_RANGE_WORDS 128 /* Must be power of 2. */ - - GC_objects_are_marked = TRUE; - INIT_HDR_CACHE; -# ifdef OS2 /* Use untweaked version to circumvent compiler problem */ - while ((word)mark_stack_top >= (word)mark_stack && credit >= 0) -# else - while ((((ptr_t)mark_stack_top - (ptr_t)mark_stack) | credit) >= 0) -# endif - { - current_p = mark_stack_top -> mse_start; - descr = mark_stack_top -> mse_descr.w; - retry: - /* current_p and descr describe the current object. */ - /* *mark_stack_top is vacant. */ - /* The following is 0 only for small objects described by a simple */ - /* length descriptor. For many applications this is the common */ - /* case, so we try to detect it quickly. */ - if (descr & ((~(WORDS_TO_BYTES(SPLIT_RANGE_WORDS) - 1)) | GC_DS_TAGS)) { - word tag = descr & GC_DS_TAGS; - - switch(tag) { - case GC_DS_LENGTH: - /* Large length. */ - /* Process part of the range to avoid pushing too much on the */ - /* stack. */ - GC_ASSERT(descr < (word)GC_greatest_plausible_heap_addr - - (word)GC_least_plausible_heap_addr); -# ifdef ENABLE_TRACE - if ((word)GC_trace_addr >= (word)current_p - && (word)GC_trace_addr < (word)(current_p + descr)) { - GC_log_printf("GC #%u: large section; start %p, len %lu\n", - (unsigned)GC_gc_no, current_p, (unsigned long)descr); - } -# endif /* ENABLE_TRACE */ -# ifdef PARALLEL_MARK -# define SHARE_BYTES 2048 - if (descr > SHARE_BYTES && GC_parallel - && (word)mark_stack_top < (word)(mark_stack_limit - 1)) { - int new_size = (descr/2) & ~(sizeof(word)-1); - mark_stack_top -> mse_start = current_p; - mark_stack_top -> mse_descr.w = new_size + sizeof(word); - /* makes sure we handle */ - /* misaligned pointers. */ - mark_stack_top++; -# ifdef ENABLE_TRACE - if ((word)GC_trace_addr >= (word)current_p - && (word)GC_trace_addr < (word)(current_p + descr)) { - GC_log_printf("GC #%u: splitting (parallel) %p at %p\n", - (unsigned)GC_gc_no, current_p, current_p + new_size); - } -# endif /* ENABLE_TRACE */ - current_p += new_size; - descr -= new_size; - goto retry; - } -# endif /* PARALLEL_MARK */ - mark_stack_top -> mse_start = - limit = current_p + WORDS_TO_BYTES(SPLIT_RANGE_WORDS-1); - mark_stack_top -> mse_descr.w = - descr - WORDS_TO_BYTES(SPLIT_RANGE_WORDS-1); -# ifdef ENABLE_TRACE - if ((word)GC_trace_addr >= (word)current_p - && (word)GC_trace_addr < (word)(current_p + descr)) { - GC_log_printf("GC #%u: splitting %p at %p\n", - (unsigned)GC_gc_no, current_p, limit); - } -# endif /* ENABLE_TRACE */ - /* Make sure that pointers overlapping the two ranges are */ - /* considered. */ - limit += sizeof(word) - ALIGNMENT; - break; - case GC_DS_BITMAP: - mark_stack_top--; -# ifdef ENABLE_TRACE - if ((word)GC_trace_addr >= (word)current_p - && (word)GC_trace_addr < (word)(current_p - + WORDS_TO_BYTES(WORDSZ-2))) { - GC_log_printf("GC #%u: tracing from %p bitmap descr %lu\n", - (unsigned)GC_gc_no, current_p, - (unsigned long)descr); - } -# endif /* ENABLE_TRACE */ - descr &= ~GC_DS_TAGS; - credit -= WORDS_TO_BYTES(WORDSZ/2); /* guess */ - while (descr != 0) { - if ((signed_word)descr < 0) { - current = *(word *)current_p; - FIXUP_POINTER(current); - if (current >= (word)least_ha && current < (word)greatest_ha) { - PREFETCH((ptr_t)current); -# ifdef ENABLE_TRACE - if (GC_trace_addr == current_p) { - GC_log_printf("GC #%u: considering(3) %p -> %p\n", - (unsigned)GC_gc_no, current_p, - (ptr_t)current); - } -# endif /* ENABLE_TRACE */ - PUSH_CONTENTS((ptr_t)current, mark_stack_top, - mark_stack_limit, current_p, exit1); - } - } - descr <<= 1; - current_p += sizeof(word); - } - continue; - case GC_DS_PROC: - mark_stack_top--; -# ifdef ENABLE_TRACE - if ((word)GC_trace_addr >= (word)current_p - && GC_base(current_p) != 0 - && GC_base(current_p) == GC_base(GC_trace_addr)) { - GC_log_printf("GC #%u: tracing from %p, proc descr %lu\n", - (unsigned)GC_gc_no, current_p, - (unsigned long)descr); - } -# endif /* ENABLE_TRACE */ - credit -= GC_PROC_BYTES; - mark_stack_top = (*PROC(descr))((word *)current_p, mark_stack_top, - mark_stack_limit, ENV(descr)); - continue; - case GC_DS_PER_OBJECT: - if ((signed_word)descr >= 0) { - /* Descriptor is in the object. */ - descr = *(word *)(current_p + descr - GC_DS_PER_OBJECT); - } else { - /* Descriptor is in type descriptor pointed to by first */ - /* word in object. */ - ptr_t type_descr = *(ptr_t *)current_p; - /* type_descr is either a valid pointer to the descriptor */ - /* structure, or this object was on a free list. If it */ - /* it was anything but the last object on the free list, */ - /* we will misinterpret the next object on the free list as */ - /* the type descriptor, and get a 0 GC descriptor, which */ - /* is ideal. Unfortunately, we need to check for the last */ - /* object case explicitly. */ - if (0 == type_descr) { - /* Rarely executed. */ - mark_stack_top--; - continue; - } - descr = *(word *)(type_descr - - (descr + (GC_INDIR_PER_OBJ_BIAS - - GC_DS_PER_OBJECT))); - } - if (0 == descr) { - /* Can happen either because we generated a 0 descriptor */ - /* or we saw a pointer to a free object. */ - mark_stack_top--; - continue; - } - goto retry; - default: - limit = 0; /* initialized to prevent warning. */ - ABORT_RET("GC_mark_from: bad state"); - } - } else /* Small object with length descriptor */ { - mark_stack_top--; -# ifndef SMALL_CONFIG - if (descr < sizeof(word)) - continue; -# endif - limit = current_p + (word)descr; - } -# ifdef ENABLE_TRACE - if ((word)GC_trace_addr >= (word)current_p - && (word)GC_trace_addr < (word)limit) { - GC_log_printf("GC #%u: Tracing from %p, length is %lu\n", - (unsigned)GC_gc_no, current_p, (unsigned long)descr); - } -# endif /* ENABLE_TRACE */ - /* The simple case in which we're scanning a range. */ - GC_ASSERT(!((word)current_p & (ALIGNMENT-1))); - credit -= limit - current_p; - limit -= sizeof(word); - { -# define PREF_DIST 4 - -# ifndef SMALL_CONFIG - word deferred; - - /* Try to prefetch the next pointer to be examined ASAP. */ - /* Empirically, this also seems to help slightly without */ - /* prefetches, at least on linux/X86. Presumably this loop */ - /* ends up with less register pressure, and gcc thus ends up */ - /* generating slightly better code. Overall gcc code quality */ - /* for this loop is still not great. */ - for(;;) { - PREFETCH(limit - PREF_DIST*CACHE_LINE_SIZE); - GC_ASSERT((word)limit >= (word)current_p); - deferred = *(word *)limit; - FIXUP_POINTER(deferred); - limit -= ALIGNMENT; - if (deferred >= (word)least_ha && deferred < (word)greatest_ha) { - PREFETCH((ptr_t)deferred); - break; - } - if ((word)current_p > (word)limit) goto next_object; - /* Unroll once, so we don't do too many of the prefetches */ - /* based on limit. */ - deferred = *(word *)limit; - FIXUP_POINTER(deferred); - limit -= ALIGNMENT; - if (deferred >= (word)least_ha && deferred < (word)greatest_ha) { - PREFETCH((ptr_t)deferred); - break; - } - if ((word)current_p > (word)limit) goto next_object; - } -# endif - - while ((word)current_p <= (word)limit) { - /* Empirically, unrolling this loop doesn't help a lot. */ - /* Since PUSH_CONTENTS expands to a lot of code, */ - /* we don't. */ - current = *(word *)current_p; - FIXUP_POINTER(current); - PREFETCH(current_p + PREF_DIST*CACHE_LINE_SIZE); - if (current >= (word)least_ha && current < (word)greatest_ha) { - /* Prefetch the contents of the object we just pushed. It's */ - /* likely we will need them soon. */ - PREFETCH((ptr_t)current); -# ifdef ENABLE_TRACE - if (GC_trace_addr == current_p) { - GC_log_printf("GC #%u: considering(1) %p -> %p\n", - (unsigned)GC_gc_no, current_p, (ptr_t)current); - } -# endif /* ENABLE_TRACE */ - PUSH_CONTENTS((ptr_t)current, mark_stack_top, - mark_stack_limit, current_p, exit2); - } - current_p += ALIGNMENT; - } - -# ifndef SMALL_CONFIG - /* We still need to mark the entry we previously prefetched. */ - /* We already know that it passes the preliminary pointer */ - /* validity test. */ -# ifdef ENABLE_TRACE - if (GC_trace_addr == current_p) { - GC_log_printf("GC #%u: considering(2) %p -> %p\n", - (unsigned)GC_gc_no, current_p, (ptr_t)deferred); - } -# endif /* ENABLE_TRACE */ - PUSH_CONTENTS((ptr_t)deferred, mark_stack_top, - mark_stack_limit, current_p, exit4); - next_object:; -# endif - } - } - return mark_stack_top; -} - -#ifdef PARALLEL_MARK - -STATIC GC_bool GC_help_wanted = FALSE; /* Protected by mark lock */ -STATIC unsigned GC_helper_count = 0; /* Number of running helpers. */ - /* Protected by mark lock */ -STATIC unsigned GC_active_count = 0; /* Number of active helpers. */ - /* Protected by mark lock */ - /* May increase and decrease */ - /* within each mark cycle. But */ - /* once it returns to 0, it */ - /* stays zero for the cycle. */ - -GC_INNER word GC_mark_no = 0; - -#define LOCAL_MARK_STACK_SIZE HBLKSIZE - /* Under normal circumstances, this is big enough to guarantee */ - /* we don't overflow half of it in a single call to */ - /* GC_mark_from. */ - - -/* Steal mark stack entries starting at mse low into mark stack local */ -/* until we either steal mse high, or we have max entries. */ -/* Return a pointer to the top of the local mark stack. */ -/* *next is replaced by a pointer to the next unscanned mark stack */ -/* entry. */ -STATIC mse * GC_steal_mark_stack(mse * low, mse * high, mse * local, - unsigned max, mse **next) -{ - mse *p; - mse *top = local - 1; - unsigned i = 0; - - GC_ASSERT((word)high >= (word)(low - 1) - && (word)(high - low + 1) <= GC_mark_stack_size); - for (p = low; (word)p <= (word)high && i <= max; ++p) { - word descr = (word)AO_load(&p->mse_descr.ao); - if (descr != 0) { - /* Must be ordered after read of descr: */ - AO_store_release_write(&p->mse_descr.ao, 0); - /* More than one thread may get this entry, but that's only */ - /* a minor performance problem. */ - ++top; - top -> mse_descr.w = descr; - top -> mse_start = p -> mse_start; - GC_ASSERT((top->mse_descr.w & GC_DS_TAGS) != GC_DS_LENGTH || - top->mse_descr.w < (word)GC_greatest_plausible_heap_addr - - (word)GC_least_plausible_heap_addr); - /* If this is a big object, count it as */ - /* size/256 + 1 objects. */ - ++i; - if ((descr & GC_DS_TAGS) == GC_DS_LENGTH) i += (int)(descr >> 8); - } - } - *next = p; - return top; -} - -/* Copy back a local mark stack. */ -/* low and high are inclusive bounds. */ -STATIC void GC_return_mark_stack(mse * low, mse * high) -{ - mse * my_top; - mse * my_start; - size_t stack_size; - - if ((word)high < (word)low) return; - stack_size = high - low + 1; - GC_acquire_mark_lock(); - my_top = GC_mark_stack_top; /* Concurrent modification impossible. */ - my_start = my_top + 1; - if ((word)(my_start - GC_mark_stack + stack_size) - > (word)GC_mark_stack_size) { - GC_COND_LOG_PRINTF("No room to copy back mark stack\n"); - GC_mark_state = MS_INVALID; - GC_mark_stack_too_small = TRUE; - /* We drop the local mark stack. We'll fix things later. */ - } else { - BCOPY(low, my_start, stack_size * sizeof(mse)); - GC_ASSERT((mse *)AO_load((volatile AO_t *)(&GC_mark_stack_top)) - == my_top); - AO_store_release_write((volatile AO_t *)(&GC_mark_stack_top), - (AO_t)(my_top + stack_size)); - /* Ensures visibility of previously written stack contents. */ - } - GC_release_mark_lock(); - GC_notify_all_marker(); -} - -/* Mark from the local mark stack. */ -/* On return, the local mark stack is empty. */ -/* But this may be achieved by copying the */ -/* local mark stack back into the global one. */ -STATIC void GC_do_local_mark(mse *local_mark_stack, mse *local_top) -{ - unsigned n; -# define N_LOCAL_ITERS 1 - -# ifdef GC_ASSERTIONS - /* Make sure we don't hold mark lock. */ - GC_acquire_mark_lock(); - GC_release_mark_lock(); -# endif - for (;;) { - for (n = 0; n < N_LOCAL_ITERS; ++n) { - local_top = GC_mark_from(local_top, local_mark_stack, - local_mark_stack + LOCAL_MARK_STACK_SIZE); - if ((word)local_top < (word)local_mark_stack) return; - if ((word)(local_top - local_mark_stack) - >= LOCAL_MARK_STACK_SIZE / 2) { - GC_return_mark_stack(local_mark_stack, local_top); - return; - } - } - if ((word)AO_load((volatile AO_t *)&GC_mark_stack_top) - < (word)AO_load(&GC_first_nonempty) - && GC_active_count < GC_helper_count - && (word)local_top > (word)(local_mark_stack + 1)) { - /* Try to share the load, since the main stack is empty, */ - /* and helper threads are waiting for a refill. */ - /* The entries near the bottom of the stack are likely */ - /* to require more work. Thus we return those, even though */ - /* it's harder. */ - mse * new_bottom = local_mark_stack - + (local_top - local_mark_stack)/2; - GC_ASSERT((word)new_bottom > (word)local_mark_stack - && (word)new_bottom < (word)local_top); - GC_return_mark_stack(local_mark_stack, new_bottom - 1); - memmove(local_mark_stack, new_bottom, - (local_top - new_bottom + 1) * sizeof(mse)); - local_top -= (new_bottom - local_mark_stack); - } - } -} - -#define ENTRIES_TO_GET 5 - -/* Mark using the local mark stack until the global mark stack is empty */ -/* and there are no active workers. Update GC_first_nonempty to reflect */ -/* progress. */ -/* Caller does not hold mark lock. */ -/* Caller has already incremented GC_helper_count. We decrement it, */ -/* and maintain GC_active_count. */ -STATIC void GC_mark_local(mse *local_mark_stack, int id) -{ - mse * my_first_nonempty; - - GC_acquire_mark_lock(); - GC_active_count++; - my_first_nonempty = (mse *)AO_load(&GC_first_nonempty); - GC_ASSERT((word)GC_mark_stack <= (word)my_first_nonempty); - GC_ASSERT((word)my_first_nonempty - <= (word)AO_load((volatile AO_t *)&GC_mark_stack_top) + sizeof(mse)); - GC_VERBOSE_LOG_PRINTF("Starting mark helper %lu\n", (unsigned long)id); - GC_release_mark_lock(); - for (;;) { - size_t n_on_stack; - unsigned n_to_get; - mse * my_top; - mse * local_top; - mse * global_first_nonempty = (mse *)AO_load(&GC_first_nonempty); - - GC_ASSERT((word)my_first_nonempty >= (word)GC_mark_stack && - (word)my_first_nonempty <= - (word)AO_load((volatile AO_t *)&GC_mark_stack_top) - + sizeof(mse)); - GC_ASSERT((word)global_first_nonempty >= (word)GC_mark_stack && - (word)global_first_nonempty <= - (word)AO_load((volatile AO_t *)&GC_mark_stack_top) - + sizeof(mse)); - if ((word)my_first_nonempty < (word)global_first_nonempty) { - my_first_nonempty = global_first_nonempty; - } else if ((word)global_first_nonempty < (word)my_first_nonempty) { - AO_compare_and_swap(&GC_first_nonempty, - (AO_t) global_first_nonempty, - (AO_t) my_first_nonempty); - /* If this fails, we just go ahead, without updating */ - /* GC_first_nonempty. */ - } - /* Perhaps we should also update GC_first_nonempty, if it */ - /* is less. But that would require using atomic updates. */ - my_top = (mse *)AO_load_acquire((volatile AO_t *)(&GC_mark_stack_top)); - n_on_stack = my_top - my_first_nonempty + 1; - if (0 == n_on_stack) { - GC_acquire_mark_lock(); - my_top = GC_mark_stack_top; - /* Asynchronous modification impossible here, */ - /* since we hold mark lock. */ - n_on_stack = my_top - my_first_nonempty + 1; - if (0 == n_on_stack) { - GC_active_count--; - GC_ASSERT(GC_active_count <= GC_helper_count); - /* Other markers may redeposit objects */ - /* on the stack. */ - if (0 == GC_active_count) GC_notify_all_marker(); - while (GC_active_count > 0 - && (word)AO_load(&GC_first_nonempty) - > (word)GC_mark_stack_top) { - /* We will be notified if either GC_active_count */ - /* reaches zero, or if more objects are pushed on */ - /* the global mark stack. */ - GC_wait_marker(); - } - if (GC_active_count == 0 - && (word)AO_load(&GC_first_nonempty) - > (word)GC_mark_stack_top) { - GC_bool need_to_notify = FALSE; - /* The above conditions can't be falsified while we */ - /* hold the mark lock, since neither */ - /* GC_active_count nor GC_mark_stack_top can */ - /* change. GC_first_nonempty can only be */ - /* incremented asynchronously. Thus we know that */ - /* both conditions actually held simultaneously. */ - GC_helper_count--; - if (0 == GC_helper_count) need_to_notify = TRUE; - GC_VERBOSE_LOG_PRINTF("Finished mark helper %lu\n", - (unsigned long)id); - GC_release_mark_lock(); - if (need_to_notify) GC_notify_all_marker(); - return; - } - /* else there's something on the stack again, or */ - /* another helper may push something. */ - GC_active_count++; - GC_ASSERT(GC_active_count > 0); - GC_release_mark_lock(); - continue; - } else { - GC_release_mark_lock(); - } - } - n_to_get = ENTRIES_TO_GET; - if (n_on_stack < 2 * ENTRIES_TO_GET) n_to_get = 1; - local_top = GC_steal_mark_stack(my_first_nonempty, my_top, - local_mark_stack, n_to_get, - &my_first_nonempty); - GC_ASSERT((word)my_first_nonempty >= (word)GC_mark_stack && - (word)my_first_nonempty <= - (word)AO_load((volatile AO_t *)&GC_mark_stack_top) - + sizeof(mse)); - GC_do_local_mark(local_mark_stack, local_top); - } -} - -/* Perform Parallel mark. */ -/* We hold the GC lock, not the mark lock. */ -/* Currently runs until the mark stack is */ -/* empty. */ -STATIC void GC_do_parallel_mark(void) -{ - mse local_mark_stack[LOCAL_MARK_STACK_SIZE]; - /* Note: local_mark_stack is quite big (up to 128 KiB). */ - - GC_acquire_mark_lock(); - GC_ASSERT(I_HOLD_LOCK()); - /* This could be a GC_ASSERT, but it seems safer to keep it on */ - /* all the time, especially since it's cheap. */ - if (GC_help_wanted || GC_active_count != 0 || GC_helper_count != 0) - ABORT("Tried to start parallel mark in bad state"); - GC_VERBOSE_LOG_PRINTF("Starting marking for mark phase number %lu\n", - (unsigned long)GC_mark_no); - GC_first_nonempty = (AO_t)GC_mark_stack; - GC_active_count = 0; - GC_helper_count = 1; - GC_help_wanted = TRUE; - GC_release_mark_lock(); - GC_notify_all_marker(); - /* Wake up potential helpers. */ - GC_mark_local(local_mark_stack, 0); - GC_acquire_mark_lock(); - GC_help_wanted = FALSE; - /* Done; clean up. */ - while (GC_helper_count > 0) { - GC_wait_marker(); - } - /* GC_helper_count cannot be incremented while GC_help_wanted == FALSE */ - GC_VERBOSE_LOG_PRINTF("Finished marking for mark phase number %lu\n", - (unsigned long)GC_mark_no); - GC_mark_no++; - GC_release_mark_lock(); - GC_notify_all_marker(); -} - - -/* Try to help out the marker, if it's running. */ -/* We do not hold the GC lock, but the requestor does. */ -GC_INNER void GC_help_marker(word my_mark_no) -{ - unsigned my_id; - mse local_mark_stack[LOCAL_MARK_STACK_SIZE]; - /* Note: local_mark_stack is quite big (up to 128 KiB). */ - - if (!GC_parallel) return; - - GC_acquire_mark_lock(); - while (GC_mark_no < my_mark_no - || (!GC_help_wanted && GC_mark_no == my_mark_no)) { - GC_wait_marker(); - } - my_id = GC_helper_count; - if (GC_mark_no != my_mark_no || my_id > (unsigned)GC_markers_m1) { - /* Second test is useful only if original threads can also */ - /* act as helpers. Under Linux they can't. */ - GC_release_mark_lock(); - return; - } - GC_helper_count = my_id + 1; - GC_release_mark_lock(); - GC_mark_local(local_mark_stack, my_id); - /* GC_mark_local decrements GC_helper_count. */ -} - -#endif /* PARALLEL_MARK */ - -/* Allocate or reallocate space for mark stack of size n entries. */ -/* May silently fail. */ -static void alloc_mark_stack(size_t n) -{ - mse * new_stack = (mse *)GC_scratch_alloc(n * sizeof(struct GC_ms_entry)); -# ifdef GWW_VDB - /* Don't recycle a stack segment obtained with the wrong flags. */ - /* Win32 GetWriteWatch requires the right kind of memory. */ - static GC_bool GC_incremental_at_stack_alloc = FALSE; - GC_bool recycle_old = (!GC_incremental || GC_incremental_at_stack_alloc); - - GC_incremental_at_stack_alloc = GC_incremental; -# else -# define recycle_old TRUE -# endif - - GC_mark_stack_too_small = FALSE; - if (GC_mark_stack_size != 0) { - if (new_stack != 0) { - if (recycle_old) { - /* Recycle old space */ - size_t page_offset = (word)GC_mark_stack & (GC_page_size - 1); - size_t size = GC_mark_stack_size * sizeof(struct GC_ms_entry); - size_t displ = 0; - - if (0 != page_offset) displ = GC_page_size - page_offset; - size = (size - displ) & ~(GC_page_size - 1); - if (size > 0) { - GC_add_to_heap((struct hblk *) - ((word)GC_mark_stack + displ), (word)size); - } - } - GC_mark_stack = new_stack; - GC_mark_stack_size = n; - /* FIXME: Do we need some way to reset GC_mark_stack_size? */ - GC_mark_stack_limit = new_stack + n; - GC_COND_LOG_PRINTF("Grew mark stack to %lu frames\n", - (unsigned long)GC_mark_stack_size); - } else { - WARN("Failed to grow mark stack to %" WARN_PRIdPTR " frames\n", n); - } - } else { - if (new_stack == 0) { - GC_err_printf("No space for mark stack\n"); - EXIT(); - } - GC_mark_stack = new_stack; - GC_mark_stack_size = n; - GC_mark_stack_limit = new_stack + n; - } - GC_mark_stack_top = GC_mark_stack-1; -} - -GC_INNER void GC_mark_init(void) -{ - alloc_mark_stack(INITIAL_MARK_STACK_SIZE); -} - -/* - * Push all locations between b and t onto the mark stack. - * b is the first location to be checked. t is one past the last - * location to be checked. - * Should only be used if there is no possibility of mark stack - * overflow. - */ -GC_API void GC_CALL GC_push_all(char *bottom, char *top) -{ - register word length; - - bottom = (char *)(((word) bottom + ALIGNMENT-1) & ~(ALIGNMENT-1)); - top = (char *)(((word) top) & ~(ALIGNMENT-1)); - if ((word)bottom >= (word)top) return; - - GC_mark_stack_top++; - if ((word)GC_mark_stack_top >= (word)GC_mark_stack_limit) { - ABORT("Unexpected mark stack overflow"); - } - length = top - bottom; -# if GC_DS_TAGS > ALIGNMENT - 1 - length += GC_DS_TAGS; - length &= ~GC_DS_TAGS; -# endif - GC_mark_stack_top -> mse_start = bottom; - GC_mark_stack_top -> mse_descr.w = length; -} - -#ifndef GC_DISABLE_INCREMENTAL - - /* Analogous to the above, but push only those pages h with */ - /* dirty_fn(h) != 0. We use GC_push_all to actually push the block. */ - /* Used both to selectively push dirty pages, or to push a block in */ - /* piecemeal fashion, to allow for more marking concurrency. */ - /* Will not overflow mark stack if GC_push_all pushes a small fixed */ - /* number of entries. (This is invoked only if GC_push_all pushes */ - /* a single entry, or if it marks each object before pushing it, thus */ - /* ensuring progress in the event of a stack overflow.) */ - STATIC void GC_push_selected(ptr_t bottom, ptr_t top, - GC_bool (*dirty_fn)(struct hblk *)) - { - struct hblk * h; - - bottom = (ptr_t)(((word) bottom + ALIGNMENT-1) & ~(ALIGNMENT-1)); - top = (ptr_t)(((word) top) & ~(ALIGNMENT-1)); - if ((word)bottom >= (word)top) return; - - h = HBLKPTR(bottom + HBLKSIZE); - if ((word)top <= (word)h) { - if ((*dirty_fn)(h-1)) { - GC_push_all(bottom, top); - } - return; - } - if ((*dirty_fn)(h-1)) { - GC_push_all(bottom, (ptr_t)h); - } - - while ((word)(h+1) <= (word)top) { - if ((*dirty_fn)(h)) { - if ((word)(GC_mark_stack_top - GC_mark_stack) - > 3 * GC_mark_stack_size / 4) { - /* Danger of mark stack overflow */ - GC_push_all((ptr_t)h, top); - return; - } else { - GC_push_all((ptr_t)h, (ptr_t)(h+1)); - } - } - h++; - } - - if ((ptr_t)h != top && (*dirty_fn)(h)) { - GC_push_all((ptr_t)h, top); - } - if ((word)GC_mark_stack_top >= (word)GC_mark_stack_limit) { - ABORT("Unexpected mark stack overflow"); - } - } - - GC_API void GC_CALL GC_push_conditional(char *bottom, char *top, int all) - { - if (!all) { - GC_push_selected((ptr_t)bottom, (ptr_t)top, GC_page_was_dirty); - } else { -# ifdef PROC_VDB - if (GC_dirty_maintained) { - /* Pages that were never dirtied cannot contain pointers. */ - GC_push_selected((ptr_t)bottom, (ptr_t)top, GC_page_was_ever_dirty); - } else -# endif - /* else */ { - GC_push_all(bottom, top); - } - } - } -#else - GC_API void GC_CALL GC_push_conditional(char *bottom, char *top, - int all GC_ATTR_UNUSED) - { - GC_push_all(bottom, top); - } -#endif /* GC_DISABLE_INCREMENTAL */ - -#if defined(MSWIN32) || defined(MSWINCE) - void __cdecl GC_push_one(word p) -#else - void GC_push_one(word p) -#endif -{ - GC_PUSH_ONE_STACK(p, MARKED_FROM_REGISTER); -} - -GC_API struct GC_ms_entry * GC_CALL GC_mark_and_push(void *obj, - mse *mark_stack_ptr, - mse *mark_stack_limit, - void ** src GC_ATTR_UNUSED) -{ - hdr * hhdr; - - PREFETCH(obj); - GET_HDR(obj, hhdr); - if ((EXPECT(IS_FORWARDING_ADDR_OR_NIL(hhdr), FALSE) - && (!GC_all_interior_pointers - || NULL == (hhdr = GC_find_header(GC_base(obj))))) - || EXPECT(HBLK_IS_FREE(hhdr), FALSE)) { - GC_ADD_TO_BLACK_LIST_NORMAL(obj, (ptr_t)src); - return mark_stack_ptr; - } - - PUSH_CONTENTS_HDR(obj, mark_stack_ptr /* modified */, mark_stack_limit, - (ptr_t)src, was_marked, hhdr, TRUE); - was_marked: - return mark_stack_ptr; -} - -#if defined(MANUAL_VDB) && defined(THREADS) - void GC_dirty(ptr_t p); -#endif - -/* Mark and push (i.e. gray) a single object p onto the main */ -/* mark stack. Consider p to be valid if it is an interior */ -/* pointer. */ -/* The object p has passed a preliminary pointer validity */ -/* test, but we do not definitely know whether it is valid. */ -/* Mark bits are NOT atomically updated. Thus this must be the */ -/* only thread setting them. */ -# if defined(PRINT_BLACK_LIST) || defined(KEEP_BACK_PTRS) - GC_INNER void GC_mark_and_push_stack(ptr_t p, ptr_t source) -# else - GC_INNER void GC_mark_and_push_stack(ptr_t p) -# define source ((ptr_t)0) -# endif -{ - hdr * hhdr; - ptr_t r = p; - - PREFETCH(p); - GET_HDR(p, hhdr); - if (EXPECT(IS_FORWARDING_ADDR_OR_NIL(hhdr), FALSE)) { - if (hhdr != 0) { - r = GC_base(p); - hhdr = HDR(r); - } - if (hhdr == 0) { - GC_ADD_TO_BLACK_LIST_STACK(p, source); - return; - } - } - if (EXPECT(HBLK_IS_FREE(hhdr), FALSE)) { - GC_ADD_TO_BLACK_LIST_NORMAL(p, source); - return; - } -# if defined(MANUAL_VDB) && defined(THREADS) - /* Pointer is on the stack. We may have dirtied the object */ - /* it points to, but not yet have called GC_dirty(); */ - GC_dirty(p); /* Implicitly affects entire object. */ -# endif - PUSH_CONTENTS_HDR(r, GC_mark_stack_top, GC_mark_stack_limit, - source, mark_and_push_exit, hhdr, FALSE); - mark_and_push_exit: ; - /* We silently ignore pointers to near the end of a block, */ - /* which is very mildly suboptimal. */ - /* FIXME: We should probably add a header word to address */ - /* this. */ -} -# undef source - -# ifdef TRACE_BUF - -# define TRACE_ENTRIES 1000 - -struct trace_entry { - char * kind; - word gc_no; - word bytes_allocd; - word arg1; - word arg2; -} GC_trace_buf[TRACE_ENTRIES]; - -int GC_trace_buf_ptr = 0; - -void GC_add_trace_entry(char *kind, word arg1, word arg2) -{ - GC_trace_buf[GC_trace_buf_ptr].kind = kind; - GC_trace_buf[GC_trace_buf_ptr].gc_no = GC_gc_no; - GC_trace_buf[GC_trace_buf_ptr].bytes_allocd = GC_bytes_allocd; - GC_trace_buf[GC_trace_buf_ptr].arg1 = arg1 ^ 0x80000000; - GC_trace_buf[GC_trace_buf_ptr].arg2 = arg2 ^ 0x80000000; - GC_trace_buf_ptr++; - if (GC_trace_buf_ptr >= TRACE_ENTRIES) GC_trace_buf_ptr = 0; -} - -void GC_print_trace_inner(word gc_no) -{ - int i; - struct trace_entry *p; - - for (i = GC_trace_buf_ptr-1; i != GC_trace_buf_ptr; i--) { - if (i < 0) i = TRACE_ENTRIES-1; - p = GC_trace_buf + i; - if (p -> gc_no < gc_no || p -> kind == 0) { - return; - } - GC_printf("Trace:%s (gc:%u, bytes:%lu) 0x%lX, 0x%lX\n", - p -> kind, (unsigned)p -> gc_no, - (unsigned long)p -> bytes_allocd, - (long)p->arg1 ^ 0x80000000L, (long)p->arg2 ^ 0x80000000L); - } - GC_printf("Trace incomplete\n"); -} - -void GC_print_trace(word gc_no) -{ - DCL_LOCK_STATE; - - LOCK(); - GC_print_trace_inner(gc_no); - UNLOCK(); -} - -# endif /* TRACE_BUF */ - -/* - * A version of GC_push_all that treats all interior pointers as valid - * and scans the entire region immediately, in case the contents - * change. - */ -GC_INNER void GC_push_all_eager(ptr_t bottom, ptr_t top) -{ - word * b = (word *)(((word) bottom + ALIGNMENT-1) & ~(ALIGNMENT-1)); - word * t = (word *)(((word) top) & ~(ALIGNMENT-1)); - register word *p; - register word q; - register word *lim; - register ptr_t greatest_ha = GC_greatest_plausible_heap_addr; - register ptr_t least_ha = GC_least_plausible_heap_addr; -# define GC_greatest_plausible_heap_addr greatest_ha -# define GC_least_plausible_heap_addr least_ha - - if (top == 0) return; - /* check all pointers in range and push if they appear */ - /* to be valid. */ - lim = t - 1 /* longword */; - for (p = b; (word)p <= (word)lim; - p = (word *)(((ptr_t)p) + ALIGNMENT)) { - q = *p; - GC_PUSH_ONE_STACK(q, p); - } -# undef GC_greatest_plausible_heap_addr -# undef GC_least_plausible_heap_addr -} - -GC_INNER void GC_push_all_stack(ptr_t bottom, ptr_t top) -{ -# if defined(THREADS) && defined(MPROTECT_VDB) - GC_push_all_eager(bottom, top); -# else - if (!NEED_FIXUP_POINTER && GC_all_interior_pointers) { - GC_push_all(bottom, top); - } else { - GC_push_all_eager(bottom, top); - } -# endif -} - -#if !defined(SMALL_CONFIG) && !defined(USE_MARK_BYTES) && \ - defined(MARK_BIT_PER_GRANULE) -# if GC_GRANULE_WORDS == 1 -# define USE_PUSH_MARKED_ACCELERATORS -# define PUSH_GRANULE(q) \ - do { \ - word qcontents = (q)[0]; \ - GC_PUSH_ONE_HEAP(qcontents, q, GC_mark_stack_top); \ - } while (0) -# elif GC_GRANULE_WORDS == 2 -# define USE_PUSH_MARKED_ACCELERATORS -# define PUSH_GRANULE(q) \ - do { \ - word qcontents = (q)[0]; \ - GC_PUSH_ONE_HEAP(qcontents, q, GC_mark_stack_top); \ - qcontents = (q)[1]; \ - GC_PUSH_ONE_HEAP(qcontents, (q)+1, GC_mark_stack_top); \ - } while (0) -# elif GC_GRANULE_WORDS == 4 -# define USE_PUSH_MARKED_ACCELERATORS -# define PUSH_GRANULE(q) \ - do { \ - word qcontents = (q)[0]; \ - GC_PUSH_ONE_HEAP(qcontents, q, GC_mark_stack_top); \ - qcontents = (q)[1]; \ - GC_PUSH_ONE_HEAP(qcontents, (q)+1, GC_mark_stack_top); \ - qcontents = (q)[2]; \ - GC_PUSH_ONE_HEAP(qcontents, (q)+2, GC_mark_stack_top); \ - qcontents = (q)[3]; \ - GC_PUSH_ONE_HEAP(qcontents, (q)+3, GC_mark_stack_top); \ - } while (0) -# endif -#endif /* !USE_MARK_BYTES && MARK_BIT_PER_GRANULE */ - -#ifdef USE_PUSH_MARKED_ACCELERATORS -/* Push all objects reachable from marked objects in the given block */ -/* containing objects of size 1 granule. */ -STATIC void GC_push_marked1(struct hblk *h, hdr *hhdr) -{ - word * mark_word_addr = &(hhdr->hb_marks[0]); - word *p; - word *plim; - word *q; - word mark_word; - - /* Allow registers to be used for some frequently accessed */ - /* global variables. Otherwise aliasing issues are likely */ - /* to prevent that. */ - ptr_t greatest_ha = GC_greatest_plausible_heap_addr; - ptr_t least_ha = GC_least_plausible_heap_addr; - mse * mark_stack_top = GC_mark_stack_top; - mse * mark_stack_limit = GC_mark_stack_limit; - -# undef GC_mark_stack_top -# undef GC_mark_stack_limit -# define GC_mark_stack_top mark_stack_top -# define GC_mark_stack_limit mark_stack_limit -# define GC_greatest_plausible_heap_addr greatest_ha -# define GC_least_plausible_heap_addr least_ha - - p = (word *)(h->hb_body); - plim = (word *)(((word)h) + HBLKSIZE); - - /* go through all words in block */ - while ((word)p < (word)plim) { - mark_word = *mark_word_addr++; - q = p; - while(mark_word != 0) { - if (mark_word & 1) { - PUSH_GRANULE(q); - } - q += GC_GRANULE_WORDS; - mark_word >>= 1; - } - p += WORDSZ*GC_GRANULE_WORDS; - } - -# undef GC_greatest_plausible_heap_addr -# undef GC_least_plausible_heap_addr -# undef GC_mark_stack_top -# undef GC_mark_stack_limit -# define GC_mark_stack_limit GC_arrays._mark_stack_limit -# define GC_mark_stack_top GC_arrays._mark_stack_top - GC_mark_stack_top = mark_stack_top; -} - - -#ifndef UNALIGNED_PTRS - -/* Push all objects reachable from marked objects in the given block */ -/* of size 2 (granules) objects. */ -STATIC void GC_push_marked2(struct hblk *h, hdr *hhdr) -{ - word * mark_word_addr = &(hhdr->hb_marks[0]); - word *p; - word *plim; - word *q; - word mark_word; - - ptr_t greatest_ha = GC_greatest_plausible_heap_addr; - ptr_t least_ha = GC_least_plausible_heap_addr; - mse * mark_stack_top = GC_mark_stack_top; - mse * mark_stack_limit = GC_mark_stack_limit; - -# undef GC_mark_stack_top -# undef GC_mark_stack_limit -# define GC_mark_stack_top mark_stack_top -# define GC_mark_stack_limit mark_stack_limit -# define GC_greatest_plausible_heap_addr greatest_ha -# define GC_least_plausible_heap_addr least_ha - - p = (word *)(h->hb_body); - plim = (word *)(((word)h) + HBLKSIZE); - - /* go through all words in block */ - while ((word)p < (word)plim) { - mark_word = *mark_word_addr++; - q = p; - while(mark_word != 0) { - if (mark_word & 1) { - PUSH_GRANULE(q); - PUSH_GRANULE(q + GC_GRANULE_WORDS); - } - q += 2 * GC_GRANULE_WORDS; - mark_word >>= 2; - } - p += WORDSZ*GC_GRANULE_WORDS; - } - -# undef GC_greatest_plausible_heap_addr -# undef GC_least_plausible_heap_addr -# undef GC_mark_stack_top -# undef GC_mark_stack_limit -# define GC_mark_stack_limit GC_arrays._mark_stack_limit -# define GC_mark_stack_top GC_arrays._mark_stack_top - GC_mark_stack_top = mark_stack_top; -} - -# if GC_GRANULE_WORDS < 4 -/* Push all objects reachable from marked objects in the given block */ -/* of size 4 (granules) objects. */ -/* There is a risk of mark stack overflow here. But we handle that. */ -/* And only unmarked objects get pushed, so it's not very likely. */ -STATIC void GC_push_marked4(struct hblk *h, hdr *hhdr) -{ - word * mark_word_addr = &(hhdr->hb_marks[0]); - word *p; - word *plim; - word *q; - word mark_word; - - ptr_t greatest_ha = GC_greatest_plausible_heap_addr; - ptr_t least_ha = GC_least_plausible_heap_addr; - mse * mark_stack_top = GC_mark_stack_top; - mse * mark_stack_limit = GC_mark_stack_limit; - -# undef GC_mark_stack_top -# undef GC_mark_stack_limit -# define GC_mark_stack_top mark_stack_top -# define GC_mark_stack_limit mark_stack_limit -# define GC_greatest_plausible_heap_addr greatest_ha -# define GC_least_plausible_heap_addr least_ha - - p = (word *)(h->hb_body); - plim = (word *)(((word)h) + HBLKSIZE); - - /* go through all words in block */ - while ((word)p < (word)plim) { - mark_word = *mark_word_addr++; - q = p; - while(mark_word != 0) { - if (mark_word & 1) { - PUSH_GRANULE(q); - PUSH_GRANULE(q + GC_GRANULE_WORDS); - PUSH_GRANULE(q + 2*GC_GRANULE_WORDS); - PUSH_GRANULE(q + 3*GC_GRANULE_WORDS); - } - q += 4 * GC_GRANULE_WORDS; - mark_word >>= 4; - } - p += WORDSZ*GC_GRANULE_WORDS; - } -# undef GC_greatest_plausible_heap_addr -# undef GC_least_plausible_heap_addr -# undef GC_mark_stack_top -# undef GC_mark_stack_limit -# define GC_mark_stack_limit GC_arrays._mark_stack_limit -# define GC_mark_stack_top GC_arrays._mark_stack_top - GC_mark_stack_top = mark_stack_top; -} - -#endif /* GC_GRANULE_WORDS < 4 */ - -#endif /* UNALIGNED_PTRS */ - -#endif /* USE_PUSH_MARKED_ACCELERATORS */ - -/* Push all objects reachable from marked objects in the given block */ -STATIC void GC_push_marked(struct hblk *h, hdr *hhdr) -{ - size_t sz = hhdr -> hb_sz; - word descr = hhdr -> hb_descr; - ptr_t p; - word bit_no; - ptr_t lim; - mse * GC_mark_stack_top_reg; - mse * mark_stack_limit = GC_mark_stack_limit; - - /* Some quick shortcuts: */ - if ((0 | GC_DS_LENGTH) == descr) return; - if (GC_block_empty(hhdr)/* nothing marked */) return; - GC_n_rescuing_pages++; - GC_objects_are_marked = TRUE; - if (sz > MAXOBJBYTES) { - lim = h -> hb_body; - } else { - lim = (h + 1)->hb_body - sz; - } - - switch(BYTES_TO_GRANULES(sz)) { -# if defined(USE_PUSH_MARKED_ACCELERATORS) - case 1: - GC_push_marked1(h, hhdr); - break; -# if !defined(UNALIGNED_PTRS) - case 2: - GC_push_marked2(h, hhdr); - break; -# if GC_GRANULE_WORDS < 4 - case 4: - GC_push_marked4(h, hhdr); - break; -# endif -# endif -# endif - default: - GC_mark_stack_top_reg = GC_mark_stack_top; - for (p = h -> hb_body, bit_no = 0; (word)p <= (word)lim; - p += sz, bit_no += MARK_BIT_OFFSET(sz)) { - if (mark_bit_from_hdr(hhdr, bit_no)) { - /* Mark from fields inside the object */ - PUSH_OBJ(p, hhdr, GC_mark_stack_top_reg, mark_stack_limit); - } - } - GC_mark_stack_top = GC_mark_stack_top_reg; - } -} - -#ifdef ENABLE_DISCLAIM -/* Unconditionally mark from all objects which have not been reclaimed. */ -/* This is useful in order to retain pointers which are reachable from */ -/* the disclaim notifiers. */ -/* */ -/* To determine whether an object has been reclaimed, we require that */ -/* any live object has a non-zero as one of the two lowest bits of the */ -/* first word. On the other hand, a reclaimed object is a members of */ -/* free-lists, and thus contains a word-aligned next-pointer as the */ -/* first word. */ - STATIC void GC_push_unconditionally(struct hblk *h, hdr *hhdr) - { - size_t sz = hhdr -> hb_sz; - word descr = hhdr -> hb_descr; - ptr_t p; - ptr_t lim; - mse * GC_mark_stack_top_reg; - mse * mark_stack_limit = GC_mark_stack_limit; - - if ((0 | GC_DS_LENGTH) == descr) - return; - - GC_n_rescuing_pages++; - GC_objects_are_marked = TRUE; - if (sz > MAXOBJBYTES) - lim = h -> hb_body; - else - lim = (h + 1)->hb_body - sz; - - GC_mark_stack_top_reg = GC_mark_stack_top; - for (p = h -> hb_body; (word)p <= (word)lim; p += sz) - if ((*(GC_word *)p & 0x3) != 0) - PUSH_OBJ(p, hhdr, GC_mark_stack_top_reg, mark_stack_limit); - GC_mark_stack_top = GC_mark_stack_top_reg; - } -#endif /* ENABLE_DISCLAIM */ - -#ifndef GC_DISABLE_INCREMENTAL - /* Test whether any page in the given block is dirty. */ - STATIC GC_bool GC_block_was_dirty(struct hblk *h, hdr *hhdr) - { - size_t sz = hhdr -> hb_sz; - - if (sz <= MAXOBJBYTES) { - return(GC_page_was_dirty(h)); - } else { - ptr_t p = (ptr_t)h; - while ((word)p < (word)h + sz) { - if (GC_page_was_dirty((struct hblk *)p)) return(TRUE); - p += HBLKSIZE; - } - return(FALSE); - } - } -#endif /* GC_DISABLE_INCREMENTAL */ - -/* Similar to GC_push_marked, but skip over unallocated blocks */ -/* and return address of next plausible block. */ -STATIC struct hblk * GC_push_next_marked(struct hblk *h) -{ - hdr * hhdr = HDR(h); - - if (EXPECT(IS_FORWARDING_ADDR_OR_NIL(hhdr) || HBLK_IS_FREE(hhdr), FALSE)) { - h = GC_next_used_block(h); - if (h == 0) return(0); - hhdr = GC_find_header((ptr_t)h); - } - GC_push_marked(h, hhdr); - return(h + OBJ_SZ_TO_BLOCKS(hhdr -> hb_sz)); -} - -#ifndef GC_DISABLE_INCREMENTAL - /* Identical to above, but mark only from dirty pages */ - STATIC struct hblk * GC_push_next_marked_dirty(struct hblk *h) - { - hdr * hhdr = HDR(h); - - if (!GC_dirty_maintained) ABORT("Dirty bits not set up"); - for (;;) { - if (EXPECT(IS_FORWARDING_ADDR_OR_NIL(hhdr) - || HBLK_IS_FREE(hhdr), FALSE)) { - h = GC_next_used_block(h); - if (h == 0) return(0); - hhdr = GC_find_header((ptr_t)h); - } -# ifdef STUBBORN_ALLOC - if (hhdr -> hb_obj_kind == STUBBORN) { - if (GC_page_was_changed(h) && GC_block_was_dirty(h, hhdr)) { - break; - } - } else { - if (GC_block_was_dirty(h, hhdr)) break; - } -# else - if (GC_block_was_dirty(h, hhdr)) break; -# endif - h += OBJ_SZ_TO_BLOCKS(hhdr -> hb_sz); - hhdr = HDR(h); - } - GC_push_marked(h, hhdr); - return(h + OBJ_SZ_TO_BLOCKS(hhdr -> hb_sz)); - } -#endif /* !GC_DISABLE_INCREMENTAL */ - -/* Similar to above, but for uncollectible pages. Needed since we */ -/* do not clear marks for such pages, even for full collections. */ -STATIC struct hblk * GC_push_next_marked_uncollectable(struct hblk *h) -{ - hdr * hhdr = HDR(h); - - for (;;) { - if (EXPECT(IS_FORWARDING_ADDR_OR_NIL(hhdr) - || HBLK_IS_FREE(hhdr), FALSE)) { - h = GC_next_used_block(h); - if (h == 0) return(0); - hhdr = GC_find_header((ptr_t)h); - } - if (hhdr -> hb_obj_kind == UNCOLLECTABLE) { - GC_push_marked(h, hhdr); - break; - } -# ifdef ENABLE_DISCLAIM - if ((hhdr -> hb_flags & MARK_UNCONDITIONALLY) != 0) { - GC_push_unconditionally(h, hhdr); - break; - } -# endif - h += OBJ_SZ_TO_BLOCKS(hhdr -> hb_sz); - hhdr = HDR(h); - } - return(h + OBJ_SZ_TO_BLOCKS(hhdr -> hb_sz)); -} diff -Nru ecl-16.1.2/src/bdwgc/mark_rts.c ecl-16.1.3+ds/src/bdwgc/mark_rts.c --- ecl-16.1.2/src/bdwgc/mark_rts.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/mark_rts.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,822 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#include "private/gc_priv.h" - -#include - -/* Data structure for list of root sets. */ -/* We keep a hash table, so that we can filter out duplicate additions. */ -/* Under Win32, we need to do a better job of filtering overlaps, so */ -/* we resort to sequential search, and pay the price. */ -/* This is really declared in gc_priv.h: -struct roots { - ptr_t r_start; - ptr_t r_end; -# if !defined(MSWIN32) && !defined(MSWINCE) && !defined(CYGWIN32) - struct roots * r_next; -# endif - GC_bool r_tmp; - -- Delete before registering new dynamic libraries -}; - -struct roots GC_static_roots[MAX_ROOT_SETS]; -*/ - -int GC_no_dls = 0; /* Register dynamic library data segments. */ - -static int n_root_sets = 0; - /* GC_static_roots[0..n_root_sets) contains the valid root sets. */ - -#if !defined(NO_DEBUGGING) || defined(GC_ASSERTIONS) - /* Should return the same value as GC_root_size. */ - GC_INNER word GC_compute_root_size(void) - { - int i; - word size = 0; - - for (i = 0; i < n_root_sets; i++) { - size += GC_static_roots[i].r_end - GC_static_roots[i].r_start; - } - return size; - } -#endif /* !NO_DEBUGGING || GC_ASSERTIONS */ - -#if !defined(NO_DEBUGGING) - /* For debugging: */ - void GC_print_static_roots(void) - { - int i; - word size; - - for (i = 0; i < n_root_sets; i++) { - GC_printf("From %p to %p%s\n", - GC_static_roots[i].r_start, GC_static_roots[i].r_end, - GC_static_roots[i].r_tmp ? " (temporary)" : ""); - } - GC_printf("GC_root_size: %lu\n", (unsigned long)GC_root_size); - - if ((size = GC_compute_root_size()) != GC_root_size) - GC_err_printf("GC_root_size incorrect!! Should be: %lu\n", - (unsigned long)size); - } -#endif /* !NO_DEBUGGING */ - -#ifndef THREADS - /* Primarily for debugging support: */ - /* Is the address p in one of the registered static root sections? */ - GC_INNER GC_bool GC_is_static_root(ptr_t p) - { - static int last_root_set = MAX_ROOT_SETS; - int i; - - if (last_root_set < n_root_sets - && (word)p >= (word)GC_static_roots[last_root_set].r_start - && (word)p < (word)GC_static_roots[last_root_set].r_end) - return(TRUE); - for (i = 0; i < n_root_sets; i++) { - if ((word)p >= (word)GC_static_roots[i].r_start - && (word)p < (word)GC_static_roots[i].r_end) { - last_root_set = i; - return(TRUE); - } - } - return(FALSE); - } -#endif /* !THREADS */ - -#if !defined(MSWIN32) && !defined(MSWINCE) && !defined(CYGWIN32) -/* -# define LOG_RT_SIZE 6 -# define RT_SIZE (1 << LOG_RT_SIZE) -- Power of 2, may be != MAX_ROOT_SETS - - struct roots * GC_root_index[RT_SIZE]; - -- Hash table header. Used only to check whether a range is - -- already present. - -- really defined in gc_priv.h -*/ - - GC_INLINE int rt_hash(ptr_t addr) - { - word result = (word) addr; -# if CPP_WORDSZ > 8*LOG_RT_SIZE - result ^= result >> 8*LOG_RT_SIZE; -# endif -# if CPP_WORDSZ > 4*LOG_RT_SIZE - result ^= result >> 4*LOG_RT_SIZE; -# endif - result ^= result >> 2*LOG_RT_SIZE; - result ^= result >> LOG_RT_SIZE; - result &= (RT_SIZE-1); - return(result); - } - - /* Is a range starting at b already in the table? If so return a */ - /* pointer to it, else NULL. */ - GC_INNER void * GC_roots_present(ptr_t b) - { - int h = rt_hash(b); - struct roots *p = GC_root_index[h]; - - while (p != 0) { - if (p -> r_start == (ptr_t)b) return(p); - p = p -> r_next; - } - return NULL; - } - - /* Add the given root structure to the index. */ - GC_INLINE void add_roots_to_index(struct roots *p) - { - int h = rt_hash(p -> r_start); - - p -> r_next = GC_root_index[h]; - GC_root_index[h] = p; - } -#endif /* !MSWIN32 && !MSWINCE && !CYGWIN32 */ - -GC_INNER word GC_root_size = 0; - -GC_API void GC_CALL GC_add_roots(void *b, void *e) -{ - DCL_LOCK_STATE; - - if (!EXPECT(GC_is_initialized, TRUE)) GC_init(); - LOCK(); - GC_add_roots_inner((ptr_t)b, (ptr_t)e, FALSE); - UNLOCK(); -} - - -/* Add [b,e) to the root set. Adding the same interval a second time */ -/* is a moderately fast no-op, and hence benign. We do not handle */ -/* different but overlapping intervals efficiently. (We do handle */ -/* them correctly.) */ -/* Tmp specifies that the interval may be deleted before */ -/* re-registering dynamic libraries. */ -void GC_add_roots_inner(ptr_t b, ptr_t e, GC_bool tmp) -{ - struct roots * old; - - GC_ASSERT((word)b <= (word)e); - b = (ptr_t)(((word)b + (sizeof(word) - 1)) & ~(sizeof(word) - 1)); - /* round b up to word boundary */ - e = (ptr_t)((word)e & ~(sizeof(word) - 1)); - /* round e down to word boundary */ - if ((word)b >= (word)e) return; /* nothing to do */ - -# if defined(MSWIN32) || defined(MSWINCE) || defined(CYGWIN32) - /* Spend the time to ensure that there are no overlapping */ - /* or adjacent intervals. */ - /* This could be done faster with e.g. a */ - /* balanced tree. But the execution time here is */ - /* virtually guaranteed to be dominated by the time it */ - /* takes to scan the roots. */ - { - register int i; - old = 0; /* initialized to prevent warning. */ - for (i = 0; i < n_root_sets; i++) { - old = GC_static_roots + i; - if ((word)b <= (word)old->r_end - && (word)e >= (word)old->r_start) { - if ((word)b < (word)old->r_start) { - GC_root_size += old->r_start - b; - old -> r_start = b; - } - if ((word)e > (word)old->r_end) { - GC_root_size += e - old->r_end; - old -> r_end = e; - } - old -> r_tmp &= tmp; - break; - } - } - if (i < n_root_sets) { - /* merge other overlapping intervals */ - struct roots *other; - - for (i++; i < n_root_sets; i++) { - other = GC_static_roots + i; - b = other -> r_start; - e = other -> r_end; - if ((word)b <= (word)old->r_end - && (word)e >= (word)old->r_start) { - if ((word)b < (word)old->r_start) { - GC_root_size += old->r_start - b; - old -> r_start = b; - } - if ((word)e > (word)old->r_end) { - GC_root_size += e - old->r_end; - old -> r_end = e; - } - old -> r_tmp &= other -> r_tmp; - /* Delete this entry. */ - GC_root_size -= (other -> r_end - other -> r_start); - other -> r_start = GC_static_roots[n_root_sets-1].r_start; - other -> r_end = GC_static_roots[n_root_sets-1].r_end; - n_root_sets--; - } - } - return; - } - } -# else - old = (struct roots *)GC_roots_present(b); - if (old != 0) { - if ((word)e <= (word)old->r_end) /* already there */ return; - /* else extend */ - GC_root_size += e - old -> r_end; - old -> r_end = e; - return; - } -# endif - if (n_root_sets == MAX_ROOT_SETS) { - ABORT("Too many root sets"); - } - -# ifdef DEBUG_ADD_DEL_ROOTS - GC_log_printf("Adding data root section %d: %p .. %p%s\n", - n_root_sets, b, e, tmp ? " (temporary)" : ""); -# endif - GC_static_roots[n_root_sets].r_start = (ptr_t)b; - GC_static_roots[n_root_sets].r_end = (ptr_t)e; - GC_static_roots[n_root_sets].r_tmp = tmp; -# if !defined(MSWIN32) && !defined(MSWINCE) && !defined(CYGWIN32) - GC_static_roots[n_root_sets].r_next = 0; - add_roots_to_index(GC_static_roots + n_root_sets); -# endif - GC_root_size += e - b; - n_root_sets++; -} - -static GC_bool roots_were_cleared = FALSE; - -GC_API void GC_CALL GC_clear_roots(void) -{ - DCL_LOCK_STATE; - - if (!EXPECT(GC_is_initialized, TRUE)) GC_init(); - LOCK(); - roots_were_cleared = TRUE; - n_root_sets = 0; - GC_root_size = 0; -# if !defined(MSWIN32) && !defined(MSWINCE) && !defined(CYGWIN32) - BZERO(GC_root_index, RT_SIZE * sizeof(void *)); -# endif -# ifdef DEBUG_ADD_DEL_ROOTS - GC_log_printf("Clear all data root sections\n"); -# endif - UNLOCK(); -} - -/* Internal use only; lock held. */ -STATIC void GC_remove_root_at_pos(int i) -{ -# ifdef DEBUG_ADD_DEL_ROOTS - GC_log_printf("Remove data root section at %d: %p .. %p%s\n", - i, GC_static_roots[i].r_start, GC_static_roots[i].r_end, - GC_static_roots[i].r_tmp ? " (temporary)" : ""); -# endif - GC_root_size -= (GC_static_roots[i].r_end - GC_static_roots[i].r_start); - GC_static_roots[i].r_start = GC_static_roots[n_root_sets-1].r_start; - GC_static_roots[i].r_end = GC_static_roots[n_root_sets-1].r_end; - GC_static_roots[i].r_tmp = GC_static_roots[n_root_sets-1].r_tmp; - n_root_sets--; -} - -#if !defined(MSWIN32) && !defined(MSWINCE) && !defined(CYGWIN32) - STATIC void GC_rebuild_root_index(void) - { - int i; - BZERO(GC_root_index, RT_SIZE * sizeof(void *)); - for (i = 0; i < n_root_sets; i++) - add_roots_to_index(GC_static_roots + i); - } -#endif - -#if defined(DYNAMIC_LOADING) || defined(MSWIN32) || defined(MSWINCE) \ - || defined(PCR) || defined(CYGWIN32) -/* Internal use only; lock held. */ -STATIC void GC_remove_tmp_roots(void) -{ - int i; - - for (i = 0; i < n_root_sets; ) { - if (GC_static_roots[i].r_tmp) { - GC_remove_root_at_pos(i); - } else { - i++; - } - } -# if !defined(MSWIN32) && !defined(MSWINCE) && !defined(CYGWIN32) - GC_rebuild_root_index(); -# endif -} -#endif - -#if !defined(MSWIN32) && !defined(MSWINCE) && !defined(CYGWIN32) - STATIC void GC_remove_roots_inner(ptr_t b, ptr_t e); - - GC_API void GC_CALL GC_remove_roots(void *b, void *e) - { - DCL_LOCK_STATE; - - /* Quick check whether has nothing to do */ - if ((((word)b + (sizeof(word) - 1)) & ~(sizeof(word) - 1)) >= - ((word)e & ~(sizeof(word) - 1))) - return; - - LOCK(); - GC_remove_roots_inner((ptr_t)b, (ptr_t)e); - UNLOCK(); - } - - /* Should only be called when the lock is held */ - STATIC void GC_remove_roots_inner(ptr_t b, ptr_t e) - { - int i; - for (i = 0; i < n_root_sets; ) { - if ((word)GC_static_roots[i].r_start >= (word)b - && (word)GC_static_roots[i].r_end <= (word)e) { - GC_remove_root_at_pos(i); - } else { - i++; - } - } - GC_rebuild_root_index(); - } -#endif /* !defined(MSWIN32) && !defined(MSWINCE) && !defined(CYGWIN32) */ - -#if (defined(MSWIN32) || defined(MSWINCE) || defined(CYGWIN32)) \ - && !defined(NO_DEBUGGING) - /* Not used at present (except for, may be, debugging purpose). */ - /* Workaround for the OS mapping and unmapping behind our back: */ - /* Is the address p in one of the temporary static root sections? */ - GC_bool GC_is_tmp_root(ptr_t p) - { - static int last_root_set = MAX_ROOT_SETS; - register int i; - - if (last_root_set < n_root_sets - && (word)p >= (word)GC_static_roots[last_root_set].r_start - && (word)p < (word)GC_static_roots[last_root_set].r_end) - return GC_static_roots[last_root_set].r_tmp; - for (i = 0; i < n_root_sets; i++) { - if ((word)p >= (word)GC_static_roots[i].r_start - && (word)p < (word)GC_static_roots[i].r_end) { - last_root_set = i; - return GC_static_roots[i].r_tmp; - } - } - return(FALSE); - } -#endif /* MSWIN32 || MSWINCE || CYGWIN32 */ - -GC_INNER ptr_t GC_approx_sp(void) -{ - volatile word sp; - sp = (word)&sp; - /* Also force stack to grow if necessary. Otherwise the */ - /* later accesses might cause the kernel to think we're */ - /* doing something wrong. */ - return((ptr_t)sp); - /* GNU C: alternatively, we may return the value of */ - /*__builtin_frame_address(0). */ -} - -/* - * Data structure for excluded static roots. - * Real declaration is in gc_priv.h. - -struct exclusion { - ptr_t e_start; - ptr_t e_end; -}; - -struct exclusion GC_excl_table[MAX_EXCLUSIONS]; - -- Array of exclusions, ascending - -- address order. -*/ - -STATIC size_t GC_excl_table_entries = 0;/* Number of entries in use. */ - -/* Return the first exclusion range that includes an address >= start_addr */ -/* Assumes the exclusion table contains at least one entry (namely the */ -/* GC data structures). */ -STATIC struct exclusion * GC_next_exclusion(ptr_t start_addr) -{ - size_t low = 0; - size_t high = GC_excl_table_entries - 1; - size_t mid; - - while (high > low) { - mid = (low + high) >> 1; - /* low <= mid < high */ - if ((word) GC_excl_table[mid].e_end <= (word) start_addr) { - low = mid + 1; - } else { - high = mid; - } - } - if ((word) GC_excl_table[low].e_end <= (word) start_addr) return 0; - return GC_excl_table + low; -} - -/* Should only be called when the lock is held. The range boundaries */ -/* should be properly aligned and valid. */ -GC_INNER void GC_exclude_static_roots_inner(void *start, void *finish) -{ - struct exclusion * next; - size_t next_index, i; - - GC_ASSERT((word)start % sizeof(word) == 0); - GC_ASSERT((word)start < (word)finish); - - if (0 == GC_excl_table_entries) { - next = 0; - } else { - next = GC_next_exclusion(start); - } - if (0 != next) { - if ((word)(next -> e_start) < (word) finish) { - /* incomplete error check. */ - ABORT("Exclusion ranges overlap"); - } - if ((word)(next -> e_start) == (word) finish) { - /* extend old range backwards */ - next -> e_start = (ptr_t)start; - return; - } - next_index = next - GC_excl_table; - for (i = GC_excl_table_entries; i > next_index; --i) { - GC_excl_table[i] = GC_excl_table[i-1]; - } - } else { - next_index = GC_excl_table_entries; - } - if (GC_excl_table_entries == MAX_EXCLUSIONS) ABORT("Too many exclusions"); - GC_excl_table[next_index].e_start = (ptr_t)start; - GC_excl_table[next_index].e_end = (ptr_t)finish; - ++GC_excl_table_entries; -} - -GC_API void GC_CALL GC_exclude_static_roots(void *b, void *e) -{ - DCL_LOCK_STATE; - - if (b == e) return; /* nothing to exclude? */ - - /* Round boundaries (in direction reverse to that of GC_add_roots). */ - b = (void *)((word)b & ~(sizeof(word) - 1)); - e = (void *)(((word)e + (sizeof(word) - 1)) & ~(sizeof(word) - 1)); - if (0 == e) e = (void *)(word)(~(sizeof(word) - 1)); /* handle overflow */ - - LOCK(); - GC_exclude_static_roots_inner(b, e); - UNLOCK(); -} - -/* Invoke push_conditional on ranges that are not excluded. */ -STATIC void GC_push_conditional_with_exclusions(ptr_t bottom, ptr_t top, - GC_bool all GC_ATTR_UNUSED) -{ - struct exclusion * next; - ptr_t excl_start; - - while ((word)bottom < (word)top) { - next = GC_next_exclusion(bottom); - if (0 == next || (word)(excl_start = next -> e_start) >= (word)top) { - GC_PUSH_CONDITIONAL(bottom, top, all); - return; - } - if ((word)excl_start > (word)bottom) - GC_PUSH_CONDITIONAL(bottom, excl_start, all); - bottom = next -> e_end; - } -} - -#ifdef IA64 - /* Similar to GC_push_all_stack_sections() but for IA-64 registers store. */ - GC_INNER void GC_push_all_register_sections(ptr_t bs_lo, ptr_t bs_hi, - int eager, struct GC_traced_stack_sect_s *traced_stack_sect) - { - while (traced_stack_sect != NULL) { - ptr_t frame_bs_lo = traced_stack_sect -> backing_store_end; - GC_ASSERT((word)frame_bs_lo <= (word)bs_hi); - if (eager) { - GC_push_all_eager(frame_bs_lo, bs_hi); - } else { - GC_push_all_stack(frame_bs_lo, bs_hi); - } - bs_hi = traced_stack_sect -> saved_backing_store_ptr; - traced_stack_sect = traced_stack_sect -> prev; - } - GC_ASSERT((word)bs_lo <= (word)bs_hi); - if (eager) { - GC_push_all_eager(bs_lo, bs_hi); - } else { - GC_push_all_stack(bs_lo, bs_hi); - } - } -#endif /* IA64 */ - -#ifdef THREADS - -GC_INNER void GC_push_all_stack_sections(ptr_t lo, ptr_t hi, - struct GC_traced_stack_sect_s *traced_stack_sect) -{ - while (traced_stack_sect != NULL) { - GC_ASSERT((word)lo HOTTER_THAN (word)traced_stack_sect); -# ifdef STACK_GROWS_UP - GC_push_all_stack((ptr_t)traced_stack_sect, lo); -# else /* STACK_GROWS_DOWN */ - GC_push_all_stack(lo, (ptr_t)traced_stack_sect); -# endif - lo = traced_stack_sect -> saved_stack_ptr; - GC_ASSERT(lo != NULL); - traced_stack_sect = traced_stack_sect -> prev; - } - GC_ASSERT(!((word)hi HOTTER_THAN (word)lo)); -# ifdef STACK_GROWS_UP - /* We got them backwards! */ - GC_push_all_stack(hi, lo); -# else /* STACK_GROWS_DOWN */ - GC_push_all_stack(lo, hi); -# endif -} - -#else /* !THREADS */ - -# ifdef TRACE_BUF - /* Defined in mark.c. */ - void GC_add_trace_entry(char *kind, word arg1, word arg2); -# endif - - /* Similar to GC_push_all_eager, but only the */ - /* part hotter than cold_gc_frame is scanned */ - /* immediately. Needed to ensure that callee- */ - /* save registers are not missed. */ -/* - * A version of GC_push_all that treats all interior pointers as valid - * and scans part of the area immediately, to make sure that saved - * register values are not lost. - * Cold_gc_frame delimits the stack section that must be scanned - * eagerly. A zero value indicates that no eager scanning is needed. - * We don't need to worry about the MANUAL_VDB case here, since this - * is only called in the single-threaded case. We assume that we - * cannot collect between an assignment and the corresponding - * GC_dirty() call. - */ -STATIC void GC_push_all_stack_partially_eager(ptr_t bottom, ptr_t top, - ptr_t cold_gc_frame) -{ - if (!NEED_FIXUP_POINTER && GC_all_interior_pointers) { - /* Push the hot end of the stack eagerly, so that register values */ - /* saved inside GC frames are marked before they disappear. */ - /* The rest of the marking can be deferred until later. */ - if (0 == cold_gc_frame) { - GC_push_all_stack(bottom, top); - return; - } - GC_ASSERT((word)bottom <= (word)cold_gc_frame - && (word)cold_gc_frame <= (word)top); -# ifdef STACK_GROWS_DOWN - GC_push_all(cold_gc_frame - sizeof(ptr_t), top); - GC_push_all_eager(bottom, cold_gc_frame); -# else /* STACK_GROWS_UP */ - GC_push_all(bottom, cold_gc_frame + sizeof(ptr_t)); - GC_push_all_eager(cold_gc_frame, top); -# endif /* STACK_GROWS_UP */ - } else { - GC_push_all_eager(bottom, top); - } -# ifdef TRACE_BUF - GC_add_trace_entry("GC_push_all_stack", bottom, top); -# endif -} - -/* Similar to GC_push_all_stack_sections() but also uses cold_gc_frame. */ -STATIC void GC_push_all_stack_part_eager_sections(ptr_t lo, ptr_t hi, - ptr_t cold_gc_frame, struct GC_traced_stack_sect_s *traced_stack_sect) -{ - GC_ASSERT(traced_stack_sect == NULL || cold_gc_frame == NULL || - (word)cold_gc_frame HOTTER_THAN (word)traced_stack_sect); - - while (traced_stack_sect != NULL) { - GC_ASSERT((word)lo HOTTER_THAN (word)traced_stack_sect); -# ifdef STACK_GROWS_UP - GC_push_all_stack_partially_eager((ptr_t)traced_stack_sect, lo, - cold_gc_frame); -# else /* STACK_GROWS_DOWN */ - GC_push_all_stack_partially_eager(lo, (ptr_t)traced_stack_sect, - cold_gc_frame); -# endif - lo = traced_stack_sect -> saved_stack_ptr; - GC_ASSERT(lo != NULL); - traced_stack_sect = traced_stack_sect -> prev; - cold_gc_frame = NULL; /* Use at most once. */ - } - - GC_ASSERT(!((word)hi HOTTER_THAN (word)lo)); -# ifdef STACK_GROWS_UP - /* We got them backwards! */ - GC_push_all_stack_partially_eager(hi, lo, cold_gc_frame); -# else /* STACK_GROWS_DOWN */ - GC_push_all_stack_partially_eager(lo, hi, cold_gc_frame); -# endif -} - -#endif /* !THREADS */ - - /* Push enough of the current stack eagerly to */ - /* ensure that callee-save registers saved in */ - /* GC frames are scanned. */ - /* In the non-threads case, schedule entire */ - /* stack for scanning. */ - /* The second argument is a pointer to the */ - /* (possibly null) thread context, for */ - /* (currently hypothetical) more precise */ - /* stack scanning. */ -/* - * In the absence of threads, push the stack contents. - * In the presence of threads, push enough of the current stack - * to ensure that callee-save registers saved in collector frames have been - * seen. - * FIXME: Merge with per-thread stuff. - */ -STATIC void GC_push_current_stack(ptr_t cold_gc_frame, - void * context GC_ATTR_UNUSED) -{ -# if defined(THREADS) - if (0 == cold_gc_frame) return; -# ifdef STACK_GROWS_DOWN - GC_push_all_eager(GC_approx_sp(), cold_gc_frame); - /* For IA64, the register stack backing store is handled */ - /* in the thread-specific code. */ -# else - GC_push_all_eager(cold_gc_frame, GC_approx_sp()); -# endif -# else - GC_push_all_stack_part_eager_sections(GC_approx_sp(), GC_stackbottom, - cold_gc_frame, GC_traced_stack_sect); -# ifdef IA64 - /* We also need to push the register stack backing store. */ - /* This should really be done in the same way as the */ - /* regular stack. For now we fudge it a bit. */ - /* Note that the backing store grows up, so we can't use */ - /* GC_push_all_stack_partially_eager. */ - { - ptr_t bsp = GC_save_regs_ret_val; - ptr_t cold_gc_bs_pointer = bsp - 2048; - if (GC_all_interior_pointers - && (word)cold_gc_bs_pointer > (word)BACKING_STORE_BASE) { - /* Adjust cold_gc_bs_pointer if below our innermost */ - /* "traced stack section" in backing store. */ - if (GC_traced_stack_sect != NULL - && (word)cold_gc_bs_pointer - < (word)GC_traced_stack_sect->backing_store_end) - cold_gc_bs_pointer = - GC_traced_stack_sect->backing_store_end; - GC_push_all_register_sections(BACKING_STORE_BASE, - cold_gc_bs_pointer, FALSE, GC_traced_stack_sect); - GC_push_all_eager(cold_gc_bs_pointer, bsp); - } else { - GC_push_all_register_sections(BACKING_STORE_BASE, bsp, - TRUE /* eager */, GC_traced_stack_sect); - } - /* All values should be sufficiently aligned that we */ - /* don't have to worry about the boundary. */ - } -# endif -# endif /* !THREADS */ -} - -GC_INNER void (*GC_push_typed_structures)(void) = 0; - - /* Push GC internal roots. These are normally */ - /* included in the static data segment, and */ - /* Thus implicitly pushed. But we must do this */ - /* explicitly if normal root processing is */ - /* disabled. */ -/* - * Push GC internal roots. Only called if there is some reason to believe - * these would not otherwise get registered. - */ -STATIC void GC_push_gc_structures(void) -{ -# ifndef GC_NO_FINALIZATION - GC_push_finalizer_structures(); -# endif -# if defined(THREADS) - GC_push_thread_structures(); -# endif - if( GC_push_typed_structures ) - GC_push_typed_structures(); -} - -GC_INNER void GC_cond_register_dynamic_libraries(void) -{ -# if defined(DYNAMIC_LOADING) || defined(MSWIN32) || defined(MSWINCE) \ - || defined(CYGWIN32) || defined(PCR) - GC_remove_tmp_roots(); - if (!GC_no_dls) GC_register_dynamic_libraries(); -# else - GC_no_dls = TRUE; -# endif -} - -STATIC void GC_push_regs_and_stack(ptr_t cold_gc_frame) -{ - GC_with_callee_saves_pushed(GC_push_current_stack, cold_gc_frame); -} - -/* - * Call the mark routines (GC_tl_push for a single pointer, - * GC_push_conditional on groups of pointers) on every top level - * accessible pointer. - * If all is FALSE, arrange to push only possibly altered values. - * Cold_gc_frame is an address inside a GC frame that - * remains valid until all marking is complete. - * A zero value indicates that it's OK to miss some - * register values. - */ -GC_INNER void GC_push_roots(GC_bool all, ptr_t cold_gc_frame GC_ATTR_UNUSED) -{ - int i; - unsigned kind; - - /* - * Next push static data. This must happen early on, since it's - * not robust against mark stack overflow. - */ - /* Re-register dynamic libraries, in case one got added. */ - /* There is some argument for doing this as late as possible, */ - /* especially on win32, where it can change asynchronously. */ - /* In those cases, we do it here. But on other platforms, it's */ - /* not safe with the world stopped, so we do it earlier. */ -# if !defined(REGISTER_LIBRARIES_EARLY) - GC_cond_register_dynamic_libraries(); -# endif - - /* Mark everything in static data areas */ - for (i = 0; i < n_root_sets; i++) { - GC_push_conditional_with_exclusions( - GC_static_roots[i].r_start, - GC_static_roots[i].r_end, all); - } - - /* Mark all free list header blocks, if those were allocated from */ - /* the garbage collected heap. This makes sure they don't */ - /* disappear if we are not marking from static data. It also */ - /* saves us the trouble of scanning them, and possibly that of */ - /* marking the freelists. */ - for (kind = 0; kind < GC_n_kinds; kind++) { - void *base = GC_base(GC_obj_kinds[kind].ok_freelist); - if (0 != base) { - GC_set_mark_bit(base); - } - } - - /* Mark from GC internal roots if those might otherwise have */ - /* been excluded. */ - if (GC_no_dls || roots_were_cleared) { - GC_push_gc_structures(); - } - - /* Mark thread local free lists, even if their mark */ - /* descriptor excludes the link field. */ - /* If the world is not stopped, this is unsafe. It is */ - /* also unnecessary, since we will do this again with the */ - /* world stopped. */ -# if defined(THREAD_LOCAL_ALLOC) - if (GC_world_stopped) GC_mark_thread_local_free_lists(); -# endif - - /* - * Now traverse stacks, and mark from register contents. - * These must be done last, since they can legitimately overflow - * the mark stack. - * This is usually done by saving the current context on the - * stack, and then just tracing from the stack. - */ -# ifndef STACK_NOT_SCANNED - GC_push_regs_and_stack(cold_gc_frame); -# endif - - if (GC_push_other_roots != 0) (*GC_push_other_roots)(); - /* In the threads case, this also pushes thread stacks. */ - /* Note that without interior pointer recognition lots */ - /* of stuff may have been pushed already, and this */ - /* should be careful about mark stack overflows. */ -} diff -Nru ecl-16.1.2/src/bdwgc/misc.c ecl-16.1.3+ds/src/bdwgc/misc.c --- ecl-16.1.2/src/bdwgc/misc.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/misc.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,2225 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1999-2001 by Hewlett-Packard Company. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#include "private/gc_pmark.h" - -#include -#include -#include - -#ifndef MSWINCE -# include -#endif - -#ifdef GC_SOLARIS_THREADS -# include -#endif - -#if defined(MSWIN32) || defined(MSWINCE) \ - || (defined(CYGWIN32) && defined(GC_READ_ENV_FILE)) -# ifndef WIN32_LEAN_AND_MEAN -# define WIN32_LEAN_AND_MEAN 1 -# endif -# define NOSERVICE -# include -#endif - -#if defined(UNIX_LIKE) || defined(CYGWIN32) || defined(SYMBIAN) -# include -# include -# include -#endif - -#ifdef NONSTOP -# include -#endif - -#ifdef THREADS -# ifdef PCR -# include "il/PCR_IL.h" - GC_INNER PCR_Th_ML GC_allocate_ml; -# elif defined(SN_TARGET_PS3) -# include - GC_INNER pthread_mutex_t GC_allocate_ml; -# endif - /* For other platforms with threads, the lock and possibly */ - /* GC_lock_holder variables are defined in the thread support code. */ -#endif /* THREADS */ - -#ifdef DYNAMIC_LOADING - /* We need to register the main data segment. Returns TRUE unless */ - /* this is done implicitly as part of dynamic library registration. */ -# define GC_REGISTER_MAIN_STATIC_DATA() GC_register_main_static_data() -#elif defined(GC_DONT_REGISTER_MAIN_STATIC_DATA) -# define GC_REGISTER_MAIN_STATIC_DATA() FALSE -#else - /* Don't unnecessarily call GC_register_main_static_data() in case */ - /* dyn_load.c isn't linked in. */ -# define GC_REGISTER_MAIN_STATIC_DATA() TRUE -#endif - -#ifdef NEED_CANCEL_DISABLE_COUNT - __thread unsigned char GC_cancel_disable_count = 0; -#endif - -GC_FAR struct _GC_arrays GC_arrays /* = { 0 } */; - -GC_INNER GC_bool GC_debugging_started = FALSE; - /* defined here so we don't have to load debug_malloc.o */ - -ptr_t GC_stackbottom = 0; - -#ifdef IA64 - ptr_t GC_register_stackbottom = 0; -#endif - -int GC_dont_gc = FALSE; - -int GC_dont_precollect = FALSE; - -GC_bool GC_quiet = 0; /* used also in pcr_interface.c */ - -#ifndef SMALL_CONFIG - int GC_print_stats = 0; -#endif - -#ifdef GC_PRINT_BACK_HEIGHT - GC_INNER GC_bool GC_print_back_height = TRUE; -#else - GC_INNER GC_bool GC_print_back_height = FALSE; -#endif - -#ifndef NO_DEBUGGING -# ifdef GC_DUMP_REGULARLY - GC_INNER GC_bool GC_dump_regularly = TRUE; - /* Generate regular debugging dumps. */ -# else - GC_INNER GC_bool GC_dump_regularly = FALSE; -# endif -#endif - -#ifdef KEEP_BACK_PTRS - GC_INNER long GC_backtraces = 0; - /* Number of random backtraces to generate for each GC. */ -#endif - -#ifdef FIND_LEAK - int GC_find_leak = 1; -#else - int GC_find_leak = 0; -#endif - -#ifndef SHORT_DBG_HDRS -# ifdef GC_FINDLEAK_DELAY_FREE - GC_INNER GC_bool GC_findleak_delay_free = TRUE; -# else - GC_INNER GC_bool GC_findleak_delay_free = FALSE; -# endif -#endif /* !SHORT_DBG_HDRS */ - -#ifdef ALL_INTERIOR_POINTERS - int GC_all_interior_pointers = 1; -#else - int GC_all_interior_pointers = 0; -#endif - -#ifdef FINALIZE_ON_DEMAND - int GC_finalize_on_demand = 1; -#else - int GC_finalize_on_demand = 0; -#endif - -#ifdef JAVA_FINALIZATION - int GC_java_finalization = 1; -#else - int GC_java_finalization = 0; -#endif - -/* All accesses to it should be synchronized to avoid data races. */ -GC_finalizer_notifier_proc GC_finalizer_notifier = - (GC_finalizer_notifier_proc)0; - -#ifdef GC_FORCE_UNMAP_ON_GCOLLECT - /* Has no effect unless USE_MUNMAP. */ - /* Has no effect on implicitly-initiated garbage collections. */ - GC_INNER GC_bool GC_force_unmap_on_gcollect = TRUE; -#else - GC_INNER GC_bool GC_force_unmap_on_gcollect = FALSE; -#endif - -#ifndef GC_LARGE_ALLOC_WARN_INTERVAL -# define GC_LARGE_ALLOC_WARN_INTERVAL 5 -#endif -GC_INNER long GC_large_alloc_warn_interval = GC_LARGE_ALLOC_WARN_INTERVAL; - /* Interval between unsuppressed warnings. */ - -STATIC void * GC_CALLBACK GC_default_oom_fn( - size_t bytes_requested GC_ATTR_UNUSED) -{ - return(0); -} - -/* All accesses to it should be synchronized to avoid data races. */ -GC_oom_func GC_oom_fn = GC_default_oom_fn; - -#ifdef CAN_HANDLE_FORK -# ifdef HANDLE_FORK - GC_INNER int GC_handle_fork = 1; - /* The value is examined by GC_thr_init. */ -# else - GC_INNER int GC_handle_fork = FALSE; -# endif - -#elif !defined(HAVE_NO_FORK) - - /* Same as above but with GC_CALL calling conventions. */ - GC_API void GC_CALL GC_atfork_prepare(void) - { -# ifdef THREADS - ABORT("fork() handling unsupported"); -# endif - } - - GC_API void GC_CALL GC_atfork_parent(void) - { - /* empty */ - } - - GC_API void GC_CALL GC_atfork_child(void) - { - /* empty */ - } -#endif /* !CAN_HANDLE_FORK && !HAVE_NO_FORK */ - -/* Overrides the default automatic handle-fork mode. Has effect only */ -/* if called before GC_INIT. */ -GC_API void GC_CALL GC_set_handle_fork(int value GC_ATTR_UNUSED) -{ -# ifdef CAN_HANDLE_FORK - if (!GC_is_initialized) - GC_handle_fork = value >= -1 ? value : 1; - /* Map all negative values except for -1 to a positive one. */ -# elif defined(THREADS) || (defined(DARWIN) && defined(MPROTECT_VDB)) - if (!GC_is_initialized && value) { -# ifndef SMALL_CONFIG - GC_init(); /* just to initialize GC_stderr */ -# endif - ABORT("fork() handling unsupported"); - } -# else - /* No at-fork handler is needed in the single-threaded mode. */ -# endif -} - -/* Set things up so that GC_size_map[i] >= granules(i), */ -/* but not too much bigger */ -/* and so that size_map contains relatively few distinct entries */ -/* This was originally stolen from Russ Atkinson's Cedar */ -/* quantization algorithm (but we precompute it). */ -STATIC void GC_init_size_map(void) -{ - int i; - - /* Map size 0 to something bigger. */ - /* This avoids problems at lower levels. */ - GC_size_map[0] = 1; - for (i = 1; i <= GRANULES_TO_BYTES(TINY_FREELISTS-1) - EXTRA_BYTES; i++) { - GC_size_map[i] = ROUNDED_UP_GRANULES(i); -# ifndef _MSC_VER - GC_ASSERT(GC_size_map[i] < TINY_FREELISTS); - /* Seems to tickle bug in VC++ 2008 for AMD64 */ -# endif - } - /* We leave the rest of the array to be filled in on demand. */ -} - -/* Fill in additional entries in GC_size_map, including the ith one */ -/* We assume the ith entry is currently 0. */ -/* Note that a filled in section of the array ending at n always */ -/* has length at least n/4. */ -GC_INNER void GC_extend_size_map(size_t i) -{ - size_t orig_granule_sz = ROUNDED_UP_GRANULES(i); - size_t granule_sz = orig_granule_sz; - size_t byte_sz = GRANULES_TO_BYTES(granule_sz); - /* The size we try to preserve. */ - /* Close to i, unless this would */ - /* introduce too many distinct sizes. */ - size_t smaller_than_i = byte_sz - (byte_sz >> 3); - size_t much_smaller_than_i = byte_sz - (byte_sz >> 2); - size_t low_limit; /* The lowest indexed entry we */ - /* initialize. */ - size_t j; - - if (GC_size_map[smaller_than_i] == 0) { - low_limit = much_smaller_than_i; - while (GC_size_map[low_limit] != 0) low_limit++; - } else { - low_limit = smaller_than_i + 1; - while (GC_size_map[low_limit] != 0) low_limit++; - granule_sz = ROUNDED_UP_GRANULES(low_limit); - granule_sz += granule_sz >> 3; - if (granule_sz < orig_granule_sz) granule_sz = orig_granule_sz; - } - /* For these larger sizes, we use an even number of granules. */ - /* This makes it easier to, for example, construct a 16byte-aligned */ - /* allocator even if GRANULE_BYTES is 8. */ - granule_sz += 1; - granule_sz &= ~1; - if (granule_sz > MAXOBJGRANULES) { - granule_sz = MAXOBJGRANULES; - } - /* If we can fit the same number of larger objects in a block, */ - /* do so. */ - { - size_t number_of_objs = HBLK_GRANULES/granule_sz; - GC_ASSERT(number_of_objs != 0); - granule_sz = HBLK_GRANULES/number_of_objs; - granule_sz &= ~1; - } - byte_sz = GRANULES_TO_BYTES(granule_sz); - /* We may need one extra byte; */ - /* don't always fill in GC_size_map[byte_sz] */ - byte_sz -= EXTRA_BYTES; - - for (j = low_limit; j <= byte_sz; j++) GC_size_map[j] = granule_sz; -} - - -/* - * The following is a gross hack to deal with a problem that can occur - * on machines that are sloppy about stack frame sizes, notably SPARC. - * Bogus pointers may be written to the stack and not cleared for - * a LONG time, because they always fall into holes in stack frames - * that are not written. We partially address this by clearing - * sections of the stack whenever we get control. - */ -# ifdef THREADS -# define BIG_CLEAR_SIZE 2048 /* Clear this much now and then. */ -# define SMALL_CLEAR_SIZE 256 /* Clear this much every time. */ -# else - STATIC word GC_stack_last_cleared = 0; /* GC_no when we last did this */ - STATIC ptr_t GC_min_sp = NULL; - /* Coolest stack pointer value from which */ - /* we've already cleared the stack. */ - STATIC ptr_t GC_high_water = NULL; - /* "hottest" stack pointer value we have seen */ - /* recently. Degrades over time. */ - STATIC word GC_bytes_allocd_at_reset = 0; -# define DEGRADE_RATE 50 -# endif - -# define CLEAR_SIZE 213 /* Granularity for GC_clear_stack_inner */ - -#if defined(ASM_CLEAR_CODE) - void *GC_clear_stack_inner(void *, ptr_t); -#else - /* Clear the stack up to about limit. Return arg. This function is */ - /* not static because it could also be erroneously defined in .S */ - /* file, so this error would be caught by the linker. */ - void * GC_clear_stack_inner(void *arg, ptr_t limit) - { - volatile word dummy[CLEAR_SIZE]; - - BZERO((/* no volatile */ void *)dummy, sizeof(dummy)); - if ((word)GC_approx_sp() COOLER_THAN (word)limit) { - (void) GC_clear_stack_inner(arg, limit); - } - /* Make sure the recursive call is not a tail call, and the bzero */ - /* call is not recognized as dead code. */ - GC_noop1((word)dummy); - return(arg); - } -#endif - -/* Clear some of the inaccessible part of the stack. Returns its */ -/* argument, so it can be used in a tail call position, hence clearing */ -/* another frame. */ -GC_API void * GC_CALL GC_clear_stack(void *arg) -{ -# ifndef STACK_NOT_SCANNED - ptr_t sp = GC_approx_sp(); /* Hotter than actual sp */ -# ifdef THREADS - word volatile dummy[SMALL_CLEAR_SIZE]; - static unsigned random_no = 0; - /* Should be more random than it is ... */ - /* Used to occasionally clear a bigger */ - /* chunk. */ -# endif - ptr_t limit; - -# define SLOP 400 - /* Extra bytes we clear every time. This clears our own */ - /* activation record, and should cause more frequent */ - /* clearing near the cold end of the stack, a good thing. */ -# define GC_SLOP 4000 - /* We make GC_high_water this much hotter than we really saw */ - /* saw it, to cover for GC noise etc. above our current frame. */ -# define CLEAR_THRESHOLD 100000 - /* We restart the clearing process after this many bytes of */ - /* allocation. Otherwise very heavily recursive programs */ - /* with sparse stacks may result in heaps that grow almost */ - /* without bounds. As the heap gets larger, collection */ - /* frequency decreases, thus clearing frequency would decrease, */ - /* thus more junk remains accessible, thus the heap gets */ - /* larger ... */ -# ifdef THREADS - if (++random_no % 13 == 0) { - limit = sp; - MAKE_HOTTER(limit, BIG_CLEAR_SIZE*sizeof(word)); - limit = (ptr_t)((word)limit & ~0xf); - /* Make it sufficiently aligned for assembly */ - /* implementations of GC_clear_stack_inner. */ - return GC_clear_stack_inner(arg, limit); - } else { - BZERO((void *)dummy, SMALL_CLEAR_SIZE*sizeof(word)); - } -# else - if (GC_gc_no > GC_stack_last_cleared) { - /* Start things over, so we clear the entire stack again */ - if (GC_stack_last_cleared == 0) - GC_high_water = (ptr_t)GC_stackbottom; - GC_min_sp = GC_high_water; - GC_stack_last_cleared = GC_gc_no; - GC_bytes_allocd_at_reset = GC_bytes_allocd; - } - /* Adjust GC_high_water */ - MAKE_COOLER(GC_high_water, WORDS_TO_BYTES(DEGRADE_RATE) + GC_SLOP); - if ((word)sp HOTTER_THAN (word)GC_high_water) { - GC_high_water = sp; - } - MAKE_HOTTER(GC_high_water, GC_SLOP); - limit = GC_min_sp; - MAKE_HOTTER(limit, SLOP); - if ((word)sp COOLER_THAN (word)limit) { - limit = (ptr_t)((word)limit & ~0xf); - /* Make it sufficiently aligned for assembly */ - /* implementations of GC_clear_stack_inner. */ - GC_min_sp = sp; - return GC_clear_stack_inner(arg, limit); - } else if (GC_bytes_allocd - GC_bytes_allocd_at_reset - > CLEAR_THRESHOLD) { - /* Restart clearing process, but limit how much clearing we do. */ - GC_min_sp = sp; - MAKE_HOTTER(GC_min_sp, CLEAR_THRESHOLD/4); - if ((word)GC_min_sp HOTTER_THAN (word)GC_high_water) - GC_min_sp = GC_high_water; - GC_bytes_allocd_at_reset = GC_bytes_allocd; - } -# endif -# endif - return arg; -} - -/* Return a pointer to the base address of p, given a pointer to a */ -/* an address within an object. Return 0 o.w. */ -GC_API void * GC_CALL GC_base(void * p) -{ - ptr_t r; - struct hblk *h; - bottom_index *bi; - hdr *candidate_hdr; - ptr_t limit; - - r = p; - if (!EXPECT(GC_is_initialized, TRUE)) return 0; - h = HBLKPTR(r); - GET_BI(r, bi); - candidate_hdr = HDR_FROM_BI(bi, r); - if (candidate_hdr == 0) return(0); - /* If it's a pointer to the middle of a large object, move it */ - /* to the beginning. */ - while (IS_FORWARDING_ADDR_OR_NIL(candidate_hdr)) { - h = FORWARDED_ADDR(h,candidate_hdr); - r = (ptr_t)h; - candidate_hdr = HDR(h); - } - if (HBLK_IS_FREE(candidate_hdr)) return(0); - /* Make sure r points to the beginning of the object */ - r = (ptr_t)((word)r & ~(WORDS_TO_BYTES(1) - 1)); - { - size_t offset = HBLKDISPL(r); - word sz = candidate_hdr -> hb_sz; - size_t obj_displ = offset % sz; - - r -= obj_displ; - limit = r + sz; - if ((word)limit > (word)(h + 1) && sz <= HBLKSIZE) { - return(0); - } - if ((word)p >= (word)limit) return(0); - } - return((void *)r); -} - -/* Return TRUE if and only if p points to somewhere in GC heap. */ -GC_API int GC_CALL GC_is_heap_ptr(const void *p) -{ - bottom_index *bi; - - GC_ASSERT(GC_is_initialized); - GET_BI(p, bi); - return HDR_FROM_BI(bi, p) != 0; -} - -/* Return the size of an object, given a pointer to its base. */ -/* (For small objects this also happens to work from interior pointers, */ -/* but that shouldn't be relied upon.) */ -GC_API size_t GC_CALL GC_size(const void * p) -{ - hdr * hhdr = HDR(p); - - return hhdr -> hb_sz; -} - - -/* These getters remain unsynchronized for compatibility (since some */ -/* clients could call some of them from a GC callback holding the */ -/* allocator lock). */ -GC_API size_t GC_CALL GC_get_heap_size(void) -{ - /* ignore the memory space returned to OS (i.e. count only the */ - /* space owned by the garbage collector) */ - return (size_t)(GC_heapsize - GC_unmapped_bytes); -} - -GC_API size_t GC_CALL GC_get_free_bytes(void) -{ - /* ignore the memory space returned to OS */ - return (size_t)(GC_large_free_bytes - GC_unmapped_bytes); -} - -GC_API size_t GC_CALL GC_get_unmapped_bytes(void) -{ - return (size_t)GC_unmapped_bytes; -} - -GC_API size_t GC_CALL GC_get_bytes_since_gc(void) -{ - return (size_t)GC_bytes_allocd; -} - -GC_API size_t GC_CALL GC_get_total_bytes(void) -{ - return (size_t)(GC_bytes_allocd + GC_bytes_allocd_before_gc); -} - -#ifndef GC_GET_HEAP_USAGE_NOT_NEEDED - -/* Return the heap usage information. This is a thread-safe (atomic) */ -/* alternative for the five above getters. NULL pointer is allowed for */ -/* any argument. Returned (filled in) values are of word type. */ -GC_API void GC_CALL GC_get_heap_usage_safe(GC_word *pheap_size, - GC_word *pfree_bytes, GC_word *punmapped_bytes, - GC_word *pbytes_since_gc, GC_word *ptotal_bytes) -{ - DCL_LOCK_STATE; - - LOCK(); - if (pheap_size != NULL) - *pheap_size = GC_heapsize - GC_unmapped_bytes; - if (pfree_bytes != NULL) - *pfree_bytes = GC_large_free_bytes - GC_unmapped_bytes; - if (punmapped_bytes != NULL) - *punmapped_bytes = GC_unmapped_bytes; - if (pbytes_since_gc != NULL) - *pbytes_since_gc = GC_bytes_allocd; - if (ptotal_bytes != NULL) - *ptotal_bytes = GC_bytes_allocd + GC_bytes_allocd_before_gc; - UNLOCK(); -} - - GC_INNER word GC_reclaimed_bytes_before_gc = 0; - - /* Fill in GC statistics provided the destination is of enough size. */ - static void fill_prof_stats(struct GC_prof_stats_s *pstats) - { - pstats->heapsize_full = GC_heapsize; - pstats->free_bytes_full = GC_large_free_bytes; - pstats->unmapped_bytes = GC_unmapped_bytes; - pstats->bytes_allocd_since_gc = GC_bytes_allocd; - pstats->allocd_bytes_before_gc = GC_bytes_allocd_before_gc; - pstats->non_gc_bytes = GC_non_gc_bytes; - pstats->gc_no = GC_gc_no; /* could be -1 */ -# ifdef PARALLEL_MARK - pstats->markers_m1 = (word)GC_markers_m1; -# else - pstats->markers_m1 = 0; /* one marker */ -# endif - pstats->bytes_reclaimed_since_gc = GC_bytes_found > 0 ? - (word)GC_bytes_found : 0; - pstats->reclaimed_bytes_before_gc = GC_reclaimed_bytes_before_gc; - } - -# include /* for memset() */ - - GC_API size_t GC_CALL GC_get_prof_stats(struct GC_prof_stats_s *pstats, - size_t stats_sz) - { - struct GC_prof_stats_s stats; - DCL_LOCK_STATE; - - LOCK(); - fill_prof_stats(stats_sz >= sizeof(stats) ? pstats : &stats); - UNLOCK(); - - if (stats_sz == sizeof(stats)) { - return sizeof(stats); - } else if (stats_sz > sizeof(stats)) { - /* Fill in the remaining part with -1. */ - memset((char *)pstats + sizeof(stats), 0xff, stats_sz - sizeof(stats)); - return sizeof(stats); - } else { - BCOPY(&stats, pstats, stats_sz); - return stats_sz; - } - } - -# ifdef THREADS - /* The _unsafe version assumes the caller holds the allocation lock. */ - GC_API size_t GC_CALL GC_get_prof_stats_unsafe( - struct GC_prof_stats_s *pstats, - size_t stats_sz) - { - struct GC_prof_stats_s stats; - - if (stats_sz >= sizeof(stats)) { - fill_prof_stats(pstats); - if (stats_sz > sizeof(stats)) - memset((char *)pstats + sizeof(stats), 0xff, - stats_sz - sizeof(stats)); - return sizeof(stats); - } else { - fill_prof_stats(&stats); - BCOPY(&stats, pstats, stats_sz); - return stats_sz; - } - } -# endif /* THREADS */ - -#endif /* !GC_GET_HEAP_USAGE_NOT_NEEDED */ - -#if defined(GC_DARWIN_THREADS) || defined(GC_OPENBSD_UTHREADS) \ - || defined(GC_WIN32_THREADS) || (defined(NACL) && defined(THREADS)) - /* GC does not use signals to suspend and restart threads. */ - GC_API void GC_CALL GC_set_suspend_signal(int sig GC_ATTR_UNUSED) - { - /* empty */ - } - - GC_API void GC_CALL GC_set_thr_restart_signal(int sig GC_ATTR_UNUSED) - { - /* empty */ - } - - GC_API int GC_CALL GC_get_suspend_signal(void) - { - return -1; - } - - GC_API int GC_CALL GC_get_thr_restart_signal(void) - { - return -1; - } -#endif /* GC_DARWIN_THREADS || GC_WIN32_THREADS || ... */ - -#if !defined(_MAX_PATH) && (defined(MSWIN32) || defined(MSWINCE) \ - || defined(CYGWIN32)) -# define _MAX_PATH MAX_PATH -#endif - -#ifdef GC_READ_ENV_FILE - /* This works for Win32/WinCE for now. Really useful only for WinCE. */ - STATIC char *GC_envfile_content = NULL; - /* The content of the GC "env" file with CR and */ - /* LF replaced to '\0'. NULL if the file is */ - /* missing or empty. Otherwise, always ends */ - /* with '\0'. */ - STATIC unsigned GC_envfile_length = 0; - /* Length of GC_envfile_content (if non-NULL). */ - -# ifndef GC_ENVFILE_MAXLEN -# define GC_ENVFILE_MAXLEN 0x4000 -# endif - - /* The routine initializes GC_envfile_content from the GC "env" file. */ - STATIC void GC_envfile_init(void) - { -# if defined(MSWIN32) || defined(MSWINCE) || defined(CYGWIN32) - HANDLE hFile; - char *content; - unsigned ofs; - unsigned len; - DWORD nBytesRead; - TCHAR path[_MAX_PATH + 0x10]; /* buffer for path + ext */ - len = (unsigned)GetModuleFileName(NULL /* hModule */, path, - _MAX_PATH + 1); - /* If GetModuleFileName() has failed then len is 0. */ - if (len > 4 && path[len - 4] == (TCHAR)'.') { - len -= 4; /* strip executable file extension */ - } - BCOPY(TEXT(".gc.env"), &path[len], sizeof(TEXT(".gc.env"))); - hFile = CreateFile(path, GENERIC_READ, - FILE_SHARE_READ | FILE_SHARE_WRITE, - NULL /* lpSecurityAttributes */, OPEN_EXISTING, - FILE_ATTRIBUTE_NORMAL, NULL /* hTemplateFile */); - if (hFile == INVALID_HANDLE_VALUE) - return; /* the file is absent or the operation is failed */ - len = (unsigned)GetFileSize(hFile, NULL); - if (len <= 1 || len >= GC_ENVFILE_MAXLEN) { - CloseHandle(hFile); - return; /* invalid file length - ignoring the file content */ - } - /* At this execution point, GC_setpagesize() and GC_init_win32() */ - /* must already be called (for GET_MEM() to work correctly). */ - content = (char *)GET_MEM(ROUNDUP_PAGESIZE_IF_MMAP(len + 1)); - if (content == NULL) { - CloseHandle(hFile); - return; /* allocation failure */ - } - ofs = 0; - nBytesRead = (DWORD)-1L; - /* Last ReadFile() call should clear nBytesRead on success. */ - while (ReadFile(hFile, content + ofs, len - ofs + 1, &nBytesRead, - NULL /* lpOverlapped */) && nBytesRead != 0) { - if ((ofs += nBytesRead) > len) - break; - } - CloseHandle(hFile); - if (ofs != len || nBytesRead != 0) - return; /* read operation is failed - ignoring the file content */ - content[ofs] = '\0'; - while (ofs-- > 0) { - if (content[ofs] == '\r' || content[ofs] == '\n') - content[ofs] = '\0'; - } - GC_envfile_length = len + 1; - GC_envfile_content = content; -# endif - } - - /* This routine scans GC_envfile_content for the specified */ - /* environment variable (and returns its value if found). */ - GC_INNER char * GC_envfile_getenv(const char *name) - { - char *p; - char *end_of_content; - unsigned namelen; -# ifndef NO_GETENV - p = getenv(name); /* try the standard getenv() first */ - if (p != NULL) - return *p != '\0' ? p : NULL; -# endif - p = GC_envfile_content; - if (p == NULL) - return NULL; /* "env" file is absent (or empty) */ - namelen = strlen(name); - if (namelen == 0) /* a sanity check */ - return NULL; - for (end_of_content = p + GC_envfile_length; - p != end_of_content; p += strlen(p) + 1) { - if (strncmp(p, name, namelen) == 0 && *(p += namelen) == '=') { - p++; /* the match is found; skip '=' */ - return *p != '\0' ? p : NULL; - } - /* If not matching then skip to the next line. */ - } - return NULL; /* no match found */ - } -#endif /* GC_READ_ENV_FILE */ - -GC_INNER GC_bool GC_is_initialized = FALSE; - -#if (defined(MSWIN32) || defined(MSWINCE)) && defined(THREADS) - GC_INNER CRITICAL_SECTION GC_write_cs; -#endif - -#ifndef DONT_USE_ATEXIT - STATIC void GC_exit_check(void) - { - if (GC_find_leak) { - GC_gcollect(); - } - } -#endif - -#if defined(UNIX_LIKE) && !defined(NO_DEBUGGING) - static void looping_handler(int sig) - { - GC_err_printf("Caught signal %d: looping in handler\n", sig); - for (;;) { - /* empty */ - } - } - - static GC_bool installed_looping_handler = FALSE; - - static void maybe_install_looping_handler(void) - { - /* Install looping handler before the write fault handler, so we */ - /* handle write faults correctly. */ - if (!installed_looping_handler && 0 != GETENV("GC_LOOP_ON_ABORT")) { - GC_set_and_save_fault_handler(looping_handler); - installed_looping_handler = TRUE; - } - } - -#else /* !UNIX_LIKE */ -# define maybe_install_looping_handler() -#endif - -#define GC_DEFAULT_STDOUT_FD 1 -#define GC_DEFAULT_STDERR_FD 2 - -#if !defined(OS2) && !defined(MACOS) && !defined(GC_ANDROID_LOG) \ - && !defined(MSWIN32) && !defined(MSWINCE) - STATIC int GC_stdout = GC_DEFAULT_STDOUT_FD; - STATIC int GC_stderr = GC_DEFAULT_STDERR_FD; - STATIC int GC_log = GC_DEFAULT_STDERR_FD; - - GC_API void GC_CALL GC_set_log_fd(int fd) - { - GC_log = fd; - } -#endif - -STATIC word GC_parse_mem_size_arg(const char *str) -{ - char *endptr; - word result = 0; /* bad value */ - char ch; - - if (*str != '\0') { - result = (word)STRTOULL(str, &endptr, 10); - ch = *endptr; - if (ch != '\0') { - if (*(endptr + 1) != '\0') - return 0; - /* Allow k, M or G suffix. */ - switch (ch) { - case 'K': - case 'k': - result <<= 10; - break; - case 'M': - case 'm': - result <<= 20; - break; - case 'G': - case 'g': - result <<= 30; - break; - default: - result = 0; - } - } - } - return result; -} - -#define GC_LOG_STD_NAME "gc.log" - -GC_API void GC_CALL GC_init(void) -{ - /* LOCK(); -- no longer does anything this early. */ - word initial_heap_sz; - IF_CANCEL(int cancel_state;) - - if (EXPECT(GC_is_initialized, TRUE)) return; -# ifdef REDIRECT_MALLOC - { - static GC_bool init_started = FALSE; - if (init_started) - ABORT("Redirected malloc() called during GC init"); - init_started = TRUE; - } -# endif - -# ifdef GC_INITIAL_HEAP_SIZE - initial_heap_sz = divHBLKSZ(GC_INITIAL_HEAP_SIZE); -# else - initial_heap_sz = (word)MINHINCR; -# endif - DISABLE_CANCEL(cancel_state); - /* Note that although we are nominally called with the */ - /* allocation lock held, the allocation lock is now */ - /* only really acquired once a second thread is forked.*/ - /* And the initialization code needs to run before */ - /* then. Thus we really don't hold any locks, and can */ - /* in fact safely initialize them here. */ -# ifdef THREADS -# ifndef GC_ALWAYS_MULTITHREADED - GC_ASSERT(!GC_need_to_lock); -# endif -# ifdef SN_TARGET_PS3 - { - pthread_mutexattr_t mattr; - - if (0 != pthread_mutexattr_init(&mattr)) { - ABORT("pthread_mutexattr_init failed"); - } - if (0 != pthread_mutex_init(&GC_allocate_ml, &mattr)) { - ABORT("pthread_mutex_init failed"); - } - (void)pthread_mutexattr_destroy(&mattr); - } -# endif -# endif /* THREADS */ -# if defined(GC_WIN32_THREADS) && !defined(GC_PTHREADS) - { -# ifndef MSWINCE - BOOL (WINAPI *pfn) (LPCRITICAL_SECTION, DWORD) = NULL; - HMODULE hK32 = GetModuleHandle(TEXT("kernel32.dll")); - if (hK32) - pfn = (BOOL (WINAPI *) (LPCRITICAL_SECTION, DWORD)) - GetProcAddress (hK32, - "InitializeCriticalSectionAndSpinCount"); - if (pfn) - pfn(&GC_allocate_ml, 4000); - else -# endif /* !MSWINCE */ - /* else */ InitializeCriticalSection (&GC_allocate_ml); - } -# endif /* GC_WIN32_THREADS */ -# if (defined(MSWIN32) || defined(MSWINCE)) && defined(THREADS) - InitializeCriticalSection(&GC_write_cs); -# endif - GC_setpagesize(); -# ifdef MSWIN32 - GC_init_win32(); -# endif -# ifdef GC_READ_ENV_FILE - GC_envfile_init(); -# endif -# ifndef SMALL_CONFIG -# ifdef GC_PRINT_VERBOSE_STATS - /* This is useful for debugging and profiling on platforms with */ - /* missing getenv() (like WinCE). */ - GC_print_stats = VERBOSE; -# else - if (0 != GETENV("GC_PRINT_VERBOSE_STATS")) { - GC_print_stats = VERBOSE; - } else if (0 != GETENV("GC_PRINT_STATS")) { - GC_print_stats = 1; - } -# endif -# if (defined(UNIX_LIKE) && !defined(GC_ANDROID_LOG)) \ - || defined(CYGWIN32) || defined(SYMBIAN) - { - char * file_name = GETENV("GC_LOG_FILE"); -# ifdef GC_LOG_TO_FILE_ALWAYS - if (NULL == file_name) - file_name = GC_LOG_STD_NAME; -# else - if (0 != file_name) -# endif - { - int log_d = open(file_name, O_CREAT|O_WRONLY|O_APPEND, 0666); - if (log_d < 0) { - GC_err_printf("Failed to open %s as log file\n", file_name); - } else { - char *str; - GC_log = log_d; - str = GETENV("GC_ONLY_LOG_TO_FILE"); -# ifdef GC_ONLY_LOG_TO_FILE - /* The similar environment variable set to "0" */ - /* overrides the effect of the macro defined. */ - if (str != NULL && *str == '0' && *(str + 1) == '\0') -# else - /* Otherwise setting the environment variable */ - /* to anything other than "0" will prevent from */ - /* redirecting stdout/err to the log file. */ - if (str == NULL || (*str == '0' && *(str + 1) == '\0')) -# endif - { - GC_stdout = log_d; - GC_stderr = log_d; - } - } - } - } -# endif -# endif /* !SMALL_CONFIG */ -# if !defined(NO_DEBUGGING) && !defined(GC_DUMP_REGULARLY) - if (0 != GETENV("GC_DUMP_REGULARLY")) { - GC_dump_regularly = TRUE; - } -# endif -# ifdef KEEP_BACK_PTRS - { - char * backtraces_string = GETENV("GC_BACKTRACES"); - if (0 != backtraces_string) { - GC_backtraces = atol(backtraces_string); - if (backtraces_string[0] == '\0') GC_backtraces = 1; - } - } -# endif - if (0 != GETENV("GC_FIND_LEAK")) { - GC_find_leak = 1; - } -# ifndef SHORT_DBG_HDRS - if (0 != GETENV("GC_FINDLEAK_DELAY_FREE")) { - GC_findleak_delay_free = TRUE; - } -# endif - if (0 != GETENV("GC_ALL_INTERIOR_POINTERS")) { - GC_all_interior_pointers = 1; - } - if (0 != GETENV("GC_DONT_GC")) { - GC_dont_gc = 1; - } - if (0 != GETENV("GC_PRINT_BACK_HEIGHT")) { - GC_print_back_height = TRUE; - } - if (0 != GETENV("GC_NO_BLACKLIST_WARNING")) { - GC_large_alloc_warn_interval = LONG_MAX; - } - { - char * addr_string = GETENV("GC_TRACE"); - if (0 != addr_string) { -# ifndef ENABLE_TRACE - WARN("Tracing not enabled: Ignoring GC_TRACE value\n", 0); -# else - word addr = (word)STRTOULL(addr_string, NULL, 16); - if (addr < 0x1000) - WARN("Unlikely trace address: %p\n", addr); - GC_trace_addr = (ptr_t)addr; -# endif - } - } -# ifdef GC_COLLECT_AT_MALLOC - { - char * string = GETENV("GC_COLLECT_AT_MALLOC"); - if (0 != string) { - size_t min_lb = (size_t)STRTOULL(string, NULL, 10); - if (min_lb > 0) - GC_dbg_collect_at_malloc_min_lb = min_lb; - } - } -# endif -# ifndef GC_DISABLE_INCREMENTAL - { - char * time_limit_string = GETENV("GC_PAUSE_TIME_TARGET"); - if (0 != time_limit_string) { - long time_limit = atol(time_limit_string); - if (time_limit < 5) { - WARN("GC_PAUSE_TIME_TARGET environment variable value too small " - "or bad syntax: Ignoring\n", 0); - } else { - GC_time_limit = time_limit; - } - } - } -# endif -# ifndef SMALL_CONFIG - { - char * full_freq_string = GETENV("GC_FULL_FREQUENCY"); - if (full_freq_string != NULL) { - int full_freq = atoi(full_freq_string); - if (full_freq > 0) - GC_full_freq = full_freq; - } - } -# endif - { - char * interval_string = GETENV("GC_LARGE_ALLOC_WARN_INTERVAL"); - if (0 != interval_string) { - long interval = atol(interval_string); - if (interval <= 0) { - WARN("GC_LARGE_ALLOC_WARN_INTERVAL environment variable has " - "bad value: Ignoring\n", 0); - } else { - GC_large_alloc_warn_interval = interval; - } - } - } - { - char * space_divisor_string = GETENV("GC_FREE_SPACE_DIVISOR"); - if (space_divisor_string != NULL) { - int space_divisor = atoi(space_divisor_string); - if (space_divisor > 0) - GC_free_space_divisor = (GC_word)space_divisor; - } - } -# ifdef USE_MUNMAP - { - char * string = GETENV("GC_UNMAP_THRESHOLD"); - if (string != NULL) { - if (*string == '0' && *(string + 1) == '\0') { - /* "0" is used to disable unmapping. */ - GC_unmap_threshold = 0; - } else { - int unmap_threshold = atoi(string); - if (unmap_threshold > 0) - GC_unmap_threshold = unmap_threshold; - } - } - } - { - char * string = GETENV("GC_FORCE_UNMAP_ON_GCOLLECT"); - if (string != NULL) { - if (*string == '0' && *(string + 1) == '\0') { - /* "0" is used to turn off the mode. */ - GC_force_unmap_on_gcollect = FALSE; - } else { - GC_force_unmap_on_gcollect = TRUE; - } - } - } - { - char * string = GETENV("GC_USE_ENTIRE_HEAP"); - if (string != NULL) { - if (*string == '0' && *(string + 1) == '\0') { - /* "0" is used to turn off the mode. */ - GC_use_entire_heap = FALSE; - } else { - GC_use_entire_heap = TRUE; - } - } - } -# endif - maybe_install_looping_handler(); - /* Adjust normal object descriptor for extra allocation. */ - if (ALIGNMENT > GC_DS_TAGS && EXTRA_BYTES != 0) { - GC_obj_kinds[NORMAL].ok_descriptor = ((word)(-ALIGNMENT) | GC_DS_LENGTH); - } - GC_exclude_static_roots_inner(beginGC_arrays, endGC_arrays); - GC_exclude_static_roots_inner(beginGC_obj_kinds, endGC_obj_kinds); -# ifdef SEPARATE_GLOBALS - GC_exclude_static_roots_inner(beginGC_objfreelist, endGC_objfreelist); - GC_exclude_static_roots_inner(beginGC_aobjfreelist, endGC_aobjfreelist); -# endif -# if defined(USE_PROC_FOR_LIBRARIES) && defined(GC_LINUX_THREADS) - WARN("USE_PROC_FOR_LIBRARIES + GC_LINUX_THREADS performs poorly.\n", 0); - /* If thread stacks are cached, they tend to be scanned in */ - /* entirety as part of the root set. This wil grow them to */ - /* maximum size, and is generally not desirable. */ -# endif -# if defined(SEARCH_FOR_DATA_START) - GC_init_linux_data_start(); -# endif -# if defined(NETBSD) && defined(__ELF__) - GC_init_netbsd_elf(); -# endif -# if !defined(THREADS) || defined(GC_PTHREADS) \ - || defined(GC_WIN32_THREADS) || defined(GC_SOLARIS_THREADS) - if (GC_stackbottom == 0) { - GC_stackbottom = GC_get_main_stack_base(); -# if (defined(LINUX) || defined(HPUX)) && defined(IA64) - GC_register_stackbottom = GC_get_register_stack_base(); -# endif - } else { -# if (defined(LINUX) || defined(HPUX)) && defined(IA64) - if (GC_register_stackbottom == 0) { - WARN("GC_register_stackbottom should be set with GC_stackbottom\n", 0); - /* The following may fail, since we may rely on */ - /* alignment properties that may not hold with a user set */ - /* GC_stackbottom. */ - GC_register_stackbottom = GC_get_register_stack_base(); - } -# endif - } -# endif - GC_STATIC_ASSERT(sizeof (ptr_t) == sizeof(word)); - GC_STATIC_ASSERT(sizeof (signed_word) == sizeof(word)); - GC_STATIC_ASSERT(sizeof (struct hblk) == HBLKSIZE); -# ifndef THREADS - GC_ASSERT(!((word)GC_stackbottom HOTTER_THAN (word)GC_approx_sp())); -# endif -# if !defined(_AUX_SOURCE) || defined(__GNUC__) - GC_STATIC_ASSERT((word)(-1) > (word)0); - /* word should be unsigned */ -# endif - /* We no longer check for ((void*)(-1) > NULL) since all pointers */ - /* are explicitly cast to word in every less-greater comparison. */ - GC_STATIC_ASSERT((signed_word)(-1) < (signed_word)0); -# ifndef GC_DISABLE_INCREMENTAL - if (GC_incremental || 0 != GETENV("GC_ENABLE_INCREMENTAL")) { - /* For GWW_VDB on Win32, this needs to happen before any */ - /* heap memory is allocated. */ - GC_dirty_init(); - GC_ASSERT(GC_bytes_allocd == 0); - GC_incremental = TRUE; - } -# endif - - /* Add initial guess of root sets. Do this first, since sbrk(0) */ - /* might be used. */ - if (GC_REGISTER_MAIN_STATIC_DATA()) GC_register_data_segments(); - GC_init_headers(); - GC_bl_init(); - GC_mark_init(); - { - char * sz_str = GETENV("GC_INITIAL_HEAP_SIZE"); - if (sz_str != NULL) { - initial_heap_sz = GC_parse_mem_size_arg(sz_str); - if (initial_heap_sz <= MINHINCR * HBLKSIZE) { - WARN("Bad initial heap size %s - ignoring it.\n", sz_str); - } - initial_heap_sz = divHBLKSZ(initial_heap_sz); - } - } - { - char * sz_str = GETENV("GC_MAXIMUM_HEAP_SIZE"); - if (sz_str != NULL) { - word max_heap_sz = GC_parse_mem_size_arg(sz_str); - if (max_heap_sz < initial_heap_sz * HBLKSIZE) { - WARN("Bad maximum heap size %s - ignoring it.\n", sz_str); - } - if (0 == GC_max_retries) GC_max_retries = 2; - GC_set_max_heap_size(max_heap_sz); - } - } - if (!GC_expand_hp_inner(initial_heap_sz)) { - GC_err_printf("Can't start up: not enough memory\n"); - EXIT(); - } else { - GC_requested_heapsize += initial_heap_sz; - } - if (GC_all_interior_pointers) - GC_initialize_offsets(); - GC_register_displacement_inner(0L); -# if defined(GC_LINUX_THREADS) && defined(REDIRECT_MALLOC) - if (!GC_all_interior_pointers) { - /* TLS ABI uses pointer-sized offsets for dtv. */ - GC_register_displacement_inner(sizeof(void *)); - } -# endif - GC_init_size_map(); -# ifdef PCR - if (PCR_IL_Lock(PCR_Bool_false, PCR_allSigsBlocked, PCR_waitForever) - != PCR_ERes_okay) { - ABORT("Can't lock load state"); - } else if (PCR_IL_Unlock() != PCR_ERes_okay) { - ABORT("Can't unlock load state"); - } - PCR_IL_Unlock(); - GC_pcr_install(); -# endif - GC_is_initialized = TRUE; -# if defined(GC_PTHREADS) || defined(GC_WIN32_THREADS) - GC_thr_init(); -# endif - COND_DUMP; - /* Get black list set up and/or incremental GC started */ - if (!GC_dont_precollect || GC_incremental) GC_gcollect_inner(); -# ifdef STUBBORN_ALLOC - GC_stubborn_init(); -# endif -# ifndef DONT_USE_ATEXIT - if (GC_find_leak) { - /* This is to give us at least one chance to detect leaks. */ - /* This may report some very benign leaks, but ... */ - atexit(GC_exit_check); - } -# endif - - /* The rest of this again assumes we don't really hold */ - /* the allocation lock. */ -# if defined(PARALLEL_MARK) || defined(THREAD_LOCAL_ALLOC) \ - || (defined(GC_ALWAYS_MULTITHREADED) && defined(GC_WIN32_THREADS) \ - && !defined(GC_NO_THREADS_DISCOVERY)) - /* Make sure marker threads are started and thread local */ - /* allocation is initialized, in case we didn't get */ - /* called from GC_init_parallel. */ - GC_init_parallel(); -# endif /* PARALLEL_MARK || THREAD_LOCAL_ALLOC */ - -# if defined(DYNAMIC_LOADING) && defined(DARWIN) - /* This must be called WITHOUT the allocation lock held */ - /* and before any threads are created. */ - GC_init_dyld(); -# endif - RESTORE_CANCEL(cancel_state); -} - -GC_API void GC_CALL GC_enable_incremental(void) -{ -# if !defined(GC_DISABLE_INCREMENTAL) && !defined(KEEP_BACK_PTRS) - DCL_LOCK_STATE; - /* If we are keeping back pointers, the GC itself dirties all */ - /* pages on which objects have been marked, making */ - /* incremental GC pointless. */ - if (!GC_find_leak && 0 == GETENV("GC_DISABLE_INCREMENTAL")) { - LOCK(); - if (!GC_incremental) { - GC_setpagesize(); - /* if (GC_no_win32_dlls) goto out; Should be win32S test? */ - maybe_install_looping_handler(); /* Before write fault handler! */ - GC_incremental = TRUE; - if (!GC_is_initialized) { - GC_init(); - } else { - GC_dirty_init(); - } - if (GC_dirty_maintained && !GC_dont_gc) { - /* Can't easily do it if GC_dont_gc. */ - if (GC_bytes_allocd > 0) { - /* There may be unmarked reachable objects. */ - GC_gcollect_inner(); - } - /* else we're OK in assuming everything's */ - /* clean since nothing can point to an */ - /* unmarked object. */ - GC_read_dirty(); - } - } - UNLOCK(); - return; - } -# endif - GC_init(); -} - -#if defined(THREADS) && (!defined(PARALLEL_MARK) || !defined(CAN_HANDLE_FORK)) - GC_API void GC_CALL GC_start_mark_threads(void) - { - /* No action since parallel markers are disabled (or no POSIX fork). */ - GC_ASSERT(I_DONT_HOLD_LOCK()); - } -#endif - -#if defined(MSWIN32) || defined(MSWINCE) - -# if defined(_MSC_VER) && defined(_DEBUG) && !defined(MSWINCE) -# include -# endif - - STATIC HANDLE GC_log = 0; - - void GC_deinit(void) - { -# ifdef THREADS - if (GC_is_initialized) { - DeleteCriticalSection(&GC_write_cs); - } -# endif - } - -# ifdef THREADS -# if defined(PARALLEL_MARK) && !defined(GC_ALWAYS_MULTITHREADED) -# define IF_NEED_TO_LOCK(x) if (GC_parallel || GC_need_to_lock) x -# else -# define IF_NEED_TO_LOCK(x) if (GC_need_to_lock) x -# endif -# else -# define IF_NEED_TO_LOCK(x) -# endif /* !THREADS */ - - STATIC HANDLE GC_CreateLogFile(void) - { - HANDLE hFile; - TCHAR *logPath; - BOOL appendToFile = FALSE; -# if !defined(NO_GETENV_WIN32) || !defined(OLD_WIN32_LOG_FILE) - TCHAR pathBuf[_MAX_PATH + 0x10]; /* buffer for path + ext */ - - logPath = pathBuf; -# endif - - /* Use GetEnvironmentVariable instead of GETENV() for unicode support. */ -# ifndef NO_GETENV_WIN32 - if (GetEnvironmentVariable(TEXT("GC_LOG_FILE"), pathBuf, - _MAX_PATH + 1) - 1U < (DWORD)_MAX_PATH) { - appendToFile = TRUE; - } else -# endif - /* else */ { - /* Env var not found or its value too long. */ -# ifdef OLD_WIN32_LOG_FILE - logPath = TEXT(GC_LOG_STD_NAME); -# else - int len = (int)GetModuleFileName(NULL /* hModule */, pathBuf, - _MAX_PATH + 1); - /* If GetModuleFileName() has failed then len is 0. */ - if (len > 4 && pathBuf[len - 4] == (TCHAR)'.') { - len -= 4; /* strip executable file extension */ - } - BCOPY(TEXT(".") TEXT(GC_LOG_STD_NAME), &pathBuf[len], - sizeof(TEXT(".") TEXT(GC_LOG_STD_NAME))); -# endif - } - - hFile = CreateFile(logPath, GENERIC_WRITE, FILE_SHARE_READ, - NULL /* lpSecurityAttributes */, - appendToFile ? OPEN_ALWAYS : CREATE_ALWAYS, - GC_print_stats == VERBOSE ? FILE_ATTRIBUTE_NORMAL : - /* immediately flush writes unless very verbose */ - FILE_ATTRIBUTE_NORMAL | FILE_FLAG_WRITE_THROUGH, - NULL /* hTemplateFile */); -# ifndef NO_GETENV_WIN32 - if (appendToFile && hFile != INVALID_HANDLE_VALUE) { - LONG posHigh = 0; - (void)SetFilePointer(hFile, 0, &posHigh, FILE_END); - /* Seek to file end (ignoring any error) */ - } -# endif - return hFile; - } - - STATIC int GC_write(const char *buf, size_t len) - { - BOOL res; - DWORD written; -# if defined(THREADS) && defined(GC_ASSERTIONS) - static GC_bool inside_write = FALSE; - /* to prevent infinite recursion at abort. */ - if (inside_write) - return -1; -# endif - - if (len == 0) - return 0; - IF_NEED_TO_LOCK(EnterCriticalSection(&GC_write_cs)); -# if defined(THREADS) && defined(GC_ASSERTIONS) - if (GC_write_disabled) { - inside_write = TRUE; - ABORT("Assertion failure: GC_write called with write_disabled"); - } -# endif - if (GC_log == 0) { - GC_log = GC_CreateLogFile(); - } - if (GC_log == INVALID_HANDLE_VALUE) { - IF_NEED_TO_LOCK(LeaveCriticalSection(&GC_write_cs)); -# ifdef NO_DEBUGGING - /* Ignore open log failure (e.g., it might be caused by */ - /* read-only folder of the client application). */ - return 0; -# else - return -1; -# endif - } - res = WriteFile(GC_log, buf, (DWORD)len, &written, NULL); -# if defined(_MSC_VER) && defined(_DEBUG) -# ifdef MSWINCE - /* There is no CrtDbgReport() in WinCE */ - { - WCHAR wbuf[1024]; - /* Always use Unicode variant of OutputDebugString() */ - wbuf[MultiByteToWideChar(CP_ACP, 0 /* dwFlags */, - buf, len, wbuf, - sizeof(wbuf) / sizeof(wbuf[0]) - 1)] = 0; - OutputDebugStringW(wbuf); - } -# else - _CrtDbgReport(_CRT_WARN, NULL, 0, NULL, "%.*s", len, buf); -# endif -# endif - IF_NEED_TO_LOCK(LeaveCriticalSection(&GC_write_cs)); - return res ? (int)written : -1; - } - - /* FIXME: This is pretty ugly ... */ -# define WRITE(f, buf, len) GC_write(buf, len) - -#elif defined(OS2) || defined(MACOS) - STATIC FILE * GC_stdout = NULL; - STATIC FILE * GC_stderr = NULL; - STATIC FILE * GC_log = NULL; - - /* Initialize GC_log (and the friends) passed to GC_write(). */ - STATIC void GC_set_files(void) - { - if (GC_stdout == NULL) { - GC_stdout = stdout; - } - if (GC_stderr == NULL) { - GC_stderr = stderr; - } - if (GC_log == NULL) { - GC_log = stderr; - } - } - - GC_INLINE int GC_write(FILE *f, const char *buf, size_t len) - { - int res = fwrite(buf, 1, len, f); - fflush(f); - return res; - } - -# define WRITE(f, buf, len) (GC_set_files(), GC_write(f, buf, len)) - -#elif defined(GC_ANDROID_LOG) - -# include - -# ifndef GC_ANDROID_LOG_TAG -# define GC_ANDROID_LOG_TAG "BDWGC" -# endif - -# define GC_stdout ANDROID_LOG_DEBUG -# define GC_stderr ANDROID_LOG_ERROR -# define GC_log GC_stdout - -# define WRITE(level, buf, unused_len) \ - __android_log_write(level, GC_ANDROID_LOG_TAG, buf) - -#else -# if !defined(AMIGA) && !defined(__CC_ARM) -# include -# endif - - STATIC int GC_write(int fd, const char *buf, size_t len) - { -# if defined(ECOS) || defined(NOSYS) -# ifdef ECOS - /* FIXME: This seems to be defined nowhere at present. */ - /* _Jv_diag_write(buf, len); */ -# else - /* No writing. */ -# endif - return len; -# else - int bytes_written = 0; - int result; - IF_CANCEL(int cancel_state;) - - DISABLE_CANCEL(cancel_state); - while ((size_t)bytes_written < len) { -# ifdef GC_SOLARIS_THREADS - result = syscall(SYS_write, fd, buf + bytes_written, - len - bytes_written); -# else - result = write(fd, buf + bytes_written, len - bytes_written); -# endif - if (-1 == result) { - RESTORE_CANCEL(cancel_state); - return(result); - } - bytes_written += result; - } - RESTORE_CANCEL(cancel_state); - return(bytes_written); -# endif - } - -# define WRITE(f, buf, len) GC_write(f, buf, len) -#endif /* !MSWIN32 && !OS2 && !MACOS && !GC_ANDROID_LOG */ - -#define BUFSZ 1024 - -#if defined(DJGPP) || defined(__STRICT_ANSI__) - /* vsnprintf is missing in DJGPP (v2.0.3) */ -# define GC_VSNPRINTF(buf, bufsz, format, args) vsprintf(buf, format, args) -#elif defined(_MSC_VER) -# ifdef MSWINCE - /* _vsnprintf is deprecated in WinCE */ -# define GC_VSNPRINTF StringCchVPrintfA -# else -# define GC_VSNPRINTF _vsnprintf -# endif -#else -# define GC_VSNPRINTF vsnprintf -#endif - -/* A version of printf that is unlikely to call malloc, and is thus safer */ -/* to call from the collector in case malloc has been bound to GC_malloc. */ -/* Floating point arguments and formats should be avoided, since FP */ -/* conversion is more likely to allocate memory. */ -/* Assumes that no more than BUFSZ-1 characters are written at once. */ -#define GC_PRINTF_FILLBUF(buf, format) \ - do { \ - va_list args; \ - va_start(args, format); \ - (buf)[sizeof(buf) - 1] = 0x15; /* guard */ \ - (void)GC_VSNPRINTF(buf, sizeof(buf) - 1, format, args); \ - va_end(args); \ - if ((buf)[sizeof(buf) - 1] != 0x15) \ - ABORT("GC_printf clobbered stack"); \ - } while (0) - -void GC_printf(const char *format, ...) -{ - char buf[BUFSZ + 1]; - - if (!GC_quiet) { - GC_PRINTF_FILLBUF(buf, format); - if (WRITE(GC_stdout, buf, strlen(buf)) < 0) - ABORT("write to stdout failed"); - } -} - -void GC_err_printf(const char *format, ...) -{ - char buf[BUFSZ + 1]; - - GC_PRINTF_FILLBUF(buf, format); - GC_err_puts(buf); -} - -void GC_log_printf(const char *format, ...) -{ - char buf[BUFSZ + 1]; - - GC_PRINTF_FILLBUF(buf, format); - if (WRITE(GC_log, buf, strlen(buf)) < 0) - ABORT("write to GC log failed"); -} - -#ifndef GC_ANDROID_LOG - -# define GC_warn_printf GC_err_printf - -#else - - GC_INNER void GC_info_log_printf(const char *format, ...) - { - char buf[BUFSZ + 1]; - - GC_PRINTF_FILLBUF(buf, format); - (void)WRITE(ANDROID_LOG_INFO, buf, 0 /* unused */); - } - - GC_INNER void GC_verbose_log_printf(const char *format, ...) - { - char buf[BUFSZ + 1]; - - GC_PRINTF_FILLBUF(buf, format); - (void)WRITE(ANDROID_LOG_VERBOSE, buf, 0); /* ignore write errors */ - } - - STATIC void GC_warn_printf(const char *format, ...) - { - char buf[BUFSZ + 1]; - - GC_PRINTF_FILLBUF(buf, format); - (void)WRITE(ANDROID_LOG_WARN, buf, 0); - } - -#endif /* GC_ANDROID_LOG */ - -void GC_err_puts(const char *s) -{ - (void)WRITE(GC_stderr, s, strlen(s)); /* ignore errors */ -} - -STATIC void GC_CALLBACK GC_default_warn_proc(char *msg, GC_word arg) -{ - /* TODO: Add assertion on arg comply with msg (format). */ - GC_warn_printf(msg, arg); -} - -GC_INNER GC_warn_proc GC_current_warn_proc = GC_default_warn_proc; - -/* This is recommended for production code (release). */ -GC_API void GC_CALLBACK GC_ignore_warn_proc(char *msg, GC_word arg) -{ - if (GC_print_stats) { - /* Don't ignore warnings if stats printing is on. */ - GC_default_warn_proc(msg, arg); - } -} - -GC_API void GC_CALL GC_set_warn_proc(GC_warn_proc p) -{ - DCL_LOCK_STATE; - GC_ASSERT(p != 0); -# ifdef GC_WIN32_THREADS -# ifdef CYGWIN32 - /* Need explicit GC_INIT call */ - GC_ASSERT(GC_is_initialized); -# else - if (!GC_is_initialized) GC_init(); -# endif -# endif - LOCK(); - GC_current_warn_proc = p; - UNLOCK(); -} - -GC_API GC_warn_proc GC_CALL GC_get_warn_proc(void) -{ - GC_warn_proc result; - DCL_LOCK_STATE; - LOCK(); - result = GC_current_warn_proc; - UNLOCK(); - return(result); -} - -#if !defined(PCR) && !defined(SMALL_CONFIG) - /* Print (or display) a message before abnormal exit (including */ - /* abort). Invoked from ABORT(msg) macro (there msg is non-NULL) */ - /* and from EXIT() macro (msg is NULL in that case). */ - STATIC void GC_CALLBACK GC_default_on_abort(const char *msg) - { - GC_find_leak = FALSE; /* disable at-exit GC_gcollect() */ - - if (msg != NULL) { -# if defined(MSWIN32) -# ifndef DONT_USE_USER32_DLL - /* Use static binding to "user32.dll". */ - (void)MessageBoxA(NULL, msg, "Fatal error in GC", - MB_ICONERROR | MB_OK); -# else - /* This simplifies linking - resolve "MessageBoxA" at run-time. */ - HINSTANCE hU32 = LoadLibrary(TEXT("user32.dll")); - if (hU32) { - FARPROC pfn = GetProcAddress(hU32, "MessageBoxA"); - if (pfn) - (void)(*(int (WINAPI *)(HWND, LPCSTR, LPCSTR, UINT))pfn)( - NULL /* hWnd */, msg, "Fatal error in GC", - MB_ICONERROR | MB_OK); - (void)FreeLibrary(hU32); - } -# endif - /* Also duplicate msg to GC log file. */ -# endif - -# ifndef GC_ANDROID_LOG - /* Avoid calling GC_err_printf() here, as GC_on_abort() could be */ - /* called from it. Note 1: this is not an atomic output. */ - /* Note 2: possible write errors are ignored. */ -# if defined(THREADS) && defined(GC_ASSERTIONS) \ - && (defined(MSWIN32) || defined(MSWINCE)) - if (!GC_write_disabled) -# endif - { - if (WRITE(GC_stderr, (void *)msg, strlen(msg)) >= 0) - (void)WRITE(GC_stderr, (void *)("\n"), 1); - } -# else - __android_log_assert("*" /* cond */, GC_ANDROID_LOG_TAG, "%s\n", msg); -# endif - } - -# if !defined(NO_DEBUGGING) && !defined(GC_ANDROID_LOG) - if (GETENV("GC_LOOP_ON_ABORT") != NULL) { - /* In many cases it's easier to debug a running process. */ - /* It's arguably nicer to sleep, but that makes it harder */ - /* to look at the thread if the debugger doesn't know much */ - /* about threads. */ - for(;;) { - /* Empty */ - } - } -# endif - } - - GC_abort_func GC_on_abort = GC_default_on_abort; - - GC_API void GC_CALL GC_set_abort_func(GC_abort_func fn) - { - DCL_LOCK_STATE; - GC_ASSERT(fn != 0); - LOCK(); - GC_on_abort = fn; - UNLOCK(); - } - - GC_API GC_abort_func GC_CALL GC_get_abort_func(void) - { - GC_abort_func fn; - DCL_LOCK_STATE; - LOCK(); - fn = GC_on_abort; - UNLOCK(); - return fn; - } -#endif /* !SMALL_CONFIG */ - -GC_API void GC_CALL GC_enable(void) -{ - DCL_LOCK_STATE; - - LOCK(); - GC_ASSERT(GC_dont_gc != 0); /* ensure no counter underflow */ - GC_dont_gc--; - UNLOCK(); -} - -GC_API void GC_CALL GC_disable(void) -{ - DCL_LOCK_STATE; - LOCK(); - GC_dont_gc++; - UNLOCK(); -} - -GC_API int GC_CALL GC_is_disabled(void) -{ - return GC_dont_gc != 0; -} - -/* Helper procedures for new kind creation. */ -GC_API void ** GC_CALL GC_new_free_list_inner(void) -{ - void *result = GC_INTERNAL_MALLOC((MAXOBJGRANULES+1)*sizeof(ptr_t), - PTRFREE); - if (result == 0) ABORT("Failed to allocate freelist for new kind"); - BZERO(result, (MAXOBJGRANULES+1)*sizeof(ptr_t)); - return result; -} - -GC_API void ** GC_CALL GC_new_free_list(void) -{ - void *result; - DCL_LOCK_STATE; - LOCK(); - result = GC_new_free_list_inner(); - UNLOCK(); - return result; -} - -GC_API unsigned GC_CALL GC_new_kind_inner(void **fl, GC_word descr, - int adjust, int clear) -{ - unsigned result = GC_n_kinds; - - if (result < MAXOBJKINDS) { - GC_n_kinds++; - GC_obj_kinds[result].ok_freelist = fl; - GC_obj_kinds[result].ok_reclaim_list = 0; - GC_obj_kinds[result].ok_descriptor = descr; - GC_obj_kinds[result].ok_relocate_descr = adjust; - GC_obj_kinds[result].ok_init = (GC_bool)clear; -# ifdef ENABLE_DISCLAIM - GC_obj_kinds[result].ok_mark_unconditionally = FALSE; - GC_obj_kinds[result].ok_disclaim_proc = 0; -# endif - } else { - ABORT("Too many kinds"); - } - return result; -} - -GC_API unsigned GC_CALL GC_new_kind(void **fl, GC_word descr, int adjust, - int clear) -{ - unsigned result; - DCL_LOCK_STATE; - LOCK(); - result = GC_new_kind_inner(fl, descr, adjust, clear); - UNLOCK(); - return result; -} - -GC_API unsigned GC_CALL GC_new_proc_inner(GC_mark_proc proc) -{ - unsigned result = GC_n_mark_procs; - - if (result < MAX_MARK_PROCS) { - GC_n_mark_procs++; - GC_mark_procs[result] = proc; - } else { - ABORT("Too many mark procedures"); - } - return result; -} - -GC_API unsigned GC_CALL GC_new_proc(GC_mark_proc proc) -{ - unsigned result; - DCL_LOCK_STATE; - LOCK(); - result = GC_new_proc_inner(proc); - UNLOCK(); - return result; -} - -GC_API void * GC_CALL GC_call_with_alloc_lock(GC_fn_type fn, void *client_data) -{ - void * result; - DCL_LOCK_STATE; - -# ifdef THREADS - LOCK(); -# endif - result = (*fn)(client_data); -# ifdef THREADS - UNLOCK(); -# endif - return(result); -} - -GC_API void * GC_CALL GC_call_with_stack_base(GC_stack_base_func fn, void *arg) -{ - struct GC_stack_base base; - void *result; - - base.mem_base = (void *)&base; -# ifdef IA64 - base.reg_base = (void *)GC_save_regs_in_stack(); - /* Unnecessarily flushes register stack, */ - /* but that probably doesn't hurt. */ -# endif - result = fn(&base, arg); - /* Strongly discourage the compiler from treating the above */ - /* as a tail call. */ - GC_noop1((word)(&base)); - return result; -} - -#ifndef THREADS - -GC_INNER ptr_t GC_blocked_sp = NULL; - /* NULL value means we are not inside GC_do_blocking() call. */ -# ifdef IA64 - STATIC ptr_t GC_blocked_register_sp = NULL; -# endif - -GC_INNER struct GC_traced_stack_sect_s *GC_traced_stack_sect = NULL; - -/* This is nearly the same as in win32_threads.c */ -GC_API void * GC_CALL GC_call_with_gc_active(GC_fn_type fn, - void * client_data) -{ - struct GC_traced_stack_sect_s stacksect; - GC_ASSERT(GC_is_initialized); - - /* Adjust our stack base value (this could happen if */ - /* GC_get_main_stack_base() is unimplemented or broken for */ - /* the platform). */ - if ((word)GC_stackbottom HOTTER_THAN (word)(&stacksect)) - GC_stackbottom = (ptr_t)(&stacksect); - - if (GC_blocked_sp == NULL) { - /* We are not inside GC_do_blocking() - do nothing more. */ - client_data = fn(client_data); - /* Prevent treating the above as a tail call. */ - GC_noop1((word)(&stacksect)); - return client_data; /* result */ - } - - /* Setup new "stack section". */ - stacksect.saved_stack_ptr = GC_blocked_sp; -# ifdef IA64 - /* This is the same as in GC_call_with_stack_base(). */ - stacksect.backing_store_end = GC_save_regs_in_stack(); - /* Unnecessarily flushes register stack, */ - /* but that probably doesn't hurt. */ - stacksect.saved_backing_store_ptr = GC_blocked_register_sp; -# endif - stacksect.prev = GC_traced_stack_sect; - GC_blocked_sp = NULL; - GC_traced_stack_sect = &stacksect; - - client_data = fn(client_data); - GC_ASSERT(GC_blocked_sp == NULL); - GC_ASSERT(GC_traced_stack_sect == &stacksect); - - /* Restore original "stack section". */ - GC_traced_stack_sect = stacksect.prev; -# ifdef IA64 - GC_blocked_register_sp = stacksect.saved_backing_store_ptr; -# endif - GC_blocked_sp = stacksect.saved_stack_ptr; - - return client_data; /* result */ -} - -/* This is nearly the same as in win32_threads.c */ -STATIC void GC_do_blocking_inner(ptr_t data, void * context GC_ATTR_UNUSED) -{ - struct blocking_data * d = (struct blocking_data *) data; - GC_ASSERT(GC_is_initialized); - GC_ASSERT(GC_blocked_sp == NULL); -# ifdef SPARC - GC_blocked_sp = GC_save_regs_in_stack(); -# else - GC_blocked_sp = (ptr_t) &d; /* save approx. sp */ -# endif -# ifdef IA64 - GC_blocked_register_sp = GC_save_regs_in_stack(); -# endif - - d -> client_data = (d -> fn)(d -> client_data); - -# ifdef SPARC - GC_ASSERT(GC_blocked_sp != NULL); -# else - GC_ASSERT(GC_blocked_sp == (ptr_t) &d); -# endif - GC_blocked_sp = NULL; -} - -#endif /* !THREADS */ - -/* Wrapper for functions that are likely to block (or, at least, do not */ -/* allocate garbage collected memory and/or manipulate pointers to the */ -/* garbage collected heap) for an appreciable length of time. */ -/* In the single threaded case, GC_do_blocking() (together */ -/* with GC_call_with_gc_active()) might be used to make stack scanning */ -/* more precise (i.e. scan only stack frames of functions that allocate */ -/* garbage collected memory and/or manipulate pointers to the garbage */ -/* collected heap). */ -GC_API void * GC_CALL GC_do_blocking(GC_fn_type fn, void * client_data) -{ - struct blocking_data my_data; - - my_data.fn = fn; - my_data.client_data = client_data; - GC_with_callee_saves_pushed(GC_do_blocking_inner, (ptr_t)(&my_data)); - return my_data.client_data; /* result */ -} - -#if !defined(NO_DEBUGGING) - GC_API void GC_CALL GC_dump(void) - { - GC_printf("***Static roots:\n"); - GC_print_static_roots(); - GC_printf("\n***Heap sections:\n"); - GC_print_heap_sects(); - GC_printf("\n***Free blocks:\n"); - GC_print_hblkfreelist(); - GC_printf("\n***Blocks in use:\n"); - GC_print_block_list(); - } -#endif /* !NO_DEBUGGING */ - -/* Getter functions for the public Read-only variables. */ - -/* GC_get_gc_no() is unsynchronized and should be typically called */ -/* inside the context of GC_call_with_alloc_lock() to prevent data */ -/* races (on multiprocessors). */ -GC_API GC_word GC_CALL GC_get_gc_no(void) -{ - return GC_gc_no; -} - -#ifdef THREADS - GC_API int GC_CALL GC_get_parallel(void) - { - /* GC_parallel is initialized at start-up. */ - return GC_parallel; - } -#endif - -/* Setter and getter functions for the public R/W function variables. */ -/* These functions are synchronized (like GC_set_warn_proc() and */ -/* GC_get_warn_proc()). */ - -GC_API void GC_CALL GC_set_oom_fn(GC_oom_func fn) -{ - GC_ASSERT(fn != 0); - DCL_LOCK_STATE; - LOCK(); - GC_oom_fn = fn; - UNLOCK(); -} - -GC_API GC_oom_func GC_CALL GC_get_oom_fn(void) -{ - GC_oom_func fn; - DCL_LOCK_STATE; - LOCK(); - fn = GC_oom_fn; - UNLOCK(); - return fn; -} - -GC_API void GC_CALL GC_set_on_heap_resize(GC_on_heap_resize_proc fn) -{ - /* fn may be 0 (means no event notifier). */ - DCL_LOCK_STATE; - LOCK(); - GC_on_heap_resize = fn; - UNLOCK(); -} - -GC_API GC_on_heap_resize_proc GC_CALL GC_get_on_heap_resize(void) -{ - GC_on_heap_resize_proc fn; - DCL_LOCK_STATE; - LOCK(); - fn = GC_on_heap_resize; - UNLOCK(); - return fn; -} - -GC_API void GC_CALL GC_set_finalizer_notifier(GC_finalizer_notifier_proc fn) -{ - /* fn may be 0 (means no finalizer notifier). */ - DCL_LOCK_STATE; - LOCK(); - GC_finalizer_notifier = fn; - UNLOCK(); -} - -GC_API GC_finalizer_notifier_proc GC_CALL GC_get_finalizer_notifier(void) -{ - GC_finalizer_notifier_proc fn; - DCL_LOCK_STATE; - LOCK(); - fn = GC_finalizer_notifier; - UNLOCK(); - return fn; -} - -/* Setter and getter functions for the public numeric R/W variables. */ -/* It is safe to call these functions even before GC_INIT(). */ -/* These functions are unsynchronized and should be typically called */ -/* inside the context of GC_call_with_alloc_lock() (if called after */ -/* GC_INIT()) to prevent data races (unless it is guaranteed the */ -/* collector is not multi-threaded at that execution point). */ - -GC_API void GC_CALL GC_set_find_leak(int value) -{ - /* value is of boolean type. */ - GC_find_leak = value; -} - -GC_API int GC_CALL GC_get_find_leak(void) -{ - return GC_find_leak; -} - -GC_API void GC_CALL GC_set_all_interior_pointers(int value) -{ - DCL_LOCK_STATE; - - GC_all_interior_pointers = value ? 1 : 0; - if (GC_is_initialized) { - /* It is not recommended to change GC_all_interior_pointers value */ - /* after GC is initialized but it seems GC could work correctly */ - /* even after switching the mode. */ - LOCK(); - GC_initialize_offsets(); /* NOTE: this resets manual offsets as well */ - if (!GC_all_interior_pointers) - GC_bl_init_no_interiors(); - UNLOCK(); - } -} - -GC_API int GC_CALL GC_get_all_interior_pointers(void) -{ - return GC_all_interior_pointers; -} - -GC_API void GC_CALL GC_set_finalize_on_demand(int value) -{ - GC_ASSERT(value != -1); - /* value is of boolean type. */ - GC_finalize_on_demand = value; -} - -GC_API int GC_CALL GC_get_finalize_on_demand(void) -{ - return GC_finalize_on_demand; -} - -GC_API void GC_CALL GC_set_java_finalization(int value) -{ - GC_ASSERT(value != -1); - /* value is of boolean type. */ - GC_java_finalization = value; -} - -GC_API int GC_CALL GC_get_java_finalization(void) -{ - return GC_java_finalization; -} - -GC_API void GC_CALL GC_set_dont_expand(int value) -{ - GC_ASSERT(value != -1); - /* value is of boolean type. */ - GC_dont_expand = value; -} - -GC_API int GC_CALL GC_get_dont_expand(void) -{ - return GC_dont_expand; -} - -GC_API void GC_CALL GC_set_no_dls(int value) -{ - GC_ASSERT(value != -1); - /* value is of boolean type. */ - GC_no_dls = value; -} - -GC_API int GC_CALL GC_get_no_dls(void) -{ - return GC_no_dls; -} - -GC_API void GC_CALL GC_set_non_gc_bytes(GC_word value) -{ - GC_non_gc_bytes = value; -} - -GC_API GC_word GC_CALL GC_get_non_gc_bytes(void) -{ - return GC_non_gc_bytes; -} - -GC_API void GC_CALL GC_set_free_space_divisor(GC_word value) -{ - GC_ASSERT(value > 0); - GC_free_space_divisor = value; -} - -GC_API GC_word GC_CALL GC_get_free_space_divisor(void) -{ - return GC_free_space_divisor; -} - -GC_API void GC_CALL GC_set_max_retries(GC_word value) -{ - GC_ASSERT(value != ~(GC_word)0); - GC_max_retries = value; -} - -GC_API GC_word GC_CALL GC_get_max_retries(void) -{ - return GC_max_retries; -} - -GC_API void GC_CALL GC_set_dont_precollect(int value) -{ - GC_ASSERT(value != -1); - /* value is of boolean type. */ - GC_dont_precollect = value; -} - -GC_API int GC_CALL GC_get_dont_precollect(void) -{ - return GC_dont_precollect; -} - -GC_API void GC_CALL GC_set_full_freq(int value) -{ - GC_ASSERT(value >= 0); - GC_full_freq = value; -} - -GC_API int GC_CALL GC_get_full_freq(void) -{ - return GC_full_freq; -} - -GC_API void GC_CALL GC_set_time_limit(unsigned long value) -{ - GC_ASSERT(value != (unsigned long)-1L); - GC_time_limit = value; -} - -GC_API unsigned long GC_CALL GC_get_time_limit(void) -{ - return GC_time_limit; -} - -GC_API void GC_CALL GC_set_force_unmap_on_gcollect(int value) -{ - GC_force_unmap_on_gcollect = (GC_bool)value; -} - -GC_API int GC_CALL GC_get_force_unmap_on_gcollect(void) -{ - return (int)GC_force_unmap_on_gcollect; -} diff -Nru ecl-16.1.2/src/bdwgc/missing ecl-16.1.3+ds/src/bdwgc/missing --- ecl-16.1.2/src/bdwgc/missing 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/missing 1970-01-01 00:00:00.000000000 +0000 @@ -1,215 +0,0 @@ -#! /bin/sh -# Common wrapper for a few potentially missing GNU programs. - -scriptversion=2013-10-28.13; # UTC - -# Copyright (C) 1996-2014 Free Software Foundation, Inc. -# Originally written by Fran,cois Pinard , 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, see . - -# 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. - -if test $# -eq 0; then - echo 1>&2 "Try '$0 --help' for more information" - exit 1 -fi - -case $1 in - - --is-lightweight) - # Used by our autoconf macros to check whether the available missing - # script is modern enough. - exit 0 - ;; - - --run) - # Back-compat with the calling convention used by older automake. - shift - ;; - - -h|--h|--he|--hel|--help) - echo "\ -$0 [OPTION]... PROGRAM [ARGUMENT]... - -Run 'PROGRAM [ARGUMENT]...', returning a proper advice when this fails due -to PROGRAM being missing or too old. - -Options: - -h, --help display this help and exit - -v, --version output version information and exit - -Supported PROGRAM values: - aclocal autoconf autoheader autom4te automake makeinfo - bison yacc flex lex help2man - -Version suffixes to PROGRAM as well as the prefixes 'gnu-', 'gnu', and -'g' are ignored when checking the name. - -Send bug reports to ." - exit $? - ;; - - -v|--v|--ve|--ver|--vers|--versi|--versio|--version) - echo "missing $scriptversion (GNU Automake)" - exit $? - ;; - - -*) - echo 1>&2 "$0: unknown '$1' option" - echo 1>&2 "Try '$0 --help' for more information" - exit 1 - ;; - -esac - -# Run the given program, remember its exit status. -"$@"; st=$? - -# If it succeeded, we are done. -test $st -eq 0 && exit 0 - -# Also exit now if we it failed (or wasn't found), and '--version' was -# passed; such an option is passed most likely to detect whether the -# program is present and works. -case $2 in --version|--help) exit $st;; esac - -# Exit code 63 means version mismatch. This often happens when the user -# tries to use an ancient version of a tool on a file that requires a -# minimum version. -if test $st -eq 63; then - msg="probably too old" -elif test $st -eq 127; then - # Program was missing. - msg="missing on your system" -else - # Program was found and executed, but failed. Give up. - exit $st -fi - -perl_URL=http://www.perl.org/ -flex_URL=http://flex.sourceforge.net/ -gnu_software_URL=http://www.gnu.org/software - -program_details () -{ - case $1 in - aclocal|automake) - echo "The '$1' program is part of the GNU Automake package:" - echo "<$gnu_software_URL/automake>" - echo "It also requires GNU Autoconf, GNU m4 and Perl in order to run:" - echo "<$gnu_software_URL/autoconf>" - echo "<$gnu_software_URL/m4/>" - echo "<$perl_URL>" - ;; - autoconf|autom4te|autoheader) - echo "The '$1' program is part of the GNU Autoconf package:" - echo "<$gnu_software_URL/autoconf/>" - echo "It also requires GNU m4 and Perl in order to run:" - echo "<$gnu_software_URL/m4/>" - echo "<$perl_URL>" - ;; - esac -} - -give_advice () -{ - # Normalize program name to check for. - normalized_program=`echo "$1" | sed ' - s/^gnu-//; t - s/^gnu//; t - s/^g//; t'` - - printf '%s\n' "'$1' is $msg." - - configure_deps="'configure.ac' or m4 files included by 'configure.ac'" - case $normalized_program in - autoconf*) - echo "You should only need it if you modified 'configure.ac'," - echo "or m4 files included by it." - program_details 'autoconf' - ;; - autoheader*) - echo "You should only need it if you modified 'acconfig.h' or" - echo "$configure_deps." - program_details 'autoheader' - ;; - automake*) - echo "You should only need it if you modified 'Makefile.am' or" - echo "$configure_deps." - program_details 'automake' - ;; - aclocal*) - echo "You should only need it if you modified 'acinclude.m4' or" - echo "$configure_deps." - program_details 'aclocal' - ;; - autom4te*) - echo "You might have modified some maintainer files that require" - echo "the 'autom4te' program to be rebuilt." - program_details 'autom4te' - ;; - bison*|yacc*) - echo "You should only need it if you modified a '.y' file." - echo "You may want to install the GNU Bison package:" - echo "<$gnu_software_URL/bison/>" - ;; - lex*|flex*) - echo "You should only need it if you modified a '.l' file." - echo "You may want to install the Fast Lexical Analyzer package:" - echo "<$flex_URL>" - ;; - help2man*) - echo "You should only need it if you modified a dependency" \ - "of a man page." - echo "You may want to install the GNU Help2man package:" - echo "<$gnu_software_URL/help2man/>" - ;; - makeinfo*) - echo "You should only need it if you modified a '.texi' file, or" - echo "any other file indirectly affecting the aspect of the manual." - echo "You might want to install the Texinfo package:" - echo "<$gnu_software_URL/texinfo/>" - echo "The spurious makeinfo call might also be the consequence of" - echo "using a buggy 'make' (AIX, DU, IRIX), in which case you might" - echo "want to install GNU make:" - echo "<$gnu_software_URL/make/>" - ;; - *) - echo "You might have modified some files without having the proper" - echo "tools for further handling them. Check the 'README' file, it" - echo "often tells you about the needed prerequisites for installing" - echo "this package. You may also peek at any GNU archive site, in" - echo "case some other package contains this missing '$1' program." - ;; - esac -} - -give_advice "$1" | sed -e '1s/^/WARNING: /' \ - -e '2,$s/^/ /' >&2 - -# Propagate the correct exit status (expected to be 127 for a program -# not found, 63 for a program that failed due to version mismatch). -exit $st - -# Local variables: -# eval: (add-hook 'write-file-hooks 'time-stamp) -# time-stamp-start: "scriptversion=" -# time-stamp-format: "%:y-%02m-%02d.%02H" -# time-stamp-time-zone: "UTC" -# time-stamp-end: "; # UTC" -# End: diff -Nru ecl-16.1.2/src/bdwgc/new_hblk.c ecl-16.1.3+ds/src/bdwgc/new_hblk.c --- ecl-16.1.2/src/bdwgc/new_hblk.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/new_hblk.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,191 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 2000 by Hewlett-Packard Company. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#include "private/gc_priv.h" - -/* - * This file contains the functions: - * ptr_t GC_build_flXXX(h, old_fl) - * void GC_new_hblk(size) - */ - -#include - -#ifndef SMALL_CONFIG - /* Build a free list for size 2 (words) cleared objects inside */ - /* hblk h. Set the last link to be ofl. Return a pointer tpo the */ - /* first free list entry. */ - STATIC ptr_t GC_build_fl_clear2(struct hblk *h, ptr_t ofl) - { - word * p = (word *)(h -> hb_body); - word * lim = (word *)(h + 1); - - p[0] = (word)ofl; - p[1] = 0; - p[2] = (word)p; - p[3] = 0; - p += 4; - for (; (word)p < (word)lim; p += 4) { - p[0] = (word)(p-2); - p[1] = 0; - p[2] = (word)p; - p[3] = 0; - }; - return((ptr_t)(p-2)); - } - - /* The same for size 4 cleared objects. */ - STATIC ptr_t GC_build_fl_clear4(struct hblk *h, ptr_t ofl) - { - word * p = (word *)(h -> hb_body); - word * lim = (word *)(h + 1); - - p[0] = (word)ofl; - p[1] = 0; - p[2] = 0; - p[3] = 0; - p += 4; - for (; (word)p < (word)lim; p += 4) { - PREFETCH_FOR_WRITE((ptr_t)(p+64)); - p[0] = (word)(p-4); - p[1] = 0; - CLEAR_DOUBLE(p+2); - }; - return((ptr_t)(p-4)); - } - - /* The same for size 2 uncleared objects. */ - STATIC ptr_t GC_build_fl2(struct hblk *h, ptr_t ofl) - { - word * p = (word *)(h -> hb_body); - word * lim = (word *)(h + 1); - - p[0] = (word)ofl; - p[2] = (word)p; - p += 4; - for (; (word)p < (word)lim; p += 4) { - p[0] = (word)(p-2); - p[2] = (word)p; - }; - return((ptr_t)(p-2)); - } - - /* The same for size 4 uncleared objects. */ - STATIC ptr_t GC_build_fl4(struct hblk *h, ptr_t ofl) - { - word * p = (word *)(h -> hb_body); - word * lim = (word *)(h + 1); - - p[0] = (word)ofl; - p[4] = (word)p; - p += 8; - for (; (word)p < (word)lim; p += 8) { - PREFETCH_FOR_WRITE((ptr_t)(p+64)); - p[0] = (word)(p-4); - p[4] = (word)p; - }; - return((ptr_t)(p-4)); - } -#endif /* !SMALL_CONFIG */ - -/* Build a free list for objects of size sz inside heap block h. */ -/* Clear objects inside h if clear is set. Add list to the end of */ -/* the free list we build. Return the new free list. */ -/* This could be called without the main GC lock, if we ensure that */ -/* there is no concurrent collection which might reclaim objects that */ -/* we have not yet allocated. */ -GC_INNER ptr_t GC_build_fl(struct hblk *h, size_t sz, GC_bool clear, - ptr_t list) -{ - word *p, *prev; - word *last_object; /* points to last object in new hblk */ - - /* Do a few prefetches here, just because its cheap. */ - /* If we were more serious about it, these should go inside */ - /* the loops. But write prefetches usually don't seem to */ - /* matter much. */ - PREFETCH_FOR_WRITE((ptr_t)h); - PREFETCH_FOR_WRITE((ptr_t)h + 128); - PREFETCH_FOR_WRITE((ptr_t)h + 256); - PREFETCH_FOR_WRITE((ptr_t)h + 378); -# ifndef SMALL_CONFIG - /* Handle small objects sizes more efficiently. For larger objects */ - /* the difference is less significant. */ - switch (sz) { - case 2: if (clear) { - return GC_build_fl_clear2(h, list); - } else { - return GC_build_fl2(h, list); - } - case 4: if (clear) { - return GC_build_fl_clear4(h, list); - } else { - return GC_build_fl4(h, list); - } - default: - break; - } -# endif /* !SMALL_CONFIG */ - - /* Clear the page if necessary. */ - if (clear) BZERO(h, HBLKSIZE); - - /* Add objects to free list */ - p = (word *)(h -> hb_body) + sz; /* second object in *h */ - prev = (word *)(h -> hb_body); /* One object behind p */ - last_object = (word *)((char *)h + HBLKSIZE); - last_object -= sz; - /* Last place for last object to start */ - - /* make a list of all objects in *h with head as last object */ - while ((word)p <= (word)last_object) { - /* current object's link points to last object */ - obj_link(p) = (ptr_t)prev; - prev = p; - p += sz; - } - p -= sz; /* p now points to last object */ - - /* Put p (which is now head of list of objects in *h) as first */ - /* pointer in the appropriate free list for this size. */ - *(ptr_t *)h = list; - return ((ptr_t)p); -} - -/* Allocate a new heapblock for small objects of size gran granules. */ -/* Add all of the heapblock's objects to the free list for objects */ -/* of that size. Set all mark bits if objects are uncollectible. */ -/* Will fail to do anything if we are out of memory. */ -GC_INNER void GC_new_hblk(size_t gran, int kind) -{ - struct hblk *h; /* the new heap block */ - GC_bool clear = GC_obj_kinds[kind].ok_init; - - GC_STATIC_ASSERT((sizeof (struct hblk)) == HBLKSIZE); - - if (GC_debugging_started) clear = TRUE; - - /* Allocate a new heap block */ - h = GC_allochblk(GRANULES_TO_BYTES(gran), kind, 0); - if (h == 0) return; - - /* Mark all objects if appropriate. */ - if (IS_UNCOLLECTABLE(kind)) GC_set_hdr_marks(HDR(h)); - - /* Build the free list */ - GC_obj_kinds[kind].ok_freelist[gran] = - GC_build_fl(h, GRANULES_TO_WORDS(gran), clear, - GC_obj_kinds[kind].ok_freelist[gran]); -} diff -Nru ecl-16.1.2/src/bdwgc/NT_MAKEFILE ecl-16.1.3+ds/src/bdwgc/NT_MAKEFILE --- ecl-16.1.2/src/bdwgc/NT_MAKEFILE 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/NT_MAKEFILE 1970-01-01 00:00:00.000000000 +0000 @@ -1,61 +0,0 @@ -# Makefile for Windows NT. Assumes Microsoft compiler, and a single thread. -# Use "nmake nodebug=1 all" for optimized versions of library, gctest and editor. - -MY_CPU=X86 -CPU=$(MY_CPU) -!include - -# Make sure that .cc is not viewed as a suffix. It is for VC++2005, but -# not earlier versions. We can deal with either, but not inconsistency. -.SUFFIXES: -.SUFFIXES: .obj .cpp .c - -OBJS= alloc.obj reclaim.obj allchblk.obj misc.obj mach_dep.obj os_dep.obj mark_rts.obj headers.obj mark.obj obj_map.obj blacklst.obj finalize.obj new_hblk.obj dbg_mlc.obj fnlz_mlc.obj malloc.obj stubborn.obj dyn_load.obj typd_mlc.obj ptr_chck.obj gc_cpp.obj mallocx.obj extra\msvc_dbg.obj - -all: gctest.exe cord\de.exe test_cpp.exe - -.c.obj: - $(cc) $(cdebug) $(cflags) $(cvars) -Iinclude -DALL_INTERIOR_POINTERS -DGC_NOT_DLL -D_CRT_SECURE_NO_DEPRECATE $*.c /Fo$*.obj - -.cpp.obj: - $(cc) $(cdebug) $(cflags) $(cvars) -Iinclude -DALL_INTERIOR_POINTERS -DGC_NOT_DLL -D_CRT_SECURE_NO_DEPRECATE $*.cpp /Fo$*.obj - -$(OBJS) tests\test.obj: include\private\gc_priv.h include\private\gc_hdrs.h include\gc.h include\private\gcconfig.h include\private\gc_locks.h include\private\gc_pmark.h include\gc_mark.h include\gc_disclaim.h include\private\msvc_dbg.h - -gc.lib: $(OBJS) - lib /MACHINE:i386 /out:gc.lib $(OBJS) -# The original NT SDK used lib32 instead of lib - -gctest.exe: tests\test.obj gc.lib -# The following works for win32 debugging. For win32s debugging use debugtype:coff -# and add mapsympe line. -# This produces a "GUI" applications that opens no windows and writes to the log file -# "gctest.gc.log". This is done to make the result runnable under win32s. - $(link) -debug -debugtype:cv $(guiflags) -stack:131072 -out:$*.exe tests\test.obj $(guilibs) gc.lib -# mapsympe -n -o gctest.sym gctest.exe - -cord\de_win.rbj: cord\de_win.res - cvtres /MACHINE:$(MY_CPU) /OUT:cord\de_win.rbj cord\de_win.res - -cord\tests\de.obj cord\tests\de_win.obj: include\cord.h include\cord_pos.h cord\tests\de_win.h cord\tests\de_cmds.h - -cord\de_win.res: cord\tests\de_win.rc cord\tests\de_win.h cord\tests\de_cmds.h - $(rc) $(rcvars) -r -fo cord\de_win.res cord\tests\de_win.rc - -# Cord/de is a real win32 gui application. -cord\de.exe: cord\cordbscs.obj cord\cordxtra.obj cord\tests\de.obj cord\tests\de_win.obj cord\de_win.rbj gc.lib - $(link) -debug -debugtype:cv $(guiflags) -stack:16384 -out:cord\de.exe cord\cordbscs.obj cord\cordxtra.obj cord\tests\de.obj cord\tests\de_win.obj cord\de_win.rbj gc.lib $(guilibs) - -gc_cpp.obj: include\gc_cpp.h include\gc.h - -gc_cpp.cpp: gc_cpp.cc -# copy gc_cpp.cc gc_cpp.cpp - -test_cpp.cpp: tests\test_cpp.cc - copy tests\test_cpp.cc test_cpp.cpp - -# This generates the C++ test executable. The executable expects -# a single numeric argument, which is the number of iterations. -# The output appears in the file "test_cpp.gc.log". -test_cpp.exe: test_cpp.obj include\gc_cpp.h include\gc.h gc.lib - $(link) -debug -debugtype:cv $(guiflags) -stack:16384 -out:test_cpp.exe test_cpp.obj gc.lib $(guilibs) diff -Nru ecl-16.1.2/src/bdwgc/NT_STATIC_THREADS_MAKEFILE ecl-16.1.3+ds/src/bdwgc/NT_STATIC_THREADS_MAKEFILE --- ecl-16.1.2/src/bdwgc/NT_STATIC_THREADS_MAKEFILE 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/NT_STATIC_THREADS_MAKEFILE 1970-01-01 00:00:00.000000000 +0000 @@ -1,71 +0,0 @@ -# Makefile for Windows NT. Assumes Microsoft compiler. -# Use "nmake nodebug=1 all" for optimized versions of library, gctest and editor. - -MY_CPU=X86 -CPU=$(MY_CPU) -!include - -# Make sure that .cc is not viewed as a suffix. It is for VC++2005, but -# not earlier versions. We can deal with either, but not inconsistency. -.SUFFIXES: -.SUFFIXES: .obj .cpp .c - -# Atomic_ops installation directory. For win32, the source directory -# should do, since we only need the headers. -# We assume this was manually unpacked, since I'm not sure there is -# a Windows standard command line tool to do this. -AO_SRC_DIR=libatomic_ops/src -AO_INCLUDE_DIR=$(AO_SRC_DIR) - -OBJS= alloc.obj reclaim.obj allchblk.obj misc.obj mach_dep.obj os_dep.obj mark_rts.obj headers.obj mark.obj obj_map.obj blacklst.obj finalize.obj new_hblk.obj dbg_mlc.obj fnlz_mlc.obj malloc.obj stubborn.obj dyn_load.obj typd_mlc.obj ptr_chck.obj gc_cpp.obj mallocx.obj win32_threads.obj extra\msvc_dbg.obj thread_local_alloc.obj - -all: gctest.exe cord\de.exe test_cpp.exe - -.c.obj: - $(cc) $(cdebug) $(cflags) $(cvarsmt) -Iinclude -I$(AO_INCLUDE_DIR) -DALL_INTERIOR_POINTERS -DGC_NOT_DLL -DGC_THREADS -DTHREAD_LOCAL_ALLOC -DPARALLEL_MARK -D_CRT_SECURE_NO_DEPRECATE $*.c /Fo$*.obj - -.cpp.obj: - $(cc) $(cdebug) $(cflags) $(cvarsmt) -Iinclude -I$(AO_INCLUDE_DIR) -DALL_INTERIOR_POINTERS -DGC_NOT_DLL -DGC_THREADS -DTHREAD_LOCAL_ALLOC -D_CRT_SECURE_NO_DEPRECATE $*.cpp /Fo$*.obj - -$(OBJS) tests\test.obj: include\private\gc_priv.h include\private\gc_hdrs.h include\gc.h include\private\gcconfig.h include\private\gc_locks.h include\private\gc_pmark.h include\gc_mark.h include\gc_disclaim.h include\private\msvc_dbg.h - -gc.lib: $(OBJS) - lib /MACHINE:i386 /out:gc.lib $(OBJS) -# The original NT SDK used lib32 instead of lib - -gctest.exe: tests\test.obj gc.lib -# The following works for win32 debugging. For win32s debugging use debugtype:coff -# and add mapsympe line. -# This produces a "GUI" applications that opens no windows and writes to the log file -# "gctest.gc.log". This is done to make the result runnable under win32s. - $(link) -debug -debugtype:cv $(guiflags) -stack:262144 -out:$*.exe tests\test.obj $(guilibs) gc.lib -# mapsympe -n -o gctest.sym gctest.exe - -cord\de_win.rbj: cord\de_win.res - cvtres /MACHINE:$(MY_CPU) /OUT:cord\de_win.rbj cord\de_win.res - -cord\tests\de.obj cord\tests\de_win.obj: include\cord.h include\cord_pos.h cord\tests\de_win.h cord\tests\de_cmds.h - -cord\de_win.res: cord\tests\de_win.rc cord\tests\de_win.h cord\tests\de_cmds.h - $(rc) $(rcvars) -r -fo cord\de_win.res cord\tests\de_win.rc - -# Cord/de is a real win32 gui application. -cord\de.exe: cord\cordbscs.obj cord\cordxtra.obj cord\tests\de.obj cord\tests\de_win.obj cord\de_win.rbj gc.lib - $(link) -debug -debugtype:cv $(guiflags) -stack:16384 -out:cord\de.exe cord\cordbscs.obj cord\cordxtra.obj cord\tests\de.obj cord\tests\de_win.obj cord\de_win.rbj gc.lib $(guilibs) - -gc_cpp.obj: include\gc_cpp.h include\gc.h - -gc_cpp.cpp: gc_cpp.cc -# copy gc_cpp.cc gc_cpp.cpp - -test_cpp.cpp: tests\test_cpp.cc - copy tests\test_cpp.cc test_cpp.cpp - -# This generates the C++ test executable. The executable expects -# a single numeric argument, which is the number of iterations. -# The output appears in the file "test_cpp.gc.log". -test_cpp.exe: test_cpp.obj include\gc_cpp.h include\gc.h gc.lib - $(link) -debug -debugtype:cv $(guiflags) -stack:16384 -out:test_cpp.exe test_cpp.obj gc.lib $(guilibs) - -AO_SCR_DIR: - tar xvfz $(AO_SRC_DIR).tar.gz; diff -Nru ecl-16.1.2/src/bdwgc/NT_X64_STATIC_THREADS_MAKEFILE ecl-16.1.3+ds/src/bdwgc/NT_X64_STATIC_THREADS_MAKEFILE --- ecl-16.1.2/src/bdwgc/NT_X64_STATIC_THREADS_MAKEFILE 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/NT_X64_STATIC_THREADS_MAKEFILE 1970-01-01 00:00:00.000000000 +0000 @@ -1,70 +0,0 @@ -# Makefile for Windows NT. Assumes Microsoft compiler. -# Use "nmake nodebug=1 all" for optimized versions of library, gctest and editor. - -MY_CPU=AMD64 -CPU=$(MY_CPU) -!include - -# Make sure that .cc is not viewed as a suffix. It is for VC++2005, but -# not earlier versions. We can deal with either, but not inconsistency. -.SUFFIXES: -.SUFFIXES: .obj .cpp .c - -# Atomic_ops installation directory. For win32, the source directory -# should do, since we only need the headers. -# We assume this was manually unpacked, since I'm not sure there is -# a Windows standard command line tool to do this. -AO_SRC_DIR=libatomic_ops/src -AO_INCLUDE_DIR=$(AO_SRC_DIR) - -OBJS= alloc.obj reclaim.obj allchblk.obj misc.obj mach_dep.obj os_dep.obj mark_rts.obj headers.obj mark.obj obj_map.obj blacklst.obj finalize.obj new_hblk.obj dbg_mlc.obj fnlz_mlc.obj malloc.obj stubborn.obj dyn_load.obj typd_mlc.obj ptr_chck.obj gc_cpp.obj mallocx.obj win32_threads.obj extra\msvc_dbg.obj thread_local_alloc.obj - -all: gctest.exe cord\de.exe test_cpp.exe - -.c.obj: - $(cc) $(cdebug) $(cflags) $(cvarsmt) -Iinclude -I$(AO_INCLUDE_DIR) -DALL_INTERIOR_POINTERS -DGC_NOT_DLL -DGC_THREADS -DTHREAD_LOCAL_ALLOC -D_CRT_SECURE_NO_DEPRECATE $*.c /Fo$*.obj /wd4701 -# Disable "may not be initialized" warnings. They're too approximate. -# Disable crt security warnings, since unfortunately they warn about all sorts -# of safe uses of strncpy. It would be nice to leave the rest enabled. - -.cpp.obj: - $(cc) $(cdebug) $(cflags) $(cvarsmt) -Iinclude -I$(AO_INCLUDE_DIR) -DALL_INTERIOR_POINTERS -DGC_NOT_DLL -DGC_THREADS -DTHREAD_LOCAL_ALLOC -D_CRT_SECURE_NO_DEPRECATE $*.cpp /Fo$*.obj - -$(OBJS) tests\test.obj: include\private\gc_priv.h include\private\gc_hdrs.h include\gc.h include\private\gcconfig.h include\private\gc_locks.h include\private\gc_pmark.h include\gc_mark.h include\gc_disclaim.h include\private\msvc_dbg.h - -gc.lib: $(OBJS) - lib /MACHINE:X64 /out:gc.lib $(OBJS) - -gctest.exe: tests\test.obj gc.lib -# This produces a "GUI" applications that opens no windows and writes to -# the log file "gctest.gc.log". - $(link) $(ldebug) $(guiflags) -out:$*.exe tests\test.obj $(guilibs) gc.lib - -cord\de_win.rbj: cord\de_win.res - cvtres /MACHINE:$(MY_CPU) /OUT:cord\de_win.rbj cord\de_win.res - -cord\tests\de.obj cord\tests\de_win.obj: include\cord.h include\cord_pos.h cord\tests\de_win.h cord\tests\de_cmds.h - -cord\de_win.res: cord\tests\de_win.rc cord\tests\de_win.h cord\tests\de_cmds.h - $(rc) $(rcvars) -r -fo cord\de_win.res cord\tests\de_win.rc - -# Cord/de is a real win32 gui application. -cord\de.exe: cord\cordbscs.obj cord\cordxtra.obj cord\tests\de.obj cord\tests\de_win.obj cord\de_win.rbj gc.lib - $(link) $(ldebug) $(guiflags) -stack:16384 -out:cord\de.exe cord\cordbscs.obj cord\cordxtra.obj cord\tests\de.obj cord\tests\de_win.obj cord\de_win.rbj gc.lib $(guilibs) - -gc_cpp.obj: include\gc_cpp.h include\gc.h - -gc_cpp.cpp: gc_cpp.cc -# copy gc_cpp.cc gc_cpp.cpp - -test_cpp.cpp: tests\test_cpp.cc - copy tests\test_cpp.cc test_cpp.cpp - -# This generates the C++ test executable. The executable expects -# a single numeric argument, which is the number of iterations. -# The output appears in the file "test_cpp.gc.log". -test_cpp.exe: test_cpp.obj include\gc_cpp.h include\gc.h gc.lib - $(link) $(ldebug) $(guiflags) -stack:16384 -out:test_cpp.exe test_cpp.obj gc.lib $(guilibs) - -AO_SCR_DIR: - tar xvfz $(AO_SRC_DIR).tar.gz; diff -Nru ecl-16.1.2/src/bdwgc/NT_X64_THREADS_MAKEFILE ecl-16.1.3+ds/src/bdwgc/NT_X64_THREADS_MAKEFILE --- ecl-16.1.2/src/bdwgc/NT_X64_THREADS_MAKEFILE 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/NT_X64_THREADS_MAKEFILE 1970-01-01 00:00:00.000000000 +0000 @@ -1,87 +0,0 @@ -# Makefile for Windows NT. Assumes Microsoft compiler. -# modified 2007 August by Friedrich Dominicus: -# - copied from NT_X64_STATIC_THREADS_MAKEFILES -# - checked agaist gc.mak (NT_THREADS_MAKEFILE) -# - added changes to integrate the tools -# - currently just with debug information -# problems can be sent to -# frido at q-software-solutions.de -# -# or the mailing list - - -MY_CPU=AMD64 -CPU=$(MY_CPU) -!include - -# Make sure that .cc is not viewed as a suffix. It is for VC++2005, but # not earlier versions. We can deal with either, but not inconsistency. -.SUFFIXES: -.SUFFIXES: .obj .cpp .c - -# Atomic_ops installation directory. For win32, the source directory -# should do, since we only need the headers. -# We assume this was manually unpacked, since I'm not sure there is -# a Windows standard command line tool to do this. -AO_SRC_DIR=libatomic_ops/src -AO_INCLUDE_DIR=$(AO_SRC_DIR) - -OBJS= alloc.obj reclaim.obj allchblk.obj misc.obj mach_dep.obj os_dep.obj mark_rts.obj headers.obj mark.obj obj_map.obj blacklst.obj finalize.obj new_hblk.obj dbg_mlc.obj fnlz_mlc.obj malloc.obj stubborn.obj dyn_load.obj typd_mlc.obj ptr_chck.obj gc_cpp.obj mallocx.obj win32_threads.obj extra\msvc_dbg.obj thread_local_alloc.obj - -all: gc64.dll gctest.exe cord\de.exe test_cpp.exe - -.c.obj: - $(cc) $(cdebug) $(cflags) $(cvarsmt) -Iinclude -I$(AO_INCLUDE_DIR) -DALL_INTERIOR_POINTERS -DGC_DLL -DGC_THREADS -D_CRT_SECURE_NO_DEPRECATE $*.c /Fo$*.obj /wd4701 -# Disable "may not be initialized" warnings. They're too approximate. -# Disable crt security warnings, since unfortunately they warn about all sorts # of safe uses of strncpy. It would be nice to leave the rest enabled. - -.cpp.obj: - $(cc) $(cdebug) $(cflags) $(cvarsmt) -Iinclude -I$(AO_INCLUDE_DIR) -DALL_INTERIOR_POINTERS -DGC_DLL -DGC_THREADS -D_CRT_SECURE_NO_DEPRECATE $*.cpp /Fo$*.obj - -$(OBJS) tests\test.obj: include\private\gc_priv.h include\private\gc_hdrs.h include\gc.h include\private\gcconfig.h include\private\gc_locks.h include\private\gc_pmark.h include\gc_mark.h include\gc_disclaim.h include\private\msvc_dbg.h - - -LINK64=link.exe -LINK64_FLAGS=kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib \ -shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo \ -/subsystem:windows /dll /incremental:no /pdb:"gc.pdb" /machine:X64 /out:"gc64.dll" \ -/implib:"gc64_dll.lib" - -gc64.dll : $(OBJS) - $(LINK64) $(ldebug) $(LINK64_FLAGS) $(OBJS) - - -gctest.exe: tests\test.obj gc64_dll.lib -# This produces a "GUI" applications that opens no windows and writes to -# the log file "gctest.gc.log". - $(link) $(ldebug) $(guiflags) -out:$*.exe tests\test.obj $(guilibs) gc64_dll.lib - -cord\de_win.rbj: cord\de_win.res - cvtres /MACHINE:$(MY_CPU) /OUT:cord\de_win.rbj cord\de_win.res - -cord\tests\de.obj cord\tests\de_win.obj: include\cord.h include\cord_pos.h cord\tests\de_win.h cord\tests\de_cmds.h - -cord\de_win.res: cord\tests\de_win.rc cord\tests\de_win.h cord\tests\de_cmds.h - $(rc) $(rcvars) -r -fo cord\de_win.res cord\tests\de_win.rc - -# Cord/de is a real win32 gui application. -cord\de.exe: cord\cordbscs.obj cord\cordxtra.obj cord\tests\de.obj cord\tests\de_win.obj cord\de_win.rbj gc64_dll.lib - $(link) $(ldebug) $(guiflags) -stack:16384 -out:cord\de.exe cord\cordbscs.obj cord\cordxtra.obj cord\tests\de.obj cord\tests\de_win.obj cord\de_win.rbj gc64_dll.lib $(guilibs) - -gc_cpp.obj: include\gc_cpp.h include\gc.h - -gc_cpp.cpp: gc_cpp.cc -# copy gc_cpp.cc gc_cpp.cpp - -test_cpp.cpp: tests\test_cpp.cc - copy tests\test_cpp.cc test_cpp.cpp - -# This generates the C++ test executable. The executable expects # a single numeric argument, which is the number of iterations. -# The output appears in the file "test_cpp.gc.log". -test_cpp.exe: test_cpp.obj include\gc_cpp.h include\gc.h gc64_dll.lib - $(link) $(ldebug) $(guiflags) -stack:16384 -out:test_cpp.exe test_cpp.obj gc64_dll.lib $(guilibs) - -AO_SCR_DIR: - tar xvfz $(AO_SRC_DIR).tar.gz; - -clean: - del *.obj gc64_dll.lib gc64.dll diff -Nru ecl-16.1.2/src/bdwgc/obj_map.c ecl-16.1.3+ds/src/bdwgc/obj_map.c --- ecl-16.1.2/src/bdwgc/obj_map.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/obj_map.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,90 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991, 1992 by Xerox Corporation. All rights reserved. - * Copyright (c) 1999-2001 by Hewlett-Packard Company. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#include "private/gc_priv.h" - -/* Routines for maintaining maps describing heap block - * layouts for various object sizes. Allows fast pointer validity checks - * and fast location of object start locations on machines (such as SPARC) - * with slow division. - */ - -/* Consider pointers that are offset bytes displaced from the beginning */ -/* of an object to be valid. */ - -GC_API void GC_CALL GC_register_displacement(size_t offset) -{ - DCL_LOCK_STATE; - - LOCK(); - GC_register_displacement_inner(offset); - UNLOCK(); -} - -GC_INNER void GC_register_displacement_inner(size_t offset) -{ - if (offset >= VALID_OFFSET_SZ) { - ABORT("Bad argument to GC_register_displacement"); - } - if (!GC_valid_offsets[offset]) { - GC_valid_offsets[offset] = TRUE; - GC_modws_valid_offsets[offset % sizeof(word)] = TRUE; - } -} - -#ifdef MARK_BIT_PER_GRANULE - /* Add a heap block map for objects of size granules to obj_map. */ - /* Return FALSE on failure. */ - /* A size of 0 granules is used for large objects. */ - GC_INNER GC_bool GC_add_map_entry(size_t granules) - { - unsigned displ; - short * new_map; - - if (granules > BYTES_TO_GRANULES(MAXOBJBYTES)) granules = 0; - if (GC_obj_map[granules] != 0) { - return(TRUE); - } - new_map = (short *)GC_scratch_alloc(MAP_LEN * sizeof(short)); - if (new_map == 0) return(FALSE); - GC_COND_LOG_PRINTF( - "Adding block map for size of %u granules (%u bytes)\n", - (unsigned)granules, (unsigned)GRANULES_TO_BYTES(granules)); - if (granules == 0) { - for (displ = 0; displ < BYTES_TO_GRANULES(HBLKSIZE); displ++) { - new_map[displ] = 1; /* Nonzero to get us out of marker fast path. */ - } - } else { - for (displ = 0; displ < BYTES_TO_GRANULES(HBLKSIZE); displ++) { - new_map[displ] = (short)(displ % granules); - } - } - GC_obj_map[granules] = new_map; - return(TRUE); - } -#endif /* MARK_BIT_PER_GRANULE */ - -GC_INNER void GC_initialize_offsets(void) -{ - unsigned i; - if (GC_all_interior_pointers) { - for (i = 0; i < VALID_OFFSET_SZ; ++i) - GC_valid_offsets[i] = TRUE; - } else { - BZERO(GC_valid_offsets, sizeof(GC_valid_offsets)); - for (i = 0; i < sizeof(word); ++i) - GC_modws_valid_offsets[i] = FALSE; - } -} diff -Nru ecl-16.1.2/src/bdwgc/OS2_MAKEFILE ecl-16.1.3+ds/src/bdwgc/OS2_MAKEFILE --- ecl-16.1.2/src/bdwgc/OS2_MAKEFILE 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/OS2_MAKEFILE 1970-01-01 00:00:00.000000000 +0000 @@ -1,45 +0,0 @@ -# Makefile for OS/2. Assumes IBM's compiler, static linking, and a single thread. -# Adding dynamic linking support seems easy, but takes a little bit of work. -# Adding thread support may be nontrivial, since we haven't yet figured out how to -# look at another thread's registers. - -# Significantly revised for GC version 4.4 by Mark Boulter (Jan 1994). - -OBJS= alloc.obj reclaim.obj allchblk.obj misc.obj mach_dep.obj os_dep.obj mark_rts.obj headers.obj mark.obj obj_map.obj blacklst.obj finalize.obj new_hblk.obj dbg_mlc.obj fnlz_mlc.obj malloc.obj stubborn.obj typd_mlc.obj ptr_chck.obj mallocx.obj - -CORDOBJS= cord\cordbscs.obj cord\cordxtra.obj cord\cordprnt.obj - -CC= icc -CFLAGS= /O /Q /DSMALL_CONFIG /DALL_INTERIOR_POINTERS -# Use /Ti instead of /O for debugging -# Setjmp_test may yield overly optimistic results when compiled -# without optimization. - -all: $(OBJS) gctest.exe cord\cordtest.exe - -$(OBJS) test.obj: include\private\gc_priv.h include\private\gc_hdrs.h include\gc.h include\private\gcconfig.h - -## ERASE THE LIB FIRST - if it is already there then this command will fail -## (make sure its there or erase will fail!) -gc.lib: $(OBJS) - echo . > gc.lib - erase gc.lib - LIB gc.lib $(OBJS), gc.lst - -mach_dep.obj: mach_dep.c - $(CC) $(CFLAGS) /C mach_dep.c - -gctest.exe: test.obj gc.lib - $(CC) $(CFLAGS) /B"/STACK:524288" /Fegctest test.obj gc.lib - -cord\cordbscs.obj: cord\cordbscs.c include\cord.h include\cord_pos.h - $(CC) $(CFLAGS) /C /Focord\cordbscs cord\cordbscs.c - -cord\cordxtra.obj: cord\cordxtra.c include\cord.h include\cord_pos.h include\ec.h - $(CC) $(CFLAGS) /C /Focord\cordxtra cord\cordxtra.c - -cord\cordprnt.obj: cord\cordprnt.c include\cord.h include\cord_pos.h include\ec.h - $(CC) $(CFLAGS) /C /Focord\cordprnt cord\cordprnt.c - -cord\cordtest.exe: cord\tests\cordtest.c include\cord.h include\cord_pos.h include\ec.h $(CORDOBJS) gc.lib - $(CC) $(CFLAGS) /B"/STACK:65536" /Fecord\cordtest cord\tests\cordtest.c gc.lib $(CORDOBJS) diff -Nru ecl-16.1.2/src/bdwgc/os_dep.c ecl-16.1.3+ds/src/bdwgc/os_dep.c --- ecl-16.1.2/src/bdwgc/os_dep.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/os_dep.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,4634 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1995 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 1999 by Hewlett-Packard Company. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#include "private/gc_priv.h" - -#if !defined(OS2) && !defined(PCR) && !defined(AMIGA) && !defined(MACOS) \ - && !defined(MSWINCE) && !defined(__CC_ARM) -# include -# if !defined(MSWIN32) -# include -# endif -#endif - -#include -#if defined(MSWINCE) || defined(SN_TARGET_PS3) -# define SIGSEGV 0 /* value is irrelevant */ -#else -# include -#endif - -#if defined(UNIX_LIKE) || defined(CYGWIN32) || defined(NACL) \ - || defined(SYMBIAN) -# include -#endif - -#if defined(LINUX) || defined(LINUX_STACKBOTTOM) -# include -#endif - -/* Blatantly OS dependent routines, except for those that are related */ -/* to dynamic loading. */ - -#ifdef AMIGA -# define GC_AMIGA_DEF -# include "extra/AmigaOS.c" -# undef GC_AMIGA_DEF -#endif - -#if defined(MSWIN32) || defined(MSWINCE) || defined(CYGWIN32) -# ifndef WIN32_LEAN_AND_MEAN -# define WIN32_LEAN_AND_MEAN 1 -# endif -# define NOSERVICE -# include - /* It's not clear this is completely kosher under Cygwin. But it */ - /* allows us to get a working GC_get_stack_base. */ -#endif - -#ifdef MACOS -# include -#endif - -#ifdef IRIX5 -# include -# include /* for locking */ -#endif - -#if defined(MMAP_SUPPORTED) || defined(ADD_HEAP_GUARD_PAGES) -# if defined(USE_MUNMAP) && !defined(USE_MMAP) -# error "invalid config - USE_MUNMAP requires USE_MMAP" -# endif -# include -# include -# include -# include -#endif - -#ifdef DARWIN - /* for get_etext and friends */ -# include -#endif - -#ifdef DJGPP - /* Apparently necessary for djgpp 2.01. May cause problems with */ - /* other versions. */ - typedef long unsigned int caddr_t; -#endif - -#ifdef PCR -# include "il/PCR_IL.h" -# include "th/PCR_ThCtl.h" -# include "mm/PCR_MM.h" -#endif - -#if !defined(NO_EXECUTE_PERMISSION) - STATIC GC_bool GC_pages_executable = TRUE; -#else - STATIC GC_bool GC_pages_executable = FALSE; -#endif -#define IGNORE_PAGES_EXECUTABLE 1 - /* Undefined on GC_pages_executable real use. */ - -#ifdef NEED_PROC_MAPS -/* We need to parse /proc/self/maps, either to find dynamic libraries, */ -/* and/or to find the register backing store base (IA64). Do it once */ -/* here. */ - -#define READ read - -/* Repeatedly perform a read call until the buffer is filled or */ -/* we encounter EOF. */ -STATIC ssize_t GC_repeat_read(int fd, char *buf, size_t count) -{ - size_t num_read = 0; - ssize_t result; - - ASSERT_CANCEL_DISABLED(); - while (num_read < count) { - result = READ(fd, buf + num_read, count - num_read); - if (result < 0) return result; - if (result == 0) break; - num_read += result; - } - return num_read; -} - -#ifdef THREADS - /* Determine the length of a file by incrementally reading it into a */ - /* This would be silly to use on a file supporting lseek, but Linux */ - /* /proc files usually do not. */ - STATIC size_t GC_get_file_len(int f) - { - size_t total = 0; - ssize_t result; -# define GET_FILE_LEN_BUF_SZ 500 - char buf[GET_FILE_LEN_BUF_SZ]; - - do { - result = read(f, buf, GET_FILE_LEN_BUF_SZ); - if (result == -1) return 0; - total += result; - } while (result > 0); - return total; - } - - STATIC size_t GC_get_maps_len(void) - { - int f = open("/proc/self/maps", O_RDONLY); - size_t result; - if (f < 0) return 0; /* treat missing file as empty */ - result = GC_get_file_len(f); - close(f); - return result; - } -#endif /* THREADS */ - -/* Copy the contents of /proc/self/maps to a buffer in our address */ -/* space. Return the address of the buffer, or zero on failure. */ -/* This code could be simplified if we could determine its size ahead */ -/* of time. */ -GC_INNER char * GC_get_maps(void) -{ - int f; - ssize_t result; - static char *maps_buf = NULL; - static size_t maps_buf_sz = 1; - size_t maps_size, old_maps_size = 0; - - /* The buffer is essentially static, so there must be a single client. */ - GC_ASSERT(I_HOLD_LOCK()); - - /* Note that in the presence of threads, the maps file can */ - /* essentially shrink asynchronously and unexpectedly as */ - /* threads that we already think of as dead release their */ - /* stacks. And there is no easy way to read the entire */ - /* file atomically. This is arguably a misfeature of the */ - /* /proc/.../maps interface. */ - - /* Since we don't believe the file can grow */ - /* asynchronously, it should suffice to first determine */ - /* the size (using lseek or read), and then to reread the */ - /* file. If the size is inconsistent we have to retry. */ - /* This only matters with threads enabled, and if we use */ - /* this to locate roots (not the default). */ - -# ifdef THREADS - /* Determine the initial size of /proc/self/maps. */ - /* Note that lseek doesn't work, at least as of 2.6.15. */ - maps_size = GC_get_maps_len(); - if (0 == maps_size) return 0; -# else - maps_size = 4000; /* Guess */ -# endif - - /* Read /proc/self/maps, growing maps_buf as necessary. */ - /* Note that we may not allocate conventionally, and */ - /* thus can't use stdio. */ - do { - while (maps_size >= maps_buf_sz) { - /* Grow only by powers of 2, since we leak "too small" buffers.*/ - while (maps_size >= maps_buf_sz) maps_buf_sz *= 2; - maps_buf = GC_scratch_alloc(maps_buf_sz); -# ifdef THREADS - /* Recompute initial length, since we allocated. */ - /* This can only happen a few times per program */ - /* execution. */ - maps_size = GC_get_maps_len(); - if (0 == maps_size) return 0; -# endif - if (maps_buf == 0) return 0; - } - GC_ASSERT(maps_buf_sz >= maps_size + 1); - f = open("/proc/self/maps", O_RDONLY); - if (-1 == f) return 0; -# ifdef THREADS - old_maps_size = maps_size; -# endif - maps_size = 0; - do { - result = GC_repeat_read(f, maps_buf, maps_buf_sz-1); - if (result <= 0) - break; - maps_size += result; - } while ((size_t)result == maps_buf_sz-1); - close(f); - if (result <= 0) - return 0; -# ifdef THREADS - if (maps_size > old_maps_size) { - ABORT_ARG2("Unexpected asynchronous /proc/self/maps growth " - "(unregistered thread?)", " from %lu to %lu", - (unsigned long)old_maps_size, - (unsigned long)maps_size); - } -# endif - } while (maps_size >= maps_buf_sz || maps_size < old_maps_size); - /* In the single-threaded case, the second clause is false. */ - maps_buf[maps_size] = '\0'; - - /* Apply fn to result. */ - return maps_buf; -} - -/* - * GC_parse_map_entry parses an entry from /proc/self/maps so we can - * locate all writable data segments that belong to shared libraries. - * The format of one of these entries and the fields we care about - * is as follows: - * XXXXXXXX-XXXXXXXX r-xp 00000000 30:05 260537 name of mapping...\n - * ^^^^^^^^ ^^^^^^^^ ^^^^ ^^ - * start end prot maj_dev - * - * Note that since about august 2003 kernels, the columns no longer have - * fixed offsets on 64-bit kernels. Hence we no longer rely on fixed offsets - * anywhere, which is safer anyway. - */ - -/* Assign various fields of the first line in buf_ptr to (*start), */ -/* (*end), (*prot), (*maj_dev) and (*mapping_name). mapping_name may */ -/* be NULL. (*prot) and (*mapping_name) are assigned pointers into the */ -/* original buffer. */ -#if (defined(DYNAMIC_LOADING) && defined(USE_PROC_FOR_LIBRARIES)) \ - || defined(IA64) || defined(INCLUDE_LINUX_THREAD_DESCR) \ - || defined(REDIRECT_MALLOC) - GC_INNER char *GC_parse_map_entry(char *buf_ptr, ptr_t *start, ptr_t *end, - char **prot, unsigned int *maj_dev, - char **mapping_name) - { - unsigned char *start_start, *end_start, *maj_dev_start; - unsigned char *p; /* unsigned for isspace, isxdigit */ - - if (buf_ptr == NULL || *buf_ptr == '\0') { - return NULL; - } - - p = (unsigned char *)buf_ptr; - while (isspace(*p)) ++p; - start_start = p; - GC_ASSERT(isxdigit(*start_start)); - *start = (ptr_t)strtoul((char *)start_start, (char **)&p, 16); - GC_ASSERT(*p=='-'); - - ++p; - end_start = p; - GC_ASSERT(isxdigit(*end_start)); - *end = (ptr_t)strtoul((char *)end_start, (char **)&p, 16); - GC_ASSERT(isspace(*p)); - - while (isspace(*p)) ++p; - GC_ASSERT(*p == 'r' || *p == '-'); - *prot = (char *)p; - /* Skip past protection field to offset field */ - while (!isspace(*p)) ++p; while (isspace(*p)) ++p; - GC_ASSERT(isxdigit(*p)); - /* Skip past offset field, which we ignore */ - while (!isspace(*p)) ++p; while (isspace(*p)) ++p; - maj_dev_start = p; - GC_ASSERT(isxdigit(*maj_dev_start)); - *maj_dev = strtoul((char *)maj_dev_start, NULL, 16); - - if (mapping_name == 0) { - while (*p && *p++ != '\n'); - } else { - while (*p && *p != '\n' && *p != '/' && *p != '[') p++; - *mapping_name = (char *)p; - while (*p && *p++ != '\n'); - } - return (char *)p; - } -#endif /* REDIRECT_MALLOC || DYNAMIC_LOADING || IA64 || ... */ - -#if defined(IA64) || defined(INCLUDE_LINUX_THREAD_DESCR) - /* Try to read the backing store base from /proc/self/maps. */ - /* Return the bounds of the writable mapping with a 0 major device, */ - /* which includes the address passed as data. */ - /* Return FALSE if there is no such mapping. */ - GC_INNER GC_bool GC_enclosing_mapping(ptr_t addr, ptr_t *startp, - ptr_t *endp) - { - char *prot; - ptr_t my_start, my_end; - unsigned int maj_dev; - char *maps = GC_get_maps(); - char *buf_ptr = maps; - - if (0 == maps) return(FALSE); - for (;;) { - buf_ptr = GC_parse_map_entry(buf_ptr, &my_start, &my_end, - &prot, &maj_dev, 0); - - if (buf_ptr == NULL) return FALSE; - if (prot[1] == 'w' && maj_dev == 0) { - if ((word)my_end > (word)addr && (word)my_start <= (word)addr) { - *startp = my_start; - *endp = my_end; - return TRUE; - } - } - } - return FALSE; - } -#endif /* IA64 || INCLUDE_LINUX_THREAD_DESCR */ - -#if defined(REDIRECT_MALLOC) - /* Find the text(code) mapping for the library whose name, after */ - /* stripping the directory part, starts with nm. */ - GC_INNER GC_bool GC_text_mapping(char *nm, ptr_t *startp, ptr_t *endp) - { - size_t nm_len = strlen(nm); - char *prot; - char *map_path; - ptr_t my_start, my_end; - unsigned int maj_dev; - char *maps = GC_get_maps(); - char *buf_ptr = maps; - - if (0 == maps) return(FALSE); - for (;;) { - buf_ptr = GC_parse_map_entry(buf_ptr, &my_start, &my_end, - &prot, &maj_dev, &map_path); - - if (buf_ptr == NULL) return FALSE; - if (prot[0] == 'r' && prot[1] == '-' && prot[2] == 'x') { - char *p = map_path; - /* Set p to point just past last slash, if any. */ - while (*p != '\0' && *p != '\n' && *p != ' ' && *p != '\t') ++p; - while (*p != '/' && (word)p >= (word)map_path) --p; - ++p; - if (strncmp(nm, p, nm_len) == 0) { - *startp = my_start; - *endp = my_end; - return TRUE; - } - } - } - return FALSE; - } -#endif /* REDIRECT_MALLOC */ - -#ifdef IA64 - static ptr_t backing_store_base_from_proc(void) - { - ptr_t my_start, my_end; - if (!GC_enclosing_mapping(GC_save_regs_in_stack(), &my_start, &my_end)) { - GC_COND_LOG_PRINTF("Failed to find backing store base from /proc\n"); - return 0; - } - return my_start; - } -#endif - -#endif /* NEED_PROC_MAPS */ - -#if defined(SEARCH_FOR_DATA_START) - /* The I386 case can be handled without a search. The Alpha case */ - /* used to be handled differently as well, but the rules changed */ - /* for recent Linux versions. This seems to be the easiest way to */ - /* cover all versions. */ - -# if defined(LINUX) || defined(HURD) - /* Some Linux distributions arrange to define __data_start. Some */ - /* define data_start as a weak symbol. The latter is technically */ - /* broken, since the user program may define data_start, in which */ - /* case we lose. Nonetheless, we try both, preferring __data_start.*/ - /* We assume gcc-compatible pragmas. */ -# pragma weak __data_start -# pragma weak data_start - extern int __data_start[], data_start[]; -# ifdef PLATFORM_ANDROID -# pragma weak _etext -# pragma weak __dso_handle - extern int _etext[], __dso_handle[]; -# endif -# endif /* LINUX */ - extern int _end[]; - - ptr_t GC_data_start = NULL; - - ptr_t GC_find_limit(ptr_t, GC_bool); - - GC_INNER void GC_init_linux_data_start(void) - { -# if (defined(LINUX) || defined(HURD)) && !defined(IGNORE_PROG_DATA_START) - /* Try the easy approaches first: */ -# ifdef PLATFORM_ANDROID - /* Workaround for "gold" (default) linker (as of Android NDK r9b). */ - if ((word)__data_start < (word)_etext - && (word)_etext < (word)__dso_handle) { - GC_data_start = (ptr_t)(__dso_handle); -# ifdef DEBUG_ADD_DEL_ROOTS - GC_log_printf( - "__data_start is wrong; using __dso_handle as data start\n"); -# endif - GC_ASSERT((word)GC_data_start <= (word)_end); - return; - } -# endif - if ((ptr_t)__data_start != 0) { - GC_data_start = (ptr_t)(__data_start); - GC_ASSERT((word)GC_data_start <= (word)_end); - return; - } - if ((ptr_t)data_start != 0) { - GC_data_start = (ptr_t)(data_start); - GC_ASSERT((word)GC_data_start <= (word)_end); - return; - } -# ifdef DEBUG_ADD_DEL_ROOTS - GC_log_printf("__data_start not provided\n"); -# endif -# endif /* LINUX */ - - if (GC_no_dls) { - /* Not needed, avoids the SIGSEGV caused by */ - /* GC_find_limit which complicates debugging. */ - GC_data_start = (ptr_t)_end; /* set data root size to 0 */ - return; - } - - GC_data_start = GC_find_limit((ptr_t)(_end), FALSE); - } -#endif /* SEARCH_FOR_DATA_START */ - -#ifdef ECOS - -# ifndef ECOS_GC_MEMORY_SIZE -# define ECOS_GC_MEMORY_SIZE (448 * 1024) -# endif /* ECOS_GC_MEMORY_SIZE */ - - /* FIXME: This is a simple way of allocating memory which is */ - /* compatible with ECOS early releases. Later releases use a more */ - /* sophisticated means of allocating memory than this simple static */ - /* allocator, but this method is at least bound to work. */ - static char ecos_gc_memory[ECOS_GC_MEMORY_SIZE]; - static char *ecos_gc_brk = ecos_gc_memory; - - static void *tiny_sbrk(ptrdiff_t increment) - { - void *p = ecos_gc_brk; - ecos_gc_brk += increment; - if ((word)ecos_gc_brk > (word)(ecos_gc_memory + sizeof(ecos_gc_memory))) { - ecos_gc_brk -= increment; - return NULL; - } - return p; - } -# define sbrk tiny_sbrk -#endif /* ECOS */ - -#if defined(NETBSD) && defined(__ELF__) - ptr_t GC_data_start = NULL; - ptr_t GC_find_limit(ptr_t, GC_bool); - - extern char **environ; - - GC_INNER void GC_init_netbsd_elf(void) - { - /* This may need to be environ, without the underscore, for */ - /* some versions. */ - GC_data_start = GC_find_limit((ptr_t)&environ, FALSE); - } -#endif /* NETBSD */ - -#ifdef OPENBSD - static struct sigaction old_segv_act; - STATIC sigjmp_buf GC_jmp_buf_openbsd; - -# ifdef THREADS -# include - extern sigset_t __syscall(quad_t, ...); -# endif - - /* Don't use GC_find_limit() because siglongjmp() outside of the */ - /* signal handler by-passes our userland pthreads lib, leaving */ - /* SIGSEGV and SIGPROF masked. Instead, use this custom one that */ - /* works-around the issues. */ - - STATIC void GC_fault_handler_openbsd(int sig GC_ATTR_UNUSED) - { - siglongjmp(GC_jmp_buf_openbsd, 1); - } - - /* Return the first non-addressable location > p or bound. */ - /* Requires the allocation lock. */ - STATIC ptr_t GC_find_limit_openbsd(ptr_t p, ptr_t bound) - { - static volatile ptr_t result; - /* Safer if static, since otherwise it may not be */ - /* preserved across the longjmp. Can safely be */ - /* static since it's only called with the */ - /* allocation lock held. */ - - struct sigaction act; - size_t pgsz = (size_t)sysconf(_SC_PAGESIZE); - GC_ASSERT(I_HOLD_LOCK()); - - act.sa_handler = GC_fault_handler_openbsd; - sigemptyset(&act.sa_mask); - act.sa_flags = SA_NODEFER | SA_RESTART; - /* act.sa_restorer is deprecated and should not be initialized. */ - sigaction(SIGSEGV, &act, &old_segv_act); - - if (sigsetjmp(GC_jmp_buf_openbsd, 1) == 0) { - result = (ptr_t)((word)p & ~(pgsz-1)); - for (;;) { - result += pgsz; - if ((word)result >= (word)bound) { - result = bound; - break; - } - GC_noop1((word)(*result)); - } - } - -# ifdef THREADS - /* Due to the siglongjump we need to manually unmask SIGPROF. */ - __syscall(SYS_sigprocmask, SIG_UNBLOCK, sigmask(SIGPROF)); -# endif - - sigaction(SIGSEGV, &old_segv_act, 0); - return(result); - } - - /* Return first addressable location > p or bound. */ - /* Requires the allocation lock. */ - STATIC ptr_t GC_skip_hole_openbsd(ptr_t p, ptr_t bound) - { - static volatile ptr_t result; - static volatile int firstpass; - - struct sigaction act; - size_t pgsz = (size_t)sysconf(_SC_PAGESIZE); - GC_ASSERT(I_HOLD_LOCK()); - - act.sa_handler = GC_fault_handler_openbsd; - sigemptyset(&act.sa_mask); - act.sa_flags = SA_NODEFER | SA_RESTART; - /* act.sa_restorer is deprecated and should not be initialized. */ - sigaction(SIGSEGV, &act, &old_segv_act); - - firstpass = 1; - result = (ptr_t)((word)p & ~(pgsz-1)); - if (sigsetjmp(GC_jmp_buf_openbsd, 1) != 0 || firstpass) { - firstpass = 0; - result += pgsz; - if ((word)result >= (word)bound) { - result = bound; - } else { - GC_noop1((word)(*result)); - } - } - - sigaction(SIGSEGV, &old_segv_act, 0); - return(result); - } -#endif /* OPENBSD */ - -# ifdef OS2 - -# include - -# if !defined(__IBMC__) && !defined(__WATCOMC__) /* e.g. EMX */ - -struct exe_hdr { - unsigned short magic_number; - unsigned short padding[29]; - long new_exe_offset; -}; - -#define E_MAGIC(x) (x).magic_number -#define EMAGIC 0x5A4D -#define E_LFANEW(x) (x).new_exe_offset - -struct e32_exe { - unsigned char magic_number[2]; - unsigned char byte_order; - unsigned char word_order; - unsigned long exe_format_level; - unsigned short cpu; - unsigned short os; - unsigned long padding1[13]; - unsigned long object_table_offset; - unsigned long object_count; - unsigned long padding2[31]; -}; - -#define E32_MAGIC1(x) (x).magic_number[0] -#define E32MAGIC1 'L' -#define E32_MAGIC2(x) (x).magic_number[1] -#define E32MAGIC2 'X' -#define E32_BORDER(x) (x).byte_order -#define E32LEBO 0 -#define E32_WORDER(x) (x).word_order -#define E32LEWO 0 -#define E32_CPU(x) (x).cpu -#define E32CPU286 1 -#define E32_OBJTAB(x) (x).object_table_offset -#define E32_OBJCNT(x) (x).object_count - -struct o32_obj { - unsigned long size; - unsigned long base; - unsigned long flags; - unsigned long pagemap; - unsigned long mapsize; - unsigned long reserved; -}; - -#define O32_FLAGS(x) (x).flags -#define OBJREAD 0x0001L -#define OBJWRITE 0x0002L -#define OBJINVALID 0x0080L -#define O32_SIZE(x) (x).size -#define O32_BASE(x) (x).base - -# else /* IBM's compiler */ - -/* A kludge to get around what appears to be a header file bug */ -# ifndef WORD -# define WORD unsigned short -# endif -# ifndef DWORD -# define DWORD unsigned long -# endif - -# define EXE386 1 -# include -# include - -# endif /* __IBMC__ */ - -# define INCL_DOSEXCEPTIONS -# define INCL_DOSPROCESS -# define INCL_DOSERRORS -# define INCL_DOSMODULEMGR -# define INCL_DOSMEMMGR -# include - -# endif /* OS/2 */ - -/* Find the page size */ -GC_INNER word GC_page_size = 0; - -#if defined(MSWIN32) || defined(MSWINCE) || defined(CYGWIN32) -# ifndef VER_PLATFORM_WIN32_CE -# define VER_PLATFORM_WIN32_CE 3 -# endif - -# if defined(MSWINCE) && defined(THREADS) - GC_INNER GC_bool GC_dont_query_stack_min = FALSE; -# endif - - GC_INNER SYSTEM_INFO GC_sysinfo; - - GC_INNER void GC_setpagesize(void) - { - GetSystemInfo(&GC_sysinfo); - GC_page_size = GC_sysinfo.dwPageSize; -# if defined(MSWINCE) && !defined(_WIN32_WCE_EMULATION) - { - OSVERSIONINFO verInfo; - /* Check the current WinCE version. */ - verInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); - if (!GetVersionEx(&verInfo)) - ABORT("GetVersionEx failed"); - if (verInfo.dwPlatformId == VER_PLATFORM_WIN32_CE && - verInfo.dwMajorVersion < 6) { - /* Only the first 32 MB of address space belongs to the */ - /* current process (unless WinCE 6.0+ or emulation). */ - GC_sysinfo.lpMaximumApplicationAddress = (LPVOID)((word)32 << 20); -# ifdef THREADS - /* On some old WinCE versions, it's observed that */ - /* VirtualQuery calls don't work properly when used to */ - /* get thread current stack committed minimum. */ - if (verInfo.dwMajorVersion < 5) - GC_dont_query_stack_min = TRUE; -# endif - } - } -# endif - } - -# ifndef CYGWIN32 -# define is_writable(prot) ((prot) == PAGE_READWRITE \ - || (prot) == PAGE_WRITECOPY \ - || (prot) == PAGE_EXECUTE_READWRITE \ - || (prot) == PAGE_EXECUTE_WRITECOPY) - /* Return the number of bytes that are writable starting at p. */ - /* The pointer p is assumed to be page aligned. */ - /* If base is not 0, *base becomes the beginning of the */ - /* allocation region containing p. */ - STATIC word GC_get_writable_length(ptr_t p, ptr_t *base) - { - MEMORY_BASIC_INFORMATION buf; - word result; - word protect; - - result = VirtualQuery(p, &buf, sizeof(buf)); - if (result != sizeof(buf)) ABORT("Weird VirtualQuery result"); - if (base != 0) *base = (ptr_t)(buf.AllocationBase); - protect = (buf.Protect & ~(PAGE_GUARD | PAGE_NOCACHE)); - if (!is_writable(protect)) { - return(0); - } - if (buf.State != MEM_COMMIT) return(0); - return(buf.RegionSize); - } - - GC_API int GC_CALL GC_get_stack_base(struct GC_stack_base *sb) - { - ptr_t trunc_sp = (ptr_t)((word)GC_approx_sp() & ~(GC_page_size - 1)); - /* FIXME: This won't work if called from a deeply recursive */ - /* client code (and the committed stack space has grown). */ - word size = GC_get_writable_length(trunc_sp, 0); - GC_ASSERT(size != 0); - sb -> mem_base = trunc_sp + size; - return GC_SUCCESS; - } -# else /* CYGWIN32 */ - /* An alternate version for Cygwin (adapted from Dave Korn's */ - /* gcc version of boehm-gc). */ - GC_API int GC_CALL GC_get_stack_base(struct GC_stack_base *sb) - { -# ifdef X86_64 - sb -> mem_base = ((NT_TIB*)NtCurrentTeb())->StackBase; -# else - void * _tlsbase; - - __asm__ ("movl %%fs:4, %0" - : "=r" (_tlsbase)); - sb -> mem_base = _tlsbase; -# endif - return GC_SUCCESS; - } -# endif /* CYGWIN32 */ -# define HAVE_GET_STACK_BASE - -#else /* !MSWIN32 */ - GC_INNER void GC_setpagesize(void) - { -# if defined(MPROTECT_VDB) || defined(PROC_VDB) || defined(USE_MMAP) - GC_page_size = GETPAGESIZE(); - if (!GC_page_size) ABORT("getpagesize failed"); -# else - /* It's acceptable to fake it. */ - GC_page_size = HBLKSIZE; -# endif - } -#endif /* !MSWIN32 */ - -#ifdef BEOS -# include - - GC_API int GC_CALL GC_get_stack_base(struct GC_stack_base *sb) - { - thread_info th; - get_thread_info(find_thread(NULL),&th); - sb->mem_base = th.stack_end; - return GC_SUCCESS; - } -# define HAVE_GET_STACK_BASE -#endif /* BEOS */ - -#ifdef OS2 - GC_API int GC_CALL GC_get_stack_base(struct GC_stack_base *sb) - { - PTIB ptib; /* thread information block */ - PPIB ppib; - if (DosGetInfoBlocks(&ptib, &ppib) != NO_ERROR) { - ABORT("DosGetInfoBlocks failed"); - } - sb->mem_base = ptib->tib_pstacklimit; - return GC_SUCCESS; - } -# define HAVE_GET_STACK_BASE -#endif /* OS2 */ - -# ifdef AMIGA -# define GC_AMIGA_SB -# include "extra/AmigaOS.c" -# undef GC_AMIGA_SB -# endif /* AMIGA */ - -# if defined(NEED_FIND_LIMIT) || defined(UNIX_LIKE) - - typedef void (*GC_fault_handler_t)(int); - -# if defined(SUNOS5SIGS) || defined(IRIX5) || defined(OSF1) \ - || defined(HURD) || defined(FREEBSD) || defined(NETBSD) - static struct sigaction old_segv_act; -# if defined(_sigargs) /* !Irix6.x */ \ - || defined(HURD) || defined(NETBSD) || defined(FREEBSD) - static struct sigaction old_bus_act; -# endif -# else - static GC_fault_handler_t old_segv_handler; -# ifdef SIGBUS - static GC_fault_handler_t old_bus_handler; -# endif -# endif - - GC_INNER void GC_set_and_save_fault_handler(GC_fault_handler_t h) - { -# if defined(SUNOS5SIGS) || defined(IRIX5) || defined(OSF1) \ - || defined(HURD) || defined(FREEBSD) || defined(NETBSD) - struct sigaction act; - - act.sa_handler = h; -# ifdef SIGACTION_FLAGS_NODEFER_HACK - /* Was necessary for Solaris 2.3 and very temporary */ - /* NetBSD bugs. */ - act.sa_flags = SA_RESTART | SA_NODEFER; -# else - act.sa_flags = SA_RESTART; -# endif - - (void) sigemptyset(&act.sa_mask); - /* act.sa_restorer is deprecated and should not be initialized. */ -# ifdef GC_IRIX_THREADS - /* Older versions have a bug related to retrieving and */ - /* and setting a handler at the same time. */ - (void) sigaction(SIGSEGV, 0, &old_segv_act); - (void) sigaction(SIGSEGV, &act, 0); -# else - (void) sigaction(SIGSEGV, &act, &old_segv_act); -# if defined(IRIX5) && defined(_sigargs) /* Irix 5.x, not 6.x */ \ - || defined(HURD) || defined(NETBSD) || defined(FREEBSD) - /* Under Irix 5.x or HP/UX, we may get SIGBUS. */ - /* Pthreads doesn't exist under Irix 5.x, so we */ - /* don't have to worry in the threads case. */ - (void) sigaction(SIGBUS, &act, &old_bus_act); -# endif -# endif /* !GC_IRIX_THREADS */ -# else - old_segv_handler = signal(SIGSEGV, h); -# ifdef SIGBUS - old_bus_handler = signal(SIGBUS, h); -# endif -# endif - } -# endif /* NEED_FIND_LIMIT || UNIX_LIKE */ - -# if defined(NEED_FIND_LIMIT) \ - || (defined(USE_PROC_FOR_LIBRARIES) && defined(THREADS)) - /* Some tools to implement HEURISTIC2 */ -# define MIN_PAGE_SIZE 256 /* Smallest conceivable page size, bytes */ - - STATIC void GC_fault_handler(int sig GC_ATTR_UNUSED) - { - LONGJMP(GC_jmp_buf, 1); - } - - GC_INNER void GC_setup_temporary_fault_handler(void) - { - /* Handler is process-wide, so this should only happen in */ - /* one thread at a time. */ - GC_ASSERT(I_HOLD_LOCK()); - GC_set_and_save_fault_handler(GC_fault_handler); - } - - GC_INNER void GC_reset_fault_handler(void) - { -# if defined(SUNOS5SIGS) || defined(IRIX5) || defined(OSF1) \ - || defined(HURD) || defined(FREEBSD) || defined(NETBSD) - (void) sigaction(SIGSEGV, &old_segv_act, 0); -# if defined(IRIX5) && defined(_sigargs) /* Irix 5.x, not 6.x */ \ - || defined(HURD) || defined(NETBSD) - (void) sigaction(SIGBUS, &old_bus_act, 0); -# endif -# else - (void) signal(SIGSEGV, old_segv_handler); -# ifdef SIGBUS - (void) signal(SIGBUS, old_bus_handler); -# endif -# endif - } - - /* Return the first non-addressable location > p (up) or */ - /* the smallest location q s.t. [q,p) is addressable (!up). */ - /* We assume that p (up) or p-1 (!up) is addressable. */ - /* Requires allocation lock. */ - STATIC ptr_t GC_find_limit_with_bound(ptr_t p, GC_bool up, ptr_t bound) - { - static volatile ptr_t result; - /* Safer if static, since otherwise it may not be */ - /* preserved across the longjmp. Can safely be */ - /* static since it's only called with the */ - /* allocation lock held. */ - - GC_ASSERT(I_HOLD_LOCK()); - GC_setup_temporary_fault_handler(); - if (SETJMP(GC_jmp_buf) == 0) { - result = (ptr_t)(((word)(p)) - & ~(MIN_PAGE_SIZE-1)); - for (;;) { - if (up) { - result += MIN_PAGE_SIZE; - if ((word)result >= (word)bound) { - result = bound; - break; - } - } else { - result -= MIN_PAGE_SIZE; - if ((word)result <= (word)bound) { - result = bound - MIN_PAGE_SIZE; - /* This is to compensate */ - /* further result increment (we */ - /* do not modify "up" variable */ - /* since it might be clobbered */ - /* by setjmp otherwise). */ - break; - } - } - GC_noop1((word)(*result)); - } - } - GC_reset_fault_handler(); - if (!up) { - result += MIN_PAGE_SIZE; - } - return(result); - } - - ptr_t GC_find_limit(ptr_t p, GC_bool up) - { - return GC_find_limit_with_bound(p, up, up ? (ptr_t)(word)(-1) : 0); - } -# endif /* NEED_FIND_LIMIT || USE_PROC_FOR_LIBRARIES */ - -#ifdef HPUX_STACKBOTTOM - -#include -#include - - GC_INNER ptr_t GC_get_register_stack_base(void) - { - struct pst_vm_status vm_status; - - int i = 0; - while (pstat_getprocvm(&vm_status, sizeof(vm_status), 0, i++) == 1) { - if (vm_status.pst_type == PS_RSESTACK) { - return (ptr_t) vm_status.pst_vaddr; - } - } - - /* old way to get the register stackbottom */ - return (ptr_t)(((word)GC_stackbottom - BACKING_STORE_DISPLACEMENT - 1) - & ~(BACKING_STORE_ALIGNMENT - 1)); - } - -#endif /* HPUX_STACK_BOTTOM */ - -#ifdef LINUX_STACKBOTTOM - -# include -# include - -# define STAT_SKIP 27 /* Number of fields preceding startstack */ - /* field in /proc/self/stat */ - -# ifdef USE_LIBC_PRIVATES -# pragma weak __libc_stack_end - extern ptr_t __libc_stack_end; -# endif - -# ifdef IA64 -# ifdef USE_LIBC_PRIVATES -# pragma weak __libc_ia64_register_backing_store_base - extern ptr_t __libc_ia64_register_backing_store_base; -# endif - - GC_INNER ptr_t GC_get_register_stack_base(void) - { - ptr_t result; - -# ifdef USE_LIBC_PRIVATES - if (0 != &__libc_ia64_register_backing_store_base - && 0 != __libc_ia64_register_backing_store_base) { - /* Glibc 2.2.4 has a bug such that for dynamically linked */ - /* executables __libc_ia64_register_backing_store_base is */ - /* defined but uninitialized during constructor calls. */ - /* Hence we check for both nonzero address and value. */ - return __libc_ia64_register_backing_store_base; - } -# endif - result = backing_store_base_from_proc(); - if (0 == result) { - result = GC_find_limit(GC_save_regs_in_stack(), FALSE); - /* Now seems to work better than constant displacement */ - /* heuristic used in 6.X versions. The latter seems to */ - /* fail for 2.6 kernels. */ - } - return result; - } -# endif /* IA64 */ - - STATIC ptr_t GC_linux_main_stack_base(void) - { - /* We read the stack base value from /proc/self/stat. We do this */ - /* using direct I/O system calls in order to avoid calling malloc */ - /* in case REDIRECT_MALLOC is defined. */ -# ifndef STAT_READ - /* Also defined in pthread_support.c. */ -# define STAT_BUF_SIZE 4096 -# define STAT_READ read -# endif - /* Should probably call the real read, if read is wrapped. */ - char stat_buf[STAT_BUF_SIZE]; - int f; - word result; - int i, buf_offset = 0, len; - - /* First try the easy way. This should work for glibc 2.2 */ - /* This fails in a prelinked ("prelink" command) executable */ - /* since the correct value of __libc_stack_end never */ - /* becomes visible to us. The second test works around */ - /* this. */ -# ifdef USE_LIBC_PRIVATES - if (0 != &__libc_stack_end && 0 != __libc_stack_end ) { -# if defined(IA64) - /* Some versions of glibc set the address 16 bytes too */ - /* low while the initialization code is running. */ - if (((word)__libc_stack_end & 0xfff) + 0x10 < 0x1000) { - return __libc_stack_end + 0x10; - } /* Otherwise it's not safe to add 16 bytes and we fall */ - /* back to using /proc. */ -# elif defined(SPARC) - /* Older versions of glibc for 64-bit SPARC do not set this */ - /* variable correctly, it gets set to either zero or one. */ - if (__libc_stack_end != (ptr_t) (unsigned long)0x1) - return __libc_stack_end; -# else - return __libc_stack_end; -# endif - } -# endif - f = open("/proc/self/stat", O_RDONLY); - if (f < 0) - ABORT("Couldn't read /proc/self/stat"); - len = STAT_READ(f, stat_buf, STAT_BUF_SIZE); - close(f); - - /* Skip the required number of fields. This number is hopefully */ - /* constant across all Linux implementations. */ - for (i = 0; i < STAT_SKIP; ++i) { - while (buf_offset < len && isspace(stat_buf[buf_offset++])) { - /* empty */ - } - while (buf_offset < len && !isspace(stat_buf[buf_offset++])) { - /* empty */ - } - } - /* Skip spaces. */ - while (buf_offset < len && isspace(stat_buf[buf_offset])) { - buf_offset++; - } - /* Find the end of the number and cut the buffer there. */ - for (i = 0; buf_offset + i < len; i++) { - if (!isdigit(stat_buf[buf_offset + i])) break; - } - if (buf_offset + i >= len) ABORT("Could not parse /proc/self/stat"); - stat_buf[buf_offset + i] = '\0'; - - result = (word)STRTOULL(&stat_buf[buf_offset], NULL, 10); - if (result < 0x100000 || (result & (sizeof(word) - 1)) != 0) - ABORT("Absurd stack bottom value"); - return (ptr_t)result; - } -#endif /* LINUX_STACKBOTTOM */ - -#ifdef FREEBSD_STACKBOTTOM - /* This uses an undocumented sysctl call, but at least one expert */ - /* believes it will stay. */ - -# include -# include -# include - - STATIC ptr_t GC_freebsd_main_stack_base(void) - { - int nm[2] = {CTL_KERN, KERN_USRSTACK}; - ptr_t base; - size_t len = sizeof(ptr_t); - int r = sysctl(nm, 2, &base, &len, NULL, 0); - if (r) ABORT("Error getting main stack base"); - return base; - } -#endif /* FREEBSD_STACKBOTTOM */ - -#if defined(ECOS) || defined(NOSYS) - ptr_t GC_get_main_stack_base(void) - { - return STACKBOTTOM; - } -# define GET_MAIN_STACKBASE_SPECIAL -#elif defined(SYMBIAN) - extern int GC_get_main_symbian_stack_base(void); - ptr_t GC_get_main_stack_base(void) - { - return (ptr_t)GC_get_main_symbian_stack_base(); - } -# define GET_MAIN_STACKBASE_SPECIAL -#elif !defined(BEOS) && !defined(AMIGA) && !defined(OS2) \ - && !defined(MSWIN32) && !defined(MSWINCE) && !defined(CYGWIN32) \ - && !defined(GC_OPENBSD_THREADS) \ - && (!defined(GC_SOLARIS_THREADS) || defined(_STRICT_STDC)) - -# if defined(LINUX) && defined(USE_GET_STACKBASE_FOR_MAIN) -# include -# elif defined(DARWIN) && !defined(NO_PTHREAD_GET_STACKADDR_NP) - /* We could use pthread_get_stackaddr_np even in case of a */ - /* single-threaded gclib (there is no -lpthread on Darwin). */ -# include -# undef STACKBOTTOM -# define STACKBOTTOM (ptr_t)pthread_get_stackaddr_np(pthread_self()) -# endif - - ptr_t GC_get_main_stack_base(void) - { - ptr_t result; -# if defined(LINUX) && !defined(NO_PTHREAD_GETATTR_NP) \ - && (defined(USE_GET_STACKBASE_FOR_MAIN) \ - || (defined(THREADS) && !defined(REDIRECT_MALLOC))) - pthread_attr_t attr; - void *stackaddr; - size_t size; - - if (pthread_getattr_np(pthread_self(), &attr) == 0) { - if (pthread_attr_getstack(&attr, &stackaddr, &size) == 0 - && stackaddr != NULL) { - (void)pthread_attr_destroy(&attr); -# ifdef STACK_GROWS_DOWN - stackaddr = (char *)stackaddr + size; -# endif - return (ptr_t)stackaddr; - } - (void)pthread_attr_destroy(&attr); - } - WARN("pthread_getattr_np or pthread_attr_getstack failed" - " for main thread\n", 0); -# endif -# ifdef STACKBOTTOM - result = STACKBOTTOM; -# else -# define STACKBOTTOM_ALIGNMENT_M1 ((word)STACK_GRAN - 1) -# ifdef HEURISTIC1 -# ifdef STACK_GROWS_DOWN - result = (ptr_t)(((word)GC_approx_sp() + STACKBOTTOM_ALIGNMENT_M1) - & ~STACKBOTTOM_ALIGNMENT_M1); -# else - result = (ptr_t)((word)GC_approx_sp() & ~STACKBOTTOM_ALIGNMENT_M1); -# endif -# endif /* HEURISTIC1 */ -# ifdef LINUX_STACKBOTTOM - result = GC_linux_main_stack_base(); -# endif -# ifdef FREEBSD_STACKBOTTOM - result = GC_freebsd_main_stack_base(); -# endif -# ifdef HEURISTIC2 - { - ptr_t sp = GC_approx_sp(); -# ifdef STACK_GROWS_DOWN - result = GC_find_limit(sp, TRUE); -# ifdef HEURISTIC2_LIMIT - if ((word)result > (word)HEURISTIC2_LIMIT - && (word)sp < (word)HEURISTIC2_LIMIT) { - result = HEURISTIC2_LIMIT; - } -# endif -# else - result = GC_find_limit(sp, FALSE); -# ifdef HEURISTIC2_LIMIT - if ((word)result < (word)HEURISTIC2_LIMIT - && (word)sp > (word)HEURISTIC2_LIMIT) { - result = HEURISTIC2_LIMIT; - } -# endif -# endif - } -# endif /* HEURISTIC2 */ -# ifdef STACK_GROWS_DOWN - if (result == 0) - result = (ptr_t)(signed_word)(-sizeof(ptr_t)); -# endif -# endif - GC_ASSERT((word)GC_approx_sp() HOTTER_THAN (word)result); - return(result); - } -# define GET_MAIN_STACKBASE_SPECIAL -#endif /* !AMIGA, !BEOS, !OPENBSD, !OS2, !Windows */ - -#if (defined(GC_LINUX_THREADS) || defined(PLATFORM_ANDROID)) \ - && !defined(NO_PTHREAD_GETATTR_NP) - -# include - /* extern int pthread_getattr_np(pthread_t, pthread_attr_t *); */ - - GC_API int GC_CALL GC_get_stack_base(struct GC_stack_base *b) - { - pthread_attr_t attr; - size_t size; -# ifdef IA64 - DCL_LOCK_STATE; -# endif - - if (pthread_getattr_np(pthread_self(), &attr) != 0) { - WARN("pthread_getattr_np failed\n", 0); - return GC_UNIMPLEMENTED; - } - if (pthread_attr_getstack(&attr, &(b -> mem_base), &size) != 0) { - ABORT("pthread_attr_getstack failed"); - } - (void)pthread_attr_destroy(&attr); -# ifdef STACK_GROWS_DOWN - b -> mem_base = (char *)(b -> mem_base) + size; -# endif -# ifdef IA64 - /* We could try backing_store_base_from_proc, but that's safe */ - /* only if no mappings are being asynchronously created. */ - /* Subtracting the size from the stack base doesn't work for at */ - /* least the main thread. */ - LOCK(); - { - IF_CANCEL(int cancel_state;) - ptr_t bsp; - ptr_t next_stack; - - DISABLE_CANCEL(cancel_state); - bsp = GC_save_regs_in_stack(); - next_stack = GC_greatest_stack_base_below(bsp); - if (0 == next_stack) { - b -> reg_base = GC_find_limit(bsp, FALSE); - } else { - /* Avoid walking backwards into preceding memory stack and */ - /* growing it. */ - b -> reg_base = GC_find_limit_with_bound(bsp, FALSE, next_stack); - } - RESTORE_CANCEL(cancel_state); - } - UNLOCK(); -# endif - return GC_SUCCESS; - } -# define HAVE_GET_STACK_BASE -#endif /* GC_LINUX_THREADS */ - -#if defined(GC_DARWIN_THREADS) && !defined(NO_PTHREAD_GET_STACKADDR_NP) -# include - - GC_API int GC_CALL GC_get_stack_base(struct GC_stack_base *b) - { - /* pthread_get_stackaddr_np() should return stack bottom (highest */ - /* stack address plus 1). */ - b->mem_base = pthread_get_stackaddr_np(pthread_self()); - GC_ASSERT((word)GC_approx_sp() HOTTER_THAN (word)b->mem_base); - return GC_SUCCESS; - } -# define HAVE_GET_STACK_BASE -#endif /* GC_DARWIN_THREADS */ - -#ifdef GC_OPENBSD_THREADS -# include -# include -# include - - /* Find the stack using pthread_stackseg_np(). */ - GC_API int GC_CALL GC_get_stack_base(struct GC_stack_base *sb) - { - stack_t stack; - if (pthread_stackseg_np(pthread_self(), &stack)) - ABORT("pthread_stackseg_np(self) failed"); - sb->mem_base = stack.ss_sp; - return GC_SUCCESS; - } -# define HAVE_GET_STACK_BASE -#endif /* GC_OPENBSD_THREADS */ - -#if defined(GC_SOLARIS_THREADS) && !defined(_STRICT_STDC) - -# include -# include -# include - - /* These variables are used to cache ss_sp value for the primordial */ - /* thread (it's better not to call thr_stksegment() twice for this */ - /* thread - see JDK bug #4352906). */ - static pthread_t stackbase_main_self = 0; - /* 0 means stackbase_main_ss_sp value is unset. */ - static void *stackbase_main_ss_sp = NULL; - - GC_API int GC_CALL GC_get_stack_base(struct GC_stack_base *b) - { - stack_t s; - pthread_t self = pthread_self(); - - if (self == stackbase_main_self) - { - /* If the client calls GC_get_stack_base() from the main thread */ - /* then just return the cached value. */ - b -> mem_base = stackbase_main_ss_sp; - GC_ASSERT(b -> mem_base != NULL); - return GC_SUCCESS; - } - - if (thr_stksegment(&s)) { - /* According to the manual, the only failure error code returned */ - /* is EAGAIN meaning "the information is not available due to the */ - /* thread is not yet completely initialized or it is an internal */ - /* thread" - this shouldn't happen here. */ - ABORT("thr_stksegment failed"); - } - /* s.ss_sp holds the pointer to the stack bottom. */ - GC_ASSERT((word)GC_approx_sp() HOTTER_THAN (word)s.ss_sp); - - if (!stackbase_main_self && thr_main() != 0) - { - /* Cache the stack base value for the primordial thread (this */ - /* is done during GC_init, so there is no race). */ - stackbase_main_ss_sp = s.ss_sp; - stackbase_main_self = self; - } - - b -> mem_base = s.ss_sp; - return GC_SUCCESS; - } -# define HAVE_GET_STACK_BASE -#endif /* GC_SOLARIS_THREADS */ - -#ifdef GC_RTEMS_PTHREADS - GC_API int GC_CALL GC_get_stack_base(struct GC_stack_base *sb) - { - sb->mem_base = rtems_get_stack_bottom(); - return GC_SUCCESS; - } -# define HAVE_GET_STACK_BASE -#endif /* GC_RTEMS_PTHREADS */ - -#ifndef HAVE_GET_STACK_BASE -# ifdef NEED_FIND_LIMIT - /* Retrieve stack base. */ - /* Using the GC_find_limit version is risky. */ - /* On IA64, for example, there is no guard page between the */ - /* stack of one thread and the register backing store of the */ - /* next. Thus this is likely to identify way too large a */ - /* "stack" and thus at least result in disastrous performance. */ - /* FIXME - Implement better strategies here. */ - GC_API int GC_CALL GC_get_stack_base(struct GC_stack_base *b) - { - IF_CANCEL(int cancel_state;) - DCL_LOCK_STATE; - - LOCK(); - DISABLE_CANCEL(cancel_state); /* May be unnecessary? */ -# ifdef STACK_GROWS_DOWN - b -> mem_base = GC_find_limit(GC_approx_sp(), TRUE); -# ifdef IA64 - b -> reg_base = GC_find_limit(GC_save_regs_in_stack(), FALSE); -# endif -# else - b -> mem_base = GC_find_limit(GC_approx_sp(), FALSE); -# endif - RESTORE_CANCEL(cancel_state); - UNLOCK(); - return GC_SUCCESS; - } -# else - GC_API int GC_CALL GC_get_stack_base( - struct GC_stack_base *b GC_ATTR_UNUSED) - { -# if defined(GET_MAIN_STACKBASE_SPECIAL) && !defined(THREADS) \ - && !defined(IA64) - b->mem_base = GC_get_main_stack_base(); - return GC_SUCCESS; -# else - return GC_UNIMPLEMENTED; -# endif - } -# endif /* !NEED_FIND_LIMIT */ -#endif /* !HAVE_GET_STACK_BASE */ - -#ifndef GET_MAIN_STACKBASE_SPECIAL - /* This is always called from the main thread. Default implementation. */ - ptr_t GC_get_main_stack_base(void) - { - struct GC_stack_base sb; - - if (GC_get_stack_base(&sb) != GC_SUCCESS) - ABORT("GC_get_stack_base failed"); - GC_ASSERT((word)GC_approx_sp() HOTTER_THAN (word)sb.mem_base); - return (ptr_t)sb.mem_base; - } -#endif /* !GET_MAIN_STACKBASE_SPECIAL */ - -/* Register static data segment(s) as roots. If more data segments are */ -/* added later then they need to be registered at that point (as we do */ -/* with SunOS dynamic loading), or GC_mark_roots needs to check for */ -/* them (as we do with PCR). Called with allocator lock held. */ -# ifdef OS2 - -void GC_register_data_segments(void) -{ - PTIB ptib; - PPIB ppib; - HMODULE module_handle; -# define PBUFSIZ 512 - UCHAR path[PBUFSIZ]; - FILE * myexefile; - struct exe_hdr hdrdos; /* MSDOS header. */ - struct e32_exe hdr386; /* Real header for my executable */ - struct o32_obj seg; /* Current segment */ - int nsegs; - - if (DosGetInfoBlocks(&ptib, &ppib) != NO_ERROR) { - ABORT("DosGetInfoBlocks failed"); - } - module_handle = ppib -> pib_hmte; - if (DosQueryModuleName(module_handle, PBUFSIZ, path) != NO_ERROR) { - ABORT("DosQueryModuleName failed"); - } - myexefile = fopen(path, "rb"); - if (myexefile == 0) { - ABORT_ARG1("Failed to open executable", ": %s", path); - } - if (fread((char *)(&hdrdos), 1, sizeof(hdrdos), myexefile) - < sizeof(hdrdos)) { - ABORT_ARG1("Could not read MSDOS header", " from: %s", path); - } - if (E_MAGIC(hdrdos) != EMAGIC) { - ABORT_ARG1("Bad DOS magic number", " in file: %s", path); - } - if (fseek(myexefile, E_LFANEW(hdrdos), SEEK_SET) != 0) { - ABORT_ARG1("Bad DOS magic number", " in file: %s", path); - } - if (fread((char *)(&hdr386), 1, sizeof(hdr386), myexefile) - < sizeof(hdr386)) { - ABORT_ARG1("Could not read OS/2 header", " from: %s", path); - } - if (E32_MAGIC1(hdr386) != E32MAGIC1 || E32_MAGIC2(hdr386) != E32MAGIC2) { - ABORT_ARG1("Bad OS/2 magic number", " in file: %s", path); - } - if (E32_BORDER(hdr386) != E32LEBO || E32_WORDER(hdr386) != E32LEWO) { - ABORT_ARG1("Bad byte order in executable", " file: %s", path); - } - if (E32_CPU(hdr386) == E32CPU286) { - ABORT_ARG1("GC cannot handle 80286 executables", ": %s", path); - } - if (fseek(myexefile, E_LFANEW(hdrdos) + E32_OBJTAB(hdr386), - SEEK_SET) != 0) { - ABORT_ARG1("Seek to object table failed", " in file: %s", path); - } - for (nsegs = E32_OBJCNT(hdr386); nsegs > 0; nsegs--) { - int flags; - if (fread((char *)(&seg), 1, sizeof(seg), myexefile) < sizeof(seg)) { - ABORT_ARG1("Could not read obj table entry", " from file: %s", path); - } - flags = O32_FLAGS(seg); - if (!(flags & OBJWRITE)) continue; - if (!(flags & OBJREAD)) continue; - if (flags & OBJINVALID) { - GC_err_printf("Object with invalid pages?\n"); - continue; - } - GC_add_roots_inner((ptr_t)O32_BASE(seg), - (ptr_t)(O32_BASE(seg)+O32_SIZE(seg)), FALSE); - } - (void)fclose(myexefile); -} - -# else /* !OS2 */ - -# if defined(GWW_VDB) -# ifndef MEM_WRITE_WATCH -# define MEM_WRITE_WATCH 0x200000 -# endif -# ifndef WRITE_WATCH_FLAG_RESET -# define WRITE_WATCH_FLAG_RESET 1 -# endif - - /* Since we can't easily check whether ULONG_PTR and SIZE_T are */ - /* defined in Win32 basetsd.h, we define own ULONG_PTR. */ -# define GC_ULONG_PTR word - - typedef UINT (WINAPI * GetWriteWatch_type)( - DWORD, PVOID, GC_ULONG_PTR /* SIZE_T */, - PVOID *, GC_ULONG_PTR *, PULONG); - static GetWriteWatch_type GetWriteWatch_func; - static DWORD GetWriteWatch_alloc_flag; - -# define GC_GWW_AVAILABLE() (GetWriteWatch_func != NULL) - - static void detect_GetWriteWatch(void) - { - static GC_bool done; - HMODULE hK32; - if (done) - return; - -# if defined(MPROTECT_VDB) - { - char * str = GETENV("GC_USE_GETWRITEWATCH"); -# if defined(GC_PREFER_MPROTECT_VDB) - if (str == NULL || (*str == '0' && *(str + 1) == '\0')) { - /* GC_USE_GETWRITEWATCH is unset or set to "0". */ - done = TRUE; /* falling back to MPROTECT_VDB strategy. */ - /* This should work as if GWW_VDB is undefined. */ - return; - } -# else - if (str != NULL && *str == '0' && *(str + 1) == '\0') { - /* GC_USE_GETWRITEWATCH is set "0". */ - done = TRUE; /* falling back to MPROTECT_VDB strategy. */ - return; - } -# endif - } -# endif - - hK32 = GetModuleHandle(TEXT("kernel32.dll")); - if (hK32 != (HMODULE)0 && - (GetWriteWatch_func = (GetWriteWatch_type)GetProcAddress(hK32, - "GetWriteWatch")) != NULL) { - /* Also check whether VirtualAlloc accepts MEM_WRITE_WATCH, */ - /* as some versions of kernel32.dll have one but not the */ - /* other, making the feature completely broken. */ - void * page = VirtualAlloc(NULL, GC_page_size, - MEM_WRITE_WATCH | MEM_RESERVE, - PAGE_READWRITE); - if (page != NULL) { - PVOID pages[16]; - GC_ULONG_PTR count = 16; - DWORD page_size; - /* Check that it actually works. In spite of some */ - /* documentation it actually seems to exist on W2K. */ - /* This test may be unnecessary, but ... */ - if (GetWriteWatch_func(WRITE_WATCH_FLAG_RESET, - page, GC_page_size, - pages, - &count, - &page_size) != 0) { - /* GetWriteWatch always fails. */ - GetWriteWatch_func = NULL; - } else { - GetWriteWatch_alloc_flag = MEM_WRITE_WATCH; - } - VirtualFree(page, 0 /* dwSize */, MEM_RELEASE); - } else { - /* GetWriteWatch will be useless. */ - GetWriteWatch_func = NULL; - } - } -# ifndef SMALL_CONFIG - if (GetWriteWatch_func == NULL) { - GC_COND_LOG_PRINTF("Did not find a usable GetWriteWatch()\n"); - } else { - GC_COND_LOG_PRINTF("Using GetWriteWatch()\n"); - } -# endif - done = TRUE; - } - -# else -# define GetWriteWatch_alloc_flag 0 -# endif /* !GWW_VDB */ - -# if defined(MSWIN32) || defined(MSWINCE) || defined(CYGWIN32) - -# ifdef MSWIN32 - /* Unfortunately, we have to handle win32s very differently from NT, */ - /* Since VirtualQuery has very different semantics. In particular, */ - /* under win32s a VirtualQuery call on an unmapped page returns an */ - /* invalid result. Under NT, GC_register_data_segments is a no-op */ - /* and all real work is done by GC_register_dynamic_libraries. Under */ - /* win32s, we cannot find the data segments associated with dll's. */ - /* We register the main data segment here. */ - GC_INNER GC_bool GC_no_win32_dlls = FALSE; - /* This used to be set for gcc, to avoid dealing with */ - /* the structured exception handling issues. But we now have */ - /* assembly code to do that right. */ - - GC_INNER GC_bool GC_wnt = FALSE; - /* This is a Windows NT derivative, i.e. NT, W2K, XP or later. */ - - GC_INNER void GC_init_win32(void) - { - /* Set GC_wnt. If we're running under win32s, assume that no DLLs */ - /* will be loaded. I doubt anyone still runs win32s, but... */ - DWORD v = GetVersion(); - GC_wnt = !(v & 0x80000000); - GC_no_win32_dlls |= ((!GC_wnt) && (v & 0xff) <= 3); -# ifdef USE_MUNMAP - if (GC_no_win32_dlls) { - /* Turn off unmapping for safety (since may not work well with */ - /* GlobalAlloc). */ - GC_unmap_threshold = 0; - } -# endif - } - - /* Return the smallest address a such that VirtualQuery */ - /* returns correct results for all addresses between a and start. */ - /* Assumes VirtualQuery returns correct information for start. */ - STATIC ptr_t GC_least_described_address(ptr_t start) - { - MEMORY_BASIC_INFORMATION buf; - size_t result; - LPVOID limit; - ptr_t p; - LPVOID q; - - limit = GC_sysinfo.lpMinimumApplicationAddress; - p = (ptr_t)((word)start & ~(GC_page_size - 1)); - for (;;) { - q = (LPVOID)(p - GC_page_size); - if ((word)q > (word)p /* underflow */ || (word)q < (word)limit) break; - result = VirtualQuery(q, &buf, sizeof(buf)); - if (result != sizeof(buf) || buf.AllocationBase == 0) break; - p = (ptr_t)(buf.AllocationBase); - } - return p; - } -# endif /* MSWIN32 */ - -# ifndef REDIRECT_MALLOC - /* We maintain a linked list of AllocationBase values that we know */ - /* correspond to malloc heap sections. Currently this is only called */ - /* during a GC. But there is some hope that for long running */ - /* programs we will eventually see most heap sections. */ - - /* In the long run, it would be more reliable to occasionally walk */ - /* the malloc heap with HeapWalk on the default heap. But that */ - /* apparently works only for NT-based Windows. */ - - STATIC size_t GC_max_root_size = 100000; /* Appr. largest root size. */ - -# ifdef USE_WINALLOC - /* In the long run, a better data structure would also be nice ... */ - STATIC struct GC_malloc_heap_list { - void * allocation_base; - struct GC_malloc_heap_list *next; - } *GC_malloc_heap_l = 0; - - /* Is p the base of one of the malloc heap sections we already know */ - /* about? */ - STATIC GC_bool GC_is_malloc_heap_base(ptr_t p) - { - struct GC_malloc_heap_list *q = GC_malloc_heap_l; - - while (0 != q) { - if (q -> allocation_base == p) return TRUE; - q = q -> next; - } - return FALSE; - } - - STATIC void *GC_get_allocation_base(void *p) - { - MEMORY_BASIC_INFORMATION buf; - size_t result = VirtualQuery(p, &buf, sizeof(buf)); - if (result != sizeof(buf)) { - ABORT("Weird VirtualQuery result"); - } - return buf.AllocationBase; - } - - GC_INNER void GC_add_current_malloc_heap(void) - { - struct GC_malloc_heap_list *new_l = - malloc(sizeof(struct GC_malloc_heap_list)); - void * candidate = GC_get_allocation_base(new_l); - - if (new_l == 0) return; - if (GC_is_malloc_heap_base(candidate)) { - /* Try a little harder to find malloc heap. */ - size_t req_size = 10000; - do { - void *p = malloc(req_size); - if (0 == p) { - free(new_l); - return; - } - candidate = GC_get_allocation_base(p); - free(p); - req_size *= 2; - } while (GC_is_malloc_heap_base(candidate) - && req_size < GC_max_root_size/10 && req_size < 500000); - if (GC_is_malloc_heap_base(candidate)) { - free(new_l); - return; - } - } - GC_COND_LOG_PRINTF("Found new system malloc AllocationBase at %p\n", - candidate); - new_l -> allocation_base = candidate; - new_l -> next = GC_malloc_heap_l; - GC_malloc_heap_l = new_l; - } -# endif /* USE_WINALLOC */ - -# endif /* !REDIRECT_MALLOC */ - - STATIC word GC_n_heap_bases = 0; /* See GC_heap_bases. */ - - /* Is p the start of either the malloc heap, or of one of our */ - /* heap sections? */ - GC_INNER GC_bool GC_is_heap_base(ptr_t p) - { - unsigned i; -# ifndef REDIRECT_MALLOC - if (GC_root_size > GC_max_root_size) GC_max_root_size = GC_root_size; -# ifdef USE_WINALLOC - if (GC_is_malloc_heap_base(p)) return TRUE; -# endif -# endif - for (i = 0; i < GC_n_heap_bases; i++) { - if (GC_heap_bases[i] == p) return TRUE; - } - return FALSE; - } - -#ifdef MSWIN32 - STATIC void GC_register_root_section(ptr_t static_root) - { - MEMORY_BASIC_INFORMATION buf; - size_t result; - DWORD protect; - LPVOID p; - char * base; - char * limit, * new_limit; - - if (!GC_no_win32_dlls) return; - p = base = limit = GC_least_described_address(static_root); - while ((word)p < (word)GC_sysinfo.lpMaximumApplicationAddress) { - result = VirtualQuery(p, &buf, sizeof(buf)); - if (result != sizeof(buf) || buf.AllocationBase == 0 - || GC_is_heap_base(buf.AllocationBase)) break; - new_limit = (char *)p + buf.RegionSize; - protect = buf.Protect; - if (buf.State == MEM_COMMIT - && is_writable(protect)) { - if ((char *)p == limit) { - limit = new_limit; - } else { - if (base != limit) GC_add_roots_inner(base, limit, FALSE); - base = p; - limit = new_limit; - } - } - if ((word)p > (word)new_limit /* overflow */) break; - p = (LPVOID)new_limit; - } - if (base != limit) GC_add_roots_inner(base, limit, FALSE); - } -#endif /* MSWIN32 */ - - void GC_register_data_segments(void) - { -# ifdef MSWIN32 - GC_register_root_section((ptr_t)&GC_pages_executable); - /* any other GC global variable would fit too. */ -# endif - } - -# else /* !OS2 && !Windows */ - -# if (defined(SVR4) || defined(AUX) || defined(DGUX) \ - || (defined(LINUX) && defined(SPARC))) && !defined(PCR) - ptr_t GC_SysVGetDataStart(size_t max_page_size, ptr_t etext_addr) - { - word text_end = ((word)(etext_addr) + sizeof(word) - 1) - & ~(sizeof(word) - 1); - /* etext rounded to word boundary */ - word next_page = ((text_end + (word)max_page_size - 1) - & ~((word)max_page_size - 1)); - word page_offset = (text_end & ((word)max_page_size - 1)); - char * volatile result = (char *)(next_page + page_offset); - /* Note that this isn't equivalent to just adding */ - /* max_page_size to &etext if &etext is at a page boundary */ - - GC_setup_temporary_fault_handler(); - if (SETJMP(GC_jmp_buf) == 0) { - /* Try writing to the address. */ - *result = *result; - GC_reset_fault_handler(); - } else { - GC_reset_fault_handler(); - /* We got here via a longjmp. The address is not readable. */ - /* This is known to happen under Solaris 2.4 + gcc, which place */ - /* string constants in the text segment, but after etext. */ - /* Use plan B. Note that we now know there is a gap between */ - /* text and data segments, so plan A bought us something. */ - result = (char *)GC_find_limit((ptr_t)(DATAEND), FALSE); - } - return((ptr_t)result); - } -# endif - -# if defined(FREEBSD) && !defined(PCR) && (defined(I386) || defined(X86_64) \ - || defined(powerpc) || defined(__powerpc__)) - -/* Its unclear whether this should be identical to the above, or */ -/* whether it should apply to non-X86 architectures. */ -/* For now we don't assume that there is always an empty page after */ -/* etext. But in some cases there actually seems to be slightly more. */ -/* This also deals with holes between read-only data and writable data. */ -ptr_t GC_FreeBSDGetDataStart(size_t max_page_size, ptr_t etext_addr) -{ - word text_end = ((word)(etext_addr) + sizeof(word) - 1) - & ~(sizeof(word) - 1); - /* etext rounded to word boundary */ - volatile word next_page = (text_end + (word)max_page_size - 1) - & ~((word)max_page_size - 1); - volatile ptr_t result = (ptr_t)text_end; - GC_setup_temporary_fault_handler(); - if (SETJMP(GC_jmp_buf) == 0) { - /* Try reading at the address. */ - /* This should happen before there is another thread. */ - for (; next_page < (word)(DATAEND); next_page += (word)max_page_size) - *(volatile char *)next_page; - GC_reset_fault_handler(); - } else { - GC_reset_fault_handler(); - /* As above, we go to plan B */ - result = GC_find_limit((ptr_t)(DATAEND), FALSE); - } - return(result); -} - -# endif /* FREEBSD */ - - -#ifdef AMIGA - -# define GC_AMIGA_DS -# include "extra/AmigaOS.c" -# undef GC_AMIGA_DS - -#elif defined(OPENBSD) - -/* Depending on arch alignment, there can be multiple holes */ -/* between DATASTART and DATAEND. Scan in DATASTART .. DATAEND */ -/* and register each region. */ -void GC_register_data_segments(void) -{ - ptr_t region_start = DATASTART; - ptr_t region_end; - - for (;;) { - region_end = GC_find_limit_openbsd(region_start, DATAEND); - GC_add_roots_inner(region_start, region_end, FALSE); - if ((word)region_end >= (word)(DATAEND)) - break; - region_start = GC_skip_hole_openbsd(region_end, DATAEND); - } -} - -# else /* !OS2 && !Windows && !AMIGA && !OPENBSD */ - -void GC_register_data_segments(void) -{ -# if !defined(PCR) && !defined(MACOS) -# if defined(REDIRECT_MALLOC) && defined(GC_SOLARIS_THREADS) - /* As of Solaris 2.3, the Solaris threads implementation */ - /* allocates the data structure for the initial thread with */ - /* sbrk at process startup. It needs to be scanned, so that */ - /* we don't lose some malloc allocated data structures */ - /* hanging from it. We're on thin ice here ... */ - extern caddr_t sbrk(int); - - GC_ASSERT(DATASTART); - { - ptr_t p = (ptr_t)sbrk(0); - if ((word)(DATASTART) < (word)p) - GC_add_roots_inner(DATASTART, p, FALSE); - } -# else - GC_ASSERT(DATASTART); - GC_add_roots_inner(DATASTART, (ptr_t)(DATAEND), FALSE); -# if defined(DATASTART2) - GC_add_roots_inner(DATASTART2, (ptr_t)(DATAEND2), FALSE); -# endif -# endif -# endif -# if defined(MACOS) - { -# if defined(THINK_C) - extern void* GC_MacGetDataStart(void); - /* globals begin above stack and end at a5. */ - GC_add_roots_inner((ptr_t)GC_MacGetDataStart(), - (ptr_t)LMGetCurrentA5(), FALSE); -# else -# if defined(__MWERKS__) -# if !__POWERPC__ - extern void* GC_MacGetDataStart(void); - /* MATTHEW: Function to handle Far Globals (CW Pro 3) */ -# if __option(far_data) - extern void* GC_MacGetDataEnd(void); -# endif - /* globals begin above stack and end at a5. */ - GC_add_roots_inner((ptr_t)GC_MacGetDataStart(), - (ptr_t)LMGetCurrentA5(), FALSE); - /* MATTHEW: Handle Far Globals */ -# if __option(far_data) - /* Far globals follow he QD globals: */ - GC_add_roots_inner((ptr_t)LMGetCurrentA5(), - (ptr_t)GC_MacGetDataEnd(), FALSE); -# endif -# else - extern char __data_start__[], __data_end__[]; - GC_add_roots_inner((ptr_t)&__data_start__, - (ptr_t)&__data_end__, FALSE); -# endif /* __POWERPC__ */ -# endif /* __MWERKS__ */ -# endif /* !THINK_C */ - } -# endif /* MACOS */ - - /* Dynamic libraries are added at every collection, since they may */ - /* change. */ -} - -# endif /* !AMIGA */ -# endif /* !MSWIN32 && !MSWINCE */ -# endif /* !OS2 */ - -/* - * Auxiliary routines for obtaining memory from OS. - */ - -# if !defined(OS2) && !defined(PCR) && !defined(AMIGA) \ - && !defined(USE_WINALLOC) && !defined(MACOS) && !defined(DOS4GW) \ - && !defined(NONSTOP) && !defined(SN_TARGET_PS3) && !defined(RTEMS) \ - && !defined(__CC_ARM) - -# define SBRK_ARG_T ptrdiff_t - -#if defined(MMAP_SUPPORTED) - -#ifdef USE_MMAP_FIXED -# define GC_MMAP_FLAGS MAP_FIXED | MAP_PRIVATE - /* Seems to yield better performance on Solaris 2, but can */ - /* be unreliable if something is already mapped at the address. */ -#else -# define GC_MMAP_FLAGS MAP_PRIVATE -#endif - -#ifdef USE_MMAP_ANON -# define zero_fd -1 -# if defined(MAP_ANONYMOUS) -# define OPT_MAP_ANON MAP_ANONYMOUS -# else -# define OPT_MAP_ANON MAP_ANON -# endif -#else - static int zero_fd; -# define OPT_MAP_ANON 0 -#endif - -#ifndef HEAP_START -# define HEAP_START ((ptr_t)0) -#endif - -#ifdef SYMBIAN - extern char* GC_get_private_path_and_zero_file(void); -#endif - -STATIC ptr_t GC_unix_mmap_get_mem(word bytes) -{ - void *result; - static ptr_t last_addr = HEAP_START; - -# ifndef USE_MMAP_ANON - static GC_bool initialized = FALSE; - - if (!EXPECT(initialized, TRUE)) { -# ifdef SYMBIAN - char* path = GC_get_private_path_and_zero_file(); - zero_fd = open(path, O_RDWR | O_CREAT, 0666); - free(path); -# else - zero_fd = open("/dev/zero", O_RDONLY); -# endif - if (zero_fd == -1) - ABORT("Could not open /dev/zero"); - - fcntl(zero_fd, F_SETFD, FD_CLOEXEC); - initialized = TRUE; - } -# endif - - if (bytes & (GC_page_size - 1)) ABORT("Bad GET_MEM arg"); - result = mmap(last_addr, bytes, (PROT_READ | PROT_WRITE) - | (GC_pages_executable ? PROT_EXEC : 0), - GC_MMAP_FLAGS | OPT_MAP_ANON, zero_fd, 0/* offset */); -# undef IGNORE_PAGES_EXECUTABLE - - if (result == MAP_FAILED) return(0); - last_addr = (ptr_t)ROUNDUP_PAGESIZE((word)result + bytes); -# if !defined(LINUX) - if (last_addr == 0) { - /* Oops. We got the end of the address space. This isn't */ - /* usable by arbitrary C code, since one-past-end pointers */ - /* don't work, so we discard it and try again. */ - munmap(result, (size_t)(-GC_page_size) - (size_t)result); - /* Leave last page mapped, so we can't repeat. */ - return GC_unix_mmap_get_mem(bytes); - } -# else - GC_ASSERT(last_addr != 0); -# endif - if (((word)result % HBLKSIZE) != 0) - ABORT( - "GC_unix_get_mem: Memory returned by mmap is not aligned to HBLKSIZE."); - return((ptr_t)result); -} - -# endif /* MMAP_SUPPORTED */ - -#if defined(USE_MMAP) - ptr_t GC_unix_get_mem(word bytes) - { - return GC_unix_mmap_get_mem(bytes); - } -#else /* !USE_MMAP */ - -STATIC ptr_t GC_unix_sbrk_get_mem(word bytes) -{ - ptr_t result; -# ifdef IRIX5 - /* Bare sbrk isn't thread safe. Play by malloc rules. */ - /* The equivalent may be needed on other systems as well. */ - __LOCK_MALLOC(); -# endif - { - ptr_t cur_brk = (ptr_t)sbrk(0); - SBRK_ARG_T lsbs = (word)cur_brk & (GC_page_size-1); - - if ((SBRK_ARG_T)bytes < 0) { - result = 0; /* too big */ - goto out; - } - if (lsbs != 0) { - if((ptr_t)sbrk(GC_page_size - lsbs) == (ptr_t)(-1)) { - result = 0; - goto out; - } - } -# ifdef ADD_HEAP_GUARD_PAGES - /* This is useful for catching severe memory overwrite problems that */ - /* span heap sections. It shouldn't otherwise be turned on. */ - { - ptr_t guard = (ptr_t)sbrk((SBRK_ARG_T)GC_page_size); - if (mprotect(guard, GC_page_size, PROT_NONE) != 0) - ABORT("ADD_HEAP_GUARD_PAGES: mprotect failed"); - } -# endif /* ADD_HEAP_GUARD_PAGES */ - result = (ptr_t)sbrk((SBRK_ARG_T)bytes); - if (result == (ptr_t)(-1)) result = 0; - } - out: -# ifdef IRIX5 - __UNLOCK_MALLOC(); -# endif - return(result); -} - -ptr_t GC_unix_get_mem(word bytes) -{ -# if defined(MMAP_SUPPORTED) - /* By default, we try both sbrk and mmap, in that order. */ - static GC_bool sbrk_failed = FALSE; - ptr_t result = 0; - - if (!sbrk_failed) result = GC_unix_sbrk_get_mem(bytes); - if (0 == result) { - sbrk_failed = TRUE; - result = GC_unix_mmap_get_mem(bytes); - } - if (0 == result) { - /* Try sbrk again, in case sbrk memory became available. */ - result = GC_unix_sbrk_get_mem(bytes); - } - return result; -# else /* !MMAP_SUPPORTED */ - return GC_unix_sbrk_get_mem(bytes); -# endif -} - -#endif /* !USE_MMAP */ - -# endif /* UN*X */ - -# ifdef OS2 - -void * os2_alloc(size_t bytes) -{ - void * result; - - if (DosAllocMem(&result, bytes, (PAG_READ | PAG_WRITE | PAG_COMMIT) - | (GC_pages_executable ? PAG_EXECUTE : 0)) - != NO_ERROR) { - return(0); - } - /* FIXME: What's the purpose of this recursion? (Probably, if */ - /* DosAllocMem returns memory at 0 address then just retry once.) */ - if (result == 0) return(os2_alloc(bytes)); - return(result); -} - -# endif /* OS2 */ - -#ifdef MSWINCE - ptr_t GC_wince_get_mem(word bytes) - { - ptr_t result = 0; /* initialized to prevent warning. */ - word i; - - bytes = ROUNDUP_PAGESIZE(bytes); - - /* Try to find reserved, uncommitted pages */ - for (i = 0; i < GC_n_heap_bases; i++) { - if (((word)(-(signed_word)GC_heap_lengths[i]) - & (GC_sysinfo.dwAllocationGranularity-1)) - >= bytes) { - result = GC_heap_bases[i] + GC_heap_lengths[i]; - break; - } - } - - if (i == GC_n_heap_bases) { - /* Reserve more pages */ - word res_bytes = (bytes + GC_sysinfo.dwAllocationGranularity-1) - & ~(GC_sysinfo.dwAllocationGranularity-1); - /* If we ever support MPROTECT_VDB here, we will probably need to */ - /* ensure that res_bytes is strictly > bytes, so that VirtualProtect */ - /* never spans regions. It seems to be OK for a VirtualFree */ - /* argument to span regions, so we should be OK for now. */ - result = (ptr_t) VirtualAlloc(NULL, res_bytes, - MEM_RESERVE | MEM_TOP_DOWN, - GC_pages_executable ? PAGE_EXECUTE_READWRITE : - PAGE_READWRITE); - if (HBLKDISPL(result) != 0) ABORT("Bad VirtualAlloc result"); - /* If I read the documentation correctly, this can */ - /* only happen if HBLKSIZE > 64k or not a power of 2. */ - if (GC_n_heap_bases >= MAX_HEAP_SECTS) ABORT("Too many heap sections"); - if (result == NULL) return NULL; - GC_heap_bases[GC_n_heap_bases] = result; - GC_heap_lengths[GC_n_heap_bases] = 0; - GC_n_heap_bases++; - } - - /* Commit pages */ - result = (ptr_t) VirtualAlloc(result, bytes, MEM_COMMIT, - GC_pages_executable ? PAGE_EXECUTE_READWRITE : - PAGE_READWRITE); -# undef IGNORE_PAGES_EXECUTABLE - - if (result != NULL) { - if (HBLKDISPL(result) != 0) ABORT("Bad VirtualAlloc result"); - GC_heap_lengths[i] += bytes; - } - - return(result); - } - -#elif defined(USE_WINALLOC) || defined(CYGWIN32) - -# ifdef USE_GLOBAL_ALLOC -# define GLOBAL_ALLOC_TEST 1 -# else -# define GLOBAL_ALLOC_TEST GC_no_win32_dlls -# endif - -# if defined(GC_USE_MEM_TOP_DOWN) && defined(USE_WINALLOC) - DWORD GC_mem_top_down = MEM_TOP_DOWN; - /* Use GC_USE_MEM_TOP_DOWN for better 64-bit */ - /* testing. Otherwise all addresses tend to */ - /* end up in first 4GB, hiding bugs. */ -# else -# define GC_mem_top_down 0 -# endif /* !GC_USE_MEM_TOP_DOWN */ - - ptr_t GC_win32_get_mem(word bytes) - { - ptr_t result; - -# ifndef USE_WINALLOC - result = GC_unix_get_mem(bytes); -# else -# ifdef MSWIN32 - if (GLOBAL_ALLOC_TEST) { - /* VirtualAlloc doesn't like PAGE_EXECUTE_READWRITE. */ - /* There are also unconfirmed rumors of other */ - /* problems, so we dodge the issue. */ - result = (ptr_t) GlobalAlloc(0, bytes + HBLKSIZE); - result = (ptr_t)(((word)result + HBLKSIZE - 1) & ~(HBLKSIZE-1)); - } else -# endif - /* else */ { - /* VirtualProtect only works on regions returned by a */ - /* single VirtualAlloc call. Thus we allocate one */ - /* extra page, which will prevent merging of blocks */ - /* in separate regions, and eliminate any temptation */ - /* to call VirtualProtect on a range spanning regions. */ - /* This wastes a small amount of memory, and risks */ - /* increased fragmentation. But better alternatives */ - /* would require effort. */ -# ifdef MPROTECT_VDB - /* We can't check for GC_incremental here (because */ - /* GC_enable_incremental() might be called some time */ - /* later after the GC initialization). */ -# ifdef GWW_VDB -# define VIRTUAL_ALLOC_PAD (GC_GWW_AVAILABLE() ? 0 : 1) -# else -# define VIRTUAL_ALLOC_PAD 1 -# endif -# else -# define VIRTUAL_ALLOC_PAD 0 -# endif - /* Pass the MEM_WRITE_WATCH only if GetWriteWatch-based */ - /* VDBs are enabled and the GetWriteWatch function is */ - /* available. Otherwise we waste resources or possibly */ - /* cause VirtualAlloc to fail (observed in Windows 2000 */ - /* SP2). */ - result = (ptr_t) VirtualAlloc(NULL, bytes + VIRTUAL_ALLOC_PAD, - GetWriteWatch_alloc_flag - | (MEM_COMMIT | MEM_RESERVE) - | GC_mem_top_down, - GC_pages_executable ? PAGE_EXECUTE_READWRITE : - PAGE_READWRITE); -# undef IGNORE_PAGES_EXECUTABLE - } -# endif /* USE_WINALLOC */ - if (HBLKDISPL(result) != 0) ABORT("Bad VirtualAlloc result"); - /* If I read the documentation correctly, this can */ - /* only happen if HBLKSIZE > 64k or not a power of 2. */ - if (GC_n_heap_bases >= MAX_HEAP_SECTS) ABORT("Too many heap sections"); - if (0 != result) GC_heap_bases[GC_n_heap_bases++] = result; - return(result); - } - - GC_API void GC_CALL GC_win32_free_heap(void) - { -# ifndef CYGWIN32 - if (GLOBAL_ALLOC_TEST) -# endif - { - while (GC_n_heap_bases-- > 0) { -# ifdef CYGWIN32 - /* FIXME: Is it OK to use non-GC free() here? */ -# else - GlobalFree(GC_heap_bases[GC_n_heap_bases]); -# endif - GC_heap_bases[GC_n_heap_bases] = 0; - } - } /* else */ -# ifndef CYGWIN32 - else { - /* Avoiding VirtualAlloc leak. */ - while (GC_n_heap_bases > 0) { - VirtualFree(GC_heap_bases[--GC_n_heap_bases], 0, MEM_RELEASE); - GC_heap_bases[GC_n_heap_bases] = 0; - } - } -# endif - } -#endif /* USE_WINALLOC || CYGWIN32 */ - -#ifdef AMIGA -# define GC_AMIGA_AM -# include "extra/AmigaOS.c" -# undef GC_AMIGA_AM -#endif - -#ifdef USE_MUNMAP - -/* For now, this only works on Win32/WinCE and some Unix-like */ -/* systems. If you have something else, don't define */ -/* USE_MUNMAP. */ - -#if !defined(MSWIN32) && !defined(MSWINCE) -# include -# include -# include -# include -#endif - -/* Compute a page aligned starting address for the unmap */ -/* operation on a block of size bytes starting at start. */ -/* Return 0 if the block is too small to make this feasible. */ -STATIC ptr_t GC_unmap_start(ptr_t start, size_t bytes) -{ - ptr_t result = (ptr_t)ROUNDUP_PAGESIZE((word)start); - - if ((word)(result + GC_page_size) > (word)(start + bytes)) return 0; - return result; -} - -/* Compute end address for an unmap operation on the indicated */ -/* block. */ -STATIC ptr_t GC_unmap_end(ptr_t start, size_t bytes) -{ - return (ptr_t)((word)(start + bytes) & ~(GC_page_size - 1)); -} - -/* Under Win32/WinCE we commit (map) and decommit (unmap) */ -/* memory using VirtualAlloc and VirtualFree. These functions */ -/* work on individual allocations of virtual memory, made */ -/* previously using VirtualAlloc with the MEM_RESERVE flag. */ -/* The ranges we need to (de)commit may span several of these */ -/* allocations; therefore we use VirtualQuery to check */ -/* allocation lengths, and split up the range as necessary. */ - -/* We assume that GC_remap is called on exactly the same range */ -/* as a previous call to GC_unmap. It is safe to consistently */ -/* round the endpoints in both places. */ -GC_INNER void GC_unmap(ptr_t start, size_t bytes) -{ - ptr_t start_addr = GC_unmap_start(start, bytes); - ptr_t end_addr = GC_unmap_end(start, bytes); - word len = end_addr - start_addr; - - if (0 == start_addr) return; -# ifdef USE_WINALLOC - while (len != 0) { - MEMORY_BASIC_INFORMATION mem_info; - GC_word free_len; - - if (VirtualQuery(start_addr, &mem_info, sizeof(mem_info)) - != sizeof(mem_info)) - ABORT("Weird VirtualQuery result"); - free_len = (len < mem_info.RegionSize) ? len : mem_info.RegionSize; - if (!VirtualFree(start_addr, free_len, MEM_DECOMMIT)) - ABORT("VirtualFree failed"); - GC_unmapped_bytes += free_len; - start_addr += free_len; - len -= free_len; - } -# else - /* We immediately remap it to prevent an intervening mmap from */ - /* accidentally grabbing the same address space. */ - { - void * result; - - result = mmap(start_addr, len, PROT_NONE, - MAP_PRIVATE | MAP_FIXED | OPT_MAP_ANON, - zero_fd, 0/* offset */); - if (result != (void *)start_addr) - ABORT("mmap(PROT_NONE) failed"); - } - GC_unmapped_bytes += len; -# endif -} - -GC_INNER void GC_remap(ptr_t start, size_t bytes) -{ - ptr_t start_addr = GC_unmap_start(start, bytes); - ptr_t end_addr = GC_unmap_end(start, bytes); - word len = end_addr - start_addr; - if (0 == start_addr) return; - - /* FIXME: Handle out-of-memory correctly (at least for Win32) */ -# ifdef USE_WINALLOC - while (len != 0) { - MEMORY_BASIC_INFORMATION mem_info; - GC_word alloc_len; - ptr_t result; - - if (VirtualQuery(start_addr, &mem_info, sizeof(mem_info)) - != sizeof(mem_info)) - ABORT("Weird VirtualQuery result"); - alloc_len = (len < mem_info.RegionSize) ? len : mem_info.RegionSize; - result = VirtualAlloc(start_addr, alloc_len, MEM_COMMIT, - GC_pages_executable ? PAGE_EXECUTE_READWRITE : - PAGE_READWRITE); - if (result != start_addr) { - if (GetLastError() == ERROR_NOT_ENOUGH_MEMORY || - GetLastError() == ERROR_OUTOFMEMORY) { - ABORT("Not enough memory to process remapping"); - } else { - ABORT("VirtualAlloc remapping failed"); - } - } - GC_unmapped_bytes -= alloc_len; - start_addr += alloc_len; - len -= alloc_len; - } -# else - /* It was already remapped with PROT_NONE. */ - { -# ifdef NACL - /* NaCl does not expose mprotect, but mmap should work fine. */ - void *mmap_result = mmap(start_addr, len, (PROT_READ | PROT_WRITE) - | (GC_pages_executable ? PROT_EXEC : 0), - MAP_PRIVATE | MAP_FIXED | OPT_MAP_ANON, - zero_fd, 0 /* offset */); - if (mmap_result != (void *)start_addr) - ABORT("mmap as mprotect failed"); -# else - if (mprotect(start_addr, len, (PROT_READ | PROT_WRITE) - | (GC_pages_executable ? PROT_EXEC : 0)) != 0) { - ABORT_ARG3("mprotect remapping failed", - " at %p (length %lu), errcode= %d", - start_addr, (unsigned long)len, errno); - } -# endif /* !NACL */ - } -# undef IGNORE_PAGES_EXECUTABLE - GC_unmapped_bytes -= len; -# endif -} - -/* Two adjacent blocks have already been unmapped and are about to */ -/* be merged. Unmap the whole block. This typically requires */ -/* that we unmap a small section in the middle that was not previously */ -/* unmapped due to alignment constraints. */ -GC_INNER void GC_unmap_gap(ptr_t start1, size_t bytes1, ptr_t start2, - size_t bytes2) -{ - ptr_t start1_addr = GC_unmap_start(start1, bytes1); - ptr_t end1_addr = GC_unmap_end(start1, bytes1); - ptr_t start2_addr = GC_unmap_start(start2, bytes2); - ptr_t start_addr = end1_addr; - ptr_t end_addr = start2_addr; - size_t len; - - GC_ASSERT(start1 + bytes1 == start2); - if (0 == start1_addr) start_addr = GC_unmap_start(start1, bytes1 + bytes2); - if (0 == start2_addr) end_addr = GC_unmap_end(start1, bytes1 + bytes2); - if (0 == start_addr) return; - len = end_addr - start_addr; -# ifdef USE_WINALLOC - while (len != 0) { - MEMORY_BASIC_INFORMATION mem_info; - GC_word free_len; - - if (VirtualQuery(start_addr, &mem_info, sizeof(mem_info)) - != sizeof(mem_info)) - ABORT("Weird VirtualQuery result"); - free_len = (len < mem_info.RegionSize) ? len : mem_info.RegionSize; - if (!VirtualFree(start_addr, free_len, MEM_DECOMMIT)) - ABORT("VirtualFree failed"); - GC_unmapped_bytes += free_len; - start_addr += free_len; - len -= free_len; - } -# else - if (len != 0) { - /* Immediately remap as above. */ - void * result; - result = mmap(start_addr, len, PROT_NONE, - MAP_PRIVATE | MAP_FIXED | OPT_MAP_ANON, - zero_fd, 0/* offset */); - if (result != (void *)start_addr) - ABORT("mmap(PROT_NONE) failed"); - } - GC_unmapped_bytes += len; -# endif -} - -#endif /* USE_MUNMAP */ - -/* Routine for pushing any additional roots. In THREADS */ -/* environment, this is also responsible for marking from */ -/* thread stacks. */ -#ifndef THREADS - GC_push_other_roots_proc GC_push_other_roots = 0; -#else /* THREADS */ - -# ifdef PCR -PCR_ERes GC_push_thread_stack(PCR_Th_T *t, PCR_Any dummy) -{ - struct PCR_ThCtl_TInfoRep info; - PCR_ERes result; - - info.ti_stkLow = info.ti_stkHi = 0; - result = PCR_ThCtl_GetInfo(t, &info); - GC_push_all_stack((ptr_t)(info.ti_stkLow), (ptr_t)(info.ti_stkHi)); - return(result); -} - -/* Push the contents of an old object. We treat this as stack */ -/* data only because that makes it robust against mark stack */ -/* overflow. */ -PCR_ERes GC_push_old_obj(void *p, size_t size, PCR_Any data) -{ - GC_push_all_stack((ptr_t)p, (ptr_t)p + size); - return(PCR_ERes_okay); -} - -extern struct PCR_MM_ProcsRep * GC_old_allocator; - /* defined in pcr_interface.c. */ - -STATIC void GC_CALLBACK GC_default_push_other_roots(void) -{ - /* Traverse data allocated by previous memory managers. */ - if ((*(GC_old_allocator->mmp_enumerate))(PCR_Bool_false, - GC_push_old_obj, 0) - != PCR_ERes_okay) { - ABORT("Old object enumeration failed"); - } - /* Traverse all thread stacks. */ - if (PCR_ERes_IsErr( - PCR_ThCtl_ApplyToAllOtherThreads(GC_push_thread_stack,0)) - || PCR_ERes_IsErr(GC_push_thread_stack(PCR_Th_CurrThread(), 0))) { - ABORT("Thread stack marking failed"); - } -} - -# endif /* PCR */ - -# if defined(GC_PTHREADS) || defined(GC_WIN32_THREADS) - STATIC void GC_CALLBACK GC_default_push_other_roots(void) - { - GC_push_all_stacks(); - } -# endif /* GC_WIN32_THREADS || GC_PTHREADS */ - -# ifdef SN_TARGET_PS3 - STATIC void GC_CALLBACK GC_default_push_other_roots(void) - { - ABORT("GC_default_push_other_roots is not implemented"); - } - - void GC_push_thread_structures(void) - { - ABORT("GC_push_thread_structures is not implemented"); - } -# endif /* SN_TARGET_PS3 */ - - GC_push_other_roots_proc GC_push_other_roots = GC_default_push_other_roots; -#endif /* THREADS */ - -GC_API void GC_CALL GC_set_push_other_roots(GC_push_other_roots_proc fn) -{ - GC_push_other_roots = fn; -} - -GC_API GC_push_other_roots_proc GC_CALL GC_get_push_other_roots(void) -{ - return GC_push_other_roots; -} - -/* - * Routines for accessing dirty bits on virtual pages. - * There are six ways to maintain this information: - * DEFAULT_VDB: A simple dummy implementation that treats every page - * as possibly dirty. This makes incremental collection - * useless, but the implementation is still correct. - * MANUAL_VDB: Stacks and static data are always considered dirty. - * Heap pages are considered dirty if GC_dirty(p) has been - * called on some pointer p pointing to somewhere inside - * an object on that page. A GC_dirty() call on a large - * object directly dirties only a single page, but for - * MANUAL_VDB we are careful to treat an object with a dirty - * page as completely dirty. - * In order to avoid races, an object must be marked dirty - * after it is written, and a reference to the object - * must be kept on a stack or in a register in the interim. - * With threads enabled, an object directly reachable from the - * stack at the time of a collection is treated as dirty. - * In single-threaded mode, it suffices to ensure that no - * collection can take place between the pointer assignment - * and the GC_dirty() call. - * PCR_VDB: Use PPCRs virtual dirty bit facility. - * PROC_VDB: Use the /proc facility for reading dirty bits. Only - * works under some SVR4 variants. Even then, it may be - * too slow to be entirely satisfactory. Requires reading - * dirty bits for entire address space. Implementations tend - * to assume that the client is a (slow) debugger. - * MPROTECT_VDB:Protect pages and then catch the faults to keep track of - * dirtied pages. The implementation (and implementability) - * is highly system dependent. This usually fails when system - * calls write to a protected page. We prevent the read system - * call from doing so. It is the clients responsibility to - * make sure that other system calls are similarly protected - * or write only to the stack. - * GWW_VDB: Use the Win32 GetWriteWatch functions, if available, to - * read dirty bits. In case it is not available (because we - * are running on Windows 95, Windows 2000 or earlier), - * MPROTECT_VDB may be defined as a fallback strategy. - */ -#ifndef GC_DISABLE_INCREMENTAL - GC_INNER GC_bool GC_dirty_maintained = FALSE; -#endif - -#if defined(PROC_VDB) || defined(GWW_VDB) - /* Add all pages in pht2 to pht1 */ - STATIC void GC_or_pages(page_hash_table pht1, page_hash_table pht2) - { - register unsigned i; - for (i = 0; i < PHT_SIZE; i++) pht1[i] |= pht2[i]; - } - -# ifdef MPROTECT_VDB - STATIC GC_bool GC_gww_page_was_dirty(struct hblk * h) -# else - GC_INNER GC_bool GC_page_was_dirty(struct hblk * h) -# endif - { - register word index; - if (HDR(h) == 0) - return TRUE; - index = PHT_HASH(h); - return get_pht_entry_from_index(GC_grungy_pages, index); - } - -# if defined(CHECKSUMS) || defined(PROC_VDB) - /* Used only if GWW_VDB. */ -# ifdef MPROTECT_VDB - STATIC GC_bool GC_gww_page_was_ever_dirty(struct hblk * h) -# else - GC_INNER GC_bool GC_page_was_ever_dirty(struct hblk * h) -# endif - { - register word index; - if (HDR(h) == 0) - return TRUE; - index = PHT_HASH(h); - return get_pht_entry_from_index(GC_written_pages, index); - } -# endif /* CHECKSUMS || PROC_VDB */ - -# ifndef MPROTECT_VDB - /* Ignore write hints. They don't help us here. */ - GC_INNER void GC_remove_protection(struct hblk * h GC_ATTR_UNUSED, - word nblocks GC_ATTR_UNUSED, - GC_bool is_ptrfree GC_ATTR_UNUSED) {} -# endif - -#endif /* PROC_VDB || GWW_VDB */ - -#ifdef GWW_VDB - -# define GC_GWW_BUF_LEN (MAXHINCR * HBLKSIZE / 4096 /* X86 page size */) - /* Still susceptible to overflow, if there are very large allocations, */ - /* and everything is dirty. */ - static PVOID gww_buf[GC_GWW_BUF_LEN]; - -# ifdef MPROTECT_VDB - GC_INNER GC_bool GC_gww_dirty_init(void) - { - detect_GetWriteWatch(); - return GC_GWW_AVAILABLE(); - } -# else - GC_INNER void GC_dirty_init(void) - { - detect_GetWriteWatch(); - GC_dirty_maintained = GC_GWW_AVAILABLE(); - } -# endif /* !MPROTECT_VDB */ - -# ifdef MPROTECT_VDB - STATIC void GC_gww_read_dirty(void) -# else - GC_INNER void GC_read_dirty(void) -# endif - { - word i; - - BZERO(GC_grungy_pages, sizeof(GC_grungy_pages)); - - for (i = 0; i != GC_n_heap_sects; ++i) { - GC_ULONG_PTR count; - - do { - PVOID * pages, * pages_end; - DWORD page_size; - - pages = gww_buf; - count = GC_GWW_BUF_LEN; - /* GetWriteWatch is documented as returning non-zero when it */ - /* fails, but the documentation doesn't explicitly say why it */ - /* would fail or what its behaviour will be if it fails. */ - /* It does appear to fail, at least on recent W2K instances, if */ - /* the underlying memory was not allocated with the appropriate */ - /* flag. This is common if GC_enable_incremental is called */ - /* shortly after GC initialization. To avoid modifying the */ - /* interface, we silently work around such a failure, it only */ - /* affects the initial (small) heap allocation. If there are */ - /* more dirty pages than will fit in the buffer, this is not */ - /* treated as a failure; we must check the page count in the */ - /* loop condition. Since each partial call will reset the */ - /* status of some pages, this should eventually terminate even */ - /* in the overflow case. */ - if (GetWriteWatch_func(WRITE_WATCH_FLAG_RESET, - GC_heap_sects[i].hs_start, - GC_heap_sects[i].hs_bytes, - pages, - &count, - &page_size) != 0) { - static int warn_count = 0; - unsigned j; - struct hblk * start = (struct hblk *)GC_heap_sects[i].hs_start; - static struct hblk *last_warned = 0; - size_t nblocks = divHBLKSZ(GC_heap_sects[i].hs_bytes); - - if ( i != 0 && last_warned != start && warn_count++ < 5) { - last_warned = start; - WARN( - "GC_gww_read_dirty unexpectedly failed at %p: " - "Falling back to marking all pages dirty\n", start); - } - for (j = 0; j < nblocks; ++j) { - word hash = PHT_HASH(start + j); - set_pht_entry_from_index(GC_grungy_pages, hash); - } - count = 1; /* Done with this section. */ - } else /* succeeded */ { - pages_end = pages + count; - while (pages != pages_end) { - struct hblk * h = (struct hblk *) *pages++; - struct hblk * h_end = (struct hblk *) ((char *) h + page_size); - do { - set_pht_entry_from_index(GC_grungy_pages, PHT_HASH(h)); - } while ((word)(++h) < (word)h_end); - } - } - } while (count == GC_GWW_BUF_LEN); - /* FIXME: It's unclear from Microsoft's documentation if this loop */ - /* is useful. We suspect the call just fails if the buffer fills */ - /* up. But that should still be handled correctly. */ - } - - GC_or_pages(GC_written_pages, GC_grungy_pages); - } -#endif /* GWW_VDB */ - -#ifdef DEFAULT_VDB - /* All of the following assume the allocation lock is held. */ - - /* The client asserts that unallocated pages in the heap are never */ - /* written. */ - - /* Initialize virtual dirty bit implementation. */ - GC_INNER void GC_dirty_init(void) - { - GC_VERBOSE_LOG_PRINTF("Initializing DEFAULT_VDB...\n"); - GC_dirty_maintained = TRUE; - } - - /* Retrieve system dirty bits for heap to a local buffer. */ - /* Restore the systems notion of which pages are dirty. */ - GC_INNER void GC_read_dirty(void) {} - - /* Is the HBLKSIZE sized page at h marked dirty in the local buffer? */ - /* If the actual page size is different, this returns TRUE if any */ - /* of the pages overlapping h are dirty. This routine may err on the */ - /* side of labeling pages as dirty (and this implementation does). */ - GC_INNER GC_bool GC_page_was_dirty(struct hblk * h GC_ATTR_UNUSED) - { - return(TRUE); - } - - /* The following two routines are typically less crucial. */ - /* They matter most with large dynamic libraries, or if we can't */ - /* accurately identify stacks, e.g. under Solaris 2.X. Otherwise the */ - /* following default versions are adequate. */ -# ifdef CHECKSUMS - /* Could any valid GC heap pointer ever have been written to this page? */ - GC_INNER GC_bool GC_page_was_ever_dirty(struct hblk * h GC_ATTR_UNUSED) - { - return(TRUE); - } -# endif /* CHECKSUMS */ - - /* A call that: */ - /* I) hints that [h, h+nblocks) is about to be written. */ - /* II) guarantees that protection is removed. */ - /* (I) may speed up some dirty bit implementations. */ - /* (II) may be essential if we need to ensure that */ - /* pointer-free system call buffers in the heap are */ - /* not protected. */ - GC_INNER void GC_remove_protection(struct hblk * h GC_ATTR_UNUSED, - word nblocks GC_ATTR_UNUSED, - GC_bool is_ptrfree GC_ATTR_UNUSED) {} -#endif /* DEFAULT_VDB */ - -#ifdef MANUAL_VDB - /* Initialize virtual dirty bit implementation. */ - GC_INNER void GC_dirty_init(void) - { - GC_VERBOSE_LOG_PRINTF("Initializing MANUAL_VDB...\n"); - /* GC_dirty_pages and GC_grungy_pages are already cleared. */ - GC_dirty_maintained = TRUE; - } - - /* Retrieve system dirty bits for heap to a local buffer. */ - /* Restore the systems notion of which pages are dirty. */ - GC_INNER void GC_read_dirty(void) - { - BCOPY((word *)GC_dirty_pages, GC_grungy_pages, - (sizeof GC_dirty_pages)); - BZERO((word *)GC_dirty_pages, (sizeof GC_dirty_pages)); - } - - /* Is the HBLKSIZE sized page at h marked dirty in the local buffer? */ - /* If the actual page size is different, this returns TRUE if any */ - /* of the pages overlapping h are dirty. This routine may err on the */ - /* side of labeling pages as dirty (and this implementation does). */ - GC_INNER GC_bool GC_page_was_dirty(struct hblk *h) - { - register word index = PHT_HASH(h); - return(HDR(h) == 0 || get_pht_entry_from_index(GC_grungy_pages, index)); - } - -# define async_set_pht_entry_from_index(db, index) \ - set_pht_entry_from_index(db, index) /* for now */ - - /* Mark the page containing p as dirty. Logically, this dirties the */ - /* entire object. */ - void GC_dirty(ptr_t p) - { - word index = PHT_HASH(p); - async_set_pht_entry_from_index(GC_dirty_pages, index); - } - - GC_INNER void GC_remove_protection(struct hblk * h GC_ATTR_UNUSED, - word nblocks GC_ATTR_UNUSED, - GC_bool is_ptrfree GC_ATTR_UNUSED) {} - -# ifdef CHECKSUMS - /* Could any valid GC heap pointer ever have been written to this page? */ - GC_INNER GC_bool GC_page_was_ever_dirty(struct hblk * h GC_ATTR_UNUSED) - { - /* FIXME - implement me. */ - return(TRUE); - } -# endif /* CHECKSUMS */ - -#endif /* MANUAL_VDB */ - -#ifdef MPROTECT_VDB - /* See DEFAULT_VDB for interface descriptions. */ - - /* - * This implementation maintains dirty bits itself by catching write - * faults and keeping track of them. We assume nobody else catches - * SIGBUS or SIGSEGV. We assume no write faults occur in system calls. - * This means that clients must ensure that system calls don't write - * to the write-protected heap. Probably the best way to do this is to - * ensure that system calls write at most to pointer-free objects in the - * heap, and do even that only if we are on a platform on which those - * are not protected. Another alternative is to wrap system calls - * (see example for read below), but the current implementation holds - * applications. - * We assume the page size is a multiple of HBLKSIZE. - * We prefer them to be the same. We avoid protecting pointer-free - * objects only if they are the same. - */ -# ifdef DARWIN - /* Using vm_protect (mach syscall) over mprotect (BSD syscall) seems to - decrease the likelihood of some of the problems described below. */ -# include - STATIC mach_port_t GC_task_self = 0; -# define PROTECT(addr,len) \ - if (vm_protect(GC_task_self, (vm_address_t)(addr), (vm_size_t)(len), \ - FALSE, VM_PROT_READ \ - | (GC_pages_executable ? VM_PROT_EXECUTE : 0)) \ - == KERN_SUCCESS) {} else ABORT("vm_protect(PROTECT) failed") -# define UNPROTECT(addr,len) \ - if (vm_protect(GC_task_self, (vm_address_t)(addr), (vm_size_t)(len), \ - FALSE, (VM_PROT_READ | VM_PROT_WRITE) \ - | (GC_pages_executable ? VM_PROT_EXECUTE : 0)) \ - == KERN_SUCCESS) {} else ABORT("vm_protect(UNPROTECT) failed") - -# elif !defined(USE_WINALLOC) -# include -# include -# include - -# define PROTECT(addr, len) \ - if (mprotect((caddr_t)(addr), (size_t)(len), \ - PROT_READ \ - | (GC_pages_executable ? PROT_EXEC : 0)) >= 0) { \ - } else ABORT("mprotect failed") -# define UNPROTECT(addr, len) \ - if (mprotect((caddr_t)(addr), (size_t)(len), \ - (PROT_READ | PROT_WRITE) \ - | (GC_pages_executable ? PROT_EXEC : 0)) >= 0) { \ - } else ABORT(GC_pages_executable ? \ - "un-mprotect executable page failed" \ - " (probably disabled by OS)" : \ - "un-mprotect failed") -# undef IGNORE_PAGES_EXECUTABLE - -# else /* USE_WINALLOC */ -# ifndef MSWINCE -# include -# endif - - static DWORD protect_junk; -# define PROTECT(addr, len) \ - if (VirtualProtect((addr), (len), \ - GC_pages_executable ? PAGE_EXECUTE_READ : \ - PAGE_READONLY, \ - &protect_junk)) { \ - } else ABORT_ARG1("VirtualProtect failed", \ - ": errcode= 0x%X", (unsigned)GetLastError()) -# define UNPROTECT(addr, len) \ - if (VirtualProtect((addr), (len), \ - GC_pages_executable ? PAGE_EXECUTE_READWRITE : \ - PAGE_READWRITE, \ - &protect_junk)) { \ - } else ABORT("un-VirtualProtect failed") -# endif /* USE_WINALLOC */ - -# if defined(MSWIN32) - typedef LPTOP_LEVEL_EXCEPTION_FILTER SIG_HNDLR_PTR; -# undef SIG_DFL -# define SIG_DFL (LPTOP_LEVEL_EXCEPTION_FILTER)((signed_word)-1) -# elif defined(MSWINCE) - typedef LONG (WINAPI *SIG_HNDLR_PTR)(struct _EXCEPTION_POINTERS *); -# undef SIG_DFL -# define SIG_DFL (SIG_HNDLR_PTR) (-1) -# elif defined(DARWIN) - typedef void (* SIG_HNDLR_PTR)(); -# else - typedef void (* SIG_HNDLR_PTR)(int, siginfo_t *, void *); - typedef void (* PLAIN_HNDLR_PTR)(int); -# endif - -# if defined(__GLIBC__) -# if __GLIBC__ < 2 || __GLIBC__ == 2 && __GLIBC_MINOR__ < 2 -# error glibc too old? -# endif -# endif - -#ifndef DARWIN - STATIC SIG_HNDLR_PTR GC_old_segv_handler = 0; - /* Also old MSWIN32 ACCESS_VIOLATION filter */ -# if !defined(MSWIN32) && !defined(MSWINCE) - STATIC SIG_HNDLR_PTR GC_old_bus_handler = 0; -# if defined(FREEBSD) || defined(HURD) || defined(HPUX) - STATIC GC_bool GC_old_bus_handler_used_si = FALSE; -# endif - STATIC GC_bool GC_old_segv_handler_used_si = FALSE; -# endif /* !MSWIN32 */ -#endif /* !DARWIN */ - -#if defined(THREADS) -/* We need to lock around the bitmap update in the write fault handler */ -/* in order to avoid the risk of losing a bit. We do this with a */ -/* test-and-set spin lock if we know how to do that. Otherwise we */ -/* check whether we are already in the handler and use the dumb but */ -/* safe fallback algorithm of setting all bits in the word. */ -/* Contention should be very rare, so we do the minimum to handle it */ -/* correctly. */ -#ifdef AO_HAVE_test_and_set_acquire - GC_INNER volatile AO_TS_t GC_fault_handler_lock = AO_TS_INITIALIZER; - static void async_set_pht_entry_from_index(volatile page_hash_table db, - size_t index) - { - while (AO_test_and_set_acquire(&GC_fault_handler_lock) == AO_TS_SET) { - /* empty */ - } - /* Could also revert to set_pht_entry_from_index_safe if initial */ - /* GC_test_and_set fails. */ - set_pht_entry_from_index(db, index); - AO_CLEAR(&GC_fault_handler_lock); - } -#else /* !AO_HAVE_test_and_set_acquire */ -# error No test_and_set operation: Introduces a race. - /* THIS WOULD BE INCORRECT! */ - /* The dirty bit vector may be temporarily wrong, */ - /* just before we notice the conflict and correct it. We may end up */ - /* looking at it while it's wrong. But this requires contention */ - /* exactly when a GC is triggered, which seems far less likely to */ - /* fail than the old code, which had no reported failures. Thus we */ - /* leave it this way while we think of something better, or support */ - /* GC_test_and_set on the remaining platforms. */ - static int * volatile currently_updating = 0; - static void async_set_pht_entry_from_index(volatile page_hash_table db, - size_t index) - { - int update_dummy; - currently_updating = &update_dummy; - set_pht_entry_from_index(db, index); - /* If we get contention in the 10 or so instruction window here, */ - /* and we get stopped by a GC between the two updates, we lose! */ - if (currently_updating != &update_dummy) { - set_pht_entry_from_index_safe(db, index); - /* We claim that if two threads concurrently try to update the */ - /* dirty bit vector, the first one to execute UPDATE_START */ - /* will see it changed when UPDATE_END is executed. (Note that */ - /* &update_dummy must differ in two distinct threads.) It */ - /* will then execute set_pht_entry_from_index_safe, thus */ - /* returning us to a safe state, though not soon enough. */ - } - } -#endif /* !AO_HAVE_test_and_set_acquire */ -#else /* !THREADS */ -# define async_set_pht_entry_from_index(db, index) \ - set_pht_entry_from_index(db, index) -#endif /* !THREADS */ - -#ifdef CHECKSUMS - void GC_record_fault(struct hblk * h); /* from checksums.c */ -#endif - -#ifndef DARWIN - -# if !defined(MSWIN32) && !defined(MSWINCE) -# include -# if defined(FREEBSD) || defined(HURD) || defined(HPUX) -# define SIG_OK (sig == SIGBUS || sig == SIGSEGV) -# else -# define SIG_OK (sig == SIGSEGV) - /* Catch SIGSEGV but ignore SIGBUS. */ -# endif -# if defined(FREEBSD) -# ifndef SEGV_ACCERR -# define SEGV_ACCERR 2 -# endif -# if defined(POWERPC) -# define AIM /* Pretend that we're AIM. */ -# include -# define CODE_OK (si -> si_code == EXC_DSI \ - || si -> si_code == SEGV_ACCERR) -# else -# define CODE_OK (si -> si_code == BUS_PAGE_FAULT \ - || si -> si_code == SEGV_ACCERR) -# endif -# elif defined(OSF1) -# define CODE_OK (si -> si_code == 2 /* experimentally determined */) -# elif defined(IRIX5) -# define CODE_OK (si -> si_code == EACCES) -# elif defined(HURD) -# define CODE_OK TRUE -# elif defined(LINUX) -# define CODE_OK TRUE - /* Empirically c.trapno == 14, on IA32, but is that useful? */ - /* Should probably consider alignment issues on other */ - /* architectures. */ -# elif defined(HPUX) -# define CODE_OK (si -> si_code == SEGV_ACCERR \ - || si -> si_code == BUS_ADRERR \ - || si -> si_code == BUS_UNKNOWN \ - || si -> si_code == SEGV_UNKNOWN \ - || si -> si_code == BUS_OBJERR) -# elif defined(SUNOS5SIGS) -# define CODE_OK (si -> si_code == SEGV_ACCERR) -# endif -# ifndef NO_GETCONTEXT -# include -# endif - STATIC void GC_write_fault_handler(int sig, siginfo_t *si, void *raw_sc) -# else -# define SIG_OK (exc_info -> ExceptionRecord -> ExceptionCode \ - == STATUS_ACCESS_VIOLATION) -# define CODE_OK (exc_info -> ExceptionRecord -> ExceptionInformation[0] \ - == 1) /* Write fault */ - STATIC LONG WINAPI GC_write_fault_handler( - struct _EXCEPTION_POINTERS *exc_info) -# endif /* MSWIN32 || MSWINCE */ - { -# if !defined(MSWIN32) && !defined(MSWINCE) - char *addr = si -> si_addr; -# else - char * addr = (char *) (exc_info -> ExceptionRecord - -> ExceptionInformation[1]); -# endif - unsigned i; - - if (SIG_OK && CODE_OK) { - register struct hblk * h = - (struct hblk *)((word)addr & ~(GC_page_size-1)); - GC_bool in_allocd_block; -# ifdef CHECKSUMS - GC_record_fault(h); -# endif - -# ifdef SUNOS5SIGS - /* Address is only within the correct physical page. */ - in_allocd_block = FALSE; - for (i = 0; i < divHBLKSZ(GC_page_size); i++) { - if (HDR(h+i) != 0) { - in_allocd_block = TRUE; - break; - } - } -# else - in_allocd_block = (HDR(addr) != 0); -# endif - if (!in_allocd_block) { - /* FIXME - We should make sure that we invoke the */ - /* old handler with the appropriate calling */ - /* sequence, which often depends on SA_SIGINFO. */ - - /* Heap blocks now begin and end on page boundaries */ - SIG_HNDLR_PTR old_handler; - -# if defined(MSWIN32) || defined(MSWINCE) - old_handler = GC_old_segv_handler; -# else - GC_bool used_si; - -# if defined(FREEBSD) || defined(HURD) || defined(HPUX) - if (sig == SIGBUS) { - old_handler = GC_old_bus_handler; - used_si = GC_old_bus_handler_used_si; - } else -# endif - /* else */ { - old_handler = GC_old_segv_handler; - used_si = GC_old_segv_handler_used_si; - } -# endif - - if (old_handler == (SIG_HNDLR_PTR)SIG_DFL) { -# if !defined(MSWIN32) && !defined(MSWINCE) - ABORT_ARG1("Unexpected bus error or segmentation fault", - " at %p", addr); -# else - return(EXCEPTION_CONTINUE_SEARCH); -# endif - } else { - /* - * FIXME: This code should probably check if the - * old signal handler used the traditional style and - * if so call it using that style. - */ -# if defined(MSWIN32) || defined(MSWINCE) - return((*old_handler)(exc_info)); -# else - if (used_si) - ((SIG_HNDLR_PTR)old_handler) (sig, si, raw_sc); - else - /* FIXME: should pass nonstandard args as well. */ - ((PLAIN_HNDLR_PTR)old_handler) (sig); - return; -# endif - } - } - UNPROTECT(h, GC_page_size); - /* We need to make sure that no collection occurs between */ - /* the UNPROTECT and the setting of the dirty bit. Otherwise */ - /* a write by a third thread might go unnoticed. Reversing */ - /* the order is just as bad, since we would end up unprotecting */ - /* a page in a GC cycle during which it's not marked. */ - /* Currently we do this by disabling the thread stopping */ - /* signals while this handler is running. An alternative might */ - /* be to record the fact that we're about to unprotect, or */ - /* have just unprotected a page in the GC's thread structure, */ - /* and then to have the thread stopping code set the dirty */ - /* flag, if necessary. */ - for (i = 0; i < divHBLKSZ(GC_page_size); i++) { - size_t index = PHT_HASH(h+i); - - async_set_pht_entry_from_index(GC_dirty_pages, index); - } - /* The write may not take place before dirty bits are read. */ - /* But then we'll fault again ... */ -# if defined(MSWIN32) || defined(MSWINCE) - return(EXCEPTION_CONTINUE_EXECUTION); -# else - return; -# endif - } -# if defined(MSWIN32) || defined(MSWINCE) - return EXCEPTION_CONTINUE_SEARCH; -# else - ABORT_ARG1("Unexpected bus error or segmentation fault", - " at %p", addr); -# endif - } - -# ifdef GC_WIN32_THREADS - GC_INNER void GC_set_write_fault_handler(void) - { - SetUnhandledExceptionFilter(GC_write_fault_handler); - } -# endif -#endif /* !DARWIN */ - -/* We hold the allocation lock. We expect block h to be written */ -/* shortly. Ensure that all pages containing any part of the n hblks */ -/* starting at h are no longer protected. If is_ptrfree is false, also */ -/* ensure that they will subsequently appear to be dirty. Not allowed */ -/* to call GC_printf (and the friends) here, see Win32 GC_stop_world() */ -/* for the information. */ -GC_INNER void GC_remove_protection(struct hblk *h, word nblocks, - GC_bool is_ptrfree) -{ - struct hblk * h_trunc; /* Truncated to page boundary */ - struct hblk * h_end; /* Page boundary following block end */ - struct hblk * current; - -# if defined(GWW_VDB) - if (GC_GWW_AVAILABLE()) return; -# endif - if (!GC_dirty_maintained) return; - h_trunc = (struct hblk *)((word)h & ~(GC_page_size-1)); - h_end = (struct hblk *)ROUNDUP_PAGESIZE((word)(h + nblocks)); - if (h_end == h_trunc + 1 && - get_pht_entry_from_index(GC_dirty_pages, PHT_HASH(h_trunc))) { - /* already marked dirty, and hence unprotected. */ - return; - } - for (current = h_trunc; (word)current < (word)h_end; ++current) { - size_t index = PHT_HASH(current); - if (!is_ptrfree || (word)current < (word)h - || (word)current >= (word)(h + nblocks)) { - async_set_pht_entry_from_index(GC_dirty_pages, index); - } - } - UNPROTECT(h_trunc, (ptr_t)h_end - (ptr_t)h_trunc); -} - -#if !defined(DARWIN) - GC_INNER void GC_dirty_init(void) - { -# if !defined(MSWIN32) && !defined(MSWINCE) - struct sigaction act, oldact; - act.sa_flags = SA_RESTART | SA_SIGINFO; - act.sa_sigaction = GC_write_fault_handler; - (void)sigemptyset(&act.sa_mask); -# if defined(THREADS) && !defined(GC_OPENBSD_UTHREADS) \ - && !defined(GC_WIN32_THREADS) && !defined(NACL) - /* Arrange to postpone the signal while we are in a write fault */ - /* handler. This effectively makes the handler atomic w.r.t. */ - /* stopping the world for GC. */ - (void)sigaddset(&act.sa_mask, GC_get_suspend_signal()); -# endif -# endif /* !MSWIN32 */ - GC_VERBOSE_LOG_PRINTF( - "Initializing mprotect virtual dirty bit implementation\n"); - GC_dirty_maintained = TRUE; - if (GC_page_size % HBLKSIZE != 0) { - ABORT("Page size not multiple of HBLKSIZE"); - } -# if !defined(MSWIN32) && !defined(MSWINCE) - /* act.sa_restorer is deprecated and should not be initialized. */ -# if defined(GC_IRIX_THREADS) - sigaction(SIGSEGV, 0, &oldact); - sigaction(SIGSEGV, &act, 0); -# else - { - int res = sigaction(SIGSEGV, &act, &oldact); - if (res != 0) ABORT("Sigaction failed"); - } -# endif - if (oldact.sa_flags & SA_SIGINFO) { - GC_old_segv_handler = oldact.sa_sigaction; - GC_old_segv_handler_used_si = TRUE; - } else { - GC_old_segv_handler = (SIG_HNDLR_PTR)oldact.sa_handler; - GC_old_segv_handler_used_si = FALSE; - } - if (GC_old_segv_handler == (SIG_HNDLR_PTR)SIG_IGN) { - WARN("Previously ignored segmentation violation!?\n", 0); - GC_old_segv_handler = (SIG_HNDLR_PTR)SIG_DFL; - } - if (GC_old_segv_handler != (SIG_HNDLR_PTR)SIG_DFL) { - GC_VERBOSE_LOG_PRINTF("Replaced other SIGSEGV handler\n"); - } -# if defined(HPUX) || defined(LINUX) || defined(HURD) \ - || (defined(FREEBSD) && defined(SUNOS5SIGS)) - sigaction(SIGBUS, &act, &oldact); - if ((oldact.sa_flags & SA_SIGINFO) != 0) { - GC_old_bus_handler = oldact.sa_sigaction; -# if !defined(LINUX) - GC_old_bus_handler_used_si = TRUE; -# endif - } else { - GC_old_bus_handler = (SIG_HNDLR_PTR)oldact.sa_handler; -# if !defined(LINUX) - GC_old_bus_handler_used_si = FALSE; -# endif - } - if (GC_old_bus_handler == (SIG_HNDLR_PTR)SIG_IGN) { - WARN("Previously ignored bus error!?\n", 0); -# if !defined(LINUX) - GC_old_bus_handler = (SIG_HNDLR_PTR)SIG_DFL; -# else - /* GC_old_bus_handler is not used by GC_write_fault_handler. */ -# endif - } else if (GC_old_bus_handler != (SIG_HNDLR_PTR)SIG_DFL) { - GC_VERBOSE_LOG_PRINTF("Replaced other SIGBUS handler\n"); - } -# endif /* HPUX || LINUX || HURD || (FREEBSD && SUNOS5SIGS) */ -# endif /* ! MS windows */ -# if defined(GWW_VDB) - if (GC_gww_dirty_init()) - return; -# endif -# if defined(MSWIN32) - GC_old_segv_handler = SetUnhandledExceptionFilter(GC_write_fault_handler); - if (GC_old_segv_handler != NULL) { - GC_COND_LOG_PRINTF("Replaced other UnhandledExceptionFilter\n"); - } else { - GC_old_segv_handler = SIG_DFL; - } -# elif defined(MSWINCE) - /* MPROTECT_VDB is unsupported for WinCE at present. */ - /* FIXME: implement it (if possible). */ -# endif - } -#endif /* !DARWIN */ - -GC_API int GC_CALL GC_incremental_protection_needs(void) -{ - GC_ASSERT(GC_is_initialized); - - if (GC_page_size == HBLKSIZE) { - return GC_PROTECTS_POINTER_HEAP; - } else { - return GC_PROTECTS_POINTER_HEAP | GC_PROTECTS_PTRFREE_HEAP; - } -} -#define HAVE_INCREMENTAL_PROTECTION_NEEDS - -#define IS_PTRFREE(hhdr) ((hhdr)->hb_descr == 0) -#define PAGE_ALIGNED(x) !((word)(x) & (GC_page_size - 1)) - -STATIC void GC_protect_heap(void) -{ - ptr_t start; - size_t len; - struct hblk * current; - struct hblk * current_start; /* Start of block to be protected. */ - struct hblk * limit; - unsigned i; - GC_bool protect_all = - (0 != (GC_incremental_protection_needs() & GC_PROTECTS_PTRFREE_HEAP)); - for (i = 0; i < GC_n_heap_sects; i++) { - start = GC_heap_sects[i].hs_start; - len = GC_heap_sects[i].hs_bytes; - if (protect_all) { - PROTECT(start, len); - } else { - GC_ASSERT(PAGE_ALIGNED(len)); - GC_ASSERT(PAGE_ALIGNED(start)); - current_start = current = (struct hblk *)start; - limit = (struct hblk *)(start + len); - while ((word)current < (word)limit) { - hdr * hhdr; - word nhblks; - GC_bool is_ptrfree; - - GC_ASSERT(PAGE_ALIGNED(current)); - GET_HDR(current, hhdr); - if (IS_FORWARDING_ADDR_OR_NIL(hhdr)) { - /* This can happen only if we're at the beginning of a */ - /* heap segment, and a block spans heap segments. */ - /* We will handle that block as part of the preceding */ - /* segment. */ - GC_ASSERT(current_start == current); - current_start = ++current; - continue; - } - if (HBLK_IS_FREE(hhdr)) { - GC_ASSERT(PAGE_ALIGNED(hhdr -> hb_sz)); - nhblks = divHBLKSZ(hhdr -> hb_sz); - is_ptrfree = TRUE; /* dirty on alloc */ - } else { - nhblks = OBJ_SZ_TO_BLOCKS(hhdr -> hb_sz); - is_ptrfree = IS_PTRFREE(hhdr); - } - if (is_ptrfree) { - if ((word)current_start < (word)current) { - PROTECT(current_start, (ptr_t)current - (ptr_t)current_start); - } - current_start = (current += nhblks); - } else { - current += nhblks; - } - } - if ((word)current_start < (word)current) { - PROTECT(current_start, (ptr_t)current - (ptr_t)current_start); - } - } - } -} - -/* We assume that either the world is stopped or its OK to lose dirty */ -/* bits while this is happening (as in GC_enable_incremental). */ -GC_INNER void GC_read_dirty(void) -{ -# if defined(GWW_VDB) - if (GC_GWW_AVAILABLE()) { - GC_gww_read_dirty(); - return; - } -# endif - BCOPY((word *)GC_dirty_pages, GC_grungy_pages, - (sizeof GC_dirty_pages)); - BZERO((word *)GC_dirty_pages, (sizeof GC_dirty_pages)); - GC_protect_heap(); -} - -GC_INNER GC_bool GC_page_was_dirty(struct hblk *h) -{ - register word index; - -# if defined(GWW_VDB) - if (GC_GWW_AVAILABLE()) - return GC_gww_page_was_dirty(h); -# endif - - index = PHT_HASH(h); - return(HDR(h) == 0 || get_pht_entry_from_index(GC_grungy_pages, index)); -} - -/* - * Acquiring the allocation lock here is dangerous, since this - * can be called from within GC_call_with_alloc_lock, and the cord - * package does so. On systems that allow nested lock acquisition, this - * happens to work. - */ - -/* We no longer wrap read by default, since that was causing too many */ -/* problems. It is preferred that the client instead avoids writing */ -/* to the write-protected heap with a system call. */ - -# ifdef CHECKSUMS - GC_INNER GC_bool GC_page_was_ever_dirty(struct hblk * h GC_ATTR_UNUSED) - { -# if defined(GWW_VDB) - if (GC_GWW_AVAILABLE()) - return GC_gww_page_was_ever_dirty(h); -# endif - return(TRUE); - } -# endif /* CHECKSUMS */ - -#endif /* MPROTECT_VDB */ - -#ifdef PROC_VDB -/* See DEFAULT_VDB for interface descriptions. */ - -/* This implementation assumes a Solaris 2.X like /proc */ -/* pseudo-file-system from which we can read page modified bits. This */ -/* facility is far from optimal (e.g. we would like to get the info for */ -/* only some of the address space), but it avoids intercepting system */ -/* calls. */ - -# include -# include -# include -# include -# include -# include -# include - -# define INITIAL_BUF_SZ 16384 - STATIC word GC_proc_buf_size = INITIAL_BUF_SZ; - STATIC char *GC_proc_buf = NULL; - STATIC int GC_proc_fd = 0; - -GC_INNER void GC_dirty_init(void) -{ - int fd; - char buf[30]; - - if (GC_bytes_allocd != 0 || GC_bytes_allocd_before_gc != 0) { - memset(GC_written_pages, 0xff, sizeof(page_hash_table)); - GC_VERBOSE_LOG_PRINTF( - "Allocated %lu bytes: all pages may have been written\n", - (unsigned long)(GC_bytes_allocd + GC_bytes_allocd_before_gc)); - } - - (void)snprintf(buf, sizeof(buf), "/proc/%ld", (long)getpid()); - buf[sizeof(buf) - 1] = '\0'; - fd = open(buf, O_RDONLY); - if (fd < 0) { - ABORT("/proc open failed"); - } - GC_proc_fd = syscall(SYS_ioctl, fd, PIOCOPENPD, 0); - close(fd); - syscall(SYS_fcntl, GC_proc_fd, F_SETFD, FD_CLOEXEC); - if (GC_proc_fd < 0) { - WARN("/proc ioctl(PIOCOPENPD) failed", 0); - return; - } - - GC_dirty_maintained = TRUE; - GC_proc_buf = GC_scratch_alloc(GC_proc_buf_size); - if (GC_proc_buf == NULL) - ABORT("Insufficient space for /proc read"); -} - -# define READ read - -GC_INNER void GC_read_dirty(void) -{ - int nmaps; - unsigned long npages; - unsigned pagesize; - ptr_t vaddr, limit; - struct prasmap * map; - char * bufp; - int i; - - BZERO(GC_grungy_pages, sizeof(GC_grungy_pages)); - bufp = GC_proc_buf; - if (READ(GC_proc_fd, bufp, GC_proc_buf_size) <= 0) { - /* Retry with larger buffer. */ - word new_size = 2 * GC_proc_buf_size; - char *new_buf; - - WARN("/proc read failed: GC_proc_buf_size = %" WARN_PRIdPTR "\n", - (signed_word)GC_proc_buf_size); - new_buf = GC_scratch_alloc(new_size); - if (new_buf != 0) { - GC_proc_buf = bufp = new_buf; - GC_proc_buf_size = new_size; - } - if (READ(GC_proc_fd, bufp, GC_proc_buf_size) <= 0) { - WARN("Insufficient space for /proc read\n", 0); - /* Punt: */ - memset(GC_grungy_pages, 0xff, sizeof (page_hash_table)); - memset(GC_written_pages, 0xff, sizeof(page_hash_table)); - return; - } - } - - /* Copy dirty bits into GC_grungy_pages */ - nmaps = ((struct prpageheader *)bufp) -> pr_nmap; -# ifdef DEBUG_DIRTY_BITS - GC_log_printf("Proc VDB read: pr_nmap= %u, pr_npage= %lu\n", - nmaps, ((struct prpageheader *)bufp)->pr_npage); -# endif - bufp += sizeof(struct prpageheader); - for (i = 0; i < nmaps; i++) { - map = (struct prasmap *)bufp; - vaddr = (ptr_t)(map -> pr_vaddr); - npages = map -> pr_npage; - pagesize = map -> pr_pagesize; -# ifdef DEBUG_DIRTY_BITS - GC_log_printf( - "pr_vaddr= %p, npage= %lu, mflags= 0x%x, pagesize= 0x%x\n", - vaddr, npages, map->pr_mflags, pagesize); -# endif - - bufp += sizeof(struct prasmap); - limit = vaddr + pagesize * npages; - for (; (word)vaddr < (word)limit; vaddr += pagesize) { - if ((*bufp++) & PG_MODIFIED) { - register struct hblk * h; - ptr_t next_vaddr = vaddr + pagesize; -# ifdef DEBUG_DIRTY_BITS - GC_log_printf("dirty page at: %p\n", vaddr); -# endif - for (h = (struct hblk *)vaddr; - (word)h < (word)next_vaddr; h++) { - register word index = PHT_HASH(h); - set_pht_entry_from_index(GC_grungy_pages, index); - } - } - } - bufp = (char *)(((word)bufp + (sizeof(long)-1)) & ~(sizeof(long)-1)); - } -# ifdef DEBUG_DIRTY_BITS - GC_log_printf("Proc VDB read done.\n"); -# endif - - /* Update GC_written_pages. */ - GC_or_pages(GC_written_pages, GC_grungy_pages); -} - -# undef READ -#endif /* PROC_VDB */ - -#ifdef PCR_VDB - -# include "vd/PCR_VD.h" - -# define NPAGES (32*1024) /* 128 MB */ - -PCR_VD_DB GC_grungy_bits[NPAGES]; - -STATIC ptr_t GC_vd_base = NULL; - /* Address corresponding to GC_grungy_bits[0] */ - /* HBLKSIZE aligned. */ - -GC_INNER void GC_dirty_init(void) -{ - GC_dirty_maintained = TRUE; - /* For the time being, we assume the heap generally grows up */ - GC_vd_base = GC_heap_sects[0].hs_start; - if (GC_vd_base == 0) { - ABORT("Bad initial heap segment"); - } - if (PCR_VD_Start(HBLKSIZE, GC_vd_base, NPAGES*HBLKSIZE) - != PCR_ERes_okay) { - ABORT("Dirty bit initialization failed"); - } -} - -GC_INNER void GC_read_dirty(void) -{ - /* lazily enable dirty bits on newly added heap sects */ - { - static int onhs = 0; - int nhs = GC_n_heap_sects; - for(; onhs < nhs; onhs++) { - PCR_VD_WriteProtectEnable( - GC_heap_sects[onhs].hs_start, - GC_heap_sects[onhs].hs_bytes ); - } - } - - if (PCR_VD_Clear(GC_vd_base, NPAGES*HBLKSIZE, GC_grungy_bits) - != PCR_ERes_okay) { - ABORT("Dirty bit read failed"); - } -} - -GC_INNER GC_bool GC_page_was_dirty(struct hblk *h) -{ - if ((word)h < (word)GC_vd_base - || (word)h >= (word)(GC_vd_base + NPAGES*HBLKSIZE)) { - return(TRUE); - } - return(GC_grungy_bits[h - (struct hblk *)GC_vd_base] & PCR_VD_DB_dirtyBit); -} - -GC_INNER void GC_remove_protection(struct hblk *h, word nblocks, - GC_bool is_ptrfree GC_ATTR_UNUSED) -{ - PCR_VD_WriteProtectDisable(h, nblocks*HBLKSIZE); - PCR_VD_WriteProtectEnable(h, nblocks*HBLKSIZE); -} - -#endif /* PCR_VDB */ - -#if defined(MPROTECT_VDB) && defined(DARWIN) -/* The following sources were used as a "reference" for this exception - handling code: - 1. Apple's mach/xnu documentation - 2. Timothy J. Wood's "Mach Exception Handlers 101" post to the - omnigroup's macosx-dev list. - www.omnigroup.com/mailman/archive/macosx-dev/2000-June/014178.html - 3. macosx-nat.c from Apple's GDB source code. -*/ - -/* The bug that caused all this trouble should now be fixed. This should - eventually be removed if all goes well. */ - -/* #define BROKEN_EXCEPTION_HANDLING */ - -#include -#include -#include -#include -#include - -/* These are not defined in any header, although they are documented */ -extern boolean_t -exc_server(mach_msg_header_t *, mach_msg_header_t *); - -extern kern_return_t -exception_raise(mach_port_t, mach_port_t, mach_port_t, exception_type_t, - exception_data_t, mach_msg_type_number_t); - -extern kern_return_t -exception_raise_state(mach_port_t, mach_port_t, mach_port_t, exception_type_t, - exception_data_t, mach_msg_type_number_t, - thread_state_flavor_t*, thread_state_t, - mach_msg_type_number_t, thread_state_t, - mach_msg_type_number_t*); - -extern kern_return_t -exception_raise_state_identity(mach_port_t, mach_port_t, mach_port_t, - exception_type_t, exception_data_t, - mach_msg_type_number_t, thread_state_flavor_t*, - thread_state_t, mach_msg_type_number_t, - thread_state_t, mach_msg_type_number_t*); - -GC_API_OSCALL kern_return_t -catch_exception_raise(mach_port_t exception_port, mach_port_t thread, - mach_port_t task, exception_type_t exception, - exception_data_t code, mach_msg_type_number_t code_count); - -/* These should never be called, but just in case... */ -GC_API_OSCALL kern_return_t -catch_exception_raise_state(mach_port_name_t exception_port GC_ATTR_UNUSED, - int exception GC_ATTR_UNUSED, exception_data_t code GC_ATTR_UNUSED, - mach_msg_type_number_t codeCnt GC_ATTR_UNUSED, int flavor GC_ATTR_UNUSED, - thread_state_t old_state GC_ATTR_UNUSED, int old_stateCnt GC_ATTR_UNUSED, - thread_state_t new_state GC_ATTR_UNUSED, int new_stateCnt GC_ATTR_UNUSED) -{ - ABORT_RET("Unexpected catch_exception_raise_state invocation"); - return(KERN_INVALID_ARGUMENT); -} - -GC_API_OSCALL kern_return_t -catch_exception_raise_state_identity( - mach_port_name_t exception_port GC_ATTR_UNUSED, - mach_port_t thread GC_ATTR_UNUSED, mach_port_t task GC_ATTR_UNUSED, - int exception GC_ATTR_UNUSED, exception_data_t code GC_ATTR_UNUSED, - mach_msg_type_number_t codeCnt GC_ATTR_UNUSED, int flavor GC_ATTR_UNUSED, - thread_state_t old_state GC_ATTR_UNUSED, int old_stateCnt GC_ATTR_UNUSED, - thread_state_t new_state GC_ATTR_UNUSED, int new_stateCnt GC_ATTR_UNUSED) -{ - ABORT_RET("Unexpected catch_exception_raise_state_identity invocation"); - return(KERN_INVALID_ARGUMENT); -} - -#define MAX_EXCEPTION_PORTS 16 - -static struct { - mach_msg_type_number_t count; - exception_mask_t masks[MAX_EXCEPTION_PORTS]; - exception_handler_t ports[MAX_EXCEPTION_PORTS]; - exception_behavior_t behaviors[MAX_EXCEPTION_PORTS]; - thread_state_flavor_t flavors[MAX_EXCEPTION_PORTS]; -} GC_old_exc_ports; - -STATIC struct { - void (*volatile os_callback[3])(void); - mach_port_t exception; -# if defined(THREADS) - mach_port_t reply; -# endif -} GC_ports = { - { - /* This is to prevent stripping these routines as dead. */ - (void (*)(void))catch_exception_raise, - (void (*)(void))catch_exception_raise_state, - (void (*)(void))catch_exception_raise_state_identity - }, -# ifdef THREADS - 0, /* for 'exception' */ -# endif - 0 -}; - -typedef struct { - mach_msg_header_t head; -} GC_msg_t; - -typedef enum { - GC_MP_NORMAL, - GC_MP_DISCARDING, - GC_MP_STOPPED -} GC_mprotect_state_t; - -#ifdef THREADS - /* FIXME: 1 and 2 seem to be safe to use in the msgh_id field, but it */ - /* is not documented. Use the source and see if they should be OK. */ -# define ID_STOP 1 -# define ID_RESUME 2 - - /* This value is only used on the reply port. */ -# define ID_ACK 3 - - STATIC GC_mprotect_state_t GC_mprotect_state = 0; - - /* The following should ONLY be called when the world is stopped. */ - STATIC void GC_mprotect_thread_notify(mach_msg_id_t id) - { - struct { - GC_msg_t msg; - mach_msg_trailer_t trailer; - } buf; - mach_msg_return_t r; - - /* remote, local */ - buf.msg.head.msgh_bits = MACH_MSGH_BITS(MACH_MSG_TYPE_MAKE_SEND, 0); - buf.msg.head.msgh_size = sizeof(buf.msg); - buf.msg.head.msgh_remote_port = GC_ports.exception; - buf.msg.head.msgh_local_port = MACH_PORT_NULL; - buf.msg.head.msgh_id = id; - - r = mach_msg(&buf.msg.head, MACH_SEND_MSG | MACH_RCV_MSG | MACH_RCV_LARGE, - sizeof(buf.msg), sizeof(buf), GC_ports.reply, - MACH_MSG_TIMEOUT_NONE, MACH_PORT_NULL); - if (r != MACH_MSG_SUCCESS) - ABORT("mach_msg failed in GC_mprotect_thread_notify"); - if (buf.msg.head.msgh_id != ID_ACK) - ABORT("Invalid ack in GC_mprotect_thread_notify"); - } - - /* Should only be called by the mprotect thread */ - STATIC void GC_mprotect_thread_reply(void) - { - GC_msg_t msg; - mach_msg_return_t r; - /* remote, local */ - - msg.head.msgh_bits = MACH_MSGH_BITS(MACH_MSG_TYPE_MAKE_SEND, 0); - msg.head.msgh_size = sizeof(msg); - msg.head.msgh_remote_port = GC_ports.reply; - msg.head.msgh_local_port = MACH_PORT_NULL; - msg.head.msgh_id = ID_ACK; - - r = mach_msg(&msg.head, MACH_SEND_MSG, sizeof(msg), 0, MACH_PORT_NULL, - MACH_MSG_TIMEOUT_NONE, MACH_PORT_NULL); - if (r != MACH_MSG_SUCCESS) - ABORT("mach_msg failed in GC_mprotect_thread_reply"); - } - - GC_INNER void GC_mprotect_stop(void) - { - GC_mprotect_thread_notify(ID_STOP); - } - - GC_INNER void GC_mprotect_resume(void) - { - GC_mprotect_thread_notify(ID_RESUME); - } - -# ifndef GC_NO_THREADS_DISCOVERY - GC_INNER void GC_darwin_register_mach_handler_thread(mach_port_t thread); -# endif - -#else - /* The compiler should optimize away any GC_mprotect_state computations */ -# define GC_mprotect_state GC_MP_NORMAL -#endif /* !THREADS */ - -STATIC void *GC_mprotect_thread(void *arg) -{ - mach_msg_return_t r; - /* These two structures contain some private kernel data. We don't */ - /* need to access any of it so we don't bother defining a proper */ - /* struct. The correct definitions are in the xnu source code. */ - struct { - mach_msg_header_t head; - char data[256]; - } reply; - struct { - mach_msg_header_t head; - mach_msg_body_t msgh_body; - char data[1024]; - } msg; - mach_msg_id_t id; - - if ((word)arg == (word)-1) return 0; /* to make compiler happy */ - -# if defined(THREADS) && !defined(GC_NO_THREADS_DISCOVERY) - GC_darwin_register_mach_handler_thread(mach_thread_self()); -# endif - - for(;;) { - r = mach_msg(&msg.head, MACH_RCV_MSG | MACH_RCV_LARGE | - (GC_mprotect_state == GC_MP_DISCARDING ? MACH_RCV_TIMEOUT : 0), - 0, sizeof(msg), GC_ports.exception, - GC_mprotect_state == GC_MP_DISCARDING ? 0 - : MACH_MSG_TIMEOUT_NONE, MACH_PORT_NULL); - id = r == MACH_MSG_SUCCESS ? msg.head.msgh_id : -1; - -# if defined(THREADS) - if(GC_mprotect_state == GC_MP_DISCARDING) { - if(r == MACH_RCV_TIMED_OUT) { - GC_mprotect_state = GC_MP_STOPPED; - GC_mprotect_thread_reply(); - continue; - } - if(r == MACH_MSG_SUCCESS && (id == ID_STOP || id == ID_RESUME)) - ABORT("Out of order mprotect thread request"); - } -# endif /* THREADS */ - - if (r != MACH_MSG_SUCCESS) { - ABORT_ARG2("mach_msg failed", - ": errcode= %d (%s)", (int)r, mach_error_string(r)); - } - - switch(id) { -# if defined(THREADS) - case ID_STOP: - if(GC_mprotect_state != GC_MP_NORMAL) - ABORT("Called mprotect_stop when state wasn't normal"); - GC_mprotect_state = GC_MP_DISCARDING; - break; - case ID_RESUME: - if(GC_mprotect_state != GC_MP_STOPPED) - ABORT("Called mprotect_resume when state wasn't stopped"); - GC_mprotect_state = GC_MP_NORMAL; - GC_mprotect_thread_reply(); - break; -# endif /* THREADS */ - default: - /* Handle the message (calls catch_exception_raise) */ - if(!exc_server(&msg.head, &reply.head)) - ABORT("exc_server failed"); - /* Send the reply */ - r = mach_msg(&reply.head, MACH_SEND_MSG, reply.head.msgh_size, 0, - MACH_PORT_NULL, MACH_MSG_TIMEOUT_NONE, - MACH_PORT_NULL); - if(r != MACH_MSG_SUCCESS) { - /* This will fail if the thread dies, but the thread */ - /* shouldn't die... */ -# ifdef BROKEN_EXCEPTION_HANDLING - GC_err_printf("mach_msg failed with %d %s while sending " - "exc reply\n", (int)r, mach_error_string(r)); -# else - ABORT("mach_msg failed while sending exception reply"); -# endif - } - } /* switch */ - } /* for(;;) */ -} - -/* All this SIGBUS code shouldn't be necessary. All protection faults should - be going through the mach exception handler. However, it seems a SIGBUS is - occasionally sent for some unknown reason. Even more odd, it seems to be - meaningless and safe to ignore. */ -#ifdef BROKEN_EXCEPTION_HANDLING - - /* Updates to this aren't atomic, but the SIGBUS'es seem pretty rare. */ - /* Even if this doesn't get updated property, it isn't really a problem. */ - STATIC int GC_sigbus_count = 0; - - STATIC void GC_darwin_sigbus(int num, siginfo_t *sip, void *context) - { - if (num != SIGBUS) - ABORT("Got a non-sigbus signal in the sigbus handler"); - - /* Ugh... some seem safe to ignore, but too many in a row probably means - trouble. GC_sigbus_count is reset for each mach exception that is - handled */ - if (GC_sigbus_count >= 8) { - ABORT("Got more than 8 SIGBUSs in a row!"); - } else { - GC_sigbus_count++; - WARN("Ignoring SIGBUS.\n", 0); - } - } -#endif /* BROKEN_EXCEPTION_HANDLING */ - -GC_INNER void GC_dirty_init(void) -{ - kern_return_t r; - mach_port_t me; - pthread_t thread; - pthread_attr_t attr; - exception_mask_t mask; - -# ifdef CAN_HANDLE_FORK - if (GC_handle_fork) { - /* To both support GC incremental mode and GC functions usage in */ - /* the forked child, pthread_atfork should be used to install */ - /* handlers that switch off GC_dirty_maintained in the child */ - /* gracefully (unprotecting all pages and clearing */ - /* GC_mach_handler_thread). For now, we just disable incremental */ - /* mode if fork() handling is requested by the client. */ - GC_COND_LOG_PRINTF("GC incremental mode disabled since fork()" - " handling requested\n"); - return; - } -# endif - - GC_VERBOSE_LOG_PRINTF("Initializing mach/darwin mprotect" - " virtual dirty bit implementation\n"); -# ifdef BROKEN_EXCEPTION_HANDLING - WARN("Enabling workarounds for various darwin " - "exception handling bugs.\n", 0); -# endif - GC_dirty_maintained = TRUE; - if (GC_page_size % HBLKSIZE != 0) { - ABORT("Page size not multiple of HBLKSIZE"); - } - - GC_task_self = me = mach_task_self(); - - r = mach_port_allocate(me, MACH_PORT_RIGHT_RECEIVE, &GC_ports.exception); - if (r != KERN_SUCCESS) - ABORT("mach_port_allocate failed (exception port)"); - - r = mach_port_insert_right(me, GC_ports.exception, GC_ports.exception, - MACH_MSG_TYPE_MAKE_SEND); - if (r != KERN_SUCCESS) - ABORT("mach_port_insert_right failed (exception port)"); - -# if defined(THREADS) - r = mach_port_allocate(me, MACH_PORT_RIGHT_RECEIVE, &GC_ports.reply); - if(r != KERN_SUCCESS) - ABORT("mach_port_allocate failed (reply port)"); -# endif - - /* The exceptions we want to catch */ - mask = EXC_MASK_BAD_ACCESS; - - r = task_get_exception_ports(me, mask, GC_old_exc_ports.masks, - &GC_old_exc_ports.count, GC_old_exc_ports.ports, - GC_old_exc_ports.behaviors, - GC_old_exc_ports.flavors); - if (r != KERN_SUCCESS) - ABORT("task_get_exception_ports failed"); - - r = task_set_exception_ports(me, mask, GC_ports.exception, EXCEPTION_DEFAULT, - GC_MACH_THREAD_STATE); - if (r != KERN_SUCCESS) - ABORT("task_set_exception_ports failed"); - if (pthread_attr_init(&attr) != 0) - ABORT("pthread_attr_init failed"); - if (pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED) != 0) - ABORT("pthread_attr_setdetachedstate failed"); - -# undef pthread_create - /* This will call the real pthread function, not our wrapper */ - if (pthread_create(&thread, &attr, GC_mprotect_thread, NULL) != 0) - ABORT("pthread_create failed"); - (void)pthread_attr_destroy(&attr); - - /* Setup the sigbus handler for ignoring the meaningless SIGBUSs */ -# ifdef BROKEN_EXCEPTION_HANDLING - { - struct sigaction sa, oldsa; - sa.sa_handler = (SIG_HNDLR_PTR)GC_darwin_sigbus; - sigemptyset(&sa.sa_mask); - sa.sa_flags = SA_RESTART|SA_SIGINFO; - /* sa.sa_restorer is deprecated and should not be initialized. */ - if (sigaction(SIGBUS, &sa, &oldsa) < 0) - ABORT("sigaction failed"); - if ((SIG_HNDLR_PTR)oldsa.sa_handler != SIG_DFL) { - GC_VERBOSE_LOG_PRINTF("Replaced other SIGBUS handler\n"); - } - } -# endif /* BROKEN_EXCEPTION_HANDLING */ -} - -/* The source code for Apple's GDB was used as a reference for the */ -/* exception forwarding code. This code is similar to be GDB code only */ -/* because there is only one way to do it. */ -STATIC kern_return_t GC_forward_exception(mach_port_t thread, mach_port_t task, - exception_type_t exception, - exception_data_t data, - mach_msg_type_number_t data_count) -{ - unsigned int i; - kern_return_t r; - mach_port_t port; - exception_behavior_t behavior; - thread_state_flavor_t flavor; - - thread_state_data_t thread_state; - mach_msg_type_number_t thread_state_count = THREAD_STATE_MAX; - - for (i=0; i < GC_old_exc_ports.count; i++) - if (GC_old_exc_ports.masks[i] & (1 << exception)) - break; - if (i == GC_old_exc_ports.count) - ABORT("No handler for exception!"); - - port = GC_old_exc_ports.ports[i]; - behavior = GC_old_exc_ports.behaviors[i]; - flavor = GC_old_exc_ports.flavors[i]; - - if (behavior == EXCEPTION_STATE || behavior == EXCEPTION_STATE_IDENTITY) { - r = thread_get_state(thread, flavor, thread_state, &thread_state_count); - if(r != KERN_SUCCESS) - ABORT("thread_get_state failed in forward_exception"); - } - - switch(behavior) { - case EXCEPTION_STATE: - r = exception_raise_state(port, thread, task, exception, data, data_count, - &flavor, thread_state, thread_state_count, - thread_state, &thread_state_count); - break; - case EXCEPTION_STATE_IDENTITY: - r = exception_raise_state_identity(port, thread, task, exception, data, - data_count, &flavor, thread_state, - thread_state_count, thread_state, - &thread_state_count); - break; - /* case EXCEPTION_DEFAULT: */ /* default signal handlers */ - default: /* user-supplied signal handlers */ - r = exception_raise(port, thread, task, exception, data, data_count); - } - - if (behavior == EXCEPTION_STATE || behavior == EXCEPTION_STATE_IDENTITY) { - r = thread_set_state(thread, flavor, thread_state, thread_state_count); - if (r != KERN_SUCCESS) - ABORT("thread_set_state failed in forward_exception"); - } - return r; -} - -#define FWD() GC_forward_exception(thread, task, exception, code, code_count) - -#ifdef ARM32 -# define DARWIN_EXC_STATE ARM_EXCEPTION_STATE -# define DARWIN_EXC_STATE_COUNT ARM_EXCEPTION_STATE_COUNT -# define DARWIN_EXC_STATE_T arm_exception_state_t -# define DARWIN_EXC_STATE_DAR THREAD_FLD(far) -#elif defined(AARCH64) -# define DARWIN_EXC_STATE ARM_EXCEPTION_STATE64 -# define DARWIN_EXC_STATE_COUNT ARM_EXCEPTION_STATE64_COUNT -# define DARWIN_EXC_STATE_T arm_exception_state64_t -# define DARWIN_EXC_STATE_DAR THREAD_FLD(far) -#elif defined(POWERPC) -# if CPP_WORDSZ == 32 -# define DARWIN_EXC_STATE PPC_EXCEPTION_STATE -# define DARWIN_EXC_STATE_COUNT PPC_EXCEPTION_STATE_COUNT -# define DARWIN_EXC_STATE_T ppc_exception_state_t -# else -# define DARWIN_EXC_STATE PPC_EXCEPTION_STATE64 -# define DARWIN_EXC_STATE_COUNT PPC_EXCEPTION_STATE64_COUNT -# define DARWIN_EXC_STATE_T ppc_exception_state64_t -# endif -# define DARWIN_EXC_STATE_DAR THREAD_FLD(dar) -#elif defined(I386) || defined(X86_64) -# if CPP_WORDSZ == 32 -# if defined(i386_EXCEPTION_STATE_COUNT) \ - && !defined(x86_EXCEPTION_STATE32_COUNT) - /* Use old naming convention for 32-bit x86. */ -# define DARWIN_EXC_STATE i386_EXCEPTION_STATE -# define DARWIN_EXC_STATE_COUNT i386_EXCEPTION_STATE_COUNT -# define DARWIN_EXC_STATE_T i386_exception_state_t -# else -# define DARWIN_EXC_STATE x86_EXCEPTION_STATE32 -# define DARWIN_EXC_STATE_COUNT x86_EXCEPTION_STATE32_COUNT -# define DARWIN_EXC_STATE_T x86_exception_state32_t -# endif -# else -# define DARWIN_EXC_STATE x86_EXCEPTION_STATE64 -# define DARWIN_EXC_STATE_COUNT x86_EXCEPTION_STATE64_COUNT -# define DARWIN_EXC_STATE_T x86_exception_state64_t -# endif -# define DARWIN_EXC_STATE_DAR THREAD_FLD(faultvaddr) -#else -# error FIXME for non-arm/ppc/x86 darwin -#endif - -/* This violates the namespace rules but there isn't anything that can */ -/* be done about it. The exception handling stuff is hard coded to */ -/* call this. catch_exception_raise, catch_exception_raise_state and */ -/* and catch_exception_raise_state_identity are called from OS. */ -GC_API_OSCALL kern_return_t -catch_exception_raise(mach_port_t exception_port GC_ATTR_UNUSED, - mach_port_t thread, mach_port_t task GC_ATTR_UNUSED, - exception_type_t exception, exception_data_t code, - mach_msg_type_number_t code_count GC_ATTR_UNUSED) -{ - kern_return_t r; - char *addr; - struct hblk *h; - unsigned int i; - thread_state_flavor_t flavor = DARWIN_EXC_STATE; - mach_msg_type_number_t exc_state_count = DARWIN_EXC_STATE_COUNT; - DARWIN_EXC_STATE_T exc_state; - - if (exception != EXC_BAD_ACCESS || code[0] != KERN_PROTECTION_FAILURE) { -# ifdef DEBUG_EXCEPTION_HANDLING - /* We aren't interested, pass it on to the old handler */ - GC_log_printf("Exception: 0x%x Code: 0x%x 0x%x in catch...\n", - exception, code_count > 0 ? code[0] : -1, - code_count > 1 ? code[1] : -1); -# endif - return FWD(); - } - - r = thread_get_state(thread, flavor, (natural_t*)&exc_state, - &exc_state_count); - if(r != KERN_SUCCESS) { - /* The thread is supposed to be suspended while the exception */ - /* handler is called. This shouldn't fail. */ -# ifdef BROKEN_EXCEPTION_HANDLING - GC_err_printf("thread_get_state failed in catch_exception_raise\n"); - return KERN_SUCCESS; -# else - ABORT("thread_get_state failed in catch_exception_raise"); -# endif - } - - /* This is the address that caused the fault */ - addr = (char*) exc_state.DARWIN_EXC_STATE_DAR; - if (HDR(addr) == 0) { - /* Ugh... just like the SIGBUS problem above, it seems we get */ - /* a bogus KERN_PROTECTION_FAILURE every once and a while. We wait */ - /* till we get a bunch in a row before doing anything about it. */ - /* If a "real" fault ever occurs it'll just keep faulting over and */ - /* over and we'll hit the limit pretty quickly. */ -# ifdef BROKEN_EXCEPTION_HANDLING - static char *last_fault; - static int last_fault_count; - - if(addr != last_fault) { - last_fault = addr; - last_fault_count = 0; - } - if(++last_fault_count < 32) { - if(last_fault_count == 1) - WARN("Ignoring KERN_PROTECTION_FAILURE at %p\n", addr); - return KERN_SUCCESS; - } - - GC_err_printf( - "Unexpected KERN_PROTECTION_FAILURE at %p; aborting...\n", addr); - /* Can't pass it along to the signal handler because that is */ - /* ignoring SIGBUS signals. We also shouldn't call ABORT here as */ - /* signals don't always work too well from the exception handler. */ - EXIT(); -# else /* BROKEN_EXCEPTION_HANDLING */ - /* Pass it along to the next exception handler - (which should call SIGBUS/SIGSEGV) */ - return FWD(); -# endif /* !BROKEN_EXCEPTION_HANDLING */ - } - -# ifdef BROKEN_EXCEPTION_HANDLING - /* Reset the number of consecutive SIGBUSs */ - GC_sigbus_count = 0; -# endif - - if (GC_mprotect_state == GC_MP_NORMAL) { /* common case */ - h = (struct hblk*)((word)addr & ~(GC_page_size-1)); - UNPROTECT(h, GC_page_size); - for (i = 0; i < divHBLKSZ(GC_page_size); i++) { - register int index = PHT_HASH(h+i); - async_set_pht_entry_from_index(GC_dirty_pages, index); - } - } else if (GC_mprotect_state == GC_MP_DISCARDING) { - /* Lie to the thread for now. No sense UNPROTECT()ing the memory - when we're just going to PROTECT() it again later. The thread - will just fault again once it resumes */ - } else { - /* Shouldn't happen, i don't think */ - GC_err_printf("KERN_PROTECTION_FAILURE while world is stopped\n"); - return FWD(); - } - return KERN_SUCCESS; -} -#undef FWD - -#ifndef NO_DESC_CATCH_EXCEPTION_RAISE - /* These symbols should have REFERENCED_DYNAMICALLY (0x10) bit set to */ - /* let strip know they are not to be stripped. */ - __asm__(".desc _catch_exception_raise, 0x10"); - __asm__(".desc _catch_exception_raise_state, 0x10"); - __asm__(".desc _catch_exception_raise_state_identity, 0x10"); -#endif - -#endif /* DARWIN && MPROTECT_VDB */ - -#ifndef HAVE_INCREMENTAL_PROTECTION_NEEDS - GC_API int GC_CALL GC_incremental_protection_needs(void) - { - return GC_PROTECTS_NONE; - } -#endif /* !HAVE_INCREMENTAL_PROTECTION_NEEDS */ - -#ifdef ECOS - /* Undo sbrk() redirection. */ -# undef sbrk -#endif - -/* If value is non-zero then allocate executable memory. */ -GC_API void GC_CALL GC_set_pages_executable(int value) -{ - GC_ASSERT(!GC_is_initialized); - /* Even if IGNORE_PAGES_EXECUTABLE is defined, GC_pages_executable is */ - /* touched here to prevent a compiler warning. */ - GC_pages_executable = (GC_bool)(value != 0); -} - -/* Returns non-zero if the GC-allocated memory is executable. */ -/* GC_get_pages_executable is defined after all the places */ -/* where GC_get_pages_executable is undefined. */ -GC_API int GC_CALL GC_get_pages_executable(void) -{ -# ifdef IGNORE_PAGES_EXECUTABLE - return 1; /* Always allocate executable memory. */ -# else - return (int)GC_pages_executable; -# endif -} - -/* Call stack save code for debugging. Should probably be in */ -/* mach_dep.c, but that requires reorganization. */ - -/* I suspect the following works for most X86 *nix variants, so */ -/* long as the frame pointer is explicitly stored. In the case of gcc, */ -/* compiler flags (e.g. -fomit-frame-pointer) determine whether it is. */ -#if defined(I386) && defined(LINUX) && defined(SAVE_CALL_CHAIN) -# include - - struct frame { - struct frame *fr_savfp; - long fr_savpc; - long fr_arg[NARGS]; /* All the arguments go here. */ - }; -#endif - -#if defined(SPARC) -# if defined(LINUX) -# include - - struct frame { - long fr_local[8]; - long fr_arg[6]; - struct frame *fr_savfp; - long fr_savpc; -# ifndef __arch64__ - char *fr_stret; -# endif - long fr_argd[6]; - long fr_argx[0]; - }; -# elif defined (DRSNX) -# include -# elif defined(OPENBSD) -# include -# elif defined(FREEBSD) || defined(NETBSD) -# include -# else -# include -# endif -# if NARGS > 6 -# error We only know how to get the first 6 arguments -# endif -#endif /* SPARC */ - -#ifdef NEED_CALLINFO -/* Fill in the pc and argument information for up to NFRAMES of my */ -/* callers. Ignore my frame and my callers frame. */ - -#ifdef LINUX -# include -#endif - -#endif /* NEED_CALLINFO */ - -#if defined(GC_HAVE_BUILTIN_BACKTRACE) -# ifdef _MSC_VER -# include "private/msvc_dbg.h" -# else -# include -# endif -#endif - -#ifdef SAVE_CALL_CHAIN - -#if NARGS == 0 && NFRAMES % 2 == 0 /* No padding */ \ - && defined(GC_HAVE_BUILTIN_BACKTRACE) - -#ifdef REDIRECT_MALLOC - /* Deal with possible malloc calls in backtrace by omitting */ - /* the infinitely recursing backtrace. */ -# ifdef THREADS - __thread /* If your compiler doesn't understand this */ - /* you could use something like pthread_getspecific. */ -# endif - GC_in_save_callers = FALSE; -#endif - -GC_INNER void GC_save_callers(struct callinfo info[NFRAMES]) -{ - void * tmp_info[NFRAMES + 1]; - int npcs, i; -# define IGNORE_FRAMES 1 - - /* We retrieve NFRAMES+1 pc values, but discard the first, since it */ - /* points to our own frame. */ -# ifdef REDIRECT_MALLOC - if (GC_in_save_callers) { - info[0].ci_pc = (word)(&GC_save_callers); - for (i = 1; i < NFRAMES; ++i) info[i].ci_pc = 0; - return; - } - GC_in_save_callers = TRUE; -# endif - GC_STATIC_ASSERT(sizeof(struct callinfo) == sizeof(void *)); - npcs = backtrace((void **)tmp_info, NFRAMES + IGNORE_FRAMES); - BCOPY(tmp_info+IGNORE_FRAMES, info, (npcs - IGNORE_FRAMES) * sizeof(void *)); - for (i = npcs - IGNORE_FRAMES; i < NFRAMES; ++i) info[i].ci_pc = 0; -# ifdef REDIRECT_MALLOC - GC_in_save_callers = FALSE; -# endif -} - -#else /* No builtin backtrace; do it ourselves */ - -#if (defined(OPENBSD) || defined(NETBSD) || defined(FREEBSD)) && defined(SPARC) -# define FR_SAVFP fr_fp -# define FR_SAVPC fr_pc -#else -# define FR_SAVFP fr_savfp -# define FR_SAVPC fr_savpc -#endif - -#if defined(SPARC) && (defined(__arch64__) || defined(__sparcv9)) -# define BIAS 2047 -#else -# define BIAS 0 -#endif - -GC_INNER void GC_save_callers(struct callinfo info[NFRAMES]) -{ - struct frame *frame; - struct frame *fp; - int nframes = 0; -# ifdef I386 - /* We assume this is turned on only with gcc as the compiler. */ - asm("movl %%ebp,%0" : "=r"(frame)); - fp = frame; -# else - frame = (struct frame *)GC_save_regs_in_stack(); - fp = (struct frame *)((long) frame -> FR_SAVFP + BIAS); -#endif - - for (; !((word)fp HOTTER_THAN (word)frame) - && !((word)GC_stackbottom HOTTER_THAN (word)fp) - && nframes < NFRAMES; - fp = (struct frame *)((long) fp -> FR_SAVFP + BIAS), nframes++) { -# if NARGS > 0 - register int i; -# endif - - info[nframes].ci_pc = fp->FR_SAVPC; -# if NARGS > 0 - for (i = 0; i < NARGS; i++) { - info[nframes].ci_arg[i] = ~(fp->fr_arg[i]); - } -# endif /* NARGS > 0 */ - } - if (nframes < NFRAMES) info[nframes].ci_pc = 0; -} - -#endif /* No builtin backtrace */ - -#endif /* SAVE_CALL_CHAIN */ - -#ifdef NEED_CALLINFO - -/* Print info to stderr. We do NOT hold the allocation lock */ -GC_INNER void GC_print_callers(struct callinfo info[NFRAMES]) -{ - int i; - static int reentry_count = 0; - GC_bool stop = FALSE; - DCL_LOCK_STATE; - - /* FIXME: This should probably use a different lock, so that we */ - /* become callable with or without the allocation lock. */ - LOCK(); - ++reentry_count; - UNLOCK(); - -# if NFRAMES == 1 - GC_err_printf("\tCaller at allocation:\n"); -# else - GC_err_printf("\tCall chain at allocation:\n"); -# endif - for (i = 0; i < NFRAMES && !stop; i++) { - if (info[i].ci_pc == 0) break; -# if NARGS > 0 - { - int j; - - GC_err_printf("\t\targs: "); - for (j = 0; j < NARGS; j++) { - if (j != 0) GC_err_printf(", "); - GC_err_printf("%d (0x%X)", ~(info[i].ci_arg[j]), - ~(info[i].ci_arg[j])); - } - GC_err_printf("\n"); - } -# endif - if (reentry_count > 1) { - /* We were called during an allocation during */ - /* a previous GC_print_callers call; punt. */ - GC_err_printf("\t\t##PC##= 0x%lx\n", info[i].ci_pc); - continue; - } - { -# if defined(GC_HAVE_BUILTIN_BACKTRACE) \ - && !defined(GC_BACKTRACE_SYMBOLS_BROKEN) - char **sym_name = - backtrace_symbols((void **)(&(info[i].ci_pc)), 1); - char *name = sym_name[0]; -# else - char buf[40]; - char *name = buf; - (void)snprintf(buf, sizeof(buf), "##PC##= 0x%lx", info[i].ci_pc); - buf[sizeof(buf) - 1] = '\0'; -# endif -# if defined(LINUX) && !defined(SMALL_CONFIG) - /* Try for a line number. */ - { - FILE *pipe; -# define EXE_SZ 100 - static char exe_name[EXE_SZ]; -# define CMD_SZ 200 - char cmd_buf[CMD_SZ]; -# define RESULT_SZ 200 - static char result_buf[RESULT_SZ]; - size_t result_len; - char *old_preload; -# define PRELOAD_SZ 200 - char preload_buf[PRELOAD_SZ]; - static GC_bool found_exe_name = FALSE; - static GC_bool will_fail = FALSE; - int ret_code; - /* Try to get it via a hairy and expensive scheme. */ - /* First we get the name of the executable: */ - if (will_fail) goto out; - if (!found_exe_name) { - ret_code = readlink("/proc/self/exe", exe_name, EXE_SZ); - if (ret_code < 0 || ret_code >= EXE_SZ - || exe_name[0] != '/') { - will_fail = TRUE; /* Don't try again. */ - goto out; - } - exe_name[ret_code] = '\0'; - found_exe_name = TRUE; - } - /* Then we use popen to start addr2line -e */ - /* There are faster ways to do this, but hopefully this */ - /* isn't time critical. */ - (void)snprintf(cmd_buf, sizeof(cmd_buf), - "/usr/bin/addr2line -f -e %s 0x%lx", - exe_name, (unsigned long)info[i].ci_pc); - cmd_buf[sizeof(cmd_buf) - 1] = '\0'; - old_preload = GETENV("LD_PRELOAD"); - if (0 != old_preload) { - size_t old_len = strlen(old_preload); - if (old_len >= PRELOAD_SZ) { - will_fail = TRUE; - goto out; - } - BCOPY(old_preload, preload_buf, old_len + 1); - unsetenv ("LD_PRELOAD"); - } - pipe = popen(cmd_buf, "r"); - if (0 != old_preload - && 0 != setenv ("LD_PRELOAD", preload_buf, 0)) { - WARN("Failed to reset LD_PRELOAD\n", 0); - } - if (pipe == NULL - || (result_len = fread(result_buf, 1, - RESULT_SZ - 1, pipe)) == 0) { - if (pipe != NULL) pclose(pipe); - will_fail = TRUE; - goto out; - } - if (result_buf[result_len - 1] == '\n') --result_len; - result_buf[result_len] = 0; - if (result_buf[0] == '?' - || (result_buf[result_len-2] == ':' - && result_buf[result_len-1] == '0')) { - pclose(pipe); - goto out; - } - /* Get rid of embedded newline, if any. Test for "main" */ - { - char * nl = strchr(result_buf, '\n'); - if (nl != NULL - && (word)nl < (word)(result_buf + result_len)) { - *nl = ':'; - } - if (strncmp(result_buf, "main", nl - result_buf) == 0) { - stop = TRUE; - } - } - if (result_len < RESULT_SZ - 25) { - /* Add in hex address */ - (void)snprintf(&result_buf[result_len], - sizeof(result_buf) - result_len, - " [0x%lx]", (unsigned long)info[i].ci_pc); - result_buf[sizeof(result_buf) - 1] = '\0'; - } - name = result_buf; - pclose(pipe); - out:; - } -# endif /* LINUX */ - GC_err_printf("\t\t%s\n", name); -# if defined(GC_HAVE_BUILTIN_BACKTRACE) \ - && !defined(GC_BACKTRACE_SYMBOLS_BROKEN) - free(sym_name); /* May call GC_free; that's OK */ -# endif - } - } - LOCK(); - --reentry_count; - UNLOCK(); -} - -#endif /* NEED_CALLINFO */ - -#if defined(LINUX) && defined(__ELF__) && !defined(SMALL_CONFIG) - /* Dump /proc/self/maps to GC_stderr, to enable looking up names for */ - /* addresses in FIND_LEAK output. */ - void GC_print_address_map(void) - { - char *maps; - - GC_err_printf("---------- Begin address map ----------\n"); - maps = GC_get_maps(); - GC_err_puts(maps != NULL ? maps : "Failed to get map!\n"); - GC_err_printf("---------- End address map ----------\n"); - } -#endif /* LINUX && ELF */ diff -Nru ecl-16.1.2/src/bdwgc/pcr_interface.c ecl-16.1.3+ds/src/bdwgc/pcr_interface.c --- ecl-16.1.2/src/bdwgc/pcr_interface.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/pcr_interface.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,179 +0,0 @@ -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ -# include "private/gc_priv.h" - -# ifdef PCR -/* - * Note that POSIX PCR requires an ANSI C compiler. Hence we are allowed - * to make the same assumption here. - * We wrap all of the allocator functions to avoid questions of - * compatibility between the prototyped and nonprototyped versions of the f - */ -# include "config/PCR_StdTypes.h" -# include "mm/PCR_MM.h" -# include - -# define MY_MAGIC 17L -# define MY_DEBUGMAGIC 42L - -void * GC_AllocProc(size_t size, PCR_Bool ptrFree, PCR_Bool clear ) -{ - if (ptrFree) { - void * result = (void *)GC_malloc_atomic(size); - if (clear && result != 0) BZERO(result, size); - return(result); - } else { - return((void *)GC_malloc(size)); - } -} - -void * GC_DebugAllocProc(size_t size, PCR_Bool ptrFree, PCR_Bool clear ) -{ - if (ptrFree) { - void * result = (void *)GC_debug_malloc_atomic(size, __FILE__, - __LINE__); - if (clear && result != 0) BZERO(result, size); - return(result); - } else { - return((void *)GC_debug_malloc(size, __FILE__, __LINE__)); - } -} - -# define GC_ReallocProc GC_realloc -void * GC_DebugReallocProc(void * old_object, size_t new_size_in_bytes) -{ - return(GC_debug_realloc(old_object, new_size_in_bytes, __FILE__, __LINE__)); -} - -# define GC_FreeProc GC_free -# define GC_DebugFreeProc GC_debug_free - -typedef struct { - PCR_ERes (*ed_proc)(void *p, size_t size, PCR_Any data); - GC_bool ed_pointerfree; - PCR_ERes ed_fail_code; - PCR_Any ed_client_data; -} enumerate_data; - -void GC_enumerate_block(struct hblk *h; enumerate_data * ed) -{ - register hdr * hhdr; - register int sz; - ptr_t p; - ptr_t lim; - word descr; -# error This code was updated without testing. -# error and its precursor was clearly broken. - - hhdr = HDR(h); - descr = hhdr -> hb_descr; - sz = hhdr -> hb_sz; - if (descr != 0 && ed -> ed_pointerfree - || descr == 0 && !(ed -> ed_pointerfree)) return; - lim = (ptr_t)(h+1) - sz; - p = (ptr_t)h; - do { - if (PCR_ERes_IsErr(ed -> ed_fail_code)) return; - ed -> ed_fail_code = - (*(ed -> ed_proc))(p, sz, ed -> ed_client_data); - p+= sz; - } while ((word)p <= (word)lim); -} - -struct PCR_MM_ProcsRep * GC_old_allocator = 0; - -PCR_ERes GC_EnumerateProc( - PCR_Bool ptrFree, - PCR_ERes (*proc)(void *p, size_t size, PCR_Any data), - PCR_Any data -) -{ - enumerate_data ed; - - ed.ed_proc = proc; - ed.ed_pointerfree = ptrFree; - ed.ed_fail_code = PCR_ERes_okay; - ed.ed_client_data = data; - GC_apply_to_all_blocks(GC_enumerate_block, &ed); - if (ed.ed_fail_code != PCR_ERes_okay) { - return(ed.ed_fail_code); - } else { - /* Also enumerate objects allocated by my predecessors */ - return((*(GC_old_allocator->mmp_enumerate))(ptrFree, proc, data)); - } -} - -void GC_DummyFreeProc(void *p) {} - -void GC_DummyShutdownProc(void) {} - -struct PCR_MM_ProcsRep GC_Rep = { - MY_MAGIC, - GC_AllocProc, - GC_ReallocProc, - GC_DummyFreeProc, /* mmp_free */ - GC_FreeProc, /* mmp_unsafeFree */ - GC_EnumerateProc, - GC_DummyShutdownProc /* mmp_shutdown */ -}; - -struct PCR_MM_ProcsRep GC_DebugRep = { - MY_DEBUGMAGIC, - GC_DebugAllocProc, - GC_DebugReallocProc, - GC_DummyFreeProc, /* mmp_free */ - GC_DebugFreeProc, /* mmp_unsafeFree */ - GC_EnumerateProc, - GC_DummyShutdownProc /* mmp_shutdown */ -}; - -GC_bool GC_use_debug = 0; - -void GC_pcr_install() -{ - PCR_MM_Install((GC_use_debug? &GC_DebugRep : &GC_Rep), &GC_old_allocator); -} - -PCR_ERes -PCR_GC_Setup(void) -{ - return PCR_ERes_okay; -} - -PCR_ERes -PCR_GC_Run(void) -{ - - if( !PCR_Base_TestPCRArg("-nogc") ) { - GC_quiet = ( PCR_Base_TestPCRArg("-gctrace") ? 0 : 1 ); - GC_use_debug = (GC_bool)PCR_Base_TestPCRArg("-debug_alloc"); - GC_init(); - if( !PCR_Base_TestPCRArg("-nogc_incremental") ) { - /* - * awful hack to test whether VD is implemented ... - */ - if( PCR_VD_Start( 0, NIL, 0) != PCR_ERes_FromErr(ENOSYS) ) { - GC_enable_incremental(); - } - } - } - return PCR_ERes_okay; -} - -void GC_push_thread_structures(void) -{ - /* PCR doesn't work unless static roots are pushed. Can't get here. */ - ABORT("In GC_push_thread_structures()"); -} - -# endif diff -Nru ecl-16.1.2/src/bdwgc/PCR-Makefile ecl-16.1.3+ds/src/bdwgc/PCR-Makefile --- ecl-16.1.2/src/bdwgc/PCR-Makefile 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/PCR-Makefile 1970-01-01 00:00:00.000000000 +0000 @@ -1,47 +0,0 @@ -# -# Default target -# - -default: gc.o - -include ../config/common.mk - -# -# compilation flags, etc. -# - -CPPFLAGS = $(INCLUDE) $(CONFIG_CPPFLAGS) \ - -DPCR_NO_RENAME -DPCR_NO_HOSTDEP_ERR -#CFLAGS = -DPCR $(CONFIG_CFLAGS) -CFLAGS = -DPCR $(CONFIG_CFLAGS) -SPECIALCFLAGS = # For code involving asm's - -ASPPFLAGS = $(INCLUDE) $(CONFIG_ASPPFLAGS) \ - -DPCR_NO_RENAME -DPCR_NO_HOSTDEP_ERR -DASM - -ASFLAGS = $(CONFIG_ASFLAGS) - -LDRFLAGS = $(CONFIG_LDRFLAGS) - -LDFLAGS = $(CONFIG_LDFLAGS) - -# -# BEGIN PACKAGE-SPECIFIC PART -# - -# Fix to point to local pcr installation directory. -PCRDIR= .. - -COBJ= alloc.o reclaim.o allchblk.o misc.o os_dep.o mark_rts.o headers.o mark.o obj_map.o pcr_interface.o blacklst.o finalize.o new_hblk.o real_malloc.o dyn_load.o dbg_mlc.o fnlz_mlc.o malloc.o stubborn.o checksums.o solaris_threads.o typd_mlc.o ptr_chck.o mallocx.o - -CSRC= reclaim.c allchblk.c misc.c alloc.c mach_dep.c os_dep.c mark_rts.c headers.c mark.c obj_map.c pcr_interface.c blacklst.c finalize.c new_hblk.c real_malloc.c dyn_load.c dbg_mlc.c fnlz_mlc.c malloc.c stubborn.c checksums.c solaris_threads.c typd_mlc.c ptr_chck.c mallocx.c - -SHELL= /bin/sh - -default: gc.o - -gc.o: $(COBJ) mach_dep.o - $(LDR) $(CONFIG_LDRFLAGS) -o gc.o $(COBJ) mach_dep.o - -mach_dep.o: mach_dep.c - $(CC) -c $(SPECIALCFLAGS) mach_dep.c diff -Nru ecl-16.1.2/src/bdwgc/pthread_start.c ecl-16.1.3+ds/src/bdwgc/pthread_start.c --- ecl-16.1.2/src/bdwgc/pthread_start.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/pthread_start.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,70 +0,0 @@ -/* - * Copyright (c) 1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996 by Silicon Graphics. All rights reserved. - * Copyright (c) 1998 by Fergus Henderson. All rights reserved. - * Copyright (c) 2000-2010 by Hewlett-Packard Development Company. - * All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -/* We want to make sure that GC_thread_exit_proc() is unconditionally */ -/* invoked, even if the client is not compiled with -fexceptions, but */ -/* the GC is. The workaround is to put GC_inner_start_routine() in its */ -/* own file (pthread_start.c), and undefine __EXCEPTIONS in the GCC */ -/* case at the top of the file. FIXME: it's still unclear whether this */ -/* will actually cause the exit handler to be invoked last when */ -/* thread_exit is called (and if -fexceptions is used). */ -#if defined(__GNUC__) && defined(__linux__) - /* We undefine __EXCEPTIONS to avoid using GCC __cleanup__ attribute. */ - /* The current NPTL implementation of pthread_cleanup_push uses */ - /* __cleanup__ attribute when __EXCEPTIONS is defined (-fexceptions). */ - /* The stack unwinding and cleanup with __cleanup__ attributes work */ - /* correctly when everything is compiled with -fexceptions, but it is */ - /* not the requirement for this library clients to use -fexceptions */ - /* everywhere. With __EXCEPTIONS undefined, the cleanup routines are */ - /* registered with __pthread_register_cancel thus should work anyway. */ -# undef __EXCEPTIONS -#endif - -#include "private/pthread_support.h" - -#if defined(GC_PTHREADS) && !defined(GC_WIN32_THREADS) - -#include -#include - -/* Invoked from GC_start_routine(). */ -GC_INNER_PTHRSTART void * GC_CALLBACK GC_inner_start_routine( - struct GC_stack_base *sb, void *arg) -{ - void * (*start)(void *); - void * start_arg; - void * result; - volatile GC_thread me = - GC_start_rtn_prepare_thread(&start, &start_arg, sb, arg); - -# ifndef NACL - pthread_cleanup_push(GC_thread_exit_proc, me); -# endif - result = (*start)(start_arg); -# if defined(DEBUG_THREADS) && !defined(GC_PTHREAD_START_STANDALONE) - GC_log_printf("Finishing thread %p\n", (void *)pthread_self()); -# endif - me -> status = result; -# ifndef NACL - pthread_cleanup_pop(1); - /* Cleanup acquires lock, ensuring that we can't exit while */ - /* a collection that thinks we're alive is trying to stop us. */ -# endif - return result; -} - -#endif /* GC_PTHREADS */ diff -Nru ecl-16.1.2/src/bdwgc/pthread_stop_world.c ecl-16.1.3+ds/src/bdwgc/pthread_stop_world.c --- ecl-16.1.2/src/bdwgc/pthread_stop_world.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/pthread_stop_world.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,945 +0,0 @@ -/* - * Copyright (c) 1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996 by Silicon Graphics. All rights reserved. - * Copyright (c) 1998 by Fergus Henderson. All rights reserved. - * Copyright (c) 2000-2009 by Hewlett-Packard Development Company. - * All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#include "private/pthread_support.h" - -#if defined(GC_PTHREADS) && !defined(GC_WIN32_THREADS) && \ - !defined(GC_DARWIN_THREADS) - -#ifdef NACL - -#include -#include - -STATIC int GC_nacl_num_gc_threads = 0; -STATIC __thread int GC_nacl_thread_idx = -1; -STATIC int GC_nacl_park_threads_now = 0; -STATIC pthread_t GC_nacl_thread_parker = -1; - -GC_INNER __thread GC_thread GC_nacl_gc_thread_self = NULL; - -int GC_nacl_thread_parked[MAX_NACL_GC_THREADS]; -int GC_nacl_thread_used[MAX_NACL_GC_THREADS]; - -#elif defined(GC_OPENBSD_UTHREADS) - -# include - -#else /* !GC_OPENBSD_UTHREADS && !NACL */ - -#include -#include -#include -#include -#include "atomic_ops.h" - -/* It's safe to call original pthread_sigmask() here. */ -#undef pthread_sigmask - -#ifdef DEBUG_THREADS -# ifndef NSIG -# if defined(MAXSIG) -# define NSIG (MAXSIG+1) -# elif defined(_NSIG) -# define NSIG _NSIG -# elif defined(__SIGRTMAX) -# define NSIG (__SIGRTMAX+1) -# else - --> please fix it -# endif -# endif /* NSIG */ - - void GC_print_sig_mask(void) - { - sigset_t blocked; - int i; - - if (pthread_sigmask(SIG_BLOCK, NULL, &blocked) != 0) - ABORT("pthread_sigmask failed"); - for (i = 1; i < NSIG; i++) { - if (sigismember(&blocked, i)) - GC_printf("Signal blocked: %d\n", i); - } - } -#endif /* DEBUG_THREADS */ - -/* Remove the signals that we want to allow in thread stopping */ -/* handler from a set. */ -STATIC void GC_remove_allowed_signals(sigset_t *set) -{ - if (sigdelset(set, SIGINT) != 0 - || sigdelset(set, SIGQUIT) != 0 - || sigdelset(set, SIGABRT) != 0 - || sigdelset(set, SIGTERM) != 0) { - ABORT("sigdelset failed"); - } - -# ifdef MPROTECT_VDB - /* Handlers write to the thread structure, which is in the heap, */ - /* and hence can trigger a protection fault. */ - if (sigdelset(set, SIGSEGV) != 0 -# ifdef SIGBUS - || sigdelset(set, SIGBUS) != 0 -# endif - ) { - ABORT("sigdelset failed"); - } -# endif -} - -static sigset_t suspend_handler_mask; - -STATIC volatile AO_t GC_stop_count = 0; - /* Incremented at the beginning of GC_stop_world. */ - -STATIC volatile AO_t GC_world_is_stopped = FALSE; - /* FALSE ==> it is safe for threads to restart, i.e. */ - /* they will see another suspend signal before they */ - /* are expected to stop (unless they have voluntarily */ - /* stopped). */ - -#ifdef GC_OSF1_THREADS - STATIC GC_bool GC_retry_signals = TRUE; -#else - STATIC GC_bool GC_retry_signals = FALSE; -#endif - -/* - * We use signals to stop threads during GC. - * - * Suspended threads wait in signal handler for SIG_THR_RESTART. - * That's more portable than semaphores or condition variables. - * (We do use sem_post from a signal handler, but that should be portable.) - * - * The thread suspension signal SIG_SUSPEND is now defined in gc_priv.h. - * Note that we can't just stop a thread; we need it to save its stack - * pointer(s) and acknowledge. - */ -#ifndef SIG_THR_RESTART -# if defined(GC_HPUX_THREADS) || defined(GC_OSF1_THREADS) \ - || defined(GC_NETBSD_THREADS) || defined(GC_USESIGRT_SIGNALS) -# ifdef _SIGRTMIN -# define SIG_THR_RESTART _SIGRTMIN + 5 -# else -# define SIG_THR_RESTART SIGRTMIN + 5 -# endif -# else -# define SIG_THR_RESTART SIGXCPU -# endif -#endif - -#define SIGNAL_UNSET (-1) - /* Since SIG_SUSPEND and/or SIG_THR_RESTART could represent */ - /* a non-constant expression (e.g., in case of SIGRTMIN), */ - /* actual signal numbers are determined by GC_stop_init() */ - /* unless manually set (before GC initialization). */ -STATIC int GC_sig_suspend = SIGNAL_UNSET; -STATIC int GC_sig_thr_restart = SIGNAL_UNSET; - -GC_API void GC_CALL GC_set_suspend_signal(int sig) -{ - if (GC_is_initialized) return; - - GC_sig_suspend = sig; -} - -GC_API void GC_CALL GC_set_thr_restart_signal(int sig) -{ - if (GC_is_initialized) return; - - GC_sig_thr_restart = sig; -} - -GC_API int GC_CALL GC_get_suspend_signal(void) -{ - return GC_sig_suspend != SIGNAL_UNSET ? GC_sig_suspend : SIG_SUSPEND; -} - -GC_API int GC_CALL GC_get_thr_restart_signal(void) -{ - return GC_sig_thr_restart != SIGNAL_UNSET - ? GC_sig_thr_restart : SIG_THR_RESTART; -} - -#ifdef GC_EXPLICIT_SIGNALS_UNBLOCK - /* Some targets (e.g., Solaris) might require this to be called when */ - /* doing thread registering from the thread destructor. */ - GC_INNER void GC_unblock_gc_signals(void) - { - sigset_t set; - sigemptyset(&set); - GC_ASSERT(GC_sig_suspend != SIGNAL_UNSET); - GC_ASSERT(GC_sig_thr_restart != SIGNAL_UNSET); - sigaddset(&set, GC_sig_suspend); - sigaddset(&set, GC_sig_thr_restart); - if (pthread_sigmask(SIG_UNBLOCK, &set, NULL) != 0) - ABORT("pthread_sigmask failed"); - } -#endif /* GC_EXPLICIT_SIGNALS_UNBLOCK */ - -STATIC sem_t GC_suspend_ack_sem; - -#ifdef GC_NETBSD_THREADS -# define GC_NETBSD_THREADS_WORKAROUND - /* It seems to be necessary to wait until threads have restarted. */ - /* But it is unclear why that is the case. */ - STATIC sem_t GC_restart_ack_sem; -#endif - -STATIC void GC_suspend_handler_inner(ptr_t sig_arg, void *context); - -#ifdef SA_SIGINFO - STATIC void GC_suspend_handler(int sig, siginfo_t * info GC_ATTR_UNUSED, - void * context GC_ATTR_UNUSED) -#else - STATIC void GC_suspend_handler(int sig) -#endif -{ - int old_errno = errno; - -# if defined(IA64) || defined(HP_PA) || defined(M68K) - GC_with_callee_saves_pushed(GC_suspend_handler_inner, (ptr_t)(word)sig); -# else - /* We believe that in all other cases the full context is already */ - /* in the signal handler frame. */ -# ifndef SA_SIGINFO - void *context = 0; -# endif - GC_suspend_handler_inner((ptr_t)(word)sig, context); -# endif - errno = old_errno; -} - -STATIC void GC_suspend_handler_inner(ptr_t sig_arg, - void * context GC_ATTR_UNUSED) -{ - pthread_t self = pthread_self(); - GC_thread me; - IF_CANCEL(int cancel_state;) - AO_t my_stop_count = AO_load(&GC_stop_count); - - if ((signed_word)sig_arg != GC_sig_suspend) { -# if defined(GC_FREEBSD_THREADS) - /* Workaround "deferred signal handling" bug in FreeBSD 9.2. */ - if (0 == sig_arg) return; -# endif - ABORT("Bad signal in suspend_handler"); - } - - DISABLE_CANCEL(cancel_state); - /* pthread_setcancelstate is not defined to be async-signal-safe. */ - /* But the glibc version appears to be in the absence of */ - /* asynchronous cancellation. And since this signal handler */ - /* to block on sigsuspend, which is both async-signal-safe */ - /* and a cancellation point, there seems to be no obvious way */ - /* out of it. In fact, it looks to me like an async-signal-safe */ - /* cancellation point is inherently a problem, unless there is */ - /* some way to disable cancellation in the handler. */ -# ifdef DEBUG_THREADS - GC_log_printf("Suspending %p\n", (void *)self); -# endif - - me = GC_lookup_thread(self); - /* The lookup here is safe, since I'm doing this on behalf */ - /* of a thread which holds the allocation lock in order */ - /* to stop the world. Thus concurrent modification of the */ - /* data structure is impossible. */ - if (me -> stop_info.last_stop_count == my_stop_count) { - /* Duplicate signal. OK if we are retrying. */ - if (!GC_retry_signals) { - WARN("Duplicate suspend signal in thread %p\n", self); - } - RESTORE_CANCEL(cancel_state); - return; - } -# ifdef SPARC - me -> stop_info.stack_ptr = GC_save_regs_in_stack(); -# else - me -> stop_info.stack_ptr = GC_approx_sp(); -# endif -# ifdef IA64 - me -> backing_store_ptr = GC_save_regs_in_stack(); -# endif - - /* Tell the thread that wants to stop the world that this */ - /* thread has been stopped. Note that sem_post() is */ - /* the only async-signal-safe primitive in LinuxThreads. */ - sem_post(&GC_suspend_ack_sem); - me -> stop_info.last_stop_count = my_stop_count; - - /* Wait until that thread tells us to restart by sending */ - /* this thread a GC_sig_thr_restart signal (should be masked */ - /* at this point thus there is no race). */ - /* We do not continue until we receive that signal, */ - /* but we do not take that as authoritative. (We may be */ - /* accidentally restarted by one of the user signals we */ - /* don't block.) After we receive the signal, we use a */ - /* primitive and expensive mechanism to wait until it's */ - /* really safe to proceed. Under normal circumstances, */ - /* this code should not be executed. */ - do { - sigsuspend (&suspend_handler_mask); - } while (AO_load_acquire(&GC_world_is_stopped) - && AO_load(&GC_stop_count) == my_stop_count); - /* If the RESTART signal gets lost, we can still lose. That should */ - /* be less likely than losing the SUSPEND signal, since we don't do */ - /* much between the sem_post and sigsuspend. */ - /* We'd need more handshaking to work around that. */ - /* Simply dropping the sigsuspend call should be safe, but is */ - /* unlikely to be efficient. */ - -# ifdef DEBUG_THREADS - GC_log_printf("Continuing %p\n", (void *)self); -# endif - RESTORE_CANCEL(cancel_state); -} - -STATIC void GC_restart_handler(int sig) -{ -# if defined(DEBUG_THREADS) || defined(GC_NETBSD_THREADS_WORKAROUND) - int old_errno = errno; /* Preserve errno value. */ -# endif - - if (sig != GC_sig_thr_restart) - ABORT("Bad signal in restart handler"); - -# ifdef GC_NETBSD_THREADS_WORKAROUND - sem_post(&GC_restart_ack_sem); -# endif - - /* - ** Note: even if we don't do anything useful here, - ** it would still be necessary to have a signal handler, - ** rather than ignoring the signals, otherwise - ** the signals will not be delivered at all, and - ** will thus not interrupt the sigsuspend() above. - */ - -# ifdef DEBUG_THREADS - GC_log_printf("In GC_restart_handler for %p\n", (void *)pthread_self()); -# endif -# if defined(DEBUG_THREADS) || defined(GC_NETBSD_THREADS_WORKAROUND) - errno = old_errno; -# endif -} - -#endif /* !GC_OPENBSD_UTHREADS && !NACL */ - -#ifdef IA64 -# define IF_IA64(x) x -#else -# define IF_IA64(x) -#endif -/* We hold allocation lock. Should do exactly the right thing if the */ -/* world is stopped. Should not fail if it isn't. */ -GC_INNER void GC_push_all_stacks(void) -{ - GC_bool found_me = FALSE; - size_t nthreads = 0; - int i; - GC_thread p; - ptr_t lo, hi; - /* On IA64, we also need to scan the register backing store. */ - IF_IA64(ptr_t bs_lo; ptr_t bs_hi;) - struct GC_traced_stack_sect_s *traced_stack_sect; - pthread_t self = pthread_self(); - word total_size = 0; - - if (!EXPECT(GC_thr_initialized, TRUE)) - GC_thr_init(); -# ifdef DEBUG_THREADS - GC_log_printf("Pushing stacks from thread %p\n", (void *)self); -# endif - for (i = 0; i < THREAD_TABLE_SZ; i++) { - for (p = GC_threads[i]; p != 0; p = p -> next) { - if (p -> flags & FINISHED) continue; - ++nthreads; - traced_stack_sect = p -> traced_stack_sect; - if (THREAD_EQUAL(p -> id, self)) { - GC_ASSERT(!p->thread_blocked); -# ifdef SPARC - lo = (ptr_t)GC_save_regs_in_stack(); -# else - lo = GC_approx_sp(); -# endif - found_me = TRUE; - IF_IA64(bs_hi = (ptr_t)GC_save_regs_in_stack();) - } else { - lo = p -> stop_info.stack_ptr; - IF_IA64(bs_hi = p -> backing_store_ptr;) - if (traced_stack_sect != NULL - && traced_stack_sect->saved_stack_ptr == lo) { - /* If the thread has never been stopped since the recent */ - /* GC_call_with_gc_active invocation then skip the top */ - /* "stack section" as stack_ptr already points to. */ - traced_stack_sect = traced_stack_sect->prev; - } - } - if ((p -> flags & MAIN_THREAD) == 0) { - hi = p -> stack_end; - IF_IA64(bs_lo = p -> backing_store_end); - } else { - /* The original stack. */ - hi = GC_stackbottom; - IF_IA64(bs_lo = BACKING_STORE_BASE;) - } -# ifdef DEBUG_THREADS - GC_log_printf("Stack for thread %p = [%p,%p)\n", - (void *)p->id, lo, hi); -# endif - if (0 == lo) ABORT("GC_push_all_stacks: sp not set!"); - GC_push_all_stack_sections(lo, hi, traced_stack_sect); -# ifdef STACK_GROWS_UP - total_size += lo - hi; -# else - total_size += hi - lo; /* lo <= hi */ -# endif -# ifdef NACL - /* Push reg_storage as roots, this will cover the reg context. */ - GC_push_all_stack((ptr_t)p -> stop_info.reg_storage, - (ptr_t)(p -> stop_info.reg_storage + NACL_GC_REG_STORAGE_SIZE)); - total_size += NACL_GC_REG_STORAGE_SIZE * sizeof(ptr_t); -# endif -# ifdef IA64 -# ifdef DEBUG_THREADS - GC_log_printf("Reg stack for thread %p = [%p,%p)\n", - (void *)p->id, bs_lo, bs_hi); -# endif - /* FIXME: This (if p->id==self) may add an unbounded number of */ - /* entries, and hence overflow the mark stack, which is bad. */ - GC_push_all_register_sections(bs_lo, bs_hi, - THREAD_EQUAL(p -> id, self), - traced_stack_sect); - total_size += bs_hi - bs_lo; /* bs_lo <= bs_hi */ -# endif - } - } - GC_VERBOSE_LOG_PRINTF("Pushed %d thread stacks\n", (int)nthreads); - if (!found_me && !GC_in_thread_creation) - ABORT("Collecting from unknown thread"); - GC_total_stacksize = total_size; -} - -#ifdef DEBUG_THREADS - /* There seems to be a very rare thread stopping problem. To help us */ - /* debug that, we save the ids of the stopping thread. */ - pthread_t GC_stopping_thread; - int GC_stopping_pid = 0; -#endif - -#ifdef PLATFORM_ANDROID - extern int tkill(pid_t tid, int sig); /* from sys/linux-unistd.h */ - - static int android_thread_kill(pid_t tid, int sig) - { - int ret; - int old_errno = errno; - - ret = tkill(tid, sig); - if (ret < 0) { - ret = errno; - errno = old_errno; - } - - return ret; - } -#endif /* PLATFORM_ANDROID */ - -/* We hold the allocation lock. Suspend all threads that might */ -/* still be running. Return the number of suspend signals that */ -/* were sent. */ -STATIC int GC_suspend_all(void) -{ - int n_live_threads = 0; - int i; - -# ifndef NACL - GC_thread p; -# ifndef GC_OPENBSD_UTHREADS - int result; -# endif - pthread_t self = pthread_self(); - -# ifdef DEBUG_THREADS - GC_stopping_thread = self; - GC_stopping_pid = getpid(); -# endif - for (i = 0; i < THREAD_TABLE_SZ; i++) { - for (p = GC_threads[i]; p != 0; p = p -> next) { - if (!THREAD_EQUAL(p -> id, self)) { - if (p -> flags & FINISHED) continue; - if (p -> thread_blocked) /* Will wait */ continue; -# ifndef GC_OPENBSD_UTHREADS - if (p -> stop_info.last_stop_count == GC_stop_count) continue; - n_live_threads++; -# endif -# ifdef DEBUG_THREADS - GC_log_printf("Sending suspend signal to %p\n", (void *)p->id); -# endif - -# ifdef GC_OPENBSD_UTHREADS - { - stack_t stack; - if (pthread_suspend_np(p -> id) != 0) - ABORT("pthread_suspend_np failed"); - if (pthread_stackseg_np(p->id, &stack)) - ABORT("pthread_stackseg_np failed"); - p -> stop_info.stack_ptr = (ptr_t)stack.ss_sp - stack.ss_size; - } -# else -# ifndef PLATFORM_ANDROID - result = pthread_kill(p -> id, GC_sig_suspend); -# else - result = android_thread_kill(p -> kernel_id, GC_sig_suspend); -# endif - switch(result) { - case ESRCH: - /* Not really there anymore. Possible? */ - n_live_threads--; - break; - case 0: - break; - default: - ABORT_ARG1("pthread_kill failed at suspend", - ": errcode= %d", result); - } -# endif - } - } - } - -# else /* NACL */ -# ifndef NACL_PARK_WAIT_NANOSECONDS -# define NACL_PARK_WAIT_NANOSECONDS (100 * 1000) -# endif -# define NANOS_PER_SECOND (1000UL * 1000 * 1000) - unsigned long num_sleeps = 0; - -# ifdef DEBUG_THREADS - GC_log_printf("pthread_stop_world: num_threads %d\n", - GC_nacl_num_gc_threads - 1); -# endif - GC_nacl_thread_parker = pthread_self(); - GC_nacl_park_threads_now = 1; -# ifdef DEBUG_THREADS - GC_stopping_thread = GC_nacl_thread_parker; - GC_stopping_pid = getpid(); -# endif - - while (1) { - int num_threads_parked = 0; - struct timespec ts; - int num_used = 0; - - /* Check the 'parked' flag for each thread the GC knows about. */ - for (i = 0; i < MAX_NACL_GC_THREADS - && num_used < GC_nacl_num_gc_threads; i++) { - if (GC_nacl_thread_used[i] == 1) { - num_used++; - if (GC_nacl_thread_parked[i] == 1) { - num_threads_parked++; - } - } - } - /* -1 for the current thread. */ - if (num_threads_parked >= GC_nacl_num_gc_threads - 1) - break; - ts.tv_sec = 0; - ts.tv_nsec = NACL_PARK_WAIT_NANOSECONDS; -# ifdef DEBUG_THREADS - GC_log_printf("Sleep waiting for %d threads to park...\n", - GC_nacl_num_gc_threads - num_threads_parked - 1); -# endif - /* This requires _POSIX_TIMERS feature. */ - nanosleep(&ts, 0); - if (++num_sleeps > NANOS_PER_SECOND / NACL_PARK_WAIT_NANOSECONDS) { - WARN("GC appears stalled waiting for %" WARN_PRIdPTR - " threads to park...\n", - GC_nacl_num_gc_threads - num_threads_parked - 1); - num_sleeps = 0; - } - } -# endif /* NACL */ - return n_live_threads; -} - -GC_INNER void GC_stop_world(void) -{ -# if !defined(GC_OPENBSD_UTHREADS) && !defined(NACL) - int i; - int n_live_threads; - int code; -# endif - GC_ASSERT(I_HOLD_LOCK()); -# ifdef DEBUG_THREADS - GC_log_printf("Stopping the world from %p\n", (void *)pthread_self()); -# endif - - /* Make sure all free list construction has stopped before we start. */ - /* No new construction can start, since free list construction is */ - /* required to acquire and release the GC lock before it starts, */ - /* and we have the lock. */ -# ifdef PARALLEL_MARK - if (GC_parallel) { - GC_acquire_mark_lock(); - GC_ASSERT(GC_fl_builder_count == 0); - /* We should have previously waited for it to become zero. */ - } -# endif /* PARALLEL_MARK */ - -# if defined(GC_OPENBSD_UTHREADS) || defined(NACL) - (void)GC_suspend_all(); -# else - AO_store(&GC_stop_count, GC_stop_count+1); - /* Only concurrent reads are possible. */ - AO_store_release(&GC_world_is_stopped, TRUE); - n_live_threads = GC_suspend_all(); - - if (GC_retry_signals) { - unsigned long wait_usecs = 0; /* Total wait since retry. */ -# define WAIT_UNIT 3000 -# define RETRY_INTERVAL 100000 - for (;;) { - int ack_count; - - sem_getvalue(&GC_suspend_ack_sem, &ack_count); - if (ack_count == n_live_threads) break; - if (wait_usecs > RETRY_INTERVAL) { - int newly_sent = GC_suspend_all(); - - GC_COND_LOG_PRINTF("Resent %d signals after timeout\n", newly_sent); - sem_getvalue(&GC_suspend_ack_sem, &ack_count); - if (newly_sent < n_live_threads - ack_count) { - WARN("Lost some threads during GC_stop_world?!\n",0); - n_live_threads = ack_count + newly_sent; - } - wait_usecs = 0; - } - usleep(WAIT_UNIT); - wait_usecs += WAIT_UNIT; - } - } - - for (i = 0; i < n_live_threads; i++) { - retry: - code = sem_wait(&GC_suspend_ack_sem); - if (0 != code) { - /* On Linux, sem_wait is documented to always return zero. */ - /* But the documentation appears to be incorrect. */ - if (errno == EINTR) { - /* Seems to happen with some versions of gdb. */ - goto retry; - } - ABORT("sem_wait for handler failed"); - } - } -# endif - -# ifdef PARALLEL_MARK - if (GC_parallel) - GC_release_mark_lock(); -# endif -# ifdef DEBUG_THREADS - GC_log_printf("World stopped from %p\n", (void *)pthread_self()); - GC_stopping_thread = 0; -# endif -} - -#ifdef NACL -# if defined(__x86_64__) -# define NACL_STORE_REGS() \ - do { \ - __asm__ __volatile__ ("push %rbx"); \ - __asm__ __volatile__ ("push %rbp"); \ - __asm__ __volatile__ ("push %r12"); \ - __asm__ __volatile__ ("push %r13"); \ - __asm__ __volatile__ ("push %r14"); \ - __asm__ __volatile__ ("push %r15"); \ - __asm__ __volatile__ ("mov %%esp, %0" \ - : "=m" (GC_nacl_gc_thread_self->stop_info.stack_ptr)); \ - BCOPY(GC_nacl_gc_thread_self->stop_info.stack_ptr, \ - GC_nacl_gc_thread_self->stop_info.reg_storage, \ - NACL_GC_REG_STORAGE_SIZE * sizeof(ptr_t)); \ - __asm__ __volatile__ ("naclasp $48, %r15"); \ - } while (0) -# elif defined(__i386__) -# define NACL_STORE_REGS() \ - do { \ - __asm__ __volatile__ ("push %ebx"); \ - __asm__ __volatile__ ("push %ebp"); \ - __asm__ __volatile__ ("push %esi"); \ - __asm__ __volatile__ ("push %edi"); \ - __asm__ __volatile__ ("mov %%esp, %0" \ - : "=m" (GC_nacl_gc_thread_self->stop_info.stack_ptr)); \ - BCOPY(GC_nacl_gc_thread_self->stop_info.stack_ptr, \ - GC_nacl_gc_thread_self->stop_info.reg_storage, \ - NACL_GC_REG_STORAGE_SIZE * sizeof(ptr_t));\ - __asm__ __volatile__ ("add $16, %esp"); \ - } while (0) -# else -# error FIXME for non-amd64/x86 NaCl -# endif - - GC_API_OSCALL void nacl_pre_syscall_hook(void) - { - if (GC_nacl_thread_idx != -1) { - NACL_STORE_REGS(); - GC_nacl_gc_thread_self->stop_info.stack_ptr = GC_approx_sp(); - GC_nacl_thread_parked[GC_nacl_thread_idx] = 1; - } - } - - GC_API_OSCALL void __nacl_suspend_thread_if_needed(void) - { - if (GC_nacl_park_threads_now) { - pthread_t self = pthread_self(); - - /* Don't try to park the thread parker. */ - if (GC_nacl_thread_parker == self) - return; - - /* This can happen when a thread is created outside of the GC */ - /* system (wthread mostly). */ - if (GC_nacl_thread_idx < 0) - return; - - /* If it was already 'parked', we're returning from a syscall, */ - /* so don't bother storing registers again, the GC has a set. */ - if (!GC_nacl_thread_parked[GC_nacl_thread_idx]) { - NACL_STORE_REGS(); - GC_nacl_gc_thread_self->stop_info.stack_ptr = GC_approx_sp(); - } - GC_nacl_thread_parked[GC_nacl_thread_idx] = 1; - while (GC_nacl_park_threads_now) { - /* Just spin. */ - } - GC_nacl_thread_parked[GC_nacl_thread_idx] = 0; - - /* Clear out the reg storage for next suspend. */ - BZERO(GC_nacl_gc_thread_self->stop_info.reg_storage, - NACL_GC_REG_STORAGE_SIZE * sizeof(ptr_t)); - } - } - - GC_API_OSCALL void nacl_post_syscall_hook(void) - { - /* Calling __nacl_suspend_thread_if_needed right away should */ - /* guarantee we don't mutate the GC set. */ - __nacl_suspend_thread_if_needed(); - if (GC_nacl_thread_idx != -1) { - GC_nacl_thread_parked[GC_nacl_thread_idx] = 0; - } - } - - STATIC GC_bool GC_nacl_thread_parking_inited = FALSE; - STATIC pthread_mutex_t GC_nacl_thread_alloc_lock = PTHREAD_MUTEX_INITIALIZER; - - extern void nacl_register_gc_hooks(void (*pre)(void), void (*post)(void)); - - GC_INNER void GC_nacl_initialize_gc_thread(void) - { - int i; - nacl_register_gc_hooks(nacl_pre_syscall_hook, nacl_post_syscall_hook); - pthread_mutex_lock(&GC_nacl_thread_alloc_lock); - if (!EXPECT(GC_nacl_thread_parking_inited, TRUE)) { - BZERO(GC_nacl_thread_parked, sizeof(GC_nacl_thread_parked)); - BZERO(GC_nacl_thread_used, sizeof(GC_nacl_thread_used)); - GC_nacl_thread_parking_inited = TRUE; - } - GC_ASSERT(GC_nacl_num_gc_threads <= MAX_NACL_GC_THREADS); - for (i = 0; i < MAX_NACL_GC_THREADS; i++) { - if (GC_nacl_thread_used[i] == 0) { - GC_nacl_thread_used[i] = 1; - GC_nacl_thread_idx = i; - GC_nacl_num_gc_threads++; - break; - } - } - pthread_mutex_unlock(&GC_nacl_thread_alloc_lock); - } - - GC_INNER void GC_nacl_shutdown_gc_thread(void) - { - pthread_mutex_lock(&GC_nacl_thread_alloc_lock); - GC_ASSERT(GC_nacl_thread_idx >= 0); - GC_ASSERT(GC_nacl_thread_idx < MAX_NACL_GC_THREADS); - GC_ASSERT(GC_nacl_thread_used[GC_nacl_thread_idx] != 0); - GC_nacl_thread_used[GC_nacl_thread_idx] = 0; - GC_nacl_thread_idx = -1; - GC_nacl_num_gc_threads--; - pthread_mutex_unlock(&GC_nacl_thread_alloc_lock); - } -#endif /* NACL */ - -/* Caller holds allocation lock, and has held it continuously since */ -/* the world stopped. */ -GC_INNER void GC_start_world(void) -{ -# ifndef NACL - pthread_t self = pthread_self(); - register int i; - register GC_thread p; -# ifndef GC_OPENBSD_UTHREADS - register int n_live_threads = 0; - register int result; -# endif -# ifdef GC_NETBSD_THREADS_WORKAROUND - int code; -# endif - -# ifdef DEBUG_THREADS - GC_log_printf("World starting\n"); -# endif - -# ifndef GC_OPENBSD_UTHREADS - AO_store(&GC_world_is_stopped, FALSE); -# endif - for (i = 0; i < THREAD_TABLE_SZ; i++) { - for (p = GC_threads[i]; p != 0; p = p -> next) { - if (!THREAD_EQUAL(p -> id, self)) { - if (p -> flags & FINISHED) continue; - if (p -> thread_blocked) continue; -# ifndef GC_OPENBSD_UTHREADS - n_live_threads++; -# endif -# ifdef DEBUG_THREADS - GC_log_printf("Sending restart signal to %p\n", (void *)p->id); -# endif - -# ifdef GC_OPENBSD_UTHREADS - if (pthread_resume_np(p -> id) != 0) - ABORT("pthread_resume_np failed"); -# else -# ifndef PLATFORM_ANDROID - result = pthread_kill(p -> id, GC_sig_thr_restart); -# else - result = android_thread_kill(p -> kernel_id, - GC_sig_thr_restart); -# endif - switch(result) { - case ESRCH: - /* Not really there anymore. Possible? */ - n_live_threads--; - break; - case 0: - break; - default: - ABORT_ARG1("pthread_kill failed at resume", - ": errcode= %d", result); - } -# endif - } - } - } -# ifdef GC_NETBSD_THREADS_WORKAROUND - for (i = 0; i < n_live_threads; i++) { - while (0 != (code = sem_wait(&GC_restart_ack_sem))) { - if (errno != EINTR) { - ABORT_ARG1("sem_wait() for restart handler failed", - ": errcode= %d", code); - } - } - } -# endif -# ifdef DEBUG_THREADS - GC_log_printf("World started\n"); -# endif -# else /* NACL */ -# ifdef DEBUG_THREADS - GC_log_printf("World starting...\n"); -# endif - GC_nacl_park_threads_now = 0; -# endif -} - -GC_INNER void GC_stop_init(void) -{ -# if !defined(GC_OPENBSD_UTHREADS) && !defined(NACL) - struct sigaction act; - - if (SIGNAL_UNSET == GC_sig_suspend) - GC_sig_suspend = SIG_SUSPEND; - if (SIGNAL_UNSET == GC_sig_thr_restart) - GC_sig_thr_restart = SIG_THR_RESTART; - if (GC_sig_suspend == GC_sig_thr_restart) - ABORT("Cannot use same signal for thread suspend and resume"); - - if (sem_init(&GC_suspend_ack_sem, GC_SEM_INIT_PSHARED, 0) != 0) - ABORT("sem_init failed"); -# ifdef GC_NETBSD_THREADS_WORKAROUND - if (sem_init(&GC_restart_ack_sem, GC_SEM_INIT_PSHARED, 0) != 0) - ABORT("sem_init failed"); -# endif - -# ifdef SA_RESTART - act.sa_flags = SA_RESTART -# else - act.sa_flags = 0 -# endif -# ifdef SA_SIGINFO - | SA_SIGINFO -# endif - ; - if (sigfillset(&act.sa_mask) != 0) { - ABORT("sigfillset failed"); - } -# ifdef GC_RTEMS_PTHREADS - if(sigprocmask(SIG_UNBLOCK, &act.sa_mask, NULL) != 0) { - ABORT("sigprocmask failed"); - } -# endif - GC_remove_allowed_signals(&act.sa_mask); - /* GC_sig_thr_restart is set in the resulting mask. */ - /* It is unmasked by the handler when necessary. */ -# ifdef SA_SIGINFO - act.sa_sigaction = GC_suspend_handler; -# else - act.sa_handler = GC_suspend_handler; -# endif - /* act.sa_restorer is deprecated and should not be initialized. */ - if (sigaction(GC_sig_suspend, &act, NULL) != 0) { - ABORT("Cannot set SIG_SUSPEND handler"); - } - -# ifdef SA_SIGINFO - act.sa_flags &= ~SA_SIGINFO; -# endif - act.sa_handler = GC_restart_handler; - if (sigaction(GC_sig_thr_restart, &act, NULL) != 0) { - ABORT("Cannot set SIG_THR_RESTART handler"); - } - - /* Initialize suspend_handler_mask (excluding GC_sig_thr_restart). */ - if (sigfillset(&suspend_handler_mask) != 0) ABORT("sigfillset failed"); - GC_remove_allowed_signals(&suspend_handler_mask); - if (sigdelset(&suspend_handler_mask, GC_sig_thr_restart) != 0) - ABORT("sigdelset failed"); - - /* Check for GC_RETRY_SIGNALS. */ - if (0 != GETENV("GC_RETRY_SIGNALS")) { - GC_retry_signals = TRUE; - } - if (0 != GETENV("GC_NO_RETRY_SIGNALS")) { - GC_retry_signals = FALSE; - } - if (GC_retry_signals) { - GC_COND_LOG_PRINTF("Will retry suspend signal if necessary\n"); - } -# endif /* !GC_OPENBSD_UTHREADS && !NACL */ -} - -#endif /* GC_PTHREADS && !GC_DARWIN_THREADS && !GC_WIN32_THREADS */ diff -Nru ecl-16.1.2/src/bdwgc/pthread_support.c ecl-16.1.3+ds/src/bdwgc/pthread_support.c --- ecl-16.1.2/src/bdwgc/pthread_support.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/pthread_support.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,2125 +0,0 @@ -/* - * Copyright (c) 1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996 by Silicon Graphics. All rights reserved. - * Copyright (c) 1998 by Fergus Henderson. All rights reserved. - * Copyright (c) 2000-2005 by Hewlett-Packard Company. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#include "private/pthread_support.h" - -/* - * Support code originally for LinuxThreads, the clone()-based kernel - * thread package for Linux which is included in libc6. - * - * This code no doubt makes some assumptions beyond what is - * guaranteed by the pthread standard, though it now does - * very little of that. It now also supports NPTL, and many - * other Posix thread implementations. We are trying to merge - * all flavors of pthread support code into this file. - */ - -/* - * Linux_threads.c now also includes some code to support HPUX and - * OSF1 (Compaq Tru64 Unix, really). The OSF1 support is based on Eric Benson's - * patch. - * - * Eric also suggested an alternate basis for a lock implementation in - * his code: - * + #elif defined(OSF1) - * + unsigned long GC_allocate_lock = 0; - * + msemaphore GC_allocate_semaphore; - * + # define GC_TRY_LOCK() \ - * + ((msem_lock(&GC_allocate_semaphore, MSEM_IF_NOWAIT) == 0) \ - * + ? (GC_allocate_lock = 1) \ - * + : 0) - * + # define GC_LOCK_TAKEN GC_allocate_lock - */ - -#if defined(GC_PTHREADS) && !defined(GC_WIN32_THREADS) - -# include -# include -# include -# include -# include -# include -# if !defined(GC_RTEMS_PTHREADS) -# include -# endif -# include -# include -# include -# include -# include - -# include "gc_inline.h" - -#if defined(GC_DARWIN_THREADS) -# include "private/darwin_semaphore.h" -#else -# include -#endif /* !GC_DARWIN_THREADS */ - -#if defined(GC_DARWIN_THREADS) || defined(GC_FREEBSD_THREADS) -# include -#endif /* GC_DARWIN_THREADS */ - -#if defined(GC_NETBSD_THREADS) || defined(GC_OPENBSD_THREADS) -# include -# include -#endif /* GC_NETBSD_THREADS */ - -/* Allocator lock definitions. */ -#if !defined(USE_SPIN_LOCK) - GC_INNER pthread_mutex_t GC_allocate_ml = PTHREAD_MUTEX_INITIALIZER; -#endif - -#ifdef GC_ASSERTIONS - GC_INNER unsigned long GC_lock_holder = NO_THREAD; - /* Used only for assertions. */ -#endif - -#if defined(GC_DGUX386_THREADS) -# include -# include - /* sem_t is an uint in DG/UX */ - typedef unsigned int sem_t; -#endif /* GC_DGUX386_THREADS */ - -/* Undefine macros used to redirect pthread primitives. */ -# undef pthread_create -# ifndef GC_NO_PTHREAD_SIGMASK -# undef pthread_sigmask -# endif -# ifndef GC_NO_PTHREAD_CANCEL -# undef pthread_cancel -# endif -# ifdef GC_PTHREAD_EXIT_ATTRIBUTE -# undef pthread_exit -# endif -# undef pthread_join -# undef pthread_detach -# if defined(GC_OSF1_THREADS) && defined(_PTHREAD_USE_MANGLED_NAMES_) \ - && !defined(_PTHREAD_USE_PTDNAM_) - /* Restore the original mangled names on Tru64 UNIX. */ -# define pthread_create __pthread_create -# define pthread_join __pthread_join -# define pthread_detach __pthread_detach -# ifndef GC_NO_PTHREAD_CANCEL -# define pthread_cancel __pthread_cancel -# endif -# ifdef GC_PTHREAD_EXIT_ATTRIBUTE -# define pthread_exit __pthread_exit -# endif -# endif - -#ifdef GC_USE_LD_WRAP -# define WRAP_FUNC(f) __wrap_##f -# define REAL_FUNC(f) __real_##f - int REAL_FUNC(pthread_create)(pthread_t *, - GC_PTHREAD_CREATE_CONST pthread_attr_t *, - void *(*start_routine)(void *), void *); - int REAL_FUNC(pthread_join)(pthread_t, void **); - int REAL_FUNC(pthread_detach)(pthread_t); -# ifndef GC_NO_PTHREAD_SIGMASK - int REAL_FUNC(pthread_sigmask)(int, const sigset_t *, sigset_t *); -# endif -# ifndef GC_NO_PTHREAD_CANCEL - int REAL_FUNC(pthread_cancel)(pthread_t); -# endif -# ifdef GC_PTHREAD_EXIT_ATTRIBUTE - void REAL_FUNC(pthread_exit)(void *) GC_PTHREAD_EXIT_ATTRIBUTE; -# endif -#else -# ifdef GC_USE_DLOPEN_WRAP -# include -# define WRAP_FUNC(f) f -# define REAL_FUNC(f) GC_real_##f - /* We define both GC_f and plain f to be the wrapped function. */ - /* In that way plain calls work, as do calls from files that */ - /* included gc.h, which redefined f to GC_f. */ - /* FIXME: Needs work for DARWIN and True64 (OSF1) */ - typedef int (* GC_pthread_create_t)(pthread_t *, - GC_PTHREAD_CREATE_CONST pthread_attr_t *, - void * (*)(void *), void *); - static GC_pthread_create_t REAL_FUNC(pthread_create); -# ifndef GC_NO_PTHREAD_SIGMASK - typedef int (* GC_pthread_sigmask_t)(int, const sigset_t *, - sigset_t *); - static GC_pthread_sigmask_t REAL_FUNC(pthread_sigmask); -# endif - typedef int (* GC_pthread_join_t)(pthread_t, void **); - static GC_pthread_join_t REAL_FUNC(pthread_join); - typedef int (* GC_pthread_detach_t)(pthread_t); - static GC_pthread_detach_t REAL_FUNC(pthread_detach); -# ifndef GC_NO_PTHREAD_CANCEL - typedef int (* GC_pthread_cancel_t)(pthread_t); - static GC_pthread_cancel_t REAL_FUNC(pthread_cancel); -# endif -# ifdef GC_PTHREAD_EXIT_ATTRIBUTE - typedef void (* GC_pthread_exit_t)(void *) GC_PTHREAD_EXIT_ATTRIBUTE; - static GC_pthread_exit_t REAL_FUNC(pthread_exit); -# endif -# else -# define WRAP_FUNC(f) GC_##f -# if !defined(GC_DGUX386_THREADS) -# define REAL_FUNC(f) f -# else /* GC_DGUX386_THREADS */ -# define REAL_FUNC(f) __d10_##f -# endif /* GC_DGUX386_THREADS */ -# endif -#endif - -#if defined(GC_USE_LD_WRAP) || defined(GC_USE_DLOPEN_WRAP) - /* Define GC_ functions as aliases for the plain ones, which will */ - /* be intercepted. This allows files which include gc.h, and hence */ - /* generate references to the GC_ symbols, to see the right symbols. */ - GC_API int GC_pthread_create(pthread_t * t, - GC_PTHREAD_CREATE_CONST pthread_attr_t *a, - void * (* fn)(void *), void * arg) - { - return pthread_create(t, a, fn, arg); - } - -# ifndef GC_NO_PTHREAD_SIGMASK - GC_API int GC_pthread_sigmask(int how, const sigset_t *mask, - sigset_t *old) - { - return pthread_sigmask(how, mask, old); - } -# endif /* !GC_NO_PTHREAD_SIGMASK */ - - GC_API int GC_pthread_join(pthread_t t, void **res) - { - return pthread_join(t, res); - } - - GC_API int GC_pthread_detach(pthread_t t) - { - return pthread_detach(t); - } - -# ifndef GC_NO_PTHREAD_CANCEL - GC_API int GC_pthread_cancel(pthread_t t) - { - return pthread_cancel(t); - } -# endif /* !GC_NO_PTHREAD_CANCEL */ - -# ifdef GC_PTHREAD_EXIT_ATTRIBUTE - GC_API GC_PTHREAD_EXIT_ATTRIBUTE void GC_pthread_exit(void *retval) - { - pthread_exit(retval); - } -# endif /* GC_PTHREAD_EXIT_ATTRIBUTE */ -#endif /* Linker-based interception. */ - -#ifdef GC_USE_DLOPEN_WRAP - STATIC GC_bool GC_syms_initialized = FALSE; - - STATIC void GC_init_real_syms(void) - { - void *dl_handle; - - if (GC_syms_initialized) return; -# ifdef RTLD_NEXT - dl_handle = RTLD_NEXT; -# else - dl_handle = dlopen("libpthread.so.0", RTLD_LAZY); - if (NULL == dl_handle) { - dl_handle = dlopen("libpthread.so", RTLD_LAZY); /* without ".0" */ - } - if (NULL == dl_handle) ABORT("Couldn't open libpthread"); -# endif - REAL_FUNC(pthread_create) = (GC_pthread_create_t) - dlsym(dl_handle, "pthread_create"); -# ifdef RTLD_NEXT - if (REAL_FUNC(pthread_create) == 0) - ABORT("pthread_create not found" - " (probably -lgc is specified after -lpthread)"); -# endif -# ifndef GC_NO_PTHREAD_SIGMASK - REAL_FUNC(pthread_sigmask) = (GC_pthread_sigmask_t) - dlsym(dl_handle, "pthread_sigmask"); -# endif - REAL_FUNC(pthread_join) = (GC_pthread_join_t) - dlsym(dl_handle, "pthread_join"); - REAL_FUNC(pthread_detach) = (GC_pthread_detach_t) - dlsym(dl_handle, "pthread_detach"); -# ifndef GC_NO_PTHREAD_CANCEL - REAL_FUNC(pthread_cancel) = (GC_pthread_cancel_t) - dlsym(dl_handle, "pthread_cancel"); -# endif -# ifdef GC_PTHREAD_EXIT_ATTRIBUTE - REAL_FUNC(pthread_exit) = (GC_pthread_exit_t) - dlsym(dl_handle, "pthread_exit"); -# endif - GC_syms_initialized = TRUE; - } - -# define INIT_REAL_SYMS() if (EXPECT(GC_syms_initialized, TRUE)) {} \ - else GC_init_real_syms() -#else -# define INIT_REAL_SYMS() (void)0 -#endif - -static GC_bool parallel_initialized = FALSE; - -#ifndef GC_ALWAYS_MULTITHREADED - GC_INNER GC_bool GC_need_to_lock = FALSE; -#endif - -STATIC int GC_nprocs = 1; - /* Number of processors. We may not have */ - /* access to all of them, but this is as good */ - /* a guess as any ... */ - -#ifdef THREAD_LOCAL_ALLOC - /* We must explicitly mark ptrfree and gcj free lists, since the free */ - /* list links wouldn't otherwise be found. We also set them in the */ - /* normal free lists, since that involves touching less memory than */ - /* if we scanned them normally. */ - GC_INNER void GC_mark_thread_local_free_lists(void) - { - int i; - GC_thread p; - - for (i = 0; i < THREAD_TABLE_SZ; ++i) { - for (p = GC_threads[i]; 0 != p; p = p -> next) { - if (!(p -> flags & FINISHED)) - GC_mark_thread_local_fls_for(&(p->tlfs)); - } - } - } - -# if defined(GC_ASSERTIONS) - void GC_check_tls_for(GC_tlfs p); -# if defined(USE_CUSTOM_SPECIFIC) - void GC_check_tsd_marks(tsd *key); -# endif - - /* Check that all thread-local free-lists are completely marked. */ - /* Also check that thread-specific-data structures are marked. */ - void GC_check_tls(void) - { - int i; - GC_thread p; - - for (i = 0; i < THREAD_TABLE_SZ; ++i) { - for (p = GC_threads[i]; 0 != p; p = p -> next) { - if (!(p -> flags & FINISHED)) - GC_check_tls_for(&(p->tlfs)); - } - } -# if defined(USE_CUSTOM_SPECIFIC) - if (GC_thread_key != 0) - GC_check_tsd_marks(GC_thread_key); -# endif - } -# endif /* GC_ASSERTIONS */ - -#endif /* THREAD_LOCAL_ALLOC */ - -#ifdef PARALLEL_MARK - -# ifndef MAX_MARKERS -# define MAX_MARKERS 16 -# endif - -static ptr_t marker_sp[MAX_MARKERS - 1] = {0}; -#ifdef IA64 - static ptr_t marker_bsp[MAX_MARKERS - 1] = {0}; -#endif - -#if defined(GC_DARWIN_THREADS) && !defined(GC_NO_THREADS_DISCOVERY) - static mach_port_t marker_mach_threads[MAX_MARKERS - 1] = {0}; - - /* Used only by GC_suspend_thread_list(). */ - GC_INNER GC_bool GC_is_mach_marker(thread_act_t thread) - { - int i; - for (i = 0; i < GC_markers_m1; i++) { - if (marker_mach_threads[i] == thread) - return TRUE; - } - return FALSE; - } -#endif /* GC_DARWIN_THREADS */ - -STATIC void * GC_mark_thread(void * id) -{ - word my_mark_no = 0; - IF_CANCEL(int cancel_state;) - - if ((word)id == (word)-1) return 0; /* to make compiler happy */ - DISABLE_CANCEL(cancel_state); - /* Mark threads are not cancellable; they */ - /* should be invisible to client. */ - marker_sp[(word)id] = GC_approx_sp(); -# ifdef IA64 - marker_bsp[(word)id] = GC_save_regs_in_stack(); -# endif -# if defined(GC_DARWIN_THREADS) && !defined(GC_NO_THREADS_DISCOVERY) - marker_mach_threads[(word)id] = mach_thread_self(); -# endif - - for (;; ++my_mark_no) { - /* GC_mark_no is passed only to allow GC_help_marker to terminate */ - /* promptly. This is important if it were called from the signal */ - /* handler or from the GC lock acquisition code. Under Linux, it's */ - /* not safe to call it from a signal handler, since it uses mutexes */ - /* and condition variables. Since it is called only here, the */ - /* argument is unnecessary. */ - if (my_mark_no < GC_mark_no || my_mark_no > GC_mark_no + 2) { - /* resynchronize if we get far off, e.g. because GC_mark_no */ - /* wrapped. */ - my_mark_no = GC_mark_no; - } -# ifdef DEBUG_THREADS - GC_log_printf("Starting mark helper for mark number %lu\n", - (unsigned long)my_mark_no); -# endif - GC_help_marker(my_mark_no); - } -} - -STATIC pthread_t GC_mark_threads[MAX_MARKERS]; - -#ifdef CAN_HANDLE_FORK - static int available_markers_m1 = 0; -# define start_mark_threads GC_start_mark_threads - GC_API void GC_CALL -#else -# define available_markers_m1 GC_markers_m1 - static void -#endif -start_mark_threads(void) -{ - int i; - pthread_attr_t attr; - - GC_ASSERT(I_DONT_HOLD_LOCK()); -# ifdef CAN_HANDLE_FORK - if (available_markers_m1 <= 0 || GC_parallel) return; - /* Skip if parallel markers disabled or already started. */ -# endif - - INIT_REAL_SYMS(); /* for pthread_create */ - - if (0 != pthread_attr_init(&attr)) ABORT("pthread_attr_init failed"); - if (0 != pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED)) - ABORT("pthread_attr_setdetachstate failed"); - -# if defined(HPUX) || defined(GC_DGUX386_THREADS) - /* Default stack size is usually too small: fix it. */ - /* Otherwise marker threads or GC may run out of */ - /* space. */ -# define MIN_STACK_SIZE (8*HBLKSIZE*sizeof(word)) - { - size_t old_size; - - if (pthread_attr_getstacksize(&attr, &old_size) != 0) - ABORT("pthread_attr_getstacksize failed"); - if (old_size < MIN_STACK_SIZE) { - if (pthread_attr_setstacksize(&attr, MIN_STACK_SIZE) != 0) - ABORT("pthread_attr_setstacksize failed"); - } - } -# endif /* HPUX || GC_DGUX386_THREADS */ - for (i = 0; i < available_markers_m1; ++i) { - if (0 != REAL_FUNC(pthread_create)(GC_mark_threads + i, &attr, - GC_mark_thread, (void *)(word)i)) { - WARN("Marker thread creation failed, errno = %" WARN_PRIdPTR "\n", - errno); - /* Don't try to create other marker threads. */ - break; - } - } - GC_markers_m1 = i; - (void)pthread_attr_destroy(&attr); - GC_COND_LOG_PRINTF("Started %d mark helper threads\n", GC_markers_m1); -} - -#endif /* PARALLEL_MARK */ - -GC_INNER GC_bool GC_thr_initialized = FALSE; - -GC_INNER volatile GC_thread GC_threads[THREAD_TABLE_SZ] = {0}; - -void GC_push_thread_structures(void) -{ - GC_ASSERT(I_HOLD_LOCK()); - GC_push_all((ptr_t)(GC_threads), (ptr_t)(GC_threads)+sizeof(GC_threads)); -# if defined(THREAD_LOCAL_ALLOC) - GC_push_all((ptr_t)(&GC_thread_key), - (ptr_t)(&GC_thread_key) + sizeof(GC_thread_key)); -# endif -} - -#ifdef DEBUG_THREADS - STATIC int GC_count_threads(void) - { - int i; - int count = 0; - GC_ASSERT(I_HOLD_LOCK()); - for (i = 0; i < THREAD_TABLE_SZ; ++i) { - GC_thread th = GC_threads[i]; - while (th) { - if (!(th->flags & FINISHED)) - ++count; - th = th->next; - } - } - return count; - } -#endif /* DEBUG_THREADS */ - -/* It may not be safe to allocate when we register the first thread. */ -static struct GC_Thread_Rep first_thread; - -/* Add a thread to GC_threads. We assume it wasn't already there. */ -/* Caller holds allocation lock. */ -STATIC GC_thread GC_new_thread(pthread_t id) -{ - int hv = NUMERIC_THREAD_ID(id) % THREAD_TABLE_SZ; - GC_thread result; - static GC_bool first_thread_used = FALSE; -# ifdef DEBUG_THREADS - GC_log_printf("Creating thread %p\n", (void *)id); -# endif - - GC_ASSERT(I_HOLD_LOCK()); - if (!EXPECT(first_thread_used, TRUE)) { - result = &first_thread; - first_thread_used = TRUE; - } else { - result = (struct GC_Thread_Rep *) - GC_INTERNAL_MALLOC(sizeof(struct GC_Thread_Rep), NORMAL); - if (result == 0) return(0); - } - result -> id = id; -# ifdef PLATFORM_ANDROID - result -> kernel_id = gettid(); -# endif - result -> next = GC_threads[hv]; - GC_threads[hv] = result; -# ifdef NACL - GC_nacl_gc_thread_self = result; - GC_nacl_initialize_gc_thread(); -# endif - GC_ASSERT(result -> flags == 0 && result -> thread_blocked == 0); - return(result); -} - -/* Delete a thread from GC_threads. We assume it is there. */ -/* (The code intentionally traps if it wasn't.) */ -/* It is safe to delete the main thread. */ -STATIC void GC_delete_thread(pthread_t id) -{ - int hv = NUMERIC_THREAD_ID(id) % THREAD_TABLE_SZ; - register GC_thread p = GC_threads[hv]; - register GC_thread prev = 0; - -# ifdef DEBUG_THREADS - GC_log_printf("Deleting thread %p, n_threads = %d\n", - (void *)id, GC_count_threads()); -# endif - -# ifdef NACL - GC_nacl_shutdown_gc_thread(); - GC_nacl_gc_thread_self = NULL; -# endif - - GC_ASSERT(I_HOLD_LOCK()); - while (!THREAD_EQUAL(p -> id, id)) { - prev = p; - p = p -> next; - } - if (prev == 0) { - GC_threads[hv] = p -> next; - } else { - prev -> next = p -> next; - } - if (p != &first_thread) { -# ifdef GC_DARWIN_THREADS - mach_port_deallocate(mach_task_self(), p->stop_info.mach_thread); -# endif - GC_INTERNAL_FREE(p); - } -} - -/* If a thread has been joined, but we have not yet */ -/* been notified, then there may be more than one thread */ -/* in the table with the same pthread id. */ -/* This is OK, but we need a way to delete a specific one. */ -STATIC void GC_delete_gc_thread(GC_thread t) -{ - pthread_t id = t -> id; - int hv = NUMERIC_THREAD_ID(id) % THREAD_TABLE_SZ; - register GC_thread p = GC_threads[hv]; - register GC_thread prev = 0; - - GC_ASSERT(I_HOLD_LOCK()); - while (p != t) { - prev = p; - p = p -> next; - } - if (prev == 0) { - GC_threads[hv] = p -> next; - } else { - prev -> next = p -> next; - } -# ifdef GC_DARWIN_THREADS - mach_port_deallocate(mach_task_self(), p->stop_info.mach_thread); -# endif - GC_INTERNAL_FREE(p); - -# ifdef DEBUG_THREADS - GC_log_printf("Deleted thread %p, n_threads = %d\n", - (void *)id, GC_count_threads()); -# endif -} - -/* Return a GC_thread corresponding to a given pthread_t. */ -/* Returns 0 if it's not there. */ -/* Caller holds allocation lock or otherwise inhibits */ -/* updates. */ -/* If there is more than one thread with the given id we */ -/* return the most recent one. */ -GC_INNER GC_thread GC_lookup_thread(pthread_t id) -{ - int hv = NUMERIC_THREAD_ID(id) % THREAD_TABLE_SZ; - register GC_thread p = GC_threads[hv]; - - while (p != 0 && !THREAD_EQUAL(p -> id, id)) p = p -> next; - return(p); -} - -/* Called by GC_finalize() (in case of an allocation failure observed). */ -GC_INNER void GC_reset_finalizer_nested(void) -{ - GC_thread me = GC_lookup_thread(pthread_self()); - me->finalizer_nested = 0; -} - -/* Checks and updates the thread-local level of finalizers recursion. */ -/* Returns NULL if GC_invoke_finalizers() should not be called by the */ -/* collector (to minimize the risk of a deep finalizers recursion), */ -/* otherwise returns a pointer to the thread-local finalizer_nested. */ -/* Called by GC_notify_or_invoke_finalizers() only (the lock is held). */ -GC_INNER unsigned char *GC_check_finalizer_nested(void) -{ - GC_thread me = GC_lookup_thread(pthread_self()); - unsigned nesting_level = me->finalizer_nested; - if (nesting_level) { - /* We are inside another GC_invoke_finalizers(). */ - /* Skip some implicitly-called GC_invoke_finalizers() */ - /* depending on the nesting (recursion) level. */ - if (++me->finalizer_skipped < (1U << nesting_level)) return NULL; - me->finalizer_skipped = 0; - } - me->finalizer_nested = (unsigned char)(nesting_level + 1); - return &me->finalizer_nested; -} - -#if defined(GC_ASSERTIONS) && defined(THREAD_LOCAL_ALLOC) - /* This is called from thread-local GC_malloc(). */ - GC_bool GC_is_thread_tsd_valid(void *tsd) - { - GC_thread me; - DCL_LOCK_STATE; - - LOCK(); - me = GC_lookup_thread(pthread_self()); - UNLOCK(); - return (word)tsd >= (word)(&me->tlfs) - && (word)tsd < (word)(&me->tlfs) + sizeof(me->tlfs); - } -#endif /* GC_ASSERTIONS && THREAD_LOCAL_ALLOC */ - -GC_API int GC_CALL GC_thread_is_registered(void) -{ - pthread_t self = pthread_self(); - GC_thread me; - DCL_LOCK_STATE; - - LOCK(); - me = GC_lookup_thread(self); - UNLOCK(); - return me != NULL; -} - -#ifdef CAN_HANDLE_FORK -/* Remove all entries from the GC_threads table, except the */ -/* one for the current thread. We need to do this in the child */ -/* process after a fork(), since only the current thread */ -/* survives in the child. */ -STATIC void GC_remove_all_threads_but_me(void) -{ - pthread_t self = pthread_self(); - int hv; - GC_thread p, next, me; - - for (hv = 0; hv < THREAD_TABLE_SZ; ++hv) { - me = 0; - for (p = GC_threads[hv]; 0 != p; p = next) { - next = p -> next; - if (THREAD_EQUAL(p -> id, self)) { - me = p; - p -> next = 0; -# ifdef GC_DARWIN_THREADS - /* Update thread Id after fork (it is OK to call */ - /* GC_destroy_thread_local and GC_free_internal */ - /* before update). */ - me -> stop_info.mach_thread = mach_thread_self(); -# elif defined(PLATFORM_ANDROID) - me -> kernel_id = gettid(); -# endif -# if defined(THREAD_LOCAL_ALLOC) && !defined(USE_CUSTOM_SPECIFIC) - /* Some TLS implementations might be not fork-friendly, so */ - /* we re-assign thread-local pointer to 'tlfs' for safety */ - /* instead of the assertion check (again, it is OK to call */ - /* GC_destroy_thread_local and GC_free_internal before). */ - if (GC_setspecific(GC_thread_key, &me->tlfs) != 0) - ABORT("GC_setspecific failed (in child)"); -# endif - } else { -# ifdef THREAD_LOCAL_ALLOC - if (!(p -> flags & FINISHED)) { - GC_destroy_thread_local(&(p->tlfs)); - GC_remove_specific(GC_thread_key); - } -# endif - if (p != &first_thread) GC_INTERNAL_FREE(p); - } - } - GC_threads[hv] = me; - } -} -#endif /* CAN_HANDLE_FORK */ - -#ifdef USE_PROC_FOR_LIBRARIES - GC_INNER GC_bool GC_segment_is_thread_stack(ptr_t lo, ptr_t hi) - { - int i; - GC_thread p; - - GC_ASSERT(I_HOLD_LOCK()); -# ifdef PARALLEL_MARK - for (i = 0; i < GC_markers_m1; ++i) { - if ((word)marker_sp[i] > (word)lo && (word)marker_sp[i] < (word)hi) - return TRUE; -# ifdef IA64 - if ((word)marker_bsp[i] > (word)lo - && (word)marker_bsp[i] < (word)hi) - return TRUE; -# endif - } -# endif - for (i = 0; i < THREAD_TABLE_SZ; i++) { - for (p = GC_threads[i]; p != 0; p = p -> next) { - if (0 != p -> stack_end) { -# ifdef STACK_GROWS_UP - if ((word)p->stack_end >= (word)lo - && (word)p->stack_end < (word)hi) - return TRUE; -# else /* STACK_GROWS_DOWN */ - if ((word)p->stack_end > (word)lo - && (word)p->stack_end <= (word)hi) - return TRUE; -# endif - } - } - } - return FALSE; - } -#endif /* USE_PROC_FOR_LIBRARIES */ - -#ifdef IA64 - /* Find the largest stack_base smaller than bound. May be used */ - /* to find the boundary between a register stack and adjacent */ - /* immediately preceding memory stack. */ - GC_INNER ptr_t GC_greatest_stack_base_below(ptr_t bound) - { - int i; - GC_thread p; - ptr_t result = 0; - - GC_ASSERT(I_HOLD_LOCK()); -# ifdef PARALLEL_MARK - for (i = 0; i < GC_markers_m1; ++i) { - if ((word)marker_sp[i] > (word)result - && (word)marker_sp[i] < (word)bound) - result = marker_sp[i]; - } -# endif - for (i = 0; i < THREAD_TABLE_SZ; i++) { - for (p = GC_threads[i]; p != 0; p = p -> next) { - if ((word)p->stack_end > (word)result - && (word)p->stack_end < (word)bound) { - result = p -> stack_end; - } - } - } - return result; - } -#endif /* IA64 */ - -#ifndef STAT_READ - /* Also defined in os_dep.c. */ -# define STAT_BUF_SIZE 4096 -# define STAT_READ read - /* If read is wrapped, this may need to be redefined to call */ - /* the real one. */ -#endif - -#ifdef GC_HPUX_THREADS -# define GC_get_nprocs() pthread_num_processors_np() - -#elif defined(GC_OSF1_THREADS) || defined(GC_AIX_THREADS) \ - || defined(GC_SOLARIS_THREADS) || defined(GC_GNU_THREADS) \ - || defined(PLATFORM_ANDROID) || defined(NACL) - GC_INLINE int GC_get_nprocs(void) - { - int nprocs = (int)sysconf(_SC_NPROCESSORS_ONLN); - return nprocs > 0 ? nprocs : 1; /* ignore error silently */ - } - -#elif defined(GC_IRIX_THREADS) - GC_INLINE int GC_get_nprocs(void) - { - int nprocs = (int)sysconf(_SC_NPROC_ONLN); - return nprocs > 0 ? nprocs : 1; /* ignore error silently */ - } - -#elif defined(GC_LINUX_THREADS) /* && !PLATFORM_ANDROID && !NACL */ - /* Return the number of processors. */ - STATIC int GC_get_nprocs(void) - { - /* Should be "return sysconf(_SC_NPROCESSORS_ONLN);" but that */ - /* appears to be buggy in many cases. */ - /* We look for lines "cpu" in /proc/stat. */ - char stat_buf[STAT_BUF_SIZE]; - int f; - int result, i, len; - - f = open("/proc/stat", O_RDONLY); - if (f < 0) { - WARN("Couldn't read /proc/stat\n", 0); - return 1; /* assume an uniprocessor */ - } - len = STAT_READ(f, stat_buf, STAT_BUF_SIZE); - close(f); - - result = 1; - /* Some old kernels only have a single "cpu nnnn ..." */ - /* entry in /proc/stat. We identify those as */ - /* uniprocessors. */ - - for (i = 0; i < len - 100; ++i) { - if (stat_buf[i] == '\n' && stat_buf[i+1] == 'c' - && stat_buf[i+2] == 'p' && stat_buf[i+3] == 'u') { - int cpu_no = atoi(&stat_buf[i + 4]); - if (cpu_no >= result) - result = cpu_no + 1; - } - } - return result; - } - -#elif defined(GC_DGUX386_THREADS) - /* Return the number of processors, or i <= 0 if it can't be determined. */ - STATIC int GC_get_nprocs(void) - { - int numCpus; - struct dg_sys_info_pm_info pm_sysinfo; - int status = 0; - - status = dg_sys_info((long int *) &pm_sysinfo, - DG_SYS_INFO_PM_INFO_TYPE, DG_SYS_INFO_PM_CURRENT_VERSION); - if (status < 0) - /* set -1 for error */ - numCpus = -1; - else - /* Active CPUs */ - numCpus = pm_sysinfo.idle_vp_count; - return(numCpus); - } - -#elif defined(GC_DARWIN_THREADS) || defined(GC_FREEBSD_THREADS) \ - || defined(GC_NETBSD_THREADS) || defined(GC_OPENBSD_THREADS) - STATIC int GC_get_nprocs(void) - { - int mib[] = {CTL_HW,HW_NCPU}; - int res; - size_t len = sizeof(res); - - sysctl(mib, sizeof(mib)/sizeof(int), &res, &len, NULL, 0); - return res; - } - -#else - /* E.g., GC_RTEMS_PTHREADS */ -# define GC_get_nprocs() 1 /* not implemented */ -#endif /* !GC_LINUX_THREADS && !GC_DARWIN_THREADS && ... */ - -#if defined(ARM32) && defined(GC_LINUX_THREADS) && !defined(NACL) - /* Some buggy Linux/arm kernels show only non-sleeping CPUs in */ - /* /proc/stat (and /proc/cpuinfo), so another data system source is */ - /* tried first. Result <= 0 on error. */ - STATIC int GC_get_nprocs_present(void) - { - char stat_buf[16]; - int f; - int len; - - f = open("/sys/devices/system/cpu/present", O_RDONLY); - if (f < 0) - return -1; /* cannot open the file */ - - len = STAT_READ(f, stat_buf, sizeof(stat_buf)); - close(f); - - /* Recognized file format: "0\n" or "0-\n" */ - /* The file might probably contain a comma-separated list */ - /* but we do not need to handle it (just silently ignore). */ - if (len < 2 || stat_buf[0] != '0' || stat_buf[len - 1] != '\n') { - return 0; /* read error or unrecognized content */ - } else if (len == 2) { - return 1; /* an uniprocessor */ - } else if (stat_buf[1] != '-') { - return 0; /* unrecognized content */ - } - - stat_buf[len - 1] = '\0'; /* terminate the string */ - return atoi(&stat_buf[2]) + 1; /* skip "0-" and parse max_cpu_num */ - } -#endif /* ARM32 && GC_LINUX_THREADS && !NACL */ - -/* We hold the GC lock. Wait until an in-progress GC has finished. */ -/* Repeatedly RELEASES GC LOCK in order to wait. */ -/* If wait_for_all is true, then we exit with the GC lock held and no */ -/* collection in progress; otherwise we just wait for the current GC */ -/* to finish. */ -STATIC void GC_wait_for_gc_completion(GC_bool wait_for_all) -{ - DCL_LOCK_STATE; - GC_ASSERT(I_HOLD_LOCK()); - ASSERT_CANCEL_DISABLED(); - if (GC_incremental && GC_collection_in_progress()) { - word old_gc_no = GC_gc_no; - - /* Make sure that no part of our stack is still on the mark stack, */ - /* since it's about to be unmapped. */ - while (GC_incremental && GC_collection_in_progress() - && (wait_for_all || old_gc_no == GC_gc_no)) { - ENTER_GC(); - GC_in_thread_creation = TRUE; - GC_collect_a_little_inner(1); - GC_in_thread_creation = FALSE; - EXIT_GC(); - UNLOCK(); - sched_yield(); - LOCK(); - } - } -} - -#ifdef CAN_HANDLE_FORK -/* Procedures called before and after a fork. The goal here is to make */ -/* it safe to call GC_malloc() in a forked child. It's unclear that is */ -/* attainable, since the single UNIX spec seems to imply that one */ -/* should only call async-signal-safe functions, and we probably can't */ -/* quite guarantee that. But we give it our best shot. (That same */ -/* spec also implies that it's not safe to call the system malloc */ -/* between fork() and exec(). Thus we're doing no worse than it.) */ - -IF_CANCEL(static int fork_cancel_state;) - /* protected by allocation lock. */ - -/* Called before a fork() */ -static void fork_prepare_proc(void) -{ - /* Acquire all relevant locks, so that after releasing the locks */ - /* the child will see a consistent state in which monitor */ - /* invariants hold. Unfortunately, we can't acquire libc locks */ - /* we might need, and there seems to be no guarantee that libc */ - /* must install a suitable fork handler. */ - /* Wait for an ongoing GC to finish, since we can't finish it in */ - /* the (one remaining thread in) the child. */ - LOCK(); - DISABLE_CANCEL(fork_cancel_state); - /* Following waits may include cancellation points. */ -# if defined(PARALLEL_MARK) - if (GC_parallel) - GC_wait_for_reclaim(); -# endif - GC_wait_for_gc_completion(TRUE); -# if defined(PARALLEL_MARK) - if (GC_parallel) - GC_acquire_mark_lock(); -# endif -} - -/* Called in parent after a fork() (even if the latter failed). */ -static void fork_parent_proc(void) -{ -# if defined(PARALLEL_MARK) - if (GC_parallel) - GC_release_mark_lock(); -# endif - RESTORE_CANCEL(fork_cancel_state); - UNLOCK(); -} - -/* Called in child after a fork() */ -static void fork_child_proc(void) -{ - /* Clean up the thread table, so that just our thread is left. */ -# if defined(PARALLEL_MARK) - if (GC_parallel) - GC_release_mark_lock(); -# endif - GC_remove_all_threads_but_me(); -# ifdef PARALLEL_MARK - /* Turn off parallel marking in the child, since we are probably */ - /* just going to exec, and we would have to restart mark threads. */ - GC_parallel = FALSE; -# endif /* PARALLEL_MARK */ - RESTORE_CANCEL(fork_cancel_state); - UNLOCK(); -} - - /* Routines for fork handling by client (no-op if pthread_atfork works). */ - GC_API void GC_CALL GC_atfork_prepare(void) - { -# if defined(GC_DARWIN_THREADS) && defined(MPROTECT_VDB) - if (GC_dirty_maintained) { - GC_ASSERT(0 == GC_handle_fork); - ABORT("Unable to fork while mprotect_thread is running"); - } -# endif - if (GC_handle_fork <= 0) - fork_prepare_proc(); - } - - GC_API void GC_CALL GC_atfork_parent(void) - { - if (GC_handle_fork <= 0) - fork_parent_proc(); - } - - GC_API void GC_CALL GC_atfork_child(void) - { - if (GC_handle_fork <= 0) - fork_child_proc(); - } -#endif /* CAN_HANDLE_FORK */ - -#ifdef INCLUDE_LINUX_THREAD_DESCR - __thread int GC_dummy_thread_local; - GC_INNER GC_bool GC_enclosing_mapping(ptr_t addr, - ptr_t *startp, ptr_t *endp); -#endif - -#ifdef PARALLEL_MARK - static void setup_mark_lock(void); -#endif - -/* We hold the allocation lock. */ -GC_INNER void GC_thr_init(void) -{ - if (GC_thr_initialized) return; - GC_thr_initialized = TRUE; - - GC_ASSERT((word)&GC_threads % sizeof(word) == 0); -# ifdef CAN_HANDLE_FORK - /* Prepare for forks if requested. */ - if (GC_handle_fork) { -# ifdef CAN_CALL_ATFORK - if (pthread_atfork(fork_prepare_proc, fork_parent_proc, - fork_child_proc) == 0) { - /* Handlers successfully registered. */ - GC_handle_fork = 1; - } else -# endif - /* else */ if (GC_handle_fork != -1) - ABORT("pthread_atfork failed"); - } -# endif -# ifdef INCLUDE_LINUX_THREAD_DESCR - /* Explicitly register the region including the address */ - /* of a thread local variable. This should include thread */ - /* locals for the main thread, except for those allocated */ - /* in response to dlopen calls. */ - { - ptr_t thread_local_addr = (ptr_t)(&GC_dummy_thread_local); - ptr_t main_thread_start, main_thread_end; - if (!GC_enclosing_mapping(thread_local_addr, &main_thread_start, - &main_thread_end)) { - ABORT("Failed to find mapping for main thread thread locals"); - } else { - /* main_thread_start and main_thread_end are initialized. */ - GC_add_roots_inner(main_thread_start, main_thread_end, FALSE); - } - } -# endif - /* Add the initial thread, so we can stop it. */ - { - GC_thread t = GC_new_thread(pthread_self()); - if (t == NULL) - ABORT("Failed to allocate memory for the initial thread"); -# ifdef GC_DARWIN_THREADS - t -> stop_info.mach_thread = mach_thread_self(); -# else - t -> stop_info.stack_ptr = GC_approx_sp(); -# endif - t -> flags = DETACHED | MAIN_THREAD; - } - -# ifndef GC_DARWIN_THREADS - GC_stop_init(); -# endif - - /* Set GC_nprocs. */ - { - char * nprocs_string = GETENV("GC_NPROCS"); - GC_nprocs = -1; - if (nprocs_string != NULL) GC_nprocs = atoi(nprocs_string); - } - if (GC_nprocs <= 0 -# if defined(ARM32) && defined(GC_LINUX_THREADS) && !defined(NACL) - && (GC_nprocs = GC_get_nprocs_present()) <= 1 - /* Workaround for some Linux/arm kernels */ -# endif - ) - { - GC_nprocs = GC_get_nprocs(); - } - if (GC_nprocs <= 0) { - WARN("GC_get_nprocs() returned %" WARN_PRIdPTR "\n", GC_nprocs); - GC_nprocs = 2; /* assume dual-core */ -# ifdef PARALLEL_MARK - available_markers_m1 = 0; /* but use only one marker */ -# endif - } else { -# ifdef PARALLEL_MARK - { - char * markers_string = GETENV("GC_MARKERS"); - int markers_m1; - - if (markers_string != NULL) { - markers_m1 = atoi(markers_string) - 1; - if (markers_m1 >= MAX_MARKERS) { - WARN("Limiting number of mark threads\n", 0); - markers_m1 = MAX_MARKERS - 1; - } - } else { - markers_m1 = GC_nprocs - 1; -# ifdef GC_MIN_MARKERS - /* This is primarily for targets without getenv(). */ - if (markers_m1 < GC_MIN_MARKERS - 1) - markers_m1 = GC_MIN_MARKERS - 1; -# endif - if (markers_m1 >= MAX_MARKERS) - markers_m1 = MAX_MARKERS - 1; /* silently limit the value */ - } - available_markers_m1 = markers_m1; - } -# endif - } - GC_COND_LOG_PRINTF("Number of processors = %d\n", GC_nprocs); -# ifdef PARALLEL_MARK - if (available_markers_m1 <= 0) { - /* Disable parallel marking. */ - GC_parallel = FALSE; - GC_COND_LOG_PRINTF( - "Single marker thread, turning off parallel marking\n"); - } else { - /* Disable true incremental collection, but generational is OK. */ - GC_time_limit = GC_TIME_UNLIMITED; - setup_mark_lock(); - /* If we are using a parallel marker, actually start helper threads. */ - start_mark_threads(); - } -# endif -} - -/* Perform all initializations, including those that */ -/* may require allocation. */ -/* Called without allocation lock. */ -/* Must be called before a second thread is created. */ -/* Did we say it's called without the allocation lock? */ -GC_INNER void GC_init_parallel(void) -{ -# if defined(THREAD_LOCAL_ALLOC) - DCL_LOCK_STATE; -# endif - if (parallel_initialized) return; - parallel_initialized = TRUE; - - /* GC_init() calls us back, so set flag first. */ - if (!GC_is_initialized) GC_init(); - /* Initialize thread local free lists if used. */ -# if defined(THREAD_LOCAL_ALLOC) - LOCK(); - GC_init_thread_local(&(GC_lookup_thread(pthread_self())->tlfs)); - UNLOCK(); -# endif -} - -#ifndef GC_NO_PTHREAD_SIGMASK - GC_API int WRAP_FUNC(pthread_sigmask)(int how, const sigset_t *set, - sigset_t *oset) - { - sigset_t fudged_set; - int sig_suspend; - - INIT_REAL_SYMS(); - if (set != NULL && (how == SIG_BLOCK || how == SIG_SETMASK)) { - fudged_set = *set; - sig_suspend = GC_get_suspend_signal(); - GC_ASSERT(sig_suspend >= 0); - sigdelset(&fudged_set, sig_suspend); - set = &fudged_set; - } - return(REAL_FUNC(pthread_sigmask)(how, set, oset)); - } -#endif /* !GC_NO_PTHREAD_SIGMASK */ - -/* Wrapper for functions that are likely to block for an appreciable */ -/* length of time. */ - -GC_INNER void GC_do_blocking_inner(ptr_t data, void * context GC_ATTR_UNUSED) -{ - struct blocking_data * d = (struct blocking_data *) data; - pthread_t self = pthread_self(); - GC_thread me; -# if defined(SPARC) || defined(IA64) - ptr_t stack_ptr = GC_save_regs_in_stack(); -# endif -# if defined(GC_DARWIN_THREADS) && !defined(DARWIN_DONT_PARSE_STACK) - GC_bool topOfStackUnset = FALSE; -# endif - DCL_LOCK_STATE; - - LOCK(); - me = GC_lookup_thread(self); - GC_ASSERT(!(me -> thread_blocked)); -# ifdef SPARC - me -> stop_info.stack_ptr = stack_ptr; -# else - me -> stop_info.stack_ptr = GC_approx_sp(); -# endif -# if defined(GC_DARWIN_THREADS) && !defined(DARWIN_DONT_PARSE_STACK) - if (me -> topOfStack == NULL) { - /* GC_do_blocking_inner is not called recursively, */ - /* so topOfStack should be computed now. */ - topOfStackUnset = TRUE; - me -> topOfStack = GC_FindTopOfStack(0); - } -# endif -# ifdef IA64 - me -> backing_store_ptr = stack_ptr; -# endif - me -> thread_blocked = (unsigned char)TRUE; - /* Save context here if we want to support precise stack marking */ - UNLOCK(); - d -> client_data = (d -> fn)(d -> client_data); - LOCK(); /* This will block if the world is stopped. */ - me -> thread_blocked = FALSE; -# if defined(GC_DARWIN_THREADS) && !defined(DARWIN_DONT_PARSE_STACK) - if (topOfStackUnset) - me -> topOfStack = NULL; /* make topOfStack unset again */ -# endif - UNLOCK(); -} - -/* GC_call_with_gc_active() has the opposite to GC_do_blocking() */ -/* functionality. It might be called from a user function invoked by */ -/* GC_do_blocking() to temporarily back allow calling any GC function */ -/* and/or manipulating pointers to the garbage collected heap. */ -GC_API void * GC_CALL GC_call_with_gc_active(GC_fn_type fn, - void * client_data) -{ - struct GC_traced_stack_sect_s stacksect; - pthread_t self = pthread_self(); - GC_thread me; - DCL_LOCK_STATE; - - LOCK(); /* This will block if the world is stopped. */ - me = GC_lookup_thread(self); - - /* Adjust our stack base value (this could happen unless */ - /* GC_get_stack_base() was used which returned GC_SUCCESS). */ - if ((me -> flags & MAIN_THREAD) == 0) { - GC_ASSERT(me -> stack_end != NULL); - if ((word)me->stack_end HOTTER_THAN (word)(&stacksect)) - me -> stack_end = (ptr_t)(&stacksect); - } else { - /* The original stack. */ - if ((word)GC_stackbottom HOTTER_THAN (word)(&stacksect)) - GC_stackbottom = (ptr_t)(&stacksect); - } - - if (!me->thread_blocked) { - /* We are not inside GC_do_blocking() - do nothing more. */ - UNLOCK(); - client_data = fn(client_data); - /* Prevent treating the above as a tail call. */ - GC_noop1((word)(&stacksect)); - return client_data; /* result */ - } - - /* Setup new "stack section". */ - stacksect.saved_stack_ptr = me -> stop_info.stack_ptr; -# ifdef IA64 - /* This is the same as in GC_call_with_stack_base(). */ - stacksect.backing_store_end = GC_save_regs_in_stack(); - /* Unnecessarily flushes register stack, */ - /* but that probably doesn't hurt. */ - stacksect.saved_backing_store_ptr = me -> backing_store_ptr; -# endif - stacksect.prev = me -> traced_stack_sect; - me -> thread_blocked = FALSE; - me -> traced_stack_sect = &stacksect; - - UNLOCK(); - client_data = fn(client_data); - GC_ASSERT(me -> thread_blocked == FALSE); - GC_ASSERT(me -> traced_stack_sect == &stacksect); - - /* Restore original "stack section". */ - LOCK(); - me -> traced_stack_sect = stacksect.prev; -# ifdef IA64 - me -> backing_store_ptr = stacksect.saved_backing_store_ptr; -# endif - me -> thread_blocked = (unsigned char)TRUE; - me -> stop_info.stack_ptr = stacksect.saved_stack_ptr; - UNLOCK(); - - return client_data; /* result */ -} - -STATIC void GC_unregister_my_thread_inner(GC_thread me) -{ -# ifdef DEBUG_THREADS - GC_log_printf( - "Unregistering thread %p, gc_thread = %p, n_threads = %d\n", - (void *)me->id, me, GC_count_threads()); -# endif - GC_ASSERT(!(me -> flags & FINISHED)); -# if defined(THREAD_LOCAL_ALLOC) - GC_ASSERT(GC_getspecific(GC_thread_key) == &me->tlfs); - GC_destroy_thread_local(&(me->tlfs)); -# endif -# if defined(GC_PTHREAD_EXIT_ATTRIBUTE) || !defined(GC_NO_PTHREAD_CANCEL) - /* Handle DISABLED_GC flag which is set by the */ - /* intercepted pthread_cancel or pthread_exit. */ - if ((me -> flags & DISABLED_GC) != 0) { - GC_dont_gc--; - } -# endif - if (me -> flags & DETACHED) { - GC_delete_thread(pthread_self()); - } else { - me -> flags |= FINISHED; - } -# if defined(THREAD_LOCAL_ALLOC) - /* It is required to call remove_specific defined in specific.c. */ - GC_remove_specific(GC_thread_key); -# endif -} - -GC_API int GC_CALL GC_unregister_my_thread(void) -{ - pthread_t self = pthread_self(); - GC_thread me; - IF_CANCEL(int cancel_state;) - DCL_LOCK_STATE; - - LOCK(); - DISABLE_CANCEL(cancel_state); - /* Wait for any GC that may be marking from our stack to */ - /* complete before we remove this thread. */ - GC_wait_for_gc_completion(FALSE); - me = GC_lookup_thread(self); -# ifdef DEBUG_THREADS - GC_log_printf( - "Called GC_unregister_my_thread on %p, gc_thread = %p\n", - (void *)self, me); -# endif - GC_ASSERT(me->id == self); - GC_unregister_my_thread_inner(me); - RESTORE_CANCEL(cancel_state); - UNLOCK(); - return GC_SUCCESS; -} - -/* Called at thread exit. */ -/* Never called for main thread. That's OK, since it */ -/* results in at most a tiny one-time leak. And */ -/* linuxthreads doesn't reclaim the main threads */ -/* resources or id anyway. */ -GC_INNER_PTHRSTART void GC_thread_exit_proc(void *arg) -{ -# ifdef DEBUG_THREADS - GC_log_printf("Called GC_thread_exit_proc on %p, gc_thread = %p\n", - (void *)((GC_thread)arg)->id, arg); -# endif - IF_CANCEL(int cancel_state;) - DCL_LOCK_STATE; - - LOCK(); - DISABLE_CANCEL(cancel_state); - GC_wait_for_gc_completion(FALSE); - GC_unregister_my_thread_inner((GC_thread)arg); - RESTORE_CANCEL(cancel_state); - UNLOCK(); -} - -GC_API int WRAP_FUNC(pthread_join)(pthread_t thread, void **retval) -{ - int result; - GC_thread t; - DCL_LOCK_STATE; - - INIT_REAL_SYMS(); - LOCK(); - t = GC_lookup_thread(thread); - /* This is guaranteed to be the intended one, since the thread id */ - /* can't have been recycled by pthreads. */ - UNLOCK(); - result = REAL_FUNC(pthread_join)(thread, retval); -# if defined(GC_FREEBSD_THREADS) - /* On FreeBSD, the wrapped pthread_join() sometimes returns (what - appears to be) a spurious EINTR which caused the test and real code - to gratuitously fail. Having looked at system pthread library source - code, I see how this return code may be generated. In one path of - code, pthread_join() just returns the errno setting of the thread - being joined. This does not match the POSIX specification or the - local man pages thus I have taken the liberty to catch this one - spurious return value properly conditionalized on GC_FREEBSD_THREADS. */ - if (result == EINTR) result = 0; -# endif - if (result == 0) { - LOCK(); - /* Here the pthread thread id may have been recycled. */ - GC_ASSERT((t -> flags & FINISHED) != 0); - GC_delete_gc_thread(t); - UNLOCK(); - } - return result; -} - -GC_API int WRAP_FUNC(pthread_detach)(pthread_t thread) -{ - int result; - GC_thread t; - DCL_LOCK_STATE; - - INIT_REAL_SYMS(); - LOCK(); - t = GC_lookup_thread(thread); - UNLOCK(); - result = REAL_FUNC(pthread_detach)(thread); - if (result == 0) { - LOCK(); - t -> flags |= DETACHED; - /* Here the pthread thread id may have been recycled. */ - if ((t -> flags & FINISHED) != 0) { - GC_delete_gc_thread(t); - } - UNLOCK(); - } - return result; -} - -#ifndef GC_NO_PTHREAD_CANCEL - /* We should deal with the fact that apparently on Solaris and, */ - /* probably, on some Linux we can't collect while a thread is */ - /* exiting, since signals aren't handled properly. This currently */ - /* gives rise to deadlocks. The only workaround seen is to intercept */ - /* pthread_cancel() and pthread_exit(), and disable the collections */ - /* until the thread exit handler is called. That's ugly, because we */ - /* risk growing the heap unnecessarily. But it seems that we don't */ - /* really have an option in that the process is not in a fully */ - /* functional state while a thread is exiting. */ - GC_API int WRAP_FUNC(pthread_cancel)(pthread_t thread) - { -# ifdef CANCEL_SAFE - GC_thread t; - DCL_LOCK_STATE; -# endif - - INIT_REAL_SYMS(); -# ifdef CANCEL_SAFE - LOCK(); - t = GC_lookup_thread(thread); - /* We test DISABLED_GC because pthread_exit could be called at */ - /* the same time. (If t is NULL then pthread_cancel should */ - /* return ESRCH.) */ - if (t != NULL && (t -> flags & DISABLED_GC) == 0) { - t -> flags |= DISABLED_GC; - GC_dont_gc++; - } - UNLOCK(); -# endif - return REAL_FUNC(pthread_cancel)(thread); - } -#endif /* !GC_NO_PTHREAD_CANCEL */ - -#ifdef GC_PTHREAD_EXIT_ATTRIBUTE - GC_API GC_PTHREAD_EXIT_ATTRIBUTE void WRAP_FUNC(pthread_exit)(void *retval) - { - pthread_t self = pthread_self(); - GC_thread me; - DCL_LOCK_STATE; - - INIT_REAL_SYMS(); - LOCK(); - me = GC_lookup_thread(self); - /* We test DISABLED_GC because someone else could call */ - /* pthread_cancel at the same time. */ - if (me != 0 && (me -> flags & DISABLED_GC) == 0) { - me -> flags |= DISABLED_GC; - GC_dont_gc++; - } - UNLOCK(); - -# ifdef NACL - /* Native Client doesn't support pthread cleanup functions, */ - /* so cleanup the thread here. */ - GC_thread_exit_proc(0); -# endif - - REAL_FUNC(pthread_exit)(retval); - } -#endif /* GC_PTHREAD_EXIT_ATTRIBUTE */ - -GC_INNER GC_bool GC_in_thread_creation = FALSE; - /* Protected by allocation lock. */ - -GC_INLINE void GC_record_stack_base(GC_thread me, - const struct GC_stack_base *sb) -{ -# ifndef GC_DARWIN_THREADS - me -> stop_info.stack_ptr = sb -> mem_base; -# endif - me -> stack_end = sb -> mem_base; - if (me -> stack_end == NULL) - ABORT("Bad stack base in GC_register_my_thread"); -# ifdef IA64 - me -> backing_store_end = sb -> reg_base; -# endif -} - -STATIC GC_thread GC_register_my_thread_inner(const struct GC_stack_base *sb, - pthread_t my_pthread) -{ - GC_thread me; - - GC_in_thread_creation = TRUE; /* OK to collect from unknown thread. */ - me = GC_new_thread(my_pthread); - GC_in_thread_creation = FALSE; - if (me == 0) - ABORT("Failed to allocate memory for thread registering"); -# ifdef GC_DARWIN_THREADS - me -> stop_info.mach_thread = mach_thread_self(); -# endif - GC_record_stack_base(me, sb); -# ifdef GC_EXPLICIT_SIGNALS_UNBLOCK - /* Since this could be executed from a detached thread */ - /* destructor, our signals might already be blocked. */ - GC_unblock_gc_signals(); -# endif - return me; -} - -GC_API void GC_CALL GC_allow_register_threads(void) -{ - /* Check GC is initialized and the current thread is registered. */ - GC_ASSERT(GC_lookup_thread(pthread_self()) != 0); - -# ifndef GC_ALWAYS_MULTITHREADED - GC_need_to_lock = TRUE; /* We are multi-threaded now. */ -# endif -} - -GC_API int GC_CALL GC_register_my_thread(const struct GC_stack_base *sb) -{ - pthread_t self = pthread_self(); - GC_thread me; - DCL_LOCK_STATE; - - if (GC_need_to_lock == FALSE) - ABORT("Threads explicit registering is not previously enabled"); - - LOCK(); - me = GC_lookup_thread(self); - if (0 == me) { - me = GC_register_my_thread_inner(sb, self); - me -> flags |= DETACHED; - /* Treat as detached, since we do not need to worry about */ - /* pointer results. */ -# if defined(THREAD_LOCAL_ALLOC) - GC_init_thread_local(&(me->tlfs)); -# endif - UNLOCK(); - return GC_SUCCESS; - } else if ((me -> flags & FINISHED) != 0) { - /* This code is executed when a thread is registered from the */ - /* client thread key destructor. */ - GC_record_stack_base(me, sb); - me -> flags &= ~FINISHED; /* but not DETACHED */ -# ifdef GC_EXPLICIT_SIGNALS_UNBLOCK - /* Since this could be executed from a thread destructor, */ - /* our signals might be blocked. */ - GC_unblock_gc_signals(); -# endif -# if defined(THREAD_LOCAL_ALLOC) - GC_init_thread_local(&(me->tlfs)); -# endif - UNLOCK(); - return GC_SUCCESS; - } else { - UNLOCK(); - return GC_DUPLICATE; - } -} - -struct start_info { - void *(*start_routine)(void *); - void *arg; - word flags; - sem_t registered; /* 1 ==> in our thread table, but */ - /* parent hasn't yet noticed. */ -}; - -/* Called from GC_inner_start_routine(). Defined in this file to */ -/* minimize the number of include files in pthread_start.c (because */ -/* sem_t and sem_post() are not used that file directly). */ -GC_INNER_PTHRSTART GC_thread GC_start_rtn_prepare_thread( - void *(**pstart)(void *), - void **pstart_arg, - struct GC_stack_base *sb, void *arg) -{ - struct start_info * si = arg; - pthread_t self = pthread_self(); - GC_thread me; - DCL_LOCK_STATE; - -# ifdef DEBUG_THREADS - GC_log_printf("Starting thread %p, pid = %ld, sp = %p\n", - (void *)self, (long)getpid(), &arg); -# endif - LOCK(); - me = GC_register_my_thread_inner(sb, self); - me -> flags = si -> flags; -# if defined(THREAD_LOCAL_ALLOC) - GC_init_thread_local(&(me->tlfs)); -# endif - UNLOCK(); - *pstart = si -> start_routine; -# ifdef DEBUG_THREADS - GC_log_printf("start_routine = %p\n", (void *)(signed_word)(*pstart)); -# endif - *pstart_arg = si -> arg; - sem_post(&(si -> registered)); /* Last action on si. */ - /* OK to deallocate. */ - return me; -} - -GC_INNER_PTHRSTART void * GC_CALLBACK GC_inner_start_routine( - struct GC_stack_base *sb, void *arg); - /* defined in pthread_start.c */ - -STATIC void * GC_start_routine(void * arg) -{ -# ifdef INCLUDE_LINUX_THREAD_DESCR - struct GC_stack_base sb; - -# ifdef REDIRECT_MALLOC - /* GC_get_stack_base may call pthread_getattr_np, which can */ - /* unfortunately call realloc, which may allocate from an */ - /* unregistered thread. This is unpleasant, since it might */ - /* force heap growth (or, even, heap overflow). */ - GC_disable(); -# endif - if (GC_get_stack_base(&sb) != GC_SUCCESS) - ABORT("Failed to get thread stack base"); -# ifdef REDIRECT_MALLOC - GC_enable(); -# endif - return GC_inner_start_routine(&sb, arg); -# else - return GC_call_with_stack_base(GC_inner_start_routine, arg); -# endif -} - -GC_API int WRAP_FUNC(pthread_create)(pthread_t *new_thread, - GC_PTHREAD_CREATE_CONST pthread_attr_t *attr, - void *(*start_routine)(void *), void *arg) -{ - int result; - int detachstate; - word my_flags = 0; - struct start_info * si; - DCL_LOCK_STATE; - /* This is otherwise saved only in an area mmapped by the thread */ - /* library, which isn't visible to the collector. */ - - /* We resist the temptation to muck with the stack size here, */ - /* even if the default is unreasonably small. That's the client's */ - /* responsibility. */ - - INIT_REAL_SYMS(); - LOCK(); - si = (struct start_info *)GC_INTERNAL_MALLOC(sizeof(struct start_info), - NORMAL); - UNLOCK(); - if (!EXPECT(parallel_initialized, TRUE)) - GC_init_parallel(); - if (EXPECT(0 == si, FALSE) && - (si = (struct start_info *) - (*GC_get_oom_fn())(sizeof(struct start_info))) == 0) - return(ENOMEM); - if (sem_init(&(si -> registered), GC_SEM_INIT_PSHARED, 0) != 0) - ABORT("sem_init failed"); - - si -> start_routine = start_routine; - si -> arg = arg; - LOCK(); - if (!EXPECT(GC_thr_initialized, TRUE)) - GC_thr_init(); -# ifdef GC_ASSERTIONS - { - size_t stack_size = 0; - if (NULL != attr) { - if (pthread_attr_getstacksize(attr, &stack_size) != 0) - ABORT("pthread_attr_getstacksize failed"); - } - if (0 == stack_size) { - pthread_attr_t my_attr; - - if (pthread_attr_init(&my_attr) != 0) - ABORT("pthread_attr_init failed"); - if (pthread_attr_getstacksize(&my_attr, &stack_size) != 0) - ABORT("pthread_attr_getstacksize failed"); - (void)pthread_attr_destroy(&my_attr); - } - /* On Solaris 10, with default attr initialization, */ - /* stack_size remains 0. Fudge it. */ - if (0 == stack_size) { -# ifndef SOLARIS - WARN("Failed to get stack size for assertion checking\n", 0); -# endif - stack_size = 1000000; - } -# ifdef PARALLEL_MARK - GC_ASSERT(stack_size >= (8*HBLKSIZE*sizeof(word))); -# else - /* FreeBSD-5.3/Alpha: default pthread stack is 64K, */ - /* HBLKSIZE=8192, sizeof(word)=8 */ - GC_ASSERT(stack_size >= 65536); -# endif - /* Our threads may need to do some work for the GC. */ - /* Ridiculously small threads won't work, and they */ - /* probably wouldn't work anyway. */ - } -# endif - if (NULL == attr) { - detachstate = PTHREAD_CREATE_JOINABLE; - } else { - pthread_attr_getdetachstate(attr, &detachstate); - } - if (PTHREAD_CREATE_DETACHED == detachstate) my_flags |= DETACHED; - si -> flags = my_flags; - UNLOCK(); -# ifdef DEBUG_THREADS - GC_log_printf("About to start new thread from thread %p\n", - (void *)pthread_self()); -# endif -# ifndef GC_ALWAYS_MULTITHREADED - GC_need_to_lock = TRUE; -# endif - - result = REAL_FUNC(pthread_create)(new_thread, attr, GC_start_routine, si); - - /* Wait until child has been added to the thread table. */ - /* This also ensures that we hold onto si until the child is done */ - /* with it. Thus it doesn't matter whether it is otherwise */ - /* visible to the collector. */ - if (0 == result) { - IF_CANCEL(int cancel_state;) - -# ifdef DEBUG_THREADS - if (new_thread) - GC_log_printf("Started thread %p\n", (void *)(*new_thread)); -# endif - DISABLE_CANCEL(cancel_state); - /* pthread_create is not a cancellation point. */ - while (0 != sem_wait(&(si -> registered))) { - if (EINTR != errno) ABORT("sem_wait failed"); - } - RESTORE_CANCEL(cancel_state); - } - sem_destroy(&(si -> registered)); - LOCK(); - GC_INTERNAL_FREE(si); - UNLOCK(); - - return(result); -} - -#if defined(USE_SPIN_LOCK) || !defined(NO_PTHREAD_TRYLOCK) -/* Spend a few cycles in a way that can't introduce contention with */ -/* other threads. */ -STATIC void GC_pause(void) -{ - int i; -# if !defined(__GNUC__) || defined(__INTEL_COMPILER) - volatile word dummy = 0; -# endif - - for (i = 0; i < 10; ++i) { -# if defined(__GNUC__) && !defined(__INTEL_COMPILER) - __asm__ __volatile__ (" " : : : "memory"); -# else - /* Something that's unlikely to be optimized away. */ - GC_noop1(++dummy); -# endif - } -} -#endif - -#define SPIN_MAX 128 /* Maximum number of calls to GC_pause before */ - /* give up. */ - -GC_INNER volatile GC_bool GC_collecting = 0; - /* A hint that we're in the collector and */ - /* holding the allocation lock for an */ - /* extended period. */ - -#if (!defined(USE_SPIN_LOCK) && !defined(NO_PTHREAD_TRYLOCK)) \ - || defined(PARALLEL_MARK) -/* If we don't want to use the below spinlock implementation, either */ -/* because we don't have a GC_test_and_set implementation, or because */ -/* we don't want to risk sleeping, we can still try spinning on */ -/* pthread_mutex_trylock for a while. This appears to be very */ -/* beneficial in many cases. */ -/* I suspect that under high contention this is nearly always better */ -/* than the spin lock. But it's a bit slower on a uniprocessor. */ -/* Hence we still default to the spin lock. */ -/* This is also used to acquire the mark lock for the parallel */ -/* marker. */ - -/* Here we use a strict exponential backoff scheme. I don't know */ -/* whether that's better or worse than the above. We eventually */ -/* yield by calling pthread_mutex_lock(); it never makes sense to */ -/* explicitly sleep. */ - -/* #define LOCK_STATS */ -/* Note that LOCK_STATS requires AO_HAVE_test_and_set. */ -#ifdef LOCK_STATS - volatile AO_t GC_spin_count = 0; - volatile AO_t GC_block_count = 0; - volatile AO_t GC_unlocked_count = 0; -#endif - -STATIC void GC_generic_lock(pthread_mutex_t * lock) -{ -#ifndef NO_PTHREAD_TRYLOCK - unsigned pause_length = 1; - unsigned i; - - if (0 == pthread_mutex_trylock(lock)) { -# ifdef LOCK_STATS - (void)AO_fetch_and_add1(&GC_unlocked_count); -# endif - return; - } - for (; pause_length <= SPIN_MAX; pause_length <<= 1) { - for (i = 0; i < pause_length; ++i) { - GC_pause(); - } - switch(pthread_mutex_trylock(lock)) { - case 0: -# ifdef LOCK_STATS - (void)AO_fetch_and_add1(&GC_spin_count); -# endif - return; - case EBUSY: - break; - default: - ABORT("Unexpected error from pthread_mutex_trylock"); - } - } -#endif /* !NO_PTHREAD_TRYLOCK */ -# ifdef LOCK_STATS - (void)AO_fetch_and_add1(&GC_block_count); -# endif - pthread_mutex_lock(lock); -} - -#endif /* !USE_SPIN_LOCK || ... */ - -#if defined(USE_SPIN_LOCK) - -/* Reasonably fast spin locks. Basically the same implementation */ -/* as STL alloc.h. This isn't really the right way to do this. */ -/* but until the POSIX scheduling mess gets straightened out ... */ - -GC_INNER volatile AO_TS_t GC_allocate_lock = AO_TS_INITIALIZER; - -GC_INNER void GC_lock(void) -{ -# define low_spin_max 30 /* spin cycles if we suspect uniprocessor */ -# define high_spin_max SPIN_MAX /* spin cycles for multiprocessor */ - static unsigned spin_max = low_spin_max; - unsigned my_spin_max; - static unsigned last_spins = 0; - unsigned my_last_spins; - unsigned i; - - if (AO_test_and_set_acquire(&GC_allocate_lock) == AO_TS_CLEAR) { - return; - } - my_spin_max = spin_max; - my_last_spins = last_spins; - for (i = 0; i < my_spin_max; i++) { - if (GC_collecting || GC_nprocs == 1) goto yield; - if (i < my_last_spins/2) { - GC_pause(); - continue; - } - if (AO_test_and_set_acquire(&GC_allocate_lock) == AO_TS_CLEAR) { - /* - * got it! - * Spinning worked. Thus we're probably not being scheduled - * against the other process with which we were contending. - * Thus it makes sense to spin longer the next time. - */ - last_spins = i; - spin_max = high_spin_max; - return; - } - } - /* We are probably being scheduled against the other process. Sleep. */ - spin_max = low_spin_max; -yield: - for (i = 0;; ++i) { - if (AO_test_and_set_acquire(&GC_allocate_lock) == AO_TS_CLEAR) { - return; - } -# define SLEEP_THRESHOLD 12 - /* Under Linux very short sleeps tend to wait until */ - /* the current time quantum expires. On old Linux */ - /* kernels nanosleep(<= 2ms) just spins under Linux. */ - /* (Under 2.4, this happens only for real-time */ - /* processes.) We want to minimize both behaviors */ - /* here. */ - if (i < SLEEP_THRESHOLD) { - sched_yield(); - } else { - struct timespec ts; - - if (i > 24) i = 24; - /* Don't wait for more than about 15msecs, even */ - /* under extreme contention. */ - ts.tv_sec = 0; - ts.tv_nsec = 1 << i; - nanosleep(&ts, 0); - } - } -} - -#else /* !USE_SPIN_LOCK */ -GC_INNER void GC_lock(void) -{ -#ifndef NO_PTHREAD_TRYLOCK - if (1 == GC_nprocs || GC_collecting) { - pthread_mutex_lock(&GC_allocate_ml); - } else { - GC_generic_lock(&GC_allocate_ml); - } -#else /* !NO_PTHREAD_TRYLOCK */ - pthread_mutex_lock(&GC_allocate_ml); -#endif /* !NO_PTHREAD_TRYLOCK */ -} - -#endif /* !USE_SPIN_LOCK */ - -#ifdef PARALLEL_MARK - -# ifdef GC_ASSERTIONS - STATIC unsigned long GC_mark_lock_holder = NO_THREAD; -# define SET_MARK_LOCK_HOLDER \ - (void)(GC_mark_lock_holder = NUMERIC_THREAD_ID(pthread_self())) -# define UNSET_MARK_LOCK_HOLDER \ - do { \ - GC_ASSERT(GC_mark_lock_holder \ - == NUMERIC_THREAD_ID(pthread_self())); \ - GC_mark_lock_holder = NO_THREAD; \ - } while (0) -# else -# define SET_MARK_LOCK_HOLDER (void)0 -# define UNSET_MARK_LOCK_HOLDER (void)0 -# endif /* !GC_ASSERTIONS */ - -#ifdef GLIBC_2_1_MUTEX_HACK - /* Ugly workaround for a linux threads bug in the final versions */ - /* of glibc2.1. Pthread_mutex_trylock sets the mutex owner */ - /* field even when it fails to acquire the mutex. This causes */ - /* pthread_cond_wait to die. Remove for glibc2.2. */ - /* According to the man page, we should use */ - /* PTHREAD_ERRORCHECK_MUTEX_INITIALIZER_NP, but that isn't actually */ - /* defined. */ - static pthread_mutex_t mark_mutex = - {0, 0, 0, PTHREAD_MUTEX_ERRORCHECK_NP, {0, 0}}; -#else - static pthread_mutex_t mark_mutex = PTHREAD_MUTEX_INITIALIZER; -#endif - -static pthread_cond_t builder_cv = PTHREAD_COND_INITIALIZER; - -#ifdef GLIBC_2_19_TSX_BUG - /* Parse string like [.[]] and return major value. */ - static int parse_version(int *pminor, const char *pverstr) { - char *endp; - unsigned long value = strtoul(pverstr, &endp, 10); - int major = (int)value; - - if (major < 0 || (char *)pverstr == endp || (unsigned)major != value) { - /* Parse error */ - return -1; - } - if (*endp != '.') { - /* No minor part. */ - *pminor = -1; - } else { - value = strtoul(endp + 1, &endp, 10); - *pminor = (int)value; - if (*pminor < 0 || (unsigned)(*pminor) != value) { - return -1; - } - } - return major; - } -#endif /* GLIBC_2_19_TSX_BUG */ - -static void setup_mark_lock(void) -{ -# ifdef GLIBC_2_19_TSX_BUG - pthread_mutexattr_t mattr; - int glibc_minor = -1; - int glibc_major = parse_version(&glibc_minor, gnu_get_libc_version()); - - if (glibc_major > 2 || (glibc_major == 2 && glibc_minor >= 19)) { - /* TODO: disable this workaround for glibc with fixed TSX */ - /* This disables lock elision to workaround a bug in glibc 2.19+ */ - if (0 != pthread_mutexattr_init(&mattr)) { - ABORT("pthread_mutexattr_init failed"); - } - if (0 != pthread_mutexattr_settype(&mattr, PTHREAD_MUTEX_NORMAL)) { - ABORT("pthread_mutexattr_settype failed"); - } - if (0 != pthread_mutex_init(&mark_mutex, &mattr)) { - ABORT("pthread_mutex_init failed"); - } - (void)pthread_mutexattr_destroy(&mattr); - } -# endif -} - -GC_INNER void GC_acquire_mark_lock(void) -{ -# ifdef NUMERIC_THREAD_ID_UNIQUE - GC_ASSERT(GC_mark_lock_holder != NUMERIC_THREAD_ID(pthread_self())); -# endif - GC_generic_lock(&mark_mutex); - SET_MARK_LOCK_HOLDER; -} - -GC_INNER void GC_release_mark_lock(void) -{ - UNSET_MARK_LOCK_HOLDER; - if (pthread_mutex_unlock(&mark_mutex) != 0) { - ABORT("pthread_mutex_unlock failed"); - } -} - -/* Collector must wait for a freelist builders for 2 reasons: */ -/* 1) Mark bits may still be getting examined without lock. */ -/* 2) Partial free lists referenced only by locals may not be scanned */ -/* correctly, e.g. if they contain "pointer-free" objects, since the */ -/* free-list link may be ignored. */ -STATIC void GC_wait_builder(void) -{ - ASSERT_CANCEL_DISABLED(); - UNSET_MARK_LOCK_HOLDER; - if (pthread_cond_wait(&builder_cv, &mark_mutex) != 0) { - ABORT("pthread_cond_wait failed"); - } - GC_ASSERT(GC_mark_lock_holder == NO_THREAD); - SET_MARK_LOCK_HOLDER; -} - -GC_INNER void GC_wait_for_reclaim(void) -{ - GC_acquire_mark_lock(); - while (GC_fl_builder_count > 0) { - GC_wait_builder(); - } - GC_release_mark_lock(); -} - -GC_INNER void GC_notify_all_builder(void) -{ - GC_ASSERT(GC_mark_lock_holder == NUMERIC_THREAD_ID(pthread_self())); - if (pthread_cond_broadcast(&builder_cv) != 0) { - ABORT("pthread_cond_broadcast failed"); - } -} - -static pthread_cond_t mark_cv = PTHREAD_COND_INITIALIZER; - -GC_INNER void GC_wait_marker(void) -{ - ASSERT_CANCEL_DISABLED(); - UNSET_MARK_LOCK_HOLDER; - if (pthread_cond_wait(&mark_cv, &mark_mutex) != 0) { - ABORT("pthread_cond_wait failed"); - } - GC_ASSERT(GC_mark_lock_holder == NO_THREAD); - SET_MARK_LOCK_HOLDER; -} - -GC_INNER void GC_notify_all_marker(void) -{ - if (pthread_cond_broadcast(&mark_cv) != 0) { - ABORT("pthread_cond_broadcast failed"); - } -} - -#endif /* PARALLEL_MARK */ - -#ifdef PTHREAD_REGISTER_CANCEL_WEAK_STUBS - /* Workaround "undefined reference" linkage errors on some targets. */ - void __pthread_register_cancel() __attribute__((__weak__)); - void __pthread_unregister_cancel() __attribute__((__weak__)); - void __pthread_register_cancel() {} - void __pthread_unregister_cancel() {} -#endif - -#endif /* GC_PTHREADS */ diff -Nru ecl-16.1.2/src/bdwgc/ptr_chck.c ecl-16.1.3+ds/src/bdwgc/ptr_chck.c --- ecl-16.1.2/src/bdwgc/ptr_chck.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/ptr_chck.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,278 +0,0 @@ -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#include "private/gc_pmark.h" - -/* - * These are checking routines calls to which could be inserted by a - * preprocessor to validate C pointer arithmetic. - */ - -STATIC void GC_CALLBACK GC_default_same_obj_print_proc(void * p, void * q) -{ - ABORT_ARG2("GC_same_obj test failed", - ": %p and %p are not in the same object", p, q); -} - -void (GC_CALLBACK *GC_same_obj_print_proc) (void *, void *) - = GC_default_same_obj_print_proc; - -/* Check that p and q point to the same object. Call */ -/* *GC_same_obj_print_proc if they don't. */ -/* Returns the first argument. (Return value may be hard */ -/* to use due to typing issues. But if we had a suitable */ -/* preprocessor...) */ -/* Succeeds if neither p nor q points to the heap. */ -/* We assume this is performance critical. (It shouldn't */ -/* be called by production code, but this can easily make */ -/* debugging intolerably slow.) */ -GC_API void * GC_CALL GC_same_obj(void *p, void *q) -{ - struct hblk *h; - hdr *hhdr; - ptr_t base, limit; - word sz; - - if (!EXPECT(GC_is_initialized, TRUE)) GC_init(); - hhdr = HDR((word)p); - if (hhdr == 0) { - if (divHBLKSZ((word)p) != divHBLKSZ((word)q) - && HDR((word)q) != 0) { - goto fail; - } - return(p); - } - /* If it's a pointer to the middle of a large object, move it */ - /* to the beginning. */ - if (IS_FORWARDING_ADDR_OR_NIL(hhdr)) { - h = HBLKPTR(p) - (word)hhdr; - hhdr = HDR(h); - while (IS_FORWARDING_ADDR_OR_NIL(hhdr)) { - h = FORWARDED_ADDR(h, hhdr); - hhdr = HDR(h); - } - limit = (ptr_t)h + hhdr -> hb_sz; - if ((word)p >= (word)limit || (word)q >= (word)limit - || (word)q < (word)h) { - goto fail; - } - return(p); - } - sz = hhdr -> hb_sz; - if (sz > MAXOBJBYTES) { - base = (ptr_t)HBLKPTR(p); - limit = base + sz; - if ((word)p >= (word)limit) { - goto fail; - } - } else { - size_t offset; - size_t pdispl = HBLKDISPL(p); - - offset = pdispl % sz; - if (HBLKPTR(p) != HBLKPTR(q)) goto fail; - /* W/o this check, we might miss an error if */ - /* q points to the first object on a page, and */ - /* points just before the page. */ - base = (ptr_t)p - offset; - limit = base + sz; - } - /* [base, limit) delimits the object containing p, if any. */ - /* If p is not inside a valid object, then either q is */ - /* also outside any valid object, or it is outside */ - /* [base, limit). */ - if ((word)q >= (word)limit || (word)q < (word)base) { - goto fail; - } - return(p); -fail: - (*GC_same_obj_print_proc)((ptr_t)p, (ptr_t)q); - return(p); -} - -STATIC void GC_CALLBACK GC_default_is_valid_displacement_print_proc (void *p) -{ - ABORT_ARG1("GC_is_valid_displacement test failed", ": %p not valid", p); -} - -void (GC_CALLBACK *GC_is_valid_displacement_print_proc)(void *) = - GC_default_is_valid_displacement_print_proc; - -/* Check that if p is a pointer to a heap page, then it points to */ -/* a valid displacement within a heap object. */ -/* Uninteresting with GC_all_interior_pointers. */ -/* Always returns its argument. */ -/* Note that we don't lock, since nothing relevant about the header */ -/* should change while we have a valid object pointer to the block. */ -GC_API void * GC_CALL GC_is_valid_displacement(void *p) -{ - hdr *hhdr; - word pdispl; - word offset; - struct hblk *h; - word sz; - - if (!EXPECT(GC_is_initialized, TRUE)) GC_init(); - hhdr = HDR((word)p); - if (hhdr == 0) return(p); - h = HBLKPTR(p); - if (GC_all_interior_pointers) { - while (IS_FORWARDING_ADDR_OR_NIL(hhdr)) { - h = FORWARDED_ADDR(h, hhdr); - hhdr = HDR(h); - } - } - if (IS_FORWARDING_ADDR_OR_NIL(hhdr)) { - goto fail; - } - sz = hhdr -> hb_sz; - pdispl = HBLKDISPL(p); - offset = pdispl % sz; - if ((sz > MAXOBJBYTES && (word)p >= (word)h + sz) - || !GC_valid_offsets[offset] - || (word)p - offset + sz > (word)(h + 1)) { - goto fail; - } - return(p); -fail: - (*GC_is_valid_displacement_print_proc)((ptr_t)p); - return(p); -} - -STATIC void GC_CALLBACK GC_default_is_visible_print_proc(void * p) -{ - ABORT_ARG1("GC_is_visible test failed", ": %p not GC-visible", p); -} - -void (GC_CALLBACK *GC_is_visible_print_proc)(void * p) = - GC_default_is_visible_print_proc; - -#ifndef THREADS -/* Could p be a stack address? */ - STATIC GC_bool GC_on_stack(ptr_t p) - { -# ifdef STACK_GROWS_DOWN - if ((word)p >= (word)GC_approx_sp() - && (word)p < (word)GC_stackbottom) { - return(TRUE); - } -# else - if ((word)p <= (word)GC_approx_sp() - && (word)p > (word)GC_stackbottom) { - return(TRUE); - } -# endif - return(FALSE); - } -#endif - -/* Check that p is visible */ -/* to the collector as a possibly pointer containing location. */ -/* If it isn't invoke *GC_is_visible_print_proc. */ -/* Returns the argument in all cases. May erroneously succeed */ -/* in hard cases. (This is intended for debugging use with */ -/* untyped allocations. The idea is that it should be possible, though */ -/* slow, to add such a call to all indirect pointer stores.) */ -/* Currently useless for the multi-threaded worlds. */ -GC_API void * GC_CALL GC_is_visible(void *p) -{ - hdr *hhdr; - - if ((word)p & (ALIGNMENT - 1)) goto fail; - if (!EXPECT(GC_is_initialized, TRUE)) GC_init(); -# ifdef THREADS - hhdr = HDR((word)p); - if (hhdr != 0 && GC_base(p) == 0) { - goto fail; - } else { - /* May be inside thread stack. We can't do much. */ - return(p); - } -# else - /* Check stack first: */ - if (GC_on_stack(p)) return(p); - hhdr = HDR((word)p); - if (hhdr == 0) { - if (GC_is_static_root(p)) return(p); - /* Else do it again correctly: */ -# if defined(DYNAMIC_LOADING) || defined(MSWIN32) \ - || defined(MSWINCE) || defined(CYGWIN32) || defined(PCR) - GC_register_dynamic_libraries(); - if (GC_is_static_root(p)) - return(p); -# endif - goto fail; - } else { - /* p points to the heap. */ - word descr; - ptr_t base = GC_base(p); /* Should be manually inlined? */ - - if (base == 0) goto fail; - if (HBLKPTR(base) != HBLKPTR(p)) hhdr = HDR((word)p); - descr = hhdr -> hb_descr; - retry: - switch(descr & GC_DS_TAGS) { - case GC_DS_LENGTH: - if ((word)p - (word)base > descr) goto fail; - break; - case GC_DS_BITMAP: - if ((word)p - (word)base >= WORDS_TO_BYTES(BITMAP_BITS) - || ((word)p & (sizeof(word) - 1))) goto fail; - if (!(((word)1 << (WORDSZ - ((ptr_t)p - (ptr_t)base) - 1)) - & descr)) goto fail; - break; - case GC_DS_PROC: - /* We could try to decipher this partially. */ - /* For now we just punt. */ - break; - case GC_DS_PER_OBJECT: - if ((signed_word)descr >= 0) { - descr = *(word *)((ptr_t)base + (descr & ~GC_DS_TAGS)); - } else { - ptr_t type_descr = *(ptr_t *)base; - descr = *(word *)(type_descr - - (descr - (word)(GC_DS_PER_OBJECT - - GC_INDIR_PER_OBJ_BIAS))); - } - goto retry; - } - return(p); - } -# endif -fail: - (*GC_is_visible_print_proc)((ptr_t)p); - return(p); -} - -GC_API void * GC_CALL GC_pre_incr (void **p, ptrdiff_t how_much) -{ - void * initial = *p; - void * result = GC_same_obj((void *)((ptr_t)initial + how_much), initial); - - if (!GC_all_interior_pointers) { - (void) GC_is_valid_displacement(result); - } - return (*p = result); -} - -GC_API void * GC_CALL GC_post_incr (void **p, ptrdiff_t how_much) -{ - void * initial = *p; - void * result = GC_same_obj((void *)((ptr_t)initial + how_much), initial); - - if (!GC_all_interior_pointers) { - (void) GC_is_valid_displacement(result); - } - *p = result; - return(initial); -} diff -Nru ecl-16.1.2/src/bdwgc/README.md ecl-16.1.3+ds/src/bdwgc/README.md --- ecl-16.1.2/src/bdwgc/README.md 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/README.md 1970-01-01 00:00:00.000000000 +0000 @@ -1,582 +0,0 @@ -# Boehm-Demers-Weiser Garbage Collector - -This is version 7.5.0 (next release development) of a conservative garbage -collector for C and C++. - -You might find a more recent version -[here](http://www.hboehm.info/gc/), or -[here](https://github.com/ivmai/bdwgc). - - -## Overview - -This is intended to be a general purpose, garbage collecting storage -allocator. The algorithms used are described in: - - * Boehm, H., and M. Weiser, "Garbage Collection in an Uncooperative - Environment", Software Practice & Experience, September 1988, pp. 807-820. - - * Boehm, H., A. Demers, and S. Shenker, "Mostly Parallel Garbage Collection", - Proceedings of the ACM SIGPLAN '91 Conference on Programming Language Design - and Implementation, SIGPLAN Notices 26, 6 (June 1991), pp. 157-164. - - * Boehm, H., "Space Efficient Conservative Garbage Collection", Proceedings - of the ACM SIGPLAN '91 Conference on Programming Language Design and - Implementation, SIGPLAN Notices 28, 6 (June 1993), pp. 197-206. - - * Boehm H., "Reducing Garbage Collector Cache Misses", Proceedings of the - 2000 International Symposium on Memory Management. - -Possible interactions between the collector and optimizing compilers are -discussed in - - * Boehm, H., and D. Chase, "A Proposal for GC-safe C Compilation", - The Journal of C Language Translation 4, 2 (December 1992). - -and - - * Boehm H., "Simple GC-safe Compilation", Proceedings of the ACM SIGPLAN '96 - Conference on Programming Language Design and Implementation. - -Unlike the collector described in the second reference, this collector -operates either with the mutator stopped during the entire collection -(default) or incrementally during allocations. (The latter is supported -on fewer machines.) On the most common platforms, it can be built -with or without thread support. On a few platforms, it can take advantage -of a multiprocessor to speed up garbage collection. - -Many of the ideas underlying the collector have previously been explored -by others. Notably, some of the run-time systems developed at Xerox PARC -in the early 1980s conservatively scanned thread stacks to locate possible -pointers (cf. Paul Rovner, "On Adding Garbage Collection and Runtime Types -to a Strongly-Typed Statically Checked, Concurrent Language" Xerox PARC -CSL 84-7). Doug McIlroy wrote a simpler fully conservative collector that -was part of version 8 UNIX (tm), but appears to not have received -widespread use. - -Rudimentary tools for use of the collector as a -[leak detector](http://www.hboehm.info/gc/leak.html) are included, -as is a fairly sophisticated string package "cord" that makes use of the -collector. (See doc/README.cords and H.-J. Boehm, R. Atkinson, and M. Plass, -"Ropes: An Alternative to Strings", Software Practice and Experience 25, 12 -(December 1995), pp. 1315-1330. This is very similar to the "rope" package -in Xerox Cedar, or the "rope" package in the SGI STL or the g++ distribution.) - -Further collector documentation can be found -[here](http://www.hboehm.info/gc/). - - -## General Description - -This is a garbage collecting storage allocator that is intended to be -used as a plug-in replacement for C's malloc. - -Since the collector does not require pointers to be tagged, it does not -attempt to ensure that all inaccessible storage is reclaimed. However, -in our experience, it is typically more successful at reclaiming unused -memory than most C programs using explicit deallocation. Unlike manually -introduced leaks, the amount of unreclaimed memory typically stays -bounded. - -In the following, an "object" is defined to be a region of memory allocated -by the routines described below. - -Any objects not intended to be collected must be pointed to either -from other such accessible objects, or from the registers, -stack, data, or statically allocated bss segments. Pointers from -the stack or registers may point to anywhere inside an object. -The same is true for heap pointers if the collector is compiled with -`ALL_INTERIOR_POINTERS` defined, or `GC_all_interior_pointers` is otherwise -set, as is now the default. - -Compiling without `ALL_INTERIOR_POINTERS` may reduce accidental retention -of garbage objects, by requiring pointers from the heap to the beginning -of an object. But this no longer appears to be a significant -issue for most programs occupying a small fraction of the possible -address space. - -There are a number of routines which modify the pointer recognition -algorithm. `GC_register_displacement` allows certain interior pointers -to be recognized even if `ALL_INTERIOR_POINTERS` is nor defined. -`GC_malloc_ignore_off_page` allows some pointers into the middle of -large objects to be disregarded, greatly reducing the probability of -accidental retention of large objects. For most purposes it seems -best to compile with `ALL_INTERIOR_POINTERS` and to use -`GC_malloc_ignore_off_page` if you get collector warnings from -allocations of very large objects. See doc/debugging.html for details. - -_WARNING_: pointers inside memory allocated by the standard `malloc` are not -seen by the garbage collector. Thus objects pointed to only from such a -region may be prematurely deallocated. It is thus suggested that the -standard `malloc` be used only for memory regions, such as I/O buffers, that -are guaranteed not to contain pointers to garbage collectible memory. -Pointers in C language automatic, static, or register variables, -are correctly recognized. (Note that `GC_malloc_uncollectable` has -semantics similar to standard malloc, but allocates objects that are -traced by the collector.) - -_WARNING_: the collector does not always know how to find pointers in data -areas that are associated with dynamic libraries. This is easy to -remedy IF you know how to find those data areas on your operating -system (see `GC_add_roots`). Code for doing this under SunOS, IRIX -5.X and 6.X, HP/UX, Alpha OSF/1, Linux, and win32 is included and used -by default. (See doc/README.win32 for Win32 details.) On other systems -pointers from dynamic library data areas may not be considered by the -collector. If you're writing a program that depends on the collector -scanning dynamic library data areas, it may be a good idea to include -at least one call to `GC_is_visible` to ensure that those areas are -visible to the collector. - -Note that the garbage collector does not need to be informed of shared -read-only data. However if the shared library mechanism can introduce -discontiguous data areas that may contain pointers, then the collector does -need to be informed. - -Signal processing for most signals may be deferred during collection, -and during uninterruptible parts of the allocation process. -Like standard ANSI C mallocs, by default it is unsafe to invoke -malloc (and other GC routines) from a signal handler while another -malloc call may be in progress. - -The allocator/collector can also be configured for thread-safe operation. -(Full signal safety can also be achieved, but only at the cost of two system -calls per malloc, which is usually unacceptable.) - -_WARNING_: the collector does not guarantee to scan thread-local storage -(e.g. of the kind accessed with `pthread_getspecific`). The collector -does scan thread stacks, though, so generally the best solution is to -ensure that any pointers stored in thread-local storage are also -stored on the thread's stack for the duration of their lifetime. -(This is arguably a longstanding bug, but it hasn't been fixed yet.) - - -## Installation and Portability - -As distributed, the collector operates silently -In the event of problems, this can usually be changed by defining the -`GC_PRINT_STATS` or `GC_PRINT_VERBOSE_STATS` environment variables. This -will result in a few lines of descriptive output for each collection. -(The given statistics exhibit a few peculiarities. -Things don't appear to add up for a variety of reasons, most notably -fragmentation losses. These are probably much more significant for the -contrived program "test.c" than for your application.) - -On most Unix-like platforms, the collector can be built either using a -GNU autoconf-based build infrastructure (type `./configure; make` in the -simplest case), or with a classic makefile by itself (type -`make -f Makefile.direct`). - -Please note that the collector source repository does not contain configure -and similar auto-generated files, thus the full procedure of autoconf-based -build of `master` branch of the collector (using `master` branch of -libatomic_ops source repository as well) could look like: - - git clone git://github.com/ivmai/bdwgc.git - cd bdwgc - git clone git://github.com/ivmai/libatomic_ops.git - autoreconf -vif - automake --add-missing - ./configure - make - make check - -Below we focus on the collector build using classic makefile. -For the Makefile.direct-based process, typing `make test` instead of `make` -will automatically build the collector and then run `setjmp_test` and `gctest`. -`Setjmp_test` will give you information about configuring the collector, which is -useful primarily if you have a machine that's not already supported. Gctest is -a somewhat superficial test of collector functionality. Failure is indicated -by a core dump or a message to the effect that the collector is broken. Gctest -takes about a second to two to run on reasonable 2007 vintage desktops. It may -use up to about 30MB of memory. (The multi-threaded version will use more. -64-bit versions may use more.) `make test` will also, as its last step, attempt -to build and test the "cord" string library.) - -Makefile.direct will generate a library gc.a which you should link against. -Typing "make cords" will add the cord library to gc.a. - -The GNU style build process understands the usual targets. `make check` -runs a number of tests. `make install` installs at least libgc, and libcord. -Try `./configure --help` to see the configuration options. It is currently -not possible to exercise all combinations of build options this way. - -It is suggested that if you need to replace a piece of the collector -(e.g. GC_mark_rts.c) you simply list your version ahead of gc.a on the -ld command line, rather than replacing the one in gc.a. (This will -generate numerous warnings under some versions of AIX, but it still -works.) - -All include files that need to be used by clients will be put in the -include subdirectory. (Normally this is just gc.h. `make cords` adds -"cord.h" and "ec.h".) - -The collector currently is designed to run essentially unmodified on -machines that use a flat 32-bit or 64-bit address space. -That includes the vast majority of Workstations and X86 (X >= 3) PCs. -(The list here was deleted because it was getting too long and constantly -out of date.) - -In a few cases (Amiga, OS/2, Win32, MacOS) a separate makefile -or equivalent is supplied. Many of these have separate README.system -files. - -Dynamic libraries are completely supported only under SunOS/Solaris, -(and even that support is not functional on the last Sun 3 release), -Linux, FreeBSD, NetBSD, IRIX 5&6, HP/UX, Win32 (not Win32S) and OSF/1 -on DEC AXP machines plus perhaps a few others listed near the top -of dyn_load.c. On other machines we recommend that you do one of -the following: - - 1) Add dynamic library support (and send us the code). - 2) Use static versions of the libraries. - 3) Arrange for dynamic libraries to use the standard malloc. - This is still dangerous if the library stores a pointer to a - garbage collected object. But nearly all standard interfaces - prohibit this, because they deal correctly with pointers - to stack allocated objects. (Strtok is an exception. Don't - use it.) - -In all cases we assume that pointer alignment is consistent with that -enforced by the standard C compilers. If you use a nonstandard compiler -you may have to adjust the alignment parameters defined in gc_priv.h. -Note that this may also be an issue with packed records/structs, if those -enforce less alignment for pointers. - -A port to a machine that is not byte addressed, or does not use 32 bit -or 64 bit addresses will require a major effort. A port to plain MSDOS -or win16 is hard. - -For machines not already mentioned, or for nonstandard compilers, -some porting suggestions are provided in doc/porting.html. - - -## The C Interface to the Allocator - -The following routines are intended to be directly called by the user. -Note that usually only `GC_malloc` is necessary. `GC_clear_roots` and -`GC_add_roots` calls may be required if the collector has to trace -from nonstandard places (e.g. from dynamic library data areas on a -machine on which the collector doesn't already understand them.) On -some machines, it may be desirable to set `GC_stacktop` to a good -approximation of the stack base. (This enhances code portability on -HP PA machines, since there is no good way for the collector to -compute this value.) Client code may include "gc.h", which defines -all of the following, plus many others. - - 1) `GC_malloc(nbytes)` - - Allocate an object of size nbytes. Unlike malloc, the object is - cleared before being returned to the user. `GC_malloc` will - invoke the garbage collector when it determines this to be appropriate. - GC_malloc may return 0 if it is unable to acquire sufficient - space from the operating system. This is the most probable - consequence of running out of space. Other possible consequences - are that a function call will fail due to lack of stack space, - or that the collector will fail in other ways because it cannot - maintain its internal data structures, or that a crucial system - process will fail and take down the machine. Most of these - possibilities are independent of the malloc implementation. - - 2) `GC_malloc_atomic(nbytes)` - - Allocate an object of size nbytes that is guaranteed not to contain any - pointers. The returned object is not guaranteed to be cleared. - (Can always be replaced by `GC_malloc`, but results in faster collection - times. The collector will probably run faster if large character - arrays, etc. are allocated with `GC_malloc_atomic` than if they are - statically allocated.) - - 3) `GC_realloc(object, new_size)` - - Change the size of object to be `new_size`. Returns a pointer to the - new object, which may, or may not, be the same as the pointer to - the old object. The new object is taken to be atomic if and only if the - old one was. If the new object is composite and larger than the original - object,then the newly added bytes are cleared (we hope). This is very - likely to allocate a new object, unless `MERGE_SIZES` is defined in - gc_priv.h. Even then, it is likely to recycle the old object only if the - object is grown in small additive increments (which, we claim, is - generally bad coding practice.) - - 4) `GC_free(object)` - - Explicitly deallocate an object returned by `GC_malloc` or - `GC_malloc_atomic`. Not necessary, but can be used to minimize - collections if performance is critical. Probably a performance - loss for very small objects (<= 8 bytes). - - 5) `GC_expand_hp(bytes)` - - Explicitly increase the heap size. (This is normally done automatically - if a garbage collection failed to `GC_reclaim` enough memory. Explicit - calls to `GC_expand_hp` may prevent unnecessarily frequent collections at - program startup.) - - 6) `GC_malloc_ignore_off_page(bytes)` - - Identical to `GC_malloc`, but the client promises to keep a pointer to - the somewhere within the first 256 bytes of the object while it is - live. (This pointer should normally be declared volatile to prevent - interference from compiler optimizations.) This is the recommended - way to allocate anything that is likely to be larger than 100 Kbytes - or so. (`GC_malloc` may result in failure to reclaim such objects.) - - 7) `GC_set_warn_proc(proc)` - - Can be used to redirect warnings from the collector. Such warnings - should be rare, and should not be ignored during code development. - - 8) `GC_enable_incremental()` - - Enables generational and incremental collection. Useful for large - heaps on machines that provide access to page dirty information. - Some dirty bit implementations may interfere with debugging - (by catching address faults) and place restrictions on heap arguments - to system calls (since write faults inside a system call may not be - handled well). - - 9) Several routines to allow for registration of finalization code. - User supplied finalization code may be invoked when an object becomes - unreachable. To call `(*f)(obj, x)` when obj becomes inaccessible, use - `GC_register_finalizer(obj, f, x, 0, 0);` - For more sophisticated uses, and for finalization ordering issues, - see gc.h. - -The global variable `GC_free_space_divisor` may be adjusted up from it -default value of 3 to use less space and more collection time, or down for -the opposite effect. Setting it to 1 will almost disable collections -and cause all allocations to simply grow the heap. - -The variable `GC_non_gc_bytes`, which is normally 0, may be changed to reflect -the amount of memory allocated by the above routines that should not be -considered as a candidate for collection. Careless use may, of course, result -in excessive memory consumption. - -Some additional tuning is possible through the parameters defined -near the top of gc_priv.h. - -If only `GC_malloc` is intended to be used, it might be appropriate to define: - - #define malloc(n) GC_malloc(n) - #define calloc(m,n) GC_malloc((m)*(n)) - -For small pieces of VERY allocation intensive code, gc_inl.h includes -some allocation macros that may be used in place of `GC_malloc` and -friends. - -All externally visible names in the garbage collector start with `GC_`. -To avoid name conflicts, client code should avoid this prefix, except when -accessing garbage collector routines or variables. - -There are provisions for allocation with explicit type information. -This is rarely necessary. Details can be found in gc_typed.h. - - -## The C++ Interface to the Allocator - -The Ellis-Hull C++ interface to the collector is included in -the collector distribution. If you intend to use this, type -`make c++` after the initial build of the collector is complete. -See gc_cpp.h for the definition of the interface. This interface -tries to approximate the Ellis-Detlefs C++ garbage collection -proposal without compiler changes. - -Very often it will also be necessary to use gc_allocator.h and the -allocator declared there to construct STL data structures. Otherwise -subobjects of STL data structures will be allocated using a system -allocator, and objects they refer to may be prematurely collected. - - -## Use as Leak Detector - -The collector may be used to track down leaks in C programs that are -intended to run with malloc/free (e.g. code with extreme real-time or -portability constraints). To do so define `FIND_LEAK` in Makefile. -This will cause the collector to invoke the `report_leak` -routine defined near the top of reclaim.c whenever an inaccessible -object is found that has not been explicitly freed. Such objects will -also be automatically reclaimed. - -If all objects are allocated with `GC_DEBUG_MALLOC` (see next section), then -the default version of report_leak will report at least the source file and -line number at which the leaked object was allocated. This may sometimes be -sufficient. (On a few machines, it will also report a cryptic stack trace. -If this is not symbolic, it can sometimes be called into a symbolic stack -trace by invoking program "foo" with "tools/callprocs.sh foo". It is a short -shell script that invokes adb to expand program counter values to symbolic -addresses. It was largely supplied by Scott Schwartz.) - -Note that the debugging facilities described in the next section can -sometimes be slightly LESS effective in leak finding mode, since in -leak finding mode, `GC_debug_free` actually results in reuse of the object. -(Otherwise the object is simply marked invalid.) Also note that the test -program is not designed to run meaningfully in `FIND_LEAK` mode. -Use "make gc.a" to build the collector. - - -## Debugging Facilities - -The routines `GC_debug_malloc`, `GC_debug_malloc_atomic`, `GC_debug_realloc`, -and `GC_debug_free` provide an alternate interface to the collector, which -provides some help with memory overwrite errors, and the like. -Objects allocated in this way are annotated with additional -information. Some of this information is checked during garbage -collections, and detected inconsistencies are reported to stderr. - -Simple cases of writing past the end of an allocated object should -be caught if the object is explicitly deallocated, or if the -collector is invoked while the object is live. The first deallocation -of an object will clear the debugging info associated with an -object, so accidentally repeated calls to `GC_debug_free` will report the -deallocation of an object without debugging information. Out of -memory errors will be reported to stderr, in addition to returning `NULL`. - -`GC_debug_malloc` checking during garbage collection is enabled -with the first call to `GC_debug_malloc`. This will result in some -slowdown during collections. If frequent heap checks are desired, -this can be achieved by explicitly invoking `GC_gcollect`, e.g. from -the debugger. - -`GC_debug_malloc` allocated objects should not be passed to `GC_realloc` -or `GC_free`, and conversely. It is however acceptable to allocate only -some objects with `GC_debug_malloc`, and to use `GC_malloc` for other objects, -provided the two pools are kept distinct. In this case, there is a very -low probability that `GC_malloc` allocated objects may be misidentified as -having been overwritten. This should happen with probability at most -one in 2**32. This probability is zero if `GC_debug_malloc` is never called. - -`GC_debug_malloc`, `GC_malloc_atomic`, and `GC_debug_realloc` take two -additional trailing arguments, a string and an integer. These are not -interpreted by the allocator. They are stored in the object (the string is -not copied). If an error involving the object is detected, they are printed. - -The macros `GC_MALLOC`, `GC_MALLOC_ATOMIC`, `GC_REALLOC`, `GC_FREE`, and -`GC_REGISTER_FINALIZER` are also provided. These require the same arguments -as the corresponding (nondebugging) routines. If gc.h is included -with `GC_DEBUG` defined, they call the debugging versions of these -functions, passing the current file name and line number as the two -extra arguments, where appropriate. If gc.h is included without `GC_DEBUG` -defined, then all these macros will instead be defined to their nondebugging -equivalents. (`GC_REGISTER_FINALIZER` is necessary, since pointers to -objects with debugging information are really pointers to a displacement -of 16 bytes form the object beginning, and some translation is necessary -when finalization routines are invoked. For details, about what's stored -in the header, see the definition of the type oh in debug_malloc.c) - - -## Incremental/Generational Collection - -The collector normally interrupts client code for the duration of -a garbage collection mark phase. This may be unacceptable if interactive -response is needed for programs with large heaps. The collector -can also run in a "generational" mode, in which it usually attempts to -collect only objects allocated since the last garbage collection. -Furthermore, in this mode, garbage collections run mostly incrementally, -with a small amount of work performed in response to each of a large number of -`GC_malloc` requests. - -This mode is enabled by a call to `GC_enable_incremental`. - -Incremental and generational collection is effective in reducing -pause times only if the collector has some way to tell which objects -or pages have been recently modified. The collector uses two sources -of information: - -1. Information provided by the VM system. This may be provided in - one of several forms. Under Solaris 2.X (and potentially under other - similar systems) information on dirty pages can be read from the - /proc file system. Under other systems (currently SunOS4.X) it is - possible to write-protect the heap, and catch the resulting faults. - On these systems we require that system calls writing to the heap - (other than read) be handled specially by client code. - See os_dep.c for details. - -2. Information supplied by the programmer. We define "stubborn" - objects to be objects that are rarely changed. Such an object - can be allocated (and enabled for writing) with `GC_malloc_stubborn`. - Once it has been initialized, the collector should be informed with - a call to `GC_end_stubborn_change`. Subsequent writes that store - pointers into the object must be preceded by a call to - `GC_change_stubborn`. - -This mechanism performs best for objects that are written only for -initialization, and such that only one stubborn object is writable -at once. It is typically not worth using for short-lived -objects. Stubborn objects are treated less efficiently than pointer-free -(atomic) objects. - -A rough rule of thumb is that, in the absence of VM information, garbage -collection pauses are proportional to the amount of pointerful storage -plus the amount of modified "stubborn" storage that is reachable during -the collection. - -Initial allocation of stubborn objects takes longer than allocation -of other objects, since other data structures need to be maintained. - -We recommend against random use of stubborn objects in client -code, since bugs caused by inappropriate writes to stubborn objects -are likely to be very infrequently observed and hard to trace. -However, their use may be appropriate in a few carefully written -library routines that do not make the objects themselves available -for writing by client code. - - -## Bugs - -Any memory that does not have a recognizable pointer to it will be -reclaimed. Exclusive-or'ing forward and backward links in a list -doesn't cut it. - -Some C optimizers may lose the last undisguised pointer to a memory -object as a consequence of clever optimizations. This has almost -never been observed in practice. - -This is not a real-time collector. In the standard configuration, -percentage of time required for collection should be constant across -heap sizes. But collection pauses will increase for larger heaps. -They will decrease with the number of processors if parallel marking -is enabled. - -(On 2007 vintage machines, GC times may be on the order of 5 msecs -per MB of accessible memory that needs to be scanned and processor. -Your mileage may vary.) The incremental/generational collection facility -may help in some cases. - -Please address bug reports [here](mailto:bdwgc@lists.opendylan.org). -If you are contemplating a major addition, you might also send mail to ask -whether it's already been done (or whether we tried and discarded it). - - -## Copyright & Warranty - - * Copyright (c) 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1996 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 1999-2011 by Hewlett-Packard Development Company. - -The file linux_threads.c is also - - * Copyright (c) 1998 by Fergus Henderson. All rights reserved. - -The files Makefile.am, and configure.in are - -* Copyright (c) 2001 by Red Hat Inc. All rights reserved. - -Several files supporting GNU-style builds are copyrighted by the Free -Software Foundation, and carry a different license from that given -below. The files included in the libatomic_ops distribution (included -here) use either the license below, or a similar MIT-style license, -or, for some files not actually used by the garbage-collector library, the -GPL. - -THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED -OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - -Permission is hereby granted to use or copy this program -for any purpose, provided the above notices are retained on all copies. -Permission to modify the code and to distribute modified code is granted, -provided the above notices are retained, and a notice that the code was -modified is included with the above copyright notice. - -A few of the files needed to use the GNU-style build procedure come with -slightly different licenses, though they are all similar in spirit. A few -are GPL'ed, but with an exception that should cover all uses in the -collector. (If you are concerned about such things, I recommend you look -at the notice in config.guess or ltmain.sh.) - -The atomic_ops library contains some code that is covered by the GNU General -Public License, but is not needed by, nor linked into the collector library. -It is included here only because the atomic_ops distribution is, for -simplicity, included in its entirety. diff -Nru ecl-16.1.2/src/bdwgc/README.QUICK ecl-16.1.3+ds/src/bdwgc/README.QUICK --- ecl-16.1.2/src/bdwgc/README.QUICK 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/README.QUICK 1970-01-01 00:00:00.000000000 +0000 @@ -1,87 +0,0 @@ -Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers -Copyright (c) 1991-1995 by Xerox Corporation. All rights reserved. -Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. -Copyright (c) 1999-2001 by Hewlett-Packard. All rights reserved. - -THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED -OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - -Permission is hereby granted to use or copy this program -for any purpose, provided the above notices are retained on all copies. -Permission to modify the code and to distribute modified code is granted, -provided the above notices are retained, and a notice that the code was -modified is included with the above copyright notice. - -A few files have other copyright holders. A few of the files needed -to use the GNU-style build procedure come with a modified GPL license -that appears not to significantly restrict use of the collector, though -use of those files for a purpose other than building the collector may -require the resulting code to be covered by the GPL. - -For more details and the names of other contributors, see the README.md, -doc/README.*, AUTHORS and include/gc.h files. These files describe typical -use of the collector on a machine that is already supported. - -For the version number, see README.md or include/gc_version.h files. - -INSTALLATION: -Under UN*X, Linux: -Alternative 1 (the old way): type "make test" in this directory. - Link against gc.a. With the most recent GC distributions - you may have to type "make -f Makefile.direct test" or - copy Makefile.direct to Makefile first. - -Alternative 2 (the new way): type - "./configure --prefix=; make; make check; make install". - Link against /lib/libgc.a or /lib/libgc.so. - See doc/README.autoconf for details - -Under Windows 95, 98, Me, NT, or 2000: -copy the appropriate makefile to MAKEFILE, read it, and type "nmake test". -(Under Windows, this assumes you have Microsoft command-line tools -installed, and suitably configured.) -Read the machine specific README.XXX in the doc directory if one exists. - -If you need thread support, you will need to follow the special -platform-dependent instructions (win32), or define GC_THREADS -as described in doc/README.macros, or possibly use ---enable-threads=posix when running the configure script. - -If you wish to use the cord (structured string) library with the stand-alone -Makefile.direct, type "make cords", after copying to "Makefile". -(This requires an ANSI C compiler. You may -need to redefine CC in the Makefile. The CORD_printf implementation in -cordprnt.c is known to be less than perfectly portable. The rest of the -package should still work.) See include/cord.h for the API. - -If you wish to use the collector from C++, type "make c++", or use ---enable-cplusplus with the configure script. With Makefile.direct, -these ones add further files to gc.a and to the include subdirectory. -With the alternate build process, this generates libgccpp. -See include/gc_cpp.h. - -TYPICAL USE: -Include "gc.h" from the include subdirectory. Link against the -appropriate library ("gc.a" under UN*X). Replace calls to malloc -by calls to GC_MALLOC, and calls to realloc by calls to GC_REALLOC. -If the object is known to never contain pointers, use GC_MALLOC_ATOMIC -instead of GC_MALLOC. - -Define GC_DEBUG before including gc.h for additional checking. - -More documentation on the collector interface can be found in README.md, -doc/gcinterface.html, include/gc.h, and other files in the doc directory. - -WARNINGS: - -Do not store the only pointer to an object in memory allocated -with system malloc, since the collector usually does not scan -memory allocated in this way. - -Use with threads may be supported on your system, but requires the -collector to be built with thread support. See Makefile. The collector -does not guarantee to scan thread-local storage (e.g. of the kind -accessed with pthread_getspecific()). The collector does scan -thread stacks though, so generally the best solution is to ensure that -any pointers stored in thread-local storage are also stored on the -thread's stack for the duration of their lifetime. diff -Nru ecl-16.1.2/src/bdwgc/real_malloc.c ecl-16.1.3+ds/src/bdwgc/real_malloc.c --- ecl-16.1.2/src/bdwgc/real_malloc.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/real_malloc.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,39 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -# ifdef HAVE_CONFIG_H -# include "config.h" -# endif - -# ifdef PCR -/* - * This definition should go in its own file that includes no other - * header files. Otherwise, we risk not getting the underlying system - * malloc. - */ -# define PCR_NO_RENAME -# include - -void * real_malloc(size_t size) -{ - return(malloc(size)); -} - -# else - -extern int GC_quiet; - /* ANSI C doesn't allow translation units to be empty. */ - /* So we guarantee this one is nonempty. */ - -#endif /* PCR */ diff -Nru ecl-16.1.2/src/bdwgc/reclaim.c ecl-16.1.3+ds/src/bdwgc/reclaim.c --- ecl-16.1.2/src/bdwgc/reclaim.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/reclaim.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,774 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1996 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 1999-2004 Hewlett-Packard Development Company, L.P. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#include "private/gc_priv.h" - -#ifdef ENABLE_DISCLAIM -# include "gc_disclaim.h" -#endif - -#include - -GC_INNER signed_word GC_bytes_found = 0; - /* Number of bytes of memory reclaimed */ - /* minus the number of bytes originally */ - /* on free lists which we had to drop. */ - -#if defined(PARALLEL_MARK) - GC_INNER word GC_fl_builder_count = 0; - /* Number of threads currently building free lists without */ - /* holding GC lock. It is not safe to collect if this is */ - /* nonzero. */ -#endif /* PARALLEL_MARK */ - -/* We defer printing of leaked objects until we're done with the GC */ -/* cycle, since the routine for printing objects needs to run outside */ -/* the collector, e.g. without the allocation lock. */ -#ifndef MAX_LEAKED -# define MAX_LEAKED 40 -#endif -STATIC ptr_t GC_leaked[MAX_LEAKED] = { NULL }; -STATIC unsigned GC_n_leaked = 0; - -GC_INNER GC_bool GC_have_errors = FALSE; - -#if !defined(EAGER_SWEEP) && defined(ENABLE_DISCLAIM) - STATIC void GC_reclaim_unconditionally_marked(void); -#endif - -GC_INLINE void GC_add_leaked(ptr_t leaked) -{ -# ifndef SHORT_DBG_HDRS - if (GC_findleak_delay_free && !GC_check_leaked(leaked)) - return; -# endif - - GC_have_errors = TRUE; - if (GC_n_leaked < MAX_LEAKED) { - GC_leaked[GC_n_leaked++] = leaked; - /* Make sure it's not reclaimed this cycle */ - GC_set_mark_bit(leaked); - } -} - -/* Print all objects on the list after printing any smashed objects. */ -/* Clear both lists. Called without the allocation lock held. */ -GC_INNER void GC_print_all_errors(void) -{ - static GC_bool printing_errors = FALSE; - GC_bool have_errors; - unsigned i, n_leaked; - ptr_t leaked[MAX_LEAKED]; - DCL_LOCK_STATE; - - LOCK(); - if (printing_errors) { - UNLOCK(); - return; - } - have_errors = GC_have_errors; - printing_errors = TRUE; - n_leaked = GC_n_leaked; - GC_ASSERT(n_leaked <= MAX_LEAKED); - BCOPY(GC_leaked, leaked, n_leaked * sizeof(ptr_t)); - GC_n_leaked = 0; - BZERO(GC_leaked, n_leaked * sizeof(ptr_t)); - UNLOCK(); - - if (GC_debugging_started) { - GC_print_all_smashed(); - } else { - have_errors = FALSE; - } - - if (n_leaked > 0) { - GC_err_printf("Found %u leaked objects:\n", n_leaked); - have_errors = TRUE; - } - for (i = 0; i < n_leaked; i++) { - ptr_t p = leaked[i]; - GC_print_heap_obj(p); - GC_free(p); - } - - if (have_errors -# ifndef GC_ABORT_ON_LEAK - && GETENV("GC_ABORT_ON_LEAK") != NULL -# endif - ) { - ABORT("Leaked or smashed objects encountered"); - } - - LOCK(); - printing_errors = FALSE; - UNLOCK(); -} - - -/* - * reclaim phase - * - */ - -/* Test whether a block is completely empty, i.e. contains no marked */ -/* objects. This does not require the block to be in physical memory. */ -GC_INNER GC_bool GC_block_empty(hdr *hhdr) -{ - return (hhdr -> hb_n_marks == 0); -} - -STATIC GC_bool GC_block_nearly_full(hdr *hhdr) -{ - return (hhdr -> hb_n_marks > 7 * HBLK_OBJS(hhdr -> hb_sz)/8); -} - -/* FIXME: This should perhaps again be specialized for USE_MARK_BYTES */ -/* and USE_MARK_BITS cases. */ - -/* - * Restore unmarked small objects in h of size sz to the object - * free list. Returns the new list. - * Clears unmarked objects. Sz is in bytes. - */ -STATIC ptr_t GC_reclaim_clear(struct hblk *hbp, hdr *hhdr, size_t sz, - ptr_t list, signed_word *count) -{ - word bit_no = 0; - word *p, *q, *plim; - signed_word n_bytes_found = 0; - - GC_ASSERT(hhdr == GC_find_header((ptr_t)hbp)); - GC_ASSERT(sz == hhdr -> hb_sz); - GC_ASSERT((sz & (BYTES_PER_WORD-1)) == 0); - p = (word *)(hbp->hb_body); - plim = (word *)(hbp->hb_body + HBLKSIZE - sz); - - /* go through all words in block */ - while ((word)p <= (word)plim) { - if (mark_bit_from_hdr(hhdr, bit_no)) { - p = (word *)((ptr_t)p + sz); - } else { - n_bytes_found += sz; - /* object is available - put on list */ - obj_link(p) = list; - list = ((ptr_t)p); - /* Clear object, advance p to next object in the process */ - q = (word *)((ptr_t)p + sz); -# ifdef USE_MARK_BYTES - GC_ASSERT(!(sz & 1) - && !((word)p & (2 * sizeof(word) - 1))); - p[1] = 0; - p += 2; - while ((word)p < (word)q) { - CLEAR_DOUBLE(p); - p += 2; - } -# else - p++; /* Skip link field */ - while ((word)p < (word)q) { - *p++ = 0; - } -# endif - } - bit_no += MARK_BIT_OFFSET(sz); - } - *count += n_bytes_found; - return(list); -} - -/* The same thing, but don't clear objects: */ -STATIC ptr_t GC_reclaim_uninit(struct hblk *hbp, hdr *hhdr, size_t sz, - ptr_t list, signed_word *count) -{ - word bit_no = 0; - word *p, *plim; - signed_word n_bytes_found = 0; - - GC_ASSERT(sz == hhdr -> hb_sz); - p = (word *)(hbp->hb_body); - plim = (word *)((ptr_t)hbp + HBLKSIZE - sz); - - /* go through all words in block */ - while ((word)p <= (word)plim) { - if (!mark_bit_from_hdr(hhdr, bit_no)) { - n_bytes_found += sz; - /* object is available - put on list */ - obj_link(p) = list; - list = ((ptr_t)p); - } - p = (word *)((ptr_t)p + sz); - bit_no += MARK_BIT_OFFSET(sz); - } - *count += n_bytes_found; - return(list); -} - -#ifdef ENABLE_DISCLAIM - /* Call reclaim notifier for block's kind on each unmarked object in */ - /* block, all within a pair of corresponding enter/leave callbacks. */ - STATIC ptr_t GC_disclaim_and_reclaim(struct hblk *hbp, hdr *hhdr, size_t sz, - ptr_t list, signed_word *count) - { - int bit_no = 0; - word *p, *q, *plim; - signed_word n_bytes_found = 0; - struct obj_kind *ok = &GC_obj_kinds[hhdr->hb_obj_kind]; - int (GC_CALLBACK *disclaim)(void *) = ok->ok_disclaim_proc; - - GC_ASSERT(sz == hhdr -> hb_sz); - p = (word *)(hbp -> hb_body); - plim = (word *)((ptr_t)p + HBLKSIZE - sz); - - while ((word)p <= (word)plim) { - int marked = mark_bit_from_hdr(hhdr, bit_no); - if (!marked && (*disclaim)(p)) { - hhdr -> hb_n_marks++; - marked = 1; - } - if (marked) - p = (word *)((ptr_t)p + sz); - else { - n_bytes_found += sz; - /* object is available - put on list */ - obj_link(p) = list; - list = ((ptr_t)p); - /* Clear object, advance p to next object in the process */ - q = (word *)((ptr_t)p + sz); -# ifdef USE_MARK_BYTES - GC_ASSERT((sz & 1) == 0); - GC_ASSERT(((word)p & (2 * sizeof(word) - 1)) == 0); - p[1] = 0; - p += 2; - while ((word)p < (word)q) { - CLEAR_DOUBLE(p); - p += 2; - } -# else - p++; /* Skip link field */ - while ((word)p < (word)q) { - *p++ = 0; - } -# endif - } - bit_no += MARK_BIT_OFFSET(sz); - } - *count += n_bytes_found; - return list; - } -#endif /* ENABLE_DISCLAIM */ - -/* Don't really reclaim objects, just check for unmarked ones: */ -STATIC void GC_reclaim_check(struct hblk *hbp, hdr *hhdr, word sz) -{ - word bit_no; - ptr_t p, plim; - GC_ASSERT(sz == hhdr -> hb_sz); - - /* go through all words in block */ - p = hbp->hb_body; - plim = p + HBLKSIZE - sz; - for (bit_no = 0; (word)p <= (word)plim; - p += sz, bit_no += MARK_BIT_OFFSET(sz)) { - if (!mark_bit_from_hdr(hhdr, bit_no)) { - GC_add_leaked(p); - } - } -} - -/* - * Generic procedure to rebuild a free list in hbp. - * Also called directly from GC_malloc_many. - * Sz is now in bytes. - */ -GC_INNER ptr_t GC_reclaim_generic(struct hblk * hbp, hdr *hhdr, size_t sz, - GC_bool init, ptr_t list, - signed_word *count) -{ - ptr_t result; - - GC_ASSERT(GC_find_header((ptr_t)hbp) == hhdr); -# ifndef GC_DISABLE_INCREMENTAL - GC_remove_protection(hbp, 1, (hhdr)->hb_descr == 0 /* Pointer-free? */); -# endif -# ifdef ENABLE_DISCLAIM - if ((hhdr -> hb_flags & HAS_DISCLAIM) != 0) { - result = GC_disclaim_and_reclaim(hbp, hhdr, sz, list, count); - } else -# endif - /* else */ if (init || GC_debugging_started) { - result = GC_reclaim_clear(hbp, hhdr, sz, list, count); - } else { - GC_ASSERT((hhdr)->hb_descr == 0 /* Pointer-free block */); - result = GC_reclaim_uninit(hbp, hhdr, sz, list, count); - } - if (IS_UNCOLLECTABLE(hhdr -> hb_obj_kind)) GC_set_hdr_marks(hhdr); - return result; -} - -/* - * Restore unmarked small objects in the block pointed to by hbp - * to the appropriate object free list. - * If entirely empty blocks are to be completely deallocated, then - * caller should perform that check. - */ -STATIC void GC_reclaim_small_nonempty_block(struct hblk *hbp, - GC_bool report_if_found) -{ - hdr *hhdr = HDR(hbp); - size_t sz = hhdr -> hb_sz; - struct obj_kind * ok = &GC_obj_kinds[hhdr -> hb_obj_kind]; - void **flh = &(ok -> ok_freelist[BYTES_TO_GRANULES(sz)]); - - hhdr -> hb_last_reclaimed = (unsigned short) GC_gc_no; - - if (report_if_found) { - GC_reclaim_check(hbp, hhdr, sz); - } else { - *flh = GC_reclaim_generic(hbp, hhdr, sz, ok -> ok_init, - *flh, &GC_bytes_found); - } -} - -#ifdef ENABLE_DISCLAIM - STATIC void GC_disclaim_and_reclaim_or_free_small_block(struct hblk *hbp) - { - hdr *hhdr = HDR(hbp); - size_t sz = hhdr -> hb_sz; - struct obj_kind * ok = &GC_obj_kinds[hhdr -> hb_obj_kind]; - void **flh = &(ok -> ok_freelist[BYTES_TO_GRANULES(sz)]); - void *flh_next; - - hhdr -> hb_last_reclaimed = (unsigned short) GC_gc_no; - flh_next = GC_reclaim_generic(hbp, hhdr, sz, ok -> ok_init, - *flh, &GC_bytes_found); - if (hhdr -> hb_n_marks) - *flh = flh_next; - else { - GC_bytes_found += HBLKSIZE; - GC_freehblk(hbp); - } - } -#endif /* ENABLE_DISCLAIM */ - -/* - * Restore an unmarked large object or an entirely empty blocks of small objects - * to the heap block free list. - * Otherwise enqueue the block for later processing - * by GC_reclaim_small_nonempty_block. - * If report_if_found is TRUE, then process any block immediately, and - * simply report free objects; do not actually reclaim them. - */ -STATIC void GC_reclaim_block(struct hblk *hbp, word report_if_found) -{ - hdr * hhdr = HDR(hbp); - size_t sz = hhdr -> hb_sz; /* size of objects in current block */ - struct obj_kind * ok = &GC_obj_kinds[hhdr -> hb_obj_kind]; - struct hblk ** rlh; - - if( sz > MAXOBJBYTES ) { /* 1 big object */ - if( !mark_bit_from_hdr(hhdr, 0) ) { - if (report_if_found) { - GC_add_leaked((ptr_t)hbp); - } else { - size_t blocks; - -# ifdef ENABLE_DISCLAIM - if (EXPECT(hhdr->hb_flags & HAS_DISCLAIM, 0)) { - struct obj_kind *ok = &GC_obj_kinds[hhdr->hb_obj_kind]; - if ((*ok->ok_disclaim_proc)(hbp)) { - /* Not disclaimed => resurrect the object. */ - set_mark_bit_from_hdr(hhdr, 0); - goto in_use; - } - } -# endif - blocks = OBJ_SZ_TO_BLOCKS(sz); - if (blocks > 1) { - GC_large_allocd_bytes -= blocks * HBLKSIZE; - } - GC_bytes_found += sz; - GC_freehblk(hbp); - } - } else { -# ifdef ENABLE_DISCLAIM - in_use: -# endif - if (hhdr -> hb_descr != 0) { - GC_composite_in_use += sz; - } else { - GC_atomic_in_use += sz; - } - } - } else { - GC_bool empty = GC_block_empty(hhdr); -# ifdef PARALLEL_MARK - /* Count can be low or one too high because we sometimes */ - /* have to ignore decrements. Objects can also potentially */ - /* be repeatedly marked by each marker. */ - /* Here we assume two markers, but this is extremely */ - /* unlikely to fail spuriously with more. And if it does, it */ - /* should be looked at. */ - GC_ASSERT(hhdr -> hb_n_marks <= 2 * (HBLKSIZE/sz + 1) + 16); -# else - GC_ASSERT(sz * hhdr -> hb_n_marks <= HBLKSIZE); -# endif - if (report_if_found) { - GC_reclaim_small_nonempty_block(hbp, TRUE /* report_if_found */); - } else if (empty) { -# ifdef ENABLE_DISCLAIM - if ((hhdr -> hb_flags & HAS_DISCLAIM) != 0) { - GC_disclaim_and_reclaim_or_free_small_block(hbp); - } else -# endif - /* else */ { - GC_bytes_found += HBLKSIZE; - GC_freehblk(hbp); - } - } else if (GC_find_leak || !GC_block_nearly_full(hhdr)) { - /* group of smaller objects, enqueue the real work */ - rlh = &(ok -> ok_reclaim_list[BYTES_TO_GRANULES(sz)]); - hhdr -> hb_next = *rlh; - *rlh = hbp; - } /* else not worth salvaging. */ - /* We used to do the nearly_full check later, but we */ - /* already have the right cache context here. Also */ - /* doing it here avoids some silly lock contention in */ - /* GC_malloc_many. */ - - if (hhdr -> hb_descr != 0) { - GC_composite_in_use += sz * hhdr -> hb_n_marks; - } else { - GC_atomic_in_use += sz * hhdr -> hb_n_marks; - } - } -} - -#if !defined(NO_DEBUGGING) -/* Routines to gather and print heap block info */ -/* intended for debugging. Otherwise should be called */ -/* with lock. */ - -struct Print_stats -{ - size_t number_of_blocks; - size_t total_bytes; -}; - -#ifdef USE_MARK_BYTES - -/* Return the number of set mark bits in the given header. */ -/* Remains externally visible as used by GNU GCJ currently. */ -int GC_n_set_marks(hdr *hhdr) -{ - int result = 0; - int i; - size_t sz = hhdr -> hb_sz; - int offset = (int)MARK_BIT_OFFSET(sz); - int limit = (int)FINAL_MARK_BIT(sz); - - for (i = 0; i < limit; i += offset) { - result += hhdr -> hb_marks[i]; - } - GC_ASSERT(hhdr -> hb_marks[limit]); - return(result); -} - -#else - -/* Number of set bits in a word. Not performance critical. */ -static int set_bits(word n) -{ - word m = n; - int result = 0; - - while (m > 0) { - if (m & 1) result++; - m >>= 1; - } - return(result); -} - -int GC_n_set_marks(hdr *hhdr) -{ - int result = 0; - int i; - int n_mark_words; -# ifdef MARK_BIT_PER_OBJ - int n_objs = (int)HBLK_OBJS(hhdr -> hb_sz); - - if (0 == n_objs) n_objs = 1; - n_mark_words = divWORDSZ(n_objs + WORDSZ - 1); -# else /* MARK_BIT_PER_GRANULE */ - n_mark_words = MARK_BITS_SZ; -# endif - for (i = 0; i < n_mark_words - 1; i++) { - result += set_bits(hhdr -> hb_marks[i]); - } -# ifdef MARK_BIT_PER_OBJ - result += set_bits((hhdr -> hb_marks[n_mark_words - 1]) - << (n_mark_words * WORDSZ - n_objs)); -# else - result += set_bits(hhdr -> hb_marks[n_mark_words - 1]); -# endif - return(result - 1); -} - -#endif /* !USE_MARK_BYTES */ - -STATIC void GC_print_block_descr(struct hblk *h, - word /* struct PrintStats */ raw_ps) -{ - hdr * hhdr = HDR(h); - size_t bytes = hhdr -> hb_sz; - struct Print_stats *ps; - unsigned n_marks = GC_n_set_marks(hhdr); - - if (hhdr -> hb_n_marks != n_marks) { - GC_printf("(%u:%u,%u!=%u)\n", hhdr->hb_obj_kind, (unsigned)bytes, - (unsigned)hhdr->hb_n_marks, n_marks); - } else { - GC_printf("(%u:%u,%u)\n", hhdr->hb_obj_kind, - (unsigned)bytes, n_marks); - } - bytes += HBLKSIZE-1; - bytes &= ~(HBLKSIZE-1); - - ps = (struct Print_stats *)raw_ps; - ps->total_bytes += bytes; - ps->number_of_blocks++; -} - -void GC_print_block_list(void) -{ - struct Print_stats pstats; - - GC_printf("(kind(0=ptrfree,1=normal,2=unc.):size_in_bytes, #_marks_set)\n"); - pstats.number_of_blocks = 0; - pstats.total_bytes = 0; - GC_apply_to_all_blocks(GC_print_block_descr, (word)&pstats); - GC_printf("blocks= %lu, bytes= %lu\n", - (unsigned long)pstats.number_of_blocks, - (unsigned long)pstats.total_bytes); -} - -/* Currently for debugger use only: */ -void GC_print_free_list(int kind, size_t sz_in_granules) -{ - struct obj_kind * ok = &GC_obj_kinds[kind]; - ptr_t flh = ok -> ok_freelist[sz_in_granules]; - int n; - - for (n = 0; flh; n++) { - struct hblk *block = HBLKPTR(flh); - GC_printf("Free object in heap block %p [%d]: %p\n", - (void *)block, n, flh); - flh = obj_link(flh); - } -} - -#endif /* !NO_DEBUGGING */ - -/* - * Clear all obj_link pointers in the list of free objects *flp. - * Clear *flp. - * This must be done before dropping a list of free gcj-style objects, - * since may otherwise end up with dangling "descriptor" pointers. - * It may help for other pointer-containing objects. - */ -STATIC void GC_clear_fl_links(void **flp) -{ - void *next = *flp; - - while (0 != next) { - *flp = 0; - flp = &(obj_link(next)); - next = *flp; - } -} - -/* - * Perform GC_reclaim_block on the entire heap, after first clearing - * small object free lists (if we are not just looking for leaks). - */ -GC_INNER void GC_start_reclaim(GC_bool report_if_found) -{ - unsigned kind; - -# if defined(PARALLEL_MARK) - GC_ASSERT(0 == GC_fl_builder_count); -# endif - /* Reset in use counters. GC_reclaim_block recomputes them. */ - GC_composite_in_use = 0; - GC_atomic_in_use = 0; - /* Clear reclaim- and free-lists */ - for (kind = 0; kind < GC_n_kinds; kind++) { - void **fop; - void **lim; - struct hblk ** rlist = GC_obj_kinds[kind].ok_reclaim_list; - GC_bool should_clobber = (GC_obj_kinds[kind].ok_descriptor != 0); - - if (rlist == 0) continue; /* This kind not used. */ - if (!report_if_found) { - lim = &(GC_obj_kinds[kind].ok_freelist[MAXOBJGRANULES+1]); - for (fop = GC_obj_kinds[kind].ok_freelist; - (word)fop < (word)lim; fop++) { - if (*fop != 0) { - if (should_clobber) { - GC_clear_fl_links(fop); - } else { - *fop = 0; - } - } - } - } /* otherwise free list objects are marked, */ - /* and its safe to leave them */ - BZERO(rlist, (MAXOBJGRANULES + 1) * sizeof(void *)); - } - - - /* Go through all heap blocks (in hblklist) and reclaim unmarked objects */ - /* or enqueue the block for later processing. */ - GC_apply_to_all_blocks(GC_reclaim_block, (word)report_if_found); - -# ifdef EAGER_SWEEP - /* This is a very stupid thing to do. We make it possible anyway, */ - /* so that you can convince yourself that it really is very stupid. */ - GC_reclaim_all((GC_stop_func)0, FALSE); -# elif defined(ENABLE_DISCLAIM) - /* However, make sure to clear reclaimable objects of kinds with */ - /* unconditional marking enabled before we do any significant */ - /* marking work. */ - GC_reclaim_unconditionally_marked(); -# endif -# if defined(PARALLEL_MARK) - GC_ASSERT(0 == GC_fl_builder_count); -# endif - -} - -/* - * Sweep blocks of the indicated object size and kind until either the - * appropriate free list is nonempty, or there are no more blocks to - * sweep. - */ -GC_INNER void GC_continue_reclaim(size_t sz /* granules */, int kind) -{ - hdr * hhdr; - struct hblk * hbp; - struct obj_kind * ok = &(GC_obj_kinds[kind]); - struct hblk ** rlh = ok -> ok_reclaim_list; - void **flh = &(ok -> ok_freelist[sz]); - - if (rlh == 0) return; /* No blocks of this kind. */ - rlh += sz; - while ((hbp = *rlh) != 0) { - hhdr = HDR(hbp); - *rlh = hhdr -> hb_next; - GC_reclaim_small_nonempty_block(hbp, FALSE); - if (*flh != 0) break; - } -} - -/* - * Reclaim all small blocks waiting to be reclaimed. - * Abort and return FALSE when/if (*stop_func)() returns TRUE. - * If this returns TRUE, then it's safe to restart the world - * with incorrectly cleared mark bits. - * If ignore_old is TRUE, then reclaim only blocks that have been - * recently reclaimed, and discard the rest. - * Stop_func may be 0. - */ -GC_INNER GC_bool GC_reclaim_all(GC_stop_func stop_func, GC_bool ignore_old) -{ - word sz; - unsigned kind; - hdr * hhdr; - struct hblk * hbp; - struct obj_kind * ok; - struct hblk ** rlp; - struct hblk ** rlh; -# ifndef SMALL_CONFIG - CLOCK_TYPE start_time = 0; /* initialized to prevent warning. */ - CLOCK_TYPE done_time; - - if (GC_print_stats == VERBOSE) - GET_TIME(start_time); -# endif - - for (kind = 0; kind < GC_n_kinds; kind++) { - ok = &(GC_obj_kinds[kind]); - rlp = ok -> ok_reclaim_list; - if (rlp == 0) continue; - for (sz = 1; sz <= MAXOBJGRANULES; sz++) { - rlh = rlp + sz; - while ((hbp = *rlh) != 0) { - if (stop_func != (GC_stop_func)0 && (*stop_func)()) { - return(FALSE); - } - hhdr = HDR(hbp); - *rlh = hhdr -> hb_next; - if (!ignore_old || hhdr -> hb_last_reclaimed == GC_gc_no - 1) { - /* It's likely we'll need it this time, too */ - /* It's been touched recently, so this */ - /* shouldn't trigger paging. */ - GC_reclaim_small_nonempty_block(hbp, FALSE); - } - } - } - } -# ifndef SMALL_CONFIG - if (GC_print_stats == VERBOSE) { - GET_TIME(done_time); - GC_verbose_log_printf("Disposing of reclaim lists took %lu msecs\n", - MS_TIME_DIFF(done_time,start_time)); - } -# endif - return(TRUE); -} - -#if !defined(EAGER_SWEEP) && defined(ENABLE_DISCLAIM) -/* We do an eager sweep on heap blocks where unconditional marking has */ -/* been enabled, so that any reclaimable objects have been reclaimed */ -/* before we start marking. This is a simplified GC_reclaim_all */ -/* restricted to kinds where ok_mark_unconditionally is true. */ - STATIC void GC_reclaim_unconditionally_marked(void) - { - word sz; - unsigned kind; - hdr * hhdr; - struct hblk * hbp; - struct obj_kind * ok; - struct hblk ** rlp; - struct hblk ** rlh; - - for (kind = 0; kind < GC_n_kinds; kind++) { - ok = &(GC_obj_kinds[kind]); - if (!ok->ok_mark_unconditionally) - continue; - rlp = ok->ok_reclaim_list; - if (rlp == 0) - continue; - for (sz = 1; sz <= MAXOBJGRANULES; sz++) { - rlh = rlp + sz; - while ((hbp = *rlh) != 0) { - hhdr = HDR(hbp); - *rlh = hhdr->hb_next; - GC_reclaim_small_nonempty_block(hbp, FALSE); - } - } - } - } -#endif /* !EAGER_SWEEP && ENABLE_DISCLAIM */ diff -Nru ecl-16.1.2/src/bdwgc/SMakefile.amiga ecl-16.1.3+ds/src/bdwgc/SMakefile.amiga --- ecl-16.1.2/src/bdwgc/SMakefile.amiga 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/SMakefile.amiga 1970-01-01 00:00:00.000000000 +0000 @@ -1,178 +0,0 @@ - -# Rewritten smakefile for amiga / sas/c. -Kjetil M. -# Dont use the cord-package if you define parm=both or parm=reg. - - -#----------------TOOLS-------------------------------- -CC=sc -LINKER=slink -LIBER=oml - -#----------------CPU OPTIONS-------------------------- - -CPU=68060 - -#----------------FPU OPTIONS-------------------------- - -MATH=8 -MATHLIB=LIB:scm881.lib - -#----------------COMPILER OPTIONS--------------------- - -IGNORE= IGNORE=85 IGNORE=154 IGNORE=161 IGNORE=100 - -OPTIMIZE=optimize optimizetime optglobal optimizerdepth=100 optimizerpeephole optloop OPTSCHED optimizerinlocal optimizerrecurdepth=100 -# optimizerinline optimizercomplexity=100 - -OPT= $(OPTIMIZE) CPU=$(CPU) math=$(MATH) NOSTACKCHECK VERBOSE \ -MAPHUNK NOVERSION NOICONS nodebug \ -parm=reg \ -DEFINE __USE_SYSBASE - - -SOPT= $(OPT) $(IGNORE) \ -DEFINE AMIGA_SKIP_SEG \ -DEFINE ATOMIC_UNCOLLECTABLE \ -DEFINE GC_AMIGA_FASTALLOC \ -DEFINE GC_AMIGA_RETRY \ -DEFINE GC_AMIGA_PRINTSTATS \ -DEFINE GC_AMIGA_GC - - -#DEFINE ALL_INTERIOR_POINTERS \ - - -SCOPT= $(SOPT) define GC_AMIGA_MAKINGLIB - -CSCOPT= $(OPT) DEFINE AMIGA IGNORE=100 IGNORE=161 - -#------------------LINKING---------------------------- - - -all: gctest setjmp_t cord/cordtest - -clean: - delete *.lib gctest setjmp_t *.o *.lnk cord/*.o cord/*.lib cord/*.lnk cord/cordtest - smake - -test: setjmp_t gctest cord/cordtest - setjmp_t - gctest - cord/cordtest - -gctest: gc$(CPU).lib GCAmigaOS$(CPU).lib test.o - $(LINKER) LIB:c.o test.o TO gctest LIB gc$(CPU).lib LIB:sc.lib $(MATHLIB) - -setjmp_t: setjmp_t.o gc.h - $(LINKER) LIB:c.o setjmp_t.o to setjmp_t lib LIB:sc.lib - -cord/cordtest: cord/cordtest.o cord/cord$(CPU).lib gc$(CPU).lib - slink LIB:c.o cord/cordtest.o LIB $(MATHLIB) gc$(CPU).lib cord/cord$(CPU).lib LIB:sc.lib TO cord/cordtest - - -#------------------LIBBING---------------------------- - -OBJS= alloc.o reclaim.o allchblk.o misc.o mach_dep.o os_dep.o mark_rts.o headers.o mark.o obj_map.o blacklst.o finalize.o new_hblk.o real_malloc.o dyn_load.o dbg_mlc.o malloc.o stubborn.o checksums.o typd_mlc.o ptr_chck.o mallocx.o fnlz_mlc.o - -gc$(CPU).lib: $(OBJS) - $(LIBER) gc$(CPU).lib r $(OBJS) - - -COBJS = cord/cordbscs.o cord/cordprnt.o cord/cordxtra.o - -cord/cord$(CPU).lib: $(COBJS) - oml cord/cord$(CPU).lib r $(COBJS) - -#------------------COMPILING-------------------------- - -INC= gc_private.h gc_hdrs.h gc.h gcconfig.h - -alloc.o : alloc.c $(INC) - $(CC) alloc.c $(SCOPT) ignore=7 - -reclaim.o : reclaim.c $(INC) - $(CC) reclaim.c $(SCOPT) - -allchblk.o : allchblk.c $(INC) - $(CC) allchblk.c $(SCOPT) - -misc.o : misc.c $(INC) - $(CC) misc.c $(SCOPT) - -os_dep.o : os_dep.c $(INC) extra/AmigaOS.c - $(CC) os_dep.c $(SCOPT) - -mark_rts.o : mark_rts.c $(INC) - $(CC) mark_rts.c $(SCOPT) - -headers.o : headers.c $(INC) - $(CC) headers.c $(SCOPT) - -mark.o : mark.c $(INC) - $(CC) mark.c $(SCOPT) - -obj_map.o : obj_map.c $(INC) - $(CC) obj_map.c $(SCOPT) - -blacklst.o : blacklst.c $(INC) - $(CC) blacklst.c $(SCOPT) - -finalize.o : finalize.c $(INC) - $(CC) finalize.c $(SCOPT) noopt -# Could sas/c still have problems with this one? Gctest sometimes fails to finalize all. - -new_hblk.o : new_hblk.c $(INC) - $(CC) new_hblk.c $(SCOPT) - -real_malloc.o : real_malloc.c $(INC) - $(CC) real_malloc.c $(SCOPT) - -dyn_load.o : dyn_load.c $(INC) - $(CC) dyn_load.c $(SCOPT) - -dbg_mlc.o : dbg_mlc.c $(INC) - $(CC) dbg_mlc.c $(SCOPT) - -fnlz_mlc.o : fnlz_mlc.c $(INC) - $(CC) fnlz_mlc.c $(SCOPT) - -malloc.o : malloc.c $(INC) - $(CC) malloc.c $(SCOPT) - -mallocx.o : mallocx.c $(INC) - $(CC) mallocx.c $(SCOPT) - -stubborn.o : stubborn.c $(INC) - $(CC) stubborn.c $(SCOPT) - -checksums.o : checksums.c $(INC) - $(CC) checksums.c $(SCOPT) - -typd_mlc.o: typd_mlc.c $(INC) - $(CC) typd_mlc.c $(SCOPT) - -mach_dep.o : mach_dep.c $(INC) - $(CC) mach_dep.c $(SCOPT) - -ptr_chck.o: ptr_chck.c $(INC) - $(CC) ptr_chck.c $(SCOPT) - -test.o : test.c $(INC) - $(CC) test.c $(SOPT) - -setjmp_t: tools/setjmp_t.c gc.h - $(CC) tools/setjmp_t.c $(SOPT) - -# cords: - -cord/cordbscs.o: cord/cordbscs.c - sc cord/cordbscs.c $(CSCOPT) - -cord/cordprnt.o: cord/cordprnt.c - sc cord/cordprnt.c $(CSCOPT) - -cord/cordxtra.o: cord/cordxtra.c - sc cord/cordxtra.c $(CSCOPT) - -cord/cordtest.o: cord/tests/cordtest.c - sc cord/tests/cordtest.c $(CSCOPT) diff -Nru ecl-16.1.2/src/bdwgc/sparc_mach_dep.S ecl-16.1.3+ds/src/bdwgc/sparc_mach_dep.S --- ecl-16.1.2/src/bdwgc/sparc_mach_dep.S 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/sparc_mach_dep.S 1970-01-01 00:00:00.000000000 +0000 @@ -1,61 +0,0 @@ -! SPARCompiler 3.0 and later apparently no longer handles -! asm outside functions. So we need a separate .s file -! This is only set up for SunOS 5, not SunOS 4. -! Assumes this is called before the stack contents are -! examined. - - .seg "text" - .globl GC_save_regs_in_stack -GC_save_regs_in_stack: -#if defined(__arch64__) || defined(__sparcv9) - save %sp,-128,%sp - flushw - ret - restore %sp,2047+128,%o0 -#else /* 32 bit SPARC */ - ta 0x3 ! ST_FLUSH_WINDOWS - mov %sp,%o0 - retl - nop -#endif /* 32 bit SPARC */ -.GC_save_regs_in_stack_end: - .size GC_save_regs_in_stack,.GC_save_regs_in_stack_end-GC_save_regs_in_stack - -! GC_clear_stack_inner(arg, limit) clears stack area up to limit and -! returns arg. Stack clearing is crucial on SPARC, so we supply -! an assembly version that s more careful. Assumes limit is hotter -! than sp, and limit is 8 byte aligned. - .globl GC_clear_stack_inner -GC_clear_stack_inner: -#if defined(__arch64__) || defined(__sparcv9) - mov %sp,%o2 ! Save sp - add %sp,2047-8,%o3 ! p = sp+bias-8 - add %o1,-2047-192,%sp ! Move sp out of the way, - ! so that traps still work. - ! Includes some extra words - ! so we can be sloppy below. -loop: - stx %g0,[%o3] ! *(long *)p = 0 - cmp %o3,%o1 - bgu,pt %xcc, loop ! if (p > limit) goto loop - add %o3,-8,%o3 ! p -= 8 (delay slot) - retl - mov %o2,%sp ! Restore sp., delay slot -#else /* 32 bit SPARC */ - mov %sp,%o2 ! Save sp - add %sp,-8,%o3 ! p = sp-8 - clr %g1 ! [g0,g1] = 0 - add %o1,-0x60,%sp ! Move sp out of the way, - ! so that traps still work. - ! Includes some extra words - ! so we can be sloppy below. -loop: - std %g0,[%o3] ! *(long long *)p = 0 - cmp %o3,%o1 - bgu loop ! if (p > limit) goto loop - add %o3,-8,%o3 ! p -= 8 (delay slot) - retl - mov %o2,%sp ! Restore sp., delay slot -#endif /* 32 bit SPARC */ -.GC_clear_stack_inner_end: - .size GC_clear_stack_inner,.GC_clear_stack_inner_end-GC_clear_stack_inner diff -Nru ecl-16.1.2/src/bdwgc/sparc_netbsd_mach_dep.s ecl-16.1.3+ds/src/bdwgc/sparc_netbsd_mach_dep.s --- ecl-16.1.2/src/bdwgc/sparc_netbsd_mach_dep.s 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/sparc_netbsd_mach_dep.s 1970-01-01 00:00:00.000000000 +0000 @@ -1,34 +0,0 @@ -! SPARCompiler 3.0 and later apparently no longer handles -! asm outside functions. So we need a separate .s file -! This is only set up for SunOS 4. -! Assumes this is called before the stack contents are -! examined. - -#include "machine/asm.h" - - .seg "text" - .globl _C_LABEL(GC_save_regs_in_stack) - .globl _C_LABEL(GC_push_regs) -_C_LABEL(GC_save_regs_in_stack): -_C_LABEL(GC_push_regs): - ta 0x3 ! ST_FLUSH_WINDOWS - mov %sp,%o0 - retl - nop - - .globl _C_LABEL(GC_clear_stack_inner) -_C_LABEL(GC_clear_stack_inner): - mov %sp,%o2 ! Save sp - add %sp,-8,%o3 ! p = sp-8 - clr %g1 ! [g0,g1] = 0 - add %o1,-0x60,%sp ! Move sp out of the way, - ! so that traps still work. - ! Includes some extra words - ! so we can be sloppy below. -loop: - std %g0,[%o3] ! *(long long *)p = 0 - cmp %o3,%o1 - bgu loop ! if (p > limit) goto loop - add %o3,-8,%o3 ! p -= 8 (delay slot) - retl - mov %o2,%sp ! Restore sp., delay slot diff -Nru ecl-16.1.2/src/bdwgc/sparc_sunos4_mach_dep.s ecl-16.1.3+ds/src/bdwgc/sparc_sunos4_mach_dep.s --- ecl-16.1.2/src/bdwgc/sparc_sunos4_mach_dep.s 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/sparc_sunos4_mach_dep.s 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -! SPARCompiler 3.0 and later apparently no longer handles -! asm outside functions. So we need a separate .s file -! This is only set up for SunOS 4. -! Assumes this is called before the stack contents are -! examined. - - .seg "text" - .globl _GC_save_regs_in_stack - .globl _GC_push_regs -_GC_save_regs_in_stack: -_GC_push_regs: - ta 0x3 ! ST_FLUSH_WINDOWS - mov %sp,%o0 - retl - nop - - .globl _GC_clear_stack_inner -_GC_clear_stack_inner: - mov %sp,%o2 ! Save sp - add %sp,-8,%o3 ! p = sp-8 - clr %g1 ! [g0,g1] = 0 - add %o1,-0x60,%sp ! Move sp out of the way, - ! so that traps still work. - ! Includes some extra words - ! so we can be sloppy below. -loop: - std %g0,[%o3] ! *(long long *)p = 0 - cmp %o3,%o1 - bgu loop ! if (p > limit) goto loop - add %o3,-8,%o3 ! p -= 8 (delay slot) - retl - mov %o2,%sp ! Restore sp., delay slot diff -Nru ecl-16.1.2/src/bdwgc/specific.c ecl-16.1.3+ds/src/bdwgc/specific.c --- ecl-16.1.2/src/bdwgc/specific.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/specific.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,167 +0,0 @@ -/* - * Copyright (c) 2000 by Hewlett-Packard Company. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#include "private/thread_local_alloc.h" - /* To determine type of tsd impl. */ - /* Includes private/specific.h */ - /* if needed. */ - -#if defined(USE_CUSTOM_SPECIFIC) - -static const tse invalid_tse = {INVALID_QTID, 0, 0, INVALID_THREADID}; - /* A thread-specific data entry which will never */ - /* appear valid to a reader. Used to fill in empty */ - /* cache entries to avoid a check for 0. */ - -GC_INNER int GC_key_create_inner(tsd ** key_ptr) -{ - int i; - int ret; - tsd * result = (tsd *)MALLOC_CLEAR(sizeof(tsd)); - - /* A quick alignment check, since we need atomic stores */ - GC_ASSERT((word)(&invalid_tse.next) % sizeof(tse *) == 0); - if (0 == result) return ENOMEM; - ret = pthread_mutex_init(&result->lock, NULL); - if (ret != 0) return ret; - for (i = 0; i < TS_CACHE_SIZE; ++i) { - result -> cache[i] = (/* no const */ tse *)&invalid_tse; - } -# ifdef GC_ASSERTIONS - for (i = 0; i < TS_HASH_SIZE; ++i) { - GC_ASSERT(result -> hash[i].p == 0); - } -# endif - *key_ptr = result; - return 0; -} - -/* Called with the lock held. */ -GC_INNER int GC_setspecific(tsd * key, void * value) -{ - pthread_t self = pthread_self(); - int hash_val = HASH(self); - volatile tse * entry; - - GC_ASSERT(self != INVALID_THREADID); - GC_dont_gc++; /* disable GC */ - entry = (volatile tse *)MALLOC_CLEAR(sizeof(tse)); - GC_dont_gc--; - if (0 == entry) return ENOMEM; - - pthread_mutex_lock(&(key -> lock)); - /* Could easily check for an existing entry here. */ - entry -> next = key->hash[hash_val].p; - entry -> thread = self; - entry -> value = value; - GC_ASSERT(entry -> qtid == INVALID_QTID); - /* There can only be one writer at a time, but this needs to be */ - /* atomic with respect to concurrent readers. */ - AO_store_release(&key->hash[hash_val].ao, (AO_t)entry); - pthread_mutex_unlock(&(key -> lock)); - return 0; -} - -/* Remove thread-specific data for this thread. Should be called on */ -/* thread exit. */ -GC_INNER void GC_remove_specific(tsd * key) -{ - pthread_t self = pthread_self(); - unsigned hash_val = HASH(self); - tse *entry; - tse **link = &key->hash[hash_val].p; - - pthread_mutex_lock(&(key -> lock)); - entry = *link; - while (entry != NULL && entry -> thread != self) { - link = &(entry -> next); - entry = *link; - } - /* Invalidate qtid field, since qtids may be reused, and a later */ - /* cache lookup could otherwise find this entry. */ - if (entry != NULL) { - entry -> qtid = INVALID_QTID; - *link = entry -> next; - /* Atomic! concurrent accesses still work. */ - /* They must, since readers don't lock. */ - /* We shouldn't need a volatile access here, */ - /* since both this and the preceding write */ - /* should become visible no later than */ - /* the pthread_mutex_unlock() call. */ - } - /* If we wanted to deallocate the entry, we'd first have to clear */ - /* any cache entries pointing to it. That probably requires */ - /* additional synchronization, since we can't prevent a concurrent */ - /* cache lookup, which should still be examining deallocated memory.*/ - /* This can only happen if the concurrent access is from another */ - /* thread, and hence has missed the cache, but still... */ - - /* With GC, we're done, since the pointers from the cache will */ - /* be overwritten, all local pointers to the entries will be */ - /* dropped, and the entry will then be reclaimed. */ - pthread_mutex_unlock(&(key -> lock)); -} - -/* Note that even the slow path doesn't lock. */ -GC_INNER void * GC_slow_getspecific(tsd * key, word qtid, - tse * volatile * cache_ptr) -{ - pthread_t self = pthread_self(); - unsigned hash_val = HASH(self); - tse *entry = key->hash[hash_val].p; - - GC_ASSERT(qtid != INVALID_QTID); - while (entry != NULL && entry -> thread != self) { - entry = entry -> next; - } - if (entry == NULL) return NULL; - /* Set cache_entry. */ - entry -> qtid = (AO_t)qtid; - /* It's safe to do this asynchronously. Either value */ - /* is safe, though may produce spurious misses. */ - /* We're replacing one qtid with another one for the */ - /* same thread. */ - *cache_ptr = entry; - /* Again this is safe since pointer assignments are */ - /* presumed atomic, and either pointer is valid. */ - return entry -> value; -} - -#ifdef GC_ASSERTIONS - /* Check that that all elements of the data structure associated */ - /* with key are marked. */ - void GC_check_tsd_marks(tsd *key) - { - int i; - tse *p; - - if (!GC_is_marked(GC_base(key))) { - ABORT("Unmarked thread-specific-data table"); - } - for (i = 0; i < TS_HASH_SIZE; ++i) { - for (p = key->hash[i].p; p != 0; p = p -> next) { - if (!GC_is_marked(GC_base(p))) { - ABORT_ARG1("Unmarked thread-specific-data entry", " at %p", p); - } - } - } - for (i = 0; i < TS_CACHE_SIZE; ++i) { - p = key -> cache[i]; - if (p != &invalid_tse && !GC_is_marked(GC_base(p))) { - ABORT_ARG1("Unmarked cached thread-specific-data entry", " at %p", p); - } - } - } -#endif /* GC_ASSERTIONS */ - -#endif /* USE_CUSTOM_SPECIFIC */ diff -Nru ecl-16.1.2/src/bdwgc/stubborn.c ecl-16.1.3+ds/src/bdwgc/stubborn.c --- ecl-16.1.2/src/bdwgc/stubborn.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/stubborn.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,56 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#include "private/gc_priv.h" - -#if defined(MANUAL_VDB) - - /* Stubborn object (hard to change, nearly immutable) allocation. */ - /* This interface is deprecated. We mostly emulate it using */ - /* MANUAL_VDB. But that imposes the additional constraint that */ - /* written, but not yet GC_dirty()ed objects must be referenced */ - /* by a stack. */ - - void GC_dirty(ptr_t p); - - GC_API GC_ATTR_MALLOC void * GC_CALL GC_malloc_stubborn(size_t lb) - { - return(GC_malloc(lb)); - } - - GC_API void GC_CALL GC_end_stubborn_change(const void *p) - { - GC_dirty((ptr_t)p); - } - - GC_API void GC_CALL GC_change_stubborn(const void *p GC_ATTR_UNUSED) - { - } - -#else /* !MANUAL_VDB */ - - GC_API GC_ATTR_MALLOC void * GC_CALL GC_malloc_stubborn(size_t lb) - { - return(GC_malloc(lb)); - } - - GC_API void GC_CALL GC_end_stubborn_change(const void *p GC_ATTR_UNUSED) - { - } - - GC_API void GC_CALL GC_change_stubborn(const void *p GC_ATTR_UNUSED) - { - } - -#endif /* !MANUAL_VDB */ diff -Nru ecl-16.1.2/src/bdwgc/test-driver ecl-16.1.3+ds/src/bdwgc/test-driver --- ecl-16.1.2/src/bdwgc/test-driver 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/test-driver 1970-01-01 00:00:00.000000000 +0000 @@ -1,148 +0,0 @@ -#! /bin/sh -# test-driver - basic testsuite driver script. - -scriptversion=2013-07-13.22; # UTC - -# Copyright (C) 2011-2014 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, see . - -# 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. - -# This file is maintained in Automake, please report -# bugs to or send patches to -# . - -# Make unconditional expansion of undefined variables an error. This -# helps a lot in preventing typo-related bugs. -set -u - -usage_error () -{ - echo "$0: $*" >&2 - print_usage >&2 - exit 2 -} - -print_usage () -{ - cat <$log_file 2>&1 -estatus=$? - -if test $enable_hard_errors = no && test $estatus -eq 99; then - tweaked_estatus=1 -else - tweaked_estatus=$estatus -fi - -case $tweaked_estatus:$expect_failure in - 0:yes) col=$red res=XPASS recheck=yes gcopy=yes;; - 0:*) col=$grn res=PASS recheck=no gcopy=no;; - 77:*) col=$blu res=SKIP recheck=no gcopy=yes;; - 99:*) col=$mgn res=ERROR recheck=yes gcopy=yes;; - *:yes) col=$lgn res=XFAIL recheck=no gcopy=yes;; - *:*) col=$red res=FAIL recheck=yes gcopy=yes;; -esac - -# Report the test outcome and exit status in the logs, so that one can -# know whether the test passed or failed simply by looking at the '.log' -# file, without the need of also peaking into the corresponding '.trs' -# file (automake bug#11814). -echo "$res $test_name (exit status: $estatus)" >>$log_file - -# Report outcome to console. -echo "${col}${res}${std}: $test_name" - -# Register the test result, and other relevant metadata. -echo ":test-result: $res" > $trs_file -echo ":global-test-result: $res" >> $trs_file -echo ":recheck: $recheck" >> $trs_file -echo ":copy-in-global-log: $gcopy" >> $trs_file - -# Local Variables: -# mode: shell-script -# sh-indentation: 2 -# eval: (add-hook 'write-file-hooks 'time-stamp) -# time-stamp-start: "scriptversion=" -# time-stamp-format: "%:y-%02m-%02d.%02H" -# time-stamp-time-zone: "UTC" -# time-stamp-end: "; # UTC" -# End: diff -Nru ecl-16.1.2/src/bdwgc/tests/CMakeLists.txt ecl-16.1.3+ds/src/bdwgc/tests/CMakeLists.txt --- ecl-16.1.2/src/bdwgc/tests/CMakeLists.txt 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/tests/CMakeLists.txt 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ -# -# Copyright (c) 1994 by Xerox Corporation. All rights reserved. -# Copyright (c) 1996 by Silicon Graphics. All rights reserved. -# Copyright (c) 1998 by Fergus Henderson. All rights reserved. -# Copyright (c) 2000-2010 by Hewlett-Packard Company. All rights reserved. -## -# THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED -# OR IMPLIED. ANY USE IS AT YOUR OWN RISK. -## -# Permission is hereby granted to use or copy this program -# for any purpose, provided the above notices are retained on all copies. -# Permission to modify the code and to distribute modified code is granted, -# provided the above notices are retained, and a notice that the code was -# modified is included with the above copyright notice. -## - -ADD_DEFINITIONS(-DGC_NOT_DLL) -ADD_EXECUTABLE(gctest WIN32 test.c) -TARGET_LINK_LIBRARIES(gctest gc-lib) diff -Nru ecl-16.1.2/src/bdwgc/tests/disclaim_bench.c ecl-16.1.3+ds/src/bdwgc/tests/disclaim_bench.c --- ecl-16.1.2/src/bdwgc/tests/disclaim_bench.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/tests/disclaim_bench.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,143 +0,0 @@ -/* - * Copyright (c) 2011 by Hewlett-Packard Company. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -#include -#include -#include - -#include "private/gc_priv.h" - -#include "gc_disclaim.h" - -#define my_assert(e) \ - if (!(e)) { \ - fprintf(stderr, "Assertion failure, line %d: " #e "\n", __LINE__); \ - exit(-1); \ - } - -static int free_count = 0; - -struct testobj_s { - struct testobj_s *keep_link; - int i; -}; - -typedef struct testobj_s *testobj_t; - -void GC_CALLBACK testobj_finalize(void *obj, void *carg) -{ - ++*(int *)carg; - my_assert(((testobj_t)obj)->i == 109); - ((testobj_t)obj)->i = 110; -} - -static const struct GC_finalizer_closure fclos = { - testobj_finalize, - &free_count -}; - -testobj_t testobj_new(int model) -{ - testobj_t obj; - switch (model) { - case 0: - obj = GC_MALLOC(sizeof(struct testobj_s)); - if (obj != NULL) - GC_register_finalizer_no_order(obj, testobj_finalize, - &free_count, NULL, NULL); - break; - case 1: - obj = GC_finalized_malloc(sizeof(struct testobj_s), &fclos); - break; - case 2: - obj = GC_MALLOC(sizeof(struct testobj_s)); - break; - default: - exit(-1); - } - if (obj == NULL) { - fprintf(stderr, "Out of memory!\n"); - exit(3); - } - my_assert(obj->i == 0 && obj->keep_link == NULL); - obj->i = 109; - return obj; -} - -#define ALLOC_CNT (4*1024*1024) -#define KEEP_CNT (32*1024) - -static char const *model_str[3] = { - "regular finalization", - "finalize on reclaim", - "no finalization" -}; - -int main(int argc, char **argv) -{ - int i; - int model, model_min, model_max; - testobj_t *keep_arr; - - GC_INIT(); - GC_init_finalized_malloc(); - - keep_arr = GC_MALLOC(sizeof(void *)*KEEP_CNT); - - if (argc == 2 && strcmp(argv[1], "--help") == 0) { - fprintf(stderr, - "Usage: %s [FINALIZATION_MODEL]\n" - "\t0 -- original finalization\n" - "\t1 -- finalization on reclaim\n" - "\t2 -- no finalization\n", argv[0]); - return 1; - } - if (argc == 2) { - model_min = model_max = atoi(argv[1]); - if (model_min < 0 || model_max > 2) - exit(2); - } - else { - model_min = 0; - model_max = 2; - } - - printf("\t\t\tfin. ratio time/s time/fin.\n"); - for (model = model_min; model <= model_max; ++model) { - double t = 0.0; - free_count = 0; - -# ifdef CLOCK_TYPE - CLOCK_TYPE tI, tF; - GET_TIME(tI); -# endif - for (i = 0; i < ALLOC_CNT; ++i) { - int k = rand() % KEEP_CNT; - keep_arr[k] = testobj_new(model); - } - GC_gcollect(); -# ifdef CLOCK_TYPE - GET_TIME(tF); - t = MS_TIME_DIFF(tF, tI)*1e-3; -# endif - - if (model < 2) - printf("%20s: %12.4lf %12lg %12lg\n", model_str[model], - free_count/(double)ALLOC_CNT, t, t/free_count); - else - printf("%20s: %12.4lf %12lg %12s\n", - model_str[model], 0.0, t, "N/A"); - } - return 0; -} diff -Nru ecl-16.1.2/src/bdwgc/tests/disclaim_test.c ecl-16.1.3+ds/src/bdwgc/tests/disclaim_test.c --- ecl-16.1.2/src/bdwgc/tests/disclaim_test.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/tests/disclaim_test.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,233 +0,0 @@ -/* - * Copyright (c) 2011 by Hewlett-Packard Company. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -/* Test that objects reachable from an object allocated with */ -/* GC_malloc_with_finalizer is not reclaimable before the finalizer */ -/* is called. */ - -#include -#include -#include - -#ifdef HAVE_CONFIG_H - /* For GC_[P]THREADS */ -# include "config.h" -#endif - -#include "gc_disclaim.h" - -#define my_assert(e) \ - if (!(e)) { \ - fflush(stdout); \ - fprintf(stderr, "Assertion failure, line %d: " #e "\n", __LINE__); \ - exit(-1); \ - } - -int memeq(void *s, int c, size_t len) -{ - while (len--) { - if (*(char *)s != c) - return 0; - s = (char *)s + 1; - } - return 1; -} - -void GC_CALLBACK misc_sizes_dct(void *obj, void *cd) -{ - unsigned log_size = *(unsigned char *)obj; - size_t size; - - my_assert(log_size < sizeof(size_t) * 8); - my_assert(cd == NULL); - size = (size_t)1 << log_size; - my_assert(memeq((char *)obj + 1, 0x56, size - 1)); -} - -void test_misc_sizes(void) -{ - static const struct GC_finalizer_closure fc = { misc_sizes_dct, NULL }; - int i; - for (i = 1; i <= 20; ++i) { /* Up to 1 MiB. */ - void *p = GC_finalized_malloc((size_t)1 << i, &fc); - if (p == NULL) { - fprintf(stderr, "Out of memory!\n"); - exit(3); - } - my_assert(memeq(p, 0, (size_t)1 << i)); - memset(p, 0x56, (size_t)1 << i); - *(unsigned char *)p = i; - } -} - -typedef struct pair_s *pair_t; - -struct pair_s { - char magic[16]; - int checksum; - pair_t car; - pair_t cdr; -}; - -static const char *pair_magic = "PAIR_MAGIC_BYTES"; - -int is_pair(pair_t p) -{ - return memcmp(p->magic, pair_magic, sizeof(p->magic)) == 0; -} - -void GC_CALLBACK pair_dct(void *obj, void *cd) -{ - pair_t p = obj; - int checksum; - - /* Check that obj and its car and cdr are not trashed. */ -# ifdef DEBUG_DISCLAIM_DESTRUCT - printf("Destruct %p = (%p, %p)\n", - (void *)p, (void *)p->car, (void *)p->cdr); -# endif - my_assert(GC_base(obj)); - my_assert(is_pair(p)); - my_assert(!p->car || is_pair(p->car)); - my_assert(!p->cdr || is_pair(p->cdr)); - checksum = 782; - if (p->car) checksum += p->car->checksum; - if (p->cdr) checksum += p->cdr->checksum; - my_assert(p->checksum == checksum); - - /* Invalidate it. */ - memset(p->magic, '*', sizeof(p->magic)); - p->checksum = 0; - p->car = cd; - p->cdr = NULL; -} - -pair_t -pair_new(pair_t car, pair_t cdr) -{ - pair_t p; - static const struct GC_finalizer_closure fc = { pair_dct, NULL }; - - p = GC_finalized_malloc(sizeof(struct pair_s), &fc); - my_assert(!is_pair(p)); - if (p == NULL) { - fprintf(stderr, "Out of memory!\n"); - exit(3); - } - my_assert(memeq(p, 0, sizeof(struct pair_s))); - memcpy(p->magic, pair_magic, sizeof(p->magic)); - p->checksum = 782 + (car? car->checksum : 0) + (cdr? cdr->checksum : 0); - p->car = car; - p->cdr = cdr; -# ifdef DEBUG_DISCLAIM_DESTRUCT - printf("Construct %p = (%p, %p)\n", - (void *)p, (void *)p->car, (void *)p->cdr); -# endif - return p; -} - -void -pair_check_rec(pair_t p) -{ - while (p) { - int checksum = 782; - if (p->car) checksum += p->car->checksum; - if (p->cdr) checksum += p->cdr->checksum; - my_assert(p->checksum == checksum); - if (rand() % 2) - p = p->car; - else - p = p->cdr; - } -} - -#ifdef GC_PTHREADS -# define THREAD_CNT 6 -# include -#else -# define THREAD_CNT 1 -#endif - -#define POP_SIZE 1000 -#if THREAD_CNT > 1 -# define MUTATE_CNT 2000000/THREAD_CNT -#else -# define MUTATE_CNT 10000000 -#endif -#define GROW_LIMIT 10000000 - -void *test(void *data) -{ - int i; - pair_t pop[POP_SIZE]; - memset(pop, 0, sizeof(pop)); - for (i = 0; i < MUTATE_CNT; ++i) { - int t = rand() % POP_SIZE; - switch (rand() % (i > GROW_LIMIT? 5 : 3)) { - case 0: case 3: - if (pop[t]) - pop[t] = pop[t]->car; - break; - case 1: case 4: - if (pop[t]) - pop[t] = pop[t]->cdr; - break; - case 2: - pop[t] = pair_new(pop[rand() % POP_SIZE], - pop[rand() % POP_SIZE]); - break; - } - if (rand() % 8 == 1) - pair_check_rec(pop[rand() % POP_SIZE]); - } - return data; -} - -int main(void) -{ -#if THREAD_CNT > 1 - pthread_t th[THREAD_CNT]; - int i; -#endif - - GC_set_all_interior_pointers(0); /* for a stricter test */ - GC_INIT(); - GC_init_finalized_malloc(); - - test_misc_sizes(); - -#if THREAD_CNT > 1 - printf("Threaded disclaim test.\n"); - for (i = 0; i < THREAD_CNT; ++i) { - int err = pthread_create(&th[i], NULL, test, NULL); - if (err) { - fprintf(stderr, "Failed to create thread # %d: %s\n", i, - strerror(err)); - exit(1); - } - } - for (i = 0; i < THREAD_CNT; ++i) { - int err = pthread_join(th[i], NULL); - if (err) { - fprintf(stderr, "Failed to join thread # %d: %s\n", i, - strerror(err)); - exit(69); - } - } -#else - printf("Unthreaded disclaim test.\n"); - test(NULL); -#endif - return 0; -} diff -Nru ecl-16.1.2/src/bdwgc/tests/huge_test.c ecl-16.1.3+ds/src/bdwgc/tests/huge_test.c --- ecl-16.1.2/src/bdwgc/tests/huge_test.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/tests/huge_test.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,52 +0,0 @@ - -#include -#include -#include - -#ifndef GC_IGNORE_WARN - /* Ignore misleading "Out of Memory!" warning (which is printed on */ - /* every GC_MALLOC(LONG_MAX) call) by defining this macro before */ - /* "gc.h" inclusion. */ -# define GC_IGNORE_WARN -#endif - -#include "gc.h" - -/* - * Check that very large allocation requests fail. "Success" would usually - * indicate that the size was somehow converted to a negative - * number. Clients shouldn't do this, but we should fail in the - * expected manner. - */ - -int main(void) -{ - GC_INIT(); - - GC_set_max_heap_size(100*1024*1024); - /* Otherwise heap expansion aborts when deallocating large block. */ - /* That's OK. We test this corner case mostly to make sure that */ - /* it fails predictably. */ - GC_expand_hp(1024*1024*5); - if (sizeof(long) == sizeof(void *)) { - void *r = GC_MALLOC(LONG_MAX-1024); - if (0 != r) { - fprintf(stderr, - "Size LONG_MAX-1024 allocation unexpectedly succeeded\n"); - exit(1); - } - r = GC_MALLOC(LONG_MAX); - if (0 != r) { - fprintf(stderr, - "Size LONG_MAX allocation unexpectedly succeeded\n"); - exit(1); - } - r = GC_MALLOC((size_t)LONG_MAX + 1024); - if (0 != r) { - fprintf(stderr, - "Size LONG_MAX+1024 allocation unexpectedly succeeded\n"); - exit(1); - } - } - return 0; -} diff -Nru ecl-16.1.2/src/bdwgc/tests/initsecondarythread.c ecl-16.1.3+ds/src/bdwgc/tests/initsecondarythread.c --- ecl-16.1.2/src/bdwgc/tests/initsecondarythread.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/tests/initsecondarythread.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,100 +0,0 @@ -/* - * Copyright (C) 2011 Ludovic Courtes - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -/* Make sure 'GC_INIT' can be called from threads other than the initial - * thread. - */ - -#ifdef HAVE_CONFIG_H -# include "config.h" -#endif - -#ifndef GC_THREADS -# define GC_THREADS -#endif - -#define GC_NO_THREAD_REDIRECTS 1 - /* Do not redirect thread creation and join calls. */ - -#include "gc.h" - -#ifdef GC_PTHREADS -# include -#else -# include -#endif - -#include -#include - -#ifdef GC_PTHREADS - static void *thread(void *arg) -#else - static DWORD WINAPI thread(LPVOID arg) -#endif -{ - GC_INIT(); - (void)GC_MALLOC(123); - (void)GC_MALLOC(12345); -# ifdef GC_PTHREADS - return arg; -# else - return (DWORD)(GC_word)arg; -# endif -} - -#include "private/gcconfig.h" - -int main(void) -{ -# ifdef GC_PTHREADS - int code; - pthread_t t; -# else - HANDLE t; - DWORD thread_id; -# endif -# if !(defined(BEOS) || defined(MSWIN32) || defined(MSWINCE) \ - || defined(CYGWIN32) || defined(GC_OPENBSD_UTHREADS) \ - || (defined(DARWIN) && !defined(NO_PTHREAD_GET_STACKADDR_NP)) \ - || (defined(LINUX) && !defined(NACL)) \ - || (defined(GC_SOLARIS_THREADS) && !defined(_STRICT_STDC)) \ - || (!defined(STACKBOTTOM) && (defined(HEURISTIC1) \ - || (!defined(LINUX_STACKBOTTOM) && !defined(FREEBSD_STACKBOTTOM))))) - /* GC_INIT() must be called from main thread only. */ - GC_INIT(); -# endif -# ifdef GC_PTHREADS - if ((code = pthread_create (&t, NULL, thread, NULL)) != 0) { - fprintf(stderr, "Thread creation failed %d\n", code); - return 1; - } - if ((code = pthread_join (t, NULL)) != 0) { - fprintf(stderr, "Thread join failed %d\n", code); - return 1; - } -# else - t = CreateThread(NULL, 0, thread, 0, 0, &thread_id); - if (t == NULL) { - fprintf(stderr, "Thread creation failed %d\n", (int)GetLastError()); - return 1; - } - if (WaitForSingleObject(t, INFINITE) != WAIT_OBJECT_0) { - fprintf(stderr, "Thread join failed %d\n", (int)GetLastError()); - CloseHandle(t); - return 1; - } - CloseHandle(t); -# endif - return 0; -} diff -Nru ecl-16.1.2/src/bdwgc/tests/leak_test.c ecl-16.1.3+ds/src/bdwgc/tests/leak_test.c --- ecl-16.1.2/src/bdwgc/tests/leak_test.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/tests/leak_test.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,25 +0,0 @@ -#include "leak_detector.h" - -int main(void) { - int *p[10]; - int i; - GC_set_find_leak(1); /* for new collect versions not compiled */ - /* with -DFIND_LEAK. */ - - GC_INIT(); /* Needed if thread-local allocation is enabled. */ - /* FIXME: This is not ideal. */ - for (i = 0; i < 10; ++i) { - p[i] = malloc(sizeof(int)+i); - } - CHECK_LEAKS(); - for (i = 1; i < 10; ++i) { - free(p[i]); - } - for (i = 0; i < 9; ++i) { - p[i] = malloc(sizeof(int)+i); - } - CHECK_LEAKS(); - CHECK_LEAKS(); - CHECK_LEAKS(); - return 0; -} diff -Nru ecl-16.1.2/src/bdwgc/tests/middle.c ecl-16.1.3+ds/src/bdwgc/tests/middle.c --- ecl-16.1.2/src/bdwgc/tests/middle.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/tests/middle.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,25 +0,0 @@ -/* - * Test at the boundary between small and large objects. - * Inspired by a test case from Zoltan Varga. - */ -#include "gc.h" -#include - -int main (void) -{ - int i; - - GC_set_all_interior_pointers(0); - GC_INIT(); - - for (i = 0; i < 20000; ++i) { - (void)GC_malloc_atomic(4096); - (void)GC_malloc(4096); - } - for (i = 0; i < 20000; ++i) { - (void)GC_malloc_atomic(2048); - (void)GC_malloc(2048); - } - printf("Final heap size is %lu\n", (unsigned long)GC_get_heap_size()); - return 0; -} diff -Nru ecl-16.1.2/src/bdwgc/tests/realloc_test.c ecl-16.1.3+ds/src/bdwgc/tests/realloc_test.c --- ecl-16.1.2/src/bdwgc/tests/realloc_test.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/tests/realloc_test.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,34 +0,0 @@ - -#include -#include -#include "gc.h" - -#define COUNT 10000000 - -int main(void) { - int i; - unsigned long last_heap_size = 0; - - GC_INIT(); - - for (i = 0; i < COUNT; i++) { - int **p = GC_MALLOC(sizeof(int *)); - int *q = GC_MALLOC_ATOMIC(sizeof(int)); - - if (p == 0 || *p != 0) { - fprintf(stderr, "GC_malloc returned garbage (or NULL)\n"); - exit(1); - } - - *p = GC_REALLOC(q, 2 * sizeof(int)); - - if (i % 10 == 0) { - unsigned long heap_size = (unsigned long)GC_get_heap_size(); - if (heap_size != last_heap_size) { - printf("Heap size: %lu\n", heap_size); - last_heap_size = heap_size; - } - } - } - return 0; -} diff -Nru ecl-16.1.2/src/bdwgc/tests/smash_test.c ecl-16.1.3+ds/src/bdwgc/tests/smash_test.c --- ecl-16.1.2/src/bdwgc/tests/smash_test.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/tests/smash_test.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,28 +0,0 @@ -/* - * Test that overwrite error detection works reasonably. - */ -#define GC_DEBUG -#include "gc.h" - -#include - -#define COUNT 7000 -#define SIZE 40 - -char * A[COUNT]; - -int main(void) -{ - int i; - char *p; - - GC_INIT(); - - for (i = 0; i < COUNT; ++i) { - A[i] = p = GC_MALLOC(SIZE); - - if (i%3000 == 0) GC_gcollect(); - if (i%5678 == 0 && p != 0) p[SIZE + i/2000] = 42; - } - return 0; -} diff -Nru ecl-16.1.2/src/bdwgc/tests/staticrootslib.c ecl-16.1.3+ds/src/bdwgc/tests/staticrootslib.c --- ecl-16.1.2/src/bdwgc/tests/staticrootslib.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/tests/staticrootslib.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,57 +0,0 @@ - -/* This test file is intended to be compiled into a DLL. */ - -#ifndef GC_DEBUG -# define GC_DEBUG -#endif - -#include "gc.h" - -#ifndef GC_TEST_EXPORT_API -# if defined(GC_VISIBILITY_HIDDEN_SET) \ - && !defined(__CEGCC__) && !defined(__CYGWIN__) && !defined(__MINGW32__) -# define GC_TEST_EXPORT_API \ - extern __attribute__((__visibility__("default"))) -# else -# define GC_TEST_EXPORT_API extern -# endif -#endif - -struct treenode { - struct treenode *x; - struct treenode *y; -}; - -static struct treenode *root[10] = { 0 }; -static struct treenode *root_nz[10] = { (void *)(GC_word)2 }; - -#ifdef STATICROOTSLIB2 -# define libsrl_getpelem libsrl_getpelem2 -#else - - GC_TEST_EXPORT_API struct treenode * libsrl_mktree(int i) - { - struct treenode * r = GC_MALLOC(sizeof(struct treenode)); - if (0 == i) return 0; - if (1 == i) r = GC_MALLOC_ATOMIC(sizeof(struct treenode)); - if (r) { - r -> x = libsrl_mktree(i-1); - r -> y = libsrl_mktree(i-1); - } - return r; - } - - GC_TEST_EXPORT_API void * libsrl_init(void) - { -# ifndef STATICROOTSLIB_INIT_IN_MAIN - GC_INIT(); -# endif - return GC_MALLOC(sizeof(struct treenode)); - } - -#endif /* !STATICROOTSLIB2 */ - -GC_TEST_EXPORT_API struct treenode ** libsrl_getpelem(int i, int j) -{ - return &((j & 1) != 0 ? root_nz : root)[i]; -} diff -Nru ecl-16.1.2/src/bdwgc/tests/staticrootstest.c ecl-16.1.3+ds/src/bdwgc/tests/staticrootstest.c --- ecl-16.1.2/src/bdwgc/tests/staticrootstest.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/tests/staticrootstest.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,67 +0,0 @@ - -#include -#include - -#ifndef GC_DEBUG -# define GC_DEBUG -#endif - -#include "gc.h" -#include "gc_backptr.h" - -#ifndef GC_TEST_IMPORT_API -# define GC_TEST_IMPORT_API extern -#endif - -/* Should match that in staticrootslib.c. */ -struct treenode { - struct treenode *x; - struct treenode *y; -}; - -struct treenode *root[10] = { NULL }; - -/* Same as "root" variable but initialized to some non-zero value (to */ -/* be placed to .data section instead of .bss). */ -struct treenode *root_nz[10] = { (void *)(GC_word)1 }; - -static char *staticroot = 0; - -GC_TEST_IMPORT_API struct treenode * libsrl_mktree(int i); -GC_TEST_IMPORT_API void * libsrl_init(void); -GC_TEST_IMPORT_API struct treenode ** libsrl_getpelem(int i, int j); - -GC_TEST_IMPORT_API struct treenode ** libsrl_getpelem2(int i, int j); - -int main(void) -{ - int i, j; - -# ifdef STATICROOTSLIB_INIT_IN_MAIN - GC_INIT(); -# endif - staticroot = libsrl_init(); - if (NULL == staticroot) { - fprintf(stderr, "GC_malloc returned NULL\n"); - return 2; - } - memset(staticroot, 0x42, sizeof(struct treenode)); - GC_gcollect(); - for (j = 0; j < 4; j++) { - for (i = 0; i < (int)(sizeof(root) / sizeof(root[0])); ++i) { -# ifdef STATICROOTSLIB2 - *libsrl_getpelem2(i, j) = libsrl_mktree(12); -# endif - *libsrl_getpelem(i, j) = libsrl_mktree(12); - ((j & 1) != 0 ? root_nz : root)[i] = libsrl_mktree(12); - GC_gcollect(); - } - for (i = 0; i < (int)sizeof(struct treenode); ++i) { - if (staticroot[i] != 0x42) { - fprintf(stderr, "Memory check failed\n"); - return -1; - } - } - } - return 0; -} diff -Nru ecl-16.1.2/src/bdwgc/tests/subthread_create.c ecl-16.1.3+ds/src/bdwgc/tests/subthread_create.c --- ecl-16.1.2/src/bdwgc/tests/subthread_create.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/tests/subthread_create.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,145 +0,0 @@ - -#ifdef HAVE_CONFIG_H - /* For PARALLEL_MARK */ -# include "config.h" -#endif - -#ifndef GC_THREADS -# define GC_THREADS -#endif -#include "gc.h" - -#ifdef PARALLEL_MARK -# define AO_REQUIRE_CAS -#endif -#include "atomic_ops.h" - -#include - -#ifdef AO_HAVE_fetch_and_add - -#ifdef GC_PTHREADS -# include -#else -# include -#endif - -#include -#include - -#ifndef MAX_SUBTHREAD_DEPTH -# define INITIAL_THREAD_COUNT 31 -# define MAX_ALIVE_THREAD_COUNT 55 -# define MAX_SUBTHREAD_DEPTH 7 -# define MAX_SUBTHREAD_COUNT 200 -#endif - -#ifndef DECAY_NUMER -# define DECAY_NUMER 15 -# define DECAY_DENOM 16 -#endif - -volatile AO_t thread_created_cnt = 0; -volatile AO_t thread_ended_cnt = 0; - -#ifdef GC_PTHREADS - void *entry(void *arg) -#else - DWORD WINAPI entry(LPVOID arg) -#endif -{ - int thread_num = AO_fetch_and_add(&thread_created_cnt, 1); - GC_word my_depth = (GC_word)arg + 1; - - if (my_depth <= MAX_SUBTHREAD_DEPTH - && thread_num < MAX_SUBTHREAD_COUNT - && (thread_num % DECAY_DENOM) < DECAY_NUMER - && (int)(thread_num - AO_load(&thread_ended_cnt)) - <= MAX_ALIVE_THREAD_COUNT) { -# ifdef GC_PTHREADS - int err; - pthread_t th; - err = pthread_create(&th, NULL, entry, (void *)my_depth); - if (err) { - fprintf(stderr, "Thread #%d creation failed: %s", thread_num, - strerror(err)); - exit(2); - } -# else - HANDLE th; - DWORD thread_id; - th = CreateThread(NULL, 0, entry, (LPVOID)my_depth, 0, &thread_id); - if (th == NULL) { - fprintf(stderr, "Thread #%d creation failed: %d\n", thread_num, - (int)GetLastError()); - exit(2); - } - CloseHandle(th); -# endif - } - - AO_fetch_and_add(&thread_ended_cnt, 1); - return 0; -} - -int main(void) -{ - int i; -# ifdef GC_PTHREADS - int err; - pthread_t th[INITIAL_THREAD_COUNT]; -# else - HANDLE th[INITIAL_THREAD_COUNT]; -# endif - - GC_INIT(); - for (i = 0; i < INITIAL_THREAD_COUNT; ++i) { -# ifdef GC_PTHREADS - err = pthread_create(&th[i], NULL, entry, 0); - if (err) { - fprintf(stderr, "Thread creation failed: %s", strerror(err)); - exit(1); - } -# else - DWORD thread_id; - th[i] = CreateThread(NULL, 0, entry, 0, 0, &thread_id); - if (th[i] == NULL) { - fprintf(stderr, "Thread creation failed: %d\n", - (int)GetLastError()); - exit(1); - } -# endif - } - - for (i = 0; i < INITIAL_THREAD_COUNT; ++i) { -# ifdef GC_PTHREADS - void *res; - err = pthread_join(th[i], &res); - if (err) { - fprintf(stderr, "Failed to join thread: %s", strerror(err)); - exit(1); - } -# else - if (WaitForSingleObject(th[i], INFINITE) != WAIT_OBJECT_0) { - fprintf(stderr, "Failed to join thread: %d\n", - (int)GetLastError()); - CloseHandle(th[i]); - exit(1); - } - CloseHandle(th[i]); -# endif - } - printf("subthread_create: created %d threads (%d ended)\n", - (int)AO_load(&thread_created_cnt), (int)AO_load(&thread_ended_cnt)); - return 0; -} - -#else - -int main(void) -{ - printf("subthread_create test skipped\n"); - return 0; -} - -#endif /* !AO_HAVE_fetch_and_add */ diff -Nru ecl-16.1.2/src/bdwgc/tests/test.c ecl-16.1.3+ds/src/bdwgc/tests/test.c --- ecl-16.1.2/src/bdwgc/tests/test.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/tests/test.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,1932 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996 by Silicon Graphics. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ -/* An incomplete test for the garbage collector. */ -/* Some more obscure entry points are not tested at all. */ -/* This must be compiled with the same flags used to build the */ -/* GC. It uses GC internals to allow more precise results */ -/* checking for some of the tests. */ - -# ifdef HAVE_CONFIG_H -# include "config.h" -# endif - -# undef GC_BUILD - -#if (defined(DBG_HDRS_ALL) || defined(MAKE_BACK_GRAPH)) && !defined(GC_DEBUG) -# define GC_DEBUG -#endif - -#include "gc.h" - -#ifndef NTHREADS /* Number of additional threads to fork. */ -# define NTHREADS 5 /* excludes main thread, which also runs a test. */ - /* Not respected by PCR test. */ -#endif - -# if defined(mips) && defined(SYSTYPE_BSD43) - /* MIPS RISCOS 4 */ -# else -# include -# endif -# include -# if defined(_WIN32_WCE) && !defined(__GNUC__) -# include -/* # define assert ASSERT */ -# else -# include /* Not normally used, but handy for debugging. */ -# endif - -# include "gc_typed.h" -# include "private/gc_priv.h" /* For output, locking, MIN_WORDS, */ - /* some statistics and gcconfig.h. */ - -# if defined(MSWIN32) || defined(MSWINCE) -# include -# endif - -#ifdef GC_PRINT_VERBOSE_STATS -# define print_stats VERBOSE -# define INIT_PRINT_STATS /* empty */ -#else - /* Use own variable as GC_print_stats might not be exported. */ - static int print_stats = 0; -# ifdef GC_READ_ENV_FILE - /* GETENV uses GC internal function in this case. */ -# define INIT_PRINT_STATS /* empty */ -# else -# define INIT_PRINT_STATS \ - { \ - if (0 != GETENV("GC_PRINT_VERBOSE_STATS")) \ - print_stats = VERBOSE; \ - else if (0 != GETENV("GC_PRINT_STATS")) \ - print_stats = 1; \ - } -# endif -#endif /* !GC_PRINT_VERBOSE_STATS */ - -# ifdef PCR -# include "th/PCR_ThCrSec.h" -# include "th/PCR_Th.h" -# define GC_printf printf -# endif - -# if defined(GC_PTHREADS) -# include -# endif - -# if (!defined(THREADS) || !defined(HANDLE_FORK) \ - || (defined(DARWIN) && defined(MPROTECT_VDB) \ - && !defined(NO_INCREMENTAL) && !defined(MAKE_BACK_GRAPH))) \ - && !defined(NO_TEST_HANDLE_FORK) && !defined(TEST_HANDLE_FORK) \ - && !defined(TEST_FORK_WITHOUT_ATFORK) -# define NO_TEST_HANDLE_FORK -# endif - -# ifndef NO_TEST_HANDLE_FORK -# include -# ifdef HANDLE_FORK -# define INIT_FORK_SUPPORT GC_set_handle_fork(1) - /* Causes abort in GC_init on pthread_atfork failure. */ -# elif !defined(TEST_FORK_WITHOUT_ATFORK) -# define INIT_FORK_SUPPORT GC_set_handle_fork(-1) - /* Passing -1 implies fork() should be as well manually */ - /* surrounded with GC_atfork_prepare/parent/child. */ -# endif -# endif - -# ifndef INIT_FORK_SUPPORT -# define INIT_FORK_SUPPORT /* empty */ -# endif - -# if defined(GC_WIN32_THREADS) && !defined(GC_PTHREADS) - static CRITICAL_SECTION incr_cs; -# endif - -# include - -#define CHECH_GCLIB_VERSION \ - if (GC_get_version() != ((GC_VERSION_MAJOR<<16) \ - | (GC_VERSION_MINOR<<8) \ - | GC_VERSION_MICRO)) { \ - GC_printf("libgc version mismatch\n"); \ - exit(1); \ - } - -/* Call GC_INIT only on platforms on which we think we really need it, */ -/* so that we can test automatic initialization on the rest. */ -#if defined(CYGWIN32) || defined (AIX) || defined(DARWIN) \ - || defined(PLATFORM_ANDROID) || defined(THREAD_LOCAL_ALLOC) \ - || (defined(MSWINCE) && !defined(GC_WINMAIN_REDIRECT)) -# define GC_OPT_INIT GC_INIT() -#else -# define GC_OPT_INIT /* empty */ -#endif - -#define GC_COND_INIT() \ - INIT_FORK_SUPPORT; GC_OPT_INIT; CHECH_GCLIB_VERSION; INIT_PRINT_STATS - -#define CHECK_OUT_OF_MEMORY(p) \ - if ((p) == NULL) { \ - GC_printf("Out of memory\n"); \ - exit(1); \ - } - -/* Allocation Statistics. Incremented without synchronization. */ -/* FIXME: We should be using synchronization. */ -int stubborn_count = 0; -int uncollectable_count = 0; -int collectable_count = 0; -int atomic_count = 0; -int realloc_count = 0; - -#if defined(GC_AMIGA_FASTALLOC) && defined(AMIGA) - - void GC_amiga_free_all_mem(void); - void Amiga_Fail(void){GC_amiga_free_all_mem();abort();} -# define FAIL (void)Amiga_Fail() - void *GC_amiga_gctest_malloc_explicitly_typed(size_t lb, GC_descr d){ - void *ret=GC_malloc_explicitly_typed(lb,d); - if(ret==NULL){ - GC_gcollect(); - ret=GC_malloc_explicitly_typed(lb,d); - if(ret==NULL){ - GC_printf("Out of memory, (typed allocations are not directly " - "supported with the GC_AMIGA_FASTALLOC option.)\n"); - FAIL; - } - } - return ret; - } - void *GC_amiga_gctest_calloc_explicitly_typed(size_t a,size_t lb, GC_descr d){ - void *ret=GC_calloc_explicitly_typed(a,lb,d); - if(ret==NULL){ - GC_gcollect(); - ret=GC_calloc_explicitly_typed(a,lb,d); - if(ret==NULL){ - GC_printf("Out of memory, (typed allocations are not directly " - "supported with the GC_AMIGA_FASTALLOC option.)\n"); - FAIL; - } - } - return ret; - } -# define GC_malloc_explicitly_typed(a,b) GC_amiga_gctest_malloc_explicitly_typed(a,b) -# define GC_calloc_explicitly_typed(a,b,c) GC_amiga_gctest_calloc_explicitly_typed(a,b,c) - -#else /* !AMIGA_FASTALLOC */ - -# if defined(PCR) || defined(LINT2) -# define FAIL (void)abort() -# else -# define FAIL ABORT("Test failed") -# endif - -#endif /* !AMIGA_FASTALLOC */ - -/* AT_END may be defined to exercise the interior pointer test */ -/* if the collector is configured with ALL_INTERIOR_POINTERS. */ -/* As it stands, this test should succeed with either */ -/* configuration. In the FIND_LEAK configuration, it should */ -/* find lots of leaks, since we free almost nothing. */ - -struct SEXPR { - struct SEXPR * sexpr_car; - struct SEXPR * sexpr_cdr; -}; - - -typedef struct SEXPR * sexpr; - -# define INT_TO_SEXPR(x) ((sexpr)(GC_word)(x)) -# define SEXPR_TO_INT(x) ((int)(GC_word)(x)) - -# undef nil -# define nil (INT_TO_SEXPR(0)) -# define car(x) ((x) -> sexpr_car) -# define cdr(x) ((x) -> sexpr_cdr) -# define is_nil(x) ((x) == nil) - - -int extra_count = 0; /* Amount of space wasted in cons node */ - -/* Silly implementation of Lisp cons. Intentionally wastes lots of space */ -/* to test collector. */ -# ifdef VERY_SMALL_CONFIG -# define cons small_cons -# else -sexpr cons (sexpr x, sexpr y) -{ - sexpr r; - int *p; - int my_extra = extra_count; - - stubborn_count++; - r = (sexpr) GC_MALLOC_STUBBORN(sizeof(struct SEXPR) + my_extra); - CHECK_OUT_OF_MEMORY(r); - for (p = (int *)r; - (word)p < (word)r + my_extra + sizeof(struct SEXPR); p++) { - if (*p) { - GC_printf("Found nonzero at %p - allocator is broken\n", - (void *)p); - FAIL; - } - *p = (int)((13 << 12) + ((p - (int *)r) & 0xfff)); - } -# ifdef AT_END - r = (sexpr)((char *)r + (my_extra & ~7)); -# endif - r -> sexpr_car = x; - r -> sexpr_cdr = y; - my_extra++; - if ( my_extra >= 5000 ) { - extra_count = 0; - } else { - extra_count = my_extra; - } - GC_END_STUBBORN_CHANGE(r); - return(r); -} -# endif - -#ifdef GC_GCJ_SUPPORT - -#include "gc_mark.h" -#include "gc_gcj.h" - -/* The following struct emulates the vtable in gcj. */ -/* This assumes the default value of MARK_DESCR_OFFSET. */ -struct fake_vtable { - void * dummy; /* class pointer in real gcj. */ - GC_word descr; -}; - -struct fake_vtable gcj_class_struct1 = { 0, sizeof(struct SEXPR) - + sizeof(struct fake_vtable *) }; - /* length based descriptor. */ -struct fake_vtable gcj_class_struct2 = - { 0, ((GC_word)3 << (CPP_WORDSZ - 3)) | GC_DS_BITMAP}; - /* Bitmap based descriptor. */ - -struct GC_ms_entry * fake_gcj_mark_proc(word * addr, - struct GC_ms_entry *mark_stack_ptr, - struct GC_ms_entry *mark_stack_limit, - word env ) -{ - sexpr x; - if (1 == env) { - /* Object allocated with debug allocator. */ - addr = (word *)GC_USR_PTR_FROM_BASE(addr); - } - x = (sexpr)(addr + 1); /* Skip the vtable pointer. */ - mark_stack_ptr = GC_MARK_AND_PUSH( - (void *)(x -> sexpr_cdr), mark_stack_ptr, - mark_stack_limit, (void * *)&(x -> sexpr_cdr)); - mark_stack_ptr = GC_MARK_AND_PUSH( - (void *)(x -> sexpr_car), mark_stack_ptr, - mark_stack_limit, (void * *)&(x -> sexpr_car)); - return(mark_stack_ptr); -} - -#endif /* GC_GCJ_SUPPORT */ - - -sexpr small_cons (sexpr x, sexpr y) -{ - sexpr r; - - collectable_count++; - r = (sexpr) GC_MALLOC(sizeof(struct SEXPR)); - CHECK_OUT_OF_MEMORY(r); - r -> sexpr_car = x; - r -> sexpr_cdr = y; - return(r); -} - -sexpr small_cons_uncollectable (sexpr x, sexpr y) -{ - sexpr r; - - uncollectable_count++; - r = (sexpr) GC_MALLOC_UNCOLLECTABLE(sizeof(struct SEXPR)); - CHECK_OUT_OF_MEMORY(r); - r -> sexpr_car = x; - r -> sexpr_cdr = (sexpr)(~(GC_word)y); - return(r); -} - -#ifdef GC_GCJ_SUPPORT - - -sexpr gcj_cons(sexpr x, sexpr y) -{ - GC_word * r; - sexpr result; - - r = (GC_word *) GC_GCJ_MALLOC(sizeof(struct SEXPR) - + sizeof(struct fake_vtable*), - &gcj_class_struct2); - CHECK_OUT_OF_MEMORY(r); - result = (sexpr)(r + 1); - result -> sexpr_car = x; - result -> sexpr_cdr = y; - return(result); -} -#endif - -/* Return reverse(x) concatenated with y */ -sexpr reverse1(sexpr x, sexpr y) -{ - if (is_nil(x)) { - return(y); - } else { - return( reverse1(cdr(x), cons(car(x), y)) ); - } -} - -sexpr reverse(sexpr x) -{ -# ifdef TEST_WITH_SYSTEM_MALLOC - malloc(100000); -# endif - return( reverse1(x, nil) ); -} - -sexpr ints(int low, int up) -{ - if (low > up) { - return(nil); - } else { - return(small_cons(small_cons(INT_TO_SEXPR(low), nil), ints(low+1, up))); - } -} - -#ifdef GC_GCJ_SUPPORT -/* Return reverse(x) concatenated with y */ -sexpr gcj_reverse1(sexpr x, sexpr y) -{ - if (is_nil(x)) { - return(y); - } else { - return( gcj_reverse1(cdr(x), gcj_cons(car(x), y)) ); - } -} - -sexpr gcj_reverse(sexpr x) -{ - return( gcj_reverse1(x, nil) ); -} - -sexpr gcj_ints(int low, int up) -{ - if (low > up) { - return(nil); - } else { - return(gcj_cons(gcj_cons(INT_TO_SEXPR(low), nil), gcj_ints(low+1, up))); - } -} -#endif /* GC_GCJ_SUPPORT */ - -/* To check uncollectible allocation we build lists with disguised cdr */ -/* pointers, and make sure they don't go away. */ -sexpr uncollectable_ints(int low, int up) -{ - if (low > up) { - return(nil); - } else { - return(small_cons_uncollectable(small_cons(INT_TO_SEXPR(low), nil), - uncollectable_ints(low+1, up))); - } -} - -void check_ints(sexpr list, int low, int up) -{ - if (SEXPR_TO_INT(car(car(list))) != low) { - GC_printf( - "List reversal produced incorrect list - collector is broken\n"); - FAIL; - } - if (low == up) { - if (cdr(list) != nil) { - GC_printf("List too long - collector is broken\n"); - FAIL; - } - } else { - check_ints(cdr(list), low+1, up); - } -} - -# define UNCOLLECTABLE_CDR(x) (sexpr)(~(GC_word)(cdr(x))) - -void check_uncollectable_ints(sexpr list, int low, int up) -{ - if (SEXPR_TO_INT(car(car(list))) != low) { - GC_printf("Uncollectable list corrupted - collector is broken\n"); - FAIL; - } - if (low == up) { - if (UNCOLLECTABLE_CDR(list) != nil) { - GC_printf("Uncollectable list too long - collector is broken\n"); - FAIL; - } - } else { - check_uncollectable_ints(UNCOLLECTABLE_CDR(list), low+1, up); - } -} - -/* Not used, but useful for debugging: */ -void print_int_list(sexpr x) -{ - if (is_nil(x)) { - GC_printf("NIL\n"); - } else { - GC_printf("(%d)", SEXPR_TO_INT(car(car(x)))); - if (!is_nil(cdr(x))) { - GC_printf(", "); - print_int_list(cdr(x)); - } else { - GC_printf("\n"); - } - } -} - -/* ditto: */ -void check_marks_int_list(sexpr x) -{ - if (!GC_is_marked(x)) - GC_printf("[unm:%p]", (void *)x); - else - GC_printf("[mkd:%p]", (void *)x); - if (is_nil(x)) { - GC_printf("NIL\n"); - } else { - if (!GC_is_marked(car(x))) - GC_printf("[unm car:%p]", (void *)car(x)); - GC_printf("(%d)", SEXPR_TO_INT(car(car(x)))); - if (!is_nil(cdr(x))) { - GC_printf(", "); - check_marks_int_list(cdr(x)); - } else { - GC_printf("\n"); - } - } -} - -/* - * A tiny list reversal test to check thread creation. - */ -#ifdef THREADS - -# ifdef VERY_SMALL_CONFIG -# define TINY_REVERSE_UPPER_VALUE 4 -# else -# define TINY_REVERSE_UPPER_VALUE 10 -# endif - -# if defined(GC_WIN32_THREADS) && !defined(GC_PTHREADS) - DWORD __stdcall tiny_reverse_test(void * arg GC_ATTR_UNUSED) -# else - void * tiny_reverse_test(void * arg GC_ATTR_UNUSED) -# endif -{ - int i; - for (i = 0; i < 5; ++i) { - check_ints(reverse(reverse(ints(1, TINY_REVERSE_UPPER_VALUE))), - 1, TINY_REVERSE_UPPER_VALUE); - } - return 0; -} - -# if defined(GC_PTHREADS) - void fork_a_thread(void) - { - pthread_t t; - int code; - if ((code = pthread_create(&t, 0, tiny_reverse_test, 0)) != 0) { - GC_printf("Small thread creation failed %d\n", code); - FAIL; - } - if ((code = pthread_join(t, 0)) != 0) { - GC_printf("Small thread join failed %d\n", code); - FAIL; - } - } - -# elif defined(GC_WIN32_THREADS) - void fork_a_thread(void) - { - DWORD thread_id; - HANDLE h; - h = GC_CreateThread((SECURITY_ATTRIBUTES *)NULL, (word)0, - tiny_reverse_test, NULL, (DWORD)0, &thread_id); - /* Explicitly specify types of the */ - /* arguments to test the prototype. */ - if (h == (HANDLE)NULL) { - GC_printf("Small thread creation failed %d\n", - (int)GetLastError()); - FAIL; - } - if (WaitForSingleObject(h, INFINITE) != WAIT_OBJECT_0) { - GC_printf("Small thread wait failed %d\n", - (int)GetLastError()); - FAIL; - } - } - -# endif - -#endif - -void test_generic_malloc_or_special(void *p) { - size_t size; - int kind = GC_get_kind_and_size(p, &size); - void *p2; - - if (size != GC_size(p)) { - GC_printf("GC_get_kind_and_size returned size not matching GC_size\n"); - FAIL; - } - p2 = GC_GENERIC_OR_SPECIAL_MALLOC(10, kind); - CHECK_OUT_OF_MEMORY(p2); - if (GC_get_kind_and_size(p2, NULL) != kind) { - GC_printf("GC_generic_or_special_malloc:" - " unexpected kind of returned object\n"); - FAIL; - } - GC_FREE(p2); -} - -/* Try to force a to be strangely aligned */ -struct { - char dummy; - sexpr aa; -} A; -#define a A.aa - -/* - * Repeatedly reverse lists built out of very different sized cons cells. - * Check that we didn't lose anything. - */ -void *GC_CALLBACK reverse_test_inner(void *data) -{ - int i; - sexpr b; - sexpr c; - sexpr d; - sexpr e; - sexpr *f, *g, *h; - - if (data == 0) { - /* This stack frame is not guaranteed to be scanned. */ - return GC_call_with_gc_active(reverse_test_inner, (void*)(word)1); - } - -# if /*defined(MSWIN32) ||*/ defined(MACOS) - /* Win32S only allows 128K stacks */ -# define BIG 1000 -# elif defined(PCR) - /* PCR default stack is 100K. Stack frames are up to 120 bytes. */ -# define BIG 700 -# elif defined(MSWINCE) || defined(RTEMS) - /* WinCE only allows 64K stacks */ -# define BIG 500 -# elif defined(OSF1) - /* OSF has limited stack space by default, and large frames. */ -# define BIG 200 -# elif defined(__MACH__) && defined(__ppc64__) -# define BIG 2500 -# else -# define BIG 4500 -# endif - - A.dummy = 17; - a = ints(1, 49); - b = ints(1, 50); - c = ints(1, BIG); - d = uncollectable_ints(1, 100); - test_generic_malloc_or_special(d); - e = uncollectable_ints(1, 1); - /* Check that realloc updates object descriptors correctly */ - collectable_count++; - f = (sexpr *)GC_MALLOC(4 * sizeof(sexpr)); - realloc_count++; - f = (sexpr *)GC_REALLOC((void *)f, 6 * sizeof(sexpr)); - CHECK_OUT_OF_MEMORY(f); - f[5] = ints(1,17); - collectable_count++; - g = (sexpr *)GC_MALLOC(513 * sizeof(sexpr)); - test_generic_malloc_or_special(g); - realloc_count++; - g = (sexpr *)GC_REALLOC((void *)g, 800 * sizeof(sexpr)); - CHECK_OUT_OF_MEMORY(g); - g[799] = ints(1,18); - collectable_count++; - h = (sexpr *)GC_MALLOC(1025 * sizeof(sexpr)); - realloc_count++; - h = (sexpr *)GC_REALLOC((void *)h, 2000 * sizeof(sexpr)); - CHECK_OUT_OF_MEMORY(h); -# ifdef GC_GCJ_SUPPORT - h[1999] = gcj_ints(1,200); - for (i = 0; i < 51; ++i) - h[1999] = gcj_reverse(h[1999]); - /* Leave it as the reversed list for now. */ -# else - h[1999] = ints(1,200); -# endif - /* Try to force some collections and reuse of small list elements */ - for (i = 0; i < 10; i++) { - (void)ints(1, BIG); - } - /* Superficially test interior pointer recognition on stack */ - c = (sexpr)((char *)c + sizeof(char *)); - d = (sexpr)((char *)d + sizeof(char *)); - - GC_FREE((void *)e); - - check_ints(b,1,50); - check_ints(a,1,49); - for (i = 0; i < 50; i++) { - check_ints(b,1,50); - b = reverse(reverse(b)); - } - check_ints(b,1,50); - check_ints(a,1,49); - for (i = 0; i < 60; i++) { -# if defined(GC_PTHREADS) || defined(GC_WIN32_THREADS) - if (i % 10 == 0) fork_a_thread(); -# endif - /* This maintains the invariant that a always points to a list of */ - /* 49 integers. Thus this is thread safe without locks, */ - /* assuming atomic pointer assignments. */ - a = reverse(reverse(a)); -# if !defined(AT_END) && !defined(THREADS) - /* This is not thread safe, since realloc explicitly deallocates */ - if (i & 1) { - a = (sexpr)GC_REALLOC((void *)a, 500); - } else { - a = (sexpr)GC_REALLOC((void *)a, 8200); - } -# endif - } - check_ints(a,1,49); - check_ints(b,1,50); - - /* Restore c and d values. */ - c = (sexpr)((char *)c - sizeof(char *)); - d = (sexpr)((char *)d - sizeof(char *)); - - check_ints(c,1,BIG); - check_uncollectable_ints(d, 1, 100); - check_ints(f[5], 1,17); - check_ints(g[799], 1,18); -# ifdef GC_GCJ_SUPPORT - h[1999] = gcj_reverse(h[1999]); -# endif - check_ints(h[1999], 1,200); -# ifndef THREADS - a = 0; -# endif - *(sexpr volatile *)&b = 0; - *(sexpr volatile *)&c = 0; - return 0; -} - -void reverse_test(void) -{ - /* Test GC_do_blocking/GC_call_with_gc_active. */ - (void)GC_do_blocking(reverse_test_inner, 0); -} - -#undef a - -/* - * The rest of this builds balanced binary trees, checks that they don't - * disappear, and tests finalization. - */ -typedef struct treenode { - int level; - struct treenode * lchild; - struct treenode * rchild; -} tn; - -int finalizable_count = 0; -int finalized_count = 0; -volatile int dropped_something = 0; - -void GC_CALLBACK finalizer(void * obj, void * client_data) -{ - tn * t = (tn *)obj; - -# ifdef PCR - PCR_ThCrSec_EnterSys(); -# endif -# if defined(GC_PTHREADS) - static pthread_mutex_t incr_lock = PTHREAD_MUTEX_INITIALIZER; - pthread_mutex_lock(&incr_lock); -# elif defined(GC_WIN32_THREADS) - EnterCriticalSection(&incr_cs); -# endif - if ((int)(GC_word)client_data != t -> level) { - GC_printf("Wrong finalization data - collector is broken\n"); - FAIL; - } - finalized_count++; - t -> level = -1; /* detect duplicate finalization immediately */ -# ifdef PCR - PCR_ThCrSec_ExitSys(); -# endif -# if defined(GC_PTHREADS) - pthread_mutex_unlock(&incr_lock); -# elif defined(GC_WIN32_THREADS) - LeaveCriticalSection(&incr_cs); -# endif -} - -size_t counter = 0; - -# define MAX_FINALIZED (NTHREADS*4000) - -# if !defined(MACOS) - GC_FAR GC_word live_indicators[MAX_FINALIZED] = {0}; -# ifndef GC_LONG_REFS_NOT_NEEDED - GC_FAR void *live_long_refs[MAX_FINALIZED] = { NULL }; -# endif -#else - /* Too big for THINK_C. have to allocate it dynamically. */ - GC_word *live_indicators = 0; -# ifndef GC_LONG_REFS_NOT_NEEDED -# define GC_LONG_REFS_NOT_NEEDED -# endif -#endif - -int live_indicators_count = 0; - -tn * mktree(int n) -{ - tn * result = (tn *)GC_MALLOC(sizeof(tn)); - - collectable_count++; -# if defined(MACOS) - /* get around static data limitations. */ - if (!live_indicators) { - live_indicators = - (GC_word*)NewPtrClear(MAX_FINALIZED * sizeof(GC_word)); - CHECK_OUT_OF_MEMORY(live_indicators); - } -# endif - if (n == 0) return(0); - CHECK_OUT_OF_MEMORY(result); - result -> level = n; - result -> lchild = mktree(n-1); - result -> rchild = mktree(n-1); - if (counter++ % 17 == 0 && n >= 2) { - tn * tmp; - - CHECK_OUT_OF_MEMORY(result->lchild); - tmp = result -> lchild -> rchild; - CHECK_OUT_OF_MEMORY(result->rchild); - result -> lchild -> rchild = result -> rchild -> lchild; - result -> rchild -> lchild = tmp; - } - if (counter++ % 119 == 0) { -# ifndef GC_NO_FINALIZATION - int my_index; - void *new_link; -# endif - - { -# ifdef PCR - PCR_ThCrSec_EnterSys(); -# endif -# if defined(GC_PTHREADS) - static pthread_mutex_t incr_lock = PTHREAD_MUTEX_INITIALIZER; - pthread_mutex_lock(&incr_lock); -# elif defined(GC_WIN32_THREADS) - EnterCriticalSection(&incr_cs); -# endif - /* Losing a count here causes erroneous report of failure. */ - finalizable_count++; -# ifndef GC_NO_FINALIZATION - my_index = live_indicators_count++; -# endif -# ifdef PCR - PCR_ThCrSec_ExitSys(); -# endif -# if defined(GC_PTHREADS) - pthread_mutex_unlock(&incr_lock); -# elif defined(GC_WIN32_THREADS) - LeaveCriticalSection(&incr_cs); -# endif - } - -# ifndef GC_NO_FINALIZATION - GC_REGISTER_FINALIZER((void *)result, finalizer, (void *)(GC_word)n, - (GC_finalization_proc *)0, (void * *)0); - if (my_index >= MAX_FINALIZED) { - GC_printf("live_indicators overflowed\n"); - FAIL; - } - live_indicators[my_index] = 13; - if (GC_GENERAL_REGISTER_DISAPPEARING_LINK( - (void * *)(&(live_indicators[my_index])), result) != 0) { - GC_printf("GC_general_register_disappearing_link failed\n"); - FAIL; - } - if (GC_move_disappearing_link((void **)(&(live_indicators[my_index])), - (void **)(&(live_indicators[my_index]))) != GC_SUCCESS) { - GC_printf("GC_move_disappearing_link(link,link) failed\n"); - FAIL; - } - new_link = (void *)live_indicators[my_index]; - if (GC_move_disappearing_link((void **)(&(live_indicators[my_index])), - &new_link) != GC_SUCCESS) { - GC_printf("GC_move_disappearing_link(new_link) failed\n"); - FAIL; - } - if (GC_unregister_disappearing_link(&new_link) == 0) { - GC_printf("GC_unregister_disappearing_link failed\n"); - FAIL; - } - if (GC_move_disappearing_link((void **)(&(live_indicators[my_index])), - &new_link) != GC_NOT_FOUND) { - GC_printf("GC_move_disappearing_link(new_link) failed 2\n"); - FAIL; - } - if (GC_GENERAL_REGISTER_DISAPPEARING_LINK( - (void * *)(&(live_indicators[my_index])), result) != 0) { - GC_printf("GC_general_register_disappearing_link failed 2\n"); - FAIL; - } -# ifndef GC_LONG_REFS_NOT_NEEDED - if (GC_REGISTER_LONG_LINK(&live_long_refs[my_index], result) != 0) { - GC_printf("GC_register_long_link failed\n"); - FAIL; - } - if (GC_move_long_link(&live_long_refs[my_index], - &live_long_refs[my_index]) != GC_SUCCESS) { - GC_printf("GC_move_long_link(link,link) failed\n"); - FAIL; - } - new_link = live_long_refs[my_index]; - if (GC_move_long_link(&live_long_refs[my_index], - &new_link) != GC_SUCCESS) { - GC_printf("GC_move_long_link(new_link) failed\n"); - FAIL; - } - if (GC_unregister_long_link(&new_link) == 0) { - GC_printf("GC_unregister_long_link failed\n"); - FAIL; - } - if (GC_move_long_link(&live_long_refs[my_index], - &new_link) != GC_NOT_FOUND) { - GC_printf("GC_move_long_link(new_link) failed 2\n"); - FAIL; - } - if (GC_REGISTER_LONG_LINK(&live_long_refs[my_index], result) != 0) { - GC_printf("GC_register_long_link failed 2\n"); - FAIL; - } -# endif -# endif - GC_reachable_here(result); - } - return(result); -} - -void chktree(tn *t, int n) -{ - if (n == 0 && t != 0) { - GC_printf("Clobbered a leaf - collector is broken\n"); - FAIL; - } - if (n == 0) return; - if (t -> level != n) { - GC_printf("Lost a node at level %d - collector is broken\n", n); - FAIL; - } - if (counter++ % 373 == 0) { - collectable_count++; - (void) GC_MALLOC(counter%5001); - } - chktree(t -> lchild, n-1); - if (counter++ % 73 == 0) { - collectable_count++; - (void) GC_MALLOC(counter%373); - } - chktree(t -> rchild, n-1); -} - - -#if defined(GC_PTHREADS) -pthread_key_t fl_key; - -void * alloc8bytes(void) -{ -# if defined(SMALL_CONFIG) || defined(GC_DEBUG) - collectable_count++; - return(GC_MALLOC(8)); -# else - void ** my_free_list_ptr; - void * my_free_list; - - my_free_list_ptr = (void **)pthread_getspecific(fl_key); - if (my_free_list_ptr == 0) { - uncollectable_count++; - my_free_list_ptr = GC_NEW_UNCOLLECTABLE(void *); - CHECK_OUT_OF_MEMORY(my_free_list_ptr); - if (pthread_setspecific(fl_key, my_free_list_ptr) != 0) { - GC_printf("pthread_setspecific failed\n"); - FAIL; - } - } - my_free_list = *my_free_list_ptr; - if (my_free_list == 0) { - my_free_list = GC_malloc_many(8); - CHECK_OUT_OF_MEMORY(my_free_list); - } - *my_free_list_ptr = GC_NEXT(my_free_list); - GC_NEXT(my_free_list) = 0; - collectable_count++; - return(my_free_list); -# endif -} - -#else -# define alloc8bytes() GC_MALLOC_ATOMIC(8) -#endif - -void alloc_small(int n) -{ - int i; - - for (i = 0; i < n; i += 8) { - atomic_count++; - if (alloc8bytes() == 0) { - GC_printf("Out of memory\n"); - FAIL; - } - } -} - -# if defined(THREADS) && defined(GC_DEBUG) -# ifdef VERY_SMALL_CONFIG -# define TREE_HEIGHT 12 -# else -# define TREE_HEIGHT 15 -# endif -# else -# ifdef VERY_SMALL_CONFIG -# define TREE_HEIGHT 13 -# else -# define TREE_HEIGHT 16 -# endif -# endif -void tree_test(void) -{ - tn * root; - int i; - - root = mktree(TREE_HEIGHT); -# ifndef VERY_SMALL_CONFIG - alloc_small(5000000); -# endif - chktree(root, TREE_HEIGHT); - if (finalized_count && ! dropped_something) { - GC_printf("Premature finalization - collector is broken\n"); - FAIL; - } - dropped_something = 1; - GC_noop1((word)root); /* Root needs to remain live until */ - /* dropped_something is set. */ - root = mktree(TREE_HEIGHT); - chktree(root, TREE_HEIGHT); - for (i = TREE_HEIGHT; i >= 0; i--) { - root = mktree(i); - chktree(root, i); - } -# ifndef VERY_SMALL_CONFIG - alloc_small(5000000); -# endif -} - -unsigned n_tests = 0; - -const GC_word bm_huge[10] = { - 0xffffffff, - 0xffffffff, - 0xffffffff, - 0xffffffff, - 0xffffffff, - 0xffffffff, - 0xffffffff, - 0xffffffff, - 0xffffffff, - 0x00ffffff, -}; - -/* A very simple test of explicitly typed allocation */ -void typed_test(void) -{ - GC_word * old, * new; - GC_word bm3 = 0x3; - GC_word bm2 = 0x2; - GC_word bm_large = 0xf7ff7fff; - GC_descr d1 = GC_make_descriptor(&bm3, 2); - GC_descr d2 = GC_make_descriptor(&bm2, 2); - GC_descr d3 = GC_make_descriptor(&bm_large, 32); - GC_descr d4 = GC_make_descriptor(bm_huge, 320); - GC_word * x = (GC_word *)GC_malloc_explicitly_typed(2000, d4); - int i; - -# ifndef LINT - (void)GC_make_descriptor(&bm_large, 32); -# endif - collectable_count++; - old = 0; - for (i = 0; i < 4000; i++) { - collectable_count++; - new = (GC_word *) GC_malloc_explicitly_typed(4 * sizeof(GC_word), d1); - CHECK_OUT_OF_MEMORY(new); - if (0 != new[0] || 0 != new[1]) { - GC_printf("Bad initialization by GC_malloc_explicitly_typed\n"); - FAIL; - } - new[0] = 17; - new[1] = (GC_word)old; - old = new; - collectable_count++; - new = (GC_word *) GC_malloc_explicitly_typed(4 * sizeof(GC_word), d2); - CHECK_OUT_OF_MEMORY(new); - new[0] = 17; - new[1] = (GC_word)old; - old = new; - collectable_count++; - new = (GC_word *) GC_malloc_explicitly_typed(33 * sizeof(GC_word), d3); - CHECK_OUT_OF_MEMORY(new); - new[0] = 17; - new[1] = (GC_word)old; - old = new; - collectable_count++; - new = (GC_word *) GC_calloc_explicitly_typed(4, 2 * sizeof(GC_word), - d1); - CHECK_OUT_OF_MEMORY(new); - new[0] = 17; - new[1] = (GC_word)old; - old = new; - collectable_count++; - if (i & 0xff) { - new = (GC_word *) GC_calloc_explicitly_typed(7, 3 * sizeof(GC_word), - d2); - } else { - new = (GC_word *) GC_calloc_explicitly_typed(1001, - 3 * sizeof(GC_word), - d2); - if (new && (0 != new[0] || 0 != new[1])) { - GC_printf("Bad initialization by GC_malloc_explicitly_typed\n"); - FAIL; - } - } - CHECK_OUT_OF_MEMORY(new); - new[0] = 17; - new[1] = (GC_word)old; - old = new; - } - for (i = 0; i < 20000; i++) { - if (new[0] != 17) { - GC_printf("typed alloc failed at %lu\n", (unsigned long)i); - FAIL; - } - new[0] = 0; - old = new; - new = (GC_word *)(old[1]); - } - GC_gcollect(); - GC_noop1((word)x); -} - -int fail_count = 0; - -void GC_CALLBACK fail_proc1(void *x GC_ATTR_UNUSED) -{ - fail_count++; -} - -static void uniq(void *p, ...) { - va_list a; - void *q[100]; - int n = 0, i, j; - q[n++] = p; - va_start(a,p); - for (;(q[n] = va_arg(a,void *)) != NULL;n++) ; - va_end(a); - for (i=0; i= (n)) -#endif - -void * GC_CALLBACK inc_int_counter(void *pcounter) -{ - ++(*(int *)pcounter); - return NULL; -} - -void run_one_test(void) -{ -# ifndef DBG_HDRS_ALL - char *x; - char **z; -# ifdef LINT - char *y = 0; -# else - char *y = (char *)(GC_word)fail_proc1; -# endif - CLOCK_TYPE typed_time; -# endif - CLOCK_TYPE start_time; - CLOCK_TYPE reverse_time; - CLOCK_TYPE tree_time; - unsigned long time_diff; - -# ifdef FIND_LEAK - GC_printf( - "This test program is not designed for leak detection mode\n"); - GC_printf("Expect lots of problems\n"); -# endif - GC_FREE(0); -# ifdef THREADS - if (!GC_thread_is_registered()) { - GC_printf("Current thread is not registered with GC\n"); - FAIL; - } -# endif -# ifndef DBG_HDRS_ALL - collectable_count += 3; - if ((GC_size(GC_malloc(7)) != 8 && - GC_size(GC_malloc(7)) != MIN_WORDS * sizeof(GC_word)) - || GC_size(GC_malloc(15)) != 16) { - GC_printf("GC_size produced unexpected results\n"); - FAIL; - } - collectable_count += 1; - if (GC_size(GC_malloc(0)) != MIN_WORDS * sizeof(GC_word)) { - GC_printf("GC_malloc(0) failed: GC_size returns %lu\n", - (unsigned long)GC_size(GC_malloc(0))); - FAIL; - } - collectable_count += 1; - if (GC_size(GC_malloc_uncollectable(0)) != MIN_WORDS * sizeof(GC_word)) { - GC_printf("GC_malloc_uncollectable(0) failed\n"); - FAIL; - } - GC_is_valid_displacement_print_proc = fail_proc1; - GC_is_visible_print_proc = fail_proc1; - collectable_count += 1; - x = GC_malloc(16); - if (GC_base(GC_PTR_ADD(x, 13)) != x) { - GC_printf("GC_base(heap ptr) produced incorrect result\n"); - FAIL; - } - if (!GC_is_heap_ptr(x)) { - GC_printf("GC_is_heap_ptr(heap_ptr) produced incorrect result\n"); - FAIL; - } - if (GC_is_heap_ptr(&x)) { - GC_printf("GC_is_heap_ptr(&local_var) produced incorrect result\n"); - FAIL; - } - if (GC_is_heap_ptr(&fail_count) || GC_is_heap_ptr(NULL)) { - GC_printf("GC_is_heap_ptr(&global_var) produced incorrect result\n"); - FAIL; - } - (void)GC_PRE_INCR(x, 0); - (void)GC_POST_INCR(x); - (void)GC_POST_DECR(x); - if (GC_base(x) != x) { - GC_printf("Bad INCR/DECR result\n"); - FAIL; - } -# ifndef PCR - if (GC_base(y) != 0) { - GC_printf("GC_base(fn_ptr) produced incorrect result\n"); - FAIL; - } -# endif - if (GC_same_obj(x+5, x) != x + 5) { - GC_printf("GC_same_obj produced incorrect result\n"); - FAIL; - } - if (GC_is_visible(y) != y || GC_is_visible(x) != x) { - GC_printf("GC_is_visible produced incorrect result\n"); - FAIL; - } - z = GC_malloc(8); - GC_PTR_STORE(z, x); - if (*z != x) { - GC_printf("GC_PTR_STORE failed: %p != %p\n", (void *)(*z), (void *)x); - FAIL; - } - if (!TEST_FAIL_COUNT(1)) { -# if!(defined(POWERPC) || defined(IA64)) || defined(M68K) - /* On POWERPCs function pointers point to a descriptor in the */ - /* data segment, so there should have been no failures. */ - /* The same applies to IA64. Something similar seems to */ - /* be going on with NetBSD/M68K. */ - GC_printf("GC_is_visible produced wrong failure indication\n"); - FAIL; -# endif - } - if (GC_is_valid_displacement(y) != y - || GC_is_valid_displacement(x) != x - || GC_is_valid_displacement(x + 3) != x + 3) { - GC_printf("GC_is_valid_displacement produced incorrect result\n"); - FAIL; - } - { - size_t i; - - (void)GC_malloc(17); - for (i = sizeof(GC_word); i < 512; i *= 2) { - GC_word result = (GC_word) GC_memalign(i, 17); - if (result % i != 0 || result == 0 || *(int *)result != 0) FAIL; - } - } -# ifndef ALL_INTERIOR_POINTERS -# if defined(RS6000) || defined(POWERPC) - if (!TEST_FAIL_COUNT(1)) -# else - if (!TEST_FAIL_COUNT(GC_get_all_interior_pointers() ? 1 : 2)) -# endif - { - GC_printf( - "GC_is_valid_displacement produced wrong failure indication\n"); - FAIL; - } -# endif -# endif /* DBG_HDRS_ALL */ - /* Test floating point alignment */ - collectable_count += 2; - { - double *dp = GC_MALLOC(sizeof(double)); - CHECK_OUT_OF_MEMORY(dp); - *dp = 1.0; - dp = GC_MALLOC(sizeof(double)); - CHECK_OUT_OF_MEMORY(dp); - *dp = 1.0; - } - /* Test size 0 allocation a bit more */ - { - size_t i; - for (i = 0; i < 10000; ++i) { - (void)GC_MALLOC(0); - GC_FREE(GC_MALLOC(0)); - (void)GC_MALLOC_ATOMIC(0); - GC_FREE(GC_MALLOC_ATOMIC(0)); - test_generic_malloc_or_special(GC_malloc_atomic(1)); - } - } -# ifdef GC_GCJ_SUPPORT - GC_REGISTER_DISPLACEMENT(sizeof(struct fake_vtable *)); - GC_init_gcj_malloc(0, (void *)(GC_word)fake_gcj_mark_proc); -# endif - /* Make sure that fn arguments are visible to the collector. */ - uniq( - GC_malloc(12), GC_malloc(12), GC_malloc(12), - (GC_gcollect(),GC_malloc(12)), - GC_malloc(12), GC_malloc(12), GC_malloc(12), - (GC_gcollect(),GC_malloc(12)), - GC_malloc(12), GC_malloc(12), GC_malloc(12), - (GC_gcollect(),GC_malloc(12)), - GC_malloc(12), GC_malloc(12), GC_malloc(12), - (GC_gcollect(),GC_malloc(12)), - GC_malloc(12), GC_malloc(12), GC_malloc(12), - (GC_gcollect(),GC_malloc(12)), - (void *)0); - /* GC_malloc(0) must return NULL or something we can deallocate. */ - GC_free(GC_malloc(0)); - GC_free(GC_malloc_atomic(0)); - GC_free(GC_malloc(0)); - GC_free(GC_malloc_atomic(0)); -# ifndef NO_TEST_HANDLE_FORK - GC_atfork_prepare(); - if (fork() != 0) { - GC_atfork_parent(); - if (print_stats) - GC_log_printf("Forked child process (or failed)\n"); - } else { - GC_atfork_child(); - if (print_stats) - GC_log_printf("Started a child process\n"); -# ifdef THREADS -# ifdef PARALLEL_MARK - GC_gcollect(); /* no parallel markers */ -# endif - GC_start_mark_threads(); -# endif - GC_gcollect(); -# ifdef THREADS - tiny_reverse_test(0); - GC_gcollect(); -# endif - if (print_stats) - GC_log_printf("Finished a child process\n"); - exit(0); - } -# endif - /* Repeated list reversal test. */ - GET_TIME(start_time); - reverse_test(); - if (print_stats) { - GET_TIME(reverse_time); - time_diff = MS_TIME_DIFF(reverse_time, start_time); - GC_log_printf("-------------Finished reverse_test at time %u (%p)\n", - (unsigned) time_diff, (void *)&start_time); - } -# ifndef DBG_HDRS_ALL - typed_test(); - if (print_stats) { - GET_TIME(typed_time); - time_diff = MS_TIME_DIFF(typed_time, start_time); - GC_log_printf("-------------Finished typed_test at time %u (%p)\n", - (unsigned) time_diff, (void *)&start_time); - } -# endif /* DBG_HDRS_ALL */ - tree_test(); - if (print_stats) { - GET_TIME(tree_time); - time_diff = MS_TIME_DIFF(tree_time, start_time); - GC_log_printf("-------------Finished tree_test at time %u (%p)\n", - (unsigned) time_diff, (void *)&start_time); - } - /* Run reverse_test a second time, so we hopefully notice corruption. */ - reverse_test(); - if (print_stats) { - GET_TIME(reverse_time); - time_diff = MS_TIME_DIFF(reverse_time, start_time); - GC_log_printf( - "-------------Finished second reverse_test at time %u (%p)\n", - (unsigned)time_diff, (void *)&start_time); - } - /* GC_allocate_ml and GC_need_to_lock are no longer exported, and */ - /* AO_fetch_and_add1() may be unavailable to update a counter. */ - (void)GC_call_with_alloc_lock(inc_int_counter, &n_tests); - if (print_stats) - GC_log_printf("Finished %p\n", (void *)&start_time); -} - -#define NUMBER_ROUND_UP(v, bound) ((((v) + (bound) - 1) / (bound)) * (bound)) - -void check_heap_stats(void) -{ - size_t max_heap_sz; - int i; -# ifndef GC_NO_FINALIZATION - int still_live; -# ifndef GC_LONG_REFS_NOT_NEEDED - int still_long_live = 0; -# endif -# ifdef FINALIZE_ON_DEMAND - int late_finalize_count = 0; -# endif -# endif - -# ifdef VERY_SMALL_CONFIG - /* The upper bounds are a guess, which has been empirically */ - /* adjusted. On low end uniprocessors with incremental GC */ - /* these may be particularly dubious, since empirically the */ - /* heap tends to grow largely as a result of the GC not */ - /* getting enough cycles. */ -# if CPP_WORDSZ == 64 - max_heap_sz = 4500000; -# else - max_heap_sz = 2800000; -# endif -# else -# if CPP_WORDSZ == 64 - max_heap_sz = 23000000; -# else - max_heap_sz = 16000000; -# endif -# endif -# ifdef GC_DEBUG - max_heap_sz *= 2; -# ifdef SAVE_CALL_CHAIN - max_heap_sz *= 3; -# ifdef SAVE_CALL_COUNT - max_heap_sz += max_heap_sz * SAVE_CALL_COUNT/4; -# endif -# endif -# endif - max_heap_sz *= n_tests; -# if defined(USE_MMAP) || defined(MSWIN32) - max_heap_sz = NUMBER_ROUND_UP(max_heap_sz, 4 * 1024 * 1024); -# endif - /* Garbage collect repeatedly so that all inaccessible objects */ - /* can be finalized. */ - while (GC_collect_a_little()) { } - for (i = 0; i < 16; i++) { - GC_gcollect(); -# ifndef GC_NO_FINALIZATION -# ifdef FINALIZE_ON_DEMAND - late_finalize_count += -# endif - GC_invoke_finalizers(); -# endif - } - if (print_stats) { - struct GC_stack_base sb; - int res = GC_get_stack_base(&sb); - - if (res == GC_SUCCESS) { - GC_log_printf("Primordial thread stack bottom: %p\n", sb.mem_base); - } else if (res == GC_UNIMPLEMENTED) { - GC_log_printf("GC_get_stack_base() unimplemented\n"); - } else { - GC_printf("GC_get_stack_base() failed: %d\n", res); - FAIL; - } - } - GC_printf("Completed %u tests\n", n_tests); - GC_printf("Allocated %d collectable objects\n", collectable_count); - GC_printf("Allocated %d uncollectable objects\n", - uncollectable_count); - GC_printf("Allocated %d atomic objects\n", atomic_count); - GC_printf("Allocated %d stubborn objects\n", stubborn_count); - GC_printf("Finalized %d/%d objects - ", - finalized_count, finalizable_count); -# ifndef GC_NO_FINALIZATION -# ifdef FINALIZE_ON_DEMAND - if (finalized_count != late_finalize_count) { - GC_printf("Demand finalization error\n"); - FAIL; - } -# endif - if (finalized_count > finalizable_count - || finalized_count < finalizable_count/2) { - GC_printf("finalization is probably broken\n"); - FAIL; - } else { - GC_printf("finalization is probably ok\n"); - } - still_live = 0; - for (i = 0; i < MAX_FINALIZED; i++) { - if (live_indicators[i] != 0) { - still_live++; - } -# ifndef GC_LONG_REFS_NOT_NEEDED - if (live_long_refs[i] != NULL) { - still_long_live++; - } -# endif - } - i = finalizable_count - finalized_count - still_live; - if (0 != i) { - GC_printf("%d disappearing links remain and %d more objects " - "were not finalized\n", still_live, i); - if (i > 10) { - GC_printf("\tVery suspicious!\n"); - } else { - GC_printf("\tSlightly suspicious, but probably OK\n"); - } - } -# ifndef GC_LONG_REFS_NOT_NEEDED - if (0 != still_long_live) { - GC_printf("%d 'long' links remain\n", still_long_live); - } -# endif -# endif - GC_printf("Total number of bytes allocated is %lu\n", - (unsigned long)GC_get_total_bytes()); - GC_printf("Final heap size is %lu bytes\n", - (unsigned long)GC_get_heap_size()); - if (GC_get_total_bytes() < n_tests * -# ifdef VERY_SMALL_CONFIG - 2700000 -# else - 33500000 -# endif - ) { - GC_printf("Incorrect execution - missed some allocations\n"); - FAIL; - } - if (GC_get_heap_size() + GC_get_unmapped_bytes() > max_heap_sz) { - GC_printf("Unexpected heap growth - collector may be broken" - " (heapsize: %lu, expected: %lu)\n", - (unsigned long)(GC_get_heap_size() + GC_get_unmapped_bytes()), - (unsigned long)max_heap_sz); - FAIL; - } - -# ifndef GC_GET_HEAP_USAGE_NOT_NEEDED - /* Get global counters (just to check the functions work). */ - GC_get_heap_usage_safe(NULL, NULL, NULL, NULL, NULL); - { - struct GC_prof_stats_s stats; - (void)GC_get_prof_stats(&stats, sizeof(stats)); -# ifdef THREADS - (void)GC_get_prof_stats_unsafe(&stats, sizeof(stats)); -# endif - } -# endif - -# ifdef THREADS - GC_unregister_my_thread(); /* just to check it works (for main) */ -# endif - GC_printf("Completed %u collections", (unsigned)GC_get_gc_no()); -# ifdef PARALLEL_MARK - GC_printf(" (using %d marker threads)", GC_get_parallel() + 1); -# endif - GC_printf("\n" "Collector appears to work\n"); -} - -#if defined(MACOS) -void SetMinimumStack(long minSize) -{ - long newApplLimit; - - if (minSize > LMGetDefltStack()) - { - newApplLimit = (long) GetApplLimit() - - (minSize - LMGetDefltStack()); - SetApplLimit((Ptr) newApplLimit); - MaxApplZone(); - } -} - -#define cMinStackSpace (512L * 1024L) - -#endif - -void GC_CALLBACK warn_proc(char *msg, GC_word p) -{ - GC_printf(msg, (unsigned long)p); - /*FAIL;*/ -} - -#if defined(MSWINCE) && defined(UNDER_CE) -# define WINMAIN_LPTSTR LPWSTR -#else -# define WINMAIN_LPTSTR LPSTR -#endif - -#if !defined(PCR) && !defined(GC_WIN32_THREADS) && !defined(GC_PTHREADS) \ - || defined(LINT) -#if defined(MSWIN32) && !defined(__MINGW32__) || defined(MSWINCE) - int APIENTRY WinMain(HINSTANCE instance GC_ATTR_UNUSED, - HINSTANCE prev GC_ATTR_UNUSED, - WINMAIN_LPTSTR cmd GC_ATTR_UNUSED, - int n GC_ATTR_UNUSED) -#elif defined(RTEMS) -# include -# define CONFIGURE_APPLICATION_NEEDS_CLOCK_DRIVER -# define CONFIGURE_APPLICATION_NEEDS_CONSOLE_DRIVER -# define CONFIGURE_RTEMS_INIT_TASKS_TABLE -# define CONFIGURE_MAXIMUM_TASKS 1 -# define CONFIGURE_INIT -# define CONFIGURE_INIT_TASK_STACK_SIZE (64*1024) -# include - rtems_task Init(rtems_task_argument ignord) -#else - int main(void) -#endif -{ - n_tests = 0; -# if defined(MACOS) - /* Make sure we have lots and lots of stack space. */ - SetMinimumStack(cMinStackSpace); - /* Cheat and let stdio initialize toolbox for us. */ - printf("Testing GC Macintosh port\n"); -# endif - GC_COND_INIT(); - GC_set_warn_proc(warn_proc); -# if (defined(MPROTECT_VDB) || defined(PROC_VDB) || defined(GWW_VDB)) \ - && !defined(MAKE_BACK_GRAPH) && !defined(NO_INCREMENTAL) - GC_enable_incremental(); - GC_printf("Switched to incremental mode\n"); -# if defined(MPROTECT_VDB) - GC_printf("Emulating dirty bits with mprotect/signals\n"); -# else -# ifdef PROC_VDB - GC_printf("Reading dirty bits from /proc\n"); -# elif defined(GWW_VDB) - GC_printf("Using GetWriteWatch-based implementation\n"); -# else - GC_printf("Using DEFAULT_VDB dirty bit implementation\n"); -# endif -# endif -# endif - run_one_test(); - check_heap_stats(); -# ifndef MSWINCE - fflush(stdout); -# endif -# ifdef MSWIN32 - GC_win32_free_heap(); -# endif -# ifdef RTEMS - exit(0); -# else - return(0); -# endif -} -# endif - -#if defined(GC_WIN32_THREADS) && !defined(GC_PTHREADS) - -DWORD __stdcall thr_run_one_test(void * arg GC_ATTR_UNUSED) -{ - run_one_test(); - return 0; -} - -#ifdef MSWINCE -HANDLE win_created_h; -HWND win_handle; - -LRESULT CALLBACK window_proc(HWND hwnd, UINT uMsg, WPARAM wParam, - LPARAM lParam) -{ - LRESULT ret = 0; - switch (uMsg) { - case WM_HIBERNATE: - GC_printf("Received WM_HIBERNATE, calling GC_gcollect\n"); - /* Force "unmap as much memory as possible" mode. */ - GC_gcollect_and_unmap(); - break; - case WM_CLOSE: - GC_printf("Received WM_CLOSE, closing window\n"); - DestroyWindow(hwnd); - break; - case WM_DESTROY: - PostQuitMessage(0); - break; - default: - ret = DefWindowProc(hwnd, uMsg, wParam, lParam); - break; - } - return ret; -} - -DWORD __stdcall thr_window(void * arg GC_ATTR_UNUSED) -{ - WNDCLASS win_class = { - CS_NOCLOSE, - window_proc, - 0, - 0, - GetModuleHandle(NULL), - NULL, - NULL, - (HBRUSH)(COLOR_APPWORKSPACE+1), - NULL, - TEXT("GCtestWindow") - }; - MSG msg; - - if (!RegisterClass(&win_class)) - FAIL; - - win_handle = CreateWindowEx( - 0, - TEXT("GCtestWindow"), - TEXT("GCtest"), - 0, - CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, - NULL, - NULL, - GetModuleHandle(NULL), - NULL); - - if (win_handle == NULL) - FAIL; - - SetEvent(win_created_h); - - ShowWindow(win_handle, SW_SHOW); - UpdateWindow(win_handle); - - while (GetMessage(&msg, NULL, 0, 0)) { - TranslateMessage(&msg); - DispatchMessage(&msg); - } - - return 0; -} -#endif - -int APIENTRY WinMain(HINSTANCE instance GC_ATTR_UNUSED, - HINSTANCE prev GC_ATTR_UNUSED, - WINMAIN_LPTSTR cmd GC_ATTR_UNUSED, - int n GC_ATTR_UNUSED) -{ -# if NTHREADS > 0 - HANDLE h[NTHREADS]; - int i; -# endif -# ifdef MSWINCE - HANDLE win_thr_h; -# endif - DWORD thread_id; -# if defined(GC_DLL) && !defined(GC_NO_THREADS_DISCOVERY) \ - && !defined(MSWINCE) && !defined(THREAD_LOCAL_ALLOC) \ - && !defined(PARALLEL_MARK) - GC_use_threads_discovery(); - /* Test with implicit thread registration if possible. */ - GC_printf("Using DllMain to track threads\n"); -# endif - GC_COND_INIT(); -# if !defined(MAKE_BACK_GRAPH) && !defined(NO_INCREMENTAL) - GC_enable_incremental(); -# endif - InitializeCriticalSection(&incr_cs); - GC_set_warn_proc(warn_proc); -# ifdef MSWINCE - win_created_h = CreateEvent(NULL, FALSE, FALSE, NULL); - if (win_created_h == (HANDLE)NULL) { - GC_printf("Event creation failed %d\n", (int)GetLastError()); - FAIL; - } - win_thr_h = GC_CreateThread(NULL, 0, thr_window, 0, 0, &thread_id); - if (win_thr_h == (HANDLE)NULL) { - GC_printf("Thread creation failed %d\n", (int)GetLastError()); - FAIL; - } - if (WaitForSingleObject(win_created_h, INFINITE) != WAIT_OBJECT_0) - FAIL; - CloseHandle(win_created_h); -# endif -# if NTHREADS > 0 - for (i = 0; i < NTHREADS; i++) { - h[i] = GC_CreateThread(NULL, 0, thr_run_one_test, 0, 0, &thread_id); - if (h[i] == (HANDLE)NULL) { - GC_printf("Thread creation failed %d\n", (int)GetLastError()); - FAIL; - } - } -# endif /* NTHREADS > 0 */ - run_one_test(); -# if NTHREADS > 0 - for (i = 0; i < NTHREADS; i++) { - if (WaitForSingleObject(h[i], INFINITE) != WAIT_OBJECT_0) { - GC_printf("Thread wait failed %d\n", (int)GetLastError()); - FAIL; - } - } -# endif /* NTHREADS > 0 */ -# ifdef MSWINCE - PostMessage(win_handle, WM_CLOSE, 0, 0); - if (WaitForSingleObject(win_thr_h, INFINITE) != WAIT_OBJECT_0) - FAIL; -# endif - check_heap_stats(); - return(0); -} - -#endif /* GC_WIN32_THREADS */ - - -#ifdef PCR -int test(void) -{ - PCR_Th_T * th1; - PCR_Th_T * th2; - int code; - - n_tests = 0; - /* GC_enable_incremental(); */ - GC_set_warn_proc(warn_proc); - th1 = PCR_Th_Fork(run_one_test, 0); - th2 = PCR_Th_Fork(run_one_test, 0); - run_one_test(); - if (PCR_Th_T_Join(th1, &code, NIL, PCR_allSigsBlocked, PCR_waitForever) - != PCR_ERes_okay || code != 0) { - GC_printf("Thread 1 failed\n"); - } - if (PCR_Th_T_Join(th2, &code, NIL, PCR_allSigsBlocked, PCR_waitForever) - != PCR_ERes_okay || code != 0) { - GC_printf("Thread 2 failed\n"); - } - check_heap_stats(); - return(0); -} -#endif - -#if defined(GC_PTHREADS) -void * thr_run_one_test(void * arg GC_ATTR_UNUSED) -{ - run_one_test(); - return(0); -} - -#ifdef GC_DEBUG -# define GC_free GC_debug_free -#endif - -int main(void) -{ - pthread_t th[NTHREADS]; - pthread_attr_t attr; - int code; - int i; -# ifdef GC_IRIX_THREADS - /* Force a larger stack to be preallocated */ - /* Since the initial can't always grow later. */ - *((volatile char *)&code - 1024*1024) = 0; /* Require 1 MB */ -# endif /* GC_IRIX_THREADS */ -# if defined(GC_HPUX_THREADS) - /* Default stack size is too small, especially with the 64 bit ABI */ - /* Increase it. */ - if (pthread_default_stacksize_np(1024*1024, 0) != 0) { - GC_printf("pthread_default_stacksize_np failed\n"); - } -# endif /* GC_HPUX_THREADS */ -# ifdef PTW32_STATIC_LIB - pthread_win32_process_attach_np (); - pthread_win32_thread_attach_np (); -# endif -# if defined(GC_DARWIN_THREADS) && !defined(GC_NO_THREADS_DISCOVERY) \ - && !defined(DARWIN_DONT_PARSE_STACK) && !defined(THREAD_LOCAL_ALLOC) - /* Test with the Darwin implicit thread registration. */ - GC_use_threads_discovery(); - GC_printf("Using Darwin task-threads-based world stop and push\n"); -# endif - GC_COND_INIT(); - - if ((code = pthread_attr_init(&attr)) != 0) { - GC_printf("pthread_attr_init failed, error=%d\n", code); - FAIL; - } -# if defined(GC_IRIX_THREADS) || defined(GC_FREEBSD_THREADS) \ - || defined(GC_DARWIN_THREADS) || defined(GC_AIX_THREADS) \ - || defined(GC_OPENBSD_THREADS) - if ((code = pthread_attr_setstacksize(&attr, 1000 * 1024)) != 0) { - GC_printf("pthread_attr_setstacksize failed, error=%d\n", code); - FAIL; - } -# endif - n_tests = 0; -# if (defined(MPROTECT_VDB)) && !defined(REDIRECT_MALLOC) \ - && !defined(MAKE_BACK_GRAPH) && !defined(USE_PROC_FOR_LIBRARIES) \ - && !defined(NO_INCREMENTAL) - GC_enable_incremental(); - GC_printf("Switched to incremental mode\n"); -# if defined(MPROTECT_VDB) - GC_printf("Emulating dirty bits with mprotect/signals\n"); -# else -# ifdef PROC_VDB - GC_printf("Reading dirty bits from /proc\n"); -# else - GC_printf("Using DEFAULT_VDB dirty bit implementation\n"); -# endif -# endif -# endif - GC_set_warn_proc(warn_proc); - if ((code = pthread_key_create(&fl_key, 0)) != 0) { - GC_printf("Key creation failed %d\n", code); - FAIL; - } - for (i = 0; i < NTHREADS; ++i) { - if ((code = pthread_create(th+i, &attr, thr_run_one_test, 0)) != 0) { - GC_printf("Thread %d creation failed %d\n", i, code); - FAIL; - } - } - run_one_test(); - for (i = 0; i < NTHREADS; ++i) { - if ((code = pthread_join(th[i], 0)) != 0) { - GC_printf("Thread %d failed %d\n", i, code); - FAIL; - } - } - check_heap_stats(); - (void)fflush(stdout); - (void)pthread_attr_destroy(&attr); -# ifdef PTW32_STATIC_LIB - pthread_win32_thread_detach_np (); - pthread_win32_process_detach_np (); -# endif - return(0); -} -#endif /* GC_PTHREADS */ diff -Nru ecl-16.1.2/src/bdwgc/tests/test_cpp.cc ecl-16.1.3+ds/src/bdwgc/tests/test_cpp.cc --- ecl-16.1.2/src/bdwgc/tests/test_cpp.cc 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/tests/test_cpp.cc 1970-01-01 00:00:00.000000000 +0000 @@ -1,314 +0,0 @@ -/**************************************************************************** -Copyright (c) 1994 by Xerox Corporation. All rights reserved. - -THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED -OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - -Permission is hereby granted to use or copy this program for any -purpose, provided the above notices are retained on all copies. -Permission to modify the code and to distribute modified code is -granted, provided the above notices are retained, and a notice that -the code was modified is included with the above copyright notice. -**************************************************************************** - -usage: test_cpp number-of-iterations - -This program tries to test the specific C++ functionality provided by -gc_c++.h that isn't tested by the more general test routines of the -collector. - -A recommended value for number-of-iterations is 10, which will take a -few minutes to complete. - -***************************************************************************/ - -#ifdef HAVE_CONFIG_H -# include "config.h" -#endif - -#undef GC_BUILD - -#include "gc_cpp.h" - -#include -#include -#include - -#ifndef DONT_USE_STD_ALLOCATOR -# include "gc_allocator.h" -#else - /* Note: This works only for ancient STL versions. */ -# include "new_gc_alloc.h" -#endif - -extern "C" { -# include "private/gcconfig.h" - -# ifndef GC_API_PRIV -# define GC_API_PRIV GC_API -# endif - GC_API_PRIV void GC_printf(const char * format, ...); - /* Use GC private output to reach the same log file. */ - /* Don't include gc_priv.h, since that may include Windows system */ - /* header files that don't take kindly to this context. */ -} - -#ifdef MSWIN32 -# include -#endif - -#ifdef GC_NAME_CONFLICT -# define USE_GC GC_NS_QUALIFY(UseGC) - struct foo * GC; -#else -# define USE_GC GC_NS_QUALIFY(GC) -#endif - -#define my_assert( e ) \ - if (! (e)) { \ - GC_printf( "Assertion failure in " __FILE__ ", line %d: " #e "\n", \ - __LINE__ ); \ - exit( 1 ); } - -#if __GNUC__ > 3 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 4) -# define ATTR_UNUSED __attribute__((__unused__)) -#else -# define ATTR_UNUSED /* empty */ -#endif - -class A {public: - /* An uncollectible class. */ - - A( int iArg ): i( iArg ) {} - void Test( int iArg ) { - my_assert( i == iArg );} - int i;}; - - -class B: public GC_NS_QUALIFY(gc), public A { public: - /* A collectible class. */ - - B( int j ): A( j ) {} - ~B() { - my_assert( deleting );} - static void Deleting( int on ) { - deleting = on;} - static int deleting;}; - -int B::deleting = 0; - - -class C: public GC_NS_QUALIFY(gc_cleanup), public A { public: - /* A collectible class with cleanup and virtual multiple inheritance. */ - - C( int levelArg ): A( levelArg ), level( levelArg ) { - nAllocated++; - if (level > 0) { - left = new C( level - 1 ); - right = new C( level - 1 );} - else { - left = right = 0;}} - ~C() { - this->A::Test( level ); - nFreed++; - my_assert( level == 0 ? - left == 0 && right == 0 : - level == left->level + 1 && level == right->level + 1 ); - left = right = 0; - level = -123456;} - static void Test() { - my_assert( nFreed <= nAllocated && nFreed >= .8 * nAllocated );} - - static int nFreed; - static int nAllocated; - int level; - C* left; - C* right;}; - -int C::nFreed = 0; -int C::nAllocated = 0; - - -class D: public GC_NS_QUALIFY(gc) { public: - /* A collectible class with a static member function to be used as - an explicit clean-up function supplied to ::new. */ - - D( int iArg ): i( iArg ) { - nAllocated++;} - static void CleanUp( void* obj, void* data ) { - D* self = (D*) obj; - nFreed++; - my_assert( self->i == (int) (GC_word) data );} - static void Test() { - my_assert( nFreed >= .8 * nAllocated );} - - int i; - static int nFreed; - static int nAllocated;}; - -int D::nFreed = 0; -int D::nAllocated = 0; - - -class E: public GC_NS_QUALIFY(gc_cleanup) { public: - /* A collectible class with clean-up for use by F. */ - - E() { - nAllocated++;} - ~E() { - nFreed++;} - - static int nFreed; - static int nAllocated;}; - -int E::nFreed = 0; -int E::nAllocated = 0; - - -class F: public E {public: - /* A collectible class with clean-up, a base with clean-up, and a - member with clean-up. */ - - F() { - nAllocated++;} - ~F() { - nFreed++;} - static void Test() { - my_assert( nFreed >= .8 * nAllocated ); - my_assert( 2 * nFreed == E::nFreed );} - - E e; - static int nFreed; - static int nAllocated;}; - -int F::nFreed = 0; -int F::nAllocated = 0; - - -GC_word Disguise( void* p ) { - return ~ (GC_word) p;} - -void* Undisguise( GC_word i ) { - return (void*) ~ i;} - -#ifdef MSWIN32 -int APIENTRY WinMain( HINSTANCE instance ATTR_UNUSED, - HINSTANCE prev ATTR_UNUSED, LPSTR cmd, int cmdShow ATTR_UNUSED ) -{ - int argc = 0; - char* argv[ 3 ]; - - if (cmd != 0) - for (argc = 1; argc < (int)(sizeof(argv) / sizeof(argv[0])); argc++) { - argv[ argc ] = strtok( argc == 1 ? cmd : 0, " \t" ); - if (0 == argv[ argc ]) break;} -#elif defined(MACOS) - int main() { - char* argv_[] = {"test_cpp", "10"}; // MacOS doesn't have a commandline - argv = argv_; - argc = sizeof(argv_)/sizeof(argv_[0]); -#else - int main( int argc, char* argv[] ) { -#endif - - GC_set_all_interior_pointers(1); - /* needed due to C++ multiple inheritance used */ - - GC_INIT(); - - int i, iters, n; -# ifndef DONT_USE_STD_ALLOCATOR - int *x = gc_allocator().allocate(1); - int *xio; - xio = gc_allocator_ignore_off_page().allocate(1); - (void)xio; - int **xptr = traceable_allocator().allocate(1); -# else - int *x = (int *)gc_alloc::allocate(sizeof(int)); -# endif - *x = 29; -# ifndef DONT_USE_STD_ALLOCATOR - if (!xptr) { - fprintf(stderr, "Out of memory!\n"); - exit(3); - } - *xptr = x; - x = 0; -# endif - if (argc != 2 || (0 >= (n = atoi( argv[ 1 ] )))) { - GC_printf( "usage: test_cpp number-of-iterations\nAssuming 10 iters\n" ); - n = 10;} - - for (iters = 1; iters <= n; iters++) { - GC_printf( "Starting iteration %d\n", iters ); - - /* Allocate some uncollectible As and disguise their pointers. - Later we'll check to see if the objects are still there. We're - checking to make sure these objects really are uncollectible. */ - GC_word as[ 1000 ]; - GC_word bs[ 1000 ]; - for (i = 0; i < 1000; i++) { - as[ i ] = Disguise( new (GC_NS_QUALIFY(NoGC)) A(i) ); - bs[ i ] = Disguise( new (GC_NS_QUALIFY(NoGC)) B(i) ); } - - /* Allocate a fair number of finalizable Cs, Ds, and Fs. - Later we'll check to make sure they've gone away. */ - for (i = 0; i < 1000; i++) { - C* c = new C( 2 ); - C c1( 2 ); /* stack allocation should work too */ - D* d; - F* f; - d = ::new (USE_GC, D::CleanUp, (void*)(GC_word)i) D( i ); - (void)d; - f = new F; - (void)f; - if (0 == i % 10) delete c;} - - /* Allocate a very large number of collectible As and Bs and - drop the references to them immediately, forcing many - collections. */ - for (i = 0; i < 1000000; i++) { - A* a; - a = new (USE_GC) A( i ); - (void)a; - B* b; - b = new B( i ); - (void)b; - b = new (USE_GC) B( i ); - if (0 == i % 10) { - B::Deleting( 1 ); - delete b; - B::Deleting( 0 );} -# ifdef FINALIZE_ON_DEMAND - GC_invoke_finalizers(); -# endif - } - - /* Make sure the uncollectible As and Bs are still there. */ - for (i = 0; i < 1000; i++) { - A* a = (A*) Undisguise( as[ i ] ); - B* b = (B*) Undisguise( bs[ i ] ); - a->Test( i ); - delete a; - b->Test( i ); - B::Deleting( 1 ); - delete b; - B::Deleting( 0 ); -# ifdef FINALIZE_ON_DEMAND - GC_invoke_finalizers(); -# endif - } - - /* Make sure most of the finalizable Cs, Ds, and Fs have - gone away. */ - C::Test(); - D::Test(); - F::Test();} - -# ifndef DONT_USE_STD_ALLOCATOR - x = *xptr; -# endif - my_assert (29 == x[0]); - GC_printf( "The test appears to have succeeded.\n" ); - return( 0 ); -} diff -Nru ecl-16.1.2/src/bdwgc/tests/tests.am ecl-16.1.3+ds/src/bdwgc/tests/tests.am --- ecl-16.1.2/src/bdwgc/tests/tests.am 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/tests/tests.am 1970-01-01 00:00:00.000000000 +0000 @@ -1,119 +0,0 @@ -# -# THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED -# OR IMPLIED. ANY USE IS AT YOUR OWN RISK. -# -# Permission is hereby granted to use or copy this program -# for any purpose, provided the above notices are retained on all copies. -# Permission to modify the code and to distribute modified code is granted, -# provided the above notices are retained, and a notice that the code was -# modified is included with the above copyright notice. - -# Common libs to _LDADD for all tests. -test_ldadd = $(top_builddir)/libgc.la $(EXTRA_TEST_LIBS) - -TESTS += gctest$(EXEEXT) -check_PROGRAMS += gctest -gctest_SOURCES = tests/test.c -gctest_LDADD = $(test_ldadd) -if THREADS -gctest_LDADD += $(THREADDLLIBS) -endif -gctest_DEPENDENCIES = $(top_builddir)/libgc.la - -TESTS += leaktest$(EXEEXT) -check_PROGRAMS += leaktest -leaktest_SOURCES = tests/leak_test.c -leaktest_LDADD = $(test_ldadd) - -TESTS += middletest$(EXEEXT) -check_PROGRAMS += middletest -middletest_SOURCES = tests/middle.c -middletest_LDADD = $(test_ldadd) - -TESTS += smashtest$(EXEEXT) -check_PROGRAMS += smashtest -smashtest_SOURCES = tests/smash_test.c -smashtest_LDADD = $(test_ldadd) - -TESTS += hugetest$(EXEEXT) -check_PROGRAMS += hugetest -hugetest_SOURCES = tests/huge_test.c -hugetest_LDADD = $(test_ldadd) - -TESTS += realloc_test$(EXEEXT) -check_PROGRAMS += realloc_test -realloc_test_SOURCES = tests/realloc_test.c -realloc_test_LDADD = $(test_ldadd) - -TESTS += staticrootstest$(EXEEXT) -check_PROGRAMS += staticrootstest -staticrootstest_SOURCES = tests/staticrootstest.c -staticrootstest_CFLAGS = -DSTATICROOTSLIB2 -staticrootstest_LDADD = $(test_ldadd) libstaticrootslib_test.la \ - libstaticrootslib2_test.la -check_LTLIBRARIES += libstaticrootslib_test.la libstaticrootslib2_test.la -libstaticrootslib_test_la_SOURCES = tests/staticrootslib.c -libstaticrootslib_test_la_LIBADD = $(test_ldadd) -libstaticrootslib_test_la_LDFLAGS = -version-info 1:3:0 -no-undefined \ - -rpath /nowhere -libstaticrootslib_test_la_DEPENDENCIES = $(top_builddir)/libgc.la -libstaticrootslib2_test_la_SOURCES = tests/staticrootslib.c -libstaticrootslib2_test_la_LIBADD = $(test_ldadd) -libstaticrootslib2_test_la_CFLAGS = -DSTATICROOTSLIB2 -libstaticrootslib2_test_la_LDFLAGS = -version-info 1:3:0 -no-undefined \ - -rpath /nowhere - -if KEEP_BACK_PTRS -TESTS += tracetest$(EXEEXT) -check_PROGRAMS += tracetest -tracetest_SOURCES = tests/trace_test.c -tracetest_LDADD = $(test_ldadd) -endif - -if THREADS -TESTS += threadleaktest$(EXEEXT) -check_PROGRAMS += threadleaktest -threadleaktest_SOURCES = tests/thread_leak_test.c -threadleaktest_LDADD = $(test_ldadd) $(THREADDLLIBS) - -TESTS += threadkey_test$(EXEEXT) -check_PROGRAMS += threadkey_test -threadkey_test_SOURCES = tests/threadkey_test.c -threadkey_test_LDADD = $(test_ldadd) $(THREADDLLIBS) - -TESTS += subthreadcreate_test$(EXEEXT) -check_PROGRAMS += subthreadcreate_test -subthreadcreate_test_SOURCES = tests/subthread_create.c -subthreadcreate_test_LDADD = $(test_ldadd) $(THREADDLLIBS) - -TESTS += initsecondarythread_test$(EXEEXT) -check_PROGRAMS += initsecondarythread_test -initsecondarythread_test_SOURCES = tests/initsecondarythread.c -initsecondarythread_test_LDADD = $(test_ldadd) $(THREADDLLIBS) -endif - -if CPLUSPLUS -TESTS += test_cpp$(EXEEXT) -check_PROGRAMS += test_cpp -test_cpp_SOURCES = tests/test_cpp.cc -if AVOID_CPP_LIB -test_cpp_LDADD = gc_cpp.o $(test_ldadd) $(CXXLIBS) -else -test_cpp_LDADD = libgccpp.la $(test_ldadd) $(CXXLIBS) -endif -endif - -if ENABLE_DISCLAIM -TESTS += disclaim_test -check_PROGRAMS += disclaim_test -disclaim_test_SOURCES = tests/disclaim_test.c -disclaim_test_LDADD = $(test_ldadd) -if THREADS -disclaim_test_LDADD += $(THREADDLLIBS) -endif - -TESTS += disclaim_bench -check_PROGRAMS += disclaim_bench -disclaim_bench_SOURCES = tests/disclaim_bench.c -disclaim_bench_LDADD = $(test_ldadd) -endif diff -Nru ecl-16.1.2/src/bdwgc/tests/threadkey_test.c ecl-16.1.3+ds/src/bdwgc/tests/threadkey_test.c --- ecl-16.1.2/src/bdwgc/tests/threadkey_test.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/tests/threadkey_test.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,100 +0,0 @@ - -#ifdef HAVE_CONFIG_H -# include "config.h" -#endif - -#ifndef GC_THREADS -# define GC_THREADS -#endif - -#define GC_NO_THREAD_REDIRECTS 1 - -#include "gc.h" - -#if (!defined(GC_PTHREADS) || defined(GC_SOLARIS_THREADS) \ - || defined(__native_client__)) && !defined(SKIP_THREADKEY_TEST) - /* FIXME: Skip this test on Solaris for now. The test may fail on */ - /* other targets as well. Currently, tested only on Linux, Cygwin */ - /* and Darwin. */ -# define SKIP_THREADKEY_TEST -#endif - -#ifdef SKIP_THREADKEY_TEST - -#include - -int main (void) -{ - printf("threadkey_test skipped\n"); - return 0; -} - -#else - -#include - -pthread_key_t key; - -#ifdef GC_SOLARIS_THREADS - /* pthread_once_t key_once = { PTHREAD_ONCE_INIT }; */ -#else - pthread_once_t key_once = PTHREAD_ONCE_INIT; -#endif - -void * entry (void *arg) -{ - pthread_setspecific(key, - (void *)GC_HIDE_POINTER(GC_STRDUP("hello, world"))); - return arg; -} - -void * GC_CALLBACK on_thread_exit_inner (struct GC_stack_base * sb, void * arg) -{ - int res = GC_register_my_thread (sb); - pthread_t t; - int creation_res; /* Used to suppress a warning about */ - /* unchecked pthread_create() result. */ - - creation_res = GC_pthread_create (&t, NULL, entry, NULL); - if (res == GC_SUCCESS) - GC_unregister_my_thread (); - - return arg ? (void*)(GC_word)creation_res : 0; -} - -void on_thread_exit (void *v) -{ - GC_call_with_stack_base (on_thread_exit_inner, v); -} - -void make_key (void) -{ - pthread_key_create (&key, on_thread_exit); -} - -#ifndef LIMIT -# define LIMIT 30 -#endif - -int main (void) -{ - int i; - GC_INIT (); - -# ifdef GC_SOLARIS_THREADS - pthread_key_create (&key, on_thread_exit); -# else - pthread_once (&key_once, make_key); -# endif - for (i = 0; i < LIMIT; i++) { - pthread_t t; - void *res; - if (GC_pthread_create (&t, NULL, entry, NULL) == 0 - && (i & 1) != 0) { - (void)GC_pthread_join(t, &res); - } - } - return 0; -} - -#endif /* !SKIP_THREADKEY_TEST */ diff -Nru ecl-16.1.2/src/bdwgc/tests/thread_leak_test.c ecl-16.1.3+ds/src/bdwgc/tests/thread_leak_test.c --- ecl-16.1.2/src/bdwgc/tests/thread_leak_test.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/tests/thread_leak_test.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,88 +0,0 @@ - -#ifdef HAVE_CONFIG_H -# include "config.h" -#endif - -#ifndef GC_THREADS -# define GC_THREADS -#endif - -#include "leak_detector.h" - -#ifdef GC_PTHREADS -# include -#else -# include -#endif - -#include - -#ifdef GC_PTHREADS - void * test(void * arg) -#else - DWORD WINAPI test(LPVOID arg) -#endif -{ - int *p[10]; - int i; - for (i = 0; i < 10; ++i) { - p[i] = malloc(sizeof(int)+i); - } - CHECK_LEAKS(); - for (i = 1; i < 10; ++i) { - free(p[i]); - } -# ifdef GC_PTHREADS - return arg; -# else - return (DWORD)(GC_word)arg; -# endif -} - -#define NTHREADS 5 - -int main(void) { - int i; -# ifdef GC_PTHREADS - pthread_t t[NTHREADS]; -# else - HANDLE t[NTHREADS]; - DWORD thread_id; -# endif - int code; - - GC_set_find_leak(1); /* for new collect versions not compiled */ - /* with -DFIND_LEAK. */ - GC_INIT(); - - for (i = 0; i < NTHREADS; ++i) { -# ifdef GC_PTHREADS - code = pthread_create(t + i, 0, test, 0); -# else - t[i] = CreateThread(NULL, 0, test, 0, 0, &thread_id); - code = t[i] != NULL ? 0 : (int)GetLastError(); -# endif - if (code != 0) { - fprintf(stderr, "Thread creation failed %d\n", code); - exit(2); - } - } - - for (i = 0; i < NTHREADS; ++i) { -# ifdef GC_PTHREADS - code = pthread_join(t[i], 0); -# else - code = WaitForSingleObject(t[i], INFINITE) == WAIT_OBJECT_0 ? 0 : - (int)GetLastError(); -# endif - if (code != 0) { - fprintf(stderr, "Thread join failed %d\n", code); - exit(2); - } - } - - CHECK_LEAKS(); - CHECK_LEAKS(); - CHECK_LEAKS(); - return 0; -} diff -Nru ecl-16.1.2/src/bdwgc/tests/trace_test.c ecl-16.1.3+ds/src/bdwgc/tests/trace_test.c --- ecl-16.1.2/src/bdwgc/tests/trace_test.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/tests/trace_test.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,41 +0,0 @@ -#include -#include - -#ifndef GC_DEBUG -# define GC_DEBUG -#endif - -#include "gc.h" -#include "gc_backptr.h" - -struct treenode { - struct treenode *x; - struct treenode *y; -} * root[10]; - -struct treenode * mktree(int i) { - struct treenode * r = GC_MALLOC(sizeof(struct treenode)); - if (0 == i) return 0; - if (1 == i) r = GC_MALLOC_ATOMIC(sizeof(struct treenode)); - if (r == NULL) { - fprintf(stderr, "Out of memory\n"); - exit(1); - } - r -> x = mktree(i-1); - r -> y = mktree(i-1); - return r; -} - -int main(void) -{ - int i; - GC_INIT(); - for (i = 0; i < 10; ++i) { - root[i] = mktree(12); - } - GC_generate_random_backtrace(); - GC_generate_random_backtrace(); - GC_generate_random_backtrace(); - GC_generate_random_backtrace(); - return 0; -} diff -Nru ecl-16.1.2/src/bdwgc/thread_local_alloc.c ecl-16.1.3+ds/src/bdwgc/thread_local_alloc.c --- ecl-16.1.2/src/bdwgc/thread_local_alloc.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/thread_local_alloc.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,328 +0,0 @@ -/* - * Copyright (c) 2000-2005 by Hewlett-Packard Company. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#include "private/gc_priv.h" - -#if defined(THREAD_LOCAL_ALLOC) - -#ifndef THREADS -# error "invalid config - THREAD_LOCAL_ALLOC requires GC_THREADS" -#endif - -#include "private/thread_local_alloc.h" - -#include - -#if defined(USE_COMPILER_TLS) - __thread -#elif defined(USE_WIN32_COMPILER_TLS) - __declspec(thread) -#endif -GC_key_t GC_thread_key; - -static GC_bool keys_initialized; - -#ifdef ENABLE_DISCLAIM - GC_INNER ptr_t * GC_finalized_objfreelist = NULL; - /* This variable is declared here to prevent linking of */ - /* fnlz_mlc module unless the client uses the latter one. */ -#endif - -/* Return a single nonempty freelist fl to the global one pointed to */ -/* by gfl. */ - -static void return_single_freelist(void *fl, void **gfl) -{ - void *q, **qptr; - - if (*gfl == 0) { - *gfl = fl; - } else { - GC_ASSERT(GC_size(fl) == GC_size(*gfl)); - /* Concatenate: */ - qptr = &(obj_link(fl)); - while ((word)(q = *qptr) >= HBLKSIZE) - qptr = &(obj_link(q)); - GC_ASSERT(0 == q); - *qptr = *gfl; - *gfl = fl; - } -} - -/* Recover the contents of the freelist array fl into the global one gfl.*/ -/* We hold the allocator lock. */ -static void return_freelists(void **fl, void **gfl) -{ - int i; - - for (i = 1; i < TINY_FREELISTS; ++i) { - if ((word)(fl[i]) >= HBLKSIZE) { - return_single_freelist(fl[i], gfl+i); - } - /* Clear fl[i], since the thread structure may hang around. */ - /* Do it in a way that is likely to trap if we access it. */ - fl[i] = (ptr_t)HBLKSIZE; - } - /* The 0 granule freelist really contains 1 granule objects. */ -# ifdef GC_GCJ_SUPPORT - if (fl[0] == ERROR_FL) return; -# endif - if ((word)(fl[0]) >= HBLKSIZE) { - return_single_freelist(fl[0], gfl+1); - } -} - -/* Each thread structure must be initialized. */ -/* This call must be made from the new thread. */ -GC_INNER void GC_init_thread_local(GC_tlfs p) -{ - int i; - - GC_ASSERT(I_HOLD_LOCK()); - if (!EXPECT(keys_initialized, TRUE)) { - GC_ASSERT((word)&GC_thread_key % sizeof(word) == 0); - if (0 != GC_key_create(&GC_thread_key, 0)) { - ABORT("Failed to create key for local allocator"); - } - keys_initialized = TRUE; - } - if (0 != GC_setspecific(GC_thread_key, p)) { - ABORT("Failed to set thread specific allocation pointers"); - } - for (i = 1; i < TINY_FREELISTS; ++i) { - p -> ptrfree_freelists[i] = (void *)(word)1; - p -> normal_freelists[i] = (void *)(word)1; -# ifdef GC_GCJ_SUPPORT - p -> gcj_freelists[i] = (void *)(word)1; -# endif -# ifdef ENABLE_DISCLAIM - p -> finalized_freelists[i] = (void *)(word)1; -# endif - } - /* Set up the size 0 free lists. */ - /* We now handle most of them like regular free lists, to ensure */ - /* That explicit deallocation works. However, allocation of a */ - /* size 0 "gcj" object is always an error. */ - p -> ptrfree_freelists[0] = (void *)(word)1; - p -> normal_freelists[0] = (void *)(word)1; -# ifdef GC_GCJ_SUPPORT - p -> gcj_freelists[0] = ERROR_FL; -# endif -# ifdef ENABLE_DISCLAIM - p -> finalized_freelists[0] = (void *)(word)1; -# endif -} - -/* We hold the allocator lock. */ -GC_INNER void GC_destroy_thread_local(GC_tlfs p) -{ - /* We currently only do this from the thread itself or from */ - /* the fork handler for a child process. */ - return_freelists(p -> ptrfree_freelists, GC_aobjfreelist); - return_freelists(p -> normal_freelists, GC_objfreelist); -# ifdef GC_GCJ_SUPPORT - return_freelists(p -> gcj_freelists, (void **)GC_gcjobjfreelist); -# endif -# ifdef ENABLE_DISCLAIM - return_freelists(p -> finalized_freelists, - (void **)GC_finalized_objfreelist); -# endif -} - -#ifdef GC_ASSERTIONS - /* Defined in pthread_support.c or win32_threads.c. */ - GC_bool GC_is_thread_tsd_valid(void *tsd); -#endif - -GC_API GC_ATTR_MALLOC void * GC_CALL GC_malloc(size_t bytes) -{ - size_t granules = ROUNDED_UP_GRANULES(bytes); - void *tsd; - void *result; - void **tiny_fl; - -# if !defined(USE_PTHREAD_SPECIFIC) && !defined(USE_WIN32_SPECIFIC) - GC_key_t k = GC_thread_key; - if (EXPECT(0 == k, FALSE)) { - /* We haven't yet run GC_init_parallel. That means */ - /* we also aren't locking, so this is fairly cheap. */ - return GC_core_malloc(bytes); - } - tsd = GC_getspecific(k); -# else - tsd = GC_getspecific(GC_thread_key); -# endif -# if !defined(USE_COMPILER_TLS) && !defined(USE_WIN32_COMPILER_TLS) - if (EXPECT(0 == tsd, FALSE)) { - return GC_core_malloc(bytes); - } -# endif - GC_ASSERT(GC_is_initialized); - - GC_ASSERT(GC_is_thread_tsd_valid(tsd)); - - tiny_fl = ((GC_tlfs)tsd) -> normal_freelists; - GC_FAST_MALLOC_GRANS(result, granules, tiny_fl, DIRECT_GRANULES, - NORMAL, GC_core_malloc(bytes), obj_link(result)=0); -# ifdef LOG_ALLOCS - GC_log_printf("GC_malloc(%lu) returned %p, recent GC #%lu\n", - (unsigned long)bytes, result, (unsigned long)GC_gc_no); -# endif - return result; -} - -GC_API GC_ATTR_MALLOC void * GC_CALL GC_malloc_atomic(size_t bytes) -{ - size_t granules = ROUNDED_UP_GRANULES(bytes); - void *tsd; - void *result; - void **tiny_fl; - -# if !defined(USE_PTHREAD_SPECIFIC) && !defined(USE_WIN32_SPECIFIC) - GC_key_t k = GC_thread_key; - if (EXPECT(0 == k, FALSE)) { - /* We haven't yet run GC_init_parallel. That means */ - /* we also aren't locking, so this is fairly cheap. */ - return GC_core_malloc_atomic(bytes); - } - tsd = GC_getspecific(k); -# else - tsd = GC_getspecific(GC_thread_key); -# endif -# if !defined(USE_COMPILER_TLS) && !defined(USE_WIN32_COMPILER_TLS) - if (EXPECT(0 == tsd, FALSE)) { - return GC_core_malloc_atomic(bytes); - } -# endif - GC_ASSERT(GC_is_initialized); - tiny_fl = ((GC_tlfs)tsd) -> ptrfree_freelists; - GC_FAST_MALLOC_GRANS(result, granules, tiny_fl, DIRECT_GRANULES, PTRFREE, - GC_core_malloc_atomic(bytes), (void)0 /* no init */); - return result; -} - -#ifdef GC_GCJ_SUPPORT - -# include "atomic_ops.h" /* for AO_compiler_barrier() */ - -# include "include/gc_gcj.h" - -/* Gcj-style allocation without locks is extremely tricky. The */ -/* fundamental issue is that we may end up marking a free list, which */ -/* has freelist links instead of "vtable" pointers. That is usually */ -/* OK, since the next object on the free list will be cleared, and */ -/* will thus be interpreted as containing a zero descriptor. That's */ -/* fine if the object has not yet been initialized. But there are */ -/* interesting potential races. */ -/* In the case of incremental collection, this seems hopeless, since */ -/* the marker may run asynchronously, and may pick up the pointer to */ -/* the next freelist entry (which it thinks is a vtable pointer), get */ -/* suspended for a while, and then see an allocated object instead */ -/* of the vtable. This may be avoidable with either a handshake with */ -/* the collector or, probably more easily, by moving the free list */ -/* links to the second word of each object. The latter isn't a */ -/* universal win, since on architecture like Itanium, nonzero offsets */ -/* are not necessarily free. And there may be cache fill order issues. */ -/* For now, we punt with incremental GC. This probably means that */ -/* incremental GC should be enabled before we fork a second thread. */ -/* Unlike the other thread local allocation calls, we assume that the */ -/* collector has been explicitly initialized. */ -GC_API GC_ATTR_MALLOC void * GC_CALL GC_gcj_malloc(size_t bytes, - void * ptr_to_struct_containing_descr) -{ - if (EXPECT(GC_incremental, FALSE)) { - return GC_core_gcj_malloc(bytes, ptr_to_struct_containing_descr); - } else { - size_t granules = ROUNDED_UP_GRANULES(bytes); - void *result; - void **tiny_fl = ((GC_tlfs)GC_getspecific(GC_thread_key)) - -> gcj_freelists; - GC_ASSERT(GC_gcj_malloc_initialized); - GC_FAST_MALLOC_GRANS(result, granules, tiny_fl, DIRECT_GRANULES, - GC_gcj_kind, - GC_core_gcj_malloc(bytes, - ptr_to_struct_containing_descr), - {AO_compiler_barrier(); - *(void **)result = ptr_to_struct_containing_descr;}); - /* This forces the initialization of the "method ptr". */ - /* This is necessary to ensure some very subtle properties */ - /* required if a GC is run in the middle of such an allocation. */ - /* Here we implicitly also assume atomicity for the free list. */ - /* and method pointer assignments. */ - /* We must update the freelist before we store the pointer. */ - /* Otherwise a GC at this point would see a corrupted */ - /* free list. */ - /* A real memory barrier is not needed, since the */ - /* action of stopping this thread will cause prior writes */ - /* to complete. */ - /* We assert that any concurrent marker will stop us. */ - /* Thus it is impossible for a mark procedure to see the */ - /* allocation of the next object, but to see this object */ - /* still containing a free list pointer. Otherwise the */ - /* marker, by misinterpreting the freelist link as a vtable */ - /* pointer, might find a random "mark descriptor" in the next */ - /* object. */ - return result; - } -} - -#endif /* GC_GCJ_SUPPORT */ - -/* The thread support layer must arrange to mark thread-local */ -/* free lists explicitly, since the link field is often */ -/* invisible to the marker. It knows how to find all threads; */ -/* we take care of an individual thread freelist structure. */ -GC_INNER void GC_mark_thread_local_fls_for(GC_tlfs p) -{ - ptr_t q; - int j; - - for (j = 0; j < TINY_FREELISTS; ++j) { - q = p -> ptrfree_freelists[j]; - if ((word)q > HBLKSIZE) GC_set_fl_marks(q); - q = p -> normal_freelists[j]; - if ((word)q > HBLKSIZE) GC_set_fl_marks(q); -# ifdef GC_GCJ_SUPPORT - if (j > 0) { - q = p -> gcj_freelists[j]; - if ((word)q > HBLKSIZE) GC_set_fl_marks(q); - } -# endif /* GC_GCJ_SUPPORT */ -# ifdef ENABLE_DISCLAIM - q = p -> finalized_freelists[j]; - if ((word)q > HBLKSIZE) - GC_set_fl_marks(q); -# endif - } -} - -#if defined(GC_ASSERTIONS) - /* Check that all thread-local free-lists in p are completely marked. */ - void GC_check_tls_for(GC_tlfs p) - { - int j; - - for (j = 1; j < TINY_FREELISTS; ++j) { - GC_check_fl_marks(&p->ptrfree_freelists[j]); - GC_check_fl_marks(&p->normal_freelists[j]); -# ifdef GC_GCJ_SUPPORT - GC_check_fl_marks(&p->gcj_freelists[j]); -# endif -# ifdef ENABLE_DISCLAIM - GC_check_fl_marks(&p->finalized_freelists[j]); -# endif - } - } -#endif /* GC_ASSERTIONS */ - -#endif /* THREAD_LOCAL_ALLOC */ diff -Nru ecl-16.1.2/src/bdwgc/TODO ecl-16.1.3+ds/src/bdwgc/TODO --- ecl-16.1.2/src/bdwgc/TODO 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/TODO 1970-01-01 00:00:00.000000000 +0000 @@ -1,93 +0,0 @@ -== TODO tasks == - -tests/CMakeLists.txt: Add more executables (see tests.am). - -Use C++0x ATM (atomic memory operations) if available (either from the -compiler runtime, provided it is reliable, or from the future libatomic_ops). - -Add a test for libatomic_ops minimal version required (at compile time). - -windows-untested: Remove if CMake can generate MS Visual Studio 6.0, 7.0, 8.0 -project files. - -BCC_MAKEFILE: Remove if CMake can generate Makefile for this compiler. -(Same for WCC_MAKEFILE, OS2_MAKEFILE, NT_MAKEFILE, NT_STATIC_THREADS_MAKEFILE, -NT_X64_STATIC_THREADS_MAKEFILE, NT_X64_THREADS_MAKEFILE, digimars.mak, -gc.mak.) - -BCC_MAKEFILE, EMX_MAKEFILE, OS2_MAKEFILE, PCR-Makefile, WCC_MAKEFILE, -SMakefile.amiga, digimars.mak: move to "build" folder. - -Do type-punning via union (instead of pointer type cast) to enable safe -'-fstrict-aliasing' compiler optimization option. - -Support CAN_HANDLE_FORK if USE_WINALLOC for Cygwin. - -Use madvise() on Unix/Cygwin. - -Use Linux VM pressure notifications to force GC and unmapping. - -Filter overlaps in GC_add_roots for Unix (same as for Win32). - -Do not resume parallel markers if only 1 core is active at GC mark start. - -Enable GC_set_handle_fork(1) for Darwin with GC_dirty_maintained on (both -single and multi-threaded modes). - -Add more fields to GC_prof_stats_s (potential candidates are: -requested_heapsize, max_large_allocd_bytes, large_allocd_bytes, bytes_dropped, -bytes_finalized, bytes_freed, finalizer_bytes_freed, composite_in_use, -atomic_in_use, GC_n_heap_sects, GC_n_memory, GC_black_list_spacing, -GC_root_size, GC_max_root_size, n_root_sets, GC_total_stacksize, -GC_collect_at_heapsize, GC_fail_count, GC_mark_stack_size, last_fo_entries, -last_bytes_finalized, last_finalizer_notification_no, GC_dl_entries, -GC_old_dl_entries, GC_used_heap_size_after_full, GC_total_stack_black_listed, -signed_log_dl_table_size, GC_n_rescuing_pages, signed_log_fo_table_size, -GC_excl_table_entries, GC_stack_last_cleared, GC_bytes_allocd_at_reset, -GC_n_heap_bases, registered_threads_cnt, GC_max_thread_index, GC_block_count, -GC_unlocked_count, GC_hdr_cache_hits, GC_hdr_cache_misses, GC_spin_count). - -Support musl libc (on sabotage linux). - -== FIXME tasks == - -Solaris + GCC: make check fails with the message: -libc.so.1: gctest: fatal: libgcc_s.so.1: open failed: No such file or directory - -Solaris/x86[_64]: gctest fails if PROC_VDB. - -Sun C++ 5.11: test_cpp.cc:237: Error: Too few arguments in call to -"operator delete(void*, GCPlacement, extern "C" void(*)(void*,void*), void*)". - -Darwin/x86_64: deadlock might occur between: -dlclose() -> GC_dyld_image_remove() -> GC_lock() and -GC_inner_start_routine()+LOCK -> dyld_stub_binder_(). - -HP-UX 11.00 with the vendor cc fails: -Perhaps GC_push_regs was configured incorrectly? FAIL: gctest. - -Linux/mips64el (N32): threadleaktest crashes once every 3-4 runs (SIGSEGV in -GC_delete_gc_thread(t=0) called from GC_pthread_join) if configured with ---disable-shared. - -FreeBSD 9.0/x86_64 (gcc-4.2.1-20070831): gctest segfaults sometimes in -GC_typed_mark_proc if configured with --enable-threads=pthreads. - -OpenBSD 5.1/i386: leaktest fails rarely (unless logging redirected to file): -cannot write to stderr from GC_gcollect invoked from 'atexit' hook. - -NetBSD 5.1/x86: threadkey_test hangs sometimes. - -Cygwin: subthread_create: exception STATUS_ACCESS_VIOLATION. - -Cygwin: gctest: assertion failure at UNLOCK in GC_fork_parent_proc. - -Mingw-w32: gctest: "SuspendThread failed" sometimes occurs (if -GC_DLL+GC_THREADS+GC_ASSERTIONS). - -Mingw: gctest (compiled with PARALLEL_MARK): launched in gdb with breakpoint -at GC_mark_local, after several breakpoint hits, crashes with the messages -"Caught ACCESS_VIOLATION in marker; memory mapping disappeared" and -"Tried to start parallel mark in bad state", or enters deadlock. - -Mingw: test_cpp: crashes at some iteration if big argument (e.g., 1000) given. diff -Nru ecl-16.1.2/src/bdwgc/tools/add_gc_prefix.c ecl-16.1.3+ds/src/bdwgc/tools/add_gc_prefix.c --- ecl-16.1.2/src/bdwgc/tools/add_gc_prefix.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/tools/add_gc_prefix.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,13 +0,0 @@ -# include -# include - -int main(int argc, char ** argv) -{ - int i; - - for (i = 1; i < argc; i++) { - printf("gc-%d.%d.%d/%s ", - GC_VERSION_MAJOR, GC_VERSION_MINOR, GC_VERSION_MICRO, argv[i]); - } - return(0); -} diff -Nru ecl-16.1.2/src/bdwgc/tools/callprocs.sh ecl-16.1.3+ds/src/bdwgc/tools/callprocs.sh --- ecl-16.1.2/src/bdwgc/tools/callprocs.sh 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/tools/callprocs.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,4 +0,0 @@ -#!/bin/sh -GC_DEBUG=1 -export GC_DEBUG -$* 2>&1 | awk '{print "0x3e=c\""$0"\""};/^\t##PC##=/ {if ($2 != 0) {print $2"?i"}}' | adb $1 | sed "s/^ >/>/" diff -Nru ecl-16.1.2/src/bdwgc/tools/gcname.c ecl-16.1.3+ds/src/bdwgc/tools/gcname.c --- ecl-16.1.2/src/bdwgc/tools/gcname.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/tools/gcname.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,9 +0,0 @@ -#include -#include - -int main(void) -{ - printf("gc-%d.%d.%d", - GC_VERSION_MAJOR, GC_VERSION_MINOR, GC_VERSION_MICRO); - return 0; -} diff -Nru ecl-16.1.2/src/bdwgc/tools/if_mach.c ecl-16.1.3+ds/src/bdwgc/tools/if_mach.c --- ecl-16.1.2/src/bdwgc/tools/if_mach.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/tools/if_mach.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,24 +0,0 @@ -/* Conditionally execute a command based on machine and OS from gcconfig.h */ - -# include "private/gc_priv.h" -# include -# include -# include - -int main(int argc, char **argv) -{ - if (argc < 4) goto Usage; - if (strcmp(MACH_TYPE, argv[1]) != 0) return(0); - if (strcmp(OS_TYPE, "") != 0 && strcmp(argv[2], "") != 0 - && strcmp(OS_TYPE, argv[2]) != 0) return(0); - fprintf(stderr, "^^^^Starting command^^^^\n"); - fflush(stdout); - execvp(argv[3], argv+3); - perror("Couldn't execute"); - -Usage: - fprintf(stderr, "Usage: %s mach_type os_type command\n", argv[0]); - fprintf(stderr, "Currently mach_type = %s, os_type = %s\n", - MACH_TYPE, OS_TYPE); - return(1); -} diff -Nru ecl-16.1.2/src/bdwgc/tools/if_not_there.c ecl-16.1.3+ds/src/bdwgc/tools/if_not_there.c --- ecl-16.1.2/src/bdwgc/tools/if_not_there.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/tools/if_not_there.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,38 +0,0 @@ -/* Conditionally execute a command based if the file argv[1] doesn't exist */ -/* Except for execvp, we stick to ANSI C. */ - -# include "private/gc_priv.h" -# include -# include -# include -#ifdef __DJGPP__ -#include -#endif /* __DJGPP__ */ - -int main(int argc, char **argv) -{ - FILE * f; -#ifdef __DJGPP__ - DIR * d; -#endif /* __DJGPP__ */ - if (argc < 3) goto Usage; - if ((f = fopen(argv[1], "rb")) != 0 - || (f = fopen(argv[1], "r")) != 0) { - fclose(f); - return(0); - } -#ifdef __DJGPP__ - if ((d = opendir(argv[1])) != 0) { - closedir(d); - return(0); - } -#endif - printf("^^^^Starting command^^^^\n"); - fflush(stdout); - execvp(argv[2], argv+2); - exit(1); - -Usage: - fprintf(stderr, "Usage: %s file_name command\n", argv[0]); - return(1); -} diff -Nru ecl-16.1.2/src/bdwgc/tools/setjmp_t.c ecl-16.1.3+ds/src/bdwgc/tools/setjmp_t.c --- ecl-16.1.2/src/bdwgc/tools/setjmp_t.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/tools/setjmp_t.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,145 +0,0 @@ -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -/* Check whether setjmp actually saves registers in jmp_buf. */ -/* If it doesn't, the generic mark_regs code won't work. */ -/* Compilers vary as to whether they will put x in a */ -/* (callee-save) register without -O. The code is */ -/* contrived such that any decent compiler should put x in */ -/* a callee-save register with -O. Thus it is */ -/* recommended that this be run optimized. (If the machine */ -/* has no callee-save registers, then the generic code is */ -/* safe, but this will not be noticed by this piece of */ -/* code.) This test appears to be far from perfect. */ -#include -#include -#include -#include "private/gc_priv.h" - -#ifdef OS2 -/* GETPAGESIZE() is set to getpagesize() by default, but that */ -/* doesn't really exist, and the collector doesn't need it. */ -#define INCL_DOSFILEMGR -#define INCL_DOSMISC -#define INCL_DOSERRORS -#include - -int getpagesize(void) -{ - ULONG result[1]; - - if (DosQuerySysInfo(QSV_PAGE_SIZE, QSV_PAGE_SIZE, - (void *)result, sizeof(ULONG)) != NO_ERROR) { - fprintf(stderr, "DosQuerySysInfo failed\n"); - result[0] = 4096; - } - return((int)(result[0])); -} -#elif defined(MSWIN32) || defined(MSWINCE) || defined(CYGWIN32) -# include - int getpagesize(void) - { - SYSTEM_INFO sysinfo; - GetSystemInfo(&sysinfo); - return sysinfo.dwPageSize; - } -#endif - -struct { - char a_a; - char * a_b; -} a; - -int * nested_sp(void) -{ - volatile word sp; - sp = (word)(&sp); - return (int *)sp; -} - -int main(void) -{ - volatile word sp; - long ps = GETPAGESIZE(); - jmp_buf b; - register int x = (int)strlen("a"); /* 1, slightly disguised */ - static int y = 0; - - sp = (word)(&sp); - printf("This appears to be a %s running %s\n", MACH_TYPE, OS_TYPE); - if ((word)nested_sp() < sp) { - printf("Stack appears to grow down, which is the default.\n"); - printf("A good guess for STACKBOTTOM on this machine is 0x%lx.\n", - ((unsigned long)sp + ps) & ~(ps-1)); - } else { - printf("Stack appears to grow up.\n"); - printf("Define STACK_GROWS_UP in gc_private.h\n"); - printf("A good guess for STACKBOTTOM on this machine is 0x%lx.\n", - ((unsigned long)sp + ps) & ~(ps-1)); - } - printf("Note that this may vary between machines of ostensibly\n"); - printf("the same architecture (e.g. Sun 3/50s and 3/80s).\n"); - printf("On many machines the value is not fixed.\n"); - printf("A good guess for ALIGNMENT on this machine is %ld.\n", - (unsigned long)((word)(&(a.a_b)) - (word)(&a))); - - printf("The following is a very dubious test of one root marking" - " strategy.\n"); - printf("Results may not be accurate/useful:\n"); - /* Encourage the compiler to keep x in a callee-save register */ - x = 2*x-1; - printf("\n"); - x = 2*x-1; - setjmp(b); - if (y == 1) { - if (x == 2) { - printf("Setjmp-based generic mark_regs code probably wont work.\n"); - printf("But we rarely try that anymore. If you have getcontect()\n"); - printf("this probably doesn't matter.\n"); - } else if (x == 1) { - printf("Setjmp-based register marking code may work.\n"); - } else { - printf("Very strange setjmp implementation.\n"); - } - } - y++; - x = 2; - if (y == 1) longjmp(b,1); - printf("Some GC internal configuration stuff: \n"); - printf("\tWORDSZ = %lu, ALIGNMENT = %d, GC_GRANULE_BYTES = %d\n", - (unsigned long)WORDSZ, ALIGNMENT, GC_GRANULE_BYTES); - printf("\tUsing one mark "); -# if defined(USE_MARK_BYTES) - printf("byte"); -# else - printf("bit"); -# endif - printf(" per "); -# if defined(MARK_BIT_PER_OBJ) - printf("object.\n"); -# elif defined(MARK_BIT_PER_GRANULE) - printf("granule.\n"); -# endif -# ifdef THREAD_LOCAL_ALLOC - printf("Thread local allocation enabled.\n"); -# endif -# ifdef PARALLEL_MARK - printf("Parallel marking enabled.\n"); -# endif - return(0); -} - -int g(int x) -{ - return(x); -} diff -Nru ecl-16.1.2/src/bdwgc/tools/threadlibs.c ecl-16.1.3+ds/src/bdwgc/tools/threadlibs.c --- ecl-16.1.2/src/bdwgc/tools/threadlibs.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/tools/threadlibs.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,82 +0,0 @@ -/* - * Copyright (c) 1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996 by Silicon Graphics. All rights reserved. - * Copyright (c) 1998 by Fergus Henderson. All rights reserved. - * Copyright (c) 2000-2010 by Hewlett-Packard Development Company. - * All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -# include "private/gc_priv.h" - -# include - -int main(void) -{ -# if defined(GC_USE_LD_WRAP) - printf("-Wl,--wrap -Wl,dlopen " - "-Wl,--wrap -Wl,pthread_create -Wl,--wrap -Wl,pthread_join " - "-Wl,--wrap -Wl,pthread_detach -Wl,--wrap -Wl,pthread_sigmask " - "-Wl,--wrap -Wl,pthread_exit -Wl,--wrap -Wl,pthread_cancel\n"); -# endif -# if (defined(GC_LINUX_THREADS) && !defined(PLATFORM_ANDROID)) \ - || defined(GC_IRIX_THREADS) || defined(GC_DARWIN_THREADS) \ - || defined(GC_AIX_THREADS) || defined(GC_GNU_THREADS) -# ifdef GC_USE_DLOPEN_WRAP - printf("-ldl "); -# endif - printf("-lpthread\n"); -# endif -# if defined(GC_OPENBSD_THREADS) - printf("-pthread\n"); -# endif -# if defined(GC_FREEBSD_THREADS) -# ifdef GC_USE_DLOPEN_WRAP - printf("-ldl "); -# endif -# if (__FREEBSD_version >= 500000) - printf("-lpthread\n"); -# else - printf("-pthread\n"); -# endif -# endif -# if defined(GC_NETBSD_THREADS) - printf("-lpthread -lrt\n"); -# endif - -# if defined(GC_HPUX_THREADS) || defined(GC_OSF1_THREADS) - printf("-lpthread -lrt\n"); -# endif -# if defined(GC_SOLARIS_THREADS) - printf("-lthread -lposix4\n"); - /* Is this right for recent versions? */ -# endif -# if defined(GC_WIN32_THREADS) && defined(CYGWIN32) - printf("-lpthread\n"); -# endif -# if defined(GC_WIN32_PTHREADS) -# ifdef PTW32_STATIC_LIB - /* assume suffix s for static version of the win32 pthread library */ - printf("-lpthreadGC2s -lws2_32\n"); -# else - printf("-lpthreadGC2\n"); -# endif -# endif -# if defined(GC_OSF1_THREADS) - printf("-pthread -lrt"); /* DOB: must be -pthread, not -lpthread */ -# endif - /* You need GCC 3.0.3 to build this one! */ - /* DG/UX native gcc doesn't know what "-pthread" is */ -# if defined(GC_DGUX386_THREADS) - printf("-ldl -pthread\n"); -# endif - return 0; -} diff -Nru ecl-16.1.2/src/bdwgc/typd_mlc.c ecl-16.1.3+ds/src/bdwgc/typd_mlc.c --- ecl-16.1.2/src/bdwgc/typd_mlc.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/typd_mlc.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,730 +0,0 @@ -/* - * Copyright (c) 1991-1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1999-2000 by Hewlett-Packard Company. All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -#include "private/gc_pmark.h" - -/* - * Some simple primitives for allocation with explicit type information. - * Simple objects are allocated such that they contain a GC_descr at the - * end (in the last allocated word). This descriptor may be a procedure - * which then examines an extended descriptor passed as its environment. - * - * Arrays are treated as simple objects if they have sufficiently simple - * structure. Otherwise they are allocated from an array kind that supplies - * a special mark procedure. These arrays contain a pointer to a - * complex_descriptor as their last word. - * This is done because the environment field is too small, and the collector - * must trace the complex_descriptor. - * - * Note that descriptors inside objects may appear cleared, if we encounter a - * false reference to an object on a free list. In the GC_descr case, this - * is OK, since a 0 descriptor corresponds to examining no fields. - * In the complex_descriptor case, we explicitly check for that case. - * - * MAJOR PARTS OF THIS CODE HAVE NOT BEEN TESTED AT ALL and are not testable, - * since they are not accessible through the current interface. - */ - -#include "gc_typed.h" - -#define TYPD_EXTRA_BYTES (sizeof(word) - EXTRA_BYTES) - -STATIC GC_bool GC_explicit_typing_initialized = FALSE; - -STATIC int GC_explicit_kind = 0; - /* Object kind for objects with indirect */ - /* (possibly extended) descriptors. */ - -STATIC int GC_array_kind = 0; - /* Object kind for objects with complex */ - /* descriptors and GC_array_mark_proc. */ - -/* Extended descriptors. GC_typed_mark_proc understands these. */ -/* These are used for simple objects that are larger than what */ -/* can be described by a BITMAP_BITS sized bitmap. */ -typedef struct { - word ed_bitmap; /* lsb corresponds to first word. */ - GC_bool ed_continued; /* next entry is continuation. */ -} ext_descr; - -/* Array descriptors. GC_array_mark_proc understands these. */ -/* We may eventually need to add provisions for headers and */ -/* trailers. Hence we provide for tree structured descriptors, */ -/* though we don't really use them currently. */ -typedef union ComplexDescriptor { - struct LeafDescriptor { /* Describes simple array */ - word ld_tag; -# define LEAF_TAG 1 - size_t ld_size; /* bytes per element */ - /* multiple of ALIGNMENT */ - size_t ld_nelements; /* Number of elements. */ - GC_descr ld_descriptor; /* A simple length, bitmap, */ - /* or procedure descriptor. */ - } ld; - struct ComplexArrayDescriptor { - word ad_tag; -# define ARRAY_TAG 2 - size_t ad_nelements; - union ComplexDescriptor * ad_element_descr; - } ad; - struct SequenceDescriptor { - word sd_tag; -# define SEQUENCE_TAG 3 - union ComplexDescriptor * sd_first; - union ComplexDescriptor * sd_second; - } sd; -} complex_descriptor; -#define TAG ld.ld_tag - -STATIC ext_descr * GC_ext_descriptors = NULL; - /* Points to array of extended */ - /* descriptors. */ - -STATIC size_t GC_ed_size = 0; /* Current size of above arrays. */ -#define ED_INITIAL_SIZE 100 - -STATIC size_t GC_avail_descr = 0; /* Next available slot. */ - -STATIC int GC_typed_mark_proc_index = 0; /* Indices of my mark */ -STATIC int GC_array_mark_proc_index = 0; /* procedures. */ - -STATIC void GC_push_typed_structures_proc(void) -{ - GC_push_all((ptr_t)&GC_ext_descriptors, - (ptr_t)&GC_ext_descriptors + sizeof(word)); -} - -/* Add a multiword bitmap to GC_ext_descriptors arrays. Return */ -/* starting index. */ -/* Returns -1 on failure. */ -/* Caller does not hold allocation lock. */ -STATIC signed_word GC_add_ext_descriptor(const GC_word * bm, word nbits) -{ - size_t nwords = divWORDSZ(nbits + WORDSZ-1); - signed_word result; - size_t i; - word last_part; - size_t extra_bits; - DCL_LOCK_STATE; - - LOCK(); - while (GC_avail_descr + nwords >= GC_ed_size) { - ext_descr * new; - size_t new_size; - word ed_size = GC_ed_size; - - if (ed_size == 0) { - GC_ASSERT((word)&GC_ext_descriptors % sizeof(word) == 0); - GC_push_typed_structures = GC_push_typed_structures_proc; - UNLOCK(); - new_size = ED_INITIAL_SIZE; - } else { - UNLOCK(); - new_size = 2 * ed_size; - if (new_size > MAX_ENV) return(-1); - } - new = (ext_descr *) GC_malloc_atomic(new_size * sizeof(ext_descr)); - if (new == 0) return(-1); - LOCK(); - if (ed_size == GC_ed_size) { - if (GC_avail_descr != 0) { - BCOPY(GC_ext_descriptors, new, - GC_avail_descr * sizeof(ext_descr)); - } - GC_ed_size = new_size; - GC_ext_descriptors = new; - } /* else another thread already resized it in the meantime */ - } - result = GC_avail_descr; - for (i = 0; i < nwords-1; i++) { - GC_ext_descriptors[result + i].ed_bitmap = bm[i]; - GC_ext_descriptors[result + i].ed_continued = TRUE; - } - last_part = bm[i]; - /* Clear irrelevant bits. */ - extra_bits = nwords * WORDSZ - nbits; - last_part <<= extra_bits; - last_part >>= extra_bits; - GC_ext_descriptors[result + i].ed_bitmap = last_part; - GC_ext_descriptors[result + i].ed_continued = FALSE; - GC_avail_descr += nwords; - UNLOCK(); - return(result); -} - -/* Table of bitmap descriptors for n word long all pointer objects. */ -STATIC GC_descr GC_bm_table[WORDSZ/2]; - -/* Return a descriptor for the concatenation of 2 nwords long objects, */ -/* each of which is described by descriptor. */ -/* The result is known to be short enough to fit into a bitmap */ -/* descriptor. */ -/* Descriptor is a GC_DS_LENGTH or GC_DS_BITMAP descriptor. */ -STATIC GC_descr GC_double_descr(GC_descr descriptor, word nwords) -{ - if ((descriptor & GC_DS_TAGS) == GC_DS_LENGTH) { - descriptor = GC_bm_table[BYTES_TO_WORDS((word)descriptor)]; - }; - descriptor |= (descriptor & ~GC_DS_TAGS) >> nwords; - return(descriptor); -} - -STATIC complex_descriptor * -GC_make_sequence_descriptor(complex_descriptor *first, - complex_descriptor *second); - -/* Build a descriptor for an array with nelements elements, */ -/* each of which can be described by a simple descriptor. */ -/* We try to optimize some common cases. */ -/* If the result is COMPLEX, then a complex_descr* is returned */ -/* in *complex_d. */ -/* If the result is LEAF, then we built a LeafDescriptor in */ -/* the structure pointed to by leaf. */ -/* The tag in the leaf structure is not set. */ -/* If the result is SIMPLE, then a GC_descr */ -/* is returned in *simple_d. */ -/* If the result is NO_MEM, then */ -/* we failed to allocate the descriptor. */ -/* The implementation knows that GC_DS_LENGTH is 0. */ -/* *leaf, *complex_d, and *simple_d may be used as temporaries */ -/* during the construction. */ -#define COMPLEX 2 -#define LEAF 1 -#define SIMPLE 0 -#define NO_MEM (-1) -STATIC int GC_make_array_descriptor(size_t nelements, size_t size, - GC_descr descriptor, GC_descr *simple_d, - complex_descriptor **complex_d, - struct LeafDescriptor * leaf) -{ -# define OPT_THRESHOLD 50 - /* For larger arrays, we try to combine descriptors of adjacent */ - /* descriptors to speed up marking, and to reduce the amount */ - /* of space needed on the mark stack. */ - if ((descriptor & GC_DS_TAGS) == GC_DS_LENGTH) { - if (descriptor == (GC_descr)size) { - *simple_d = nelements * descriptor; - return(SIMPLE); - } else if ((word)descriptor == 0) { - *simple_d = (GC_descr)0; - return(SIMPLE); - } - } - if (nelements <= OPT_THRESHOLD) { - if (nelements <= 1) { - if (nelements == 1) { - *simple_d = descriptor; - return(SIMPLE); - } else { - *simple_d = (GC_descr)0; - return(SIMPLE); - } - } - } else if (size <= BITMAP_BITS/2 - && (descriptor & GC_DS_TAGS) != GC_DS_PROC - && (size & (sizeof(word)-1)) == 0) { - int result = - GC_make_array_descriptor(nelements/2, 2*size, - GC_double_descr(descriptor, - BYTES_TO_WORDS(size)), - simple_d, complex_d, leaf); - if ((nelements & 1) == 0) { - return(result); - } else { - struct LeafDescriptor * one_element = - (struct LeafDescriptor *) - GC_malloc_atomic(sizeof(struct LeafDescriptor)); - - if (result == NO_MEM || one_element == 0) return(NO_MEM); - one_element -> ld_tag = LEAF_TAG; - one_element -> ld_size = size; - one_element -> ld_nelements = 1; - one_element -> ld_descriptor = descriptor; - switch(result) { - case SIMPLE: - { - struct LeafDescriptor * beginning = - (struct LeafDescriptor *) - GC_malloc_atomic(sizeof(struct LeafDescriptor)); - if (beginning == 0) return(NO_MEM); - beginning -> ld_tag = LEAF_TAG; - beginning -> ld_size = size; - beginning -> ld_nelements = 1; - beginning -> ld_descriptor = *simple_d; - *complex_d = GC_make_sequence_descriptor( - (complex_descriptor *)beginning, - (complex_descriptor *)one_element); - break; - } - case LEAF: - { - struct LeafDescriptor * beginning = - (struct LeafDescriptor *) - GC_malloc_atomic(sizeof(struct LeafDescriptor)); - if (beginning == 0) return(NO_MEM); - beginning -> ld_tag = LEAF_TAG; - beginning -> ld_size = leaf -> ld_size; - beginning -> ld_nelements = leaf -> ld_nelements; - beginning -> ld_descriptor = leaf -> ld_descriptor; - *complex_d = GC_make_sequence_descriptor( - (complex_descriptor *)beginning, - (complex_descriptor *)one_element); - break; - } - case COMPLEX: - *complex_d = GC_make_sequence_descriptor( - *complex_d, - (complex_descriptor *)one_element); - break; - } - return(COMPLEX); - } - } - - leaf -> ld_size = size; - leaf -> ld_nelements = nelements; - leaf -> ld_descriptor = descriptor; - return(LEAF); -} - -STATIC complex_descriptor * -GC_make_sequence_descriptor(complex_descriptor *first, - complex_descriptor *second) -{ - struct SequenceDescriptor * result = - (struct SequenceDescriptor *) - GC_malloc(sizeof(struct SequenceDescriptor)); - /* Can't result in overly conservative marking, since tags are */ - /* very small integers. Probably faster than maintaining type */ - /* info. */ - if (result != 0) { - result -> sd_tag = SEQUENCE_TAG; - result -> sd_first = first; - result -> sd_second = second; - } - return((complex_descriptor *)result); -} - -#ifdef UNDEFINED - complex_descriptor * GC_make_complex_array_descriptor(word nelements, - complex_descriptor *descr) - { - struct ComplexArrayDescriptor * result = - (struct ComplexArrayDescriptor *) - GC_malloc(sizeof(struct ComplexArrayDescriptor)); - - if (result != 0) { - result -> ad_tag = ARRAY_TAG; - result -> ad_nelements = nelements; - result -> ad_element_descr = descr; - } - return((complex_descriptor *)result); - } -#endif - -STATIC ptr_t * GC_eobjfreelist = NULL; - -STATIC ptr_t * GC_arobjfreelist = NULL; - -STATIC mse * GC_typed_mark_proc(word * addr, mse * mark_stack_ptr, - mse * mark_stack_limit, word env); - -STATIC mse * GC_array_mark_proc(word * addr, mse * mark_stack_ptr, - mse * mark_stack_limit, word env); - -/* Caller does not hold allocation lock. */ -STATIC void GC_init_explicit_typing(void) -{ - register unsigned i; - DCL_LOCK_STATE; - - GC_STATIC_ASSERT(sizeof(struct LeafDescriptor) % sizeof(word) == 0); - LOCK(); - if (GC_explicit_typing_initialized) { - UNLOCK(); - return; - } - GC_explicit_typing_initialized = TRUE; - /* Set up object kind with simple indirect descriptor. */ - GC_eobjfreelist = (ptr_t *)GC_new_free_list_inner(); - GC_explicit_kind = GC_new_kind_inner( - (void **)GC_eobjfreelist, - (WORDS_TO_BYTES((word)-1) | GC_DS_PER_OBJECT), - TRUE, TRUE); - /* Descriptors are in the last word of the object. */ - GC_typed_mark_proc_index = GC_new_proc_inner(GC_typed_mark_proc); - /* Set up object kind with array descriptor. */ - GC_arobjfreelist = (ptr_t *)GC_new_free_list_inner(); - GC_array_mark_proc_index = GC_new_proc_inner(GC_array_mark_proc); - GC_array_kind = GC_new_kind_inner( - (void **)GC_arobjfreelist, - GC_MAKE_PROC(GC_array_mark_proc_index, 0), - FALSE, TRUE); - for (i = 0; i < WORDSZ/2; i++) { - GC_bm_table[i] = (((word)-1) << (WORDSZ - i)) | GC_DS_BITMAP; - } - UNLOCK(); -} - -STATIC mse * GC_typed_mark_proc(word * addr, mse * mark_stack_ptr, - mse * mark_stack_limit, word env) -{ - word bm = GC_ext_descriptors[env].ed_bitmap; - word * current_p = addr; - word current; - ptr_t greatest_ha = GC_greatest_plausible_heap_addr; - ptr_t least_ha = GC_least_plausible_heap_addr; - DECLARE_HDR_CACHE; - - INIT_HDR_CACHE; - for (; bm != 0; bm >>= 1, current_p++) { - if (bm & 1) { - current = *current_p; - FIXUP_POINTER(current); - if (current >= (word)least_ha && current <= (word)greatest_ha) { - PUSH_CONTENTS((ptr_t)current, mark_stack_ptr, - mark_stack_limit, (ptr_t)current_p, exit1); - } - } - } - if (GC_ext_descriptors[env].ed_continued) { - /* Push an entry with the rest of the descriptor back onto the */ - /* stack. Thus we never do too much work at once. Note that */ - /* we also can't overflow the mark stack unless we actually */ - /* mark something. */ - mark_stack_ptr++; - if ((word)mark_stack_ptr >= (word)mark_stack_limit) { - mark_stack_ptr = GC_signal_mark_stack_overflow(mark_stack_ptr); - } - mark_stack_ptr -> mse_start = (ptr_t)(addr + WORDSZ); - mark_stack_ptr -> mse_descr.w = - GC_MAKE_PROC(GC_typed_mark_proc_index, env + 1); - } - return(mark_stack_ptr); -} - -/* Return the size of the object described by d. It would be faster to */ -/* store this directly, or to compute it as part of */ -/* GC_push_complex_descriptor, but hopefully it doesn't matter. */ -STATIC word GC_descr_obj_size(complex_descriptor *d) -{ - switch(d -> TAG) { - case LEAF_TAG: - return(d -> ld.ld_nelements * d -> ld.ld_size); - case ARRAY_TAG: - return(d -> ad.ad_nelements - * GC_descr_obj_size(d -> ad.ad_element_descr)); - case SEQUENCE_TAG: - return(GC_descr_obj_size(d -> sd.sd_first) - + GC_descr_obj_size(d -> sd.sd_second)); - default: - ABORT_RET("Bad complex descriptor"); - return 0; - } -} - -/* Push descriptors for the object at addr with complex descriptor d */ -/* onto the mark stack. Return 0 if the mark stack overflowed. */ -STATIC mse * GC_push_complex_descriptor(word *addr, complex_descriptor *d, - mse *msp, mse *msl) -{ - register ptr_t current = (ptr_t) addr; - register word nelements; - register word sz; - register word i; - - switch(d -> TAG) { - case LEAF_TAG: - { - register GC_descr descr = d -> ld.ld_descriptor; - - nelements = d -> ld.ld_nelements; - if (msl - msp <= (ptrdiff_t)nelements) return(0); - sz = d -> ld.ld_size; - for (i = 0; i < nelements; i++) { - msp++; - msp -> mse_start = current; - msp -> mse_descr.w = descr; - current += sz; - } - return(msp); - } - case ARRAY_TAG: - { - register complex_descriptor *descr = d -> ad.ad_element_descr; - - nelements = d -> ad.ad_nelements; - sz = GC_descr_obj_size(descr); - for (i = 0; i < nelements; i++) { - msp = GC_push_complex_descriptor((word *)current, descr, - msp, msl); - if (msp == 0) return(0); - current += sz; - } - return(msp); - } - case SEQUENCE_TAG: - { - sz = GC_descr_obj_size(d -> sd.sd_first); - msp = GC_push_complex_descriptor((word *)current, d -> sd.sd_first, - msp, msl); - if (msp == 0) return(0); - current += sz; - msp = GC_push_complex_descriptor((word *)current, d -> sd.sd_second, - msp, msl); - return(msp); - } - default: - ABORT_RET("Bad complex descriptor"); - return 0; - } -} - -STATIC mse * GC_array_mark_proc(word * addr, mse * mark_stack_ptr, - mse * mark_stack_limit, - word env GC_ATTR_UNUSED) -{ - hdr * hhdr = HDR(addr); - size_t sz = hhdr -> hb_sz; - size_t nwords = BYTES_TO_WORDS(sz); - complex_descriptor * descr = (complex_descriptor *)(addr[nwords-1]); - mse * orig_mark_stack_ptr = mark_stack_ptr; - mse * new_mark_stack_ptr; - - if (descr == 0) { - /* Found a reference to a free list entry. Ignore it. */ - return(orig_mark_stack_ptr); - } - /* In use counts were already updated when array descriptor was */ - /* pushed. Here we only replace it by subobject descriptors, so */ - /* no update is necessary. */ - new_mark_stack_ptr = GC_push_complex_descriptor(addr, descr, - mark_stack_ptr, - mark_stack_limit-1); - if (new_mark_stack_ptr == 0) { - /* Doesn't fit. Conservatively push the whole array as a unit */ - /* and request a mark stack expansion. */ - /* This cannot cause a mark stack overflow, since it replaces */ - /* the original array entry. */ - GC_mark_stack_too_small = TRUE; - new_mark_stack_ptr = orig_mark_stack_ptr + 1; - new_mark_stack_ptr -> mse_start = (ptr_t)addr; - new_mark_stack_ptr -> mse_descr.w = sz | GC_DS_LENGTH; - } else { - /* Push descriptor itself */ - new_mark_stack_ptr++; - new_mark_stack_ptr -> mse_start = (ptr_t)(addr + nwords - 1); - new_mark_stack_ptr -> mse_descr.w = sizeof(word) | GC_DS_LENGTH; - } - return new_mark_stack_ptr; -} - -GC_API GC_descr GC_CALL GC_make_descriptor(const GC_word * bm, size_t len) -{ - signed_word last_set_bit = len - 1; - GC_descr result; - signed_word i; -# define HIGH_BIT (((word)1) << (WORDSZ - 1)) - - if (!EXPECT(GC_explicit_typing_initialized, TRUE)) - GC_init_explicit_typing(); - - while (last_set_bit >= 0 && !GC_get_bit(bm, last_set_bit)) - last_set_bit--; - if (last_set_bit < 0) return(0 /* no pointers */); -# if ALIGNMENT == CPP_WORDSZ/8 - { - register GC_bool all_bits_set = TRUE; - for (i = 0; i < last_set_bit; i++) { - if (!GC_get_bit(bm, i)) { - all_bits_set = FALSE; - break; - } - } - if (all_bits_set) { - /* An initial section contains all pointers. Use length descriptor. */ - return (WORDS_TO_BYTES(last_set_bit+1) | GC_DS_LENGTH); - } - } -# endif - if ((word)last_set_bit < BITMAP_BITS) { - /* Hopefully the common case. */ - /* Build bitmap descriptor (with bits reversed) */ - result = HIGH_BIT; - for (i = last_set_bit - 1; i >= 0; i--) { - result >>= 1; - if (GC_get_bit(bm, i)) result |= HIGH_BIT; - } - result |= GC_DS_BITMAP; - return(result); - } else { - signed_word index; - - index = GC_add_ext_descriptor(bm, (word)last_set_bit+1); - if (index == -1) return(WORDS_TO_BYTES(last_set_bit+1) | GC_DS_LENGTH); - /* Out of memory: use conservative */ - /* approximation. */ - result = GC_MAKE_PROC(GC_typed_mark_proc_index, (word)index); - return result; - } -} - -GC_API GC_ATTR_MALLOC void * GC_CALL GC_malloc_explicitly_typed(size_t lb, - GC_descr d) -{ - ptr_t op; - size_t lg; - DCL_LOCK_STATE; - - lb += TYPD_EXTRA_BYTES; - if(SMALL_OBJ(lb)) { - GC_DBG_COLLECT_AT_MALLOC(lb); - lg = GC_size_map[lb]; - LOCK(); - op = GC_eobjfreelist[lg]; - if (EXPECT(0 == op, FALSE)) { - UNLOCK(); - op = (ptr_t)GENERAL_MALLOC((word)lb, GC_explicit_kind); - if (0 == op) return 0; - lg = GC_size_map[lb]; /* May have been uninitialized. */ - } else { - GC_eobjfreelist[lg] = obj_link(op); - obj_link(op) = 0; - GC_bytes_allocd += GRANULES_TO_BYTES(lg); - UNLOCK(); - } - ((word *)op)[GRANULES_TO_WORDS(lg) - 1] = d; - } else { - op = (ptr_t)GENERAL_MALLOC((word)lb, GC_explicit_kind); - if (op != NULL) { - lg = BYTES_TO_GRANULES(GC_size(op)); - ((word *)op)[GRANULES_TO_WORDS(lg) - 1] = d; - } - } - return((void *) op); -} - -GC_API GC_ATTR_MALLOC void * GC_CALL - GC_malloc_explicitly_typed_ignore_off_page(size_t lb, GC_descr d) -{ - ptr_t op; - size_t lg; - DCL_LOCK_STATE; - - lb += TYPD_EXTRA_BYTES; - if (SMALL_OBJ(lb)) { - GC_DBG_COLLECT_AT_MALLOC(lb); - lg = GC_size_map[lb]; - LOCK(); - op = GC_eobjfreelist[lg]; - if (EXPECT(0 == op, FALSE)) { - UNLOCK(); - op = (ptr_t)GENERAL_MALLOC_IOP(lb, GC_explicit_kind); - if (0 == op) return 0; - lg = GC_size_map[lb]; /* May have been uninitialized. */ - } else { - GC_eobjfreelist[lg] = obj_link(op); - obj_link(op) = 0; - GC_bytes_allocd += GRANULES_TO_BYTES(lg); - UNLOCK(); - } - ((word *)op)[GRANULES_TO_WORDS(lg) - 1] = d; - } else { - op = (ptr_t)GENERAL_MALLOC_IOP(lb, GC_explicit_kind); - if (op != NULL) { - lg = BYTES_TO_GRANULES(GC_size(op)); - ((word *)op)[GRANULES_TO_WORDS(lg) - 1] = d; - } - } - return((void *) op); -} - -GC_API GC_ATTR_MALLOC void * GC_CALL GC_calloc_explicitly_typed(size_t n, - size_t lb, GC_descr d) -{ - ptr_t op; - size_t lg; - GC_descr simple_descr; - complex_descriptor *complex_descr; - register int descr_type; - struct LeafDescriptor leaf; - DCL_LOCK_STATE; - - descr_type = GC_make_array_descriptor((word)n, (word)lb, d, - &simple_descr, &complex_descr, &leaf); - switch(descr_type) { - case NO_MEM: return(0); - case SIMPLE: return(GC_malloc_explicitly_typed(n*lb, simple_descr)); - case LEAF: - lb *= n; - lb += sizeof(struct LeafDescriptor) + TYPD_EXTRA_BYTES; - break; - case COMPLEX: - lb *= n; - lb += TYPD_EXTRA_BYTES; - break; - } - if( SMALL_OBJ(lb) ) { - lg = GC_size_map[lb]; - LOCK(); - op = GC_arobjfreelist[lg]; - if (EXPECT(0 == op, FALSE)) { - UNLOCK(); - op = (ptr_t)GENERAL_MALLOC((word)lb, GC_array_kind); - if (0 == op) return(0); - lg = GC_size_map[lb]; /* May have been uninitialized. */ - } else { - GC_arobjfreelist[lg] = obj_link(op); - obj_link(op) = 0; - GC_bytes_allocd += GRANULES_TO_BYTES(lg); - UNLOCK(); - } - } else { - op = (ptr_t)GENERAL_MALLOC((word)lb, GC_array_kind); - if (0 == op) return(0); - lg = BYTES_TO_GRANULES(GC_size(op)); - } - if (descr_type == LEAF) { - /* Set up the descriptor inside the object itself. */ - volatile struct LeafDescriptor * lp = - (struct LeafDescriptor *) - ((word *)op - + GRANULES_TO_WORDS(lg) - - (BYTES_TO_WORDS(sizeof(struct LeafDescriptor)) + 1)); - - lp -> ld_tag = LEAF_TAG; - lp -> ld_size = leaf.ld_size; - lp -> ld_nelements = leaf.ld_nelements; - lp -> ld_descriptor = leaf.ld_descriptor; - ((volatile word *)op)[GRANULES_TO_WORDS(lg) - 1] = (word)lp; - } else { -# ifndef GC_NO_FINALIZATION - size_t lw = GRANULES_TO_WORDS(lg); - - ((word *)op)[lw - 1] = (word)complex_descr; - /* Make sure the descriptor is cleared once there is any danger */ - /* it may have been collected. */ - if (GC_general_register_disappearing_link((void * *)((word *)op+lw-1), - op) == GC_NO_MEMORY) -# endif - { - /* Couldn't register it due to lack of memory. Punt. */ - /* This will probably fail too, but gives the recovery code */ - /* a chance. */ - return(GC_malloc(n*lb)); - } - } - return((void *) op); -} diff -Nru ecl-16.1.2/src/bdwgc/WCC_MAKEFILE ecl-16.1.3+ds/src/bdwgc/WCC_MAKEFILE --- ecl-16.1.2/src/bdwgc/WCC_MAKEFILE 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/WCC_MAKEFILE 1970-01-01 00:00:00.000000000 +0000 @@ -1,196 +0,0 @@ -# Makefile for Watcom C/C++ 10.5, 10.6, 11.0 on NT, OS2 and DOS4GW. -# May work with Watcom 10.0. - -# Uncoment one of the lines below for cross compilation. -SYSTEM=MSWIN32 -#SYSTEM=DOS4GW -#SYSTEM=OS2 - -# The collector can be built either as dynamic or as static library. -# Select the library type you need. -#MAKE_AS_DLL=1 -MAKE_AS_LIB=1 - -# Select calling conventions. -# Possible choices are r and s. -CALLING=s - -# Select target CPU. -# Possible choices are 3, 4, 5, and 6. -# The last choice available only since version 11.0. -CPU=5 - -# Set optimization options. -# Watcom before 11.0 does not support option "-oh". -OPTIM=-oneatx -s -#OPTIM=-ohneatx -s - -DEFS=-DALL_INTERIOR_POINTERS #-DSMALL_CONFIG #-DGC_DEBUG - - -##### - -!ifndef SYSTEM -!ifdef __MSDOS__ -SYSTEM=DOS4GW -!else ifdef __NT__ -SYSTEM=MSWIN32 -!else ifdef __OS2__ -SYSTEM=OS2 -!else -SYSTEM=Unknown -!endif -!endif - -!define $(SYSTEM) - -!ifdef DOS4GW -SYSFLAG=-DDOS4GW -bt=dos -!else ifdef MSWIN32 -SYSFLAG=-DMSWIN32 -bt=nt -!else ifdef OS2 -SYSFLAG=-DOS2 -bt=os2 -!else -!error undefined or unsupported target platform: $(SYSTEM) -!endif -!ifdef MAKE_AS_DLL -DLLFLAG=-bd -DGC_DLL -TEST_DLLFLAG=-DGC_DLL -!else ifdef MAKE_AS_LIB -DLLFLAG= -TEST_DLLFLAG= -!else -!error Either MAKE_AS_LIB or MAKE_AS_DLL should be defined -!endif - -CC=wcc386 -CXX=wpp386 - -# -DUSE_GENERIC is required ! -CFLAGS=-$(CPU)$(CALLING) $(OPTIM) -zp4 -zc $(SYSFLAG) $(DLLFLAG) -DUSE_GENERIC $(DEFS) -CXXFLAGS= $(CFLAGS) -TEST_CFLAGS=-$(CPU)$(CALLING) $(OPTIM) -zp4 -zc $(SYSFLAG) $(TEST_DLLFLAG) $(DEFS) -TEST_CXXFLAGS= $(TEST_CFLAGS) - -OBJS= alloc.obj reclaim.obj allchblk.obj misc.obj & - mach_dep.obj os_dep.obj mark_rts.obj headers.obj mark.obj & - obj_map.obj blacklst.obj finalize.obj new_hblk.obj & - dbg_mlc.obj malloc.obj stubborn.obj dyn_load.obj & - typd_mlc.obj ptr_chck.obj mallocx.obj fnlz_mlc.obj - -all: gc.lib gctest.exe test_cpp.exe - -!ifdef MAKE_AS_DLL - -gc.lib: gc.dll gc_cpp.obj - *wlib -b -c -n -p=512 $@ +gc.dll +gc_cpp.obj - -gc.dll: $(OBJS) .AUTODEPEND - @%create $*.lnk -!ifdef DOS4GW - @%append $*.lnk sys os2v2_dll -!else ifdef MSWIN32 - @%append $*.lnk sys nt_dll -!else ifdef OS2 - @%append $*.lnk sys os2v2_dll -!endif - @%append $*.lnk name $* - @for %i in ($(OBJS)) do @%append $*.lnk file '%i' -!ifeq CALLING s - @%append $*.lnk export GC_is_marked - @%append $*.lnk export GC_incr_bytes_allocd - @%append $*.lnk export GC_incr_bytes_freed - @%append $*.lnk export GC_generic_malloc_words_small -!else - @%append $*.lnk export GC_is_marked_ - @%append $*.lnk export GC_incr_bytes_allocd_ - @%append $*.lnk export GC_incr_bytes_freed_ - @%append $*.lnk export GC_generic_malloc_words_small_ -!endif - *wlink @$*.lnk -!else -gc.lib: $(OBJS) gc_cpp.obj - @%create $*.lb1 - @for %i in ($(OBJS)) do @%append $*.lb1 +'%i' - @%append $*.lb1 +'gc_cpp.obj' - *wlib -b -c -n -p=512 $@ @$*.lb1 - -!endif - - -gctest.exe: test.obj gc.lib - %create $*.lnk -!ifdef DOS4GW - @%append $*.lnk sys dos4g -!else ifdef MSWIN32 - @%append $*.lnk sys nt -!else ifdef OS2 - @%append $*.lnk sys os2v2 -!endif - @%append $*.lnk op case - @%append $*.lnk op stack=256K - @%append $*.lnk name $* - @%append $*.lnk file test.obj - @%append $*.lnk library gc.lib -!ifdef MAKE_AS_DLL -!ifeq CALLING s - @%append $*.lnk import GC_is_marked gc -!else - @%append $*.lnk import GC_is_marked_ gc -!endif -!endif - *wlink @$*.lnk -test_cpp.exe: test_cpp.obj gc.lib - %create $*.lnk -!ifdef DOS4GW - @%append $*.lnk sys dos4g -!else ifdef MSWIN32 - @%append $*.lnk sys nt -!else ifdef OS2 - @%append $*.lnk sys os2v2 -!endif - @%append $*.lnk op case - @%append $*.lnk op stack=256K - @%append $*.lnk name $* - @%append $*.lnk file test_cpp.obj - @%append $*.lnk library gc.lib -!ifdef MAKE_AS_DLL -!ifeq CALLING s - @%append $*.lnk import GC_incr_bytes_allocd gc - @%append $*.lnk import GC_incr_bytes_freed gc - @%append $*.lnk import GC_generic_malloc_words_small gc -!else - @%append $*.lnk import GC_incr_bytes_allocd_ gc - @%append $*.lnk import GC_incr_bytes_freed_ gc - @%append $*.lnk import GC_generic_malloc_words_small_ gc -!endif -!endif - *wlink @$*.lnk - -gc_cpp.obj: gc_cpp.cc .AUTODEPEND - $(CXX) $(TEST_CXXFLAGS) -iinclude $*.cc -test.obj: tests\test.c .AUTODEPEND - $(CC) $(TEST_CFLAGS) $*.c -test_cpp.obj: tests\test_cpp.cc .AUTODEPEND - $(CXX) $(TEST_CXXFLAGS) -iinclude $*.cc - - -.c.obj: .AUTODEPEND - $(CC) $(CFLAGS) $*.c - -.cc.obj: .AUTODEPEND - $(CXX) $(CXXFLAGS) $*.cc - -clean : .SYMBOLIC - @if exist *.obj del *.obj - @if exist *.map del *.map - @if exist *.lnk del *.lnk - @if exist *.lb1 del *.lb1 - @if exist *.sym del *.sym - @if exist *.err del *.err - @if exist *.tmp del *.tmp - @if exist *.lst del *.lst - @if exist *.exe del *.exe - @if exist *.log del *.log - @if exist *.lib del *.lib - @if exist *.dll del *.dll diff -Nru ecl-16.1.2/src/bdwgc/win32_threads.c ecl-16.1.3+ds/src/bdwgc/win32_threads.c --- ecl-16.1.2/src/bdwgc/win32_threads.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/win32_threads.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,2848 +0,0 @@ -/* - * Copyright (c) 1994 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996 by Silicon Graphics. All rights reserved. - * Copyright (c) 1998 by Fergus Henderson. All rights reserved. - * Copyright (c) 2000-2008 by Hewlett-Packard Development Company. - * All rights reserved. - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - */ - -#include "private/gc_priv.h" - -#if defined(GC_WIN32_THREADS) - -#ifndef WIN32_LEAN_AND_MEAN -# define WIN32_LEAN_AND_MEAN 1 -#endif -#define NOSERVICE -#include - -#ifdef THREAD_LOCAL_ALLOC -# include "private/thread_local_alloc.h" -#endif /* THREAD_LOCAL_ALLOC */ - -/* Allocation lock declarations. */ -#if !defined(USE_PTHREAD_LOCKS) - GC_INNER CRITICAL_SECTION GC_allocate_ml; -# ifdef GC_ASSERTIONS - GC_INNER DWORD GC_lock_holder = NO_THREAD; - /* Thread id for current holder of allocation lock */ -# endif -#else - GC_INNER pthread_mutex_t GC_allocate_ml = PTHREAD_MUTEX_INITIALIZER; -# ifdef GC_ASSERTIONS - GC_INNER unsigned long GC_lock_holder = NO_THREAD; -# endif -#endif - -#undef CreateThread -#undef ExitThread -#undef _beginthreadex -#undef _endthreadex - -#ifdef GC_PTHREADS -# include /* for EAGAIN */ - - /* Cygwin-specific forward decls */ -# undef pthread_create -# undef pthread_join -# undef pthread_detach - -# ifndef GC_NO_PTHREAD_SIGMASK -# undef pthread_sigmask -# endif - - STATIC void * GC_pthread_start(void * arg); - STATIC void GC_thread_exit_proc(void *arg); - -# include -# ifdef CAN_CALL_ATFORK -# include -# endif - -#elif !defined(MSWINCE) -# include /* For _beginthreadex, _endthreadex */ -# include /* for errno, EAGAIN */ - -#endif /* !GC_PTHREADS && !MSWINCE */ - -/* DllMain-based thread registration is currently incompatible */ -/* with thread-local allocation, pthreads and WinCE. */ -#if (defined(GC_DLL) || defined(GC_INSIDE_DLL)) \ - && !defined(GC_NO_THREADS_DISCOVERY) && !defined(MSWINCE) \ - && !defined(THREAD_LOCAL_ALLOC) && !defined(GC_PTHREADS) -# include "atomic_ops.h" - - /* This code operates in two distinct modes, depending on */ - /* the setting of GC_win32_dll_threads. */ - /* If GC_win32_dll_threads is set, all threads in the process */ - /* are implicitly registered with the GC by DllMain. */ - /* No explicit registration is required, and attempts at */ - /* explicit registration are ignored. This mode is */ - /* very different from the Posix operation of the collector. */ - /* In this mode access to the thread table is lock-free. */ - /* Hence there is a static limit on the number of threads. */ - -# ifdef GC_DISCOVER_TASK_THREADS - /* GC_DISCOVER_TASK_THREADS should be used if DllMain-based */ - /* thread registration is required but it is impossible to */ - /* call GC_use_threads_discovery before other GC routines. */ -# define GC_win32_dll_threads TRUE -# else - STATIC GC_bool GC_win32_dll_threads = FALSE; - /* GC_win32_dll_threads must be set (if needed) at the */ - /* application initialization time, i.e. before any */ - /* collector or thread calls. We make it a "dynamic" */ - /* option only to avoid multiple library versions. */ -# endif - -#else - /* If GC_win32_dll_threads is FALSE (or the collector is */ - /* built without GC_DLL defined), things operate in a way */ - /* that is very similar to Posix platforms, and new threads */ - /* must be registered with the collector, e.g. by using */ - /* preprocessor-based interception of the thread primitives. */ - /* In this case, we use a real data structure for the thread */ - /* table. Note that there is no equivalent of linker-based */ - /* call interception, since we don't have ELF-like */ - /* facilities. The Windows analog appears to be "API */ - /* hooking", which really seems to be a standard way to */ - /* do minor binary rewriting (?). I'd prefer not to have */ - /* the basic collector rely on such facilities, but an */ - /* optional package that intercepts thread calls this way */ - /* would probably be nice. */ -# ifndef GC_NO_THREADS_DISCOVERY -# define GC_NO_THREADS_DISCOVERY -# endif -# define GC_win32_dll_threads FALSE -# undef MAX_THREADS -# define MAX_THREADS 1 /* dll_thread_table[] is always empty. */ -#endif /* GC_NO_THREADS_DISCOVERY */ - -/* We have two versions of the thread table. Which one */ -/* we us depends on whether or not GC_win32_dll_threads */ -/* is set. Note that before initialization, we don't */ -/* add any entries to either table, even if DllMain is */ -/* called. The main thread will be added on */ -/* initialization. */ - -/* The type of the first argument to InterlockedExchange. */ -/* Documented to be LONG volatile *, but at least gcc likes */ -/* this better. */ -typedef LONG * IE_t; - -STATIC GC_bool GC_thr_initialized = FALSE; - -#ifndef GC_ALWAYS_MULTITHREADED - GC_INNER GC_bool GC_need_to_lock = FALSE; -#endif - -static GC_bool parallel_initialized = FALSE; - -/* GC_use_threads_discovery() is currently incompatible with pthreads */ -/* and WinCE. It might be possible to get DllMain-based thread */ -/* registration to work with Cygwin, but if you try it then you are on */ -/* your own. */ -GC_API void GC_CALL GC_use_threads_discovery(void) -{ -# ifdef GC_NO_THREADS_DISCOVERY - ABORT("GC DllMain-based thread registration unsupported"); -# else - /* Turn on GC_win32_dll_threads. */ - GC_ASSERT(!parallel_initialized); -# ifndef GC_DISCOVER_TASK_THREADS - GC_win32_dll_threads = TRUE; -# endif - GC_init_parallel(); -# endif -} - -STATIC DWORD GC_main_thread = 0; - -#define ADDR_LIMIT ((ptr_t)(word)-1) - -struct GC_Thread_Rep { - union { -# ifndef GC_NO_THREADS_DISCOVERY - volatile AO_t in_use; - /* Updated without lock. */ - /* We assert that unused */ - /* entries have invalid ids of */ - /* zero and zero stack fields. */ - /* Used only with GC_win32_dll_threads. */ -# endif - struct GC_Thread_Rep * next; - /* Hash table link without */ - /* GC_win32_dll_threads. */ - /* More recently allocated threads */ - /* with a given pthread id come */ - /* first. (All but the first are */ - /* guaranteed to be dead, but we may */ - /* not yet have registered the join.) */ - } tm; /* table_management */ - DWORD id; - -# ifdef MSWINCE - /* According to MSDN specs for WinCE targets: */ - /* - DuplicateHandle() is not applicable to thread handles; and */ - /* - the value returned by GetCurrentThreadId() could be used as */ - /* a "real" thread handle (for SuspendThread(), ResumeThread() and */ - /* GetThreadContext()). */ -# define THREAD_HANDLE(t) (HANDLE)(word)(t)->id -# else - HANDLE handle; -# define THREAD_HANDLE(t) (t)->handle -# endif - - ptr_t stack_base; /* The cold end of the stack. */ - /* 0 ==> entry not valid. */ - /* !in_use ==> stack_base == 0 */ - ptr_t last_stack_min; /* Last known minimum (hottest) address */ - /* in stack or ADDR_LIMIT if unset */ -# ifdef IA64 - ptr_t backing_store_end; - ptr_t backing_store_ptr; -# endif - - ptr_t thread_blocked_sp; /* Protected by GC lock. */ - /* NULL value means thread unblocked. */ - /* If set to non-NULL, thread will */ - /* acquire GC lock before doing any */ - /* pointer manipulations. Thus it does */ - /* not need to stop this thread. */ - - struct GC_traced_stack_sect_s *traced_stack_sect; - /* Points to the "stack section" data */ - /* held in stack by the innermost */ - /* GC_call_with_gc_active() of this */ - /* thread. May be NULL. */ - - unsigned short finalizer_skipped; - unsigned char finalizer_nested; - /* Used by GC_check_finalizer_nested() */ - /* to minimize the level of recursion */ - /* when a client finalizer allocates */ - /* memory (initially both are 0). */ - - unsigned char suspended; /* really of GC_bool type */ - -# ifdef GC_PTHREADS - unsigned char flags; /* Protected by GC lock. */ -# define FINISHED 1 /* Thread has exited. */ -# define DETACHED 2 /* Thread is intended to be detached. */ -# define KNOWN_FINISHED(t) (((t) -> flags) & FINISHED) - pthread_t pthread_id; - void *status; /* hold exit value until join in case it's a pointer */ -# else -# define KNOWN_FINISHED(t) 0 -# endif - -# ifdef THREAD_LOCAL_ALLOC - struct thread_local_freelists tlfs; -# endif -}; - -typedef struct GC_Thread_Rep * GC_thread; -typedef volatile struct GC_Thread_Rep * GC_vthread; - -#ifndef GC_NO_THREADS_DISCOVERY - /* We assumed that volatile ==> memory ordering, at least among */ - /* volatiles. This code should consistently use atomic_ops. */ - STATIC volatile GC_bool GC_please_stop = FALSE; -#elif defined(GC_ASSERTIONS) - STATIC GC_bool GC_please_stop = FALSE; -#endif - -/* - * We track thread attachments while the world is supposed to be stopped. - * Unfortunately, we can't stop them from starting, since blocking in - * DllMain seems to cause the world to deadlock. Thus we have to recover - * If we notice this in the middle of marking. - */ - -#ifndef GC_NO_THREADS_DISCOVERY - STATIC volatile AO_t GC_attached_thread = FALSE; -#endif - -#if !defined(__GNUC__) - /* Return TRUE if an thread was attached since we last asked or */ - /* since GC_attached_thread was explicitly reset. */ - GC_INNER GC_bool GC_started_thread_while_stopped(void) - { -# ifndef GC_NO_THREADS_DISCOVERY - if (GC_win32_dll_threads) { -# ifdef AO_HAVE_compare_and_swap_release - if (AO_compare_and_swap_release(&GC_attached_thread, TRUE, - FALSE /* stored */)) - return TRUE; -# else - AO_nop_full(); /* Prior heap reads need to complete earlier. */ - if (AO_load(&GC_attached_thread)) { - AO_store(&GC_attached_thread, FALSE); - return TRUE; - } -# endif - } -# endif - return FALSE; - } -#endif /* !__GNUC__ */ - -/* Thread table used if GC_win32_dll_threads is set. */ -/* This is a fixed size array. */ -/* Since we use runtime conditionals, both versions */ -/* are always defined. */ -# ifndef MAX_THREADS -# define MAX_THREADS 512 -# endif - -/* Things may get quite slow for large numbers of threads, */ -/* since we look them up with sequential search. */ -volatile struct GC_Thread_Rep dll_thread_table[MAX_THREADS]; - -STATIC volatile LONG GC_max_thread_index = 0; - /* Largest index in dll_thread_table */ - /* that was ever used. */ - -/* And now the version used if GC_win32_dll_threads is not set. */ -/* This is a chained hash table, with much of the code borrowed */ -/* From the Posix implementation. */ -#ifndef THREAD_TABLE_SZ -# define THREAD_TABLE_SZ 256 /* Power of 2 (for speed). */ -#endif -#define THREAD_TABLE_INDEX(id) (((word)(id) >> 2) % THREAD_TABLE_SZ) -STATIC GC_thread GC_threads[THREAD_TABLE_SZ]; - -/* It may not be safe to allocate when we register the first thread. */ -/* Thus we allocated one statically. It does not contain any field we */ -/* need to push ("next" and "status" fields are unused). */ -static struct GC_Thread_Rep first_thread; -static GC_bool first_thread_used = FALSE; - -/* Add a thread to GC_threads. We assume it wasn't already there. */ -/* Caller holds allocation lock. */ -/* Unlike the pthreads version, the id field is set by the caller. */ -STATIC GC_thread GC_new_thread(DWORD id) -{ - word hv = THREAD_TABLE_INDEX(id); - GC_thread result; - - GC_ASSERT(I_HOLD_LOCK()); - if (!EXPECT(first_thread_used, TRUE)) { - result = &first_thread; - first_thread_used = TRUE; - } else { - GC_ASSERT(!GC_win32_dll_threads); - result = (struct GC_Thread_Rep *) - GC_INTERNAL_MALLOC(sizeof(struct GC_Thread_Rep), NORMAL); - /* result can be NULL */ - if (result == 0) return(0); - } - /* result -> id = id; Done by caller. */ - result -> tm.next = GC_threads[hv]; - GC_threads[hv] = result; -# ifdef GC_PTHREADS - GC_ASSERT(result -> flags == 0); -# endif - GC_ASSERT(result -> thread_blocked_sp == NULL); - return(result); -} - -STATIC GC_bool GC_in_thread_creation = FALSE; - /* Protected by allocation lock. */ - -GC_INLINE void GC_record_stack_base(GC_vthread me, - const struct GC_stack_base *sb) -{ - me -> stack_base = sb -> mem_base; -# ifdef IA64 - me -> backing_store_end = sb -> reg_base; -# endif - if (me -> stack_base == NULL) - ABORT("Bad stack base in GC_register_my_thread"); -} - -/* This may be called from DllMain, and hence operates under unusual */ -/* constraints. In particular, it must be lock-free if */ -/* GC_win32_dll_threads is set. Always called from the thread being */ -/* added. If GC_win32_dll_threads is not set, we already hold the */ -/* allocation lock except possibly during single-threaded startup code. */ -STATIC GC_thread GC_register_my_thread_inner(const struct GC_stack_base *sb, - DWORD thread_id) -{ - GC_vthread me; - - /* The following should be a no-op according to the win32 */ - /* documentation. There is empirical evidence that it */ - /* isn't. - HB */ -# if defined(MPROTECT_VDB) - if (GC_incremental -# ifdef GWW_VDB - && !GC_gww_dirty_init() -# endif - ) - GC_set_write_fault_handler(); -# endif - -# ifndef GC_NO_THREADS_DISCOVERY - if (GC_win32_dll_threads) { - int i; - /* It appears to be unsafe to acquire a lock here, since this */ - /* code is apparently not preemptible on some systems. */ - /* (This is based on complaints, not on Microsoft's official */ - /* documentation, which says this should perform "only simple */ - /* initialization tasks".) */ - /* Hence we make do with nonblocking synchronization. */ - /* It has been claimed that DllMain is really only executed with */ - /* a particular system lock held, and thus careful use of locking */ - /* around code that doesn't call back into the system libraries */ - /* might be OK. But this hasn't been tested across all win32 */ - /* variants. */ - /* cast away volatile qualifier */ - for (i = 0; - InterlockedExchange((void*)&dll_thread_table[i].tm.in_use, 1) != 0; - i++) { - /* Compare-and-swap would make this cleaner, but that's not */ - /* supported before Windows 98 and NT 4.0. In Windows 2000, */ - /* InterlockedExchange is supposed to be replaced by */ - /* InterlockedExchangePointer, but that's not really what I */ - /* want here. */ - /* FIXME: We should eventually declare Win95 dead and use AO_ */ - /* primitives here. */ - if (i == MAX_THREADS - 1) - ABORT("Too many threads"); - } - /* Update GC_max_thread_index if necessary. The following is */ - /* safe, and unlike CompareExchange-based solutions seems to work */ - /* on all Windows95 and later platforms. */ - /* Unfortunately, GC_max_thread_index may be temporarily out of */ - /* bounds, so readers have to compensate. */ - while (i > GC_max_thread_index) { - InterlockedIncrement((IE_t)&GC_max_thread_index); - } - if (GC_max_thread_index >= MAX_THREADS) { - /* We overshot due to simultaneous increments. */ - /* Setting it to MAX_THREADS-1 is always safe. */ - GC_max_thread_index = MAX_THREADS - 1; - } - me = dll_thread_table + i; - } else -# endif - /* else */ /* Not using DllMain */ { - GC_ASSERT(I_HOLD_LOCK()); - GC_in_thread_creation = TRUE; /* OK to collect from unknown thread. */ - me = GC_new_thread(thread_id); - GC_in_thread_creation = FALSE; - if (me == 0) - ABORT("Failed to allocate memory for thread registering"); - } -# ifdef GC_PTHREADS - /* me can be NULL -> segfault */ - me -> pthread_id = pthread_self(); -# endif -# ifndef MSWINCE - /* GetCurrentThread() returns a pseudohandle (a const value). */ - if (!DuplicateHandle(GetCurrentProcess(), GetCurrentThread(), - GetCurrentProcess(), - (HANDLE*)&(me -> handle), - 0 /* dwDesiredAccess */, FALSE /* bInheritHandle */, - DUPLICATE_SAME_ACCESS)) { - ABORT_ARG1("DuplicateHandle failed", - ": errcode= 0x%X", (unsigned)GetLastError()); - } -# endif - me -> last_stack_min = ADDR_LIMIT; - GC_record_stack_base(me, sb); - /* Up until this point, GC_push_all_stacks considers this thread */ - /* invalid. */ - /* Up until this point, this entry is viewed as reserved but invalid */ - /* by GC_delete_thread. */ - me -> id = thread_id; -# if defined(THREAD_LOCAL_ALLOC) - GC_init_thread_local((GC_tlfs)(&(me->tlfs))); -# endif -# ifndef GC_NO_THREADS_DISCOVERY - if (GC_win32_dll_threads) { - if (GC_please_stop) { - AO_store(&GC_attached_thread, TRUE); - AO_nop_full(); /* Later updates must become visible after this. */ - } - /* We'd like to wait here, but can't, since waiting in DllMain */ - /* provokes deadlocks. */ - /* Thus we force marking to be restarted instead. */ - } else -# endif - /* else */ { - GC_ASSERT(!GC_please_stop); - /* Otherwise both we and the thread stopping code would be */ - /* holding the allocation lock. */ - } - return (GC_thread)(me); -} - -/* - * GC_max_thread_index may temporarily be larger than MAX_THREADS. - * To avoid subscript errors, we check on access. - */ -GC_INLINE LONG GC_get_max_thread_index(void) -{ - LONG my_max = GC_max_thread_index; - if (my_max >= MAX_THREADS) return MAX_THREADS - 1; - return my_max; -} - -/* Return the GC_thread corresponding to a thread id. May be called */ -/* without a lock, but should be called in contexts in which the */ -/* requested thread cannot be asynchronously deleted, e.g. from the */ -/* thread itself. */ -/* This version assumes that either GC_win32_dll_threads is set, or */ -/* we hold the allocator lock. */ -/* Also used (for assertion checking only) from thread_local_alloc.c. */ -STATIC GC_thread GC_lookup_thread_inner(DWORD thread_id) -{ -# ifndef GC_NO_THREADS_DISCOVERY - if (GC_win32_dll_threads) { - int i; - LONG my_max = GC_get_max_thread_index(); - for (i = 0; i <= my_max && - (!AO_load_acquire(&dll_thread_table[i].tm.in_use) - || dll_thread_table[i].id != thread_id); - /* Must still be in_use, since nobody else can store our */ - /* thread_id. */ - i++) { - /* empty */ - } - return i <= my_max ? (GC_thread)(dll_thread_table + i) : NULL; - } else -# endif - /* else */ { - word hv = THREAD_TABLE_INDEX(thread_id); - register GC_thread p = GC_threads[hv]; - - GC_ASSERT(I_HOLD_LOCK()); - while (p != 0 && p -> id != thread_id) p = p -> tm.next; - return(p); - } -} - -#ifdef LINT2 -# define CHECK_LOOKUP_MY_THREAD(me) \ - if (!(me)) ABORT("GC_lookup_thread_inner(GetCurrentThreadId) failed") -#else -# define CHECK_LOOKUP_MY_THREAD(me) /* empty */ -#endif - -/* Called by GC_finalize() (in case of an allocation failure observed). */ -/* GC_reset_finalizer_nested() is the same as in pthread_support.c. */ -GC_INNER void GC_reset_finalizer_nested(void) -{ - GC_thread me = GC_lookup_thread_inner(GetCurrentThreadId()); - CHECK_LOOKUP_MY_THREAD(me); - me->finalizer_nested = 0; -} - -/* Checks and updates the thread-local level of finalizers recursion. */ -/* Returns NULL if GC_invoke_finalizers() should not be called by the */ -/* collector (to minimize the risk of a deep finalizers recursion), */ -/* otherwise returns a pointer to the thread-local finalizer_nested. */ -/* Called by GC_notify_or_invoke_finalizers() only (the lock is held). */ -/* GC_check_finalizer_nested() is the same as in pthread_support.c. */ -GC_INNER unsigned char *GC_check_finalizer_nested(void) -{ - GC_thread me = GC_lookup_thread_inner(GetCurrentThreadId()); - unsigned nesting_level; - CHECK_LOOKUP_MY_THREAD(me); - nesting_level = me->finalizer_nested; - if (nesting_level) { - /* We are inside another GC_invoke_finalizers(). */ - /* Skip some implicitly-called GC_invoke_finalizers() */ - /* depending on the nesting (recursion) level. */ - if (++me->finalizer_skipped < (1U << nesting_level)) return NULL; - me->finalizer_skipped = 0; - } - me->finalizer_nested = (unsigned char)(nesting_level + 1); - return &me->finalizer_nested; -} - -#if defined(GC_ASSERTIONS) && defined(THREAD_LOCAL_ALLOC) - /* This is called from thread-local GC_malloc(). */ - GC_bool GC_is_thread_tsd_valid(void *tsd) - { - GC_thread me; - DCL_LOCK_STATE; - - LOCK(); - me = GC_lookup_thread_inner(GetCurrentThreadId()); - UNLOCK(); - return (word)tsd >= (word)(&me->tlfs) - && (word)tsd < (word)(&me->tlfs) + sizeof(me->tlfs); - } -#endif /* GC_ASSERTIONS && THREAD_LOCAL_ALLOC */ - -GC_API int GC_CALL GC_thread_is_registered(void) -{ - DWORD thread_id = GetCurrentThreadId(); - GC_thread me; - DCL_LOCK_STATE; - - LOCK(); - me = GC_lookup_thread_inner(thread_id); - UNLOCK(); - return me != NULL; -} - -/* Make sure thread descriptor t is not protected by the VDB */ -/* implementation. */ -/* Used to prevent write faults when the world is (partially) stopped, */ -/* since it may have been stopped with a system lock held, and that */ -/* lock may be required for fault handling. */ -#if defined(MPROTECT_VDB) -# define UNPROTECT_THREAD(t) \ - if (!GC_win32_dll_threads && GC_dirty_maintained \ - && t != &first_thread) { \ - GC_ASSERT(SMALL_OBJ(GC_size(t))); \ - GC_remove_protection(HBLKPTR(t), 1, FALSE); \ - } else (void)0 -#else -# define UNPROTECT_THREAD(t) (void)0 -#endif - -#ifdef CYGWIN32 -# define GC_PTHREAD_PTRVAL(pthread_id) pthread_id -#elif defined(GC_WIN32_PTHREADS) || defined(GC_PTHREADS_PARAMARK) -# include /* to check for winpthreads */ -# if defined(__WINPTHREADS_VERSION_MAJOR) -# define GC_PTHREAD_PTRVAL(pthread_id) pthread_id -# else -# define GC_PTHREAD_PTRVAL(pthread_id) pthread_id.p -# endif -#endif - -/* If a thread has been joined, but we have not yet */ -/* been notified, then there may be more than one thread */ -/* in the table with the same win32 id. */ -/* This is OK, but we need a way to delete a specific one. */ -/* Assumes we hold the allocation lock unless */ -/* GC_win32_dll_threads is set. Does not actually free */ -/* GC_thread entry (only unlinks it). */ -/* If GC_win32_dll_threads is set it should be called from the */ -/* thread being deleted. */ -STATIC void GC_delete_gc_thread_no_free(GC_vthread t) -{ -# ifndef MSWINCE - CloseHandle(t->handle); -# endif -# ifndef GC_NO_THREADS_DISCOVERY - if (GC_win32_dll_threads) { - /* This is intended to be lock-free. */ - /* It is either called synchronously from the thread being */ - /* deleted, or by the joining thread. */ - /* In this branch asynchronous changes to (*t) are possible. */ - /* It's not allowed to call GC_printf (and the friends) here, */ - /* see GC_stop_world() for the information. */ - t -> stack_base = 0; - t -> id = 0; - AO_store_release(&t->tm.in_use, FALSE); - } else -# endif - /* else */ { - DWORD id = ((GC_thread)t) -> id; - /* Cast away volatile qualifier, since we have lock. */ - word hv = THREAD_TABLE_INDEX(id); - register GC_thread p = GC_threads[hv]; - register GC_thread prev = 0; - - GC_ASSERT(I_HOLD_LOCK()); - while (p != (GC_thread)t) { - prev = p; - p = p -> tm.next; - } - if (prev == 0) { - GC_threads[hv] = p -> tm.next; - } else { - prev -> tm.next = p -> tm.next; - } - } -} - -/* Delete a thread from GC_threads. We assume it is there. */ -/* (The code intentionally traps if it wasn't.) Assumes we */ -/* hold the allocation lock unless GC_win32_dll_threads is set. */ -/* If GC_win32_dll_threads is set then it should be called from */ -/* the thread being deleted. It is also safe to delete the */ -/* main thread (unless GC_win32_dll_threads). */ -STATIC void GC_delete_thread(DWORD id) -{ - if (GC_win32_dll_threads) { - GC_vthread t = GC_lookup_thread_inner(id); - - if (0 == t) { - WARN("Removing nonexistent thread, id = %" WARN_PRIdPTR "\n", id); - } else { - GC_delete_gc_thread_no_free(t); - } - } else { - word hv = THREAD_TABLE_INDEX(id); - register GC_thread p = GC_threads[hv]; - register GC_thread prev = 0; - - GC_ASSERT(I_HOLD_LOCK()); - while (p -> id != id) { - prev = p; - p = p -> tm.next; - } -# ifndef MSWINCE - CloseHandle(p->handle); -# endif - if (prev == 0) { - GC_threads[hv] = p -> tm.next; - } else { - prev -> tm.next = p -> tm.next; - } - if (p != &first_thread) { - GC_INTERNAL_FREE(p); - } - } -} - -GC_API void GC_CALL GC_allow_register_threads(void) -{ - /* Check GC is initialized and the current thread is registered. */ - GC_ASSERT(GC_lookup_thread_inner(GetCurrentThreadId()) != 0); -# ifndef GC_ALWAYS_MULTITHREADED -# if !defined(GC_NO_THREADS_DISCOVERY) && !defined(PARALLEL_MARK) - /* GC_init() does not call GC_init_parallel() in this case. */ - parallel_initialized = TRUE; -# endif - GC_need_to_lock = TRUE; /* We are multi-threaded now. */ -# endif -} - -GC_API int GC_CALL GC_register_my_thread(const struct GC_stack_base *sb) -{ - GC_thread me; - DWORD thread_id = GetCurrentThreadId(); - DCL_LOCK_STATE; - - if (GC_need_to_lock == FALSE) - ABORT("Threads explicit registering is not previously enabled"); - - /* We lock here, since we want to wait for an ongoing GC. */ - LOCK(); - me = GC_lookup_thread_inner(thread_id); - if (me == 0) { -# ifdef GC_PTHREADS - me = GC_register_my_thread_inner(sb, thread_id); - me -> flags |= DETACHED; - /* Treat as detached, since we do not need to worry about */ - /* pointer results. */ -# else - GC_register_my_thread_inner(sb, thread_id); -# endif - UNLOCK(); - return GC_SUCCESS; - } else -# ifdef GC_PTHREADS - /* else */ if ((me -> flags & FINISHED) != 0) { - GC_record_stack_base(me, sb); - me -> flags &= ~FINISHED; /* but not DETACHED */ -# ifdef THREAD_LOCAL_ALLOC - GC_init_thread_local((GC_tlfs)(&me->tlfs)); -# endif - UNLOCK(); - return GC_SUCCESS; - } else -# endif - /* else */ { - UNLOCK(); - return GC_DUPLICATE; - } -} - -/* Similar to that in pthread_support.c. */ -STATIC void GC_wait_for_gc_completion(GC_bool wait_for_all) -{ - GC_ASSERT(I_HOLD_LOCK()); - if (GC_incremental && GC_collection_in_progress()) { - word old_gc_no = GC_gc_no; - - /* Make sure that no part of our stack is still on the mark stack, */ - /* since it's about to be unmapped. */ - do { - ENTER_GC(); - GC_in_thread_creation = TRUE; - GC_collect_a_little_inner(1); - GC_in_thread_creation = FALSE; - EXIT_GC(); - - UNLOCK(); - Sleep(0); /* yield */ - LOCK(); - } while (GC_incremental && GC_collection_in_progress() - && (wait_for_all || old_gc_no == GC_gc_no)); - } -} - -GC_API int GC_CALL GC_unregister_my_thread(void) -{ - DCL_LOCK_STATE; - -# ifdef DEBUG_THREADS - GC_log_printf("Unregistering thread 0x%lx\n", (long)GetCurrentThreadId()); -# endif - - if (GC_win32_dll_threads) { -# if defined(THREAD_LOCAL_ALLOC) - /* Can't happen: see GC_use_threads_discovery(). */ - GC_ASSERT(FALSE); -# else - /* FIXME: Should we just ignore this? */ - GC_delete_thread(GetCurrentThreadId()); -# endif - } else { -# if defined(THREAD_LOCAL_ALLOC) || defined(GC_PTHREADS) - GC_thread me; -# endif - DWORD thread_id = GetCurrentThreadId(); - - LOCK(); - GC_wait_for_gc_completion(FALSE); -# if defined(THREAD_LOCAL_ALLOC) || defined(GC_PTHREADS) - me = GC_lookup_thread_inner(thread_id); - CHECK_LOOKUP_MY_THREAD(me); - GC_ASSERT(!KNOWN_FINISHED(me)); -# endif -# if defined(THREAD_LOCAL_ALLOC) - GC_ASSERT(GC_getspecific(GC_thread_key) == &me->tlfs); - GC_destroy_thread_local(&(me->tlfs)); -# endif -# ifdef GC_PTHREADS - if ((me -> flags & DETACHED) == 0) { - me -> flags |= FINISHED; - } else -# endif - /* else */ { - GC_delete_thread(thread_id); - } -# if defined(THREAD_LOCAL_ALLOC) - /* It is required to call remove_specific defined in specific.c. */ - GC_remove_specific(GC_thread_key); -# endif - UNLOCK(); - } - return GC_SUCCESS; -} - -/* Wrapper for functions that are likely to block for an appreciable */ -/* length of time. */ - -/* GC_do_blocking_inner() is nearly the same as in pthread_support.c */ -GC_INNER void GC_do_blocking_inner(ptr_t data, void * context GC_ATTR_UNUSED) -{ - struct blocking_data * d = (struct blocking_data *) data; - DWORD thread_id = GetCurrentThreadId(); - GC_thread me; -# ifdef IA64 - ptr_t stack_ptr = GC_save_regs_in_stack(); -# endif - DCL_LOCK_STATE; - - LOCK(); - me = GC_lookup_thread_inner(thread_id); - CHECK_LOOKUP_MY_THREAD(me); - GC_ASSERT(me -> thread_blocked_sp == NULL); -# ifdef IA64 - me -> backing_store_ptr = stack_ptr; -# endif - me -> thread_blocked_sp = (ptr_t) &d; /* save approx. sp */ - /* Save context here if we want to support precise stack marking */ - UNLOCK(); - d -> client_data = (d -> fn)(d -> client_data); - LOCK(); /* This will block if the world is stopped. */ - me -> thread_blocked_sp = NULL; - UNLOCK(); -} - -/* GC_call_with_gc_active() has the opposite to GC_do_blocking() */ -/* functionality. It might be called from a user function invoked by */ -/* GC_do_blocking() to temporarily back allow calling any GC function */ -/* and/or manipulating pointers to the garbage collected heap. */ -GC_API void * GC_CALL GC_call_with_gc_active(GC_fn_type fn, - void * client_data) -{ - struct GC_traced_stack_sect_s stacksect; - DWORD thread_id = GetCurrentThreadId(); - GC_thread me; - DCL_LOCK_STATE; - - LOCK(); /* This will block if the world is stopped. */ - me = GC_lookup_thread_inner(thread_id); - CHECK_LOOKUP_MY_THREAD(me); - /* Adjust our stack base value (this could happen unless */ - /* GC_get_stack_base() was used which returned GC_SUCCESS). */ - GC_ASSERT(me -> stack_base != NULL); - if ((word)me->stack_base < (word)(&stacksect)) - me -> stack_base = (ptr_t)(&stacksect); - - if (me -> thread_blocked_sp == NULL) { - /* We are not inside GC_do_blocking() - do nothing more. */ - UNLOCK(); - client_data = fn(client_data); - /* Prevent treating the above as a tail call. */ - GC_noop1((word)(&stacksect)); - return client_data; /* result */ - } - - /* Setup new "stack section". */ - stacksect.saved_stack_ptr = me -> thread_blocked_sp; -# ifdef IA64 - /* This is the same as in GC_call_with_stack_base(). */ - stacksect.backing_store_end = GC_save_regs_in_stack(); - /* Unnecessarily flushes register stack, */ - /* but that probably doesn't hurt. */ - stacksect.saved_backing_store_ptr = me -> backing_store_ptr; -# endif - stacksect.prev = me -> traced_stack_sect; - me -> thread_blocked_sp = NULL; - me -> traced_stack_sect = &stacksect; - - UNLOCK(); - client_data = fn(client_data); - GC_ASSERT(me -> thread_blocked_sp == NULL); - GC_ASSERT(me -> traced_stack_sect == &stacksect); - - /* Restore original "stack section". */ - LOCK(); - me -> traced_stack_sect = stacksect.prev; -# ifdef IA64 - me -> backing_store_ptr = stacksect.saved_backing_store_ptr; -# endif - me -> thread_blocked_sp = stacksect.saved_stack_ptr; - UNLOCK(); - - return client_data; /* result */ -} - -#ifdef GC_PTHREADS - - /* A quick-and-dirty cache of the mapping between pthread_t */ - /* and win32 thread id. */ -# define PTHREAD_MAP_SIZE 512 - DWORD GC_pthread_map_cache[PTHREAD_MAP_SIZE] = {0}; -# define PTHREAD_MAP_INDEX(pthread_id) \ - ((NUMERIC_THREAD_ID(pthread_id) >> 5) % PTHREAD_MAP_SIZE) - /* It appears pthread_t is really a pointer type ... */ -# define SET_PTHREAD_MAP_CACHE(pthread_id, win32_id) \ - (void)(GC_pthread_map_cache[PTHREAD_MAP_INDEX(pthread_id)] = (win32_id)) -# define GET_PTHREAD_MAP_CACHE(pthread_id) \ - GC_pthread_map_cache[PTHREAD_MAP_INDEX(pthread_id)] - - /* Return a GC_thread corresponding to a given pthread_t. */ - /* Returns 0 if it's not there. */ - /* We assume that this is only called for pthread ids that */ - /* have not yet terminated or are still joinable, and */ - /* cannot be concurrently terminated. */ - /* Assumes we do NOT hold the allocation lock. */ - STATIC GC_thread GC_lookup_pthread(pthread_t id) - { -# ifndef GC_NO_THREADS_DISCOVERY - if (GC_win32_dll_threads) { - int i; - LONG my_max = GC_get_max_thread_index(); - - for (i = 0; i <= my_max && - (!AO_load_acquire(&dll_thread_table[i].tm.in_use) - || THREAD_EQUAL(dll_thread_table[i].pthread_id, id)); - /* Must still be in_use, since nobody else can */ - /* store our thread_id. */ - i++) { - /* empty */ - } - return i <= my_max ? (GC_thread)(dll_thread_table + i) : NULL; - } else -# endif - /* else */ { - /* We first try the cache. If that fails, we use a very slow */ - /* approach. */ - word hv_guess = THREAD_TABLE_INDEX(GET_PTHREAD_MAP_CACHE(id)); - int hv; - GC_thread p; - DCL_LOCK_STATE; - - LOCK(); - for (p = GC_threads[hv_guess]; 0 != p; p = p -> tm.next) { - if (THREAD_EQUAL(p -> pthread_id, id)) - goto foundit; - } - for (hv = 0; hv < THREAD_TABLE_SZ; ++hv) { - for (p = GC_threads[hv]; 0 != p; p = p -> tm.next) { - if (THREAD_EQUAL(p -> pthread_id, id)) - goto foundit; - } - } - p = 0; - foundit: - UNLOCK(); - return p; - } - } - -#endif /* GC_PTHREADS */ - -#ifdef CAN_HANDLE_FORK - /* Similar to that in pthread_support.c but also rehashes the table */ - /* since hash map key (thread_id) differs from that in the parent. */ - STATIC void GC_remove_all_threads_but_me(void) - { - int hv; - GC_thread p, next, me = NULL; - DWORD thread_id; - pthread_t pthread_id = pthread_self(); /* same as in parent */ - - GC_ASSERT(!GC_win32_dll_threads); - for (hv = 0; hv < THREAD_TABLE_SZ; ++hv) { - for (p = GC_threads[hv]; 0 != p; p = next) { - next = p -> tm.next; - if (THREAD_EQUAL(p -> pthread_id, pthread_id)) { - GC_ASSERT(me == NULL); - me = p; - p -> tm.next = 0; - } else { -# ifdef THREAD_LOCAL_ALLOC - if ((p -> flags & FINISHED) == 0) { - GC_destroy_thread_local(&p->tlfs); - GC_remove_specific(GC_thread_key); - } -# endif - if (&first_thread != p) - GC_INTERNAL_FREE(p); - } - } - GC_threads[hv] = NULL; - } - - /* Put "me" back to GC_threads. */ - GC_ASSERT(me != NULL); - thread_id = GetCurrentThreadId(); /* differs from that in parent */ - GC_threads[THREAD_TABLE_INDEX(thread_id)] = me; - - /* Update Win32 thread Id and handle. */ - me -> id = thread_id; -# ifndef MSWINCE - if (!DuplicateHandle(GetCurrentProcess(), GetCurrentThread(), - GetCurrentProcess(), (HANDLE *)&me->handle, - 0 /* dwDesiredAccess */, FALSE /* bInheritHandle */, - DUPLICATE_SAME_ACCESS)) - ABORT("DuplicateHandle failed"); -# endif - -# if defined(THREAD_LOCAL_ALLOC) && !defined(USE_CUSTOM_SPECIFIC) - /* For Cygwin, we need to re-assign thread-local pointer to */ - /* 'tlfs' (it is OK to call GC_destroy_thread_local and */ - /* GC_free_internal before this action). */ - if (GC_setspecific(GC_thread_key, &me->tlfs) != 0) - ABORT("GC_setspecific failed (in child)"); -# endif - } - - static void fork_prepare_proc(void) - { - LOCK(); -# ifdef PARALLEL_MARK - if (GC_parallel) - GC_wait_for_reclaim(); -# endif - GC_wait_for_gc_completion(TRUE); -# ifdef PARALLEL_MARK - if (GC_parallel) - GC_acquire_mark_lock(); -# endif - } - - static void fork_parent_proc(void) - { -# ifdef PARALLEL_MARK - if (GC_parallel) - GC_release_mark_lock(); -# endif - UNLOCK(); - } - - static void fork_child_proc(void) - { -# ifdef PARALLEL_MARK - if (GC_parallel) { - GC_release_mark_lock(); - GC_parallel = FALSE; /* or GC_markers_m1 = 0 */ - /* Turn off parallel marking in the child, since we are */ - /* probably just going to exec, and we would have to */ - /* restart mark threads. */ - } -# endif - GC_remove_all_threads_but_me(); - UNLOCK(); - } - - /* Routines for fork handling by client (no-op if pthread_atfork works). */ - GC_API void GC_CALL GC_atfork_prepare(void) - { - if (GC_handle_fork <= 0) - fork_prepare_proc(); - } - - GC_API void GC_CALL GC_atfork_parent(void) - { - if (GC_handle_fork <= 0) - fork_parent_proc(); - } - - GC_API void GC_CALL GC_atfork_child(void) - { - if (GC_handle_fork <= 0) - fork_child_proc(); - } -#endif /* CAN_HANDLE_FORK */ - -void GC_push_thread_structures(void) -{ - GC_ASSERT(I_HOLD_LOCK()); -# ifndef GC_NO_THREADS_DISCOVERY - if (GC_win32_dll_threads) { - /* Unlike the other threads implementations, the thread table */ - /* here contains no pointers to the collectible heap (note also */ - /* that GC_PTHREADS is incompatible with DllMain-based thread */ - /* registration). Thus we have no private structures we need */ - /* to preserve. */ - } else -# endif - /* else */ { - GC_push_all((ptr_t)(GC_threads), (ptr_t)(GC_threads)+sizeof(GC_threads)); - } -# if defined(THREAD_LOCAL_ALLOC) - GC_push_all((ptr_t)(&GC_thread_key), - (ptr_t)(&GC_thread_key) + sizeof(GC_thread_key)); - /* Just in case we ever use our own TLS implementation. */ -# endif -} - -/* Suspend the given thread, if it's still active. */ -STATIC void GC_suspend(GC_thread t) -{ -# ifndef MSWINCE - /* Apparently the Windows 95 GetOpenFileName call creates */ - /* a thread that does not properly get cleaned up, and */ - /* SuspendThread on its descriptor may provoke a crash. */ - /* This reduces the probability of that event, though it still */ - /* appears there's a race here. */ - DWORD exitCode; -# endif - UNPROTECT_THREAD(t); -# ifndef MSWINCE - if (GetExitCodeThread(t -> handle, &exitCode) && - exitCode != STILL_ACTIVE) { -# ifdef GC_PTHREADS - t -> stack_base = 0; /* prevent stack from being pushed */ -# else - /* this breaks pthread_join on Cygwin, which is guaranteed to */ - /* only see user pthreads */ - GC_ASSERT(GC_win32_dll_threads); - GC_delete_gc_thread_no_free(t); -# endif - return; - } -# endif -# if defined(MPROTECT_VDB) - /* Acquire the spin lock we use to update dirty bits. */ - /* Threads shouldn't get stopped holding it. But we may */ - /* acquire and release it in the UNPROTECT_THREAD call. */ - while (AO_test_and_set_acquire(&GC_fault_handler_lock) == AO_TS_SET) { - /* empty */ - } -# endif - -# ifdef MSWINCE - /* SuspendThread() will fail if thread is running kernel code. */ - while (SuspendThread(THREAD_HANDLE(t)) == (DWORD)-1) - Sleep(10); /* in millis */ -# else - if (SuspendThread(t -> handle) == (DWORD)-1) - ABORT("SuspendThread failed"); -# endif /* !MSWINCE */ - t -> suspended = (unsigned char)TRUE; -# if defined(MPROTECT_VDB) - AO_CLEAR(&GC_fault_handler_lock); -# endif -} - -#if defined(GC_ASSERTIONS) && !defined(CYGWIN32) - GC_INNER GC_bool GC_write_disabled = FALSE; - /* TRUE only if GC_stop_world() acquired GC_write_cs. */ -#endif - -GC_INNER void GC_stop_world(void) -{ - DWORD thread_id = GetCurrentThreadId(); - - if (!GC_thr_initialized) - ABORT("GC_stop_world() called before GC_thr_init()"); - GC_ASSERT(I_HOLD_LOCK()); - - /* This code is the same as in pthread_stop_world.c */ -# ifdef PARALLEL_MARK - if (GC_parallel) { - GC_acquire_mark_lock(); - GC_ASSERT(GC_fl_builder_count == 0); - /* We should have previously waited for it to become zero. */ - } -# endif /* PARALLEL_MARK */ - -# if !defined(GC_NO_THREADS_DISCOVERY) || defined(GC_ASSERTIONS) - GC_please_stop = TRUE; -# endif -# ifndef CYGWIN32 - GC_ASSERT(!GC_write_disabled); - EnterCriticalSection(&GC_write_cs); - /* It's not allowed to call GC_printf() (and friends) here down to */ - /* LeaveCriticalSection (same applies recursively to GC_suspend, */ - /* GC_delete_gc_thread_no_free, GC_get_max_thread_index, GC_size */ - /* and GC_remove_protection). */ -# ifdef GC_ASSERTIONS - GC_write_disabled = TRUE; -# endif -# endif -# ifndef GC_NO_THREADS_DISCOVERY - if (GC_win32_dll_threads) { - int i; - int my_max; - /* Any threads being created during this loop will end up setting */ - /* GC_attached_thread when they start. This will force marking */ - /* to restart. This is not ideal, but hopefully correct. */ - AO_store(&GC_attached_thread, FALSE); - my_max = (int)GC_get_max_thread_index(); - for (i = 0; i <= my_max; i++) { - GC_vthread t = dll_thread_table + i; - if (t -> stack_base != 0 && t -> thread_blocked_sp == NULL - && t -> id != thread_id) { - GC_suspend((GC_thread)t); - } - } - } else -# endif - /* else */ { - GC_thread t; - int i; - - for (i = 0; i < THREAD_TABLE_SZ; i++) { - for (t = GC_threads[i]; t != 0; t = t -> tm.next) { - if (t -> stack_base != 0 && t -> thread_blocked_sp == NULL - && !KNOWN_FINISHED(t) && t -> id != thread_id) { - GC_suspend(t); - } - } - } - } -# ifndef CYGWIN32 -# ifdef GC_ASSERTIONS - GC_write_disabled = FALSE; -# endif - LeaveCriticalSection(&GC_write_cs); -# endif -# ifdef PARALLEL_MARK - if (GC_parallel) - GC_release_mark_lock(); -# endif -} - -GC_INNER void GC_start_world(void) -{ -# ifdef GC_ASSERTIONS - DWORD thread_id = GetCurrentThreadId(); -# endif - int i; - - GC_ASSERT(I_HOLD_LOCK()); - if (GC_win32_dll_threads) { - LONG my_max = GC_get_max_thread_index(); - for (i = 0; i <= my_max; i++) { - GC_thread t = (GC_thread)(dll_thread_table + i); - if (t -> suspended) { - GC_ASSERT(t -> stack_base != 0 && t -> id != thread_id); - if (ResumeThread(THREAD_HANDLE(t)) == (DWORD)-1) - ABORT("ResumeThread failed"); - t -> suspended = FALSE; - } - } - } else { - GC_thread t; - int i; - - for (i = 0; i < THREAD_TABLE_SZ; i++) { - for (t = GC_threads[i]; t != 0; t = t -> tm.next) { - if (t -> suspended) { - GC_ASSERT(t -> stack_base != 0 && t -> id != thread_id); - if (ResumeThread(THREAD_HANDLE(t)) == (DWORD)-1) - ABORT("ResumeThread failed"); - UNPROTECT_THREAD(t); - t -> suspended = FALSE; - } - } - } - } -# if !defined(GC_NO_THREADS_DISCOVERY) || defined(GC_ASSERTIONS) - GC_please_stop = FALSE; -# endif -} - -#ifdef MSWINCE - /* The VirtualQuery calls below won't work properly on some old WinCE */ - /* versions, but since each stack is restricted to an aligned 64 KiB */ - /* region of virtual memory we can just take the next lowest multiple */ - /* of 64 KiB. The result of this macro must not be used as its */ - /* argument later and must not be used as the lower bound for sp */ - /* check (since the stack may be bigger than 64 KiB). */ -# define GC_wince_evaluate_stack_min(s) \ - (ptr_t)(((word)(s) - 1) & ~(word)0xFFFF) -#elif defined(GC_ASSERTIONS) -# define GC_dont_query_stack_min FALSE -#endif - -/* A cache holding the results of the recent VirtualQuery call. */ -/* Protected by the allocation lock. */ -static ptr_t last_address = 0; -static MEMORY_BASIC_INFORMATION last_info; - -/* Probe stack memory region (starting at "s") to find out its */ -/* lowest address (i.e. stack top). */ -/* S must be a mapped address inside the region, NOT the first */ -/* unmapped address. */ -STATIC ptr_t GC_get_stack_min(ptr_t s) -{ - ptr_t bottom; - - GC_ASSERT(I_HOLD_LOCK()); - if (s != last_address) { - VirtualQuery(s, &last_info, sizeof(last_info)); - last_address = s; - } - do { - bottom = last_info.BaseAddress; - VirtualQuery(bottom - 1, &last_info, sizeof(last_info)); - last_address = bottom - 1; - } while ((last_info.Protect & PAGE_READWRITE) - && !(last_info.Protect & PAGE_GUARD)); - return(bottom); -} - -/* Return true if the page at s has protections appropriate */ -/* for a stack page. */ -static GC_bool may_be_in_stack(ptr_t s) -{ - GC_ASSERT(I_HOLD_LOCK()); - if (s != last_address) { - VirtualQuery(s, &last_info, sizeof(last_info)); - last_address = s; - } - return (last_info.Protect & PAGE_READWRITE) - && !(last_info.Protect & PAGE_GUARD); -} - -STATIC word GC_push_stack_for(GC_thread thread, DWORD me) -{ - ptr_t sp, stack_min; - - struct GC_traced_stack_sect_s *traced_stack_sect = - thread -> traced_stack_sect; - if (thread -> id == me) { - GC_ASSERT(thread -> thread_blocked_sp == NULL); - sp = GC_approx_sp(); - } else if ((sp = thread -> thread_blocked_sp) == NULL) { - /* Use saved sp value for blocked threads. */ - /* For unblocked threads call GetThreadContext(). */ - CONTEXT context; - context.ContextFlags = CONTEXT_INTEGER|CONTEXT_CONTROL; - if (!GetThreadContext(THREAD_HANDLE(thread), &context)) - ABORT("GetThreadContext failed"); - - /* Push all registers that might point into the heap. Frame */ - /* pointer registers are included in case client code was */ - /* compiled with the 'omit frame pointer' optimization. */ -# define PUSH1(reg) GC_push_one((word)context.reg) -# define PUSH2(r1,r2) (PUSH1(r1), PUSH1(r2)) -# define PUSH4(r1,r2,r3,r4) (PUSH2(r1,r2), PUSH2(r3,r4)) -# if defined(I386) - PUSH4(Edi,Esi,Ebx,Edx), PUSH2(Ecx,Eax), PUSH1(Ebp); - sp = (ptr_t)context.Esp; -# elif defined(X86_64) - PUSH4(Rax,Rcx,Rdx,Rbx); PUSH2(Rbp, Rsi); PUSH1(Rdi); - PUSH4(R8, R9, R10, R11); PUSH4(R12, R13, R14, R15); - sp = (ptr_t)context.Rsp; -# elif defined(ARM32) - PUSH4(R0,R1,R2,R3),PUSH4(R4,R5,R6,R7),PUSH4(R8,R9,R10,R11); - PUSH1(R12); - sp = (ptr_t)context.Sp; -# elif defined(SHx) - PUSH4(R0,R1,R2,R3), PUSH4(R4,R5,R6,R7), PUSH4(R8,R9,R10,R11); - PUSH2(R12,R13), PUSH1(R14); - sp = (ptr_t)context.R15; -# elif defined(MIPS) - PUSH4(IntAt,IntV0,IntV1,IntA0), PUSH4(IntA1,IntA2,IntA3,IntT0); - PUSH4(IntT1,IntT2,IntT3,IntT4), PUSH4(IntT5,IntT6,IntT7,IntS0); - PUSH4(IntS1,IntS2,IntS3,IntS4), PUSH4(IntS5,IntS6,IntS7,IntT8); - PUSH4(IntT9,IntK0,IntK1,IntS8); - sp = (ptr_t)context.IntSp; -# elif defined(PPC) - PUSH4(Gpr0, Gpr3, Gpr4, Gpr5), PUSH4(Gpr6, Gpr7, Gpr8, Gpr9); - PUSH4(Gpr10,Gpr11,Gpr12,Gpr14), PUSH4(Gpr15,Gpr16,Gpr17,Gpr18); - PUSH4(Gpr19,Gpr20,Gpr21,Gpr22), PUSH4(Gpr23,Gpr24,Gpr25,Gpr26); - PUSH4(Gpr27,Gpr28,Gpr29,Gpr30), PUSH1(Gpr31); - sp = (ptr_t)context.Gpr1; -# elif defined(ALPHA) - PUSH4(IntV0,IntT0,IntT1,IntT2), PUSH4(IntT3,IntT4,IntT5,IntT6); - PUSH4(IntT7,IntS0,IntS1,IntS2), PUSH4(IntS3,IntS4,IntS5,IntFp); - PUSH4(IntA0,IntA1,IntA2,IntA3), PUSH4(IntA4,IntA5,IntT8,IntT9); - PUSH4(IntT10,IntT11,IntT12,IntAt); - sp = (ptr_t)context.IntSp; -# else -# error "architecture is not supported" -# endif - } /* ! current thread */ - - /* Set stack_min to the lowest address in the thread stack, */ - /* or to an address in the thread stack no larger than sp, */ - /* taking advantage of the old value to avoid slow traversals */ - /* of large stacks. */ - if (thread -> last_stack_min == ADDR_LIMIT) { -# ifdef MSWINCE - if (GC_dont_query_stack_min) { - stack_min = GC_wince_evaluate_stack_min(traced_stack_sect != NULL ? - (ptr_t)traced_stack_sect : thread -> stack_base); - /* Keep last_stack_min value unmodified. */ - } else -# endif - /* else */ { - stack_min = GC_get_stack_min(traced_stack_sect != NULL ? - (ptr_t)traced_stack_sect : thread -> stack_base); - UNPROTECT_THREAD(thread); - thread -> last_stack_min = stack_min; - } - } else { - /* First, adjust the latest known minimum stack address if we */ - /* are inside GC_call_with_gc_active(). */ - if (traced_stack_sect != NULL && - (word)thread->last_stack_min > (word)traced_stack_sect) { - UNPROTECT_THREAD(thread); - thread -> last_stack_min = (ptr_t)traced_stack_sect; - } - - if ((word)sp < (word)thread->stack_base - && (word)sp >= (word)thread->last_stack_min) { - stack_min = sp; - } else { - /* In the current thread it is always safe to use sp value. */ - if (may_be_in_stack(thread -> id == me && - (word)sp < (word)thread->last_stack_min ? - sp : thread -> last_stack_min)) { - stack_min = last_info.BaseAddress; - /* Do not probe rest of the stack if sp is correct. */ - if ((word)sp < (word)stack_min - || (word)sp >= (word)thread->stack_base) - stack_min = GC_get_stack_min(thread -> last_stack_min); - } else { - /* Stack shrunk? Is this possible? */ - stack_min = GC_get_stack_min(thread -> stack_base); - } - UNPROTECT_THREAD(thread); - thread -> last_stack_min = stack_min; - } - } - - GC_ASSERT(GC_dont_query_stack_min - || stack_min == GC_get_stack_min(thread -> stack_base) - || ((word)sp >= (word)stack_min - && (word)stack_min < (word)thread->stack_base - && (word)stack_min - > (word)GC_get_stack_min(thread -> stack_base))); - - if ((word)sp >= (word)stack_min && (word)sp < (word)thread->stack_base) { -# ifdef DEBUG_THREADS - GC_log_printf("Pushing stack for 0x%x from sp %p to %p from 0x%x\n", - (int)thread -> id, sp, thread -> stack_base, (int)me); -# endif - GC_push_all_stack_sections(sp, thread->stack_base, traced_stack_sect); - } else { - /* If not current thread then it is possible for sp to point to */ - /* the guarded (untouched yet) page just below the current */ - /* stack_min of the thread. */ - if (thread -> id == me || (word)sp >= (word)thread->stack_base - || (word)(sp + GC_page_size) < (word)stack_min) - WARN("Thread stack pointer %p out of range, pushing everything\n", - sp); -# ifdef DEBUG_THREADS - GC_log_printf("Pushing stack for 0x%x from (min) %p to %p from 0x%x\n", - (int)thread->id, stack_min, thread->stack_base, (int)me); -# endif - /* Push everything - ignore "traced stack section" data. */ - GC_push_all_stack(stack_min, thread->stack_base); - } - return thread->stack_base - sp; /* stack grows down */ -} - -GC_INNER void GC_push_all_stacks(void) -{ - DWORD thread_id = GetCurrentThreadId(); - GC_bool found_me = FALSE; -# ifndef SMALL_CONFIG - unsigned nthreads = 0; -# endif - word total_size = 0; -# ifndef GC_NO_THREADS_DISCOVERY - if (GC_win32_dll_threads) { - int i; - LONG my_max = GC_get_max_thread_index(); - - for (i = 0; i <= my_max; i++) { - GC_thread t = (GC_thread)(dll_thread_table + i); - if (t -> tm.in_use && t -> stack_base) { -# ifndef SMALL_CONFIG - ++nthreads; -# endif - total_size += GC_push_stack_for(t, thread_id); - if (t -> id == thread_id) found_me = TRUE; - } - } - } else -# endif - /* else */ { - int i; - for (i = 0; i < THREAD_TABLE_SZ; i++) { - GC_thread t; - for (t = GC_threads[i]; t != 0; t = t -> tm.next) { - if (!KNOWN_FINISHED(t) && t -> stack_base) { -# ifndef SMALL_CONFIG - ++nthreads; -# endif - total_size += GC_push_stack_for(t, thread_id); - if (t -> id == thread_id) found_me = TRUE; - } - } - } - } -# ifndef SMALL_CONFIG - GC_VERBOSE_LOG_PRINTF("Pushed %d thread stacks%s\n", nthreads, - GC_win32_dll_threads ? - " based on DllMain thread tracking" : ""); -# endif - if (!found_me && !GC_in_thread_creation) - ABORT("Collecting from unknown thread"); - GC_total_stacksize = total_size; -} - -#ifdef PARALLEL_MARK - -# ifndef MAX_MARKERS -# define MAX_MARKERS 16 -# endif - - static ptr_t marker_sp[MAX_MARKERS - 1]; /* The cold end of the stack */ - /* for markers. */ -# ifdef IA64 - static ptr_t marker_bsp[MAX_MARKERS - 1]; -# endif - - static ptr_t marker_last_stack_min[MAX_MARKERS - 1]; - /* Last known minimum (hottest) address */ - /* in stack (or ADDR_LIMIT if unset) */ - /* for markers. */ - -#endif /* PARALLEL_MARK */ - -/* Find stack with the lowest address which overlaps the */ -/* interval [start, limit). */ -/* Return stack bounds in *lo and *hi. If no such stack */ -/* is found, both *hi and *lo will be set to an address */ -/* higher than limit. */ -GC_INNER void GC_get_next_stack(char *start, char *limit, - char **lo, char **hi) -{ - int i; - char * current_min = ADDR_LIMIT; /* Least in-range stack base */ - ptr_t *plast_stack_min = NULL; /* Address of last_stack_min */ - /* field for thread corresponding */ - /* to current_min. */ - GC_thread thread = NULL; /* Either NULL or points to the */ - /* thread's hash table entry */ - /* containing *plast_stack_min. */ - - /* First set current_min, ignoring limit. */ - if (GC_win32_dll_threads) { - LONG my_max = GC_get_max_thread_index(); - - for (i = 0; i <= my_max; i++) { - ptr_t s = (ptr_t)(dll_thread_table[i].stack_base); - - if ((word)s > (word)start && (word)s < (word)current_min) { - /* Update address of last_stack_min. */ - plast_stack_min = (ptr_t * /* no volatile */) - &dll_thread_table[i].last_stack_min; - current_min = s; - } - } - } else { - for (i = 0; i < THREAD_TABLE_SZ; i++) { - GC_thread t; - - for (t = GC_threads[i]; t != 0; t = t -> tm.next) { - ptr_t s = t -> stack_base; - - if ((word)s > (word)start && (word)s < (word)current_min) { - /* Update address of last_stack_min. */ - plast_stack_min = &t -> last_stack_min; - thread = t; /* Remember current thread to unprotect. */ - current_min = s; - } - } - } -# ifdef PARALLEL_MARK - for (i = 0; i < GC_markers_m1; ++i) { - ptr_t s = marker_sp[i]; -# ifdef IA64 - /* FIXME: not implemented */ -# endif - if ((word)s > (word)start && (word)s < (word)current_min) { - GC_ASSERT(marker_last_stack_min[i] != NULL); - plast_stack_min = &marker_last_stack_min[i]; - current_min = s; - thread = NULL; /* Not a thread's hash table entry. */ - } - } -# endif - } - - *hi = current_min; - if (current_min == ADDR_LIMIT) { - *lo = ADDR_LIMIT; - return; - } - - GC_ASSERT((word)current_min > (word)start && plast_stack_min != NULL); -# ifdef MSWINCE - if (GC_dont_query_stack_min) { - *lo = GC_wince_evaluate_stack_min(current_min); - /* Keep last_stack_min value unmodified. */ - return; - } -# endif - - if ((word)current_min > (word)limit && !may_be_in_stack(limit)) { - /* Skip the rest since the memory region at limit address is */ - /* not a stack (so the lowest address of the found stack would */ - /* be above the limit value anyway). */ - *lo = ADDR_LIMIT; - return; - } - - /* Get the minimum address of the found stack by probing its memory */ - /* region starting from the recent known minimum (if set). */ - if (*plast_stack_min == ADDR_LIMIT - || !may_be_in_stack(*plast_stack_min)) { - /* Unsafe to start from last_stack_min value. */ - *lo = GC_get_stack_min(current_min); - } else { - /* Use the recent value to optimize search for min address. */ - *lo = GC_get_stack_min(*plast_stack_min); - } - - /* Remember current stack_min value. */ - if (thread != NULL) { - UNPROTECT_THREAD(thread); - } - *plast_stack_min = *lo; -} - -#ifdef PARALLEL_MARK - -# if defined(GC_PTHREADS) && !defined(GC_PTHREADS_PARAMARK) - /* Use pthread-based parallel mark implementation. */ -# define GC_PTHREADS_PARAMARK -# endif - -# if !defined(GC_PTHREADS_PARAMARK) - STATIC HANDLE GC_marker_cv[MAX_MARKERS - 1] = {0}; - /* Events with manual reset (one for each */ - /* mark helper). */ - - STATIC DWORD GC_marker_Id[MAX_MARKERS - 1] = {0}; - /* This table is used for mapping helper */ - /* threads ID to mark helper index (linear */ - /* search is used since the mapping contains */ - /* only a few entries). */ -# endif - - /* GC_mark_thread() is the same as in pthread_support.c */ -# ifdef GC_PTHREADS_PARAMARK - STATIC void * GC_mark_thread(void * id) -# else -# ifdef MSWINCE - STATIC DWORD WINAPI GC_mark_thread(LPVOID id) -# else - STATIC unsigned __stdcall GC_mark_thread(void * id) -# endif -# endif - { - word my_mark_no = 0; - - if ((word)id == (word)-1) return 0; /* to make compiler happy */ - marker_sp[(word)id] = GC_approx_sp(); -# ifdef IA64 - marker_bsp[(word)id] = GC_save_regs_in_stack(); -# endif -# if !defined(GC_PTHREADS_PARAMARK) - GC_marker_Id[(word)id] = GetCurrentThreadId(); -# endif - - for (;; ++my_mark_no) { - if (my_mark_no - GC_mark_no > (word)2) { - /* resynchronize if we get far off, e.g. because GC_mark_no */ - /* wrapped. */ - my_mark_no = GC_mark_no; - } -# ifdef DEBUG_THREADS - GC_log_printf("Starting mark helper for mark number %lu\n", - (unsigned long)my_mark_no); -# endif - GC_help_marker(my_mark_no); - } - } - -# ifndef GC_ASSERTIONS -# define SET_MARK_LOCK_HOLDER (void)0 -# define UNSET_MARK_LOCK_HOLDER (void)0 -# endif - - /* GC_mark_threads[] is unused here unlike that in pthread_support.c */ - -# ifndef CAN_HANDLE_FORK -# define available_markers_m1 GC_markers_m1 -# endif - -# ifdef GC_PTHREADS_PARAMARK -# include - -# ifndef NUMERIC_THREAD_ID -# define NUMERIC_THREAD_ID(id) (unsigned long)GC_PTHREAD_PTRVAL(id) - /* Id not guaranteed to be unique. */ -# endif - - /* start_mark_threads is the same as in pthread_support.c except */ - /* for thread stack that is assumed to be large enough. */ -# ifdef CAN_HANDLE_FORK - static int available_markers_m1 = 0; -# define start_mark_threads GC_start_mark_threads - GC_API void GC_CALL -# else - static void -# endif - start_mark_threads(void) - { - int i; - pthread_attr_t attr; - pthread_t new_thread; - - GC_ASSERT(I_DONT_HOLD_LOCK()); -# ifdef CAN_HANDLE_FORK - if (available_markers_m1 <= 0 || GC_parallel) return; - /* Skip if parallel markers disabled or already started. */ -# endif - - if (0 != pthread_attr_init(&attr)) ABORT("pthread_attr_init failed"); - if (0 != pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED)) - ABORT("pthread_attr_setdetachstate failed"); - - for (i = 0; i < available_markers_m1; ++i) { - marker_last_stack_min[i] = ADDR_LIMIT; - if (0 != pthread_create(&new_thread, &attr, - GC_mark_thread, (void *)(word)i)) { - WARN("Marker thread creation failed.\n", 0); - /* Don't try to create other marker threads. */ - break; - } - } - GC_markers_m1 = i; - (void)pthread_attr_destroy(&attr); - GC_COND_LOG_PRINTF("Started %d mark helper threads\n", GC_markers_m1); - } - -# ifdef GC_ASSERTIONS - STATIC unsigned long GC_mark_lock_holder = NO_THREAD; -# define SET_MARK_LOCK_HOLDER \ - (void)(GC_mark_lock_holder = NUMERIC_THREAD_ID(pthread_self())) -# define UNSET_MARK_LOCK_HOLDER \ - do { \ - GC_ASSERT(GC_mark_lock_holder \ - == NUMERIC_THREAD_ID(pthread_self())); \ - GC_mark_lock_holder = NO_THREAD; \ - } while (0) -# endif /* GC_ASSERTIONS */ - - static pthread_mutex_t mark_mutex = PTHREAD_MUTEX_INITIALIZER; - - static pthread_cond_t builder_cv = PTHREAD_COND_INITIALIZER; - - /* GC_acquire/release_mark_lock(), GC_wait_builder/marker(), */ - /* GC_wait_for_reclaim(), GC_notify_all_builder/marker() are the same */ - /* as in pthread_support.c except that GC_generic_lock() is not used. */ - -# ifdef LOCK_STATS - volatile AO_t GC_block_count = 0; -# endif - - GC_INNER void GC_acquire_mark_lock(void) - { -# ifdef NUMERIC_THREAD_ID_UNIQUE - GC_ASSERT(GC_mark_lock_holder != NUMERIC_THREAD_ID(pthread_self())); -# endif - if (pthread_mutex_lock(&mark_mutex) != 0) { - ABORT("pthread_mutex_lock failed"); - } -# ifdef LOCK_STATS - (void)AO_fetch_and_add1(&GC_block_count); -# endif - /* GC_generic_lock(&mark_mutex); */ - SET_MARK_LOCK_HOLDER; - } - - GC_INNER void GC_release_mark_lock(void) - { - UNSET_MARK_LOCK_HOLDER; - if (pthread_mutex_unlock(&mark_mutex) != 0) { - ABORT("pthread_mutex_unlock failed"); - } - } - - /* Collector must wait for a freelist builders for 2 reasons: */ - /* 1) Mark bits may still be getting examined without lock. */ - /* 2) Partial free lists referenced only by locals may not be */ - /* scanned correctly, e.g. if they contain "pointer-free" objects, */ - /* since the free-list link may be ignored. */ - STATIC void GC_wait_builder(void) - { - UNSET_MARK_LOCK_HOLDER; - if (pthread_cond_wait(&builder_cv, &mark_mutex) != 0) { - ABORT("pthread_cond_wait failed"); - } - GC_ASSERT(GC_mark_lock_holder == NO_THREAD); - SET_MARK_LOCK_HOLDER; - } - - GC_INNER void GC_wait_for_reclaim(void) - { - GC_acquire_mark_lock(); - while (GC_fl_builder_count > 0) { - GC_wait_builder(); - } - GC_release_mark_lock(); - } - - GC_INNER void GC_notify_all_builder(void) - { - GC_ASSERT(GC_mark_lock_holder == NUMERIC_THREAD_ID(pthread_self())); - if (pthread_cond_broadcast(&builder_cv) != 0) { - ABORT("pthread_cond_broadcast failed"); - } - } - - static pthread_cond_t mark_cv = PTHREAD_COND_INITIALIZER; - - GC_INNER void GC_wait_marker(void) - { - UNSET_MARK_LOCK_HOLDER; - if (pthread_cond_wait(&mark_cv, &mark_mutex) != 0) { - ABORT("pthread_cond_wait failed"); - } - GC_ASSERT(GC_mark_lock_holder == NO_THREAD); - SET_MARK_LOCK_HOLDER; - } - - GC_INNER void GC_notify_all_marker(void) - { - if (pthread_cond_broadcast(&mark_cv) != 0) { - ABORT("pthread_cond_broadcast failed"); - } - } - -# else /* ! GC_PTHREADS_PARAMARK */ - -# ifndef MARK_THREAD_STACK_SIZE -# define MARK_THREAD_STACK_SIZE 0 /* default value */ -# endif - - /* mark_mutex_event, builder_cv, mark_cv are initialized in GC_thr_init */ - static HANDLE mark_mutex_event = (HANDLE)0; /* Event with auto-reset. */ - static HANDLE builder_cv = (HANDLE)0; /* Event with manual reset. */ - static HANDLE mark_cv = (HANDLE)0; /* Event with manual reset. */ - - static void start_mark_threads(void) - { - int i; -# ifdef MSWINCE - HANDLE handle; - DWORD thread_id; -# else - GC_uintptr_t handle; - unsigned thread_id; -# endif - - /* Initialize GC_marker_cv[] fully before starting the */ - /* first helper thread. */ - for (i = 0; i < GC_markers_m1; ++i) { - if ((GC_marker_cv[i] = CreateEvent(NULL /* attrs */, - TRUE /* isManualReset */, - FALSE /* initialState */, - NULL /* name (A/W) */)) == (HANDLE)0) - ABORT("CreateEvent failed"); - } - - for (i = 0; i < GC_markers_m1; ++i) { - marker_last_stack_min[i] = ADDR_LIMIT; -# ifdef MSWINCE - /* There is no _beginthreadex() in WinCE. */ - handle = CreateThread(NULL /* lpsa */, - MARK_THREAD_STACK_SIZE /* ignored */, - GC_mark_thread, (LPVOID)(word)i, - 0 /* fdwCreate */, &thread_id); - if (handle == NULL) { - WARN("Marker thread creation failed\n", 0); - /* The most probable failure reason is "not enough memory". */ - /* Don't try to create other marker threads. */ - break; - } else { - /* It's safe to detach the thread. */ - CloseHandle(handle); - } -# else - handle = _beginthreadex(NULL /* security_attr */, - MARK_THREAD_STACK_SIZE, GC_mark_thread, - (void *)(word)i, 0 /* flags */, &thread_id); - if (!handle || handle == (GC_uintptr_t)-1L) { - WARN("Marker thread creation failed\n", 0); - /* Don't try to create other marker threads. */ - break; - } else {/* We may detach the thread (if handle is of HANDLE type) */ - /* CloseHandle((HANDLE)handle); */ - } -# endif - } - - /* Adjust GC_markers_m1 (and free unused resources) if failed. */ - while (GC_markers_m1 > i) { - GC_markers_m1--; - CloseHandle(GC_marker_cv[GC_markers_m1]); - } - GC_COND_LOG_PRINTF("Started %d mark helper threads\n", GC_markers_m1); - if (i == 0) { - CloseHandle(mark_cv); - CloseHandle(builder_cv); - CloseHandle(mark_mutex_event); - } - } - -# ifdef GC_ASSERTIONS - STATIC DWORD GC_mark_lock_holder = NO_THREAD; -# define SET_MARK_LOCK_HOLDER \ - (void)(GC_mark_lock_holder = GetCurrentThreadId()) -# define UNSET_MARK_LOCK_HOLDER \ - do { \ - GC_ASSERT(GC_mark_lock_holder == GetCurrentThreadId()); \ - GC_mark_lock_holder = NO_THREAD; \ - } while (0) -# endif /* GC_ASSERTIONS */ - - STATIC /* volatile */ LONG GC_mark_mutex_state = 0; - /* Mutex state: 0 - unlocked, */ - /* 1 - locked and no other waiters, */ - /* -1 - locked and waiters may exist. */ - /* Accessed by InterlockedExchange(). */ - - /* #define LOCK_STATS */ -# ifdef LOCK_STATS - volatile AO_t GC_block_count = 0; - volatile AO_t GC_unlocked_count = 0; -# endif - - GC_INNER void GC_acquire_mark_lock(void) - { - GC_ASSERT(GC_mark_lock_holder != GetCurrentThreadId()); - if (InterlockedExchange(&GC_mark_mutex_state, 1 /* locked */) != 0) { -# ifdef LOCK_STATS - (void)AO_fetch_and_add1(&GC_block_count); -# endif - /* Repeatedly reset the state and wait until acquire the lock. */ - while (InterlockedExchange(&GC_mark_mutex_state, - -1 /* locked_and_has_waiters */) != 0) { - if (WaitForSingleObject(mark_mutex_event, INFINITE) == WAIT_FAILED) - ABORT("WaitForSingleObject failed"); - } - } -# ifdef LOCK_STATS - else { - (void)AO_fetch_and_add1(&GC_unlocked_count); - } -# endif - - GC_ASSERT(GC_mark_lock_holder == NO_THREAD); - SET_MARK_LOCK_HOLDER; - } - - GC_INNER void GC_release_mark_lock(void) - { - UNSET_MARK_LOCK_HOLDER; - if (InterlockedExchange(&GC_mark_mutex_state, 0 /* unlocked */) < 0) { - /* wake a waiter */ - if (SetEvent(mark_mutex_event) == FALSE) - ABORT("SetEvent failed"); - } - } - - /* In GC_wait_for_reclaim/GC_notify_all_builder() we emulate POSIX */ - /* cond_wait/cond_broadcast() primitives with WinAPI Event object */ - /* (working in "manual reset" mode). This works here because */ - /* GC_notify_all_builder() is always called holding lock on */ - /* mark_mutex and the checked condition (GC_fl_builder_count == 0) */ - /* is the only one for which broadcasting on builder_cv is performed. */ - - GC_INNER void GC_wait_for_reclaim(void) - { - GC_ASSERT(builder_cv != 0); - for (;;) { - GC_acquire_mark_lock(); - if (GC_fl_builder_count == 0) - break; - if (ResetEvent(builder_cv) == FALSE) - ABORT("ResetEvent failed"); - GC_release_mark_lock(); - if (WaitForSingleObject(builder_cv, INFINITE) == WAIT_FAILED) - ABORT("WaitForSingleObject failed"); - } - GC_release_mark_lock(); - } - - GC_INNER void GC_notify_all_builder(void) - { - GC_ASSERT(GC_mark_lock_holder == GetCurrentThreadId()); - GC_ASSERT(builder_cv != 0); - GC_ASSERT(GC_fl_builder_count == 0); - if (SetEvent(builder_cv) == FALSE) - ABORT("SetEvent failed"); - } - - /* mark_cv is used (for waiting) by a non-helper thread. */ - - GC_INNER void GC_wait_marker(void) - { - HANDLE event = mark_cv; - DWORD thread_id = GetCurrentThreadId(); - int i = GC_markers_m1; - - while (i-- > 0) { - if (GC_marker_Id[i] == thread_id) { - event = GC_marker_cv[i]; - break; - } - } - - if (ResetEvent(event) == FALSE) - ABORT("ResetEvent failed"); - GC_release_mark_lock(); - if (WaitForSingleObject(event, INFINITE) == WAIT_FAILED) - ABORT("WaitForSingleObject failed"); - GC_acquire_mark_lock(); - } - - GC_INNER void GC_notify_all_marker(void) - { - DWORD thread_id = GetCurrentThreadId(); - int i = GC_markers_m1; - - while (i-- > 0) { - /* Notify every marker ignoring self (for efficiency). */ - if (SetEvent(GC_marker_Id[i] != thread_id ? GC_marker_cv[i] : - mark_cv) == FALSE) - ABORT("SetEvent failed"); - } - } - -# endif /* ! GC_PTHREADS_PARAMARK */ - -#endif /* PARALLEL_MARK */ - - /* We have no DllMain to take care of new threads. Thus we */ - /* must properly intercept thread creation. */ - - typedef struct { - LPTHREAD_START_ROUTINE start; - LPVOID param; - } thread_args; - - STATIC void * GC_CALLBACK GC_win32_start_inner(struct GC_stack_base *sb, - void *arg) - { - void * ret; - LPTHREAD_START_ROUTINE start = ((thread_args *)arg)->start; - LPVOID param = ((thread_args *)arg)->param; - - GC_register_my_thread(sb); /* This waits for an in-progress GC. */ - -# ifdef DEBUG_THREADS - GC_log_printf("thread 0x%lx starting...\n", (long)GetCurrentThreadId()); -# endif - - GC_free(arg); - - /* Clear the thread entry even if we exit with an exception. */ - /* This is probably pointless, since an uncaught exception is */ - /* supposed to result in the process being killed. */ -# ifndef __GNUC__ - __try -# endif - { - ret = (void *)(word)(*start)(param); - } -# ifndef __GNUC__ - __finally -# endif - { - GC_unregister_my_thread(); - } - -# ifdef DEBUG_THREADS - GC_log_printf("thread 0x%lx returned from start routine\n", - (long)GetCurrentThreadId()); -# endif - return ret; - } - - STATIC DWORD WINAPI GC_win32_start(LPVOID arg) - { - return (DWORD)(word)GC_call_with_stack_base(GC_win32_start_inner, arg); - } - - GC_API HANDLE WINAPI GC_CreateThread( - LPSECURITY_ATTRIBUTES lpThreadAttributes, - GC_WIN32_SIZE_T dwStackSize, - LPTHREAD_START_ROUTINE lpStartAddress, - LPVOID lpParameter, DWORD dwCreationFlags, - LPDWORD lpThreadId) - { - HANDLE thread_h; - thread_args *args; - - if (!EXPECT(parallel_initialized, TRUE)) - GC_init_parallel(); - /* make sure GC is initialized (i.e. main thread is */ - /* attached, tls initialized). */ - -# ifdef DEBUG_THREADS - GC_log_printf("About to create a thread from 0x%lx\n", - (long)GetCurrentThreadId()); -# endif - if (GC_win32_dll_threads) { - return CreateThread(lpThreadAttributes, dwStackSize, lpStartAddress, - lpParameter, dwCreationFlags, lpThreadId); - } else { - args = GC_malloc_uncollectable(sizeof(thread_args)); - /* Handed off to and deallocated by child thread. */ - if (0 == args) { - SetLastError(ERROR_NOT_ENOUGH_MEMORY); - return NULL; - } - - /* set up thread arguments */ - args -> start = lpStartAddress; - args -> param = lpParameter; - -# ifndef GC_ALWAYS_MULTITHREADED - GC_need_to_lock = TRUE; -# endif - thread_h = CreateThread(lpThreadAttributes, dwStackSize, GC_win32_start, - args, dwCreationFlags, lpThreadId); - if (thread_h == 0) GC_free(args); - return thread_h; - } - } - - GC_API DECLSPEC_NORETURN void WINAPI GC_ExitThread(DWORD dwExitCode) - { - GC_unregister_my_thread(); - ExitThread(dwExitCode); - } - -# if !defined(MSWINCE) && !defined(CYGWIN32) - - GC_API GC_uintptr_t GC_CALL GC_beginthreadex( - void *security, unsigned stack_size, - unsigned (__stdcall *start_address)(void *), - void *arglist, unsigned initflag, - unsigned *thrdaddr) - { - GC_uintptr_t thread_h; - thread_args *args; - - if (!EXPECT(parallel_initialized, TRUE)) - GC_init_parallel(); - /* make sure GC is initialized (i.e. main thread is */ - /* attached, tls initialized). */ -# ifdef DEBUG_THREADS - GC_log_printf("About to create a thread from 0x%lx\n", - (long)GetCurrentThreadId()); -# endif - - if (GC_win32_dll_threads) { - return _beginthreadex(security, stack_size, start_address, - arglist, initflag, thrdaddr); - } else { - args = GC_malloc_uncollectable(sizeof(thread_args)); - /* Handed off to and deallocated by child thread. */ - if (0 == args) { - /* MSDN docs say _beginthreadex() returns 0 on error and sets */ - /* errno to either EAGAIN (too many threads) or EINVAL (the */ - /* argument is invalid or the stack size is incorrect), so we */ - /* set errno to EAGAIN on "not enough memory". */ - errno = EAGAIN; - return 0; - } - - /* set up thread arguments */ - args -> start = (LPTHREAD_START_ROUTINE)start_address; - args -> param = arglist; - -# ifndef GC_ALWAYS_MULTITHREADED - GC_need_to_lock = TRUE; -# endif - thread_h = _beginthreadex(security, stack_size, - (unsigned (__stdcall *)(void *))GC_win32_start, - args, initflag, thrdaddr); - if (thread_h == 0) GC_free(args); - return thread_h; - } - } - - GC_API void GC_CALL GC_endthreadex(unsigned retval) - { - GC_unregister_my_thread(); - _endthreadex(retval); - } - -# endif /* !MSWINCE && !CYGWIN32 */ - -#ifdef GC_WINMAIN_REDIRECT - /* This might be useful on WinCE. Shouldn't be used with GC_DLL. */ - -# if defined(MSWINCE) && defined(UNDER_CE) -# define WINMAIN_LPTSTR LPWSTR -# else -# define WINMAIN_LPTSTR LPSTR -# endif - - /* This is defined in gc.h. */ -# undef WinMain - - /* Defined outside GC by an application. */ - int WINAPI GC_WinMain(HINSTANCE, HINSTANCE, WINMAIN_LPTSTR, int); - - typedef struct { - HINSTANCE hInstance; - HINSTANCE hPrevInstance; - WINMAIN_LPTSTR lpCmdLine; - int nShowCmd; - } main_thread_args; - - static DWORD WINAPI main_thread_start(LPVOID arg) - { - main_thread_args * args = (main_thread_args *) arg; - return (DWORD)GC_WinMain(args->hInstance, args->hPrevInstance, - args->lpCmdLine, args->nShowCmd); - } - - STATIC void * GC_waitForSingleObjectInfinite(void * handle) - { - return (void *)(word)WaitForSingleObject((HANDLE)handle, INFINITE); - } - -# ifndef WINMAIN_THREAD_STACK_SIZE -# define WINMAIN_THREAD_STACK_SIZE 0 /* default value */ -# endif - - int WINAPI WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, - WINMAIN_LPTSTR lpCmdLine, int nShowCmd) - { - DWORD exit_code = 1; - - main_thread_args args = { - hInstance, hPrevInstance, lpCmdLine, nShowCmd - }; - HANDLE thread_h; - DWORD thread_id; - - /* initialize everything */ - GC_INIT(); - - /* start the main thread */ - thread_h = GC_CreateThread(NULL /* lpsa */, - WINMAIN_THREAD_STACK_SIZE /* ignored on WinCE */, - main_thread_start, &args, 0 /* fdwCreate */, - &thread_id); - - if (thread_h != NULL) { - if ((DWORD)(word)GC_do_blocking(GC_waitForSingleObjectInfinite, - (void *)thread_h) == WAIT_FAILED) - ABORT("WaitForSingleObject(main_thread) failed"); - GetExitCodeThread (thread_h, &exit_code); - CloseHandle (thread_h); - } else { - ABORT("GC_CreateThread(main_thread) failed"); - } - -# ifdef MSWINCE - GC_deinit(); - DeleteCriticalSection(&GC_allocate_ml); -# endif - return (int) exit_code; - } - -#endif /* GC_WINMAIN_REDIRECT */ - -/* Called by GC_init() - we hold the allocation lock. */ -GC_INNER void GC_thr_init(void) -{ - struct GC_stack_base sb; -# ifdef GC_ASSERTIONS - int sb_result; -# endif - - GC_ASSERT(I_HOLD_LOCK()); - if (GC_thr_initialized) return; - - GC_ASSERT((word)&GC_threads % sizeof(word) == 0); - GC_main_thread = GetCurrentThreadId(); - GC_thr_initialized = TRUE; - -# ifdef CAN_HANDLE_FORK - /* Prepare for forks if requested. */ - if (GC_handle_fork) { -# ifdef CAN_CALL_ATFORK - if (pthread_atfork(fork_prepare_proc, fork_parent_proc, - fork_child_proc) == 0) { - /* Handlers successfully registered. */ - GC_handle_fork = 1; - } else -# endif - /* else */ if (GC_handle_fork != -1) - ABORT("pthread_atfork failed"); - } -# endif - - /* Add the initial thread, so we can stop it. */ -# ifdef GC_ASSERTIONS - sb_result = -# endif - GC_get_stack_base(&sb); - GC_ASSERT(sb_result == GC_SUCCESS); - -# if defined(PARALLEL_MARK) - { - char * markers_string = GETENV("GC_MARKERS"); - int markers_m1; - - if (markers_string != NULL) { - markers_m1 = atoi(markers_string) - 1; - if (markers_m1 >= MAX_MARKERS) { - WARN("Limiting number of mark threads\n", 0); - markers_m1 = MAX_MARKERS - 1; - } - } else { -# ifdef MSWINCE - /* There is no GetProcessAffinityMask() in WinCE. */ - /* GC_sysinfo is already initialized. */ - markers_m1 = (int)GC_sysinfo.dwNumberOfProcessors - 1; -# else -# ifdef _WIN64 - DWORD_PTR procMask = 0; - DWORD_PTR sysMask; -# else - DWORD procMask = 0; - DWORD sysMask; -# endif - int ncpu = 0; - if (GetProcessAffinityMask(GetCurrentProcess(), - (void *)&procMask, (void *)&sysMask) - && procMask) { - do { - ncpu++; - } while ((procMask &= procMask - 1) != 0); - } - markers_m1 = ncpu - 1; -# endif -# ifdef GC_MIN_MARKERS - /* This is primarily for testing on systems without getenv(). */ - if (markers_m1 < GC_MIN_MARKERS - 1) - markers_m1 = GC_MIN_MARKERS - 1; -# endif - if (markers_m1 >= MAX_MARKERS) - markers_m1 = MAX_MARKERS - 1; /* silently limit the value */ - } - available_markers_m1 = markers_m1; - } - - /* Check whether parallel mode could be enabled. */ - { - if (GC_win32_dll_threads || available_markers_m1 <= 0) { - /* Disable parallel marking. */ - GC_parallel = FALSE; - GC_COND_LOG_PRINTF( - "Single marker thread, turning off parallel marking\n"); - } else { -# ifndef GC_PTHREADS_PARAMARK - /* Initialize Win32 event objects for parallel marking. */ - mark_mutex_event = CreateEvent(NULL /* attrs */, - FALSE /* isManualReset */, - FALSE /* initialState */, NULL /* name */); - builder_cv = CreateEvent(NULL /* attrs */, - TRUE /* isManualReset */, - FALSE /* initialState */, NULL /* name */); - mark_cv = CreateEvent(NULL /* attrs */, TRUE /* isManualReset */, - FALSE /* initialState */, NULL /* name */); - if (mark_mutex_event == (HANDLE)0 || builder_cv == (HANDLE)0 - || mark_cv == (HANDLE)0) - ABORT("CreateEvent failed"); -# endif - /* Disable true incremental collection, but generational is OK. */ - GC_time_limit = GC_TIME_UNLIMITED; - } - } -# endif /* PARALLEL_MARK */ - - GC_ASSERT(0 == GC_lookup_thread_inner(GC_main_thread)); - GC_register_my_thread_inner(&sb, GC_main_thread); - -# ifdef PARALLEL_MARK -# ifndef CAN_HANDLE_FORK - if (GC_parallel) -# endif - { - /* If we are using a parallel marker, actually start helper threads. */ - start_mark_threads(); - } -# endif -} - -#ifdef GC_PTHREADS - - struct start_info { - void *(*start_routine)(void *); - void *arg; - GC_bool detached; - }; - - GC_API int GC_pthread_join(pthread_t pthread_id, void **retval) - { - int result; - GC_thread t; - DCL_LOCK_STATE; - - GC_ASSERT(!GC_win32_dll_threads); -# ifdef DEBUG_THREADS - GC_log_printf("thread %p(0x%lx) is joining thread %p\n", - GC_PTHREAD_PTRVAL(pthread_self()), - (long)GetCurrentThreadId(), GC_PTHREAD_PTRVAL(pthread_id)); -# endif - - /* Thread being joined might not have registered itself yet. */ - /* After the join, thread id may have been recycled. */ - /* FIXME: It would be better if this worked more like */ - /* pthread_support.c. */ -# ifndef GC_WIN32_PTHREADS - while ((t = GC_lookup_pthread(pthread_id)) == 0) - Sleep(10); - result = pthread_join(pthread_id, retval); -# else - result = pthread_join(pthread_id, retval); - /* pthreads-win32 and winpthreads id are unique (not recycled). */ - t = GC_lookup_pthread(pthread_id); - if (NULL == t) ABORT("Thread not registered"); -# endif - - LOCK(); - GC_delete_gc_thread_no_free(t); - GC_INTERNAL_FREE(t); - UNLOCK(); - -# ifdef DEBUG_THREADS - GC_log_printf("thread %p(0x%lx) completed join with thread %p\n", - GC_PTHREAD_PTRVAL(pthread_self()), - (long)GetCurrentThreadId(), GC_PTHREAD_PTRVAL(pthread_id)); -# endif - return result; - } - - /* Cygwin-pthreads calls CreateThread internally, but it's not easily */ - /* interceptible by us..., so intercept pthread_create instead. */ - GC_API int GC_pthread_create(pthread_t *new_thread, - GC_PTHREAD_CREATE_CONST pthread_attr_t *attr, - void *(*start_routine)(void *), void *arg) - { - int result; - struct start_info * si; - - if (!EXPECT(parallel_initialized, TRUE)) - GC_init_parallel(); - /* make sure GC is initialized (i.e. main thread is attached) */ - GC_ASSERT(!GC_win32_dll_threads); - - /* This is otherwise saved only in an area mmapped by the thread */ - /* library, which isn't visible to the collector. */ - si = GC_malloc_uncollectable(sizeof(struct start_info)); - if (0 == si) return(EAGAIN); - - si -> start_routine = start_routine; - si -> arg = arg; - if (attr != 0 && - pthread_attr_getdetachstate(attr, &si->detached) - == PTHREAD_CREATE_DETACHED) { - si->detached = TRUE; - } - -# ifdef DEBUG_THREADS - GC_log_printf("About to create a thread from %p(0x%lx)\n", - GC_PTHREAD_PTRVAL(pthread_self()), - (long)GetCurrentThreadId()); -# endif -# ifndef GC_ALWAYS_MULTITHREADED - GC_need_to_lock = TRUE; -# endif - result = pthread_create(new_thread, attr, GC_pthread_start, si); - - if (result) { /* failure */ - GC_free(si); - } - return(result); - } - - STATIC void * GC_CALLBACK GC_pthread_start_inner(struct GC_stack_base *sb, - void * arg) - { - struct start_info * si = arg; - void * result; - void *(*start)(void *); - void *start_arg; - DWORD thread_id = GetCurrentThreadId(); - pthread_t pthread_id = pthread_self(); - GC_thread me; - DCL_LOCK_STATE; - -# ifdef DEBUG_THREADS - GC_log_printf("thread %p(0x%x) starting...\n", - GC_PTHREAD_PTRVAL(pthread_id), (int)thread_id); -# endif - - GC_ASSERT(!GC_win32_dll_threads); - /* If a GC occurs before the thread is registered, that GC will */ - /* ignore this thread. That's fine, since it will block trying to */ - /* acquire the allocation lock, and won't yet hold interesting */ - /* pointers. */ - LOCK(); - /* We register the thread here instead of in the parent, so that */ - /* we don't need to hold the allocation lock during pthread_create. */ - me = GC_register_my_thread_inner(sb, thread_id); - SET_PTHREAD_MAP_CACHE(pthread_id, thread_id); - me -> pthread_id = pthread_id; - if (si->detached) me -> flags |= DETACHED; - UNLOCK(); - - start = si -> start_routine; - start_arg = si -> arg; - - GC_free(si); /* was allocated uncollectible */ - - pthread_cleanup_push(GC_thread_exit_proc, (void *)me); - result = (*start)(start_arg); - me -> status = result; - pthread_cleanup_pop(1); - -# ifdef DEBUG_THREADS - GC_log_printf("thread %p(0x%x) returned from start routine\n", - GC_PTHREAD_PTRVAL(pthread_id), (int)thread_id); -# endif - return(result); - } - - STATIC void * GC_pthread_start(void * arg) - { - return GC_call_with_stack_base(GC_pthread_start_inner, arg); - } - - STATIC void GC_thread_exit_proc(void *arg) - { - GC_thread me = (GC_thread)arg; - DCL_LOCK_STATE; - - GC_ASSERT(!GC_win32_dll_threads); -# ifdef DEBUG_THREADS - GC_log_printf("thread %p(0x%lx) called pthread_exit()\n", - GC_PTHREAD_PTRVAL(pthread_self()), - (long)GetCurrentThreadId()); -# endif - - LOCK(); - GC_wait_for_gc_completion(FALSE); -# if defined(THREAD_LOCAL_ALLOC) - GC_ASSERT(GC_getspecific(GC_thread_key) == &me->tlfs); - GC_destroy_thread_local(&(me->tlfs)); -# endif - if (me -> flags & DETACHED) { - GC_delete_thread(GetCurrentThreadId()); - } else { - /* deallocate it as part of join */ - me -> flags |= FINISHED; - } -# if defined(THREAD_LOCAL_ALLOC) - /* It is required to call remove_specific defined in specific.c. */ - GC_remove_specific(GC_thread_key); -# endif - UNLOCK(); - } - -# ifndef GC_NO_PTHREAD_SIGMASK - /* Win32 pthread does not support sigmask. */ - /* So, nothing required here... */ - GC_API int GC_pthread_sigmask(int how, const sigset_t *set, - sigset_t *oset) - { - return pthread_sigmask(how, set, oset); - } -# endif /* !GC_NO_PTHREAD_SIGMASK */ - - GC_API int GC_pthread_detach(pthread_t thread) - { - int result; - GC_thread t; - DCL_LOCK_STATE; - - GC_ASSERT(!GC_win32_dll_threads); - LOCK(); - t = GC_lookup_pthread(thread); - UNLOCK(); - result = pthread_detach(thread); - if (result == 0) { - if (NULL == t) ABORT("Thread not registered"); - LOCK(); - t -> flags |= DETACHED; - /* Here the pthread thread id may have been recycled. */ - if ((t -> flags & FINISHED) != 0) { - GC_delete_gc_thread_no_free(t); - GC_INTERNAL_FREE(t); - } - UNLOCK(); - } - return result; - } - -#elif !defined(GC_NO_THREADS_DISCOVERY) - /* We avoid acquiring locks here, since this doesn't seem to be */ - /* preemptible. This may run with an uninitialized collector, in */ - /* which case we don't do much. This implies that no threads other */ - /* than the main one should be created with an uninitialized */ - /* collector. (The alternative of initializing the collector here */ - /* seems dangerous, since DllMain is limited in what it can do.) */ - -# ifdef GC_INSIDE_DLL - /* Export only if needed by client. */ - GC_API -# else -# define GC_DllMain DllMain -# endif - BOOL WINAPI GC_DllMain(HINSTANCE inst GC_ATTR_UNUSED, ULONG reason, - LPVOID reserved GC_ATTR_UNUSED) - { - DWORD thread_id; - static int entry_count = 0; - - if (!GC_win32_dll_threads && parallel_initialized) return TRUE; - - switch (reason) { - case DLL_THREAD_ATTACH: -# ifdef PARALLEL_MARK - /* Don't register marker threads. */ - if (GC_parallel) { - /* We could reach here only if parallel_initialized == FALSE. */ - break; - } -# endif - GC_ASSERT(entry_count == 0 || parallel_initialized); - ++entry_count; /* and fall through: */ - case DLL_PROCESS_ATTACH: - /* This may run with the collector uninitialized. */ - thread_id = GetCurrentThreadId(); - if (parallel_initialized && GC_main_thread != thread_id) { -# ifdef PARALLEL_MARK - ABORT("Cannot initialize parallel marker from DllMain"); -# else - struct GC_stack_base sb; - /* Don't lock here. */ -# ifdef GC_ASSERTIONS - int sb_result = -# endif - GC_get_stack_base(&sb); - GC_ASSERT(sb_result == GC_SUCCESS); - GC_register_my_thread_inner(&sb, thread_id); -# endif - } /* o.w. we already did it during GC_thr_init, called by GC_init */ - break; - - case DLL_THREAD_DETACH: - /* We are hopefully running in the context of the exiting thread. */ - GC_ASSERT(parallel_initialized); - if (GC_win32_dll_threads) { - GC_delete_thread(GetCurrentThreadId()); - } - break; - - case DLL_PROCESS_DETACH: - if (GC_win32_dll_threads) { - int i; - int my_max = (int)GC_get_max_thread_index(); - - for (i = 0; i <= my_max; ++i) { - if (AO_load(&(dll_thread_table[i].tm.in_use))) - GC_delete_gc_thread_no_free(&dll_thread_table[i]); - } - GC_deinit(); - DeleteCriticalSection(&GC_allocate_ml); - } - break; - } - return TRUE; - } -#endif /* !GC_NO_THREADS_DISCOVERY && !GC_PTHREADS */ - -/* Perform all initializations, including those that */ -/* may require allocation. */ -/* Called without allocation lock. */ -/* Must be called before a second thread is created. */ -GC_INNER void GC_init_parallel(void) -{ -# if defined(THREAD_LOCAL_ALLOC) - GC_thread me; - DCL_LOCK_STATE; -# endif - - if (parallel_initialized) return; - parallel_initialized = TRUE; - /* GC_init() calls us back, so set flag first. */ - - if (!GC_is_initialized) GC_init(); -# ifndef GC_ALWAYS_MULTITHREADED - if (GC_win32_dll_threads) { - GC_need_to_lock = TRUE; - /* Cannot intercept thread creation. Hence we don't know if */ - /* other threads exist. However, client is not allowed to */ - /* create other threads before collector initialization. */ - /* Thus it's OK not to lock before this. */ - } -# endif - /* Initialize thread local free lists if used. */ -# if defined(THREAD_LOCAL_ALLOC) - LOCK(); - me = GC_lookup_thread_inner(GetCurrentThreadId()); - CHECK_LOOKUP_MY_THREAD(me); - GC_init_thread_local(&me->tlfs); - UNLOCK(); -# endif -} - -#if defined(USE_PTHREAD_LOCKS) - /* Support for pthread locking code. */ - /* Pthread_mutex_try_lock may not win here, */ - /* due to builtin support for spinning first? */ - - GC_INNER volatile GC_bool GC_collecting = 0; - /* A hint that we're in the collector and */ - /* holding the allocation lock for an */ - /* extended period. */ - - GC_INNER void GC_lock(void) - { - pthread_mutex_lock(&GC_allocate_ml); - } -#endif /* USE_PTHREAD_LOCKS */ - -#if defined(THREAD_LOCAL_ALLOC) - - /* Add thread-local allocation support. VC++ uses __declspec(thread). */ - - /* We must explicitly mark ptrfree and gcj free lists, since the free */ - /* list links wouldn't otherwise be found. We also set them in the */ - /* normal free lists, since that involves touching less memory than if */ - /* we scanned them normally. */ - GC_INNER void GC_mark_thread_local_free_lists(void) - { - int i; - GC_thread p; - - for (i = 0; i < THREAD_TABLE_SZ; ++i) { - for (p = GC_threads[i]; 0 != p; p = p -> tm.next) { - if (!KNOWN_FINISHED(p)) { -# ifdef DEBUG_THREADS - GC_log_printf("Marking thread locals for 0x%x\n", (int)p -> id); -# endif - GC_mark_thread_local_fls_for(&(p->tlfs)); - } - } - } - } - -# if defined(GC_ASSERTIONS) - void GC_check_tls_for(GC_tlfs p); -# if defined(USE_CUSTOM_SPECIFIC) - void GC_check_tsd_marks(tsd *key); -# endif - /* Check that all thread-local free-lists are completely marked. */ - /* also check that thread-specific-data structures are marked. */ - void GC_check_tls(void) - { - int i; - GC_thread p; - - for (i = 0; i < THREAD_TABLE_SZ; ++i) { - for (p = GC_threads[i]; 0 != p; p = p -> tm.next) { - if (!KNOWN_FINISHED(p)) - GC_check_tls_for(&(p->tlfs)); - } - } -# if defined(USE_CUSTOM_SPECIFIC) - if (GC_thread_key != 0) - GC_check_tsd_marks(GC_thread_key); -# endif - } -# endif /* GC_ASSERTIONS */ - -#endif /* THREAD_LOCAL_ALLOC ... */ - -# ifndef GC_NO_THREAD_REDIRECTS - /* Restore thread calls redirection. */ -# define CreateThread GC_CreateThread -# define ExitThread GC_ExitThread -# undef _beginthreadex -# define _beginthreadex GC_beginthreadex -# undef _endthreadex -# define _endthreadex GC_endthreadex -# endif /* !GC_NO_THREAD_REDIRECTS */ - -#endif /* GC_WIN32_THREADS */ diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/gc.def ecl-16.1.3+ds/src/bdwgc/windows-untested/gc.def --- ecl-16.1.2/src/bdwgc/windows-untested/gc.def 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/gc.def 1970-01-01 00:00:00.000000000 +0000 @@ -1,2 +0,0 @@ -EXPORTS - GC_version DATA diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/gc.rc ecl-16.1.3+ds/src/bdwgc/windows-untested/gc.rc --- ecl-16.1.2/src/bdwgc/windows-untested/gc.rc 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/gc.rc 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -#include "gc.ver" diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/gc.ver ecl-16.1.3+ds/src/bdwgc/windows-untested/gc.ver --- ecl-16.1.2/src/bdwgc/windows-untested/gc.ver 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/gc.ver 1970-01-01 00:00:00.000000000 +0000 @@ -1,81 +0,0 @@ -#include -#include - -#include "../include/../version.h" - -#define GC_VERSION_REVISION 0 - -#define GC_VERSION ((GC_VERSION_MAJOR) * 100 + GC_VERSION_MINOR) -#define GC_FULL_VERSION ((GC_VERSION) * 10000 + GC_VERSION_MICRO) - -#ifndef __T -# ifdef UNICODE -# define __T(x) L ## x -# else -# define __T(x) x -# endif -#endif - -#define PP_TSTR(x) __T(#x) -#define PP_EVAL_TSTR(x) PP_TSTR(x) - -#define GC_VERSION_STR PP_EVAL_TSTR(GC_VERSION_MAJOR) __T(".") PP_EVAL_TSTR(GC_VERSION_MINOR) -#define GC_FULL_VERSION_STR PP_EVAL_TSTR(GC_VERSION_MAJOR) __T(".") PP_EVAL_TSTR(GC_VERSION_MINOR) __T(".") PP_EVAL_TSTR(GC_VERSION_MICRO) __T(".") PP_EVAL_TSTR(GC_VERSION_REVISION) -#define GC_FULL_VERSION_CSV GC_VERSION_MAJOR, GC_VERSION_MINOR, GC_VERSION_MICRO, GC_VERSION_REVISION - -#ifdef _DEBUG -#define VER_DEBUG VS_FF_DEBUG -#else -#define VER_DEBUG 0 -#endif - -#ifdef _BETA -#define VER_PRERELEASE VS_FF_PRERELEASE -#else -#define VER_PRERELEASE 0 -#endif - -LANGUAGE LANG_ENGLISH, SUBLANG_ENGLISH_US -#pragma code_page(1252) - -VS_VERSION_INFO VERSIONINFO - FILEVERSION GC_FULL_VERSION_CSV - PRODUCTVERSION GC_FULL_VERSION_CSV - FILEFLAGSMASK VS_FFI_FILEFLAGSMASK - FILEFLAGS VER_DEBUG | VER_PRERELEASE - FILEOS VOS__WINDOWS32 - FILETYPE VFT_DLL - FILESUBTYPE VFT2_UNKNOWN -BEGIN - BLOCK "StringFileInfo" - BEGIN - BLOCK "040904B0" - BEGIN - VALUE "CompanyName", "\ -Hans-J. Boehm, \ -Alan J. Demers, \ -Xerox Corporation, \ -Silicon Graphics, \ -and Hewlett-Packard Company. \ -\0" - VALUE "LegalCopyright", "\ -Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers. \ -Copyright (c) 1991-1995 by Xerox Corporation. All rights reserved. \ -Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. \ -Copyright (c) 1999-2004 by Hewlett-Packard. All rights reserved. \ -\0" - - VALUE "OriginalFilename", "GC.DLL\0" - VALUE "InternalName", "GC\0" - VALUE "FileDescription", "Conservative Garbage Collector for C and C++\0" - VALUE "FileVersion", GC_FULL_VERSION_STR - - VALUE "ProductName", "Conservative Garbage Collector for C and C++\0" - VALUE "ProductVersion", GC_FULL_VERSION_STR - END - END - BLOCK "VarFileInfo" - BEGIN - VALUE "Translation", 0x409, 1200 - END -END diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/README ecl-16.1.3+ds/src/bdwgc/windows-untested/README --- ecl-16.1.2/src/bdwgc/windows-untested/README 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/README 1970-01-01 00:00:00.000000000 +0000 @@ -1,4 +0,0 @@ -gc.def should probably be removed completely. - -I removed an apparently erroneous line for GC_CreateThread. Unfortunately -gc.def is referenced in various other places I cannot easily edit. -HB diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/stdafx.c ecl-16.1.3+ds/src/bdwgc/windows-untested/stdafx.c --- ecl-16.1.2/src/bdwgc/windows-untested/stdafx.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/stdafx.c 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -#include "stdafx.h" diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/stdafx.h ecl-16.1.3+ds/src/bdwgc/windows-untested/stdafx.h --- ecl-16.1.2/src/bdwgc/windows-untested/stdafx.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/stdafx.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,15 +0,0 @@ -#define WIN32_LEAN_AND_MEAN -#include - -#pragma warning(error: 4013) // function undefined; assuming extern returning int - -#ifdef _MT -# define GC_THREADS 1 -#endif - -#ifdef _DEBUG -# define GC_DEBUG -#endif - -#define SAVE_CALL_CHAIN -#define SAVE_CALL_COUNT 8 diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc60/all.dsp ecl-16.1.3+ds/src/bdwgc/windows-untested/vc60/all.dsp --- ecl-16.1.2/src/bdwgc/windows-untested/vc60/all.dsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc60/all.dsp 1970-01-01 00:00:00.000000000 +0000 @@ -1,63 +0,0 @@ -# Microsoft Developer Studio Project File - Name="all" - Package Owner=<4> -# Microsoft Developer Studio Generated Build File, Format Version 6.00 -# ** DO NOT EDIT ** - -# TARGTYPE "Win32 (x86) Generic Project" 0x010a - -CFG=all - Win32 Debug -!MESSAGE This is not a valid makefile. To build this project using NMAKE, -!MESSAGE use the Export Makefile command and run -!MESSAGE -!MESSAGE NMAKE /f "all.mak". -!MESSAGE -!MESSAGE You can specify a configuration when running NMAKE -!MESSAGE by defining the macro CFG on the command line. For example: -!MESSAGE -!MESSAGE NMAKE /f "all.mak" CFG="all - Win32 Debug" -!MESSAGE -!MESSAGE Possible choices for configuration are: -!MESSAGE -!MESSAGE "all - Win32 Release" (based on "Win32 (x86) Generic Project") -!MESSAGE "all - Win32 Debug" (based on "Win32 (x86) Generic Project") -!MESSAGE - -# Begin Project -# PROP AllowPerConfigDependencies 0 -# PROP Scc_ProjName "" -# PROP Scc_LocalPath "" -MTL=midl.exe - -!IF "$(CFG)" == "all - Win32 Release" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 0 -# PROP BASE Output_Dir "Release" -# PROP BASE Intermediate_Dir "Release" -# PROP BASE Target_Dir "" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 0 -# PROP Output_Dir "..\..\..\bin" -# PROP Intermediate_Dir "..\..\..\obj\Release" -# PROP Target_Dir "" - -!ELSEIF "$(CFG)" == "all - Win32 Debug" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 1 -# PROP BASE Output_Dir "Debug" -# PROP BASE Intermediate_Dir "Debug" -# PROP BASE Target_Dir "" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 1 -# PROP Output_Dir "..\..\..\bin" -# PROP Intermediate_Dir "..\..\..\obj\Debug" -# PROP Target_Dir "" - -!ENDIF - -# Begin Target - -# Name "all - Win32 Release" -# Name "all - Win32 Debug" -# End Target -# End Project diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc60/gc.dsp ecl-16.1.3+ds/src/bdwgc/windows-untested/vc60/gc.dsp --- ecl-16.1.2/src/bdwgc/windows-untested/vc60/gc.dsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc60/gc.dsp 1970-01-01 00:00:00.000000000 +0000 @@ -1,332 +0,0 @@ -# Microsoft Developer Studio Project File - Name="gc" - Package Owner=<4> -# Microsoft Developer Studio Generated Build File, Format Version 6.00 -# ** DO NOT EDIT ** - -# TARGTYPE "Win32 (x86) Dynamic-Link Library" 0x0102 - -CFG=gc - Win32 Debug -!MESSAGE This is not a valid makefile. To build this project using NMAKE, -!MESSAGE use the Export Makefile command and run -!MESSAGE -!MESSAGE NMAKE /f "gc.mak". -!MESSAGE -!MESSAGE You can specify a configuration when running NMAKE -!MESSAGE by defining the macro CFG on the command line. For example: -!MESSAGE -!MESSAGE NMAKE /f "gc.mak" CFG="gc - Win32 Debug" -!MESSAGE -!MESSAGE Possible choices for configuration are: -!MESSAGE -!MESSAGE "gc - Win32 Release" (based on "Win32 (x86) Dynamic-Link Library") -!MESSAGE "gc - Win32 Debug" (based on "Win32 (x86) Dynamic-Link Library") -!MESSAGE - -# Begin Project -# PROP AllowPerConfigDependencies 0 -# PROP Scc_ProjName "" -# PROP Scc_LocalPath "" -CPP=cl.exe -MTL=midl.exe -RSC=rc.exe - -!IF "$(CFG)" == "gc - Win32 Release" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 0 -# PROP BASE Output_Dir "Release" -# PROP BASE Intermediate_Dir "Release" -# PROP BASE Target_Dir "" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 0 -# PROP Output_Dir "..\..\..\bin" -# PROP Intermediate_Dir "..\..\..\obj\Release\gc" -# PROP Ignore_Export_Lib 0 -# PROP Target_Dir "" -# ADD BASE CPP /nologo /MT /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "GC_EXPORTS" /YX /FD /c -# ADD CPP /nologo /MD /W3 /GX /Zi /O2 /I "..\..\include" /FI"stdafx.h" /D "NDEBUG" /D "_WINDOWS" /D "_USRDLL" /D "GC_DLL" /D "WIN32" /D "_MBCS" /D "GC_THREADS" /Yu"stdafx.h" /FD /c -# ADD BASE MTL /nologo /D "NDEBUG" /mktyplib203 /win32 -# ADD MTL /nologo /D "NDEBUG" /mktyplib203 /win32 -# ADD BASE RSC /l 0x409 /d "NDEBUG" -# ADD RSC /l 0x409 /i "..\..\include" /d "NDEBUG" -BSC32=bscmake.exe -# ADD BASE BSC32 /nologo -# ADD BSC32 /nologo -LINK32=link.exe -# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /machine:I386 -# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib /nologo /base:"0x37C30000" /subsystem:console /dll /debug /machine:I386 /out:"..\..\..\bin/gc60.dll" /implib:"..\..\..\lib/gc.lib" /opt:ref /release -# SUBTRACT LINK32 /pdb:none -# Begin Special Build Tool -OutDir=.\..\..\..\bin -SOURCE="$(InputPath)" -PostBuild_Cmds=del $(OutDir)\..\lib\gc.exp -# End Special Build Tool - -!ELSEIF "$(CFG)" == "gc - Win32 Debug" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 1 -# PROP BASE Output_Dir "Debug" -# PROP BASE Intermediate_Dir "Debug" -# PROP BASE Target_Dir "" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 1 -# PROP Output_Dir "..\..\..\bin" -# PROP Intermediate_Dir "..\..\..\obj\Debug\gc" -# PROP Ignore_Export_Lib 0 -# PROP Target_Dir "" -# ADD BASE CPP /nologo /MTd /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "GC_EXPORTS" /YX /FD /GZ /c -# ADD CPP /nologo /MDd /W3 /GX /Zi /Od /I "..\..\include" /FI"stdafx.h" /D "_DEBUG" /D "_WINDOWS" /D "_USRDLL" /D "GC_DLL" /D "WIN32" /D "_MBCS" /D "GC_THREADS" /Yu"stdafx.h" /FD /GZ /c -# ADD BASE MTL /nologo /D "_DEBUG" /mktyplib203 /win32 -# ADD MTL /nologo /D "_DEBUG" /mktyplib203 /win32 -# ADD BASE RSC /l 0x409 /d "_DEBUG" -# ADD RSC /l 0x409 /i "..\..\include" /d "_DEBUG" -BSC32=bscmake.exe -# ADD BASE BSC32 /nologo -# ADD BSC32 /nologo /o"..\..\..\bin/gcd.bsc" -LINK32=link.exe -# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /debug /machine:I386 /pdbtype:sept -# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib /nologo /base:"0x37C30000" /subsystem:console /dll /incremental:no /debug /machine:I386 /out:"..\..\..\bin/gc60d.dll" /implib:"..\..\..\lib/gcd.lib" /pdbtype:sept -# SUBTRACT LINK32 /pdb:none -# Begin Special Build Tool -OutDir=.\..\..\..\bin -SOURCE="$(InputPath)" -PostBuild_Cmds=del $(OutDir)\..\lib\gcd.exp -# End Special Build Tool - -!ENDIF - -# Begin Target - -# Name "gc - Win32 Release" -# Name "gc - Win32 Debug" -# Begin Group "Source Files" - -# PROP Default_Filter "c;cpp;cc;cxx;tcc;rc;def;r;odl;idl;hpj;bat" -# Begin Source File - -SOURCE=..\..\allchblk.c -# End Source File -# Begin Source File - -SOURCE=..\..\alloc.c -# End Source File -# Begin Source File - -SOURCE=..\..\backgraph.c -# End Source File -# Begin Source File - -SOURCE=..\..\blacklst.c -# End Source File -# Begin Source File - -SOURCE=..\..\checksums.c -# End Source File -# Begin Source File - -SOURCE=..\..\dbg_mlc.c -# End Source File -# Begin Source File - -SOURCE=..\..\gcj_mlc.c -# End Source File -# Begin Source File - -SOURCE=..\..\fnlz_mlc.c -# End Source File -# Begin Source File - -SOURCE=..\..\dyn_load.c -# End Source File -# Begin Source File - -SOURCE=..\..\finalize.c -# End Source File -# Begin Source File - -SOURCE=..\..\headers.c -# End Source File -# Begin Source File - -SOURCE=..\..\mach_dep.c -# End Source File -# Begin Source File - -SOURCE=..\..\malloc.c -# End Source File -# Begin Source File - -SOURCE=..\..\mallocx.c -# End Source File -# Begin Source File - -SOURCE=..\..\mark.c -# End Source File -# Begin Source File - -SOURCE=..\..\mark_rts.c -# End Source File -# Begin Source File - -SOURCE=..\..\misc.c -# End Source File -# Begin Source File - -SOURCE=..\..\msvc_dbg.c -# End Source File -# Begin Source File - -SOURCE=..\..\new_hblk.c -# End Source File -# Begin Source File - -SOURCE=..\..\obj_map.c -# End Source File -# Begin Source File - -SOURCE=..\..\os_dep.c -# End Source File -# Begin Source File - -SOURCE=..\..\ptr_chck.c -# End Source File -# Begin Source File - -SOURCE=..\..\reclaim.c -# End Source File -# Begin Source File - -SOURCE=..\stdafx.c -# ADD CPP /Yc"stdafx.h" -# End Source File -# Begin Source File - -SOURCE=..\..\stubborn.c -# End Source File -# Begin Source File - -SOURCE=..\..\typd_mlc.c -# End Source File -# Begin Source File - -SOURCE=..\..\win32_threads.c -# End Source File -# End Group -# Begin Group "Header Files" - -# PROP Default_Filter "h;hh;hpp;hxx;hm;inl" -# Begin Source File - -SOURCE=..\..\include\gc.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\gc_allocator.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\gc_backptr.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\gc_config_macros.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\gc_cpp.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\gc_gcj.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\private\gc_hdrs.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\gc_inl.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\gc_inline.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\private\gc_locks.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\gc_mark.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\gc_disclaim.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\private\gc_pmark.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\private\gc_priv.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\gc_pthread_redirects.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\gc_typed.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\private\gcconfig.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\javaxfc.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\leak_detector.h -# End Source File -# Begin Source File - -SOURCE=..\..\msvc_dbg.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\new_gc_alloc.h -# End Source File -# Begin Source File - -SOURCE=..\stdafx.h -# End Source File -# Begin Source File - -SOURCE=..\..\version.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\weakpointer.h -# End Source File -# End Group -# Begin Group "Resource Files" - -# PROP Default_Filter "ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe" -# Begin Source File - -SOURCE=..\gc.def -# End Source File -# Begin Source File - -SOURCE=..\gc.rc -# End Source File -# Begin Source File - -SOURCE=..\gc.ver -# End Source File -# End Group -# End Target -# End Project diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc60/gc.dsw ecl-16.1.3+ds/src/bdwgc/windows-untested/vc60/gc.dsw --- ecl-16.1.2/src/bdwgc/windows-untested/vc60/gc.dsw 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc60/gc.dsw 1970-01-01 00:00:00.000000000 +0000 @@ -1,194 +0,0 @@ -Microsoft Developer Studio Workspace File, Format Version 6.00 -# WARNING: DO NOT EDIT OR DELETE THIS WORKSPACE FILE! - -############################################################################### - -Project: "all"=".\all.dsp" - Package Owner=<4> - -Package=<5> -{{{ -}}} - -Package=<4> -{{{ - Begin Project Dependency - Project_Dep_Name gc - End Project Dependency - Begin Project Dependency - Project_Dep_Name libgc - End Project Dependency - Begin Project Dependency - Project_Dep_Name libgcmt - End Project Dependency -}}} - -############################################################################### - -Project: "gc"=".\gc.dsp" - Package Owner=<4> - -Package=<5> -{{{ -}}} - -Package=<4> -{{{ -}}} - -############################################################################### - -Project: "libgc"=".\libgc.dsp" - Package Owner=<4> - -Package=<5> -{{{ -}}} - -Package=<4> -{{{ -}}} - -############################################################################### - -Project: "libgcmt"=".\libgcmt.dsp" - Package Owner=<4> - -Package=<5> -{{{ -}}} - -Package=<4> -{{{ -}}} - -############################################################################### - -Project: "test"=".\test.dsp" - Package Owner=<4> - -Package=<5> -{{{ -}}} - -Package=<4> -{{{ - Begin Project Dependency - Project_Dep_Name test_gc - End Project Dependency - Begin Project Dependency - Project_Dep_Name test_libgc - End Project Dependency - Begin Project Dependency - Project_Dep_Name test_libgcmt - End Project Dependency - Begin Project Dependency - Project_Dep_Name test_leak_gc - End Project Dependency - Begin Project Dependency - Project_Dep_Name test_leak_libgc - End Project Dependency - Begin Project Dependency - Project_Dep_Name test_leak_libgcmt - End Project Dependency -}}} - -############################################################################### - -Project: "test_gc"=".\test_gc.dsp" - Package Owner=<4> - -Package=<5> -{{{ -}}} - -Package=<4> -{{{ - Begin Project Dependency - Project_Dep_Name gc - End Project Dependency -}}} - -############################################################################### - -Project: "test_leak_gc"=".\test_leak_gc.dsp" - Package Owner=<4> - -Package=<5> -{{{ -}}} - -Package=<4> -{{{ - Begin Project Dependency - Project_Dep_Name gc - End Project Dependency -}}} - -############################################################################### - -Project: "test_leak_libgc"=".\test_leak_libgc.dsp" - Package Owner=<4> - -Package=<5> -{{{ -}}} - -Package=<4> -{{{ - Begin Project Dependency - Project_Dep_Name libgc - End Project Dependency -}}} - -############################################################################### - -Project: "test_leak_libgcmt"=".\test_leak_libgcmt.dsp" - Package Owner=<4> - -Package=<5> -{{{ -}}} - -Package=<4> -{{{ - Begin Project Dependency - Project_Dep_Name libgcmt - End Project Dependency -}}} - -############################################################################### - -Project: "test_libgc"=".\test_libgc.dsp" - Package Owner=<4> - -Package=<5> -{{{ -}}} - -Package=<4> -{{{ - Begin Project Dependency - Project_Dep_Name libgc - End Project Dependency -}}} - -############################################################################### - -Project: "test_libgcmt"=".\test_libgcmt.dsp" - Package Owner=<4> - -Package=<5> -{{{ -}}} - -Package=<4> -{{{ - Begin Project Dependency - Project_Dep_Name libgcmt - End Project Dependency -}}} - -############################################################################### - -Global: - -Package=<5> -{{{ -}}} - -Package=<3> -{{{ -}}} - -############################################################################### - diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc60/libgc.dsp ecl-16.1.3+ds/src/bdwgc/windows-untested/vc60/libgc.dsp --- ecl-16.1.2/src/bdwgc/windows-untested/vc60/libgc.dsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc60/libgc.dsp 1970-01-01 00:00:00.000000000 +0000 @@ -1,269 +0,0 @@ -# Microsoft Developer Studio Project File - Name="libgc" - Package Owner=<4> -# Microsoft Developer Studio Generated Build File, Format Version 6.00 -# ** DO NOT EDIT ** - -# TARGTYPE "Win32 (x86) Static Library" 0x0104 - -CFG=libgc - Win32 Debug -!MESSAGE This is not a valid makefile. To build this project using NMAKE, -!MESSAGE use the Export Makefile command and run -!MESSAGE -!MESSAGE NMAKE /f "libgc.mak". -!MESSAGE -!MESSAGE You can specify a configuration when running NMAKE -!MESSAGE by defining the macro CFG on the command line. For example: -!MESSAGE -!MESSAGE NMAKE /f "libgc.mak" CFG="libgc - Win32 Debug" -!MESSAGE -!MESSAGE Possible choices for configuration are: -!MESSAGE -!MESSAGE "libgc - Win32 Release" (based on "Win32 (x86) Static Library") -!MESSAGE "libgc - Win32 Debug" (based on "Win32 (x86) Static Library") -!MESSAGE - -# Begin Project -# PROP AllowPerConfigDependencies 0 -# PROP Scc_ProjName "" -# PROP Scc_LocalPath "" -CPP=cl.exe -RSC=rc.exe - -!IF "$(CFG)" == "libgc - Win32 Release" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 0 -# PROP BASE Output_Dir "Release" -# PROP BASE Intermediate_Dir "Release" -# PROP BASE Target_Dir "" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 0 -# PROP Output_Dir "..\..\..\lib" -# PROP Intermediate_Dir "..\..\..\obj\Release\libgc" -# PROP Target_Dir "" -# ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_MBCS" /D "_LIB" /YX /FD /c -# ADD CPP /nologo /W3 /GX /Zi /O2 /I "..\..\include" /FI"stdafx.h" /D "NDEBUG" /D "_LIB" /D "WIN32" /D "_MBCS" /Yu"stdafx.h" /Fd"..\..\..\lib\libgc.pdb" /FD /c -# ADD BASE RSC /l 0x409 /d "NDEBUG" -# ADD RSC /l 0x409 /d "NDEBUG" -BSC32=bscmake.exe -# ADD BASE BSC32 /nologo -# ADD BSC32 /nologo -LIB32=link.exe -lib -# ADD BASE LIB32 /nologo -# ADD LIB32 /nologo -# Begin Special Build Tool -OutDir=.\..\..\..\lib -TargetName=libgc -SOURCE="$(InputPath)" -PostBuild_Cmds=del $(OutDir)\$(TargetName).idb -# End Special Build Tool - -!ELSEIF "$(CFG)" == "libgc - Win32 Debug" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 1 -# PROP BASE Output_Dir "Debug" -# PROP BASE Intermediate_Dir "Debug" -# PROP BASE Target_Dir "" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 1 -# PROP Output_Dir "..\..\..\lib" -# PROP Intermediate_Dir "..\..\..\obj\Debug\libgc" -# PROP Target_Dir "" -# ADD BASE CPP /nologo /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_MBCS" /D "_LIB" /YX /FD /GZ /c -# ADD CPP /nologo /W3 /GX /Zi /Od /I "..\..\include" /FI"stdafx.h" /D "_DEBUG" /D "_LIB" /D "WIN32" /D "_MBCS" /Yu"stdafx.h" /Fd"..\..\..\lib\libgcd.pdb" /FD /GZ /c -# ADD BASE RSC /l 0x409 /d "_DEBUG" -# ADD RSC /l 0x409 /d "_DEBUG" -BSC32=bscmake.exe -# ADD BASE BSC32 /nologo -# ADD BSC32 /nologo /o"..\..\..\lib/libgcd.bsc" -LIB32=link.exe -lib -# ADD BASE LIB32 /nologo -# ADD LIB32 /nologo /out:"..\..\..\lib\libgcd.lib" -# Begin Special Build Tool -OutDir=.\..\..\..\lib -TargetName=libgcd -SOURCE="$(InputPath)" -PostBuild_Cmds=del $(OutDir)\$(TargetName).idb -# End Special Build Tool - -!ENDIF - -# Begin Target - -# Name "libgc - Win32 Release" -# Name "libgc - Win32 Debug" -# Begin Group "Source Files" - -# PROP Default_Filter "c;cpp;cc;cxx;tcc;rc;def;r;odl;idl;hpj;bat" -# Begin Source File - -SOURCE=..\..\allchblk.c -# End Source File -# Begin Source File - -SOURCE=..\..\alloc.c -# End Source File -# Begin Source File - -SOURCE=..\..\backgraph.c -# End Source File -# Begin Source File - -SOURCE=..\..\blacklst.c -# End Source File -# Begin Source File - -SOURCE=..\..\checksums.c -# End Source File -# Begin Source File - -SOURCE=..\..\dbg_mlc.c -# End Source File -# Begin Source File - -SOURCE=..\..\gcj_mlc.c -# End Source File -# Begin Source File - -SOURCE=..\..\fnlz_mlc.c -# End Source File -# Begin Source File - -SOURCE=..\..\dyn_load.c -# End Source File -# Begin Source File - -SOURCE=..\..\finalize.c -# End Source File -# Begin Source File - -SOURCE=..\..\headers.c -# End Source File -# Begin Source File - -SOURCE=..\..\mach_dep.c -# End Source File -# Begin Source File - -SOURCE=..\..\malloc.c -# End Source File -# Begin Source File - -SOURCE=..\..\mallocx.c -# End Source File -# Begin Source File - -SOURCE=..\..\mark.c -# End Source File -# Begin Source File - -SOURCE=..\..\mark_rts.c -# End Source File -# Begin Source File - -SOURCE=..\..\misc.c -# End Source File -# Begin Source File - -SOURCE=..\..\msvc_dbg.c -# End Source File -# Begin Source File - -SOURCE=..\..\new_hblk.c -# End Source File -# Begin Source File - -SOURCE=..\..\obj_map.c -# End Source File -# Begin Source File - -SOURCE=..\..\os_dep.c -# End Source File -# Begin Source File - -SOURCE=..\..\ptr_chck.c -# End Source File -# Begin Source File - -SOURCE=..\..\reclaim.c -# End Source File -# Begin Source File - -SOURCE=..\stdafx.c -# ADD CPP /Yc"stdafx.h" -# End Source File -# Begin Source File - -SOURCE=..\..\stubborn.c -# End Source File -# Begin Source File - -SOURCE=..\..\typd_mlc.c -# End Source File -# Begin Source File - -SOURCE=..\..\win32_threads.c -# End Source File -# End Group -# Begin Group "Header Files" - -# PROP Default_Filter "h;hh;hpp;hxx;hm;inl" -# Begin Source File - -SOURCE=..\..\include\gc_allocator.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\gc_backptr.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\gc_cpp.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\gc_gcj.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\gc_inl.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\gc_inline.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\gc_pthread_redirects.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\javaxfc.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\leak_detector.h -# End Source File -# Begin Source File - -SOURCE=..\..\msvc_dbg.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\new_gc_alloc.h -# End Source File -# Begin Source File - -SOURCE=..\stdafx.h -# End Source File -# Begin Source File - -SOURCE=..\..\version.h -# End Source File -# Begin Source File - -SOURCE=..\..\include\weakpointer.h -# End Source File -# End Group -# End Target -# End Project diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc60/libgcmt.dsp ecl-16.1.3+ds/src/bdwgc/windows-untested/vc60/libgcmt.dsp --- ecl-16.1.2/src/bdwgc/windows-untested/vc60/libgcmt.dsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc60/libgcmt.dsp 1970-01-01 00:00:00.000000000 +0000 @@ -1,225 +0,0 @@ -# Microsoft Developer Studio Project File - Name="libgcmt" - Package Owner=<4> -# Microsoft Developer Studio Generated Build File, Format Version 6.00 -# ** DO NOT EDIT ** - -# TARGTYPE "Win32 (x86) Static Library" 0x0104 - -CFG=libgcmt - Win32 Debug -!MESSAGE This is not a valid makefile. To build this project using NMAKE, -!MESSAGE use the Export Makefile command and run -!MESSAGE -!MESSAGE NMAKE /f "libgcmt.mak". -!MESSAGE -!MESSAGE You can specify a configuration when running NMAKE -!MESSAGE by defining the macro CFG on the command line. For example: -!MESSAGE -!MESSAGE NMAKE /f "libgcmt.mak" CFG="libgcmt - Win32 Debug" -!MESSAGE -!MESSAGE Possible choices for configuration are: -!MESSAGE -!MESSAGE "libgcmt - Win32 Release" (based on "Win32 (x86) Static Library") -!MESSAGE "libgcmt - Win32 Debug" (based on "Win32 (x86) Static Library") -!MESSAGE - -# Begin Project -# PROP AllowPerConfigDependencies 0 -# PROP Scc_ProjName "" -# PROP Scc_LocalPath "" -CPP=cl.exe -RSC=rc.exe - -!IF "$(CFG)" == "libgcmt - Win32 Release" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 0 -# PROP BASE Output_Dir "Release" -# PROP BASE Intermediate_Dir "Release" -# PROP BASE Target_Dir "" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 0 -# PROP Output_Dir "..\..\..\lib" -# PROP Intermediate_Dir "..\..\..\obj\Release\libgcmt" -# PROP Target_Dir "" -# ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_MBCS" /D "_LIB" /YX /FD /c -# ADD CPP /nologo /MT /W3 /GX /Zi /O2 /I "..\..\include" /FI"stdafx.h" /D "NDEBUG" /D "_LIB" /D "WIN32" /D "_MBCS" /D "GC_THREADS" /Yu"stdafx.h" /Fd"..\..\..\lib\libgcmt.pdb" /Zl /FD /c -# ADD BASE RSC /l 0x409 /d "NDEBUG" -# ADD RSC /l 0x409 /d "NDEBUG" -BSC32=bscmake.exe -# ADD BASE BSC32 /nologo -# ADD BSC32 /nologo -LIB32=link.exe -lib -# ADD BASE LIB32 /nologo -# ADD LIB32 /nologo -# Begin Special Build Tool -OutDir=.\..\..\..\lib -TargetName=libgcmt -SOURCE="$(InputPath)" -PostBuild_Cmds=del $(OutDir)\$(TargetName).idb -# End Special Build Tool - -!ELSEIF "$(CFG)" == "libgcmt - Win32 Debug" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 1 -# PROP BASE Output_Dir "Debug" -# PROP BASE Intermediate_Dir "Debug" -# PROP BASE Target_Dir "" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 1 -# PROP Output_Dir "..\..\..\lib" -# PROP Intermediate_Dir "..\..\..\obj\Debug\libgcmt" -# PROP Target_Dir "" -# ADD BASE CPP /nologo /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_MBCS" /D "_LIB" /YX /FD /GZ /c -# ADD CPP /nologo /MTd /W3 /GX /Zi /Od /I "..\..\include" /FI"stdafx.h" /D "_DEBUG" /D "_LIB" /D "WIN32" /D "_MBCS" /D "GC_THREADS" /Yu"stdafx.h" /Fd"..\..\..\lib\libgcmtd.pdb" /Zl /FD /GZ /c -# ADD BASE RSC /l 0x409 /d "_DEBUG" -# ADD RSC /l 0x409 /d "_DEBUG" -BSC32=bscmake.exe -# ADD BASE BSC32 /nologo -# ADD BSC32 /nologo /o"..\..\..\lib/libgcmtd.bsc" -LIB32=link.exe -lib -# ADD BASE LIB32 /nologo -# ADD LIB32 /nologo /out:"..\..\..\lib\libgcmtd.lib" -# Begin Special Build Tool -OutDir=.\..\..\..\lib -TargetName=libgcmtd -SOURCE="$(InputPath)" -PostBuild_Cmds=del $(OutDir)\$(TargetName).idb -# End Special Build Tool - -!ENDIF - -# Begin Target - -# Name "libgcmt - Win32 Release" -# Name "libgcmt - Win32 Debug" -# Begin Group "Source Files" - -# PROP Default_Filter "c;cpp;cc;cxx;tcc;rc;def;r;odl;idl;hpj;bat" -# Begin Source File - -SOURCE=..\..\allchblk.c -# End Source File -# Begin Source File - -SOURCE=..\..\alloc.c -# End Source File -# Begin Source File - -SOURCE=..\..\backgraph.c -# End Source File -# Begin Source File - -SOURCE=..\..\blacklst.c -# End Source File -# Begin Source File - -SOURCE=..\..\checksums.c -# End Source File -# Begin Source File - -SOURCE=..\..\dbg_mlc.c -# End Source File -# Begin Source File - -SOURCE=..\..\gcj_mlc.c -# End Source File -# Begin Source File - -SOURCE=..\..\fnlz_mlc.c -# End Source File -# Begin Source File - -SOURCE=..\..\dyn_load.c -# End Source File -# Begin Source File - -SOURCE=..\..\finalize.c -# End Source File -# Begin Source File - -SOURCE=..\..\headers.c -# End Source File -# Begin Source File - -SOURCE=..\..\mach_dep.c -# End Source File -# Begin Source File - -SOURCE=..\..\malloc.c -# End Source File -# Begin Source File - -SOURCE=..\..\mallocx.c -# End Source File -# Begin Source File - -SOURCE=..\..\mark.c -# End Source File -# Begin Source File - -SOURCE=..\..\mark_rts.c -# End Source File -# Begin Source File - -SOURCE=..\..\misc.c -# End Source File -# Begin Source File - -SOURCE=..\..\msvc_dbg.c -# End Source File -# Begin Source File - -SOURCE=..\..\new_hblk.c -# End Source File -# Begin Source File - -SOURCE=..\..\obj_map.c -# End Source File -# Begin Source File - -SOURCE=..\..\os_dep.c -# End Source File -# Begin Source File - -SOURCE=..\..\ptr_chck.c -# End Source File -# Begin Source File - -SOURCE=..\..\reclaim.c -# End Source File -# Begin Source File - -SOURCE=..\stdafx.c -# ADD CPP /Yc"stdafx.h" -# End Source File -# Begin Source File - -SOURCE=..\..\stubborn.c -# End Source File -# Begin Source File - -SOURCE=..\..\typd_mlc.c -# End Source File -# Begin Source File - -SOURCE=..\..\win32_threads.c -# End Source File -# End Group -# Begin Group "Header Files" - -# PROP Default_Filter "h;hh;hpp;hxx;hm;inl" -# Begin Source File - -SOURCE=..\..\msvc_dbg.h -# End Source File -# Begin Source File - -SOURCE=..\stdafx.h -# End Source File -# Begin Source File - -SOURCE=..\..\version.h -# End Source File -# End Group -# End Target -# End Project diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc60/test.dsp ecl-16.1.3+ds/src/bdwgc/windows-untested/vc60/test.dsp --- ecl-16.1.2/src/bdwgc/windows-untested/vc60/test.dsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc60/test.dsp 1970-01-01 00:00:00.000000000 +0000 @@ -1,63 +0,0 @@ -# Microsoft Developer Studio Project File - Name="test" - Package Owner=<4> -# Microsoft Developer Studio Generated Build File, Format Version 6.00 -# ** DO NOT EDIT ** - -# TARGTYPE "Win32 (x86) Generic Project" 0x010a - -CFG=test - Win32 Debug -!MESSAGE This is not a valid makefile. To build this project using NMAKE, -!MESSAGE use the Export Makefile command and run -!MESSAGE -!MESSAGE NMAKE /f "test.mak". -!MESSAGE -!MESSAGE You can specify a configuration when running NMAKE -!MESSAGE by defining the macro CFG on the command line. For example: -!MESSAGE -!MESSAGE NMAKE /f "test.mak" CFG="test - Win32 Debug" -!MESSAGE -!MESSAGE Possible choices for configuration are: -!MESSAGE -!MESSAGE "test - Win32 Release" (based on "Win32 (x86) Generic Project") -!MESSAGE "test - Win32 Debug" (based on "Win32 (x86) Generic Project") -!MESSAGE - -# Begin Project -# PROP testowPerConfigDependencies 0 -# PROP Scc_ProjName "" -# PROP Scc_LocalPath "" -MTL=midl.exe - -!IF "$(CFG)" == "test - Win32 Release" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 0 -# PROP BASE Output_Dir "Release" -# PROP BASE Intermediate_Dir "Release" -# PROP BASE Target_Dir "" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 0 -# PROP Output_Dir "..\..\..\bin" -# PROP Intermediate_Dir "..\..\..\obj\Release" -# PROP Target_Dir "" - -!ELSEIF "$(CFG)" == "test - Win32 Debug" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 1 -# PROP BASE Output_Dir "Debug" -# PROP BASE Intermediate_Dir "Debug" -# PROP BASE Target_Dir "" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 1 -# PROP Output_Dir "..\..\..\bin" -# PROP Intermediate_Dir "..\..\..\obj\Debug" -# PROP Target_Dir "" - -!ENDIF - -# Begin Target - -# Name "test - Win32 Release" -# Name "test - Win32 Debug" -# End Target -# End Project diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc60/test_gc.dsp ecl-16.1.3+ds/src/bdwgc/windows-untested/vc60/test_gc.dsp --- ecl-16.1.2/src/bdwgc/windows-untested/vc60/test_gc.dsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc60/test_gc.dsp 1970-01-01 00:00:00.000000000 +0000 @@ -1,93 +0,0 @@ -# Microsoft Developer Studio Project File - Name="test_gc" - Package Owner=<4> -# Microsoft Developer Studio Generated Build File, Format Version 6.00 -# ** DO NOT EDIT ** - -# TARGTYPE "Win32 (x86) Console Application" 0x0103 - -CFG=test_gc - Win32 Debug -!MESSAGE This is not a valid makefile. To build this project using NMAKE, -!MESSAGE use the Export Makefile command and run -!MESSAGE -!MESSAGE NMAKE /f "test_gc.mak". -!MESSAGE -!MESSAGE You can specify a configuration when running NMAKE -!MESSAGE by defining the macro CFG on the command line. For example: -!MESSAGE -!MESSAGE NMAKE /f "test_gc.mak" CFG="test_gc - Win32 Debug" -!MESSAGE -!MESSAGE Possible choices for configuration are: -!MESSAGE -!MESSAGE "test_gc - Win32 Release" (based on "Win32 (x86) Console Application") -!MESSAGE "test_gc - Win32 Debug" (based on "Win32 (x86) Console Application") -!MESSAGE - -# Begin Project -# PROP AllowPerConfigDependencies 0 -# PROP Scc_ProjName "" -# PROP Scc_LocalPath "" -CPP=cl.exe -RSC=rc.exe - -!IF "$(CFG)" == "test_gc - Win32 Release" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 0 -# PROP BASE Output_Dir "Release" -# PROP BASE Intermediate_Dir "Release" -# PROP BASE Target_Dir "" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 0 -# PROP Output_Dir "..\..\..\bin" -# PROP Intermediate_Dir "..\..\..\obj\Release\test_gc" -# PROP Ignore_Export_Lib 0 -# PROP Target_Dir "" -# ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c -# ADD CPP /nologo /MD /W3 /GX /Zi /O2 /I "..\..\include" /D "NDEBUG" /D "_CONSOLE" /D "GC_DLL" /D "WIN32" /D "_MBCS" /D "GC_THREADS" /FD /c -# SUBTRACT CPP /Fr /YX -# ADD BASE RSC /l 0x409 /d "NDEBUG" -# ADD RSC /l 0x409 /d "NDEBUG" -BSC32=bscmake.exe -# ADD BASE BSC32 /nologo -# ADD BSC32 /nologo -LINK32=link.exe -# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /machine:I386 -# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib /nologo /debug /machine:I386 /release /opt:ref -# SUBTRACT LINK32 /pdb:none - -!ELSEIF "$(CFG)" == "test_gc - Win32 Debug" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 1 -# PROP BASE Output_Dir "Debug" -# PROP BASE Intermediate_Dir "Debug" -# PROP BASE Target_Dir "" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 1 -# PROP Output_Dir "..\..\..\bin" -# PROP Intermediate_Dir "..\..\..\obj\Debug\test_gc" -# PROP Ignore_Export_Lib 0 -# PROP Target_Dir "" -# ADD BASE CPP /nologo /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /GZ /c -# ADD CPP /nologo /MDd /W3 /Gm /GX /Zi /Od /I "..\..\include" /D "_DEBUG" /D "_CONSOLE" /D "GC_DLL" /D "WIN32" /D "_MBCS" /D "GC_THREADS" /YX /FD /GZ /c -# SUBTRACT CPP /Fr -# ADD BASE RSC /l 0x409 /d "_DEBUG" -# ADD RSC /l 0x409 /d "_DEBUG" -BSC32=bscmake.exe -# ADD BASE BSC32 /nologo -# ADD BSC32 /nologo /o"..\..\..\bin/test_gcd.bsc" -LINK32=link.exe -# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /debug /machine:I386 /pdbtype:sept -# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib /nologo /incremental:no /debug /machine:I386 /out:"..\..\..\bin/test_gcd.exe" /pdbtype:sept - -!ENDIF - -# Begin Target - -# Name "test_gc - Win32 Release" -# Name "test_gc - Win32 Debug" -# Begin Source File - -SOURCE=..\..\tests\test.c -# End Source File -# End Target -# End Project diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc60/test_leak_gc.dsp ecl-16.1.3+ds/src/bdwgc/windows-untested/vc60/test_leak_gc.dsp --- ecl-16.1.2/src/bdwgc/windows-untested/vc60/test_leak_gc.dsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc60/test_leak_gc.dsp 1970-01-01 00:00:00.000000000 +0000 @@ -1,93 +0,0 @@ -# Microsoft Developer Studio Project File - Name="test_leak_gc" - Package Owner=<4> -# Microsoft Developer Studio Generated Build File, Format Version 6.00 -# ** DO NOT EDIT ** - -# TARGTYPE "Win32 (x86) Console Application" 0x0103 - -CFG=test_leak_gc - Win32 Debug -!MESSAGE This is not a valid makefile. To build this project using NMAKE, -!MESSAGE use the Export Makefile command and run -!MESSAGE -!MESSAGE NMAKE /f "test_leak_gc.mak". -!MESSAGE -!MESSAGE You can specify a configuration when running NMAKE -!MESSAGE by defining the macro CFG on the command line. For example: -!MESSAGE -!MESSAGE NMAKE /f "test_leak_gc.mak" CFG="test_leak_gc - Win32 Debug" -!MESSAGE -!MESSAGE Possible choices for configuration are: -!MESSAGE -!MESSAGE "test_leak_gc - Win32 Release" (based on "Win32 (x86) Console Application") -!MESSAGE "test_leak_gc - Win32 Debug" (based on "Win32 (x86) Console Application") -!MESSAGE - -# Begin Project -# PROP AllowPerConfigDependencies 0 -# PROP Scc_ProjName "" -# PROP Scc_LocalPath "" -CPP=cl.exe -RSC=rc.exe - -!IF "$(CFG)" == "test_leak_gc - Win32 Release" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 0 -# PROP BASE Output_Dir "Release" -# PROP BASE Intermediate_Dir "Release" -# PROP BASE Target_Dir "" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 0 -# PROP Output_Dir "..\..\..\bin" -# PROP Intermediate_Dir "..\..\..\obj\Release\test_leak_gc" -# PROP Ignore_Export_Lib 0 -# PROP Target_Dir "" -# ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c -# ADD CPP /nologo /MD /W3 /GX /Zi /O2 /I "..\..\include" /D "NDEBUG" /D "_CONSOLE" /D "GC_DLL" /D "WIN32" /D "_MBCS" /D "GC_THREADS" /FD /c -# SUBTRACT CPP /Fr /YX -# ADD BASE RSC /l 0x409 /d "NDEBUG" -# ADD RSC /l 0x409 /d "NDEBUG" -BSC32=bscmake.exe -# ADD BASE BSC32 /nologo -# ADD BSC32 /nologo -LINK32=link.exe -# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /machine:I386 -# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib /nologo /debug /machine:I386 /release /opt:ref -# SUBTRACT LINK32 /pdb:none - -!ELSEIF "$(CFG)" == "test_leak_gc - Win32 Debug" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 1 -# PROP BASE Output_Dir "Debug" -# PROP BASE Intermediate_Dir "Debug" -# PROP BASE Target_Dir "" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 1 -# PROP Output_Dir "..\..\..\bin" -# PROP Intermediate_Dir "..\..\..\obj\Debug\test_leak_gc" -# PROP Ignore_Export_Lib 0 -# PROP Target_Dir "" -# ADD BASE CPP /nologo /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /GZ /c -# ADD CPP /nologo /MDd /W3 /Gm /GX /Zi /Od /I "..\..\include" /D "_DEBUG" /D "_CONSOLE" /D "GC_DLL" /D "WIN32" /D "_MBCS" /D "GC_THREADS" /YX /FD /GZ /c -# SUBTRACT CPP /Fr -# ADD BASE RSC /l 0x409 /d "_DEBUG" -# ADD RSC /l 0x409 /d "_DEBUG" -BSC32=bscmake.exe -# ADD BASE BSC32 /nologo -# ADD BSC32 /nologo /o"..\..\..\bin/test_leak_gcd.bsc" -LINK32=link.exe -# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /debug /machine:I386 /pdbtype:sept -# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib /nologo /incremental:no /debug /machine:I386 /out:"..\..\..\bin/test_leak_gcd.exe" /pdbtype:sept - -!ENDIF - -# Begin Target - -# Name "test_leak_gc - Win32 Release" -# Name "test_leak_gc - Win32 Debug" -# Begin Source File - -SOURCE=..\..\tests\leak_test.c -# End Source File -# End Target -# End Project diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc60/test_leak_libgc.dsp ecl-16.1.3+ds/src/bdwgc/windows-untested/vc60/test_leak_libgc.dsp --- ecl-16.1.2/src/bdwgc/windows-untested/vc60/test_leak_libgc.dsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc60/test_leak_libgc.dsp 1970-01-01 00:00:00.000000000 +0000 @@ -1,93 +0,0 @@ -# Microsoft Developer Studio Project File - Name="test_leak_libgc" - Package Owner=<4> -# Microsoft Developer Studio Generated Build File, Format Version 6.00 -# ** DO NOT EDIT ** - -# TARGTYPE "Win32 (x86) Console Application" 0x0103 - -CFG=test_leak_libgc - Win32 Debug -!MESSAGE This is not a valid makefile. To build this project using NMAKE, -!MESSAGE use the Export Makefile command and run -!MESSAGE -!MESSAGE NMAKE /f "test_leak_libgc.mak". -!MESSAGE -!MESSAGE You can specify a configuration when running NMAKE -!MESSAGE by defining the macro CFG on the command line. For example: -!MESSAGE -!MESSAGE NMAKE /f "test_leak_libgc.mak" CFG="test_leak_libgc - Win32 Debug" -!MESSAGE -!MESSAGE Possible choices for configuration are: -!MESSAGE -!MESSAGE "test_leak_libgc - Win32 Release" (based on "Win32 (x86) Console Application") -!MESSAGE "test_leak_libgc - Win32 Debug" (based on "Win32 (x86) Console Application") -!MESSAGE - -# Begin Project -# PROP AllowPerConfigDependencies 0 -# PROP Scc_ProjName "" -# PROP Scc_LocalPath "" -CPP=cl.exe -RSC=rc.exe - -!IF "$(CFG)" == "test_leak_libgc - Win32 Release" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 0 -# PROP BASE Output_Dir "Release" -# PROP BASE Intermediate_Dir "Release" -# PROP BASE Target_Dir "" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 0 -# PROP Output_Dir "..\..\..\bin" -# PROP Intermediate_Dir "..\..\..\obj\Release\test_leak_libgc" -# PROP Ignore_Export_Lib 0 -# PROP Target_Dir "" -# ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c -# ADD CPP /nologo /W3 /GX /Zi /O2 /I "..\..\include" /D "NDEBUG" /D "_CONSOLE" /D "WIN32" /D "_MBCS" /FD /c -# SUBTRACT CPP /Fr /YX -# ADD BASE RSC /l 0x409 /d "NDEBUG" -# ADD RSC /l 0x409 /d "NDEBUG" -BSC32=bscmake.exe -# ADD BASE BSC32 /nologo -# ADD BSC32 /nologo -LINK32=link.exe -# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /machine:I386 -# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib /nologo /debug /machine:I386 /release /opt:ref -# SUBTRACT LINK32 /pdb:none - -!ELSEIF "$(CFG)" == "test_leak_libgc - Win32 Debug" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 1 -# PROP BASE Output_Dir "Debug" -# PROP BASE Intermediate_Dir "Debug" -# PROP BASE Target_Dir "" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 1 -# PROP Output_Dir "..\..\..\bin" -# PROP Intermediate_Dir "..\..\..\obj\Debug\test_leak_libgc" -# PROP Ignore_Export_Lib 0 -# PROP Target_Dir "" -# ADD BASE CPP /nologo /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /GZ /c -# ADD CPP /nologo /W3 /Gm /GX /Zi /Od /I "..\..\include" /D "_DEBUG" /D "_CONSOLE" /D "WIN32" /D "_MBCS" /YX /FD /GZ /c -# SUBTRACT CPP /Fr -# ADD BASE RSC /l 0x409 /d "_DEBUG" -# ADD RSC /l 0x409 /d "_DEBUG" -BSC32=bscmake.exe -# ADD BASE BSC32 /nologo -# ADD BSC32 /nologo /o"..\..\..\bin/test_leak_libgcd.bsc" -LINK32=link.exe -# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /debug /machine:I386 /pdbtype:sept -# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib /nologo /incremental:no /debug /machine:I386 /out:"..\..\..\bin/test_leak_libgcd.exe" /pdbtype:sept - -!ENDIF - -# Begin Target - -# Name "test_leak_libgc - Win32 Release" -# Name "test_leak_libgc - Win32 Debug" -# Begin Source File - -SOURCE=..\..\tests\leak_test.c -# End Source File -# End Target -# End Project diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc60/test_leak_libgcmt.dsp ecl-16.1.3+ds/src/bdwgc/windows-untested/vc60/test_leak_libgcmt.dsp --- ecl-16.1.2/src/bdwgc/windows-untested/vc60/test_leak_libgcmt.dsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc60/test_leak_libgcmt.dsp 1970-01-01 00:00:00.000000000 +0000 @@ -1,93 +0,0 @@ -# Microsoft Developer Studio Project File - Name="test_leak_libgcmt" - Package Owner=<4> -# Microsoft Developer Studio Generated Build File, Format Version 6.00 -# ** DO NOT EDIT ** - -# TARGTYPE "Win32 (x86) Console Application" 0x0103 - -CFG=test_leak_libgcmt - Win32 Debug -!MESSAGE This is not a valid makefile. To build this project using NMAKE, -!MESSAGE use the Export Makefile command and run -!MESSAGE -!MESSAGE NMAKE /f "test_leak_libgcmt.mak". -!MESSAGE -!MESSAGE You can specify a configuration when running NMAKE -!MESSAGE by defining the macro CFG on the command line. For example: -!MESSAGE -!MESSAGE NMAKE /f "test_leak_libgcmt.mak" CFG="test_leak_libgcmt - Win32 Debug" -!MESSAGE -!MESSAGE Possible choices for configuration are: -!MESSAGE -!MESSAGE "test_leak_libgcmt - Win32 Release" (based on "Win32 (x86) Console Application") -!MESSAGE "test_leak_libgcmt - Win32 Debug" (based on "Win32 (x86) Console Application") -!MESSAGE - -# Begin Project -# PROP AllowPerConfigDependencies 0 -# PROP Scc_ProjName "" -# PROP Scc_LocalPath "" -CPP=cl.exe -RSC=rc.exe - -!IF "$(CFG)" == "test_leak_libgcmt - Win32 Release" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 0 -# PROP BASE Output_Dir "Release" -# PROP BASE Intermediate_Dir "Release" -# PROP BASE Target_Dir "" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 0 -# PROP Output_Dir "..\..\..\bin" -# PROP Intermediate_Dir "..\..\..\obj\Release\test_leak_libgcmt" -# PROP Ignore_Export_Lib 0 -# PROP Target_Dir "" -# ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c -# ADD CPP /nologo /MT /W3 /GX /Zi /O2 /I "..\..\include" /D "NDEBUG" /D "_CONSOLE" /D "WIN32" /D "_MBCS" /D "GC_THREADS" /FD /c -# SUBTRACT CPP /Fr /YX -# ADD BASE RSC /l 0x409 /d "NDEBUG" -# ADD RSC /l 0x409 /d "NDEBUG" -BSC32=bscmake.exe -# ADD BASE BSC32 /nologo -# ADD BSC32 /nologo -LINK32=link.exe -# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /machine:I386 -# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib /nologo /debug /machine:I386 /release /opt:ref -# SUBTRACT LINK32 /pdb:none - -!ELSEIF "$(CFG)" == "test_leak_libgcmt - Win32 Debug" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 1 -# PROP BASE Output_Dir "Debug" -# PROP BASE Intermediate_Dir "Debug" -# PROP BASE Target_Dir "" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 1 -# PROP Output_Dir "..\..\..\bin" -# PROP Intermediate_Dir "..\..\..\obj\Debug\test_leak_libgcmt" -# PROP Ignore_Export_Lib 0 -# PROP Target_Dir "" -# ADD BASE CPP /nologo /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /GZ /c -# ADD CPP /nologo /MTd /W3 /Gm /GX /Zi /Od /I "..\..\include" /D "_DEBUG" /D "_CONSOLE" /D "WIN32" /D "_MBCS" /D "GC_THREADS" /YX /FD /GZ /c -# SUBTRACT CPP /Fr -# ADD BASE RSC /l 0x409 /d "_DEBUG" -# ADD RSC /l 0x409 /d "_DEBUG" -BSC32=bscmake.exe -# ADD BASE BSC32 /nologo -# ADD BSC32 /nologo /o"..\..\..\bin/test_leak_libgcmtd.bsc" -LINK32=link.exe -# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /debug /machine:I386 /pdbtype:sept -# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib /nologo /incremental:no /debug /machine:I386 /out:"..\..\..\bin/test_leak_libgcmtd.exe" /pdbtype:sept - -!ENDIF - -# Begin Target - -# Name "test_leak_libgcmt - Win32 Release" -# Name "test_leak_libgcmt - Win32 Debug" -# Begin Source File - -SOURCE=..\..\tests\leak_test.c -# End Source File -# End Target -# End Project diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc60/test_libgc.dsp ecl-16.1.3+ds/src/bdwgc/windows-untested/vc60/test_libgc.dsp --- ecl-16.1.2/src/bdwgc/windows-untested/vc60/test_libgc.dsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc60/test_libgc.dsp 1970-01-01 00:00:00.000000000 +0000 @@ -1,93 +0,0 @@ -# Microsoft Developer Studio Project File - Name="test_libgc" - Package Owner=<4> -# Microsoft Developer Studio Generated Build File, Format Version 6.00 -# ** DO NOT EDIT ** - -# TARGTYPE "Win32 (x86) Console Application" 0x0103 - -CFG=test_libgc - Win32 Debug -!MESSAGE This is not a valid makefile. To build this project using NMAKE, -!MESSAGE use the Export Makefile command and run -!MESSAGE -!MESSAGE NMAKE /f "test_libgc.mak". -!MESSAGE -!MESSAGE You can specify a configuration when running NMAKE -!MESSAGE by defining the macro CFG on the command line. For example: -!MESSAGE -!MESSAGE NMAKE /f "test_libgc.mak" CFG="test_libgc - Win32 Debug" -!MESSAGE -!MESSAGE Possible choices for configuration are: -!MESSAGE -!MESSAGE "test_libgc - Win32 Release" (based on "Win32 (x86) Console Application") -!MESSAGE "test_libgc - Win32 Debug" (based on "Win32 (x86) Console Application") -!MESSAGE - -# Begin Project -# PROP AllowPerConfigDependencies 0 -# PROP Scc_ProjName "" -# PROP Scc_LocalPath "" -CPP=cl.exe -RSC=rc.exe - -!IF "$(CFG)" == "test_libgc - Win32 Release" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 0 -# PROP BASE Output_Dir "Release" -# PROP BASE Intermediate_Dir "Release" -# PROP BASE Target_Dir "" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 0 -# PROP Output_Dir "..\..\..\bin" -# PROP Intermediate_Dir "..\..\..\obj\Release\test_libgc" -# PROP Ignore_Export_Lib 0 -# PROP Target_Dir "" -# ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c -# ADD CPP /nologo /W3 /GX /Zi /O2 /I "..\..\include" /D "NDEBUG" /D "_CONSOLE" /D "WIN32" /D "_MBCS" /FD /c -# SUBTRACT CPP /Fr /YX -# ADD BASE RSC /l 0x409 /d "NDEBUG" -# ADD RSC /l 0x409 /d "NDEBUG" -BSC32=bscmake.exe -# ADD BASE BSC32 /nologo -# ADD BSC32 /nologo -LINK32=link.exe -# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /machine:I386 -# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib /nologo /debug /machine:I386 /release /opt:ref -# SUBTRACT LINK32 /pdb:none - -!ELSEIF "$(CFG)" == "test_libgc - Win32 Debug" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 1 -# PROP BASE Output_Dir "Debug" -# PROP BASE Intermediate_Dir "Debug" -# PROP BASE Target_Dir "" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 1 -# PROP Output_Dir "..\..\..\bin" -# PROP Intermediate_Dir "..\..\..\obj\Debug\test_libgc" -# PROP Ignore_Export_Lib 0 -# PROP Target_Dir "" -# ADD BASE CPP /nologo /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /GZ /c -# ADD CPP /nologo /W3 /Gm /GX /Zi /Od /I "..\..\include" /D "_DEBUG" /D "_CONSOLE" /D "WIN32" /D "_MBCS" /YX /FD /GZ /c -# SUBTRACT CPP /Fr -# ADD BASE RSC /l 0x409 /d "_DEBUG" -# ADD RSC /l 0x409 /d "_DEBUG" -BSC32=bscmake.exe -# ADD BASE BSC32 /nologo -# ADD BSC32 /nologo /o"..\..\..\bin/test_libgcd.bsc" -LINK32=link.exe -# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /debug /machine:I386 /pdbtype:sept -# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib /nologo /incremental:no /debug /machine:I386 /out:"..\..\..\bin/test_libgcd.exe" /pdbtype:sept - -!ENDIF - -# Begin Target - -# Name "test_libgc - Win32 Release" -# Name "test_libgc - Win32 Debug" -# Begin Source File - -SOURCE=..\..\tests\test.c -# End Source File -# End Target -# End Project diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc60/test_libgcmt.dsp ecl-16.1.3+ds/src/bdwgc/windows-untested/vc60/test_libgcmt.dsp --- ecl-16.1.2/src/bdwgc/windows-untested/vc60/test_libgcmt.dsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc60/test_libgcmt.dsp 1970-01-01 00:00:00.000000000 +0000 @@ -1,93 +0,0 @@ -# Microsoft Developer Studio Project File - Name="test_libgcmt" - Package Owner=<4> -# Microsoft Developer Studio Generated Build File, Format Version 6.00 -# ** DO NOT EDIT ** - -# TARGTYPE "Win32 (x86) Console Application" 0x0103 - -CFG=test_libgcmt - Win32 Debug -!MESSAGE This is not a valid makefile. To build this project using NMAKE, -!MESSAGE use the Export Makefile command and run -!MESSAGE -!MESSAGE NMAKE /f "test_libgcmt.mak". -!MESSAGE -!MESSAGE You can specify a configuration when running NMAKE -!MESSAGE by defining the macro CFG on the command line. For example: -!MESSAGE -!MESSAGE NMAKE /f "test_libgcmt.mak" CFG="test_libgcmt - Win32 Debug" -!MESSAGE -!MESSAGE Possible choices for configuration are: -!MESSAGE -!MESSAGE "test_libgcmt - Win32 Release" (based on "Win32 (x86) Console Application") -!MESSAGE "test_libgcmt - Win32 Debug" (based on "Win32 (x86) Console Application") -!MESSAGE - -# Begin Project -# PROP AllowPerConfigDependencies 0 -# PROP Scc_ProjName "" -# PROP Scc_LocalPath "" -CPP=cl.exe -RSC=rc.exe - -!IF "$(CFG)" == "test_libgcmt - Win32 Release" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 0 -# PROP BASE Output_Dir "Release" -# PROP BASE Intermediate_Dir "Release" -# PROP BASE Target_Dir "" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 0 -# PROP Output_Dir "..\..\..\bin" -# PROP Intermediate_Dir "..\..\..\obj\Release\test_libgcmt" -# PROP Ignore_Export_Lib 0 -# PROP Target_Dir "" -# ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c -# ADD CPP /nologo /MT /W3 /GX /Zi /O2 /I "..\..\include" /D "NDEBUG" /D "_CONSOLE" /D "WIN32" /D "_MBCS" /D "GC_THREADS" /FD /c -# SUBTRACT CPP /Fr /YX -# ADD BASE RSC /l 0x409 /d "NDEBUG" -# ADD RSC /l 0x409 /d "NDEBUG" -BSC32=bscmake.exe -# ADD BASE BSC32 /nologo -# ADD BSC32 /nologo -LINK32=link.exe -# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /machine:I386 -# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib /nologo /debug /machine:I386 /release /opt:ref -# SUBTRACT LINK32 /pdb:none - -!ELSEIF "$(CFG)" == "test_libgcmt - Win32 Debug" - -# PROP BASE Use_MFC 0 -# PROP BASE Use_Debug_Libraries 1 -# PROP BASE Output_Dir "Debug" -# PROP BASE Intermediate_Dir "Debug" -# PROP BASE Target_Dir "" -# PROP Use_MFC 0 -# PROP Use_Debug_Libraries 1 -# PROP Output_Dir "..\..\..\bin" -# PROP Intermediate_Dir "..\..\..\obj\Debug\test_libgcmt" -# PROP Ignore_Export_Lib 0 -# PROP Target_Dir "" -# ADD BASE CPP /nologo /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /GZ /c -# ADD CPP /nologo /MTd /W3 /Gm /GX /Zi /Od /I "..\..\include" /D "_DEBUG" /D "_CONSOLE" /D "WIN32" /D "_MBCS" /D "GC_THREADS" /YX /FD /GZ /c -# SUBTRACT CPP /Fr -# ADD BASE RSC /l 0x409 /d "_DEBUG" -# ADD RSC /l 0x409 /d "_DEBUG" -BSC32=bscmake.exe -# ADD BASE BSC32 /nologo -# ADD BSC32 /nologo /o"..\..\..\bin/test_libgcmtd.bsc" -LINK32=link.exe -# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /debug /machine:I386 /pdbtype:sept -# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib /nologo /incremental:no /debug /machine:I386 /out:"..\..\..\bin/test_libgcmtd.exe" /pdbtype:sept - -!ENDIF - -# Begin Target - -# Name "test_libgcmt - Win32 Release" -# Name "test_libgcmt - Win32 Debug" -# Begin Source File - -SOURCE=..\..\tests\test.c -# End Source File -# End Target -# End Project diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc60/vc60crlf.cmd ecl-16.1.3+ds/src/bdwgc/windows-untested/vc60/vc60crlf.cmd --- ecl-16.1.2/src/bdwgc/windows-untested/vc60/vc60crlf.cmd 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc60/vc60crlf.cmd 1970-01-01 00:00:00.000000000 +0000 @@ -1,15 +0,0 @@ -@echo off -rem This script will convert Unix-style line endings into Windows format. - -for %%P in (*.ds?) do call :fixline %%P -goto :eof - -:fixline -@echo on -if exist "%~1.new" del "%~1.new" -for /f %%S in (%1) do ( - echo %%S>>"%~1.new" -) -ren %1 "%~1.bak" -ren "%~1.new" %1 -goto :eof diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc70/all.vcproj ecl-16.1.3+ds/src/bdwgc/windows-untested/vc70/all.vcproj --- ecl-16.1.2/src/bdwgc/windows-untested/vc70/all.vcproj 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc70/all.vcproj 1970-01-01 00:00:00.000000000 +0000 @@ -1,49 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc70/gc.sln ecl-16.1.3+ds/src/bdwgc/windows-untested/vc70/gc.sln --- ecl-16.1.2/src/bdwgc/windows-untested/vc70/gc.sln 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc70/gc.sln 1970-01-01 00:00:00.000000000 +0000 @@ -1,96 +0,0 @@ -Microsoft Visual Studio Solution File, Format Version 7.00 -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "all", "all.vcproj", "{CED9D953-AC1A-4795-9853-6D60857509EE}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "gc", "gc.vcproj", "{D7ADAD9A-14FF-4C93-9BF1-ACD03FB6A2FA}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "libgc", "libgc.vcproj", "{F80C47A7-2B2D-4BA9-BEED-AAFA7541650D}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "libgcmt", "libgcmt.vcproj", "{39802D97-BEF7-499D-8570-294AEA39ED7D}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "test", "test.vcproj", "{997208FE-7A7D-435A-945A-C61C57D8070C}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "test_gc", "test_gc.vcproj", "{D1F56655-8C27-4320-9436-2A11729A337B}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "test_leak_gc", "test_leak_gc.vcproj", "{6E545988-1AE7-41FB-A981-D256A84F4C3A}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "test_leak_libgc", "test_leak_libgc.vcproj", "{A561AE5C-33FE-4DBC-A4D4-52B7F196D20F}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "test_leak_libgcmt", "test_leak_libgcmt.vcproj", "{92046CBF-2EF9-408D-B997-8445E945D687}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "test_libgc", "test_libgc.vcproj", "{8CFE55AA-676C-4B5A-B133-390B4BF02AB8}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "test_libgcmt", "test_libgcmt.vcproj", "{8C63DB39-DBF4-49D3-A908-172ADA21753B}" -EndProject -Global - GlobalSection(SolutionConfiguration) = preSolution - ConfigName.0 = Debug - ConfigName.1 = Release - EndGlobalSection - GlobalSection(ProjectDependencies) = postSolution - {CED9D953-AC1A-4795-9853-6D60857509EE}.0 = {39802D97-BEF7-499D-8570-294AEA39ED7D} - {CED9D953-AC1A-4795-9853-6D60857509EE}.1 = {F80C47A7-2B2D-4BA9-BEED-AAFA7541650D} - {CED9D953-AC1A-4795-9853-6D60857509EE}.2 = {D7ADAD9A-14FF-4C93-9BF1-ACD03FB6A2FA} - {997208FE-7A7D-435A-945A-C61C57D8070C}.0 = {92046CBF-2EF9-408D-B997-8445E945D687} - {997208FE-7A7D-435A-945A-C61C57D8070C}.1 = {A561AE5C-33FE-4DBC-A4D4-52B7F196D20F} - {997208FE-7A7D-435A-945A-C61C57D8070C}.2 = {6E545988-1AE7-41FB-A981-D256A84F4C3A} - {997208FE-7A7D-435A-945A-C61C57D8070C}.3 = {8C63DB39-DBF4-49D3-A908-172ADA21753B} - {997208FE-7A7D-435A-945A-C61C57D8070C}.4 = {8CFE55AA-676C-4B5A-B133-390B4BF02AB8} - {997208FE-7A7D-435A-945A-C61C57D8070C}.5 = {D1F56655-8C27-4320-9436-2A11729A337B} - {D1F56655-8C27-4320-9436-2A11729A337B}.0 = {D7ADAD9A-14FF-4C93-9BF1-ACD03FB6A2FA} - {6E545988-1AE7-41FB-A981-D256A84F4C3A}.0 = {D7ADAD9A-14FF-4C93-9BF1-ACD03FB6A2FA} - {A561AE5C-33FE-4DBC-A4D4-52B7F196D20F}.0 = {F80C47A7-2B2D-4BA9-BEED-AAFA7541650D} - {92046CBF-2EF9-408D-B997-8445E945D687}.0 = {39802D97-BEF7-499D-8570-294AEA39ED7D} - {8CFE55AA-676C-4B5A-B133-390B4BF02AB8}.0 = {F80C47A7-2B2D-4BA9-BEED-AAFA7541650D} - {8C63DB39-DBF4-49D3-A908-172ADA21753B}.0 = {39802D97-BEF7-499D-8570-294AEA39ED7D} - EndGlobalSection - GlobalSection(ProjectConfiguration) = postSolution - {CED9D953-AC1A-4795-9853-6D60857509EE}.Debug.ActiveCfg = Debug|Win32 - {CED9D953-AC1A-4795-9853-6D60857509EE}.Debug.Build.0 = Debug|Win32 - {CED9D953-AC1A-4795-9853-6D60857509EE}.Release.ActiveCfg = Release|Win32 - {CED9D953-AC1A-4795-9853-6D60857509EE}.Release.Build.0 = Release|Win32 - {D7ADAD9A-14FF-4C93-9BF1-ACD03FB6A2FA}.Debug.ActiveCfg = Debug|Win32 - {D7ADAD9A-14FF-4C93-9BF1-ACD03FB6A2FA}.Debug.Build.0 = Debug|Win32 - {D7ADAD9A-14FF-4C93-9BF1-ACD03FB6A2FA}.Release.ActiveCfg = Release|Win32 - {D7ADAD9A-14FF-4C93-9BF1-ACD03FB6A2FA}.Release.Build.0 = Release|Win32 - {F80C47A7-2B2D-4BA9-BEED-AAFA7541650D}.Debug.ActiveCfg = Debug|Win32 - {F80C47A7-2B2D-4BA9-BEED-AAFA7541650D}.Debug.Build.0 = Debug|Win32 - {F80C47A7-2B2D-4BA9-BEED-AAFA7541650D}.Release.ActiveCfg = Release|Win32 - {F80C47A7-2B2D-4BA9-BEED-AAFA7541650D}.Release.Build.0 = Release|Win32 - {39802D97-BEF7-499D-8570-294AEA39ED7D}.Debug.ActiveCfg = Debug|Win32 - {39802D97-BEF7-499D-8570-294AEA39ED7D}.Debug.Build.0 = Debug|Win32 - {39802D97-BEF7-499D-8570-294AEA39ED7D}.Release.ActiveCfg = Release|Win32 - {39802D97-BEF7-499D-8570-294AEA39ED7D}.Release.Build.0 = Release|Win32 - {997208FE-7A7D-435A-945A-C61C57D8070C}.Debug.ActiveCfg = Debug|Win32 - {997208FE-7A7D-435A-945A-C61C57D8070C}.Debug.Build.0 = Debug|Win32 - {997208FE-7A7D-435A-945A-C61C57D8070C}.Release.ActiveCfg = Release|Win32 - {997208FE-7A7D-435A-945A-C61C57D8070C}.Release.Build.0 = Release|Win32 - {D1F56655-8C27-4320-9436-2A11729A337B}.Debug.ActiveCfg = Debug|Win32 - {D1F56655-8C27-4320-9436-2A11729A337B}.Debug.Build.0 = Debug|Win32 - {D1F56655-8C27-4320-9436-2A11729A337B}.Release.ActiveCfg = Release|Win32 - {D1F56655-8C27-4320-9436-2A11729A337B}.Release.Build.0 = Release|Win32 - {6E545988-1AE7-41FB-A981-D256A84F4C3A}.Debug.ActiveCfg = Debug|Win32 - {6E545988-1AE7-41FB-A981-D256A84F4C3A}.Debug.Build.0 = Debug|Win32 - {6E545988-1AE7-41FB-A981-D256A84F4C3A}.Release.ActiveCfg = Release|Win32 - {6E545988-1AE7-41FB-A981-D256A84F4C3A}.Release.Build.0 = Release|Win32 - {A561AE5C-33FE-4DBC-A4D4-52B7F196D20F}.Debug.ActiveCfg = Debug|Win32 - {A561AE5C-33FE-4DBC-A4D4-52B7F196D20F}.Debug.Build.0 = Debug|Win32 - {A561AE5C-33FE-4DBC-A4D4-52B7F196D20F}.Release.ActiveCfg = Release|Win32 - {A561AE5C-33FE-4DBC-A4D4-52B7F196D20F}.Release.Build.0 = Release|Win32 - {92046CBF-2EF9-408D-B997-8445E945D687}.Debug.ActiveCfg = Debug|Win32 - {92046CBF-2EF9-408D-B997-8445E945D687}.Debug.Build.0 = Debug|Win32 - {92046CBF-2EF9-408D-B997-8445E945D687}.Release.ActiveCfg = Release|Win32 - {92046CBF-2EF9-408D-B997-8445E945D687}.Release.Build.0 = Release|Win32 - {8CFE55AA-676C-4B5A-B133-390B4BF02AB8}.Debug.ActiveCfg = Debug|Win32 - {8CFE55AA-676C-4B5A-B133-390B4BF02AB8}.Debug.Build.0 = Debug|Win32 - {8CFE55AA-676C-4B5A-B133-390B4BF02AB8}.Release.ActiveCfg = Release|Win32 - {8CFE55AA-676C-4B5A-B133-390B4BF02AB8}.Release.Build.0 = Release|Win32 - {8C63DB39-DBF4-49D3-A908-172ADA21753B}.Debug.ActiveCfg = Debug|Win32 - {8C63DB39-DBF4-49D3-A908-172ADA21753B}.Debug.Build.0 = Debug|Win32 - {8C63DB39-DBF4-49D3-A908-172ADA21753B}.Release.ActiveCfg = Release|Win32 - {8C63DB39-DBF4-49D3-A908-172ADA21753B}.Release.Build.0 = Release|Win32 - EndGlobalSection - GlobalSection(ExtensibilityGlobals) = postSolution - EndGlobalSection - GlobalSection(ExtensibilityAddIns) = postSolution - EndGlobalSection -EndGlobal diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc70/gc.vcproj ecl-16.1.3+ds/src/bdwgc/windows-untested/vc70/gc.vcproj --- ecl-16.1.2/src/bdwgc/windows-untested/vc70/gc.vcproj 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc70/gc.vcproj 1970-01-01 00:00:00.000000000 +0000 @@ -1,347 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc70/libgcmt.vcproj ecl-16.1.3+ds/src/bdwgc/windows-untested/vc70/libgcmt.vcproj --- ecl-16.1.2/src/bdwgc/windows-untested/vc70/libgcmt.vcproj 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc70/libgcmt.vcproj 1970-01-01 00:00:00.000000000 +0000 @@ -1,225 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc70/libgc.vcproj ecl-16.1.3+ds/src/bdwgc/windows-untested/vc70/libgc.vcproj --- ecl-16.1.2/src/bdwgc/windows-untested/vc70/libgc.vcproj 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc70/libgc.vcproj 1970-01-01 00:00:00.000000000 +0000 @@ -1,258 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc70/test_gc.vcproj ecl-16.1.3+ds/src/bdwgc/windows-untested/vc70/test_gc.vcproj --- ecl-16.1.2/src/bdwgc/windows-untested/vc70/test_gc.vcproj 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc70/test_gc.vcproj 1970-01-01 00:00:00.000000000 +0000 @@ -1,127 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc70/test_leak_gc.vcproj ecl-16.1.3+ds/src/bdwgc/windows-untested/vc70/test_leak_gc.vcproj --- ecl-16.1.2/src/bdwgc/windows-untested/vc70/test_leak_gc.vcproj 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc70/test_leak_gc.vcproj 1970-01-01 00:00:00.000000000 +0000 @@ -1,127 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc70/test_leak_libgcmt.vcproj ecl-16.1.3+ds/src/bdwgc/windows-untested/vc70/test_leak_libgcmt.vcproj --- ecl-16.1.2/src/bdwgc/windows-untested/vc70/test_leak_libgcmt.vcproj 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc70/test_leak_libgcmt.vcproj 1970-01-01 00:00:00.000000000 +0000 @@ -1,127 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc70/test_leak_libgc.vcproj ecl-16.1.3+ds/src/bdwgc/windows-untested/vc70/test_leak_libgc.vcproj --- ecl-16.1.2/src/bdwgc/windows-untested/vc70/test_leak_libgc.vcproj 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc70/test_leak_libgc.vcproj 1970-01-01 00:00:00.000000000 +0000 @@ -1,127 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc70/test_libgcmt.vcproj ecl-16.1.3+ds/src/bdwgc/windows-untested/vc70/test_libgcmt.vcproj --- ecl-16.1.2/src/bdwgc/windows-untested/vc70/test_libgcmt.vcproj 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc70/test_libgcmt.vcproj 1970-01-01 00:00:00.000000000 +0000 @@ -1,127 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc70/test_libgc.vcproj ecl-16.1.3+ds/src/bdwgc/windows-untested/vc70/test_libgc.vcproj --- ecl-16.1.2/src/bdwgc/windows-untested/vc70/test_libgc.vcproj 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc70/test_libgc.vcproj 1970-01-01 00:00:00.000000000 +0000 @@ -1,127 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc70/test.vcproj ecl-16.1.3+ds/src/bdwgc/windows-untested/vc70/test.vcproj --- ecl-16.1.2/src/bdwgc/windows-untested/vc70/test.vcproj 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc70/test.vcproj 1970-01-01 00:00:00.000000000 +0000 @@ -1,49 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc71/all.vcproj ecl-16.1.3+ds/src/bdwgc/windows-untested/vc71/all.vcproj --- ecl-16.1.2/src/bdwgc/windows-untested/vc71/all.vcproj 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc71/all.vcproj 1970-01-01 00:00:00.000000000 +0000 @@ -1,57 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc71/gc.sln ecl-16.1.3+ds/src/bdwgc/windows-untested/vc71/gc.sln --- ecl-16.1.2/src/bdwgc/windows-untested/vc71/gc.sln 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc71/gc.sln 1970-01-01 00:00:00.000000000 +0000 @@ -1,116 +0,0 @@ -Microsoft Visual Studio Solution File, Format Version 8.00 -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "all", "all.vcproj", "{684E465A-3944-4BA0-BA8D-52A064B43A5D}" - ProjectSection(ProjectDependencies) = postProject - {EDA8C8B6-2538-4F1E-9C9A-F5C4FAF1EC16} = {EDA8C8B6-2538-4F1E-9C9A-F5C4FAF1EC16} - {1C32FB8B-6F91-4190-9F05-CE1E772BB5E0} = {1C32FB8B-6F91-4190-9F05-CE1E772BB5E0} - {93622AAF-633A-4D02-B023-674D4CDA266B} = {93622AAF-633A-4D02-B023-674D4CDA266B} - EndProjectSection -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "gc", "gc.vcproj", "{93622AAF-633A-4D02-B023-674D4CDA266B}" - ProjectSection(ProjectDependencies) = postProject - EndProjectSection -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "libgc", "libgc.vcproj", "{1C32FB8B-6F91-4190-9F05-CE1E772BB5E0}" - ProjectSection(ProjectDependencies) = postProject - EndProjectSection -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "libgcmt", "libgcmt.vcproj", "{EDA8C8B6-2538-4F1E-9C9A-F5C4FAF1EC16}" - ProjectSection(ProjectDependencies) = postProject - EndProjectSection -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "test", "test.vcproj", "{1891ADD8-C39B-494B-B69D-D64F76729E5A}" - ProjectSection(ProjectDependencies) = postProject - {8A595901-33E6-4959-A8E9-6DACC2D57330} = {8A595901-33E6-4959-A8E9-6DACC2D57330} - {EB1D2ECA-926D-4B6E-BF65-B429C713381C} = {EB1D2ECA-926D-4B6E-BF65-B429C713381C} - {500B7CE2-FD16-42C5-B738-1406C13A68B4} = {500B7CE2-FD16-42C5-B738-1406C13A68B4} - {9551B5E4-94A5-4B04-ACA1-9FB28DFD28AA} = {9551B5E4-94A5-4B04-ACA1-9FB28DFD28AA} - {B0F6C137-5153-48E3-ABED-6C02D3912EDA} = {B0F6C137-5153-48E3-ABED-6C02D3912EDA} - {1911057C-30C3-41CE-AF9E-232AEB37BCD3} = {1911057C-30C3-41CE-AF9E-232AEB37BCD3} - EndProjectSection -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "test_gc", "test_gc.vcproj", "{1911057C-30C3-41CE-AF9E-232AEB37BCD3}" - ProjectSection(ProjectDependencies) = postProject - {93622AAF-633A-4D02-B023-674D4CDA266B} = {93622AAF-633A-4D02-B023-674D4CDA266B} - EndProjectSection -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "test_leak_gc", "test_leak_gc.vcproj", "{500B7CE2-FD16-42C5-B738-1406C13A68B4}" - ProjectSection(ProjectDependencies) = postProject - {93622AAF-633A-4D02-B023-674D4CDA266B} = {93622AAF-633A-4D02-B023-674D4CDA266B} - EndProjectSection -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "test_leak_libgc", "test_leak_libgc.vcproj", "{EB1D2ECA-926D-4B6E-BF65-B429C713381C}" - ProjectSection(ProjectDependencies) = postProject - {1C32FB8B-6F91-4190-9F05-CE1E772BB5E0} = {1C32FB8B-6F91-4190-9F05-CE1E772BB5E0} - EndProjectSection -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "test_leak_libgcmt", "test_leak_libgcmt.vcproj", "{8A595901-33E6-4959-A8E9-6DACC2D57330}" - ProjectSection(ProjectDependencies) = postProject - {EDA8C8B6-2538-4F1E-9C9A-F5C4FAF1EC16} = {EDA8C8B6-2538-4F1E-9C9A-F5C4FAF1EC16} - EndProjectSection -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "test_libgc", "test_libgc.vcproj", "{B0F6C137-5153-48E3-ABED-6C02D3912EDA}" - ProjectSection(ProjectDependencies) = postProject - {1C32FB8B-6F91-4190-9F05-CE1E772BB5E0} = {1C32FB8B-6F91-4190-9F05-CE1E772BB5E0} - EndProjectSection -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "test_libgcmt", "test_libgcmt.vcproj", "{9551B5E4-94A5-4B04-ACA1-9FB28DFD28AA}" - ProjectSection(ProjectDependencies) = postProject - {EDA8C8B6-2538-4F1E-9C9A-F5C4FAF1EC16} = {EDA8C8B6-2538-4F1E-9C9A-F5C4FAF1EC16} - EndProjectSection -EndProject -Global - GlobalSection(SolutionConfiguration) = preSolution - Debug = Debug - Release = Release - EndGlobalSection - GlobalSection(ProjectConfiguration) = postSolution - {684E465A-3944-4BA0-BA8D-52A064B43A5D}.Debug.ActiveCfg = Debug|Win32 - {684E465A-3944-4BA0-BA8D-52A064B43A5D}.Debug.Build.0 = Debug|Win32 - {684E465A-3944-4BA0-BA8D-52A064B43A5D}.Release.ActiveCfg = Release|Win32 - {684E465A-3944-4BA0-BA8D-52A064B43A5D}.Release.Build.0 = Release|Win32 - {93622AAF-633A-4D02-B023-674D4CDA266B}.Debug.ActiveCfg = Debug|Win32 - {93622AAF-633A-4D02-B023-674D4CDA266B}.Debug.Build.0 = Debug|Win32 - {93622AAF-633A-4D02-B023-674D4CDA266B}.Release.ActiveCfg = Release|Win32 - {93622AAF-633A-4D02-B023-674D4CDA266B}.Release.Build.0 = Release|Win32 - {1C32FB8B-6F91-4190-9F05-CE1E772BB5E0}.Debug.ActiveCfg = Debug|Win32 - {1C32FB8B-6F91-4190-9F05-CE1E772BB5E0}.Debug.Build.0 = Debug|Win32 - {1C32FB8B-6F91-4190-9F05-CE1E772BB5E0}.Release.ActiveCfg = Release|Win32 - {1C32FB8B-6F91-4190-9F05-CE1E772BB5E0}.Release.Build.0 = Release|Win32 - {EDA8C8B6-2538-4F1E-9C9A-F5C4FAF1EC16}.Debug.ActiveCfg = Debug|Win32 - {EDA8C8B6-2538-4F1E-9C9A-F5C4FAF1EC16}.Debug.Build.0 = Debug|Win32 - {EDA8C8B6-2538-4F1E-9C9A-F5C4FAF1EC16}.Release.ActiveCfg = Release|Win32 - {EDA8C8B6-2538-4F1E-9C9A-F5C4FAF1EC16}.Release.Build.0 = Release|Win32 - {1891ADD8-C39B-494B-B69D-D64F76729E5A}.Debug.ActiveCfg = Debug|Win32 - {1891ADD8-C39B-494B-B69D-D64F76729E5A}.Debug.Build.0 = Debug|Win32 - {1891ADD8-C39B-494B-B69D-D64F76729E5A}.Release.ActiveCfg = Release|Win32 - {1891ADD8-C39B-494B-B69D-D64F76729E5A}.Release.Build.0 = Release|Win32 - {1911057C-30C3-41CE-AF9E-232AEB37BCD3}.Debug.ActiveCfg = Debug|Win32 - {1911057C-30C3-41CE-AF9E-232AEB37BCD3}.Debug.Build.0 = Debug|Win32 - {1911057C-30C3-41CE-AF9E-232AEB37BCD3}.Release.ActiveCfg = Release|Win32 - {1911057C-30C3-41CE-AF9E-232AEB37BCD3}.Release.Build.0 = Release|Win32 - {500B7CE2-FD16-42C5-B738-1406C13A68B4}.Debug.ActiveCfg = Debug|Win32 - {500B7CE2-FD16-42C5-B738-1406C13A68B4}.Debug.Build.0 = Debug|Win32 - {500B7CE2-FD16-42C5-B738-1406C13A68B4}.Release.ActiveCfg = Release|Win32 - {500B7CE2-FD16-42C5-B738-1406C13A68B4}.Release.Build.0 = Release|Win32 - {EB1D2ECA-926D-4B6E-BF65-B429C713381C}.Debug.ActiveCfg = Debug|Win32 - {EB1D2ECA-926D-4B6E-BF65-B429C713381C}.Debug.Build.0 = Debug|Win32 - {EB1D2ECA-926D-4B6E-BF65-B429C713381C}.Release.ActiveCfg = Release|Win32 - {EB1D2ECA-926D-4B6E-BF65-B429C713381C}.Release.Build.0 = Release|Win32 - {8A595901-33E6-4959-A8E9-6DACC2D57330}.Debug.ActiveCfg = Debug|Win32 - {8A595901-33E6-4959-A8E9-6DACC2D57330}.Debug.Build.0 = Debug|Win32 - {8A595901-33E6-4959-A8E9-6DACC2D57330}.Release.ActiveCfg = Release|Win32 - {8A595901-33E6-4959-A8E9-6DACC2D57330}.Release.Build.0 = Release|Win32 - {B0F6C137-5153-48E3-ABED-6C02D3912EDA}.Debug.ActiveCfg = Debug|Win32 - {B0F6C137-5153-48E3-ABED-6C02D3912EDA}.Debug.Build.0 = Debug|Win32 - {B0F6C137-5153-48E3-ABED-6C02D3912EDA}.Release.ActiveCfg = Release|Win32 - {B0F6C137-5153-48E3-ABED-6C02D3912EDA}.Release.Build.0 = Release|Win32 - {9551B5E4-94A5-4B04-ACA1-9FB28DFD28AA}.Debug.ActiveCfg = Debug|Win32 - {9551B5E4-94A5-4B04-ACA1-9FB28DFD28AA}.Debug.Build.0 = Debug|Win32 - {9551B5E4-94A5-4B04-ACA1-9FB28DFD28AA}.Release.ActiveCfg = Release|Win32 - {9551B5E4-94A5-4B04-ACA1-9FB28DFD28AA}.Release.Build.0 = Release|Win32 - EndGlobalSection - GlobalSection(ExtensibilityGlobals) = postSolution - EndGlobalSection - GlobalSection(ExtensibilityAddIns) = postSolution - EndGlobalSection -EndGlobal diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc71/gc.vcproj ecl-16.1.3+ds/src/bdwgc/windows-untested/vc71/gc.vcproj --- ecl-16.1.2/src/bdwgc/windows-untested/vc71/gc.vcproj 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc71/gc.vcproj 1970-01-01 00:00:00.000000000 +0000 @@ -1,869 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc71/libgcmt.vcproj ecl-16.1.3+ds/src/bdwgc/windows-untested/vc71/libgcmt.vcproj --- ecl-16.1.2/src/bdwgc/windows-untested/vc71/libgcmt.vcproj 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc71/libgcmt.vcproj 1970-01-01 00:00:00.000000000 +0000 @@ -1,743 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc71/libgc.vcproj ecl-16.1.3+ds/src/bdwgc/windows-untested/vc71/libgc.vcproj --- ecl-16.1.2/src/bdwgc/windows-untested/vc71/libgc.vcproj 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc71/libgc.vcproj 1970-01-01 00:00:00.000000000 +0000 @@ -1,776 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc71/test_gc.vcproj ecl-16.1.3+ds/src/bdwgc/windows-untested/vc71/test_gc.vcproj --- ecl-16.1.2/src/bdwgc/windows-untested/vc71/test_gc.vcproj 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc71/test_gc.vcproj 1970-01-01 00:00:00.000000000 +0000 @@ -1,161 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc71/test_leak_gc.vcproj ecl-16.1.3+ds/src/bdwgc/windows-untested/vc71/test_leak_gc.vcproj --- ecl-16.1.2/src/bdwgc/windows-untested/vc71/test_leak_gc.vcproj 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc71/test_leak_gc.vcproj 1970-01-01 00:00:00.000000000 +0000 @@ -1,161 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc71/test_leak_libgcmt.vcproj ecl-16.1.3+ds/src/bdwgc/windows-untested/vc71/test_leak_libgcmt.vcproj --- ecl-16.1.2/src/bdwgc/windows-untested/vc71/test_leak_libgcmt.vcproj 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc71/test_leak_libgcmt.vcproj 1970-01-01 00:00:00.000000000 +0000 @@ -1,161 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc71/test_leak_libgc.vcproj ecl-16.1.3+ds/src/bdwgc/windows-untested/vc71/test_leak_libgc.vcproj --- ecl-16.1.2/src/bdwgc/windows-untested/vc71/test_leak_libgc.vcproj 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc71/test_leak_libgc.vcproj 1970-01-01 00:00:00.000000000 +0000 @@ -1,161 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc71/test_libgcmt.vcproj ecl-16.1.3+ds/src/bdwgc/windows-untested/vc71/test_libgcmt.vcproj --- ecl-16.1.2/src/bdwgc/windows-untested/vc71/test_libgcmt.vcproj 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc71/test_libgcmt.vcproj 1970-01-01 00:00:00.000000000 +0000 @@ -1,161 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc71/test_libgc.vcproj ecl-16.1.3+ds/src/bdwgc/windows-untested/vc71/test_libgc.vcproj --- ecl-16.1.2/src/bdwgc/windows-untested/vc71/test_libgc.vcproj 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc71/test_libgc.vcproj 1970-01-01 00:00:00.000000000 +0000 @@ -1,161 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -Nru ecl-16.1.2/src/bdwgc/windows-untested/vc71/test.vcproj ecl-16.1.3+ds/src/bdwgc/windows-untested/vc71/test.vcproj --- ecl-16.1.2/src/bdwgc/windows-untested/vc71/test.vcproj 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/bdwgc/windows-untested/vc71/test.vcproj 1970-01-01 00:00:00.000000000 +0000 @@ -1,57 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - diff -Nru ecl-16.1.2/src/c/alloc_2.d ecl-16.1.3+ds/src/c/alloc_2.d --- ecl-16.1.2/src/c/alloc_2.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/alloc_2.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - alloc_2.c -- Memory allocation based on the Boehmn GC. -*/ -/* - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * alloc_2.c - memory allocation based on the Boehm GC + * + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -41,6 +36,7 @@ extern void (*GC_start_call_back)(void); #endif static void gather_statistics(void); +static void update_bytes_consed(void); static void ecl_mark_env(struct cl_env_struct *env); /* We need these prototypes because private/gc.h is not available @@ -74,25 +70,25 @@ void _ecl_set_max_heap_size(size_t new_size) { - const cl_env_ptr the_env = ecl_process_env(); - ecl_disable_interrupts_env(the_env); - GC_set_max_heap_size(cl_core.max_heap_size = new_size); - if (new_size == 0) { - cl_index size = ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA]; - cl_core.safety_region = ecl_alloc_atomic_unprotected(size); - } else if (cl_core.safety_region) { - GC_FREE(cl_core.safety_region); - cl_core.safety_region = 0; - } - ecl_enable_interrupts_env(the_env); + const cl_env_ptr the_env = ecl_process_env(); + ecl_disable_interrupts_env(the_env); + GC_set_max_heap_size(cl_core.max_heap_size = new_size); + if (new_size == 0) { + cl_index size = ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA]; + cl_core.safety_region = ecl_alloc_atomic_unprotected(size); + } else if (cl_core.safety_region) { + GC_FREE(cl_core.safety_region); + cl_core.safety_region = 0; + } + ecl_enable_interrupts_env(the_env); } static int failure; static void * out_of_memory_check(size_t requested_bytes) { - failure = 1; - return 0; + failure = 1; + return 0; } static void @@ -103,81 +99,81 @@ static void * out_of_memory(size_t requested_bytes) { - const cl_env_ptr the_env = ecl_process_env(); - int interrupts = the_env->disable_interrupts; - int method = 0; - void *output; - if (!interrupts) - ecl_disable_interrupts_env(the_env); - /* Free the input / output buffers */ - the_env->string_pool = ECL_NIL; + const cl_env_ptr the_env = ecl_process_env(); + int interrupts = the_env->disable_interrupts; + int method = 0; + void *output; + if (!interrupts) + ecl_disable_interrupts_env(the_env); + /* Free the input / output buffers */ + the_env->string_pool = ECL_NIL; - /* The out of memory condition may happen in more than one thread */ - /* But then we have to ensure the error has not been solved */ + /* The out of memory condition may happen in more than one thread */ + /* But then we have to ensure the error has not been solved */ #ifdef ECL_THREADS - mp_get_lock_wait(cl_core.error_lock); - ECL_UNWIND_PROTECT_BEGIN(the_env) + mp_get_lock_wait(cl_core.error_lock); + ECL_UNWIND_PROTECT_BEGIN(the_env) #endif -{ - failure = 0; - GC_gcollect(); - GC_set_oom_fn(out_of_memory_check); - { - output = GC_MALLOC(requested_bytes); - GC_set_oom_fn(out_of_memory); - if (output != 0 && failure == 0) { - method = 2; - goto OUTPUT; - } - } - if (cl_core.max_heap_size == 0) { - /* We did not set any limit in the amount of memory, - * yet we failed, or we had some limits but we have - * not reached them. */ - if (cl_core.safety_region) { - /* We can free some memory and try handling the error */ - GC_FREE(cl_core.safety_region); - the_env->string_pool = ECL_NIL; - cl_core.safety_region = 0; - method = 0; - } else { - /* No possibility of continuing */ - method = 2; - } - } else { - cl_core.max_heap_size += ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA]; - GC_set_max_heap_size(cl_core.max_heap_size); - method = 1; - } - OUTPUT: - (void)0; -} + { + failure = 0; + GC_gcollect(); + GC_set_oom_fn(out_of_memory_check); + { + output = GC_MALLOC(requested_bytes); + GC_set_oom_fn(out_of_memory); + if (output != 0 && failure == 0) { + method = 2; + goto OUTPUT; + } + } + if (cl_core.max_heap_size == 0) { + /* We did not set any limit in the amount of memory, + * yet we failed, or we had some limits but we have + * not reached them. */ + if (cl_core.safety_region) { + /* We can free some memory and try handling the error */ + GC_FREE(cl_core.safety_region); + the_env->string_pool = ECL_NIL; + cl_core.safety_region = 0; + method = 0; + } else { + /* No possibility of continuing */ + method = 2; + } + } else { + cl_core.max_heap_size += ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA]; + GC_set_max_heap_size(cl_core.max_heap_size); + method = 1; + } + OUTPUT: + (void)0; + } #ifdef ECL_THREADS - ECL_UNWIND_PROTECT_EXIT { - mp_giveup_lock(cl_core.error_lock); - ecl_enable_interrupts_env(the_env); - } ECL_UNWIND_PROTECT_END; + ECL_UNWIND_PROTECT_EXIT { + mp_giveup_lock(cl_core.error_lock); + ecl_enable_interrupts_env(the_env); + } ECL_UNWIND_PROTECT_END; #else - ecl_enable_interrupts_env(the_env); + ecl_enable_interrupts_env(the_env); #endif - switch (method) { - case 0: cl_error(1, @'ext::storage-exhausted'); - break; - case 1: cl_cerror(2, make_constant_base_string("Extend heap size"), - @'ext::storage-exhausted'); - break; - case 2: - return output; - default: - ecl_internal_error("Memory exhausted, quitting program."); - break; - } - if (!interrupts) - ecl_disable_interrupts_env(the_env); - GC_set_max_heap_size(cl_core.max_heap_size += - cl_core.max_heap_size / 2); - /* Default allocation. Note that we do not allocate atomic. */ - return GC_MALLOC(requested_bytes); + switch (method) { + case 0: cl_error(1, @'ext::storage-exhausted'); + break; + case 1: cl_cerror(2, make_constant_base_string("Extend heap size"), + @'ext::storage-exhausted'); + break; + case 2: + return output; + default: + ecl_internal_error("Memory exhausted, quitting program."); + break; + } + if (!interrupts) + ecl_disable_interrupts_env(the_env); + GC_set_max_heap_size(cl_core.max_heap_size += + cl_core.max_heap_size / 2); + /* Default allocation. Note that we do not allocate atomic. */ + return GC_MALLOC(requested_bytes); } #ifdef alloc_object @@ -185,67 +181,67 @@ #endif static struct ecl_type_information { - size_t size; + size_t size; #ifdef GBC_BOEHM_PRECISE - GC_word descriptor; + GC_word descriptor; #endif - cl_object (*allocator)(register struct ecl_type_information *); - size_t t; + cl_object (*allocator)(register struct ecl_type_information *); + size_t t; } type_info[t_end]; static void error_wrong_tag(cl_type t) { - ecl_internal_error("Collector called with invalid tag number."); + ecl_internal_error("Collector called with invalid tag number."); } cl_index ecl_object_byte_size(cl_type t) { - if (t == t_fixnum || t == t_character) - FEerror("ecl_object_byte_size invoked with an immediate type ~D", - 1, ecl_make_fixnum(1)); - if (t >= t_end) - FEerror("ecl_object_byte_size invoked with an unknown type ~D", - 1, ecl_make_fixnum(1)); - return type_info[t].size; + if (t == t_fixnum || t == t_character) + FEerror("ecl_object_byte_size invoked with an immediate type ~D", + 1, ecl_make_fixnum(1)); + if (t >= t_end) + FEerror("ecl_object_byte_size invoked with an unknown type ~D", + 1, ecl_make_fixnum(1)); + return type_info[t].size; } static cl_object allocate_object_atomic(register struct ecl_type_information *type_info) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object op; - ecl_disable_interrupts_env(the_env); - op = GC_MALLOC_ATOMIC(type_info->size); - op->d.t = type_info->t; - ecl_enable_interrupts_env(the_env); - return op; + const cl_env_ptr the_env = ecl_process_env(); + cl_object op; + ecl_disable_interrupts_env(the_env); + op = GC_MALLOC_ATOMIC(type_info->size); + op->d.t = type_info->t; + ecl_enable_interrupts_env(the_env); + return op; } static cl_object allocate_object_full(register struct ecl_type_information *type_info) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object op; - ecl_disable_interrupts_env(the_env); - op = GC_MALLOC(type_info->size); - op->d.t = type_info->t; - ecl_enable_interrupts_env(the_env); - return op; + const cl_env_ptr the_env = ecl_process_env(); + cl_object op; + ecl_disable_interrupts_env(the_env); + op = GC_MALLOC(type_info->size); + op->d.t = type_info->t; + ecl_enable_interrupts_env(the_env); + return op; } #ifdef GBC_BOEHM_PRECISE static cl_object allocate_object_typed(register struct ecl_type_information *type_info) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object op; - ecl_disable_interrupts_env(the_env); - op = GC_malloc_explicitly_typed(type_info->size, type_info->descriptor); - op->d.t = type_info->t; - ecl_enable_interrupts_env(the_env); - return op; + const cl_env_ptr the_env = ecl_process_env(); + cl_object op; + ecl_disable_interrupts_env(the_env); + op = GC_malloc_explicitly_typed(type_info->size, type_info->descriptor); + op->d.t = type_info->t; + ecl_enable_interrupts_env(the_env); + return op; } #endif @@ -256,280 +252,280 @@ { #define TYPD_EXTRA_BYTES (sizeof(word) - EXTRA_BYTES) #define GENERAL_MALLOC(lb,k) (void *)GC_generic_malloc(lb, k) - const cl_env_ptr the_env = ecl_process_env(); - typedef void *ptr_t; - ptr_t op; - ptr_t * opp; - size_t lg, lb; - DCL_LOCK_STATE; - - ecl_disable_interrupts_env(the_env); - lb = type_info->size + TYPD_EXTRA_BYTES; - if (ecl_likely(SMALL_OBJ(lb))) { - lg = GC_size_map[lb]; - opp = &(cl_object_free_list[lg]); - LOCK(); - if( (op = *opp) == 0 ) { - UNLOCK(); - op = (ptr_t)GENERAL_MALLOC((word)lb, cl_object_kind); - if (0 == op) return 0; - lg = GC_size_map[lb]; /* May have been uninitialized. */ - } else { - *opp = obj_link(op); - obj_link(op) = 0; - GC_bytes_allocd += GRANULES_TO_BYTES(lg); - UNLOCK(); - } - } else { - op = (ptr_t)GENERAL_MALLOC((word)lb, cl_object_kind); - lg = BYTES_TO_GRANULES(GC_size(op)); - } - ((word *)op)[GRANULES_TO_WORDS(lg) - 1] = type_info->descriptor; - ((cl_object)op)->d.t = type_info->t; - ecl_enable_interrupts_env(the_env); - return (cl_object)op; + const cl_env_ptr the_env = ecl_process_env(); + typedef void *ptr_t; + ptr_t op; + ptr_t * opp; + size_t lg, lb; + DCL_LOCK_STATE; + + ecl_disable_interrupts_env(the_env); + lb = type_info->size + TYPD_EXTRA_BYTES; + if (ecl_likely(SMALL_OBJ(lb))) { + lg = GC_size_map[lb]; + opp = &(cl_object_free_list[lg]); + LOCK(); + if( (op = *opp) == 0 ) { + UNLOCK(); + op = (ptr_t)GENERAL_MALLOC((word)lb, cl_object_kind); + if (0 == op) return 0; + lg = GC_size_map[lb]; /* May have been uninitialized. */ + } else { + *opp = obj_link(op); + obj_link(op) = 0; + GC_bytes_allocd += GRANULES_TO_BYTES(lg); + UNLOCK(); + } + } else { + op = (ptr_t)GENERAL_MALLOC((word)lb, cl_object_kind); + lg = BYTES_TO_GRANULES(GC_size(op)); + } + ((word *)op)[GRANULES_TO_WORDS(lg) - 1] = type_info->descriptor; + ((cl_object)op)->d.t = type_info->t; + ecl_enable_interrupts_env(the_env); + return (cl_object)op; } #endif /* GBC_BOEHM_OWN_ALLOCATOR */ #ifdef GBC_BOEHM_OWN_MARKER #define IGNORABLE_POINTER(obj) (ECL_IMMEDIATE(obj) & 2) -#define GC_MARK_AND_PUSH(obj, msp, lim, src) \ - ((!IGNORABLE_POINTER(obj) && \ - (GC_word)obj >= (GC_word)GC_least_plausible_heap_addr && \ - (GC_word)obj <= (GC_word)GC_greatest_plausible_heap_addr)? \ - GC_mark_and_push(obj, msp, lim, src) : \ - msp) +#define GC_MARK_AND_PUSH(obj, msp, lim, src) \ + ((!IGNORABLE_POINTER(obj) && \ + (GC_word)obj >= (GC_word)GC_least_plausible_heap_addr && \ + (GC_word)obj <= (GC_word)GC_greatest_plausible_heap_addr)? \ + GC_mark_and_push(obj, msp, lim, src) : \ + msp) static struct GC_ms_entry * cl_object_mark_proc(void *addr, struct GC_ms_entry *msp, struct GC_ms_entry *msl, GC_word env) { #if 1 - cl_type t = ((cl_object)addr)->d.t; - if (ecl_likely(t > t_start && t < t_end)) { - struct ecl_type_information *info = type_info + t; - GC_word d = info->descriptor; - GC_word *p; - for (p = addr; d; p++, d<<=1) { - if ((GC_signed_word)d < 0) { - GC_word aux = *p; - if ((aux & 2) || - aux <= (GC_word)GC_least_plausible_heap_addr || - aux >= (GC_word)GC_greatest_plausible_heap_addr) - continue; - msp = GC_mark_and_push((void*)aux, (void*)msp, - (void*)msl, (void*)p); - } - } - } + cl_type t = ((cl_object)addr)->d.t; + if (ecl_likely(t > t_start && t < t_end)) { + struct ecl_type_information *info = type_info + t; + GC_word d = info->descriptor; + GC_word *p; + for (p = addr; d; p++, d<<=1) { + if ((GC_signed_word)d < 0) { + GC_word aux = *p; + if ((aux & 2) || + aux <= (GC_word)GC_least_plausible_heap_addr || + aux >= (GC_word)GC_greatest_plausible_heap_addr) + continue; + msp = GC_mark_and_push((void*)aux, (void*)msp, + (void*)msl, (void*)p); + } + } + } #else -#define MAYBE_MARK2(ptr) { \ - GC_word aux = (GC_word)(ptr); \ - if (!(aux & 2) && \ - aux >= (GC_word)GC_least_plausible_heap_addr && \ - aux <= (GC_word)GC_greatest_plausible_heap_addr) \ - msp = GC_mark_and_push((void*)aux, msp, msl, (void*)o); \ - } -#define MAYBE_MARK(ptr) { \ - GC_word aux = (GC_word)(ptr); \ - if (!(aux & 2) && \ - aux >= (GC_word)lpa && \ - aux <= (GC_word)gpa) \ - msp = GC_mark_and_push((void*)aux, msp, msl, (void*)o); \ - } - cl_object o = (cl_object)addr; - const GC_word lpa = (GC_word)GC_least_plausible_heap_addr; - const GC_word gpa = (GC_word)GC_greatest_plausible_heap_addr; - switch (o->d.t) { - case t_bignum: - MAYBE_MARK(ECL_BIGNUN_LIMBS(o)); - break; - case t_ratio: - MAYBE_MARK(o->ratio.num); - MAYBE_MARK(o->ratio.den); - break; - case t_complex: - MAYBE_MARK(o->complex.real); - MAYBE_MARK(o->complex.imag); - break; - case t_symbol: - MAYBE_MARK(o->symbol.hpack); - MAYBE_MARK(o->symbol.name); - MAYBE_MARK(o->symbol.plist); - MAYBE_MARK(o->symbol.gfdef); - MAYBE_MARK(o->symbol.value); - break; - case t_package: - MAYBE_MARK(o->pack.external); - MAYBE_MARK(o->pack.internal); - MAYBE_MARK(o->pack.usedby); - MAYBE_MARK(o->pack.uses); - MAYBE_MARK(o->pack.shadowings); - MAYBE_MARK(o->pack.nicknames); - MAYBE_MARK(o->pack.name); - break; - case t_hashtable: - MAYBE_MARK(o->hash.threshold); - MAYBE_MARK(o->hash.rehash_size); - MAYBE_MARK(o->hash.data); - break; - case t_array: - MAYBE_MARK(o->array.dims); - case t_vector: +#define MAYBE_MARK2(ptr) { \ + GC_word aux = (GC_word)(ptr); \ + if (!(aux & 2) && \ + aux >= (GC_word)GC_least_plausible_heap_addr && \ + aux <= (GC_word)GC_greatest_plausible_heap_addr) \ + msp = GC_mark_and_push((void*)aux, msp, msl, (void*)o); \ + } +#define MAYBE_MARK(ptr) { \ + GC_word aux = (GC_word)(ptr); \ + if (!(aux & 2) && \ + aux >= (GC_word)lpa && \ + aux <= (GC_word)gpa) \ + msp = GC_mark_and_push((void*)aux, msp, msl, (void*)o); \ + } + cl_object o = (cl_object)addr; + const GC_word lpa = (GC_word)GC_least_plausible_heap_addr; + const GC_word gpa = (GC_word)GC_greatest_plausible_heap_addr; + switch (o->d.t) { + case t_bignum: + MAYBE_MARK(ECL_BIGNUN_LIMBS(o)); + break; + case t_ratio: + MAYBE_MARK(o->ratio.num); + MAYBE_MARK(o->ratio.den); + break; + case t_complex: + MAYBE_MARK(o->complex.real); + MAYBE_MARK(o->complex.imag); + break; + case t_symbol: + MAYBE_MARK(o->symbol.hpack); + MAYBE_MARK(o->symbol.name); + MAYBE_MARK(o->symbol.plist); + MAYBE_MARK(o->symbol.gfdef); + MAYBE_MARK(o->symbol.value); + break; + case t_package: + MAYBE_MARK(o->pack.external); + MAYBE_MARK(o->pack.internal); + MAYBE_MARK(o->pack.usedby); + MAYBE_MARK(o->pack.uses); + MAYBE_MARK(o->pack.shadowings); + MAYBE_MARK(o->pack.nicknames); + MAYBE_MARK(o->pack.name); + break; + case t_hashtable: + MAYBE_MARK(o->hash.threshold); + MAYBE_MARK(o->hash.rehash_size); + MAYBE_MARK(o->hash.data); + break; + case t_array: + MAYBE_MARK(o->array.dims); + case t_vector: # ifdef ECL_UNICODE - case t_string: + case t_string: # endif - case t_base_string: - case t_bitvector: - MAYBE_MARK(o->vector.self.t); - MAYBE_MARK(o->vector.displaced); - break; - case t_stream: - MAYBE_MARK(o->stream.format_table); - MAYBE_MARK(o->stream.format); - MAYBE_MARK(o->stream.buffer); - MAYBE_MARK(o->stream.byte_stack); - MAYBE_MARK(o->stream.object1); - MAYBE_MARK(o->stream.object0); - MAYBE_MARK(o->stream.ops); - break; - case t_random: - MAYBE_MARK(o->random.value); - break; - case t_readtable: + case t_base_string: + case t_bitvector: + MAYBE_MARK(o->vector.self.t); + MAYBE_MARK(o->vector.displaced); + break; + case t_stream: + MAYBE_MARK(o->stream.format_table); + MAYBE_MARK(o->stream.format); + MAYBE_MARK(o->stream.buffer); + MAYBE_MARK(o->stream.byte_stack); + MAYBE_MARK(o->stream.object1); + MAYBE_MARK(o->stream.object0); + MAYBE_MARK(o->stream.ops); + break; + case t_random: + MAYBE_MARK(o->random.value); + break; + case t_readtable: # ifdef ECL_UNICODE - MAYBE_MARK(o->readtable.hash); + MAYBE_MARK(o->readtable.hash); # endif - MAYBE_MARK(o->readtable.table); - break; - case t_pathname: - MAYBE_MARK(o->pathname.version); - MAYBE_MARK(o->pathname.type); - MAYBE_MARK(o->pathname.name); - MAYBE_MARK(o->pathname.directory); - MAYBE_MARK(o->pathname.device); - MAYBE_MARK(o->pathname.host); - break; - case t_bytecodes: - MAYBE_MARK(o->bytecodes.file_position); - MAYBE_MARK(o->bytecodes.file); - MAYBE_MARK(o->bytecodes.data); - MAYBE_MARK(o->bytecodes.code); - MAYBE_MARK(o->bytecodes.definition); - MAYBE_MARK(o->bytecodes.name); - break; - case t_bclosure: - MAYBE_MARK(o->bclosure.lex); - MAYBE_MARK(o->bclosure.code); - break; - case t_cfun: - MAYBE_MARK(o->cfun.file_position); - MAYBE_MARK(o->cfun.file); - MAYBE_MARK(o->cfun.block); - MAYBE_MARK(o->cfun.name); - break; - case t_cfunfixed: - MAYBE_MARK(o->cfunfixed.file_position); - MAYBE_MARK(o->cfunfixed.file); - MAYBE_MARK(o->cfunfixed.block); - MAYBE_MARK(o->cfunfixed.name); - break; - case t_cclosure: - MAYBE_MARK(o->cclosure.file_position); - MAYBE_MARK(o->cclosure.file); - MAYBE_MARK(o->cclosure.block); - MAYBE_MARK(o->cclosure.env); - break; - case t_instance: - MAYBE_MARK(o->instance.slots); - MAYBE_MARK(o->instance.sig); - MAYBE_MARK(o->instance.clas); - break; + MAYBE_MARK(o->readtable.table); + break; + case t_pathname: + MAYBE_MARK(o->pathname.version); + MAYBE_MARK(o->pathname.type); + MAYBE_MARK(o->pathname.name); + MAYBE_MARK(o->pathname.directory); + MAYBE_MARK(o->pathname.device); + MAYBE_MARK(o->pathname.host); + break; + case t_bytecodes: + MAYBE_MARK(o->bytecodes.file_position); + MAYBE_MARK(o->bytecodes.file); + MAYBE_MARK(o->bytecodes.data); + MAYBE_MARK(o->bytecodes.code); + MAYBE_MARK(o->bytecodes.definition); + MAYBE_MARK(o->bytecodes.name); + break; + case t_bclosure: + MAYBE_MARK(o->bclosure.lex); + MAYBE_MARK(o->bclosure.code); + break; + case t_cfun: + MAYBE_MARK(o->cfun.file_position); + MAYBE_MARK(o->cfun.file); + MAYBE_MARK(o->cfun.block); + MAYBE_MARK(o->cfun.name); + break; + case t_cfunfixed: + MAYBE_MARK(o->cfunfixed.file_position); + MAYBE_MARK(o->cfunfixed.file); + MAYBE_MARK(o->cfunfixed.block); + MAYBE_MARK(o->cfunfixed.name); + break; + case t_cclosure: + MAYBE_MARK(o->cclosure.file_position); + MAYBE_MARK(o->cclosure.file); + MAYBE_MARK(o->cclosure.block); + MAYBE_MARK(o->cclosure.env); + break; + case t_instance: + MAYBE_MARK(o->instance.slots); + MAYBE_MARK(o->instance.sig); + MAYBE_MARK(o->instance.clas); + break; # ifdef ECL_THREADS - case t_process: - MAYBE_MARK(o->process.queue_record); - MAYBE_MARK(o->process.start_spinlock); - MAYBE_MARK(o->process.woken_up); - MAYBE_MARK(o->process.exit_values); - MAYBE_MARK(o->process.exit_barrier); - MAYBE_MARK(o->process.parent); - MAYBE_MARK(o->process.initial_bindings); - MAYBE_MARK(o->process.interrupt); - MAYBE_MARK(o->process.args); - MAYBE_MARK(o->process.function); - MAYBE_MARK(o->process.name); - if (o->process.env && o->process.env != ECL_NIL) - ecl_mark_env(o->process.env); - break; - case t_lock: - MAYBE_MARK(o->lock.queue_list); - MAYBE_MARK(o->lock.queue_spinlock); - MAYBE_MARK(o->lock.owner); - MAYBE_MARK(o->lock.name); - break; - case t_condition_variable: - MAYBE_MARK(o->condition_variable.queue_spinlock); - MAYBE_MARK(o->condition_variable.queue_list); - MAYBE_MARK(o->condition_variable.lock); - break; - case t_rwlock: - MAYBE_MARK(o->rwlock.name); + case t_process: + MAYBE_MARK(o->process.queue_record); + MAYBE_MARK(o->process.start_spinlock); + MAYBE_MARK(o->process.woken_up); + MAYBE_MARK(o->process.exit_values); + MAYBE_MARK(o->process.exit_barrier); + MAYBE_MARK(o->process.parent); + MAYBE_MARK(o->process.initial_bindings); + MAYBE_MARK(o->process.interrupt); + MAYBE_MARK(o->process.args); + MAYBE_MARK(o->process.function); + MAYBE_MARK(o->process.name); + if (o->process.env && o->process.env != ECL_NIL) + ecl_mark_env(o->process.env); + break; + case t_lock: + MAYBE_MARK(o->lock.queue_list); + MAYBE_MARK(o->lock.queue_spinlock); + MAYBE_MARK(o->lock.owner); + MAYBE_MARK(o->lock.name); + break; + case t_condition_variable: + MAYBE_MARK(o->condition_variable.queue_spinlock); + MAYBE_MARK(o->condition_variable.queue_list); + MAYBE_MARK(o->condition_variable.lock); + break; + case t_rwlock: + MAYBE_MARK(o->rwlock.name); # ifndef ECL_RWLOCK - MAYBE_MARK(o->rwlock.mutex); - break; + MAYBE_MARK(o->rwlock.mutex); + break; # endif - case t_semaphore: - MAYBE_MARK(o->semaphore.queue_list); - MAYBE_MARK(o->semaphore.queue_spinlock); - MAYBE_MARK(o->semaphore.name); - break; - case t_barrier: - MAYBE_MARK(o->barrier.queue_list); - MAYBE_MARK(o->barrier.queue_spinlock); - MAYBE_MARK(o->barrier.name); - break; - case t_mailbox: - MAYBE_MARK(o->mailbox.data); - MAYBE_MARK(o->mailbox.name); - MAYBE_MARK(o->mailbox.reader_semaphore); - MAYBE_MARK(o->mailbox.writer_semaphore); - break; + case t_semaphore: + MAYBE_MARK(o->semaphore.queue_list); + MAYBE_MARK(o->semaphore.queue_spinlock); + MAYBE_MARK(o->semaphore.name); + break; + case t_barrier: + MAYBE_MARK(o->barrier.queue_list); + MAYBE_MARK(o->barrier.queue_spinlock); + MAYBE_MARK(o->barrier.name); + break; + case t_mailbox: + MAYBE_MARK(o->mailbox.data); + MAYBE_MARK(o->mailbox.name); + MAYBE_MARK(o->mailbox.reader_semaphore); + MAYBE_MARK(o->mailbox.writer_semaphore); + break; # endif - case t_codeblock: - MAYBE_MARK(o->cblock.error); - MAYBE_MARK(o->cblock.source); - MAYBE_MARK(o->cblock.links); - MAYBE_MARK(o->cblock.name); - MAYBE_MARK(o->cblock.next); - MAYBE_MARK(o->cblock.temp_data); - MAYBE_MARK(o->cblock.data); - break; - case t_foreign: - MAYBE_MARK(o->foreign.tag); - MAYBE_MARK(o->foreign.data); - break; - case t_frame: - MAYBE_MARK(o->frame.env); - MAYBE_MARK(o->frame.base); - MAYBE_MARK(o->frame.stack); - break; - default: - break; - } + case t_codeblock: + MAYBE_MARK(o->cblock.error); + MAYBE_MARK(o->cblock.source); + MAYBE_MARK(o->cblock.links); + MAYBE_MARK(o->cblock.name); + MAYBE_MARK(o->cblock.next); + MAYBE_MARK(o->cblock.temp_data); + MAYBE_MARK(o->cblock.data); + break; + case t_foreign: + MAYBE_MARK(o->foreign.tag); + MAYBE_MARK(o->foreign.data); + break; + case t_frame: + MAYBE_MARK(o->frame.env); + MAYBE_MARK(o->frame.base); + MAYBE_MARK(o->frame.stack); + break; + default: + break; + } #endif - return msp; + return msp; } static cl_object allocate_object_marked(register struct ecl_type_information *type_info) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object op; - ecl_disable_interrupts_env(the_env); - op = GC_generic_malloc(type_info->size, cl_object_kind); - op->d.t = type_info->t; - ecl_enable_interrupts_env(the_env); - return op; + const cl_env_ptr the_env = ecl_process_env(); + cl_object op; + ecl_disable_interrupts_env(the_env); + op = GC_generic_malloc(type_info->size, cl_object_kind); + op->d.t = type_info->t; + ecl_enable_interrupts_env(the_env); + return op; } #endif @@ -537,212 +533,212 @@ ecl_alloc_object(cl_type t) { #ifdef GBC_BOEHM_PRECISE - struct ecl_type_information *ti; - if (ecl_likely(t > t_start && t < t_end)) { - ti = type_info + t; - return ti->allocator(ti); - } - error_wrong_tag(t); - return OBJNULL; + struct ecl_type_information *ti; + if (ecl_likely(t > t_start && t < t_end)) { + ti = type_info + t; + return ti->allocator(ti); + } + error_wrong_tag(t); + return OBJNULL; #else - const cl_env_ptr the_env = ecl_process_env(); + const cl_env_ptr the_env = ecl_process_env(); - /* GC_MALLOC already resets objects */ - switch (t) { - case t_fixnum: - return ecl_make_fixnum(0); /* Immediate fixnum */ - case t_character: - return ECL_CODE_CHAR(' '); /* Immediate character */ + /* GC_MALLOC already resets objects */ + switch (t) { + case t_fixnum: + return ecl_make_fixnum(0); /* Immediate fixnum */ + case t_character: + return ECL_CODE_CHAR(' '); /* Immediate character */ #ifdef ECL_SSE2 - case t_sse_pack: + case t_sse_pack: #endif #ifdef ECL_LONG_FLOAT - case t_longfloat: + case t_longfloat: #endif - case t_singlefloat: - case t_doublefloat: { - cl_object obj; - ecl_disable_interrupts_env(the_env); - obj = (cl_object)GC_MALLOC_ATOMIC(type_info[t].size); - ecl_enable_interrupts_env(the_env); - obj->d.t = t; - return obj; - } - case t_bignum: - case t_ratio: - case t_complex: - case t_symbol: - case t_package: - case t_hashtable: - case t_array: - case t_vector: - case t_base_string: + case t_singlefloat: + case t_doublefloat: { + cl_object obj; + ecl_disable_interrupts_env(the_env); + obj = (cl_object)GC_MALLOC_ATOMIC(type_info[t].size); + ecl_enable_interrupts_env(the_env); + obj->d.t = t; + return obj; + } + case t_bignum: + case t_ratio: + case t_complex: + case t_symbol: + case t_package: + case t_hashtable: + case t_array: + case t_vector: + case t_base_string: #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_bitvector: - case t_stream: - case t_random: - case t_readtable: - case t_pathname: - case t_bytecodes: - case t_bclosure: - case t_cfun: - case t_cfunfixed: - case t_cclosure: - case t_instance: + case t_bitvector: + case t_stream: + case t_random: + case t_readtable: + case t_pathname: + case t_bytecodes: + case t_bclosure: + case t_cfun: + case t_cfunfixed: + case t_cclosure: + case t_instance: #ifdef ECL_THREADS - case t_process: - case t_lock: - case t_rwlock: - case t_condition_variable: - case t_semaphore: - case t_barrier: - case t_mailbox: -#endif - case t_foreign: - case t_codeblock: { - cl_object obj; - ecl_disable_interrupts_env(the_env); - obj = (cl_object)GC_MALLOC(type_info[t].size); - ecl_enable_interrupts_env(the_env); - obj->d.t = t; - return obj; - } - default: - printf("\ttype = %d\n", t); - ecl_internal_error("alloc botch."); - } + case t_process: + case t_lock: + case t_rwlock: + case t_condition_variable: + case t_semaphore: + case t_barrier: + case t_mailbox: +#endif + case t_foreign: + case t_codeblock: { + cl_object obj; + ecl_disable_interrupts_env(the_env); + obj = (cl_object)GC_MALLOC(type_info[t].size); + ecl_enable_interrupts_env(the_env); + obj->d.t = t; + return obj; + } + default: + printf("\ttype = %d\n", t); + ecl_internal_error("alloc botch."); + } #endif } cl_object ecl_alloc_compact_object(cl_type t, cl_index extra_space) { - const cl_env_ptr the_env = ecl_process_env(); - cl_index size = type_info[t].size; - cl_object x; - ecl_disable_interrupts_env(the_env); - x = (cl_object)GC_MALLOC_ATOMIC(size + extra_space); - ecl_enable_interrupts_env(the_env); - x->array.t = t; - x->array.displaced = (void*)(((char*)x) + size); - return x; + const cl_env_ptr the_env = ecl_process_env(); + cl_index size = type_info[t].size; + cl_object x; + ecl_disable_interrupts_env(the_env); + x = (cl_object)GC_MALLOC_ATOMIC(size + extra_space); + ecl_enable_interrupts_env(the_env); + x->array.t = t; + x->array.displaced = (void*)(((char*)x) + size); + return x; } cl_object ecl_cons(cl_object a, cl_object d) { - const cl_env_ptr the_env = ecl_process_env(); - struct ecl_cons *obj; - ecl_disable_interrupts_env(the_env); - obj = GC_MALLOC(sizeof(struct ecl_cons)); - ecl_enable_interrupts_env(the_env); + const cl_env_ptr the_env = ecl_process_env(); + struct ecl_cons *obj; + ecl_disable_interrupts_env(the_env); + obj = GC_MALLOC(sizeof(struct ecl_cons)); + ecl_enable_interrupts_env(the_env); #ifdef ECL_SMALL_CONS - obj->car = a; - obj->cdr = d; - return ECL_PTR_CONS(obj); + obj->car = a; + obj->cdr = d; + return ECL_PTR_CONS(obj); #else - obj->t = t_list; - obj->car = a; - obj->cdr = d; - return (cl_object)obj; + obj->t = t_list; + obj->car = a; + obj->cdr = d; + return (cl_object)obj; #endif } cl_object ecl_list1(cl_object a) { - const cl_env_ptr the_env = ecl_process_env(); - struct ecl_cons *obj; - ecl_disable_interrupts_env(the_env); - obj = GC_MALLOC(sizeof(struct ecl_cons)); - ecl_enable_interrupts_env(the_env); + const cl_env_ptr the_env = ecl_process_env(); + struct ecl_cons *obj; + ecl_disable_interrupts_env(the_env); + obj = GC_MALLOC(sizeof(struct ecl_cons)); + ecl_enable_interrupts_env(the_env); #ifdef ECL_SMALL_CONS - obj->car = a; - obj->cdr = ECL_NIL; - return ECL_PTR_CONS(obj); + obj->car = a; + obj->cdr = ECL_NIL; + return ECL_PTR_CONS(obj); #else - obj->t = t_list; - obj->car = a; - obj->cdr = ECL_NIL; - return (cl_object)obj; + obj->t = t_list; + obj->car = a; + obj->cdr = ECL_NIL; + return (cl_object)obj; #endif } cl_object ecl_alloc_instance(cl_index slots) { - cl_object i; - i = ecl_alloc_object(t_instance); - i->instance.slots = (cl_object *)ecl_alloc(sizeof(cl_object) * slots); - i->instance.length = slots; - i->instance.entry = FEnot_funcallable_vararg; - i->instance.sig = ECL_UNBOUND; - return i; + cl_object i; + i = ecl_alloc_object(t_instance); + i->instance.slots = (cl_object *)ecl_alloc(sizeof(cl_object) * slots); + i->instance.length = slots; + i->instance.entry = FEnot_funcallable_vararg; + i->instance.sig = ECL_UNBOUND; + return i; } void * ecl_alloc_uncollectable(size_t size) { - const cl_env_ptr the_env = ecl_process_env(); - void *output; - ecl_disable_interrupts_env(the_env); - output = GC_MALLOC_UNCOLLECTABLE(size); - ecl_enable_interrupts_env(the_env); - return output; + const cl_env_ptr the_env = ecl_process_env(); + void *output; + ecl_disable_interrupts_env(the_env); + output = GC_MALLOC_UNCOLLECTABLE(size); + ecl_enable_interrupts_env(the_env); + return output; } void ecl_free_uncollectable(void *pointer) { - const cl_env_ptr the_env = ecl_process_env(); - ecl_disable_interrupts_env(the_env); - GC_FREE(pointer); - ecl_enable_interrupts_env(the_env); + const cl_env_ptr the_env = ecl_process_env(); + ecl_disable_interrupts_env(the_env); + GC_FREE(pointer); + ecl_enable_interrupts_env(the_env); } void * ecl_alloc_unprotected(cl_index n) { - return GC_MALLOC_IGNORE_OFF_PAGE(n); + return GC_MALLOC_IGNORE_OFF_PAGE(n); } void * ecl_alloc_atomic_unprotected(cl_index n) { - return GC_MALLOC_ATOMIC_IGNORE_OFF_PAGE(n); + return GC_MALLOC_ATOMIC_IGNORE_OFF_PAGE(n); } void * ecl_alloc(cl_index n) { - const cl_env_ptr the_env = ecl_process_env(); - void *output; - ecl_disable_interrupts_env(the_env); - output = ecl_alloc_unprotected(n); - ecl_enable_interrupts_env(the_env); - return output; + const cl_env_ptr the_env = ecl_process_env(); + void *output; + ecl_disable_interrupts_env(the_env); + output = ecl_alloc_unprotected(n); + ecl_enable_interrupts_env(the_env); + return output; } void * ecl_alloc_atomic(cl_index n) { - const cl_env_ptr the_env = ecl_process_env(); - void *output; - ecl_disable_interrupts_env(the_env); - output = ecl_alloc_atomic_unprotected(n); - ecl_enable_interrupts_env(the_env); - return output; + const cl_env_ptr the_env = ecl_process_env(); + void *output; + ecl_disable_interrupts_env(the_env); + output = ecl_alloc_atomic_unprotected(n); + ecl_enable_interrupts_env(the_env); + return output; } void ecl_dealloc(void *ptr) { - const cl_env_ptr the_env = ecl_process_env(); - ecl_disable_interrupts_env(the_env); - GC_FREE(ptr); - ecl_enable_interrupts_env(the_env); + const cl_env_ptr the_env = ecl_process_env(); + ecl_disable_interrupts_env(the_env); + GC_FREE(ptr); + ecl_enable_interrupts_env(the_env); } static int alloc_initialized = FALSE; @@ -754,340 +750,340 @@ static cl_index to_bitmap(void *x, void *y) { - cl_index n = (char*)y - (char*)x; - if (n % sizeof(void*)) - ecl_internal_error("Misaligned pointer in ECL structure."); - n /= sizeof(void*); - return 1 << n; + cl_index n = (char*)y - (char*)x; + if (n % sizeof(void*)) + ecl_internal_error("Misaligned pointer in ECL structure."); + n /= sizeof(void*); + return 1 << n; } void init_alloc(void) { - union cl_lispunion o; - struct ecl_cons c; - int i; - if (alloc_initialized) return; - alloc_initialized = TRUE; - /* - * Garbage collector restrictions: we set up the garbage collector - * library to work as follows - * - * 1) The garbage collector shall not scan shared libraries - * explicitely. - * 2) We only detect objects that are referenced by a pointer to - * the begining or to the first byte. - * 3) Out of the incremental garbage collector, we only use the - * generational component. - */ - GC_set_no_dls(1); - GC_set_all_interior_pointers(0); - GC_set_time_limit(GC_TIME_UNLIMITED); - GC_init(); + union cl_lispunion o; + struct ecl_cons c; + int i; + if (alloc_initialized) return; + alloc_initialized = TRUE; + /* + * Garbage collector restrictions: we set up the garbage collector + * library to work as follows + * + * 1) The garbage collector shall not scan shared libraries + * explicitely. + * 2) We only detect objects that are referenced by a pointer to + * the begining or to the first byte. + * 3) Out of the incremental garbage collector, we only use the + * generational component. + */ + GC_set_no_dls(1); + GC_set_all_interior_pointers(0); + GC_set_time_limit(GC_TIME_UNLIMITED); + GC_init(); #ifdef ECL_THREADS # if GC_VERSION_MAJOR > 7 || GC_VERSION_MINOR > 1 - GC_allow_register_threads(); + GC_allow_register_threads(); # endif #endif - if (ecl_option_values[ECL_OPT_INCREMENTAL_GC]) { - GC_enable_incremental(); - } - GC_register_displacement(1); + if (ecl_option_values[ECL_OPT_INCREMENTAL_GC]) { + GC_enable_incremental(); + } + GC_register_displacement(1); #ifdef GBC_BOEHM_PRECISE - GC_init_explicit_typing(); + GC_init_explicit_typing(); #endif - GC_clear_roots(); - GC_disable(); + GC_clear_roots(); + GC_disable(); #ifdef GBC_BOEHM_PRECISE # ifdef GBC_BOEHM_OWN_ALLOCATOR - cl_object_free_list = (void **)GC_new_free_list_inner(); - cl_object_kind = GC_new_kind_inner(cl_object_free_list, - (((word)WORDS_TO_BYTES(-1)) | GC_DS_PER_OBJECT), - TRUE, TRUE); + cl_object_free_list = (void **)GC_new_free_list_inner(); + cl_object_kind = GC_new_kind_inner(cl_object_free_list, + (((word)WORDS_TO_BYTES(-1)) | GC_DS_PER_OBJECT), + TRUE, TRUE); # else # ifdef GBC_BOEHM_OWN_MARKER - cl_object_free_list = (void **)GC_new_free_list_inner(); - cl_object_mark_proc_index = GC_new_proc((GC_mark_proc)cl_object_mark_proc); - cl_object_kind = GC_new_kind_inner(cl_object_free_list, - GC_MAKE_PROC(cl_object_mark_proc_index, 0), - FALSE, TRUE); + cl_object_free_list = (void **)GC_new_free_list_inner(); + cl_object_mark_proc_index = GC_new_proc((GC_mark_proc)cl_object_mark_proc); + cl_object_kind = GC_new_kind_inner(cl_object_free_list, + GC_MAKE_PROC(cl_object_mark_proc_index, 0), + FALSE, TRUE); # endif # endif #endif /* !GBC_BOEHM_PRECISE */ - GC_set_max_heap_size(cl_core.max_heap_size = ecl_option_values[ECL_OPT_HEAP_SIZE]); - /* Save some memory for the case we get tight. */ - if (cl_core.max_heap_size == 0) { - cl_index size = ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA]; - cl_core.safety_region = ecl_alloc_atomic_unprotected(size); - } else if (cl_core.safety_region) { - cl_core.safety_region = 0; - } + GC_set_max_heap_size(cl_core.max_heap_size = ecl_option_values[ECL_OPT_HEAP_SIZE]); + /* Save some memory for the case we get tight. */ + if (cl_core.max_heap_size == 0) { + cl_index size = ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA]; + cl_core.safety_region = ecl_alloc_atomic_unprotected(size); + } else if (cl_core.safety_region) { + cl_core.safety_region = 0; + } #define init_tm(x,y,z,w) { \ - type_info[x].size = (z); \ - if ((w) == 0) { type_info[x].allocator = allocate_object_atomic; } } - for (i = 0; i < t_end; i++) { - type_info[i].t = i; - type_info[i].size = 0; - type_info[i].allocator = allocate_object_full; - } - init_tm(t_list, "CONS", sizeof(struct ecl_cons), 2); - init_tm(t_bignum, "BIGNUM", sizeof(struct ecl_bignum), 2); - init_tm(t_ratio, "RATIO", sizeof(struct ecl_ratio), 2); - init_tm(t_singlefloat, "SINGLE-FLOAT", sizeof(struct ecl_singlefloat), 0); - init_tm(t_doublefloat, "DOUBLE-FLOAT", sizeof(struct ecl_doublefloat), 0); + type_info[x].size = (z); \ + if ((w) == 0) { type_info[x].allocator = allocate_object_atomic; } } + for (i = 0; i < t_end; i++) { + type_info[i].t = i; + type_info[i].size = 0; + type_info[i].allocator = allocate_object_full; + } + init_tm(t_list, "CONS", sizeof(struct ecl_cons), 2); + init_tm(t_bignum, "BIGNUM", sizeof(struct ecl_bignum), 2); + init_tm(t_ratio, "RATIO", sizeof(struct ecl_ratio), 2); + init_tm(t_singlefloat, "SINGLE-FLOAT", sizeof(struct ecl_singlefloat), 0); + init_tm(t_doublefloat, "DOUBLE-FLOAT", sizeof(struct ecl_doublefloat), 0); #ifdef ECL_LONG_FLOAT - init_tm(t_longfloat, "LONG-FLOAT", sizeof(struct ecl_long_float), 0); + init_tm(t_longfloat, "LONG-FLOAT", sizeof(struct ecl_long_float), 0); #endif - init_tm(t_complex, "COMPLEX", sizeof(struct ecl_complex), 2); - init_tm(t_symbol, "SYMBOL", sizeof(struct ecl_symbol), 5); - init_tm(t_package, "PACKAGE", sizeof(struct ecl_package), -1); /* 36 */ + init_tm(t_complex, "COMPLEX", sizeof(struct ecl_complex), 2); + init_tm(t_symbol, "SYMBOL", sizeof(struct ecl_symbol), 5); + init_tm(t_package, "PACKAGE", sizeof(struct ecl_package), -1); /* 36 */ #ifdef ECL_THREADS - init_tm(t_hashtable, "HASH-TABLE", sizeof(struct ecl_hashtable), 3); + init_tm(t_hashtable, "HASH-TABLE", sizeof(struct ecl_hashtable), 3); #else - init_tm(t_hashtable, "HASH-TABLE", sizeof(struct ecl_hashtable), 4); + init_tm(t_hashtable, "HASH-TABLE", sizeof(struct ecl_hashtable), 4); #endif - init_tm(t_array, "ARRAY", sizeof(struct ecl_array), 3); - init_tm(t_vector, "VECTOR", sizeof(struct ecl_vector), 2); + init_tm(t_array, "ARRAY", sizeof(struct ecl_array), 3); + init_tm(t_vector, "VECTOR", sizeof(struct ecl_vector), 2); #ifdef ECL_UNICODE - init_tm(t_string, "STRING", sizeof(struct ecl_string), 2); + init_tm(t_string, "STRING", sizeof(struct ecl_string), 2); #endif - init_tm(t_base_string, "BASE-STRING", sizeof(struct ecl_base_string), 2); - init_tm(t_bitvector, "BIT-VECTOR", sizeof(struct ecl_vector), 2); - init_tm(t_stream, "STREAM", sizeof(struct ecl_stream), 6); - init_tm(t_random, "RANDOM-STATE", sizeof(struct ecl_random), -1); - init_tm(t_readtable, "READTABLE", sizeof(struct ecl_readtable), 2); - init_tm(t_pathname, "PATHNAME", sizeof(struct ecl_pathname), -1); - init_tm(t_bytecodes, "BYTECODES", sizeof(struct ecl_bytecodes), -1); - init_tm(t_bclosure, "BCLOSURE", sizeof(struct ecl_bclosure), 3); - init_tm(t_cfun, "CFUN", sizeof(struct ecl_cfun), -1); - init_tm(t_cfunfixed, "CFUNFIXED", sizeof(struct ecl_cfunfixed), -1); - init_tm(t_cclosure, "CCLOSURE", sizeof(struct ecl_cclosure), -1); - init_tm(t_instance, "INSTANCE", sizeof(struct ecl_instance), 4); + init_tm(t_base_string, "BASE-STRING", sizeof(struct ecl_base_string), 2); + init_tm(t_bitvector, "BIT-VECTOR", sizeof(struct ecl_vector), 2); + init_tm(t_stream, "STREAM", sizeof(struct ecl_stream), 6); + init_tm(t_random, "RANDOM-STATE", sizeof(struct ecl_random), -1); + init_tm(t_readtable, "READTABLE", sizeof(struct ecl_readtable), 2); + init_tm(t_pathname, "PATHNAME", sizeof(struct ecl_pathname), -1); + init_tm(t_bytecodes, "BYTECODES", sizeof(struct ecl_bytecodes), -1); + init_tm(t_bclosure, "BCLOSURE", sizeof(struct ecl_bclosure), 3); + init_tm(t_cfun, "CFUN", sizeof(struct ecl_cfun), -1); + init_tm(t_cfunfixed, "CFUNFIXED", sizeof(struct ecl_cfunfixed), -1); + init_tm(t_cclosure, "CCLOSURE", sizeof(struct ecl_cclosure), -1); + init_tm(t_instance, "INSTANCE", sizeof(struct ecl_instance), 4); #ifdef ECL_THREADS - init_tm(t_process, "PROCESS", sizeof(struct ecl_process), 8); - init_tm(t_lock, "LOCK", sizeof(struct ecl_lock), 2); - init_tm(t_rwlock, "LOCK", sizeof(struct ecl_rwlock), 0); - init_tm(t_condition_variable, "CONDITION-VARIABLE", - sizeof(struct ecl_condition_variable), 0); - init_tm(t_semaphore, "SEMAPHORES", sizeof(struct ecl_semaphore), 0); - init_tm(t_barrier, "BARRIER", sizeof(struct ecl_barrier), 0); - init_tm(t_mailbox, "MAILBOX", sizeof(struct ecl_mailbox), 0); -#endif - init_tm(t_codeblock, "CODEBLOCK", sizeof(struct ecl_codeblock), -1); - init_tm(t_foreign, "FOREIGN", sizeof(struct ecl_foreign), 2); - init_tm(t_frame, "STACK-FRAME", sizeof(struct ecl_stack_frame), 2); - init_tm(t_weak_pointer, "WEAK-POINTER", sizeof(struct ecl_weak_pointer), 0); + init_tm(t_process, "PROCESS", sizeof(struct ecl_process), 8); + init_tm(t_lock, "LOCK", sizeof(struct ecl_lock), 2); + init_tm(t_rwlock, "RWLOCK", sizeof(struct ecl_rwlock), 0); + init_tm(t_condition_variable, "CONDITION-VARIABLE", + sizeof(struct ecl_condition_variable), 0); + init_tm(t_semaphore, "SEMAPHORES", sizeof(struct ecl_semaphore), 0); + init_tm(t_barrier, "BARRIER", sizeof(struct ecl_barrier), 0); + init_tm(t_mailbox, "MAILBOX", sizeof(struct ecl_mailbox), 0); +#endif + init_tm(t_codeblock, "CODEBLOCK", sizeof(struct ecl_codeblock), -1); + init_tm(t_foreign, "FOREIGN", sizeof(struct ecl_foreign), 2); + init_tm(t_frame, "STACK-FRAME", sizeof(struct ecl_stack_frame), 2); + init_tm(t_weak_pointer, "WEAK-POINTER", sizeof(struct ecl_weak_pointer), 0); #ifdef ECL_SSE2 - init_tm(t_sse_pack, "SSE-PACK", sizeof(struct ecl_sse_pack), 0); + init_tm(t_sse_pack, "SSE-PACK", sizeof(struct ecl_sse_pack), 0); #endif #ifdef GBC_BOEHM_PRECISE - type_info[t_list].descriptor = - to_bitmap(&c, &(c.car)) | - to_bitmap(&c, &(c.cdr)); - type_info[t_bignum].descriptor = - to_bitmap(&o, &(ECL_BIGNUM_LIMBS(&o))); - type_info[t_ratio].descriptor = - to_bitmap(&o, &(o.ratio.num)) | - to_bitmap(&o, &(o.ratio.den)); - type_info[t_singlefloat].descriptor = 0; - type_info[t_doublefloat].descriptor = 0; + type_info[t_list].descriptor = + to_bitmap(&c, &(c.car)) | + to_bitmap(&c, &(c.cdr)); + type_info[t_bignum].descriptor = + to_bitmap(&o, &(ECL_BIGNUM_LIMBS(&o))); + type_info[t_ratio].descriptor = + to_bitmap(&o, &(o.ratio.num)) | + to_bitmap(&o, &(o.ratio.den)); + type_info[t_singlefloat].descriptor = 0; + type_info[t_doublefloat].descriptor = 0; #ifdef ECL_LONG_FLOAT - type_info[t_longfloat].descriptor = 0; + type_info[t_longfloat].descriptor = 0; #endif - type_info[t_complex].descriptor = - to_bitmap(&o, &(o.complex.real)) | - to_bitmap(&o, &(o.complex.imag)); - type_info[t_symbol].descriptor = - to_bitmap(&o, &(o.symbol.value)) | - to_bitmap(&o, &(o.symbol.gfdef)) | - to_bitmap(&o, &(o.symbol.plist)) | - to_bitmap(&o, &(o.symbol.name)) | - to_bitmap(&o, &(o.symbol.hpack)); - type_info[t_package].descriptor = - to_bitmap(&o, &(o.pack.name)) | - to_bitmap(&o, &(o.pack.nicknames)) | - to_bitmap(&o, &(o.pack.shadowings)) | - to_bitmap(&o, &(o.pack.uses)) | - to_bitmap(&o, &(o.pack.usedby)) | - to_bitmap(&o, &(o.pack.internal)) | - to_bitmap(&o, &(o.pack.external)); - type_info[t_hashtable].descriptor = - to_bitmap(&o, &(o.hash.data)) | - to_bitmap(&o, &(o.hash.rehash_size)) | - to_bitmap(&o, &(o.hash.threshold)); - type_info[t_array].descriptor = - to_bitmap(&o, &(o.array.dims)) | - to_bitmap(&o, &(o.array.self.t)) | - to_bitmap(&o, &(o.array.displaced)); - type_info[t_vector].descriptor = - to_bitmap(&o, &(o.vector.self.t)) | - to_bitmap(&o, &(o.vector.displaced)); + type_info[t_complex].descriptor = + to_bitmap(&o, &(o.complex.real)) | + to_bitmap(&o, &(o.complex.imag)); + type_info[t_symbol].descriptor = + to_bitmap(&o, &(o.symbol.value)) | + to_bitmap(&o, &(o.symbol.gfdef)) | + to_bitmap(&o, &(o.symbol.plist)) | + to_bitmap(&o, &(o.symbol.name)) | + to_bitmap(&o, &(o.symbol.hpack)); + type_info[t_package].descriptor = + to_bitmap(&o, &(o.pack.name)) | + to_bitmap(&o, &(o.pack.nicknames)) | + to_bitmap(&o, &(o.pack.shadowings)) | + to_bitmap(&o, &(o.pack.uses)) | + to_bitmap(&o, &(o.pack.usedby)) | + to_bitmap(&o, &(o.pack.internal)) | + to_bitmap(&o, &(o.pack.external)); + type_info[t_hashtable].descriptor = + to_bitmap(&o, &(o.hash.data)) | + to_bitmap(&o, &(o.hash.rehash_size)) | + to_bitmap(&o, &(o.hash.threshold)); + type_info[t_array].descriptor = + to_bitmap(&o, &(o.array.dims)) | + to_bitmap(&o, &(o.array.self.t)) | + to_bitmap(&o, &(o.array.displaced)); + type_info[t_vector].descriptor = + to_bitmap(&o, &(o.vector.self.t)) | + to_bitmap(&o, &(o.vector.displaced)); # ifdef ECL_UNICODE - type_info[t_string].descriptor = - to_bitmap(&o, &(o.string.self)) | - to_bitmap(&o, &(o.string.displaced)); + type_info[t_string].descriptor = + to_bitmap(&o, &(o.string.self)) | + to_bitmap(&o, &(o.string.displaced)); # endif - type_info[t_base_string].descriptor = - to_bitmap(&o, &(o.base_string.self)) | - to_bitmap(&o, &(o.base_string.displaced)); - type_info[t_bitvector].descriptor = - to_bitmap(&o, &(o.vector.self.t)) | - to_bitmap(&o, &(o.vector.displaced)); - type_info[t_stream].descriptor = - to_bitmap(&o, &(o.stream.ops)) | - to_bitmap(&o, &(o.stream.object0)) | - to_bitmap(&o, &(o.stream.object1)) | - to_bitmap(&o, &(o.stream.byte_stack)) | - to_bitmap(&o, &(o.stream.buffer)) | - to_bitmap(&o, &(o.stream.format)) | - to_bitmap(&o, &(o.stream.format_table)); - type_info[t_random].descriptor = - to_bitmap(&o, &(o.random.value)); - type_info[t_readtable].descriptor = + type_info[t_base_string].descriptor = + to_bitmap(&o, &(o.base_string.self)) | + to_bitmap(&o, &(o.base_string.displaced)); + type_info[t_bitvector].descriptor = + to_bitmap(&o, &(o.vector.self.t)) | + to_bitmap(&o, &(o.vector.displaced)); + type_info[t_stream].descriptor = + to_bitmap(&o, &(o.stream.ops)) | + to_bitmap(&o, &(o.stream.object0)) | + to_bitmap(&o, &(o.stream.object1)) | + to_bitmap(&o, &(o.stream.byte_stack)) | + to_bitmap(&o, &(o.stream.buffer)) | + to_bitmap(&o, &(o.stream.format)) | + to_bitmap(&o, &(o.stream.format_table)); + type_info[t_random].descriptor = + to_bitmap(&o, &(o.random.value)); + type_info[t_readtable].descriptor = # ifdef ECL_UNICODE - to_bitmap(&o, &(o.readtable.hash)) | + to_bitmap(&o, &(o.readtable.hash)) | # endif - to_bitmap(&o, &(o.readtable.table)); - type_info[t_pathname].descriptor = - to_bitmap(&o, &(o.pathname.version)) | - to_bitmap(&o, &(o.pathname.type)) | - to_bitmap(&o, &(o.pathname.name)) | - to_bitmap(&o, &(o.pathname.directory)) | - to_bitmap(&o, &(o.pathname.device)) | - to_bitmap(&o, &(o.pathname.host)); - type_info[t_bytecodes].descriptor = - to_bitmap(&o, &(o.bytecodes.name)) | - to_bitmap(&o, &(o.bytecodes.definition)) | - to_bitmap(&o, &(o.bytecodes.code)) | - to_bitmap(&o, &(o.bytecodes.data)) | - to_bitmap(&o, &(o.bytecodes.file)) | - to_bitmap(&o, &(o.bytecodes.file_position)); - type_info[t_bclosure].descriptor = - to_bitmap(&o, &(o.bclosure.code)) | - to_bitmap(&o, &(o.bclosure.lex)); - type_info[t_cfun].descriptor = - to_bitmap(&o, &(o.cfun.name)) | - to_bitmap(&o, &(o.cfun.block)) | - to_bitmap(&o, &(o.cfun.file)) | - to_bitmap(&o, &(o.cfun.file_position)); - type_info[t_cfunfixed].descriptor = - to_bitmap(&o, &(o.cfunfixed.name)) | - to_bitmap(&o, &(o.cfunfixed.block)) | - to_bitmap(&o, &(o.cfunfixed.file)) | - to_bitmap(&o, &(o.cfunfixed.file_position)); - type_info[t_cclosure].descriptor = - to_bitmap(&o, &(o.cclosure.env)) | - to_bitmap(&o, &(o.cclosure.block)) | - to_bitmap(&o, &(o.cclosure.file)) | - to_bitmap(&o, &(o.cclosure.file_position)); - type_info[t_instance].descriptor = - to_bitmap(&o, &(o.instance.clas)) | - to_bitmap(&o, &(o.instance.sig)) | - to_bitmap(&o, &(o.instance.slots)); + to_bitmap(&o, &(o.readtable.table)); + type_info[t_pathname].descriptor = + to_bitmap(&o, &(o.pathname.version)) | + to_bitmap(&o, &(o.pathname.type)) | + to_bitmap(&o, &(o.pathname.name)) | + to_bitmap(&o, &(o.pathname.directory)) | + to_bitmap(&o, &(o.pathname.device)) | + to_bitmap(&o, &(o.pathname.host)); + type_info[t_bytecodes].descriptor = + to_bitmap(&o, &(o.bytecodes.name)) | + to_bitmap(&o, &(o.bytecodes.definition)) | + to_bitmap(&o, &(o.bytecodes.code)) | + to_bitmap(&o, &(o.bytecodes.data)) | + to_bitmap(&o, &(o.bytecodes.file)) | + to_bitmap(&o, &(o.bytecodes.file_position)); + type_info[t_bclosure].descriptor = + to_bitmap(&o, &(o.bclosure.code)) | + to_bitmap(&o, &(o.bclosure.lex)); + type_info[t_cfun].descriptor = + to_bitmap(&o, &(o.cfun.name)) | + to_bitmap(&o, &(o.cfun.block)) | + to_bitmap(&o, &(o.cfun.file)) | + to_bitmap(&o, &(o.cfun.file_position)); + type_info[t_cfunfixed].descriptor = + to_bitmap(&o, &(o.cfunfixed.name)) | + to_bitmap(&o, &(o.cfunfixed.block)) | + to_bitmap(&o, &(o.cfunfixed.file)) | + to_bitmap(&o, &(o.cfunfixed.file_position)); + type_info[t_cclosure].descriptor = + to_bitmap(&o, &(o.cclosure.env)) | + to_bitmap(&o, &(o.cclosure.block)) | + to_bitmap(&o, &(o.cclosure.file)) | + to_bitmap(&o, &(o.cclosure.file_position)); + type_info[t_instance].descriptor = + to_bitmap(&o, &(o.instance.clas)) | + to_bitmap(&o, &(o.instance.sig)) | + to_bitmap(&o, &(o.instance.slots)); # ifdef ECL_THREADS - type_info[t_process].descriptor = - to_bitmap(&o, &(o.process.name)) | - to_bitmap(&o, &(o.process.function)) | - to_bitmap(&o, &(o.process.args)) | - to_bitmap(&o, &(o.process.env)) | - to_bitmap(&o, &(o.process.interrupt)) | - to_bitmap(&o, &(o.process.initial_bindings)) | - to_bitmap(&o, &(o.process.parent)) | - to_bitmap(&o, &(o.process.exit_barrier)) | - to_bitmap(&o, &(o.process.exit_values)) | - to_bitmap(&o, &(o.process.woken_up)) | - to_bitmap(&o, &(o.process.start_spinlock)) | - to_bitmap(&o, &(o.process.queue_record)); - type_info[t_lock].descriptor = - to_bitmap(&o, &(o.lock.name)) | - to_bitmap(&o, &(o.lock.owner)) | - to_bitmap(&o, &(o.lock.queue_spinlock)) | - to_bitmap(&o, &(o.lock.queue_list)); + type_info[t_process].descriptor = + to_bitmap(&o, &(o.process.name)) | + to_bitmap(&o, &(o.process.function)) | + to_bitmap(&o, &(o.process.args)) | + to_bitmap(&o, &(o.process.env)) | + to_bitmap(&o, &(o.process.interrupt)) | + to_bitmap(&o, &(o.process.initial_bindings)) | + to_bitmap(&o, &(o.process.parent)) | + to_bitmap(&o, &(o.process.exit_barrier)) | + to_bitmap(&o, &(o.process.exit_values)) | + to_bitmap(&o, &(o.process.woken_up)) | + to_bitmap(&o, &(o.process.start_spinlock)) | + to_bitmap(&o, &(o.process.queue_record)); + type_info[t_lock].descriptor = + to_bitmap(&o, &(o.lock.name)) | + to_bitmap(&o, &(o.lock.owner)) | + to_bitmap(&o, &(o.lock.queue_spinlock)) | + to_bitmap(&o, &(o.lock.queue_list)); # ifdef ECL_RWLOCK - type_info[t_rwlock].descriptor = - to_bitmap(&o, &(o.rwlock.name)); + type_info[t_rwlock].descriptor = + to_bitmap(&o, &(o.rwlock.name)); # else - type_info[t_rwlock].descriptor = - to_bitmap(&o, &(o.rwlock.name)) | - to_bitmap(&o, &(o.rwlock.mutex)); + type_info[t_rwlock].descriptor = + to_bitmap(&o, &(o.rwlock.name)) | + to_bitmap(&o, &(o.rwlock.mutex)); # endif - type_info[t_condition_variable].descriptor = - to_bitmap(&o, &(o.condition_variable.lock)) | - to_bitmap(&o, &(o.condition_variable.queue_list)) | - to_bitmap(&o, &(o.condition_variable.queue_spinlock)); - type_info[t_semaphore].descriptor = - to_bitmap(&o, &(o.semaphore.name)) | - to_bitmap(&o, &(o.semaphore.queue_list)) | - to_bitmap(&o, &(o.semaphore.queue_spinlock)); - type_info[t_barrier].descriptor = - to_bitmap(&o, &(o.barrier.name)) | - to_bitmap(&o, &(o.barrier.queue_list)) | - to_bitmap(&o, &(o.barrier.queue_spinlock)); - type_info[t_mailbox].descriptor = - to_bitmap(&o, &(o.mailbox.name)) | - to_bitmap(&o, &(o.mailbox.data)) | - to_bitmap(&o, &(o.mailbox.reader_semaphore)) | - to_bitmap(&o, &(o.mailbox.writer_semaphore)); + type_info[t_condition_variable].descriptor = + to_bitmap(&o, &(o.condition_variable.lock)) | + to_bitmap(&o, &(o.condition_variable.queue_list)) | + to_bitmap(&o, &(o.condition_variable.queue_spinlock)); + type_info[t_semaphore].descriptor = + to_bitmap(&o, &(o.semaphore.name)) | + to_bitmap(&o, &(o.semaphore.queue_list)) | + to_bitmap(&o, &(o.semaphore.queue_spinlock)); + type_info[t_barrier].descriptor = + to_bitmap(&o, &(o.barrier.name)) | + to_bitmap(&o, &(o.barrier.queue_list)) | + to_bitmap(&o, &(o.barrier.queue_spinlock)); + type_info[t_mailbox].descriptor = + to_bitmap(&o, &(o.mailbox.name)) | + to_bitmap(&o, &(o.mailbox.data)) | + to_bitmap(&o, &(o.mailbox.reader_semaphore)) | + to_bitmap(&o, &(o.mailbox.writer_semaphore)); # endif - type_info[t_codeblock].descriptor = - to_bitmap(&o, &(o.cblock.data)) | - to_bitmap(&o, &(o.cblock.temp_data)) | - to_bitmap(&o, &(o.cblock.next)) | - to_bitmap(&o, &(o.cblock.name)) | - to_bitmap(&o, &(o.cblock.links)) | - to_bitmap(&o, &(o.cblock.source)) | - to_bitmap(&o, &(o.cblock.error)); - type_info[t_foreign].descriptor = - to_bitmap(&o, &(o.foreign.data)) | - to_bitmap(&o, &(o.foreign.tag)); - type_info[t_frame].descriptor = - to_bitmap(&o, &(o.frame.stack)) | - to_bitmap(&o, &(o.frame.base)) | - to_bitmap(&o, &(o.frame.env)); - type_info[t_weak_pointer].descriptor = 0; + type_info[t_codeblock].descriptor = + to_bitmap(&o, &(o.cblock.data)) | + to_bitmap(&o, &(o.cblock.temp_data)) | + to_bitmap(&o, &(o.cblock.next)) | + to_bitmap(&o, &(o.cblock.name)) | + to_bitmap(&o, &(o.cblock.links)) | + to_bitmap(&o, &(o.cblock.source)) | + to_bitmap(&o, &(o.cblock.error)); + type_info[t_foreign].descriptor = + to_bitmap(&o, &(o.foreign.data)) | + to_bitmap(&o, &(o.foreign.tag)); + type_info[t_frame].descriptor = + to_bitmap(&o, &(o.frame.stack)) | + to_bitmap(&o, &(o.frame.base)) | + to_bitmap(&o, &(o.frame.env)); + type_info[t_weak_pointer].descriptor = 0; #ifdef ECL_SSE2 - type_info[t_sse_pack].descriptor = 0; + type_info[t_sse_pack].descriptor = 0; #endif - for (i = 0; i < t_end; i++) { - GC_word descriptor = type_info[i].descriptor; - int bits = type_info[i].size / sizeof(GC_word); - if (descriptor) { + for (i = 0; i < t_end; i++) { + GC_word descriptor = type_info[i].descriptor; + int bits = type_info[i].size / sizeof(GC_word); + if (descriptor) { #ifdef GBC_BOEHM_OWN_MARKER - type_info[i].allocator = allocate_object_marked; - descriptor = GC_make_descriptor(&descriptor, bits); - descriptor &= ~GC_DS_TAGS; + type_info[i].allocator = allocate_object_marked; + descriptor = GC_make_descriptor(&descriptor, bits); + descriptor &= ~GC_DS_TAGS; #else - GC_word mask = (1 << (bits-1)) - 1; - mask ^= (descriptor >> 1); - if (mask == 0) - type_info[i].allocator = allocate_object_full; - else - type_info[i].allocator = allocate_object_typed; - descriptor = GC_make_descriptor(&descriptor, bits); -#endif - } else { - type_info[i].allocator = allocate_object_atomic; - descriptor = 0; - } - type_info[i].descriptor = descriptor; - } + GC_word mask = (1 << (bits-1)) - 1; + mask ^= (descriptor >> 1); + if (mask == 0) + type_info[i].allocator = allocate_object_full; + else + type_info[i].allocator = allocate_object_typed; + descriptor = GC_make_descriptor(&descriptor, bits); +#endif + } else { + type_info[i].allocator = allocate_object_atomic; + descriptor = 0; + } + type_info[i].descriptor = descriptor; + } #endif /* GBC_BOEHM_PRECISE */ - old_GC_push_other_roots = GC_push_other_roots; - GC_push_other_roots = stacks_scanner; + old_GC_push_other_roots = GC_push_other_roots; + GC_push_other_roots = stacks_scanner; #ifdef HAVE_GC_SET_START_CALLBACK - GC_old_start_callback = GC_get_start_callback(); - GC_set_start_callback(gather_statistics); + GC_old_start_callback = GC_get_start_callback(); + GC_set_start_callback(gather_statistics); #else - GC_old_start_callback = GC_start_call_back; - GC_start_call_back = (void (*)(void))gather_statistics; + GC_old_start_callback = GC_start_call_back; + GC_start_call_back = (void (*)(void))gather_statistics; #endif - GC_set_java_finalization(1); - GC_set_oom_fn(out_of_memory); - GC_set_warn_proc(no_warnings); - GC_enable(); + GC_set_java_finalization(1); + GC_set_oom_fn(out_of_memory); + GC_set_warn_proc(no_warnings); + GC_enable(); } /********************************************************** @@ -1097,100 +1093,135 @@ static void standard_finalizer(cl_object o) { - switch (o->d.t) { + switch (o->d.t) { #ifdef ENABLE_DLOPEN - case t_codeblock: - ecl_library_close(o); - break; -#endif - case t_stream: - cl_close(1, o); - break; - case t_weak_pointer: - GC_unregister_disappearing_link((void**)&(o->weak.value)); - break; + case t_codeblock: + ecl_library_close(o); + break; +#endif + case t_stream: + cl_close(1, o); + break; + case t_weak_pointer: + GC_unregister_disappearing_link((void**)&(o->weak.value)); + break; #ifdef ECL_THREADS # ifdef ECL_RWLOCK - case t_rwlock: { - const cl_env_ptr the_env = ecl_process_env(); - ecl_disable_interrupts_env(the_env); - pthread_rwlock_destroy(&o->rwlock.mutex); - ecl_enable_interrupts_env(the_env); - break; - } + case t_rwlock: { + const cl_env_ptr the_env = ecl_process_env(); + ecl_disable_interrupts_env(the_env); + pthread_rwlock_destroy(&o->rwlock.mutex); + ecl_enable_interrupts_env(the_env); + break; + } # endif - case t_symbol: { - ecl_atomic_push(&cl_core.reused_indices, - ecl_make_fixnum(o->symbol.binding)); - } + case t_symbol: { + ecl_atomic_push(&cl_core.reused_indices, + ecl_make_fixnum(o->symbol.binding)); + } #endif /* ECL_THREADS */ - default:; - } + default:; + } } static void +wrapped_finalizer(cl_object o, cl_object finalizer); + +static void +deferred_finalizer(cl_object o) +{ + wrapped_finalizer(cl_first(o), cl_second(o)); +} + +void wrapped_finalizer(cl_object o, cl_object finalizer) { - if (finalizer != ECL_NIL && finalizer != NULL) { - CL_NEWENV_BEGIN { - if (finalizer != ECL_T) { - funcall(2, finalizer, o); - } - standard_finalizer(o); - } CL_NEWENV_END; - } + if (finalizer != ECL_NIL && finalizer != NULL) { +#ifdef ECL_THREADS + const cl_env_ptr the_env = ecl_process_env(); + if (!the_env + || !the_env->own_process + || the_env->own_process->process.phase < ECL_PROCESS_ACTIVE) + { + /* + * The finalizer is invoked while we are registering or setup a + * new lisp process. As example that may happen when we are + * doing ecl_import_current_thread. That mean the finalizer + * can not be executed right now, so in some way we need to + * queue the finalization. When we return from this function + * the original finalizer is no more registered to o, and if o + * is not anymore reachable it will be colleted. To prevent + * this we need to make this object reachable again after that + * roundtrip and postpone the finalization to the next garbace + * colletion. Given that this is a rare condition one way to + * do that is: + */ + GC_finalization_proc ofn; + void *odata; + GC_register_finalizer_no_order(cl_list(2,o,finalizer), + (GC_finalization_proc)deferred_finalizer, 0, + &ofn, &odata); + return; + } +#endif /* ECL_THREADS */ + CL_NEWENV_BEGIN { + if (finalizer != ECL_T) { + funcall(2, finalizer, o); + } + standard_finalizer(o); + } CL_NEWENV_END; + } } cl_object si_get_finalizer(cl_object o) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object output; - GC_finalization_proc ofn; - void *odata; - ecl_disable_interrupts_env(the_env); - GC_register_finalizer_no_order(o, (GC_finalization_proc)0, 0, &ofn, &odata); - if (ofn == 0) { - output = ECL_NIL; - } else if (ofn == (GC_finalization_proc)wrapped_finalizer) { - output = (cl_object)odata; - } else { - output = ECL_NIL; - } - GC_register_finalizer_no_order(o, ofn, odata, &ofn, &odata); - ecl_enable_interrupts_env(the_env); - @(return output) + const cl_env_ptr the_env = ecl_process_env(); + cl_object output; + GC_finalization_proc ofn; + void *odata; + ecl_disable_interrupts_env(the_env); + GC_register_finalizer_no_order(o, (GC_finalization_proc)0, 0, &ofn, &odata); + if (ofn == 0) { + output = ECL_NIL; + } else if (ofn == (GC_finalization_proc)wrapped_finalizer) { + output = (cl_object)odata; + } else { + output = ECL_NIL; + } + GC_register_finalizer_no_order(o, ofn, odata, &ofn, &odata); + ecl_enable_interrupts_env(the_env); + @(return output); } void ecl_set_finalizer_unprotected(cl_object o, cl_object finalizer) { - GC_finalization_proc ofn; - void *odata; - if (finalizer == ECL_NIL) { - GC_register_finalizer_no_order(o, (GC_finalization_proc)0, - 0, &ofn, &odata); - } else { - GC_finalization_proc newfn; - newfn = (GC_finalization_proc)wrapped_finalizer; - GC_register_finalizer_no_order(o, newfn, finalizer, - &ofn, &odata); - } + GC_finalization_proc ofn; + void *odata; + if (finalizer == ECL_NIL) { + GC_register_finalizer_no_order(o, (GC_finalization_proc)0, + 0, &ofn, &odata); + } else { + GC_finalization_proc newfn; + newfn = (GC_finalization_proc)wrapped_finalizer; + GC_register_finalizer_no_order(o, newfn, finalizer, + &ofn, &odata); + } } cl_object si_set_finalizer(cl_object o, cl_object finalizer) { - const cl_env_ptr the_env = ecl_process_env(); - ecl_disable_interrupts_env(the_env); - ecl_set_finalizer_unprotected(o, finalizer); - ecl_enable_interrupts_env(the_env); - @(return) + const cl_env_ptr the_env = ecl_process_env(); + ecl_disable_interrupts_env(the_env); + ecl_set_finalizer_unprotected(o, finalizer); + ecl_enable_interrupts_env(the_env); + @(return); } /* If we do not build our own version of the library, we do not have - * control over the existence of this variable. - */ + * control over the existence of this variable. */ #if GBC_BOEHM == 0 extern int GC_print_stats; #else @@ -1200,81 +1231,88 @@ cl_object si_gc_stats(cl_object enable) { - cl_object old_status; - cl_object size1 = ecl_make_fixnum(0); - cl_object size2 = ecl_make_fixnum(0); - if (cl_core.gc_stats == 0) { - old_status = ECL_NIL; - } else if (GC_print_stats) { - old_status = @':full'; - } else { - old_status = ECL_T; - } - if (cl_core.bytes_consed == ECL_NIL) { - cl_core.bytes_consed = ecl_alloc_object(t_bignum); - mpz_init2(cl_core.bytes_consed->big.big_num, 128); - cl_core.gc_counter = ecl_alloc_object(t_bignum); - mpz_init2(cl_core.gc_counter->big.big_num, 128); - } else { - /* We need fresh copies of the bignums */ - size1 = _ecl_big_plus_fix(cl_core.bytes_consed, 1); - size2 = _ecl_big_plus_fix(cl_core.gc_counter, 1); - } - if (enable == ECL_NIL) { - GC_print_stats = 0; - cl_core.gc_stats = 0; - } else if (enable == ecl_make_fixnum(0)) { - mpz_set_ui(cl_core.bytes_consed->big.big_num, 0); - mpz_set_ui(cl_core.gc_counter->big.big_num, 0); - } else { - cl_core.gc_stats = 1; - GC_print_stats = (enable == @':full'); - } - @(return size1 size2 old_status) + cl_object old_status; + cl_object size1; + cl_object size2; + if (cl_core.gc_stats == 0) { + old_status = ECL_NIL; + } else if (GC_print_stats) { + old_status = @':full'; + } else { + old_status = ECL_T; + } + if (cl_core.bytes_consed == ECL_NIL) { + cl_core.bytes_consed = ecl_alloc_object(t_bignum); + mpz_init2(cl_core.bytes_consed->big.big_num, 128); + cl_core.gc_counter = ecl_alloc_object(t_bignum); + mpz_init2(cl_core.gc_counter->big.big_num, 128); + } + + update_bytes_consed(); + /* We need fresh copies of the bignums */ + size1 = _ecl_big_register_copy(cl_core.bytes_consed); + size2 = _ecl_big_register_copy(cl_core.gc_counter); + + if (enable == ECL_NIL) { + GC_print_stats = 0; + cl_core.gc_stats = 0; + } else if (enable == ecl_make_fixnum(0)) { + mpz_set_ui(cl_core.bytes_consed->big.big_num, 0); + mpz_set_ui(cl_core.gc_counter->big.big_num, 0); + } else { + cl_core.gc_stats = 1; + GC_print_stats = (enable == @':full'); + } + @(return size1 size2 old_status); } -/* - * This procedure is invoked after garbage collection. Note that we +/* This procedure is invoked after garbage collection. Note that we * cannot cons because this procedure is invoked with the garbage - * collection lock on. - */ + * collection lock on. */ static void gather_statistics() { - if (cl_core.gc_stats) { - /* Sorry, no gc stats if you do not use bignums */ + /* GC stats rely on bignums */ + if (cl_core.gc_stats) { + update_bytes_consed(); + mpz_add_ui(cl_core.gc_counter->big.big_num, + cl_core.gc_counter->big.big_num, + 1); + } + if (GC_old_start_callback) + GC_old_start_callback(); +} + +static void +update_bytes_consed () { #if GBC_BOEHM == 0 - mpz_add_ui(cl_core.bytes_consed->big.big_num, - cl_core.bytes_consed->big.big_num, - GC_get_bytes_since_gc()); + mpz_add_ui(cl_core.bytes_consed->big.big_num, + cl_core.bytes_consed->big.big_num, + GC_get_bytes_since_gc()); #else - /* This is not accurate and may wrap around. We try - to detect this assuming that an overflow in an - unsigned integer will produce an smaller - integer.*/ - static cl_index bytes = 0; - cl_index new_bytes = GC_get_total_bytes(); - if (bytes > new_bytes) { - cl_index wrapped; - wrapped = ~((cl_index)0) - bytes; - mpz_add_ui(cl_core.bytes_consed->big.big_num, - cl_core.bytes_consed->big.big_num, - wrapped); - bytes = new_bytes; - } - mpz_add_ui(cl_core.bytes_consed->big.big_num, - cl_core.bytes_consed->big.big_num, - new_bytes - bytes); -#endif - mpz_add_ui(cl_core.gc_counter->big.big_num, - cl_core.gc_counter->big.big_num, - 1); - } - if (GC_old_start_callback) - GC_old_start_callback(); + /* This is not accurate and may wrap around. We try to detect this + assuming that an overflow in an unsigned integer will produce + a smaller integer.*/ + static cl_index bytes = 0; + cl_index new_bytes = GC_get_total_bytes(); + if (bytes > new_bytes) { + cl_index wrapped; + wrapped = ~((cl_index)0) - bytes; + mpz_add_ui(cl_core.bytes_consed->big.big_num, + cl_core.bytes_consed->big.big_num, + wrapped); + mpz_add_ui(cl_core.bytes_consed->big.big_num, + cl_core.bytes_consed->big.big_num, + new_bytes); + } else { + mpz_add_ui(cl_core.bytes_consed->big.big_num, + cl_core.bytes_consed->big.big_num, + new_bytes - bytes); + } + bytes = new_bytes; +#endif } - /********************************************************** * GARBAGE COLLECTOR * **********************************************************/ @@ -1283,64 +1321,64 @@ ecl_mark_env(struct cl_env_struct *env) { #if 1 - if (env->stack) { - GC_push_conditional((void *)env->stack, (void *)env->stack_top, 1); - GC_set_mark_bit((void *)env->stack); - } - if (env->frs_top) { - GC_push_conditional((void *)env->frs_org, (void *)(env->frs_top+1), 1); - GC_set_mark_bit((void *)env->frs_org); - } - if (env->bds_top) { - GC_push_conditional((void *)env->bds_org, (void *)(env->bds_top+1), 1); - GC_set_mark_bit((void *)env->bds_org); - } + if (env->stack) { + GC_push_conditional((void *)env->stack, (void *)env->stack_top, 1); + GC_set_mark_bit((void *)env->stack); + } + if (env->frs_top) { + GC_push_conditional((void *)env->frs_org, (void *)(env->frs_top+1), 1); + GC_set_mark_bit((void *)env->frs_org); + } + if (env->bds_top) { + GC_push_conditional((void *)env->bds_org, (void *)(env->bds_top+1), 1); + GC_set_mark_bit((void *)env->bds_org); + } #endif - /*memset(env->values[env->nvalues], 0, (64-env->nvalues)*sizeof(cl_object));*/ + /*memset(env->values[env->nvalues], 0, (64-env->nvalues)*sizeof(cl_object));*/ #if defined(ECL_THREADS) && !defined(ECL_USE_MPROTECT) && !defined(ECL_USE_GUARD_PAGE) - /* When using threads, "env" is a pointer to memory allocated by ECL. */ - GC_push_conditional((void *)env, (void *)(env + 1), 1); - GC_set_mark_bit((void *)env); + /* When using threads, "env" is a pointer to memory allocated by ECL. */ + GC_push_conditional((void *)env, (void *)(env + 1), 1); + GC_set_mark_bit((void *)env); #else - /* When not using threads, "env" is mmaped or statically allocated. */ - GC_push_all((void *)env, (void *)(env + 1)); + /* When not using threads, "env" is mmaped or statically allocated. */ + GC_push_all((void *)env, (void *)(env + 1)); #endif } static void stacks_scanner() { - cl_env_ptr the_env = ecl_process_env(); - cl_object l; - l = cl_core.libraries; - if (l) { - for (; l != ECL_NIL; l = ECL_CONS_CDR(l)) { - cl_object dll = ECL_CONS_CAR(l); - if (dll->cblock.locked) { - GC_push_conditional((void *)dll, (void *)(&dll->cblock + 1), 1); - GC_set_mark_bit((void *)dll); - } - } - } - GC_push_all((void *)(&cl_core), (void *)(&cl_core + 1)); - GC_push_all((void *)cl_symbols, (void *)(cl_symbols + cl_num_symbols_in_core)); - if (the_env != NULL) - ecl_mark_env(the_env); + cl_env_ptr the_env = ecl_process_env(); + cl_object l; + l = cl_core.libraries; + if (l) { + for (; l != ECL_NIL; l = ECL_CONS_CDR(l)) { + cl_object dll = ECL_CONS_CAR(l); + if (dll->cblock.locked) { + GC_push_conditional((void *)dll, (void *)(&dll->cblock + 1), 1); + GC_set_mark_bit((void *)dll); + } + } + } + GC_push_all((void *)(&cl_core), (void *)(&cl_core + 1)); + GC_push_all((void *)cl_symbols, (void *)(cl_symbols + cl_num_symbols_in_core)); + if (the_env != NULL) + ecl_mark_env(the_env); #ifdef ECL_THREADS - l = cl_core.processes; - if (l != OBJNULL) { - cl_index i, size; - for (i = 0, size = l->vector.dim; i < size; i++) { - cl_object process = l->vector.self.t[i]; - if (!Null(process)) { - cl_env_ptr env = process->process.env; - if (env && (env != the_env)) ecl_mark_env(env); - } - } - } + l = cl_core.processes; + if (l != OBJNULL) { + cl_index i, size; + for (i = 0, size = l->vector.dim; i < size; i++) { + cl_object process = l->vector.self.t[i]; + if (!Null(process)) { + cl_env_ptr env = process->process.env; + if (env && (env != the_env)) ecl_mark_env(env); + } + } + } #endif - if (old_GC_push_other_roots) - (*old_GC_push_other_roots)(); + if (old_GC_push_other_roots) + (*old_GC_push_other_roots)(); } /********************************************************** @@ -1350,30 +1388,30 @@ void ecl_register_root(cl_object *p) { - const cl_env_ptr the_env = ecl_process_env(); - ecl_disable_interrupts_env(the_env); - GC_add_roots((char*)p, (char*)(p+1)); - ecl_enable_interrupts_env(the_env); + const cl_env_ptr the_env = ecl_process_env(); + ecl_disable_interrupts_env(the_env); + GC_add_roots((char*)p, (char*)(p+1)); + ecl_enable_interrupts_env(the_env); } cl_object si_gc(cl_narg narg, ...) { - const cl_env_ptr the_env = ecl_process_env(); - ecl_disable_interrupts_env(the_env); - GC_gcollect(); - ecl_enable_interrupts_env(the_env); - @(return) + const cl_env_ptr the_env = ecl_process_env(); + ecl_disable_interrupts_env(the_env); + GC_gcollect(); + ecl_enable_interrupts_env(the_env); + @(return); } cl_object si_gc_dump() { - const cl_env_ptr the_env = ecl_process_env(); - ecl_disable_interrupts_env(the_env); - GC_dump(); - ecl_enable_interrupts_env(the_env); - @(return) + const cl_env_ptr the_env = ecl_process_env(); + ecl_disable_interrupts_env(the_env); + GC_dump(); + ecl_enable_interrupts_env(the_env); + @(return); } /********************************************************************** @@ -1383,42 +1421,42 @@ static cl_object ecl_alloc_weak_pointer(cl_object o) { - const cl_env_ptr the_env = ecl_process_env(); - struct ecl_weak_pointer *obj; - ecl_disable_interrupts_env(the_env); - obj = GC_MALLOC_ATOMIC(sizeof(struct ecl_weak_pointer)); - ecl_enable_interrupts_env(the_env); - obj->t = t_weak_pointer; - obj->value = o; - if (!ECL_FIXNUMP(o) && !ECL_CHARACTERP(o) && !Null(o)) { - GC_general_register_disappearing_link((void**)&(obj->value), (void*)o); - si_set_finalizer((cl_object)obj, ECL_T); - } - return (cl_object)obj; + const cl_env_ptr the_env = ecl_process_env(); + struct ecl_weak_pointer *obj; + ecl_disable_interrupts_env(the_env); + obj = GC_MALLOC_ATOMIC(sizeof(struct ecl_weak_pointer)); + ecl_enable_interrupts_env(the_env); + obj->t = t_weak_pointer; + obj->value = o; + if (!ECL_FIXNUMP(o) && !ECL_CHARACTERP(o) && !Null(o)) { + GC_general_register_disappearing_link((void**)&(obj->value), (void*)o); + si_set_finalizer((cl_object)obj, ECL_T); + } + return (cl_object)obj; } cl_object si_make_weak_pointer(cl_object o) { - cl_object pointer = ecl_alloc_weak_pointer(o); - @(return pointer); + cl_object pointer = ecl_alloc_weak_pointer(o); + @(return pointer); } static cl_object ecl_weak_pointer_value(cl_object o) { - return o->weak.value; + return o->weak.value; } cl_object si_weak_pointer_value(cl_object o) { - cl_object value; - if (ecl_unlikely(ecl_t_of(o) != t_weak_pointer)) - FEwrong_type_only_arg(@[ext::weak-pointer-value], o, - @[ext::weak-pointer]); - value = (cl_object)GC_call_with_alloc_lock((GC_fn_type)ecl_weak_pointer_value, o); - @(return (value? value : ECL_NIL)); + cl_object value; + if (ecl_unlikely(ecl_t_of(o) != t_weak_pointer)) + FEwrong_type_only_arg(@[ext::weak-pointer-value], o, + @[ext::weak-pointer]); + value = (cl_object)GC_call_with_alloc_lock((GC_fn_type)ecl_weak_pointer_value, o); + @(return (value? value : ECL_NIL)); } #endif /* GBC_BOEHM */ diff -Nru ecl-16.1.2/src/c/alloc.d ecl-16.1.3+ds/src/c/alloc.d --- ecl-16.1.2/src/c/alloc.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/alloc.d 1970-01-01 00:00:00.000000000 +0000 @@ -1,978 +0,0 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ - - -/* - alloc.c -- Memory allocation. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ - -/******************************************************************************** - *** *** - *** IMPORTANT: This is obsolete code. The current garbage collector of ECL *** - *** is the Boehm-Weiser garbage collector and it is dealt with in *** - *** alloc_2.d *** - *** This file is kept here because of historical purposes, but also because *** - *** it might be useful in the future to implement another garbage collector *** - *** *** - ********************************************************************************/ - -/* - Heap and Relocatable Area - - heap_end data_end - +------+--------------------+ - - - + - - --------+ - | text | heap | hole | stack | - +------+--------------------+ - - - + - - --------+ - - The type_map array covers all pages of memory: those not used for objects - are marked as type t_other. - - The tm_table array holds a struct typemanager for each type, which contains - the first element of the free list for the type, and other bookkeeping - information. -*/ - -#include -#include -#include -#include -#include -#include - -#define USE_MMAP -#if defined(USE_MMAP) -#include -#include -#elif defined(HAVE_ULIMIT_H) -#include -#else -#include -#endif - -#ifdef ECL_SMALL_CONS -#error "Internal error: ECL cannot be built with --disable-boehm and --enable-smallcons" -#endif - -/******************************* EXPORTS ******************************/ - -cl_index real_maxpage; -cl_index new_holepage; -char type_map[MAXPAGE]; -struct typemanager tm_table[(int)t_end]; -struct contblock *cb_pointer = NULL; - -cl_index ncb; /* number of contblocks */ -cl_index ncbpage; /* number of contblock pages */ -cl_index maxcbpage; /* maximum number of contblock pages */ -cl_index cbgccount; /* contblock gc count */ -cl_index holepage; /* hole pages */ - -cl_ptr heap_end; /* heap end */ -cl_ptr heap_start; /* heap start */ -cl_ptr data_end; /* end of data space */ - -/******************************* ------- ******************************/ - -static bool ignore_maximum_pages = TRUE; - -#ifdef NEED_MALLOC -static cl_object malloc_list; -#endif - -/* - Ensure that the hole is at least "n" pages large. If it is not, - allocate space from the operating system. -*/ - -#if defined(USE_MMAP) -void -cl_resize_hole(cl_index n) -{ -#define PAGESIZE 8192 - cl_index m, bytes; - cl_ptr result, last_addr; - bytes = n * LISP_PAGESIZE; - bytes = (bytes + PAGESIZE-1) / PAGESIZE; - bytes = bytes * PAGESIZE; - if (heap_start == NULL) { - /* First time use. We allocate the memory and keep the first - * address in heap_start. - */ - result = mmap(0x2E000000, bytes, PROT_READ | PROT_WRITE, - MAP_ANON | MAP_FIXED | MAP_PRIVATE, -1 ,0); - if (result == MAP_FAILED) - ecl_internal_error("Cannot allocate memory. Good-bye!"); - data_end = heap_end = heap_start = result; - last_addr = heap_start + bytes; - holepage = n; - } else { - /* Next time use. We extend the region of memory that we had - * mapped before. - */ - m = (data_end - heap_end)/LISP_PAGESIZE; - if (n <= m) - return; - result = mmap(data_end, bytes, PROT_READ | PROT_WRITE, - MAP_ANON | MAP_FIXED | MAP_PRIVATE, -1, 0); - if (result == MAP_FAILED) - ecl_internal_error("Cannot resize memory pool. Good-bye!"); - last_addr = result + bytes; - if (result != data_end) { - cl_dealloc(heap_end, data_end - heap_end); - while (heap_end < result) { - cl_index p = page(heap_end); - if (p > real_maxpage) - ecl_internal_error("Memory limit exceeded."); - type_map[p] = t_other; - heap_end += LISP_PAGESIZE; - } - } - holepage = (last_addr - heap_end) / LISP_PAGESIZE; - } - while (data_end < last_addr) { - type_map[page(data_end)] = t_other; - data_end += LISP_PAGESIZE; - } -} -#else -void -cl_resize_hole(cl_index n) -{ - cl_ptr e; - cl_index m; - m = (data_end - heap_end)/LISP_PAGESIZE; - if (n <= m) - return; - - /* Create the hole */ - e = sbrk(0); - if (data_end == e) { - e = sbrk((n -= m) * LISP_PAGESIZE); - } else { - cl_dealloc(heap_end, data_end - heap_end); - /* FIXME! Horrible hack! */ - /* mark as t_other pages not allocated by us */ - heap_end = e; - while (data_end < heap_end) { - type_map[page(data_end)] = t_other; - data_end += LISP_PAGESIZE; - } - holepage = 0; - e = sbrk(n * LISP_PAGESIZE + (data_end - e)); - } - if ((cl_fixnum)e < 0) - ecl_internal_error("Can't allocate. Good-bye!"); - data_end = e; - holepage += n; -} -#endif - -/* Allocates n pages from the hole. */ -static void * -alloc_page(cl_index n) -{ - cl_ptr e = heap_end; - if (n >= holepage) { - ecl_gc(t_contiguous); - cl_resize_hole(new_holepage+n); - } - holepage -= n; - heap_end += LISP_PAGESIZE*n; - return e; -} - -/* - * We have to mark all objects within the page as FREE. However, at - * the end of the page there might be extra bytes, which have to be - * tagged as useless. Since these bytes are at least 4, x->m points to - * data within the page and we can mark this object setting x->m=FREE. - */ -static void -add_page_to_freelist(cl_ptr p, struct typemanager *tm) -{ - cl_type t; - cl_object x, f; - cl_index i; - t = tm->tm_type; - type_map[page(p)] = t; - f = tm->tm_free; - for (i = tm->tm_nppage; i > 0; --i, p += tm->tm_size) { - x = (cl_object)p; - ((struct freelist *)x)->t = (short)t; - ((struct freelist *)x)->m = FREE; - ((struct freelist *)x)->f_link = f; - f = x; - } - /* Mark the extra bytes which cannot be used. */ - if (tm->tm_size * tm->tm_nppage < LISP_PAGESIZE) { - x = (cl_object)p; - x->d.m = FREE; - } - tm->tm_free = f; - tm->tm_nfree += tm->tm_nppage; - tm->tm_npage++; -} - -cl_object -ecl_alloc_object(cl_type t) -{ - register cl_object obj; - register struct typemanager *tm; - register cl_ptr p; - - switch (t) { - case t_fixnum: - return MAKE_FIXNUM(0); /* Immediate fixnum */ - case t_character: - return ECL_CODE_CHAR('\0'); /* Immediate character */ - default:; - } - - ecl_disable_interrupts(); - tm = tm_of(t); -ONCE_MORE: - obj = tm->tm_free; - if (obj == OBJNULL) { - cl_index available = available_pages(); - if (tm->tm_npage >= tm->tm_maxpage) - goto CALL_GC; - if (available < 1) { - ignore_maximum_pages = FALSE; - goto CALL_GC; - } - p = alloc_page(1); - add_page_to_freelist(p, tm); - obj = tm->tm_free; - /* why this? Beppe - if (tm->tm_npage >= tm->tm_maxpage) - goto CALL_GC; */ - } - tm->tm_free = ((struct freelist *)obj)->f_link; - --(tm->tm_nfree); - (tm->tm_nused)++; - obj->d.t = (short)t; - obj->d.m = FALSE; - /* Now initialize the object so that it can be correctly marked - * by the GC - */ - switch (t) { - case t_bignum: - ECL_BIGNUM_DIM(obj) = ECL_BIGNUM_SIZE(obj) = 0; - ECL_BIGNUM_LIMBS(obj) = NULL; - break; - case t_ratio: - obj->ratio.num = OBJNULL; - obj->ratio.den = OBJNULL; - break; -#ifdef ECL_SSE2 - case t_sse_pack: -#endif - case t_singlefloat: - case t_doublefloat: -#ifdef ECL_LONG_FLOAT - case t_longfloat: -#endif - break; - case t_complex: - obj->complex.imag = OBJNULL; - obj->complex.real = OBJNULL; - break; - case t_symbol: - obj->symbol.plist = OBJNULL; - obj->symbol.gfdef = OBJNULL; - obj->symbol.value = OBJNULL; - obj->symbol.name = OBJNULL; - obj->symbol.hpack = OBJNULL; - break; - case t_package: - obj->pack.name = OBJNULL; - obj->pack.nicknames = OBJNULL; - obj->pack.shadowings = OBJNULL; - obj->pack.uses = OBJNULL; - obj->pack.usedby = OBJNULL; - obj->pack.internal = OBJNULL; - obj->pack.external = OBJNULL; - break; - case t_cons: -#error "FIXME" - obj->cons.car = OBJNULL; - obj->cons.cdr = OBJNULL; - break; - case t_hashtable: - obj->hash.rehash_size = OBJNULL; - obj->hash.threshold = OBJNULL; - obj->hash.data = NULL; - break; - case t_array: - obj->array.dims = NULL; - obj->array.displaced = ECL_NIL; - obj->array.elttype = (short)ecl_aet_object; - obj->array.self.t = NULL; - break; -#ifdef ECL_UNICODE - case t_string: -#endif - case t_vector: - obj->array.displaced = ECL_NIL; - obj->array.elttype = (short)ecl_aet_object; - obj->array.self.t = NULL; - break; - case t_base_string: - obj->base_string.displaced = ECL_NIL; - obj->base_string.self = NULL; - break; - case t_bitvector: - obj->vector.displaced = ECL_NIL; - obj->vector.self.bit = NULL; - break; - case t_stream: - obj->stream.mode = (short)ecl_smm_broadcast; - obj->stream.file.descriptor = -1; - obj->stream.object0 = OBJNULL; - obj->stream.object1 = OBJNULL; - obj->stream.buffer = NULL; - break; - case t_random: - break; - case t_readtable: - obj->readtable.table = NULL; - break; - case t_pathname: - obj->pathname.host = OBJNULL; - obj->pathname.device = OBJNULL; - obj->pathname.directory = OBJNULL; - obj->pathname.name = OBJNULL; - obj->pathname.type = OBJNULL; - obj->pathname.version = OBJNULL; - break; - case t_bytecodes: - obj->bytecodes.lex = ECL_NIL; - obj->bytecodes.name = ECL_NIL; - obj->bytecodes.definition = ECL_NIL; - obj->bytecodes.specials = ECL_NIL; - obj->bytecodes.code_size = 0; - obj->bytecodes.code = NULL; - obj->bytecodes.data = NULL; - break; - case t_bclosure: - obj->bclosure.code = - obj->bclosure.lex = ECL_NIL; - break; - case t_cfun: - case t_cfunfixed: - obj->cfun.name = OBJNULL; - obj->cfun.block = NULL; - break; - case t_cclosure: - obj->cclosure.env = OBJNULL; - obj->cclosure.block = NULL; - break; -/* - case t_spice: - break; -*/ -#ifdef ECL_THREADS - case t_process: - obj->process.name = OBJNULL; - obj->process.function = OBJNULL; - obj->process.args = OBJNULL; - obj->process.env = NULL; - obj->process.interrupt = OBJNULL; - break; - case t_lock: - obj->lock.mutex = OBJNULL; - case t_condition_variable: - obj->condition_variable.cv = OBJNULL; - break; -#endif -#ifdef ECL_SEMAPHORES - case t_semaphore: - obj->semaphore.handle = NULL; - break; -#endif - case t_instance: - obj->instance.length = 0; - ECL_CLASS_OF(obj) = OBJNULL; - obj->instance.sig = ECL_NIL; - obj->instance.isgf = 0; - obj->instance.slots = NULL; - break; - case t_codeblock: - obj->cblock.locked = 0; - obj->cblock.name = ECL_NIL; - obj->cblock.handle = NULL; - obj->cblock.entry = NULL; - obj->cblock.data = NULL; - obj->cblock.data_size = 0; - obj->cblock.data_text = NULL; - obj->cblock.data_text_size = 0; - obj->cblock.links = ECL_NIL; - obj->cblock.next = ECL_NIL; - break; - case t_foreign: - obj->foreign.tag = ECL_NIL; - obj->foreign.size = 0; - obj->foreign.data = NULL; - break; - default: - printf("\ttype = %d\n", t); - ecl_internal_error("alloc botch."); - } - ecl_enable_interrupts(); - return(obj); -CALL_GC: - ecl_gc(tm->tm_type); - if (tm->tm_nfree != 0 && - (float)tm->tm_nfree * 10.0 >= (float)tm->tm_nused) - goto ONCE_MORE; - -/* EXHAUSTED: */ - if (ignore_maximum_pages) { - if (tm->tm_maxpage/2 <= 0) - tm->tm_maxpage += 1; - else - tm->tm_maxpage += tm->tm_maxpage/2; - goto ONCE_MORE; - } - GC_disable(); - { cl_object s = ecl_make_simple_base_string(tm_table[(int)t].tm_name+1, -1); - GC_enable(); - CEerror(ECL_T, "The storage for ~A is exhausted.~%\ -Currently, ~D pages are allocated.~%\ -Use ALLOCATE to expand the space.", - 2, s, MAKE_FIXNUM(tm->tm_npage)); - } - goto ONCE_MORE; -} - -cl_object -ecl_cons(cl_object a, cl_object d) -{ - register cl_object obj; - register cl_ptr p; - struct typemanager *tm=(&tm_table[(int)t_cons]); - - ecl_disable_interrupts(); - -ONCE_MORE: - obj = tm->tm_free; - if (obj == OBJNULL) { - if (tm->tm_npage >= tm->tm_maxpage) - goto CALL_GC; - if (available_pages() < 1) { - ignore_maximum_pages = FALSE; - goto CALL_GC; - } - p = alloc_page(1); - add_page_to_freelist(p,tm); - obj = tm->tm_free; - if (tm->tm_npage >= tm->tm_maxpage) - goto CALL_GC; - } - tm->tm_free = ((struct freelist *)obj)->f_link; - --(tm->tm_nfree); - (tm->tm_nused)++; - obj->d.t = (short)t_cons; - obj->d.m = FALSE; - obj->cons.car = a; - obj->cons.cdr = d; - - ecl_enable_interrupts(); - return(obj); - -CALL_GC: - ecl_gc(t_cons); - if ((tm->tm_nfree != 0) && (tm->tm_nfree * 10.0 >= tm->tm_nused)) - goto ONCE_MORE; - -/* EXHAUSTED: */ - if (ignore_maximum_pages) { - if (tm->tm_maxpage/2 <= 0) - tm->tm_maxpage += 1; - else - tm->tm_maxpage += tm->tm_maxpage/2; - goto ONCE_MORE; - } - CEerror(ECL_T, "The storage for CONS is exhausted.~%\ -Currently, ~D pages are allocated.~%\ -Use ALLOCATE to expand the space.", - 1, MAKE_FIXNUM(tm->tm_npage)); - goto ONCE_MORE; -#undef tm -} - -cl_object -ecl_alloc_instance(cl_index slots) -{ - cl_object i = ecl_alloc_object(t_instance); - if (slots >= ECL_SLOTS_LIMIT) - FEerror("Limit on instance size exceeded: ~S slots requested.", - 1, MAKE_FIXNUM(slots)); - /* INV: slots > 0 */ - i->instance.slots = (cl_object*)ecl_alloc(sizeof(cl_object) * slots); - i->instance.length = slots; - return i; -} - -void * -ecl_alloc(cl_index n) -{ - volatile cl_ptr p; - struct contblock **cbpp; - cl_index i, m; - bool g; - - g = FALSE; - n = round_up(n); - - ecl_disable_interrupts(); -ONCE_MORE: - /* Use extra indirection so that cb_pointer can be updated */ - for (cbpp = &cb_pointer; (*cbpp) != NULL; cbpp = &(*cbpp)->cb_link) - if ((*cbpp)->cb_size >= n) { - p = (cl_ptr)(*cbpp); - i = (*cbpp)->cb_size - n; - *cbpp = (*cbpp)->cb_link; - --ncb; - cl_dealloc(p+n, i); - - ecl_enable_interrupts(); - return(p); - } - m = round_to_page(n); - if (ncbpage + m > maxcbpage || available_pages() < m) { - if (available_pages() < m) - ignore_maximum_pages = FALSE; - if (!g) { - ecl_gc(t_contiguous); - g = TRUE; - goto ONCE_MORE; - } - if (ignore_maximum_pages) { - if (maxcbpage/2 <= 0) - maxcbpage += 1; - else - maxcbpage += maxcbpage/2; - g = FALSE; - goto ONCE_MORE; - } - CEerror(ECL_T, "Contiguous blocks exhausted.~%\ -Currently, ~D pages are allocated.~%\ -Use ALLOCATE-CONTIGUOUS-PAGES to expand the space.", - 1, MAKE_FIXNUM(ncbpage)); - g = FALSE; - goto ONCE_MORE; - } - p = alloc_page(m); - - for (i = 0; i < m; i++) - type_map[page(p) + i] = (char)t_contiguous; - ncbpage += m; - cl_dealloc(p+n, LISP_PAGESIZE*m - n); - - ecl_enable_interrupts(); - return memset(p, 0, n); -} - -/* - * adds a contblock to the list of available ones, pointed by cb_pointer, - * sorted by increasing size. - */ -void -cl_dealloc(void *p, cl_index s) -{ - struct contblock **cbpp, *cbp; - - if (s < CBMINSIZE) - return; - ncb++; - cbp = (struct contblock *)p; - cbp->cb_size = s; - for (cbpp = &cb_pointer; *cbpp != NULL; cbpp = &((*cbpp)->cb_link)) - if ((*cbpp)->cb_size >= s) { - cbp->cb_link = *cbpp; - *cbpp = cbp; - return; - } - cbp->cb_link = NULL; - *cbpp = cbp; -} - -/* - * align must be a power of 2 representing the alignment boundary - * required for the block. - */ -void * -ecl_alloc_align(cl_index size, cl_index align) -{ - void *output; - ecl_disable_interrupts(); - align--; - if (align) - output = (void*)(((cl_index)ecl_alloc(size + align) + align - 1) & ~align); - else - output = ecl_alloc(size); - ecl_enable_interrupts(); - return output; -} - -static void -init_tm(cl_type t, const char *name, cl_index elsize, cl_index maxpage) -{ - int i, j; - struct typemanager *tm = &tm_table[(int)t]; - - if (elsize < 2*sizeof(cl_index)) { - // A free list cell does not fit into this type - elsize = 2*sizeof(cl_index); - } - - tm->tm_name = name; - for (i = (int)t_start, j = i-1; i < (int)t_end; i++) - if (tm_table[i].tm_size >= elsize && - (j < (int)t_start || tm_table[j].tm_size > tm_table[i].tm_size)) - j = i; - if (j >= (int)t_start) { - tm->tm_type = (cl_type)j; - tm_table[j].tm_maxpage += maxpage; - return; - } - tm->tm_type = t; - tm->tm_size = round_up(elsize); - tm->tm_nppage = LISP_PAGESIZE/round_up(elsize); - tm->tm_free = OBJNULL; - tm->tm_nfree = 0; - tm->tm_nused = 0; - tm->tm_npage = 0; - tm->tm_maxpage = maxpage; - tm->tm_gccount = 0; -} - -static int alloc_initialized = FALSE; - -void -init_alloc(void) -{ - cl_index i; - - if (alloc_initialized) return; - alloc_initialized = TRUE; - - holepage = 0; - new_holepage = HOLEPAGE; - -#ifdef USE_MMAP - real_maxpage = MAXPAGE; -#elif defined(MSDOS) || defined(__CYGWIN__) - real_maxpage = MAXPAGE; -#elif !defined(HAVE_ULIMIT_H) - { - struct rlimit data_rlimit; -# ifdef __MACH__ - sbrk(0); - getrlimit(RLIMIT_DATA, &data_rlimit); - real_maxpage = ((unsigned)get_etext() + - (unsigned)data_rlimit.rlim_cur)/LISP_PAGESIZE; -# else - extern etext; - - getrlimit(RLIMIT_DATA, &data_rlimit); - real_maxpage = ((unsigned int)&etext + - (unsigned)data_rlimit.rlim_cur)/LISP_PAGESIZE; -# endif - if (real_maxpage > MAXPAGE) real_maxpage = MAXPAGE; - } -#else /* HAVE_ULIMIT */ - real_maxpage= ulimit(UL_GMEMLIM)/LISP_PAGESIZE; - if (real_maxpage > MAXPAGE) real_maxpage = MAXPAGE; -#endif /* USE_MMAP, MSDOS, or HAVE_ULIMIT */ - -#ifdef USE_MMAP - heap_start = NULL; -#else - heap_end = sbrk(0); - i = ((cl_index)heap_end) % LISP_PAGESIZE; - if (i) - sbrk(LISP_PAGESIZE - i); - heap_end = heap_start = data_end = sbrk(0); -#endif - cl_resize_hole(INIT_HOLEPAGE); - for (i = 0; i < MAXPAGE; i++) - type_map[i] = (char)t_other; - -/* Initialization must be done in increasing size order: */ - init_tm(t_singlefloat, "FSINGLE-FLOAT", /* 8 */ - sizeof(struct ecl_singlefloat), 1); - init_tm(t_cons, ".CONS", sizeof(struct ecl_cons), 384); /* 12 */ - init_tm(t_doublefloat, "LDOUBLE-FLOAT", /* 16 */ - sizeof(struct ecl_doublefloat), 1); - init_tm(t_bytecodes, "bBYTECODES", sizeof(struct ecl_bytecodes), 64); - init_tm(t_bytecodes, "bBCLOSURE", sizeof(struct ecl_bclosure), 64); - init_tm(t_base_string, "\"BASE-STRING", sizeof(struct ecl_base_string), 64); /* 20 */ -#ifdef ECL_UNICODE - init_tm(t_string, "\"STRING", sizeof(struct ecl_string), 64); -#endif - init_tm(t_array, "aARRAY", sizeof(struct ecl_array), 64); /* 24 */ - init_tm(t_pathname, "pPATHNAME", sizeof(struct ecl_pathname), 1); /* 28 */ - init_tm(t_symbol, "|SYMBOL", sizeof(struct ecl_symbol), 64); /* 32 */ - init_tm(t_package, ":PACKAGE", sizeof(struct ecl_package), 1); /* 36 */ - init_tm(t_codeblock, "#CODEBLOCK", sizeof(struct ecl_codeblock), 1); - init_tm(t_bignum, "BBIGNUM", sizeof(struct ecl_bignum), 16); - init_tm(t_ratio, "RRATIO", sizeof(struct ecl_ratio), 1); - init_tm(t_complex, "CCOMPLEX", sizeof(struct ecl_complex), 1); - init_tm(t_hashtable, "hHASH-TABLE", sizeof(struct ecl_hashtable), 1); - init_tm(t_vector, "vVECTOR", sizeof(struct ecl_vector), 2); - init_tm(t_bitvector, "bBIT-VECTOR", sizeof(struct ecl_vector), 1); - init_tm(t_stream, "sSTREAM", sizeof(struct ecl_stream), 1); - init_tm(t_random, "$RANDOM-STATE", sizeof(struct ecl_random), 1); - init_tm(t_readtable, "rREADTABLE", sizeof(struct ecl_readtable), 1); - init_tm(t_cfun, "fCFUN", sizeof(struct ecl_cfun), 32); - init_tm(t_cfunfixed, "fCFUN", sizeof(struct ecl_cfun), 32); - init_tm(t_cclosure, "cCCLOSURE", sizeof(struct ecl_cclosure), 1); - init_tm(t_instance, "IINSTANCE", sizeof(struct ecl_instance), 32); - init_tm(t_foreign, "LFOREIGN", sizeof(struct ecl_foreign), 1); -#ifdef ECL_THREADS - init_tm(t_process, "tPROCESS", sizeof(struct ecl_process), 2); - init_tm(t_lock, "tLOCK", sizeof(struct ecl_lock), 2); - init_tm(t_condition_variable, "tCONDITION-VARIABLE", - sizeof(struct ecl_condition_variable), 2); -#endif /* THREADS */ -#ifdef ECL_SEMAPHORES - init_tm(t_semaphore, "tSEMAPHORE", - sizeof(struct ecl_semaphore), 2); -#endif -#ifdef ECL_LONG_FLOAT - init_tm(t_longfloat, "tLONGFLOAT", sizeof(struct ecl_long_float), 2); -#endif - - ncb = 0; - ncbpage = 0; - maxcbpage = 2048; - -#ifdef NEED_MALLOC - malloc_list = ECL_NIL; - ecl_register_static_root(&malloc_list); -#endif -} - -static int -t_from_type(cl_object type) -{ int t; - - type = cl_string(type); - for (t = (int)t_start ; t < (int)t_end ; t++) { - struct typemanager *tm = &tm_table[t]; - if (tm->tm_name && - strncmp((tm->tm_name)+1, type->base_string.self, type->base_string.fillp) == 0) - return(t); - } - FEerror("Unrecognized type", 0); -} - -@(defun si::allocate (type qty &optional (now ECL_NIL)) - struct typemanager *tm; - cl_ptr pp; - cl_index i; -@ - tm = tm_of(t_from_type(type)); - i = ecl_to_size(qty); - if (tm->tm_npage > i) i = tm->tm_npage; - tm->tm_maxpage = i; - if (now == ECL_NIL || tm->tm_maxpage <= tm->tm_npage) - @(return ECL_T) - if (available_pages() < tm->tm_maxpage - tm->tm_npage || - (pp = alloc_page(tm->tm_maxpage - tm->tm_npage)) == NULL) - FEerror("Can't allocate ~D pages for ~A.", 2, type, - make_constant_base_string(tm->tm_name+1)); - for (; tm->tm_npage < tm->tm_maxpage; pp += LISP_PAGESIZE) - add_page_to_freelist(pp, tm); - @(return ECL_T) -@) - -@(defun si::maximum-allocatable-pages (type) -@ - @(return MAKE_FIXNUM(tm_of(t_from_type(type))->tm_maxpage)) -@) - -@(defun si::allocated-pages (type) -@ - @(return MAKE_FIXNUM(tm_of(t_from_type(type))->tm_npage)) -@) - -@(defun si::allocate-contiguous-pages (qty &optional (now ECL_NIL)) - cl_index i, m; - cl_ptr p; -@ - i = ecl_to_size(qty); - if (ncbpage > i) - FEerror("Can't set the limit for contiguous blocks to ~D,~%\ -since ~D pages are already allocated.", - 2, qty, MAKE_FIXNUM(ncbpage)); - maxcbpage = i; - if (Null(now)) - @(return ECL_T) - m = maxcbpage - ncbpage; - if (available_pages() < m || (p = alloc_page(m)) == NULL) - FEerror("Can't allocate ~D pages for contiguous blocks.", - 1, qty); - for (i = 0; i < m; i++) - type_map[page(p + LISP_PAGESIZE*i)] = (char)t_contiguous; - ncbpage += m; - cl_dealloc(p, LISP_PAGESIZE*m); - @(return ECL_T) -@) - -@(defun si::allocated-contiguous-pages () -@ - @(return MAKE_FIXNUM(ncbpage)) -@) - -@(defun si::maximum-contiguous-pages () -@ - @(return MAKE_FIXNUM(maxcbpage)) -@) - -@(defun si::get-hole-size () -@ - @(return MAKE_FIXNUM(new_holepage)) -@) - -@(defun si::set-hole-size (size) - cl_index i; -@ - i = ecl_to_size(size); - if (i == 0 || i > available_pages() + new_holepage) - FEerror("Illegal value for the hole size.", 0); - new_holepage = i; - @(return size) -@) - -@(defun si::ignore-maximum-pages (&optional (flag OBJNULL)) -@ - if (flag == OBJNULL) - @(return (ignore_maximum_pages? ECL_T : ECL_NIL)) - ignore_maximum_pages = Null(flag); - @(return flag) -@) - -#ifdef NEED_MALLOC -/* - UNIX malloc simulator. - - Used by - getwd, popen, etc. -*/ - -#undef malloc -#undef calloc -#undef free -#undef cfree -#undef realloc - -void * -malloc(size_t size) -{ - cl_object x; - - if (!GC_enabled() && !alloc_initialized) - init_alloc(); - - x = alloc_simple_base_string(size-1); - x->base_string.self = (char *)ecl_alloc(size); - malloc_list = ecl_cons(x, malloc_list); - return(x->base_string.self); -} - -void -free(void *ptr) -{ - cl_object *p; - - if (ptr) { - for (p = &malloc_list; !ecl_endp(*p); p = &(CDR((*p)))) - if ((CAR((*p)))->base_string.self == ptr) { - cl_dealloc(CAR((*p))->base_string.self, CAR((*p))->base_string.dim+1); - CAR((*p))->base_string.self = NULL; - *p = CDR((*p)); - return; - } - FEerror("free(3) error.", 0); - } -} - -void * -realloc(void *ptr, size_t size) -{ - cl_object x; - size_t i, j; - - if (ptr == NULL) - return malloc(size); - for (x = malloc_list; !ecl_endp(x); x = CDR(x)) - if (CAR(x)->base_string.self == ptr) { - x = CAR(x); - if (x->base_string.dim >= size) { - x->base_string.fillp = size; - return(ptr); - } else { - j = x->base_string.dim; - x->base_string.self = (char *)ecl_alloc(size); - x->base_string.fillp = x->base_string.dim = size; - memcpy(x->base_string.self, ptr, j); - cl_dealloc(ptr, j); - return(x->base_string.self); - } - } - FEerror("realloc(3) error.", 0); -} - -void * -calloc(size_t nelem, size_t elsize) -{ - char *ptr; - size_t i = nelem*elsize; - ptr = malloc(i); - memset(ptr, 0 , i); - return(ptr); -} - -void cfree(void *ptr) -{ - free(ptr); -} - -/* make f allocate enough extra, so that we can round - up, the address given to an even multiple. Special - case of size == 0 , in which case we just want an aligned - number in the address range - */ - -#define ALLOC_ALIGNED(f, size, align) \ - ((align) <= 4 ? (int)(f)(size) : \ - ((align) * (((unsigned)(f)(size + (size ? (align) - 1 : 0)) + (align) - 1)/(align)))) - -void * -memalign(size_t align, size_t size) -{ cl_object x = alloc_simple_base_string(size); - malloc_list = ecl_cons(x, malloc_list); - return x->base_string.self; -} - -# ifdef WANT_VALLOC -char * -valloc(size_t size) -{ return memalign(getpagesize(), size);} -# endif /* WANT_VALLOC */ -#endif /* NEED_MALLOC */ diff -Nru ecl-16.1.2/src/c/all_symbols.d ecl-16.1.3+ds/src/c/all_symbols.d --- ecl-16.1.2/src/c/all_symbols.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/all_symbols.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,5 +1,5 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ #include #include @@ -48,217 +48,224 @@ static unsigned char * mangle_name(cl_object output, unsigned char *source, int l) { - unsigned char c; + unsigned char c; - while (l--) { - c = *(source++); - if (ecl_alphanumericp(c)) { - c = ecl_char_downcase(c); - } else if (c == '-' || c == '_') { - c = '_'; - } else if (c == '&') { - c = 'A'; - } else if (c == '*') { - c = 'X'; - } else if (c == '+') { - c = 'P'; - } else if (c == '<') { - c = 'L'; - } else if (c == '>') { - c = 'G'; - } else if (c == '=') { - c = 'E'; - } else if (c == '/') { - c = 'N'; - } else if (c == ':') { - c = 'X'; - } else { - return NULL; - } - output->base_string.self[output->base_string.fillp++] = c; - } - return &output->base_string.self[output->base_string.fillp]; + while (l--) { + c = *(source++); + if (ecl_alphanumericp(c)) { + c = ecl_char_downcase(c); + } else if (c == '-' || c == '_') { + c = '_'; + } else if (c == '&') { + c = 'A'; + } else if (c == '*') { + c = 'X'; + } else if (c == '+') { + c = 'P'; + } else if (c == '<') { + c = 'L'; + } else if (c == '>') { + c = 'G'; + } else if (c == '=') { + c = 'E'; + } else if (c == '/') { + c = 'N'; + } else if (c == ':') { + c = 'X'; + } else { + return NULL; + } + output->base_string.self[output->base_string.fillp++] = c; + } + return &output->base_string.self[output->base_string.fillp]; } @(defun si::mangle-name (symbol &optional as_function) - cl_index l; - unsigned char c, *source, *dest; - cl_object output; - cl_object package; - cl_object found = ECL_NIL; - cl_object maxarg = ecl_make_fixnum(ECL_CALL_ARGUMENTS_LIMIT); - cl_object minarg = ecl_make_fixnum(0); - bool is_symbol; - cl_object name; + cl_index l; + unsigned char c, *source, *dest; + cl_object output; + cl_object package; + cl_object found = ECL_NIL; + cl_object maxarg = ecl_make_fixnum(ECL_CALL_ARGUMENTS_LIMIT); + cl_object minarg = ecl_make_fixnum(0); + bool is_symbol; + cl_object name; @ - name = ecl_symbol_name(symbol); - is_symbol = Null(as_function); - if (is_symbol) { - cl_fixnum p; - if (symbol == ECL_NIL) - @(return ECL_T make_constant_base_string("ECL_NIL")) - else if (symbol == ECL_T) - @(return ECL_T make_constant_base_string("ECL_T")) - p = (cl_symbol_initializer*)symbol - cl_symbols; - if (p >= 0 && p <= cl_num_symbols_in_core) { - found = ECL_T; - output = cl_format(4, ECL_NIL, - make_constant_base_string("ECL_SYM(~S,~D)"), - name, ecl_make_fixnum(p)); - @(return found output maxarg) - } - } else if (!Null(symbol)) { - cl_object fun = symbol->symbol.gfdef; - cl_type t = (fun == OBJNULL)? t_other : type_of(fun); - if ((t == t_cfun || t == t_cfunfixed) && fun->cfun.block == OBJNULL) { - for (l = 0; l <= cl_num_symbols_in_core; l++) { - cl_object s = (cl_object)(cl_symbols + l); - if (fun == ECL_SYM_FUN(s)) { - symbol = s; - found = ECL_T; - if (fun->cfun.narg >= 0) { - minarg = - maxarg = ecl_make_fixnum(fun->cfun.narg); - } - break; - } - } - } - } - package = ecl_symbol_package(symbol); - if (Null(package)) - ; - else if (package == cl_core.lisp_package) - package = make_constant_base_string("cl"); - else if (package == cl_core.system_package) - package = make_constant_base_string("si"); - else if (package == cl_core.ext_package) - package = make_constant_base_string("si"); - else if (package == cl_core.keyword_package) - package = ECL_NIL; - else - package = package->pack.name; - symbol = ecl_symbol_name(symbol); - l = symbol->base_string.fillp; - source = symbol->base_string.self; - output = ecl_alloc_simple_base_string(ecl_length(package) + l + 1); - if (is_symbol && source[0] == '*') { - if (l > 2 && source[l-1] == '*') l--; - c = 'V'; - l--; - source++; - } else if (is_symbol && l > 2 && source[0] == '+' && source[l-1] == '+') { - c = 'C'; - l-= 2; - source++; - } else if (!is_symbol) { - c = '_'; - } else if (package == cl_core.keyword_package) { - c = 'K'; - } else { - c = 'S'; + name = ecl_symbol_name(symbol); + is_symbol = Null(as_function); + if (is_symbol) { + cl_fixnum p; + if (symbol == ECL_NIL) { + @(return ECL_T make_constant_base_string("ECL_NIL")); + } + else if (symbol == ECL_T) { + @(return ECL_T make_constant_base_string("ECL_T")); + } + + p = (cl_symbol_initializer*)symbol - cl_symbols; + if (p >= 0 && p <= cl_num_symbols_in_core) { + found = ECL_T; + output = cl_format(4, ECL_NIL, + make_constant_base_string("ECL_SYM(~S,~D)"), + name, ecl_make_fixnum(p)); + @(return found output maxarg); + } + } else if (!Null(symbol)) { + cl_object fun = symbol->symbol.gfdef; + cl_type t = (fun == OBJNULL)? t_other : type_of(fun); + if ((t == t_cfun || t == t_cfunfixed) && fun->cfun.block == OBJNULL) { + for (l = 0; l <= cl_num_symbols_in_core; l++) { + cl_object s = (cl_object)(cl_symbols + l); + if (fun == ECL_SYM_FUN(s)) { + symbol = s; + found = ECL_T; + if (fun->cfun.narg >= 0) { + minarg = + maxarg = ecl_make_fixnum(fun->cfun.narg); + } + break; } - output->base_string.fillp = 0; - if (!Null(package)) - if (!mangle_name(output, package->base_string.self, package->base_string.fillp)) - @(return ECL_NIL ECL_NIL maxarg) - output->base_string.self[output->base_string.fillp++] = c; - if (!(dest = mangle_name(output, source, l))) - @(return ECL_NIL ECL_NIL maxarg) - if (dest[-1] == '_') - dest[-1] = 'M'; - *(dest++) = '\0'; - @(return found output minarg maxarg) + } + } + } + package = ecl_symbol_package(symbol); + if (Null(package)) { + ; + } + else if (package == cl_core.lisp_package) + package = make_constant_base_string("cl"); + else if (package == cl_core.system_package) + package = make_constant_base_string("si"); + else if (package == cl_core.ext_package) + package = make_constant_base_string("si"); + else if (package == cl_core.keyword_package) + package = ECL_NIL; + else + package = package->pack.name; + symbol = ecl_symbol_name(symbol); + l = symbol->base_string.fillp; + source = symbol->base_string.self; + output = ecl_alloc_simple_base_string(ecl_length(package) + l + 1); + if (is_symbol && source[0] == '*') { + if (l > 2 && source[l-1] == '*') l--; + c = 'V'; + l--; + source++; + } else if (is_symbol && l > 2 && source[0] == '+' && source[l-1] == '+') { + c = 'C'; + l-= 2; + source++; + } else if (!is_symbol) { + c = '_'; + } else if (package == cl_core.keyword_package) { + c = 'K'; + } else { + c = 'S'; + } + output->base_string.fillp = 0; + if (!Null(package)) { + if (!mangle_name(output, package->base_string.self, package->base_string.fillp)) { + @(return ECL_NIL ECL_NIL maxarg); + } + } + output->base_string.self[output->base_string.fillp++] = c; + if (!(dest = mangle_name(output, source, l))) { + @(return ECL_NIL ECL_NIL maxarg); + } + if (dest[-1] == '_') + dest[-1] = 'M'; + *(dest++) = '\0'; + @(return found output minarg maxarg); @) static void make_this_symbol(int i, cl_object s, int code, const char *name, cl_objectfn fun, int narg, cl_object value) { - enum ecl_stype stp; - cl_object package; - bool form = 0; - - switch (code & 3) { - case ORDINARY_SYMBOL: stp = ecl_stp_ordinary; break; - case SPECIAL_SYMBOL: stp = ecl_stp_special; break; - case CONSTANT_SYMBOL: stp = ecl_stp_constant; break; - case FORM_SYMBOL: form = 1; stp = ecl_stp_ordinary; - } - switch (code & 0xfc) { - case CL_PACKAGE: package = cl_core.lisp_package; break; - case SI_PACKAGE: package = cl_core.system_package; break; - case EXT_PACKAGE: package = cl_core.ext_package; break; - case KEYWORD_PACKAGE: package = cl_core.keyword_package; break; - case MP_PACKAGE: package = cl_core.mp_package; break; - case CLOS_PACKAGE: package = cl_core.clos_package; break; + enum ecl_stype stp; + cl_object package; + bool form = 0; + + switch (code & 3) { + case ORDINARY_SYMBOL: stp = ecl_stp_ordinary; break; + case SPECIAL_SYMBOL: stp = ecl_stp_special; break; + case CONSTANT_SYMBOL: stp = ecl_stp_constant; break; + case FORM_SYMBOL: form = 1; stp = ecl_stp_ordinary; + } + switch (code & 0xfc) { + case CL_PACKAGE: package = cl_core.lisp_package; break; + case SI_PACKAGE: package = cl_core.system_package; break; + case EXT_PACKAGE: package = cl_core.ext_package; break; + case KEYWORD_PACKAGE: package = cl_core.keyword_package; break; + case MP_PACKAGE: package = cl_core.mp_package; break; + case CLOS_PACKAGE: package = cl_core.clos_package; break; #ifdef ECL_CLOS_STREAMS - case GRAY_PACKAGE: package = cl_core.gray_package; break; + case GRAY_PACKAGE: package = cl_core.gray_package; break; #endif - case FFI_PACKAGE: package = cl_core.ffi_package; break; - default: printf("%d\n", code & ~(int)3); ecl_internal_error("Unknown package code in init_all_symbols()"); - } - s->symbol.t = t_symbol; - s->symbol.dynamic = 0; + case FFI_PACKAGE: package = cl_core.ffi_package; break; + default: printf("%d\n", code & ~(int)3); ecl_internal_error("Unknown package code in init_all_symbols()"); + } + s->symbol.t = t_symbol; + s->symbol.dynamic = 0; #ifdef ECL_THREADS - s->symbol.binding = ECL_MISSING_SPECIAL_BINDING; + s->symbol.binding = ECL_MISSING_SPECIAL_BINDING; #endif - ECL_SET(s, OBJNULL); - ECL_SYM_FUN(s) = ECL_NIL; - s->symbol.plist = ECL_NIL; - s->symbol.hpack = ECL_NIL; - s->symbol.stype = stp; - s->symbol.hpack = package; - s->symbol.name = make_constant_base_string(name); - if (package == cl_core.keyword_package) { - package->pack.external = - _ecl_sethash(s->symbol.name, package->pack.external, s); - ECL_SET(s, s); - } else { - int intern_flag; - ECL_SET(s, value); - if (ecl_find_symbol(s->symbol.name, package, &intern_flag) != ECL_NIL - && intern_flag == ECL_INHERITED) { - ecl_shadowing_import(s, package); - } else { - cl_import2(s, package); - } - if (!(code & PRIVATE)) { - cl_export2(s, package); - if (package == cl_core.ext_package) - cl_export2(s, cl_core.system_package); - } - } - if (form) { - s->symbol.stype |= ecl_stp_special_form; - } else if (fun) { - cl_object f; - if (narg >= 0) { - f = ecl_make_cfun((cl_objectfn_fixed)fun, s, NULL, narg); - } else { - f = ecl_make_cfun_va(fun, s, NULL); - } - ECL_SYM_FUN(s) = f; - } - cl_num_symbols_in_core = i + 1; + ECL_SET(s, OBJNULL); + ECL_SYM_FUN(s) = ECL_NIL; + s->symbol.plist = ECL_NIL; + s->symbol.hpack = ECL_NIL; + s->symbol.stype = stp; + s->symbol.hpack = package; + s->symbol.name = make_constant_base_string(name); + if (package == cl_core.keyword_package) { + package->pack.external = + _ecl_sethash(s->symbol.name, package->pack.external, s); + ECL_SET(s, s); + } else { + int intern_flag; + ECL_SET(s, value); + if (ecl_find_symbol(s->symbol.name, package, &intern_flag) != ECL_NIL + && intern_flag == ECL_INHERITED) { + ecl_shadowing_import(s, package); + } else { + cl_import2(s, package); + } + if (!(code & PRIVATE)) { + cl_export2(s, package); + if (package == cl_core.ext_package) + cl_export2(s, cl_core.system_package); + } + } + if (form) { + s->symbol.stype |= ecl_stp_special_form; + } else if (fun) { + cl_object f; + if (narg >= 0) { + f = ecl_make_cfun((cl_objectfn_fixed)fun, s, NULL, narg); + } else { + f = ecl_make_cfun_va(fun, s, NULL); + } + ECL_SYM_FUN(s) = f; + } + cl_num_symbols_in_core = i + 1; } void init_all_symbols(void) { - int i, code, narg; - const char *name; - cl_object s, value; - cl_objectfn fun; - - /* We skip NIL and T */ - for (i = 2; cl_symbols[i].init.name != NULL; i++) { - s = (cl_object)(cl_symbols + i); - code = cl_symbols[i].init.type; - name = cl_symbols[i].init.name; - fun = (cl_objectfn)cl_symbols[i].init.fun; - narg = cl_symbols[i].init.narg; - value = cl_symbols[i].init.value; - make_this_symbol(i, s, code, name, fun, narg, value); - } + int i, code, narg; + const char *name; + cl_object s, value; + cl_objectfn fun; + + /* We skip NIL and T */ + for (i = 2; cl_symbols[i].init.name != NULL; i++) { + s = (cl_object)(cl_symbols + i); + code = cl_symbols[i].init.type; + name = cl_symbols[i].init.name; + fun = (cl_objectfn)cl_symbols[i].init.fun; + narg = cl_symbols[i].init.narg; + value = cl_symbols[i].init.value; + make_this_symbol(i, s, code, name, fun, narg, value); + } } diff -Nru ecl-16.1.2/src/c/apply.d ecl-16.1.3+ds/src/c/apply.d --- ecl-16.1.2/src/c/apply.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/apply.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,15 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - apply.c -- Interface to C call mechanism. -*/ -/* - Copyright (c) 1993, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ - + * apply.c - interface to C call mechanism + * + * Copyright (c) 1993 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include @@ -34,314 +28,314 @@ case 7: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6]); case 8: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7]); case 9: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8]); + x[8]); case 10: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9]); + x[8],x[9]); case 11: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10]); + x[8],x[9],x[10]); case 12: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11]); + x[8],x[9],x[10],x[11]); case 13: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12]); + x[8],x[9],x[10],x[11],x[12]); case 14: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13]); + x[8],x[9],x[10],x[11],x[12],x[13]); case 15: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14]); case 16: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15]); case 17: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16]); case 18: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17]); case 19: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18]); case 20: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19]); case 21: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20]); case 22: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21]); case 23: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22]); case 24: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23]); case 25: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24]); case 26: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25]); case 27: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26]); case 28: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27]); case 29: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28]); case 30: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29]); case 31: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30]); case 32: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31]); case 33: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32]); case 34: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33]); case 35: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34]); case 36: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35]); case 37: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36]); case 38: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37]); case 39: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38]); case 40: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39]); case 41: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40]); case 42: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41]); case 43: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42]); case 44: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43]); case 45: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44]); case 46: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45]); case 47: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46]); case 48: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47]); case 49: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48]); case 50: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49]); case 51: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50]); case 52: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51]); case 53: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52]); case 54: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53]); case 55: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54]); case 56: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55]); case 57: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56]); case 58: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57]); case 59: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57],x[58]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58]); case 60: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57],x[58],x[59]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58],x[59]); case 61: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57],x[58],x[59],x[60]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58],x[59],x[60]); case 62: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57],x[58],x[59],x[60],x[61]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58],x[59],x[60],x[61]); case 63: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57],x[58],x[59],x[60],x[61],x[62]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58],x[59],x[60],x[61],x[62]); default: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57],x[58],x[59],x[60],x[61],x[62],x[63]); - /* Arguments above 64 have been pushed on the stack */ + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58],x[59],x[60],x[61],x[62],x[63]); + /* Arguments above 64 have been pushed on the stack */ } } @@ -359,315 +353,315 @@ case 7: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6]); case 8: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7]); case 9: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8]); + x[8]); case 10: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9]); + x[8],x[9]); case 11: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10]); + x[8],x[9],x[10]); case 12: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11]); + x[8],x[9],x[10],x[11]); case 13: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12]); + x[8],x[9],x[10],x[11],x[12]); case 14: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13]); + x[8],x[9],x[10],x[11],x[12],x[13]); case 15: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14]); case 16: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15]); case 17: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16]); case 18: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17]); case 19: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18]); case 20: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19]); case 21: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20]); case 22: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21]); case 23: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22]); case 24: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23]); case 25: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24]); case 26: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25]); case 27: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26]); case 28: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27]); case 29: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28]); case 30: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29]); case 31: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30]); case 32: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31]); case 33: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32]); case 34: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33]); case 35: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34]); case 36: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35]); case 37: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36]); case 38: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37]); case 39: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38]); case 40: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39]); case 41: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40]); case 42: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41]); case 43: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42]); case 44: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43]); case 45: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44]); case 46: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45]); case 47: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46]); case 48: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47]); case 49: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48]); case 50: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49]); case 51: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50]); case 52: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51]); case 53: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52]); case 54: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53]); case 55: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54]); case 56: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55]); case 57: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56]); case 58: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57]); case 59: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57],x[58]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58]); case 60: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57],x[58],x[59]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58],x[59]); case 61: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57],x[58],x[59],x[60]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58],x[59],x[60]); case 62: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57],x[58],x[59],x[60],x[61]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58],x[59],x[60],x[61]); case 63: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57],x[58],x[59],x[60],x[61],x[62]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58],x[59],x[60],x[61],x[62]); case 64: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57],x[58],x[59],x[60],x[61],x[62],x[63]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58],x[59],x[60],x[61],x[62],x[63]); default: - FEprogram_error_noreturn("Too many arguments", 0); + FEprogram_error_noreturn("Too many arguments", 0); } } #endif diff -Nru ecl-16.1.2/src/c/arch/apply_x86.d ecl-16.1.3+ds/src/c/arch/apply_x86.d --- ecl-16.1.2/src/c/arch/apply_x86.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/arch/apply_x86.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,109 +1,103 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - apply.c -- Interface to C call mechanism. -*/ -/* - Copyright (c) 2008, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ - + * apply.c - interface to C call mechanism (x86 specific) + * + * Copyright (c) 2008 Giuseppe Attardi + * + * See file 'LICENSE' for the copyright details. + * + */ #include cl_object APPLY(cl_narg n, cl_objectfn fn, cl_object *x) { - cl_object output; - asm volatile ( - "movl 4(%%ebp),%%edx\n\t" /* Create a fake frame for debugger */ - "pushl %%edx\n\t" - "pushl %%ebp\n\t" - "movl %%ecx, %%edx\n\t" - "cmpl $63, %%ecx\n\t" /* Copy at most 63 arguments onto the stack */ - "jle FOO1\n\t" - "movl $63, %%ecx\n\t" -"FOO1:\n\t" /* Here we compute the new address of the stack pointer */ - "movl %%esp, %%ebp\n\t" /* using the formula ESP = (ESP - ECX*4 - 4) & -16 */ - "negl %%ecx\n\t" /* which rounds ESP making it a multiple of 16 bytes. */ - "leal -4(%%esp,%%ecx,4), %%esp\n\t" - "andl $-16, %%esp\n\t" - "movl %%edx, (%%esp)\n\t" /* Then ESP[0] is the number of arguments */ - "negl %%ecx\n\t" - "leal 4(%%esp), %%edi\n\t" /* and the other arguments are copied from ESP[4] on */ - "rep\n\t" - "movsl\n\t" - "call *%%eax\n\t" /* At this point the stack must be aligned */ - "movl %%ebp, %%esp\n\t" - "popl %%ebp\n\t" - "popl %%edx\n\t" - : "=a" (output) : "c" (n), "a" (fn), "S" (x) : "%edx", "%edi"); - return output; + cl_object output; + asm volatile ( + "movl 4(%%ebp),%%edx\n\t" /* Create a fake frame for debugger */ + "pushl %%edx\n\t" + "pushl %%ebp\n\t" + "movl %%ecx, %%edx\n\t" + "cmpl $63, %%ecx\n\t" /* Copy at most 63 arguments onto the stack */ + "jle FOO1\n\t" + "movl $63, %%ecx\n\t" +"FOO1:\n\t" /* Here we compute the new address of the stack pointer */ + "movl %%esp, %%ebp\n\t" /* using the formula ESP = (ESP - ECX*4 - 4) & -16 */ + "negl %%ecx\n\t" /* which rounds ESP making it a multiple of 16 bytes. */ + "leal -4(%%esp,%%ecx,4), %%esp\n\t" + "andl $-16, %%esp\n\t" + "movl %%edx, (%%esp)\n\t" /* Then ESP[0] is the number of arguments */ + "negl %%ecx\n\t" + "leal 4(%%esp), %%edi\n\t" /* and the other arguments are copied from ESP[4] on */ + "rep\n\t" + "movsl\n\t" + "call *%%eax\n\t" /* At this point the stack must be aligned */ + "movl %%ebp, %%esp\n\t" + "popl %%ebp\n\t" + "popl %%edx\n\t" + : "=a" (output) : "c" (n), "a" (fn), "S" (x) : "%edx", "%edi"); + return output; } cl_object APPLY_fixed(cl_narg n, cl_object (*fn)(), cl_object *x) { - cl_object output; - asm volatile ( - "movl 4(%%ebp),%%edx\n\t" /* Create a fake frame for debugger */ - "pushl %%edx\n\t" - "pushl %%ebp\n\t" - "movl %%ecx, %%edx\n\t" /* Copy at most 63 arguments onto the stack */ - "cmpl $63, %%ecx\n\t" - "jle FOO2\n\t" - "movl $63, %%ecx\n" -"FOO2:\n\t" /* Here we compute the new address of the stack pointer */ - "movl %%esp, %%ebp\n\t" /* using the formula ESP = (ESP - ECX*4) & -16 */ - "negl %%ecx\n\t" /* which rounds ESP making it a multiple of 16 bytes. */ - "leal (%%esp,%%ecx,4), %%esp\n\t" - "andl $-16, %%esp\n\t" - "negl %%ecx\n\t" - "movl %%esp, %%edi\n\t" /* then the arguments are copied from ESP[0] on */ - "rep\n\t" - "movsl\n\t" - "call *%%eax\n\t" /* At this point the stack must be aligned */ - "movl %%ebp, %%esp\n\t" - "popl %%ebp\n\t" - "popl %%edx\n\t" - : "=a" (output) : "c" (n), "a" (fn), "S" (x) : "%edx", "%edi"); - return output; + cl_object output; + asm volatile ( + "movl 4(%%ebp),%%edx\n\t" /* Create a fake frame for debugger */ + "pushl %%edx\n\t" + "pushl %%ebp\n\t" + "movl %%ecx, %%edx\n\t" /* Copy at most 63 arguments onto the stack */ + "cmpl $63, %%ecx\n\t" + "jle FOO2\n\t" + "movl $63, %%ecx\n" +"FOO2:\n\t" /* Here we compute the new address of the stack pointer */ + "movl %%esp, %%ebp\n\t" /* using the formula ESP = (ESP - ECX*4) & -16 */ + "negl %%ecx\n\t" /* which rounds ESP making it a multiple of 16 bytes. */ + "leal (%%esp,%%ecx,4), %%esp\n\t" + "andl $-16, %%esp\n\t" + "negl %%ecx\n\t" + "movl %%esp, %%edi\n\t" /* then the arguments are copied from ESP[0] on */ + "rep\n\t" + "movsl\n\t" + "call *%%eax\n\t" /* At this point the stack must be aligned */ + "movl %%ebp, %%esp\n\t" + "popl %%ebp\n\t" + "popl %%edx\n\t" + : "=a" (output) : "c" (n), "a" (fn), "S" (x) : "%edx", "%edi"); + return output; } cl_object APPLY_closure(cl_narg n, cl_objectfn fn, cl_object cl, cl_object *x) { - cl_object output; - asm volatile ( - "movl 4(%%ebp),%%edx\n\t" /* Create a fake frame for debugger */ - "pushl %%edx\n\t" - "pushl %%ebp\n\t" - "movl %%ecx, %%edx\n\t" - "cmpl $63, %%ecx\n\t" /* Copy at most 63 arguments onto the stack */ - "jle FOO3\n\t" - "movl $63, %%ecx\n\t" -"FOO3:\n\t" /* Here we compute the new address of the stack pointer */ - "movl %%esp, %%ebp\n\t" /* using the formula ESP = (ESP - ECX*4 - 8) & -16 */ - "negl %%ecx\n\t" /* which rounds ESP making it a multiple of 16 bytes. */ - "leal -8(%%esp,%%ecx,4), %%esp\n\t" - "andl $-16, %%esp\n\t" - "movl %%edx, (%%esp)\n\t" /* Then ESP[0] is the number of arguments */ - "movl %%edi, 4(%%esp)\n\t" /* ESP[4] is the closure environment */ - "negl %%ecx\n\t" - "leal 8(%%esp), %%edi\n\t" /* and the other arguments are copied from ESP[8] on */ - "rep\n\t" - "movsl\n\t" - "call *%%eax\n\t" /* At this point the stack must be aligned */ - "movl %%ebp, %%esp\n\t" - "popl %%ebp\n\t" - "popl %%edx\n\t" - : "=a" (output) : "c" (n), "a" (fn), "S" (x), "D" (cl) : "%edx"); - return output; + cl_object output; + asm volatile ( + "movl 4(%%ebp),%%edx\n\t" /* Create a fake frame for debugger */ + "pushl %%edx\n\t" + "pushl %%ebp\n\t" + "movl %%ecx, %%edx\n\t" + "cmpl $63, %%ecx\n\t" /* Copy at most 63 arguments onto the stack */ + "jle FOO3\n\t" + "movl $63, %%ecx\n\t" +"FOO3:\n\t" /* Here we compute the new address of the stack pointer */ + "movl %%esp, %%ebp\n\t" /* using the formula ESP = (ESP - ECX*4 - 8) & -16 */ + "negl %%ecx\n\t" /* which rounds ESP making it a multiple of 16 bytes. */ + "leal -8(%%esp,%%ecx,4), %%esp\n\t" + "andl $-16, %%esp\n\t" + "movl %%edx, (%%esp)\n\t" /* Then ESP[0] is the number of arguments */ + "movl %%edi, 4(%%esp)\n\t" /* ESP[4] is the closure environment */ + "negl %%ecx\n\t" + "leal 8(%%esp), %%edi\n\t" /* and the other arguments are copied from ESP[8] on */ + "rep\n\t" + "movsl\n\t" + "call *%%eax\n\t" /* At this point the stack must be aligned */ + "movl %%ebp, %%esp\n\t" + "popl %%ebp\n\t" + "popl %%edx\n\t" + : "=a" (output) : "c" (n), "a" (fn), "S" (x), "D" (cl) : "%edx"); + return output; } diff -Nru ecl-16.1.2/src/c/arch/ffi_ppc32.d ecl-16.1.3+ds/src/c/arch/ffi_ppc32.d --- ecl-16.1.2/src/c/arch/ffi_ppc32.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/arch/ffi_ppc32.d 1970-01-01 00:00:00.000000000 +0000 @@ -1,215 +0,0 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ - -/* - ffi_x86.c -- Nonportable component of the FFI -*/ -/* - Copyright (c) 2005, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ - -#include -#include -#include - -#error "This file is a placeholder for current development" - -/* - * Calling conventions for OS X under PowerPC/32bit architecture. The rules are - * as follows: - * - * - Registers GPR3-GPR10 are used to pass 32-bit arguments. This includes - * integers and composed data structures which fit in the registers. - * - Registers FPR1-FPR13 are used to pass float and double arguments. - * - For each argument passed in a register, the same amount of memory is - * reserved in the stack. - * - When the amount of registers is exhausted, the remaining arguments are - * passed in the stack. - * - There is a difference between functions whose signature is known and those - * whose is not. In the second case, when passing float/double arguments, - * they are passed redundantly using a GPR, a FPR and the stack. In the - * former case, only the FPR or the stack is used. - * - Since we do not allow functions with varargs (i.e "..." in C parlance), we - * do not care about the last case. - * - * Since we do not allow passing or receiving structures, we need not care - * about it and the only rule is: - * - * - Returns arguments <= 32 bits are stored in GPR3 - * - Returns arguments <= 64 bits are shared between GPR3 and GPR4, for high - * and low bits, respectively. - * - Floating point values are returned in FPR1. - * - * This information appears in "Mac OS X ABI Function Call Guide", from Apple - * Developer's Documentation (April 2006). - */ - -#define MAX_INT_REGISTERS 8 -#define MAX_FP_REGISTERS 13 - -struct ecl_fficall_reg { - long int registers[MAX_INT_REGISTERS]; - int int_registers_size; - double fp_registers[MAX_FP_REGISTERS]; - int fp_registers_size; -}; - -struct ecl_fficall_reg * -ecl_fficall_prepare_extra(struct ecl_fficall_reg *registers) -{ - if (registers == 0) { - registers = (struct ecl_fficall_reg *)cl_alloc_atomic(sizeof(*registers)); - } - registers->int_registers_size = 0; - registers->fp_registers_size = 0; -} - -void -ecl_fficall_push_arg(union ecl_ffi_values *data, enum ecl_ffi_tag type) -{ - long i; - struct ecl_fficall *fficall = cl_env.fficall; - struct ecl_fficall_reg *registers = cl_env.fficall->registers; - switch (type) { - case ECL_FFI_CHAR: i = data->c; goto INT; - case ECL_FFI_UNSIGNED_CHAR: i = data->uc; goto INT; - case ECL_FFI_BYTE: i = data->b; goto INT; - case ECL_FFI_UNSIGNED_BYTE: i = data->ub; goto INT; - case ECL_FFI_SHORT: i = data->s; goto INT; - case ECL_FFI_UNSIGNED_SHORT: i = data->us; goto INT; - case ECL_FFI_INT: i = data->i; goto INT; - case ECL_FFI_UNSIGNED_INT: i = data->ui; goto INT; - case ECL_FFI_LONG: - case ECL_FFI_UNSIGNED_LONG: - case ECL_FFI_POINTER_VOID: - case ECL_FFI_CSTRING: - case ECL_FFI_OBJECT: - i = data->l; - INT: - if (registers->int_registers_size < MAX_INT_REGISTERS) { - registers->registers[registers->int_registers_size++] = i; - } - ecl_fficall_align(sizeof(long)); - ecl_fficall_push_bytes(&i, sizeof(long)); - break; - case ECL_FFI_DOUBLE: - if (registers->fp_registers_size < MAX_FP_REGISTERS) { - registers->fp_registers[registers->fp_registers_size++] = data->d; - registers->int_registers_size += 2; - } - ecl_fficall_align(sizeof(long)); - ecl_fficall_push_bytes(&data->d, sizeof(double), sizeof(long)); - break; - case ECL_FFI_FLOAT: - if (registers->fp_registers_size < MAX_FP_REGISTERS) { - registers->fp_registers[registers->fp_registers_size++] = data->f; - registers->int_registers_size++; - } - ecl_fficall_align(sizeof(long)); - ecl_fficall_push_bytes(&data->f, sizeof(float), sizeof(long)); - break; - case ECL_FFI_VOID: - FEerror("VOID is not a valid argument type for a C function", 0); - } -} - -static void -ecl_fficall_do_execute(cl_index buf_size, void *stack, void *gpr, void *gpfr, void *f) -{ -} - -void -ecl_fficall_execute(void *_f_ptr, struct ecl_fficall *fficall, enum ecl_ffi_tag return_type) -{ - struct ecl_fficall_reg *registers = fficall->registers; - long bufsize = fficall->buffer_size; - char* buf = fficall->buffer; - - asm volatile ( - "mr r5,%[bufsize]\n\t" /* r5 = size of stack */ - "mr r6,%[buf]\n\t" /* r6 = origin of stack data */ - "mr r17,%[registers]\n\t" /* r17 = origin of integer registers */ - "mr r16,%[fp_registers]\n\t"/* r16 = origin of fp registers */ - "mr r15,%[fptr]\n\t" /* r15 = _f_ptr */ - "mr r29, r1\n\t" /* r29 saves r1 */ - - "subf r13,r5,r1\n\t" - "stwu r13,-80(r13)\n\t" /* r13 <- r1 - r5 - 80 */ - "mflr r0\n\t" - "stw r0,8(r1)\n\t" - "mr r1,r13\n\t" /* r1 <- r13 */ - - "stwu r14,24(r1)\n\t" /* r14 <- begin of parameters */ - "cmpwi cr0,r5,0\n\t" /* copy r5 bytes from (r6) to (r14) */ - "ble cr0,L3\n\t" - "mtctr r5\n" -"LX: lbz r0,0(r6)\n\t" - "addi r6,r6,1\n\t" - "stb r0,0(r14)\n\t" - "addi r14,r14,1\n" -"L3: lfd f1, 0(r16)\n\t" /* load fp registers from (r16) */ - "lfd f2, 8(r16)\n\t" - "lfd f3, 16(r16)\n\t" - "lfd f4, 24(r16)\n\t" - "lfd f5, 32(r16)\n\t" - "lfd f6, 40(r16)\n\t" - "lfd f7, 48(r16)\n\t" - "lfd f8, 56(r16)\n\t" - "lfd f9, 64(r16)\n\t" - "lfd f10, 72(r16)\n\t" - "lfd f11, 80(r16)\n\t" - "lfd f12, 88(r16)\n\t" - "lfd f13, 96(r16)\n\t" - - "lwz r6, 16(r17)\n\t" /* load int registers from (r17) */ - "lwz r7, 20(r17)\n\t" - "lwz r8, 24(r17)\n\t" - "lwz r9, 28(r17)\n\t" - "lwz r10, 32(r17)\n\t" - "lwz r5, 8(r17)\n\t" - "lwz r4, 4(r17)\n\t" - "lwz r3, 0(r17)\n\t" - - "mtctr r15\n\t" /* call the function stored in r15 */ - "bctrl \n\t" - "mr r1,r29\n\t" /* restore stack and return pointer */ - "lwz r0,8(r1)\n\t" - "mtlr r0\n\t" - "stw r3,0(r17)\n\t" /* store function's output */ - "stw r4,4(r17)\n\t" - "stfd f1,0(r16)\n\t" - - :: [bufsize] "r" (bufsize), [buf] "r" (buf), [registers] "r" (registers->registers), - [fp_registers] "r" (registers->fp_registers), [fptr] "r" (_f_ptr) - : "r5","r6","r17","r16","r29","r13","r14"); - - - void *data = registers->registers; - if (return_type <= ECL_FFI_UNSIGNED_LONG) { - fficall->output.i = *((unsigned long *)data); - } else if (return_type == ECL_FFI_POINTER_VOID) { - fficall->output.pv = *((void **)data); - } else if (return_type == ECL_FFI_CSTRING) { - fficall->output.pc = *((char *)data); - } else if (return_type == ECL_FFI_OBJECT) { - fficall->output.o = *((cl_object *)data); - } else if (return_type == ECL_FFI_FLOAT) { - fficall->output.f = registers->fp_registers[0]; - } else if (return_type == ECL_FFI_DOUBLE) { - fficall->output.d = registers->fp_registers[0]; - } -} - - -void* -ecl_dynamic_callback_make(cl_object data, enum ecl_ffi_calling_convention cc_type) -{ - exit(0); -} diff -Nru ecl-16.1.2/src/c/arch/ffi_x86_64.d ecl-16.1.3+ds/src/c/arch/ffi_x86_64.d --- ecl-16.1.2/src/c/arch/ffi_x86_64.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/arch/ffi_x86_64.d 1970-01-01 00:00:00.000000000 +0000 @@ -1,370 +0,0 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ - -/* - ffi_x86.c -- Nonportable component of the FFI -*/ -/* - Copyright (c) 2005, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ - -#include -#include -#include - -#if !defined(HAVE_LIBFFI) - -#define MAX_INT_REGISTERS 6 -#define MAX_FP_REGISTERS 8 - -struct ecl_fficall_reg { - long int_registers[MAX_INT_REGISTERS]; - int int_registers_size; - double fp_registers[MAX_FP_REGISTERS]; - int fp_registers_size; -}; - -struct ecl_fficall_reg * -ecl_fficall_prepare_extra(struct ecl_fficall_reg *registers) -{ - if (registers == 0) { - registers = ecl_alloc_atomic_align(sizeof(*registers), sizeof(long)); - } - registers->int_registers_size = 0; - registers->fp_registers_size = 0; - return registers; -} - -void -ecl_fficall_push_arg(union ecl_ffi_values *data, enum ecl_ffi_tag type) -{ - long i; - struct ecl_fficall *fficall = cl_env.fficall; - struct ecl_fficall_reg *registers = fficall->registers; - switch (type) { - case ECL_FFI_CHAR: i = data->c; goto INT; - case ECL_FFI_UNSIGNED_CHAR: i = data->uc; goto INT; -#ifdef ecl_uint8_t - case ECL_FFI_INT8_T: i = data->i8; goto INT; - case ECL_FFI_UINT8_T: i = data->u8; goto INT; -#endif - case ECL_FFI_BYTE: i = data->b; goto INT; - case ECL_FFI_UNSIGNED_BYTE: i = data->ub; goto INT; -#ifdef ecl_uint16_t - case ECL_FFI_INT16_T: i = data->i16; goto INT; - case ECL_FFI_UINT16_T: i = data->u16; goto INT; -#endif - case ECL_FFI_SHORT: i = data->s; goto INT; - case ECL_FFI_UNSIGNED_SHORT: i = data->us; goto INT; -#ifdef ecl_uint32_t - case ECL_FFI_INT32_T: i = data->i32; goto INT; - case ECL_FFI_UINT32_T: i = data->u32; goto INT; -#endif - case ECL_FFI_INT: i = data->i; goto INT; - case ECL_FFI_UNSIGNED_INT: i = data->ui; goto INT; - case ECL_FFI_LONG: - case ECL_FFI_UNSIGNED_LONG: -#ifdef ecl_uint64_t - case ECL_FFI_INT64_T: - case ECL_FFI_UINT64_T: -#endif - case ECL_FFI_POINTER_VOID: - case ECL_FFI_CSTRING: - case ECL_FFI_OBJECT: - i = data->l; - INT: - if (registers->int_registers_size < MAX_INT_REGISTERS) { - registers->int_registers[registers->int_registers_size++] = i; - } else { - ecl_fficall_align(sizeof(long)); - ecl_fficall_push_bytes(&i, sizeof(long)); - } - break; - case ECL_FFI_DOUBLE: - if (registers->fp_registers_size < MAX_FP_REGISTERS) { - registers->fp_registers[registers->fp_registers_size++] = data->d; - } else { - ecl_fficall_align(sizeof(long)); - ecl_fficall_push_bytes(&data->d, sizeof(double)); - } - break; - case ECL_FFI_FLOAT: - if (registers->fp_registers_size < MAX_FP_REGISTERS) { - memset(®isters->fp_registers[registers->fp_registers_size], 0, sizeof(double)); - (*(float*)(®isters->fp_registers[registers->fp_registers_size++])) = (float)data->f; - } else { - i = 0; - ecl_fficall_align(sizeof(long)); - ecl_fficall_push_bytes(&data->f, sizeof(float)); - ecl_fficall_push_bytes(&i, sizeof(float)); - } - break; - case ECL_FFI_VOID: - FEerror("VOID is not a valid argument type for a C function", 0); - } -} - -void -ecl_fficall_execute(void *_f_ptr, struct ecl_fficall *fficall, enum ecl_ffi_tag return_type) -{ - struct ecl_fficall_reg *registers = fficall->registers; - long bufsize = fficall->buffer_size; - char* buf = fficall->buffer; - char* stack_p; - register void* f_ptr asm("r10"); - - ecl_fficall_align(16); - bufsize = fficall->buffer_size; - f_ptr = _f_ptr; - - asm volatile ( - "mov %%rsp, %0\n\t" - "sub %1, %%rsp\n\t" - "mov %2, %%rsi\n\t" - "mov %%rsp, %%rdi\n\t" - "rep\n\t" - "movsb\n\t" - : "=a" (stack_p) : "c" (bufsize), "d" (buf) : "%rdi", "%rsi"); - - asm volatile ( - "mov (%%rax), %%rdi\n\t" - "mov 0x08(%%rax), %%rsi\n\t" - "mov 0x10(%%rax), %%rdx\n\t" - "mov 0x18(%%rax), %%rcx\n\t" - "mov 0x20(%%rax), %%r8\n\t" - "mov 0x28(%%rax), %%r9\n\t" - :: "a" (registers->int_registers)); - - asm volatile ( - "movsd (%%rax), %%xmm0\n\t" - "movsd 0x08(%%rax), %%xmm1\n\t" - "movsd 0x10(%%rax), %%xmm2\n\t" - "movsd 0x18(%%rax), %%xmm3\n\t" - "movsd 0x20(%%rax), %%xmm4\n\t" - "movsd 0x28(%%rax), %%xmm5\n\t" - "movsd 0x30(%%rax), %%xmm6\n\t" - "movsd 0x38(%%rax), %%xmm7\n\t" - :: "a" (registers->fp_registers)); - - if (return_type <= ECL_FFI_UNSIGNED_LONG) { - fficall->output.ul = ((unsigned long (*)())f_ptr)(); - } else if (return_type == ECL_FFI_POINTER_VOID) { - fficall->output.pv = ((void * (*)())f_ptr)(); - } else if (return_type == ECL_FFI_CSTRING) { - fficall->output.pc = ((char * (*)())f_ptr)(); - } else if (return_type == ECL_FFI_OBJECT) { - fficall->output.o = ((cl_object (*)())f_ptr)(); - } else if (return_type == ECL_FFI_FLOAT) { - fficall->output.f = ((float (*)())f_ptr)(); - } else if (return_type == ECL_FFI_DOUBLE) { - fficall->output.d = ((double (*)())f_ptr)(); - } -#ifdef ecl_uint8_t - else if (return_type == ECL_FFI_INT8_T) { - fficall->output.i8 = ((ecl_int8_t (*)())f_ptr)(); - } else if (return_type == ECL_FFI_UINT16_T) { - fficall->output.u8 = ((ecl_uint8_t (*)())f_ptr)(); - } -#endif -#ifdef ecl_uint16_t - else if (return_type == ECL_FFI_INT16_T) { - fficall->output.i16 = ((ecl_int16_t (*)())f_ptr)(); - } else if (return_type == ECL_FFI_UINT16_T) { - fficall->output.u16 = ((ecl_uint16_t (*)())f_ptr)(); - } -#endif -#ifdef ecl_uint32_t - else if (return_type == ECL_FFI_INT32_T) { - fficall->output.i32 = ((ecl_int32_t (*)())f_ptr)(); - } else if (return_type == ECL_FFI_UINT32_T) { - fficall->output.u32 = ((ecl_uint32_t (*)())f_ptr)(); - } -#endif -#ifdef ecl_uint64_t - else if (return_type == ECL_FFI_INT64_T) { - fficall->output.i64 = ((ecl_int64_t (*)())f_ptr)(); - } else if (return_type == ECL_FFI_UINT32_T) { - fficall->output.u64 = ((ecl_uint64_t (*)())f_ptr)(); - } -#endif -#ifdef ecl_long_long_t - else if (return_type == ECL_FFI_LONG_LONG) { - fficall->output.ll = ((ecl_long_long_t (*)())f_ptr)(); - } else if (return_type == ECL_FFI_UNSIGNED_LONG_LONG) { - fficall->output.ull = ((ecl_ulong_long_t (*)())f_ptr)(); - } -#endif - else { - ((void (*)())f_ptr)(); - } - - asm volatile ("mov %0,%%rsp" :: "a" (stack_p)); -} - -static void -ecl_dynamic_callback_execute(long i1, long i2, long i3, long i4, long i5, long i6, - double f1, double f2, double f3, double f4, - double f5, double f6, double f7, double f8, - cl_object cbk_info, char *arg_buffer) -{ - cl_object fun, rtype, argtypes; - cl_object result; - cl_index i, size, i_reg_index, f_reg_index; - union ecl_ffi_values output; - enum ecl_ffi_tag tag; - long i_reg[MAX_INT_REGISTERS]; - double f_reg[MAX_FP_REGISTERS]; - cl_env_ptr env = ecl_process_env(); - - ECL_BUILD_STACK_FRAME(env, frame, aux); - - fun = CAR(cbk_info); - rtype = CADR(cbk_info); - argtypes = CADDR(cbk_info); - - i_reg_index = f_reg_index = 0; - i_reg[0] = i1; - i_reg[1] = i2; - i_reg[2] = i3; - i_reg[3] = i4; - i_reg[4] = i5; - i_reg[5] = i6; - f_reg[0] = f1; - f_reg[1] = f2; - f_reg[2] = f3; - f_reg[3] = f4; - f_reg[4] = f5; - f_reg[5] = f6; - f_reg[6] = f7; - f_reg[7] = f8; - - arg_buffer += 2*sizeof(void*); /* Skip return address and base pointer */ - for (i=0; !ecl_endp(argtypes); argtypes = CDR(argtypes), i++) { - tag = ecl_foreign_type_code(CAR(argtypes)); - size = ecl_fixnum(si_size_of_foreign_elt_type(CAR(argtypes))); - if (tag <= ECL_FFI_OBJECT) { - if (i_reg_index < MAX_INT_REGISTERS) - result = ecl_foreign_data_ref_elt(&i_reg[i_reg_index++], tag); - else - goto ARG_FROM_STACK; - } else if (tag <= ECL_FFI_DOUBLE) { - if (f_reg_index < MAX_FP_REGISTERS) - result = ecl_foreign_data_ref_elt(&f_reg[f_reg_index++], tag); - else - goto ARG_FROM_STACK; - } else { -ARG_FROM_STACK: - result = ecl_foreign_data_ref_elt(arg_buffer, tag); - { - int mask = 7; - int sp = (size + mask) & ~mask; - arg_buffer += (sp); - } - } - ecl_stack_frame_push(frame, result); - } - - result = ecl_apply_from_stack_frame(frame, fun); - ecl_stack_frame_close(frame); - - tag = ecl_foreign_type_code(rtype); - memset(&output, 0, sizeof(output)); - ecl_foreign_data_set_elt(&output, tag, result); - - switch (tag) { - case ECL_FFI_CHAR: i = output.c; goto INT; - case ECL_FFI_UNSIGNED_CHAR: i = output.uc; goto INT; - case ECL_FFI_BYTE: i = output.b; goto INT; - case ECL_FFI_UNSIGNED_BYTE: i = output.ub; goto INT; -#ifdef ecl_uint8_t - case ECL_FFI_INT8_T: i = output.i8; goto INT; - case ECL_FFI_UINT8_T: i = output.u8; goto INT; -#endif -#ifdef ecl_uint16_t - case ECL_FFI_INT16_T: i = output.i16; goto INT; - case ECL_FFI_UINT16_T: i = output.u16; goto INT; -#endif - case ECL_FFI_SHORT: i = output.s; goto INT; - case ECL_FFI_UNSIGNED_SHORT: i = output.us; goto INT; -#ifdef ecl_uint32_t - case ECL_FFI_INT32_T: i = output.i32; goto INT; - case ECL_FFI_UINT32_T: i = output.u32; goto INT; -#endif - case ECL_FFI_POINTER_VOID: - case ECL_FFI_OBJECT: - case ECL_FFI_CSTRING: - case ECL_FFI_INT: - case ECL_FFI_UNSIGNED_INT: - case ECL_FFI_LONG: - case ECL_FFI_UNSIGNED_LONG: -#ifdef ecl_uint64_t - case ECL_FFI_INT64_T: - case ECL_FFI_UINT64_T: -#endif - i = output.i; -INT: - { - register long eax asm("rax"); - eax = i; - } - return; - case ECL_FFI_DOUBLE: { - { - asm("movsd (%0),%%xmm0" :: "a" (&output.d)); - } - return; - } - case ECL_FFI_FLOAT: { - { - asm("movss (%0),%%xmm0" :: "a" (&output.f)); - } - return; - } - case ECL_FFI_VOID: - return; - } -} - -void* -ecl_dynamic_callback_make(cl_object data, enum ecl_ffi_calling_convention cc_type) -{ - /* - * push %rbp 55 - * push %rsp 54 - * mov ,%rax 48 b8 - * push %rax 50 - * mov ,%rax 48 b8 - * callq *%rax 48 ff d0 - * pop %rcx 59 - * pop %rcx 59 - * pop %rbp 5d - * ret c3 - * nop 90 - * nop 90 - */ - char *buf = (char*)ecl_alloc_atomic_align(sizeof(char)*32, 8); - *(char*) (buf+0) = 0x55; - *(char*) (buf+1) = 0x54; - *(short*)(buf+2) = 0xb848; - *(long*) (buf+4) = (long)data; - *(char*) (buf+12) = 0x50; - *(short*)(buf+13) = 0xb848; - *(long*) (buf+15) = (long)ecl_dynamic_callback_execute; - *(int*) (buf+23) = (int)0x00d0ff48; /* leading null byte is overwritten */ - *(char*) (buf+26) = 0x59; - *(char*) (buf+27) = 0x59; - *(char*) (buf+28) = 0x5d; - *(char*) (buf+29) = 0xc3; - *(short*)(buf+30) = 0x9090; - - return buf; -} - -#endif diff -Nru ecl-16.1.2/src/c/arch/ffi_x86.d ecl-16.1.3+ds/src/c/arch/ffi_x86.d --- ecl-16.1.2/src/c/arch/ffi_x86.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/arch/ffi_x86.d 1970-01-01 00:00:00.000000000 +0000 @@ -1,342 +0,0 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ - -/* - ffi_x86.c -- Nonportable component of the FFI -*/ -/* - Copyright (c) 2005, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ - -#include -#include -#include - -#if !defined(HAVE_LIBFFI) - -struct ecl_fficall_reg * -ecl_fficall_prepare_extra(struct ecl_fficall_reg *registers) -{ - /* No need to prepare registers */ - return 0; -} - -void -ecl_fficall_push_arg(union ecl_ffi_values *data, enum ecl_ffi_tag type) -{ - int i; - switch (type) { - case ECL_FFI_CHAR: i = data->c; goto INT_ECL; - case ECL_FFI_UNSIGNED_CHAR: i = data->uc; goto INT_ECL; - case ECL_FFI_BYTE: i = data->b; goto INT_ECL; - case ECL_FFI_UNSIGNED_BYTE: i = data->ub; goto INT_ECL; - case ECL_FFI_SHORT: i = data->s; goto INT_ECL; - case ECL_FFI_UNSIGNED_SHORT: i = data->us; goto INT_ECL; -#ifdef ecl_uint8_t - case ECL_FFI_INT8_T: i = data->i8; goto INT_ECL; - case ECL_FFI_UINT8_T: i = data->u8; goto INT_ECL; -#endif -#ifdef ecl_uint16_t - case ECL_FFI_INT16_T: i = data->i16; goto INT_ECL; - case ECL_FFI_UINT16_T: i = data->u16; goto INT_ECL; -#endif - case ECL_FFI_INT: - case ECL_FFI_LONG: - case ECL_FFI_UNSIGNED_INT: - case ECL_FFI_UNSIGNED_LONG: -#ifdef ecl_uint32_t - case ECL_FFI_INT32_T: - case ECL_FFI_UINT32_T: -#endif - case ECL_FFI_POINTER_VOID: - case ECL_FFI_CSTRING: - case ECL_FFI_OBJECT: - i = data->i; - INT_ECL: - ecl_fficall_align(sizeof(int)); - ecl_fficall_push_int(i); - break; - case ECL_FFI_DOUBLE: - ecl_fficall_align(sizeof(int)); - ecl_fficall_push_bytes(&data->d, sizeof(double)); - break; - case ECL_FFI_FLOAT: - ecl_fficall_align(sizeof(int)); - ecl_fficall_push_bytes(&data->f, sizeof(float)); - break; -#ifdef ecl_uint64_t - case ECL_FFI_UINT64_T: - case ECL_FFI_INT64_T: - ecl_fficall_align(sizeof(ecl_uint64_t)); - ecl_fficall_push_bytes(&data->ull, sizeof(ecl_uint64_t)); - break; -#endif -#ifdef ecl_long_long_t - case ECL_FFI_UNSIGNED_LONG_LONG: - case ECL_FFI_LONG_LONG: - ecl_fficall_align(sizeof(unsigned long)); - ecl_fficall_push_bytes(&data->ull, sizeof(unsigned long long)); - break; -#endif - case ECL_FFI_VOID: - FEerror("VOID is not a valid argument type for a C function", 0); - } -} - -void -ecl_fficall_execute(void *f_ptr, struct ecl_fficall *fficall, enum ecl_ffi_tag return_type) -{ - int bufsize = fficall->buffer_size; - char* buf = fficall->buffer; - char* stack_p; -#ifdef _MSC_VER - __asm - { - mov stack_p,esp - sub esp,bufsize - mov esi,buf - mov edi,esp - mov ecx,bufsize - rep movsb - } -#else - asm volatile ( - "movl %%esp, %0\n\t" - "subl %1, %%esp\n\t" - "movl %2, %%esi\n\t" - "movl %%esp, %%edi\n\t" - "rep\n\t" - "movsb\n\t" - : "=a" (stack_p) : "c" (bufsize), "d" (buf) : "%edi", "%esi"); -#endif - if (return_type <= ECL_FFI_UNSIGNED_LONG) { - fficall->output.i = ((int (*)())f_ptr)(); - } else if (return_type == ECL_FFI_POINTER_VOID) { - fficall->output.pv = ((void * (*)())f_ptr)(); - } else if (return_type == ECL_FFI_CSTRING) { - fficall->output.pc = ((char * (*)())f_ptr)(); - } else if (return_type == ECL_FFI_OBJECT) { - fficall->output.o = ((cl_object (*)())f_ptr)(); - } else if (return_type == ECL_FFI_FLOAT) { - fficall->output.f = ((float (*)())f_ptr)(); - } else if (return_type == ECL_FFI_DOUBLE) { - fficall->output.d = ((double (*)())f_ptr)(); - } -#ifdef ecl_uint8_t - else if (return_type == ECL_FFI_INT8_T) { - fficall->output.i8 = ((ecl_int8_t (*)())f_ptr)(); - } else if (return_type == ECL_FFI_UINT16_T) { - fficall->output.u8 = ((ecl_uint8_t (*)())f_ptr)(); - } -#endif -#ifdef ecl_uint16_t - else if (return_type == ECL_FFI_INT16_T) { - fficall->output.i16 = ((ecl_int16_t (*)())f_ptr)(); - } else if (return_type == ECL_FFI_UINT16_T) { - fficall->output.u16 = ((ecl_uint16_t (*)())f_ptr)(); - } -#endif -#ifdef ecl_uint32_t - else if (return_type == ECL_FFI_INT32_T) { - fficall->output.i32 = ((ecl_int32_t (*)())f_ptr)(); - } else if (return_type == ECL_FFI_UINT32_T) { - fficall->output.u32 = ((ecl_uint32_t (*)())f_ptr)(); - } -#endif -#ifdef ecl_uint64_t - else if (return_type == ECL_FFI_INT64_T) { - fficall->output.i64 = ((ecl_int64_t (*)())f_ptr)(); - } else if (return_type == ECL_FFI_UINT32_T) { - fficall->output.u64 = ((ecl_uint64_t (*)())f_ptr)(); - } -#endif -#ifdef ecl_long_long_t - else if (return_type == ECL_FFI_LONG_LONG) { - fficall->output.ll = ((ecl_long_long_t (*)())f_ptr)(); - } else if (return_type == ECL_FFI_UNSIGNED_LONG_LONG) { - fficall->output.ull = ((ecl_ulong_long_t (*)())f_ptr)(); - } -#endif - else { - ((void (*)())f_ptr)(); - } -#ifdef _MSC_VER - __asm mov esp,stack_p -#else - asm volatile ("mov %0,%%esp" :: "a" (stack_p)); -#endif -} - -static void -ecl_dynamic_callback_execute(cl_object cbk_info, char *arg_buffer) -{ - cl_object fun, rtype, argtypes; - cl_object result; - cl_index i, size; - union ecl_ffi_values output; - enum ecl_ffi_tag tag; - cl_env_ptr env = ecl_process_env(); - - ECL_BUILD_STACK_FRAME(env, frame, aux); - - fun = CAR(cbk_info); - rtype = CADR(cbk_info); - argtypes = CADDR(cbk_info); - - arg_buffer += 4; /* Skip return address */ - for (i=0; !ecl_endp(argtypes); argtypes = CDR(argtypes), i++) { - tag = ecl_foreign_type_code(CAR(argtypes)); - size = ecl_fixnum(si_size_of_foreign_elt_type(CAR(argtypes))); - result = ecl_foreign_data_ref_elt(arg_buffer, tag); - ecl_stack_frame_push(frame,result); - { - int mask = 3; - int sp = (size + mask) & ~mask; - arg_buffer += (sp); - } - } - - result = ecl_apply_from_stack_frame(frame, fun); - ecl_stack_frame_close(frame); - - tag = ecl_foreign_type_code(rtype); - memset(&output, 0, sizeof(output)); - ecl_foreign_data_set_elt(&output, tag, result); - - switch (tag) { - case ECL_FFI_CHAR: i = output.c; goto INT_ECL; - case ECL_FFI_UNSIGNED_CHAR: i = output.uc; goto INT_ECL; - case ECL_FFI_BYTE: i = output.b; goto INT_ECL; - case ECL_FFI_UNSIGNED_BYTE: i = output.ub; goto INT_ECL; -#ifdef ecl_uint8_t - case ECL_FFI_INT8_T: i = output.i8; goto INT_ECL; - case ECL_FFI_UINT8_T: i = output.u8; goto INT_ECL; -#endif -#ifdef ecl_uint16_t - case ECL_FFI_INT16_T: -#endif - case ECL_FFI_SHORT: i = output.s; goto INT_ECL; -#ifdef ecl_uint16_t - case ECL_FFI_UINT16_T: -#endif - case ECL_FFI_UNSIGNED_SHORT: i = output.us; goto INT_ECL; - case ECL_FFI_POINTER_VOID: - case ECL_FFI_OBJECT: - case ECL_FFI_CSTRING: - case ECL_FFI_INT: - case ECL_FFI_UNSIGNED_INT: -#ifdef ecl_uint32_t - case ECL_FFI_INT32_T: - case ECL_FFI_UINT32_T: -#endif - case ECL_FFI_LONG: - case ECL_FFI_UNSIGNED_LONG: - i = output.i; -INT_ECL: -#ifdef _MSC_VER - __asm mov eax,i -#else - { - register int eax asm("eax"); - eax = i; - } -#endif - return; -#if defined(ecl_long_long_t) || defined(ecl_uint64_t) -# ifdef ecl_long_long_t - case ECL_FFI_LONG_LONG: - case ECL_FFI_UNSIGNED_LONG_LONG: -# endif -# ifdef ecl_uint64_t - case ECL_FFI_INT64_T: - case ECL_FFI_UINT64_T: -# endif -# ifdef _MSC_VER - __asm mov eax,output.l2[0] - __asm mov edx,output.l2[1] -# else - { - register int eax asm("eax"); - register int edx asm("edx"); - eax = output.l2[0]; - edx = output.l2[1]; - } -# endif - return; -#endif /* ecl_long_long_t */ - case ECL_FFI_DOUBLE: { -#ifdef _MSC_VER - __asm fld output.d -#else - { - asm("fldl (%0)" :: "a" (&output.d)); - } -#endif - return; - } - case ECL_FFI_FLOAT: { -#ifdef _MSC_VER - __asm fld output.f -#else - { - asm("flds (%0)" :: "a" (&output.f)); - } -#endif - return; - } - case ECL_FFI_VOID: - return; - } -} - -void* -ecl_dynamic_callback_make(cl_object data, enum ecl_ffi_calling_convention cc_type) -{ - /* - * push %esp 54 - * pushl 68 - * call ecl_dynamic_callback_call E8 - * [ Here we could use also lea 4(%esp), %esp, but %ecx seems to be free ] - * pop %ecx 59 - * pop %ecx 59 - * ret c3 - * nop 90 - * nop 90 - */ - char *buf = (char*)ecl_alloc_atomic_align(sizeof(char)*16, 4); - *(char*) (buf+0) = 0x54; - *(char*) (buf+1) = 0x68; - *(long*) (buf+2) = (long)data; - *(unsigned char*) (buf+6) = 0xE8; - *(long*) (buf+7) = (long)ecl_dynamic_callback_execute - (long)(buf+11); - *(char*) (buf+11) = 0x59; - *(char*) (buf+12) = 0x59; - if (cc_type == ECL_FFI_CC_CDECL) { - *(unsigned char*) (buf+13) = 0xc3; - *(unsigned short*)(buf+14) = 0x9090; - } else { - cl_object arg_types = CADDR(data); - int byte_size = 0; - int mask = 3; - - while (CONSP(arg_types)) { - int sz = ecl_fixnum(si_size_of_foreign_elt_type(CAR(arg_types))); - byte_size += ((sz+mask)&(~mask)); - arg_types = CDR(arg_types); - } - - *(unsigned char*) (buf+13) = 0xc2; - *(unsigned short*)(buf+14) = (unsigned short)byte_size; - } - - return buf; -} - -#endif diff -Nru ecl-16.1.2/src/c/array.d ecl-16.1.3+ds/src/c/array.d --- ecl-16.1.2/src/c/array.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/array.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - array.c -- Array routines -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * array.c - array routines + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -24,30 +19,30 @@ #include static const cl_object ecl_aet_name[] = { - ECL_T, /* ecl_aet_object */ - @'single-float', /* ecl_aet_sf */ - @'double-float', /* ecl_aet_df */ - @'bit', /* ecl_aet_bit: cannot be handled with this code */ - @'ext::cl-fixnum', /* ecl_aet_fix */ - @'ext::cl-index', /* ecl_aet_index */ - @'ext::byte8', /* ecl_aet_b8 */ - @'ext::integer8', /* ecl_aet_i8 */ + ECL_T, /* ecl_aet_object */ + @'single-float', /* ecl_aet_sf */ + @'double-float', /* ecl_aet_df */ + @'bit', /* ecl_aet_bit: cannot be handled with this code */ + @'ext::cl-fixnum', /* ecl_aet_fix */ + @'ext::cl-index', /* ecl_aet_index */ + @'ext::byte8', /* ecl_aet_b8 */ + @'ext::integer8', /* ecl_aet_i8 */ #ifdef ecl_uint16_t - @'ext::byte16', - @'ext::integer16', + @'ext::byte16', + @'ext::integer16', #endif #ifdef ecl_uint32_t - @'ext::byte32', - @'ext::integer32', + @'ext::byte32', + @'ext::integer32', #endif #ifdef ecl_uint64_t - @'ext::byte64', - @'ext::integer64', + @'ext::byte64', + @'ext::integer64', #endif #ifdef ECL_UNICODE - @'character', /* ecl_aet_ch */ + @'character', /* ecl_aet_ch */ #endif - @'base-char' /* ecl_aet_bc */ + @'base-char' /* ecl_aet_bc */ }; static void FEbad_aet() ecl_attr_noreturn; @@ -55,1375 +50,1376 @@ static void FEbad_aet() { - FEerror( -"A routine from ECL got an object with a bad array element type.\n" -"If you are running a standard copy of ECL, please report this bug.\n" -"If you are embedding ECL into an application, please ensure you\n" -"passed the right value to the array creation routines.\n",0); + FEerror( + "A routine from ECL got an object with a bad array element type.\n" + "If you are running a standard copy of ECL, please report this bug.\n" + "If you are embedding ECL into an application, please ensure you\n" + "passed the right value to the array creation routines.\n",0); } static cl_index out_of_bounds_error(cl_index ndx, cl_object x) { - cl_object type = cl_list(3, @'integer', ecl_make_fixnum(0), - ecl_make_fixnum(x->array.dim)); - FEwrong_type_argument(ecl_make_integer(ndx), type); + cl_object type = cl_list(3, @'integer', ecl_make_fixnum(0), + ecl_make_fixnum(x->array.dim)); + FEwrong_type_argument(ecl_make_integer(ndx), type); } void FEwrong_dimensions(cl_object a, cl_index rank) { - cl_object list = cl_make_list(3, ecl_make_fixnum(rank), - @':initial-element', @'*'); - cl_object type = cl_list(3, @'array', @'*', list); - FEwrong_type_argument(type, a); + cl_object list = cl_make_list(3, ecl_make_fixnum(rank), + @':initial-element', @'*'); + cl_object type = cl_list(3, @'array', @'*', list); + FEwrong_type_argument(type, a); } static ECL_INLINE cl_index checked_index(cl_object function, cl_object a, int which, cl_object index, cl_index nonincl_limit) { - cl_index output; - unlikely_if (!ECL_FIXNUMP(index) || ecl_fixnum_minusp(index)) - FEwrong_index(function, a, which, index, nonincl_limit); - output = ecl_fixnum(index); - unlikely_if (output >= nonincl_limit) - FEwrong_index(function, a, which, index, nonincl_limit); - return output; + cl_index output; + unlikely_if (!ECL_FIXNUMP(index) || ecl_fixnum_minusp(index)) + FEwrong_index(function, a, which, index, nonincl_limit); + output = ecl_fixnum(index); + unlikely_if (output >= nonincl_limit) + FEwrong_index(function, a, which, index, nonincl_limit); + return output; } cl_index ecl_to_index(cl_object n) { - switch (ecl_t_of(n)) { - case t_fixnum: { - cl_fixnum out = ecl_fixnum(n); - if (out < 0 || out >= ECL_ARRAY_DIMENSION_LIMIT) - FEtype_error_index(ECL_NIL, out); - return out; - } - default: - FEwrong_type_only_arg(@[coerce], n, @[fixnum]); - } + switch (ecl_t_of(n)) { + case t_fixnum: { + cl_fixnum out = ecl_fixnum(n); + if (out < 0 || out >= ECL_ARRAY_DIMENSION_LIMIT) + FEtype_error_index(ECL_NIL, out); + return out; + } + default: + FEwrong_type_only_arg(@[coerce], n, @[fixnum]); + } } cl_object cl_row_major_aref(cl_object x, cl_object indx) { - cl_index j = ecl_to_size(indx); - @(return ecl_aref(x, j)) + cl_index j = ecl_to_size(indx); + @(return ecl_aref(x, j)); } cl_object si_row_major_aset(cl_object x, cl_object indx, cl_object val) { - cl_index j = ecl_to_size(indx); - @(return ecl_aset(x, j, val)) + cl_index j = ecl_to_size(indx); + @(return ecl_aset(x, j, val)); } @(defun aref (x &rest indx) @ { - cl_index i, j; - cl_index r = narg - 1; - switch (ecl_t_of(x)) { - case t_array: - if (r != x->array.rank) - FEerror("Wrong number of indices.", 0); - for (i = j = 0; i < r; i++) { - cl_index s = checked_index(@[aref], x, i, - ecl_va_arg(indx), - x->array.dims[i]); - j = j*(x->array.dims[i]) + s; - } - break; - case t_vector: + cl_index i, j; + cl_index r = narg - 1; + switch (ecl_t_of(x)) { + case t_array: + if (r != x->array.rank) + FEerror("Wrong number of indices.", 0); + for (i = j = 0; i < r; i++) { + cl_index s = checked_index(@[aref], x, i, + ecl_va_arg(indx), + x->array.dims[i]); + j = j*(x->array.dims[i]) + s; + } + break; + case t_vector: #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - case t_bitvector: - if (r != 1) - FEerror("Wrong number of indices.", 0); - j = checked_index(@[aref], x, -1, ecl_va_arg(indx), x->vector.dim); - break; - default: - FEwrong_type_nth_arg(@[aref], 1, x, @[array]); - } - @(return ecl_aref_unsafe(x, j)); + case t_base_string: + case t_bitvector: + if (r != 1) + FEerror("Wrong number of indices.", 0); + j = checked_index(@[aref], x, -1, ecl_va_arg(indx), x->vector.dim); + break; + default: + FEwrong_type_nth_arg(@[aref], 1, x, @[array]); + } + @(return ecl_aref_unsafe(x, j)); } @) cl_object ecl_aref_unsafe(cl_object x, cl_index index) { - switch (x->array.elttype) { - case ecl_aet_object: - return x->array.self.t[index]; - case ecl_aet_bc: - return ECL_CODE_CHAR(x->base_string.self[index]); + switch (x->array.elttype) { + case ecl_aet_object: + return x->array.self.t[index]; + case ecl_aet_bc: + return ECL_CODE_CHAR(x->base_string.self[index]); #ifdef ECL_UNICODE - case ecl_aet_ch: - return ECL_CODE_CHAR(x->string.self[index]); + case ecl_aet_ch: + return ECL_CODE_CHAR(x->string.self[index]); #endif - case ecl_aet_bit: - index += x->vector.offset; - if (x->vector.self.bit[index/CHAR_BIT] & (0200>>index%CHAR_BIT)) - return(ecl_make_fixnum(1)); - else - return(ecl_make_fixnum(0)); - case ecl_aet_fix: - return ecl_make_integer(x->array.self.fix[index]); - case ecl_aet_index: - return ecl_make_unsigned_integer(x->array.self.index[index]); - case ecl_aet_sf: - return(ecl_make_single_float(x->array.self.sf[index])); - case ecl_aet_df: - return(ecl_make_double_float(x->array.self.df[index])); - case ecl_aet_b8: - return ecl_make_uint8_t(x->array.self.b8[index]); - case ecl_aet_i8: - return ecl_make_int8_t(x->array.self.i8[index]); + case ecl_aet_bit: + index += x->vector.offset; + if (x->vector.self.bit[index/CHAR_BIT] & (0200>>index%CHAR_BIT)) + return(ecl_make_fixnum(1)); + else + return(ecl_make_fixnum(0)); + case ecl_aet_fix: + return ecl_make_integer(x->array.self.fix[index]); + case ecl_aet_index: + return ecl_make_unsigned_integer(x->array.self.index[index]); + case ecl_aet_sf: + return(ecl_make_single_float(x->array.self.sf[index])); + case ecl_aet_df: + return(ecl_make_double_float(x->array.self.df[index])); + case ecl_aet_b8: + return ecl_make_uint8_t(x->array.self.b8[index]); + case ecl_aet_i8: + return ecl_make_int8_t(x->array.self.i8[index]); #ifdef ecl_uint16_t - case ecl_aet_b16: - return ecl_make_uint16_t(x->array.self.b16[index]); - case ecl_aet_i16: - return ecl_make_int16_t(x->array.self.i16[index]); + case ecl_aet_b16: + return ecl_make_uint16_t(x->array.self.b16[index]); + case ecl_aet_i16: + return ecl_make_int16_t(x->array.self.i16[index]); #endif #ifdef ecl_uint32_t - case ecl_aet_b32: - return ecl_make_uint32_t(x->array.self.b32[index]); - case ecl_aet_i32: - return ecl_make_int32_t(x->array.self.i32[index]); + case ecl_aet_b32: + return ecl_make_uint32_t(x->array.self.b32[index]); + case ecl_aet_i32: + return ecl_make_int32_t(x->array.self.i32[index]); #endif #ifdef ecl_uint64_t - case ecl_aet_b64: - return ecl_make_uint64_t(x->array.self.b64[index]); - case ecl_aet_i64: - return ecl_make_int64_t(x->array.self.i64[index]); -#endif - default: - FEbad_aet(); - } + case ecl_aet_b64: + return ecl_make_uint64_t(x->array.self.b64[index]); + case ecl_aet_i64: + return ecl_make_int64_t(x->array.self.i64[index]); +#endif + default: + FEbad_aet(); + } } cl_object ecl_aref(cl_object x, cl_index index) { - if (ecl_unlikely(!ECL_ARRAYP(x))) { - FEwrong_type_nth_arg(@[aref], 1, x, @[array]); - } - if (ecl_unlikely(index >= x->array.dim)) { - FEwrong_index(@[row-major-aref], x, -1, ecl_make_fixnum(index), - x->array.dim); - } - return ecl_aref_unsafe(x, index); + if (ecl_unlikely(!ECL_ARRAYP(x))) { + FEwrong_type_nth_arg(@[aref], 1, x, @[array]); + } + if (ecl_unlikely(index >= x->array.dim)) { + FEwrong_index(@[row-major-aref], x, -1, ecl_make_fixnum(index), + x->array.dim); + } + return ecl_aref_unsafe(x, index); } cl_object ecl_aref1(cl_object x, cl_index index) { - if (ecl_unlikely(!ECL_VECTORP(x))) { - FEwrong_type_nth_arg(@[aref], 1, x, @[array]); - } - if (ecl_unlikely(index >= x->array.dim)) { - FEwrong_index(@[aref], x, -1, ecl_make_fixnum(index), - x->array.dim); - } - return ecl_aref_unsafe(x, index); + if (ecl_unlikely(!ECL_VECTORP(x))) { + FEwrong_type_nth_arg(@[aref], 1, x, @[array]); + } + if (ecl_unlikely(index >= x->array.dim)) { + FEwrong_index(@[aref], x, -1, ecl_make_fixnum(index), + x->array.dim); + } + return ecl_aref_unsafe(x, index); } void * ecl_row_major_ptr(cl_object x, cl_index index, cl_index bytes) { - cl_index elt_size, offset; - cl_elttype elt_type; + cl_index elt_size, offset; + cl_elttype elt_type; - if (ecl_unlikely(!ECL_ARRAYP(x))) { - FEwrong_type_nth_arg(@[aref], 1, x, @[array]); - } - - elt_type = x->array.elttype; - if (ecl_unlikely(elt_type == ecl_aet_bit || elt_type == ecl_aet_object)) - FEerror("In ecl_row_major_ptr: Specialized array expected, element type ~S found.", - 1,ecl_elttype_to_symbol(elt_type)); - - elt_size = ecl_aet_size[elt_type]; - offset = index*elt_size; - - /* don't check bounds if bytes == 0 */ - if (ecl_unlikely(bytes > 0 && offset + bytes > x->array.dim*elt_size)) { - FEwrong_index(@[row-major-aref], x, -1, ecl_make_fixnum(index), - x->array.dim); - } + if (ecl_unlikely(!ECL_ARRAYP(x))) { + FEwrong_type_nth_arg(@[aref], 1, x, @[array]); + } + + elt_type = x->array.elttype; + if (ecl_unlikely(elt_type == ecl_aet_bit || elt_type == ecl_aet_object)) + FEerror("In ecl_row_major_ptr: Specialized array expected, element type ~S found.", + 1,ecl_elttype_to_symbol(elt_type)); + + elt_size = ecl_aet_size[elt_type]; + offset = index*elt_size; + + /* don't check bounds if bytes == 0 */ + if (ecl_unlikely(bytes > 0 && offset + bytes > x->array.dim*elt_size)) { + FEwrong_index(@[row-major-aref], x, -1, ecl_make_fixnum(index), + x->array.dim); + } - return x->array.self.b8 + offset; + return x->array.self.b8 + offset; } /* - Internal function for setting array elements: + Internal function for setting array elements: - (si:aset value array dim0 ... dimN) + (si:aset value array dim0 ... dimN) */ @(defun si::aset (x &rest dims) -@ { - cl_index i, j; - cl_index r = narg - 2; - cl_object v; - switch (ecl_t_of(x)) { - case t_array: - if (ecl_unlikely(r != x->array.rank)) - FEerror("Wrong number of indices.", 0); - for (i = j = 0; i < r; i++) { - cl_index s = checked_index(@[si::aset], x, i, - ecl_va_arg(dims), - x->array.dims[i]); - j = j*(x->array.dims[i]) + s; - } - break; - case t_vector: + @ { + cl_index i, j; + cl_index r = narg - 2; + cl_object v; + switch (ecl_t_of(x)) { + case t_array: + if (ecl_unlikely(r != x->array.rank)) + FEerror("Wrong number of indices.", 0); + for (i = j = 0; i < r; i++) { + cl_index s = checked_index(@[si::aset], x, i, + ecl_va_arg(dims), + x->array.dims[i]); + j = j*(x->array.dims[i]) + s; + } + break; + case t_vector: #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - case t_bitvector: - if (ecl_unlikely(r != 1)) - FEerror("Wrong number of indices.", 0); - j = checked_index(@[si::aset], x, -1, ecl_va_arg(dims), - x->vector.dim); - break; - default: - FEwrong_type_nth_arg(@[si::aset], 1, x, @[array]); - } - v = ecl_va_arg(dims); - @(return ecl_aset_unsafe(x, j, v)) + case t_base_string: + case t_bitvector: + if (ecl_unlikely(r != 1)) + FEerror("Wrong number of indices.", 0); + j = checked_index(@[si::aset], x, -1, ecl_va_arg(dims), + x->vector.dim); + break; + default: + FEwrong_type_nth_arg(@[si::aset], 1, x, @[array]); + } + v = ecl_va_arg(dims); + @(return ecl_aset_unsafe(x, j, v)); } @) cl_object ecl_aset_unsafe(cl_object x, cl_index index, cl_object value) { - switch (x->array.elttype) { - case ecl_aet_object: - x->array.self.t[index] = value; - break; - case ecl_aet_bc: - /* INV: ecl_char_code() checks the type of `value' */ - x->base_string.self[index] = ecl_char_code(value); - break; + switch (x->array.elttype) { + case ecl_aet_object: + x->array.self.t[index] = value; + break; + case ecl_aet_bc: + /* INV: ecl_char_code() checks the type of `value' */ + x->base_string.self[index] = ecl_char_code(value); + break; #ifdef ECL_UNICODE - case ecl_aet_ch: - x->string.self[index] = ecl_char_code(value); - break; -#endif - case ecl_aet_bit: { - cl_fixnum i = ecl_to_bit(value); - index += x->vector.offset; - if (i == 0) - x->vector.self.bit[index/CHAR_BIT] &= ~(0200>>index%CHAR_BIT); - else - x->vector.self.bit[index/CHAR_BIT] |= 0200>>index%CHAR_BIT; - break; - } - case ecl_aet_fix: - x->array.self.fix[index] = ecl_to_fix(value); - break; - case ecl_aet_index: - x->array.self.index[index] = ecl_to_size(value); - break; - case ecl_aet_sf: - x->array.self.sf[index] = ecl_to_float(value); - break; - case ecl_aet_df: - x->array.self.df[index] = ecl_to_double(value); - break; - case ecl_aet_b8: - x->array.self.b8[index] = ecl_to_uint8_t(value); - break; - case ecl_aet_i8: - x->array.self.i8[index] = ecl_to_int8_t(value); - break; + case ecl_aet_ch: + x->string.self[index] = ecl_char_code(value); + break; +#endif + case ecl_aet_bit: { + cl_fixnum i = ecl_to_bit(value); + index += x->vector.offset; + if (i == 0) + x->vector.self.bit[index/CHAR_BIT] &= ~(0200>>index%CHAR_BIT); + else + x->vector.self.bit[index/CHAR_BIT] |= 0200>>index%CHAR_BIT; + break; + } + case ecl_aet_fix: + x->array.self.fix[index] = ecl_to_fix(value); + break; + case ecl_aet_index: + x->array.self.index[index] = ecl_to_size(value); + break; + case ecl_aet_sf: + x->array.self.sf[index] = ecl_to_float(value); + break; + case ecl_aet_df: + x->array.self.df[index] = ecl_to_double(value); + break; + case ecl_aet_b8: + x->array.self.b8[index] = ecl_to_uint8_t(value); + break; + case ecl_aet_i8: + x->array.self.i8[index] = ecl_to_int8_t(value); + break; #ifdef ecl_uint16_t - case ecl_aet_b16: - x->array.self.b16[index] = ecl_to_uint16_t(value); - break; - case ecl_aet_i16: - x->array.self.i16[index] = ecl_to_int16_t(value); - break; + case ecl_aet_b16: + x->array.self.b16[index] = ecl_to_uint16_t(value); + break; + case ecl_aet_i16: + x->array.self.i16[index] = ecl_to_int16_t(value); + break; #endif #ifdef ecl_uint32_t - case ecl_aet_b32: - x->array.self.b32[index] = ecl_to_uint32_t(value); - break; - case ecl_aet_i32: - x->array.self.i32[index] = ecl_to_int32_t(value); - break; + case ecl_aet_b32: + x->array.self.b32[index] = ecl_to_uint32_t(value); + break; + case ecl_aet_i32: + x->array.self.i32[index] = ecl_to_int32_t(value); + break; #endif #ifdef ecl_uint64_t - case ecl_aet_b64: - x->array.self.b64[index] = ecl_to_uint64_t(value); - break; - case ecl_aet_i64: - x->array.self.i64[index] = ecl_to_int64_t(value); - break; + case ecl_aet_b64: + x->array.self.b64[index] = ecl_to_uint64_t(value); + break; + case ecl_aet_i64: + x->array.self.i64[index] = ecl_to_int64_t(value); + break; #endif - } - return(value); + } + return(value); } cl_object ecl_aset(cl_object x, cl_index index, cl_object value) { - if (ecl_unlikely(!ECL_ARRAYP(x))) { - FEwrong_type_nth_arg(@[si::aset], 1, x, @[array]); - } - if (ecl_unlikely(index >= x->array.dim)) { - out_of_bounds_error(index, x); - } - return ecl_aset_unsafe(x, index, value); + if (ecl_unlikely(!ECL_ARRAYP(x))) { + FEwrong_type_nth_arg(@[si::aset], 1, x, @[array]); + } + if (ecl_unlikely(index >= x->array.dim)) { + out_of_bounds_error(index, x); + } + return ecl_aset_unsafe(x, index, value); } cl_object ecl_aset1(cl_object x, cl_index index, cl_object value) { - if (ecl_unlikely(!ECL_VECTORP(x))) { - FEwrong_type_nth_arg(@[si::aset], 1, x, @[array]); - } - if (ecl_unlikely(index >= x->array.dim)) { - out_of_bounds_error(index, x); - } - return ecl_aset_unsafe(x, index, value); + if (ecl_unlikely(!ECL_VECTORP(x))) { + FEwrong_type_nth_arg(@[si::aset], 1, x, @[array]); + } + if (ecl_unlikely(index >= x->array.dim)) { + out_of_bounds_error(index, x); + } + return ecl_aset_unsafe(x, index, value); } /* - Internal function for making arrays of more than one dimension: + Internal function for making arrays of more than one dimension: - (si:make-pure-array dimension-list element-type adjustable - displaced-to displaced-index-offset) + (si:make-pure-array dimension-list element-type adjustable + displaced-to displaced-index-offset) */ cl_object si_make_pure_array(cl_object etype, cl_object dims, cl_object adj, cl_object fillp, cl_object displ, cl_object disploff) { - cl_index r, s, i, j; - cl_object x; - if (ECL_FIXNUMP(dims)) { - return si_make_vector(etype, dims, adj, fillp, displ, disploff); - } else if (ecl_unlikely(!ECL_LISTP(dims))) { - FEwrong_type_nth_arg(@[make-array], 1, dims, - cl_list(3, @'or', @'list', @'fixnum')); - } - r = ecl_length(dims); - if (ecl_unlikely(r >= ECL_ARRAY_RANK_LIMIT)) { - FEerror("The array rank, ~R, is too large.", 1, ecl_make_fixnum(r)); - } else if (r == 1) { - return si_make_vector(etype, ECL_CONS_CAR(dims), adj, fillp, - displ, disploff); - } else if (ecl_unlikely(!Null(fillp))) { - FEerror(":FILL-POINTER may not be specified for an array of rank ~D", - 1, ecl_make_fixnum(r)); - } - x = ecl_alloc_object(t_array); - x->array.displaced = ECL_NIL; - x->array.self.t = NULL; /* for GC sake */ - x->array.rank = r; - x->array.elttype = (short)ecl_symbol_to_elttype(etype); - x->array.flags = 0; /* no fill pointer, no adjustable */ - x->array.dims = (cl_index *)ecl_alloc_atomic_align(sizeof(cl_index)*r, sizeof(cl_index)); - for (i = 0, s = 1; i < r; i++, dims = ECL_CONS_CDR(dims)) { - cl_object d = ECL_CONS_CAR(dims); - if (ecl_unlikely(!ECL_FIXNUMP(d) || - ecl_fixnum_minusp(d) || - ecl_fixnum_greater(d, ecl_make_fixnum(ECL_ARRAY_DIMENSION_LIMIT)))) - { - cl_object type = ecl_make_integer_type(ecl_make_fixnum(0), - ecl_make_fixnum(ECL_ARRAY_DIMENSION_LIMIT)); - FEwrong_type_nth_arg(@[make-array], 1, d, type); - } - j = ecl_fixnum(d); - s *= (x->array.dims[i] = j); - if (ecl_unlikely(s > ECL_ARRAY_TOTAL_LIMIT)) { - cl_object type = ecl_make_integer_type(ecl_make_fixnum(0), - ecl_make_fixnum(ECL_ARRAY_TOTAL_LIMIT)); - FEwrong_type_key_arg(@[make-array], @[array-total-size], - ecl_make_fixnum(s), type); - } - } - x->array.dim = s; - if (adj != ECL_NIL) { - x->array.flags |= ECL_FLAG_ADJUSTABLE; - } - if (Null(displ)) - ecl_array_allocself(x); - else - ecl_displace(x, displ, disploff); - @(return x); + cl_index r, s, i, j; + cl_object x; + if (ECL_FIXNUMP(dims)) { + return si_make_vector(etype, dims, adj, fillp, displ, disploff); + } else if (ecl_unlikely(!ECL_LISTP(dims))) { + FEwrong_type_nth_arg(@[make-array], 1, dims, + cl_list(3, @'or', @'list', @'fixnum')); + } + r = ecl_length(dims); + if (ecl_unlikely(r >= ECL_ARRAY_RANK_LIMIT)) { + FEerror("The array rank, ~R, is too large.", 1, ecl_make_fixnum(r)); + } else if (r == 1) { + return si_make_vector(etype, ECL_CONS_CAR(dims), adj, fillp, + displ, disploff); + } else if (ecl_unlikely(!Null(fillp))) { + FEerror(":FILL-POINTER may not be specified for an array of rank ~D", + 1, ecl_make_fixnum(r)); + } + x = ecl_alloc_object(t_array); + x->array.displaced = ECL_NIL; + x->array.self.t = NULL; /* for GC sake */ + x->array.rank = r; + x->array.elttype = (short)ecl_symbol_to_elttype(etype); + x->array.flags = 0; /* no fill pointer, no adjustable */ + x->array.dims = (cl_index *)ecl_alloc_atomic_align(sizeof(cl_index)*r, sizeof(cl_index)); + for (i = 0, s = 1; i < r; i++, dims = ECL_CONS_CDR(dims)) { + cl_object d = ECL_CONS_CAR(dims); + if (ecl_unlikely(!ECL_FIXNUMP(d) || + ecl_fixnum_minusp(d) || + ecl_fixnum_greater(d, ecl_make_fixnum(ECL_ARRAY_DIMENSION_LIMIT)))) + { + cl_object type = ecl_make_integer_type(ecl_make_fixnum(0), + ecl_make_fixnum(ECL_ARRAY_DIMENSION_LIMIT)); + FEwrong_type_nth_arg(@[make-array], 1, d, type); + } + j = ecl_fixnum(d); + s *= (x->array.dims[i] = j); + if (ecl_unlikely(s > ECL_ARRAY_TOTAL_LIMIT)) { + cl_object type = ecl_make_integer_type(ecl_make_fixnum(0), + ecl_make_fixnum(ECL_ARRAY_TOTAL_LIMIT)); + FEwrong_type_key_arg(@[make-array], @[array-total-size], + ecl_make_fixnum(s), type); + } + } + x->array.dim = s; + if (adj != ECL_NIL) { + x->array.flags |= ECL_FLAG_ADJUSTABLE; + } + if (Null(displ)) + ecl_array_allocself(x); + else + ecl_displace(x, displ, disploff); + @(return x); } /* - Internal function for making vectors: + Internal function for making vectors: - (si:make-vector element-type dimension adjustable fill-pointer - displaced-to displaced-index-offset) + (si:make-vector element-type dimension adjustable fill-pointer + displaced-to displaced-index-offset) */ cl_object si_make_vector(cl_object etype, cl_object dim, cl_object adj, cl_object fillp, cl_object displ, cl_object disploff) { - cl_index d, f; - cl_object x; - cl_elttype aet; + cl_index d, f; + cl_object x; + cl_elttype aet; AGAIN: - aet = ecl_symbol_to_elttype(etype); - if (ecl_unlikely(!ECL_FIXNUMP(dim) || ecl_fixnum_minusp(dim) || - ecl_fixnum_greater(dim, ECL_ARRAY_DIMENSION_LIMIT))) { - cl_object type = ecl_make_integer_type(ecl_make_fixnum(0), - ecl_make_fixnum(ECL_ARRAY_DIMENSION_LIMIT)); - FEwrong_type_nth_arg(@[make-array], 1, dim, type); - } - d = ecl_fixnum(dim); - if (aet == ecl_aet_bc) { - x = ecl_alloc_object(t_base_string); - x->base_string.elttype = (short)aet; - } else if (aet == ecl_aet_bit) { - x = ecl_alloc_object(t_bitvector); - x->vector.elttype = (short)aet; + aet = ecl_symbol_to_elttype(etype); + if (ecl_unlikely(!ECL_FIXNUMP(dim) || ecl_fixnum_minusp(dim) || + ecl_fixnum_greater(dim, ECL_ARRAY_DIMENSION_LIMIT))) { + cl_object type = ecl_make_integer_type(ecl_make_fixnum(0), + ecl_make_fixnum(ECL_ARRAY_DIMENSION_LIMIT)); + FEwrong_type_nth_arg(@[make-array], 1, dim, type); + } + d = ecl_fixnum(dim); + if (aet == ecl_aet_bc) { + x = ecl_alloc_object(t_base_string); + x->base_string.elttype = (short)aet; + } else if (aet == ecl_aet_bit) { + x = ecl_alloc_object(t_bitvector); + x->vector.elttype = (short)aet; #ifdef ECL_UNICODE - } else if (aet == ecl_aet_ch) { - x = ecl_alloc_object(t_string); - x->string.elttype = (short)aet; -#endif - } else { - x = ecl_alloc_object(t_vector); - x->vector.elttype = (short)aet; - } - x->vector.self.t = NULL; /* for GC sake */ - x->vector.displaced = ECL_NIL; - x->vector.dim = d; - x->vector.flags = 0; - if (adj != ECL_NIL) { - x->vector.flags |= ECL_FLAG_ADJUSTABLE; - } - if (Null(fillp)) { - f = d; - } else if (fillp == ECL_T) { - x->vector.flags |= ECL_FLAG_HAS_FILL_POINTER; - f = d; - } else if (ECL_FIXNUMP(fillp) && ecl_fixnum_geq(fillp,ecl_make_fixnum(0)) && - ((f = ecl_fixnum(fillp)) <= d)) { - x->vector.flags |= ECL_FLAG_HAS_FILL_POINTER; - } else { - fillp = ecl_type_error(@'make-array',"fill pointer",fillp, - cl_list(3,@'or',cl_list(3,@'member',ECL_NIL,ECL_T), - cl_list(3,@'integer',ecl_make_fixnum(0), - dim))); - goto AGAIN; - } - x->vector.fillp = f; - - if (Null(displ)) - ecl_array_allocself(x); - else - ecl_displace(x, displ, disploff); - @(return x) + } else if (aet == ecl_aet_ch) { + x = ecl_alloc_object(t_string); + x->string.elttype = (short)aet; +#endif + } else { + x = ecl_alloc_object(t_vector); + x->vector.elttype = (short)aet; + } + x->vector.self.t = NULL; /* for GC sake */ + x->vector.displaced = ECL_NIL; + x->vector.dim = d; + x->vector.flags = 0; + if (adj != ECL_NIL) { + x->vector.flags |= ECL_FLAG_ADJUSTABLE; + } + if (Null(fillp)) { + f = d; + } else if (fillp == ECL_T) { + x->vector.flags |= ECL_FLAG_HAS_FILL_POINTER; + f = d; + } else if (ECL_FIXNUMP(fillp) && ecl_fixnum_geq(fillp,ecl_make_fixnum(0)) && + ((f = ecl_fixnum(fillp)) <= d)) { + x->vector.flags |= ECL_FLAG_HAS_FILL_POINTER; + } else { + fillp = ecl_type_error(@'make-array',"fill pointer",fillp, + cl_list(3,@'or',cl_list(3,@'member',ECL_NIL,ECL_T), + cl_list(3,@'integer',ecl_make_fixnum(0), + dim))); + goto AGAIN; + } + x->vector.fillp = f; + + if (Null(displ)) + ecl_array_allocself(x); + else + ecl_displace(x, displ, disploff); + @(return x); } cl_object * alloc_pointerfull_memory(cl_index l) { - cl_object *p = ecl_alloc_align(sizeof(cl_object) * l, sizeof(cl_object)); - cl_index i; - for (i = 0; l--;) - p[i++] = ECL_NIL; - return p; + cl_object *p = ecl_alloc_align(sizeof(cl_object) * l, sizeof(cl_object)); + cl_index i; + for (i = 0; l--;) + p[i++] = ECL_NIL; + return p; } void ecl_array_allocself(cl_object x) { - cl_elttype t = x->array.elttype; - cl_index d = x->array.dim; - switch (t) { - /* assign self field only after it has been filled, for GC sake */ - case ecl_aet_object: - x->array.self.t = alloc_pointerfull_memory(d); - return; + cl_elttype t = x->array.elttype; + cl_index d = x->array.dim; + switch (t) { + /* assign self field only after it has been filled, for GC sake */ + case ecl_aet_object: + x->array.self.t = alloc_pointerfull_memory(d); + return; #ifdef ECL_UNICODE - case ecl_aet_ch: { - ecl_character *elts; - d *= sizeof(ecl_character); - elts = (ecl_character *)ecl_alloc_atomic_align(d, sizeof(ecl_character)); - x->string.self = elts; - return; - } -#endif - case ecl_aet_bc: { - cl_index elt_size = 1; - x->vector.self.bc = (ecl_base_char *)ecl_alloc_atomic(d+1); - /* Null terminate the string */ - x->vector.self.bc[d] = 0; - break; - } - case ecl_aet_bit: - d = (d + (CHAR_BIT-1)) / CHAR_BIT; - x->vector.self.bit = (byte *)ecl_alloc_atomic(d); - x->vector.offset = 0; - break; - default: { - cl_index elt_size = ecl_aet_size[t]; - d *= elt_size; - x->vector.self.bc = (ecl_base_char *)ecl_alloc_atomic_align(d, elt_size); - } - } + case ecl_aet_ch: { + ecl_character *elts; + d *= sizeof(ecl_character); + elts = (ecl_character *)ecl_alloc_atomic_align(d, sizeof(ecl_character)); + x->string.self = elts; + return; + } +#endif + case ecl_aet_bc: { + cl_index elt_size = 1; + x->vector.self.bc = (ecl_base_char *)ecl_alloc_atomic(d+1); + /* Null terminate the string */ + x->vector.self.bc[d] = 0; + break; + } + case ecl_aet_bit: + d = (d + (CHAR_BIT-1)) / CHAR_BIT; + x->vector.self.bit = (byte *)ecl_alloc_atomic(d); + x->vector.offset = 0; + break; + default: { + cl_index elt_size = ecl_aet_size[t]; + d *= elt_size; + x->vector.self.bc = (ecl_base_char *)ecl_alloc_atomic_align(d, elt_size); + } + } } cl_object ecl_alloc_simple_vector(cl_index l, cl_elttype aet) { - cl_object x; + cl_object x; - switch (aet) { - case ecl_aet_bc: - x = ecl_alloc_compact_object(t_base_string, l+1); - x->base_string.self = ECL_COMPACT_OBJECT_EXTRA(x); - x->base_string.self[l] = 0; - break; + switch (aet) { + case ecl_aet_bc: + x = ecl_alloc_compact_object(t_base_string, l+1); + x->base_string.self = ECL_COMPACT_OBJECT_EXTRA(x); + x->base_string.self[l] = 0; + break; #ifdef ECL_UNICODE - case ecl_aet_ch: - { - cl_index bytes = sizeof(ecl_character) * l; - x = ecl_alloc_compact_object(t_string, bytes); - x->string.self = ECL_COMPACT_OBJECT_EXTRA(x); - } - break; -#endif - case ecl_aet_bit: - { - cl_index bytes = (l + (CHAR_BIT-1))/CHAR_BIT; - x = ecl_alloc_compact_object(t_bitvector, bytes); - x->vector.self.bit = ECL_COMPACT_OBJECT_EXTRA(x); - x->vector.offset = 0; - } - break; - case ecl_aet_object: - { - x = ecl_alloc_object(t_vector); - x->vector.self.t = alloc_pointerfull_memory(l); - } - break; - default: - x = ecl_alloc_compact_object(t_vector, l * ecl_aet_size[aet]); - x->vector.self.bc = ECL_COMPACT_OBJECT_EXTRA(x); - } - x->base_string.elttype = aet; - x->base_string.flags = 0; /* no fill pointer, not adjustable */ - x->base_string.displaced = ECL_NIL; - x->base_string.dim = x->base_string.fillp = l; - return x; + case ecl_aet_ch: + { + cl_index bytes = sizeof(ecl_character) * l; + x = ecl_alloc_compact_object(t_string, bytes); + x->string.self = ECL_COMPACT_OBJECT_EXTRA(x); + } + break; +#endif + case ecl_aet_bit: + { + cl_index bytes = (l + (CHAR_BIT-1))/CHAR_BIT; + x = ecl_alloc_compact_object(t_bitvector, bytes); + x->vector.self.bit = ECL_COMPACT_OBJECT_EXTRA(x); + x->vector.offset = 0; + } + break; + case ecl_aet_object: + { + x = ecl_alloc_object(t_vector); + x->vector.self.t = alloc_pointerfull_memory(l); + } + break; + default: + x = ecl_alloc_compact_object(t_vector, l * ecl_aet_size[aet]); + x->vector.self.bc = ECL_COMPACT_OBJECT_EXTRA(x); + } + x->base_string.elttype = aet; + x->base_string.flags = 0; /* no fill pointer, not adjustable */ + x->base_string.displaced = ECL_NIL; + x->base_string.dim = x->base_string.fillp = l; + return x; } cl_elttype ecl_symbol_to_elttype(cl_object x) { BEGIN: - if (x == @'base-char') - return(ecl_aet_bc); + if (x == @'base-char') + return(ecl_aet_bc); #ifdef ECL_UNICODE - if (x == @'character') - return(ecl_aet_ch); + if (x == @'character') + return(ecl_aet_ch); #endif - else if (x == @'bit') - return(ecl_aet_bit); - else if (x == @'ext::cl-fixnum') - return(ecl_aet_fix); - else if (x == @'ext::cl-index') - return(ecl_aet_index); - else if (x == @'single-float' || x == @'short-float') - return(ecl_aet_sf); - else if (x == @'double-float') - return(ecl_aet_df); - else if (x == @'long-float') { + else if (x == @'bit') + return(ecl_aet_bit); + else if (x == @'ext::cl-fixnum') + return(ecl_aet_fix); + else if (x == @'ext::cl-index') + return(ecl_aet_index); + else if (x == @'single-float' || x == @'short-float') + return(ecl_aet_sf); + else if (x == @'double-float') + return(ecl_aet_df); + else if (x == @'long-float') { #ifdef ECL_LONG_FLOAT - return(ecl_aet_object); + return(ecl_aet_object); #else - return(ecl_aet_df); + return(ecl_aet_df); #endif - } else if (x == @'ext::byte8') - return(ecl_aet_b8); - else if (x == @'ext::integer8') - return(ecl_aet_i8); + } else if (x == @'ext::byte8') + return(ecl_aet_b8); + else if (x == @'ext::integer8') + return(ecl_aet_i8); #ifdef ecl_uint16_t - else if (x == @'ext::byte16') - return(ecl_aet_b16); - else if (x == @'ext::integer16') - return(ecl_aet_i16); + else if (x == @'ext::byte16') + return(ecl_aet_b16); + else if (x == @'ext::integer16') + return(ecl_aet_i16); #endif #ifdef ecl_uint32_t - else if (x == @'ext::byte32') - return(ecl_aet_b32); - else if (x == @'ext::integer32') - return(ecl_aet_i32); + else if (x == @'ext::byte32') + return(ecl_aet_b32); + else if (x == @'ext::integer32') + return(ecl_aet_i32); #endif #ifdef ecl_uint64_t - else if (x == @'ext::byte64') - return(ecl_aet_b64); - else if (x == @'ext::integer64') - return(ecl_aet_i64); -#endif - else if (x == @'t') - return(ecl_aet_object); - else if (x == ECL_NIL) { - FEerror("ECL does not support arrays with element type NIL", 0); - } - x = cl_upgraded_array_element_type(1, x); - goto BEGIN; + else if (x == @'ext::byte64') + return(ecl_aet_b64); + else if (x == @'ext::integer64') + return(ecl_aet_i64); +#endif + else if (x == @'t') + return(ecl_aet_object); + else if (x == ECL_NIL) { + FEerror("ECL does not support arrays with element type NIL", 0); + } + x = cl_upgraded_array_element_type(1, x); + goto BEGIN; } cl_object ecl_elttype_to_symbol(cl_elttype aet) { - return ecl_aet_name[aet]; + return ecl_aet_name[aet]; } cl_object si_array_element_type_byte_size(cl_object type) { - cl_elttype aet = ECL_ARRAYP(type) ? - type->array.elttype : - ecl_symbol_to_elttype(type); - cl_object size = ecl_make_fixnum(ecl_aet_size[aet]); - if (aet == ecl_aet_bit) - size = ecl_make_ratio(ecl_make_fixnum(1),ecl_make_fixnum(CHAR_BIT)); - @(return size ecl_elttype_to_symbol(aet)) + cl_elttype aet = ECL_ARRAYP(type) ? + type->array.elttype : + ecl_symbol_to_elttype(type); + cl_object size = ecl_make_fixnum(ecl_aet_size[aet]); + if (aet == ecl_aet_bit) + size = ecl_make_ratio(ecl_make_fixnum(1),ecl_make_fixnum(CHAR_BIT)); + + @(return size ecl_elttype_to_symbol(aet)); } static void * address_inc(void *address, cl_fixnum inc, cl_elttype elt_type) { - union ecl_array_data aux; - aux.t = address; - switch (elt_type) { - case ecl_aet_object: - return aux.t + inc; - case ecl_aet_fix: - return aux.fix + inc; - case ecl_aet_index: - return aux.fix + inc; - case ecl_aet_sf: - return aux.sf + inc; - case ecl_aet_bc: - return aux.bc + inc; + union ecl_array_data aux; + aux.t = address; + switch (elt_type) { + case ecl_aet_object: + return aux.t + inc; + case ecl_aet_fix: + return aux.fix + inc; + case ecl_aet_index: + return aux.fix + inc; + case ecl_aet_sf: + return aux.sf + inc; + case ecl_aet_bc: + return aux.bc + inc; #ifdef ECL_UNICODE - case ecl_aet_ch: - return aux.c + inc; + case ecl_aet_ch: + return aux.c + inc; #endif - case ecl_aet_df: - return aux.df + inc; - case ecl_aet_b8: - case ecl_aet_i8: - return aux.b8 + inc; + case ecl_aet_df: + return aux.df + inc; + case ecl_aet_b8: + case ecl_aet_i8: + return aux.b8 + inc; #ifdef ecl_uint16_t - case ecl_aet_b16: - case ecl_aet_i16: - return aux.b16 + inc; + case ecl_aet_b16: + case ecl_aet_i16: + return aux.b16 + inc; #endif #ifdef ecl_uint32_t - case ecl_aet_b32: - case ecl_aet_i32: - return aux.b32 + inc; + case ecl_aet_b32: + case ecl_aet_i32: + return aux.b32 + inc; #endif #ifdef ecl_uint64_t - case ecl_aet_b64: - case ecl_aet_i64: - return aux.b64 + inc; -#endif - default: - FEbad_aet(); - } + case ecl_aet_b64: + case ecl_aet_i64: + return aux.b64 + inc; +#endif + default: + FEbad_aet(); + } } cl_object cl_array_element_type(cl_object a) { - @(return ecl_elttype_to_symbol(ecl_array_elttype(a))) + @(return ecl_elttype_to_symbol(ecl_array_elttype(a))); } /* - Displace(from, to, offset) displaces the from-array - to the to-array (the original array) by the specified offset. - It changes the a_displaced field of both arrays. - The field is a cons; the car of the from-array points to - the to-array and the cdr of the to-array is a list of arrays - displaced to the to-array, so the from-array is pushed to the - cdr of the to-array's array.displaced. + Displace(from, to, offset) displaces the from-array + to the to-array (the original array) by the specified offset. + It changes the a_displaced field of both arrays. + The field is a cons; the car of the from-array points to + the to-array and the cdr of the to-array is a list of arrays + displaced to the to-array, so the from-array is pushed to the + cdr of the to-array's array.displaced. */ void ecl_displace(cl_object from, cl_object to, cl_object offset) { - cl_index j; - void *base; - cl_elttype totype, fromtype; - fromtype = from->array.elttype; - if (ecl_unlikely(!ECL_FIXNUMP(offset) || ((j = ecl_fixnum(offset)) < 0))) { - FEwrong_type_key_arg(@[adjust-array], @[:displaced-index-offset], - offset, @[fixnum]); - } - if (ecl_t_of(to) == t_foreign) { - if (fromtype == ecl_aet_bit || fromtype == ecl_aet_object) { - FEerror("Cannot displace arrays with element type T or BIT onto foreign data",0); - } - base = to->foreign.data; - from->array.displaced = to; - } else { - cl_fixnum maxdim; - totype = to->array.elttype; - if (totype != fromtype) - FEerror("Cannot displace the array, " - "because the element types don't match.", 0); - maxdim = to->array.dim - from->array.dim; - if (maxdim < 0) - FEerror("Cannot displace the array, " - "because the total size of the to-array" - "is too small.", 0); - if (j > maxdim) { - cl_object type = ecl_make_integer_type(ecl_make_fixnum(0), - ecl_make_fixnum(maxdim)); - FEwrong_type_key_arg(@[adjust-array], @[:displaced-index-offset], - offset, type); - } - from->array.displaced = ecl_list1(to); - /* We only need to keep track of the arrays that displace to us - * when this one array is adjustable */ - if (ECL_ADJUSTABLE_ARRAY_P(to)) { - cl_object track_list = to->array.displaced; - if (Null(track_list)) - to->array.displaced = - track_list = ecl_list1(ECL_NIL); - ECL_RPLACD(track_list, - CONS(from, ECL_CONS_CDR(track_list))); - } - if (fromtype == ecl_aet_bit) { - j += to->vector.offset; - from->vector.offset = j%CHAR_BIT; - from->vector.self.bit = to->vector.self.bit + j/CHAR_BIT; - return; - } - base = to->array.self.t; - } - from->array.self.t = address_inc(base, j, fromtype); + cl_index j; + void *base; + cl_elttype totype, fromtype; + fromtype = from->array.elttype; + if (ecl_unlikely(!ECL_FIXNUMP(offset) || ((j = ecl_fixnum(offset)) < 0))) { + FEwrong_type_key_arg(@[adjust-array], @[:displaced-index-offset], + offset, @[fixnum]); + } + if (ecl_t_of(to) == t_foreign) { + if (fromtype == ecl_aet_bit || fromtype == ecl_aet_object) { + FEerror("Cannot displace arrays with element type T or BIT onto foreign data",0); + } + base = to->foreign.data; + from->array.displaced = to; + } else { + cl_fixnum maxdim; + totype = to->array.elttype; + if (totype != fromtype) + FEerror("Cannot displace the array, " + "because the element types don't match.", 0); + maxdim = to->array.dim - from->array.dim; + if (maxdim < 0) + FEerror("Cannot displace the array, " + "because the total size of the to-array" + "is too small.", 0); + if (j > maxdim) { + cl_object type = ecl_make_integer_type(ecl_make_fixnum(0), + ecl_make_fixnum(maxdim)); + FEwrong_type_key_arg(@[adjust-array], @[:displaced-index-offset], + offset, type); + } + from->array.displaced = ecl_list1(to); + /* We only need to keep track of the arrays that displace to us + * when this one array is adjustable */ + if (ECL_ADJUSTABLE_ARRAY_P(to)) { + cl_object track_list = to->array.displaced; + if (Null(track_list)) + to->array.displaced = + track_list = ecl_list1(ECL_NIL); + ECL_RPLACD(track_list, + CONS(from, ECL_CONS_CDR(track_list))); + } + if (fromtype == ecl_aet_bit) { + j += to->vector.offset; + from->vector.offset = j%CHAR_BIT; + from->vector.self.bit = to->vector.self.bit + j/CHAR_BIT; + return; + } + base = to->array.self.t; + } + from->array.self.t = address_inc(base, j, fromtype); } cl_object si_array_raw_data(cl_object x) { - cl_elttype et = ecl_array_elttype(x); - cl_index total_size = x->vector.dim * ecl_aet_size[et]; - cl_object output, to_array; - uint8_t *data; - if (et == ecl_aet_object) { - FEerror("EXT:ARRAY-RAW-DATA can not get data " - "from an array with element type T.", 0); - } - data = x->vector.self.b8; - to_array = x->array.displaced; - if (to_array == ECL_NIL || ((to_array = ECL_CONS_CAR(to_array)) == ECL_NIL)) { - cl_index used_size = total_size; - int flags = 0; - if (ECL_ARRAY_HAS_FILL_POINTER_P(x)) { - used_size = x->vector.fillp * ecl_aet_size[et]; - flags = ECL_FLAG_HAS_FILL_POINTER; - } - output = ecl_alloc_object(t_vector); - output->vector.elttype = ecl_aet_b8; - output->vector.self.b8 = data; - output->vector.dim = total_size; - output->vector.fillp = used_size; - output->vector.flags = flags; - output->vector.displaced = ECL_NIL; - } else { - cl_index displ = data - to_array->vector.self.b8; - cl_object fillp = ECL_NIL; - if (ECL_ARRAY_HAS_FILL_POINTER_P(x)) { - fillp = ecl_make_fixnum(x->vector.fillp * ecl_aet_size[et]); - } - output = si_make_vector(@'ext::byte8', - ecl_make_fixnum(total_size), - ECL_NIL, - fillp, - si_array_raw_data(to_array), - ecl_make_fixnum(displ)); - } - @(return output) + cl_elttype et = ecl_array_elttype(x); + cl_index total_size = x->vector.dim * ecl_aet_size[et]; + cl_object output, to_array; + uint8_t *data; + if (et == ecl_aet_object) { + FEerror("EXT:ARRAY-RAW-DATA can not get data " + "from an array with element type T.", 0); + } + data = x->vector.self.b8; + to_array = x->array.displaced; + if (to_array == ECL_NIL || ((to_array = ECL_CONS_CAR(to_array)) == ECL_NIL)) { + cl_index used_size = total_size; + int flags = 0; + if (ECL_ARRAY_HAS_FILL_POINTER_P(x)) { + used_size = x->vector.fillp * ecl_aet_size[et]; + flags = ECL_FLAG_HAS_FILL_POINTER; + } + output = ecl_alloc_object(t_vector); + output->vector.elttype = ecl_aet_b8; + output->vector.self.b8 = data; + output->vector.dim = total_size; + output->vector.fillp = used_size; + output->vector.flags = flags; + output->vector.displaced = ECL_NIL; + } else { + cl_index displ = data - to_array->vector.self.b8; + cl_object fillp = ECL_NIL; + if (ECL_ARRAY_HAS_FILL_POINTER_P(x)) { + fillp = ecl_make_fixnum(x->vector.fillp * ecl_aet_size[et]); + } + output = si_make_vector(@'ext::byte8', + ecl_make_fixnum(total_size), + ECL_NIL, + fillp, + si_array_raw_data(to_array), + ecl_make_fixnum(displ)); + } + @(return output); } cl_elttype ecl_array_elttype(cl_object x) { - if (ecl_unlikely(!ECL_ARRAYP(x))) - FEwrong_type_argument(@[array], x); - return x->array.elttype; + if (ecl_unlikely(!ECL_ARRAYP(x))) + FEwrong_type_argument(@[array], x); + return x->array.elttype; } cl_object cl_array_rank(cl_object a) { - @(return ecl_make_fixnum(ecl_array_rank(a))) + @(return ecl_make_fixnum(ecl_array_rank(a))); } cl_index ecl_array_rank(cl_object a) { - switch (ecl_t_of(a)) { - case t_array: - return a->array.rank; + switch (ecl_t_of(a)) { + case t_array: + return a->array.rank; #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - case t_vector: - case t_bitvector: - return 1; - default: - FEwrong_type_only_arg(@[array-dimension], a, @[array]); - } + case t_base_string: + case t_vector: + case t_bitvector: + return 1; + default: + FEwrong_type_only_arg(@[array-dimension], a, @[array]); + } } cl_object cl_array_dimension(cl_object a, cl_object index) { - @(return ecl_make_fixnum(ecl_array_dimension(a, ecl_to_size(index)))) + @(return ecl_make_fixnum(ecl_array_dimension(a, ecl_to_size(index)))); } cl_index ecl_array_dimension(cl_object a, cl_index index) { - switch (ecl_t_of(a)) { - case t_array: { - if (ecl_unlikely(index > a->array.rank)) - FEwrong_dimensions(a, index+1); - return a->array.dims[index]; - } + switch (ecl_t_of(a)) { + case t_array: { + if (ecl_unlikely(index > a->array.rank)) + FEwrong_dimensions(a, index+1); + return a->array.dims[index]; + } #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - case t_vector: - case t_bitvector: - if (ecl_unlikely(index)) - FEwrong_dimensions(a, index+1); - return a->vector.dim; - default: - FEwrong_type_only_arg(@[array-dimension], a, @[array]); - } + case t_base_string: + case t_vector: + case t_bitvector: + if (ecl_unlikely(index)) + FEwrong_dimensions(a, index+1); + return a->vector.dim; + default: + FEwrong_type_only_arg(@[array-dimension], a, @[array]); + } } cl_object cl_array_total_size(cl_object a) { - if (ecl_unlikely(!ECL_ARRAYP(a))) - FEwrong_type_only_arg(@[array-total-size], a, @[array]); - @(return ecl_make_fixnum(a->array.dim)) + if (ecl_unlikely(!ECL_ARRAYP(a))) + FEwrong_type_only_arg(@[array-total-size], a, @[array]); + @(return ecl_make_fixnum(a->array.dim)); } cl_object cl_adjustable_array_p(cl_object a) { - if (ecl_unlikely(!ECL_ARRAYP(a))) - FEwrong_type_only_arg(@[adjustable-array-p], a, @[array]); - @(return (ECL_ADJUSTABLE_ARRAY_P(a) ? ECL_T : ECL_NIL)) + if (ecl_unlikely(!ECL_ARRAYP(a))) + FEwrong_type_only_arg(@[adjustable-array-p], a, @[array]); + @(return (ECL_ADJUSTABLE_ARRAY_P(a) ? ECL_T : ECL_NIL)); } /* - Internal function for checking if an array is displaced. + Internal function for checking if an array is displaced. */ cl_object cl_array_displacement(cl_object a) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object to_array; - cl_index offset; - - if (ecl_unlikely(!ECL_ARRAYP(a))) - FEwrong_type_only_arg(@[array-displacement], a, @[array]); - to_array = a->array.displaced; - if (Null(to_array)) { - offset = 0; - } else if (Null(to_array = CAR(a->array.displaced))) { - offset = 0; - } else { - switch (a->array.elttype) { - case ecl_aet_object: - offset = a->array.self.t - to_array->array.self.t; - break; - case ecl_aet_bc: - offset = a->array.self.bc - to_array->array.self.bc; - break; + const cl_env_ptr the_env = ecl_process_env(); + cl_object to_array; + cl_index offset; + + if (ecl_unlikely(!ECL_ARRAYP(a))) + FEwrong_type_only_arg(@[array-displacement], a, @[array]); + to_array = a->array.displaced; + if (Null(to_array)) { + offset = 0; + } else if (Null(to_array = CAR(a->array.displaced))) { + offset = 0; + } else { + switch (a->array.elttype) { + case ecl_aet_object: + offset = a->array.self.t - to_array->array.self.t; + break; + case ecl_aet_bc: + offset = a->array.self.bc - to_array->array.self.bc; + break; #ifdef ECL_UNICODE - case ecl_aet_ch: - offset = a->array.self.c - to_array->array.self.c; - break; -#endif - case ecl_aet_bit: - offset = a->array.self.bit - to_array->array.self.bit; - offset = offset * CHAR_BIT + a->array.offset - - to_array->array.offset; - break; - case ecl_aet_fix: - offset = a->array.self.fix - to_array->array.self.fix; - break; - case ecl_aet_index: - offset = a->array.self.fix - to_array->array.self.fix; - break; - case ecl_aet_sf: - offset = a->array.self.sf - to_array->array.self.sf; - break; - case ecl_aet_df: - offset = a->array.self.df - to_array->array.self.df; - break; - case ecl_aet_b8: - case ecl_aet_i8: - offset = a->array.self.b8 - to_array->array.self.b8; - break; + case ecl_aet_ch: + offset = a->array.self.c - to_array->array.self.c; + break; +#endif + case ecl_aet_bit: + offset = a->array.self.bit - to_array->array.self.bit; + offset = offset * CHAR_BIT + a->array.offset + - to_array->array.offset; + break; + case ecl_aet_fix: + offset = a->array.self.fix - to_array->array.self.fix; + break; + case ecl_aet_index: + offset = a->array.self.fix - to_array->array.self.fix; + break; + case ecl_aet_sf: + offset = a->array.self.sf - to_array->array.self.sf; + break; + case ecl_aet_df: + offset = a->array.self.df - to_array->array.self.df; + break; + case ecl_aet_b8: + case ecl_aet_i8: + offset = a->array.self.b8 - to_array->array.self.b8; + break; #ifdef ecl_uint16_t - case ecl_aet_b16: - case ecl_aet_i16: - offset = a->array.self.b16 - to_array->array.self.b16; - break; + case ecl_aet_b16: + case ecl_aet_i16: + offset = a->array.self.b16 - to_array->array.self.b16; + break; #endif #ifdef ecl_uint32_t - case ecl_aet_b32: - case ecl_aet_i32: - offset = a->array.self.b32 - to_array->array.self.b32; - break; + case ecl_aet_b32: + case ecl_aet_i32: + offset = a->array.self.b32 - to_array->array.self.b32; + break; #endif #ifdef ecl_uint64_t - case ecl_aet_b64: - case ecl_aet_i64: - offset = a->array.self.b64 - to_array->array.self.b64; - break; -#endif - default: - FEbad_aet(); - } - } - ecl_return2(the_env, to_array, ecl_make_fixnum(offset)); + case ecl_aet_b64: + case ecl_aet_i64: + offset = a->array.self.b64 - to_array->array.self.b64; + break; +#endif + default: + FEbad_aet(); + } + } + ecl_return2(the_env, to_array, ecl_make_fixnum(offset)); } cl_object cl_svref(cl_object x, cl_object index) { - const cl_env_ptr the_env = ecl_process_env(); - cl_index i; + const cl_env_ptr the_env = ecl_process_env(); + cl_index i; - if (ecl_unlikely(ecl_t_of(x) != t_vector || - (x->vector.flags & (ECL_FLAG_ADJUSTABLE | ECL_FLAG_HAS_FILL_POINTER)) || - CAR(x->vector.displaced) != ECL_NIL || - (cl_elttype)x->vector.elttype != ecl_aet_object)) - { - FEwrong_type_nth_arg(@[svref],1,x,@[simple-vector]); - } - i = checked_index(@[svref], x, -1, index, x->vector.dim); - ecl_return1(the_env, x->vector.self.t[i]); + if (ecl_unlikely(ecl_t_of(x) != t_vector || + (x->vector.flags & (ECL_FLAG_ADJUSTABLE | ECL_FLAG_HAS_FILL_POINTER)) || + CAR(x->vector.displaced) != ECL_NIL || + (cl_elttype)x->vector.elttype != ecl_aet_object)) + { + FEwrong_type_nth_arg(@[svref],1,x,@[simple-vector]); + } + i = checked_index(@[svref], x, -1, index, x->vector.dim); + ecl_return1(the_env, x->vector.self.t[i]); } cl_object si_svset(cl_object x, cl_object index, cl_object v) { - const cl_env_ptr the_env = ecl_process_env(); - cl_index i; + const cl_env_ptr the_env = ecl_process_env(); + cl_index i; - if (ecl_unlikely(ecl_t_of(x) != t_vector || - (x->vector.flags & (ECL_FLAG_ADJUSTABLE | ECL_FLAG_HAS_FILL_POINTER)) || - CAR(x->vector.displaced) != ECL_NIL || - (cl_elttype)x->vector.elttype != ecl_aet_object)) - { - FEwrong_type_nth_arg(@[si::svset],1,x,@[simple-vector]); - } - i = checked_index(@[svref], x, -1, index, x->vector.dim); - ecl_return1(the_env, x->vector.self.t[i] = v); + if (ecl_unlikely(ecl_t_of(x) != t_vector || + (x->vector.flags & (ECL_FLAG_ADJUSTABLE | ECL_FLAG_HAS_FILL_POINTER)) || + CAR(x->vector.displaced) != ECL_NIL || + (cl_elttype)x->vector.elttype != ecl_aet_object)) + { + FEwrong_type_nth_arg(@[si::svset],1,x,@[simple-vector]); + } + i = checked_index(@[svref], x, -1, index, x->vector.dim); + ecl_return1(the_env, x->vector.self.t[i] = v); } cl_object cl_array_has_fill_pointer_p(cl_object a) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object r; - switch (ecl_t_of(a)) { - case t_array: - r = ECL_NIL; break; - case t_vector: - case t_bitvector: + const cl_env_ptr the_env = ecl_process_env(); + cl_object r; + switch (ecl_t_of(a)) { + case t_array: + r = ECL_NIL; break; + case t_vector: + case t_bitvector: #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - r = ECL_ARRAY_HAS_FILL_POINTER_P(a)? ECL_T : ECL_NIL; - break; - default: - FEwrong_type_nth_arg(@[array-has-fill-pointer-p],1,a,@[array]); - } - ecl_return1(the_env, r); + case t_base_string: + r = ECL_ARRAY_HAS_FILL_POINTER_P(a)? ECL_T : ECL_NIL; + break; + default: + FEwrong_type_nth_arg(@[array-has-fill-pointer-p],1,a,@[array]); + } + ecl_return1(the_env, r); } cl_object cl_fill_pointer(cl_object a) { - const cl_env_ptr the_env = ecl_process_env(); - if (ecl_unlikely(!ECL_VECTORP(a))) - FEwrong_type_only_arg(@[fill-pointer], a, @[vector]); - if (ecl_unlikely(!ECL_ARRAY_HAS_FILL_POINTER_P(a))) { - const char *type = "(AND VECTOR (SATISFIES ARRAY-HAS-FILL-POINTER-P))"; - FEwrong_type_nth_arg(@[fill-pointer], 1, a, ecl_read_from_cstring(type)); - } - ecl_return1(the_env, ecl_make_fixnum(a->vector.fillp)); + const cl_env_ptr the_env = ecl_process_env(); + if (ecl_unlikely(!ECL_VECTORP(a))) + FEwrong_type_only_arg(@[fill-pointer], a, @[vector]); + if (ecl_unlikely(!ECL_ARRAY_HAS_FILL_POINTER_P(a))) { + const char *type = "(AND VECTOR (SATISFIES ARRAY-HAS-FILL-POINTER-P))"; + FEwrong_type_nth_arg(@[fill-pointer], 1, a, ecl_read_from_cstring(type)); + } + ecl_return1(the_env, ecl_make_fixnum(a->vector.fillp)); } /* - Internal function for setting fill pointer. + Internal function for setting fill pointer. */ cl_object si_fill_pointer_set(cl_object a, cl_object fp) { - const cl_env_ptr the_env = ecl_process_env(); - cl_fixnum i; - if (ecl_unlikely(!ECL_VECTORP(a) || !ECL_ARRAY_HAS_FILL_POINTER_P(a))) { - const char *type = "(AND VECTOR (SATISFIES ARRAY-HAS-FILL-POINTER-P))"; - FEwrong_type_nth_arg(@[adjust-array], 1, a, - ecl_read_from_cstring(type)); - } - if (ecl_unlikely(!ECL_FIXNUMP(fp) || ((i = ecl_fixnum(fp)) < 0) || - (i > a->vector.dim))) { - cl_object type = ecl_make_integer_type(ecl_make_fixnum(0), - ecl_make_fixnum(a->vector.dim-1)); - FEwrong_type_key_arg(@[adjust-array], @[:fill-pointer], fp, type); - } - a->vector.fillp = i; - ecl_return1(the_env, fp); + const cl_env_ptr the_env = ecl_process_env(); + cl_fixnum i; + if (ecl_unlikely(!ECL_VECTORP(a) || !ECL_ARRAY_HAS_FILL_POINTER_P(a))) { + const char *type = "(AND VECTOR (SATISFIES ARRAY-HAS-FILL-POINTER-P))"; + FEwrong_type_nth_arg(@[adjust-array], 1, a, + ecl_read_from_cstring(type)); + } + if (ecl_unlikely(!ECL_FIXNUMP(fp) || ((i = ecl_fixnum(fp)) < 0) || + (i > a->vector.dim))) { + cl_object type = ecl_make_integer_type(ecl_make_fixnum(0), + ecl_make_fixnum(a->vector.dim-1)); + FEwrong_type_key_arg(@[adjust-array], @[:fill-pointer], fp, type); + } + a->vector.fillp = i; + ecl_return1(the_env, fp); } /* - Internal function for replacing the contents of arrays: + Internal function for replacing the contents of arrays: - (si:replace-array old-array new-array). + (si:replace-array old-array new-array). - Used in ADJUST-ARRAY. + Used in ADJUST-ARRAY. */ cl_object si_replace_array(cl_object olda, cl_object newa) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object dlist; - if (ecl_t_of(olda) != ecl_t_of(newa) - || (ecl_t_of(olda) == t_array && olda->array.rank != newa->array.rank)) - goto CANNOT; - if (!ECL_ADJUSTABLE_ARRAY_P(olda)) { - /* When an array is not adjustable, we simply output the new array */ - olda = newa; - goto OUTPUT; - } - for (dlist = CDR(olda->array.displaced); dlist != ECL_NIL; dlist = CDR(dlist)) { - cl_object other_array = CAR(dlist); - cl_object offset; - cl_array_displacement(other_array); - offset = ecl_nth_value(the_env, 1); - ecl_displace(other_array, newa, offset); - } - switch (ecl_t_of(olda)) { - case t_array: - case t_vector: - case t_bitvector: - olda->array = newa->array; - break; + const cl_env_ptr the_env = ecl_process_env(); + cl_object dlist; + if (ecl_t_of(olda) != ecl_t_of(newa) + || (ecl_t_of(olda) == t_array && olda->array.rank != newa->array.rank)) + goto CANNOT; + if (!ECL_ADJUSTABLE_ARRAY_P(olda)) { + /* When an array is not adjustable, we simply output the new array */ + olda = newa; + goto OUTPUT; + } + for (dlist = CDR(olda->array.displaced); dlist != ECL_NIL; dlist = CDR(dlist)) { + cl_object other_array = CAR(dlist); + cl_object offset; + cl_array_displacement(other_array); + offset = ecl_nth_value(the_env, 1); + ecl_displace(other_array, newa, offset); + } + switch (ecl_t_of(olda)) { + case t_array: + case t_vector: + case t_bitvector: + olda->array = newa->array; + break; #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - olda->base_string = newa->base_string; - break; - default: - CANNOT: - FEerror("Cannot replace the array ~S by the array ~S.", - 2, olda, newa); - } + case t_base_string: + olda->base_string = newa->base_string; + break; + default: + CANNOT: + FEerror("Cannot replace the array ~S by the array ~S.", + 2, olda, newa); + } OUTPUT: - ecl_return1(the_env, olda); + ecl_return1(the_env, olda); } void ecl_copy_subarray(cl_object dest, cl_index i0, cl_object orig, cl_index i1, cl_index l) { - cl_elttype t = ecl_array_elttype(dest); - if (i0 + l > dest->array.dim) { - l = dest->array.dim - i0; - } - if (i1 + l > orig->array.dim) { - l = orig->array.dim - i1; - } - if (t != ecl_array_elttype(orig) || t == ecl_aet_bit) { - if (dest == orig && i0 > i1) { - for (i0 += l, i1 += l; l--; ) { - ecl_aset_unsafe(dest, --i0, - ecl_aref_unsafe(orig, --i1)); - } - } else { - while (l--) { - ecl_aset_unsafe(dest, i0++, - ecl_aref_unsafe(orig, i1++)); - } - } - } else { - /* We could have singled out also dest == orig and used memcpy - * but gcc-4.6 breaks this code even when i0 < i1 if the regions - * overlap sufficiently. */ - cl_index elt_size = ecl_aet_size[t]; - memmove(dest->array.self.bc + i0 * elt_size, - orig->array.self.bc + i1 * elt_size, - l * elt_size); - } + cl_elttype t = ecl_array_elttype(dest); + if (i0 + l > dest->array.dim) { + l = dest->array.dim - i0; + } + if (i1 + l > orig->array.dim) { + l = orig->array.dim - i1; + } + if (t != ecl_array_elttype(orig) || t == ecl_aet_bit) { + if (dest == orig && i0 > i1) { + for (i0 += l, i1 += l; l--; ) { + ecl_aset_unsafe(dest, --i0, + ecl_aref_unsafe(orig, --i1)); + } + } else { + while (l--) { + ecl_aset_unsafe(dest, i0++, + ecl_aref_unsafe(orig, i1++)); + } + } + } else { + /* We could have singled out also dest == orig and used memcpy + * but gcc-4.6 breaks this code even when i0 < i1 if the regions + * overlap sufficiently. */ + cl_index elt_size = ecl_aet_size[t]; + memmove(dest->array.self.bc + i0 * elt_size, + orig->array.self.bc + i1 * elt_size, + l * elt_size); + } } void ecl_reverse_subarray(cl_object x, cl_index i0, cl_index i1) { - cl_elttype t = ecl_array_elttype(x); - cl_index i, j; - if (x->array.dim == 0) { - return; - } - if (i1 >= x->array.dim) { - i1 = x->array.dim; - } - switch (t) { - case ecl_aet_object: - case ecl_aet_fix: - case ecl_aet_index: - for (i = i0, j = i1-1; i < j; i++, --j) { - cl_object y = x->vector.self.t[i]; - x->vector.self.t[i] = x->vector.self.t[j]; - x->vector.self.t[j] = y; - } - break; - case ecl_aet_sf: - for (i = i0, j = i1-1; i < j; i++, --j) { - float y = x->array.self.sf[i]; - x->array.self.sf[i] = x->array.self.sf[j]; - x->array.self.sf[j] = y; - } - break; - case ecl_aet_df: - for (i = i0, j = i1-1; i < j; i++, --j) { - double y = x->array.self.df[i]; - x->array.self.df[i] = x->array.self.df[j]; - x->array.self.df[j] = y; - } - break; - case ecl_aet_bc: - for (i = i0, j = i1-1; i < j; i++, --j) { - ecl_base_char y = x->array.self.bc[i]; - x->array.self.bc[i] = x->array.self.bc[j]; - x->array.self.bc[j] = y; - } - break; - case ecl_aet_b8: - case ecl_aet_i8: - for (i = i0, j = i1-1; i < j; i++, --j) { - ecl_uint8_t y = x->array.self.b8[i]; - x->array.self.b8[i] = x->array.self.b8[j]; - x->array.self.b8[j] = y; - } - break; + cl_elttype t = ecl_array_elttype(x); + cl_index i, j; + if (x->array.dim == 0) { + return; + } + if (i1 >= x->array.dim) { + i1 = x->array.dim; + } + switch (t) { + case ecl_aet_object: + case ecl_aet_fix: + case ecl_aet_index: + for (i = i0, j = i1-1; i < j; i++, --j) { + cl_object y = x->vector.self.t[i]; + x->vector.self.t[i] = x->vector.self.t[j]; + x->vector.self.t[j] = y; + } + break; + case ecl_aet_sf: + for (i = i0, j = i1-1; i < j; i++, --j) { + float y = x->array.self.sf[i]; + x->array.self.sf[i] = x->array.self.sf[j]; + x->array.self.sf[j] = y; + } + break; + case ecl_aet_df: + for (i = i0, j = i1-1; i < j; i++, --j) { + double y = x->array.self.df[i]; + x->array.self.df[i] = x->array.self.df[j]; + x->array.self.df[j] = y; + } + break; + case ecl_aet_bc: + for (i = i0, j = i1-1; i < j; i++, --j) { + ecl_base_char y = x->array.self.bc[i]; + x->array.self.bc[i] = x->array.self.bc[j]; + x->array.self.bc[j] = y; + } + break; + case ecl_aet_b8: + case ecl_aet_i8: + for (i = i0, j = i1-1; i < j; i++, --j) { + ecl_uint8_t y = x->array.self.b8[i]; + x->array.self.b8[i] = x->array.self.b8[j]; + x->array.self.b8[j] = y; + } + break; #ifdef ecl_uint16_t - case ecl_aet_b16: - case ecl_aet_i16: - for (i = i0, j = i1-1; i < j; i++, --j) { - ecl_uint16_t y = x->array.self.b16[i]; - x->array.self.b16[i] = x->array.self.b16[j]; - x->array.self.b16[j] = y; - } - break; + case ecl_aet_b16: + case ecl_aet_i16: + for (i = i0, j = i1-1; i < j; i++, --j) { + ecl_uint16_t y = x->array.self.b16[i]; + x->array.self.b16[i] = x->array.self.b16[j]; + x->array.self.b16[j] = y; + } + break; #endif #ifdef ecl_uint32_t - case ecl_aet_b32: - case ecl_aet_i32: - for (i = i0, j = i1-1; i < j; i++, --j) { - ecl_uint32_t y = x->array.self.b32[i]; - x->array.self.b32[i] = x->array.self.b32[j]; - x->array.self.b32[j] = y; - } - break; + case ecl_aet_b32: + case ecl_aet_i32: + for (i = i0, j = i1-1; i < j; i++, --j) { + ecl_uint32_t y = x->array.self.b32[i]; + x->array.self.b32[i] = x->array.self.b32[j]; + x->array.self.b32[j] = y; + } + break; #endif #ifdef ecl_uint64_t - case ecl_aet_b64: - case ecl_aet_i64: - for (i = i0, j = i1-1; i < j; i++, --j) { - ecl_uint64_t y = x->array.self.b64[i]; - x->array.self.b64[i] = x->array.self.b64[j]; - x->array.self.b64[j] = y; - } - break; + case ecl_aet_b64: + case ecl_aet_i64: + for (i = i0, j = i1-1; i < j; i++, --j) { + ecl_uint64_t y = x->array.self.b64[i]; + x->array.self.b64[i] = x->array.self.b64[j]; + x->array.self.b64[j] = y; + } + break; #endif #ifdef ECL_UNICODE - case ecl_aet_ch: - for (i = i0, j = i1-1; i < j; i++, --j) { - ecl_character y = x->array.self.c[i]; - x->array.self.c[i] = x->array.self.c[j]; - x->array.self.c[j] = y; - } - break; -#endif - case ecl_aet_bit: - for (i = i0 + x->vector.offset, - j = i1 + x->vector.offset - 1; - i < j; - i++, --j) { - int k = x->array.self.bit[i/CHAR_BIT]&(0200>>i%CHAR_BIT); - if (x->array.self.bit[j/CHAR_BIT]&(0200>>j%CHAR_BIT)) - x->array.self.bit[i/CHAR_BIT] - |= 0200>>i%CHAR_BIT; - else - x->array.self.bit[i/CHAR_BIT] - &= ~(0200>>i%CHAR_BIT); - if (k) - x->array.self.bit[j/CHAR_BIT] - |= 0200>>j%CHAR_BIT; - else - x->array.self.bit[j/CHAR_BIT] - &= ~(0200>>j%CHAR_BIT); - } - break; - default: - FEbad_aet(); - } + case ecl_aet_ch: + for (i = i0, j = i1-1; i < j; i++, --j) { + ecl_character y = x->array.self.c[i]; + x->array.self.c[i] = x->array.self.c[j]; + x->array.self.c[j] = y; + } + break; +#endif + case ecl_aet_bit: + for (i = i0 + x->vector.offset, + j = i1 + x->vector.offset - 1; + i < j; + i++, --j) { + int k = x->array.self.bit[i/CHAR_BIT]&(0200>>i%CHAR_BIT); + if (x->array.self.bit[j/CHAR_BIT]&(0200>>j%CHAR_BIT)) + x->array.self.bit[i/CHAR_BIT] + |= 0200>>i%CHAR_BIT; + else + x->array.self.bit[i/CHAR_BIT] + &= ~(0200>>i%CHAR_BIT); + if (k) + x->array.self.bit[j/CHAR_BIT] + |= 0200>>j%CHAR_BIT; + else + x->array.self.bit[j/CHAR_BIT] + &= ~(0200>>j%CHAR_BIT); + } + break; + default: + FEbad_aet(); + } } cl_object si_copy_subarray(cl_object dest, cl_object start0, cl_object orig, cl_object start1, cl_object length) { - ecl_copy_subarray(dest, ecl_to_size(start0), - orig, ecl_to_size(start1), - ecl_to_size(length)); - @(return dest) + ecl_copy_subarray(dest, ecl_to_size(start0), + orig, ecl_to_size(start1), + ecl_to_size(length)); + @(return dest); } cl_object si_fill_array_with_elt(cl_object x, cl_object elt, cl_object start, cl_object end) { - cl_elttype t = ecl_array_elttype(x); - cl_index first = ecl_to_size(start); - cl_index last = Null(end)? x->array.dim : ecl_to_size(end); - if (first >= last) { - goto END; - } - switch (t) { - case ecl_aet_object: { - cl_object *p = x->vector.self.t + first; - for (first = last - first; first; --first, ++p) { *p = elt; } - break; - } - case ecl_aet_bc: { - ecl_base_char e = ecl_char_code(elt); - ecl_base_char *p = x->vector.self.bc + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; - } + cl_elttype t = ecl_array_elttype(x); + cl_index first = ecl_to_size(start); + cl_index last = Null(end)? x->array.dim : ecl_to_size(end); + if (first >= last) { + goto END; + } + switch (t) { + case ecl_aet_object: { + cl_object *p = x->vector.self.t + first; + for (first = last - first; first; --first, ++p) { *p = elt; } + break; + } + case ecl_aet_bc: { + ecl_base_char e = ecl_char_code(elt); + ecl_base_char *p = x->vector.self.bc + first; + for (first = last - first; first; --first, ++p) { *p = e; } + break; + } #ifdef ECL_UNICODE - case ecl_aet_ch: { - ecl_character e = ecl_char_code(elt); - ecl_character *p = x->vector.self.c + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; - } -#endif - case ecl_aet_fix: { - cl_fixnum e = ecl_to_fix(elt); - cl_fixnum *p = x->vector.self.fix + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; - } - case ecl_aet_index: { - cl_index e = ecl_to_size(elt); - cl_index *p = x->vector.self.index + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; - } - case ecl_aet_sf: { - float e = ecl_to_float(elt); - float *p = x->vector.self.sf + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; - } - case ecl_aet_df: { - double e = ecl_to_double(elt); - double *p = x->vector.self.df + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; - } - case ecl_aet_b8: { - uint8_t e = ecl_to_uint8_t(elt); - uint8_t *p = x->vector.self.b8 + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; - } - case ecl_aet_i8: { - int8_t e = ecl_to_int8_t(elt); - int8_t *p = x->vector.self.i8 + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; - } + case ecl_aet_ch: { + ecl_character e = ecl_char_code(elt); + ecl_character *p = x->vector.self.c + first; + for (first = last - first; first; --first, ++p) { *p = e; } + break; + } +#endif + case ecl_aet_fix: { + cl_fixnum e = ecl_to_fix(elt); + cl_fixnum *p = x->vector.self.fix + first; + for (first = last - first; first; --first, ++p) { *p = e; } + break; + } + case ecl_aet_index: { + cl_index e = ecl_to_size(elt); + cl_index *p = x->vector.self.index + first; + for (first = last - first; first; --first, ++p) { *p = e; } + break; + } + case ecl_aet_sf: { + float e = ecl_to_float(elt); + float *p = x->vector.self.sf + first; + for (first = last - first; first; --first, ++p) { *p = e; } + break; + } + case ecl_aet_df: { + double e = ecl_to_double(elt); + double *p = x->vector.self.df + first; + for (first = last - first; first; --first, ++p) { *p = e; } + break; + } + case ecl_aet_b8: { + uint8_t e = ecl_to_uint8_t(elt); + uint8_t *p = x->vector.self.b8 + first; + for (first = last - first; first; --first, ++p) { *p = e; } + break; + } + case ecl_aet_i8: { + int8_t e = ecl_to_int8_t(elt); + int8_t *p = x->vector.self.i8 + first; + for (first = last - first; first; --first, ++p) { *p = e; } + break; + } #ifdef ecl_uint16_t - case ecl_aet_b16: { - ecl_uint16_t e = ecl_to_uint16_t(elt); - ecl_uint16_t *p = x->vector.self.b16 + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; - } - case ecl_aet_i16: { - ecl_int16_t e = ecl_to_int16_t(elt); - ecl_int16_t *p = x->vector.self.i16 + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; - } + case ecl_aet_b16: { + ecl_uint16_t e = ecl_to_uint16_t(elt); + ecl_uint16_t *p = x->vector.self.b16 + first; + for (first = last - first; first; --first, ++p) { *p = e; } + break; + } + case ecl_aet_i16: { + ecl_int16_t e = ecl_to_int16_t(elt); + ecl_int16_t *p = x->vector.self.i16 + first; + for (first = last - first; first; --first, ++p) { *p = e; } + break; + } #endif #ifdef ecl_uint32_t - case ecl_aet_b32: { - ecl_uint32_t e = ecl_to_uint32_t(elt); - ecl_uint32_t *p = x->vector.self.b32 + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; - } - case ecl_aet_i32: { - ecl_int32_t e = ecl_to_int32_t(elt); - ecl_int32_t *p = x->vector.self.i32 + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; - } + case ecl_aet_b32: { + ecl_uint32_t e = ecl_to_uint32_t(elt); + ecl_uint32_t *p = x->vector.self.b32 + first; + for (first = last - first; first; --first, ++p) { *p = e; } + break; + } + case ecl_aet_i32: { + ecl_int32_t e = ecl_to_int32_t(elt); + ecl_int32_t *p = x->vector.self.i32 + first; + for (first = last - first; first; --first, ++p) { *p = e; } + break; + } #endif #ifdef ecl_uint64_t - case ecl_aet_b64: { - ecl_uint64_t e = ecl_to_uint64_t(elt); - ecl_uint64_t *p = x->vector.self.b64 + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; - } - case ecl_aet_i64: { - ecl_int64_t e = ecl_to_int64_t(elt); - ecl_int64_t *p = x->vector.self.i64 + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; - } -#endif - case ecl_aet_bit: { - int i = ecl_to_bit(elt); - for (last -= first, first += x->vector.offset; last; --last, ++first) { - int mask = 0200>>first%CHAR_BIT; - if (i == 0) - x->vector.self.bit[first/CHAR_BIT] &= ~mask; - else - x->vector.self.bit[first/CHAR_BIT] |= mask; - } - break; - } - default: - FEbad_aet(); - } + case ecl_aet_b64: { + ecl_uint64_t e = ecl_to_uint64_t(elt); + ecl_uint64_t *p = x->vector.self.b64 + first; + for (first = last - first; first; --first, ++p) { *p = e; } + break; + } + case ecl_aet_i64: { + ecl_int64_t e = ecl_to_int64_t(elt); + ecl_int64_t *p = x->vector.self.i64 + first; + for (first = last - first; first; --first, ++p) { *p = e; } + break; + } +#endif + case ecl_aet_bit: { + int i = ecl_to_bit(elt); + for (last -= first, first += x->vector.offset; last; --last, ++first) { + int mask = 0200>>first%CHAR_BIT; + if (i == 0) + x->vector.self.bit[first/CHAR_BIT] &= ~mask; + else + x->vector.self.bit[first/CHAR_BIT] |= mask; + } + break; + } + default: + FEbad_aet(); + } END: - @(return x) + @(return x); } diff -Nru ecl-16.1.2/src/c/assignment.d ecl-16.1.3+ds/src/c/assignment.d --- ecl-16.1.2/src/c/assignment.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/assignment.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - assignment.c -- Assignment. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * assignment.c - assignment + * + * Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. + * Copyright (c) 1990, Giuseppe Attardi. + * Copyright (c) 2001, Juan Jose Garcia Ripoll. + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -26,209 +21,215 @@ static void FEconstant_assignment(cl_object var) { - FEinvalid_variable("Cannot assign to the constant ~S.", var); + FEinvalid_variable("Cannot assign to the constant ~S.", var); } cl_object cl_set(cl_object var, cl_object value) { - const cl_env_ptr env = ecl_process_env(); - unlikely_if (Null(var)) { - FEconstant_assignment(var); - } - unlikely_if (ecl_t_of(var) != t_symbol) { - FEwrong_type_nth_arg(@[setq], 1, var, @[symbol]); - } - unlikely_if (var->symbol.stype & ecl_stp_constant) - FEconstant_assignment(var); - ecl_return1(env, ECL_SETQ(env, var, value)); + const cl_env_ptr env = ecl_process_env(); + unlikely_if (Null(var)) { + FEconstant_assignment(var); + } + unlikely_if (ecl_t_of(var) != t_symbol) { + FEwrong_type_nth_arg(@[setq], 1, var, @[symbol]); + } + unlikely_if (var->symbol.stype & ecl_stp_constant) + FEconstant_assignment(var); + ecl_return1(env, ECL_SETQ(env, var, value)); } cl_object ecl_setq(cl_env_ptr env, cl_object var, cl_object value) { - unlikely_if (Null(var)) { - FEconstant_assignment(var); - } - unlikely_if (ecl_t_of(var) != t_symbol) { - FEwrong_type_nth_arg(@[setq], 1, var, @[symbol]); - } - return ECL_SETQ(env, var, value); + unlikely_if (Null(var)) { + FEconstant_assignment(var); + } + unlikely_if (ecl_t_of(var) != t_symbol) { + FEwrong_type_nth_arg(@[setq], 1, var, @[symbol]); + } + return ECL_SETQ(env, var, value); } static cl_object unbound_setf_function_error(cl_narg narg, ...) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object name = the_env->function->cclosure.env; - FEundefined_function(cl_list(2, @'setf', name)); + const cl_env_ptr the_env = ecl_process_env(); + cl_object name = the_env->function->cclosure.env; + FEundefined_function(cl_list(2, @'setf', name)); } static cl_object make_setf_function_error(cl_object name) { - return ecl_make_cclosure_va((cl_objectfn)unbound_setf_function_error, - name, ECL_NIL); + return ecl_make_cclosure_va((cl_objectfn)unbound_setf_function_error, + name, ECL_NIL); } cl_object ecl_setf_definition(cl_object sym, cl_object createp) { - cl_env_ptr the_env = ecl_process_env(); - cl_object pair; - ECL_WITH_GLOBAL_ENV_RDLOCK_BEGIN(the_env) { - pair = ecl_gethash_safe(sym, cl_core.setf_definitions, ECL_NIL); - if (Null(pair) && !Null(createp)) { - createp = make_setf_function_error(sym); - pair = ecl_cons(createp, ECL_NIL); - ecl_sethash(sym, cl_core.setf_definitions, pair); - } - } ECL_WITH_GLOBAL_ENV_RDLOCK_END; - return pair; + cl_env_ptr the_env = ecl_process_env(); + cl_object pair; + ECL_WITH_GLOBAL_ENV_RDLOCK_BEGIN(the_env) { + pair = ecl_gethash_safe(sym, cl_core.setf_definitions, ECL_NIL); + if (Null(pair) && !Null(createp)) { + createp = make_setf_function_error(sym); + pair = ecl_cons(createp, ECL_NIL); + ecl_sethash(sym, cl_core.setf_definitions, pair); + } + } ECL_WITH_GLOBAL_ENV_RDLOCK_END; + return pair; } cl_object si_setf_definition(cl_object sym, cl_object value) { - @(return ecl_setf_definition(sym, value)) + @(return ecl_setf_definition(sym, value)); } static void ecl_rem_setf_definition(cl_object sym) { - cl_env_ptr the_env = ecl_process_env(); - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(the_env) { - cl_object pair = ecl_gethash_safe(sym, cl_core.setf_definitions, ECL_NIL); - if (!Null(pair)) { - ECL_RPLACA(pair, make_setf_function_error(sym)); - ECL_RPLACD(pair, ECL_NIL); - /* - FIXME: This leaks resources - We actually cannot remove it, because some compiled - code might be using it! - ecl_remhash(sym, cl_core.setf_definitions); - */ - } - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + cl_env_ptr the_env = ecl_process_env(); + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(the_env) { + cl_object pair = ecl_gethash_safe(sym, cl_core.setf_definitions, ECL_NIL); + if (!Null(pair)) { + ECL_RPLACA(pair, make_setf_function_error(sym)); + ECL_RPLACD(pair, ECL_NIL); + /* + FIXME: This leaks resources + We actually cannot remove it, because some compiled + code might be using it! + ecl_remhash(sym, cl_core.setf_definitions); + */ + } + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; } @(defun si::fset (fname def &optional macro pprint) - cl_object sym = si_function_block_name(fname); - cl_object pack; - bool mflag; - int type; + cl_object sym = si_function_block_name(fname); + cl_object pack; + bool mflag; + int type; @ - if (Null(cl_functionp(def))) - FEinvalid_function(def); - pack = ecl_symbol_package(sym); - if (pack != ECL_NIL && pack->pack.locked) { - CEpackage_error("Attempt to redefine function ~S in locked package.", - "Ignore lock and proceed", pack, 1, fname); - } - mflag = !Null(macro); - type = ecl_symbol_type(sym); - if ((type & ecl_stp_special_form) && !mflag) { - FEerror("Given that ~S is a special form, ~S cannot be defined as a function.", - 2, sym, fname); - } - if (ECL_SYMBOLP(fname)) { - if (mflag) { - type |= ecl_stp_macro; - } else { - type &= ~ecl_stp_macro; - } - ecl_symbol_type_set(sym, type); - ECL_SYM_FUN(sym) = def; - ecl_clear_compiler_properties(sym); + if (Null(cl_functionp(def))) + FEinvalid_function(def); + pack = ecl_symbol_package(sym); + if (pack != ECL_NIL + && pack->pack.locked + && ECL_SYM_VAL(ecl_process_env(), + @'si::*ignore-package-locks*') == ECL_NIL) { + CEpackage_error("Attempt to redefine function ~S in locked package.", + "Ignore lock and proceed", pack, 1, fname); + } + mflag = !Null(macro); + type = ecl_symbol_type(sym); + if ((type & ecl_stp_special_form) && !mflag) { + FEerror("Given that ~S is a special form, ~S cannot be defined as a function.", + 2, sym, fname); + } + if (ECL_SYMBOLP(fname)) { + if (mflag) { + type |= ecl_stp_macro; + } else { + type &= ~ecl_stp_macro; + } + ecl_symbol_type_set(sym, type); + ECL_SYM_FUN(sym) = def; + ecl_clear_compiler_properties(sym); #ifndef ECL_CMU_FORMAT - if (pprint == ECL_NIL) - si_rem_sysprop(sym, @'si::pretty-print-format'); - else - si_put_sysprop(sym, @'si::pretty-print-format', pprint); + if (pprint == ECL_NIL) + si_rem_sysprop(sym, @'si::pretty-print-format'); + else + si_put_sysprop(sym, @'si::pretty-print-format', pprint); #endif - } else if (mflag) { - FEerror("~S is not a valid name for a macro.", 1, fname); - } else { - cl_object pair = ecl_setf_definition(sym, def); - ECL_RPLACA(pair, def); - ECL_RPLACD(pair, sym); - } - @(return def) + } else if (mflag) { + FEerror("~S is not a valid name for a macro.", 1, fname); + } else { + cl_object pair = ecl_setf_definition(sym, def); + ECL_RPLACA(pair, def); + ECL_RPLACD(pair, sym); + } + @(return def); @) cl_object cl_makunbound(cl_object sym) { - if (ecl_symbol_type(sym) & ecl_stp_constant) - FEinvalid_variable("Cannot unbind the constant ~S.", sym); - /* FIXME! The semantics of MAKUNBOUND is not very clear with local - bindings ... */ - ECL_SET(sym, OBJNULL); - @(return sym) + if (ecl_symbol_type(sym) & ecl_stp_constant) + FEinvalid_variable("Cannot unbind the constant ~S.", sym); + /* FIXME! The semantics of MAKUNBOUND is not very clear with local + bindings ... */ + ECL_SET(sym, OBJNULL); + @(return sym); } cl_object cl_fmakunbound(cl_object fname) { - cl_object sym = si_function_block_name(fname); - cl_object pack = ecl_symbol_package(sym); - if (pack != ECL_NIL && pack->pack.locked) { - CEpackage_error("Attempt to redefine function ~S in locked package.", - "Ignore lock and proceed", pack, 1, fname); - } - if (ECL_SYMBOLP(fname)) { - ecl_clear_compiler_properties(sym); - ECL_SYM_FUN(sym) = ECL_NIL; - ecl_symbol_type_set(sym, ecl_symbol_type(sym) & ~ecl_stp_macro); - } else { - ecl_rem_setf_definition(sym); - si_rem_sysprop(sym, @'si::setf-method'); - } - @(return fname) + cl_object sym = si_function_block_name(fname); + cl_object pack = ecl_symbol_package(sym); + if (pack != ECL_NIL + && pack->pack.locked + && ECL_SYM_VAL(ecl_process_env(), + @'si::*ignore-package-locks*') == ECL_NIL) { + CEpackage_error("Attempt to redefine function ~S in locked package.", + "Ignore lock and proceed", pack, 1, fname); + } + if (ECL_SYMBOLP(fname)) { + ecl_clear_compiler_properties(sym); + ECL_SYM_FUN(sym) = ECL_NIL; + ecl_symbol_type_set(sym, ecl_symbol_type(sym) & ~ecl_stp_macro); + } else { + ecl_rem_setf_definition(sym); + si_rem_sysprop(sym, @'si::setf-method'); + } + @(return fname); } void ecl_clear_compiler_properties(cl_object sym) { - if (ecl_option_values[ECL_OPT_BOOTED]) { - funcall(2, @'si::clear-compiler-properties', sym); - } + if (ecl_option_values[ECL_OPT_BOOTED]) { + funcall(2, @'si::clear-compiler-properties', sym); + } } cl_object si_get_sysprop(cl_object sym, cl_object prop) { - cl_env_ptr the_env = ecl_process_env(); - ECL_WITH_GLOBAL_ENV_RDLOCK_BEGIN(the_env) { - cl_object plist = ecl_gethash_safe(sym, cl_core.system_properties, ECL_NIL); - prop = ecl_getf(plist, prop, OBJNULL); - } ECL_WITH_GLOBAL_ENV_RDLOCK_END; - if (prop == OBJNULL) { - @(return ECL_NIL ECL_NIL); - } else { - @(return prop ECL_T); - } + cl_env_ptr the_env = ecl_process_env(); + ECL_WITH_GLOBAL_ENV_RDLOCK_BEGIN(the_env) { + cl_object plist = ecl_gethash_safe(sym, cl_core.system_properties, ECL_NIL); + prop = ecl_getf(plist, prop, OBJNULL); + } ECL_WITH_GLOBAL_ENV_RDLOCK_END; + if (prop == OBJNULL) { + @(return ECL_NIL ECL_NIL); + } else { + @(return prop ECL_T); + } } cl_object si_put_sysprop(cl_object sym, cl_object prop, cl_object value) { - cl_env_ptr the_env = ecl_process_env(); - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(the_env) { - cl_object plist = ecl_gethash_safe(sym, cl_core.system_properties, ECL_NIL); - ecl_sethash(sym, cl_core.system_properties, si_put_f(plist, value, prop)); - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; - @(return value); + cl_env_ptr the_env = ecl_process_env(); + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(the_env) { + cl_object plist = ecl_gethash_safe(sym, cl_core.system_properties, ECL_NIL); + ecl_sethash(sym, cl_core.system_properties, si_put_f(plist, value, prop)); + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + @(return value); } cl_object si_rem_sysprop(cl_object sym, cl_object prop) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object plist, found; - plist = ecl_gethash_safe(sym, cl_core.system_properties, ECL_NIL); - plist = si_rem_f(plist, prop); - found = ecl_nth_value(the_env, 1); - ecl_sethash(sym, cl_core.system_properties, plist); - ecl_return1(the_env, found); + const cl_env_ptr the_env = ecl_process_env(); + cl_object plist, found; + plist = ecl_gethash_safe(sym, cl_core.system_properties, ECL_NIL); + plist = si_rem_f(plist, prop); + found = ecl_nth_value(the_env, 1); + ecl_sethash(sym, cl_core.system_properties, plist); + ecl_return1(the_env, found); } diff -Nru ecl-16.1.2/src/c/backq.d ecl-16.1.3+ds/src/c/backq.d --- ecl-16.1.2/src/c/backq.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/backq.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - backq.c -- Backquote mechanism. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * backq.c - backquote mechanism + * + * Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. + * Copyright (c) 1990, Giuseppe Attardi. + * Copyright (c) 2001, Juan Jose Garcia Ripoll. + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -35,234 +30,234 @@ static cl_object kwote(cl_object x) { - cl_type t = ecl_t_of(x); - if ((t == t_symbol && !Null(x) && !ecl_keywordp(x)) || - t == t_list || t == t_vector) - x = CONS(@'quote', ecl_list1(x)); - return x; + cl_type t = ecl_t_of(x); + if ((t == t_symbol && !Null(x) && !ecl_keywordp(x)) || + t == t_list || t == t_vector) + x = CONS(@'quote', ecl_list1(x)); + return x; } /* - _cl_backq_cdr(&x) puts result into x and returns one of + _cl_backq_cdr(&x) puts result into x and returns one of - QUOTE the form should be quoted - EVAL the form should be evaluated - LIST the form should be applied to LIST - LISTX the form should be applied to LIST* - APPEND the form should be applied to APPEND - NCONC the form should be applied to NCONC + QUOTE the form should be quoted + EVAL the form should be evaluated + LIST the form should be applied to LIST + LISTX the form should be applied to LIST* + APPEND the form should be applied to APPEND + NCONC the form should be applied to NCONC */ static int _cl_backq_cdr(cl_object *px) { - cl_object x = *px, ax, dx; - int a, d, out; + cl_object x = *px, ax, dx; + int a, d, out; - if (ECL_ATOM(x)) - return(QUOTE); - if (CAR(x) == @'si::unquote') { - *px = CADR(x); - return(EVAL); - } - if (CAR(x) == @'si::unquote-splice' || CAR(x) == @'si::unquote-nsplice') - FEerror(",@@ or ,. has appeared in an illegal position.", 0); - - ax = CAR(x); dx = CDR(x); - a = _cl_backq_car(&ax); - d = _cl_backq_cdr(&dx); - if (d == QUOTE) { - switch (a) { - case QUOTE: - return(QUOTE); - - case EVAL: - if (Null(dx)) { - out = LIST; - } else if (CONSP(dx) && Null(CDR(dx))) { - dx = ecl_list1(kwote(CAR(dx))); - out = LIST; - } else { - dx = ecl_list1(kwote(dx)); - out = LISTX; - } - break; - case APPEND: - case NCONC: - if (Null(dx)) { - *px = ax; - return EVAL; - } else { - dx = ecl_list1(kwote(dx)); - out = a; - } - break; - default: - ecl_internal_error("backquote botch"); - } - } else if (d == EVAL) { - switch (a) { - case QUOTE: - ax = kwote(ax); - dx = ecl_list1(dx); - out = LISTX; - break; - case EVAL: - dx = ecl_list1(dx); - out = LISTX; - break; - case APPEND: - case NCONC: - dx = ecl_list1(dx); - out = a; - break; - default: - ecl_internal_error("backquote botch"); - } - } else if (d == a) { - out = d; - } else { - switch (d) { - case LIST: - if (a == QUOTE) { - ax = kwote(ax); - out = LIST; - goto OUTPUT; - } else if (a == EVAL) { - out = LIST; - goto OUTPUT; - } - dx = CONS(@'list', dx); - break; - case LISTX: - if (a == QUOTE) { - ax = kwote(ax); - out = LISTX; - goto OUTPUT; - } else if (a == EVAL) { - out = LISTX; - goto OUTPUT; - } - dx = CONS(@'list*', dx); - break; - case APPEND: - dx = CONS(@'append', dx); - break; - case NCONC: - dx = CONS(@'nconc', dx); - break; - default: - ecl_internal_error("backquote botch"); - } - switch (a) { - case QUOTE: - ax = kwote(ax); - dx = ecl_list1(dx); - out = LISTX; - break; - case EVAL: - dx = ecl_list1(dx); - out = LISTX; - break; - case APPEND: - case NCONC: - dx = ecl_list1(dx); - out = a; - break; - default: - ecl_internal_error("backquote botch"); - } - } + if (ECL_ATOM(x)) + return(QUOTE); + if (CAR(x) == @'si::unquote') { + *px = CADR(x); + return(EVAL); + } + if (CAR(x) == @'si::unquote-splice' || CAR(x) == @'si::unquote-nsplice') + FEerror(",@@ or ,. has appeared in an illegal position.", 0); + + ax = CAR(x); dx = CDR(x); + a = _cl_backq_car(&ax); + d = _cl_backq_cdr(&dx); + if (d == QUOTE) { + switch (a) { + case QUOTE: + return(QUOTE); + + case EVAL: + if (Null(dx)) { + out = LIST; + } else if (CONSP(dx) && Null(CDR(dx))) { + dx = ecl_list1(kwote(CAR(dx))); + out = LIST; + } else { + dx = ecl_list1(kwote(dx)); + out = LISTX; + } + break; + case APPEND: + case NCONC: + if (Null(dx)) { + *px = ax; + return EVAL; + } else { + dx = ecl_list1(kwote(dx)); + out = a; + } + break; + default: + ecl_internal_error("backquote botch"); + } + } else if (d == EVAL) { + switch (a) { + case QUOTE: + ax = kwote(ax); + dx = ecl_list1(dx); + out = LISTX; + break; + case EVAL: + dx = ecl_list1(dx); + out = LISTX; + break; + case APPEND: + case NCONC: + dx = ecl_list1(dx); + out = a; + break; + default: + ecl_internal_error("backquote botch"); + } + } else if (d == a) { + out = d; + } else { + switch (d) { + case LIST: + if (a == QUOTE) { + ax = kwote(ax); + out = LIST; + goto OUTPUT; + } else if (a == EVAL) { + out = LIST; + goto OUTPUT; + } + dx = CONS(@'list', dx); + break; + case LISTX: + if (a == QUOTE) { + ax = kwote(ax); + out = LISTX; + goto OUTPUT; + } else if (a == EVAL) { + out = LISTX; + goto OUTPUT; + } + dx = CONS(@'list*', dx); + break; + case APPEND: + dx = CONS(@'append', dx); + break; + case NCONC: + dx = CONS(@'nconc', dx); + break; + default: + ecl_internal_error("backquote botch"); + } + switch (a) { + case QUOTE: + ax = kwote(ax); + dx = ecl_list1(dx); + out = LISTX; + break; + case EVAL: + dx = ecl_list1(dx); + out = LISTX; + break; + case APPEND: + case NCONC: + dx = ecl_list1(dx); + out = a; + break; + default: + ecl_internal_error("backquote botch"); + } + } OUTPUT: - *px = CONS(ax, dx); - return out; + *px = CONS(ax, dx); + return out; } /* - _cl_backq_car(&x) puts result into x and returns one of + _cl_backq_car(&x) puts result into x and returns one of - QUOTE the form should be quoted - EVAL the form should be evaluated - APPEND the form should be appended - into the outer form - NCONC the form should be nconc'ed - into the outer form + QUOTE the form should be quoted + EVAL the form should be evaluated + APPEND the form should be appended + into the outer form + NCONC the form should be nconc'ed + into the outer form */ int _cl_backq_car(cl_object *px) { - cl_object x = *px; - int d; + cl_object x = *px; + int d; AGAIN: - if (ECL_ATOM(x)) - return(QUOTE); - if (CAR(x) == @'si::quasiquote') { - x = *px = backq(CADR(x)); - goto AGAIN; - } - if (CAR(x) == @'si::unquote') { - *px = CADR(x); - return EVAL; - } - if (CAR(x) == @'si::unquote-splice') { - *px = CADR(x); - return APPEND; - } - if (CAR(x) == @'si::unquote-nsplice') { - *px = CADR(x); - return NCONC; - } - d = _cl_backq_cdr(px); - switch (d) { - case QUOTE: - case EVAL: - return(d); - - case LIST: - *px = CONS(@'list', *px); - break; - - case LISTX: - *px = CONS(@'list*', *px); - break; - - case APPEND: - *px = CONS(@'append', *px); - break; - - case NCONC: - *px = CONS(@'nconc', *px); - break; - - default: - ecl_internal_error("backquote botch"); - } - return(EVAL); + if (ECL_ATOM(x)) + return(QUOTE); + if (CAR(x) == @'si::quasiquote') { + x = *px = backq(CADR(x)); + goto AGAIN; + } + if (CAR(x) == @'si::unquote') { + *px = CADR(x); + return EVAL; + } + if (CAR(x) == @'si::unquote-splice') { + *px = CADR(x); + return APPEND; + } + if (CAR(x) == @'si::unquote-nsplice') { + *px = CADR(x); + return NCONC; + } + d = _cl_backq_cdr(px); + switch (d) { + case QUOTE: + case EVAL: + return(d); + + case LIST: + *px = CONS(@'list', *px); + break; + + case LISTX: + *px = CONS(@'list*', *px); + break; + + case APPEND: + *px = CONS(@'append', *px); + break; + + case NCONC: + *px = CONS(@'nconc', *px); + break; + + default: + ecl_internal_error("backquote botch"); + } + return(EVAL); } static cl_object backq(cl_object x) { - int a; + int a; - a = _cl_backq_car(&x); - if (a == APPEND || a == NCONC) - FEerror(",@@ or ,. has appeared in an illegal position.", 0); - if (a == QUOTE) - return(kwote(x)); - return(x); + a = _cl_backq_car(&x); + if (a == APPEND || a == NCONC) + FEerror(",@@ or ,. has appeared in an illegal position.", 0); + if (a == QUOTE) + return(kwote(x)); + return(x); } static cl_object quasiquote_macro(cl_object whole, cl_object env) { - if (ecl_length(whole) != 2) { - FEprogram_error("Syntax error: ~S.", 1, whole); - } - @(return backq(CADR(whole))) + if (ecl_length(whole) != 2) { + FEprogram_error("Syntax error: ~S.", 1, whole); + } + @(return backq(CADR(whole))); } void init_backq(void) { - ecl_def_c_macro(@'si::quasiquote', quasiquote_macro, 2); + ecl_def_c_macro(@'si::quasiquote', quasiquote_macro, 2); } diff -Nru ecl-16.1.2/src/c/big.d ecl-16.1.3+ds/src/c/big.d --- ecl-16.1.2/src/c/big.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/big.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,20 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - big.c -- Bignum routines. -*/ -/* - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * big.c - bignum routines based on the GMP + * + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * Copyright (c) 2015 Daniel Kochmański + * + * See file 'LICENSE' for the copyright details. + * + */ #define ECL_INCLUDE_MATH_H #include @@ -28,309 +24,301 @@ void _ecl_big_register_free(cl_object x) { - return; - /* We only need to free the integer when it gets too large */ - if (ECL_BIGNUM_DIM(x) > 3 * ECL_BIG_REGISTER_SIZE) { - mpz_realloc2(x->big.big_num, ECL_BIG_REGISTER_SIZE * GMP_LIMB_BITS); - } + return; } static cl_object _ecl_alloc_compact_bignum(cl_index limbs) { -#if 1 - cl_index bytes = limbs * sizeof(mp_limb_t); - cl_object new_big = ecl_alloc_compact_object(t_bignum, bytes); - ECL_BIGNUM_LIMBS(new_big) = ECL_COMPACT_OBJECT_EXTRA(new_big); - ECL_BIGNUM_SIZE(new_big) = 0; - ECL_BIGNUM_DIM(new_big) = limbs; -#else - cl_object new_big = ecl_alloc_object(t_bignum); - mpz_init2(new_big->big.big_num, limbs * GMP_LIMB_BITS); -#endif - return new_big; + cl_index bytes = limbs * sizeof(mp_limb_t); + cl_object new_big = ecl_alloc_compact_object(t_bignum, bytes); + ECL_BIGNUM_LIMBS(new_big) = ECL_COMPACT_OBJECT_EXTRA(new_big); + ECL_BIGNUM_SIZE(new_big) = 0; + ECL_BIGNUM_DIM(new_big) = limbs; + + return new_big; } static cl_object _ecl_big_copy(cl_object old) { - cl_fixnum size = ECL_BIGNUM_SIZE(old); - cl_index dim = (size < 0)? (-size) : size; - cl_index bytes = dim * sizeof(mp_limb_t); - cl_object new_big = _ecl_alloc_compact_bignum(dim); - ECL_BIGNUM_SIZE(new_big) = size; - memcpy(ECL_BIGNUM_LIMBS(new_big), ECL_BIGNUM_LIMBS(old), bytes); - return new_big; + cl_fixnum size = ECL_BIGNUM_SIZE(old); + cl_index dim = (size < 0)? (-size) : size; + cl_index bytes = dim * sizeof(mp_limb_t); + cl_object new_big = _ecl_alloc_compact_bignum(dim); + ECL_BIGNUM_SIZE(new_big) = size; + memcpy(ECL_BIGNUM_LIMBS(new_big), ECL_BIGNUM_LIMBS(old), bytes); + return new_big; } cl_object _ecl_big_register_copy(cl_object old) { - cl_object new_big = _ecl_big_copy(old); - _ecl_big_register_free(old); - return new_big; + cl_object new_big = _ecl_big_copy(old); + _ecl_big_register_free(old); + return new_big; } static cl_object big_normalize(cl_object x) { - int s = ECL_BIGNUM_SIZE(x); - if (s == 0) - return(ecl_make_fixnum(0)); - if (s == 1) { - mp_limb_t y = ECL_BIGNUM_LIMBS(x)[0]; - if (y <= MOST_POSITIVE_FIXNUM) - return ecl_make_fixnum(y); - } else if (s == -1) { - mp_limb_t y = ECL_BIGNUM_LIMBS(x)[0]; - if (y <= -MOST_NEGATIVE_FIXNUM) - return ecl_make_fixnum(-y); - } - return x; + int s = ECL_BIGNUM_SIZE(x); + if (s == 0) + return(ecl_make_fixnum(0)); + if (s == 1) { + mp_limb_t y = ECL_BIGNUM_LIMBS(x)[0]; + if (y <= MOST_POSITIVE_FIXNUM) + return ecl_make_fixnum(y); + } else if (s == -1) { + mp_limb_t y = ECL_BIGNUM_LIMBS(x)[0]; + if (y <= -MOST_NEGATIVE_FIXNUM) + return ecl_make_fixnum(-y); + } + return x; } cl_object _ecl_big_register_normalize(cl_object x) { - int s = ECL_BIGNUM_SIZE(x); - if (s == 0) - return(ecl_make_fixnum(0)); - if (s == 1) { - mp_limb_t y = ECL_BIGNUM_LIMBS(x)[0]; - if (y <= MOST_POSITIVE_FIXNUM) - return ecl_make_fixnum(y); - } else if (s == -1) { - mp_limb_t y = ECL_BIGNUM_LIMBS(x)[0]; - if (y <= -MOST_NEGATIVE_FIXNUM) - return ecl_make_fixnum(-y); - } - return _ecl_big_register_copy(x); + int s = ECL_BIGNUM_SIZE(x); + if (s == 0) + return(ecl_make_fixnum(0)); + if (s == 1) { + mp_limb_t y = ECL_BIGNUM_LIMBS(x)[0]; + if (y <= MOST_POSITIVE_FIXNUM) + return ecl_make_fixnum(y); + } else if (s == -1) { + mp_limb_t y = ECL_BIGNUM_LIMBS(x)[0]; + if (y <= -MOST_NEGATIVE_FIXNUM) + return ecl_make_fixnum(-y); + } + return _ecl_big_register_copy(x); } #if GMP_LIMB_BITS >= ECL_FIXNUM_BITS static const int limbs_per_fixnum = 1; #else static const int limbs_per_fixnum = (ECL_FIXNUM_BITS + GMP_LIMB_BITS - 1) / - GMP_LIMB_BITS; + GMP_LIMB_BITS; #endif -#define ECL_BIGNUM_ABS_SIZE(x) \ - (ECL_BIGNUM_SIZE(x)<0? -ECL_BIGNUM_SIZE(x) : ECL_BIGNUM_SIZE(x)) +#define ECL_BIGNUM_ABS_SIZE(x) \ + (ECL_BIGNUM_SIZE(x)<0? -ECL_BIGNUM_SIZE(x) : ECL_BIGNUM_SIZE(x)) cl_object _ecl_fix_times_fix(cl_fixnum x, cl_fixnum y) { #if ECL_LONG_BITS >= ECL_FIXNUM_BITS - ECL_WITH_TEMP_BIGNUM(z,4); - _ecl_big_set_si(z, x); - _ecl_big_mul_si(z, z, y); + ECL_WITH_TEMP_BIGNUM(z,4); + _ecl_big_set_si(z, x); + _ecl_big_mul_si(z, z, y); #else - ECL_WITH_TEMP_BIGNUM(z,4); - ECL_WITH_TEMP_BIGNUM(w,4); - _ecl_big_set_fixnum(z, x); - _ecl_big_set_fixnum(w, y); - _ecl_big_mul(z, z, w); + ECL_WITH_TEMP_BIGNUM(z,4); + ECL_WITH_TEMP_BIGNUM(w,4); + _ecl_big_set_fixnum(z, x); + _ecl_big_set_fixnum(w, y); + _ecl_big_mul(z, z, w); #endif - { - cl_object y = big_normalize(z); - if (y == z) y = _ecl_big_copy(z); - return y; - } + { + cl_object y = big_normalize(z); + if (y == z) y = _ecl_big_copy(z); + return y; + } } cl_object _ecl_big_times_big(cl_object a, cl_object b) { - cl_index size_a = ECL_BIGNUM_ABS_SIZE(a); - cl_index size_b = ECL_BIGNUM_ABS_SIZE(b); - cl_index size = size_a + size_b; - cl_object z = _ecl_alloc_compact_bignum(size); - _ecl_big_mul(z, a, b); - return z; + cl_index size_a = ECL_BIGNUM_ABS_SIZE(a); + cl_index size_b = ECL_BIGNUM_ABS_SIZE(b); + cl_index size = size_a + size_b; + cl_object z = _ecl_alloc_compact_bignum(size); + _ecl_big_mul(z, a, b); + return z; } cl_object _ecl_big_times_fix(cl_object b, cl_fixnum i) { - cl_index size; - cl_object z; + cl_index size; + cl_object z; - if (i == 0) - return ecl_make_fixnum(0); - if (i == 1) - return b; - size = ECL_BIGNUM_ABS_SIZE(b); - size += limbs_per_fixnum; - z = _ecl_alloc_compact_bignum(size); + if (i == 0) + return ecl_make_fixnum(0); + if (i == 1) + return b; + size = ECL_BIGNUM_ABS_SIZE(b); + size += limbs_per_fixnum; + z = _ecl_alloc_compact_bignum(size); #if ECL_LONG_BITS >= ECL_FIXNUM_BITS - _ecl_big_mul_si(z, b, i); + _ecl_big_mul_si(z, b, i); #else - { - ECL_WITH_TEMP_BIGNUM(w,4); - _ecl_big_set_fixnum(w, i); - _ecl_big_mul(z, b, w); - } + { + ECL_WITH_TEMP_BIGNUM(w,4); + _ecl_big_set_fixnum(w, i); + _ecl_big_mul(z, b, w); + } #endif - return z; + return z; } cl_object _ecl_big_plus_fix(cl_object a, cl_fixnum b) { - ECL_WITH_TEMP_BIGNUM(big_b, 2); - _ecl_big_set_fixnum(big_b, b); - return _ecl_big_plus_big(a, big_b); + ECL_WITH_TEMP_BIGNUM(big_b, 2); + _ecl_big_set_fixnum(big_b, b); + return _ecl_big_plus_big(a, big_b); } cl_object _ecl_big_plus_big(cl_object a, cl_object b) { - cl_index size_a = ECL_BIGNUM_ABS_SIZE(a); - cl_index size_b = ECL_BIGNUM_ABS_SIZE(b); - cl_index size_z = (size_a < size_b)? (size_b + 1) : (size_a + 1); - cl_object z = _ecl_alloc_compact_bignum(size_z); - _ecl_big_add(z, a, b); - return big_normalize(z); + cl_index size_a = ECL_BIGNUM_ABS_SIZE(a); + cl_index size_b = ECL_BIGNUM_ABS_SIZE(b); + cl_index size_z = (size_a < size_b)? (size_b + 1) : (size_a + 1); + cl_object z = _ecl_alloc_compact_bignum(size_z); + _ecl_big_add(z, a, b); + return big_normalize(z); } cl_object _ecl_big_minus_big(cl_object a, cl_object b) { - cl_index size_a = ECL_BIGNUM_ABS_SIZE(a); - cl_index size_b = ECL_BIGNUM_ABS_SIZE(b); - cl_index size_z = (size_a < size_b)? (size_b + 1) : (size_a + 1); - cl_object z = _ecl_alloc_compact_bignum(size_z); - mpz_sub(z->big.big_num, a->big.big_num, b->big.big_num); - return big_normalize(z); + cl_index size_a = ECL_BIGNUM_ABS_SIZE(a); + cl_index size_b = ECL_BIGNUM_ABS_SIZE(b); + cl_index size_z = (size_a < size_b)? (size_b + 1) : (size_a + 1); + cl_object z = _ecl_alloc_compact_bignum(size_z); + mpz_sub(z->big.big_num, a->big.big_num, b->big.big_num); + return big_normalize(z); } cl_object _ecl_fix_minus_big(cl_fixnum a, cl_object b) { - cl_index size_b = ECL_BIGNUM_ABS_SIZE(b); - cl_index size_z = size_b + limbs_per_fixnum; - cl_object z = _ecl_alloc_compact_bignum(size_z); - _ecl_big_set_fixnum(z, a); - mpz_sub(z->big.big_num, z->big.big_num, b->big.big_num); - return big_normalize(z); + cl_index size_b = ECL_BIGNUM_ABS_SIZE(b); + cl_index size_z = size_b + limbs_per_fixnum; + cl_object z = _ecl_alloc_compact_bignum(size_z); + _ecl_big_set_fixnum(z, a); + mpz_sub(z->big.big_num, z->big.big_num, b->big.big_num); + return big_normalize(z); } cl_object _ecl_big_negate(cl_object a) { - cl_index size_a = ECL_BIGNUM_ABS_SIZE(a); - cl_object z = _ecl_alloc_compact_bignum(size_a); - mpz_neg(z->big.big_num, a->big.big_num); - return big_normalize(z); + cl_index size_a = ECL_BIGNUM_ABS_SIZE(a); + cl_object z = _ecl_alloc_compact_bignum(size_a); + mpz_neg(z->big.big_num, a->big.big_num); + return big_normalize(z); } cl_object _ecl_big_divided_by_big(cl_object a, cl_object b) { - cl_object z; - cl_index size_a = ECL_BIGNUM_ABS_SIZE(a); - cl_index size_b = ECL_BIGNUM_ABS_SIZE(b); - cl_fixnum size_z = size_a - size_b + 1; - if (size_z <= 0) size_z = 1; - z = _ecl_alloc_compact_bignum(size_z); - mpz_tdiv_q(z->big.big_num,a->big.big_num,b->big.big_num); - return big_normalize(z); + cl_object z; + cl_index size_a = ECL_BIGNUM_ABS_SIZE(a); + cl_index size_b = ECL_BIGNUM_ABS_SIZE(b); + cl_fixnum size_z = size_a - size_b + 1; + if (size_z <= 0) size_z = 1; + z = _ecl_alloc_compact_bignum(size_z); + mpz_tdiv_q(z->big.big_num,a->big.big_num,b->big.big_num); + return big_normalize(z); } cl_object _ecl_big_gcd(cl_object a, cl_object b) { - cl_object z = _ecl_big_register0(); - mpz_gcd(z->big.big_num, a->big.big_num, b->big.big_num); - return _ecl_big_register_normalize(z); + cl_object z = _ecl_big_register0(); + mpz_gcd(z->big.big_num, a->big.big_num, b->big.big_num); + return _ecl_big_register_normalize(z); } cl_object _ecl_big_divided_by_fix(cl_object x, cl_fixnum y) { - ECL_WITH_TEMP_BIGNUM(by, 2); - _ecl_big_set_fixnum(by, y); - return _ecl_big_divided_by_big(x, by); + ECL_WITH_TEMP_BIGNUM(by, 2); + _ecl_big_set_fixnum(by, y); + return _ecl_big_divided_by_big(x, by); } cl_object _ecl_big_ceiling(cl_object a, cl_object b, cl_object *pr) { - cl_object q = _ecl_big_register0(); - cl_object r = _ecl_big_register1(); - mpz_cdiv_qr(q->big.big_num, r->big.big_num, a->big.big_num, b->big.big_num); - *pr = _ecl_big_register_normalize(r); - return _ecl_big_register_normalize(q); + cl_object q = _ecl_big_register0(); + cl_object r = _ecl_big_register1(); + mpz_cdiv_qr(q->big.big_num, r->big.big_num, a->big.big_num, b->big.big_num); + *pr = _ecl_big_register_normalize(r); + return _ecl_big_register_normalize(q); } cl_object _ecl_big_floor(cl_object a, cl_object b, cl_object *pr) { - cl_object q = _ecl_big_register0(); - cl_object r = _ecl_big_register1(); - mpz_fdiv_qr(q->big.big_num, r->big.big_num, a->big.big_num, b->big.big_num); - *pr = _ecl_big_register_normalize(r); - return _ecl_big_register_normalize(q); + cl_object q = _ecl_big_register0(); + cl_object r = _ecl_big_register1(); + mpz_fdiv_qr(q->big.big_num, r->big.big_num, a->big.big_num, b->big.big_num); + *pr = _ecl_big_register_normalize(r); + return _ecl_big_register_normalize(q); } cl_object _ecl_fix_divided_by_big(cl_fixnum x, cl_object y) { - ECL_WITH_TEMP_BIGNUM(bx, 2); - _ecl_big_set_fixnum(bx, x); - return _ecl_big_divided_by_big(bx, y); + ECL_WITH_TEMP_BIGNUM(bx, 2); + _ecl_big_set_fixnum(bx, x); + return _ecl_big_divided_by_big(bx, y); } static void * mp_alloc(size_t size) { - return ecl_alloc_uncollectable(size); + return ecl_alloc_uncollectable(size); } static void mp_free(void *ptr, size_t size) { - ecl_free_uncollectable(ptr); + ecl_free_uncollectable(ptr); } static void * mp_realloc(void *ptr, size_t osize, size_t nsize) { - mp_limb_t *p = mp_alloc(nsize); - memcpy(p, ptr, (osize < nsize)? osize : nsize); - mp_free(ptr, osize); - return p; + mp_limb_t *p = mp_alloc(nsize); + memcpy(p, ptr, (osize < nsize)? osize : nsize); + mp_free(ptr, osize); + return p; } cl_fixnum fixint(cl_object x) { - if (ECL_FIXNUMP(x)) - return ecl_fixnum(x); - if (ECL_BIGNUMP(x)) { - if (mpz_fits_slong_p(x->big.big_num)) { - return mpz_get_si(x->big.big_num); - } - } - FEwrong_type_argument(@[fixnum], x); + if (ECL_FIXNUMP(x)) + return ecl_fixnum(x); + if (ECL_BIGNUMP(x)) { + if (mpz_fits_slong_p(x->big.big_num)) { + return mpz_get_si(x->big.big_num); + } + } + FEwrong_type_argument(@[fixnum], x); } cl_index fixnnint(cl_object x) { - if (ECL_FIXNUMP(x)) { - cl_fixnum i = ecl_fixnum(x); - if (i >= 0) - return i; - } else if (ECL_BIGNUMP(x)) { - if (mpz_fits_ulong_p(x->big.big_num)) { - return mpz_get_ui(x->big.big_num); - } - } - FEwrong_type_argument(cl_list(3, @'integer', ecl_make_fixnum(0), - ecl_make_fixnum(MOST_POSITIVE_FIXNUM)), - x); + if (ECL_FIXNUMP(x)) { + cl_fixnum i = ecl_fixnum(x); + if (i >= 0) + return i; + } else if (ECL_BIGNUMP(x)) { + if (mpz_fits_ulong_p(x->big.big_num)) { + return mpz_get_ui(x->big.big_num); + } + } + FEwrong_type_argument(cl_list(3, @'integer', ecl_make_fixnum(0), + ecl_make_fixnum(MOST_POSITIVE_FIXNUM)), + x); } #undef _ecl_big_set_fixnum @@ -339,75 +327,75 @@ cl_object _ecl_big_set_fixnum(cl_object x, cl_fixnum f) { - mpz_set_si((x)->big.big_num,(f)); - return x; + mpz_set_si((x)->big.big_num,(f)); + return x; } cl_object _ecl_big_set_index(cl_object x, cl_index f) { - mpz_set_ui((x)->big.big_num,(f)); - return x; + mpz_set_ui((x)->big.big_num,(f)); + return x; } cl_fixnum _ecl_big_get_fixnum(cl_object x) { - return mpz_get_si((x)->big.big_num); + return mpz_get_si((x)->big.big_num); } cl_index _ecl_big_get_index(cl_object x) { - return mpz_get_ui((x)->big.big_num); + return mpz_get_ui((x)->big.big_num); } #elif GMP_LIMB_BITS >= ECL_FIXNUM_BITS cl_object _ecl_big_set_fixnum(cl_object x, cl_fixnum f) { - if (f == 0) { - mpz_set_si(x->big.big_num, 0); - } else if (f > 0) { - ECL_BIGNUM_SIZE(x) = 1; - ECL_BIGNUM_LIMBS(x)[0] = f; - } else if (f < 0) { - ECL_BIGNUM_SIZE(x) = -1; - ECL_BIGNUM_LIMBS(x)[0] = -f; - } + if (f == 0) { + mpz_set_si(x->big.big_num, 0); + } else if (f > 0) { + ECL_BIGNUM_SIZE(x) = 1; + ECL_BIGNUM_LIMBS(x)[0] = f; + } else if (f < 0) { + ECL_BIGNUM_SIZE(x) = -1; + ECL_BIGNUM_LIMBS(x)[0] = -f; + } } cl_object _ecl_big_set_index(cl_object x, cl_index f) { - if (f == 0) { - mpz_set_si(x->big.big_num, 0); - } else if (f > 0) { - ECL_BIGNUM_SIZE(x) = 1; - ECL_BIGNUM_LIMBS(x)[0] = f; - } + if (f == 0) { + mpz_set_si(x->big.big_num, 0); + } else if (f > 0) { + ECL_BIGNUM_SIZE(x) = 1; + ECL_BIGNUM_LIMBS(x)[0] = f; + } } cl_fixnum _ecl_big_get_fixnum(cl_object x) { - /* INV: x is a bignum and thus size != 0 */ - cl_fixnum output = ECL_BIGNUM_LIMBS(x)[0]; - return (ECL_BIGNUM_SIZE(x) > 0) ? output : -output; + /* INV: x is a bignum and thus size != 0 */ + cl_fixnum output = ECL_BIGNUM_LIMBS(x)[0]; + return (ECL_BIGNUM_SIZE(x) > 0) ? output : -output; } cl_index _ecl_big_get_index(cl_object x) { - /* INV: x is a bignum and thus size != 0 */ - cl_index output = ECL_BIGNUM_LIMBS(x)[0]; - return (ECL_BIGNUM_SIZE(x) > 0)? output : ~(output - 1); + /* INV: x is a bignum and thus size != 0 */ + cl_index output = ECL_BIGNUM_LIMBS(x)[0]; + return (ECL_BIGNUM_SIZE(x) > 0)? output : ~(output - 1); } bool _ecl_big_fits_in_index(cl_object x) { - /* INV: x is a bignum and thus size != 0 */ - return (ECL_BIGNUM_SIZE(x) ^ 1) == 0; + /* INV: x is a bignum and thus size != 0 */ + return (ECL_BIGNUM_SIZE(x) ^ 1) == 0; } #else # error "ECL cannot build with GMP when both long and mp_limb_t are smaller than cl_fixnum" @@ -417,153 +405,153 @@ long double _ecl_big_to_long_double(cl_object o) { - long double output = 0; - int i, l = mpz_size(o->big.big_num), exp = 0; - for (i = 0; i < l; i++) { - output += ldexpl(mpz_getlimbn(o->big.big_num, i), exp); - exp += GMP_LIMB_BITS; - } - return (mpz_sgn(o->big.big_num) < 0)? -output : output; + long double output = 0; + int i, l = mpz_size(o->big.big_num), exp = 0; + for (i = 0; i < l; i++) { + output += ldexpl(mpz_getlimbn(o->big.big_num, i), exp); + exp += GMP_LIMB_BITS; + } + return (mpz_sgn(o->big.big_num) < 0)? -output : output; } #endif static void mpz_ior_op(cl_object out, cl_object i, cl_object j) { - mpz_ior(out->big.big_num, i->big.big_num, j->big.big_num); + mpz_ior(out->big.big_num, i->big.big_num, j->big.big_num); } static void mpz_xor_op(cl_object out, cl_object i, cl_object j) { - mpz_xor(out->big.big_num, i->big.big_num, j->big.big_num); + mpz_xor(out->big.big_num, i->big.big_num, j->big.big_num); } static void mpz_and_op(cl_object out, cl_object i, cl_object j) { - mpz_and(out->big.big_num, i->big.big_num, j->big.big_num); + mpz_and(out->big.big_num, i->big.big_num, j->big.big_num); } static void mpz_eqv_op(cl_object out, cl_object i, cl_object j) { - mpz_xor(out->big.big_num, i->big.big_num, j->big.big_num); - mpz_com(out->big.big_num, out->big.big_num); + mpz_xor(out->big.big_num, i->big.big_num, j->big.big_num); + mpz_com(out->big.big_num, out->big.big_num); } static void mpz_nand_op(cl_object out, cl_object i, cl_object j) { - mpz_and(out->big.big_num, i->big.big_num, j->big.big_num); - mpz_com(out->big.big_num, out->big.big_num); + mpz_and(out->big.big_num, i->big.big_num, j->big.big_num); + mpz_com(out->big.big_num, out->big.big_num); } static void mpz_nor_op(cl_object out, cl_object i, cl_object j) { - mpz_ior(out->big.big_num, i->big.big_num, j->big.big_num); - mpz_com(out->big.big_num, out->big.big_num); + mpz_ior(out->big.big_num, i->big.big_num, j->big.big_num); + mpz_com(out->big.big_num, out->big.big_num); } static void mpz_andc1_op(cl_object out, cl_object i, cl_object j) { - mpz_com(out->big.big_num, i->big.big_num); - mpz_and(out->big.big_num, out->big.big_num, j->big.big_num); + mpz_com(out->big.big_num, i->big.big_num); + mpz_and(out->big.big_num, out->big.big_num, j->big.big_num); } static void mpz_orc1_op(cl_object out, cl_object i, cl_object j) { - mpz_com(out->big.big_num, i->big.big_num); - mpz_ior(out->big.big_num, out->big.big_num, j->big.big_num); + mpz_com(out->big.big_num, i->big.big_num); + mpz_ior(out->big.big_num, out->big.big_num, j->big.big_num); } static void mpz_andc2_op(cl_object out, cl_object i, cl_object j) { - /* (i & ~j) = ~((~i) | j) */ - mpz_orc1_op(out, i, j); - mpz_com(out->big.big_num, out->big.big_num); + /* (i & ~j) = ~((~i) | j) */ + mpz_orc1_op(out, i, j); + mpz_com(out->big.big_num, out->big.big_num); } static void mpz_orc2_op(cl_object out, cl_object i, cl_object j) { - /* (i | ~j) = ~((~i) & j) */ - mpz_andc1_op(out, i, j); - mpz_com(out->big.big_num, out->big.big_num); + /* (i | ~j) = ~((~i) & j) */ + mpz_andc1_op(out, i, j); + mpz_com(out->big.big_num, out->big.big_num); } static void mpz_b_clr_op(cl_object out, cl_object i, cl_object j) { - mpz_set_si(out->big.big_num, 0); + mpz_set_si(out->big.big_num, 0); } static void mpz_b_set_op(cl_object o, cl_object i, cl_object j) { - mpz_set_si(o->big.big_num, -1); + mpz_set_si(o->big.big_num, -1); } static void mpz_b_1_op(cl_object out, cl_object i, cl_object j) { - if (i != out) - mpz_set(out->big.big_num, i->big.big_num); + if (i != out) + mpz_set(out->big.big_num, i->big.big_num); } static void mpz_b_2_op(cl_object out, cl_object i, cl_object j) { - mpz_set(out->big.big_num, j->big.big_num); + mpz_set(out->big.big_num, j->big.big_num); } static void mpz_b_c1_op(cl_object out, cl_object i, cl_object j) { - mpz_com(out->big.big_num, i->big.big_num); + mpz_com(out->big.big_num, i->big.big_num); } static void mpz_b_c2_op(cl_object out, cl_object i, cl_object j) { - mpz_com(out->big.big_num, j->big.big_num); + mpz_com(out->big.big_num, j->big.big_num); } static _ecl_big_binary_op bignum_operations[16] = { - mpz_b_clr_op, - mpz_and_op, - mpz_andc2_op, - mpz_b_1_op, - mpz_andc1_op, - mpz_b_2_op, - mpz_xor_op, - mpz_ior_op, - mpz_nor_op, - mpz_eqv_op, - mpz_b_c2_op, - mpz_orc2_op, - mpz_b_c1_op, - mpz_orc1_op, - mpz_nand_op, - mpz_b_set_op}; + mpz_b_clr_op, + mpz_and_op, + mpz_andc2_op, + mpz_b_1_op, + mpz_andc1_op, + mpz_b_2_op, + mpz_xor_op, + mpz_ior_op, + mpz_nor_op, + mpz_eqv_op, + mpz_b_c2_op, + mpz_orc2_op, + mpz_b_c1_op, + mpz_orc1_op, + mpz_nand_op, + mpz_b_set_op}; _ecl_big_binary_op _ecl_big_boole_operator(int op) { - unlikely_if((op < 0) || (op >= 16)) { - ecl_internal_error("_ecl_big_boole_operator passed " - "an invalid operator"); - } - return bignum_operations[op]; + unlikely_if((op < 0) || (op >= 16)) { + ecl_internal_error("_ecl_big_boole_operator passed " + "an invalid operator"); + } + return bignum_operations[op]; } void init_big() { - if (ecl_option_values[ECL_OPT_SET_GMP_MEMORY_FUNCTIONS]) - mp_set_memory_functions(mp_alloc, mp_realloc, mp_free); + if (ecl_option_values[ECL_OPT_SET_GMP_MEMORY_FUNCTIONS]) + mp_set_memory_functions(mp_alloc, mp_realloc, mp_free); } diff -Nru ecl-16.1.2/src/c/big_ll.d ecl-16.1.3+ds/src/c/big_ll.d --- ecl-16.1.2/src/c/big_ll.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/big_ll.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ -/* - big_ll.c -- Bignum emulation with long long. - */ /* - Copyright (c) 2005, Maciek Pasternacki. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * big_ll.c - bignum emulation with long long + * + * Copyright (c) 2005 Maciek Pasternacki + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -24,145 +19,145 @@ cl_object _ecl_big_register_copy(cl_object old) { - cl_object new_big = ecl_alloc_object(t_bignum); - new_big->big.big_num = old->big.big_num; - return new_big; + cl_object new_big = ecl_alloc_object(t_bignum); + new_big->big.big_num = old->big.big_num; + return new_big; } static cl_object big_normalize(cl_object x) { - if (x->big.big_num == 0ll) - return(ecl_make_fixnum(0)); - if (x->big.big_num <= MOST_POSITIVE_FIXNUM && x->big.big_num >= MOST_NEGATIVE_FIXNUM) - return(ecl_make_fixnum(x->big.big_num)); - return x; + if (x->big.big_num == 0ll) + return(ecl_make_fixnum(0)); + if (x->big.big_num <= MOST_POSITIVE_FIXNUM && x->big.big_num >= MOST_NEGATIVE_FIXNUM) + return(ecl_make_fixnum(x->big.big_num)); + return x; } cl_object _ecl_big_register_normalize(cl_object x) { - if (x->big.big_num == 0ll) - return(ecl_make_fixnum(0)); - if (x->big.big_num <= MOST_POSITIVE_FIXNUM && x->big.big_num >= MOST_NEGATIVE_FIXNUM) - return(ecl_make_fixnum(x->big.big_num)); - return _ecl_big_register_copy(x); + if (x->big.big_num == 0ll) + return(ecl_make_fixnum(0)); + if (x->big.big_num <= MOST_POSITIVE_FIXNUM && x->big.big_num >= MOST_NEGATIVE_FIXNUM) + return(ecl_make_fixnum(x->big.big_num)); + return _ecl_big_register_copy(x); } static cl_object big_alloc(int size) { - volatile cl_object x = ecl_alloc_object(t_bignum); - if (size <= 0) - ecl_internal_error("negative or zero size for bignum in big_alloc"); - x->big.big_num = 0ll; - return x; + volatile cl_object x = ecl_alloc_object(t_bignum); + if (size <= 0) + ecl_internal_error("negative or zero size for bignum in big_alloc"); + x->big.big_num = 0ll; + return x; } static cl_object _ecl_big_copy(cl_object x) { - volatile cl_object y = ecl_alloc_object(t_bignum); - y->big.big_num = x->big.big_num; - return y; + volatile cl_object y = ecl_alloc_object(t_bignum); + y->big.big_num = x->big.big_num; + return y; } cl_object _ecl_big_gcd(cl_object x, cl_object y) { - big_num_t i = x->big.big_num, j = y->big.big_num; - cl_object gcd = ecl_alloc_object(t_bignum); - while ( 1 ) { - big_num_t k; - if ( ibig.big_num = k; - return gcd; - } - k = i % j; - i = j; - j = k; - } + big_num_t i = x->big.big_num, j = y->big.big_num; + cl_object gcd = ecl_alloc_object(t_bignum); + while ( 1 ) { + big_num_t k; + if ( ibig.big_num = k; + return gcd; + } + k = i % j; + i = j; + j = k; + } } int _ecl_big_num_t_sgn(big_num_t x) { - return ( x == (big_num_t)0 ) ? 0 : (x < (big_num_t)0) ? -1 : 1; + return ( x == (big_num_t)0 ) ? 0 : (x < (big_num_t)0) ? -1 : 1; } cl_object _ecl_big_times_big(cl_object x, cl_object y) { - cl_object z = ecl_alloc_object(t_bignum); - z->big.big_num = x->big.big_num * y->big.big_num; - return z; + cl_object z = ecl_alloc_object(t_bignum); + z->big.big_num = x->big.big_num * y->big.big_num; + return z; } cl_object _ecl_big_times_fix(cl_object x, cl_fixnum y) { - cl_object z = ecl_alloc_object(t_bignum); - z->big.big_num = x->big.big_num * y; - return big_normalize(z); + cl_object z = ecl_alloc_object(t_bignum); + z->big.big_num = x->big.big_num * y; + return big_normalize(z); } cl_object _ecl_big_plus_big(cl_object x, cl_object y) { - cl_object z = ecl_alloc_object(t_bignum); - z->big.big_num = x->big.big_num + y->big.big_num; - return z; + cl_object z = ecl_alloc_object(t_bignum); + z->big.big_num = x->big.big_num + y->big.big_num; + return z; } cl_object _ecl_big_plus_fix(cl_object x, cl_fixnum y) { - cl_object z = ecl_alloc_object(t_bignum); - z->big.big_num = x->big.big_num + y; - return big_normalize(z); + cl_object z = ecl_alloc_object(t_bignum); + z->big.big_num = x->big.big_num + y; + return big_normalize(z); } cl_object _ecl_fix_times_fix(cl_fixnum x, cl_fixnum y) { - cl_object z = ecl_alloc_object(t_bignum); - z->big.big_num = x * y; - return big_normalize(z); + cl_object z = ecl_alloc_object(t_bignum); + z->big.big_num = x * y; + return big_normalize(z); } cl_object _ecl_big_ceiling(cl_object a, cl_object b, cl_object *pr) { - cl_object q = ecl_alloc_object(t_bignum); - cl_object r = ecl_alloc_object(t_bignum); - q->big.num = x->big.num / y->big.big_num; - r->big.num = x->big.num % y->big.big_num; - *pr = big_normalize(r); - return big_normalize(q); + cl_object q = ecl_alloc_object(t_bignum); + cl_object r = ecl_alloc_object(t_bignum); + q->big.num = x->big.num / y->big.big_num; + r->big.num = x->big.num % y->big.big_num; + *pr = big_normalize(r); + return big_normalize(q); } cl_object _ecl_big_floor(cl_object a, cl_object b, cl_object *pr) { - cl_object q = ecl_alloc_object(t_bignum); - cl_object r = ecl_alloc_object(t_bignum); - q->big.num = x->big.num / y->big.big_num; - r->big.num = x->big.num % y->big.big_num; - *pr = big_normalize(r); - return big_normalize(q); + cl_object q = ecl_alloc_object(t_bignum); + cl_object r = ecl_alloc_object(t_bignum); + q->big.num = x->big.num / y->big.big_num; + r->big.num = x->big.num % y->big.big_num; + *pr = big_normalize(r); + return big_normalize(q); } cl_object _ecl_big_negate(cl_object x) { - cl_object z = ecl_alloc_object(t_bignum); - z->big.big_num = -x->big.big_num; - return z; + cl_object z = ecl_alloc_object(t_bignum); + z->big.big_num = -x->big.big_num; + return z; } void diff -Nru ecl-16.1.2/src/c/cfun.d ecl-16.1.3+ds/src/c/cfun.d --- ecl-16.1.2/src/c/cfun.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/cfun.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - cfun.c -- Compiled functions. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * cfun.c - compiled functions + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include /* for memmove() */ @@ -25,222 +20,222 @@ cl_object ecl_make_cfun(cl_objectfn_fixed c_function, cl_object name, cl_object cblock, int narg) { - cl_object cf; + cl_object cf; - cf = ecl_alloc_object(t_cfunfixed); - cf->cfunfixed.entry = dispatch_table[narg]; - cf->cfunfixed.entry_fixed = c_function; - cf->cfunfixed.name = name; - cf->cfunfixed.block = cblock; - cf->cfunfixed.file = ECL_NIL; - cf->cfunfixed.file_position = ecl_make_fixnum(-1); - cf->cfunfixed.narg = narg; - if (ecl_unlikely(narg < 0 || narg > ECL_C_ARGUMENTS_LIMIT)) - FEprogram_error_noreturn("ecl_make_cfun: function requires " - "too many arguments.",0); - return cf; + cf = ecl_alloc_object(t_cfunfixed); + cf->cfunfixed.entry = dispatch_table[narg]; + cf->cfunfixed.entry_fixed = c_function; + cf->cfunfixed.name = name; + cf->cfunfixed.block = cblock; + cf->cfunfixed.file = ECL_NIL; + cf->cfunfixed.file_position = ecl_make_fixnum(-1); + cf->cfunfixed.narg = narg; + if (ecl_unlikely(narg < 0 || narg > ECL_C_ARGUMENTS_LIMIT)) + FEprogram_error_noreturn("ecl_make_cfun: function requires " + "too many arguments.",0); + return cf; } cl_object ecl_make_cfun_va(cl_objectfn c_function, cl_object name, cl_object cblock) { - cl_object cf; + cl_object cf; - cf = ecl_alloc_object(t_cfun); - cf->cfun.entry = c_function; - cf->cfun.name = name; - cf->cfun.block = cblock; - cf->cfun.narg = -1; - cf->cfun.file = ECL_NIL; - cf->cfun.file_position = ecl_make_fixnum(-1); - return cf; + cf = ecl_alloc_object(t_cfun); + cf->cfun.entry = c_function; + cf->cfun.name = name; + cf->cfun.block = cblock; + cf->cfun.narg = -1; + cf->cfun.file = ECL_NIL; + cf->cfun.file_position = ecl_make_fixnum(-1); + return cf; } cl_object ecl_make_cclosure_va(cl_objectfn c_function, cl_object env, cl_object block) { - cl_object cc; + cl_object cc; - cc = ecl_alloc_object(t_cclosure); - cc->cclosure.entry = c_function; - cc->cclosure.env = env; - cc->cclosure.block = block; - cc->cclosure.file = ECL_NIL; - cc->cclosure.file_position = ecl_make_fixnum(-1); - return cc; + cc = ecl_alloc_object(t_cclosure); + cc->cclosure.entry = c_function; + cc->cclosure.env = env; + cc->cclosure.block = block; + cc->cclosure.file = ECL_NIL; + cc->cclosure.file_position = ecl_make_fixnum(-1); + return cc; } void ecl_def_c_function(cl_object sym, cl_objectfn_fixed c_function, int narg) { - si_fset(2, sym, - ecl_make_cfun(c_function, sym, ecl_symbol_value(@'si::*cblock*'), narg)); + si_fset(2, sym, + ecl_make_cfun(c_function, sym, ecl_symbol_value(@'si::*cblock*'), narg)); } void ecl_def_c_macro(cl_object sym, cl_objectfn_fixed c_function, int narg) { - si_fset(3, sym, - ecl_make_cfun(c_function, sym, ecl_symbol_value(@'si::*cblock*'), 2), - ECL_T); + si_fset(3, sym, + ecl_make_cfun(c_function, sym, ecl_symbol_value(@'si::*cblock*'), 2), + ECL_T); } void ecl_def_c_macro_va(cl_object sym, cl_objectfn c_function) { - si_fset(3, sym, - ecl_make_cfun_va(c_function, sym, ecl_symbol_value(@'si::*cblock*')), - ECL_T); + si_fset(3, sym, + ecl_make_cfun_va(c_function, sym, ecl_symbol_value(@'si::*cblock*')), + ECL_T); } void ecl_def_c_function_va(cl_object sym, cl_objectfn c_function) { - si_fset(2, sym, - ecl_make_cfun_va(c_function, sym, ecl_symbol_value(@'si::*cblock*'))); + si_fset(2, sym, + ecl_make_cfun_va(c_function, sym, ecl_symbol_value(@'si::*cblock*'))); } cl_object si_compiled_function_name(cl_object fun) { - cl_env_ptr the_env = ecl_process_env(); - cl_object output; + cl_env_ptr the_env = ecl_process_env(); + cl_object output; - switch(ecl_t_of(fun)) { - case t_bclosure: - fun = fun->bclosure.code; - case t_bytecodes: - output = fun->bytecodes.name; break; - case t_cfun: - case t_cfunfixed: - output = fun->cfun.name; break; - case t_cclosure: - output = ECL_NIL; break; - default: - FEinvalid_function(fun); - } - ecl_return1(the_env, output); + switch(ecl_t_of(fun)) { + case t_bclosure: + fun = fun->bclosure.code; + case t_bytecodes: + output = fun->bytecodes.name; break; + case t_cfun: + case t_cfunfixed: + output = fun->cfun.name; break; + case t_cclosure: + output = ECL_NIL; break; + default: + FEinvalid_function(fun); + } + ecl_return1(the_env, output); } cl_object cl_function_lambda_expression(cl_object fun) { - cl_env_ptr the_env = ecl_process_env(); - cl_object output, name = ECL_NIL, lex = ECL_NIL; + cl_env_ptr the_env = ecl_process_env(); + cl_object output, name = ECL_NIL, lex = ECL_NIL; - switch(ecl_t_of(fun)) { - case t_bclosure: - lex = fun->bclosure.lex; - fun = fun->bclosure.code; - case t_bytecodes: - name = fun->bytecodes.name; - output = fun->bytecodes.definition; - if (name == ECL_NIL) - output = cl_cons(@'lambda', output); - else if (name != @'si::bytecodes') - output = @list*(3, @'ext::lambda-block', name, output); - break; - case t_cfun: - case t_cfunfixed: - name = fun->cfun.name; - lex = ECL_NIL; - output = ECL_NIL; - break; - case t_cclosure: - name = ECL_NIL; - lex = ECL_T; - output = ECL_NIL; - break; - case t_instance: - if (fun->instance.isgf) { - name = ECL_NIL; - lex = ECL_NIL; - output = ECL_NIL; - break; - } - default: - FEinvalid_function(fun); - } - ecl_return3(the_env, output, lex, name); + switch(ecl_t_of(fun)) { + case t_bclosure: + lex = fun->bclosure.lex; + fun = fun->bclosure.code; + case t_bytecodes: + name = fun->bytecodes.name; + output = fun->bytecodes.definition; + if (name == ECL_NIL) + output = cl_cons(@'lambda', output); + else if (name != @'si::bytecodes') + output = @list*(3, @'ext::lambda-block', name, output); + break; + case t_cfun: + case t_cfunfixed: + name = fun->cfun.name; + lex = ECL_NIL; + output = ECL_NIL; + break; + case t_cclosure: + name = ECL_NIL; + lex = ECL_T; + output = ECL_NIL; + break; + case t_instance: + if (fun->instance.isgf) { + name = ECL_NIL; + lex = ECL_NIL; + output = ECL_NIL; + break; + } + default: + FEinvalid_function(fun); + } + ecl_return3(the_env, output, lex, name); } cl_object si_compiled_function_block(cl_object fun) { - cl_object output; + cl_object output; - switch(ecl_t_of(fun)) { - case t_cfun: - output = fun->cfun.block; break; - case t_cfunfixed: - output = fun->cfunfixed.block; break; - case t_cclosure: - output = fun->cclosure.block; break; - default: - FEerror("~S is not a C compiled function.", 1, fun); - } - @(return output) + switch(ecl_t_of(fun)) { + case t_cfun: + output = fun->cfun.block; break; + case t_cfunfixed: + output = fun->cfunfixed.block; break; + case t_cclosure: + output = fun->cclosure.block; break; + default: + FEerror("~S is not a C compiled function.", 1, fun); + } + @(return output); } cl_object si_compiled_function_file(cl_object b) { - cl_env_ptr the_env = ecl_process_env(); + cl_env_ptr the_env = ecl_process_env(); BEGIN: - switch (ecl_t_of(b)) { - case t_bclosure: - b = b->bclosure.code; - goto BEGIN; - case t_bytecodes: - ecl_return2(the_env, b->bytecodes.file, b->bytecodes.file_position); - case t_cfun: - ecl_return2(the_env, b->cfun.file, b->cfun.file_position); - case t_cfunfixed: - ecl_return2(the_env, b->cfunfixed.file, b->cfunfixed.file_position); - case t_cclosure: - ecl_return2(the_env, b->cclosure.file, b->cclosure.file_position); - default: - ecl_return2(the_env, ECL_NIL, ECL_NIL); - } + switch (ecl_t_of(b)) { + case t_bclosure: + b = b->bclosure.code; + goto BEGIN; + case t_bytecodes: + ecl_return2(the_env, b->bytecodes.file, b->bytecodes.file_position); + case t_cfun: + ecl_return2(the_env, b->cfun.file, b->cfun.file_position); + case t_cfunfixed: + ecl_return2(the_env, b->cfunfixed.file, b->cfunfixed.file_position); + case t_cclosure: + ecl_return2(the_env, b->cclosure.file, b->cclosure.file_position); + default: + ecl_return2(the_env, ECL_NIL, ECL_NIL); + } } void ecl_set_function_source_file_info(cl_object b, cl_object source, cl_object position) { BEGIN: - switch (ecl_t_of(b)) { - case t_bclosure: - b = b->bclosure.code; - goto BEGIN; - case t_bytecodes: - b->bytecodes.file = source; - b->bytecodes.file_position = position; - break; - case t_cfun: - b->cfun.file = source; - b->cfun.file_position = position; - break; - case t_cfunfixed: - b->cfunfixed.file = source; - b->cfunfixed.file_position = position; - break; - case t_cclosure: - b->cclosure.file = source; - b->cclosure.file_position = position; - break; - default: - FEerror("~S is not a compiled function.", 1, b); - } + switch (ecl_t_of(b)) { + case t_bclosure: + b = b->bclosure.code; + goto BEGIN; + case t_bytecodes: + b->bytecodes.file = source; + b->bytecodes.file_position = position; + break; + case t_cfun: + b->cfun.file = source; + b->cfun.file_position = position; + break; + case t_cfunfixed: + b->cfunfixed.file = source; + b->cfunfixed.file_position = position; + break; + case t_cclosure: + b->cclosure.file = source; + b->cclosure.file_position = position; + break; + default: + FEerror("~S is not a compiled function.", 1, b); + } } void ecl_cmp_defmacro(cl_object fun) { - si_fset(3, fun->cfun.name, fun, ECL_T); + si_fset(3, fun->cfun.name, fun, ECL_T); } void ecl_cmp_defun(cl_object fun) { - si_fset(2, fun->cfun.name, fun); + si_fset(2, fun->cfun.name, fun); } diff -Nru ecl-16.1.2/src/c/cfun_dispatch.d ecl-16.1.3+ds/src/c/cfun_dispatch.d --- ecl-16.1.2/src/c/cfun_dispatch.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/cfun_dispatch.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,8 +1,8 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - cfun_dispatch.c -- Trampolines for functions + cfun_dispatch.c - trampolines for functions */ static cl_object dispatch0 (cl_narg narg) { diff -Nru ecl-16.1.2/src/c/character.d ecl-16.1.3+ds/src/c/character.d --- ecl-16.1.2/src/c/character.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/character.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - character.d -- Character routines. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2015, Daniel Kochmański. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * character.d - character routines + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2015 Daniel Kochmański + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -25,449 +20,457 @@ ecl_character ecl_char_code(cl_object c) { - if (ecl_unlikely(!ECL_CHARACTERP(c))) - FEwrong_type_only_arg(@[char-code], c, @[character]); - return ECL_CHAR_CODE(c); + if (ecl_unlikely(!ECL_CHARACTERP(c))) + FEwrong_type_only_arg(@[char-code], c, @[character]); + return ECL_CHAR_CODE(c); } ecl_base_char ecl_base_char_code(cl_object c) { #ifdef ECL_UNICODE - if (ECL_CHARACTERP(c)) { - cl_fixnum code = ECL_CHAR_CODE(c); - if (code <= 255) { - return (int)code; - } - } - FEwrong_type_only_arg(@[char-code], c, @[base-char]); + if (ECL_CHARACTERP(c)) { + cl_fixnum code = ECL_CHAR_CODE(c); + if (code <= 255) { + return (int)code; + } + } + FEwrong_type_only_arg(@[char-code], c, @[base-char]); #else - return ecl_char_code(c); + return ecl_char_code(c); #endif } cl_object cl_standard_char_p(cl_object c) { - /* INV: ecl_char_code() checks the type */ - cl_fixnum i = ecl_char_code(c); - @(return (ecl_standard_char_p(i)? ECL_T : ECL_NIL)) + /* INV: ecl_char_code() checks the type */ + cl_fixnum i = ecl_char_code(c); + @(return (ecl_standard_char_p(i)? ECL_T : ECL_NIL)); } bool ecl_standard_char_p(ecl_character code) { - return ((' ' <= code) && (code < '\177')) || (code == '\n'); + return ((' ' <= code) && (code < '\177')) || (code == '\n'); } bool ecl_base_char_p(ecl_character c) { - return c <= 255; + return c <= 255; } cl_object cl_graphic_char_p(cl_object c) { - /* INV: ecl_char_code() checks the type */ - @(return (ecl_graphic_char_p(ecl_char_code(c))? ECL_T : ECL_NIL)) + /* INV: ecl_char_code() checks the type */ + @(return (ecl_graphic_char_p(ecl_char_code(c))? ECL_T : ECL_NIL)); } cl_object cl_alpha_char_p(cl_object c) { - /* INV: ecl_char_code() checks the type */ - @(return (ecl_alpha_char_p(ecl_char_code(c))? ECL_T : ECL_NIL)) + /* INV: ecl_char_code() checks the type */ + @(return (ecl_alpha_char_p(ecl_char_code(c))? ECL_T : ECL_NIL)); } cl_object cl_upper_case_p(cl_object c) { - /* INV: ecl_char_code() checks the type */ - @(return (ecl_upper_case_p(ecl_char_code(c))? ECL_T : ECL_NIL)) + /* INV: ecl_char_code() checks the type */ + @(return (ecl_upper_case_p(ecl_char_code(c))? ECL_T : ECL_NIL)); } cl_object cl_lower_case_p(cl_object c) { - /* INV: ecl_char_code() checks the type */ - @(return (ecl_lower_case_p(ecl_char_code(c))? ECL_T : ECL_NIL)) + /* INV: ecl_char_code() checks the type */ + @(return (ecl_lower_case_p(ecl_char_code(c))? ECL_T : ECL_NIL)); } cl_object cl_both_case_p(cl_object c) { - /* INV: ecl_char_code() checks the type */ - @(return (ecl_both_case_p(ecl_char_code(c))? ECL_T : ECL_NIL)) + /* INV: ecl_char_code() checks the type */ + @(return (ecl_both_case_p(ecl_char_code(c))? ECL_T : ECL_NIL)); } int ecl_string_case(cl_object s) { - int upcase; - cl_index i; - ecl_base_char *text; + int upcase; + cl_index i; + ecl_base_char *text; - switch (ecl_t_of(s)) { + switch (ecl_t_of(s)) { #ifdef ECL_UNICODE - case t_string: - s = si_coerce_to_base_string(s); + case t_string: + s = si_coerce_to_base_string(s); #endif - case t_base_string: - text = (ecl_base_char*)s->base_string.self; - for (i = 0, upcase = 0; i < s->base_string.dim; i++) { - if (ecl_upper_case_p(text[i])) { - if (upcase < 0) - return 0; - upcase = +1; - } else if (ecl_lower_case_p(text[i])) { - if (upcase > 0) - return 0; - upcase = -1; - } - } - break; - default: - FEwrong_type_argument(@[string], s); - } - return upcase; + case t_base_string: + text = (ecl_base_char*)s->base_string.self; + for (i = 0, upcase = 0; i < s->base_string.dim; i++) { + if (ecl_upper_case_p(text[i])) { + if (upcase < 0) + return 0; + upcase = +1; + } else if (ecl_lower_case_p(text[i])) { + if (upcase > 0) + return 0; + upcase = -1; + } + } + break; + default: + FEwrong_type_argument(@[string], s); + } + return upcase; } @(defun digit_char_p (c &optional (radix ecl_make_fixnum(10))) @ { - cl_fixnum basis, value; - if (ecl_unlikely(!ECL_FIXNUMP(radix) || - ecl_fixnum_lower(radix, ecl_make_fixnum(2)) || - ecl_fixnum_greater(radix, ecl_make_fixnum(36)))) { - FEwrong_type_nth_arg(@[digit-char-p], 2, radix, - ecl_make_integer_type(ecl_make_fixnum(2), - ecl_make_fixnum(36))); - } - basis = ecl_fixnum(radix); - value = ecl_digitp(ecl_char_code(c), basis); - @(return ((value < 0)? ECL_NIL: ecl_make_fixnum(value))); + cl_fixnum basis, value; + if (ecl_unlikely(!ECL_FIXNUMP(radix) || + ecl_fixnum_lower(radix, ecl_make_fixnum(2)) || + ecl_fixnum_greater(radix, ecl_make_fixnum(36)))) { + FEwrong_type_nth_arg(@[digit-char-p], 2, radix, + ecl_make_integer_type(ecl_make_fixnum(2), + ecl_make_fixnum(36))); + } + basis = ecl_fixnum(radix); + value = ecl_digitp(ecl_char_code(c), basis); + @(return ((value < 0)? ECL_NIL: ecl_make_fixnum(value))); } @) /* - Ecl_Digitp(i, r) returns the weight of code i - as a digit of radix r, which must be 1 < r <= 36. - If i is not a digit, -1 is returned. + Ecl_Digitp(i, r) returns the weight of code i + as a digit of radix r, which must be 1 < r <= 36. + If i is not a digit, -1 is returned. */ int ecl_digitp(ecl_character i, int r) { - if (('0' <= i) && (i <= '9') && (i < '0' + r)) - return i - '0'; - if (('A' <= i) && (10 < r) && (i < 'A' + (r - 10))) - return i - 'A' + 10; - if (('a' <= i) && (10 < r) && (i < 'a' + (r - 10))) - return i - 'a' + 10; + if (('0' <= i) && (i <= '9') && (i < '0' + r)) + return i - '0'; + if (('A' <= i) && (10 < r) && (i < 'A' + (r - 10))) + return i - 'A' + 10; + if (('a' <= i) && (10 < r) && (i < 'a' + (r - 10))) + return i - 'a' + 10; #ifdef ECL_UNICODE - if (i > 255) { - int number = ucd_decimal_digit(i); - if (number < r) - return number; - } + if (i > 255) { + int number = ucd_decimal_digit(i); + if (number < r) + return number; + } #endif - return -1; + return -1; } cl_object cl_alphanumericp(cl_object c) { - /* INV: ecl_char_code() checks type of `c' */ - cl_fixnum i = ecl_char_code(c); - @(return (ecl_alphanumericp(i)? ECL_T : ECL_NIL)) + /* INV: ecl_char_code() checks type of `c' */ + cl_fixnum i = ecl_char_code(c); + @(return (ecl_alphanumericp(i)? ECL_T : ECL_NIL)); } @(defun char= (c &rest cs) -@ - /* INV: ecl_char_eq() checks types of `c' and `cs' */ - while (--narg) - if (!ecl_char_eq(c, ecl_va_arg(cs))) - @(return ECL_NIL) - @(return ECL_T) -@) +@ { + /* INV: ecl_char_eq() checks types of `c' and `cs' */ + while (--narg) { + if (!ecl_char_eq(c, ecl_va_arg(cs))) { + @(return ECL_NIL); + } + } + @(return ECL_T); +} @) bool ecl_char_eq(cl_object x, cl_object y) { - return ecl_char_code(x) == ecl_char_code(y); + return ecl_char_code(x) == ecl_char_code(y); } @(defun char/= (&rest cs) - int i, j; - cl_object c; -@ - /* INV: ecl_char_eq() checks types of its arguments */ - if (narg == 0) - FEwrong_num_arguments(@[char/=]); - c = ecl_va_arg(cs); - for (i = 2; i<=narg; i++) { - ecl_va_list ds; - ecl_va_start(ds, narg, narg, 0); - c = ecl_va_arg(cs); - for (j = 1; j (&rest args) -@ - return Lchar_cmp(the_env, narg,-1, 1, args); -@) + @ + return Lchar_cmp(the_env, narg,-1, 1, args); + @) @(defun char<= (&rest args) -@ - return Lchar_cmp(the_env, narg, 1, 0, args); -@) + @ + return Lchar_cmp(the_env, narg, 1, 0, args); + @) @(defun char>= (&rest args) -@ - return Lchar_cmp(the_env, narg,-1, 0, args); -@) + @ + return Lchar_cmp(the_env, narg,-1, 0, args); + @) @(defun char_equal (c &rest cs) - int i; -@ - /* INV: ecl_char_equal() checks the type of its arguments */ - for (narg--, i = 0; i < narg; i++) { - if (!ecl_char_equal(c, ecl_va_arg(cs))) - @(return ECL_NIL) - } - @(return ECL_T) -@) + int i; +@ { + /* INV: ecl_char_equal() checks the type of its arguments */ + for (narg--, i = 0; i < narg; i++) { + if (!ecl_char_equal(c, ecl_va_arg(cs))) { + @(return ECL_NIL); + } + } + @(return ECL_T); +} @) #define char_equal_code(x) ecl_char_upcase(ecl_char_code(x)) bool ecl_char_equal(cl_object x, cl_object y) { - return char_equal_code(x) == char_equal_code(y); + return char_equal_code(x) == char_equal_code(y); } @(defun char-not-equal (&rest cs) - int i, j; - cl_object c; -@ - /* INV: ecl_char_equal() checks the type of its arguments */ - if (narg == 0) - FEwrong_num_arguments(@[char-not-equal]); - c = ecl_va_arg(cs); - for (i = 2; i<=narg; i++) { - ecl_va_list ds; - ecl_va_start(ds, narg, narg, 0); - c = ecl_va_arg(cs); - for (j=1; jsymbol.name); + switch (ecl_t_of(x)) { + case t_character: + break; + case t_symbol: + return cl_character(x->symbol.name); #ifdef ECL_UNICODE - case t_string: - if (x->string.fillp == 1) { - x = ECL_CODE_CHAR(x->string.self[0]); - break; - } - goto ERROR; + case t_string: + if (x->string.fillp == 1) { + x = ECL_CODE_CHAR(x->string.self[0]); + break; + } + goto ERROR; #endif - case t_base_string: - if (x->base_string.fillp == 1) { - x = ECL_CODE_CHAR(x->base_string.self[0]); - break; - } - default: ERROR: - FEwrong_type_nth_arg(@[character], 1, x, ecl_read_from_cstring("(OR CHARACTER SYMBOL (ARRAY CHARACTER (1)) (ARRAY BASE-CHAR (1)))")); - } - @(return x) + case t_base_string: + if (x->base_string.fillp == 1) { + x = ECL_CODE_CHAR(x->base_string.self[0]); + break; + } + default: ERROR: + FEwrong_type_nth_arg + (@[character], + 1, x, + ecl_read_from_cstring("(OR CHARACTER SYMBOL (ARRAY CHARACTER (1)) (ARRAY BASE-CHAR (1)))")); + } + @(return x); } cl_object cl_char_code(cl_object c) { - /* INV: ecl_char_code() checks the type of `c' */ - @(return ecl_make_fixnum(ecl_char_code(c))) + /* INV: ecl_char_code() checks the type of `c' */ + @(return ecl_make_fixnum(ecl_char_code(c))); } cl_object cl_code_char(cl_object c) { - cl_fixnum fc; + cl_fixnum fc; - switch (ecl_t_of(c)) { - case t_fixnum: - fc = ecl_fixnum(c); - if (fc < ECL_CHAR_CODE_LIMIT && fc >= 0) { - c = ECL_CODE_CHAR(fc); - break; - } - case t_bignum: - c = ECL_NIL; - break; - default: - FEwrong_type_only_arg(@[code-char], c, @[integer]); - } - @(return c) + switch (ecl_t_of(c)) { + case t_fixnum: + fc = ecl_fixnum(c); + if (fc < ECL_CHAR_CODE_LIMIT && fc >= 0) { + c = ECL_CODE_CHAR(fc); + break; + } + case t_bignum: + c = ECL_NIL; + break; + default: + FEwrong_type_only_arg(@[code-char], c, @[integer]); + } + @(return c); } cl_object cl_char_upcase(cl_object c) { - /* INV: ecl_char_code() checks the type of `c' */ - cl_fixnum code = ecl_char_code(c); - @(return ECL_CODE_CHAR(ecl_char_upcase(code))) + /* INV: ecl_char_code() checks the type of `c' */ + cl_fixnum code = ecl_char_code(c); + @(return ECL_CODE_CHAR(ecl_char_upcase(code))); } cl_object cl_char_downcase(cl_object c) { - /* INV: ecl_char_code() checks the type of `c' */ - cl_fixnum code = ecl_char_code(c); - @(return ECL_CODE_CHAR(ecl_char_downcase(code))) + /* INV: ecl_char_code() checks the type of `c' */ + cl_fixnum code = ecl_char_code(c); + @(return ECL_CODE_CHAR(ecl_char_downcase(code))); } @(defun digit_char (weight &optional (radix ecl_make_fixnum(10))) @ { - cl_fixnum basis; - cl_object output = ECL_NIL; - if (ecl_unlikely(!ECL_FIXNUMP(radix) || - ecl_fixnum_lower(radix, ecl_make_fixnum(2)) || - ecl_fixnum_greater(radix, ecl_make_fixnum(36)))) { - FEwrong_type_nth_arg(@[digit-char], 2, radix, - ecl_make_integer_type(ecl_make_fixnum(2), - ecl_make_fixnum(36))); - } - basis = ecl_fixnum(radix); - switch (ecl_t_of(weight)) { - case t_fixnum: { - cl_fixnum value = ecl_fixnum(weight); - if (value >= 0) { - int dw = ecl_digit_char(value, basis); - if (dw >= 0) { - output = ECL_CODE_CHAR(dw); - } - } - break; - } - case t_bignum: - break; - default: - FEwrong_type_nth_arg(@[digit-char],1,weight,@[integer]); - } - @(return output) + cl_fixnum basis; + cl_object output = ECL_NIL; + if (ecl_unlikely(!ECL_FIXNUMP(radix) || + ecl_fixnum_lower(radix, ecl_make_fixnum(2)) || + ecl_fixnum_greater(radix, ecl_make_fixnum(36)))) { + FEwrong_type_nth_arg(@[digit-char], 2, radix, + ecl_make_integer_type(ecl_make_fixnum(2), + ecl_make_fixnum(36))); + } + basis = ecl_fixnum(radix); + switch (ecl_t_of(weight)) { + case t_fixnum: { + cl_fixnum value = ecl_fixnum(weight); + if (value >= 0) { + int dw = ecl_digit_char(value, basis); + if (dw >= 0) { + output = ECL_CODE_CHAR(dw); + } + } + break; + } + case t_bignum: + break; + default: + FEwrong_type_nth_arg(@[digit-char],1,weight,@[integer]); + } + @(return output); } @) short ecl_digit_char(cl_fixnum w, cl_fixnum r) { - if (r < 2 || r > 36 || w < 0 || w >= r) - return(-1); - if (w < 10) - return(w + '0'); - else - return(w - 10 + 'A'); + if (r < 2 || r > 36 || w < 0 || w >= r) + return(-1); + if (w < 10) + return(w + '0'); + else + return(w - 10 + 'A'); } cl_object cl_char_int(cl_object c) { - const cl_env_ptr the_env = ecl_process_env(); - /* INV: ecl_char_code() checks the type of `c' */ - ecl_return1(the_env, ecl_make_fixnum(ecl_char_code(c))); + const cl_env_ptr the_env = ecl_process_env(); + /* INV: ecl_char_code() checks the type of `c' */ + ecl_return1(the_env, ecl_make_fixnum(ecl_char_code(c))); } /* here we give every character an implicit name of the form 'u#' where # is a hexadecimal number, @@ -478,72 +481,72 @@ cl_object cl_char_name(cl_object c) { - ecl_character code = ecl_char_code(c); - cl_object output; - if (code <= 127) { - output = ecl_gethash_safe(ecl_make_fixnum(code), cl_core.char_names, ECL_NIL); - } + ecl_character code = ecl_char_code(c); + cl_object output; + if (code <= 127) { + output = ecl_gethash_safe(ecl_make_fixnum(code), cl_core.char_names, ECL_NIL); + } #ifdef ECL_UNICODE_NAMES - else if (!Null(output = _ecl_ucd_code_to_name(code))) { - (void)0; - } + else if (!Null(output = _ecl_ucd_code_to_name(code))) { + (void)0; + } #endif - else { - ecl_base_char name[8]; - ecl_base_char *start; - name[7] = 0; - name[6] = ecl_digit_char(code & 0xF, 16); code >>= 4; - name[5] = ecl_digit_char(code & 0xF, 16); code >>= 4; - name[4] = ecl_digit_char(code & 0xF, 16); code >>= 4; - name[3] = ecl_digit_char(code & 0xF, 16); code >>= 4; - if (code == 0) { - start = name + 2; - } else { - name[2] = ecl_digit_char(code & 0xF, 16); code >>= 4; - name[1] = ecl_digit_char(code & 0xF, 16); - start = name; - } - start[0] = 'U'; - output = make_base_string_copy((const char*)start); - } - @(return output); + else { + ecl_base_char name[8]; + ecl_base_char *start; + name[7] = 0; + name[6] = ecl_digit_char(code & 0xF, 16); code >>= 4; + name[5] = ecl_digit_char(code & 0xF, 16); code >>= 4; + name[4] = ecl_digit_char(code & 0xF, 16); code >>= 4; + name[3] = ecl_digit_char(code & 0xF, 16); code >>= 4; + if (code == 0) { + start = name + 2; + } else { + name[2] = ecl_digit_char(code & 0xF, 16); code >>= 4; + name[1] = ecl_digit_char(code & 0xF, 16); + start = name; + } + start[0] = 'U'; + output = make_base_string_copy((const char*)start); + } + @(return output); } cl_object cl_name_char(cl_object name) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object c; - cl_index l; - name = cl_string(name); - c = ecl_gethash_safe(name, cl_core.char_names, ECL_NIL); - if (c != ECL_NIL) { - ecl_return1(the_env, ECL_CODE_CHAR(ecl_fixnum(c))); - } + const cl_env_ptr the_env = ecl_process_env(); + cl_object c; + cl_index l; + name = cl_string(name); + c = ecl_gethash_safe(name, cl_core.char_names, ECL_NIL); + if (c != ECL_NIL) { + ecl_return1(the_env, ECL_CODE_CHAR(ecl_fixnum(c))); + } #ifdef ECL_UNICODE_NAMES - c = _ecl_ucd_name_to_code(name); - if (c != ECL_NIL) { - ecl_return1(the_env, cl_code_char(c)); - } + c = _ecl_ucd_name_to_code(name); + if (c != ECL_NIL) { + ecl_return1(the_env, cl_code_char(c)); + } #endif - if (ecl_stringp(name) && (l = ecl_length(name))) { - c = cl_char(name, ecl_make_fixnum(0)); - if (l == 1) { - (void)0; - } else if (c != ECL_CODE_CHAR('u') && c != ECL_CODE_CHAR('U')) { - c = ECL_NIL; - } else { - cl_index used_l; - cl_index end = name->base_string.fillp; - cl_index real_end = end; - c = ecl_parse_integer(name, 1, end, &real_end, 16); - used_l = real_end; - if (!ECL_FIXNUMP(c) || (used_l == (l - 1))) { - c = ECL_NIL; - } else { - c = ECL_CODE_CHAR(ecl_fixnum(c)); - } - } - } - ecl_return1(the_env, c); + if (ecl_stringp(name) && (l = ecl_length(name))) { + c = cl_char(name, ecl_make_fixnum(0)); + if (l == 1) { + (void)0; + } else if (c != ECL_CODE_CHAR('u') && c != ECL_CODE_CHAR('U')) { + c = ECL_NIL; + } else { + cl_index used_l; + cl_index end = name->base_string.fillp; + cl_index real_end = end; + c = ecl_parse_integer(name, 1, end, &real_end, 16); + used_l = real_end; + if (!ECL_FIXNUMP(c) || (used_l == (l - 1))) { + c = ECL_NIL; + } else { + c = ECL_CODE_CHAR(ecl_fixnum(c)); + } + } + } + ecl_return1(the_env, c); } diff -Nru ecl-16.1.2/src/c/char_ctype.d ecl-16.1.3+ds/src/c/char_ctype.d --- ecl-16.1.2/src/c/char_ctype.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/char_ctype.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - char_ctype.d -- Character properties. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2015, Daniel Kochmański. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * char_ctype.d - character properties + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2015 Daniel Kochmański + * + * See file 'LICENSE' for the copyright details. + * + */ #ifndef ECL_UNICODE #include @@ -23,49 +18,49 @@ bool ecl_graphic_char_p(ecl_character code) { - return code == ' ' || isgraph(code); + return code == ' ' || isgraph(code); } bool ecl_alpha_char_p(ecl_character code) { - return isalpha(code); + return isalpha(code); } bool ecl_upper_case_p(ecl_character code) { - return isupper(code); + return isupper(code); } bool ecl_lower_case_p(ecl_character code) { - return islower(code); + return islower(code); } bool ecl_both_case_p(ecl_character code) { - return islower(code) || isupper(code); + return islower(code) || isupper(code); } bool ecl_alphanumericp(ecl_character i) { - return isalnum(i); + return isalnum(i); } ecl_character ecl_char_upcase(ecl_character code) { - return toupper(code); + return toupper(code); } ecl_character ecl_char_downcase(ecl_character code) { - return tolower(code); + return tolower(code); } #else /* ECL_UNICODE */ @@ -82,16 +77,16 @@ const unsigned char * ucd_char_data(ecl_character code) { - const unsigned char *page = ecl_ucd_page_table[code >> 8]; - return page + (4 * (code & 0xFF)); + const unsigned char *page = ecl_ucd_page_table[code >> 8]; + return page + (4 * (code & 0xFF)); } static cl_index ucd_value_0(ecl_character code) { - if (ecl_unlikely((code >= 0x110000))) - FEerror("The value ~A is not of type (MOD 1114112)", 1, code); - return ucd_char_data(code)[0]; + if (ecl_unlikely((code >= 0x110000))) + FEerror("The value ~A is not of type (MOD 1114112)", 1, code); + return ucd_char_data(code)[0]; } #define read_case_bytes(c) (c[1] + (c[2] << 8) + (c[3] << 16)) @@ -106,14 +101,14 @@ const unsigned char * ucd_char_data(ecl_character code) { - const unsigned char *page = ecl_ucd_page_table[code >> 8]; - return page + (3 * (code & 0xFF)); + const unsigned char *page = ecl_ucd_page_table[code >> 8]; + return page + (3 * (code & 0xFF)); } static cl_index ucd_value_0(ecl_character code) { - return ucd_char_data(code)[0]; + return ucd_char_data(code)[0]; } #define read_case_bytes(c) (c[1] + (c[2] << 8)) @@ -122,72 +117,72 @@ static int ucd_general_category(ecl_character code) { - return ecl_ucd_misc_table[8 * ucd_value_0(code)]; + return ecl_ucd_misc_table[8 * ucd_value_0(code)]; } static int ucd_decimal_digit(ecl_character code) { - return ecl_ucd_misc_table[3 + 8 * ucd_value_0(code)]; + return ecl_ucd_misc_table[3 + 8 * ucd_value_0(code)]; } bool ecl_graphic_char_p(ecl_character code) { - /* compatible to SBCL */ - return code > 159 || ((31 < code) && (code < 127)); + /* compatible to SBCL */ + return code > 159 || ((31 < code) && (code < 127)); } bool ecl_alpha_char_p(ecl_character code) { - return ucd_general_category(code) < 5; + return ucd_general_category(code) < 5; } bool ecl_upper_case_p(ecl_character code) { - return ucd_value_0(code) == 0; + return ucd_value_0(code) == 0; } bool ecl_lower_case_p(ecl_character code) { - return ucd_value_0(code) == 1; + return ucd_value_0(code) == 1; } bool ecl_both_case_p(ecl_character code) { - return ucd_value_0(code) < 2; + return ucd_value_0(code) < 2; } bool ecl_alphanumericp(ecl_character i) { - int gc = ucd_general_category(i); - return (gc < 5) || (gc == 12); + int gc = ucd_general_category(i); + return (gc < 5) || (gc == 12); } ecl_character ecl_char_upcase(ecl_character code) { - const unsigned char *c = ucd_char_data(code); - if (c[0] == 1) { - return read_case_bytes(c); - } else { - return code; - } + const unsigned char *c = ucd_char_data(code); + if (c[0] == 1) { + return read_case_bytes(c); + } else { + return code; + } } ecl_character ecl_char_downcase(ecl_character code) { - const unsigned char *c = ucd_char_data(code); - if (c[0] == 0) { - return read_case_bytes(c); - } else { - return code; - } + const unsigned char *c = ucd_char_data(code); + if (c[0] == 0) { + return read_case_bytes(c); + } else { + return code; + } } #endif diff -Nru ecl-16.1.2/src/c/cinit.d ecl-16.1.3+ds/src/c/cinit.d --- ecl-16.1.2/src/c/cinit.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/cinit.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,20 +1,15 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - init.c -- Lisp Initialization. -*/ -/* - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * cinit.d - lisp initialization + * + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -33,176 +28,177 @@ extern cl_object cl_upgraded_array_element_type(cl_narg narg, cl_object type, ...) { - return _ecl_funcall2(@'upgraded-array-element-type', type); + return _ecl_funcall2(@'upgraded-array-element-type', type); } extern cl_object si_safe_eval(cl_narg narg, cl_object form, cl_object env, ...) { - if (narg == 3) { - cl_object err_value; - va_list args; va_start(args, env); - err_value = va_arg(args, cl_object); - return _ecl_funcall4(@'ext::safe-eval', form, env, err_value); - } - return _ecl_funcall3(@'ext::safe-eval', form, env); + if (narg == 3) { + cl_object err_value; + va_list args; va_start(args, env); + err_value = va_arg(args, cl_object); + return _ecl_funcall4(@'ext::safe-eval', form, env, err_value); + } + return _ecl_funcall3(@'ext::safe-eval', form, env); } extern cl_object cl_slot_value(cl_object instance, cl_object name) { - return _ecl_funcall3(@'slot-value', instance, name); + return _ecl_funcall3(@'slot-value', instance, name); } extern cl_object clos_slot_value_set(cl_object value, cl_object instance, cl_object name) { - return _ecl_funcall4(@'clos::slot-value-set', value, instance, name); + return _ecl_funcall4(@'clos::slot-value-set', value, instance, name); } extern cl_object clos_std_compute_applicable_methods(cl_object gf, cl_object arglist) { - return _ecl_funcall3(@'clos::std-compute-applicable-methods', gf, arglist); + return _ecl_funcall3(@'clos::std-compute-applicable-methods', gf, arglist); } extern cl_object si_bind_simple_restarts(cl_object tag, cl_object names) { - if (ECL_SYM_FUN(@'si::bind-simple-restarts') != Cnil) - return _ecl_funcall3(@'si::bind-simple-restarts', tag, names); - else - return ECL_SYM_VAL(ecl_process_env(), @'si::*restart-clusters*'); + if (ECL_SYM_FUN(@'si::bind-simple-restarts') != Cnil) + return _ecl_funcall3(@'si::bind-simple-restarts', tag, names); + else + return ECL_SYM_VAL(ecl_process_env(), @'si::*restart-clusters*'); } extern cl_object si_bind_simple_handlers(cl_object tag, cl_object names) { - if (ECL_SYM_FUN(@'si::bind-simple-handlers') != Cnil) - return _ecl_funcall3(@'si::bind-simple-handlers', tag, names); - else - return ECL_SYM_VAL(ecl_process_env(), @'si::*handler-clusters*'); + if (ECL_SYM_FUN(@'si::bind-simple-handlers') != Cnil) + return _ecl_funcall3(@'si::bind-simple-handlers', tag, names); + else + return ECL_SYM_VAL(ecl_process_env(), @'si::*handler-clusters*'); } extern cl_object clos_std_compute_effective_method(cl_object gf, cl_object combination, cl_object methods_list) { - return _ecl_funcall4(@'clos::std-compute-effective-method', gf, combination, methods_list); + return _ecl_funcall4(@'clos::std-compute-effective-method', gf, combination, methods_list); } extern cl_object clos_compute_effective_method_function(cl_object gf, cl_object combination, cl_object methods_list) { - return _ecl_funcall4(@'clos::compute-effective-method-function', gf, combination, methods_list); + return _ecl_funcall4(@'clos::compute-effective-method-function', gf, combination, methods_list); } extern cl_object si_string_to_object(cl_narg narg, cl_object string, ...) { - if (narg == 2) { - cl_object err_value; - va_list args; va_start(args, string); - err_value = va_arg(args, cl_object); - return _ecl_funcall3(@'si::string-to-object', string, err_value); - } - return _ecl_funcall2(@'si::string-to-object', string); + if (narg == 2) { + cl_object err_value; + va_list args; va_start(args, string); + err_value = va_arg(args, cl_object); + return _ecl_funcall3(@'si::string-to-object', string, err_value); + } + return _ecl_funcall2(@'si::string-to-object', string); } extern cl_object si_signal_simple_error(cl_narg narg, cl_object condition, cl_object continuable, cl_object format, cl_object format_args, ...) { - ecl_va_list args; - cl_object rest; - ecl_va_start(args, format_args, narg, 4); - rest = cl_grab_rest_args(args); - return cl_apply(6, @'si::signal-simple-error', condition, continuable, - format, format_args, rest); + ecl_va_list args; + cl_object rest; + ecl_va_start(args, format_args, narg, 4); + rest = cl_grab_rest_args(args); + cl_apply(6, @'si::signal-simple-error', condition, continuable, + format, format_args, rest); } extern cl_object cl_set_difference(cl_narg narg, cl_object l1, cl_object l2, ...) { - @(return l1) + @(return l1); } extern cl_object cl_array_dimensions(cl_object array) { - return _ecl_funcall2(@'ARRAY-DIMENSIONS', array); + return _ecl_funcall2(@'ARRAY-DIMENSIONS', array); } extern cl_object si_find_relative_package(cl_narg narg, cl_object package, ...) { - @(return ECL_NIL); + @(return ECL_NIL); } extern cl_object si_wrong_type_argument(cl_narg narg, cl_object object, cl_object type, ...) { - return _ecl_funcall3(@'si::wrong-type-argument', object, type); + return _ecl_funcall3(@'si::wrong-type-argument', object, type); } extern cl_object si_make_encoding(cl_object mapping) { - return _ecl_funcall2(@'ext::make-encoding', mapping); + return _ecl_funcall2(@'ext::make-encoding', mapping); } static cl_object si_simple_toplevel () { - cl_env_ptr env = ecl_process_env(); - cl_object output = cl_core.standard_output; - cl_object sentence; - int i; - - /* Simple minded top level loop */ - ECL_CATCH_ALL_BEGIN(env) { - writestr_stream(";*** Lisp core booted ****\n" - "ECL (Embeddable Common Lisp)\n", - output); - ecl_force_output(output); - for (i = 1; i ", output); - sentence = @read(3, ECL_NIL, ECL_NIL, OBJNULL); - if (sentence == OBJNULL) - @(return); - sentence = si_eval_with_env(1, sentence); - ecl_prin1(sentence, output); - } - } ECL_CATCH_ALL_END; + cl_env_ptr env = ecl_process_env(); + cl_object output = cl_core.standard_output; + cl_object sentence; + int i; + + /* Simple minded top level loop */ + ECL_CATCH_ALL_BEGIN(env) { + writestr_stream(";*** Lisp core booted ****\n" + "ECL (Embeddable Common Lisp)\n", + output); + ecl_force_output(output); + for (i = 1; i ", output); + sentence = @read(3, ECL_NIL, ECL_NIL, OBJNULL); + if (sentence == OBJNULL) { + @(return); + } + sentence = si_eval_with_env(1, sentence); + ecl_prin1(sentence, output); + } + } ECL_CATCH_ALL_END; } int main(int argc, char **args) { - cl_object top_level, features; + cl_object top_level, features; - /* This should be always the first call */ - cl_boot(argc, args); + /* This should be always the first call */ + cl_boot(argc, args); - /* We are computing unnormalized numbers at some point */ - si_trap_fpe(ECL_T, ECL_NIL); + /* We are computing unnormalized numbers at some point */ + si_trap_fpe(ECL_T, ECL_NIL); #ifdef ECL_CMU_FORMAT - ECL_SET(@'*load-verbose*', ECL_NIL); + ECL_SET(@'*load-verbose*', ECL_NIL); #endif - ECL_SET(@'*package*', cl_core.system_package); + ECL_SET(@'*package*', cl_core.system_package); - features = ecl_symbol_value(@'*features*'); - features = CONS(ecl_make_keyword("ECL-MIN"), features); + features = ecl_symbol_value(@'*features*'); + features = CONS(ecl_make_keyword("ECL-MIN"), features); #ifdef HAVE_UNAME - features = CONS(ecl_make_keyword("UNAME"), features); + features = CONS(ecl_make_keyword("UNAME"), features); #endif - ECL_SET(@'*features*', features); - top_level = _ecl_intern("TOP-LEVEL", cl_core.system_package); - ecl_def_c_function(top_level, si_simple_toplevel, 0); - _ecl_funcall1(top_level); - return(0); + ECL_SET(@'*features*', features); + top_level = _ecl_intern("TOP-LEVEL", cl_core.system_package); + ecl_def_c_function(top_level, si_simple_toplevel, 0); + _ecl_funcall1(top_level); + return(0); } #ifdef __cplusplus diff -Nru ecl-16.1.2/src/c/clos/accessor.d ecl-16.1.3+ds/src/c/clos/accessor.d --- ecl-16.1.2/src/c/clos/accessor.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/clos/accessor.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - gfun.c -- Dispatch for generic functions. -*/ -/* - Copyright (c) 1990, Giuseppe Attardi. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * accessor.d - dispatch for slots + * + * Copyright (c) 2011 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -24,172 +19,172 @@ static void no_applicable_method(cl_env_ptr env, cl_object gfun, cl_object args) { - env->values[0] = cl_apply(3, @'no-applicable-method', gfun, args); + env->values[0] = cl_apply(3, @'no-applicable-method', gfun, args); } static cl_object fill_spec_vector(cl_object vector, cl_object gfun, cl_object instance) { - cl_object *argtype = vector->vector.self.t; - argtype[0] = gfun; - argtype[1] = ECL_CLASS_OF(instance); - vector->vector.fillp = 2; - return vector; + cl_object *argtype = vector->vector.self.t; + argtype[0] = gfun; + argtype[1] = ECL_CLASS_OF(instance); + vector->vector.fillp = 2; + return vector; } static cl_object slot_method_name(cl_object gfun, cl_object args) { - cl_object methods = _ecl_funcall3(@'compute-applicable-methods', - gfun, args); - unlikely_if (Null(methods)) { - return OBJNULL; - } else { - cl_object first = ECL_CONS_CAR(methods); - cl_object slotd = _ecl_funcall3(@'slot-value', first, - @'clos::slot-definition'); - return _ecl_funcall3(@'slot-value', slotd, @'clos::name'); - } + cl_object methods = _ecl_funcall3(@'compute-applicable-methods', + gfun, args); + unlikely_if (Null(methods)) { + return OBJNULL; + } else { + cl_object first = ECL_CONS_CAR(methods); + cl_object slotd = _ecl_funcall3(@'slot-value', first, + @'clos::slot-definition'); + return _ecl_funcall3(@'slot-value', slotd, @'clos::name'); + } } static cl_object slot_method_index(cl_object gfun, cl_object instance, cl_object args) { - cl_object slot_name = slot_method_name(gfun, args); - unlikely_if (slot_name == OBJNULL) - return OBJNULL; - else { - cl_object table = _ecl_funcall3(@'slot-value', - ECL_CLASS_OF(instance), - @'clos::location-table'); - /* The class might not be a standard class. This happens - * when a nonstandard class inherits from a standard class - * and does not add any new slot accessor. - */ - unlikely_if (Null(table)) - return slot_name; - return ecl_gethash_safe(slot_name, table, OBJNULL); - } + cl_object slot_name = slot_method_name(gfun, args); + unlikely_if (slot_name == OBJNULL) + return OBJNULL; + else { + cl_object table = _ecl_funcall3(@'slot-value', + ECL_CLASS_OF(instance), + @'clos::location-table'); + /* The class might not be a standard class. This happens + * when a nonstandard class inherits from a standard class + * and does not add any new slot accessor. + */ + unlikely_if (Null(table)) + return slot_name; + return ecl_gethash_safe(slot_name, table, OBJNULL); + } } static ecl_cache_record_ptr search_slot_index(const cl_env_ptr env, cl_object gfun, cl_object instance) { - ecl_cache_ptr cache = env->slot_cache; - fill_spec_vector(cache->keys, gfun, instance); - return ecl_search_cache(cache); + ecl_cache_ptr cache = env->slot_cache; + fill_spec_vector(cache->keys, gfun, instance); + return ecl_search_cache(cache); } static ecl_cache_record_ptr add_new_index(const cl_env_ptr env, cl_object gfun, cl_object instance, cl_object args) { - /* The keys and the cache may change while we compute the - * applicable methods. We must save the keys and recompute the - * cache location if it was filled. */ - cl_object index = slot_method_index(gfun, instance, args); - unlikely_if (index == OBJNULL) { - no_applicable_method(env, gfun, args); - return 0; - } - { - ecl_cache_record_ptr e; - ecl_cache_ptr cache = env->slot_cache; - fill_spec_vector(cache->keys, gfun, instance); - e = ecl_search_cache(cache); - e->key = cl_copy_seq(cache->keys); - e->value = index; - return e; - } + /* The keys and the cache may change while we compute the + * applicable methods. We must save the keys and recompute the + * cache location if it was filled. */ + cl_object index = slot_method_index(gfun, instance, args); + unlikely_if (index == OBJNULL) { + no_applicable_method(env, gfun, args); + return 0; + } + { + ecl_cache_record_ptr e; + ecl_cache_ptr cache = env->slot_cache; + fill_spec_vector(cache->keys, gfun, instance); + e = ecl_search_cache(cache); + e->key = cl_copy_seq(cache->keys); + e->value = index; + return e; + } } static void ensure_up_to_date_instance(cl_object instance) { - cl_object clas = ECL_CLASS_OF(instance); - cl_object slots = ECL_CLASS_SLOTS(clas); - unlikely_if (slots != ECL_UNBOUND && instance->instance.sig != slots) { - _ecl_funcall2(@'clos::update-instance', instance); - } + cl_object clas = ECL_CLASS_OF(instance); + cl_object slots = ECL_CLASS_SLOTS(clas); + unlikely_if (slots != ECL_UNBOUND && instance->instance.sig != slots) { + _ecl_funcall2(@'clos::update-instance', instance); + } } cl_object ecl_slot_reader_dispatch(cl_narg narg, cl_object instance) { - const cl_env_ptr env = ecl_process_env(); - cl_object gfun = env->function; - cl_object index, value; - ecl_cache_record_ptr e; - - unlikely_if (narg != 1) - FEwrong_num_arguments(gfun); - unlikely_if (!ECL_INSTANCEP(instance)) { - no_applicable_method(env, gfun, ecl_list1(instance)); - return env->values[0]; - } - - e = search_slot_index(env, gfun, instance); - unlikely_if (e->key == OBJNULL) { - cl_object args = ecl_list1(instance); - e = add_new_index(env, gfun, instance, args); - /* no_applicable_method() was called */ - unlikely_if (e == 0) { - return env->values[0]; - } - } - ensure_up_to_date_instance(instance); - index = e->value; - if (ECL_FIXNUMP(index)) { - value = instance->instance.slots[ecl_fixnum(index)]; - } else if (ecl_unlikely(!ECL_LISTP(index))) { - value = cl_slot_value(instance, index); - } else if (ecl_unlikely(Null(index))) { - FEerror("Error when accessing method cache for ~A", 1, gfun); - } else { - value = ECL_CONS_CAR(index); - } - unlikely_if (value == ECL_UNBOUND) { - cl_object slot_name = slot_method_name(gfun, ecl_list1(instance)); - value = _ecl_funcall4(@'slot-unbound', - ECL_CLASS_OF(instance), - instance, - slot_name); - } - @(return value) + const cl_env_ptr env = ecl_process_env(); + cl_object gfun = env->function; + cl_object index, value; + ecl_cache_record_ptr e; + + unlikely_if (narg != 1) + FEwrong_num_arguments(gfun); + unlikely_if (!ECL_INSTANCEP(instance)) { + no_applicable_method(env, gfun, ecl_list1(instance)); + return env->values[0]; + } + + e = search_slot_index(env, gfun, instance); + unlikely_if (e->key == OBJNULL) { + cl_object args = ecl_list1(instance); + e = add_new_index(env, gfun, instance, args); + /* no_applicable_method() was called */ + unlikely_if (e == 0) { + return env->values[0]; + } + } + ensure_up_to_date_instance(instance); + index = e->value; + if (ECL_FIXNUMP(index)) { + value = instance->instance.slots[ecl_fixnum(index)]; + } else if (ecl_unlikely(!ECL_LISTP(index))) { + value = cl_slot_value(instance, index); + } else if (ecl_unlikely(Null(index))) { + FEerror("Error when accessing method cache for ~A", 1, gfun); + } else { + value = ECL_CONS_CAR(index); + } + unlikely_if (value == ECL_UNBOUND) { + cl_object slot_name = slot_method_name(gfun, ecl_list1(instance)); + value = _ecl_funcall4(@'slot-unbound', + ECL_CLASS_OF(instance), + instance, + slot_name); + } + @(return value); } cl_object ecl_slot_writer_dispatch(cl_narg narg, cl_object value, cl_object instance) { - const cl_env_ptr env = ecl_process_env(); - cl_object gfun = env->function; - ecl_cache_record_ptr e; - cl_object index; - - unlikely_if (narg != 2) { - FEwrong_num_arguments(gfun); - } - unlikely_if (!ECL_INSTANCEP(instance)) { - no_applicable_method(env, gfun, cl_list(2, value, instance)); - return env->values[0]; - } - e = search_slot_index(env, gfun, instance); - unlikely_if (e->key == OBJNULL) { - cl_object args = cl_list(2, value, instance); - e = add_new_index(env, gfun, instance, args); - /* no_applicable_method() was called */ - unlikely_if (e == 0) { - return env->values[0]; - } - } - index = e->value; - if (ECL_FIXNUMP(index)) { - instance->instance.slots[ecl_fixnum(index)] = value; - } else if (ecl_unlikely(!ECL_LISTP(index))) { - clos_slot_value_set(value, instance, index); - } else if (ecl_unlikely(Null(index))) { - FEerror("Error when accessing method cache for ~A", 1, gfun); - } else { - ECL_RPLACA(index, value); - } - @(return value) + const cl_env_ptr env = ecl_process_env(); + cl_object gfun = env->function; + ecl_cache_record_ptr e; + cl_object index; + + unlikely_if (narg != 2) { + FEwrong_num_arguments(gfun); + } + unlikely_if (!ECL_INSTANCEP(instance)) { + no_applicable_method(env, gfun, cl_list(2, value, instance)); + return env->values[0]; + } + e = search_slot_index(env, gfun, instance); + unlikely_if (e->key == OBJNULL) { + cl_object args = cl_list(2, value, instance); + e = add_new_index(env, gfun, instance, args); + /* no_applicable_method() was called */ + unlikely_if (e == 0) { + return env->values[0]; + } + } + index = e->value; + if (ECL_FIXNUMP(index)) { + instance->instance.slots[ecl_fixnum(index)] = value; + } else if (ecl_unlikely(!ECL_LISTP(index))) { + clos_slot_value_set(value, instance, index); + } else if (ecl_unlikely(Null(index))) { + FEerror("Error when accessing method cache for ~A", 1, gfun); + } else { + ECL_RPLACA(index, value); + } + @(return value); } diff -Nru ecl-16.1.2/src/c/clos/cache.d ecl-16.1.3+ds/src/c/clos/cache.d --- ecl-16.1.2/src/c/clos/cache.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/clos/cache.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - cache.d -- thread-local cache for a variety of operations -*/ -/* - Copyright (c) 2011, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * cache.d - thread-local cache for a variety of operations + * + * Copyright (c) 2011 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -28,103 +23,103 @@ static void empty_cache(ecl_cache_ptr cache) { - cl_object table = cache->table; - cl_index i, total_size = table->vector.dim; - cache->generation = 0; - for (i = 0; i < total_size; i+=3) { - table->vector.self.t[i] = OBJNULL; - table->vector.self.t[i+1] = OBJNULL; - table->vector.self.fix[i+2] = 0; - } + cl_object table = cache->table; + cl_index i, total_size = table->vector.dim; + cache->generation = 0; + for (i = 0; i < total_size; i+=3) { + table->vector.self.t[i] = OBJNULL; + table->vector.self.t[i+1] = OBJNULL; + table->vector.self.fix[i+2] = 0; + } #ifdef ECL_THREADS - cache->clear_list = ECL_NIL; + cache->clear_list = ECL_NIL; #endif } static void clear_one_from_cache(ecl_cache_ptr cache, cl_object target) { - cl_object table = cache->table; - cl_index i, total_size = table->vector.dim; - for (i = 0; i < total_size; i+=3) { - cl_object key = table->vector.self.t[i]; - if (key != OBJNULL) { - if (target == key->vector.self.t[0]) { - table->vector.self.t[i] = OBJNULL; - table->vector.self.fix[i+2] = 0; - } - } - } + cl_object table = cache->table; + cl_index i, total_size = table->vector.dim; + for (i = 0; i < total_size; i+=3) { + cl_object key = table->vector.self.t[i]; + if (key != OBJNULL) { + if (target == key->vector.self.t[0]) { + table->vector.self.t[i] = OBJNULL; + table->vector.self.fix[i+2] = 0; + } + } + } } #ifdef ECL_THREADS static void clear_list_from_cache(ecl_cache_ptr cache) { - cl_object list = ecl_atomic_get(&cache->clear_list); - cl_object table = cache->table; - cl_index i, total_size = table->vector.dim; - for (i = 0; i < total_size; i+=3) { - cl_object key = table->vector.self.t[i]; - if (key != OBJNULL) { - if (ecl_member_eq(key->vector.self.t[0], list)) { - table->vector.self.t[i] = OBJNULL; - table->vector.self.fix[i+2] = 0; - } - } - } + cl_object list = ecl_atomic_get(&cache->clear_list); + cl_object table = cache->table; + cl_index i, total_size = table->vector.dim; + for (i = 0; i < total_size; i+=3) { + cl_object key = table->vector.self.t[i]; + if (key != OBJNULL) { + if (ecl_member_eq(key->vector.self.t[0], list)) { + table->vector.self.t[i] = OBJNULL; + table->vector.self.fix[i+2] = 0; + } + } + } } #endif ecl_cache_ptr ecl_make_cache(cl_index key_size, cl_index cache_size) { - ecl_cache_ptr cache = ecl_alloc(sizeof(struct ecl_cache)); - cache->keys = - si_make_vector(ECL_T, /* element type */ - ecl_make_fixnum(key_size), /* Maximum size */ - ECL_T, /* adjustable */ - ecl_make_fixnum(0), /* fill pointer */ - ECL_NIL, /* displaced */ - ECL_NIL); - cache->table = - si_make_vector(ECL_T, /* element type */ - ecl_make_fixnum(3*cache_size), /* Maximum size */ - ECL_NIL, /* adjustable */ - ECL_NIL, /* fill pointer */ - ECL_NIL, /* displaced */ - ECL_NIL); - empty_cache(cache); - return cache; + ecl_cache_ptr cache = ecl_alloc(sizeof(struct ecl_cache)); + cache->keys = + si_make_vector(ECL_T, /* element type */ + ecl_make_fixnum(key_size), /* Maximum size */ + ECL_T, /* adjustable */ + ecl_make_fixnum(0), /* fill pointer */ + ECL_NIL, /* displaced */ + ECL_NIL); + cache->table = + si_make_vector(ECL_T, /* element type */ + ecl_make_fixnum(3*cache_size), /* Maximum size */ + ECL_NIL, /* adjustable */ + ECL_NIL, /* fill pointer */ + ECL_NIL, /* displaced */ + ECL_NIL); + empty_cache(cache); + return cache; } void ecl_cache_remove_one(ecl_cache_ptr cache, cl_object first_key) { #ifdef ECL_THREADS - ecl_atomic_push(&cache->clear_list, first_key); + ecl_atomic_push(&cache->clear_list, first_key); #else - clear_one_from_cache(cache, first_key); + clear_one_from_cache(cache, first_key); #endif } static cl_index vector_hash_key(cl_object keys) { - cl_index c, n, a = GOLDEN_RATIO, b = GOLDEN_RATIO; - for (c = 0, n = keys->vector.fillp; n >= 3; ) { - c += keys->vector.self.index[--n]; - b += keys->vector.self.index[--n]; - a += keys->vector.self.index[--n]; - mix(a, b, c); - } - switch (n) { - case 2: b += keys->vector.self.index[--n]; - case 1: a += keys->vector.self.index[--n]; - c += keys->vector.dim; - mix(a,b,c); - } - return c; + cl_index c, n, a = GOLDEN_RATIO, b = GOLDEN_RATIO; + for (c = 0, n = keys->vector.fillp; n >= 3; ) { + c += keys->vector.self.index[--n]; + b += keys->vector.self.index[--n]; + a += keys->vector.self.index[--n]; + mix(a, b, c); + } + switch (n) { + case 2: b += keys->vector.self.index[--n]; + case 1: a += keys->vector.self.index[--n]; + c += keys->vector.dim; + mix(a,b,c); + } + return c; } @@ -137,88 +132,88 @@ ecl_search_cache(ecl_cache_ptr cache) { #ifdef ECL_THREADS - if (!Null(cache->clear_list)) { - clear_list_from_cache(cache); - } + if (!Null(cache->clear_list)) { + clear_list_from_cache(cache); + } #endif -{ - cl_object table = cache->table; - cl_object keys = cache->keys; - cl_index argno = keys->vector.fillp; - cl_index i = vector_hash_key(keys); - cl_index total_size = table->vector.dim; - cl_fixnum min_gen, gen; - cl_object *min_e; - int k; - i = i % total_size; - i = i - (i % 3); - min_gen = cache->generation; - min_e = 0; - for (k = 20; k--; ) { - cl_object *e = table->vector.self.t + i; - cl_object hkey = RECORD_KEY(e); - if (hkey == OBJNULL) { - min_gen = -1; - min_e = e; - if (RECORD_VALUE(e) == OBJNULL) { - /* This record is not only deleted but empty - * Hence we cannot find our method ahead */ - break; - } - /* Else we only know that the record has been - * delete, but we might find our data ahead. */ - } else if (argno == hkey->vector.fillp) { - cl_index n; - for (n = 0; n < argno; n++) { - if (keys->vector.self.t[n] != - hkey->vector.self.t[n]) - goto NO_MATCH; - } - min_e = e; - goto FOUND; - } else if (min_gen >= 0) { - NO_MATCH: - /* Unless we have found a deleted record, keep - * looking for the oldest record that we can - * overwrite with the new data. */ - gen = RECORD_GEN(e); - if (gen < min_gen) { - min_gen = gen; - min_e = e; - } - } - i += 3; - if (i >= total_size) i = 0; - } - if (min_e == 0) { - ecl_internal_error("search_method_hash"); - } - RECORD_KEY(min_e) = OBJNULL; - cache->generation++; - FOUND: - /* - * Once we have reached here, we set the new generation of - * this record and perform a global shift so that the total - * generation number does not become too large and we can - * expire some elements. - */ - gen = cache->generation; - RECORD_GEN_SET(min_e, gen); - if (gen >= total_size/2) { - cl_object *e = table->vector.self.t; - gen = 0.5*gen; - cache->generation -= gen; - for (i = table->vector.dim; i; i-= 3, e += 3) { - cl_fixnum g = RECORD_GEN(e) - gen; - if (g <= 0) { - RECORD_KEY(e) = OBJNULL; - RECORD_VALUE(e) = ECL_NIL; - g = 0; - } - RECORD_GEN_SET(e, g); - } - } - return (ecl_cache_record_ptr)min_e; -} + { + cl_object table = cache->table; + cl_object keys = cache->keys; + cl_index argno = keys->vector.fillp; + cl_index i = vector_hash_key(keys); + cl_index total_size = table->vector.dim; + cl_fixnum min_gen, gen; + cl_object *min_e; + int k; + i = i % total_size; + i = i - (i % 3); + min_gen = cache->generation; + min_e = 0; + for (k = 20; k--; ) { + cl_object *e = table->vector.self.t + i; + cl_object hkey = RECORD_KEY(e); + if (hkey == OBJNULL) { + min_gen = -1; + min_e = e; + if (RECORD_VALUE(e) == OBJNULL) { + /* This record is not only deleted but empty + * Hence we cannot find our method ahead */ + break; + } + /* Else we only know that the record has been + * delete, but we might find our data ahead. */ + } else if (argno == hkey->vector.fillp) { + cl_index n; + for (n = 0; n < argno; n++) { + if (keys->vector.self.t[n] != + hkey->vector.self.t[n]) + goto NO_MATCH; + } + min_e = e; + goto FOUND; + } else if (min_gen >= 0) { + NO_MATCH: + /* Unless we have found a deleted record, keep + * looking for the oldest record that we can + * overwrite with the new data. */ + gen = RECORD_GEN(e); + if (gen < min_gen) { + min_gen = gen; + min_e = e; + } + } + i += 3; + if (i >= total_size) i = 0; + } + if (min_e == 0) { + ecl_internal_error("search_method_hash"); + } + RECORD_KEY(min_e) = OBJNULL; + cache->generation++; + FOUND: + /* + * Once we have reached here, we set the new generation of + * this record and perform a global shift so that the total + * generation number does not become too large and we can + * expire some elements. + */ + gen = cache->generation; + RECORD_GEN_SET(min_e, gen); + if (gen >= total_size/2) { + cl_object *e = table->vector.self.t; + gen = 0.5*gen; + cache->generation -= gen; + for (i = table->vector.dim; i; i-= 3, e += 3) { + cl_fixnum g = RECORD_GEN(e) - gen; + if (g <= 0) { + RECORD_KEY(e) = OBJNULL; + RECORD_VALUE(e) = ECL_NIL; + g = 0; + } + RECORD_GEN_SET(e, g); + } + } + return (ecl_cache_record_ptr)min_e; + } } diff -Nru ecl-16.1.2/src/c/cmpaux.d ecl-16.1.3+ds/src/c/cmpaux.d --- ecl-16.1.2/src/c/cmpaux.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/cmpaux.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - cmpaux.c -- Auxiliaries used in compiled Lisp code. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * cmpaux.d - auxiliaries used in compiled Lisp code + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -24,30 +19,30 @@ cl_object si_specialp(cl_object sym) { - @(return ((ecl_symbol_type(sym) & ecl_stp_special)? ECL_T : ECL_NIL)) -} + @(return ((ecl_symbol_type(sym) & ecl_stp_special)? ECL_T : ECL_NIL)) + } cl_fixnum ecl_ifloor(cl_fixnum x, cl_fixnum y) { - if (y == 0) - FEerror("Zero divizor", 0); - else if (y > 0) - if (x >= 0) - return(x/y); - else - return(-((-x+y-1))/y); - else - if (x >= 0) - return(-((x-y-1)/(-y))); - else - return((-x)/(-y)); + if (y == 0) + FEerror("Zero divizor", 0); + else if (y > 0) + if (x >= 0) + return(x/y); + else + return(-((-x+y-1))/y); + else + if (x >= 0) + return(-((x-y-1)/(-y))); + else + return((-x)/(-y)); } cl_fixnum ecl_imod(cl_fixnum x, cl_fixnum y) { - return(x - ecl_ifloor(x, y)*y); + return(x - ecl_ifloor(x, y)*y); } /* @@ -59,59 +54,59 @@ char ecl_to_char(cl_object x) { - switch (ecl_t_of(x)) { - case t_fixnum: - return ecl_fixnum(x); - case t_character: - return ECL_CHAR_CODE(x); - default: - FEerror("~S cannot be coerced to a C char.", 1, x); - } + switch (ecl_t_of(x)) { + case t_fixnum: + return ecl_fixnum(x); + case t_character: + return ECL_CHAR_CODE(x); + default: + FEerror("~S cannot be coerced to a C char.", 1, x); + } } cl_fixnum ecl_to_fixnum(cl_object x) { - switch (ecl_t_of(x)) { - case t_fixnum: - case t_bignum: - return fixint(x); -/* case t_character: return (cl_fixnum)ECL_CHAR_CODE(x); */ - case t_ratio: - return (cl_fixnum)ecl_to_double(x); - case t_singlefloat: - return (cl_fixnum)ecl_single_float(x); - case t_doublefloat: - return (cl_fixnum)ecl_double_float(x); + switch (ecl_t_of(x)) { + case t_fixnum: + case t_bignum: + return fixint(x); + /* case t_character: return (cl_fixnum)ECL_CHAR_CODE(x); */ + case t_ratio: + return (cl_fixnum)ecl_to_double(x); + case t_singlefloat: + return (cl_fixnum)ecl_single_float(x); + case t_doublefloat: + return (cl_fixnum)ecl_double_float(x); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return (cl_fixnum)ecl_long_float(x); + case t_longfloat: + return (cl_fixnum)ecl_long_float(x); #endif - default: - FEerror("~S cannot be coerced to a C int.", 1, x); - } + default: + FEerror("~S cannot be coerced to a C int.", 1, x); + } } cl_index ecl_to_unsigned_integer(cl_object x) { - switch (ecl_t_of(x)) { - case t_fixnum: - case t_bignum: - return fixnnint(x); - case t_ratio: - return (cl_index)ecl_to_double(x); - case t_singlefloat: - return (cl_index)ecl_single_float(x); - case t_doublefloat: - return (cl_index)ecl_double_float(x); + switch (ecl_t_of(x)) { + case t_fixnum: + case t_bignum: + return fixnnint(x); + case t_ratio: + return (cl_index)ecl_to_double(x); + case t_singlefloat: + return (cl_index)ecl_single_float(x); + case t_doublefloat: + return (cl_index)ecl_double_float(x); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return (cl_index)ecl_long_float(x); + case t_longfloat: + return (cl_index)ecl_long_float(x); #endif - default: - FEerror("~S cannot be coerced to a C unsigned int.", 1, x); - } + default: + FEerror("~S cannot be coerced to a C unsigned int.", 1, x); + } } int @@ -135,97 +130,97 @@ void cl_throw(cl_object tag) { - ecl_frame_ptr fr = frs_sch(tag); - if (fr == NULL) - FEcontrol_error("THROW: The catch ~S is undefined.", 1, tag); - ecl_unwind(ecl_process_env(), fr); + ecl_frame_ptr fr = frs_sch(tag); + if (fr == NULL) + FEcontrol_error("THROW: The catch ~S is undefined.", 1, tag); + ecl_unwind(ecl_process_env(), fr); } void cl_return_from(cl_object block_id, cl_object block_name) { - ecl_frame_ptr fr = frs_sch(block_id); - if (fr == NULL) - FEcontrol_error("RETURN-FROM: The block ~S with id ~S is missing.", - 2, block_name, block_id); - ecl_unwind(ecl_process_env(), fr); + ecl_frame_ptr fr = frs_sch(block_id); + if (fr == NULL) + FEcontrol_error("RETURN-FROM: The block ~S with id ~S is missing.", + 2, block_name, block_id); + ecl_unwind(ecl_process_env(), fr); } void cl_go(cl_object tag_id, cl_object label) { - const cl_env_ptr the_env = ecl_process_env(); - ecl_frame_ptr fr = frs_sch(tag_id); - if (fr == NULL) - FEcontrol_error("GO: The tagbody ~S is missing.", 1, tag_id); - the_env->values[0] = label; - the_env->nvalues = 1; - ecl_unwind(the_env, fr); + const cl_env_ptr the_env = ecl_process_env(); + ecl_frame_ptr fr = frs_sch(tag_id); + if (fr == NULL) + FEcontrol_error("GO: The tagbody ~S is missing.", 1, tag_id); + the_env->values[0] = label; + the_env->nvalues = 1; + ecl_unwind(the_env, fr); } cl_object cl_grab_rest_args(ecl_va_list args) { - cl_object rest = ECL_NIL; - cl_object *r = &rest; - while (args[0].narg) { - *r = ecl_list1(ecl_va_arg(args)); - r = &ECL_CONS_CDR(*r); - } - return rest; + cl_object rest = ECL_NIL; + cl_object *r = &rest; + while (args[0].narg) { + *r = ecl_list1(ecl_va_arg(args)); + r = &ECL_CONS_CDR(*r); + } + return rest; } void cl_parse_key( - ecl_va_list args, /* actual args */ - int nkey, /* number of keywords */ - cl_object *keys, /* keywords for the function */ - cl_object *vars, /* where to put values (vars[0..nkey-1]) - and suppliedp (vars[nkey..2*nkey-1]) */ - cl_object *rest, /* if rest != NULL, where to collect rest values */ - bool allow_other_keys) /* whether other key are allowed */ -{ - int i; - cl_object supplied_allow_other_keys = OBJNULL; - cl_object unknown_keyword = OBJNULL; - - if (rest != NULL) *rest = ECL_NIL; - - for (i = 0; i < 2*nkey; i++) - vars[i] = ECL_NIL; /* default values: NIL, supplied: NIL */ - if (args[0].narg <= 0) return; - - for (; args[0].narg > 1; ) { - cl_object keyword = ecl_va_arg(args); - cl_object value = ecl_va_arg(args); - if (ecl_unlikely(!ECL_SYMBOLP(keyword))) - FEprogram_error_noreturn("LAMBDA: Keyword expected, got ~S.", - 1, keyword); - if (rest != NULL) { - rest = &ECL_CONS_CDR(*rest = ecl_list1(keyword)); - rest = &ECL_CONS_CDR(*rest = ecl_list1(value)); - } - for (i = 0; i < nkey; i++) { - if (keys[i] == keyword) { - if (vars[nkey+i] == ECL_NIL) { - vars[i] = value; - vars[nkey+i] = ECL_T; - } - goto goon; - } - } - /* the key is a new one */ - if (keyword == @':allow-other-keys') { - if (supplied_allow_other_keys == OBJNULL) - supplied_allow_other_keys = value; - } else if (unknown_keyword == OBJNULL) - unknown_keyword = keyword; - goon:; + ecl_va_list args, /* actual args */ + int nkey, /* number of keywords */ + cl_object *keys, /* keywords for the function */ + cl_object *vars, /* where to put values (vars[0..nkey-1]) + and suppliedp (vars[nkey..2*nkey-1]) */ + cl_object *rest, /* if rest != NULL, where to collect rest values */ + bool allow_other_keys) /* whether other key are allowed */ +{ + int i; + cl_object supplied_allow_other_keys = OBJNULL; + cl_object unknown_keyword = OBJNULL; + + if (rest != NULL) *rest = ECL_NIL; + + for (i = 0; i < 2*nkey; i++) + vars[i] = ECL_NIL; /* default values: NIL, supplied: NIL */ + if (args[0].narg <= 0) return; + + for (; args[0].narg > 1; ) { + cl_object keyword = ecl_va_arg(args); + cl_object value = ecl_va_arg(args); + if (ecl_unlikely(!ECL_SYMBOLP(keyword))) + FEprogram_error_noreturn("LAMBDA: Keyword expected, got ~S.", + 1, keyword); + if (rest != NULL) { + rest = &ECL_CONS_CDR(*rest = ecl_list1(keyword)); + rest = &ECL_CONS_CDR(*rest = ecl_list1(value)); + } + for (i = 0; i < nkey; i++) { + if (keys[i] == keyword) { + if (vars[nkey+i] == ECL_NIL) { + vars[i] = value; + vars[nkey+i] = ECL_T; } - if (ecl_unlikely(args[0].narg != 0)) - FEprogram_error_noreturn("Odd number of keys", 0); - if (ecl_unlikely(unknown_keyword != OBJNULL && !allow_other_keys && - (supplied_allow_other_keys == ECL_NIL || - supplied_allow_other_keys == OBJNULL))) - FEprogram_error("Unknown keyword ~S", 1, unknown_keyword); + goto goon; + } + } + /* the key is a new one */ + if (keyword == @':allow-other-keys') { + if (supplied_allow_other_keys == OBJNULL) + supplied_allow_other_keys = value; + } else if (unknown_keyword == OBJNULL) + unknown_keyword = keyword; + goon:; + } + if (ecl_unlikely(args[0].narg != 0)) + FEprogram_error_noreturn("Odd number of keys", 0); + if (ecl_unlikely(unknown_keyword != OBJNULL && !allow_other_keys && + (supplied_allow_other_keys == ECL_NIL || + supplied_allow_other_keys == OBJNULL))) + FEprogram_error("Unknown keyword ~S", 1, unknown_keyword); } diff -Nru ecl-16.1.2/src/c/compiler.d ecl-16.1.3+ds/src/c/compiler.d --- ecl-16.1.2/src/c/compiler.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/compiler.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,26 +1,21 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - compiler.c -- Bytecode compiler -*/ -/* - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * compiler.d - bytecode compiler + * + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ /* Remarks: [1] The virtual machine has a word size of 16 bits. Operands and arguments have this very size, so that for instance, a jump - OP_JMP increment + OP_JMP increment takes two words of memory: one for the operator and one for the argument. The interpreter is written with this assumption in mind, but it should be @@ -139,73 +134,72 @@ static void FEill_formed_input(void) ecl_attr_noreturn; /* -------------------- SAFE LIST HANDLING -------------------- */ - static cl_object pop(cl_object *l) { - cl_object head, list = *l; - unlikely_if (ECL_ATOM(list)) - FEill_formed_input(); - head = ECL_CONS_CAR(list); - *l = ECL_CONS_CDR(list); - return head; + cl_object head, list = *l; + unlikely_if (ECL_ATOM(list)) + FEill_formed_input(); + head = ECL_CONS_CAR(list); + *l = ECL_CONS_CDR(list); + return head; } static cl_object pop_maybe_nil(cl_object *l) { - cl_object head, list = *l; - if (list == ECL_NIL) - return ECL_NIL; - unlikely_if (!ECL_LISTP(list)) - FEill_formed_input(); - head = ECL_CONS_CAR(list); - *l = ECL_CONS_CDR(list); - return head; + cl_object head, list = *l; + if (list == ECL_NIL) + return ECL_NIL; + unlikely_if (!ECL_LISTP(list)) + FEill_formed_input(); + head = ECL_CONS_CAR(list); + *l = ECL_CONS_CDR(list); + return head; } /* ------------------------------ ASSEMBLER ------------------------------ */ static cl_object asm_end(cl_env_ptr env, cl_index beginning, cl_object definition) { - const cl_compiler_ptr c_env = env->c_env; - cl_object bytecodes; - cl_index code_size, i; - cl_opcode *code; - cl_object file = ECL_SYM_VAL(env,@'ext::*source-location*'), position; - if (Null(file)) { - file = ECL_SYM_VAL(env,@'*load-truename*'); - position = ecl_make_fixnum(0); - } else { - position = cl_cdr(file); - file = cl_car(file); - } - - /* Save bytecodes from this session in a new vector */ - code_size = current_pc(env) - beginning; - bytecodes = ecl_alloc_object(t_bytecodes); - bytecodes->bytecodes.name = @'si::bytecodes'; - bytecodes->bytecodes.definition = definition; - bytecodes->bytecodes.code_size = code_size; - bytecodes->bytecodes.code = ecl_alloc_atomic(code_size * sizeof(cl_opcode)); - bytecodes->bytecodes.data = c_env->constants; - for (i = 0, code = (cl_opcode *)bytecodes->bytecodes.code; i < code_size; i++) { - code[i] = (cl_opcode)(cl_fixnum)(env->stack[beginning+i]); - } - bytecodes->bytecodes.entry = _ecl_bytecodes_dispatch_vararg; - ecl_set_function_source_file_info(bytecodes, (file == OBJNULL)? ECL_NIL : file, - (file == OBJNULL)? ECL_NIL : position); - asm_clear(env, beginning); - return bytecodes; + const cl_compiler_ptr c_env = env->c_env; + cl_object bytecodes; + cl_index code_size, i; + cl_opcode *code; + cl_object file = ECL_SYM_VAL(env,@'ext::*source-location*'), position; + if (Null(file)) { + file = ECL_SYM_VAL(env,@'*load-truename*'); + position = ecl_make_fixnum(0); + } else { + position = cl_cdr(file); + file = cl_car(file); + } + + /* Save bytecodes from this session in a new vector */ + code_size = current_pc(env) - beginning; + bytecodes = ecl_alloc_object(t_bytecodes); + bytecodes->bytecodes.name = @'si::bytecodes'; + bytecodes->bytecodes.definition = definition; + bytecodes->bytecodes.code_size = code_size; + bytecodes->bytecodes.code = ecl_alloc_atomic(code_size * sizeof(cl_opcode)); + bytecodes->bytecodes.data = c_env->constants; + for (i = 0, code = (cl_opcode *)bytecodes->bytecodes.code; i < code_size; i++) { + code[i] = (cl_opcode)(cl_fixnum)(env->stack[beginning+i]); + } + bytecodes->bytecodes.entry = _ecl_bytecodes_dispatch_vararg; + ecl_set_function_source_file_info(bytecodes, (file == OBJNULL)? ECL_NIL : file, + (file == OBJNULL)? ECL_NIL : position); + asm_clear(env, beginning); + return bytecodes; } #if defined(ECL_SMALL_BYTECODES) static void asm_arg(cl_env_ptr env, int n) { #ifdef WORDS_BIGENDIAN - asm_op(env, (n >> 8) & 0xFF); - asm_op(env, n & 0xFF); + asm_op(env, (n >> 8) & 0xFF); + asm_op(env, n & 0xFF); #else - asm_op(env, n & 0xFF); - asm_op(env, (n >> 8) & 0xFF); + asm_op(env, n & 0xFF); + asm_op(env, (n >> 8) & 0xFF); #endif } #else @@ -214,63 +208,63 @@ static void asm_op(cl_env_ptr env, cl_fixnum code) { - cl_object v = (cl_object)code; - ECL_STACK_PUSH(env,v); + cl_object v = (cl_object)code; + ECL_STACK_PUSH(env,v); } static void asm_clear(cl_env_ptr env, cl_index h) { - ECL_STACK_SET_INDEX(env, h); + ECL_STACK_SET_INDEX(env, h); } static void asm_op2(cl_env_ptr env, int code, int n) { - if (ecl_unlikely(n < -MAX_OPARG || MAX_OPARG < n)) - FEprogram_error_noreturn("Argument to bytecode is too large", 0); - asm_op(env, code); - asm_arg(env, n); + if (ecl_unlikely(n < -MAX_OPARG || MAX_OPARG < n)) + FEprogram_error_noreturn("Argument to bytecode is too large", 0); + asm_op(env, code); + asm_arg(env, n); } static cl_index asm_constant(cl_env_ptr env, cl_object c) { - const cl_compiler_ptr c_env = env->c_env; - cl_object constants = c_env->constants; - cl_vector_push_extend(2, c, constants); - return constants->vector.fillp-1; + const cl_compiler_ptr c_env = env->c_env; + cl_object constants = c_env->constants; + cl_vector_push_extend(2, c, constants); + return constants->vector.fillp-1; } static cl_index asm_jmp(cl_env_ptr env, int op) { - cl_index output; - asm_op(env, op); - output = current_pc(env); - asm_arg(env, 0); - return output; + cl_index output; + asm_op(env, op); + output = current_pc(env); + asm_arg(env, 0); + return output; } static void asm_complete(cl_env_ptr env, int op, cl_index pc) { - cl_fixnum delta = current_pc(env) - pc; /* [1] */ - if (ecl_unlikely(op && (asm_ref(env, pc-1) != op))) - FEprogram_error_noreturn("Non matching codes in ASM-COMPLETE2", 0); - else if (ecl_unlikely(delta < -MAX_OPARG || delta > MAX_OPARG)) - FEprogram_error_noreturn("Too large jump", 0); - else { + cl_fixnum delta = current_pc(env) - pc; /* [1] */ + if (ecl_unlikely(op && (asm_ref(env, pc-1) != op))) + FEprogram_error_noreturn("Non matching codes in ASM-COMPLETE2", 0); + else if (ecl_unlikely(delta < -MAX_OPARG || delta > MAX_OPARG)) + FEprogram_error_noreturn("Too large jump", 0); + else { #ifdef ECL_SMALL_BYTECODES - unsigned char low = delta & 0xFF; - char high = delta >> 8; + unsigned char low = delta & 0xFF; + char high = delta >> 8; # ifdef WORDS_BIGENDIAN - env->stack[pc] = (cl_object)(cl_fixnum)high; - env->stack[pc+1] = (cl_object)(cl_fixnum)low; + env->stack[pc] = (cl_object)(cl_fixnum)high; + env->stack[pc+1] = (cl_object)(cl_fixnum)low; # else - env->stack[pc] = (cl_object)(cl_fixnum)low; - env->stack[pc+1] = (cl_object)(cl_fixnum)high; + env->stack[pc] = (cl_object)(cl_fixnum)low; + env->stack[pc+1] = (cl_object)(cl_fixnum)high; # endif #else - env->stack[pc] = (cl_object)(cl_fixnum)delta; + env->stack[pc] = (cl_object)(cl_fixnum)delta; #endif - } + } } /* ------------------------------ COMPILER ------------------------------ */ @@ -345,53 +339,53 @@ static void assert_type_symbol(cl_object v) { - if (ecl_t_of(v) != t_symbol) - FEprogram_error_noreturn("Expected a symbol, found ~S.", 1, v); + if (ecl_t_of(v) != t_symbol) + FEprogram_error_noreturn("Expected a symbol, found ~S.", 1, v); } static void FEillegal_variable_name(cl_object v) { - FEprogram_error_noreturn("Not a valid variable name ~S.", 1, v); + FEprogram_error_noreturn("Not a valid variable name ~S.", 1, v); } static void FEill_formed_input() { - FEprogram_error_noreturn("Syntax error: list with too few elements or improperly terminated.", 0); + FEprogram_error_noreturn("Syntax error: list with too few elements or improperly terminated.", 0); } static int c_search_constant(cl_env_ptr env, cl_object c) { - const cl_compiler_ptr c_env = env->c_env; - cl_object p = c_env->constants; - int n; - for (n = 0; n < p->vector.fillp; n++) { - if (ecl_eql(p->vector.self.t[n], c)) { - return n; - } - } - return -1; + const cl_compiler_ptr c_env = env->c_env; + cl_object p = c_env->constants; + int n; + for (n = 0; n < p->vector.fillp; n++) { + if (ecl_eql(p->vector.self.t[n], c)) { + return n; + } + } + return -1; } static int c_register_constant(cl_env_ptr env, cl_object c) { - int n = c_search_constant(env, c); - return (n < 0)? - asm_constant(env, c) : - n; + int n = c_search_constant(env, c); + return (n < 0)? + asm_constant(env, c) : + n; } static void asm_c(cl_env_ptr env, cl_object o) { - asm_arg(env, c_register_constant(env, o)); + asm_arg(env, c_register_constant(env, o)); } static void asm_op2c(cl_env_ptr env, int code, cl_object o) { - asm_op2(env, code, c_register_constant(env, o)); + asm_op2(env, code, c_register_constant(env, o)); } /* @@ -446,182 +440,182 @@ static cl_object new_location(const cl_compiler_ptr c_env) { - return CONS(ecl_make_fixnum(c_env->env_depth), - ecl_make_fixnum(c_env->env_size++)); + return CONS(ecl_make_fixnum(c_env->env_depth), + ecl_make_fixnum(c_env->env_size++)); } #endif static cl_index c_register_block(cl_env_ptr env, cl_object name) { - const cl_compiler_ptr c_env = env->c_env; - cl_object loc = new_location(c_env); - c_env->variables = CONS(cl_list(4, @':block', name, ECL_NIL, loc), - c_env->variables); - return ecl_fixnum(ECL_CONS_CDR(loc)); + const cl_compiler_ptr c_env = env->c_env; + cl_object loc = new_location(c_env); + c_env->variables = CONS(cl_list(4, @':block', name, ECL_NIL, loc), + c_env->variables); + return ecl_fixnum(ECL_CONS_CDR(loc)); } static cl_index c_register_tags(cl_env_ptr env, cl_object all_tags) { - const cl_compiler_ptr c_env = env->c_env; - cl_object loc = new_location(c_env); - c_env->variables = CONS(cl_list(4, @':tag', all_tags, ECL_NIL, loc), - c_env->variables); - return ecl_fixnum(ECL_CONS_CDR(loc)); + const cl_compiler_ptr c_env = env->c_env; + cl_object loc = new_location(c_env); + c_env->variables = CONS(cl_list(4, @':tag', all_tags, ECL_NIL, loc), + c_env->variables); + return ecl_fixnum(ECL_CONS_CDR(loc)); } static void c_register_function(cl_env_ptr env, cl_object name) { - const cl_compiler_ptr c_env = env->c_env; - c_env->variables = CONS(cl_list(4, @':function', name, ECL_NIL, - new_location(c_env)), - c_env->variables); - c_env->macros = CONS(cl_list(2, name, @'function'), c_env->macros); + const cl_compiler_ptr c_env = env->c_env; + c_env->variables = CONS(cl_list(4, @':function', name, ECL_NIL, + new_location(c_env)), + c_env->variables); + c_env->macros = CONS(cl_list(2, name, @'function'), c_env->macros); } static cl_object c_macro_expand1(cl_env_ptr env, cl_object stmt) { - const cl_compiler_ptr c_env = env->c_env; - return cl_macroexpand_1(2, stmt, CONS(c_env->variables, c_env->macros)); + const cl_compiler_ptr c_env = env->c_env; + return cl_macroexpand_1(2, stmt, CONS(c_env->variables, c_env->macros)); } static void c_register_symbol_macro(cl_env_ptr env, cl_object name, cl_object exp_fun) { - const cl_compiler_ptr c_env = env->c_env; - c_env->variables = CONS(cl_list(3, name, @'si::symbol-macro', exp_fun), - c_env->variables); + const cl_compiler_ptr c_env = env->c_env; + c_env->variables = CONS(cl_list(3, name, @'si::symbol-macro', exp_fun), + c_env->variables); } /* UNUSED -static void -c_register_macro(cl_env_ptr env, cl_object name, cl_object exp_fun) -{ - const cl_compiler_ptr c_env = env->c_env; - c_env->macros = CONS(cl_list(3, name, @'si::macro', exp_fun), c_env->macros); -} + static void + c_register_macro(cl_env_ptr env, cl_object name, cl_object exp_fun) + { + const cl_compiler_ptr c_env = env->c_env; + c_env->macros = CONS(cl_list(3, name, @'si::macro', exp_fun), c_env->macros); + } */ static void c_register_var(cl_env_ptr env, cl_object var, bool special, bool bound) { - const cl_compiler_ptr c_env = env->c_env; - c_env->variables = CONS(cl_list(4, var, - special? @'special' : ECL_NIL, - bound? ECL_T : ECL_NIL, - new_location(c_env)), - c_env->variables); + const cl_compiler_ptr c_env = env->c_env; + c_env->variables = CONS(cl_list(4, var, + special? @'special' : ECL_NIL, + bound? ECL_T : ECL_NIL, + new_location(c_env)), + c_env->variables); } static void guess_environment(cl_env_ptr env, cl_object interpreter_env) { - if (!LISTP(interpreter_env)) - return; - /* - * Given the environment of an interpreted function, we guess a - * suitable compiler enviroment to compile forms that access the - * variables and local functions of this interpreted code. - */ - for (interpreter_env = @revappend(interpreter_env, ECL_NIL); - !Null(interpreter_env); - interpreter_env = ECL_CONS_CDR(interpreter_env)) - { - cl_object record = ECL_CONS_CAR(interpreter_env); - if (!LISTP(record)) { - c_register_function(env, record); - } else { - cl_object record0 = ECL_CONS_CAR(record); - cl_object record1 = ECL_CONS_CDR(record); - if (ECL_SYMBOLP(record0)) { - c_register_var(env, record0, FALSE, TRUE); - } else if (record1 == ecl_make_fixnum(0)) { - c_register_tags(env, ECL_NIL); - } else { - c_register_block(env, record1); - } - } + if (!LISTP(interpreter_env)) + return; + /* + * Given the environment of an interpreted function, we guess a + * suitable compiler enviroment to compile forms that access the + * variables and local functions of this interpreted code. + */ + for (interpreter_env = @revappend(interpreter_env, ECL_NIL); + !Null(interpreter_env); + interpreter_env = ECL_CONS_CDR(interpreter_env)) + { + cl_object record = ECL_CONS_CAR(interpreter_env); + if (!LISTP(record)) { + c_register_function(env, record); + } else { + cl_object record0 = ECL_CONS_CAR(record); + cl_object record1 = ECL_CONS_CDR(record); + if (ECL_SYMBOLP(record0)) { + c_register_var(env, record0, FALSE, TRUE); + } else if (record1 == ecl_make_fixnum(0)) { + c_register_tags(env, ECL_NIL); + } else { + c_register_block(env, record1); } + } + } } static void c_new_env(cl_env_ptr the_env, cl_compiler_env_ptr new, cl_object env, cl_compiler_env_ptr old) { - the_env->c_env = new; - if (old) { - *new = *old; - new->env_depth = old->env_depth + 1; - } else { - new->code_walker = ECL_SYM_VAL(the_env, @'si::*code-walker*'); - new->constants = si_make_vector(ECL_T, ecl_make_fixnum(16), - ECL_T, /* Adjustable */ - ecl_make_fixnum(0), /* Fillp */ - ECL_NIL, /* displacement */ - ECL_NIL); - new->stepping = 0; - new->lexical_level = 0; - new->load_time_forms = ECL_NIL; - new->env_depth = 0; - new->macros = CDR(env); - new->variables = CAR(env); - for (env = new->variables; !Null(env); env = CDR(env)) { - cl_object record = CAR(env); - if (ECL_ATOM(record)) - continue; - if (ECL_SYMBOLP(CAR(record)) && CADR(record) != @'si::symbol-macro') { - continue; - } else { - new->lexical_level = 1; - break; - } - } - new->mode = FLAG_EXECUTE; - } - new->env_size = 0; + the_env->c_env = new; + if (old) { + *new = *old; + new->env_depth = old->env_depth + 1; + } else { + new->code_walker = ECL_SYM_VAL(the_env, @'si::*code-walker*'); + new->constants = si_make_vector(ECL_T, ecl_make_fixnum(16), + ECL_T, /* Adjustable */ + ecl_make_fixnum(0), /* Fillp */ + ECL_NIL, /* displacement */ + ECL_NIL); + new->stepping = 0; + new->lexical_level = 0; + new->load_time_forms = ECL_NIL; + new->env_depth = 0; + new->macros = CDR(env); + new->variables = CAR(env); + for (env = new->variables; !Null(env); env = CDR(env)) { + cl_object record = CAR(env); + if (ECL_ATOM(record)) + continue; + if (ECL_SYMBOLP(CAR(record)) && CADR(record) != @'si::symbol-macro') { + continue; + } else { + new->lexical_level = 1; + break; + } + } + new->mode = FLAG_EXECUTE; + } + new->env_size = 0; } static cl_object c_tag_ref(cl_env_ptr env, cl_object the_tag, cl_object the_type) { - cl_fixnum n = 0; - cl_object l; - const cl_compiler_ptr c_env = env->c_env; - for (l = c_env->variables; CONSP(l); l = ECL_CONS_CDR(l)) { - cl_object type, name, record = ECL_CONS_CAR(l); - if (ECL_ATOM(record)) - continue; - type = ECL_CONS_CAR(record); - record = ECL_CONS_CDR(record); - name = ECL_CONS_CAR(record); - if (type == @':tag') { - if (type == the_type) { - cl_object label = ecl_assql(the_tag, name); - if (!Null(label)) { - return CONS(ecl_make_fixnum(n), ECL_CONS_CDR(label)); - } - } - n++; - } else if (type == @':block' || type == @':function') { - /* We compare with EQUAL, because of (SETF fname) */ - if (type == the_type && ecl_equal(name, the_tag)) { - /* Mark as used */ - record = ECL_CONS_CDR(record); - ECL_RPLACA(record, ECL_T); - return ecl_make_fixnum(n); - } - n++; - } else if (Null(name)) { - n++; - } else { - /* We are counting only locals and ignore specials - * and other declarations */ - } - } - return ECL_NIL; + cl_fixnum n = 0; + cl_object l; + const cl_compiler_ptr c_env = env->c_env; + for (l = c_env->variables; CONSP(l); l = ECL_CONS_CDR(l)) { + cl_object type, name, record = ECL_CONS_CAR(l); + if (ECL_ATOM(record)) + continue; + type = ECL_CONS_CAR(record); + record = ECL_CONS_CDR(record); + name = ECL_CONS_CAR(record); + if (type == @':tag') { + if (type == the_type) { + cl_object label = ecl_assql(the_tag, name); + if (!Null(label)) { + return CONS(ecl_make_fixnum(n), ECL_CONS_CDR(label)); + } + } + n++; + } else if (type == @':block' || type == @':function') { + /* We compare with EQUAL, because of (SETF fname) */ + if (type == the_type && ecl_equal(name, the_tag)) { + /* Mark as used */ + record = ECL_CONS_CDR(record); + ECL_RPLACA(record, ECL_T); + return ecl_make_fixnum(n); + } + n++; + } else if (Null(name)) { + n++; + } else { + /* We are counting only locals and ignore specials + * and other declarations */ + } + } + return ECL_NIL; } ecl_def_ct_base_string(undefined_variable, @@ -631,161 +625,161 @@ static cl_fixnum c_var_ref(cl_env_ptr env, cl_object var, int allow_symbol_macro, bool ensure_defined) { - cl_fixnum n = 0; - cl_object l, record, special, name; - const cl_compiler_ptr c_env = env->c_env; - for (l = c_env->variables; CONSP(l); l = ECL_CONS_CDR(l)) { - record = ECL_CONS_CAR(l); - if (ECL_ATOM(record)) - continue; - name = ECL_CONS_CAR(record); - record = ECL_CONS_CDR(record); - special = ECL_CONS_CAR(record); - if (name == @':block' || name == @':tag' || name == @':function') { - n++; - } else if (name == @':declare') { - /* Ignored */ - } else if (name != var) { - /* Symbol not yet found. Only count locals. */ - if (Null(special)) n++; - } else if (special == @'si::symbol-macro') { - /* We can only get here when we try to redefine a - symbol macro */ - if (allow_symbol_macro) - return -1; - FEprogram_error_noreturn("Internal error: symbol macro ~S" - " used as variable", - 1, var); - } else if (Null(special)) { - return n; - } else { - return ECL_SPECIAL_VAR_REF; - } - } - if (ensure_defined) { - l = ecl_symbol_value(@'ext::*action-on-undefined-variable*'); - if (l != ECL_NIL) { - funcall(3, l, undefined_variable, var); - } - } - return ECL_UNDEFINED_VAR_REF; + cl_fixnum n = 0; + cl_object l, record, special, name; + const cl_compiler_ptr c_env = env->c_env; + for (l = c_env->variables; CONSP(l); l = ECL_CONS_CDR(l)) { + record = ECL_CONS_CAR(l); + if (ECL_ATOM(record)) + continue; + name = ECL_CONS_CAR(record); + record = ECL_CONS_CDR(record); + special = ECL_CONS_CAR(record); + if (name == @':block' || name == @':tag' || name == @':function') { + n++; + } else if (name == @':declare') { + /* Ignored */ + } else if (name != var) { + /* Symbol not yet found. Only count locals. */ + if (Null(special)) n++; + } else if (special == @'si::symbol-macro') { + /* We can only get here when we try to redefine a + symbol macro */ + if (allow_symbol_macro) + return -1; + FEprogram_error_noreturn("Internal error: symbol macro ~S" + " used as variable", + 1, var); + } else if (Null(special)) { + return n; + } else { + return ECL_SPECIAL_VAR_REF; + } + } + if (ensure_defined) { + l = ecl_symbol_value(@'ext::*action-on-undefined-variable*'); + if (l != ECL_NIL) { + funcall(3, l, undefined_variable, var); + } + } + return ECL_UNDEFINED_VAR_REF; } static bool c_declared_special(register cl_object var, register cl_object specials) { - return ((ecl_symbol_type(var) & ecl_stp_special) || ecl_member_eq(var, specials)); + return ((ecl_symbol_type(var) & ecl_stp_special) || ecl_member_eq(var, specials)); } static void c_declare_specials(cl_env_ptr env, cl_object specials) { - while (!Null(specials)) { - int ndx; - cl_object var = pop(&specials); - ndx = c_var_ref(env, var, 1, FALSE); - if (ndx >= 0 || ndx == ECL_UNDEFINED_VAR_REF) - c_register_var(env, var, TRUE, FALSE); - } + while (!Null(specials)) { + int ndx; + cl_object var = pop(&specials); + ndx = c_var_ref(env, var, 1, FALSE); + if (ndx >= 0 || ndx == ECL_UNDEFINED_VAR_REF) + c_register_var(env, var, TRUE, FALSE); + } } static cl_object c_process_declarations(cl_object body) { - const cl_env_ptr the_env = ecl_process_env(); - @si::process-declarations(1, body); - body = ecl_nth_value(the_env, 1); - return body; + const cl_env_ptr the_env = ecl_process_env(); + @si::process-declarations(1, body); + body = ecl_nth_value(the_env, 1); + return body; } static bool c_pbind(cl_env_ptr env, cl_object var, cl_object specials) { - bool special; - if (!ECL_SYMBOLP(var)) - FEillegal_variable_name(var); - else if ((special = c_declared_special(var, specials))) { - c_register_var(env, var, TRUE, TRUE); - asm_op2c(env, OP_PBINDS, var); - } else { - c_register_var(env, var, FALSE, TRUE); - asm_op2c(env, OP_PBIND, var); - } - return special; + bool special; + if (!ECL_SYMBOLP(var)) + FEillegal_variable_name(var); + else if ((special = c_declared_special(var, specials))) { + c_register_var(env, var, TRUE, TRUE); + asm_op2c(env, OP_PBINDS, var); + } else { + c_register_var(env, var, FALSE, TRUE); + asm_op2c(env, OP_PBIND, var); + } + return special; } static bool c_bind(cl_env_ptr env, cl_object var, cl_object specials) { - bool special; - if (!ECL_SYMBOLP(var)) - FEillegal_variable_name(var); - else if ((special = c_declared_special(var, specials))) { - c_register_var(env, var, TRUE, TRUE); - asm_op2c(env, OP_BINDS, var); - } else { - c_register_var(env, var, FALSE, TRUE); - asm_op2c(env, OP_BIND, var); - } - return special; + bool special; + if (!ECL_SYMBOLP(var)) + FEillegal_variable_name(var); + else if ((special = c_declared_special(var, specials))) { + c_register_var(env, var, TRUE, TRUE); + asm_op2c(env, OP_BINDS, var); + } else { + c_register_var(env, var, FALSE, TRUE); + asm_op2c(env, OP_BIND, var); + } + return special; } static void c_undo_bindings(cl_env_ptr the_env, cl_object old_vars, int only_specials) { - cl_object env; - cl_index num_lexical = 0; - cl_index num_special = 0; - const cl_compiler_ptr c_env = the_env->c_env; - - for (env = c_env->variables; env != old_vars && !Null(env); env = ECL_CONS_CDR(env)) - { - cl_object record, name, special; - record = ECL_CONS_CAR(env); - name = ECL_CONS_CAR(record); - record = ECL_CONS_CDR(record); - special = ECL_CONS_CAR(record); - if (name == @':block' || name == @':tag') { - (void)0; - } else if (name == @':function' || Null(special)) { - if (!only_specials) ++num_lexical; - } else if (name == @':declare') { - /* Ignored */ - } else if (special != @'si::symbol-macro') { - /* If (third special) = NIL, the variable was declared - special, but there is no binding! */ - record = ECL_CONS_CDR(record); - if (!Null(ECL_CONS_CAR(record))) { - num_special++; - } - } - } - c_env->variables = env; - if (num_lexical) asm_op2(the_env, OP_UNBIND, num_lexical); - if (num_special) asm_op2(the_env, OP_UNBINDS, num_special); + cl_object env; + cl_index num_lexical = 0; + cl_index num_special = 0; + const cl_compiler_ptr c_env = the_env->c_env; + + for (env = c_env->variables; env != old_vars && !Null(env); env = ECL_CONS_CDR(env)) + { + cl_object record, name, special; + record = ECL_CONS_CAR(env); + name = ECL_CONS_CAR(record); + record = ECL_CONS_CDR(record); + special = ECL_CONS_CAR(record); + if (name == @':block' || name == @':tag') { + (void)0; + } else if (name == @':function' || Null(special)) { + if (!only_specials) ++num_lexical; + } else if (name == @':declare') { + /* Ignored */ + } else if (special != @'si::symbol-macro') { + /* If (third special) = NIL, the variable was declared + special, but there is no binding! */ + record = ECL_CONS_CDR(record); + if (!Null(ECL_CONS_CAR(record))) { + num_special++; + } + } + } + c_env->variables = env; + if (num_lexical) asm_op2(the_env, OP_UNBIND, num_lexical); + if (num_special) asm_op2(the_env, OP_UNBINDS, num_special); } static void compile_setq(cl_env_ptr env, int op, cl_object var) { - cl_fixnum ndx; + cl_fixnum ndx; - if (!ECL_SYMBOLP(var)) - FEillegal_variable_name(var); - ndx = c_var_ref(env, var,0,TRUE); - if (ndx < 0) { /* Not a lexical variable */ - if (ecl_symbol_type(var) & ecl_stp_constant) { - FEassignment_to_constant(var); - } - ndx = c_register_constant(env, var); - if (op == OP_SETQ) - op = OP_SETQS; - else if (op == OP_PSETQ) - op = OP_PSETQS; - else if (op == OP_VSETQ) - op = OP_VSETQS; - } - asm_op2(env, op, ndx); + if (!ECL_SYMBOLP(var)) + FEillegal_variable_name(var); + ndx = c_var_ref(env, var,0,TRUE); + if (ndx < 0) { /* Not a lexical variable */ + if (ecl_symbol_type(var) & ecl_stp_constant) { + FEassignment_to_constant(var); + } + ndx = c_register_constant(env, var); + if (op == OP_SETQ) + op = OP_SETQS; + else if (op == OP_PSETQ) + op = OP_PSETQS; + else if (op == OP_VSETQ) + op = OP_VSETQS; + } + asm_op2(env, op, ndx); } /* @@ -800,10 +794,10 @@ */ static int maybe_values_or_reg0(int flags) { - if (flags & FLAG_PUSH) - return (flags | FLAG_VALUES) & ~FLAG_PUSH; - else - return flags; + if (flags & FLAG_PUSH) + return (flags | FLAG_VALUES) & ~FLAG_PUSH; + else + return flags; } /* @@ -818,10 +812,10 @@ */ static int maybe_values(int flags) { - if (flags & FLAG_USEFUL) - return (flags & ~(FLAG_PUSH | FLAG_REG0)) | FLAG_VALUES; - else - return flags; + if (flags & FLAG_USEFUL) + return (flags & ~(FLAG_PUSH | FLAG_REG0)) | FLAG_VALUES; + else + return flags; } /* @@ -836,358 +830,358 @@ */ static int maybe_reg0(int flags) { - if (flags & FLAG_USEFUL) - return (flags & ~(FLAG_VALUES | FLAG_PUSH)) | FLAG_REG0; - else - return flags; + if (flags & FLAG_USEFUL) + return (flags & ~(FLAG_VALUES | FLAG_PUSH)) | FLAG_REG0; + else + return flags; } /* -------------------- THE COMPILER -------------------- */ /* - The OP_BLOCK operator encloses several forms within a block - named BLOCK_NAME, thus catching any OP_RETFROM whose argument - matches BLOCK_NAME. The end of this block is marked both by - the OP_EXIT operator and the LABELZ which is packed within - the OP_BLOCK operator. - - [OP_BLOCK + name + labelz] - .... - OP_EXIT_FRAME - labelz: ... + The OP_BLOCK operator encloses several forms within a block + named BLOCK_NAME, thus catching any OP_RETFROM whose argument + matches BLOCK_NAME. The end of this block is marked both by + the OP_EXIT operator and the LABELZ which is packed within + the OP_BLOCK operator. + + [OP_BLOCK + name + labelz] + .... + OP_EXIT_FRAME + labelz: ... */ static int c_block(cl_env_ptr env, cl_object body, int old_flags) { - struct cl_compiler_env old_env; - cl_object name = pop(&body); - cl_object block_record; - cl_index labelz, pc, loc, constants; - int flags; - - if (!ECL_SYMBOLP(name)) - FEprogram_error_noreturn("BLOCK: Not a valid block name, ~S", 1, name); - - old_env = *(env->c_env); - constants = old_env.constants->vector.fillp; - pc = current_pc(env); - - flags = maybe_values_or_reg0(old_flags); - loc = c_register_block(env, name); - block_record = ECL_CONS_CAR(env->c_env->variables); - if (Null(name)) { - asm_op(env, OP_DO); - } else { - asm_op2c(env, OP_BLOCK, name); - } - labelz = asm_jmp(env, OP_FRAME); - compile_body(env, body, flags); - if (CADDR(block_record) == ECL_NIL) { - /* Block unused. We remove the enclosing OP_BLOCK/OP_DO */ - /* We also have to remove the constants we compiled, because */ - /* some of them might be from load-time-value */ - old_env.constants->vector.fillp = constants; - *(env->c_env) = old_env; - set_pc(env, pc); - return compile_body(env, body, old_flags); - } else { - c_undo_bindings(env, old_env.variables, 0); - asm_op(env, OP_EXIT_FRAME); - asm_complete(env, 0, labelz); - return flags; - } + struct cl_compiler_env old_env; + cl_object name = pop(&body); + cl_object block_record; + cl_index labelz, pc, loc, constants; + int flags; + + if (!ECL_SYMBOLP(name)) + FEprogram_error_noreturn("BLOCK: Not a valid block name, ~S", 1, name); + + old_env = *(env->c_env); + constants = old_env.constants->vector.fillp; + pc = current_pc(env); + + flags = maybe_values_or_reg0(old_flags); + loc = c_register_block(env, name); + block_record = ECL_CONS_CAR(env->c_env->variables); + if (Null(name)) { + asm_op(env, OP_DO); + } else { + asm_op2c(env, OP_BLOCK, name); + } + labelz = asm_jmp(env, OP_FRAME); + compile_body(env, body, flags); + if (CADDR(block_record) == ECL_NIL) { + /* Block unused. We remove the enclosing OP_BLOCK/OP_DO */ + /* We also have to remove the constants we compiled, because */ + /* some of them might be from load-time-value */ + old_env.constants->vector.fillp = constants; + *(env->c_env) = old_env; + set_pc(env, pc); + return compile_body(env, body, old_flags); + } else { + c_undo_bindings(env, old_env.variables, 0); + asm_op(env, OP_EXIT_FRAME); + asm_complete(env, 0, labelz); + return flags; + } } /* - There are several ways to invoke functions and to handle the - output arguments. These are - - [OP_CALL + nargs] - function_name - - [OP_FCALL + nargs] - - OP_CALL and OP_FCALL leave all arguments in the VALUES() array, - while OP_PCALL and OP_PFCALL leave the first argument in the - stack. - - OP_CALL and OP_PCALL use the value in VALUES(0) to retrieve the - function, while OP_FCALL and OP_PFCALL use a value from the - stack. - */ + There are several ways to invoke functions and to handle the + output arguments. These are + + [OP_CALL + nargs] + function_name + + [OP_FCALL + nargs] + + OP_CALL and OP_FCALL leave all arguments in the VALUES() array, + while OP_PCALL and OP_PFCALL leave the first argument in the + stack. + + OP_CALL and OP_PCALL use the value in VALUES(0) to retrieve the + function, while OP_FCALL and OP_PFCALL use a value from the + stack. +*/ static int c_arguments(cl_env_ptr env, cl_object args) { - cl_index nargs; - for (nargs = 0; !Null(args); nargs++) { - compile_form(env, pop(&args), FLAG_PUSH); - } - return nargs; + cl_index nargs; + for (nargs = 0; !Null(args); nargs++) { + compile_form(env, pop(&args), FLAG_PUSH); + } + return nargs; } static int asm_function(cl_env_ptr env, cl_object args, int flags); static int c_call(cl_env_ptr env, cl_object args, int flags) { - cl_object name; - cl_index nargs; + cl_object name; + cl_index nargs; - name = pop(&args); - if (name >= (cl_object)cl_symbols - && name < (cl_object)(cl_symbols + cl_num_symbols_in_core)) - { - cl_object f = ECL_SYM_FUN(name); - cl_type t = (f == OBJNULL)? t_other : ecl_t_of(f); - if (t == t_cfunfixed) { - cl_index n = ecl_length(args); - if (f->cfun.narg == 1 && n == 1) { - compile_form(env, ECL_CONS_CAR(args), FLAG_REG0); - asm_op2c(env, OP_CALLG1, name); - return FLAG_VALUES; - } else if (f->cfun.narg == 2 && n == 2) { - compile_form(env, ECL_CONS_CAR(args), FLAG_PUSH); - args = ECL_CONS_CDR(args); - compile_form(env, ECL_CONS_CAR(args), FLAG_REG0); - asm_op2c(env, OP_CALLG2, name); - return FLAG_VALUES; - } - } - } - nargs = c_arguments(env, args); - if (env->c_env->stepping) { - /* When stepping, we only have one opcode to do function - * calls: OP_STEPFCALL. */ - asm_function(env, name, (flags & FLAG_GLOBAL) | FLAG_REG0); - asm_op2(env, OP_STEPCALL, nargs); - flags = FLAG_VALUES; - } else if (ECL_SYMBOLP(name) && - ((flags & FLAG_GLOBAL) || Null(c_tag_ref(env, name, @':function')))) - { - asm_op2(env, OP_CALLG, nargs); - asm_c(env, name); - flags = FLAG_VALUES; - } else { - /* Fixme!! We can optimize the case of global functions! */ - asm_function(env, name, (flags & FLAG_GLOBAL) | FLAG_REG0); - asm_op2(env, OP_CALL, nargs); - flags = FLAG_VALUES; - } - return flags; + name = pop(&args); + if (name >= (cl_object)cl_symbols + && name < (cl_object)(cl_symbols + cl_num_symbols_in_core)) + { + cl_object f = ECL_SYM_FUN(name); + cl_type t = (f == OBJNULL)? t_other : ecl_t_of(f); + if (t == t_cfunfixed) { + cl_index n = ecl_length(args); + if (f->cfun.narg == 1 && n == 1) { + compile_form(env, ECL_CONS_CAR(args), FLAG_REG0); + asm_op2c(env, OP_CALLG1, name); + return FLAG_VALUES; + } else if (f->cfun.narg == 2 && n == 2) { + compile_form(env, ECL_CONS_CAR(args), FLAG_PUSH); + args = ECL_CONS_CDR(args); + compile_form(env, ECL_CONS_CAR(args), FLAG_REG0); + asm_op2c(env, OP_CALLG2, name); + return FLAG_VALUES; + } + } + } + nargs = c_arguments(env, args); + if (env->c_env->stepping) { + /* When stepping, we only have one opcode to do function + * calls: OP_STEPFCALL. */ + asm_function(env, name, (flags & FLAG_GLOBAL) | FLAG_REG0); + asm_op2(env, OP_STEPCALL, nargs); + flags = FLAG_VALUES; + } else if (ECL_SYMBOLP(name) && + ((flags & FLAG_GLOBAL) || Null(c_tag_ref(env, name, @':function')))) + { + asm_op2(env, OP_CALLG, nargs); + asm_c(env, name); + flags = FLAG_VALUES; + } else { + /* Fixme!! We can optimize the case of global functions! */ + asm_function(env, name, (flags & FLAG_GLOBAL) | FLAG_REG0); + asm_op2(env, OP_CALL, nargs); + flags = FLAG_VALUES; + } + return flags; } static int c_funcall(cl_env_ptr env, cl_object args, int flags) { - cl_object name; - cl_index nargs; + cl_object name; + cl_index nargs; - name = pop(&args); - if (CONSP(name)) { - cl_object kind = ECL_CONS_CAR(name); - if (kind == @'function') { - if (cl_list_length(name) != ecl_make_fixnum(2)) - FEprogram_error_noreturn("FUNCALL: Invalid function name ~S", - 1, name); - return c_call(env, CONS(CADR(name), args), flags); - } - if (kind == @'quote') { - if (cl_list_length(name) != ecl_make_fixnum(2)) - FEprogram_error_noreturn("FUNCALL: Invalid function name ~S", - 1, name); - return c_call(env, CONS(CADR(name), args), flags | FLAG_GLOBAL); - } - } - compile_form(env, name, FLAG_PUSH); - nargs = c_arguments(env, args); - if (env->c_env->stepping) { - asm_op2(env, OP_STEPCALL, nargs); - flags = FLAG_VALUES; - } else { - asm_op2(env, OP_FCALL, nargs); - flags = FLAG_VALUES; - } - asm_op(env, OP_POP1); - return flags; + name = pop(&args); + if (CONSP(name)) { + cl_object kind = ECL_CONS_CAR(name); + if (kind == @'function') { + if (cl_list_length(name) != ecl_make_fixnum(2)) + FEprogram_error_noreturn("FUNCALL: Invalid function name ~S", + 1, name); + return c_call(env, CONS(CADR(name), args), flags); + } + if (kind == @'quote') { + if (cl_list_length(name) != ecl_make_fixnum(2)) + FEprogram_error_noreturn("FUNCALL: Invalid function name ~S", + 1, name); + return c_call(env, CONS(CADR(name), args), flags | FLAG_GLOBAL); + } + } + compile_form(env, name, FLAG_PUSH); + nargs = c_arguments(env, args); + if (env->c_env->stepping) { + asm_op2(env, OP_STEPCALL, nargs); + flags = FLAG_VALUES; + } else { + asm_op2(env, OP_FCALL, nargs); + flags = FLAG_VALUES; + } + asm_op(env, OP_POP1); + return flags; } static int perform_c_case(cl_env_ptr env, cl_object args, int flags) { - cl_object test, clause; + cl_object test, clause; - do { - if (Null(args)) - return compile_body(env, ECL_NIL, flags); - clause = pop(&args); - if (ECL_ATOM(clause)) - FEprogram_error_noreturn("CASE: Illegal clause ~S.",1,clause); - test = pop(&clause); - } while (test == ECL_NIL); - - if (@'otherwise' == test || test == ECL_T) { - unlikely_if (args != ECL_NIL) { - FEprogram_error_noreturn("CASE: The selector ~A can only appear at the last position.", - 1, test); - } - compile_body(env, clause, flags); - } else { - cl_index labeln, labelz; - if (CONSP(test)) { - cl_index n = ecl_length(test); - while (n-- > 1) { - cl_object v = pop(&test); - asm_op(env, OP_JEQL); - asm_c(env, v); - asm_arg(env, n * (OPCODE_SIZE + OPARG_SIZE * 2) - + OPARG_SIZE); - } - test = ECL_CONS_CAR(test); - } - asm_op(env, OP_JNEQL); - asm_c(env, test); - labeln = current_pc(env); - asm_arg(env, 0); - compile_body(env, clause, flags); - if (Null(args) && !(flags & FLAG_USEFUL)) { - /* Ther is no otherwise. The test has failed and - we need no output value. We simply close jumps. */ - asm_complete(env, 0 & OP_JNEQL, labeln); - } else { - labelz = asm_jmp(env, OP_JMP); - asm_complete(env, 0 & OP_JNEQL, labeln); - perform_c_case(env, args, flags); - asm_complete(env, OP_JMP, labelz); - } - } - return flags; + do { + if (Null(args)) + return compile_body(env, ECL_NIL, flags); + clause = pop(&args); + if (ECL_ATOM(clause)) + FEprogram_error_noreturn("CASE: Illegal clause ~S.",1,clause); + test = pop(&clause); + } while (test == ECL_NIL); + + if (@'otherwise' == test || test == ECL_T) { + unlikely_if (args != ECL_NIL) { + FEprogram_error_noreturn("CASE: The selector ~A can only appear at the last position.", + 1, test); + } + compile_body(env, clause, flags); + } else { + cl_index labeln, labelz; + if (CONSP(test)) { + cl_index n = ecl_length(test); + while (n-- > 1) { + cl_object v = pop(&test); + asm_op(env, OP_JEQL); + asm_c(env, v); + asm_arg(env, n * (OPCODE_SIZE + OPARG_SIZE * 2) + + OPARG_SIZE); + } + test = ECL_CONS_CAR(test); + } + asm_op(env, OP_JNEQL); + asm_c(env, test); + labeln = current_pc(env); + asm_arg(env, 0); + compile_body(env, clause, flags); + if (Null(args) && !(flags & FLAG_USEFUL)) { + /* Ther is no otherwise. The test has failed and + we need no output value. We simply close jumps. */ + asm_complete(env, 0 & OP_JNEQL, labeln); + } else { + labelz = asm_jmp(env, OP_JMP); + asm_complete(env, 0 & OP_JNEQL, labeln); + perform_c_case(env, args, flags); + asm_complete(env, OP_JMP, labelz); + } + } + return flags; } static int c_case(cl_env_ptr env, cl_object clause, int flags) { - compile_form(env, pop(&clause), FLAG_REG0); - return perform_c_case(env, clause, maybe_values_or_reg0(flags)); + compile_form(env, pop(&clause), FLAG_REG0); + return perform_c_case(env, clause, maybe_values_or_reg0(flags)); } /* - The OP_CATCH takes the object in VALUES(0) and uses it to catch - any OP_THROW operation which uses that value as argument. If a - catch occurs, or when all forms have been properly executed, it - jumps to LABELZ. LABELZ is packed within the OP_CATCH operator. - [OP_CATCH + labelz] - ... - "forms to be caught" - ... - OP_EXIT_FRAME - labelz: ... + The OP_CATCH takes the object in VALUES(0) and uses it to catch + any OP_THROW operation which uses that value as argument. If a + catch occurs, or when all forms have been properly executed, it + jumps to LABELZ. LABELZ is packed within the OP_CATCH operator. + [OP_CATCH + labelz] + ... + "forms to be caught" + ... + OP_EXIT_FRAME + labelz: ... */ static int c_catch(cl_env_ptr env, cl_object args, int flags) { - cl_index labelz, loc; - cl_object old_env; + cl_index labelz, loc; + cl_object old_env; - /* Compile evaluation of tag */ - compile_form(env, pop(&args), FLAG_REG0); + /* Compile evaluation of tag */ + compile_form(env, pop(&args), FLAG_REG0); - /* Compile binding of tag */ - old_env = env->c_env->variables; - loc = c_register_block(env, ecl_make_fixnum(0)); - asm_op(env, OP_CATCH); + /* Compile binding of tag */ + old_env = env->c_env->variables; + loc = c_register_block(env, ecl_make_fixnum(0)); + asm_op(env, OP_CATCH); - /* Compile jump point */ - labelz = asm_jmp(env, OP_FRAME); + /* Compile jump point */ + labelz = asm_jmp(env, OP_FRAME); - /* Compile body of CATCH */ - compile_body(env, args, FLAG_VALUES); + /* Compile body of CATCH */ + compile_body(env, args, FLAG_VALUES); - c_undo_bindings(env, old_env, 0); - asm_op(env, OP_EXIT_FRAME); - asm_complete(env, 0, labelz); + c_undo_bindings(env, old_env, 0); + asm_op(env, OP_EXIT_FRAME); + asm_complete(env, 0, labelz); - return FLAG_VALUES; + return FLAG_VALUES; } static int c_compiler_let(cl_env_ptr env, cl_object args, int flags) { - cl_object bindings; - cl_index old_bds_top_index = env->bds_top - env->bds_org; + cl_object bindings; + cl_index old_bds_top_index = env->bds_top - env->bds_org; - for (bindings = pop(&args); !Null(bindings); ) { - cl_object form = pop(&bindings); - cl_object var = pop(&form); - cl_object value = pop_maybe_nil(&form); - ecl_bds_bind(env, var, value); - } - flags = compile_toplevel_body(env, args, flags); - ecl_bds_unwind(env, old_bds_top_index); - return flags; + for (bindings = pop(&args); !Null(bindings); ) { + cl_object form = pop(&bindings); + cl_object var = pop(&form); + cl_object value = pop_maybe_nil(&form); + ecl_bds_bind(env, var, value); + } + flags = compile_toplevel_body(env, args, flags); + ecl_bds_unwind(env, old_bds_top_index); + return flags; } /* - There are three operators which perform explicit jumps, but - almost all other operators use labels in one way or - another. - - 1) Jumps are always relative to the place where the jump label - is retrieved so that if the label is in vector[0], then the - destination is roughly vector + vector[0]. - - 2) The three jump forms are - - [OP_JMP + label] ; Unconditional jump - [OP_JNIL + label] ; Jump if VALUES(0) == ECL_NIL - [OP_JT + label] ; Jump if VALUES(0) != ECL_NIL - - It is important to remark that both OP_JNIL and OP_JT truncate - the values stack, so that always NVALUES = 1 after performing - any of these operations. + There are three operators which perform explicit jumps, but + almost all other operators use labels in one way or + another. + + 1) Jumps are always relative to the place where the jump label + is retrieved so that if the label is in vector[0], then the + destination is roughly vector + vector[0]. + + 2) The three jump forms are + + [OP_JMP + label] ; Unconditional jump + [OP_JNIL + label] ; Jump if VALUES(0) == ECL_NIL + [OP_JT + label] ; Jump if VALUES(0) != ECL_NIL + + It is important to remark that both OP_JNIL and OP_JT truncate + the values stack, so that always NVALUES = 1 after performing + any of these operations. */ static int c_cond(cl_env_ptr env, cl_object args, int flags) { - cl_object test, clause; - cl_index label_nil, label_exit; + cl_object test, clause; + cl_index label_nil, label_exit; - if (Null(args)) - return compile_form(env, ECL_NIL, flags); - clause = pop(&args); - if (ECL_ATOM(clause)) - FEprogram_error_noreturn("COND: Illegal clause ~S.",1,clause); - test = pop(&clause); - flags = maybe_values_or_reg0(flags); - if (ECL_T == test) { - /* Default sentence. If no forms, just output T. */ - if (Null(clause)) - compile_form(env, ECL_T, flags); - else - compile_body(env, clause, flags); - } else { - /* Compile the test. If no more forms, just output - the first value (this is guaranteed by OP_JT), but make - sure it is stored in the appropriate place. */ - if (Null(args)) { - if (Null(clause)) { - c_values(env, cl_list(1,test), flags); - } else { - compile_form(env, test, FLAG_REG0); - if (flags & FLAG_VALUES) asm_op(env, OP_VALUEREG0); - label_nil = asm_jmp(env, OP_JNIL); - compile_body(env, clause, flags); - asm_complete(env, OP_JNIL, label_nil); - } - } else if (Null(clause)) { - compile_form(env, test, FLAG_REG0); - if (flags & FLAG_VALUES) asm_op(env, OP_VALUEREG0); - label_exit = asm_jmp(env, OP_JT); - c_cond(env, args, flags); - asm_complete(env, OP_JT, label_exit); - } else { - compile_form(env, test, FLAG_REG0); - label_nil = asm_jmp(env, OP_JNIL); - compile_body(env, clause, flags); - label_exit = asm_jmp(env, OP_JMP); - asm_complete(env, OP_JNIL, label_nil); - c_cond(env, args, flags); - asm_complete(env, OP_JMP, label_exit); - } - } - return flags; + if (Null(args)) + return compile_form(env, ECL_NIL, flags); + clause = pop(&args); + if (ECL_ATOM(clause)) + FEprogram_error_noreturn("COND: Illegal clause ~S.",1,clause); + test = pop(&clause); + flags = maybe_values_or_reg0(flags); + if (ECL_T == test) { + /* Default sentence. If no forms, just output T. */ + if (Null(clause)) + compile_form(env, ECL_T, flags); + else + compile_body(env, clause, flags); + } else { + /* Compile the test. If no more forms, just output + the first value (this is guaranteed by OP_JT), but make + sure it is stored in the appropriate place. */ + if (Null(args)) { + if (Null(clause)) { + c_values(env, cl_list(1,test), flags); + } else { + compile_form(env, test, FLAG_REG0); + if (flags & FLAG_VALUES) asm_op(env, OP_VALUEREG0); + label_nil = asm_jmp(env, OP_JNIL); + compile_body(env, clause, flags); + asm_complete(env, OP_JNIL, label_nil); + } + } else if (Null(clause)) { + compile_form(env, test, FLAG_REG0); + if (flags & FLAG_VALUES) asm_op(env, OP_VALUEREG0); + label_exit = asm_jmp(env, OP_JT); + c_cond(env, args, flags); + asm_complete(env, OP_JT, label_exit); + } else { + compile_form(env, test, FLAG_REG0); + label_nil = asm_jmp(env, OP_JNIL); + compile_body(env, clause, flags); + label_exit = asm_jmp(env, OP_JMP); + asm_complete(env, OP_JNIL, label_nil); + c_cond(env, args, flags); + asm_complete(env, OP_JMP, label_exit); + } + } + return flags; } /* The OP_DO operator saves the lexical environment and establishes @@ -1196,88 +1190,88 @@ means of a OP_RETFROM jump or because of normal termination, the lexical environment is restored, and all bindings undone. - [OP_DO + labelz] - ... ; bindings - [JMP + labelt] + [OP_DO + labelz] + ... ; bindings + [JMP + labelt] labelb: ... ; body - ... ; stepping forms + ... ; stepping forms labelt: ... ; test form - [JNIL + label] - ... ; output form - OP_EXIT_FRAME + [JNIL + label] + ... ; output form + OP_EXIT_FRAME labelz: */ static int c_while_until(cl_env_ptr env, cl_object body, int flags, bool is_while) { - cl_object test = pop(&body); - cl_index labelt, labelb; + cl_object test = pop(&body); + cl_index labelt, labelb; - flags = maybe_reg0(flags); + flags = maybe_reg0(flags); - /* Jump to test */ - labelt = asm_jmp(env, OP_JMP); + /* Jump to test */ + labelt = asm_jmp(env, OP_JMP); - /* Compile body */ - labelb = current_pc(env); - c_tagbody(env, body, flags); + /* Compile body */ + labelb = current_pc(env); + c_tagbody(env, body, flags); - /* Compile test */ - asm_complete(env, OP_JMP, labelt); - compile_form(env, test, FLAG_REG0); - asm_op(env, is_while? OP_JT : OP_JNIL); - asm_arg(env, labelb - current_pc(env)); + /* Compile test */ + asm_complete(env, OP_JMP, labelt); + compile_form(env, test, FLAG_REG0); + asm_op(env, is_while? OP_JT : OP_JNIL); + asm_arg(env, labelb - current_pc(env)); - return flags; + return flags; } static int c_while(cl_env_ptr env, cl_object body, int flags) { - return c_while_until(env, body, flags, 1); + return c_while_until(env, body, flags, 1); } static int c_until(cl_env_ptr env, cl_object body, int flags) { - return c_while_until(env, body, flags, 0); + return c_while_until(env, body, flags, 0); } static int c_with_backend(cl_env_ptr env, cl_object args, int flags) { - cl_object forms = ECL_NIL; - while (!Null(args)) { - cl_object tag = pop(&args); - cl_object form = pop(&args); - if (tag == @':bytecodes') - forms = CONS(form, forms); - } - return compile_toplevel_body(env, forms, flags); + cl_object forms = ECL_NIL; + while (!Null(args)) { + cl_object tag = pop(&args); + cl_object form = pop(&args); + if (tag == @':bytecodes') + forms = CONS(form, forms); + } + return compile_toplevel_body(env, forms, flags); } static int eval_when_flags(cl_object situation) { - int code = 0; - cl_object p; - for (p = situation; p != ECL_NIL; p = ECL_CONS_CDR(p)) { - cl_object keyword; - unlikely_if (!ECL_LISTP(p)) - FEtype_error_proper_list(situation); - keyword = ECL_CONS_CAR(p); - if (keyword == @'load') - code |= FLAG_LOAD; - else if (keyword == @':load-toplevel') - code |= FLAG_LOAD; - else if (keyword == @'compile') - code |= FLAG_COMPILE; - else if (keyword == @':compile-toplevel') - code |= FLAG_COMPILE; - else if (keyword == @'eval') - code |= FLAG_EXECUTE; - else if (keyword == @':execute') - code |= FLAG_EXECUTE; - } - return code; + int code = 0; + cl_object p; + for (p = situation; p != ECL_NIL; p = ECL_CONS_CDR(p)) { + cl_object keyword; + unlikely_if (!ECL_LISTP(p)) + FEtype_error_proper_list(situation); + keyword = ECL_CONS_CAR(p); + if (keyword == @'load') + code |= FLAG_LOAD; + else if (keyword == @':load-toplevel') + code |= FLAG_LOAD; + else if (keyword == @'compile') + code |= FLAG_COMPILE; + else if (keyword == @':compile-toplevel') + code |= FLAG_COMPILE; + else if (keyword == @'eval') + code |= FLAG_EXECUTE; + else if (keyword == @':execute') + code |= FLAG_EXECUTE; + } + return code; } #define when_load_p(s) ((s) & FLAG_LOAD) @@ -1286,1158 +1280,1158 @@ static int c_eval_when(cl_env_ptr env, cl_object args, int flags) { - cl_object situation_list = pop(&args); - int situation = eval_when_flags(situation_list); - const cl_compiler_ptr c_env = env->c_env; - int mode = c_env->mode; - if (mode == FLAG_EXECUTE) { - if (!when_execute_p(situation)) - args = ECL_NIL; - } else if (c_env->lexical_level) { - if (!when_execute_p(situation)) - args = ECL_NIL; - } else if (mode == FLAG_LOAD) { - if (when_compile_p(situation)) { - env->c_env->mode = FLAG_COMPILE; - execute_each_form(env, args); - env->c_env->mode = FLAG_LOAD; - if (!when_load_p(situation)) - args = ECL_NIL; - } else if (when_load_p(situation)) { - env->c_env->mode = FLAG_ONLY_LOAD; - flags = compile_toplevel_body(env, args, flags); - env->c_env->mode = FLAG_LOAD; - return flags; - } else { - args = ECL_NIL; - } - } else if (mode == FLAG_ONLY_LOAD) { - if (!when_load_p(situation)) - args = ECL_NIL; - } else { /* FLAG_COMPILE */ - if (when_execute_p(situation) || when_compile_p(situation)) { - execute_each_form(env, args); - } - args = ECL_NIL; - } - return compile_toplevel_body(env, args, flags); + cl_object situation_list = pop(&args); + int situation = eval_when_flags(situation_list); + const cl_compiler_ptr c_env = env->c_env; + int mode = c_env->mode; + if (mode == FLAG_EXECUTE) { + if (!when_execute_p(situation)) + args = ECL_NIL; + } else if (c_env->lexical_level) { + if (!when_execute_p(situation)) + args = ECL_NIL; + } else if (mode == FLAG_LOAD) { + if (when_compile_p(situation)) { + env->c_env->mode = FLAG_COMPILE; + execute_each_form(env, args); + env->c_env->mode = FLAG_LOAD; + if (!when_load_p(situation)) + args = ECL_NIL; + } else if (when_load_p(situation)) { + env->c_env->mode = FLAG_ONLY_LOAD; + flags = compile_toplevel_body(env, args, flags); + env->c_env->mode = FLAG_LOAD; + return flags; + } else { + args = ECL_NIL; + } + } else if (mode == FLAG_ONLY_LOAD) { + if (!when_load_p(situation)) + args = ECL_NIL; + } else { /* FLAG_COMPILE */ + if (when_execute_p(situation) || when_compile_p(situation)) { + execute_each_form(env, args); + } + args = ECL_NIL; + } + return compile_toplevel_body(env, args, flags); } /* - The OP_FLET/OP_FLABELS operators change the lexical environment - to add a few local functions. - - [OP_FLET/OP_FLABELS + nfun + fun1] - ... - OP_UNBIND nfun - labelz: + The OP_FLET/OP_FLABELS operators change the lexical environment + to add a few local functions. + + [OP_FLET/OP_FLABELS + nfun + fun1] + ... + OP_UNBIND nfun + labelz: */ static cl_index c_register_functions(cl_env_ptr env, cl_object l) { - cl_index nfun; - for (nfun = 0; !Null(l); nfun++) { - cl_object definition = pop(&l); - cl_object name = pop(&definition); - c_register_function(env, name); - } - return nfun; + cl_index nfun; + for (nfun = 0; !Null(l); nfun++) { + cl_object definition = pop(&l); + cl_object name = pop(&definition); + c_register_function(env, name); + } + return nfun; } static int c_labels_flet(cl_env_ptr env, int op, cl_object args, int flags) { #define push(v,l) { cl_object c = *l = CONS(v, *l); l = &ECL_CONS_CDR(c); } - cl_object l, def_list = pop(&args); - cl_object old_vars = env->c_env->variables; - cl_object old_funs = env->c_env->macros; - cl_object fnames = ECL_NIL; - cl_object v, *f = &fnames; - cl_index nfun; + cl_object l, def_list = pop(&args); + cl_object old_vars = env->c_env->variables; + cl_object old_funs = env->c_env->macros; + cl_object fnames = ECL_NIL; + cl_object v, *f = &fnames; + cl_index nfun; + + if (def_list == ECL_NIL) { + return c_locally(env, args, flags); + } + + /* ANSI doesn't specify what should happen if we define + multiple functions of the same name in the flet/labels + block – ECL treats this undefined behavior as an error */ + for (l = def_list, nfun = 0; !Null(l); nfun++) { + v = CAR(pop(&l)); + if (ecl_member_eq(v, fnames)) + FEprogram_error_noreturn + ("~s: The function ~s was already defined.", + 2, (op == OP_LABELS ? @'LABELS' : @'FLET'), v); + push(v, f); + } + + /* If compiling a LABELS form, add the function names to the lexical + environment before compiling the functions */ + if (op == OP_LABELS) + c_register_functions(env, def_list); + + /* Push the operator (OP_LABELS/OP_FLET) with the number of functions */ + asm_op2(env, op, nfun); + + /* Compile the local functions now. */ + for (l = def_list; !Null(l); ) { + cl_object definition = pop(&l); + cl_object name = pop(&definition); + cl_object lambda = ecl_make_lambda(env, name, definition); + cl_index c = c_register_constant(env, lambda); + asm_arg(env, c); + } + + /* If compiling a FLET form, add the function names to the lexical + environment after compiling the functions */ + if (op == OP_FLET) + c_register_functions(env, def_list); + + /* Compile the body of the form with the local functions in the lexical + environment. */ + flags = c_locally(env, args, flags); + + /* Restore and return */ + c_undo_bindings(env, old_vars, 0); + env->c_env->macros = old_funs; - if (def_list == ECL_NIL) { - return c_locally(env, args, flags); - } - - /* ANSI doesn't specify what should happen if we define - multiple functions of the same name in the flet/labels - block – ECL treats this undefined behavior as an error */ - for (l = def_list, nfun = 0; !Null(l); nfun++) { - v = CAR(pop(&l)); - if (ecl_member_eq(v, fnames)) - FEprogram_error_noreturn - ("~s: The function ~s was already defined.", - 2, (op == OP_LABELS ? @'LABELS' : @'FLET'), v); - push(v, f); - } - - /* If compiling a LABELS form, add the function names to the lexical - environment before compiling the functions */ - if (op == OP_LABELS) - c_register_functions(env, def_list); - - /* Push the operator (OP_LABELS/OP_FLET) with the number of functions */ - asm_op2(env, op, nfun); - - /* Compile the local functions now. */ - for (l = def_list; !Null(l); ) { - cl_object definition = pop(&l); - cl_object name = pop(&definition); - cl_object lambda = ecl_make_lambda(env, name, definition); - cl_index c = c_register_constant(env, lambda); - asm_arg(env, c); - } - - /* If compiling a FLET form, add the function names to the lexical - environment after compiling the functions */ - if (op == OP_FLET) - c_register_functions(env, def_list); - - /* Compile the body of the form with the local functions in the lexical - environment. */ - flags = c_locally(env, args, flags); - - /* Restore and return */ - c_undo_bindings(env, old_vars, 0); - env->c_env->macros = old_funs; - - return flags; + return flags; #undef push } static int c_flet(cl_env_ptr env, cl_object args, int flags) { - return c_labels_flet(env, OP_FLET, args, flags); + return c_labels_flet(env, OP_FLET, args, flags); } /* - There are two operators that produce functions. The first one - is - [OP_FUNCTION + name] - which takes the function binding of SYMBOL. The second one is - OP_CLOSE - interpreted - which encloses the INTERPRETED function in the current lexical - environment. + There are two operators that produce functions. The first one + is + [OP_FUNCTION + name] + which takes the function binding of SYMBOL. The second one is + OP_CLOSE + interpreted + which encloses the INTERPRETED function in the current lexical + environment. */ static int c_function(cl_env_ptr env, cl_object args, int flags) { - cl_object function = pop(&args); - if (!Null(args)) - FEprogram_error_noreturn("FUNCTION: Too many arguments.", 0); - return asm_function(env, function, flags); + cl_object function = pop(&args); + if (!Null(args)) + FEprogram_error_noreturn("FUNCTION: Too many arguments.", 0); + return asm_function(env, function, flags); } static int asm_function(cl_env_ptr env, cl_object function, int flags) { - if (!Null(si_valid_function_name_p(function))) { - cl_object ndx = c_tag_ref(env, function, @':function'); - if (Null(ndx)) { - /* Globally defined function */ - asm_op2c(env, OP_FUNCTION, function); - return FLAG_REG0; - } else { - /* Function from a FLET/LABELS form */ - asm_op2(env, OP_LFUNCTION, ecl_fixnum(ndx)); - return FLAG_REG0; - } - } - if (CONSP(function)) { - cl_object kind = ECL_CONS_CAR(function); - cl_object body = ECL_CONS_CDR(function); - cl_object name; - if (kind == @'lambda') { - name = ECL_NIL; - } else if (kind == @'ext::lambda-block') { - name = ECL_CONS_CAR(body); - body = ECL_CONS_CDR(body); - } else { - goto ERROR; - } - { - const cl_compiler_ptr c_env = env->c_env; - asm_op2c(env, - (Null(c_env->variables) && - Null(c_env->macros))? - OP_QUOTE : OP_CLOSE, - ecl_make_lambda(env, name, body)); - } - return FLAG_REG0; - } + if (!Null(si_valid_function_name_p(function))) { + cl_object ndx = c_tag_ref(env, function, @':function'); + if (Null(ndx)) { + /* Globally defined function */ + asm_op2c(env, OP_FUNCTION, function); + return FLAG_REG0; + } else { + /* Function from a FLET/LABELS form */ + asm_op2(env, OP_LFUNCTION, ecl_fixnum(ndx)); + return FLAG_REG0; + } + } + if (CONSP(function)) { + cl_object kind = ECL_CONS_CAR(function); + cl_object body = ECL_CONS_CDR(function); + cl_object name; + if (kind == @'lambda') { + name = ECL_NIL; + } else if (kind == @'ext::lambda-block') { + name = ECL_CONS_CAR(body); + body = ECL_CONS_CDR(body); + } else { + goto ERROR; + } + { + const cl_compiler_ptr c_env = env->c_env; + asm_op2c(env, + (Null(c_env->variables) && + Null(c_env->macros))? + OP_QUOTE : OP_CLOSE, + ecl_make_lambda(env, name, body)); + } + return FLAG_REG0; + } ERROR: - FEprogram_error_noreturn("FUNCTION: Not a valid argument ~S.", 1, function); - return FLAG_REG0; + FEprogram_error_noreturn("FUNCTION: Not a valid argument ~S.", 1, function); + return FLAG_REG0; } static int c_go(cl_env_ptr env, cl_object args, int flags) { - cl_object tag = pop(&args); - cl_object info = c_tag_ref(env, tag, @':tag'); - if (Null(info)) - FEprogram_error_noreturn("GO: Unknown tag ~S.", 1, tag); - if (!Null(args)) - FEprogram_error_noreturn("GO: Too many arguments.",0); - asm_op2(env, OP_GO, ecl_fixnum(CAR(info))); - asm_arg(env, ecl_fixnum(CDR(info))); - return flags; + cl_object tag = pop(&args); + cl_object info = c_tag_ref(env, tag, @':tag'); + if (Null(info)) + FEprogram_error_noreturn("GO: Unknown tag ~S.", 1, tag); + if (!Null(args)) + FEprogram_error_noreturn("GO: Too many arguments.",0); + asm_op2(env, OP_GO, ecl_fixnum(CAR(info))); + asm_arg(env, ecl_fixnum(CDR(info))); + return flags; } /* - (if a b) -> (cond (a b)) - (if a b c) -> (cond (a b) (t c)) + (if a b) -> (cond (a b)) + (if a b c) -> (cond (a b) (t c)) */ static int c_if(cl_env_ptr env, cl_object form, int flags) { - cl_object test = pop(&form); - cl_object then = pop(&form); - then = cl_list(2, test, then); - if (Null(form)) { - return c_cond(env, ecl_list1(then), flags); - } else { - return c_cond(env, cl_list(2, then, CONS(ECL_T, form)), flags); - } + cl_object test = pop(&form); + cl_object then = pop(&form); + then = cl_list(2, test, then); + if (Null(form)) { + return c_cond(env, ecl_list1(then), flags); + } else { + return c_cond(env, cl_list(2, then, CONS(ECL_T, form)), flags); + } } static int c_labels(cl_env_ptr env, cl_object args, int flags) { - return c_labels_flet(env, OP_LABELS, args, flags); + return c_labels_flet(env, OP_LABELS, args, flags); } /* - The OP_PUSHENV saves the current lexical environment to allow - several bindings. - OP_PUSHENV - ... ; binding forms - ... ; body - OP_EXIT + The OP_PUSHENV saves the current lexical environment to allow + several bindings. + OP_PUSHENV + ... ; binding forms + ... ; body + OP_EXIT - There are four forms which perform bindings - OP_PBIND name ; Bind NAME in the lexical env. using - ; a value from the stack - OP_PBINDS name ; Bind NAME as special variable using - ; a value from the stack - OP_BIND name ; Bind NAME in the lexical env. using - ; VALUES(0) - OP_BINDS name ; Bind NAME as special variable using - ; VALUES(0) + There are four forms which perform bindings + OP_PBIND name ; Bind NAME in the lexical env. using + ; a value from the stack + OP_PBINDS name ; Bind NAME as special variable using + ; a value from the stack + OP_BIND name ; Bind NAME in the lexical env. using + ; VALUES(0) + OP_BINDS name ; Bind NAME as special variable using + ; VALUES(0) - After a variable has been bound, there are several ways to - refer to it. + After a variable has been bound, there are several ways to + refer to it. - 1) Refer to the n-th variable in the lexical environment - [SYMVAL + n] + 1) Refer to the n-th variable in the lexical environment + [SYMVAL + n] - 2) Refer to the value of a special variable or constant - SYMVALS - name + 2) Refer to the value of a special variable or constant + SYMVALS + name - 3) Push the value of the n-th variable of the lexical environment - [PUSHV + n] + 3) Push the value of the n-th variable of the lexical environment + [PUSHV + n] - 4) Push the value of a special variable or constant - PUSHVS - name + 4) Push the value of a special variable or constant + PUSHVS + name */ static int c_let_leta(cl_env_ptr env, int op, cl_object args, int flags) { - cl_object bindings, specials, body, l, vars; - cl_object old_variables = env->c_env->variables; - - bindings = cl_car(args); - body = c_process_declarations(ECL_CONS_CDR(args)); - specials = env->values[3]; - - /* Optimize some common cases */ - if (bindings == ECL_NIL) - return c_locally(env, CDR(args), flags); - if (ECL_CONS_CDR(bindings) == ECL_NIL) - op = OP_BIND; - - for (vars=ECL_NIL, l=bindings; !Null(l); ) { - cl_object aux = pop(&l); - cl_object var, value; - if (ECL_ATOM(aux)) { - var = aux; - value = ECL_NIL; - } else { - var = pop(&aux); - value = pop_maybe_nil(&aux); - if (!Null(aux)) - FEprogram_error_noreturn("LET: Ill formed declaration.",0); - } - if (!ECL_SYMBOLP(var)) - FEillegal_variable_name(var); - if (op == OP_PBIND) { - compile_form(env, value, FLAG_PUSH); - if (ecl_member_eq(var, vars)) - FEprogram_error_noreturn - ("LET: The variable ~s occurs more than " - "once in the LET.", 1, var); - vars = CONS(var, vars); - } else { - compile_form(env, value, FLAG_REG0); - c_bind(env, var, specials); - } - } - while (!Null(vars)) - c_pbind(env, pop(&vars), specials); + cl_object bindings, specials, body, l, vars; + cl_object old_variables = env->c_env->variables; - /* We have to register all specials, because in the list - * there might be some variable that is not bound by this LET form - */ - c_declare_specials(env, specials); + bindings = cl_car(args); + body = c_process_declarations(ECL_CONS_CDR(args)); + specials = env->values[3]; + + /* Optimize some common cases */ + if (bindings == ECL_NIL) + return c_locally(env, CDR(args), flags); + if (ECL_CONS_CDR(bindings) == ECL_NIL) + op = OP_BIND; + + for (vars=ECL_NIL, l=bindings; !Null(l); ) { + cl_object aux = pop(&l); + cl_object var, value; + if (ECL_ATOM(aux)) { + var = aux; + value = ECL_NIL; + } else { + var = pop(&aux); + value = pop_maybe_nil(&aux); + if (!Null(aux)) + FEprogram_error_noreturn("LET: Ill formed declaration.",0); + } + if (!ECL_SYMBOLP(var)) + FEillegal_variable_name(var); + if (op == OP_PBIND) { + compile_form(env, value, FLAG_PUSH); + if (ecl_member_eq(var, vars)) + FEprogram_error_noreturn + ("LET: The variable ~s occurs more than " + "once in the LET.", 1, var); + vars = CONS(var, vars); + } else { + compile_form(env, value, FLAG_REG0); + c_bind(env, var, specials); + } + } + while (!Null(vars)) + c_pbind(env, pop(&vars), specials); + + /* We have to register all specials, because in the list + * there might be some variable that is not bound by this LET form + */ + c_declare_specials(env, specials); - flags = compile_body(env, body, flags); + flags = compile_body(env, body, flags); - c_undo_bindings(env, old_variables, 0); - return flags; + c_undo_bindings(env, old_variables, 0); + return flags; } static int c_let(cl_env_ptr env, cl_object args, int flags) { - return c_let_leta(env, OP_PBIND, args, flags); + return c_let_leta(env, OP_PBIND, args, flags); } static int c_leta(cl_env_ptr env, cl_object args, int flags) { - return c_let_leta(env, OP_BIND, args, flags); + return c_let_leta(env, OP_BIND, args, flags); } static int c_load_time_value(cl_env_ptr env, cl_object args, int flags) { - const cl_compiler_ptr c_env = env->c_env; - cl_object value; - unlikely_if (Null(args) || cl_cddr(args) != ECL_NIL) - FEprogram_error_noreturn("LOAD-TIME-VALUE: Wrong number of arguments.", 0); - value = ECL_CONS_CAR(args); - if (c_env->mode != FLAG_LOAD && c_env->mode != FLAG_ONLY_LOAD) { - value = si_eval_with_env(1, value); - } else if (ECL_SYMBOLP(value) || ECL_LISTP(value)) { - /* Using the form as constant, we force the system to coalesce multiple - * copies of the same load-time-value form */ - c_env->load_time_forms = - ecl_cons(cl_list(3, args, value, ECL_NIL), - c_env->load_time_forms); - value = args; - } - return compile_constant(env, value, flags); + const cl_compiler_ptr c_env = env->c_env; + cl_object value; + unlikely_if (Null(args) || cl_cddr(args) != ECL_NIL) + FEprogram_error_noreturn("LOAD-TIME-VALUE: Wrong number of arguments.", 0); + value = ECL_CONS_CAR(args); + if (c_env->mode != FLAG_LOAD && c_env->mode != FLAG_ONLY_LOAD) { + value = si_eval_with_env(1, value); + } else if (ECL_SYMBOLP(value) || ECL_LISTP(value)) { + /* Using the form as constant, we force the system to coalesce multiple + * copies of the same load-time-value form */ + c_env->load_time_forms = + ecl_cons(cl_list(3, args, value, ECL_NIL), + c_env->load_time_forms); + value = args; + } + return compile_constant(env, value, flags); } static int c_locally(cl_env_ptr env, cl_object args, int flags) { - cl_object old_env = env->c_env->variables; + cl_object old_env = env->c_env->variables; - /* First use declarations by declaring special variables... */ - args = c_process_declarations(args); - c_declare_specials(env, env->values[3]); + /* First use declarations by declaring special variables... */ + args = c_process_declarations(args); + c_declare_specials(env, env->values[3]); - /* ...and then process body */ - flags = compile_toplevel_body(env, args, flags); + /* ...and then process body */ + flags = compile_toplevel_body(env, args, flags); - c_undo_bindings(env, old_env, 0); + c_undo_bindings(env, old_env, 0); - return flags; + return flags; } /* - MACROLET + MACROLET - The current lexical environment is saved. A new one is prepared with - the definitions of these macros, and this environment is used to - compile the body. - */ + The current lexical environment is saved. A new one is prepared with + the definitions of these macros, and this environment is used to + compile the body. +*/ static int c_macrolet(cl_env_ptr the_env, cl_object args, int flags) { - const cl_compiler_ptr c_env = the_env->c_env; - cl_object old_env = c_env->macros; - cl_object env = funcall(3, @'si::cmp-env-register-macrolet', pop(&args), - CONS(c_env->variables, c_env->macros)); - c_env->macros = CDR(env); - flags = c_locally(the_env, args, flags); - c_env->macros = old_env; - return flags; + const cl_compiler_ptr c_env = the_env->c_env; + cl_object old_env = c_env->macros; + cl_object env = funcall(3, @'si::cmp-env-register-macrolet', pop(&args), + CONS(c_env->variables, c_env->macros)); + c_env->macros = CDR(env); + flags = c_locally(the_env, args, flags); + c_env->macros = old_env; + return flags; } static void c_vbind(cl_env_ptr env, cl_object var, int n, cl_object specials) { - if (c_declared_special(var, specials)) { - c_register_var(env, var, FLAG_PUSH, TRUE); - if (n) { - asm_op2(env, OP_VBINDS, n); - } else { - asm_op(env, OP_BINDS); - } - } else { - c_register_var(env, var, FALSE, TRUE); - if (n) { - asm_op2(env, OP_VBIND, n); - } else { - asm_op(env, OP_BIND); - } - } - asm_c(env, var); + if (c_declared_special(var, specials)) { + c_register_var(env, var, FLAG_PUSH, TRUE); + if (n) { + asm_op2(env, OP_VBINDS, n); + } else { + asm_op(env, OP_BINDS); + } + } else { + c_register_var(env, var, FALSE, TRUE); + if (n) { + asm_op2(env, OP_VBIND, n); + } else { + asm_op(env, OP_BIND); + } + } + asm_c(env, var); } static int c_multiple_value_bind(cl_env_ptr env, cl_object args, int flags) { - cl_object vars = pop(&args); - int n = ecl_length(vars); - switch (n) { - case 0: - return c_locally(env, args, flags); - case 1: - vars = ECL_CONS_CAR(vars); - vars = ecl_list1(cl_list(2, vars, pop(&args))); - return c_leta(env, cl_listX(2, vars, args), flags); - default: { - cl_object value = pop(&args); - cl_object old_variables = env->c_env->variables; - cl_object body = c_process_declarations(args); - cl_object specials = env->values[3]; - compile_form(env, value, FLAG_VALUES); - for (vars=cl_reverse(vars); n--; ) { - cl_object var = pop(&vars); - if (!ECL_SYMBOLP(var)) - FEillegal_variable_name(var); - c_vbind(env, var, n, specials); - } - c_declare_specials(env, specials); - flags = compile_body(env, body, flags); - c_undo_bindings(env, old_variables, 0); - return flags; - }} + cl_object vars = pop(&args); + int n = ecl_length(vars); + switch (n) { + case 0: + return c_locally(env, args, flags); + case 1: + vars = ECL_CONS_CAR(vars); + vars = ecl_list1(cl_list(2, vars, pop(&args))); + return c_leta(env, cl_listX(2, vars, args), flags); + default: { + cl_object value = pop(&args); + cl_object old_variables = env->c_env->variables; + cl_object body = c_process_declarations(args); + cl_object specials = env->values[3]; + compile_form(env, value, FLAG_VALUES); + for (vars=cl_reverse(vars); n--; ) { + cl_object var = pop(&vars); + if (!ECL_SYMBOLP(var)) + FEillegal_variable_name(var); + c_vbind(env, var, n, specials); + } + c_declare_specials(env, specials); + flags = compile_body(env, body, flags); + c_undo_bindings(env, old_variables, 0); + return flags; + }} } static int c_multiple_value_call(cl_env_ptr env, cl_object args, int flags) { - cl_object name; - int op; + cl_object name; + int op; - name = pop(&args); - if (Null(args)) { - /* If no arguments, just use ordinary call */ - return c_funcall(env, cl_list(1, name), flags); - } - compile_form(env, name, FLAG_PUSH); - for (op = OP_PUSHVALUES; !Null(args); op = OP_PUSHMOREVALUES) { - compile_form(env, pop(&args), FLAG_VALUES); - asm_op(env, op); - } - asm_op(env, OP_MCALL); - asm_op(env, OP_POP1); + name = pop(&args); + if (Null(args)) { + /* If no arguments, just use ordinary call */ + return c_funcall(env, cl_list(1, name), flags); + } + compile_form(env, name, FLAG_PUSH); + for (op = OP_PUSHVALUES; !Null(args); op = OP_PUSHMOREVALUES) { + compile_form(env, pop(&args), FLAG_VALUES); + asm_op(env, op); + } + asm_op(env, OP_MCALL); + asm_op(env, OP_POP1); - return FLAG_VALUES; + return FLAG_VALUES; } static int c_multiple_value_prog1(cl_env_ptr env, cl_object args, int flags) { - compile_form(env, pop(&args), FLAG_VALUES); - if (!Null(args)) { - asm_op(env, OP_PUSHVALUES); - compile_body(env, args, FLAG_IGNORE); - asm_op(env, OP_POPVALUES); - } - return FLAG_VALUES; + compile_form(env, pop(&args), FLAG_VALUES); + if (!Null(args)) { + asm_op(env, OP_PUSHVALUES); + compile_body(env, args, FLAG_IGNORE); + asm_op(env, OP_POPVALUES); + } + return FLAG_VALUES; } static int c_multiple_value_setq(cl_env_ptr env, cl_object orig_args, int flags) { - cl_object args = orig_args; - cl_object orig_vars; - cl_object vars = ECL_NIL, values; - cl_object old_variables = env->c_env->variables; - cl_index nvars = 0; - - /* Look for symbol macros, building the list of variables - and the list of late assignments. */ - for (orig_vars = pop(&args); !Null(orig_vars); ) { - cl_object v = pop(&orig_vars); - if (!ECL_SYMBOLP(v)) - FEillegal_variable_name(v); - v = c_macro_expand1(env, v); - if (!ECL_SYMBOLP(v)) { - /* If any of the places to be set is not a variable, - * transform MULTIPLE-VALUE-SETQ into (SETF (VALUES ...)) - */ - args = orig_args; - return compile_form(env, cl_listX(3, @'setf', - CONS(@'values', CAR(args)), - CDR(args)), - flags); - } - vars = CONS(v, vars); - nvars++; - } - - /* Compile values */ - values = pop(&args); - if (args != ECL_NIL) - FEprogram_error_noreturn("MULTIPLE-VALUE-SETQ: Too many arguments.", 0); - if (nvars == 0) { - /* No variables */ - return compile_form(env, cl_list(2, @'values', values), flags); - } - compile_form(env, values, FLAG_VALUES); - - /* Compile variables */ - for (nvars = 0, vars = cl_nreverse(vars); vars != ECL_NIL; nvars++, vars = ECL_CONS_CDR(vars)) { - if (nvars) { - compile_setq(env, OP_VSETQ, ECL_CONS_CAR(vars)); - asm_arg(env, nvars); - } else { - compile_setq(env, OP_SETQ, ECL_CONS_CAR(vars)); - } - } + cl_object args = orig_args; + cl_object orig_vars; + cl_object vars = ECL_NIL, values; + cl_object old_variables = env->c_env->variables; + cl_index nvars = 0; + + /* Look for symbol macros, building the list of variables + and the list of late assignments. */ + for (orig_vars = pop(&args); !Null(orig_vars); ) { + cl_object v = pop(&orig_vars); + if (!ECL_SYMBOLP(v)) + FEillegal_variable_name(v); + v = c_macro_expand1(env, v); + if (!ECL_SYMBOLP(v)) { + /* If any of the places to be set is not a variable, + * transform MULTIPLE-VALUE-SETQ into (SETF (VALUES ...)) + */ + args = orig_args; + return compile_form(env, cl_listX(3, @'setf', + CONS(@'values', CAR(args)), + CDR(args)), + flags); + } + vars = CONS(v, vars); + nvars++; + } + + /* Compile values */ + values = pop(&args); + if (args != ECL_NIL) + FEprogram_error_noreturn("MULTIPLE-VALUE-SETQ: Too many arguments.", 0); + if (nvars == 0) { + /* No variables */ + return compile_form(env, cl_list(2, @'values', values), flags); + } + compile_form(env, values, FLAG_VALUES); + + /* Compile variables */ + for (nvars = 0, vars = cl_nreverse(vars); vars != ECL_NIL; nvars++, vars = ECL_CONS_CDR(vars)) { + if (nvars) { + compile_setq(env, OP_VSETQ, ECL_CONS_CAR(vars)); + asm_arg(env, nvars); + } else { + compile_setq(env, OP_SETQ, ECL_CONS_CAR(vars)); + } + } - c_undo_bindings(env, old_variables, 0); + c_undo_bindings(env, old_variables, 0); - return FLAG_REG0; + return FLAG_REG0; } /* - The OP_NOT operator reverses the boolean value of VALUES(0). + The OP_NOT operator reverses the boolean value of VALUES(0). */ static int c_not(cl_env_ptr env, cl_object args, int flags) { - flags = maybe_reg0(flags); - if (flags & FLAG_USEFUL) { - /* The value is useful */ - compile_form(env, pop(&args), FLAG_REG0); - asm_op(env, OP_NOT); - } else { - /* The value may be ignored. */ - flags = compile_form(env, pop(&args), flags); - } - if (!Null(args)) - FEprogram_error_noreturn("NOT/NULL: Too many arguments.", 0); - return flags; + flags = maybe_reg0(flags); + if (flags & FLAG_USEFUL) { + /* The value is useful */ + compile_form(env, pop(&args), FLAG_REG0); + asm_op(env, OP_NOT); + } else { + /* The value may be ignored. */ + flags = compile_form(env, pop(&args), flags); + } + if (!Null(args)) + FEprogram_error_noreturn("NOT/NULL: Too many arguments.", 0); + return flags; } /* - The OP_NTHVAL operator moves a value from VALUES(ndx) to - VALUES(0). The index NDX is taken from the stack. + The OP_NTHVAL operator moves a value from VALUES(ndx) to + VALUES(0). The index NDX is taken from the stack. - OP_NTHVAL + OP_NTHVAL */ static int c_nth_value(cl_env_ptr env, cl_object args, int flags) { - compile_form(env, pop(&args), FLAG_PUSH); /* INDEX */ - compile_form(env, pop(&args), FLAG_VALUES); /* VALUES */ - if (args != ECL_NIL) - FEprogram_error_noreturn("NTH-VALUE: Too many arguments.",0); - asm_op(env, OP_NTHVAL); - return FLAG_REG0; + compile_form(env, pop(&args), FLAG_PUSH); /* INDEX */ + compile_form(env, pop(&args), FLAG_VALUES); /* VALUES */ + if (args != ECL_NIL) + FEprogram_error_noreturn("NTH-VALUE: Too many arguments.",0); + asm_op(env, OP_NTHVAL); + return FLAG_REG0; } static int c_prog1(cl_env_ptr env, cl_object args, int flags) { - cl_object form = pop(&args); - if (!(flags & FLAG_USEFUL) || (flags & FLAG_PUSH)) { - flags = compile_form(env, form, flags); - compile_body(env, args, FLAG_IGNORE); - } else { - flags = FLAG_REG0; - compile_form(env, form, FLAG_PUSH); - compile_body(env, args, FLAG_IGNORE); - asm_op(env, OP_POP); - } - return flags; + cl_object form = pop(&args); + if (!(flags & FLAG_USEFUL) || (flags & FLAG_PUSH)) { + flags = compile_form(env, form, flags); + compile_body(env, args, FLAG_IGNORE); + } else { + flags = FLAG_REG0; + compile_form(env, form, FLAG_PUSH); + compile_body(env, args, FLAG_IGNORE); + asm_op(env, OP_POP); + } + return flags; } /* - The OP_PROGV operator exectures a set of statements in a lexical - environment that has been extended with special variables. The - list of special variables is taken from the top of the stack, - while the list of values is in VALUES(0). - - ... ; list of variables - OP_PUSH - ... ; list of values - OP_PROGV - ... ; body of progv - OP_EXIT + The OP_PROGV operator exectures a set of statements in a lexical + environment that has been extended with special variables. The + list of special variables is taken from the top of the stack, + while the list of values is in VALUES(0). + + ... ; list of variables + OP_PUSH + ... ; list of values + OP_PROGV + ... ; body of progv + OP_EXIT */ static int c_progv(cl_env_ptr env, cl_object args, int flags) { - cl_object vars = pop(&args); - cl_object values = pop(&args); + cl_object vars = pop(&args); + cl_object values = pop(&args); - /* The list of variables is in the stack */ - compile_form(env, vars, FLAG_PUSH); + /* The list of variables is in the stack */ + compile_form(env, vars, FLAG_PUSH); - /* The list of values is in reg0 */ - compile_form(env, values, FLAG_REG0); + /* The list of values is in reg0 */ + compile_form(env, values, FLAG_REG0); - /* The body is interpreted within an extended lexical - environment. However, as all the new variables are - special, the compiler need not take care of them - */ - asm_op(env, OP_PROGV); - flags = compile_body(env, args, FLAG_VALUES); - asm_op(env, OP_EXIT_PROGV); + /* The body is interpreted within an extended lexical + environment. However, as all the new variables are + special, the compiler need not take care of them + */ + asm_op(env, OP_PROGV); + flags = compile_body(env, args, FLAG_VALUES); + asm_op(env, OP_EXIT_PROGV); - return flags; + return flags; } /* - There are four assignment operators. They are + There are four assignment operators. They are - 1) Assign VALUES(0) to the lexical variable which occupies the - N-th position - [OP_SETQ + n] + 1) Assign VALUES(0) to the lexical variable which occupies the + N-th position + [OP_SETQ + n] - 2) Assign VALUES(0) to the special variable NAME - [OP_SETQS + name] + 2) Assign VALUES(0) to the special variable NAME + [OP_SETQS + name] - 3) Pop a value from the stack and assign it to the lexical - variable in the N-th position. - [OP_PSETQ + n] + 3) Pop a value from the stack and assign it to the lexical + variable in the N-th position. + [OP_PSETQ + n] - 4) Pop a value from the stack and assign it to the special - variable denoted by NAME - [OP_PSETQS + name] + 4) Pop a value from the stack and assign it to the special + variable denoted by NAME + [OP_PSETQS + name] */ static int c_psetq(cl_env_ptr env, cl_object old_args, int flags) { - cl_object args = ECL_NIL, vars = ECL_NIL; - bool use_psetf = FALSE; - cl_index nvars = 0; - - if (Null(old_args)) - return compile_body(env, ECL_NIL, flags); - /* We have to make sure that non of the variables which - are to be assigned is actually a symbol macro. If that - is the case, we invoke (PSETF ...) to handle the - macro expansions. - */ - do { - cl_object var = pop(&old_args); - cl_object value = pop(&old_args); - if (!ECL_SYMBOLP(var)) - FEillegal_variable_name(var); - var = c_macro_expand1(env, var); - if (!ECL_SYMBOLP(var)) - use_psetf = TRUE; - args = ecl_nconc(args, cl_list(2, var, value)); - nvars++; - } while (!Null(old_args)); - if (use_psetf) { - return compile_form(env, CONS(@'psetf', args), flags); - } - do { - cl_object var = pop(&args); - cl_object value = pop(&args); - vars = CONS(var, vars); - compile_form(env, value, FLAG_PUSH); - } while (!Null(args)); - do { - compile_setq(env, OP_PSETQ, pop(&vars)); - } while (!Null(vars)); - return compile_form(env, ECL_NIL, flags); + cl_object args = ECL_NIL, vars = ECL_NIL; + bool use_psetf = FALSE; + cl_index nvars = 0; + + if (Null(old_args)) + return compile_body(env, ECL_NIL, flags); + /* We have to make sure that non of the variables which + are to be assigned is actually a symbol macro. If that + is the case, we invoke (PSETF ...) to handle the + macro expansions. + */ + do { + cl_object var = pop(&old_args); + cl_object value = pop(&old_args); + if (!ECL_SYMBOLP(var)) + FEillegal_variable_name(var); + var = c_macro_expand1(env, var); + if (!ECL_SYMBOLP(var)) + use_psetf = TRUE; + args = ecl_nconc(args, cl_list(2, var, value)); + nvars++; + } while (!Null(old_args)); + if (use_psetf) { + return compile_form(env, CONS(@'psetf', args), flags); + } + do { + cl_object var = pop(&args); + cl_object value = pop(&args); + vars = CONS(var, vars); + compile_form(env, value, FLAG_PUSH); + } while (!Null(args)); + do { + compile_setq(env, OP_PSETQ, pop(&vars)); + } while (!Null(vars)); + return compile_form(env, ECL_NIL, flags); } /* - The OP_RETFROM operator returns from a block using the objects - in VALUES() as output values. - - ... ; output form - OP_RETFROM - tag ; object which names the block + The OP_RETFROM operator returns from a block using the objects + in VALUES() as output values. + + ... ; output form + OP_RETFROM + tag ; object which names the block */ static int c_return_aux(cl_env_ptr env, cl_object name, cl_object stmt, int flags) { - cl_object ndx = c_tag_ref(env, name, @':block'); - cl_object output = pop_maybe_nil(&stmt); + cl_object ndx = c_tag_ref(env, name, @':block'); + cl_object output = pop_maybe_nil(&stmt); - if (!ECL_SYMBOLP(name) || Null(ndx)) - FEprogram_error_noreturn("RETURN-FROM: Unknown block name ~S.", 1, name); - if (stmt != ECL_NIL) - FEprogram_error_noreturn("RETURN-FROM: Too many arguments.", 0); - compile_form(env, output, FLAG_VALUES); - asm_op2(env, OP_RETURN, ecl_fixnum(ndx)); - return FLAG_VALUES; + if (!ECL_SYMBOLP(name) || Null(ndx)) + FEprogram_error_noreturn("RETURN-FROM: Unknown block name ~S.", 1, name); + if (stmt != ECL_NIL) + FEprogram_error_noreturn("RETURN-FROM: Too many arguments.", 0); + compile_form(env, output, FLAG_VALUES); + asm_op2(env, OP_RETURN, ecl_fixnum(ndx)); + return FLAG_VALUES; } static int c_return(cl_env_ptr env, cl_object stmt, int flags) { - return c_return_aux(env, ECL_NIL, stmt, flags); + return c_return_aux(env, ECL_NIL, stmt, flags); } static int c_return_from(cl_env_ptr env, cl_object stmt, int flags) { - cl_object name = pop(&stmt); - return c_return_aux(env, name, stmt, flags); + cl_object name = pop(&stmt); + return c_return_aux(env, name, stmt, flags); } static int c_setq(cl_env_ptr env, cl_object args, int flags) { - if (Null(args)) - return compile_form(env, ECL_NIL, flags); - do { - cl_object var = pop(&args); - cl_object value = pop(&args); - if (!ECL_SYMBOLP(var)) - FEillegal_variable_name(var); - var = c_macro_expand1(env, var); - if (ECL_SYMBOLP(var)) { - flags = FLAG_REG0; - compile_form(env, value, FLAG_REG0); - compile_setq(env, OP_SETQ, var); - } else { - flags = ecl_endp(args)? FLAG_VALUES : FLAG_REG0; - compile_form(env, cl_list(3, @'setf', var, value), flags); - } - } while (!Null(args)); - return flags; + if (Null(args)) + return compile_form(env, ECL_NIL, flags); + do { + cl_object var = pop(&args); + cl_object value = pop(&args); + if (!ECL_SYMBOLP(var)) + FEillegal_variable_name(var); + var = c_macro_expand1(env, var); + if (ECL_SYMBOLP(var)) { + flags = FLAG_REG0; + compile_form(env, value, FLAG_REG0); + compile_setq(env, OP_SETQ, var); + } else { + flags = ecl_endp(args)? FLAG_VALUES : FLAG_REG0; + compile_form(env, cl_list(3, @'setf', var, value), flags); + } + } while (!Null(args)); + return flags; } static int c_symbol_macrolet(cl_env_ptr env, cl_object args, int flags) { - cl_object def_list, specials, body; - cl_object old_variables = env->c_env->variables; + cl_object def_list, specials, body; + cl_object old_variables = env->c_env->variables; - def_list = pop(&args); - body = c_process_declarations(args); - specials = env->values[3]; - - /* Scan the list of definitions */ - while (!Null(def_list)) { - cl_object definition = pop(&def_list); - cl_object name = pop(&definition); - cl_object expansion = pop(&definition); - cl_object arglist = cl_list(2, @gensym(0), @gensym(0)); - cl_object function; - if ((ecl_symbol_type(name) & (ecl_stp_constant|ecl_stp_special)) || - ecl_member_eq(name, specials)) - { - FEprogram_error_noreturn("SYMBOL-MACROLET: Symbol ~A cannot be \ + def_list = pop(&args); + body = c_process_declarations(args); + specials = env->values[3]; + + /* Scan the list of definitions */ + while (!Null(def_list)) { + cl_object definition = pop(&def_list); + cl_object name = pop(&definition); + cl_object expansion = pop(&definition); + cl_object arglist = cl_list(2, @gensym(0), @gensym(0)); + cl_object function; + if ((ecl_symbol_type(name) & (ecl_stp_constant|ecl_stp_special)) || + ecl_member_eq(name, specials)) + { + FEprogram_error_noreturn("SYMBOL-MACROLET: Symbol ~A cannot be \ declared special and appear in a symbol-macrolet.", 1, name); - } - definition = cl_list(2, arglist, cl_list(2, @'quote', expansion)); - function = ecl_make_lambda(env, name, definition); - c_register_symbol_macro(env, name, function); - } - c_declare_specials(env, specials); - flags = compile_toplevel_body(env, body, flags); - c_undo_bindings(env, old_variables, 0); - return flags; + } + definition = cl_list(2, arglist, cl_list(2, @'quote', expansion)); + function = ecl_make_lambda(env, name, definition); + c_register_symbol_macro(env, name, function); + } + c_declare_specials(env, specials); + flags = compile_toplevel_body(env, body, flags); + c_undo_bindings(env, old_variables, 0); + return flags; } static int c_tagbody(cl_env_ptr env, cl_object args, int flags) { - cl_object old_env = env->c_env->variables; - cl_index tag_base; - cl_object labels = ECL_NIL, label, body; - cl_type item_type; - int nt, i; - - /* count the tags */ - for (nt = 0, body = args; !Null(body); ) { - label = pop(&body); - item_type = ecl_t_of(label); - if (item_type == t_symbol || item_type == t_fixnum || - item_type == t_bignum) { - labels = CONS(CONS(label,ecl_make_fixnum(nt)), labels); - nt += 1; - } - } - if (nt == 0) { - compile_body(env, args, 0); - return compile_form(env, ECL_NIL, flags); - } - asm_op2c(env, OP_BLOCK, ecl_make_fixnum(0)); - c_register_tags(env, labels); - asm_op2(env, OP_TAGBODY, nt); - tag_base = current_pc(env); - for (i = nt; i; i--) - asm_arg(env, 0); - - for (body = args; !Null(body); ) { - label = pop(&body); - item_type = ecl_t_of(label); - if (item_type == t_symbol || item_type == t_fixnum || - item_type == t_bignum) { - asm_complete(env, 0, tag_base); - tag_base += OPARG_SIZE; - } else { - compile_form(env, label, FLAG_IGNORE); - } - } - asm_op(env, OP_EXIT_TAGBODY); - c_undo_bindings(env, old_env, 0); - return FLAG_REG0; + cl_object old_env = env->c_env->variables; + cl_index tag_base; + cl_object labels = ECL_NIL, label, body; + cl_type item_type; + int nt, i; + + /* count the tags */ + for (nt = 0, body = args; !Null(body); ) { + label = pop(&body); + item_type = ecl_t_of(label); + if (item_type == t_symbol || item_type == t_fixnum || + item_type == t_bignum) { + labels = CONS(CONS(label,ecl_make_fixnum(nt)), labels); + nt += 1; + } + } + if (nt == 0) { + compile_body(env, args, 0); + return compile_form(env, ECL_NIL, flags); + } + asm_op2c(env, OP_BLOCK, ecl_make_fixnum(0)); + c_register_tags(env, labels); + asm_op2(env, OP_TAGBODY, nt); + tag_base = current_pc(env); + for (i = nt; i; i--) + asm_arg(env, 0); + + for (body = args; !Null(body); ) { + label = pop(&body); + item_type = ecl_t_of(label); + if (item_type == t_symbol || item_type == t_fixnum || + item_type == t_bignum) { + asm_complete(env, 0, tag_base); + tag_base += OPARG_SIZE; + } else { + compile_form(env, label, FLAG_IGNORE); + } + } + asm_op(env, OP_EXIT_TAGBODY); + c_undo_bindings(env, old_env, 0); + return FLAG_REG0; } static int c_the(cl_env_ptr env, cl_object stmt, int flags) { - cl_object type = pop(&stmt); - cl_object value = pop(&stmt); - if (stmt != ECL_NIL) { - FEprogram_error_noreturn("THE: Too many arguments",0); - } - return compile_form(env, value, flags); + cl_object type = pop(&stmt); + cl_object value = pop(&stmt); + if (stmt != ECL_NIL) { + FEprogram_error_noreturn("THE: Too many arguments",0); + } + return compile_form(env, value, flags); } /* - The OP_THROW jumps to an enclosing OP_CATCH whose tag - matches the one of the throw. The tag is taken from the - stack, while the output values are left in VALUES(). + The OP_THROW jumps to an enclosing OP_CATCH whose tag + matches the one of the throw. The tag is taken from the + stack, while the output values are left in VALUES(). */ static int c_throw(cl_env_ptr env, cl_object stmt, int flags) { - cl_object tag = pop(&stmt); - cl_object form = pop(&stmt); - if (stmt != ECL_NIL) - FEprogram_error_noreturn("THROW: Too many arguments.",0); - compile_form(env, tag, FLAG_PUSH); - compile_form(env, form, FLAG_VALUES); - asm_op(env, OP_THROW); - return flags; + cl_object tag = pop(&stmt); + cl_object form = pop(&stmt); + if (stmt != ECL_NIL) + FEprogram_error_noreturn("THROW: Too many arguments.",0); + compile_form(env, tag, FLAG_PUSH); + compile_form(env, form, FLAG_VALUES); + asm_op(env, OP_THROW); + return flags; } static int c_unwind_protect(cl_env_ptr env, cl_object args, int flags) { - cl_index label = asm_jmp(env, OP_PROTECT); + cl_index label = asm_jmp(env, OP_PROTECT); - flags = maybe_values(flags); + flags = maybe_values(flags); - /* Compile form to be protected */ - flags = compile_form(env, pop(&args), flags); - asm_op(env, OP_PROTECT_NORMAL); + /* Compile form to be protected */ + flags = compile_form(env, pop(&args), flags); + asm_op(env, OP_PROTECT_NORMAL); - /* Compile exit clause */ - asm_complete(env, OP_PROTECT, label); - compile_body(env, args, FLAG_IGNORE); - asm_op(env, OP_PROTECT_EXIT); + /* Compile exit clause */ + asm_complete(env, OP_PROTECT, label); + compile_body(env, args, FLAG_IGNORE); + asm_op(env, OP_PROTECT_EXIT); - return flags; + return flags; } /* - The OP_VALUES moves N values from the stack to VALUES(). + The OP_VALUES moves N values from the stack to VALUES(). - [OP_VALUES + n] + [OP_VALUES + n] */ static int c_values(cl_env_ptr env, cl_object args, int flags) { - if (!(flags & FLAG_USEFUL)) { - /* This value will be discarded. We do not care to - push it or to save it in VALUES */ - if (Null(args)) - return flags; - return compile_body(env, args, flags); - } else if (flags & FLAG_PUSH) { - /* We only need the first value. However, the rest - of arguments HAVE to be be evaluated */ - if (Null(args)) - return compile_form(env, ECL_NIL, flags); - flags = compile_form(env, pop(&args), FLAG_PUSH); - compile_body(env, args, FLAG_IGNORE); - return flags; - } else if (Null(args)) { - asm_op(env, OP_NOP); - } else { - int n = 0; - while (!Null(args)) { - compile_form(env, pop_maybe_nil(&args), FLAG_PUSH); - n++; - } - asm_op2(env, OP_VALUES, n); - } - return FLAG_VALUES; + if (!(flags & FLAG_USEFUL)) { + /* This value will be discarded. We do not care to + push it or to save it in VALUES */ + if (Null(args)) + return flags; + return compile_body(env, args, flags); + } else if (flags & FLAG_PUSH) { + /* We only need the first value. However, the rest + of arguments HAVE to be be evaluated */ + if (Null(args)) + return compile_form(env, ECL_NIL, flags); + flags = compile_form(env, pop(&args), FLAG_PUSH); + compile_body(env, args, FLAG_IGNORE); + return flags; + } else if (Null(args)) { + asm_op(env, OP_NOP); + } else { + int n = 0; + while (!Null(args)) { + compile_form(env, pop_maybe_nil(&args), FLAG_PUSH); + n++; + } + asm_op2(env, OP_VALUES, n); + } + return FLAG_VALUES; } static int need_to_make_load_form_p(cl_object o) { - switch (ecl_t_of(o)) { - case t_character: - case t_fixnum: - case t_bignum: - case t_ratio: - case t_singlefloat: - case t_doublefloat: + switch (ecl_t_of(o)) { + case t_character: + case t_fixnum: + case t_bignum: + case t_ratio: + case t_singlefloat: + case t_doublefloat: #ifdef ECL_LONG_FLOAT - case t_longfloat: + case t_longfloat: #endif - case t_complex: - case t_symbol: - case t_pathname: + case t_complex: + case t_symbol: + case t_pathname: #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - case t_bitvector: - return 0; - case t_list: - if (Null(o)) return 0; - default: - return _ecl_funcall3(@'clos::need-to-make-load-form-p', o, ECL_NIL) - != ECL_NIL; - } + case t_base_string: + case t_bitvector: + return 0; + case t_list: + if (Null(o)) return 0; + default: + return _ecl_funcall3(@'clos::need-to-make-load-form-p', o, ECL_NIL) + != ECL_NIL; + } } static void maybe_make_load_forms(cl_env_ptr env, cl_object constant) { - const cl_compiler_ptr c_env = env->c_env; - cl_object init, make; - if (c_env->mode != FLAG_LOAD && c_env->mode != FLAG_ONLY_LOAD) - return; - if (c_search_constant(env, constant) >= 0) - return; - if (!need_to_make_load_form_p(constant)) - return; - make = _ecl_funcall2(@'make-load-form', constant); - init = (env->nvalues > 1)? env->values[1] : ECL_NIL; - c_env->load_time_forms = ecl_cons(cl_list(3, constant, make, init), - c_env->load_time_forms); + const cl_compiler_ptr c_env = env->c_env; + cl_object init, make; + if (c_env->mode != FLAG_LOAD && c_env->mode != FLAG_ONLY_LOAD) + return; + if (c_search_constant(env, constant) >= 0) + return; + if (!need_to_make_load_form_p(constant)) + return; + make = _ecl_funcall2(@'make-load-form', constant); + init = (env->nvalues > 1)? env->values[1] : ECL_NIL; + c_env->load_time_forms = ecl_cons(cl_list(3, constant, make, init), + c_env->load_time_forms); } static int compile_constant(cl_env_ptr env, cl_object stmt, int flags) { - if (flags & FLAG_USEFUL) { - bool push = flags & FLAG_PUSH; - cl_fixnum n; - maybe_make_load_forms(env, stmt); - if (stmt == ECL_NIL) { - asm_op(env, push? OP_PUSHNIL : OP_NIL); - } else if (ECL_FIXNUMP(stmt) && (n = ecl_fixnum(stmt)) <= MAX_OPARG - && n >= -MAX_OPARG) { - asm_op2(env, push? OP_PINT : OP_INT, n); - } else { - asm_op2c(env, push? OP_PUSHQ : OP_QUOTE, stmt); - } - if (flags & FLAG_VALUES) - flags = (flags & ~FLAG_VALUES) | FLAG_REG0; - } - return flags; + if (flags & FLAG_USEFUL) { + bool push = flags & FLAG_PUSH; + cl_fixnum n; + maybe_make_load_forms(env, stmt); + if (stmt == ECL_NIL) { + asm_op(env, push? OP_PUSHNIL : OP_NIL); + } else if (ECL_FIXNUMP(stmt) && (n = ecl_fixnum(stmt)) <= MAX_OPARG + && n >= -MAX_OPARG) { + asm_op2(env, push? OP_PINT : OP_INT, n); + } else { + asm_op2c(env, push? OP_PUSHQ : OP_QUOTE, stmt); + } + if (flags & FLAG_VALUES) + flags = (flags & ~FLAG_VALUES) | FLAG_REG0; + } + return flags; } static int c_quote(cl_env_ptr env, cl_object args, int flags) { - if (ECL_ATOM(args) || ECL_CONS_CDR(args) != ECL_NIL) - FEill_formed_input(); - return compile_constant(env, ECL_CONS_CAR(args), flags); + if (ECL_ATOM(args) || ECL_CONS_CDR(args) != ECL_NIL) + FEill_formed_input(); + return compile_constant(env, ECL_CONS_CAR(args), flags); } static int compile_symbol(cl_env_ptr env, cl_object stmt, int flags) { - cl_object stmt1 = c_macro_expand1(env, stmt); - if (stmt1 != stmt) { - return compile_form(env, stmt1, flags); - } else { - cl_fixnum index = c_var_ref(env, stmt,0,FALSE); - bool push = flags & FLAG_PUSH; - if (index >= 0) { - asm_op2(env, push? OP_PUSHV : OP_VAR, index); - } else { - asm_op2c(env, push? OP_PUSHVS : OP_VARS, stmt); - } - if (flags & FLAG_VALUES) - return (flags & ~FLAG_VALUES) | FLAG_REG0; - else - return flags; - } + cl_object stmt1 = c_macro_expand1(env, stmt); + if (stmt1 != stmt) { + return compile_form(env, stmt1, flags); + } else { + cl_fixnum index = c_var_ref(env, stmt,0,FALSE); + bool push = flags & FLAG_PUSH; + if (index >= 0) { + asm_op2(env, push? OP_PUSHV : OP_VAR, index); + } else { + asm_op2c(env, push? OP_PUSHVS : OP_VARS, stmt); + } + if (flags & FLAG_VALUES) + return (flags & ~FLAG_VALUES) | FLAG_REG0; + else + return flags; + } } static int compile_form(cl_env_ptr env, cl_object stmt, int flags) { - const cl_compiler_ptr c_env = env->c_env; - cl_object function; - int new_flags; + const cl_compiler_ptr c_env = env->c_env; + cl_object function; + int new_flags; - ecl_bds_bind(env, @'si::*current-form*', stmt); + ecl_bds_bind(env, @'si::*current-form*', stmt); BEGIN: - if (c_env->code_walker != OBJNULL) { - stmt = funcall(3, c_env->code_walker, stmt, - CONS(c_env->variables, c_env->macros)); - } - /* - * First try with variable references and quoted constants - */ - if (Null(stmt)) { - new_flags = compile_constant(env, stmt, flags); - goto OUTPUT; - } - if (!ECL_LISTP(stmt)) { - if (ECL_SYMBOLP(stmt)) { - new_flags = compile_symbol(env, stmt, flags); - } else { - new_flags = compile_constant(env, stmt, flags); - } - goto OUTPUT; - } - /* - * Next try with special forms. - */ - function = ECL_CONS_CAR(stmt); - if (ECL_SYMBOLP(function)) { - cl_object index = ecl_gethash(function, cl_core.compiler_dispatch); - if (index != OBJNULL) { - compiler_record *l = database + ecl_fixnum(index); - c_env->lexical_level += l->lexical_increment; - if (c_env->stepping && function != @'function' && - c_env->lexical_level) - asm_op2c(env, OP_STEPIN, stmt); - new_flags = (*(l->compiler))(env, ECL_CONS_CDR(stmt), flags); - if (c_env->stepping && function != @'function' && - c_env->lexical_level) - asm_op(env, OP_STEPOUT); - c_env->lexical_level -= l->lexical_increment; - goto OUTPUT; - } - /* - * Next try to macroexpand - */ - { - cl_object new_stmt = c_macro_expand1(env, stmt); - if (new_stmt != stmt){ - stmt = new_stmt; - goto BEGIN; - } - } - } - /* - * Finally resort to ordinary function calls. - */ - if (c_env->stepping) - asm_op2c(env, OP_STEPIN, stmt); - c_env->lexical_level++; - new_flags = c_call(env, stmt, flags); - c_env->lexical_level--; + if (c_env->code_walker != OBJNULL) { + stmt = funcall(3, c_env->code_walker, stmt, + CONS(c_env->variables, c_env->macros)); + } + /* + * First try with variable references and quoted constants + */ + if (Null(stmt)) { + new_flags = compile_constant(env, stmt, flags); + goto OUTPUT; + } + if (!ECL_LISTP(stmt)) { + if (ECL_SYMBOLP(stmt)) { + new_flags = compile_symbol(env, stmt, flags); + } else { + new_flags = compile_constant(env, stmt, flags); + } + goto OUTPUT; + } + /* + * Next try with special forms. + */ + function = ECL_CONS_CAR(stmt); + if (ECL_SYMBOLP(function)) { + cl_object index = ecl_gethash(function, cl_core.compiler_dispatch); + if (index != OBJNULL) { + compiler_record *l = database + ecl_fixnum(index); + c_env->lexical_level += l->lexical_increment; + if (c_env->stepping && function != @'function' && + c_env->lexical_level) + asm_op2c(env, OP_STEPIN, stmt); + new_flags = (*(l->compiler))(env, ECL_CONS_CDR(stmt), flags); + if (c_env->stepping && function != @'function' && + c_env->lexical_level) + asm_op(env, OP_STEPOUT); + c_env->lexical_level -= l->lexical_increment; + goto OUTPUT; + } + /* + * Next try to macroexpand + */ + { + cl_object new_stmt = c_macro_expand1(env, stmt); + if (new_stmt != stmt){ + stmt = new_stmt; + goto BEGIN; + } + } + } + /* + * Finally resort to ordinary function calls. + */ + if (c_env->stepping) + asm_op2c(env, OP_STEPIN, stmt); + c_env->lexical_level++; + new_flags = c_call(env, stmt, flags); + c_env->lexical_level--; OUTPUT: - /* - flags new_flags action - PUSH PUSH --- - PUSH VALUES OP_PUSH - PUSH REG0 OP_PUSH - VALUES PUSH Impossible - VALUES VALUES --- - VALUES REG0 OP_VALUEREG0 - REG0 PUSH Impossible - REG0 VALUES --- - REG0 REG0 --- - */ - if (flags & FLAG_PUSH) { - if (new_flags & (FLAG_REG0 | FLAG_VALUES)) - asm_op(env, OP_PUSH); - } else if (flags & FLAG_VALUES) { - if (new_flags & FLAG_REG0) { - asm_op(env, OP_VALUEREG0); - } else if (new_flags & FLAG_PUSH) { - FEerror("Internal error in bytecodes compiler", 0); - } - } else if (new_flags & FLAG_PUSH) { - FEerror("Internal error in bytecodes compiler", 0); - } - ecl_bds_unwind1(env); - return flags; + /* + flags new_flags action + PUSH PUSH --- + PUSH VALUES OP_PUSH + PUSH REG0 OP_PUSH + VALUES PUSH Impossible + VALUES VALUES --- + VALUES REG0 OP_VALUEREG0 + REG0 PUSH Impossible + REG0 VALUES --- + REG0 REG0 --- + */ + if (flags & FLAG_PUSH) { + if (new_flags & (FLAG_REG0 | FLAG_VALUES)) + asm_op(env, OP_PUSH); + } else if (flags & FLAG_VALUES) { + if (new_flags & FLAG_REG0) { + asm_op(env, OP_VALUEREG0); + } else if (new_flags & FLAG_PUSH) { + FEerror("Internal error in bytecodes compiler", 0); + } + } else if (new_flags & FLAG_PUSH) { + FEerror("Internal error in bytecodes compiler", 0); + } + ecl_bds_unwind1(env); + return flags; } static void eval_nontrivial_form(cl_env_ptr env, cl_object form) { - const cl_compiler_ptr old_c_env = env->c_env; - struct cl_compiler_env new_c_env = *old_c_env; - cl_index handle; - cl_object bytecodes; - struct ecl_stack_frame frame; - frame.t = t_frame; - frame.stack = frame.base = 0; - frame.size = 0; - frame.env = env; - env->nvalues = 0; - env->values[0] = ECL_NIL; - new_c_env.constants = si_make_vector(ECL_T, ecl_make_fixnum(16), - ECL_T, /* Adjustable */ - ecl_make_fixnum(0), /* Fillp */ - ECL_NIL, /* displacement */ - ECL_NIL); - new_c_env.load_time_forms = ECL_NIL; - new_c_env.env_depth = 0; - new_c_env.env_size = 0; - env->c_env = &new_c_env; - handle = asm_begin(env); - compile_with_load_time_forms(env, form, FLAG_VALUES); - if (current_pc(env) != handle) { - asm_op(env, OP_EXIT); - bytecodes = asm_end(env, handle, form); - env->values[0] = ecl_interpret((cl_object)&frame, - new_c_env.lex_env, - bytecodes); + const cl_compiler_ptr old_c_env = env->c_env; + struct cl_compiler_env new_c_env = *old_c_env; + cl_index handle; + cl_object bytecodes; + struct ecl_stack_frame frame; + frame.t = t_frame; + frame.stack = frame.base = 0; + frame.size = 0; + frame.env = env; + env->nvalues = 0; + env->values[0] = ECL_NIL; + new_c_env.constants = si_make_vector(ECL_T, ecl_make_fixnum(16), + ECL_T, /* Adjustable */ + ecl_make_fixnum(0), /* Fillp */ + ECL_NIL, /* displacement */ + ECL_NIL); + new_c_env.load_time_forms = ECL_NIL; + new_c_env.env_depth = 0; + new_c_env.env_size = 0; + env->c_env = &new_c_env; + handle = asm_begin(env); + compile_with_load_time_forms(env, form, FLAG_VALUES); + if (current_pc(env) != handle) { + asm_op(env, OP_EXIT); + bytecodes = asm_end(env, handle, form); + env->values[0] = ecl_interpret((cl_object)&frame, + new_c_env.lex_env, + bytecodes); #ifdef GBC_BOEHM - GC_free(bytecodes->bytecodes.code); - GC_free(bytecodes); + GC_free(bytecodes->bytecodes.code); + GC_free(bytecodes); #endif - } - env->c_env = old_c_env; + } + env->c_env = old_c_env; } static void eval_form(cl_env_ptr env, cl_object form) { - if (ECL_LISTP(form) || ECL_SYMBOLP(form)) { - eval_nontrivial_form(env, form); - } else { - env->values[0] = form; - env->nvalues = 1; - } + if (ECL_LISTP(form) || ECL_SYMBOLP(form)) { + eval_nontrivial_form(env, form); + } else { + env->values[0] = form; + env->nvalues = 1; + } } static int execute_each_form(cl_env_ptr env, cl_object body) { - cl_object form = ECL_NIL, next_form; - for (form = ECL_NIL; !Null(body); form = next_form) { - unlikely_if (!ECL_LISTP(body)) - FEtype_error_proper_list(body); - next_form = ECL_CONS_CAR(body); - body = ECL_CONS_CDR(body); - eval_form(env, form); - } - eval_form(env, form); - return FLAG_VALUES; + cl_object form = ECL_NIL, next_form; + for (form = ECL_NIL; !Null(body); form = next_form) { + unlikely_if (!ECL_LISTP(body)) + FEtype_error_proper_list(body); + next_form = ECL_CONS_CAR(body); + body = ECL_CONS_CDR(body); + eval_form(env, form); + } + eval_form(env, form); + return FLAG_VALUES; } static cl_index * save_bytecodes(cl_env_ptr env, cl_index start, cl_index end) { #ifdef GBC_BOEHM - cl_index l = end - start; - cl_index *bytecodes = ecl_alloc_atomic((l + 1) * sizeof(cl_index)); - cl_index *p = bytecodes; - for (*(p++) = l; end > start; end--, p++) { - *p = (cl_index)ECL_STACK_POP_UNSAFE(env); - } - return bytecodes; + cl_index l = end - start; + cl_index *bytecodes = ecl_alloc_atomic((l + 1) * sizeof(cl_index)); + cl_index *p = bytecodes; + for (*(p++) = l; end > start; end--, p++) { + *p = (cl_index)ECL_STACK_POP_UNSAFE(env); + } + return bytecodes; #else #error "Pointer references outside of recognizable object" #endif @@ -2446,96 +2440,96 @@ static void restore_bytecodes(cl_env_ptr env, cl_index *bytecodes) { - cl_index *p = bytecodes; - cl_index l; - for (l = *p; l; l--) { - ECL_STACK_PUSH(env, (cl_object)p[l]); - } - ecl_dealloc(bytecodes); + cl_index *p = bytecodes; + cl_index l; + for (l = *p; l; l--) { + ECL_STACK_PUSH(env, (cl_object)p[l]); + } + ecl_dealloc(bytecodes); } static int compile_with_load_time_forms(cl_env_ptr env, cl_object form, int flags) { - /* - * First compile the form as usual. - */ - const cl_compiler_ptr c_env = env->c_env; - cl_index handle = asm_begin(env); - int output_flags = compile_form(env, form, flags); - /* - * If some constants need to be built, we insert the - * code _before_ the actual forms; - */ - if (c_env->load_time_forms != ECL_NIL) { - cl_index *bytecodes = save_bytecodes(env, handle, current_pc(env)); - cl_object p, forms_list = c_env->load_time_forms; - c_env->load_time_forms = ECL_NIL; - p = forms_list; - do { - cl_object r = ECL_CONS_CAR(p); - cl_object constant = pop(&r); - cl_object make_form = pop(&r); - cl_object init_form = pop(&r); - cl_index loc = c_register_constant(env, constant); - compile_with_load_time_forms(env, make_form, FLAG_REG0); - asm_op2(env, OP_CSET, loc); - compile_with_load_time_forms(env, init_form, FLAG_IGNORE); - ECL_RPLACA(p, ecl_make_fixnum(loc)); - p = ECL_CONS_CDR(p); - } while (p != ECL_NIL); - p = forms_list; - do { - cl_index loc = ecl_fixnum(ECL_CONS_CAR(p)); - /* Clear created constants (they cannot be printed) */ - c_env->constants->vector.self.t[loc] = ecl_make_fixnum(0); - p = ECL_CONS_CDR(p); - } while (p != ECL_NIL); - restore_bytecodes(env, bytecodes); - } - return output_flags; + /* + * First compile the form as usual. + */ + const cl_compiler_ptr c_env = env->c_env; + cl_index handle = asm_begin(env); + int output_flags = compile_form(env, form, flags); + /* + * If some constants need to be built, we insert the + * code _before_ the actual forms; + */ + if (c_env->load_time_forms != ECL_NIL) { + cl_index *bytecodes = save_bytecodes(env, handle, current_pc(env)); + cl_object p, forms_list = c_env->load_time_forms; + c_env->load_time_forms = ECL_NIL; + p = forms_list; + do { + cl_object r = ECL_CONS_CAR(p); + cl_object constant = pop(&r); + cl_object make_form = pop(&r); + cl_object init_form = pop(&r); + cl_index loc = c_register_constant(env, constant); + compile_with_load_time_forms(env, make_form, FLAG_REG0); + asm_op2(env, OP_CSET, loc); + compile_with_load_time_forms(env, init_form, FLAG_IGNORE); + ECL_RPLACA(p, ecl_make_fixnum(loc)); + p = ECL_CONS_CDR(p); + } while (p != ECL_NIL); + p = forms_list; + do { + cl_index loc = ecl_fixnum(ECL_CONS_CAR(p)); + /* Clear created constants (they cannot be printed) */ + c_env->constants->vector.self.t[loc] = ecl_make_fixnum(0); + p = ECL_CONS_CDR(p); + } while (p != ECL_NIL); + restore_bytecodes(env, bytecodes); + } + return output_flags; } static int compile_each_form(cl_env_ptr env, cl_object body, int flags) { - cl_object form = ECL_NIL, next_form; - for (form = ECL_NIL; !Null(body); form = next_form) { - unlikely_if (!ECL_LISTP(body)) - FEtype_error_proper_list(body); - next_form = ECL_CONS_CAR(body); - body = ECL_CONS_CDR(body); - compile_with_load_time_forms(env, form, FLAG_IGNORE); - } - return compile_with_load_time_forms(env, form, flags); + cl_object form = ECL_NIL, next_form; + for (form = ECL_NIL; !Null(body); form = next_form) { + unlikely_if (!ECL_LISTP(body)) + FEtype_error_proper_list(body); + next_form = ECL_CONS_CAR(body); + body = ECL_CONS_CDR(body); + compile_with_load_time_forms(env, form, FLAG_IGNORE); + } + return compile_with_load_time_forms(env, form, flags); } static int compile_toplevel_body(cl_env_ptr env, cl_object body, int flags) { - const cl_compiler_ptr c_env = env->c_env; - if (!c_env->lexical_level) { - if (c_env->mode == FLAG_EXECUTE) - return execute_each_form(env, body); - else - return compile_each_form(env, body, flags); - } else { - return compile_body(env, body, flags); - } + const cl_compiler_ptr c_env = env->c_env; + if (!c_env->lexical_level) { + if (c_env->mode == FLAG_EXECUTE) + return execute_each_form(env, body); + else + return compile_each_form(env, body, flags); + } else { + return compile_body(env, body, flags); + } } static int compile_body(cl_env_ptr env, cl_object body, int flags) { - cl_object form = ECL_NIL, next_form; - for (form = ECL_NIL; !Null(body); form = next_form) { - unlikely_if (!ECL_LISTP(body)) - FEtype_error_proper_list(body); - next_form = ECL_CONS_CAR(body); - body = ECL_CONS_CDR(body); - compile_form(env, form, FLAG_IGNORE); - } - return compile_form(env, form, flags); + cl_object form = ECL_NIL, next_form; + for (form = ECL_NIL; !Null(body); form = next_form) { + unlikely_if (!ECL_LISTP(body)) + FEtype_error_proper_list(body); + next_form = ECL_CONS_CAR(body); + body = ECL_CONS_CDR(body); + compile_form(env, form, FLAG_IGNORE); + } + return compile_form(env, form, flags); } /* ------------------------ INLINED FUNCTIONS -------------------------------- */ @@ -2543,78 +2537,78 @@ static int c_cons(cl_env_ptr env, cl_object args, int flags) { - if (ecl_length(args) != 2) { - FEprogram_error_noreturn("CONS: Wrong number of arguments", 0); - } - compile_form(env, cl_first(args), FLAG_PUSH); - compile_form(env, cl_second(args), FLAG_REG0); - asm_op(env, OP_CONS); - return FLAG_REG0; + if (ecl_length(args) != 2) { + FEprogram_error_noreturn("CONS: Wrong number of arguments", 0); + } + compile_form(env, cl_first(args), FLAG_PUSH); + compile_form(env, cl_second(args), FLAG_REG0); + asm_op(env, OP_CONS); + return FLAG_REG0; } static int c_endp(cl_env_ptr env, cl_object args, int flags) { - cl_object list = pop(&args); - if (args != ECL_NIL) { - FEprogram_error_noreturn("ENDP: Too many arguments", 0); - } - compile_form(env, list, FLAG_REG0); - asm_op(env, OP_ENDP); - return FLAG_REG0; + cl_object list = pop(&args); + if (args != ECL_NIL) { + FEprogram_error_noreturn("ENDP: Too many arguments", 0); + } + compile_form(env, list, FLAG_REG0); + asm_op(env, OP_ENDP); + return FLAG_REG0; } static int c_car(cl_env_ptr env, cl_object args, int flags) { - cl_object list = pop(&args); - if (args != ECL_NIL) { - FEprogram_error_noreturn("CAR: Too many arguments", 0); - } - compile_form(env, list, FLAG_REG0); - asm_op(env, OP_CAR); - return FLAG_REG0; + cl_object list = pop(&args); + if (args != ECL_NIL) { + FEprogram_error_noreturn("CAR: Too many arguments", 0); + } + compile_form(env, list, FLAG_REG0); + asm_op(env, OP_CAR); + return FLAG_REG0; } static int c_cdr(cl_env_ptr env, cl_object args, int flags) { - cl_object list = pop(&args); - if (args != ECL_NIL) { - FEprogram_error_noreturn("CDR: Too many arguments", 0); - } - compile_form(env, list, FLAG_REG0); - asm_op(env, OP_CDR); - return FLAG_REG0; + cl_object list = pop(&args); + if (args != ECL_NIL) { + FEprogram_error_noreturn("CDR: Too many arguments", 0); + } + compile_form(env, list, FLAG_REG0); + asm_op(env, OP_CDR); + return FLAG_REG0; } static int c_list_listA(cl_env_ptr env, cl_object args, int flags, int op) { - cl_index n = ecl_length(args); - if (n == 0) { - return compile_form(env, ECL_NIL, flags); - } else { - while (ECL_CONS_CDR(args) != ECL_NIL) { - compile_form(env, ECL_CONS_CAR(args), FLAG_PUSH); - args = ECL_CONS_CDR(args); - } - compile_form(env, ECL_CONS_CAR(args), FLAG_REG0); - asm_op2(env, op, n); - return FLAG_REG0; - } + cl_index n = ecl_length(args); + if (n == 0) { + return compile_form(env, ECL_NIL, flags); + } else { + while (ECL_CONS_CDR(args) != ECL_NIL) { + compile_form(env, ECL_CONS_CAR(args), FLAG_PUSH); + args = ECL_CONS_CDR(args); + } + compile_form(env, ECL_CONS_CAR(args), FLAG_REG0); + asm_op2(env, op, n); + return FLAG_REG0; + } } static int c_list(cl_env_ptr env, cl_object args, int flags) { - return c_list_listA(env, args, flags, OP_LIST); + return c_list_listA(env, args, flags, OP_LIST); } static int c_listA(cl_env_ptr env, cl_object args, int flags) { - return c_list_listA(env, args, flags, OP_LISTA); + return c_list_listA(env, args, flags, OP_LISTA); } @@ -2622,88 +2616,88 @@ /* ------------------------------------------------------------ LAMBDA OBJECTS: An interpreted function is a vector made of - the following components + the following components - #(LAMBDA - {block-name | NIL} - {variable-env | NIL} - {function-env | NIL} - {block-env | NIL} - (list of variables declared special) - Nreq {var}* ; required arguments - Nopt {var value flag}* ; optional arguments - {rest-var NIL} ; rest variable - {T | NIL} ; allow other keys? - Nkey {key var value flag}* ; keyword arguments - Naux {var init} ; auxiliary variables - documentation-string - list-of-declarations - {form}* ; body) + #(LAMBDA + {block-name | NIL} + {variable-env | NIL} + {function-env | NIL} + {block-env | NIL} + (list of variables declared special) + Nreq {var}* ; required arguments + Nopt {var value flag}* ; optional arguments + {rest-var NIL} ; rest variable + {T | NIL} ; allow other keys? + Nkey {key var value flag}* ; keyword arguments + Naux {var init} ; auxiliary variables + documentation-string + list-of-declarations + {form}* ; body) ------------------------------------------------------------ */ /* Handles special declarations, removes declarations from body - */ +*/ @(defun si::process-declarations (body &optional doc) - cl_object documentation = ECL_NIL, declarations = ECL_NIL, specials = ECL_NIL; + cl_object documentation = ECL_NIL, declarations = ECL_NIL, specials = ECL_NIL; @ - for (; !Null(body); body = ECL_CONS_CDR(body)) { - cl_object form; - unlikely_if (!ECL_LISTP(body)) - FEill_formed_input(); - form = ECL_CONS_CAR(body); - if (!Null(doc) && ecl_stringp(form) && !Null(ECL_CONS_CDR(body))) { - if (documentation != ECL_NIL) - break; - documentation = form; - continue; - } - if (ECL_ATOM(form) || (ECL_CONS_CAR(form) != @'declare')) { - break; - } - for (form = ECL_CONS_CDR(form); !Null(form); ) { - cl_object sentence = pop(&form); - declarations = ecl_cons(sentence, declarations); - if (pop(&sentence) == @'special') { - while (!Null(sentence)) { - cl_object v = pop(&sentence); - assert_type_symbol(v); - specials = ecl_cons(v, specials); - } - } - } - } - @(return cl_nreverse(declarations) body documentation specials) + for (; !Null(body); body = ECL_CONS_CDR(body)) { + cl_object form; + unlikely_if (!ECL_LISTP(body)) + FEill_formed_input(); + form = ECL_CONS_CAR(body); + if (!Null(doc) && ecl_stringp(form) && !Null(ECL_CONS_CDR(body))) { + if (documentation != ECL_NIL) + break; + documentation = form; + continue; + } + if (ECL_ATOM(form) || (ECL_CONS_CAR(form) != @'declare')) { + break; + } + for (form = ECL_CONS_CDR(form); !Null(form); ) { + cl_object sentence = pop(&form); + declarations = ecl_cons(sentence, declarations); + if (pop(&sentence) == @'special') { + while (!Null(sentence)) { + cl_object v = pop(&sentence); + assert_type_symbol(v); + specials = ecl_cons(v, specials); + } + } + } + } + @(return cl_nreverse(declarations) body documentation specials); @) cl_object si_process_lambda(cl_object lambda) { - cl_object documentation, declarations, specials; - cl_object lambda_list, body; - const cl_env_ptr env = ecl_process_env(); - unlikely_if (ECL_ATOM(lambda)) - FEprogram_error_noreturn("LAMBDA: No lambda list.", 0); - - lambda_list = ECL_CONS_CAR(lambda); - body = ECL_CONS_CDR(lambda); - declarations = @si::process-declarations(2, body, ECL_T); - body = env->values[1]; - documentation = env->values[2]; - specials = env->values[3]; - - lambda_list = si_process_lambda_list(lambda_list, @'function'); - { - cl_index n = env->nvalues; - env->values[0] = lambda_list; - env->values[n++] = documentation; - env->values[n++] = specials; - env->values[n++] = declarations; - env->values[n++] = body; - env->nvalues = n; - } - return lambda_list; + cl_object documentation, declarations, specials; + cl_object lambda_list, body; + const cl_env_ptr env = ecl_process_env(); + unlikely_if (ECL_ATOM(lambda)) + FEprogram_error_noreturn("LAMBDA: No lambda list.", 0); + + lambda_list = ECL_CONS_CAR(lambda); + body = ECL_CONS_CDR(lambda); + declarations = @si::process-declarations(2, body, ECL_T); + body = env->values[1]; + documentation = env->values[2]; + specials = env->values[3]; + + lambda_list = si_process_lambda_list(lambda_list, @'function'); + { + cl_index n = env->nvalues; + env->values[0] = lambda_list; + env->values[n++] = documentation; + env->values[n++] = specials; + env->values[n++] = declarations; + env->values[n++] = body; + env->nvalues = n; + } + return lambda_list; } /* @@ -2737,205 +2731,205 @@ si_process_lambda_list(cl_object org_lambda_list, cl_object context) { #define push(v,l) { cl_object c = *l = CONS(v, *l); l = &ECL_CONS_CDR(c); } -#define assert_var_name(v) \ - if (context == @'function') { \ - unlikely_if (ecl_symbol_type(v) & ecl_stp_constant) \ - FEillegal_variable_name(v); } - cl_object lists[4] = {ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL}; - cl_object *reqs = lists, *opts = lists+1, *keys = lists+2, *auxs = lists+3; - cl_object v, rest = ECL_NIL, lambda_list = org_lambda_list; - int nreq = 0, nopt = 0, nkey = 0, naux = 0; - cl_object allow_other_keys = ECL_NIL; - cl_object key_flag = ECL_NIL; - enum { AT_REQUIREDS, - AT_OPTIONALS, - AT_REST, - AT_KEYS, - AT_OTHER_KEYS, - AT_AUXS - } stage = AT_REQUIREDS; - - if (!ECL_LISTP(lambda_list)) - goto ILLEGAL_LAMBDA; -LOOP: - if (Null(lambda_list)) - goto OUTPUT; - if (!ECL_LISTP(lambda_list)) { - unlikely_if (context == @'function' || context == @'ftype') - goto ILLEGAL_LAMBDA; - v = lambda_list; - lambda_list = ECL_NIL; - goto REST; - } - v = ECL_CONS_CAR(lambda_list); - lambda_list = ECL_CONS_CDR(lambda_list); - if (v == @'&optional') { - unlikely_if (stage >= AT_OPTIONALS) - goto ILLEGAL_LAMBDA; - stage = AT_OPTIONALS; - goto LOOP; - } - if (v == @'&rest' - || (v == @'&body' - && (context == @'si::macro' || context == @'destructuring-bind'))) { - unlikely_if (ECL_ATOM(lambda_list)) - goto ILLEGAL_LAMBDA; - v = ECL_CONS_CAR(lambda_list); - lambda_list = ECL_CONS_CDR(lambda_list); -REST: unlikely_if (stage >= AT_REST) - goto ILLEGAL_LAMBDA; - stage = AT_REST; - rest = v; - goto LOOP; - } - if (v == @'&key') { - unlikely_if (stage >= AT_KEYS) - goto ILLEGAL_LAMBDA; - key_flag = ECL_T; - stage = AT_KEYS; - goto LOOP; - } - if (v == @'&aux') { - unlikely_if (stage >= AT_AUXS) - goto ILLEGAL_LAMBDA; - stage = AT_AUXS; - goto LOOP; - } - if (v == @'&allow-other-keys') { - allow_other_keys = ECL_T; - unlikely_if (stage != AT_KEYS) - goto ILLEGAL_LAMBDA; - stage = AT_OTHER_KEYS; - goto LOOP; - } - switch (stage) { - case AT_REQUIREDS: - nreq++; - assert_var_name(v); - if (context == @'function' && ecl_member_eq(v, lists[0])) - /* note: ftype isn't valid context for this check */ - FEprogram_error_noreturn - ("The variable ~s occurs more than once as the " - "required parameter in the lambda list.", 1, v); - push(v, reqs); - break; - case AT_OPTIONALS: { - cl_object spp = ECL_NIL; - cl_object init = ECL_NIL; - if (!ECL_ATOM(v) && (context != @'ftype')) { - cl_object x = v; - unlikely_if (!ECL_LISTP(x)) goto ILLEGAL_LAMBDA; - v = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - if (!Null(x)) { - unlikely_if (!ECL_LISTP(x)) goto ILLEGAL_LAMBDA; - init = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - if (!Null(x)) { - unlikely_if (!ECL_LISTP(x)) goto ILLEGAL_LAMBDA; - spp = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - if (spp != ECL_NIL) assert_var_name(spp); - unlikely_if (!Null(x)) - goto ILLEGAL_LAMBDA; - } - } - } - nopt++; - assert_var_name(v); - push(v, opts); - push(init, opts); - push(spp, opts); - break; - } - case AT_REST: - /* If we get here, the user has declared more than one - * &rest variable, as in (lambda (&rest x y) ...) */ - goto ILLEGAL_LAMBDA; - case AT_KEYS: { - cl_object init = ECL_NIL; - cl_object spp = ECL_NIL; - cl_object key; - if (context == @'ftype') { - unlikely_if (ECL_ATOM(v)) - goto ILLEGAL_LAMBDA; - key = ECL_CONS_CAR(v); - v = CADR(v); - goto KEY_PUSH; - } - if (!ECL_ATOM(v)) { - cl_object x = v; - v = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - if (!Null(x)) { - unlikely_if (!ECL_LISTP(x)) goto ILLEGAL_LAMBDA; - init = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - if (!Null(x)) { - unlikely_if (!ECL_LISTP(x)) goto ILLEGAL_LAMBDA; - spp = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - unlikely_if (!Null(x)) - goto ILLEGAL_LAMBDA; - if (spp != ECL_NIL) assert_var_name(spp); - } - } - } - if (CONSP(v)) { - key = ECL_CONS_CAR(v); - v = ECL_CONS_CDR(v); - unlikely_if (ECL_ATOM(v) || !Null(ECL_CONS_CDR(v))) - goto ILLEGAL_LAMBDA; - v = ECL_CONS_CAR(v); - if (context == @'function') - assert_type_symbol(v); - assert_type_symbol(key); - } else { - int intern_flag; - key = ecl_intern(ecl_symbol_name(v), cl_core.keyword_package, - &intern_flag); - } - KEY_PUSH: - nkey++; - push(key, keys); - assert_var_name(v); - push(v, keys); - push(init, keys); - push(spp, keys); - break; - } - default: { - cl_object init; - if (ECL_ATOM(v)) { - init = ECL_NIL; - } else if (Null(CDDR(v))) { - cl_object x = v; - v = ECL_CONS_CAR(x); - init = CADR(x); - } else - goto ILLEGAL_LAMBDA; - naux++; - assert_var_name(v); - push(v, auxs); - push(init, auxs); - } - } - goto LOOP; +#define assert_var_name(v) \ + if (context == @'function') { \ + unlikely_if (ecl_symbol_type(v) & ecl_stp_constant) \ + FEillegal_variable_name(v); } + cl_object lists[4] = {ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL}; + cl_object *reqs = lists, *opts = lists+1, *keys = lists+2, *auxs = lists+3; + cl_object v, rest = ECL_NIL, lambda_list = org_lambda_list; + int nreq = 0, nopt = 0, nkey = 0, naux = 0; + cl_object allow_other_keys = ECL_NIL; + cl_object key_flag = ECL_NIL; + enum { AT_REQUIREDS, + AT_OPTIONALS, + AT_REST, + AT_KEYS, + AT_OTHER_KEYS, + AT_AUXS + } stage = AT_REQUIREDS; + + if (!ECL_LISTP(lambda_list)) + goto ILLEGAL_LAMBDA; + LOOP: + if (Null(lambda_list)) + goto OUTPUT; + if (!ECL_LISTP(lambda_list)) { + unlikely_if (context == @'function' || context == @'ftype') + goto ILLEGAL_LAMBDA; + v = lambda_list; + lambda_list = ECL_NIL; + goto REST; + } + v = ECL_CONS_CAR(lambda_list); + lambda_list = ECL_CONS_CDR(lambda_list); + if (v == @'&optional') { + unlikely_if (stage >= AT_OPTIONALS) + goto ILLEGAL_LAMBDA; + stage = AT_OPTIONALS; + goto LOOP; + } + if (v == @'&rest' + || (v == @'&body' + && (context == @'si::macro' || context == @'destructuring-bind'))) { + unlikely_if (ECL_ATOM(lambda_list)) + goto ILLEGAL_LAMBDA; + v = ECL_CONS_CAR(lambda_list); + lambda_list = ECL_CONS_CDR(lambda_list); + REST: unlikely_if (stage >= AT_REST) + goto ILLEGAL_LAMBDA; + stage = AT_REST; + rest = v; + goto LOOP; + } + if (v == @'&key') { + unlikely_if (stage >= AT_KEYS) + goto ILLEGAL_LAMBDA; + key_flag = ECL_T; + stage = AT_KEYS; + goto LOOP; + } + if (v == @'&aux') { + unlikely_if (stage >= AT_AUXS) + goto ILLEGAL_LAMBDA; + stage = AT_AUXS; + goto LOOP; + } + if (v == @'&allow-other-keys') { + allow_other_keys = ECL_T; + unlikely_if (stage != AT_KEYS) + goto ILLEGAL_LAMBDA; + stage = AT_OTHER_KEYS; + goto LOOP; + } + switch (stage) { + case AT_REQUIREDS: + nreq++; + assert_var_name(v); + if (context == @'function' && ecl_member_eq(v, lists[0])) + /* note: ftype isn't valid context for this check */ + FEprogram_error_noreturn + ("The variable ~s occurs more than once as the " + "required parameter in the lambda list.", 1, v); + push(v, reqs); + break; + case AT_OPTIONALS: { + cl_object spp = ECL_NIL; + cl_object init = ECL_NIL; + if (!ECL_ATOM(v) && (context != @'ftype')) { + cl_object x = v; + unlikely_if (!ECL_LISTP(x)) goto ILLEGAL_LAMBDA; + v = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + if (!Null(x)) { + unlikely_if (!ECL_LISTP(x)) goto ILLEGAL_LAMBDA; + init = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + if (!Null(x)) { + unlikely_if (!ECL_LISTP(x)) goto ILLEGAL_LAMBDA; + spp = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + if (spp != ECL_NIL) assert_var_name(spp); + unlikely_if (!Null(x)) + goto ILLEGAL_LAMBDA; + } + } + } + nopt++; + assert_var_name(v); + push(v, opts); + push(init, opts); + push(spp, opts); + break; + } + case AT_REST: + /* If we get here, the user has declared more than one + * &rest variable, as in (lambda (&rest x y) ...) */ + goto ILLEGAL_LAMBDA; + case AT_KEYS: { + cl_object init = ECL_NIL; + cl_object spp = ECL_NIL; + cl_object key; + if (context == @'ftype') { + unlikely_if (ECL_ATOM(v)) + goto ILLEGAL_LAMBDA; + key = ECL_CONS_CAR(v); + v = CADR(v); + goto KEY_PUSH; + } + if (!ECL_ATOM(v)) { + cl_object x = v; + v = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + if (!Null(x)) { + unlikely_if (!ECL_LISTP(x)) goto ILLEGAL_LAMBDA; + init = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + if (!Null(x)) { + unlikely_if (!ECL_LISTP(x)) goto ILLEGAL_LAMBDA; + spp = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + unlikely_if (!Null(x)) + goto ILLEGAL_LAMBDA; + if (spp != ECL_NIL) assert_var_name(spp); + } + } + } + if (CONSP(v)) { + key = ECL_CONS_CAR(v); + v = ECL_CONS_CDR(v); + unlikely_if (ECL_ATOM(v) || !Null(ECL_CONS_CDR(v))) + goto ILLEGAL_LAMBDA; + v = ECL_CONS_CAR(v); + if (context == @'function') + assert_type_symbol(v); + assert_type_symbol(key); + } else { + int intern_flag; + key = ecl_intern(ecl_symbol_name(v), cl_core.keyword_package, + &intern_flag); + } + KEY_PUSH: + nkey++; + push(key, keys); + assert_var_name(v); + push(v, keys); + push(init, keys); + push(spp, keys); + break; + } + default: { + cl_object init; + if (ECL_ATOM(v)) { + init = ECL_NIL; + } else if (Null(CDDR(v))) { + cl_object x = v; + v = ECL_CONS_CAR(x); + init = CADR(x); + } else + goto ILLEGAL_LAMBDA; + naux++; + assert_var_name(v); + push(v, auxs); + push(init, auxs); + } + } + goto LOOP; -OUTPUT: - if ((nreq+nopt+(!Null(rest))+nkey) >= ECL_CALL_ARGUMENTS_LIMIT) - FEprogram_error_noreturn("LAMBDA: Argument list ist too long, ~S.", 1, - org_lambda_list); - @(return CONS(ecl_make_fixnum(nreq), lists[0]) - CONS(ecl_make_fixnum(nopt), lists[1]) - rest - key_flag - CONS(ecl_make_fixnum(nkey), lists[2]) - allow_other_keys - lists[3]) + OUTPUT: + if ((nreq+nopt+(!Null(rest))+nkey) >= ECL_CALL_ARGUMENTS_LIMIT) + FEprogram_error_noreturn("LAMBDA: Argument list ist too long, ~S.", 1, + org_lambda_list); + @(return CONS(ecl_make_fixnum(nreq), lists[0]) + CONS(ecl_make_fixnum(nopt), lists[1]) + rest + key_flag + CONS(ecl_make_fixnum(nkey), lists[2]) + allow_other_keys + lists[3]); -ILLEGAL_LAMBDA: - FEprogram_error_noreturn("LAMBDA: Illegal lambda list ~S.", 1, org_lambda_list); + ILLEGAL_LAMBDA: + FEprogram_error_noreturn("LAMBDA: Illegal lambda list ~S.", 1, org_lambda_list); #undef push #undef assert_var_name @@ -2944,235 +2938,235 @@ static void c_default(cl_env_ptr env, cl_object var, cl_object stmt, cl_object flag, cl_object specials) { - /* Flag is in REG0, value, if it exists, in stack */ - cl_index label; - label = asm_jmp(env, OP_JT); - compile_form(env, stmt, FLAG_PUSH); - if (Null(flag)) { - asm_complete(env, OP_JT, label); - } else { - compile_form(env, ECL_NIL, FLAG_REG0); - asm_complete(env, OP_JT, label); - c_bind(env, flag, specials); - } - c_pbind(env, var, specials); + /* Flag is in REG0, value, if it exists, in stack */ + cl_index label; + label = asm_jmp(env, OP_JT); + compile_form(env, stmt, FLAG_PUSH); + if (Null(flag)) { + asm_complete(env, OP_JT, label); + } else { + compile_form(env, ECL_NIL, FLAG_REG0); + asm_complete(env, OP_JT, label); + c_bind(env, flag, specials); + } + c_pbind(env, var, specials); } cl_object ecl_make_lambda(cl_env_ptr env, cl_object name, cl_object lambda) { - cl_object reqs, opts, rest, key, keys, auxs, allow_other_keys; - cl_object specials, doc, decl, body, output; - cl_index handle; - struct cl_compiler_env *old_c_env, new_c_env; - - ecl_bds_bind(env, @'si::*current-form*', - @list*(3, @'ext::lambda-block', name, lambda)); - - old_c_env = env->c_env; - c_new_env(env, &new_c_env, ECL_NIL, old_c_env); - new_c_env.lexical_level++; - - reqs = si_process_lambda(lambda); - opts = env->values[1]; - rest = env->values[2]; - key = env->values[3]; - keys = env->values[4]; - allow_other_keys = env->values[5]; - auxs = env->values[6]; - doc = env->values[7]; - specials = env->values[8]; - decl = env->values[9]; - body = env->values[10]; - - handle = asm_begin(env); - - /* Transform (SETF fname) => fname */ - if (!Null(name) && Null(si_valid_function_name_p(name))) - FEprogram_error_noreturn("LAMBDA: Not a valid function name ~S",1,name); - - /* We register as special variable a symbol which is not - * to be used. We use this to mark the boundary of a function - * environment and when code-walking */ - c_register_var(env, @'si::function-boundary', TRUE, FALSE); - - reqs = ECL_CONS_CDR(reqs); /* Required arguments */ - while (!Null(reqs)) { - cl_object var = pop(&reqs); - asm_op(env, OP_POPREQ); - c_bind(env, var, specials); - } - opts = ECL_CONS_CDR(opts); - while (!Null(opts)) { /* Optional arguments */ - cl_object var = pop(&opts); - cl_object stmt = pop(&opts); - cl_object flag = pop(&opts); - asm_op(env, OP_POPOPT); - c_default(env, var, stmt, flag, specials); - } - if (Null(rest) && Null(key)) { /* Check no excess arguments */ - asm_op(env, OP_NOMORE); - } - if (!Null(rest)) { /* &rest argument */ - asm_op(env, OP_POPREST); - c_bind(env, rest, specials); - } - if (!Null(key)) { - cl_object aux = CONS(allow_other_keys,ECL_NIL); - cl_object names = ECL_NIL; - asm_op2c(env, OP_PUSHKEYS, aux); - keys = ECL_CONS_CDR(keys); - while (!Null(keys)) { - cl_object name = pop(&keys); - cl_object var = pop(&keys); - cl_object stmt = pop(&keys); - cl_object flag = pop(&keys); - names = CONS(name, names); - asm_op(env, OP_POP); - c_default(env, var, stmt, flag, specials); - } - ECL_RPLACD(aux, names); - } + cl_object reqs, opts, rest, key, keys, auxs, allow_other_keys; + cl_object specials, doc, decl, body, output; + cl_index handle; + struct cl_compiler_env *old_c_env, new_c_env; + + ecl_bds_bind(env, @'si::*current-form*', + @list*(3, @'ext::lambda-block', name, lambda)); + + old_c_env = env->c_env; + c_new_env(env, &new_c_env, ECL_NIL, old_c_env); + new_c_env.lexical_level++; + + reqs = si_process_lambda(lambda); + opts = env->values[1]; + rest = env->values[2]; + key = env->values[3]; + keys = env->values[4]; + allow_other_keys = env->values[5]; + auxs = env->values[6]; + doc = env->values[7]; + specials = env->values[8]; + decl = env->values[9]; + body = env->values[10]; + + handle = asm_begin(env); + + /* Transform (SETF fname) => fname */ + if (!Null(name) && Null(si_valid_function_name_p(name))) + FEprogram_error_noreturn("LAMBDA: Not a valid function name ~S",1,name); + + /* We register as special variable a symbol which is not + * to be used. We use this to mark the boundary of a function + * environment and when code-walking */ + c_register_var(env, @'si::function-boundary', TRUE, FALSE); + + reqs = ECL_CONS_CDR(reqs); /* Required arguments */ + while (!Null(reqs)) { + cl_object var = pop(&reqs); + asm_op(env, OP_POPREQ); + c_bind(env, var, specials); + } + opts = ECL_CONS_CDR(opts); + while (!Null(opts)) { /* Optional arguments */ + cl_object var = pop(&opts); + cl_object stmt = pop(&opts); + cl_object flag = pop(&opts); + asm_op(env, OP_POPOPT); + c_default(env, var, stmt, flag, specials); + } + if (Null(rest) && Null(key)) { /* Check no excess arguments */ + asm_op(env, OP_NOMORE); + } + if (!Null(rest)) { /* &rest argument */ + asm_op(env, OP_POPREST); + c_bind(env, rest, specials); + } + if (!Null(key)) { + cl_object aux = CONS(allow_other_keys,ECL_NIL); + cl_object names = ECL_NIL; + asm_op2c(env, OP_PUSHKEYS, aux); + keys = ECL_CONS_CDR(keys); + while (!Null(keys)) { + cl_object name = pop(&keys); + cl_object var = pop(&keys); + cl_object stmt = pop(&keys); + cl_object flag = pop(&keys); + names = CONS(name, names); + asm_op(env, OP_POP); + c_default(env, var, stmt, flag, specials); + } + ECL_RPLACD(aux, names); + } + + while (!Null(auxs)) { /* Local bindings */ + cl_object var = pop(&auxs); + cl_object value = pop(&auxs); + compile_form(env, value, FLAG_REG0); + c_bind(env, var, specials); + } + c_declare_specials(env, specials); + + if (!Null(name)) { + compile_form(env, @list*(3, @'block', si_function_block_name(name), + body), FLAG_VALUES); + } else { + while (!Null(decl)) { + cl_object l = ECL_CONS_CAR(decl); + if (ECL_CONSP(l) && ECL_CONS_CAR(l) == @'si::function-block-name') { + name = ECL_CONS_CAR(ECL_CONS_CDR(l)); + break; + } + decl = ECL_CONS_CDR(decl); + } + compile_body(env, body, FLAG_VALUES); + } + + /* Only undo special bindings */ + c_undo_bindings(env, old_c_env->variables, 1); + asm_op(env, OP_EXIT); + + if (Null(ecl_symbol_value(@'si::*keep-definitions*'))) + lambda = ECL_NIL; + output = asm_end(env, handle, lambda); + output->bytecodes.name = name; - while (!Null(auxs)) { /* Local bindings */ - cl_object var = pop(&auxs); - cl_object value = pop(&auxs); - compile_form(env, value, FLAG_REG0); - c_bind(env, var, specials); - } - c_declare_specials(env, specials); + old_c_env->load_time_forms = env->c_env->load_time_forms; + env->c_env = old_c_env; - if (!Null(name)) { - compile_form(env, @list*(3, @'block', si_function_block_name(name), - body), FLAG_VALUES); - } else { - while (!Null(decl)) { - cl_object l = ECL_CONS_CAR(decl); - if (ECL_CONSP(l) && ECL_CONS_CAR(l) == @'si::function-block-name') { - name = ECL_CONS_CAR(ECL_CONS_CDR(l)); - break; - } - decl = ECL_CONS_CDR(decl); - } - compile_body(env, body, FLAG_VALUES); - } - - /* Only undo special bindings */ - c_undo_bindings(env, old_c_env->variables, 1); - asm_op(env, OP_EXIT); - - if (Null(ecl_symbol_value(@'si::*keep-definitions*'))) - lambda = ECL_NIL; - output = asm_end(env, handle, lambda); - output->bytecodes.name = name; - - old_c_env->load_time_forms = env->c_env->load_time_forms; - env->c_env = old_c_env; + ecl_bds_unwind1(env); - ecl_bds_unwind1(env); - - return output; + return output; } static cl_object ecl_function_block_name(cl_object name) { - if (ECL_SYMBOLP(name)) { - return name; - } else if (CONSP(name) && ECL_CONS_CAR(name) == @'setf') { - name = ECL_CONS_CDR(name); - if (CONSP(name)) { - cl_object output = ECL_CONS_CAR(name); - if (ECL_SYMBOLP(output) && Null(ECL_CONS_CDR(name))) - return output; - } - } - return NULL; + if (ECL_SYMBOLP(name)) { + return name; + } else if (CONSP(name) && ECL_CONS_CAR(name) == @'setf') { + name = ECL_CONS_CDR(name); + if (CONSP(name)) { + cl_object output = ECL_CONS_CAR(name); + if (ECL_SYMBOLP(output) && Null(ECL_CONS_CDR(name))) + return output; + } + } + return NULL; } cl_object si_function_block_name(cl_object name) { - cl_object output = ecl_function_block_name(name); - if (!output) - FEinvalid_function_name(name); - @(return output) + cl_object output = ecl_function_block_name(name); + if (!output) + FEinvalid_function_name(name); + @(return output); } cl_object si_valid_function_name_p(cl_object name) { - name = ecl_function_block_name(name); - @(return (name? ECL_T : ECL_NIL)) + name = ecl_function_block_name(name); + @(return (name? ECL_T : ECL_NIL)); } cl_object si_make_lambda(cl_object name, cl_object rest) { - cl_object lambda; - const cl_env_ptr the_env = ecl_process_env(); - volatile cl_compiler_env_ptr old_c_env = the_env->c_env; - struct cl_compiler_env new_c_env; - - c_new_env(the_env, &new_c_env, ECL_NIL, 0); - ECL_UNWIND_PROTECT_BEGIN(the_env) { - lambda = ecl_make_lambda(the_env, name, rest); - } ECL_UNWIND_PROTECT_EXIT { - the_env->c_env = old_c_env; - } ECL_UNWIND_PROTECT_END; - @(return lambda) + cl_object lambda; + const cl_env_ptr the_env = ecl_process_env(); + volatile cl_compiler_env_ptr old_c_env = the_env->c_env; + struct cl_compiler_env new_c_env; + + c_new_env(the_env, &new_c_env, ECL_NIL, 0); + ECL_UNWIND_PROTECT_BEGIN(the_env) { + lambda = ecl_make_lambda(the_env, name, rest); + } ECL_UNWIND_PROTECT_EXIT { + the_env->c_env = old_c_env; + } ECL_UNWIND_PROTECT_END; + @(return lambda); } @(defun si::eval-with-env (form &optional (env ECL_NIL) (stepping ECL_NIL) (compiler_env_p ECL_NIL) (execute ECL_T)) - volatile cl_compiler_env_ptr old_c_env; - struct cl_compiler_env new_c_env; - cl_object interpreter_env, compiler_env; + volatile cl_compiler_env_ptr old_c_env; + struct cl_compiler_env new_c_env; + cl_object interpreter_env, compiler_env; @ - /* - * Compile to bytecodes. - */ - if (compiler_env_p == ECL_NIL) { - interpreter_env = env; - compiler_env = ECL_NIL; - } else { - interpreter_env = ECL_NIL; - compiler_env = env; - } - old_c_env = the_env->c_env; - c_new_env(the_env, &new_c_env, compiler_env, 0); - guess_environment(the_env, interpreter_env); - new_c_env.lex_env = env; - new_c_env.stepping = stepping != ECL_NIL; - ECL_UNWIND_PROTECT_BEGIN(the_env) { - if (Null(execute)) { - cl_index handle = asm_begin(the_env); - new_c_env.mode = FLAG_LOAD; - /*cl_print(1,form);*/ - compile_with_load_time_forms(the_env, form, FLAG_VALUES); - asm_op(the_env, OP_EXIT); - the_env->values[0] = asm_end(the_env, handle, form); - the_env->nvalues = 1; - } else { - eval_form(the_env, form); - } - } ECL_UNWIND_PROTECT_EXIT { - /* Clear up */ - the_env->c_env = old_c_env; - memset(&new_c_env, 0, sizeof(new_c_env)); - } ECL_UNWIND_PROTECT_END; - return the_env->values[0]; + /* + * Compile to bytecodes. + */ + if (compiler_env_p == ECL_NIL) { + interpreter_env = env; + compiler_env = ECL_NIL; + } else { + interpreter_env = ECL_NIL; + compiler_env = env; + } + old_c_env = the_env->c_env; + c_new_env(the_env, &new_c_env, compiler_env, 0); + guess_environment(the_env, interpreter_env); + new_c_env.lex_env = env; + new_c_env.stepping = stepping != ECL_NIL; + ECL_UNWIND_PROTECT_BEGIN(the_env) { + if (Null(execute)) { + cl_index handle = asm_begin(the_env); + new_c_env.mode = FLAG_LOAD; + /*cl_print(1,form);*/ + compile_with_load_time_forms(the_env, form, FLAG_VALUES); + asm_op(the_env, OP_EXIT); + the_env->values[0] = asm_end(the_env, handle, form); + the_env->nvalues = 1; + } else { + eval_form(the_env, form); + } + } ECL_UNWIND_PROTECT_EXIT { + /* Clear up */ + the_env->c_env = old_c_env; + memset(&new_c_env, 0, sizeof(new_c_env)); + } ECL_UNWIND_PROTECT_END; + return the_env->values[0]; @) void init_compiler() { - cl_object dispatch_table = - cl_core.compiler_dispatch = - cl__make_hash_table(@'eq', ecl_make_fixnum(128), /* size */ - cl_core.rehash_size, - cl_core.rehash_threshold); - int i; - for (i = 0; database[i].symbol; i++) { - ecl_sethash(database[i].symbol, dispatch_table, ecl_make_fixnum(i)); - } + cl_object dispatch_table = + cl_core.compiler_dispatch = + cl__make_hash_table(@'eq', ecl_make_fixnum(128), /* size */ + cl_core.rehash_size, + cl_core.rehash_threshold); + int i; + for (i = 0; database[i].symbol; i++) { + ecl_sethash(database[i].symbol, dispatch_table, ecl_make_fixnum(i)); + } } diff -Nru ecl-16.1.2/src/c/cons.d ecl-16.1.3+ds/src/c/cons.d --- ecl-16.1.2/src/c/cons.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/cons.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - cons.d -- list manipulation macros & functions -*/ -/* - Copyright (c) 2011, Juan Jose Garcia-Ripoll - - ECL 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. - - See file '../Copyright' for full details. -*/ + * cons.d - list manipulation macros & functions + * + * Copyright (c) 2011 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include diff -Nru ecl-16.1.2/src/c/disassembler.d ecl-16.1.3+ds/src/c/disassembler.d --- ecl-16.1.2/src/c/disassembler.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/disassembler.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - disassembler.c -- Byte compiler and function evaluator -*/ -/* - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * disassembler.d - bytecodes disassembler utilities + * + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -26,60 +21,60 @@ static void print_noarg(const char *s) { - ecl_princ_str(s, ECL_NIL); + ecl_princ_str(s, ECL_NIL); } static void print_oparg(const char *s, cl_fixnum n) { - ecl_princ_str(s, ECL_NIL); - ecl_princ(ecl_make_fixnum(n), ECL_NIL); + ecl_princ_str(s, ECL_NIL); + ecl_princ(ecl_make_fixnum(n), ECL_NIL); } static void print_arg(const char *s, cl_object x) { - ecl_princ_str(s, ECL_NIL); - ecl_princ(x, ECL_NIL); + ecl_princ_str(s, ECL_NIL); + ecl_princ(x, ECL_NIL); } static void print_oparg_arg(const char *s, cl_fixnum n, cl_object x) { - ecl_princ_str(s, ECL_NIL); - ecl_princ(ecl_make_fixnum(n), ECL_NIL); - ecl_princ_str(",", ECL_NIL); - ecl_princ(x, ECL_NIL); + ecl_princ_str(s, ECL_NIL); + ecl_princ(ecl_make_fixnum(n), ECL_NIL); + ecl_princ_str(",", ECL_NIL); + ecl_princ(x, ECL_NIL); } -#define GET_DATA(r,v,data) { \ - cl_oparg ndx; \ - GET_OPARG(ndx, v); \ - r = data[ndx]; \ -} +#define GET_DATA(r,v,data) { \ + cl_oparg ndx; \ + GET_OPARG(ndx, v); \ + r = data[ndx]; \ + } static void disassemble_lambda(cl_object bytecodes) { - const cl_env_ptr env = ecl_process_env(); - cl_object *data; - cl_opcode *vector; - - ecl_bds_bind(env, @'*print-pretty*', ECL_NIL); - - /* Print required arguments */ - data = bytecodes->bytecodes.data->vector.self.t; - cl_print(1,bytecodes->bytecodes.data); - - /* Name of LAMBDA */ - print_arg("\nName:\t\t", bytecodes->bytecodes.name); - if (bytecodes->bytecodes.name == OBJNULL || - bytecodes->bytecodes.name == @'si::bytecodes') { - print_noarg("\nEvaluated form:"); - goto NO_ARGS; - } + const cl_env_ptr env = ecl_process_env(); + cl_object *data; + cl_opcode *vector; + + ecl_bds_bind(env, @'*print-pretty*', ECL_NIL); + + /* Print required arguments */ + data = bytecodes->bytecodes.data->vector.self.t; + cl_print(1,bytecodes->bytecodes.data); + + /* Name of LAMBDA */ + print_arg("\nName:\t\t", bytecodes->bytecodes.name); + if (bytecodes->bytecodes.name == OBJNULL || + bytecodes->bytecodes.name == @'si::bytecodes') { + print_noarg("\nEvaluated form:"); + goto NO_ARGS; + } NO_ARGS: - base = vector = (cl_opcode *)bytecodes->bytecodes.code; - disassemble(bytecodes, vector); + base = vector = (cl_opcode *)bytecodes->bytecodes.code; + disassemble(bytecodes, vector); - ecl_bds_unwind1(env); + ecl_bds_unwind1(env); } /* -------------------- DISASSEMBLER CORE -------------------- */ @@ -87,606 +82,606 @@ /* OP_FLET nfun{arg}, fun1{object} ... - Executes the enclosed code in a lexical enviroment extended with - the functions "fun1" ... "funn". + Executes the enclosed code in a lexical enviroment extended with + the functions "fun1" ... "funn". */ static cl_opcode * disassemble_flet(cl_object bytecodes, cl_opcode *vector) { - cl_index nfun; - cl_object *data = bytecodes->bytecodes.data->vector.self.t; - GET_OPARG(nfun, vector); - print_noarg("FLET"); - while (nfun--) { - cl_object fun; - GET_DATA(fun, vector, data); - print_arg("\n\tFLET\t", fun->bytecodes.name); - } - return vector; + cl_index nfun; + cl_object *data = bytecodes->bytecodes.data->vector.self.t; + GET_OPARG(nfun, vector); + print_noarg("FLET"); + while (nfun--) { + cl_object fun; + GET_DATA(fun, vector, data); + print_arg("\n\tFLET\t", fun->bytecodes.name); + } + return vector; } /* OP_LABELS nfun{arg}, fun1{object} ... - Executes the enclosed code in a lexical enviroment extended with - the functions "fun1" ... "funn". + Executes the enclosed code in a lexical enviroment extended with + the functions "fun1" ... "funn". */ static cl_opcode * disassemble_labels(cl_object bytecodes, cl_opcode *vector) { - cl_index nfun; - cl_object *data = bytecodes->bytecodes.data->vector.self.t; - GET_OPARG(nfun, vector); - print_noarg("LABELS"); - while (nfun--) { - cl_object fun; - GET_DATA(fun, vector, data); - print_arg("\n\tLABELS\t", fun->bytecodes.name); - } - return vector; + cl_index nfun; + cl_object *data = bytecodes->bytecodes.data->vector.self.t; + GET_OPARG(nfun, vector); + print_noarg("LABELS"); + while (nfun--) { + cl_object fun; + GET_DATA(fun, vector, data); + print_arg("\n\tLABELS\t", fun->bytecodes.name); + } + return vector; } /* OP_PROGV bindings{list} ... OP_EXIT - Execute the code enclosed with the special variables in BINDINGS - set to the values in the list which was passed in VALUES(0). + Execute the code enclosed with the special variables in BINDINGS + set to the values in the list which was passed in VALUES(0). */ static cl_opcode * disassemble_progv(cl_object bytecodes, cl_opcode *vector) { - print_noarg("PROGV"); - vector = disassemble(bytecodes, vector); - print_noarg("\t\t; progv"); - return vector; + print_noarg("PROGV"); + vector = disassemble(bytecodes, vector); + print_noarg("\t\t; progv"); + return vector; } /* OP_TAGBODY n{arg} label1 ... labeln -label1: + label1: ... -labeln: + labeln: ... OP_EXIT - High level construct for the TAGBODY form. + High level construct for the TAGBODY form. */ static cl_opcode * disassemble_tagbody(cl_object bytecodes, cl_opcode *vector) { - cl_index i, ntags; - cl_opcode *destination; - GET_OPARG(ntags, vector); - print_noarg("TAGBODY"); - for (i=0; ibytecodes.data->vector.self.t; - cl_object line_no; - - if (cl_fboundp(@'si::formatter-aux') != ECL_NIL) - line_format = make_constant_base_string("~%~4d\t"); - else - line_format = ECL_NIL; + const char *string; + cl_object o; + cl_fixnum n, m; + cl_object line_format; + cl_object *data = bytecodes->bytecodes.data->vector.self.t; + cl_object line_no; + + if (cl_fboundp(@'si::formatter-aux') != ECL_NIL) + line_format = make_constant_base_string("~%~4d\t"); + else + line_format = ECL_NIL; BEGIN: - if (1) { - line_no = ecl_make_fixnum(vector-base); - } else { - line_no = @'*'; - } - if (line_format != ECL_NIL) { - cl_format(3, ECL_T, line_format, line_no); - } else { - ecl_princ_char('\n', ECL_NIL); - ecl_princ(line_no, ECL_NIL); - ecl_princ_char('\t', ECL_NIL); - } - switch (GET_OPCODE(vector)) { - - /* OP_NOP - Sets VALUES(0) = NIL and NVALUES = 1 - */ - case OP_NOP: string = "NOP"; goto NOARG; - - case OP_INT: string = "QUOTE\t"; - GET_OPARG(n, vector); - goto OPARG; - - case OP_PINT: string = "PUSH\t"; - GET_OPARG(n, vector); - goto OPARG; - - /* OP_QUOTE - Sets VALUES(0) to an immediate value. - */ - case OP_QUOTE: string = "QUOTE\t"; - GET_DATA(o, vector, data); - goto ARG; - - /* OP_CSET n{arg} - Replace constant with a computed value - */ - case OP_CSET: string = "CSET\t"; - GET_OPARG(n, vector); - goto OPARG; - - /* OP_VAR n{arg} - Sets NVALUES=1 and VALUES(0) to the value of the n-th local. - */ - case OP_VAR: string = "VAR\t"; - GET_OPARG(n, vector); - goto OPARG; - - /* OP_VARS var{symbol} - Sets NVALUES=1 and VALUES(0) to the value of the symbol VAR. - VAR should be either a special variable or a constant. - */ - case OP_VARS: string = "VARS\t"; - GET_DATA(o, vector, data); - goto ARG; - - /* OP_PUSH - Pushes the object in VALUES(0). - */ - case OP_PUSH: string = "PUSH\tVALUES(0)"; - goto NOARG; - - case OP_VALUEREG0: string = "SET\tVALUES(0),REG0"; - goto NOARG; - - /* OP_PUSHV n{arg} - Pushes the value of the n-th local onto the stack. - */ - case OP_PUSHV: string = "PUSHV\t"; - GET_OPARG(n, vector); - goto OPARG; - - /* OP_PUSHVS var{symbol} - Pushes the value of the symbol VAR onto the stack. - VAR should be either a special variable or a constant. - */ - case OP_PUSHVS: string = "PUSHVS\t"; - GET_DATA(o, vector, data); - goto ARG; - - /* OP_PUSHQ value{object} - Pushes "value" onto the stack. - */ - case OP_PUSHQ: string = "PUSH\t'"; - GET_DATA(o, vector, data); - goto ARG; - - /* OP_PUSHVALUES - Pushes the values output by the last form, plus the number - of values. - */ - case OP_PUSHVALUES: string = "PUSH\tVALUES"; - goto NOARG; - /* OP_PUSHMOREVALUES - Adds more values to the ones pushed by OP_PUSHVALUES. - */ - case OP_PUSHMOREVALUES: string = "PUSH\tMORE VALUES"; - goto NOARG; - /* OP_POP - Pops a single value pushed by a OP_PUSH[V[S]] operator. - */ - case OP_POP: string = "POP"; - goto NOARG; - /* OP_POP1 - Pops a single value pushed by a OP_PUSH[V[S]] operator. - */ - case OP_POP1: string = "POP1"; - goto NOARG; - /* OP_POPVALUES - Pops all values pushed by a OP_PUSHVALUES operator. - */ - case OP_POPVALUES: string = "POP\tVALUES"; - goto NOARG; - - case OP_BLOCK: string = "BLOCK\t"; - GET_DATA(o, vector, data); - goto ARG; - case OP_CATCH: string = "CATCH\tREG0"; - goto NOARG; - case OP_DO: string = "BLOCK\t"; - o = ECL_NIL; - goto ARG; - case OP_FRAME: string = "FRAME\t"; - goto JMP; - - /* OP_CALL n{arg} - Calls the function in VALUES(0) with N arguments which - have been deposited in the stack. The output values - are left in VALUES(...) - */ - case OP_CALL: string = "CALL\t"; - GET_OPARG(n, vector); - goto OPARG; - - /* OP_CALLG n{arg}, name{arg} - Calls the function NAME with N arguments which have been - deposited in the stack. The output values are left in VALUES. - */ - case OP_CALLG: string = "CALLG\t"; - GET_OPARG(n, vector); - GET_DATA(o, vector, data); - goto OPARG_ARG; - - /* OP_FCALL n{arg} - Calls the function in the stack with N arguments which - have been also deposited in the stack. The output values - are left in VALUES(...) - */ - case OP_STEPCALL: - case OP_FCALL: string = "FCALL\t"; - GET_OPARG(n, vector); - goto OPARG; - - /* OP_MCALL - Similar to FCALL, but gets the number of arguments from - the stack (They all have been deposited by OP_PUSHVALUES) - */ - case OP_MCALL: string = "MCALL"; - goto NOARG; - - /* OP_POPREQ - Extracts next required argument. - */ - case OP_POPREQ: string = "POP\tREQ"; - goto NOARG; - /* OP_NOMORE - Ensure there are no more arguments. - */ - case OP_NOMORE: string = "NOMORE"; - goto NOARG; - /* OP_POPOPT - Extracts next optional argument. - */ - case OP_POPOPT: string = "POP\tOPT"; - goto NOARG; - /* OP_POPREST - Extracts list of remaining arguments. - */ - case OP_POPREST: string = "POP\tREST"; - goto NOARG; - /* OP_PUSHKEYS - Parses the keyword arguments - */ - case OP_PUSHKEYS: string = "PUSH\tKEYS "; - GET_DATA(o, vector, data); - goto ARG; - - /* OP_EXIT - Marks the end of a high level construct - */ - case OP_EXIT: print_noarg("EXIT"); - return vector; - /* OP_EXIT_FRAME - Marks the end of a high level construct (BLOCK, CATCH...) - */ - case OP_EXIT_FRAME: string = "EXIT\tFRAME"; - goto NOARG; - /* OP_EXIT_TAGBODY - Marks the end of a high level construct (TAGBODY) - */ - case OP_EXIT_TAGBODY: print_noarg("EXIT\tTAGBODY"); - return vector; - - case OP_FLET: vector = disassemble_flet(bytecodes, vector); - break; - case OP_LABELS: vector = disassemble_labels(bytecodes, vector); - break; - - /* OP_LFUNCTION name{symbol} - Extracts the function associated to a symbol. The function - may be defined in the global environment or in the local - environment. This last value takes precedence. - */ - case OP_LFUNCTION: string = "LOCFUNC\t"; - GET_OPARG(n, vector); - goto OPARG; - - /* OP_FUNCTION name{symbol} - Extracts the function associated to a symbol. The function - may be defined in the global environment or in the local - environment. This last value takes precedence. - */ - case OP_FUNCTION: string = "SYMFUNC\t"; - GET_DATA(o, vector, data); - goto ARG; - - /* OP_CLOSE name{arg} - Extracts the function associated to a symbol. The function - may be defined in the global environment or in the local - environment. This last value takes precedence. - */ - case OP_CLOSE: string = "CLOSE\t"; - GET_DATA(o, vector, data); - goto ARG; - - /* OP_GO n{arg}, tag-ndx{arg} - OP_QUOTE tag-name{symbol} - Jumps to the tag which is defined at the n-th position in - the lexical environment. TAG-NAME is kept for debugging - purposes. - */ - case OP_GO: string = "GO\t"; - GET_OPARG(n, vector); - GET_OPARG(m, vector); - o = ecl_make_fixnum(m); - goto OPARG_ARG; - - /* OP_RETURN n{arg} - Returns from the block whose record in the lexical environment - occuppies the n-th position. - */ - case OP_RETURN: string = "RETFROM"; - GET_OPARG(n, vector); - goto OPARG; - - /* OP_THROW - Jumps to an enclosing CATCH form whose tag matches the one - of the THROW. The tag is taken from the stack, while the - output values are left in VALUES(...). - */ - case OP_THROW: string = "THROW"; - goto NOARG; - - /* OP_JMP label{arg} - OP_JNIL label{arg} - OP_JT label{arg} - OP_JEQ label{arg}, value{object} - OP_JNEQ label{arg}, value{object} - Direct or conditional jumps. The conditional jumps are made - comparing with the value of VALUES(0). - */ - case OP_JMP: string = "JMP\t"; - goto JMP; - case OP_JNIL: string = "JNIL\t"; - goto JMP; - case OP_JT: string = "JT\t"; - JMP: { GET_OPARG(m, vector); - n = vector + m - OPARG_SIZE - base; - goto OPARG; - } - case OP_JEQL: string = "JEQL\t"; - goto JEQL; - case OP_JNEQL: string = "JNEQL\t"; - JEQL: { GET_DATA(o, vector, data); - GET_OPARG(m, vector); - n = vector + m - OPARG_SIZE - base; - goto OPARG_ARG; - } - case OP_NOT: string = "NOT"; - goto NOARG; - - /* OP_UNBIND n{arg} - Undo "n" bindings of lexical variables. - */ - case OP_UNBIND: string = "UNBIND\t"; - GET_OPARG(n, vector); - goto OPARG; - /* OP_UNBINDS n{arg} - Undo "n" bindings of special variables. - */ - case OP_UNBINDS: string = "UNBINDS\t"; - GET_OPARG(n, vector); - goto OPARG; - /* OP_BIND name{symbol} - OP_PBIND name{symbol} - OP_BINDS name{symbol} - OP_PBINDS name{symbol} - Binds a lexical or special variable to the either the - value of VALUES(0), to the first value of the stack, or - to the n-th value of VALUES(...). - */ - case OP_BIND: string = "BIND\t"; - GET_DATA(o, vector, data); - goto ARG; - case OP_PBIND: string = "PBIND\t"; - GET_DATA(o, vector, data); - goto ARG; - case OP_VBIND: string = "VBIND\t"; - GET_OPARG(n, vector); - GET_DATA(o, vector, data); - goto OPARG_ARG; - case OP_BINDS: string = "BINDS\t"; - GET_DATA(o, vector, data); - goto ARG; - case OP_PBINDS: string = "PBINDS\t"; - GET_DATA(o, vector, data); - goto ARG; - case OP_VBINDS: string = "VBINDS\t"; - GET_OPARG(n, vector); - GET_DATA(o, vector, data); - goto OPARG_ARG; - /* OP_SETQ n{arg} - OP_PSETQ n{arg} - OP_SETQS var-name{symbol} - OP_PSETQS var-name{symbol} - Sets either the n-th local or a special variable VAR-NAME, - to either the value in VALUES(0) (OP_SETQ[S]) or to the - first value on the stack (OP_PSETQ[S]). - */ - case OP_SETQ: string = "SETQ\t"; - GET_OPARG(n, vector); - goto OPARG; - case OP_PSETQ: string = "PSETQ\t"; - GET_OPARG(n, vector); - goto OPARG; - case OP_VSETQ: string = "VSETQ\t"; - GET_OPARG(m, vector); - o = ecl_make_fixnum(m); - GET_OPARG(n, vector); - goto OPARG_ARG; - case OP_SETQS: string = "SETQS\t"; - GET_DATA(o, vector, data); - goto ARG; - case OP_PSETQS: string = "PSETQS\t"; - GET_DATA(o, vector, data); - goto ARG; - case OP_VSETQS: string = "VSETQS\t"; - GET_DATA(o, vector, data); - GET_OPARG(n, vector); - goto OPARG_ARG; - - case OP_PROGV: vector = disassemble_progv(bytecodes, vector); - break; - case OP_EXIT_PROGV: print_noarg("PROGV\tEXIT"); - return vector; - - /* OP_VALUES n{arg} - Pop N values from the stack and store them in VALUES(...) - */ - case OP_VALUES: string = "VALUES\t"; - GET_OPARG(n, vector); - goto OPARG; - /* OP_NTHVAL - Set VALUES(0) to the N-th value of the VALUES(...) list. - The index N-th is extracted from the top of the stack. - */ - case OP_NTHVAL: string = "NTHVAL\t"; - goto NOARG; - case OP_TAGBODY: vector = disassemble_tagbody(bytecodes, vector); - break; - case OP_PROTECT: string = "PROTECT\t"; - goto JMP; - case OP_PROTECT_NORMAL: string = "PROTECT\tNORMAL"; - goto NOARG; - case OP_PROTECT_EXIT: string = "PROTECT\tEXIT"; - goto NOARG; - case OP_NIL: string = "QUOTE\tNIL"; - goto NOARG; - case OP_PUSHNIL: string = "PUSH\t'NIL"; - goto NOARG; - case OP_STEPIN: string = "STEP\tIN,"; - GET_DATA(o, vector, data); - goto ARG; - case OP_STEPOUT: string = "STEP\tOUT"; - goto NOARG; - - case OP_CONS: string = "CONS"; goto NOARG; - case OP_ENDP: string = "ENDP\tREG0"; goto NOARG; - case OP_CAR: string = "CAR\tREG0"; goto NOARG; - case OP_CDR: string = "CDR\tREG0"; goto NOARG; - case OP_LIST: string = "LIST\t"; - GET_OPARG(n, vector); - goto OPARG; - case OP_LISTA: string = "LIST*\t"; - GET_OPARG(n, vector); - goto OPARG; - case OP_CALLG1: string = "CALLG1\t"; - GET_DATA(o, vector, data); - goto ARG; - case OP_CALLG2: string = "CALLG2\t"; - GET_DATA(o, vector, data); - goto ARG; - - default: - FEerror("Unknown code ~S", 1, ecl_make_fixnum(*(vector-1))); - return vector; - NOARG: print_noarg(string); - break; - ARG: print_noarg(string); - @prin1(1, o); - break; - OPARG: print_oparg(string, n); - break; - OPARG_ARG: print_oparg_arg(string, n, o); - break; - } - goto BEGIN; + if (1) { + line_no = ecl_make_fixnum(vector-base); + } else { + line_no = @'*'; + } + if (line_format != ECL_NIL) { + cl_format(3, ECL_T, line_format, line_no); + } else { + ecl_princ_char('\n', ECL_NIL); + ecl_princ(line_no, ECL_NIL); + ecl_princ_char('\t', ECL_NIL); + } + switch (GET_OPCODE(vector)) { + + /* OP_NOP + Sets VALUES(0) = NIL and NVALUES = 1 + */ + case OP_NOP: string = "NOP"; goto NOARG; + + case OP_INT: string = "QUOTE\t"; + GET_OPARG(n, vector); + goto OPARG; + + case OP_PINT: string = "PUSH\t"; + GET_OPARG(n, vector); + goto OPARG; + + /* OP_QUOTE + Sets VALUES(0) to an immediate value. + */ + case OP_QUOTE: string = "QUOTE\t"; + GET_DATA(o, vector, data); + goto ARG; + + /* OP_CSET n{arg} + Replace constant with a computed value + */ + case OP_CSET: string = "CSET\t"; + GET_OPARG(n, vector); + goto OPARG; + + /* OP_VAR n{arg} + Sets NVALUES=1 and VALUES(0) to the value of the n-th local. + */ + case OP_VAR: string = "VAR\t"; + GET_OPARG(n, vector); + goto OPARG; + + /* OP_VARS var{symbol} + Sets NVALUES=1 and VALUES(0) to the value of the symbol VAR. + VAR should be either a special variable or a constant. + */ + case OP_VARS: string = "VARS\t"; + GET_DATA(o, vector, data); + goto ARG; + + /* OP_PUSH + Pushes the object in VALUES(0). + */ + case OP_PUSH: string = "PUSH\tVALUES(0)"; + goto NOARG; + + case OP_VALUEREG0: string = "SET\tVALUES(0),REG0"; + goto NOARG; + + /* OP_PUSHV n{arg} + Pushes the value of the n-th local onto the stack. + */ + case OP_PUSHV: string = "PUSHV\t"; + GET_OPARG(n, vector); + goto OPARG; + + /* OP_PUSHVS var{symbol} + Pushes the value of the symbol VAR onto the stack. + VAR should be either a special variable or a constant. + */ + case OP_PUSHVS: string = "PUSHVS\t"; + GET_DATA(o, vector, data); + goto ARG; + + /* OP_PUSHQ value{object} + Pushes "value" onto the stack. + */ + case OP_PUSHQ: string = "PUSH\t'"; + GET_DATA(o, vector, data); + goto ARG; + + /* OP_PUSHVALUES + Pushes the values output by the last form, plus the number + of values. + */ + case OP_PUSHVALUES: string = "PUSH\tVALUES"; + goto NOARG; + /* OP_PUSHMOREVALUES + Adds more values to the ones pushed by OP_PUSHVALUES. + */ + case OP_PUSHMOREVALUES: string = "PUSH\tMORE VALUES"; + goto NOARG; + /* OP_POP + Pops a single value pushed by a OP_PUSH[V[S]] operator. + */ + case OP_POP: string = "POP"; + goto NOARG; + /* OP_POP1 + Pops a single value pushed by a OP_PUSH[V[S]] operator. + */ + case OP_POP1: string = "POP1"; + goto NOARG; + /* OP_POPVALUES + Pops all values pushed by a OP_PUSHVALUES operator. + */ + case OP_POPVALUES: string = "POP\tVALUES"; + goto NOARG; + + case OP_BLOCK: string = "BLOCK\t"; + GET_DATA(o, vector, data); + goto ARG; + case OP_CATCH: string = "CATCH\tREG0"; + goto NOARG; + case OP_DO: string = "BLOCK\t"; + o = ECL_NIL; + goto ARG; + case OP_FRAME: string = "FRAME\t"; + goto JMP; + + /* OP_CALL n{arg} + Calls the function in VALUES(0) with N arguments which + have been deposited in the stack. The output values + are left in VALUES(...) + */ + case OP_CALL: string = "CALL\t"; + GET_OPARG(n, vector); + goto OPARG; + + /* OP_CALLG n{arg}, name{arg} + Calls the function NAME with N arguments which have been + deposited in the stack. The output values are left in VALUES. + */ + case OP_CALLG: string = "CALLG\t"; + GET_OPARG(n, vector); + GET_DATA(o, vector, data); + goto OPARG_ARG; + + /* OP_FCALL n{arg} + Calls the function in the stack with N arguments which + have been also deposited in the stack. The output values + are left in VALUES(...) + */ + case OP_STEPCALL: + case OP_FCALL: string = "FCALL\t"; + GET_OPARG(n, vector); + goto OPARG; + + /* OP_MCALL + Similar to FCALL, but gets the number of arguments from + the stack (They all have been deposited by OP_PUSHVALUES) + */ + case OP_MCALL: string = "MCALL"; + goto NOARG; + + /* OP_POPREQ + Extracts next required argument. + */ + case OP_POPREQ: string = "POP\tREQ"; + goto NOARG; + /* OP_NOMORE + Ensure there are no more arguments. + */ + case OP_NOMORE: string = "NOMORE"; + goto NOARG; + /* OP_POPOPT + Extracts next optional argument. + */ + case OP_POPOPT: string = "POP\tOPT"; + goto NOARG; + /* OP_POPREST + Extracts list of remaining arguments. + */ + case OP_POPREST: string = "POP\tREST"; + goto NOARG; + /* OP_PUSHKEYS + Parses the keyword arguments + */ + case OP_PUSHKEYS: string = "PUSH\tKEYS "; + GET_DATA(o, vector, data); + goto ARG; + + /* OP_EXIT + Marks the end of a high level construct + */ + case OP_EXIT: print_noarg("EXIT"); + return vector; + /* OP_EXIT_FRAME + Marks the end of a high level construct (BLOCK, CATCH...) + */ + case OP_EXIT_FRAME: string = "EXIT\tFRAME"; + goto NOARG; + /* OP_EXIT_TAGBODY + Marks the end of a high level construct (TAGBODY) + */ + case OP_EXIT_TAGBODY: print_noarg("EXIT\tTAGBODY"); + return vector; + + case OP_FLET: vector = disassemble_flet(bytecodes, vector); + break; + case OP_LABELS: vector = disassemble_labels(bytecodes, vector); + break; + + /* OP_LFUNCTION name{symbol} + Extracts the function associated to a symbol. The function + may be defined in the global environment or in the local + environment. This last value takes precedence. + */ + case OP_LFUNCTION: string = "LOCFUNC\t"; + GET_OPARG(n, vector); + goto OPARG; + + /* OP_FUNCTION name{symbol} + Extracts the function associated to a symbol. The function + may be defined in the global environment or in the local + environment. This last value takes precedence. + */ + case OP_FUNCTION: string = "SYMFUNC\t"; + GET_DATA(o, vector, data); + goto ARG; + + /* OP_CLOSE name{arg} + Extracts the function associated to a symbol. The function + may be defined in the global environment or in the local + environment. This last value takes precedence. + */ + case OP_CLOSE: string = "CLOSE\t"; + GET_DATA(o, vector, data); + goto ARG; + + /* OP_GO n{arg}, tag-ndx{arg} + OP_QUOTE tag-name{symbol} + Jumps to the tag which is defined at the n-th position in + the lexical environment. TAG-NAME is kept for debugging + purposes. + */ + case OP_GO: string = "GO\t"; + GET_OPARG(n, vector); + GET_OPARG(m, vector); + o = ecl_make_fixnum(m); + goto OPARG_ARG; + + /* OP_RETURN n{arg} + Returns from the block whose record in the lexical environment + occuppies the n-th position. + */ + case OP_RETURN: string = "RETFROM"; + GET_OPARG(n, vector); + goto OPARG; + + /* OP_THROW + Jumps to an enclosing CATCH form whose tag matches the one + of the THROW. The tag is taken from the stack, while the + output values are left in VALUES(...). + */ + case OP_THROW: string = "THROW"; + goto NOARG; + + /* OP_JMP label{arg} + OP_JNIL label{arg} + OP_JT label{arg} + OP_JEQ label{arg}, value{object} + OP_JNEQ label{arg}, value{object} + Direct or conditional jumps. The conditional jumps are made + comparing with the value of VALUES(0). + */ + case OP_JMP: string = "JMP\t"; + goto JMP; + case OP_JNIL: string = "JNIL\t"; + goto JMP; + case OP_JT: string = "JT\t"; + JMP: { GET_OPARG(m, vector); + n = vector + m - OPARG_SIZE - base; + goto OPARG; + } + case OP_JEQL: string = "JEQL\t"; + goto JEQL; + case OP_JNEQL: string = "JNEQL\t"; + JEQL: { GET_DATA(o, vector, data); + GET_OPARG(m, vector); + n = vector + m - OPARG_SIZE - base; + goto OPARG_ARG; + } + case OP_NOT: string = "NOT"; + goto NOARG; + + /* OP_UNBIND n{arg} + Undo "n" bindings of lexical variables. + */ + case OP_UNBIND: string = "UNBIND\t"; + GET_OPARG(n, vector); + goto OPARG; + /* OP_UNBINDS n{arg} + Undo "n" bindings of special variables. + */ + case OP_UNBINDS: string = "UNBINDS\t"; + GET_OPARG(n, vector); + goto OPARG; + /* OP_BIND name{symbol} + OP_PBIND name{symbol} + OP_BINDS name{symbol} + OP_PBINDS name{symbol} + Binds a lexical or special variable to the either the + value of VALUES(0), to the first value of the stack, or + to the n-th value of VALUES(...). + */ + case OP_BIND: string = "BIND\t"; + GET_DATA(o, vector, data); + goto ARG; + case OP_PBIND: string = "PBIND\t"; + GET_DATA(o, vector, data); + goto ARG; + case OP_VBIND: string = "VBIND\t"; + GET_OPARG(n, vector); + GET_DATA(o, vector, data); + goto OPARG_ARG; + case OP_BINDS: string = "BINDS\t"; + GET_DATA(o, vector, data); + goto ARG; + case OP_PBINDS: string = "PBINDS\t"; + GET_DATA(o, vector, data); + goto ARG; + case OP_VBINDS: string = "VBINDS\t"; + GET_OPARG(n, vector); + GET_DATA(o, vector, data); + goto OPARG_ARG; + /* OP_SETQ n{arg} + OP_PSETQ n{arg} + OP_SETQS var-name{symbol} + OP_PSETQS var-name{symbol} + Sets either the n-th local or a special variable VAR-NAME, + to either the value in VALUES(0) (OP_SETQ[S]) or to the + first value on the stack (OP_PSETQ[S]). + */ + case OP_SETQ: string = "SETQ\t"; + GET_OPARG(n, vector); + goto OPARG; + case OP_PSETQ: string = "PSETQ\t"; + GET_OPARG(n, vector); + goto OPARG; + case OP_VSETQ: string = "VSETQ\t"; + GET_OPARG(m, vector); + o = ecl_make_fixnum(m); + GET_OPARG(n, vector); + goto OPARG_ARG; + case OP_SETQS: string = "SETQS\t"; + GET_DATA(o, vector, data); + goto ARG; + case OP_PSETQS: string = "PSETQS\t"; + GET_DATA(o, vector, data); + goto ARG; + case OP_VSETQS: string = "VSETQS\t"; + GET_DATA(o, vector, data); + GET_OPARG(n, vector); + goto OPARG_ARG; + + case OP_PROGV: vector = disassemble_progv(bytecodes, vector); + break; + case OP_EXIT_PROGV: print_noarg("PROGV\tEXIT"); + return vector; + + /* OP_VALUES n{arg} + Pop N values from the stack and store them in VALUES(...) + */ + case OP_VALUES: string = "VALUES\t"; + GET_OPARG(n, vector); + goto OPARG; + /* OP_NTHVAL + Set VALUES(0) to the N-th value of the VALUES(...) list. + The index N-th is extracted from the top of the stack. + */ + case OP_NTHVAL: string = "NTHVAL\t"; + goto NOARG; + case OP_TAGBODY: vector = disassemble_tagbody(bytecodes, vector); + break; + case OP_PROTECT: string = "PROTECT\t"; + goto JMP; + case OP_PROTECT_NORMAL: string = "PROTECT\tNORMAL"; + goto NOARG; + case OP_PROTECT_EXIT: string = "PROTECT\tEXIT"; + goto NOARG; + case OP_NIL: string = "QUOTE\tNIL"; + goto NOARG; + case OP_PUSHNIL: string = "PUSH\t'NIL"; + goto NOARG; + case OP_STEPIN: string = "STEP\tIN,"; + GET_DATA(o, vector, data); + goto ARG; + case OP_STEPOUT: string = "STEP\tOUT"; + goto NOARG; + + case OP_CONS: string = "CONS"; goto NOARG; + case OP_ENDP: string = "ENDP\tREG0"; goto NOARG; + case OP_CAR: string = "CAR\tREG0"; goto NOARG; + case OP_CDR: string = "CDR\tREG0"; goto NOARG; + case OP_LIST: string = "LIST\t"; + GET_OPARG(n, vector); + goto OPARG; + case OP_LISTA: string = "LIST*\t"; + GET_OPARG(n, vector); + goto OPARG; + case OP_CALLG1: string = "CALLG1\t"; + GET_DATA(o, vector, data); + goto ARG; + case OP_CALLG2: string = "CALLG2\t"; + GET_DATA(o, vector, data); + goto ARG; + + default: + FEerror("Unknown code ~S", 1, ecl_make_fixnum(*(vector-1))); + return vector; + NOARG: print_noarg(string); + break; + ARG: print_noarg(string); + @prin1(1, o); + break; + OPARG: print_oparg(string, n); + break; + OPARG_ARG: print_oparg_arg(string, n, o); + break; + } + goto BEGIN; } cl_object si_bc_disassemble(cl_object v) { - if (ecl_t_of(v) == t_bclosure) { - v = v->bclosure.code; - } - if (ecl_t_of(v) == t_bytecodes) { - disassemble_lambda(v); - @(return v) - } - @(return ECL_NIL) + if (ecl_t_of(v) == t_bclosure) { + v = v->bclosure.code; + } + if (ecl_t_of(v) == t_bytecodes) { + disassemble_lambda(v); + @(return v); + } + @(return ECL_NIL); } cl_object si_bc_split(cl_object b) { - cl_object vector, data, name, lex = ECL_NIL; + cl_object vector, data, name, lex = ECL_NIL; - if (ecl_t_of(b) == t_bclosure) { - b = b->bclosure.code; - lex = b->bclosure.lex; - } - if (ecl_t_of(b) != t_bytecodes) { - vector = ECL_NIL; - data = ECL_NIL; - name = ECL_NIL; - } else { - vector = ecl_alloc_simple_vector(b->bytecodes.code_size * - sizeof(cl_opcode), ecl_aet_b8); - vector->vector.self.b8 = (uint8_t*)b->bytecodes.code; - data = cl_copy_seq(b->bytecodes.data); - name = b->bytecodes.name; - } - @(return lex vector data name) + if (ecl_t_of(b) == t_bclosure) { + b = b->bclosure.code; + lex = b->bclosure.lex; + } + if (ecl_t_of(b) != t_bytecodes) { + vector = ECL_NIL; + data = ECL_NIL; + name = ECL_NIL; + } else { + vector = ecl_alloc_simple_vector(b->bytecodes.code_size * + sizeof(cl_opcode), ecl_aet_b8); + vector->vector.self.b8 = (uint8_t*)b->bytecodes.code; + data = cl_copy_seq(b->bytecodes.data); + name = b->bytecodes.name; + } + @(return lex vector data name); } cl_object si_bc_join(cl_object lex, cl_object code, cl_object data, cl_object name) { - cl_object output; - if (lex != ECL_NIL) { - output = ecl_alloc_object(t_bclosure); - output->bclosure.code = si_bc_join(ECL_NIL, code, data, name); - output->bclosure.lex = lex; - output->bclosure.entry = _ecl_bclosure_dispatch_vararg; - } else { - /* Ensure minimal sanity of data */ - unlikely_if (!ECL_VECTORP(code) || - (code->vector.elttype != ecl_aet_b8)) { - FEwrong_type_nth_arg(@[si::bc-join], - 0, code, - cl_list(2, - @'simple-array', - @'ext::byte8')); - } - unlikely_if (!ECL_VECTORP(code) || - (data->vector.elttype != ecl_aet_object)) { - FEwrong_type_nth_arg(@[si::bc-join], - 0, code, - cl_list(2, - @'simple-array', - ECL_T)); - } - /* Duplicate the vectors and steal their data pointers */ - code = cl_copy_seq(code); - data = cl_copy_seq(data); - output = ecl_alloc_object(t_bytecodes); - output->bytecodes.name = ECL_NIL; - output->bytecodes.definition = ECL_NIL; - output->bytecodes.entry = _ecl_bytecodes_dispatch_vararg; - output->bytecodes.code_size = code->vector.fillp / sizeof(cl_opcode); - output->bytecodes.code = (void*)code->vector.self.b8; - output->bytecodes.data = data; - output->bytecodes.file = ECL_NIL; - output->bytecodes.file_position = ECL_NIL; - } - @(return output) + cl_object output; + if (lex != ECL_NIL) { + output = ecl_alloc_object(t_bclosure); + output->bclosure.code = si_bc_join(ECL_NIL, code, data, name); + output->bclosure.lex = lex; + output->bclosure.entry = _ecl_bclosure_dispatch_vararg; + } else { + /* Ensure minimal sanity of data */ + unlikely_if (!ECL_VECTORP(code) || + (code->vector.elttype != ecl_aet_b8)) { + FEwrong_type_nth_arg(@[si::bc-join], + 0, code, + cl_list(2, + @'simple-array', + @'ext::byte8')); + } + unlikely_if (!ECL_VECTORP(code) || + (data->vector.elttype != ecl_aet_object)) { + FEwrong_type_nth_arg(@[si::bc-join], + 0, code, + cl_list(2, + @'simple-array', + ECL_T)); + } + /* Duplicate the vectors and steal their data pointers */ + code = cl_copy_seq(code); + data = cl_copy_seq(data); + output = ecl_alloc_object(t_bytecodes); + output->bytecodes.name = ECL_NIL; + output->bytecodes.definition = ECL_NIL; + output->bytecodes.entry = _ecl_bytecodes_dispatch_vararg; + output->bytecodes.code_size = code->vector.fillp / sizeof(cl_opcode); + output->bytecodes.code = (void*)code->vector.self.b8; + output->bytecodes.data = data; + output->bytecodes.file = ECL_NIL; + output->bytecodes.file_position = ECL_NIL; + } + @(return output); } diff -Nru ecl-16.1.2/src/c/dosdummy.d ecl-16.1.3+ds/src/c/dosdummy.d --- ecl-16.1.2/src/c/dosdummy.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/dosdummy.d 1970-01-01 00:00:00.000000000 +0000 @@ -1,12 +0,0 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ - -#define DUM(a) int a(int n) {} - -DUM(alarm) -DUM(getpid) -DUM(getuid) -DUM(popen) -DUM(pclose) -DUM(getpwuid) -DUM(getpwnam) diff -Nru ecl-16.1.2/src/c/dostimes.d ecl-16.1.3+ds/src/c/dostimes.d --- ecl-16.1.2/src/c/dostimes.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/dostimes.d 1970-01-01 00:00:00.000000000 +0000 @@ -1,21 +0,0 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ - -#include -#include - -#ifdef __ZTC__ -#define HZ 100 -#endif - -times(struct tms *x) -{ int hz; - struct rusage ru; - getrusage(RUSAGE_SELF,&ru); - hz = ru.ru_utime.tv_sec * HZ + - (ru.ru_utime.tv_usec * HZ)/1000000; - x->tms_utime = hz; - x->tms_stime = hz; - return 0; -} - diff -Nru ecl-16.1.2/src/c/dpp.c ecl-16.1.3+ds/src/c/dpp.c --- ecl-16.1.2/src/c/dpp.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/dpp.c 2016-12-19 10:25:00.000000000 +0000 @@ -1,82 +1,86 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - dpp.c -- Defun preprocessor. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ - + * dpp.c - defun preprocessor + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ /* - Usage: - dpp [in-file [out-file]] - - The file named in-file is preprocessed and the output will be - written to the file whose name is out-file. If in-file is "-" - program is read from standard input, while if out-file is "-" - C-program is written to standard output. - - - The function definition: - - @(defun name ({var}* - [&optional {var | (var [initform [svar]])}*] - [&rest var] - [&key {var | - ({var | (keyword var)} [initform [svar]])}* - [&allow_other_keys]] - [&aux {var | (var [initform])}*]) - - C-declaration - - @ - - C-body - - @) - - name can be either an identifier or a full C procedure header - enclosed in quotes ('). - - &optional may be abbreviated as &o. - &rest may be abbreviated as &r. - &key may be abbreviated as &k. - &allow_other_keys may be abbreviated as &aok. - &aux may be abbreviated as &a. - - Each variable becomes a C variable. - - Each supplied-p parameter becomes a boolean C variable. - - Initforms are C expressions. - If an expression contains non-alphanumeric characters, - it should be surrounded by backquotes (`). - - - Function return: - - @(return {form}*) - -*/ + * Usage: + * dpp [in-file [out-file]] + * + * The file named in-file is preprocessed and the output will be + * written to the file whose name is out-file. If in-file is "-" + * program is read from standard input, while if out-file is "-" + * C-program is written to standard output. + * + * + * The function definition: + * + * @(defun name ({var}* + * [&optional {var | (var [initform [svar]])}*] + * [&rest var] + * [&key {var | + * ({var | (keyword var)} [initform [svar]])}* + * [&allow_other_keys]] + * [&aux {var | (var [initform])}*]) + * + * C-declaration + * + * @ { + * + * C-body + * + * } @) + * + * name can be either an identifier or a full C procedure header + * enclosed in quotes ('). + * + * &optional may be abbreviated as &o. + * &rest may be abbreviated as &r. + * &key may be abbreviated as &k. + * &allow_other_keys may be abbreviated as &aok. + * &aux may be abbreviated as &a. + * + * Each variable becomes a C variable. + * + * Each supplied-p parameter becomes a boolean C variable. + * + * Initforms are C expressions. + * If an expression contains non-alphanumeric characters, + * it should be surrounded by backquotes (`). + * + * + * Function return: + * + * @(return {form}*); + * + * Return function expands into a lexical block {}, so if it's + * used inside IF/ELSE, then it should be enclosed, even if we + * use sole @(return);, because ";" will be treated as the next + * instruction. + * + */ #include #include #include #include +#if defined(_MSC_VER) && (_MSC_VER >= 1800) +#include +#endif + #define DPP #include +#include #include "symbols_list2.h" /* #define POOLSIZE 2048 */ @@ -91,8 +95,11 @@ #define FALSE 0 #ifndef __cplusplus +#if ! ( defined(__bool_true_false_are_defined) \ + &&__bool_true_false_are_defined ) typedef int bool; #endif +#endif FILE *in, *out; @@ -115,9 +122,9 @@ int the_env_defined = 0; struct optional { - char *o_var; - char *o_init; - char *o_svar; + char *o_var; + char *o_init; + char *o_svar; } optional[MAXOPT]; int nopt; @@ -126,17 +133,17 @@ bool key_flag; struct keyword { - char *k_key; - char *k_var; - char *k_init; - char *k_svar; + char *k_key; + char *k_var; + char *k_init; + char *k_svar; } keyword[MAXKEY]; int nkey; bool allow_other_keys_flag; struct aux { - char *a_var; - char *a_init; + char *a_var; + char *a_init; } aux[MAXAUX]; int naux; @@ -146,511 +153,511 @@ void put_lineno(void) { - static int flag = 0; - if (flag) - fprintf(out, "#line %d\n", lineno); - else { - flag++; - fprintf(out, "#line %d \"%s\"\n", lineno, filename); - } + static int flag = 0; + if (flag) + fprintf(out, "#line %d\n", lineno); + else { + flag++; + fprintf(out, "#line %d \"%s\"\n", lineno, filename); + } } void error(char *s) { - printf("Error in line %d: %s.\n", lineno, s); - exit(1); + printf("Error in line %d: %s.\n", lineno, s); + exit(1); } void error_symbol(char *s) { - printf("Error in line %d: illegal symbol %s.\n", lineno, s); - exit(1); + printf("Error in line %d: illegal symbol %s.\n", lineno, s); + exit(1); } int readc(void) { - int c; + int c; - c = getc(in); - if (feof(in)) { - if (function != NULL) - error("unexpected end of file"); - exit(0); - } - if (c == '\n') { - lineno++; - tab = 0; - } else if (c == '\t') - tab++; - return(c); + c = getc(in); + if (feof(in)) { + if (function != NULL) + error("unexpected end of file"); + exit(0); + } + if (c == '\n') { + lineno++; + tab = 0; + } else if (c == '\t') + tab++; + return(c); } int nextc(void) { - int c; + int c; - while (isspace(c = readc())) - ; - return(c); + while (isspace(c = readc())) + ; + return(c); } void unreadc(int c) { - if (c == '\n') - --lineno; - else if (c == '\t') - --tab; - ungetc(c, in); + if (c == '\n') + --lineno; + else if (c == '\t') + --tab; + ungetc(c, in); } void put_tabs(int n) { - put_lineno(); - while (n--) - putc('\t', out); + put_lineno(); + while (n--) + putc('\t', out); } void pushc(int c) { - if (poolp >= &pool[POOLSIZE]) - error("buffer pool overflow"); - *poolp++ = c; + if (poolp >= &pool[POOLSIZE]) + error("buffer pool overflow"); + *poolp++ = c; } void pushstr(const char *s) { - while (*s) - pushc(*(s++)); + while (*s) + pushc(*(s++)); } int search_keyword(const char *name) { - int i; - char c[256]; + int i; + char c[256]; - for (i=0; name[i] && i<255; i++) - if (name[i] == '_') - c[i] = '-'; - else - c[i] = name[i]; - if (i == 255) - error("Too long keyword"); - c[i] = 0; - for (i = 0; cl_symbols[i].name != NULL; i++) { - if (cl_symbols[i].name[0] == ':') - if (!strcasecmp(c, cl_symbols[i].name+1)) - return i; - } - printf("Keyword not found: %s.\n", c); - return 0; + for (i=0; name[i] && i<255; i++) + if (name[i] == '_') + c[i] = '-'; + else + c[i] = name[i]; + if (i == 255) + error("Too long keyword"); + c[i] = 0; + for (i = 0; cl_symbols[i].name != NULL; i++) { + if (cl_symbols[i].name[0] == ':') + if (!strcasecmp(c, cl_symbols[i].name+1)) + return i; + } + printf("Keyword not found: %s.\n", c); + return 0; } char * search_symbol(char *name, int *symbol_code, int code) { - int i; - for (i = 0; cl_symbols[i].name != NULL; i++) { - if (!strcasecmp(name, cl_symbols[i].name)) { - name = poolp; - if (code) { - pushstr("ecl_make_fixnum(/*"); - pushstr(cl_symbols[i].name); - pushstr("*/"); - if (i >= 1000) - pushc((i / 1000) % 10 + '0'); - if (i >= 100) - pushc((i / 100) % 10 + '0'); - if (i >= 10) - pushc((i / 10) % 10 + '0'); - pushc(i % 10 + '0'); - pushstr(")"); - pushc(0); - } else if (i == 0) { - pushstr("ECL_NIL"); - pushc(0); - } else { - pushstr("ECL_SYM(\""); - pushstr(cl_symbols[i].name); - pushstr("\","); - if (i >= 1000) - pushc((i / 1000) % 10 + '0'); - if (i >= 100) - pushc((i / 100) % 10 + '0'); - if (i >= 10) - pushc((i / 10) % 10 + '0'); - pushc(i % 10 + '0'); - pushstr(")"); - pushc(0); - } - if (symbol_code) - *symbol_code = i; - return name; - } - } - return NULL; + int i; + for (i = 0; cl_symbols[i].name != NULL; i++) { + if (!strcasecmp(name, cl_symbols[i].name)) { + name = poolp; + if (code) { + pushstr("ecl_make_fixnum(/*"); + pushstr(cl_symbols[i].name); + pushstr("*/"); + if (i >= 1000) + pushc((i / 1000) % 10 + '0'); + if (i >= 100) + pushc((i / 100) % 10 + '0'); + if (i >= 10) + pushc((i / 10) % 10 + '0'); + pushc(i % 10 + '0'); + pushstr(")"); + pushc(0); + } else if (i == 0) { + pushstr("ECL_NIL"); + pushc(0); + } else { + pushstr("ECL_SYM(\""); + pushstr(cl_symbols[i].name); + pushstr("\","); + if (i >= 1000) + pushc((i / 1000) % 10 + '0'); + if (i >= 100) + pushc((i / 100) % 10 + '0'); + if (i >= 10) + pushc((i / 10) % 10 + '0'); + pushc(i % 10 + '0'); + pushstr(")"); + pushc(0); + } + if (symbol_code) + *symbol_code = i; + return name; + } + } + return NULL; } char * read_symbol(int code) { - char c, *name = poolp; - char end = code? ']' : '\''; + char c, *name = poolp; + char end = code? ']' : '\''; - c = readc(); - while (c != end) { - if (c == '_') c = '-'; - pushc(c); - c = readc(); - } - pushc(0); + c = readc(); + while (c != end) { + if (c == '_') c = '-'; + pushc(c); + c = readc(); + } + pushc(0); - name = search_symbol(poolp = name, 0, code); - if (name == NULL) { - name = poolp; - printf("\nUnknown symbol: %s\n", name); - pushstr("unknown"); - } - return name; + name = search_symbol(poolp = name, 0, code); + if (name == NULL) { + name = poolp; + printf("\nUnknown symbol: %s\n", name); + pushstr("unknown"); + } + return name; } char * search_function(char *name) { - int i; - for (i = 0; cl_symbols[i].name != NULL; i++) { - if (cl_symbols[i].translation != NULL && - !strcasecmp(name, cl_symbols[i].name)) { - name = poolp; - pushstr(cl_symbols[i].translation); - pushc(0); - return name; - } - } - return name; + int i; + for (i = 0; cl_symbols[i].name != NULL; i++) { + if (cl_symbols[i].translation != NULL && + !strcasecmp(name, cl_symbols[i].name)) { + name = poolp; + pushstr(cl_symbols[i].translation); + pushc(0); + return name; + } + } + return name; } char * read_function() { - char c, *name = poolp; + char c, *name = poolp; - c = readc(); - if (c == '"') { - c = readc(); - while (c != '"') { - pushc(c); - c = readc(); - } - pushc(0); - return name; - } - while (c != '(' && !isspace(c) && c != ')' && c != ',') { - if (c == '_') c = '-'; - pushc(c); - c = readc(); - } - unreadc(c); - pushc(0); - return name; + c = readc(); + if (c == '"') { + c = readc(); + while (c != '"') { + pushc(c); + c = readc(); + } + pushc(0); + return name; + } + while (c != '(' && !isspace(c) && c != ')' && c != ',') { + if (c == '_') c = '-'; + pushc(c); + c = readc(); + } + unreadc(c); + pushc(0); + return name; } char * translate_function(char *name) { - char *output = search_function(name); - if (output == NULL) { - printf("\nUnknown function: %s\n", name); - pushstr("unknown"); - output = poolp; - } - return output; + char *output = search_function(name); + if (output == NULL) { + printf("\nUnknown function: %s\n", name); + pushstr("unknown"); + output = poolp; + } + return output; } char * read_token(void) { - int c; - int left_paren = 0; - char *p; - - p = poolp; + int c; + int left_paren = 0; + char *p; + + p = poolp; + c = readc(); + while (isspace(c)) + c = readc(); + do { + if (c == '(') { + left_paren++; + pushc(c); + } else if (c == ')') { + if (left_paren == 0) { + break; + } else { + left_paren--; + pushc(c); + } + } else if (isspace(c) && left_paren == 0) { + do c = readc(); - while (isspace(c)) - c = readc(); - do { - if (c == '(') { - left_paren++; - pushc(c); - } else if (c == ')') { - if (left_paren == 0) { - break; - } else { - left_paren--; - pushc(c); - } - } else if (isspace(c) && left_paren == 0) { - do - c = readc(); - while (isspace(c)); - break; - } else if (c == '@') { - c = readc(); - if (c == '\'') { - (void)read_symbol(0); - poolp--; - } else if (c == '[') { - (void)read_symbol(1); - poolp--; - } else if (c == '@') { - pushc(c); - } else { - char *name; - unreadc(c); - poolp = name = read_function(); - (void)translate_function(poolp); - } - } else { - pushc(c); - } - c = readc(); - } while (1); + while (isspace(c)); + break; + } else if (c == '@') { + c = readc(); + if (c == '\'') { + (void)read_symbol(0); + poolp--; + } else if (c == '[') { + (void)read_symbol(1); + poolp--; + } else if (c == '@') { + pushc(c); + } else { + char *name; unreadc(c); - pushc('\0'); - return(p); + poolp = name = read_function(); + (void)translate_function(poolp); + } + } else { + pushc(c); + } + c = readc(); + } while (1); + unreadc(c); + pushc('\0'); + return(p); } void reset(void) { - int i; + int i; - the_env_defined = 0; - poolp = pool; - function = NULL; - function_symbol = ""; - function_c_name = ""; - nreq = 0; - for (i = 0; i < MAXREQ; i++) - required[i] = NULL; - nopt = 0; - for (i = 0; i < MAXOPT; i++) - optional[i].o_var - = optional[i].o_init - = optional[i].o_svar - = NULL; - rest_flag = FALSE; - rest_var = "ARGS"; - key_flag = FALSE; - nkey = 0; - for (i = 0; i < MAXKEY; i++) - keyword[i].k_key - = keyword[i].k_var - = keyword[i].k_init - = keyword[i].k_svar - = NULL; - allow_other_keys_flag = FALSE; - naux = 0; - for (i = 0; i < MAXAUX; i++) - aux[i].a_var - = aux[i].a_init - = NULL; + the_env_defined = 0; + poolp = pool; + function = NULL; + function_symbol = ""; + function_c_name = ""; + nreq = 0; + for (i = 0; i < MAXREQ; i++) + required[i] = NULL; + nopt = 0; + for (i = 0; i < MAXOPT; i++) + optional[i].o_var + = optional[i].o_init + = optional[i].o_svar + = NULL; + rest_flag = FALSE; + rest_var = "ARGS"; + key_flag = FALSE; + nkey = 0; + for (i = 0; i < MAXKEY; i++) + keyword[i].k_key + = keyword[i].k_var + = keyword[i].k_init + = keyword[i].k_svar + = NULL; + allow_other_keys_flag = FALSE; + naux = 0; + for (i = 0; i < MAXAUX; i++) + aux[i].a_var + = aux[i].a_init + = NULL; } void get_function(void) { - function = read_function(); - function_symbol = search_symbol(function, &function_code, 0); - if (function_symbol == NULL) { - function_symbol = poolp; - pushstr("ECL_NIL"); - pushc('\0'); - } - function_c_name = translate_function(function); + function = read_function(); + function_symbol = search_symbol(function, &function_code, 0); + if (function_symbol == NULL) { + function_symbol = poolp; + pushstr("ECL_NIL"); + pushc('\0'); + } + function_c_name = translate_function(function); } void get_lambda_list(void) { - int c; - char *p; + int c; + char *p; - if ((c = nextc()) != '(') - error("( expected"); - for (;;) { - if ((c = nextc()) == ')') - return; - if (c == '&') { - p = read_token(); - goto _OPT; - } - unreadc(c); - p = read_token(); - if (nreq >= MAXREQ) - error("too many required variables"); - required[nreq++] = p; - } + if ((c = nextc()) != '(') + error("( expected"); + for (;;) { + if ((c = nextc()) == ')') + return; + if (c == '&') { + p = read_token(); + goto _OPT; + } + unreadc(c); + p = read_token(); + if (nreq >= MAXREQ) + error("too many required variables"); + required[nreq++] = p; + } -_OPT: - if (strcmp(p, "optional") != 0 && strcmp(p, "o") != 0) - goto _REST; - for (;; nopt++) { - if ((c = nextc()) == ')') - return; - if (c == '&') { - p = read_token(); - goto _REST; - } - if (nopt >= MAXOPT) - error("too many optional argument"); - if (c == '(') { - optional[nopt].o_var = read_token(); - if ((c = nextc()) == ')') - continue; - unreadc(c); - optional[nopt].o_init = read_token(); - if ((c = nextc()) == ')') - continue; - unreadc(c); - optional[nopt].o_svar = read_token(); - if (nextc() != ')') - error(") expected"); - } else { - unreadc(c); - optional[nopt].o_var = read_token(); - } - } + _OPT: + if (strcmp(p, "optional") != 0 && strcmp(p, "o") != 0) + goto _REST; + for (;; nopt++) { + if ((c = nextc()) == ')') + return; + if (c == '&') { + p = read_token(); + goto _REST; + } + if (nopt >= MAXOPT) + error("too many optional argument"); + if (c == '(') { + optional[nopt].o_var = read_token(); + if ((c = nextc()) == ')') + continue; + unreadc(c); + optional[nopt].o_init = read_token(); + if ((c = nextc()) == ')') + continue; + unreadc(c); + optional[nopt].o_svar = read_token(); + if (nextc() != ')') + error(") expected"); + } else { + unreadc(c); + optional[nopt].o_var = read_token(); + } + } -_REST: - if (strcmp(p, "rest") != 0 && strcmp(p, "r") != 0) - goto _KEY; - rest_flag = TRUE; - if ((c = nextc()) == ')' || c == '&') - error("&rest var missing"); - unreadc(c); - rest_var = read_token(); + _REST: + if (strcmp(p, "rest") != 0 && strcmp(p, "r") != 0) + goto _KEY; + rest_flag = TRUE; + if ((c = nextc()) == ')' || c == '&') + error("&rest var missing"); + unreadc(c); + rest_var = read_token(); + if ((c = nextc()) == ')') + return; + if (c != '&') + error("& expected"); + p = read_token(); + + _KEY: + if (strcmp(p, "key") != 0 && strcmp(p, "k") != 0) + goto _AUX; + key_flag = TRUE; + for (;; nkey++) { + if ((c = nextc()) == ')') + return; + if (c == '&') { + p = read_token(); + if (strcmp(p, "allow_other_keys") == 0 || + strcmp(p, "aok") == 0) { + allow_other_keys_flag = TRUE; if ((c = nextc()) == ')') - return; + return; if (c != '&') - error("& expected"); + error("& expected"); p = read_token(); + } + goto _AUX; + } + if (nkey >= MAXKEY) + error("too many optional argument"); + if (c == '(') { + if ((c = nextc()) == '(') { + p = read_token(); + if (p[0] != ':' || p[1] == '\0') + error("keyword expected"); + keyword[nkey].k_key = p + 1; + keyword[nkey].k_var = read_token(); + if (nextc() != ')') + error(") expected"); + } else { + unreadc(c); + keyword[nkey].k_key + = keyword[nkey].k_var + = read_token(); + } + if ((c = nextc()) == ')') + continue; + unreadc(c); + keyword[nkey].k_init = read_token(); + if ((c = nextc()) == ')') + continue; + unreadc(c); + keyword[nkey].k_svar = read_token(); + if (nextc() != ')') + error(") expected"); + } else { + unreadc(c); + keyword[nkey].k_key + = keyword[nkey].k_var + = read_token(); + } + } -_KEY: - if (strcmp(p, "key") != 0 && strcmp(p, "k") != 0) - goto _AUX; - key_flag = TRUE; - for (;; nkey++) { - if ((c = nextc()) == ')') - return; - if (c == '&') { - p = read_token(); - if (strcmp(p, "allow_other_keys") == 0 || - strcmp(p, "aok") == 0) { - allow_other_keys_flag = TRUE; - if ((c = nextc()) == ')') - return; - if (c != '&') - error("& expected"); - p = read_token(); - } - goto _AUX; - } - if (nkey >= MAXKEY) - error("too many optional argument"); - if (c == '(') { - if ((c = nextc()) == '(') { - p = read_token(); - if (p[0] != ':' || p[1] == '\0') - error("keyword expected"); - keyword[nkey].k_key = p + 1; - keyword[nkey].k_var = read_token(); - if (nextc() != ')') - error(") expected"); - } else { - unreadc(c); - keyword[nkey].k_key - = keyword[nkey].k_var - = read_token(); - } - if ((c = nextc()) == ')') - continue; - unreadc(c); - keyword[nkey].k_init = read_token(); - if ((c = nextc()) == ')') - continue; - unreadc(c); - keyword[nkey].k_svar = read_token(); - if (nextc() != ')') - error(") expected"); - } else { - unreadc(c); - keyword[nkey].k_key - = keyword[nkey].k_var - = read_token(); - } - } - -_AUX: - if (strcmp(p, "aux") != 0 && strcmp(p, "a") != 0) - error("illegal lambda-list keyword"); - for (;;) { - if ((c = nextc()) == ')') - return; - if (c == '&') - error("illegal lambda-list keyword"); - if (naux >= MAXAUX) - error("too many auxiliary variable"); - if (c == '(') { - aux[naux].a_var = read_token(); - if ((c = nextc()) == ')') - continue; - unreadc(c); - aux[naux].a_init = read_token(); - if (nextc() != ')') - error(") expected"); - } else { - unreadc(c); - aux[naux].a_var = read_token(); - } - naux++; - } + _AUX: + if (strcmp(p, "aux") != 0 && strcmp(p, "a") != 0) + error("illegal lambda-list keyword"); + for (;;) { + if ((c = nextc()) == ')') + return; + if (c == '&') + error("illegal lambda-list keyword"); + if (naux >= MAXAUX) + error("too many auxiliary variable"); + if (c == '(') { + aux[naux].a_var = read_token(); + if ((c = nextc()) == ')') + continue; + unreadc(c); + aux[naux].a_init = read_token(); + if (nextc() != ')') + error(") expected"); + } else { + unreadc(c); + aux[naux].a_var = read_token(); + } + naux++; + } } void get_return(void) { - int c; + int c; - nres = 0; - for (;;) { - if ((c = nextc()) == ')') - return; - unreadc(c); - result[nres++] = read_token(); - } + nres = 0; + for (;;) { + if ((c = nextc()) == ')') + return; + unreadc(c); + result[nres++] = read_token(); + } } void put_fhead(void) { - int i; + int i; - put_lineno(); - fprintf(out, "cl_object %s(cl_narg narg", function_c_name); - for (i = 0; i < nreq; i++) - fprintf(out, ", cl_object %s", required[i]); - if (nopt > 0 || rest_flag || key_flag) - fprintf(out, ", ..."); - fprintf(out, ")\n{\n"); + put_lineno(); + fprintf(out, "cl_object %s(cl_narg narg", function_c_name); + for (i = 0; i < nreq; i++) + fprintf(out, ", cl_object %s", required[i]); + if (nopt > 0 || rest_flag || key_flag) + fprintf(out, ", ..."); + fprintf(out, ")\n{\n"); } void @@ -712,12 +719,12 @@ } put_lineno(); if (simple_varargs) - fprintf(out,"\tva_list %s;\n\tva_start(%s, %s);\n", - rest_var, rest_var, ((nreq > 0) ? required[nreq-1] : "narg")); + fprintf(out,"\tva_list %s;\n\tva_start(%s, %s);\n", + rest_var, rest_var, ((nreq > 0) ? required[nreq-1] : "narg")); else - fprintf(out,"\tecl_va_list %s;\n\tecl_va_start(%s, %s, narg, %d);\n", - rest_var, rest_var, ((nreq > 0) ? required[nreq-1] : "narg"), - nreq); + fprintf(out,"\tecl_va_list %s;\n\tecl_va_start(%s, %s, narg, %d);\n", + rest_var, rest_var, ((nreq > 0) ? required[nreq-1] : "narg"), + nreq); put_lineno(); fprintf(out, "\tif (ecl_unlikely(narg < %d", nreq); if (nopt > 0 && !rest_flag && !key_flag) { @@ -787,149 +794,149 @@ void put_return(void) { - int i, t; + int i, t; - t = tab_save+1; + t = tab_save+1; - fprintf(out, "{\n"); - if (!the_env_defined) { - put_tabs(t); - fprintf(out, "const cl_env_ptr the_env = ecl_process_env();\n"); - } - if (nres == 0) { - fprintf(out, "the_env->nvalues = 0; return ECL_NIL;\n"); - } else { - put_tabs(t); - for (i = 0; i < nres; i++) { - put_tabs(t); - fprintf(out, "cl_object __value%d = %s;\n", i, result[i]); - } - put_tabs(t); - fprintf(out, "the_env->nvalues = %d;\n", nres); - for (i = nres-1; i > 0; i--) { - put_tabs(t); - fprintf(out, "the_env->values[%d] = __value%d;\n", i, i); - } - put_tabs(t); - fprintf(out, "return __value0;\n"); - } - put_tabs(tab_save); - fprintf(out, "}\n"); + fprintf(out, "{\n"); + if (!the_env_defined) { + put_tabs(t); + fprintf(out, "const cl_env_ptr the_env = ecl_process_env();\n"); + } + if (nres == 0) { + fprintf(out, "the_env->nvalues = 0; return ECL_NIL;\n"); + } else { + put_tabs(t); + for (i = 0; i < nres; i++) { + put_tabs(t); + fprintf(out, "cl_object __value%d = %s;\n", i, result[i]); + } + put_tabs(t); + fprintf(out, "the_env->nvalues = %d;\n", nres); + for (i = nres-1; i > 0; i--) { + put_tabs(t); + fprintf(out, "the_env->values[%d] = __value%d;\n", i, i); + } + put_tabs(t); + fprintf(out, "return __value0;\n"); + } + put_tabs(tab_save); + fprintf(out, "}\n"); } int jump_to_at(void) { - int c; + int c; GO_ON: - while ((c = readc()) != '@') - putc(c, out); - if ((c = readc()) == '@') { - putc(c, out); - goto GO_ON; - } - return c; + while ((c = readc()) != '@') + putc(c, out); + if ((c = readc()) == '@') { + putc(c, out); + goto GO_ON; + } + return c; } void main_loop(void) { - int c; - int in_defun=0; - char *p; + int c; + int in_defun=0; + char *p; - lineno = 1; + lineno = 1; - reset(); - put_lineno(); -LOOP: - c = jump_to_at(); - if (c == ')') { - if (!in_defun) - error("unmatched @) found"); - in_defun = 0; - putc('}',out); - reset(); - goto LOOP; - } else if (c == '\'') { - char *p; - poolp = pool; - p = read_symbol(0); - pushc('\0'); - fprintf(out,"%s",p); - goto LOOP; - } else if (c == '[') { - char *p; - poolp = pool; - p = read_symbol(1); - pushc('\0'); - fprintf(out,"%s",p); - goto LOOP; - } else if (c != '(') { - char *p; - unreadc(c); - poolp = pool; - poolp = p = read_function(); - fprintf(out,"%s",translate_function(poolp)); - goto LOOP; - } - p = read_token(); - if (strcmp(p, "defun") == 0) { - if (in_defun) - error("@) expected before new function definition"); - in_defun = 1; - get_function(); - get_lambda_list(); - put_fhead(); - put_lineno(); - c = jump_to_at(); - put_declaration(); - put_lineno(); - } else if (strcmp(p, "return") == 0) { - tab_save = tab; - get_return(); - put_return(); - } else - error_symbol(p); - goto LOOP; + reset(); + put_lineno(); + LOOP: + c = jump_to_at(); + if (c == ')') { + if (!in_defun) + error("unmatched @) found"); + in_defun = 0; + putc('}',out); + reset(); + goto LOOP; + } else if (c == '\'') { + char *p; + poolp = pool; + p = read_symbol(0); + pushc('\0'); + fprintf(out,"%s",p); + goto LOOP; + } else if (c == '[') { + char *p; + poolp = pool; + p = read_symbol(1); + pushc('\0'); + fprintf(out,"%s",p); + goto LOOP; + } else if (c != '(') { + char *p; + unreadc(c); + poolp = pool; + poolp = p = read_function(); + fprintf(out,"%s",translate_function(poolp)); + goto LOOP; + } + p = read_token(); + if (strcmp(p, "defun") == 0) { + if (in_defun) + error("@) expected before new function definition"); + in_defun = 1; + get_function(); + get_lambda_list(); + put_fhead(); + put_lineno(); + c = jump_to_at(); + put_declaration(); + put_lineno(); + } else if (strcmp(p, "return") == 0) { + tab_save = tab; + get_return(); + put_return(); + } else + error_symbol(p); + goto LOOP; } int main(int argc, char **argv) { - char outfile[BUFSIZ]; + char outfile[BUFSIZ]; #ifdef _MSC_VER - char *p; + char *p; #endif - if (argc < 2 || !strcmp(argv[1],"-")) { - in = stdin; - strcpy(filename, "-"); - } else { - in = fopen(argv[1],"r"); - strncpy(filename, argv[1], BUFSIZ-1); - filename[BUFSIZ-1] = '\0'; - } + if (argc < 2 || !strcmp(argv[1],"-")) { + in = stdin; + strcpy(filename, "-"); + } else { + in = fopen(argv[1],"r"); + strncpy(filename, argv[1], BUFSIZ-1); + filename[BUFSIZ-1] = '\0'; + } #ifdef _MSC_VER - /* Convert all backslashes in filename into slashes, - * to avoid warnings when compiling with MSVC - */ - for ( p=filename; *p; p++ ) - if ( *p == '\\' ) - *p = '/'; + /* Convert all backslashes in filename into slashes, + * to avoid warnings when compiling with MSVC + */ + for ( p=filename; *p; p++ ) + if ( *p == '\\' ) + *p = '/'; #endif - if (argc < 3 || !strcmp(argv[2],"-")) { - out = stdout; - strcpy(outfile, "-"); - } else { - out = fopen(argv[2],"w"); - strncpy(outfile, argv[2], BUFSIZ-1); - outfile[BUFSIZ-1] = '\0'; - } - if (in == NULL) - error("can't open input file"); - if (out == NULL) - error("can't open output file"); - printf("dpp: %s -> %s\n", filename, outfile); - main_loop(); - return 0; + if (argc < 3 || !strcmp(argv[2],"-")) { + out = stdout; + strcpy(outfile, "-"); + } else { + out = fopen(argv[2],"w"); + strncpy(outfile, argv[2], BUFSIZ-1); + outfile[BUFSIZ-1] = '\0'; + } + if (in == NULL) + error("can't open input file"); + if (out == NULL) + error("can't open output file"); + printf("dpp: %s -> %s\n", filename, outfile); + main_loop(); + return 0; } diff -Nru ecl-16.1.2/src/c/earith.d ecl-16.1.3+ds/src/c/earith.d --- ecl-16.1.2/src/c/earith.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/earith.d 1970-01-01 00:00:00.000000000 +0000 @@ -1,496 +0,0 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ - -/* - earith.c -- Support for bignum arithmetic. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ - -/* - - EXTENDED_MUL and EXTENDED_DIV perform 32 bit multiplication and - division, respectively. - - EXTENDED_MUL(D,Q,R,HP,LP) - calculates D*Q+R and saves the result into the locations HP and LP. - D, Q, and R are 32 bit non-negative integers and HP and LP are - word addresses. The word at LP will contain the lower 31 (not 32) - bits of the result and its most significant bit is set 0. The word - at HP will contain the rest of the result and its MSB is also set 0. - - EXTENDED_DIV(D,H,L,QP,RP) - divides [H:L] by D and saves the quotient and the remainder into - the locations QP and RP, respectively. D, H, L are 32 bit non-negative - integers and QP and RP are word addresses. Here, [H:L] means the - 64 bit integer (imaginary) represented by H and L as follows. - - 63 62 31 30 0 - |0|0||| - - Although [H:L] is 64 bits, you can assume that the quotient is always - represented as 32 bit non-negative integer. -*/ - -#include - -#ifdef CONVEX - -static void -extended_mul(int d, int q, int r, int *hp, int *lp) -{ - long long int ld, lq, lr, z; - int zh, zl; - - ld = d; - lq = q; - lr = r; - z = ld*lq+lr; - zl = (z & 0x000000007fffffffLL); - zh = (z >> 31LL); - *hp = zh; - *lp = zl; -} - -static void -extended_div(int d, int h, int l, int *qp, int *rp) -{ - long long int lh, ld, ll; - - ld = d; - lh = h; - ll = l; - lh = (lh << 31LL); - lh = (lh | ll); - *qp = (lh/ld); - *rp = (lh%ld); - } -#endif /* CONVEX */ - -#ifdef i386 - -static void -extended_mul(int d, int q, int r, int *hp, int *lp) -{ asm("pushl %ecx"); - asm("movl 8(%ebp),%eax"); - asm("mull 12(%ebp)"); - asm("addl 16(%ebp),%eax"); - asm("adcl $0,%edx"); - asm("shll $1,%edx"); - asm("btrl $31,%eax"); - asm("adcl $0,%edx"); - asm("movl 20(%ebp),%ecx"); - asm("movl %edx, (%ecx)"); - asm("movl 24(%ebp), %ecx"); - asm("movl %eax, (%ecx)"); - asm("popl %ecx"); -} - -static void -extended_div(int d, int h, int l, int *qp, int *rp) -{ - asm("pushl %ebx"); - asm("movl 12(%ebp),%edx"); - asm("movl 16(%ebp),%eax"); - asm("btl $0,%edx"); - asm("jae 1f"); - asm("btsl $31,%eax"); - asm("1: shrl $1,%edx"); - asm("idivl 8(%ebp)"); - asm("movl 20(%ebp),%ebx"); - asm("movl %eax,(%ebx)"); - asm("movl 24(%ebp),%ebx"); - asm("movl %edx,(%ebx)"); - asm("popl %ebx"); -} -#endif /* i386 */ - -#ifdef IBMRT - -static void -extended_mul(int d, int q, int r, int *hp, int *lp) -{ - /* d=L750+20, q=L750+24, etc. */ - asm(" get r0,L750+20(r13)"); /* get an argument */ - asm(" mts r10,r0"); /* put in MQ */ - asm(" get r2,L750+24(r13)"); /* get the other argument */ - asm(" s r0,r0"); /* zero partial product. set carry to 1. */ - asm(" m r0,r2 - m r0,r2 - m r0,r2 - m r0,r2 - m r0,r2 - m r0,r2 - m r0,r2 - m r0,r2 - m r0,r2 - m r0,r2 - m r0,r2 - m r0,r2 - m r0,r2 - m r0,r2 - m r0,r2 - m r0,r2"); - /* Now (r0)//mq has the 64 bit product; overflow is ignored. */ - asm(" mfs r10,r2"); /* set r2 = low order word of result - * so product is in (r0)//(r2). - */ - /* - * Force product into two single precision words. - */ - - asm(" get r3,$1f - sli r0,1 - ar2,r2 - bnc0r r3"); /* branch if carry = 0 */ - asm(" oil r0,r0,1 - 1: - sri r2,1"); - /* Now add in the third argument. */ - asm(" get r4,$2f - get r3,L750+28(r13) - a r2,r3 - - bnmr r4"); /* branch if not minus */ - asm(" clrbu r2,0 - lis r3,1 - a r0,r3 - 2: - - get r3,L750+32(r13) - put r0,0(r3) - get r3,L750+36(r13) - put r2,0(r3) - "); -} - -static void -extended_div(int d, int h, int l, int *qp, int *rp) -{ - /* d=L754+20, h=L754+24, etc. */ - /* Move arguments into registers. */ - asm(" get r0,L754+28(r13)"); /* Low order word of dividend. */ - asm(" get r2,L754+24(r13)"); /* High order word of dividend. */ - asm(" mttbil r2,15 - mftbiu r0,0 - sri r2,1 - mts r10,r0 - get r3,L754+20(r13)") /* Divisor. */ - /* Perform 32 steps of division. */ - asm(" d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3"); - /* Now MQ has the quotient, R2 the remainder, and R3 is - * the unchanged divisor. */ - asm(" mttbiu r2,0"); /* Do add-back if necessary. */ - asm(" jntb 1f - a r2,r3 - 1: - mfs r10,r0 - c r2,r3"); /* Remainder : divisor. */ - asm(" jne 2f - inc r0,1 - x r2,r2 - 2:"); - /* Now r0 has the quotient and r2 has the remainder. */ - asm(" get r3,L754+32(r13)"); /* Quotient address. */ - asm(" put r0,0(r3)"); - asm(" get r3,L754+36(r13)"); /* Remainder address. */ - asm(" put r2,0(r3)"); -} - -#endif /* IBMRT */ - -#if defined(NEWS) || defined(MAC) - -static void -extended_mul(int d, int q, int r, int *hp, int *lp) -{ - asm(" move.l d2,-(sp) - clr.l d2 - move.l (8,fp),d0 - mulu.l (12,fp),d1:d0 - add.l (16,fp),d0 - addx.l d2,d1 - lsl.l #1,d0 - roxl.l #1,d1 - lsr.l #1,d0 - move.l (20,fp),a0 - move.l d1,(a0) - move.l (24,a6),a0 - move.l d0,(a0)"); -} - -static void -extended_div(int d, int h, int l, int *qp, int *rp) -{ - asm("movem.l (12,fp),#0x303 - lsl.l #1,d1 - lsr.l #1,d0 - roxr.l #1,d1 - divu.l (8,fp),d0:d1 - move.l d0,(a1) - move.l d1,(a0) - "); -} - -#endif /* NEWS || MAC */ - -#ifdef __mips - - /* earith.s for MIPS R2000 processor - by Doug Katzman - version 2.1.d dated 7/13/89 15:31 EDT */ - -/* Register names: -#define v0 $2 return value -#define v1 $3 -#define a0 $4 argument registers -#define a1 $5 -#define a2 $6 -#define a3 $7 -#define t7 $15 -*/ - -static void -extended_mul(unsigned int d, unsigned int q, unsigned int r, unsigned int *hp, - unsigned int *lp) -{ - asm("mult $4, $5"); /* [hi:lo] = d * q */ - asm("mfhi $5"); /* a1 = hi */ - asm("sll $5, 1"); - asm("mflo $4"); - asm("srl $15, $4, 31"); - asm("and $4, 0x7fffffff"); - asm("or $5, $15"); - asm("addu $4, $6"); /* [a1:a0] += r */ - asm("srl $15, $4, 31"); - asm("and $4, 0x7fffffff"); - asm("addu $5, $15"); - asm("sw $5, 0($7)"); /* *hp = a1 */ -#ifdef __GNUC__ - asm("lw $7, %0" :: "g" (lp)); -#else - asm("lw $7, 16($sp)"); /* fetch fifth actual argument from stack */ -#endif - asm("sw $4, 0($7)"); /* *lp = a0 */ -} - -static void -extended_div(unsigned int d, unsigned int h, unsigned int l, unsigned int *qp, - unsigned int *rp) -{ - - asm("sll $6, 1"); - asm("li $2, 31"); /* v0 holds number of shifts */ - asm("loop: - srl $15, $6, 31"); - asm("sll $5, 1"); - asm("or $5, $15"); - asm("sll $6, 1"); - asm("subu $15, $5, $4"); /* t = h - d */ - asm("bltz $15, underflow"); - asm("move $5, $15"); - asm("or $6, 1"); - asm("underflow: - subu $2, 1"); - asm("bnez $2, loop"); - asm("sw $6, 0($7)"); /* *qp = l */ -#ifdef __GNUC__ - asm("lw $7, %0" :: "g" (rp)); -#else - asm("lw $7, 16($sp)"); /* fetch fifth actual argument from stack */ -#endif - asm("sw $5, 0($7)"); /* *rp = h */ -} -#endif /* __mips */ - -#if defined(sun3) || (defined __NeXT) - -static void -extended_mul(int d, int q, int r, int *hp, int *lp) -{ - asm(" - movl d2,a7@- - clrl d2 - movl a6@(8),d0 - mulul a6@(12),d1:d0 - addl a6@(16),d0 - addxl d2,d1 - lsll #1,d0 - roxll #1,d1 - lsrl #1,d0 - movl a6@(20),a0 - movl d1,a0@ - movl a6@(24),a0 - movl d0,a0@ - movl a7@+,d2 - "); -} - -static void -extended_div(int d, int h, int l, int *qp, int *rp) -{ - asm("moveml a6@(12),#0x303 - lsll #1,d1 - lsrl #1,d0 - roxrl #1,d1 - divul a6@(8),d0:d1 - movl d0,a1@ - movl d1,a0@ - "); -} - -#endif /* sun3 */ - -/* Possible assembler version: -#ifdef sparc -_extended_mul: -!#PROLOGUE# 0 -!#PROLOGUE# 1 - save %sp,-96,%sp - mov %i0,%o0 - call .umul,2 - mov %i1,%o1 - addcc %o0,%i2,%i0 - addx %o1,0,%o1 - sll %o1,1,%o1 - tst %i0 - bge L77003 - sethi %hi(0x7fffffff),%o3 - or %o3,%lo(0x7fffffff),%o3 ! [internal] - and %i0,%o3,%i0 - inc %o1 -L77003: - st %i0,[%i4] - st %o1,[%i3] - ret - restore %g0,0,%o0 - -#endif sparc -*/ - -#if defined(sparc) || defined(APOLLO) || defined(hpux) || defined(UNIGRAPH)n - -/* for the time being use the C version:*/ - -static void -extended_mul(unsigned int d, unsigned int q, unsigned int r, unsigned int *hp, - unsigned int *lp) -{ - register unsigned short dlo = d & 0xffff, - dhi = d >> 16, - qlo = q & 0xffff, - qhi = q >> 16; - unsigned int d0 = dhi * qlo + dlo * qhi, - d1 = dhi * qhi, - d2 = dlo * qlo; - - d1 = (d1 << 1) + (d0 >> 15); /* add 17 MSB of d0 */ - d1 += d2 >> 31; /* add MSB of d2 */ - d2 &= 0x7fffffff; /* clear MSB of d2 */ - d2 += (d0 & 0x7fff) << 16; /* add 15 LSB of d0: no overflow occurs */ - d1 += d2 >> 31; /* add MSB of d2 */ - d2 &= 0x7fffffff; /* clear MSB of d2 */ - d2 += r; - d1 += d2 >> 31; /* add MSB of d2 */ - d2 &= 0x7fffffff; /* clear MSB of d2 */ - - *hp = d1; - *lp = d2; -} - -static void -extended_div(unsigned int d, unsigned int h, unsigned int l, unsigned int *qp, - unsigned int *rp) -{ - int i; - int borrow; - - l = (l << 1) | 1; - - for (i = 31; i >= 0;) { - - if (h >= d) { - h -= d; - borrow = 0; - } - else - borrow = 1; - - if (i--) - h = (h << 1) | ((unsigned)l >> 31); - - l = (l << 1) | borrow; - - } - - l = - l - 1; - - *qp = l; - *rp = h; -} - -#endif /* sparc */ - -#ifdef vax - -static void -extended_mul(int d, int q, int r, int *hp, int *lp) -{ - asm(" emul 4(ap),8(ap),12(ap),r0"); - asm(" ashq $1,r0,r0"); - asm(" rotl $-1,r0,r0"); - asm(" movl r0,*20(ap)"); - asm(" movl r1,*16(ap)"); -} - -static void -extended_div(int d, int h, int l, int *qp, int *rp) -{ - asm(" clrl r0"); - asm(" movl 8(ap),r1"); - asm(" ashq $-1,r0,r0"); - asm(" addl2 12(ap),r0"); - asm(" ediv 4(ap),r0,*16(ap),*20(ap)"); -} -#endif /* vax */ diff -Nru ecl-16.1.2/src/c/ecl_constants.h ecl-16.1.3+ds/src/c/ecl_constants.h --- ecl-16.1.2/src/c/ecl_constants.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/ecl_constants.h 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - ecl_constants.c -- constant values for all_symbols.d -*/ -/* - Copyright (c) 2010, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * ecl_constants.h - contstant values for all_symbols.d + * + * Copyright (c) 2010 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include diff -Nru ecl-16.1.2/src/c/ecl_features.h ecl-16.1.3+ds/src/c/ecl_features.h --- ecl-16.1.2/src/c/ecl_features.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/ecl_features.h 2016-12-19 10:25:00.000000000 +0000 @@ -1,126 +1,116 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - features.h -- names of features compiled into ECL -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * features.h - names of features compiled into ECL + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ ecl_def_string_array(feature_names,static,const) = { - ecl_def_string_array_elt("ECL"), - ecl_def_string_array_elt("COMMON"), - ecl_def_string_array_elt(ECL_ARCHITECTURE), - ecl_def_string_array_elt("FFI"), - ecl_def_string_array_elt("PREFIXED-API"), + ecl_def_string_array_elt("ECL"), + ecl_def_string_array_elt("COMMON"), + ecl_def_string_array_elt(ECL_ARCHITECTURE), + ecl_def_string_array_elt("FFI"), + ecl_def_string_array_elt("PREFIXED-API"), + ecl_def_string_array_elt("CDR-14"), #ifdef ECL_IEEE_FP - ecl_def_string_array_elt("IEEE-FLOATING-POINT"), + ecl_def_string_array_elt("IEEE-FLOATING-POINT"), #endif - ecl_def_string_array_elt("COMMON-LISP"), - ecl_def_string_array_elt("ANSI-CL"), + ecl_def_string_array_elt("COMMON-LISP"), + ecl_def_string_array_elt("ANSI-CL"), #if defined(GBC_BOEHM) - ecl_def_string_array_elt("BOEHM-GC"), + ecl_def_string_array_elt("BOEHM-GC"), #endif #ifdef ECL_THREADS - ecl_def_string_array_elt("THREADS"), + ecl_def_string_array_elt("THREADS"), #endif - ecl_def_string_array_elt("CLOS"), + ecl_def_string_array_elt("CLOS"), #ifdef ENABLE_DLOPEN - ecl_def_string_array_elt("DLOPEN"), + ecl_def_string_array_elt("DLOPEN"), #endif -#ifdef ECL_OLD_LOOP - ecl_def_string_array_elt("OLD-LOOP"), -#endif - ecl_def_string_array_elt("ECL-PDE"), + ecl_def_string_array_elt("ECL-PDE"), #if defined(unix) || defined(netbsd) || defined(openbsd) || defined(linux) || defined(darwin) || \ - defined(freebsd) || defined(dragonfly) || defined(kfreebsd) || defined(gnu) || defined(nsk) - ecl_def_string_array_elt("UNIX"), + defined(freebsd) || defined(dragonfly) || defined(kfreebsd) || defined(gnu) || defined(nsk) || defined(aix) + ecl_def_string_array_elt("UNIX"), #endif #ifdef BSD - ecl_def_string_array_elt("BSD"), + ecl_def_string_array_elt("BSD"), #endif #ifdef SYSV - ecl_def_string_array_elt("SYSTEM-V"), -#endif -#ifdef MSDOS - ecl_def_string_array_elt("MS-DOS"), + ecl_def_string_array_elt("SYSTEM-V"), #endif #if defined(__MINGW32__) - ecl_def_string_array_elt("MINGW32"), - ecl_def_string_array_elt("WIN32"), + ecl_def_string_array_elt("MINGW32"), + ecl_def_string_array_elt("WIN32"), #endif #if defined(__WIN64__) - ecl_def_string_array_elt("WIN64"), + ecl_def_string_array_elt("WIN64"), #endif #ifdef _MSC_VER - ecl_def_string_array_elt("MSVC"), + ecl_def_string_array_elt("MSVC"), #endif #if defined(ECL_MS_WINDOWS_HOST) - ecl_def_string_array_elt("WINDOWS"), + ecl_def_string_array_elt("WINDOWS"), #endif #ifdef ECL_CMU_FORMAT - ecl_def_string_array_elt("CMU-FORMAT"), + ecl_def_string_array_elt("CMU-FORMAT"), #endif #ifdef ECL_CLOS_STREAMS - ecl_def_string_array_elt("CLOS-STREAMS"), + ecl_def_string_array_elt("CLOS-STREAMS"), #endif -#if defined(ECL_DYNAMIC_FFI) || defined(HAVE_LIBFFI) - ecl_def_string_array_elt("DFFI"), +#if defined(HAVE_LIBFFI) + ecl_def_string_array_elt("DFFI"), #endif #ifdef ECL_UNICODE - ecl_def_string_array_elt("UNICODE"), + ecl_def_string_array_elt("UNICODE"), #endif #ifdef ECL_LONG_FLOAT - ecl_def_string_array_elt("LONG-FLOAT"), + ecl_def_string_array_elt("LONG-FLOAT"), #endif #ifdef ECL_RELATIVE_PACKAGE_NAMES - ecl_def_string_array_elt("RELATIVE-PACKAGE-NAMES"), + ecl_def_string_array_elt("RELATIVE-PACKAGE-NAMES"), #endif #ifdef ecl_uint16_t - ecl_def_string_array_elt("UINT16-T"), + ecl_def_string_array_elt("UINT16-T"), #endif #ifdef ecl_uint32_t - ecl_def_string_array_elt("UINT32-T"), + ecl_def_string_array_elt("UINT32-T"), #endif #ifdef ecl_uint64_t - ecl_def_string_array_elt("UINT64-T"), + ecl_def_string_array_elt("UINT64-T"), #endif #ifdef ecl_long_long_t - ecl_def_string_array_elt("LONG-LONG"), + ecl_def_string_array_elt("LONG-LONG"), #endif #ifdef ECL_EXTERNALIZABLE - ecl_def_string_array_elt("EXTERNALIZABLE"), + ecl_def_string_array_elt("EXTERNALIZABLE"), #endif -#ifdef __cplusplus - ecl_def_string_array_elt("C++"), +#ifdef ECL_CXX_CORE + ecl_def_string_array_elt("CXX-CORE"), #endif #ifdef ECL_SSE2 - ecl_def_string_array_elt("SSE2"), + ecl_def_string_array_elt("SSE2"), #endif #ifdef ECL_SEMAPHORES - ecl_def_string_array_elt("SEMAPHORES"), + ecl_def_string_array_elt("SEMAPHORES"), #endif #ifdef ECL_RWLOCK - ecl_def_string_array_elt("ECL-READ-WRITE-LOCK"), + ecl_def_string_array_elt("ECL-READ-WRITE-LOCK"), #endif #ifdef WORDS_BIGENDIAN - ecl_def_string_array_elt("BIG-ENDIAN"), + ecl_def_string_array_elt("BIG-ENDIAN"), #else - ecl_def_string_array_elt("LITTLE-ENDIAN"), + ecl_def_string_array_elt("LITTLE-ENDIAN"), #endif #ifdef ECL_WEAK_HASH - ecl_def_string_array_elt("ECL-WEAK-HASH"), + ecl_def_string_array_elt("ECL-WEAK-HASH"), #endif - ecl_def_string_array_elt(0) + ecl_def_string_array_elt(0) }; diff -Nru ecl-16.1.2/src/c/error.d ecl-16.1.3+ds/src/c/error.d --- ecl-16.1.2/src/c/error.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/error.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - error.c -- Error handling. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * error.d - error handling + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -32,73 +27,73 @@ static cl_object cl_symbol_or_object(cl_object x) { - if (ECL_FIXNUMP(x)) - return (cl_object)(cl_symbols + ecl_fixnum(x)); - return x; + if (ECL_FIXNUMP(x)) + return (cl_object)(cl_symbols + ecl_fixnum(x)); + return x; } void _ecl_unexpected_return() { - ecl_internal_error( -"*** \n" -"*** A call to ERROR returned without handling the error.\n" -"*** This should have never happened and is usually a signal\n" -"*** that the debugger or the universal error handler were\n" -"*** improperly coded or altered. Please contact the maintainers\n" -"***\n"); + ecl_internal_error( + "*** \n" + "*** A call to ERROR returned without handling the error.\n" + "*** This should have never happened and is usually a signal\n" + "*** that the debugger or the universal error handler were\n" + "*** improperly coded or altered. Please contact the maintainers\n" + "***\n"); } void ecl_internal_error(const char *s) { - int saved_errno = errno; - fprintf(stderr, "\nInternal or unrecoverable error in:\n%s\n", s); - if (saved_errno) { - fprintf(stderr, " [%d: %s]\n", saved_errno, - strerror(saved_errno)); - } - fflush(stderr); - si_dump_c_backtrace(ecl_make_fixnum(32)); + int saved_errno = errno; + fprintf(stderr, "\nInternal or unrecoverable error in:\n%s\n", s); + if (saved_errno) { + fprintf(stderr, " [%d: %s]\n", saved_errno, + strerror(saved_errno)); + } + fflush(stderr); + si_dump_c_backtrace(ecl_make_fixnum(32)); #ifdef SIGIOT - signal(SIGIOT, SIG_DFL); /* avoid getting into a loop with abort */ + signal(SIGIOT, SIG_DFL); /* avoid getting into a loop with abort */ #endif - abort(); + abort(); } void ecl_unrecoverable_error(cl_env_ptr the_env, const char *message) { - /* - * Right now we have no means of specifying a jump point - * for really bad events. We just jump to the outermost - * frame, which is equivalent to quitting, and wait for - * someone to intercept this jump. - */ - ecl_frame_ptr destination; - cl_object tag; - - /* - * We output the error message with very low level routines - * because we can not risk another stack overflow. - */ - writestr_stream(message, cl_core.error_output); - - tag = ECL_SYM_VAL(the_env, @'si::*quit-tag*'); - the_env->nvalues = 0; - if (tag) { - destination = frs_sch(tag); - if (destination) { - ecl_unwind(the_env, destination); - } - } - if (the_env->frs_org <= the_env->frs_top) { - destination = ecl_process_env()->frs_org; - ecl_unwind(the_env, destination); - } else { - ecl_internal_error("\n;;;\n;;; No frame to jump to\n;;; Aborting ECL\n;;;"); - } + /* + * Right now we have no means of specifying a jump point + * for really bad events. We just jump to the outermost + * frame, which is equivalent to quitting, and wait for + * someone to intercept this jump. + */ + ecl_frame_ptr destination; + cl_object tag; + + /* + * We output the error message with very low level routines + * because we can not risk another stack overflow. + */ + writestr_stream(message, cl_core.error_output); + + tag = ECL_SYM_VAL(the_env, @'si::*quit-tag*'); + the_env->nvalues = 0; + if (tag) { + destination = frs_sch(tag); + if (destination) { + ecl_unwind(the_env, destination); + } + } + if (the_env->frs_org <= the_env->frs_top) { + destination = ecl_process_env()->frs_org; + ecl_unwind(the_env, destination); + } else { + ecl_internal_error("\n;;;\n;;; No frame to jump to\n;;; Aborting ECL\n;;;"); + } } /*****************************************************************************/ @@ -108,26 +103,26 @@ void FEerror(const char *s, int narg, ...) { - ecl_va_list args; - ecl_va_start(args, narg, narg, 0); - ecl_enable_interrupts(); - funcall(4, @'si::universal-error-handler', - ECL_NIL, /* not correctable */ - make_constant_base_string(s), /* condition text */ - cl_grab_rest_args(args)); - _ecl_unexpected_return(); + ecl_va_list args; + ecl_va_start(args, narg, narg, 0); + ecl_enable_interrupts(); + funcall(4, @'si::universal-error-handler', + ECL_NIL, /* not correctable */ + make_constant_base_string(s), /* condition text */ + cl_grab_rest_args(args)); + _ecl_unexpected_return(); } cl_object CEerror(cl_object c, const char *err, int narg, ...) { - ecl_va_list args; - ecl_va_start(args, narg, narg, 0); - ecl_enable_interrupts(); - return funcall(4, @'si::universal-error-handler', - c, /* correctable */ - make_constant_base_string(err), /* continue-format-string */ - cl_grab_rest_args(args)); + ecl_va_list args; + ecl_va_start(args, narg, narg, 0); + ecl_enable_interrupts(); + return funcall(4, @'si::universal-error-handler', + c, /* correctable */ + make_constant_base_string(err), /* continue-format-string */ + cl_grab_rest_args(args)); } /*********************** @@ -137,245 +132,252 @@ void FEprogram_error(const char *s, int narg, ...) { - cl_object real_args, text; - ecl_va_list args; - ecl_va_start(args, narg, narg, 0); - text = make_constant_base_string(s); - real_args = cl_grab_rest_args(args); - if (cl_boundp(@'si::*current-form*') != ECL_NIL) { - /* When FEprogram_error is invoked from the compiler, we can - * provide information about the offending form. - */ - cl_object stmt = ecl_symbol_value(@'si::*current-form*'); - if (stmt != ECL_NIL) { - real_args = @list(3, stmt, text, real_args); - text = make_constant_base_string("In form~%~S~%~?"); - } - } - si_signal_simple_error(4, - @'program-error', /* condition name */ - ECL_NIL, /* not correctable */ - text, - real_args); + cl_object real_args, text; + ecl_va_list args; + ecl_va_start(args, narg, narg, 0); + text = make_constant_base_string(s); + real_args = cl_grab_rest_args(args); + if (cl_boundp(@'si::*current-form*') != ECL_NIL) { + /* When FEprogram_error is invoked from the compiler, we can + * provide information about the offending form. + */ + cl_object stmt = ecl_symbol_value(@'si::*current-form*'); + if (stmt != ECL_NIL) { + real_args = @list(3, stmt, text, real_args); + text = make_constant_base_string("In form~%~S~%~?"); + } + } + si_signal_simple_error(4, + @'program-error', /* condition name */ + ECL_NIL, /* not correctable */ + text, + real_args); + _ecl_unexpected_return(); } void FEprogram_error_noreturn(const char *s, int narg, ...) { - cl_object real_args, text; - ecl_va_list args; - ecl_va_start(args, narg, narg, 0); - text = make_constant_base_string(s); - real_args = cl_grab_rest_args(args); - if (cl_boundp(@'si::*current-form*') != ECL_NIL) { - /* When FEprogram_error is invoked from the compiler, we can - * provide information about the offending form. - */ - cl_object stmt = ecl_symbol_value(@'si::*current-form*'); - if (stmt != ECL_NIL) { - real_args = @list(3, stmt, text, real_args); - text = make_constant_base_string("In form~%~S~%~?"); - } - } - si_signal_simple_error(4, - @'program-error', /* condition name */ - ECL_NIL, /* not correctable */ - text, - real_args); + cl_object real_args, text; + ecl_va_list args; + ecl_va_start(args, narg, narg, 0); + text = make_constant_base_string(s); + real_args = cl_grab_rest_args(args); + if (cl_boundp(@'si::*current-form*') != ECL_NIL) { + /* When FEprogram_error is invoked from the compiler, we can + * provide information about the offending form. + */ + cl_object stmt = ecl_symbol_value(@'si::*current-form*'); + if (stmt != ECL_NIL) { + real_args = @list(3, stmt, text, real_args); + text = make_constant_base_string("In form~%~S~%~?"); + } + } + si_signal_simple_error(4, + @'program-error', /* condition name */ + ECL_NIL, /* not correctable */ + text, + real_args); + _ecl_unexpected_return(); } void FEcontrol_error(const char *s, int narg, ...) { - ecl_va_list args; - ecl_va_start(args, narg, narg, 0); - si_signal_simple_error(4, - @'control-error', /* condition name */ - ECL_NIL, /* not correctable */ - make_constant_base_string(s), /* format control */ - cl_grab_rest_args(args)); /* format args */ + ecl_va_list args; + ecl_va_start(args, narg, narg, 0); + si_signal_simple_error(4, + @'control-error', /* condition name */ + ECL_NIL, /* not correctable */ + make_constant_base_string(s), /* format control */ + cl_grab_rest_args(args)); /* format args */ + _ecl_unexpected_return(); } void FEreader_error(const char *s, cl_object stream, int narg, ...) { - cl_object message = make_constant_base_string(s); - cl_object args_list; - ecl_va_list args; - ecl_va_start(args, narg, narg, 0); - args_list = cl_grab_rest_args(args); - if (Null(stream)) { - /* Parser error */ - si_signal_simple_error(4, - @'parse-error', /* condition name */ - ECL_NIL, /* not correctable */ - message, /* format control */ - args_list); - } else { - /* Actual reader error */ - cl_object prefix = make_constant_base_string("Reader error in file ~S, " - "position ~D:~%"); - cl_object position = cl_file_position(1, stream); - message = si_base_string_concatenate(2, prefix, message); - args_list = cl_listX(3, stream, position, args_list); - si_signal_simple_error(6, - @'reader-error', /* condition name */ - ECL_NIL, /* not correctable */ - message, /* format control */ - args_list, /* format args */ - @':stream', stream); - } + cl_object message = make_constant_base_string(s); + cl_object args_list; + ecl_va_list args; + ecl_va_start(args, narg, narg, 0); + args_list = cl_grab_rest_args(args); + if (Null(stream)) { + /* Parser error */ + si_signal_simple_error(4, + @'parse-error', /* condition name */ + ECL_NIL, /* not correctable */ + message, /* format control */ + args_list); + } else { + /* Actual reader error */ + cl_object prefix = make_constant_base_string("Reader error in file ~S, " + "position ~D:~%"); + cl_object position = cl_file_position(1, stream); + message = si_base_string_concatenate(2, prefix, message); + args_list = cl_listX(3, stream, position, args_list); + si_signal_simple_error(6, + @'reader-error', /* condition name */ + ECL_NIL, /* not correctable */ + message, /* format control */ + args_list, /* format args */ + @':stream', stream); + } + _ecl_unexpected_return(); } void FEcannot_open(cl_object fn) { - cl_error(3, @'file-error', @':pathname', fn); + cl_error(3, @'file-error', @':pathname', fn); } void FEend_of_file(cl_object strm) { - cl_error(3, @'end-of-file', @':stream', strm); + cl_error(3, @'end-of-file', @':stream', strm); } void FEclosed_stream(cl_object strm) { - cl_error(3, @'stream-error', @':stream', strm); + cl_error(3, @'stream-error', @':stream', strm); } cl_object si_signal_type_error(cl_object value, cl_object type) { - return cl_error(5, @'type-error', @':expected-type', type, - @':datum', value); + cl_error(5, @'type-error', @':expected-type', type, + @':datum', value); } void FEwrong_type_argument(cl_object type, cl_object value) { - si_signal_type_error(value, cl_symbol_or_object(type)); + si_signal_type_error(value, cl_symbol_or_object(type)); } void FEwrong_type_only_arg(cl_object function, cl_object value, cl_object type) { - const char *message = - "In ~:[an anonymous function~;~:*function ~A~], " - "the value of the only argument is~& ~S~&which is " - "not of the expected type ~A"; - cl_env_ptr env = ecl_process_env(); - struct ecl_ihs_frame tmp_ihs; - function = cl_symbol_or_object(function); - type = cl_symbol_or_object(type); - if (!Null(function) && env->ihs_top && env->ihs_top->function != function) { - ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL); - } - si_signal_simple_error(8, - @'type-error', /* condition name */ - ECL_NIL, /* not correctable */ - make_constant_base_string(message), /* format control */ - cl_list(3, function, value, type), - @':expected-type', type, - @':datum', value); + const char *message = + "In ~:[an anonymous function~;~:*function ~A~], " + "the value of the only argument is~& ~S~&which is " + "not of the expected type ~A"; + cl_env_ptr env = ecl_process_env(); + struct ecl_ihs_frame tmp_ihs; + function = cl_symbol_or_object(function); + type = cl_symbol_or_object(type); + if (!Null(function) && env->ihs_top && env->ihs_top->function != function) { + ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL); + } + si_signal_simple_error(8, + @'type-error', /* condition name */ + ECL_NIL, /* not correctable */ + make_constant_base_string(message), /* format control */ + cl_list(3, function, value, type), + @':expected-type', type, + @':datum', value); + _ecl_unexpected_return(); } void FEwrong_type_nth_arg(cl_object function, cl_narg narg, cl_object value, cl_object type) { - const char *message = - "In ~:[an anonymous function~;~:*function ~A~], " - "the value of the ~:R argument is~& ~S~&which is " - "not of the expected type ~A"; - cl_env_ptr env = ecl_process_env(); - struct ecl_ihs_frame tmp_ihs; - function = cl_symbol_or_object(function); - type = cl_symbol_or_object(type); - if (!Null(function) && env->ihs_top && env->ihs_top->function != function) { - ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL); - } - si_signal_simple_error(8, - @'type-error', /* condition name */ - ECL_NIL, /* not correctable */ - make_constant_base_string(message), /* format control */ - cl_list(4, function, ecl_make_fixnum(narg), - value, type), - @':expected-type', type, - @':datum', value); + const char *message = + "In ~:[an anonymous function~;~:*function ~A~], " + "the value of the ~:R argument is~& ~S~&which is " + "not of the expected type ~A"; + cl_env_ptr env = ecl_process_env(); + struct ecl_ihs_frame tmp_ihs; + function = cl_symbol_or_object(function); + type = cl_symbol_or_object(type); + if (!Null(function) && env->ihs_top && env->ihs_top->function != function) { + ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL); + } + si_signal_simple_error(8, + @'type-error', /* condition name */ + ECL_NIL, /* not correctable */ + make_constant_base_string(message), /* format control */ + cl_list(4, function, ecl_make_fixnum(narg), + value, type), + @':expected-type', type, + @':datum', value); + _ecl_unexpected_return(); } void FEwrong_type_key_arg(cl_object function, cl_object key, cl_object value, cl_object type) { - const char *message = - "In ~:[an anonymous function~;~:*function ~A~], " - "the value of the argument ~S is~& ~S~&which is " - "not of the expected type ~A"; - cl_env_ptr env = ecl_process_env(); - struct ecl_ihs_frame tmp_ihs; - function = cl_symbol_or_object(function); - type = cl_symbol_or_object(type); - key = cl_symbol_or_object(key); - if (!Null(function) && env->ihs_top && env->ihs_top->function != function) { - ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL); - } - si_signal_simple_error(8, - @'type-error', /* condition name */ - ECL_NIL, /* not correctable */ - make_constant_base_string(message), /* format control */ - cl_list(4, function, key, value, type), - @':expected-type', type, - @':datum', value); + const char *message = + "In ~:[an anonymous function~;~:*function ~A~], " + "the value of the argument ~S is~& ~S~&which is " + "not of the expected type ~A"; + cl_env_ptr env = ecl_process_env(); + struct ecl_ihs_frame tmp_ihs; + function = cl_symbol_or_object(function); + type = cl_symbol_or_object(type); + key = cl_symbol_or_object(key); + if (!Null(function) && env->ihs_top && env->ihs_top->function != function) { + ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL); + } + si_signal_simple_error(8, + @'type-error', /* condition name */ + ECL_NIL, /* not correctable */ + make_constant_base_string(message), /* format control */ + cl_list(4, function, key, value, type), + @':expected-type', type, + @':datum', value); + _ecl_unexpected_return(); } void FEwrong_index(cl_object function, cl_object a, int which, cl_object ndx, cl_index nonincl_limit) { - const char *message1 = - "In ~:[an anonymous function~;~:*function ~A~], " - "the ~*index into the object~% ~A.~%" - "takes a value ~D out of the range ~A."; - const char *message2 = - "In ~:[an anonymous function~;~:*function ~A~], " - "the ~:R index into the object~% ~A~%" - "takes a value ~D out of the range ~A."; - cl_object limit = ecl_make_integer(nonincl_limit-1); - cl_object type = ecl_make_integer_type(ecl_make_fixnum(0), limit); - cl_object message = make_constant_base_string((which<0) ? message1 : message2); - cl_env_ptr env = ecl_process_env(); - struct ecl_ihs_frame tmp_ihs; - function = cl_symbol_or_object(function); - if (!Null(function) && env->ihs_top && env->ihs_top->function != function) { - ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL); - } - cl_error(9, - @'simple-type-error', /* condition name */ - @':format-control', message, - @':format-arguments', - cl_list(5, function, ecl_make_fixnum(which+1), a, ndx, type), - @':expected-type', type, - @':datum', ndx); + const char *message1 = + "In ~:[an anonymous function~;~:*function ~A~], " + "the ~*index into the object~% ~A.~%" + "takes a value ~D out of the range ~A."; + const char *message2 = + "In ~:[an anonymous function~;~:*function ~A~], " + "the ~:R index into the object~% ~A~%" + "takes a value ~D out of the range ~A."; + cl_object limit = ecl_make_integer(nonincl_limit-1); + cl_object type = ecl_make_integer_type(ecl_make_fixnum(0), limit); + cl_object message = make_constant_base_string((which<0) ? message1 : message2); + cl_env_ptr env = ecl_process_env(); + struct ecl_ihs_frame tmp_ihs; + function = cl_symbol_or_object(function); + if (!Null(function) && env->ihs_top && env->ihs_top->function != function) { + ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL); + } + cl_error(9, + @'simple-type-error', /* condition name */ + @':format-control', message, + @':format-arguments', + cl_list(5, function, ecl_make_fixnum(which+1), a, ndx, type), + @':expected-type', type, + @':datum', ndx); } void FEunbound_variable(cl_object sym) { - cl_error(3, @'unbound-variable', @':name', sym); + cl_error(3, @'unbound-variable', @':name', sym); } void FEundefined_function(cl_object fname) { - cl_error(3, @'undefined-function', @':name', fname); + cl_error(3, @'undefined-function', @':name', fname); } void FEprint_not_readable(cl_object x) { - cl_error(3, @'print-not-readable', @':object', x); + cl_error(3, @'print-not-readable', @':object', x); } /************* @@ -385,49 +387,49 @@ void FEwrong_num_arguments(cl_object fun) { - fun = cl_symbol_or_object(fun); - FEprogram_error("Wrong number of arguments passed to function ~S.", - 1, fun); + fun = cl_symbol_or_object(fun); + FEprogram_error("Wrong number of arguments passed to function ~S.", + 1, fun); } void FEwrong_num_arguments_anonym(void) { - FEprogram_error("Wrong number of arguments passed to an anonymous function", 0); + FEprogram_error("Wrong number of arguments passed to an anonymous function", 0); } void FEinvalid_macro_call(cl_object name) { - FEerror("Invalid macro call to ~S.", 1, name); + FEerror("Invalid macro call to ~S.", 1, name); } void FEinvalid_variable(const char *s, cl_object obj) { - FEerror(s, 1, obj); + FEerror(s, 1, obj); } void FEassignment_to_constant(cl_object v) { - FEprogram_error("SETQ: Tried to assign a value to the constant ~S.", 1, v); + FEprogram_error("SETQ: Tried to assign a value to the constant ~S.", 1, v); } void FEinvalid_function(cl_object obj) { - FEwrong_type_argument(@'function', obj); + FEwrong_type_argument(@'function', obj); } void FEinvalid_function_name(cl_object fname) { - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("Not a valid function name ~D"), - @':format-arguments', cl_list(1, fname), - @':expected-type', cl_list(2, @'satisfies', @'si::valid-function-name-p'), - @':datum', fname); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("Not a valid function name ~D"), + @':format-arguments', cl_list(1, fname), + @':expected-type', cl_list(2, @'satisfies', @'si::valid-function-name-p'), + @':datum', fname); } /* bootstrap version */ @@ -437,42 +439,42 @@ universal_error_handler(cl_object continue_string, cl_object datum, cl_object args) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object stream; - if (recursive_error) - goto ABORT; - recursive_error = 1; - stream = cl_core.error_output; - if (!Null(stream)) { - ecl_bds_bind(the_env, @'*print-readably*', ECL_NIL); - ecl_bds_bind(the_env, @'*print-level*', ecl_make_fixnum(3)); - ecl_bds_bind(the_env, @'*print-length*', ecl_make_fixnum(3)); - ecl_bds_bind(the_env, @'*print-circle*', ECL_NIL); - ecl_bds_bind(the_env, @'*print-base*', ecl_make_fixnum(10)); - writestr_stream("\n;;; Unhandled lisp initialization error", - stream); - writestr_stream("\n;;; Message:\n", stream); - si_write_ugly_object(datum, stream); - writestr_stream("\n;;; Arguments:\n", stream); - si_write_ugly_object(args, stream); - ecl_bds_unwind_n(the_env, 5); - } + const cl_env_ptr the_env = ecl_process_env(); + cl_object stream; + if (recursive_error) + goto ABORT; + recursive_error = 1; + stream = cl_core.error_output; + if (!Null(stream)) { + ecl_bds_bind(the_env, @'*print-readably*', ECL_NIL); + ecl_bds_bind(the_env, @'*print-level*', ecl_make_fixnum(3)); + ecl_bds_bind(the_env, @'*print-length*', ecl_make_fixnum(3)); + ecl_bds_bind(the_env, @'*print-circle*', ECL_NIL); + ecl_bds_bind(the_env, @'*print-base*', ecl_make_fixnum(10)); + writestr_stream("\n;;; Unhandled lisp initialization error", + stream); + writestr_stream("\n;;; Message:\n", stream); + si_write_ugly_object(datum, stream); + writestr_stream("\n;;; Arguments:\n", stream); + si_write_ugly_object(args, stream); + ecl_bds_unwind_n(the_env, 5); + } ABORT: - ecl_internal_error("\nLisp initialization error.\n"); + ecl_internal_error("\nLisp initialization error.\n"); } void FEdivision_by_zero(cl_object x, cl_object y) { - cl_error(5, @'division-by-zero', @':operation', @'/', - @':operands', cl_list(2, x, y)); + cl_error(5, @'division-by-zero', @':operation', @'/', + @':operands', cl_list(2, x, y)); } cl_object _ecl_strerror(int code) { - const char *error = strerror(code); - return make_base_string_copy(error); + const char *error = strerror(code); + return make_base_string_copy(error); } /************************************* @@ -486,15 +488,15 @@ void FElibc_error(const char *msg, int narg, ...) { - ecl_va_list args; - cl_object rest, error = _ecl_strerror(errno); + ecl_va_list args; + cl_object rest, error = _ecl_strerror(errno); - ecl_va_start(args, narg, narg, 0); - rest = cl_grab_rest_args(args); + ecl_va_start(args, narg, narg, 0); + rest = cl_grab_rest_args(args); - FEerror("~?~%C library explanation: ~A.", 3, - make_constant_base_string(msg), rest, - error); + FEerror("~?~%C library explanation: ~A.", 3, + make_constant_base_string(msg), rest, + error); } #if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin) @@ -503,23 +505,23 @@ void FEwin32_error(const char *msg, int narg, ...) { - ecl_va_list args; - cl_object rest, win_msg_obj; - char *win_msg; - - if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_ALLOCATE_BUFFER, - 0, GetLastError(), 0, (void*)&win_msg, 0, NULL) == 0) - win_msg_obj = unknown_error; - else { - win_msg_obj = make_base_string_copy(win_msg); - LocalFree(win_msg); - } - - ecl_va_start(args, narg, narg, 0); - rest = cl_grab_rest_args(args); - FEerror("~?~%Windows library explanation: ~A.", 3, - make_constant_base_string(msg), rest, - win_msg_obj); + ecl_va_list args; + cl_object rest, win_msg_obj; + char *win_msg; + + if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_ALLOCATE_BUFFER, + 0, GetLastError(), 0, (void*)&win_msg, 0, NULL) == 0) + win_msg_obj = unknown_error; + else { + win_msg_obj = make_base_string_copy(win_msg); + LocalFree(win_msg); + } + + ecl_va_start(args, narg, narg, 0); + rest = cl_grab_rest_args(args); + FEerror("~?~%Windows library explanation: ~A.", 3, + make_constant_base_string(msg), rest, + win_msg_obj); } #endif @@ -528,32 +530,31 @@ ************************************/ @(defun error (eformat &rest args) -@ - ecl_enable_interrupts(); - funcall(4, @'si::universal-error-handler', ECL_NIL, eformat, - cl_grab_rest_args(args)); - _ecl_unexpected_return(); - @(return); -@) +@ { + ecl_enable_interrupts(); + funcall(4, @'si::universal-error-handler', ECL_NIL, eformat, + cl_grab_rest_args(args)); + _ecl_unexpected_return(); +} @) @(defun cerror (cformat eformat &rest args) -@ - ecl_enable_interrupts(); - return funcall(4, @'si::universal-error-handler', cformat, eformat, - cl_grab_rest_args(args)); -@) +@ { + ecl_enable_interrupts(); + return funcall(4, @'si::universal-error-handler', cformat, eformat, + cl_grab_rest_args(args)); +} @) @(defun si::serror (cformat eformat &rest args) -@ - ecl_enable_interrupts(); - return funcall(4, @'si::stack-error-handler', cformat, eformat, - cl_grab_rest_args(args)); -@) +@ { + ecl_enable_interrupts(); + return funcall(4, @'si::stack-error-handler', cformat, eformat, + cl_grab_rest_args(args)); +} @) void init_error(void) { - ecl_def_c_function(@'si::universal-error-handler', - (cl_objectfn_fixed)universal_error_handler, - 3); + ecl_def_c_function(@'si::universal-error-handler', + (cl_objectfn_fixed)universal_error_handler, + 3); } diff -Nru ecl-16.1.2/src/c/eval.d ecl-16.1.3+ds/src/c/eval.d --- ecl-16.1.2/src/c/eval.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/eval.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,22 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - eval.c -- Eval. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ - + * eval.d - evaluation + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -25,234 +19,230 @@ cl_object * _ecl_va_sp(cl_narg narg) { - return ecl_process_env()->stack_top - narg; + return ecl_process_env()->stack_top - narg; } /* Calling conventions: - Compiled C code calls lisp function supplying #args, and args. - Linking function performs check_args, gets jmp_buf with _setjmp, then - if cfun then stores C code address into function link location - and transfers to jmp_buf at cf_self - if cclosure then replaces #args with cc_env and calls cc_self - otherwise, it emulates funcall. + * Compiled C code calls lisp function supplying #args, and args. + * Linking function performs check_args, gets jmp_buf with _setjmp, then + * if cfun then stores C code address into function link location + * and transfers to jmp_buf at cf_self + * if cclosure then replaces #args with cc_env and calls cc_self + * otherwise, it emulates funcall. */ cl_object ecl_apply_from_stack_frame(cl_object frame, cl_object x) { - cl_object *sp = frame->frame.base; - cl_index narg = frame->frame.size; - cl_object fun = x; - AGAIN: - frame->frame.env->function = fun; - if (ecl_unlikely(fun == OBJNULL || fun == ECL_NIL)) - FEundefined_function(x); - switch (ecl_t_of(fun)) { - case t_cfunfixed: - if (ecl_unlikely(narg != (cl_index)fun->cfun.narg)) - FEwrong_num_arguments(fun); - return APPLY_fixed(narg, fun->cfunfixed.entry_fixed, sp); - case t_cfun: - return APPLY(narg, fun->cfun.entry, sp); - case t_cclosure: - return APPLY(narg, fun->cclosure.entry, sp); - case t_instance: - switch (fun->instance.isgf) { - case ECL_STANDARD_DISPATCH: - case ECL_RESTRICTED_DISPATCH: - return _ecl_standard_dispatch(frame, fun); - case ECL_USER_DISPATCH: - fun = fun->instance.slots[fun->instance.length - 1]; - goto AGAIN; - case ECL_READER_DISPATCH: - case ECL_WRITER_DISPATCH: - return APPLY(narg, fun->instance.entry, sp); - default: - FEinvalid_function(fun); - } - case t_symbol: - if (ecl_unlikely(fun->symbol.stype & ecl_stp_macro)) - FEundefined_function(x); - fun = ECL_SYM_FUN(fun); - goto AGAIN; - case t_bytecodes: - return ecl_interpret(frame, ECL_NIL, fun); - case t_bclosure: - return ecl_interpret(frame, fun->bclosure.lex, fun->bclosure.code); - default: - FEinvalid_function(x); - } + cl_object *sp = frame->frame.base; + cl_index narg = frame->frame.size; + cl_object fun = x; + AGAIN: + frame->frame.env->function = fun; + if (ecl_unlikely(fun == OBJNULL || fun == ECL_NIL)) + FEundefined_function(x); + switch (ecl_t_of(fun)) { + case t_cfunfixed: + if (ecl_unlikely(narg != (cl_index)fun->cfun.narg)) + FEwrong_num_arguments(fun); + return APPLY_fixed(narg, fun->cfunfixed.entry_fixed, sp); + case t_cfun: + return APPLY(narg, fun->cfun.entry, sp); + case t_cclosure: + return APPLY(narg, fun->cclosure.entry, sp); + case t_instance: + switch (fun->instance.isgf) { + case ECL_STANDARD_DISPATCH: + case ECL_RESTRICTED_DISPATCH: + return _ecl_standard_dispatch(frame, fun); + case ECL_USER_DISPATCH: + fun = fun->instance.slots[fun->instance.length - 1]; + goto AGAIN; + case ECL_READER_DISPATCH: + case ECL_WRITER_DISPATCH: + return APPLY(narg, fun->instance.entry, sp); + default: + FEinvalid_function(fun); + } + case t_symbol: + if (ecl_unlikely(fun->symbol.stype & ecl_stp_macro)) + FEundefined_function(x); + fun = ECL_SYM_FUN(fun); + goto AGAIN; + case t_bytecodes: + return ecl_interpret(frame, ECL_NIL, fun); + case t_bclosure: + return ecl_interpret(frame, fun->bclosure.lex, fun->bclosure.code); + default: + FEinvalid_function(x); + } } cl_objectfn ecl_function_dispatch(cl_env_ptr env, cl_object x) { - cl_object fun = x; + cl_object fun = x; AGAIN: - if (ecl_unlikely(fun == OBJNULL || fun == ECL_NIL)) - FEundefined_function(x); - switch (ecl_t_of(fun)) { - case t_cfunfixed: - env->function = fun; - return fun->cfunfixed.entry; - case t_cfun: - env->function = fun; - return fun->cfun.entry; - case t_cclosure: - env->function = fun; - return fun->cclosure.entry; - case t_instance: - env->function = fun; - return fun->instance.entry; - case t_symbol: - if (ecl_unlikely(fun->symbol.stype & ecl_stp_macro)) - FEundefined_function(x); - fun = ECL_SYM_FUN(fun); - goto AGAIN; - case t_bytecodes: - env->function = fun; - return fun->bytecodes.entry; - case t_bclosure: - env->function = fun; - return fun->bclosure.entry; - default: - FEinvalid_function(x); - } + if (ecl_unlikely(fun == OBJNULL || fun == ECL_NIL)) + FEundefined_function(x); + switch (ecl_t_of(fun)) { + case t_cfunfixed: + env->function = fun; + return fun->cfunfixed.entry; + case t_cfun: + env->function = fun; + return fun->cfun.entry; + case t_cclosure: + env->function = fun; + return fun->cclosure.entry; + case t_instance: + env->function = fun; + return fun->instance.entry; + case t_symbol: + if (ecl_unlikely(fun->symbol.stype & ecl_stp_macro)) + FEundefined_function(x); + fun = ECL_SYM_FUN(fun); + goto AGAIN; + case t_bytecodes: + env->function = fun; + return fun->bytecodes.entry; + case t_bclosure: + env->function = fun; + return fun->bclosure.entry; + default: + FEinvalid_function(x); + } } cl_object cl_funcall(cl_narg narg, cl_object function, ...) { - cl_object output; - --narg; - { - ECL_STACK_FRAME_VARARGS_BEGIN(narg, function, frame); - output = ecl_apply_from_stack_frame(frame, function); - ECL_STACK_FRAME_VARARGS_END(frame); - } - return output; + cl_object output; + --narg; + { + ECL_STACK_FRAME_VARARGS_BEGIN(narg, function, frame); + output = ecl_apply_from_stack_frame(frame, function); + ECL_STACK_FRAME_VARARGS_END(frame); + } + return output; } @(defun apply (fun lastarg &rest args) -@ - if (narg == 2 && ecl_t_of(lastarg) == t_frame) { - return ecl_apply_from_stack_frame(lastarg, fun); - } else { - cl_object out; - cl_index i; - struct ecl_stack_frame frame_aux; - const cl_object frame = ecl_stack_frame_open(the_env, - (cl_object)&frame_aux, - narg -= 2); - for (i = 0; i < narg; i++) { - ECL_STACK_FRAME_SET(frame, i, lastarg); - lastarg = ecl_va_arg(args); - } - if (ecl_t_of(lastarg) == t_frame) { - /* This could be replaced with a memcpy() */ - for (i = 0; i < lastarg->frame.size; i++) { - ecl_stack_frame_push(frame, lastarg->frame.base[i]); - } - } else loop_for_in (lastarg) { - if (ecl_unlikely(i >= ECL_CALL_ARGUMENTS_LIMIT)) { - ecl_stack_frame_close(frame); - FEprogram_error_noreturn("CALL-ARGUMENTS-LIMIT exceeded",0); - } - ecl_stack_frame_push(frame, CAR(lastarg)); - i++; - } end_loop_for_in; - out = ecl_apply_from_stack_frame(frame, fun); - ecl_stack_frame_close(frame); - return out; - } -@) +@ { + if (narg == 2 && ecl_t_of(lastarg) == t_frame) { + return ecl_apply_from_stack_frame(lastarg, fun); + } else { + cl_object out; + cl_index i; + struct ecl_stack_frame frame_aux; + const cl_object frame = ecl_stack_frame_open(the_env, + (cl_object)&frame_aux, + narg -= 2); + for (i = 0; i < narg; i++) { + ECL_STACK_FRAME_SET(frame, i, lastarg); + lastarg = ecl_va_arg(args); + } + if (ecl_t_of(lastarg) == t_frame) { + /* This could be replaced with a memcpy() */ + for (i = 0; i < lastarg->frame.size; i++) { + ecl_stack_frame_push(frame, lastarg->frame.base[i]); + } + } else loop_for_in (lastarg) { + if (ecl_unlikely(i >= ECL_CALL_ARGUMENTS_LIMIT)) { + ecl_stack_frame_close(frame); + FEprogram_error_noreturn("CALL-ARGUMENTS-LIMIT exceeded",0); + } + ecl_stack_frame_push(frame, CAR(lastarg)); + i++; + } end_loop_for_in; + out = ecl_apply_from_stack_frame(frame, fun); + ecl_stack_frame_close(frame); + return out; + } +}@) cl_object cl_eval(cl_object form) { - return si_eval_with_env(1, form); + return si_eval_with_env(1, form); } @(defun constantp (arg &optional env) @ - return _ecl_funcall3(@'ext::constantp-inner', arg, env); + return _ecl_funcall3(@'ext::constantp-inner', arg, env); @) @(defun ext::constantp-inner (form &optional env) - cl_object value; -@ + cl_object value; +@ { AGAIN: - switch (ecl_t_of(form)) { - case t_list: - if (Null(form)) { - value = ECL_T; - break; - } - if (ECL_CONS_CAR(form) == @'quote') { - value = ECL_T; - break; - } - /* - value = cl_macroexpand(2, form, env); - if (value != form) { - form = value; - goto AGAIN; - } - */ - value = ECL_NIL; - break; - case t_symbol: - value = cl_macroexpand(2, form, env); - if (value != form) { - form = value; - goto AGAIN; - } - if (!(form->symbol.stype & ecl_stp_constant)) { - value = ECL_NIL; - break; - } - default: - value = ECL_T; - } - ecl_return1(the_env, value); -@) + switch (ecl_t_of(form)) { + case t_list: + if (Null(form)) { + value = ECL_T; + break; + } + if (ECL_CONS_CAR(form) == @'quote') { + value = ECL_T; + break; + } + /* + value = cl_macroexpand(2, form, env); + if (value != form) { + form = value; + goto AGAIN; + } + */ + value = ECL_NIL; + break; + case t_symbol: + value = cl_macroexpand(2, form, env); + if (value != form) { + form = value; + goto AGAIN; + } + if (!(form->symbol.stype & ecl_stp_constant)) { + value = ECL_NIL; + break; + } + default: + value = ECL_T; + } + ecl_return1(the_env, value); +} @) @(defun ext::constant-form-value (form &optional env) - cl_object value; -@ -{ - AGAIN: - switch (ecl_t_of(form)) { - case t_list: - if (Null(form)) { - value = ECL_NIL; - break; - } - if (ECL_CONS_CAR(form) == @'quote') { - return cl_second(form); - } - /* - value = cl_macroexpand(2, form, env); - if (value != form) { - form = value; - goto AGAIN; - } - */ - ERROR: - FEerror("EXT:CONSTANT-FORM-VALUE invoked with a non-constant form ~A", - 0, form); - break; - case t_symbol: - value = cl_macroexpand(2, form, env); - if (value != form) { - form = value; - goto AGAIN; - } - value = ECL_SYM_VAL(the_env, value); - break; - default: - value = form; - } - @(return value); -} -@) + cl_object value; +@ { + AGAIN: + switch (ecl_t_of(form)) { + case t_list: + if (Null(form)) { + value = ECL_NIL; + break; + } + if (ECL_CONS_CAR(form) == @'quote') { + return cl_second(form); + } + /* value = cl_macroexpand(2, form, env); */ + /* if (value != form) { */ + /* form = value; */ + /* goto AGAIN; */ + /* } */ + ERROR: + FEerror("EXT:CONSTANT-FORM-VALUE invoked with a non-constant form ~A", + 0, form); + break; + case t_symbol: + value = cl_macroexpand(2, form, env); + if (value != form) { + form = value; + goto AGAIN; + } + value = ECL_SYM_VAL(the_env, value); + break; + default: + value = form; + } + @(return value); +} @) diff -Nru ecl-16.1.2/src/c/ffi/backtrace.d ecl-16.1.3+ds/src/c/ffi/backtrace.d --- ecl-16.1.2/src/c/ffi/backtrace.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/ffi/backtrace.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - backtrace.d -- C backtraces -*/ -/* - Copyright (c) 2010, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * backtrace.d - C backtraces + * + * Copyright (c) 2010 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -34,43 +29,43 @@ static int backtrace(void **buffer, int n) { - int nframes = (n > 32)? 32 : n; - int i; - switch (nframes) { - case 32: buffer[31] = __builtin_return_address(31); - case 31: buffer[30] = __builtin_return_address(30); - case 30: buffer[29] = __builtin_return_address(29); - case 29: buffer[28] = __builtin_return_address(28); - case 28: buffer[27] = __builtin_return_address(27); - case 27: buffer[26] = __builtin_return_address(26); - case 26: buffer[25] = __builtin_return_address(25); - case 25: buffer[24] = __builtin_return_address(24); - case 24: buffer[23] = __builtin_return_address(23); - case 23: buffer[22] = __builtin_return_address(22); - case 22: buffer[21] = __builtin_return_address(21); - case 21: buffer[20] = __builtin_return_address(20); - case 20: buffer[19] = __builtin_return_address(19); - case 19: buffer[18] = __builtin_return_address(18); - case 18: buffer[17] = __builtin_return_address(17); - case 17: buffer[16] = __builtin_return_address(16); - case 16: buffer[15] = __builtin_return_address(15); - case 15: buffer[14] = __builtin_return_address(14); - case 14: buffer[13] = __builtin_return_address(13); - case 13: buffer[12] = __builtin_return_address(12); - case 12: buffer[11] = __builtin_return_address(11); - case 11: buffer[10] = __builtin_return_address(10); - case 10: buffer[9] = __builtin_return_address(9); - case 9: buffer[8] = __builtin_return_address(8); - case 8: buffer[7] = __builtin_return_address(7); - case 7: buffer[6] = __builtin_return_address(6); - case 6: buffer[5] = __builtin_return_address(5); - case 5: buffer[4] = __builtin_return_address(4); - case 4: buffer[3] = __builtin_return_address(3); - case 3: buffer[2] = __builtin_return_address(2); - case 2: buffer[1] = __builtin_return_address(1); - case 1: buffer[0] = __builtin_return_address(0); - } - return nframes; + int nframes = (n > 32)? 32 : n; + int i; + switch (nframes) { + case 32: buffer[31] = __builtin_return_address(31); + case 31: buffer[30] = __builtin_return_address(30); + case 30: buffer[29] = __builtin_return_address(29); + case 29: buffer[28] = __builtin_return_address(28); + case 28: buffer[27] = __builtin_return_address(27); + case 27: buffer[26] = __builtin_return_address(26); + case 26: buffer[25] = __builtin_return_address(25); + case 25: buffer[24] = __builtin_return_address(24); + case 24: buffer[23] = __builtin_return_address(23); + case 23: buffer[22] = __builtin_return_address(22); + case 22: buffer[21] = __builtin_return_address(21); + case 21: buffer[20] = __builtin_return_address(20); + case 20: buffer[19] = __builtin_return_address(19); + case 19: buffer[18] = __builtin_return_address(18); + case 18: buffer[17] = __builtin_return_address(17); + case 17: buffer[16] = __builtin_return_address(16); + case 16: buffer[15] = __builtin_return_address(15); + case 15: buffer[14] = __builtin_return_address(14); + case 14: buffer[13] = __builtin_return_address(13); + case 13: buffer[12] = __builtin_return_address(12); + case 12: buffer[11] = __builtin_return_address(11); + case 11: buffer[10] = __builtin_return_address(10); + case 10: buffer[9] = __builtin_return_address(9); + case 9: buffer[8] = __builtin_return_address(8); + case 8: buffer[7] = __builtin_return_address(7); + case 7: buffer[6] = __builtin_return_address(6); + case 6: buffer[5] = __builtin_return_address(5); + case 5: buffer[4] = __builtin_return_address(4); + case 4: buffer[3] = __builtin_return_address(3); + case 3: buffer[2] = __builtin_return_address(2); + case 2: buffer[1] = __builtin_return_address(1); + case 1: buffer[0] = __builtin_return_address(0); + } + return nframes; } #endif @@ -81,17 +76,17 @@ static char ** backtrace_symbols(void **buffer, int nframes) { - Dl_info data[1]; - int i; - char **strings = malloc(nframes * sizeof(char*)); - for (i = 0; i < nframes; i++) { - if (dladdr(buffer[i], data)) { - strings[i] = data->dli_sname; - } else { - strings[i] = "unknown"; - } - } - return strings; + Dl_info data[1]; + int i; + char **strings = malloc(nframes * sizeof(char*)); + for (i = 0; i < nframes; i++) { + if (dladdr(buffer[i], data)) { + strings[i] = data->dli_sname; + } else { + strings[i] = "unknown"; + } + } + return strings; } # endif /* HAVE_BACKTRACE && HAVE_DLADDR */ #endif /* !HAVE_BACKTRACE_SYMBOLS */ @@ -99,32 +94,32 @@ cl_object si_dump_c_backtrace(cl_object size) { - cl_env_ptr the_env = ecl_process_env(); + cl_env_ptr the_env = ecl_process_env(); #ifdef HAVE_BACKTRACE_SYMBOLS - { - void *pointers[32]; - int nframes = backtrace(pointers, 32); - char **names = backtrace_symbols(pointers, nframes); - int i; - fprintf(stderr, "\n;;; ECL C Backtrace\n"); - for (i = 0; i < nframes; i++) { + { + void *pointers[32]; + int nframes = backtrace(pointers, 32); + char **names = backtrace_symbols(pointers, nframes); + int i; + fprintf(stderr, "\n;;; ECL C Backtrace\n"); + for (i = 0; i < nframes; i++) { #ifdef BACKTRACE_SYMBOLS_SIMPLE - fprintf(stderr, ";;; %4d %s (%p) \n", i, names[i], pointers[i]); + fprintf(stderr, ";;; %4d %s (%p) \n", i, names[i], pointers[i]); #else - fprintf(stderr, ";;; %s\n", names[i]); + fprintf(stderr, ";;; %s\n", names[i]); #endif - } - fflush(stderr); - free(names); - } - ecl_return1(the_env, ECL_T); + } + fflush(stderr); + free(names); + } + ecl_return1(the_env, ECL_T); #else - ecl_return1(the_env, ECL_NIL); + ecl_return1(the_env, ECL_NIL); #endif } cl_object si_backtrace(cl_object start, cl_object end) { - @(return ECL_NIL) + @(return ECL_NIL); } diff -Nru ecl-16.1.2/src/c/ffi/cdata.d ecl-16.1.3+ds/src/c/ffi/cdata.d --- ecl-16.1.2/src/c/ffi/cdata.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/ffi/cdata.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - cdata.d -- Data for compiled files. -*/ -/* - Copyright (c) 2011, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * cdata.d - data for compiled files + * + * Copyright (c) 2011 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -23,8 +18,8 @@ #define HEADER_PREFIX_LENGTH 15 typedef struct { - char code[16]; - cl_index offset, size; + char code[16]; + cl_index offset, size; } cdata_header; ecl_def_ct_base_string(str_no_data,"",0,static,const); @@ -32,55 +27,55 @@ cl_object si_get_cdata(cl_object filename) { - cl_object map, array, displaced; - cdata_header *header; - map = si_mmap(3, filename, @':direction', @':input'); - array = si_mmap_array(map); - { - char *v = (char*)array->base_string.self - + array->base_string.dim - - sizeof(cdata_header); - header = (cdata_header*)v; + cl_object map, array, displaced; + cdata_header *header; + map = si_mmap(3, filename, @':direction', @':input'); + array = si_mmap_array(map); + { + char *v = (char*)array->base_string.self + + array->base_string.dim + - sizeof(cdata_header); + header = (cdata_header*)v; - } - if (memcmp(header->code, HEADER_PREFIX, HEADER_PREFIX_LENGTH)) { - displaced = str_no_data; - } else { - displaced = cl_funcall(8, @'make-array', - ecl_make_fixnum(header->size), - @':element-type', @'base-char', - @':displaced-to', array, - @':displaced-index-offset', - ecl_make_fixnum(header->offset)); - } - @(return map displaced); + } + if (memcmp(header->code, HEADER_PREFIX, HEADER_PREFIX_LENGTH)) { + displaced = str_no_data; + } else { + displaced = cl_funcall(8, @'make-array', + ecl_make_fixnum(header->size), + @':element-type', @'base-char', + @':displaced-to', array, + @':displaced-index-offset', + ecl_make_fixnum(header->offset)); + } + @(return map displaced); } cl_object si_add_cdata(cl_object filename, cl_object data) { - cl_object stream, offset; - cdata_header header; + cl_object stream, offset; + cdata_header header; - data = si_copy_to_simple_base_string(data); - stream = cl_open(9, filename, - @':element-type', @'base-char', - @':direction', @':output', - @':if-does-not-exist', @':error', - @':if-exists', @':append'); - offset = ecl_file_length(stream); - ecl_file_position_set(stream, offset); - cl_write_sequence(2, data, stream); - memcpy(header.code, HEADER_PREFIX, HEADER_PREFIX_LENGTH); - header.offset = fixnnint(offset); - header.size = data->base_string.dim; - { - unsigned char *c = (unsigned char *)&header; - int i; - for (i = 0; i < sizeof(header); i++) { - ecl_write_byte(ecl_make_fixnum(c[i]), stream); - } - } - cl_close(1, stream); - @(return) + data = si_copy_to_simple_base_string(data); + stream = cl_open(9, filename, + @':element-type', @'base-char', + @':direction', @':output', + @':if-does-not-exist', @':error', + @':if-exists', @':append'); + offset = ecl_file_length(stream); + ecl_file_position_set(stream, offset); + cl_write_sequence(2, data, stream); + memcpy(header.code, HEADER_PREFIX, HEADER_PREFIX_LENGTH); + header.offset = fixnnint(offset); + header.size = data->base_string.dim; + { + unsigned char *c = (unsigned char *)&header; + int i; + for (i = 0; i < sizeof(header); i++) { + ecl_write_byte(ecl_make_fixnum(c[i]), stream); + } + } + cl_close(1, stream); + @(return); } diff -Nru ecl-16.1.2/src/c/ffi/libraries.d ecl-16.1.3+ds/src/c/ffi/libraries.d --- ecl-16.1.2/src/c/ffi/libraries.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/ffi/libraries.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,20 +1,15 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - load.d -- Shared library and bundle opening / copying / closing -*/ -/* - Copyright (c) 1990, Giuseppe Attardi and William F. Schelter. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * libraries.d - shared library and bundle opening / copying / closing + * + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include /* @@ -78,384 +73,384 @@ cl_object ecl_make_codeblock() { - cl_object block = ecl_alloc(t_codeblock); - block = ecl_alloc_object(t_codeblock); - block->cblock.self_destruct = 0; - block->cblock.locked = 0; - block->cblock.handle = NULL; - block->cblock.data = NULL; - block->cblock.data_size = 0; - block->cblock.temp_data = NULL; - block->cblock.temp_data_size = 0; - block->cblock.data_text = NULL; - block->cblock.next = ECL_NIL; - block->cblock.name = ECL_NIL; - block->cblock.links = ECL_NIL; - block->cblock.cfuns_size = 0; - block->cblock.cfuns = NULL; - block->cblock.source = ECL_NIL; - block->cblock.error = ECL_NIL; - block->cblock.refs = ecl_make_fixnum(0); - si_set_finalizer(block, ECL_T); - return block; + cl_object block = ecl_alloc(t_codeblock); + block = ecl_alloc_object(t_codeblock); + block->cblock.self_destruct = 0; + block->cblock.locked = 0; + block->cblock.handle = NULL; + block->cblock.data = NULL; + block->cblock.data_size = 0; + block->cblock.temp_data = NULL; + block->cblock.temp_data_size = 0; + block->cblock.data_text = NULL; + block->cblock.next = ECL_NIL; + block->cblock.name = ECL_NIL; + block->cblock.links = ECL_NIL; + block->cblock.cfuns_size = 0; + block->cblock.cfuns = NULL; + block->cblock.source = ECL_NIL; + block->cblock.error = ECL_NIL; + block->cblock.refs = ecl_make_fixnum(0); + si_set_finalizer(block, ECL_T); + return block; } static cl_object copy_object_file(cl_object original) { - int err; - cl_object copy = make_constant_base_string("TMP:ECL"); - copy = si_coerce_to_filename(si_mkstemp(copy)); - /* - * We either have to make a full copy to convince the loader to load this object - * file again, or we want to retain the possibility of overwriting the object - * file we load later on (case of Windows, which locks files that are loaded). - * The symlinks do not seem to work in latest versions of Linux. - */ + int err; + cl_object copy = make_constant_base_string("TMP:ECL"); + copy = si_coerce_to_filename(si_mkstemp(copy)); + /* + * We either have to make a full copy to convince the loader to load this object + * file again, or we want to retain the possibility of overwriting the object + * file we load later on (case of Windows, which locks files that are loaded). + * The symlinks do not seem to work in latest versions of Linux. + */ #if defined(ECL_MS_WINDOWS_HOST) - ecl_disable_interrupts(); - err = !CopyFile(original->base_string.self, copy->base_string.self, 0); - ecl_enable_interrupts(); - if (err) { - FEwin32_error("Error when copying file from~&~3T~A~&to~&~3T~A", - 2, original, copy); - } + ecl_disable_interrupts(); + err = !CopyFile(original->base_string.self, copy->base_string.self, 0); + ecl_enable_interrupts(); + if (err) { + FEwin32_error("Error when copying file from~&~3T~A~&to~&~3T~A", + 2, original, copy); + } #else - err = Null(si_copy_file(original, copy)); - if (err) { - FEerror("Error when copying file from~&~3T~A~&to~&~3T~A", - 2, original, copy); - } + err = Null(si_copy_file(original, copy)); + if (err) { + FEerror("Error when copying file from~&~3T~A~&to~&~3T~A", + 2, original, copy); + } #endif #ifdef cygwin - { - cl_object new_copy = make_constant_base_string(".dll"); - new_copy = si_base_string_concatenate(2, copy, new_copy); - cl_rename_file(2, copy, new_copy); - copy = new_copy; - } - ecl_disable_interrupts(); - err = chmod(copy->base_string.self, S_IRWXU) < 0; - ecl_enable_interrupts(); - if (err) { - FElibc_error("Unable to give executable permissions to ~A", - 1, copy); - } + { + cl_object new_copy = make_constant_base_string(".dll"); + new_copy = si_base_string_concatenate(2, copy, new_copy); + cl_rename_file(2, copy, new_copy); + copy = new_copy; + } + ecl_disable_interrupts(); + err = chmod(copy->base_string.self, S_IRWXU) < 0; + ecl_enable_interrupts(); + if (err) { + FElibc_error("Unable to give executable permissions to ~A", + 1, copy); + } #endif - return copy; + return copy; } #ifdef ENABLE_DLOPEN static void set_library_error(cl_object block) { - cl_object output; - ecl_disable_interrupts(); + cl_object output; + ecl_disable_interrupts(); #ifdef HAVE_DLFCN_H - output = make_base_string_copy(dlerror()); + output = make_base_string_copy(dlerror()); #endif #ifdef HAVE_MACH_O_DYLD_H - { - NSLinkEditErrors c; - int number; - const char *filename; - NSLinkEditError(&c, &number, &filename, &message); - output = make_base_string_copy(message); - } + { + NSLinkEditErrors c; + int number; + const char *filename; + NSLinkEditError(&c, &number, &filename, &message); + output = make_base_string_copy(message); + } #endif #if defined(ECL_MS_WINDOWS_HOST) - { - const char *message; - FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | - FORMAT_MESSAGE_ALLOCATE_BUFFER, - 0, GetLastError(), 0, (void*)&message, 0, NULL); - output = make_base_string_copy(message); - LocalFree(message); - } + { + const char *message; + FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | + FORMAT_MESSAGE_ALLOCATE_BUFFER, + 0, GetLastError(), 0, (void*)&message, 0, NULL); + output = make_base_string_copy(message); + LocalFree(message); + } #endif - ecl_enable_interrupts(); - block->cblock.error = output; + ecl_enable_interrupts(); + block->cblock.error = output; } static void dlopen_wrapper(cl_object block) { - cl_object filename = block->cblock.name; - char *filename_string = (char*)filename->base_string.self; + cl_object filename = block->cblock.name; + char *filename_string = (char*)filename->base_string.self; #ifdef HAVE_DLFCN_H - block->cblock.handle = dlopen(filename_string, RTLD_NOW|RTLD_GLOBAL); + block->cblock.handle = dlopen(filename_string, RTLD_NOW|RTLD_GLOBAL); #endif #ifdef HAVE_MACH_O_DYLD_H - { - NSObjectFileImage file; - static NSObjectFileImageReturnCode code; - code = NSCreateObjectFileImageFromFile(filename_string, &file); - if (code != NSObjectFileImageSuccess) { - block->cblock.handle = NULL; - } else { - NSModule out = NSLinkModule(file, filename_string, - NSLINKMODULE_OPTION_PRIVATE| - NSLINKMODULE_OPTION_BINDNOW| - NSLINKMODULE_OPTION_RETURN_ON_ERROR); - block->cblock.handle = out; - }} + { + NSObjectFileImage file; + static NSObjectFileImageReturnCode code; + code = NSCreateObjectFileImageFromFile(filename_string, &file); + if (code != NSObjectFileImageSuccess) { + block->cblock.handle = NULL; + } else { + NSModule out = NSLinkModule(file, filename_string, + NSLINKMODULE_OPTION_PRIVATE| + NSLINKMODULE_OPTION_BINDNOW| + NSLINKMODULE_OPTION_RETURN_ON_ERROR); + block->cblock.handle = out; + }} #endif #if defined(ECL_MS_WINDOWS_HOST) - block->cblock.handle = LoadLibrary(filename_string); + block->cblock.handle = LoadLibrary(filename_string); #endif - if (block->cblock.handle == NULL) - set_library_error(block); + if (block->cblock.handle == NULL) + set_library_error(block); } static int dlclose_wrapper(cl_object block) { - if (block->cblock.handle != NULL) { + if (block->cblock.handle != NULL) { #ifdef HAVE_DLFCN_H - dlclose(block->cblock.handle); + dlclose(block->cblock.handle); #endif #ifdef HAVE_MACH_O_DYLD_H - NSUnLinkModule(block->cblock.handle, NSUNLINKMODULE_OPTION_NONE); + NSUnLinkModule(block->cblock.handle, NSUNLINKMODULE_OPTION_NONE); #endif #if defined(ECL_MS_WINDOWS_HOST) - FreeLibrary(block->cblock.handle); + FreeLibrary(block->cblock.handle); #endif - block->cblock.handle = NULL; - return TRUE; - } - return FALSE; + block->cblock.handle = NULL; + return TRUE; + } + return FALSE; } static cl_object ecl_library_find_by_name(cl_object filename) { - cl_object l; - for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { - cl_object other = ECL_CONS_CAR(l); - cl_object name = other->cblock.name; - if (!Null(name) && ecl_string_eq(name, filename)) { - return other; - } - } - return ECL_NIL; + cl_object l; + for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { + cl_object other = ECL_CONS_CAR(l); + cl_object name = other->cblock.name; + if (!Null(name) && ecl_string_eq(name, filename)) { + return other; + } + } + return ECL_NIL; } static cl_object ecl_library_find_by_handle(void *handle) { - cl_object l; - for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { - cl_object other = ECL_CONS_CAR(l); - if (handle == other->cblock.handle) { - return other; - } - } - return ECL_NIL; + cl_object l; + for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { + cl_object other = ECL_CONS_CAR(l); + if (handle == other->cblock.handle) { + return other; + } + } + return ECL_NIL; } static cl_object ecl_library_open_inner(cl_object filename, bool self_destruct) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object block = ecl_make_codeblock(); - block->cblock.self_destruct = self_destruct; - block->cblock.name = filename; - block->cblock.refs = ecl_make_fixnum(1); - - ECL_WITH_GLOBAL_LOCK_BEGIN(the_env) { - ecl_disable_interrupts(); - GC_call_with_alloc_lock(dlopen_wrapper, block); - if (block->cblock.handle != NULL) { - /* Have we already loaded this library? If so, then unload this - * copy and increase the reference counter so that we can keep - * track (in lisp) of how many copies we use. - */ - cl_object other = ecl_library_find_by_handle(block->cblock.handle); - if (other != ECL_NIL) { - GC_call_with_alloc_lock(dlclose_wrapper, block); - block = other; - block->cblock.refs = ecl_one_plus(block->cblock.refs); - } else { - si_set_finalizer(block, ECL_T); - cl_core.libraries = CONS(block, cl_core.libraries); - } - } - ecl_enable_interrupts(); - } ECL_WITH_GLOBAL_LOCK_END; - return block; + const cl_env_ptr the_env = ecl_process_env(); + cl_object block = ecl_make_codeblock(); + block->cblock.self_destruct = self_destruct; + block->cblock.name = filename; + block->cblock.refs = ecl_make_fixnum(1); + + ECL_WITH_GLOBAL_LOCK_BEGIN(the_env) { + ecl_disable_interrupts(); + GC_call_with_alloc_lock(dlopen_wrapper, block); + if (block->cblock.handle != NULL) { + /* Have we already loaded this library? If so, then unload this + * copy and increase the reference counter so that we can keep + * track (in lisp) of how many copies we use. + */ + cl_object other = ecl_library_find_by_handle(block->cblock.handle); + if (other != ECL_NIL) { + GC_call_with_alloc_lock(dlclose_wrapper, block); + block = other; + block->cblock.refs = ecl_one_plus(block->cblock.refs); + } else { + si_set_finalizer(block, ECL_T); + cl_core.libraries = CONS(block, cl_core.libraries); + } + } + ecl_enable_interrupts(); + } ECL_WITH_GLOBAL_LOCK_END; + return block; } cl_object ecl_library_open(cl_object filename, bool force_reload) { - cl_object block; - bool self_destruct = 0; - char *filename_string; - - /* Coerces to a file name but does not merge with cwd */ - filename = coerce_to_physical_pathname(filename); - filename = ecl_namestring(filename, - ECL_NAMESTRING_TRUNCATE_IF_ERROR | - ECL_NAMESTRING_FORCE_BASE_STRING); - - if (!force_reload) { - /* When loading a foreign library, such as a dll or a - * so, it cannot contain any executable top level - * code. In that case force_reload=0 and there is no - * need to reload it if it has already been loaded. */ - block = ecl_library_find_by_name(filename); - if (!Null(block)) { - return block; - } - } else { - /* We are using shared libraries as modules and - * force_reload=1. Here we have to face the problem - * that many operating systems do not allow to load a - * shared library twice, even if it has changed. Hence - * we have to make a unique copy to be able to load - * the same FASL twice. In Windows this copy is - * _always_ made because otherwise it cannot be - * overwritten. In Unix we need only do that when the - * file has been previously loaded. */ + cl_object block; + bool self_destruct = 0; + char *filename_string; + + /* Coerces to a file name but does not merge with cwd */ + filename = coerce_to_physical_pathname(filename); + filename = ecl_namestring(filename, + ECL_NAMESTRING_TRUNCATE_IF_ERROR | + ECL_NAMESTRING_FORCE_BASE_STRING); + + if (!force_reload) { + /* When loading a foreign library, such as a dll or a + * so, it cannot contain any executable top level + * code. In that case force_reload=0 and there is no + * need to reload it if it has already been loaded. */ + block = ecl_library_find_by_name(filename); + if (!Null(block)) { + return block; + } + } else { + /* We are using shared libraries as modules and + * force_reload=1. Here we have to face the problem + * that many operating systems do not allow to load a + * shared library twice, even if it has changed. Hence + * we have to make a unique copy to be able to load + * the same FASL twice. In Windows this copy is + * _always_ made because otherwise it cannot be + * overwritten. In Unix we need only do that when the + * file has been previously loaded. */ #if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin) - filename = copy_object_file(filename); - self_destruct = 1; + filename = copy_object_file(filename); + self_destruct = 1; #else - block = ecl_library_find_by_name(filename); - if (!Null(block)) { - filename = copy_object_file(filename); - self_destruct = 1; - } + block = ecl_library_find_by_name(filename); + if (!Null(block)) { + filename = copy_object_file(filename); + self_destruct = 1; + } #endif - } + } DO_LOAD: - block = ecl_library_open_inner(filename, self_destruct); - /* - * A second pass to ensure that the dlopen routine has not - * returned a library that we had already loaded. If this is - * the case, we close the new copy to ensure we do refcounting - * right. - */ - if (block->cblock.refs != ecl_make_fixnum(1)) { - if (force_reload) { - ecl_library_close(block); - filename = copy_object_file(filename); - self_destruct = 1; - goto DO_LOAD; - } - } - return block; + block = ecl_library_open_inner(filename, self_destruct); + /* + * A second pass to ensure that the dlopen routine has not + * returned a library that we had already loaded. If this is + * the case, we close the new copy to ensure we do refcounting + * right. + */ + if (block->cblock.refs != ecl_make_fixnum(1)) { + if (force_reload) { + ecl_library_close(block); + filename = copy_object_file(filename); + self_destruct = 1; + goto DO_LOAD; + } + } + return block; } void * ecl_library_symbol(cl_object block, const char *symbol, bool lock) { - void *p; - if (block == @':default') { - cl_object l; - for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { - cl_object block = ECL_CONS_CAR(l); - p = ecl_library_symbol(block, symbol, lock); - if (p) return p; - } - ecl_disable_interrupts(); + void *p; + if (block == @':default') { + cl_object l; + for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { + cl_object block = ECL_CONS_CAR(l); + p = ecl_library_symbol(block, symbol, lock); + if (p) return p; + } + ecl_disable_interrupts(); #if defined(ECL_MS_WINDOWS_HOST) - { - HANDLE hndSnap = NULL; - HANDLE hnd = NULL; - hndSnap = CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, GetCurrentProcessId()); - if (hndSnap != INVALID_HANDLE_VALUE) - { - MODULEENTRY32 me32; - me32.dwSize = sizeof(MODULEENTRY32); - if (Module32First(hndSnap, &me32)) - { - do - hnd = GetProcAddress(me32.hModule, symbol); - while (hnd == NULL && Module32Next(hndSnap, &me32)); - } - CloseHandle(hndSnap); - } - p = (void*)hnd; - } + { + HANDLE hndSnap = NULL; + HANDLE hnd = NULL; + hndSnap = CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, GetCurrentProcessId()); + if (hndSnap != INVALID_HANDLE_VALUE) + { + MODULEENTRY32 me32; + me32.dwSize = sizeof(MODULEENTRY32); + if (Module32First(hndSnap, &me32)) + { + do + hnd = GetProcAddress(me32.hModule, symbol); + while (hnd == NULL && Module32Next(hndSnap, &me32)); + } + CloseHandle(hndSnap); + } + p = (void*)hnd; + } #endif #ifdef HAVE_DLFCN_H - p = dlsym(0, symbol); + p = dlsym(0, symbol); #endif #if !defined(ECL_MS_WINDOWS_HOST) && !defined(HAVE_DLFCN_H) - p = 0; + p = 0; #endif - ecl_enable_interrupts(); - } else { - ecl_disable_interrupts(); + ecl_enable_interrupts(); + } else { + ecl_disable_interrupts(); #ifdef HAVE_DLFCN_H - p = dlsym(block->cblock.handle, symbol); + p = dlsym(block->cblock.handle, symbol); #endif #if defined(ECL_MS_WINDOWS_HOST) - { - HMODULE h = (HMODULE)(block->cblock.handle); - p = GetProcAddress(h, symbol); - } + { + HMODULE h = (HMODULE)(block->cblock.handle); + p = GetProcAddress(h, symbol); + } #endif #ifdef HAVE_MACH_O_DYLD_H - NSSymbol sym; - sym = NSLookupSymbolInModule((NSModule)(block->cblock.handle), - symbol); - if (sym == 0) { - p = 0; - } else { - p = NSAddressOfSymbol(sym); - } -#endif - ecl_enable_interrupts(); - /* Libraries whose symbols are being referenced by the FFI should not - * get garbage collected. Until we find a better solution we simply lock - * them for the rest of the runtime */ - if (p) { - block->cblock.locked |= lock; - } - } - if (!p) - set_library_error(block); - return p; + NSSymbol sym; + sym = NSLookupSymbolInModule((NSModule)(block->cblock.handle), + symbol); + if (sym == 0) { + p = 0; + } else { + p = NSAddressOfSymbol(sym); + } +#endif + ecl_enable_interrupts(); + /* Libraries whose symbols are being referenced by the FFI should not + * get garbage collected. Until we find a better solution we simply lock + * them for the rest of the runtime */ + if (p) { + block->cblock.locked |= lock; + } + } + if (!p) + set_library_error(block); + return p; } cl_object ecl_library_error(cl_object block) { - return block->cblock.error; + return block->cblock.error; } bool ecl_library_close(cl_object block) { - const cl_env_ptr the_env = ecl_process_env(); - bool success = TRUE; - ECL_WITH_GLOBAL_LOCK_BEGIN(the_env) { - ecl_disable_interrupts(); - /* is it ever a case? no matter how many times i call - load-foreign-module it seems that block->cblock.refs = 1 */ - if (block->cblock.refs > ecl_make_fixnum(1)) { - block->cblock.refs = ecl_one_minus(block->cblock.refs); - block = ECL_NIL; - } else if (block->cblock.handle != NULL) { - success = GC_call_with_alloc_lock(dlclose_wrapper, block); - cl_core.libraries = ecl_remove_eq(block, cl_core.libraries); - } else { /* block not loaded */ - success = FALSE; - } - ecl_enable_interrupts(); - } ECL_WITH_GLOBAL_LOCK_END; - if (block != ECL_NIL && block->cblock.self_destruct) { - if (!Null(block->cblock.name)) { - unlink((char*)block->cblock.name->base_string.self); - } - } - return success; + const cl_env_ptr the_env = ecl_process_env(); + bool success = TRUE; + ECL_WITH_GLOBAL_LOCK_BEGIN(the_env) { + ecl_disable_interrupts(); + /* is it ever a case? no matter how many times i call + load-foreign-module it seems that block->cblock.refs = 1 */ + if (block->cblock.refs > ecl_make_fixnum(1)) { + block->cblock.refs = ecl_one_minus(block->cblock.refs); + block = ECL_NIL; + } else if (block->cblock.handle != NULL) { + success = GC_call_with_alloc_lock(dlclose_wrapper, block); + cl_core.libraries = ecl_remove_eq(block, cl_core.libraries); + } else { /* block not loaded */ + success = FALSE; + } + ecl_enable_interrupts(); + } ECL_WITH_GLOBAL_LOCK_END; + if (block != ECL_NIL && block->cblock.self_destruct) { + if (!Null(block->cblock.name)) { + unlink((char*)block->cblock.name->base_string.self); + } + } + return success; } void ecl_library_close_all(void) { - while (cl_core.libraries != ECL_NIL) { - ecl_library_close(ECL_CONS_CAR(cl_core.libraries)); - } + while (cl_core.libraries != ECL_NIL) { + ecl_library_close(ECL_CONS_CAR(cl_core.libraries)); + } } ecl_def_ct_base_string(init_prefix, INIT_PREFIX, sizeof(INIT_PREFIX)-1, static, const); @@ -463,15 +458,15 @@ cl_object _ecl_library_init_prefix(void) { - return init_prefix; + return init_prefix; } ecl_def_ct_base_string(default_entry, INIT_PREFIX "CODE", sizeof(INIT_PREFIX "CODE")-1, - static, const); + static, const); cl_object _ecl_library_default_entry(void) { - return default_entry; + return default_entry; } #endif /* ENABLE_DLOPEN */ diff -Nru ecl-16.1.2/src/c/ffi/mmap.d ecl-16.1.3+ds/src/c/ffi/mmap.d --- ecl-16.1.2/src/c/ffi/mmap.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/ffi/mmap.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - mmap.d -- Mapping of binary files. -*/ -/* - Copyright (c) 2011, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * mmap.d - mapping of binary files + * + * Copyright (c) 2011 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #ifdef HAVE_SYS_MMAN_H @@ -33,77 +28,77 @@ (external_format @':default')) @ #ifdef HAVE_SYS_MMAN_H -{ - cl_object output, stream; - int c_prot, c_flags, fd; - size_t len; - void *pa; - if (direction == @':input') - c_prot = PROT_READ; - else if (direction == @':output') - c_prot = PROT_WRITE; - else if (direction == @':io') - c_prot = PROT_READ | PROT_WRITE; - else - c_prot = PROT_NONE; - if (Null(filename)) { - c_flags = MAP_ANON | MAP_PRIVATE; - fd = -1; - len = ecl_to_unsigned_integer(length); - stream = ECL_NIL; - } else { - c_flags = MAP_SHARED; - stream = cl_open(13, filename, + { + cl_object output, stream; + int c_prot, c_flags, fd; + size_t len; + void *pa; + if (direction == @':input') + c_prot = PROT_READ; + else if (direction == @':output') + c_prot = PROT_WRITE; + else if (direction == @':io') + c_prot = PROT_READ | PROT_WRITE; + else + c_prot = PROT_NONE; + if (Null(filename)) { + c_flags = MAP_ANON | MAP_PRIVATE; + fd = -1; + len = ecl_to_unsigned_integer(length); + stream = ECL_NIL; + } else { + c_flags = MAP_SHARED; + stream = cl_open(13, filename, + @':direction', direction, + @':element-type', element_type, + @':if-exists', if_exists, + @':if-does-not-exist', if_does_not_exist, + @':external-format', @':default', + @':cstream', ECL_NIL); + fd = ecl_to_int(si_file_stream_fd(stream)); + if (Null(length)) + len = ecl_to_unsigned_integer(ecl_file_length(stream)); + else + len = ecl_to_unsigned_integer(length); + } + output = si_make_vector(element_type, ecl_make_fixnum(0), ECL_NIL, + ECL_NIL, ECL_NIL, ECL_NIL); + pa = mmap(0, len, c_prot, c_flags, fd, + ecl_integer_to_off_t(offset)); + if (pa == MAP_FAILED) { + FElibc_error("EXT::MMAP failed.", 0); + } else { + output->base_string.self = pa; + output->base_string.dim = + output->base_string.fillp = len; + } + @(return CONS(output, stream)); + } +#else + { + cl_object output, vector; + if (Null(filename)) { + output = si_make_vector(element_type, length, ECL_NIL, + ECL_NIL, ECL_NIL, ECL_NIL); + } else { + cl_object stream = cl_open(13, filename, @':direction', direction, @':element-type', element_type, @':if-exists', if_exists, @':if-does-not-exist', if_does_not_exist, - @':external-format', @':default', - @':cstream', ECL_NIL); - fd = ecl_to_int(si_file_stream_fd(stream)); - if (Null(length)) - len = ecl_to_unsigned_integer(ecl_file_length(stream)); - else - len = ecl_to_unsigned_integer(length); - } - output = si_make_vector(element_type, ecl_make_fixnum(0), ECL_NIL, - ECL_NIL, ECL_NIL, ECL_NIL); - pa = mmap(0, len, c_prot, c_flags, fd, - ecl_integer_to_off_t(offset)); - if (pa == MAP_FAILED) { - FElibc_error("EXT::MMAP failed.", 0); - } else { - output->base_string.self = pa; - output->base_string.dim = - output->base_string.fillp = len; - } - @(return CONS(output, stream)) -} -#else -{ - cl_object output, vector; - if (Null(filename)) { - output = si_make_vector(element_type, length, ECL_NIL, - ECL_NIL, ECL_NIL, ECL_NIL); - } else { - cl_object stream = cl_open(13, filename, - @':direction', direction, - @':element-type', element_type, - @':if-exists', if_exists, - @':if-does-not-exist', if_does_not_exist, - @':external-format', @':pass-through', - @':cstream', ECL_T); - if (Null(length)) - length = ecl_file_length(stream); - else - length = ecl_to_unsigned_integer(length); - output = si_make_vector(element_type, length, ECL_NIL, - ECL_NIL, ECL_NIL, ECL_NIL); - cl_read_sequence(2, output, stream); - cl_close(1, stream); - } - @(return output) -} + @':external-format', @':pass-through', + @':cstream', ECL_T); + if (Null(length)) + length = ecl_file_length(stream); + else + length = ecl_to_unsigned_integer(length); + output = si_make_vector(element_type, length, ECL_NIL, + ECL_NIL, ECL_NIL, ECL_NIL); + cl_read_sequence(2, output, stream); + cl_close(1, stream); + } + @(return output); + } #endif @) @@ -111,9 +106,9 @@ si_mmap_array(cl_object map) { #ifdef HAVE_SYS_MMAN_H - @(return cl_car(map)); + @(return cl_car(map)); #else - @(return map); + @(return map); #endif } @@ -121,13 +116,13 @@ si_munmap(cl_object map) { #ifdef HAVE_SYS_MMAN_H - cl_object array = cl_car(map); - cl_object stream = cl_cdr(map); - int code = munmap(array->base_string.self, array->base_string.dim); - if (code < 0) { - FElibc_error("Error when unmapping file.", 0); - } - cl_close(1, stream); + cl_object array = cl_car(map); + cl_object stream = cl_cdr(map); + int code = munmap(array->base_string.self, array->base_string.dim); + if (code < 0) { + FElibc_error("Error when unmapping file.", 0); + } + cl_close(1, stream); #endif - @(return ECL_NIL) + @(return ECL_NIL); } diff -Nru ecl-16.1.2/src/c/ffi.d ecl-16.1.3+ds/src/c/ffi.d --- ecl-16.1.2/src/c/ffi.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/ffi.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - ffi.c -- User defined data types and foreign functions interface. -*/ -/* - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * ffi.d - user defined data types and foreign functions interface + * + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #define ECL_INCLUDE_FFI_H @@ -21,429 +16,408 @@ #include static const cl_object ecl_aet_to_ffi_table[ecl_aet_bc+1] = { - @':void', /* ecl_aet_object */ - @':float', /* ecl_aet_df */ - @':double', /* ecl_aet_df */ - @':void', /* ecl_aet_bit */ + @':void', /* ecl_aet_object */ + @':float', /* ecl_aet_df */ + @':double', /* ecl_aet_df */ + @':void', /* ecl_aet_bit */ #if ECL_FIXNUM_BITS == 32 && defined(ecl_uint32_t) - @':int32-t', /* ecl_aet_fix */ - @':uint32-t', /* ecl_aet_index */ + @':int32-t', /* ecl_aet_fix */ + @':uint32-t', /* ecl_aet_index */ #else # if ECL_FIXNUM_BITS == 64 && defined(ecl_uint64_t) - @':int64-t', /* ecl_aet_fix */ - @':uint64-t', /* ecl_aet_index */ + @':int64-t', /* ecl_aet_fix */ + @':uint64-t', /* ecl_aet_index */ # else - @':void', /* ecl_aet_fix */ - @':void', /* ecl_aet_index */ + @':void', /* ecl_aet_fix */ + @':void', /* ecl_aet_index */ # endif #endif - @':uint8-t', /* ecl_aet_b8 */ - @':int8-t', /* ecl_aet_i8 */ + @':uint8-t', /* ecl_aet_b8 */ + @':int8-t', /* ecl_aet_i8 */ #ifdef ecl_uint16_t - @':uint16-t', /* ecl_aet_b16 */ - @':int16-t', /* ecl_aet_i16 */ + @':uint16-t', /* ecl_aet_b16 */ + @':int16-t', /* ecl_aet_i16 */ #endif #ifdef ecl_uint32_t - @':uint32-t', /* ecl_aet_b32 */ - @':int32-t', /* ecl_aet_i32 */ + @':uint32-t', /* ecl_aet_b32 */ + @':int32-t', /* ecl_aet_i32 */ #endif #ifdef ecl_uint64_t - @':uint64-t', /* ecl_aet_b64 */ - @':int64-t', /* ecl_aet_i64 */ + @':uint64-t', /* ecl_aet_b64 */ + @':int64-t', /* ecl_aet_i64 */ #endif #ifdef ECL_UNICODE # ifdef ecl_int32_t - @':int32-t', /* ecl_aet_ch */ + @':int32-t', /* ecl_aet_ch */ # else - @':void', /* ecl_aet_ch */ + @':void', /* ecl_aet_ch */ # endif #endif - @':char' /* ecl_aet_bc */ + @':char' /* ecl_aet_bc */ }; -#define AUX_PTR(type) \ - ((struct { char a[1]; union { type c[1]; char d[sizeof(type)]; } b; } *)0) +#define AUX_PTR(type) \ + ((struct { char a[1]; union { type c[1]; char d[sizeof(type)]; } b; } *)0) #ifdef __GNUC__ typedef struct { - cl_object name; - cl_index size; - cl_index alignment; + cl_object name; + cl_index size; + cl_index alignment; } ecl_foreign_type_record; # define ALIGNMENT(tag) (ecl_foreign_type_table[tag].alignment) -# define FFI_DESC(symbol,type) \ +# define FFI_DESC(symbol,type) \ {symbol, sizeof(type), (AUX_PTR(type)->b.d - AUX_PTR(type)->a)} #else typedef struct { - cl_object name; - cl_index size; - char *d, *a; + cl_object name; + cl_index size; + char *d, *a; } ecl_foreign_type_record; #define ALIGNMENT(tag) (ecl_foreign_type_table[tag].d - ecl_foreign_type_table[tag].a) -#define AUX_PTR(type) \ - ((struct { char a[1]; union { type c[1]; char d[sizeof(type)]; } b; } *)0) -#define FFI_DESC(symbol,type) \ +#define AUX_PTR(type) \ + ((struct { char a[1]; union { type c[1]; char d[sizeof(type)]; } b; } *)0) +#define FFI_DESC(symbol,type) \ {symbol, sizeof(type), AUX_PTR(type)->b.d, AUX_PTR(type)->a} #endif static const ecl_foreign_type_record ecl_foreign_type_table[] = { - FFI_DESC(@':char', char), - FFI_DESC(@':unsigned-char', unsigned char), - FFI_DESC(@':byte', ecl_int8_t), - FFI_DESC(@':unsigned-byte', ecl_uint8_t), - FFI_DESC(@':short', short), - FFI_DESC(@':unsigned-short', unsigned short), - FFI_DESC(@':int', int), - FFI_DESC(@':unsigned-int', unsigned int), - FFI_DESC(@':long', long), - FFI_DESC(@':unsigned-long', unsigned long), + FFI_DESC(@':char', char), + FFI_DESC(@':unsigned-char', unsigned char), + FFI_DESC(@':byte', ecl_int8_t), + FFI_DESC(@':unsigned-byte', ecl_uint8_t), + FFI_DESC(@':short', short), + FFI_DESC(@':unsigned-short', unsigned short), + FFI_DESC(@':int', int), + FFI_DESC(@':unsigned-int', unsigned int), + FFI_DESC(@':long', long), + FFI_DESC(@':unsigned-long', unsigned long), #ifdef ecl_uint8_t - FFI_DESC(@':int8-t', ecl_int8_t), - FFI_DESC(@':uint8-t', ecl_uint8_t), + FFI_DESC(@':int8-t', ecl_int8_t), + FFI_DESC(@':uint8-t', ecl_uint8_t), #endif #ifdef ecl_uint16_t - FFI_DESC(@':int16-t', ecl_int16_t), - FFI_DESC(@':uint16-t', ecl_uint16_t), + FFI_DESC(@':int16-t', ecl_int16_t), + FFI_DESC(@':uint16-t', ecl_uint16_t), #endif #ifdef ecl_uint32_t - FFI_DESC(@':int32-t', ecl_int32_t), - FFI_DESC(@':uint32-t', ecl_uint32_t), + FFI_DESC(@':int32-t', ecl_int32_t), + FFI_DESC(@':uint32-t', ecl_uint32_t), #endif #ifdef ecl_uint64_t - FFI_DESC(@':int64-t', ecl_int64_t), - FFI_DESC(@':uint64-t', ecl_uint64_t), + FFI_DESC(@':int64-t', ecl_int64_t), + FFI_DESC(@':uint64-t', ecl_uint64_t), #endif #ifdef ecl_long_long_t - FFI_DESC(@':long-long', long long), - FFI_DESC(@':unsigned-long-long', unsigned long long), + FFI_DESC(@':long-long', long long), + FFI_DESC(@':unsigned-long-long', unsigned long long), #endif - FFI_DESC(@':pointer-void', void *), - FFI_DESC(@':cstring', char *), - FFI_DESC(@':object', cl_object), - FFI_DESC(@':float', float), - FFI_DESC(@':double', double), - {@':void', 0, 0} -}; - -#ifdef ECL_DYNAMIC_FFI -static const cl_object ecl_foreign_cc_table[] = { - @':cdecl', - @':stdcall' + FFI_DESC(@':pointer-void', void *), + FFI_DESC(@':cstring', char *), + FFI_DESC(@':object', cl_object), + FFI_DESC(@':float', float), + FFI_DESC(@':double', double), + {@':void', 0, 0} }; -#endif #ifdef HAVE_LIBFFI static struct { - const cl_object symbol; - ffi_abi abi; + const cl_object symbol; + ffi_abi abi; } ecl_foreign_cc_table[] = { - {@':default', FFI_DEFAULT_ABI}, + {@':default', FFI_DEFAULT_ABI}, #ifdef X86_WIN32 - {@':cdecl', FFI_SYSV}, - {@':sysv', FFI_SYSV}, - {@':stdcall', FFI_STDCALL}, + {@':cdecl', FFI_SYSV}, + {@':sysv', FFI_SYSV}, + {@':stdcall', FFI_STDCALL}, #elif defined(X86_WIN64) - {@':win64', FFI_WIN64}, + {@':win64', FFI_WIN64}, #elif defined(X86_ANY) || defined(X86) || defined(X86_64) - {@':cdecl', FFI_SYSV}, - {@':sysv', FFI_SYSV}, - {@':unix64', FFI_UNIX64}, + {@':cdecl', FFI_SYSV}, + {@':sysv', FFI_SYSV}, + {@':unix64', FFI_UNIX64}, #endif }; static ffi_type *ecl_type_to_libffi_type[] = { - &ffi_type_schar, /*@':char',*/ - &ffi_type_uchar, /*@':unsigned-char',*/ - &ffi_type_sint8, /*@':byte',*/ - &ffi_type_uint8, /*@':unsigned-byte',*/ - &ffi_type_sshort, /*@':short',*/ - &ffi_type_ushort, /*@':unsigned-short',*/ - &ffi_type_sint, /*@':int',*/ - &ffi_type_uint, /*@':unsigned-int',*/ - &ffi_type_slong, /*@':long',*/ - &ffi_type_ulong, /*@':unsigned-long',*/ + &ffi_type_schar, /*@':char',*/ + &ffi_type_uchar, /*@':unsigned-char',*/ + &ffi_type_sint8, /*@':byte',*/ + &ffi_type_uint8, /*@':unsigned-byte',*/ + &ffi_type_sshort, /*@':short',*/ + &ffi_type_ushort, /*@':unsigned-short',*/ + &ffi_type_sint, /*@':int',*/ + &ffi_type_uint, /*@':unsigned-int',*/ + &ffi_type_slong, /*@':long',*/ + &ffi_type_ulong, /*@':unsigned-long',*/ #ifdef ecl_uint8_t - &ffi_type_sint8, /*@':int8-t',*/ - &ffi_type_uint8, /*@':uint8-t',*/ + &ffi_type_sint8, /*@':int8-t',*/ + &ffi_type_uint8, /*@':uint8-t',*/ #endif #ifdef ecl_uint16_t - &ffi_type_sint16, /*@':int16-t',*/ - &ffi_type_uint16, /*@':uint16-t',*/ + &ffi_type_sint16, /*@':int16-t',*/ + &ffi_type_uint16, /*@':uint16-t',*/ #endif #ifdef ecl_uint32_t - &ffi_type_sint32, /*@':int32-t',*/ - &ffi_type_uint32, /*@':uint32-t',*/ + &ffi_type_sint32, /*@':int32-t',*/ + &ffi_type_uint32, /*@':uint32-t',*/ #endif #ifdef ecl_uint64_t - &ffi_type_sint64, /*@':int64-t',*/ - &ffi_type_uint64, /*@':uint64-t',*/ + &ffi_type_sint64, /*@':int64-t',*/ + &ffi_type_uint64, /*@':uint64-t',*/ #endif #ifdef ecl_long_long_t - &ffi_type_sint64, /*@':long-long',*/ /*FIXME! libffi does not have long long */ - &ffi_type_uint64, /*@':unsigned-long-long',*/ + &ffi_type_sint64, /*@':long-long',*/ /*FIXME! libffi does not have long long */ + &ffi_type_uint64, /*@':unsigned-long-long',*/ #endif - &ffi_type_pointer, /*@':pointer-void',*/ - &ffi_type_pointer, /*@':cstring',*/ - &ffi_type_pointer, /*@':object',*/ - &ffi_type_float, /*@':float',*/ - &ffi_type_double, /*@':double',*/ - &ffi_type_void /*@':void'*/ + &ffi_type_pointer, /*@':pointer-void',*/ + &ffi_type_pointer, /*@':cstring',*/ + &ffi_type_pointer, /*@':object',*/ + &ffi_type_float, /*@':float',*/ + &ffi_type_double, /*@':double',*/ + &ffi_type_void /*@':void'*/ }; #endif /* HAVE_LIBFFI */ cl_object ecl_make_foreign_data(cl_object tag, cl_index size, void *data) { - cl_object output = ecl_alloc_object(t_foreign); - output->foreign.tag = tag == ECL_NIL ? @':void' : tag; - output->foreign.size = size; - output->foreign.data = (char*)data; - return output; + cl_object output = ecl_alloc_object(t_foreign); + output->foreign.tag = tag == ECL_NIL ? @':void' : tag; + output->foreign.size = size; + output->foreign.data = (char*)data; + return output; } cl_object ecl_allocate_foreign_data(cl_object tag, cl_index size) { - cl_object output = ecl_alloc_object(t_foreign); - output->foreign.tag = tag; - output->foreign.size = size; - output->foreign.data = (char*)ecl_alloc_atomic(size); - return output; + cl_object output = ecl_alloc_object(t_foreign); + output->foreign.tag = tag; + output->foreign.size = size; + output->foreign.data = (char*)ecl_alloc_atomic(size); + return output; } void * ecl_foreign_data_pointer_safe(cl_object f) { - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { - FEwrong_type_only_arg(@[si::foreign-data-pointer], f, - @[si::foreign-data]); - } - return f->foreign.data; + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { + FEwrong_type_only_arg(@[si::foreign-data-pointer], f, + @[si::foreign-data]); + } + return f->foreign.data; } char * ecl_base_string_pointer_safe(cl_object f) { - unsigned char *s; - /* FIXME! Is there a better function name? */ - f = ecl_check_cl_type(@'si::make-foreign-data-from-array', f, t_base_string); - s = f->base_string.self; - if (ecl_unlikely(ECL_ARRAY_HAS_FILL_POINTER_P(f) && - s[f->base_string.fillp] != 0)) { - FEerror("Cannot coerce a string with fill pointer to (char *)", 0); - } - return (char *)s; + unsigned char *s; + /* FIXME! Is there a better function name? */ + f = ecl_check_cl_type(@'si::make-foreign-data-from-array', f, t_base_string); + s = f->base_string.self; + if (ecl_unlikely(ECL_ARRAY_HAS_FILL_POINTER_P(f) && + s[f->base_string.fillp] != 0)) { + FEerror("Cannot coerce a string with fill pointer to (char *)", 0); + } + return (char *)s; } cl_object ecl_null_terminated_base_string(cl_object f) { - /* FIXME! Is there a better function name? */ - f = ecl_check_cl_type(@'si::make-foreign-data-from-array', f, t_base_string); - if (ECL_ARRAY_HAS_FILL_POINTER_P(f) && - f->base_string.self[f->base_string.fillp] != 0) { - return cl_copy_seq(f); - } else { - return f; - } + /* FIXME! Is there a better function name? */ + f = ecl_check_cl_type(@'si::make-foreign-data-from-array', f, t_base_string); + if (ECL_ARRAY_HAS_FILL_POINTER_P(f) && + f->base_string.self[f->base_string.fillp] != 0) { + return cl_copy_seq(f); + } else { + return f; + } } cl_object si_allocate_foreign_data(cl_object tag, cl_object size) { - cl_object output = ecl_alloc_object(t_foreign); - cl_index bytes = ecl_to_size(size); - output->foreign.tag = tag; - output->foreign.size = bytes; - /* FIXME! Should be atomic uncollectable or malloc, but we do not export - * that garbage collector interface and malloc may be overwritten - * by the GC library */ - output->foreign.data = bytes? ecl_alloc_uncollectable(bytes) : NULL; - @(return output) + cl_object output = ecl_alloc_object(t_foreign); + cl_index bytes = ecl_to_size(size); + output->foreign.tag = tag; + output->foreign.size = bytes; + /* FIXME! Should be atomic uncollectable or malloc, but we do not export + * that garbage collector interface and malloc may be overwritten + * by the GC library */ + output->foreign.data = bytes? ecl_alloc_uncollectable(bytes) : NULL; + @(return output); } cl_object si_free_foreign_data(cl_object f) { - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { - FEwrong_type_only_arg(@[si::free-foreign-data], f, - @[si::foreign-data]); - } - if (f->foreign.size) { - /* See si_allocate_foreign_data() */ - ecl_free_uncollectable(f->foreign.data); - } - f->foreign.size = 0; - f->foreign.data = NULL; - @(return) + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { + FEwrong_type_only_arg(@[si::free-foreign-data], f, + @[si::foreign-data]); + } + if (f->foreign.size) { + /* See si_allocate_foreign_data() */ + ecl_free_uncollectable(f->foreign.data); + } + f->foreign.size = 0; + f->foreign.data = NULL; + @(return); } cl_object si_make_foreign_data_from_array(cl_object array) { - cl_object tag; - if (!ECL_ARRAYP (array)) - FEwrong_type_only_arg(@[si::make-foreign-data-from-array], - array, @[array]); - tag = ecl_aet_to_ffi_table[array->array.elttype]; - if (ecl_unlikely(Null(tag))) { - FEerror("Cannot make foreign object from array " - "with element type ~S.", 1, - ecl_elttype_to_symbol(array->array.elttype)); - } - @(return ecl_make_foreign_data(tag, 0, array->array.self.bc)); + cl_object tag; + if (!ECL_ARRAYP (array)) + FEwrong_type_only_arg(@[si::make-foreign-data-from-array], + array, @[array]); + tag = ecl_aet_to_ffi_table[array->array.elttype]; + if (ecl_unlikely(Null(tag))) { + FEerror("Cannot make foreign object from array " + "with element type ~S.", 1, + ecl_elttype_to_symbol(array->array.elttype)); + } + @(return ecl_make_foreign_data(tag, 0, array->array.self.bc)); } cl_object si_foreign_data_p(cl_object f) { - @(return (ECL_FOREIGN_DATA_P(f)? ECL_T : ECL_NIL)) + @(return (ECL_FOREIGN_DATA_P(f)? ECL_T : ECL_NIL)); } cl_object si_foreign_data_address(cl_object f) { - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { - FEwrong_type_only_arg(@[si::foreign-data-address], f, - @[si::foreign-data]); - } - @(return ecl_make_unsigned_integer((cl_index)f->foreign.data)) + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { + FEwrong_type_only_arg(@[si::foreign-data-address], f, + @[si::foreign-data]); + } + @(return ecl_make_unsigned_integer((cl_index)f->foreign.data)); } cl_object si_foreign_data_tag(cl_object f) { - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { - FEwrong_type_only_arg(@[si::foreign-data-tag], f, - @[si::foreign-data]); - } - @(return f->foreign.tag); + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { + FEwrong_type_only_arg(@[si::foreign-data-tag], f, + @[si::foreign-data]); + } + @(return f->foreign.tag); } cl_object si_foreign_data_equal(cl_object f1, cl_object f2) { - if (ecl_unlikely(!ECL_FOREIGN_DATA_P(f1))) { - FEwrong_type_only_arg(@[si::foreign-data-address], f1, - @[si::foreign-data]); - } - if (ecl_unlikely(!ECL_FOREIGN_DATA_P(f2))) { - FEwrong_type_only_arg(@[si::foreign-data-address], f2, - @[si::foreign-data]); - } - @(return ((f1->foreign.data == f2->foreign.data)? ECL_T : ECL_NIL)) + if (ecl_unlikely(!ECL_FOREIGN_DATA_P(f1))) { + FEwrong_type_only_arg(@[si::foreign-data-address], f1, + @[si::foreign-data]); + } + if (ecl_unlikely(!ECL_FOREIGN_DATA_P(f2))) { + FEwrong_type_only_arg(@[si::foreign-data-address], f2, + @[si::foreign-data]); + } + @(return ((f1->foreign.data == f2->foreign.data)? ECL_T : ECL_NIL)); } cl_object si_foreign_data_pointer(cl_object f, cl_object andx, cl_object asize, cl_object tag) { - cl_index ndx = ecl_to_size(andx); - cl_index size = ecl_to_size(asize); - cl_object output; - - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { - FEwrong_type_only_arg(@[si::foreign-data-pointer], f, - @[si::foreign-data]); - } - if (ecl_unlikely(ndx >= f->foreign.size || (f->foreign.size - ndx) < size)) { - FEerror("Out of bounds reference into foreign data type ~A.", 1, f); - } - output = ecl_alloc_object(t_foreign); - output->foreign.tag = tag; - output->foreign.size = size; - output->foreign.data = f->foreign.data + ndx; - @(return output) + cl_index ndx = ecl_to_size(andx); + cl_index size = ecl_to_size(asize); + cl_object output; + + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { + FEwrong_type_only_arg(@[si::foreign-data-pointer], f, + @[si::foreign-data]); + } + if (ecl_unlikely(ndx >= f->foreign.size || (f->foreign.size - ndx) < size)) { + FEerror("Out of bounds reference into foreign data type ~A.", 1, f); + } + output = ecl_alloc_object(t_foreign); + output->foreign.tag = tag; + output->foreign.size = size; + output->foreign.data = f->foreign.data + ndx; + @(return output); } cl_object si_foreign_data_ref(cl_object f, cl_object andx, cl_object asize, cl_object tag) { - cl_index ndx = ecl_to_size(andx); - cl_index size = ecl_to_size(asize); - cl_object output; - - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { - FEwrong_type_nth_arg(@[si::foreign-data-ref], 1, f, - @[si::foreign-data]); - } - if (ecl_unlikely(ndx >= f->foreign.size || (f->foreign.size - ndx) < size)) { - FEerror("Out of bounds reference into foreign data type ~A.", 1, f); - } - output = ecl_allocate_foreign_data(tag, size); - memcpy(output->foreign.data, f->foreign.data + ndx, size); - @(return output) + cl_index ndx = ecl_to_size(andx); + cl_index size = ecl_to_size(asize); + cl_object output; + + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { + FEwrong_type_nth_arg(@[si::foreign-data-ref], 1, f, + @[si::foreign-data]); + } + if (ecl_unlikely(ndx >= f->foreign.size || (f->foreign.size - ndx) < size)) { + FEerror("Out of bounds reference into foreign data type ~A.", 1, f); + } + output = ecl_allocate_foreign_data(tag, size); + memcpy(output->foreign.data, f->foreign.data + ndx, size); + @(return output); } cl_object si_foreign_data_set(cl_object f, cl_object andx, cl_object value) { - cl_index ndx = ecl_to_size(andx); - cl_index size, limit; + cl_index ndx = ecl_to_size(andx); + cl_index size, limit; - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { - FEwrong_type_nth_arg(@[si::foreign-data-set], 1, f, - @[si::foreign-data]); - } - if (ecl_unlikely(ecl_t_of(value) != t_foreign)) { - FEwrong_type_nth_arg(@[si::foreign-data-set], 3, value, - @[si::foreign-data]); - } - size = value->foreign.size; - limit = f->foreign.size; - if (ecl_unlikely(ndx >= limit || (limit - ndx) < size)) { - FEerror("Out of bounds reference into foreign data type ~A.", 1, f); - } - memcpy(f->foreign.data + ndx, value->foreign.data, size); - @(return value) + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { + FEwrong_type_nth_arg(@[si::foreign-data-set], 1, f, + @[si::foreign-data]); + } + if (ecl_unlikely(ecl_t_of(value) != t_foreign)) { + FEwrong_type_nth_arg(@[si::foreign-data-set], 3, value, + @[si::foreign-data]); + } + size = value->foreign.size; + limit = f->foreign.size; + if (ecl_unlikely(ndx >= limit || (limit - ndx) < size)) { + FEerror("Out of bounds reference into foreign data type ~A.", 1, f); + } + memcpy(f->foreign.data + ndx, value->foreign.data, size); + @(return value); } static int foreign_type_code(cl_object type) { - int i; - for (i = 0; i <= ECL_FFI_VOID; i++) { - if (type == ecl_foreign_type_table[i].name) - return i; - } - return -1; + int i; + for (i = 0; i <= ECL_FFI_VOID; i++) { + if (type == ecl_foreign_type_table[i].name) + return i; + } + return -1; } enum ecl_ffi_tag ecl_foreign_type_code(cl_object type) { - int i = foreign_type_code(type); - if (ecl_unlikely(i < 0)) { - FEerror("~A does not denote an elementary foreign type.", 1, type); - } - return (enum ecl_ffi_tag)i; + int i = foreign_type_code(type); + if (ecl_unlikely(i < 0)) { + FEerror("~A does not denote an elementary foreign type.", 1, type); + } + return (enum ecl_ffi_tag)i; } #ifdef HAVE_LIBFFI ffi_abi ecl_foreign_cc_code(cl_object cc) { - int i; - for (i = 0; i <= ECL_FFI_CC_STDCALL; i++) { - if (cc == ecl_foreign_cc_table[i].symbol) - return ecl_foreign_cc_table[i].abi; - } - FEerror("~A does no denote a valid calling convention.", 1, cc); - return ECL_FFI_CC_CDECL; -} -#endif - -#ifdef ECL_DYNAMIC_FFI -enum ecl_ffi_calling_convention -ecl_foreign_cc_code(cl_object cc) -{ - int i; - for (i = 0; i <= ECL_FFI_CC_STDCALL; i++) { - if (cc == ecl_foreign_cc_table[i]) - return (enum ecl_ffi_calling_convention)i; - } - FEerror("~A does no denote a valid calling convention.", 1, cc); - return ECL_FFI_CC_CDECL; + int i; + for (i = 0; i <= ECL_FFI_CC_STDCALL; i++) { + if (cc == ecl_foreign_cc_table[i].symbol) + return ecl_foreign_cc_table[i].abi; + } + FEerror("~A does no denote a valid calling convention.", 1, cc); + return ECL_FFI_CC_CDECL; } #endif @@ -452,280 +426,280 @@ static void wrong_ffi_tag(enum ecl_ffi_tag tag) { - FEerror("Invalid ecl_ffi_tag code ~D", 1, ecl_make_integer(tag)); + FEerror("Invalid ecl_ffi_tag code ~D", 1, ecl_make_integer(tag)); } cl_object ecl_foreign_data_ref_elt(void *p, enum ecl_ffi_tag tag) { - switch (tag) { - case ECL_FFI_CHAR: - return ECL_CODE_CHAR(*(char *)p); - case ECL_FFI_UNSIGNED_CHAR: - return ECL_CODE_CHAR(*(unsigned char *)p); - case ECL_FFI_BYTE: - return ecl_make_fixnum(*(int8_t *)p); - case ECL_FFI_UNSIGNED_BYTE: - return ecl_make_fixnum(*(uint8_t *)p); - case ECL_FFI_SHORT: - return ecl_make_fixnum(*(short *)p); - case ECL_FFI_UNSIGNED_SHORT: - return ecl_make_fixnum(*(unsigned short *)p); - case ECL_FFI_INT: - return ecl_make_integer(*(int *)p); - case ECL_FFI_UNSIGNED_INT: - return ecl_make_unsigned_integer(*(unsigned int *)p); - case ECL_FFI_LONG: - return ecl_make_integer(*(long *)p); + switch (tag) { + case ECL_FFI_CHAR: + return ECL_CODE_CHAR(*(char *)p); + case ECL_FFI_UNSIGNED_CHAR: + return ECL_CODE_CHAR(*(unsigned char *)p); + case ECL_FFI_BYTE: + return ecl_make_fixnum(*(int8_t *)p); + case ECL_FFI_UNSIGNED_BYTE: + return ecl_make_fixnum(*(uint8_t *)p); + case ECL_FFI_SHORT: + return ecl_make_fixnum(*(short *)p); + case ECL_FFI_UNSIGNED_SHORT: + return ecl_make_fixnum(*(unsigned short *)p); + case ECL_FFI_INT: + return ecl_make_integer(*(int *)p); + case ECL_FFI_UNSIGNED_INT: + return ecl_make_unsigned_integer(*(unsigned int *)p); + case ECL_FFI_LONG: + return ecl_make_integer(*(long *)p); #ifdef ecl_uint8_t - case ECL_FFI_INT8_T: - return ecl_make_fixnum(*(ecl_int8_t *)p); - case ECL_FFI_UINT8_T: - return ecl_make_fixnum(*(ecl_uint8_t *)p); + case ECL_FFI_INT8_T: + return ecl_make_fixnum(*(ecl_int8_t *)p); + case ECL_FFI_UINT8_T: + return ecl_make_fixnum(*(ecl_uint8_t *)p); #endif #ifdef ecl_uint16_t - case ECL_FFI_INT16_T: - return ecl_make_int16_t(*(ecl_int16_t *)p); - case ECL_FFI_UINT16_T: - return ecl_make_uint16_t(*(ecl_uint16_t *)p); + case ECL_FFI_INT16_T: + return ecl_make_int16_t(*(ecl_int16_t *)p); + case ECL_FFI_UINT16_T: + return ecl_make_uint16_t(*(ecl_uint16_t *)p); #endif #ifdef ecl_uint32_t - case ECL_FFI_INT32_T: - return ecl_make_int32_t(*(ecl_int32_t *)p); - case ECL_FFI_UINT32_T: - return ecl_make_uint32_t(*(ecl_uint32_t *)p); + case ECL_FFI_INT32_T: + return ecl_make_int32_t(*(ecl_int32_t *)p); + case ECL_FFI_UINT32_T: + return ecl_make_uint32_t(*(ecl_uint32_t *)p); #endif #ifdef ecl_uint64_t - case ECL_FFI_INT64_T: - return ecl_make_int64_t(*(ecl_int64_t *)p); - case ECL_FFI_UINT64_T: - return ecl_make_uint64_t(*(ecl_uint64_t *)p); + case ECL_FFI_INT64_T: + return ecl_make_int64_t(*(ecl_int64_t *)p); + case ECL_FFI_UINT64_T: + return ecl_make_uint64_t(*(ecl_uint64_t *)p); #endif #ifdef ecl_long_long_t - case ECL_FFI_LONG_LONG: - return ecl_make_long_long(*(ecl_long_long_t *)p); - case ECL_FFI_UNSIGNED_LONG_LONG: - return ecl_make_ulong_long(*(ecl_ulong_long_t *)p); -#endif - case ECL_FFI_UNSIGNED_LONG: - return ecl_make_unsigned_integer(*(unsigned long *)p); - case ECL_FFI_POINTER_VOID: - return ecl_make_foreign_data(@':pointer-void', 0, *(void **)p); - case ECL_FFI_CSTRING: - return *(char **)p ? - ecl_make_simple_base_string(*(char **)p, -1) : ECL_NIL; - case ECL_FFI_OBJECT: - return *(cl_object *)p; - case ECL_FFI_FLOAT: - return ecl_make_single_float(*(float *)p); - case ECL_FFI_DOUBLE: - return ecl_make_double_float(*(double *)p); - case ECL_FFI_VOID: - return ECL_NIL; - default: - wrong_ffi_tag(tag); - } + case ECL_FFI_LONG_LONG: + return ecl_make_long_long(*(ecl_long_long_t *)p); + case ECL_FFI_UNSIGNED_LONG_LONG: + return ecl_make_ulong_long(*(ecl_ulong_long_t *)p); +#endif + case ECL_FFI_UNSIGNED_LONG: + return ecl_make_unsigned_integer(*(unsigned long *)p); + case ECL_FFI_POINTER_VOID: + return ecl_make_foreign_data(@':pointer-void', 0, *(void **)p); + case ECL_FFI_CSTRING: + return *(char **)p ? + ecl_make_simple_base_string(*(char **)p, -1) : ECL_NIL; + case ECL_FFI_OBJECT: + return *(cl_object *)p; + case ECL_FFI_FLOAT: + return ecl_make_single_float(*(float *)p); + case ECL_FFI_DOUBLE: + return ecl_make_double_float(*(double *)p); + case ECL_FFI_VOID: + return ECL_NIL; + default: + wrong_ffi_tag(tag); + } } void ecl_foreign_data_set_elt(void *p, enum ecl_ffi_tag tag, cl_object value) { - switch (tag) { - case ECL_FFI_CHAR: - *(char *)p = (char)ecl_base_char_code(value); - break; - case ECL_FFI_UNSIGNED_CHAR: - *(unsigned char*)p = (unsigned char)ecl_base_char_code(value); - break; - case ECL_FFI_BYTE: - *(int8_t *)p = ecl_to_int8_t(value); - break; - case ECL_FFI_UNSIGNED_BYTE: - *(uint8_t *)p = ecl_to_uint8_t(value); - break; - case ECL_FFI_SHORT: - *(short *)p = ecl_to_short(value); - break; - case ECL_FFI_UNSIGNED_SHORT: - *(unsigned short *)p = ecl_to_ushort(value); - break; - case ECL_FFI_INT: - *(int *)p = ecl_to_int(value); - break; - case ECL_FFI_UNSIGNED_INT: - *(unsigned int *)p = ecl_to_uint(value); - break; - case ECL_FFI_LONG: - *(long *)p = ecl_to_long(value); - break; - case ECL_FFI_UNSIGNED_LONG: - *(unsigned long *)p = ecl_to_ulong(value); - break; - case ECL_FFI_INT8_T: - *(ecl_int8_t *)p = ecl_to_int8_t(value); - break; - case ECL_FFI_UINT8_T: - *(ecl_uint8_t *)p = ecl_to_uint8_t(value); - break; + switch (tag) { + case ECL_FFI_CHAR: + *(char *)p = (char)ecl_base_char_code(value); + break; + case ECL_FFI_UNSIGNED_CHAR: + *(unsigned char*)p = (unsigned char)ecl_base_char_code(value); + break; + case ECL_FFI_BYTE: + *(int8_t *)p = ecl_to_int8_t(value); + break; + case ECL_FFI_UNSIGNED_BYTE: + *(uint8_t *)p = ecl_to_uint8_t(value); + break; + case ECL_FFI_SHORT: + *(short *)p = ecl_to_short(value); + break; + case ECL_FFI_UNSIGNED_SHORT: + *(unsigned short *)p = ecl_to_ushort(value); + break; + case ECL_FFI_INT: + *(int *)p = ecl_to_int(value); + break; + case ECL_FFI_UNSIGNED_INT: + *(unsigned int *)p = ecl_to_uint(value); + break; + case ECL_FFI_LONG: + *(long *)p = ecl_to_long(value); + break; + case ECL_FFI_UNSIGNED_LONG: + *(unsigned long *)p = ecl_to_ulong(value); + break; + case ECL_FFI_INT8_T: + *(ecl_int8_t *)p = ecl_to_int8_t(value); + break; + case ECL_FFI_UINT8_T: + *(ecl_uint8_t *)p = ecl_to_uint8_t(value); + break; #ifdef ecl_uint16_t - case ECL_FFI_INT16_T: - *(ecl_int16_t *)p = ecl_to_int16_t(value); - break; - case ECL_FFI_UINT16_T: - *(ecl_uint16_t *)p = ecl_to_uint16_t(value); - break; + case ECL_FFI_INT16_T: + *(ecl_int16_t *)p = ecl_to_int16_t(value); + break; + case ECL_FFI_UINT16_T: + *(ecl_uint16_t *)p = ecl_to_uint16_t(value); + break; #endif #ifdef ecl_uint32_t - case ECL_FFI_INT32_T: - *(ecl_int32_t *)p = ecl_to_int32_t(value); - break; - case ECL_FFI_UINT32_T: - *(ecl_uint32_t *)p = ecl_to_uint32_t(value); - break; + case ECL_FFI_INT32_T: + *(ecl_int32_t *)p = ecl_to_int32_t(value); + break; + case ECL_FFI_UINT32_T: + *(ecl_uint32_t *)p = ecl_to_uint32_t(value); + break; #endif #ifdef ecl_uint64_t - case ECL_FFI_INT64_T: - *(ecl_int64_t *)p = ecl_to_int64_t(value); - break; - case ECL_FFI_UINT64_T: - *(ecl_uint64_t *)p = ecl_to_uint64_t(value); - break; + case ECL_FFI_INT64_T: + *(ecl_int64_t *)p = ecl_to_int64_t(value); + break; + case ECL_FFI_UINT64_T: + *(ecl_uint64_t *)p = ecl_to_uint64_t(value); + break; #endif #ifdef ecl_long_long_t - case ECL_FFI_LONG_LONG: - *(ecl_long_long_t *)p = ecl_to_long_long(value); - break; - case ECL_FFI_UNSIGNED_LONG_LONG: - *(ecl_ulong_long_t *)p = ecl_to_ulong_long(value); - break; -#endif - case ECL_FFI_POINTER_VOID: - *(void **)p = ecl_foreign_data_pointer_safe(value); - break; - case ECL_FFI_CSTRING: - *(char **)p = value == ECL_NIL ? NULL : (char*)value->base_string.self; - break; - case ECL_FFI_OBJECT: - *(cl_object *)p = value; - break; - case ECL_FFI_FLOAT: - *(float *)p = ecl_to_float(value); - break; - case ECL_FFI_DOUBLE: - *(double *)p = ecl_to_double(value); - break; - case ECL_FFI_VOID: - break; - default: - wrong_ffi_tag(tag); - } + case ECL_FFI_LONG_LONG: + *(ecl_long_long_t *)p = ecl_to_long_long(value); + break; + case ECL_FFI_UNSIGNED_LONG_LONG: + *(ecl_ulong_long_t *)p = ecl_to_ulong_long(value); + break; +#endif + case ECL_FFI_POINTER_VOID: + *(void **)p = ecl_foreign_data_pointer_safe(value); + break; + case ECL_FFI_CSTRING: + *(char **)p = value == ECL_NIL ? NULL : (char*)value->base_string.self; + break; + case ECL_FFI_OBJECT: + *(cl_object *)p = value; + break; + case ECL_FFI_FLOAT: + *(float *)p = ecl_to_float(value); + break; + case ECL_FFI_DOUBLE: + *(double *)p = ecl_to_double(value); + break; + case ECL_FFI_VOID: + break; + default: + wrong_ffi_tag(tag); + } } cl_object si_foreign_data_ref_elt(cl_object f, cl_object andx, cl_object type) { - cl_index ndx = ecl_to_size(andx); - cl_index limit = f->foreign.size; - enum ecl_ffi_tag tag = ecl_foreign_type_code(type); - if (ecl_unlikely(ndx >= limit || - (ndx + ecl_foreign_type_table[tag].size > limit))) { - FEerror("Out of bounds reference into foreign data type ~A.", 1, f); - } - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { - FEwrong_type_nth_arg(@[si::foreign-data-ref-elt], 1, f, - @[si::foreign-data]); - } - @(return ecl_foreign_data_ref_elt((void*)(f->foreign.data + ndx), tag)) + cl_index ndx = ecl_to_size(andx); + cl_index limit = f->foreign.size; + enum ecl_ffi_tag tag = ecl_foreign_type_code(type); + if (ecl_unlikely(ndx >= limit || + (ndx + ecl_foreign_type_table[tag].size > limit))) { + FEerror("Out of bounds reference into foreign data type ~A.", 1, f); + } + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { + FEwrong_type_nth_arg(@[si::foreign-data-ref-elt], 1, f, + @[si::foreign-data]); + } + @(return ecl_foreign_data_ref_elt((void*)(f->foreign.data + ndx), tag)); } cl_object si_foreign_data_set_elt(cl_object f, cl_object andx, cl_object type, cl_object value) { - cl_index ndx = ecl_to_size(andx); - cl_index limit = f->foreign.size; - enum ecl_ffi_tag tag = ecl_foreign_type_code(type); - if (ecl_unlikely(ndx >= limit || - ndx + ecl_foreign_type_table[tag].size > limit)) { - FEerror("Out of bounds reference into foreign data type ~A.", 1, f); - } - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { - FEwrong_type_nth_arg(@[si::foreign-data-set-elt], 1, f, - @[si::foreign-data]); - } - ecl_foreign_data_set_elt((void*)(f->foreign.data + ndx), tag, value); - @(return value) + cl_index ndx = ecl_to_size(andx); + cl_index limit = f->foreign.size; + enum ecl_ffi_tag tag = ecl_foreign_type_code(type); + if (ecl_unlikely(ndx >= limit || + ndx + ecl_foreign_type_table[tag].size > limit)) { + FEerror("Out of bounds reference into foreign data type ~A.", 1, f); + } + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { + FEwrong_type_nth_arg(@[si::foreign-data-set-elt], 1, f, + @[si::foreign-data]); + } + ecl_foreign_data_set_elt((void*)(f->foreign.data + ndx), tag, value); + @(return value); } cl_object si_size_of_foreign_elt_type(cl_object type) { - enum ecl_ffi_tag tag = ecl_foreign_type_code(type); - @(return ecl_make_fixnum(ecl_foreign_type_table[tag].size)) + enum ecl_ffi_tag tag = ecl_foreign_type_code(type); + @(return ecl_make_fixnum(ecl_foreign_type_table[tag].size)); } cl_object si_alignment_of_foreign_elt_type(cl_object type) { - enum ecl_ffi_tag tag = ecl_foreign_type_code(type); - @(return ecl_make_fixnum(ALIGNMENT(tag))) + enum ecl_ffi_tag tag = ecl_foreign_type_code(type); + @(return ecl_make_fixnum(ALIGNMENT(tag))); } cl_object si_foreign_elt_type_p(cl_object type) { - @(return ((foreign_type_code(type) < 0)? ECL_NIL : ECL_T)) + @(return ((foreign_type_code(type) < 0)? ECL_NIL : ECL_T)); } cl_object si_null_pointer_p(cl_object f) { - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) - FEwrong_type_only_arg(@[si::null-pointer-p], f, - @[si::foreign-data]); - @(return ((f->foreign.data == NULL)? ECL_T : ECL_NIL)) + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) + FEwrong_type_only_arg(@[si::null-pointer-p], f, + @[si::foreign-data]); + @(return ((f->foreign.data == NULL)? ECL_T : ECL_NIL)); } cl_object si_foreign_data_recast(cl_object f, cl_object size, cl_object tag) { - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) - FEwrong_type_nth_arg(@[si::foreign-data-recast], 1, f, - @[si::foreign-data]); - f->foreign.size = ecl_to_size(size); - f->foreign.tag = tag; - @(return f) + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) + FEwrong_type_nth_arg(@[si::foreign-data-recast], 1, f, + @[si::foreign-data]); + f->foreign.size = ecl_to_size(size); + f->foreign.tag = tag; + @(return f); } cl_object si_load_foreign_module(cl_object filename) { #if !defined(ENABLE_DLOPEN) - FEerror("SI:LOAD-FOREIGN-MODULE does not work when ECL is statically linked", 0); + FEerror("SI:LOAD-FOREIGN-MODULE does not work when ECL is statically linked", 0); #else - cl_object output; + cl_object output; # ifdef ECL_THREADS - mp_get_lock(1, ecl_symbol_value(@'mp::+load-compile-lock+')); - ECL_UNWIND_PROTECT_BEGIN(ecl_process_env()) { + mp_get_lock(1, ecl_symbol_value(@'mp::+load-compile-lock+')); + ECL_UNWIND_PROTECT_BEGIN(ecl_process_env()) { # endif - output = ecl_library_open(filename, 0); - if (output->cblock.handle == NULL) { - cl_object aux = ecl_library_error(output); - ecl_library_close(output); - output = aux; - } + output = ecl_library_open(filename, 0); + if (output->cblock.handle == NULL) { + cl_object aux = ecl_library_error(output); + ecl_library_close(output); + output = aux; + } # ifdef ECL_THREADS - (void)0; /* MSVC complains about missing ';' before '}' */ - } ECL_UNWIND_PROTECT_EXIT { - mp_giveup_lock(ecl_symbol_value(@'mp::+load-compile-lock+')); - } ECL_UNWIND_PROTECT_END; + (void)0; /* MSVC complains about missing ';' before '}' */ + } ECL_UNWIND_PROTECT_EXIT { + mp_giveup_lock(ecl_symbol_value(@'mp::+load-compile-lock+')); + } ECL_UNWIND_PROTECT_END; # endif - if (ecl_unlikely(ecl_t_of(output) != t_codeblock)) { - FEerror("LOAD-FOREIGN-MODULE: Could not load " - "foreign module ~S (Error: ~S)", 2, filename, output); - } - output->cblock.locked |= 1; - @(return output) + if (ecl_unlikely(ecl_t_of(output) != t_codeblock)) { + FEerror("LOAD-FOREIGN-MODULE: Could not load " + "foreign module ~S (Error: ~S)", 2, filename, output); + } + output->cblock.locked |= 1; + @(return output); #endif } @@ -733,26 +707,26 @@ si_unload_foreign_module(cl_object module) { #if !defined(ENABLE_DLOPEN) - FEerror("SI:UNLOAD-FOREIGN-MODULE does not work when ECL is statically linked", 0); + FEerror("SI:UNLOAD-FOREIGN-MODULE does not work when ECL is statically linked", 0); #else - cl_object output = ECL_NIL; + cl_object output = ECL_NIL; - if (ecl_unlikely(ecl_t_of(module) != t_codeblock)) { - FEerror("UNLOAD-FOREIGN-MODULE: Argument is not a foreign module: ~S ", - 1, module); - } + if (ecl_unlikely(ecl_t_of(module) != t_codeblock)) { + FEerror("UNLOAD-FOREIGN-MODULE: Argument is not a foreign module: ~S ", + 1, module); + } # ifdef ECL_THREADS - mp_get_lock(1, ecl_symbol_value(@'mp::+load-compile-lock+')); - ECL_UNWIND_PROTECT_BEGIN(ecl_process_env()) { + mp_get_lock(1, ecl_symbol_value(@'mp::+load-compile-lock+')); + ECL_UNWIND_PROTECT_BEGIN(ecl_process_env()) { # endif - if (ecl_likely(ecl_library_close(module))) output = ECL_T; + if (ecl_likely(ecl_library_close(module))) output = ECL_T; # ifdef ECL_THREADS - (void)0; /* MSVC complains about missing ';' before '}' */ - } ECL_UNWIND_PROTECT_EXIT { - mp_giveup_lock(ecl_symbol_value(@'mp::+load-compile-lock+')); - } ECL_UNWIND_PROTECT_END; + (void)0; /* MSVC complains about missing ';' before '}' */ + } ECL_UNWIND_PROTECT_EXIT { + mp_giveup_lock(ecl_symbol_value(@'mp::+load-compile-lock+')); + } ECL_UNWIND_PROTECT_END; # endif - @(return output) + @(return output); #endif } @@ -760,156 +734,54 @@ si_find_foreign_symbol(cl_object var, cl_object module, cl_object type, cl_object size) { #if !defined(ENABLE_DLOPEN) - FEerror("SI:FIND-FOREIGN-SYMBOL does not work when ECL is statically linked", 0); + FEerror("SI:FIND-FOREIGN-SYMBOL does not work when ECL is statically linked", 0); #else - cl_object block; - cl_object output = ECL_NIL; - void *sym; - - block = (module == @':default' ? module : si_load_foreign_module(module)); - var = ecl_null_terminated_base_string(var); - sym = ecl_library_symbol(block, (char*)var->base_string.self, 1); - if (sym == NULL) { - if (block != @':default') - output = ecl_library_error(block); - goto OUTPUT; - } - output = ecl_make_foreign_data(type, ecl_to_fixnum(size), sym); -OUTPUT: - if (ecl_unlikely(ecl_t_of(output) != t_foreign)) - FEerror("FIND-FOREIGN-SYMBOL: Could not load " - "foreign symbol ~S from module ~S (Error: ~S)", - 3, var, module, output); - @(return output) + cl_object block; + cl_object output = ECL_NIL; + void *sym; + + block = (module == @':default' ? module : si_load_foreign_module(module)); + var = ecl_null_terminated_base_string(var); + sym = ecl_library_symbol(block, (char*)var->base_string.self, 1); + if (sym == NULL) { + if (block != @':default') + output = ecl_library_error(block); + goto OUTPUT; + } + output = ecl_make_foreign_data(type, ecl_to_fixnum(size), sym); + OUTPUT: + if (ecl_unlikely(ecl_t_of(output) != t_foreign)) + FEerror("FIND-FOREIGN-SYMBOL: Could not load " + "foreign symbol ~S from module ~S (Error: ~S)", + 3, var, module, output); + @(return output); #endif } -#ifdef ECL_DYNAMIC_FFI -static void -ecl_fficall_overflow() -{ - FEerror("Stack overflow on SI:CALL-CFUN", 0); -} - -void -ecl_fficall_prepare(cl_object return_type, cl_object arg_type, cl_object cc_type) -{ - struct ecl_fficall *fficall = cl_env.fficall; - fficall->buffer_sp = fficall->buffer; - fficall->buffer_size = 0; - fficall->cstring = ECL_NIL; - fficall->cc = ecl_foreign_cc_code(cc_type); - fficall->registers = ecl_fficall_prepare_extra(fficall->registers); -} - -void -ecl_fficall_push_bytes(void *data, size_t bytes) -{ - struct ecl_fficall *fficall = cl_env.fficall; - fficall->buffer_size += bytes; - if (fficall->buffer_size >= ECL_FFICALL_LIMIT) - ecl_fficall_overflow(); - memcpy(fficall->buffer_sp, (char*)data, bytes); - fficall->buffer_sp += bytes; -} - -void -ecl_fficall_push_int(int data) -{ - ecl_fficall_push_bytes(&data, sizeof(int)); -} - -void -ecl_fficall_align(int data) -{ - struct ecl_fficall *fficall = cl_env.fficall; - if (data == 1) - return; - else { - size_t sp = fficall->buffer_sp - fficall->buffer; - size_t mask = data - 1; - size_t new_sp = (sp + mask) & ~mask; - if (new_sp >= ECL_FFICALL_LIMIT) - ecl_fficall_overflow(); - fficall->buffer_sp = fficall->buffer + new_sp; - fficall->buffer_size = new_sp; - } -} - -@(defun si::call-cfun (fun return_type arg_types args &optional (cc_type @':cdecl')) - struct ecl_fficall *fficall = cl_env.fficall; - void *cfun = ecl_foreign_data_pointer_safe(fun); - cl_object object; - enum ecl_ffi_tag return_type_tag = ecl_foreign_type_code(return_type); -@ - - ecl_fficall_prepare(return_type, arg_types, cc_type); - while (CONSP(arg_types)) { - enum ecl_ffi_tag type; - if (!CONSP(args)) { - FEerror("In SI:CALL-CFUN, mismatch between argument types and argument list: ~A vs ~A", 0); - } - type = ecl_foreign_type_code(CAR(arg_types)); - if (type == ECL_FFI_CSTRING) { - object = ecl_null_terminated_base_string(CAR(args)); - if (CAR(args) != object) - fficall->cstring = - CONS(object, fficall->cstring); - } else { - object = CAR(args); - } - ecl_foreign_data_set_elt(&fficall->output, type, object); - ecl_fficall_push_arg(&fficall->output, type); - arg_types = CDR(arg_types); - args = CDR(args); - } - ecl_fficall_execute(cfun, fficall, return_type_tag); - object = ecl_foreign_data_ref_elt(&fficall->output, return_type_tag); - - fficall->buffer_size = 0; - fficall->buffer_sp = fficall->buffer; - fficall->cstring = ECL_NIL; - - @(return object) -@) - -@(defun si::make-dynamic-callback (fun sym rtype argtypes &optional (cctype @':cdecl')) - cl_object data; - cl_object cbk; -@ - data = cl_list(3, fun, rtype, argtypes); - cbk = ecl_make_foreign_data(@':pointer-void', 0, ecl_dynamic_callback_make(data, ecl_foreign_cc_code(cctype))); - - si_put_sysprop(sym, @':callback', CONS(cbk, data)); - @(return cbk) -@) -#endif /* ECL_DYNAMIC_FFI */ - - #ifdef HAVE_LIBFFI static void resize_call_stack(cl_env_ptr env, cl_index new_size) { - cl_index i; - ffi_type **types = - ecl_alloc_atomic((new_size + 1) * sizeof(ffi_type*)); - union ecl_ffi_values *values = - ecl_alloc_atomic((new_size + 1) * sizeof(union ecl_ffi_values)); - union ecl_ffi_values **values_ptrs = - ecl_alloc_atomic(new_size * sizeof(union ecl_ffi_values *)); - memcpy(types, env->ffi_types, env->ffi_args_limit * sizeof(ffi_type*)); - memcpy(values, env->ffi_values, env->ffi_args_limit * - sizeof(union ecl_ffi_values)); - for (i = 0; i < new_size; i++) { - values_ptrs[i] = (values + i + 1); - } - env->ffi_args_limit = new_size; - ecl_dealloc(env->ffi_types); - env->ffi_types = types; - ecl_dealloc(env->ffi_values); - env->ffi_values = values; - ecl_dealloc(env->ffi_values_ptrs); - env->ffi_values_ptrs = values_ptrs; + cl_index i; + ffi_type **types = + ecl_alloc_atomic((new_size + 1) * sizeof(ffi_type*)); + union ecl_ffi_values *values = + ecl_alloc_atomic((new_size + 1) * sizeof(union ecl_ffi_values)); + union ecl_ffi_values **values_ptrs = + ecl_alloc_atomic(new_size * sizeof(union ecl_ffi_values *)); + memcpy(types, env->ffi_types, env->ffi_args_limit * sizeof(ffi_type*)); + memcpy(values, env->ffi_values, env->ffi_args_limit * + sizeof(union ecl_ffi_values)); + for (i = 0; i < new_size; i++) { + values_ptrs[i] = (values + i + 1); + } + env->ffi_args_limit = new_size; + ecl_dealloc(env->ffi_types); + env->ffi_types = types; + ecl_dealloc(env->ffi_values); + env->ffi_values = values; + ecl_dealloc(env->ffi_values_ptrs); + env->ffi_values_ptrs = values_ptrs; } static int @@ -917,139 +789,135 @@ cl_object arg_types, cl_object args, cl_object cc_type, ffi_type ***output_copy) { - int n, ok; - ffi_type **types; - enum ecl_ffi_tag type = ecl_foreign_type_code(return_type); - if (!the_env->ffi_args_limit) - resize_call_stack(the_env, 32); - the_env->ffi_types[0] = ecl_type_to_libffi_type[type]; - for (n=0; !Null(arg_types); ) { - if (!LISTP(arg_types)) { - FEerror("In CALL-CFUN, types lists is not a proper list", 0); - } - if (n >= the_env->ffi_args_limit) { - resize_call_stack(the_env, n + 32); - } - type = ecl_foreign_type_code(ECL_CONS_CAR(arg_types)); - arg_types = ECL_CONS_CDR(arg_types); - the_env->ffi_types[++n] = ecl_type_to_libffi_type[type]; - if (CONSP(args)) { - cl_object object = ECL_CONS_CAR(args); - args = ECL_CONS_CDR(args); - if (type == ECL_FFI_CSTRING) { - object = ecl_null_terminated_base_string(CAR(args)); - if (ECL_CONS_CAR(args) != object) { - ECL_STACK_PUSH(the_env, object); - } - } - ecl_foreign_data_set_elt(the_env->ffi_values + n, type, object); - } - } - if (output_copy) { - cl_index bytes = (n + 1) * sizeof(ffi_type*); - *output_copy = types = (ffi_type**)ecl_alloc_atomic(bytes); - memcpy(types, the_env->ffi_types, bytes); - } else { - types = the_env->ffi_types; - } - ok = ffi_prep_cif(cif, ecl_foreign_cc_code(cc_type), n, types[0], types + 1); - if (ok != FFI_OK) { - if (ok == FFI_BAD_ABI) { - FEerror("In CALL-CFUN, not a valid ABI: ~A", 1, - cc_type); - } - if (ok == FFI_BAD_TYPEDEF) { - FEerror("In CALL-CFUN, wrong or malformed argument types", 0); - } - } - return n; + int n, ok; + ffi_type **types; + enum ecl_ffi_tag type = ecl_foreign_type_code(return_type); + if (!the_env->ffi_args_limit) + resize_call_stack(the_env, 32); + the_env->ffi_types[0] = ecl_type_to_libffi_type[type]; + for (n=0; !Null(arg_types); ) { + if (!LISTP(arg_types)) { + FEerror("In CALL-CFUN, types lists is not a proper list", 0); + } + if (n >= the_env->ffi_args_limit) { + resize_call_stack(the_env, n + 32); + } + type = ecl_foreign_type_code(ECL_CONS_CAR(arg_types)); + arg_types = ECL_CONS_CDR(arg_types); + the_env->ffi_types[++n] = ecl_type_to_libffi_type[type]; + if (CONSP(args)) { + cl_object object = ECL_CONS_CAR(args); + args = ECL_CONS_CDR(args); + if (type == ECL_FFI_CSTRING) { + object = ecl_null_terminated_base_string(CAR(args)); + if (ECL_CONS_CAR(args) != object) { + ECL_STACK_PUSH(the_env, object); + } + } + ecl_foreign_data_set_elt(the_env->ffi_values + n, type, object); + } + } + if (output_copy) { + cl_index bytes = (n + 1) * sizeof(ffi_type*); + *output_copy = types = (ffi_type**)ecl_alloc_atomic(bytes); + memcpy(types, the_env->ffi_types, bytes); + } else { + types = the_env->ffi_types; + } + ok = ffi_prep_cif(cif, ecl_foreign_cc_code(cc_type), n, types[0], types + 1); + if (ok != FFI_OK) { + if (ok == FFI_BAD_ABI) { + FEerror("In CALL-CFUN, not a valid ABI: ~A", 1, + cc_type); + } + if (ok == FFI_BAD_TYPEDEF) { + FEerror("In CALL-CFUN, wrong or malformed argument types", 0); + } + } + return n; } @(defun si::call-cfun (fun return_type arg_types args &optional (cc_type @':default')) - void *cfun = ecl_foreign_data_pointer_safe(fun); - cl_object object; - volatile cl_index sp; - ffi_cif cif; -@ -{ - sp = ECL_STACK_INDEX(the_env); - prepare_cif(the_env, &cif, return_type, arg_types, args, cc_type, NULL); - ffi_call(&cif, cfun, the_env->ffi_values, (void **)the_env->ffi_values_ptrs); - object = ecl_foreign_data_ref_elt(the_env->ffi_values, - ecl_foreign_type_code(return_type)); - ECL_STACK_SET_INDEX(the_env, sp); - @(return object) -} -@) + void *cfun = ecl_foreign_data_pointer_safe(fun); + cl_object object; + volatile cl_index sp; + ffi_cif cif; +@ { + sp = ECL_STACK_INDEX(the_env); + prepare_cif(the_env, &cif, return_type, arg_types, args, cc_type, NULL); + ffi_call(&cif, cfun, the_env->ffi_values, (void **)the_env->ffi_values_ptrs); + object = ecl_foreign_data_ref_elt(the_env->ffi_values, + ecl_foreign_type_code(return_type)); + ECL_STACK_SET_INDEX(the_env, sp); + @(return object); +} @) static void callback_executor(ffi_cif *cif, void *result, void **args, void *userdata) { - cl_object data = (cl_object)userdata; - cl_object fun = ECL_CONS_CAR(data); - cl_object ret_type = (data = ECL_CONS_CDR(data), ECL_CONS_CAR(data)); - cl_object arg_types = (data = ECL_CONS_CDR(data), ECL_CONS_CAR(data)); - cl_env_ptr the_env = ecl_process_env(); - struct ecl_stack_frame frame_aux; - const cl_object frame = ecl_stack_frame_open(the_env, (cl_object)&frame_aux, 0); - cl_object x; - while (arg_types != ECL_NIL) { - cl_object type = ECL_CONS_CAR(arg_types); - enum ecl_ffi_tag tag = ecl_foreign_type_code(type); - x = ecl_foreign_data_ref_elt(*args, tag); - ecl_stack_frame_push(frame, x); - arg_types = ECL_CONS_CDR(arg_types); - args++; - } - x = ecl_apply_from_stack_frame(frame, fun); - ecl_stack_frame_close(frame); - ecl_foreign_data_set_elt(result, ecl_foreign_type_code(ret_type), x); + cl_object data = (cl_object)userdata; + cl_object fun = ECL_CONS_CAR(data); + cl_object ret_type = (data = ECL_CONS_CDR(data), ECL_CONS_CAR(data)); + cl_object arg_types = (data = ECL_CONS_CDR(data), ECL_CONS_CAR(data)); + cl_env_ptr the_env = ecl_process_env(); + struct ecl_stack_frame frame_aux; + const cl_object frame = ecl_stack_frame_open(the_env, (cl_object)&frame_aux, 0); + cl_object x; + while (arg_types != ECL_NIL) { + cl_object type = ECL_CONS_CAR(arg_types); + enum ecl_ffi_tag tag = ecl_foreign_type_code(type); + x = ecl_foreign_data_ref_elt(*args, tag); + ecl_stack_frame_push(frame, x); + arg_types = ECL_CONS_CDR(arg_types); + args++; + } + x = ecl_apply_from_stack_frame(frame, fun); + ecl_stack_frame_close(frame); + ecl_foreign_data_set_elt(result, ecl_foreign_type_code(ret_type), x); } cl_object si_free_ffi_closure(cl_object closure) { - ffi_closure_free(ecl_foreign_data_pointer_safe(closure)); - @(return); + ffi_closure_free(ecl_foreign_data_pointer_safe(closure)); + @(return); } @(defun si::make-dynamic-callback (fun sym return_type arg_types &optional (cc_type @':default')) -@ -{ - ffi_cif *cif = ecl_alloc(sizeof(ffi_cif)); - ffi_type **types; - int n = prepare_cif(the_env, cif, return_type, arg_types, ECL_NIL, cc_type, - &types); - - /* libffi allocates executable memory for us. ffi_closure_alloc() - * returns a pointer to memory and a pointer to the beginning of - * the actual executable region (executable_closure) which is - * where the code resides. */ - void *executable_region; - ffi_closure *closure = ffi_closure_alloc(sizeof(ffi_closure), &executable_region); - - cl_object closure_object = ecl_make_foreign_data(@':pointer-void', - sizeof(ffi_closure), - closure); - si_set_finalizer(closure_object, @'si::free-ffi-closure'); - - cl_object data = cl_list(6, closure_object, - fun, return_type, arg_types, cc_type, - ecl_make_foreign_data(@':pointer-void', - sizeof(*cif), cif), - ecl_make_foreign_data(@':pointer-void', - (n + 1) * sizeof(ffi_type*), - types)); - int status = ffi_prep_closure_loc(closure, cif, callback_executor, - ECL_CONS_CDR(data), executable_region); - - if (status != FFI_OK) { - FEerror("Unable to build callback. libffi returns ~D", 1, - ecl_make_fixnum(status)); - } - si_put_sysprop(sym, @':callback', data); - @(return closure_object); -} -@) +@ { + ffi_cif *cif = ecl_alloc(sizeof(ffi_cif)); + ffi_type **types; + int n = prepare_cif(the_env, cif, return_type, arg_types, ECL_NIL, cc_type, + &types); + + /* libffi allocates executable memory for us. ffi_closure_alloc() + * returns a pointer to memory and a pointer to the beginning of + * the actual executable region (executable_closure) which is + * where the code resides. */ + void *executable_region; + ffi_closure *closure = ffi_closure_alloc(sizeof(ffi_closure), &executable_region); + + cl_object closure_object = ecl_make_foreign_data(@':pointer-void', + sizeof(ffi_closure), + closure); + si_set_finalizer(closure_object, @'si::free-ffi-closure'); + + cl_object data = cl_list(6, closure_object, + fun, return_type, arg_types, cc_type, + ecl_make_foreign_data(@':pointer-void', + sizeof(*cif), cif), + ecl_make_foreign_data(@':pointer-void', + (n + 1) * sizeof(ffi_type*), + types)); + int status = ffi_prep_closure_loc(closure, cif, callback_executor, + ECL_CONS_CDR(data), executable_region); + + if (status != FFI_OK) { + FEerror("Unable to build callback. libffi returns ~D", 1, + ecl_make_fixnum(status)); + } + si_put_sysprop(sym, @':callback', data); + @(return closure_object); +} @) #endif /* HAVE_LIBFFI */ diff -Nru ecl-16.1.2/src/c/file.d ecl-16.1.3+ds/src/c/file.d --- ecl-16.1.2/src/c/file.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/file.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,27 +1,22 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - file.d -- File interface. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * file.d - file interface + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ /* - IMPLEMENTATION-DEPENDENT + IMPLEMENTATION-DEPENDENT - The file contains code to reclaim the I/O buffer - by accessing the FILE structure of C. + The file contains code to reclaim the I/O buffer + by accessing the FILE structure of C. */ #include @@ -56,7 +51,7 @@ # define STDOUT_FILENO 1 # define STDERR_FILENO 2 # define HAVE_SELECT -#elif defined(HAVE_SYS_IOCTL_H) && !defined(MSDOS) && !defined(cygwin) +#elif defined(HAVE_SYS_IOCTL_H) && !defined(cygwin) # include #endif @@ -104,129 +99,129 @@ static cl_index not_output_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - not_an_output_stream(strm); - return 0; + not_an_output_stream(strm); + return 0; } static cl_index not_input_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - not_an_input_stream(strm); - return 0; + not_an_input_stream(strm); + return 0; } static cl_index not_binary_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - not_a_binary_stream(strm); - return 0; + not_a_binary_stream(strm); + return 0; } static void not_output_write_byte(cl_object c, cl_object strm) { - not_an_output_stream(strm); + not_an_output_stream(strm); } static cl_object not_input_read_byte(cl_object strm) { - not_an_input_stream(strm); - return OBJNULL; + not_an_input_stream(strm); + return OBJNULL; } static void not_binary_write_byte(cl_object c, cl_object strm) { - not_a_binary_stream(strm); + not_a_binary_stream(strm); } static cl_object not_binary_read_byte(cl_object strm) { - not_a_binary_stream(strm); - return OBJNULL; + not_a_binary_stream(strm); + return OBJNULL; } static ecl_character not_input_read_char(cl_object strm) { - not_an_input_stream(strm); - return -1; + not_an_input_stream(strm); + return -1; } static ecl_character not_output_write_char(cl_object strm, ecl_character c) { - not_an_output_stream(strm); - return c; + not_an_output_stream(strm); + return c; } static void not_input_unread_char(cl_object strm, ecl_character c) { - not_an_input_stream(strm); + not_an_input_stream(strm); } static int not_input_listen(cl_object strm) { - not_an_input_stream(strm); - return -1; + not_an_input_stream(strm); + return -1; } static ecl_character not_character_read_char(cl_object strm) { - not_a_character_stream(strm); - return -1; + not_a_character_stream(strm); + return -1; } static ecl_character not_character_write_char(cl_object strm, ecl_character c) { - not_a_character_stream(strm); - return c; + not_a_character_stream(strm); + return c; } static void not_input_clear_input(cl_object strm) { - not_an_input_stream(strm); - return; + not_an_input_stream(strm); + return; } static void not_output_clear_output(cl_object strm) { - not_an_output_stream(strm); + not_an_output_stream(strm); } static void not_output_force_output(cl_object strm) { - not_an_output_stream(strm); + not_an_output_stream(strm); } static void not_output_finish_output(cl_object strm) { - not_an_output_stream(strm); + not_an_output_stream(strm); } #if defined(ECL_WSOCK) static cl_object not_implemented_get_position(cl_object strm) { - FEerror("file-position not implemented for stream ~S", 1, strm); - return ECL_NIL; + FEerror("file-position not implemented for stream ~S", 1, strm); + return ECL_NIL; } static cl_object not_implemented_set_position(cl_object strm, cl_object pos) { - FEerror("file-position not implemented for stream ~S", 1, strm); - return ECL_NIL; + FEerror("file-position not implemented for stream ~S", 1, strm); + return ECL_NIL; } #endif @@ -237,48 +232,48 @@ static cl_index closed_stream_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - FEclosed_stream(strm); - return 0; + FEclosed_stream(strm); + return 0; } static cl_index closed_stream_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - FEclosed_stream(strm); - return 0; + FEclosed_stream(strm); + return 0; } static ecl_character closed_stream_read_char(cl_object strm) { - FEclosed_stream(strm); - return 0; + FEclosed_stream(strm); + return 0; } static ecl_character closed_stream_write_char(cl_object strm, ecl_character c) { - FEclosed_stream(strm); - return c; + FEclosed_stream(strm); + return c; } static void closed_stream_unread_char(cl_object strm, ecl_character c) { - FEclosed_stream(strm); + FEclosed_stream(strm); } static int closed_stream_listen(cl_object strm) { - FEclosed_stream(strm); - return 0; + FEclosed_stream(strm); + return 0; } static void closed_stream_clear_input(cl_object strm) { - FEclosed_stream(strm); + FEclosed_stream(strm); } #define closed_stream_clear_output closed_stream_clear_input @@ -288,7 +283,7 @@ static cl_object closed_stream_length(cl_object strm) { - FEclosed_stream(strm); + FEclosed_stream(strm); } #define closed_stream_get_position closed_stream_length @@ -296,7 +291,7 @@ static cl_object closed_stream_set_position(cl_object strm, cl_object position) { - FEclosed_stream(strm); + FEclosed_stream(strm); } /********************************************************************** @@ -310,123 +305,123 @@ static cl_object generic_read_byte_unsigned8(cl_object strm) { - unsigned char c; - if (strm->stream.ops->read_byte8(strm, &c, 1) < 1) { - return ECL_NIL; - } - return ecl_make_fixnum(c); + unsigned char c; + if (strm->stream.ops->read_byte8(strm, &c, 1) < 1) { + return ECL_NIL; + } + return ecl_make_fixnum(c); } static void generic_write_byte_unsigned8(cl_object byte, cl_object strm) { - unsigned char c = ecl_to_uint8_t(byte); - strm->stream.ops->write_byte8(strm, &c, 1); + unsigned char c = ecl_to_uint8_t(byte); + strm->stream.ops->write_byte8(strm, &c, 1); } static cl_object generic_read_byte_signed8(cl_object strm) { - signed char c; - if (strm->stream.ops->read_byte8(strm, (unsigned char *)&c, 1) < 1) - return ECL_NIL; - return ecl_make_fixnum(c); + signed char c; + if (strm->stream.ops->read_byte8(strm, (unsigned char *)&c, 1) < 1) + return ECL_NIL; + return ecl_make_fixnum(c); } static void generic_write_byte_signed8(cl_object byte, cl_object strm) { - signed char c = fixint(byte); - strm->stream.ops->write_byte8(strm, (unsigned char *)&c, 1); + signed char c = fixint(byte); + strm->stream.ops->write_byte8(strm, (unsigned char *)&c, 1); } static cl_object generic_read_byte_le(cl_object strm) { - cl_index (*read_byte8)(cl_object, unsigned char *, cl_index); - unsigned char c; - cl_index nb, bs; - cl_object output = ecl_make_fixnum(0); - read_byte8 = strm->stream.ops->read_byte8; - bs = strm->stream.byte_size; - for (nb = 0; bs >= 8; bs -= 8, nb += 8) { - cl_object aux; - if (read_byte8(strm, &c, 1) < 1) - return ECL_NIL; - if (bs <= 8 && (strm->stream.flags & ECL_STREAM_SIGNED_BYTES)) - aux = ecl_make_fixnum((signed char)c); - else - aux = ecl_make_fixnum((unsigned char)c); - output = cl_logior(2, output, cl_ash(aux, ecl_make_fixnum(nb))); - } - return output; + cl_index (*read_byte8)(cl_object, unsigned char *, cl_index); + unsigned char c; + cl_index nb, bs; + cl_object output = ecl_make_fixnum(0); + read_byte8 = strm->stream.ops->read_byte8; + bs = strm->stream.byte_size; + for (nb = 0; bs >= 8; bs -= 8, nb += 8) { + cl_object aux; + if (read_byte8(strm, &c, 1) < 1) + return ECL_NIL; + if (bs <= 8 && (strm->stream.flags & ECL_STREAM_SIGNED_BYTES)) + aux = ecl_make_fixnum((signed char)c); + else + aux = ecl_make_fixnum((unsigned char)c); + output = cl_logior(2, output, cl_ash(aux, ecl_make_fixnum(nb))); + } + return output; } static void generic_write_byte_le(cl_object c, cl_object strm) { - cl_index (*write_byte8)(cl_object strm, unsigned char *c, cl_index n); - cl_index bs; - write_byte8 = strm->stream.ops->write_byte8; - bs = strm->stream.byte_size; - do { - cl_object b = cl_logand(2, c, ecl_make_fixnum(0xFF)); - unsigned char aux = (unsigned char)ecl_fixnum(b); - if (write_byte8(strm, &aux, 1) < 1) - break; - c = cl_ash(c, ecl_make_fixnum(-8)); - bs -= 8; - } while (bs); + cl_index (*write_byte8)(cl_object strm, unsigned char *c, cl_index n); + cl_index bs; + write_byte8 = strm->stream.ops->write_byte8; + bs = strm->stream.byte_size; + do { + cl_object b = cl_logand(2, c, ecl_make_fixnum(0xFF)); + unsigned char aux = (unsigned char)ecl_fixnum(b); + if (write_byte8(strm, &aux, 1) < 1) + break; + c = cl_ash(c, ecl_make_fixnum(-8)); + bs -= 8; + } while (bs); } static cl_object generic_read_byte(cl_object strm) { - cl_index (*read_byte8)(cl_object, unsigned char *, cl_index); - unsigned char c; - cl_object output = NULL; - cl_index bs; - read_byte8 = strm->stream.ops->read_byte8; - bs = strm->stream.byte_size; - for (; bs >= 8; bs -= 8) { - if (read_byte8(strm, &c, 1) < 1) - return ECL_NIL; - if (output) { - output = cl_logior(2, ecl_make_fixnum(c), - cl_ash(output, ecl_make_fixnum(8))); - } else if (strm->stream.flags & ECL_STREAM_SIGNED_BYTES) { - output = ecl_make_fixnum((signed char)c); - } else { - output = ecl_make_fixnum((unsigned char)c); - } - } - return output; + cl_index (*read_byte8)(cl_object, unsigned char *, cl_index); + unsigned char c; + cl_object output = NULL; + cl_index bs; + read_byte8 = strm->stream.ops->read_byte8; + bs = strm->stream.byte_size; + for (; bs >= 8; bs -= 8) { + if (read_byte8(strm, &c, 1) < 1) + return ECL_NIL; + if (output) { + output = cl_logior(2, ecl_make_fixnum(c), + cl_ash(output, ecl_make_fixnum(8))); + } else if (strm->stream.flags & ECL_STREAM_SIGNED_BYTES) { + output = ecl_make_fixnum((signed char)c); + } else { + output = ecl_make_fixnum((unsigned char)c); + } + } + return output; } static void generic_write_byte(cl_object c, cl_object strm) { - cl_index (*write_byte8)(cl_object strm, unsigned char *c, cl_index n); - cl_index bs; - write_byte8 = strm->stream.ops->write_byte8; - bs = strm->stream.byte_size; - do { - unsigned char aux; - cl_object b; - bs -= 8; - b = cl_logand(2, ecl_make_fixnum(0xFF), bs? cl_ash(c, ecl_make_fixnum(-bs)) : c); - aux = (unsigned char)ecl_fixnum(b); - if (write_byte8(strm, &aux, 1) < 1) - break; - } while (bs); + cl_index (*write_byte8)(cl_object strm, unsigned char *c, cl_index n); + cl_index bs; + write_byte8 = strm->stream.ops->write_byte8; + bs = strm->stream.byte_size; + do { + unsigned char aux; + cl_object b; + bs -= 8; + b = cl_logand(2, ecl_make_fixnum(0xFF), bs? cl_ash(c, ecl_make_fixnum(-bs)) : c); + aux = (unsigned char)ecl_fixnum(b); + if (write_byte8(strm, &aux, 1) < 1) + break; + } while (bs); } static ecl_character generic_peek_char(cl_object strm) { - ecl_character out = ecl_read_char(strm); - if (out != EOF) ecl_unread_char(out, strm); - return out; + ecl_character out = ecl_read_char(strm); + if (out != EOF) ecl_unread_char(out, strm); + return out; } static void @@ -437,111 +432,111 @@ static int generic_always_true(cl_object strm) { - return 1; + return 1; } static int generic_always_false(cl_object strm) { - return 0; + return 0; } static cl_object generic_always_nil(cl_object strm) { - return ECL_NIL; + return ECL_NIL; } static int generic_column(cl_object strm) { - return 0; + return 0; } static cl_object generic_set_position(cl_object strm, cl_object pos) { - return ECL_NIL; + return ECL_NIL; } static cl_object generic_close(cl_object strm) { - struct ecl_file_ops *ops = strm->stream.ops; - if (ecl_input_stream_p(strm)) { - ops->read_byte8 = closed_stream_read_byte8; - ops->read_char = closed_stream_read_char; - ops->unread_char = closed_stream_unread_char; - ops->listen = closed_stream_listen; - ops->clear_input = closed_stream_clear_input; - } - if (ecl_output_stream_p(strm)) { - ops->write_byte8 = closed_stream_write_byte8; - ops->write_char = closed_stream_write_char; - ops->clear_output = closed_stream_clear_output; - ops->force_output = closed_stream_force_output; - ops->finish_output = closed_stream_finish_output; - } - ops->get_position = closed_stream_get_position; - ops->set_position = closed_stream_set_position; - ops->length = closed_stream_length; - ops->close = generic_close; - strm->stream.closed = 1; - return ECL_T; + struct ecl_file_ops *ops = strm->stream.ops; + if (ecl_input_stream_p(strm)) { + ops->read_byte8 = closed_stream_read_byte8; + ops->read_char = closed_stream_read_char; + ops->unread_char = closed_stream_unread_char; + ops->listen = closed_stream_listen; + ops->clear_input = closed_stream_clear_input; + } + if (ecl_output_stream_p(strm)) { + ops->write_byte8 = closed_stream_write_byte8; + ops->write_char = closed_stream_write_char; + ops->clear_output = closed_stream_clear_output; + ops->force_output = closed_stream_force_output; + ops->finish_output = closed_stream_finish_output; + } + ops->get_position = closed_stream_get_position; + ops->set_position = closed_stream_set_position; + ops->length = closed_stream_length; + ops->close = generic_close; + strm->stream.closed = 1; + return ECL_T; } static cl_index generic_write_vector(cl_object strm, cl_object data, cl_index start, cl_index end) { - cl_elttype elttype; - const struct ecl_file_ops *ops; - if (start >= end) - return start; - ops = stream_dispatch_table(strm); - elttype = ecl_array_elttype(data); - if (elttype == ecl_aet_bc || + cl_elttype elttype; + const struct ecl_file_ops *ops; + if (start >= end) + return start; + ops = stream_dispatch_table(strm); + elttype = ecl_array_elttype(data); + if (elttype == ecl_aet_bc || #ifdef ECL_UNICODE - elttype == ecl_aet_ch || + elttype == ecl_aet_ch || #endif - (elttype == ecl_aet_object && ECL_CHARACTERP(ecl_elt(data, 0)))) { - ecl_character (*write_char)(cl_object, ecl_character) = ops->write_char; - for (; start < end; start++) { - write_char(strm, ecl_char_code(ecl_elt(data, start))); - } - } else { - void (*write_byte)(cl_object, cl_object) = ops->write_byte; - for (; start < end; start++) { - write_byte(ecl_elt(data, start), strm); - } - } - return start; + (elttype == ecl_aet_object && ECL_CHARACTERP(ecl_elt(data, 0)))) { + ecl_character (*write_char)(cl_object, ecl_character) = ops->write_char; + for (; start < end; start++) { + write_char(strm, ecl_char_code(ecl_elt(data, start))); + } + } else { + void (*write_byte)(cl_object, cl_object) = ops->write_byte; + for (; start < end; start++) { + write_byte(ecl_elt(data, start), strm); + } + } + return start; } static cl_index generic_read_vector(cl_object strm, cl_object data, cl_index start, cl_index end) { - const struct ecl_file_ops *ops; - cl_object expected_type; - if (start >= end) - return start; - expected_type = ecl_stream_element_type(strm); - ops = stream_dispatch_table(strm); - if (expected_type == @'base-char' || expected_type == @'character') { - ecl_character (*read_char)(cl_object) = ops->read_char; - for (; start < end; start++) { - cl_fixnum c = read_char(strm); - if (c == EOF) break; - ecl_elt_set(data, start, ECL_CODE_CHAR(c)); - } - } else { - cl_object (*read_byte)(cl_object) = ops->read_byte; - for (; start < end; start++) { - cl_object x = read_byte(strm); - if (Null(x)) break; - ecl_elt_set(data, start, x); - } - } - return start; + const struct ecl_file_ops *ops; + cl_object expected_type; + if (start >= end) + return start; + expected_type = ecl_stream_element_type(strm); + ops = stream_dispatch_table(strm); + if (expected_type == @'base-char' || expected_type == @'character') { + ecl_character (*read_char)(cl_object) = ops->read_char; + for (; start < end; start++) { + cl_fixnum c = read_char(strm); + if (c == EOF) break; + ecl_elt_set(data, start, ECL_CODE_CHAR(c)); + } + } else { + cl_object (*read_byte)(cl_object) = ops->read_byte; + for (; start < end; start++) { + cl_object x = read_byte(strm); + if (Null(x)) break; + ecl_elt_set(data, start, x); + } + } + return start; } /********************************************************************** @@ -551,113 +546,113 @@ static void eformat_unread_char(cl_object strm, ecl_character c) { - unlikely_if (c != strm->stream.last_char) { - unread_twice(strm); - } - { - unsigned char buffer[2*ENCODING_BUFFER_MAX_SIZE]; - int ndx = 0; - cl_object l = strm->stream.byte_stack; - cl_fixnum i = strm->stream.last_code[0]; - if (i != EOF) { - ndx += strm->stream.encoder(strm, buffer, i); - } - i = strm->stream.last_code[1]; - if (i != EOF) { - ndx += strm->stream.encoder(strm, buffer+ndx, i); - } - while (ndx != 0) { - l = CONS(ecl_make_fixnum(buffer[--ndx]), l); - } - strm->stream.byte_stack = l; - strm->stream.last_char = EOF; - } + unlikely_if (c != strm->stream.last_char) { + unread_twice(strm); + } + { + unsigned char buffer[2*ENCODING_BUFFER_MAX_SIZE]; + int ndx = 0; + cl_object l = strm->stream.byte_stack; + cl_fixnum i = strm->stream.last_code[0]; + if (i != EOF) { + ndx += strm->stream.encoder(strm, buffer, i); + } + i = strm->stream.last_code[1]; + if (i != EOF) { + ndx += strm->stream.encoder(strm, buffer+ndx, i); + } + while (ndx != 0) { + l = CONS(ecl_make_fixnum(buffer[--ndx]), l); + } + strm->stream.byte_stack = l; + strm->stream.last_char = EOF; + } } static ecl_character eformat_read_char(cl_object strm) { - ecl_character c = strm->stream.decoder(strm); - unlikely_if (c == strm->stream.eof_char) - return EOF; - if (c != EOF) { - strm->stream.last_char = c; - strm->stream.last_code[0] = c; - strm->stream.last_code[1] = EOF; - } - return c; + ecl_character c = strm->stream.decoder(strm); + unlikely_if (c == strm->stream.eof_char) + return EOF; + if (c != EOF) { + strm->stream.last_char = c; + strm->stream.last_code[0] = c; + strm->stream.last_code[1] = EOF; + } + return c; } static ecl_character eformat_write_char(cl_object strm, ecl_character c) { - unsigned char buffer[ENCODING_BUFFER_MAX_SIZE]; - ecl_character nbytes; - nbytes = strm->stream.encoder(strm, buffer, c); - strm->stream.ops->write_byte8(strm, buffer, nbytes); - if (c == '\n') - strm->stream.column = 0; - else if (c == '\t') - strm->stream.column = (strm->stream.column & ~((cl_index)07)) + 8; - else - strm->stream.column++; - fflush(stdout); - return c; + unsigned char buffer[ENCODING_BUFFER_MAX_SIZE]; + ecl_character nbytes; + nbytes = strm->stream.encoder(strm, buffer, c); + strm->stream.ops->write_byte8(strm, buffer, nbytes); + if (c == '\n') + strm->stream.column = 0; + else if (c == '\t') + strm->stream.column = (strm->stream.column & ~((cl_index)07)) + 8; + else + strm->stream.column++; + fflush(stdout); + return c; } static ecl_character eformat_read_char_cr(cl_object strm) { - ecl_character c = eformat_read_char(strm); - if (c == ECL_CHAR_CODE_RETURN) { - c = ECL_CHAR_CODE_NEWLINE; - strm->stream.last_char = c; - } - return c; + ecl_character c = eformat_read_char(strm); + if (c == ECL_CHAR_CODE_RETURN) { + c = ECL_CHAR_CODE_NEWLINE; + strm->stream.last_char = c; + } + return c; } static ecl_character eformat_write_char_cr(cl_object strm, ecl_character c) { - if (c == ECL_CHAR_CODE_NEWLINE) { - eformat_write_char(strm, ECL_CHAR_CODE_RETURN); - strm->stream.column = 0; - return c; - } - return eformat_write_char(strm, c); + if (c == ECL_CHAR_CODE_NEWLINE) { + eformat_write_char(strm, ECL_CHAR_CODE_RETURN); + strm->stream.column = 0; + return c; + } + return eformat_write_char(strm, c); } static ecl_character eformat_read_char_crlf(cl_object strm) { - ecl_character c = eformat_read_char(strm); - if (c == ECL_CHAR_CODE_RETURN) { - c = eformat_read_char(strm); - if (c == ECL_CHAR_CODE_LINEFEED) { - strm->stream.last_code[0] = ECL_CHAR_CODE_RETURN; - strm->stream.last_code[1] = c; - c = ECL_CHAR_CODE_NEWLINE; - } else { - eformat_unread_char(strm, c); - c = ECL_CHAR_CODE_RETURN; - strm->stream.last_code[0] = c; - strm->stream.last_code[1] = EOF; - } - strm->stream.last_char = c; - } - return c; + ecl_character c = eformat_read_char(strm); + if (c == ECL_CHAR_CODE_RETURN) { + c = eformat_read_char(strm); + if (c == ECL_CHAR_CODE_LINEFEED) { + strm->stream.last_code[0] = ECL_CHAR_CODE_RETURN; + strm->stream.last_code[1] = c; + c = ECL_CHAR_CODE_NEWLINE; + } else { + eformat_unread_char(strm, c); + c = ECL_CHAR_CODE_RETURN; + strm->stream.last_code[0] = c; + strm->stream.last_code[1] = EOF; + } + strm->stream.last_char = c; + } + return c; } static ecl_character eformat_write_char_crlf(cl_object strm, ecl_character c) { - if (c == ECL_CHAR_CODE_NEWLINE) { - eformat_write_char(strm, ECL_CHAR_CODE_RETURN); - eformat_write_char(strm, ECL_CHAR_CODE_LINEFEED); - strm->stream.column = 0; - return c; - } - return eformat_write_char(strm, c); + if (c == ECL_CHAR_CODE_NEWLINE) { + eformat_write_char(strm, ECL_CHAR_CODE_RETURN); + eformat_write_char(strm, ECL_CHAR_CODE_LINEFEED); + strm->stream.column = 0; + return c; + } + return eformat_write_char(strm, c); } /* @@ -669,23 +664,23 @@ static ecl_character passthrough_decoder(cl_object stream) { - unsigned char aux; - if (ecl_read_byte8(stream, &aux, 1) < 1) - return EOF; - else - return aux; + unsigned char aux; + if (ecl_read_byte8(stream, &aux, 1) < 1) + return EOF; + else + return aux; } static int passthrough_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { #ifdef ECL_UNICODE - unlikely_if (c > 0xFF) { - return encoding_error(stream, buffer, c); - } + unlikely_if (c > 0xFF) { + return encoding_error(stream, buffer, c); + } #endif - buffer[0] = c; - return 1; + buffer[0] = c; + return 1; } #ifdef ECL_UNICODE @@ -696,24 +691,24 @@ static ecl_character ascii_decoder(cl_object stream) { - unsigned char aux; - if (ecl_read_byte8(stream, &aux, 1) < 1) { - return EOF; - } else if (aux > 127) { - return decoding_error(stream, &aux, 1); - } else { - return aux; - } + unsigned char aux; + if (ecl_read_byte8(stream, &aux, 1) < 1) { + return EOF; + } else if (aux > 127) { + return decoding_error(stream, &aux, 1); + } else { + return aux; + } } static int ascii_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - unlikely_if (c > 127) { - return encoding_error(stream, buffer, c); - } - buffer[0] = c; - return 1; + unlikely_if (c > 127) { + return encoding_error(stream, buffer, c); + } + buffer[0] = c; + return 1; } /* @@ -723,22 +718,22 @@ static ecl_character ucs_4be_decoder(cl_object stream) { - unsigned char buffer[4]; - if (ecl_read_byte8(stream, buffer, 4) < 4) { - return EOF; - } else { - return buffer[3]+(buffer[2]<<8)+(buffer[1]<<16)+(buffer[0]<<24); - } + unsigned char buffer[4]; + if (ecl_read_byte8(stream, buffer, 4) < 4) { + return EOF; + } else { + return buffer[3]+(buffer[2]<<8)+(buffer[1]<<16)+(buffer[0]<<24); + } } static int ucs_4be_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - buffer[3] = c & 0xFF; c >>= 8; - buffer[2] = c & 0xFF; c >>= 8; - buffer[1] = c & 0xFF; c >>= 8; - buffer[0] = c; - return 4; + buffer[3] = c & 0xFF; c >>= 8; + buffer[2] = c & 0xFF; c >>= 8; + buffer[1] = c & 0xFF; c >>= 8; + buffer[0] = c; + return 4; } /* @@ -748,22 +743,22 @@ static ecl_character ucs_4le_decoder(cl_object stream) { - unsigned char buffer[4]; - if (ecl_read_byte8(stream, buffer, 4) < 4) { - return EOF; - } else { - return buffer[0]+(buffer[1]<<8)+(buffer[2]<<16)+(buffer[3]<<24); - } + unsigned char buffer[4]; + if (ecl_read_byte8(stream, buffer, 4) < 4) { + return EOF; + } else { + return buffer[0]+(buffer[1]<<8)+(buffer[2]<<16)+(buffer[3]<<24); + } } static int ucs_4le_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - buffer[0] = c & 0xFF; c >>= 8; - buffer[1] = c & 0xFF; c >>= 8; - buffer[2] = c & 0xFF; c >>= 8; - buffer[3] = c; - return 4; + buffer[0] = c & 0xFF; c >>= 8; + buffer[1] = c & 0xFF; c >>= 8; + buffer[2] = c & 0xFF; c >>= 8; + buffer[3] = c; + return 4; } /* @@ -773,31 +768,31 @@ static ecl_character ucs_4_decoder(cl_object stream) { - cl_fixnum c = ucs_4be_decoder(stream); - if (c == 0xFEFF) { - stream->stream.decoder = ucs_4be_decoder; - stream->stream.encoder = ucs_4be_encoder; - return ucs_4be_decoder(stream); - } else if (c == 0xFFFE0000) { - stream->stream.decoder = ucs_4le_decoder; - stream->stream.encoder = ucs_4le_encoder; - return ucs_4le_decoder(stream); - } else { - stream->stream.decoder = ucs_4be_decoder; - stream->stream.encoder = ucs_4be_encoder; - return c; - } + cl_fixnum c = ucs_4be_decoder(stream); + if (c == 0xFEFF) { + stream->stream.decoder = ucs_4be_decoder; + stream->stream.encoder = ucs_4be_encoder; + return ucs_4be_decoder(stream); + } else if (c == 0xFFFE0000) { + stream->stream.decoder = ucs_4le_decoder; + stream->stream.encoder = ucs_4le_encoder; + return ucs_4le_decoder(stream); + } else { + stream->stream.decoder = ucs_4be_decoder; + stream->stream.encoder = ucs_4be_encoder; + return c; + } } static int ucs_4_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - stream->stream.decoder = ucs_4be_decoder; - stream->stream.encoder = ucs_4be_encoder; - buffer[0] = 0xFF; - buffer[1] = 0xFE; - buffer[2] = buffer[3] = 0; - return 4 + ucs_4be_encoder(stream, buffer+4, c); + stream->stream.decoder = ucs_4be_decoder; + stream->stream.encoder = ucs_4be_encoder; + buffer[0] = 0xFF; + buffer[1] = 0xFE; + buffer[2] = buffer[3] = 0; + return 4 + ucs_4be_encoder(stream, buffer+4, c); } @@ -808,40 +803,40 @@ static ecl_character ucs_2be_decoder(cl_object stream) { - unsigned char buffer[2] = {0,0}; - if (ecl_read_byte8(stream, buffer, 2) < 2) { - return EOF; - } else { - ecl_character c = ((ecl_character)buffer[0] << 8) | buffer[1]; - if ((buffer[0] & 0xFC) == 0xD8) { - if (ecl_read_byte8(stream, buffer, 2) < 2) { - return EOF; - } else { - ecl_character aux; - if ((buffer[1] & 0xFC) != 0xDC) { - return decoding_error(stream, buffer, 1); - } - aux = ((ecl_character)buffer[0] << 8) | buffer[1]; - return ((c & 0x3FFF) << 10) + (aux & 0x3FFF) + 0x10000; - } - } - return c; - } + unsigned char buffer[2] = {0,0}; + if (ecl_read_byte8(stream, buffer, 2) < 2) { + return EOF; + } else { + ecl_character c = ((ecl_character)buffer[0] << 8) | buffer[1]; + if ((buffer[0] & 0xFC) == 0xD8) { + if (ecl_read_byte8(stream, buffer, 2) < 2) { + return EOF; + } else { + ecl_character aux; + if ((buffer[1] & 0xFC) != 0xDC) { + return decoding_error(stream, buffer, 1); + } + aux = ((ecl_character)buffer[0] << 8) | buffer[1]; + return ((c & 0x3FFF) << 10) + (aux & 0x3FFF) + 0x10000; + } + } + return c; + } } static int ucs_2be_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - if (c >= 0x10000) { - c -= 0x10000; - ucs_2be_encoder(stream, buffer, (c >> 10) | 0xD800); - ucs_2be_encoder(stream, buffer+2, (c & 0x3FFF) | 0xDC00); - return 4; - } else { - buffer[1] = c & 0xFF; c >>= 8; - buffer[0] = c; - return 2; - } + if (c >= 0x10000) { + c -= 0x10000; + ucs_2be_encoder(stream, buffer, (c >> 10) | 0xD800); + ucs_2be_encoder(stream, buffer+2, (c & 0x3FFF) | 0xDC00); + return 4; + } else { + buffer[1] = c & 0xFF; c >>= 8; + buffer[0] = c; + return 2; + } } /* @@ -851,40 +846,40 @@ static ecl_character ucs_2le_decoder(cl_object stream) { - unsigned char buffer[2]; - if (ecl_read_byte8(stream, buffer, 2) < 2) { - return EOF; - } else { - ecl_character c = ((ecl_character)buffer[1] << 8) | buffer[0]; - if ((buffer[1] & 0xFC) == 0xD8) { - if (ecl_read_byte8(stream, buffer, 2) < 2) { - return EOF; - } else { - ecl_character aux; - if ((buffer[1] & 0xFC) != 0xDC) { - return decoding_error(stream, buffer, 2); - } - aux = ((ecl_character)buffer[1] << 8) | buffer[0]; - return ((c & 0x3FFF) << 10) + (aux & 0x3FFF) + 0x10000; - } - } - return c; - } + unsigned char buffer[2]; + if (ecl_read_byte8(stream, buffer, 2) < 2) { + return EOF; + } else { + ecl_character c = ((ecl_character)buffer[1] << 8) | buffer[0]; + if ((buffer[1] & 0xFC) == 0xD8) { + if (ecl_read_byte8(stream, buffer, 2) < 2) { + return EOF; + } else { + ecl_character aux; + if ((buffer[1] & 0xFC) != 0xDC) { + return decoding_error(stream, buffer, 2); + } + aux = ((ecl_character)buffer[1] << 8) | buffer[0]; + return ((c & 0x3FFF) << 10) + (aux & 0x3FFF) + 0x10000; + } + } + return c; + } } static int ucs_2le_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - if (c >= 0x10000) { - c -= 0x10000; - ucs_2le_encoder(stream, buffer, (c >> 10) | 0xD8000); - ucs_2le_encoder(stream, buffer+2, (c & 0x3FFF) | 0xD800); - return 4; - } else { - buffer[0] = c & 0xFF; c >>= 8; - buffer[1] = c & 0xFF; - return 2; - } + if (c >= 0x10000) { + c -= 0x10000; + ucs_2le_encoder(stream, buffer, (c >> 10) | 0xD8000); + ucs_2le_encoder(stream, buffer+2, (c & 0x3FFF) | 0xD800); + return 4; + } else { + buffer[0] = c & 0xFF; c >>= 8; + buffer[1] = c & 0xFF; + return 2; + } } /* @@ -894,30 +889,30 @@ static ecl_character ucs_2_decoder(cl_object stream) { - ecl_character c = ucs_2be_decoder(stream); - if (c == 0xFEFF) { - stream->stream.decoder = ucs_2be_decoder; - stream->stream.encoder = ucs_2be_encoder; - return ucs_2be_decoder(stream); - } else if (c == 0xFFFE) { - stream->stream.decoder = ucs_2le_decoder; - stream->stream.encoder = ucs_2le_encoder; - return ucs_2le_decoder(stream); - } else { - stream->stream.decoder = ucs_2be_decoder; - stream->stream.encoder = ucs_2be_encoder; - return c; - } + ecl_character c = ucs_2be_decoder(stream); + if (c == 0xFEFF) { + stream->stream.decoder = ucs_2be_decoder; + stream->stream.encoder = ucs_2be_encoder; + return ucs_2be_decoder(stream); + } else if (c == 0xFFFE) { + stream->stream.decoder = ucs_2le_decoder; + stream->stream.encoder = ucs_2le_encoder; + return ucs_2le_decoder(stream); + } else { + stream->stream.decoder = ucs_2be_decoder; + stream->stream.encoder = ucs_2be_encoder; + return c; + } } static int ucs_2_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - stream->stream.decoder = ucs_2be_decoder; - stream->stream.encoder = ucs_2be_encoder; - buffer[0] = 0xFF; - buffer[1] = 0xFE; - return 2 + ucs_2be_encoder(stream, buffer+2, c); + stream->stream.decoder = ucs_2be_decoder; + stream->stream.encoder = ucs_2be_encoder; + buffer[0] = 0xFF; + buffer[1] = 0xFE; + return 2 + ucs_2be_encoder(stream, buffer+2, c); } /* @@ -927,47 +922,47 @@ static ecl_character user_decoder(cl_object stream) { - cl_object table = stream->stream.format_table; - cl_object character; - unsigned char buffer[2]; - if (ecl_read_byte8(stream, buffer, 1) < 1) { - return EOF; - } - character = ecl_gethash_safe(ecl_make_fixnum(buffer[0]), table, ECL_NIL); - unlikely_if (Null(character)) { - return decoding_error(stream, buffer, 1); - } - if (character == ECL_T) { - if (ecl_read_byte8(stream, buffer+1, 1) < 1) { - return EOF; - } else { - cl_fixnum byte = (buffer[0]<<8) + buffer[1]; - character = ecl_gethash_safe(ecl_make_fixnum(byte), table, ECL_NIL); - unlikely_if (Null(character)) { - return decoding_error(stream, buffer, 2); - } - } - } - return ECL_CHAR_CODE(character); + cl_object table = stream->stream.format_table; + cl_object character; + unsigned char buffer[2]; + if (ecl_read_byte8(stream, buffer, 1) < 1) { + return EOF; + } + character = ecl_gethash_safe(ecl_make_fixnum(buffer[0]), table, ECL_NIL); + unlikely_if (Null(character)) { + return decoding_error(stream, buffer, 1); + } + if (character == ECL_T) { + if (ecl_read_byte8(stream, buffer+1, 1) < 1) { + return EOF; + } else { + cl_fixnum byte = (buffer[0]<<8) + buffer[1]; + character = ecl_gethash_safe(ecl_make_fixnum(byte), table, ECL_NIL); + unlikely_if (Null(character)) { + return decoding_error(stream, buffer, 2); + } + } + } + return ECL_CHAR_CODE(character); } static int user_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - cl_object byte = ecl_gethash_safe(ECL_CODE_CHAR(c), stream->stream.format_table, ECL_NIL); - if (Null(byte)) { - return encoding_error(stream, buffer, c); - } else { - cl_fixnum code = ecl_fixnum(byte); - if (code > 0xFF) { - buffer[1] = code & 0xFF; code >>= 8; - buffer[0] = code; - return 2; - } else { - buffer[0] = code; - return 1; - } - } + cl_object byte = ecl_gethash_safe(ECL_CODE_CHAR(c), stream->stream.format_table, ECL_NIL); + if (Null(byte)) { + return encoding_error(stream, buffer, c); + } else { + cl_fixnum code = ecl_fixnum(byte); + if (code > 0xFF) { + buffer[1] = code & 0xFF; code >>= 8; + buffer[0] = code; + return 2; + } else { + buffer[0] = code; + return 1; + } + } } /* @@ -977,74 +972,74 @@ static ecl_character user_multistate_decoder(cl_object stream) { - cl_object table_list = stream->stream.format_table; - cl_object table = ECL_CONS_CAR(table_list); - cl_object character; - cl_fixnum i, j; - unsigned char buffer[ENCODING_BUFFER_MAX_SIZE]; - for (i = j = 0; i < ENCODING_BUFFER_MAX_SIZE; i++) { - if (ecl_read_byte8(stream, buffer+i, 1) < 1) { - return EOF; - } - j = (j << 8) | buffer[i]; - character = ecl_gethash_safe(ecl_make_fixnum(j), table, ECL_NIL); - if (ECL_CHARACTERP(character)) { - return ECL_CHAR_CODE(character); - } - unlikely_if (Null(character)) { - return decoding_error(stream, buffer, i); - } - if (character == ECL_T) { - /* Need more characters */ - continue; - } - if (CONSP(character)) { - /* Changed the state. */ - stream->stream.format_table = table_list = character; - table = ECL_CONS_CAR(table_list); - i = j = 0; - continue; - } - break; - } - FEerror("Internal error in decoder table.", 0); + cl_object table_list = stream->stream.format_table; + cl_object table = ECL_CONS_CAR(table_list); + cl_object character; + cl_fixnum i, j; + unsigned char buffer[ENCODING_BUFFER_MAX_SIZE]; + for (i = j = 0; i < ENCODING_BUFFER_MAX_SIZE; i++) { + if (ecl_read_byte8(stream, buffer+i, 1) < 1) { + return EOF; + } + j = (j << 8) | buffer[i]; + character = ecl_gethash_safe(ecl_make_fixnum(j), table, ECL_NIL); + if (ECL_CHARACTERP(character)) { + return ECL_CHAR_CODE(character); + } + unlikely_if (Null(character)) { + return decoding_error(stream, buffer, i); + } + if (character == ECL_T) { + /* Need more characters */ + continue; + } + if (CONSP(character)) { + /* Changed the state. */ + stream->stream.format_table = table_list = character; + table = ECL_CONS_CAR(table_list); + i = j = 0; + continue; + } + break; + } + FEerror("Internal error in decoder table.", 0); } static int user_multistate_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - cl_object table_list = stream->stream.format_table; - cl_object p = table_list; - do { - cl_object table = ECL_CONS_CAR(p); - cl_object byte = ecl_gethash_safe(ECL_CODE_CHAR(c), table, ECL_NIL); - if (!Null(byte)) { - cl_fixnum code = ecl_fixnum(byte); - ecl_character n = 0; - if (p != table_list) { - /* Must output a escape sequence */ - cl_object x = ecl_gethash_safe(ECL_T, table, ECL_NIL); - while (!Null(x)) { - buffer[0] = ecl_fixnum(ECL_CONS_CAR(x)); - buffer++; - x = ECL_CONS_CDR(x); - n++; - } - stream->stream.format_table = p; - } - if (code > 0xFF) { - buffer[1] = code & 0xFF; code >>= 8; - buffer[0] = code; - return n+2; - } else { - buffer[0] = code; - return n+1; - } - } - p = ECL_CONS_CDR(p); - } while (p != table_list); - /* Exhausted all lists */ - return encoding_error(stream, buffer, c); + cl_object table_list = stream->stream.format_table; + cl_object p = table_list; + do { + cl_object table = ECL_CONS_CAR(p); + cl_object byte = ecl_gethash_safe(ECL_CODE_CHAR(c), table, ECL_NIL); + if (!Null(byte)) { + cl_fixnum code = ecl_fixnum(byte); + ecl_character n = 0; + if (p != table_list) { + /* Must output a escape sequence */ + cl_object x = ecl_gethash_safe(ECL_T, table, ECL_NIL); + while (!Null(x)) { + buffer[0] = ecl_fixnum(ECL_CONS_CAR(x)); + buffer++; + x = ECL_CONS_CDR(x); + n++; + } + stream->stream.format_table = p; + } + if (code > 0xFF) { + buffer[1] = code & 0xFF; code >>= 8; + buffer[0] = code; + return n+2; + } else { + buffer[0] = code; + return n+1; + } + } + p = ECL_CONS_CDR(p); + } while (p != table_list); + /* Exhausted all lists */ + return encoding_error(stream, buffer, c); } /* @@ -1054,80 +1049,80 @@ static ecl_character utf_8_decoder(cl_object stream) { - /* In understanding this code: - * 0x8 = 1000, 0xC = 1100, 0xE = 1110, 0xF = 1111 - * 0x1 = 0001, 0x3 = 0011, 0x7 = 0111, 0xF = 1111 - */ - ecl_character cum = 0; - unsigned char buffer[5]; - int nbytes, i; - if (ecl_read_byte8(stream, buffer, 1) < 1) - return EOF; - if ((buffer[0] & 0x80) == 0) { - return buffer[0]; - } - unlikely_if ((buffer[0] & 0x40) == 0) - return decoding_error(stream, buffer, 1); - if ((buffer[0] & 0x20) == 0) { - cum = buffer[0] & 0x1F; - nbytes = 1; - } else if ((buffer[0] & 0x10) == 0) { - cum = buffer[0] & 0x0F; - nbytes = 2; - } else if ((buffer[0] & 0x08) == 0) { - cum = buffer[0] & 0x07; - nbytes = 3; - } else { - return decoding_error(stream, buffer, 1); - } - if (ecl_read_byte8(stream, buffer+1, nbytes) < nbytes) - return EOF; - for (i = 1; i <= nbytes; i++) { - unsigned char c = buffer[i]; - /*printf(": %04x :", c);*/ - unlikely_if ((c & 0xC0) != 0x80) - return decoding_error(stream, buffer, nbytes+1); - cum = (cum << 6) | (c & 0x3F); - unlikely_if (cum == 0) - return decoding_error(stream, buffer, nbytes+1); - } - if (cum >= 0xd800) { - unlikely_if (cum <= 0xdfff) - return decoding_error(stream, buffer, nbytes+1); - unlikely_if (cum >= 0xFFFE && cum <= 0xFFFF) - return decoding_error(stream, buffer, nbytes+1); - } - /*printf("; %04x ;", cum);*/ - return cum; + /* In understanding this code: + * 0x8 = 1000, 0xC = 1100, 0xE = 1110, 0xF = 1111 + * 0x1 = 0001, 0x3 = 0011, 0x7 = 0111, 0xF = 1111 + */ + ecl_character cum = 0; + unsigned char buffer[5]; + int nbytes, i; + if (ecl_read_byte8(stream, buffer, 1) < 1) + return EOF; + if ((buffer[0] & 0x80) == 0) { + return buffer[0]; + } + unlikely_if ((buffer[0] & 0x40) == 0) + return decoding_error(stream, buffer, 1); + if ((buffer[0] & 0x20) == 0) { + cum = buffer[0] & 0x1F; + nbytes = 1; + } else if ((buffer[0] & 0x10) == 0) { + cum = buffer[0] & 0x0F; + nbytes = 2; + } else if ((buffer[0] & 0x08) == 0) { + cum = buffer[0] & 0x07; + nbytes = 3; + } else { + return decoding_error(stream, buffer, 1); + } + if (ecl_read_byte8(stream, buffer+1, nbytes) < nbytes) + return EOF; + for (i = 1; i <= nbytes; i++) { + unsigned char c = buffer[i]; + /*printf(": %04x :", c);*/ + unlikely_if ((c & 0xC0) != 0x80) + return decoding_error(stream, buffer, nbytes+1); + cum = (cum << 6) | (c & 0x3F); + unlikely_if (cum == 0) + return decoding_error(stream, buffer, nbytes+1); + } + if (cum >= 0xd800) { + unlikely_if (cum <= 0xdfff) + return decoding_error(stream, buffer, nbytes+1); + unlikely_if (cum >= 0xFFFE && cum <= 0xFFFF) + return decoding_error(stream, buffer, nbytes+1); + } + /*printf("; %04x ;", cum);*/ + return cum; } static int utf_8_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - int nbytes; - if (c < 0) { - nbytes = 0; - } else if (c <= 0x7F) { - buffer[0] = c; - nbytes = 1; - } else if (c <= 0x7ff) { - buffer[1] = (c & 0x3f) | 0x80; c >>= 6; - buffer[0] = c | 0xC0; - /*printf("\n; %04x ;: %04x :: %04x :\n", c_orig, buffer[0], buffer[1]);*/ - nbytes = 2; - } else if (c <= 0xFFFF) { - buffer[2] = (c & 0x3f) | 0x80; c >>= 6; - buffer[1] = (c & 0x3f) | 0x80; c >>= 6; - buffer[0] = c | 0xE0; - nbytes = 3; - } else if (c <= 0x1FFFFFL) { - buffer[3] = (c & 0x3f) | 0x80; c >>= 6; - buffer[2] = (c & 0x3f) | 0x80; c >>= 6; - buffer[1] = (c & 0x3f) | 0x80; c >>= 6; - buffer[0] = c | 0xF0; - nbytes = 4; - } - return nbytes; + int nbytes; + if (c < 0) { + nbytes = 0; + } else if (c <= 0x7F) { + buffer[0] = c; + nbytes = 1; + } else if (c <= 0x7ff) { + buffer[1] = (c & 0x3f) | 0x80; c >>= 6; + buffer[0] = c | 0xC0; + /*printf("\n; %04x ;: %04x :: %04x :\n", c_orig, buffer[0], buffer[1]);*/ + nbytes = 2; + } else if (c <= 0xFFFF) { + buffer[2] = (c & 0x3f) | 0x80; c >>= 6; + buffer[1] = (c & 0x3f) | 0x80; c >>= 6; + buffer[0] = c | 0xE0; + nbytes = 3; + } else if (c <= 0x1FFFFFL) { + buffer[3] = (c & 0x3f) | 0x80; c >>= 6; + buffer[2] = (c & 0x3f) | 0x80; c >>= 6; + buffer[1] = (c & 0x3f) | 0x80; c >>= 6; + buffer[0] = c | 0xF0; + nbytes = 4; + } + return nbytes; } #endif @@ -1139,136 +1134,136 @@ static cl_index clos_stream_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - cl_index i; - for (i = 0; i < n; i++) { - cl_object byte = _ecl_funcall2(@'gray::stream-read-byte', strm); - if (!ECL_FIXNUMP(byte)) - break; - c[i] = ecl_fixnum(byte); - } - return i; + cl_index i; + for (i = 0; i < n; i++) { + cl_object byte = _ecl_funcall2(@'gray::stream-read-byte', strm); + if (!ECL_FIXNUMP(byte)) + break; + c[i] = ecl_fixnum(byte); + } + return i; } static cl_index clos_stream_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - cl_index i; - for (i = 0; i < n; i++) { - cl_object byte = _ecl_funcall3(@'gray::stream-write-byte', strm, - ecl_make_fixnum(c[i])); - if (!ECL_FIXNUMP(byte)) - break; - } - return i; + cl_index i; + for (i = 0; i < n; i++) { + cl_object byte = _ecl_funcall3(@'gray::stream-write-byte', strm, + ecl_make_fixnum(c[i])); + if (!ECL_FIXNUMP(byte)) + break; + } + return i; } static cl_object clos_stream_read_byte(cl_object strm) { - cl_object b = _ecl_funcall2(@'gray::stream-read-byte', strm); - if (b == @':eof') b = ECL_NIL; - return b; + cl_object b = _ecl_funcall2(@'gray::stream-read-byte', strm); + if (b == @':eof') b = ECL_NIL; + return b; } static void clos_stream_write_byte(cl_object c, cl_object strm) { - _ecl_funcall3(@'gray::stream-write-byte', strm, c); + _ecl_funcall3(@'gray::stream-write-byte', strm, c); } static ecl_character clos_stream_read_char(cl_object strm) { - cl_object output = _ecl_funcall2(@'gray::stream-read-char', strm); - cl_fixnum value; - if (ECL_CHARACTERP(output)) - value = ECL_CHAR_CODE(output); - else if (ECL_FIXNUMP(output)) - value = ecl_fixnum(output); - else if (output == ECL_NIL || output == @':eof') - return EOF; - else - value = -1; - unlikely_if (value < 0 || value > ECL_CHAR_CODE_LIMIT) - FEerror("Unknown character ~A", 1, output); - return value; + cl_object output = _ecl_funcall2(@'gray::stream-read-char', strm); + cl_fixnum value; + if (ECL_CHARACTERP(output)) + value = ECL_CHAR_CODE(output); + else if (ECL_FIXNUMP(output)) + value = ecl_fixnum(output); + else if (output == ECL_NIL || output == @':eof') + return EOF; + else + value = -1; + unlikely_if (value < 0 || value > ECL_CHAR_CODE_LIMIT) + FEerror("Unknown character ~A", 1, output); + return value; } static ecl_character clos_stream_write_char(cl_object strm, ecl_character c) { - _ecl_funcall3(@'gray::stream-write-char', strm, ECL_CODE_CHAR(c)); - return c; + _ecl_funcall3(@'gray::stream-write-char', strm, ECL_CODE_CHAR(c)); + return c; } static void clos_stream_unread_char(cl_object strm, ecl_character c) { - _ecl_funcall3(@'gray::stream-unread-char', strm, ECL_CODE_CHAR(c)); + _ecl_funcall3(@'gray::stream-unread-char', strm, ECL_CODE_CHAR(c)); } static int clos_stream_peek_char(cl_object strm) { - cl_object out = _ecl_funcall2(@'gray::stream-peek-char', strm); - if (out == @':eof') return EOF; - return ecl_char_code(out); + cl_object out = _ecl_funcall2(@'gray::stream-peek-char', strm); + if (out == @':eof') return EOF; + return ecl_char_code(out); } static int clos_stream_listen(cl_object strm) { - return !Null(_ecl_funcall2(@'gray::stream-listen', strm)); + return !Null(_ecl_funcall2(@'gray::stream-listen', strm)); } static void clos_stream_clear_input(cl_object strm) { - _ecl_funcall2(@'gray::stream-clear-input', strm); + _ecl_funcall2(@'gray::stream-clear-input', strm); } static void clos_stream_clear_output(cl_object strm) { - _ecl_funcall2(@'gray::stream-clear-output', strm); - return; + _ecl_funcall2(@'gray::stream-clear-output', strm); + return; } static void clos_stream_force_output(cl_object strm) { - _ecl_funcall2(@'gray::stream-force-output', strm); + _ecl_funcall2(@'gray::stream-force-output', strm); } static void clos_stream_finish_output(cl_object strm) { - _ecl_funcall2(@'gray::stream-finish-output', strm); + _ecl_funcall2(@'gray::stream-finish-output', strm); } static int clos_stream_input_p(cl_object strm) { - return !Null(_ecl_funcall2(@'gray::input-stream-p', strm)); + return !Null(_ecl_funcall2(@'gray::input-stream-p', strm)); } static int clos_stream_output_p(cl_object strm) { - return !Null(_ecl_funcall2(@'gray::output-stream-p', strm)); + return !Null(_ecl_funcall2(@'gray::output-stream-p', strm)); } static int clos_stream_interactive_p(cl_object strm) { - return !Null(_ecl_funcall2(@'gray::stream-interactive-p', strm)); + return !Null(_ecl_funcall2(@'gray::stream-interactive-p', strm)); } static cl_object clos_stream_element_type(cl_object strm) { - return _ecl_funcall2(@'gray::stream-element-type', strm); + return _ecl_funcall2(@'gray::stream-element-type', strm); } #define clos_stream_length not_a_file_stream @@ -1276,62 +1271,62 @@ static cl_object clos_stream_get_position(cl_object strm) { - return _ecl_funcall2(@'gray::stream-file-position', strm); + return _ecl_funcall2(@'gray::stream-file-position', strm); } static cl_object clos_stream_set_position(cl_object strm, cl_object pos) { - return _ecl_funcall3(@'gray::stream-file-position', strm, pos); + return _ecl_funcall3(@'gray::stream-file-position', strm, pos); } static int clos_stream_column(cl_object strm) { - cl_object col = _ecl_funcall2(@'gray::stream-line-column', strm); - /* FIXME! The Gray streams specifies NIL is a valid - * value but means "unknown". Should we make it - * zero? */ - return Null(col)? 0 : ecl_to_size(col); + cl_object col = _ecl_funcall2(@'gray::stream-line-column', strm); + /* FIXME! The Gray streams specifies NIL is a valid + * value but means "unknown". Should we make it + * zero? */ + return Null(col)? 0 : ecl_to_size(col); } static cl_object clos_stream_close(cl_object strm) { - return _ecl_funcall2(@'gray::close', strm); + return _ecl_funcall2(@'gray::close', strm); } const struct ecl_file_ops clos_stream_ops = { - clos_stream_write_byte8, - clos_stream_read_byte8, + clos_stream_write_byte8, + clos_stream_read_byte8, - clos_stream_write_byte, - clos_stream_read_byte, + clos_stream_write_byte, + clos_stream_read_byte, - clos_stream_read_char, - clos_stream_write_char, - clos_stream_unread_char, - clos_stream_peek_char, - - generic_read_vector, - generic_write_vector, - - clos_stream_listen, - clos_stream_clear_input, - clos_stream_clear_output, - clos_stream_finish_output, - clos_stream_force_output, - - clos_stream_input_p, - clos_stream_output_p, - clos_stream_interactive_p, - clos_stream_element_type, - - clos_stream_length, - clos_stream_get_position, - clos_stream_set_position, - clos_stream_column, - clos_stream_close + clos_stream_read_char, + clos_stream_write_char, + clos_stream_unread_char, + clos_stream_peek_char, + + generic_read_vector, + generic_write_vector, + + clos_stream_listen, + clos_stream_clear_input, + clos_stream_clear_output, + clos_stream_finish_output, + clos_stream_force_output, + + clos_stream_input_p, + clos_stream_output_p, + clos_stream_interactive_p, + clos_stream_element_type, + + clos_stream_length, + clos_stream_get_position, + clos_stream_set_position, + clos_stream_column, + clos_stream_close }; #endif /* ECL_CLOS_STREAMS */ @@ -1342,165 +1337,165 @@ static ecl_character str_out_write_char(cl_object strm, ecl_character c) { - int column = strm->stream.column; - if (c == '\n') - strm->stream.column = 0; - else if (c == '\t') - strm->stream.column = (column&~(cl_index)7) + 8; - else - strm->stream.column++; - ecl_string_push_extend(STRING_OUTPUT_STRING(strm), c); - return c; + int column = strm->stream.column; + if (c == '\n') + strm->stream.column = 0; + else if (c == '\t') + strm->stream.column = (column&~(cl_index)7) + 8; + else + strm->stream.column++; + ecl_string_push_extend(STRING_OUTPUT_STRING(strm), c); + return c; } static cl_object str_out_element_type(cl_object strm) { - cl_object string = STRING_OUTPUT_STRING(strm); - if (ECL_BASE_STRING_P(string)) - return @'base-char'; - return @'character'; + cl_object string = STRING_OUTPUT_STRING(strm); + if (ECL_BASE_STRING_P(string)) + return @'base-char'; + return @'character'; } static cl_object str_out_get_position(cl_object strm) { - return ecl_make_unsigned_integer(STRING_OUTPUT_STRING(strm)->base_string.fillp); + return ecl_make_unsigned_integer(STRING_OUTPUT_STRING(strm)->base_string.fillp); } static cl_object str_out_set_position(cl_object strm, cl_object pos) { - cl_object string = STRING_OUTPUT_STRING(strm); - cl_fixnum disp; - if (Null(pos)) { - disp = strm->base_string.dim; - } else { - disp = ecl_to_size(pos); - } - if (disp < string->base_string.fillp) { - string->base_string.fillp = disp; - } else { - disp -= string->base_string.fillp; - while (disp-- > 0) - ecl_write_char(' ', strm); - } - return ECL_T; + cl_object string = STRING_OUTPUT_STRING(strm); + cl_fixnum disp; + if (Null(pos)) { + disp = strm->base_string.dim; + } else { + disp = ecl_to_size(pos); + } + if (disp < string->base_string.fillp) { + string->base_string.fillp = disp; + } else { + disp -= string->base_string.fillp; + while (disp-- > 0) + ecl_write_char(' ', strm); + } + return ECL_T; } static int str_out_column(cl_object strm) { - return strm->stream.column; + return strm->stream.column; } const struct ecl_file_ops str_out_ops = { - not_output_write_byte8, - not_binary_read_byte8, + not_output_write_byte8, + not_binary_read_byte8, - not_binary_write_byte, - not_input_read_byte, + not_binary_write_byte, + not_input_read_byte, - not_input_read_char, - str_out_write_char, - not_input_unread_char, - generic_peek_char, - - generic_read_vector, - generic_write_vector, - - not_input_listen, - not_input_clear_input, - generic_void, /* clear-output */ - generic_void, /* finish-output */ - generic_void, /* force-output */ - - generic_always_false, /* input_p */ - generic_always_true, /* output_p */ - generic_always_false, - str_out_element_type, - - not_a_file_stream, /* length */ - str_out_get_position, - str_out_set_position, - str_out_column, - generic_close + not_input_read_char, + str_out_write_char, + not_input_unread_char, + generic_peek_char, + + generic_read_vector, + generic_write_vector, + + not_input_listen, + not_input_clear_input, + generic_void, /* clear-output */ + generic_void, /* finish-output */ + generic_void, /* force-output */ + + generic_always_false, /* input_p */ + generic_always_true, /* output_p */ + generic_always_false, + str_out_element_type, + + not_a_file_stream, /* length */ + str_out_get_position, + str_out_set_position, + str_out_column, + generic_close }; cl_object si_make_string_output_stream_from_string(cl_object s) { - cl_object strm = alloc_stream(); - unlikely_if (!ECL_STRINGP(s) || !ECL_ARRAY_HAS_FILL_POINTER_P(s)) - FEerror("~S is not a -string with a fill-pointer.", 1, s); - strm->stream.ops = duplicate_dispatch_table(&str_out_ops); - strm->stream.mode = (short)ecl_smm_string_output; - STRING_OUTPUT_STRING(strm) = s; - strm->stream.column = 0; + cl_object strm = alloc_stream(); + unlikely_if (!ECL_STRINGP(s) || !ECL_ARRAY_HAS_FILL_POINTER_P(s)) + FEerror("~S is not a -string with a fill-pointer.", 1, s); + strm->stream.ops = duplicate_dispatch_table(&str_out_ops); + strm->stream.mode = (short)ecl_smm_string_output; + STRING_OUTPUT_STRING(strm) = s; + strm->stream.column = 0; #if !defined(ECL_UNICODE) - strm->stream.format = @':pass-through'; - strm->stream.flags = ECL_STREAM_DEFAULT_FORMAT; - strm->stream.byte_size = 8; + strm->stream.format = @':pass-through'; + strm->stream.flags = ECL_STREAM_DEFAULT_FORMAT; + strm->stream.byte_size = 8; #else - if (ECL_BASE_STRING_P(s)) { - strm->stream.format = @':latin-1'; - strm->stream.flags = ECL_STREAM_LATIN_1; - strm->stream.byte_size = 8; - } else { - strm->stream.format = @':ucs-4'; - strm->stream.flags = ECL_STREAM_UCS_4; - strm->stream.byte_size = 32; - } + if (ECL_BASE_STRING_P(s)) { + strm->stream.format = @':latin-1'; + strm->stream.flags = ECL_STREAM_LATIN_1; + strm->stream.byte_size = 8; + } else { + strm->stream.format = @':ucs-4'; + strm->stream.flags = ECL_STREAM_UCS_4; + strm->stream.byte_size = 32; + } #endif - @(return strm) + @(return strm); } cl_object ecl_make_string_output_stream(cl_index line_length, int extended) { #ifdef ECL_UNICODE - cl_object s = extended? - ecl_alloc_adjustable_extended_string(line_length) : - ecl_alloc_adjustable_base_string(line_length); + cl_object s = extended? + ecl_alloc_adjustable_extended_string(line_length) : + ecl_alloc_adjustable_base_string(line_length); #else - cl_object s = ecl_alloc_adjustable_base_string(line_length); + cl_object s = ecl_alloc_adjustable_base_string(line_length); #endif - return si_make_string_output_stream_from_string(s); + return si_make_string_output_stream_from_string(s); } @(defun make-string-output-stream (&key (element_type @'character')) - int extended = 0; + int extended = 0; @ - if (element_type == @'base-char') { - (void)0; - } else if (element_type == @'character') { + if (element_type == @'base-char') { + (void)0; + } else if (element_type == @'character') { #ifdef ECL_UNICODE - extended = 1; + extended = 1; #endif - } else if (!Null(_ecl_funcall3(@'subtypep', element_type, @'base-char'))) { - (void)0; - } else if (!Null(_ecl_funcall3(@'subtypep', element_type, @'character'))) { + } else if (!Null(_ecl_funcall3(@'subtypep', element_type, @'base-char'))) { + (void)0; + } else if (!Null(_ecl_funcall3(@'subtypep', element_type, @'character'))) { #ifdef ECL_UNICODE - extended = 1; + extended = 1; #endif - } else { - FEerror("In MAKE-STRING-OUTPUT-STREAM, the argument :ELEMENT-TYPE (~A) must be a subtype of character", - 1, element_type); - } - @(return ecl_make_string_output_stream(128, extended)) + } else { + FEerror("In MAKE-STRING-OUTPUT-STREAM, the argument :ELEMENT-TYPE (~A) must be a subtype of character", + 1, element_type); + } + @(return ecl_make_string_output_stream(128, extended)); @) cl_object cl_get_output_stream_string(cl_object strm) { - cl_object strng; - unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_string_output)) - FEwrong_type_only_arg(@[get-output-stream-string], - strm, @[string-stream]); - strng = cl_copy_seq(STRING_OUTPUT_STRING(strm)); - STRING_OUTPUT_STRING(strm)->base_string.fillp = 0; - @(return strng) + cl_object strng; + unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_string_output)) + FEwrong_type_only_arg(@[get-output-stream-string], + strm, @[string-stream]); + strng = cl_copy_seq(STRING_OUTPUT_STRING(strm)); + STRING_OUTPUT_STRING(strm)->base_string.fillp = 0; + @(return strng); } /********************************************************************** @@ -1510,146 +1505,146 @@ static ecl_character str_in_read_char(cl_object strm) { - cl_fixnum curr_pos = STRING_INPUT_POSITION(strm); - ecl_character c; - if (curr_pos >= STRING_INPUT_LIMIT(strm)) { - c = EOF; - } else { - c = ecl_char(STRING_INPUT_STRING(strm), curr_pos); - STRING_INPUT_POSITION(strm) = curr_pos+1; - } - return c; + cl_fixnum curr_pos = STRING_INPUT_POSITION(strm); + ecl_character c; + if (curr_pos >= STRING_INPUT_LIMIT(strm)) { + c = EOF; + } else { + c = ecl_char(STRING_INPUT_STRING(strm), curr_pos); + STRING_INPUT_POSITION(strm) = curr_pos+1; + } + return c; } static void str_in_unread_char(cl_object strm, ecl_character c) { - cl_fixnum curr_pos = STRING_INPUT_POSITION(strm); - unlikely_if (c <= 0) { - unread_error(strm); - } - STRING_INPUT_POSITION(strm) = curr_pos - 1; + cl_fixnum curr_pos = STRING_INPUT_POSITION(strm); + unlikely_if (c <= 0) { + unread_error(strm); + } + STRING_INPUT_POSITION(strm) = curr_pos - 1; } static ecl_character str_in_peek_char(cl_object strm) { - cl_index pos = STRING_INPUT_POSITION(strm); - if (pos >= STRING_INPUT_LIMIT(strm)) { - return EOF; - } else { - return ecl_char(STRING_INPUT_STRING(strm), pos); - } + cl_index pos = STRING_INPUT_POSITION(strm); + if (pos >= STRING_INPUT_LIMIT(strm)) { + return EOF; + } else { + return ecl_char(STRING_INPUT_STRING(strm), pos); + } } static int str_in_listen(cl_object strm) { - if (STRING_INPUT_POSITION(strm) < STRING_INPUT_LIMIT(strm)) - return ECL_LISTEN_AVAILABLE; - else - return ECL_LISTEN_EOF; + if (STRING_INPUT_POSITION(strm) < STRING_INPUT_LIMIT(strm)) + return ECL_LISTEN_AVAILABLE; + else + return ECL_LISTEN_EOF; } static cl_object str_in_element_type(cl_object strm) { - cl_object string = STRING_INPUT_STRING(strm); - if (ECL_BASE_STRING_P(string)) - return @'base-char'; - return @'character'; + cl_object string = STRING_INPUT_STRING(strm); + if (ECL_BASE_STRING_P(string)) + return @'base-char'; + return @'character'; } static cl_object str_in_get_position(cl_object strm) { - return ecl_make_unsigned_integer(STRING_INPUT_POSITION(strm)); + return ecl_make_unsigned_integer(STRING_INPUT_POSITION(strm)); } static cl_object str_in_set_position(cl_object strm, cl_object pos) { - cl_fixnum disp; - if (Null(pos)) { - disp = STRING_INPUT_LIMIT(strm); - } else { - disp = ecl_to_size(pos); - if (disp >= STRING_INPUT_LIMIT(strm)) { - disp = STRING_INPUT_LIMIT(strm); - } - } - STRING_INPUT_POSITION(strm) = disp; - return ECL_T; + cl_fixnum disp; + if (Null(pos)) { + disp = STRING_INPUT_LIMIT(strm); + } else { + disp = ecl_to_size(pos); + if (disp >= STRING_INPUT_LIMIT(strm)) { + disp = STRING_INPUT_LIMIT(strm); + } + } + STRING_INPUT_POSITION(strm) = disp; + return ECL_T; } const struct ecl_file_ops str_in_ops = { - not_output_write_byte8, - not_binary_read_byte8, + not_output_write_byte8, + not_binary_read_byte8, - not_output_write_byte, - not_binary_read_byte, + not_output_write_byte, + not_binary_read_byte, - str_in_read_char, - not_output_write_char, - str_in_unread_char, - str_in_peek_char, - - generic_read_vector, - generic_write_vector, - - str_in_listen, - generic_void, /* clear-input */ - not_output_clear_output, - not_output_finish_output, - not_output_force_output, - - generic_always_true, /* input_p */ - generic_always_false, /* output_p */ - generic_always_false, - str_in_element_type, - - not_a_file_stream, /* length */ - str_in_get_position, - str_in_set_position, - generic_column, - generic_close + str_in_read_char, + not_output_write_char, + str_in_unread_char, + str_in_peek_char, + + generic_read_vector, + generic_write_vector, + + str_in_listen, + generic_void, /* clear-input */ + not_output_clear_output, + not_output_finish_output, + not_output_force_output, + + generic_always_true, /* input_p */ + generic_always_false, /* output_p */ + generic_always_false, + str_in_element_type, + + not_a_file_stream, /* length */ + str_in_get_position, + str_in_set_position, + generic_column, + generic_close }; cl_object ecl_make_string_input_stream(cl_object strng, cl_index istart, cl_index iend) { - cl_object strm; + cl_object strm; - strm = alloc_stream(); - strm->stream.ops = duplicate_dispatch_table(&str_in_ops); - strm->stream.mode = (short)ecl_smm_string_input; - STRING_INPUT_STRING(strm) = strng; - STRING_INPUT_POSITION(strm) = istart; - STRING_INPUT_LIMIT(strm) = iend; + strm = alloc_stream(); + strm->stream.ops = duplicate_dispatch_table(&str_in_ops); + strm->stream.mode = (short)ecl_smm_string_input; + STRING_INPUT_STRING(strm) = strng; + STRING_INPUT_POSITION(strm) = istart; + STRING_INPUT_LIMIT(strm) = iend; #if !defined(ECL_UNICODE) - strm->stream.format = @':pass-through'; - strm->stream.flags = ECL_STREAM_DEFAULT_FORMAT; - strm->stream.byte_size = 8; + strm->stream.format = @':pass-through'; + strm->stream.flags = ECL_STREAM_DEFAULT_FORMAT; + strm->stream.byte_size = 8; #else - if (ECL_BASE_STRING_P(strng) == t_base_string) { - strm->stream.format = @':latin-1'; - strm->stream.flags = ECL_STREAM_LATIN_1; - strm->stream.byte_size = 8; - } else { - strm->stream.format = @':ucs-4'; - strm->stream.flags = ECL_STREAM_UCS_4; - strm->stream.byte_size = 32; - } + if (ECL_BASE_STRING_P(strng) == t_base_string) { + strm->stream.format = @':latin-1'; + strm->stream.flags = ECL_STREAM_LATIN_1; + strm->stream.byte_size = 8; + } else { + strm->stream.format = @':ucs-4'; + strm->stream.flags = ECL_STREAM_UCS_4; + strm->stream.byte_size = 32; + } #endif - return strm; + return strm; } @(defun make_string_input_stream (strng &o (istart ecl_make_fixnum(0)) iend) - cl_index_pair p; + cl_index_pair p; @ - strng = cl_string(strng); - p = ecl_vector_start_end(@[make-string-input-stream], strng, istart, iend); - @(return (ecl_make_string_input_stream(strng, p.start, p.end))) + strng = cl_string(strng); + p = ecl_vector_start_end(@[make-string-input-stream], strng, istart, iend); + @(return (ecl_make_string_input_stream(strng, p.start, p.end))); @) /********************************************************************** @@ -1659,192 +1654,192 @@ static cl_index two_way_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - if (strm == cl_core.terminal_io) - ecl_force_output(TWO_WAY_STREAM_OUTPUT(cl_core.terminal_io)); - return ecl_read_byte8(TWO_WAY_STREAM_INPUT(strm), c, n); + if (strm == cl_core.terminal_io) + ecl_force_output(TWO_WAY_STREAM_OUTPUT(cl_core.terminal_io)); + return ecl_read_byte8(TWO_WAY_STREAM_INPUT(strm), c, n); } static cl_index two_way_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - return ecl_write_byte8(TWO_WAY_STREAM_OUTPUT(strm), c, n); + return ecl_write_byte8(TWO_WAY_STREAM_OUTPUT(strm), c, n); } static void two_way_write_byte(cl_object byte, cl_object stream) { - ecl_write_byte(byte, TWO_WAY_STREAM_OUTPUT(stream)); + ecl_write_byte(byte, TWO_WAY_STREAM_OUTPUT(stream)); } static cl_object two_way_read_byte(cl_object stream) { - return ecl_read_byte(TWO_WAY_STREAM_INPUT(stream)); + return ecl_read_byte(TWO_WAY_STREAM_INPUT(stream)); } static ecl_character two_way_read_char(cl_object strm) { - return ecl_read_char(TWO_WAY_STREAM_INPUT(strm)); + return ecl_read_char(TWO_WAY_STREAM_INPUT(strm)); } static ecl_character two_way_write_char(cl_object strm, ecl_character c) { - return ecl_write_char(c, TWO_WAY_STREAM_OUTPUT(strm)); + return ecl_write_char(c, TWO_WAY_STREAM_OUTPUT(strm)); } static void two_way_unread_char(cl_object strm, ecl_character c) { - ecl_unread_char(c, TWO_WAY_STREAM_INPUT(strm)); + ecl_unread_char(c, TWO_WAY_STREAM_INPUT(strm)); } static ecl_character two_way_peek_char(cl_object strm) { - return ecl_peek_char(TWO_WAY_STREAM_INPUT(strm)); + return ecl_peek_char(TWO_WAY_STREAM_INPUT(strm)); } static cl_index two_way_read_vector(cl_object strm, cl_object data, cl_index start, cl_index n) { - strm = TWO_WAY_STREAM_INPUT(strm); - return stream_dispatch_table(strm)->read_vector(strm, data, start, n); + strm = TWO_WAY_STREAM_INPUT(strm); + return stream_dispatch_table(strm)->read_vector(strm, data, start, n); } static cl_index two_way_write_vector(cl_object strm, cl_object data, cl_index start, cl_index n) { - strm = TWO_WAY_STREAM_OUTPUT(strm); - return stream_dispatch_table(strm)->write_vector(strm, data, start, n); + strm = TWO_WAY_STREAM_OUTPUT(strm); + return stream_dispatch_table(strm)->write_vector(strm, data, start, n); } static int two_way_listen(cl_object strm) { - return ecl_listen_stream(TWO_WAY_STREAM_INPUT(strm)); + return ecl_listen_stream(TWO_WAY_STREAM_INPUT(strm)); } static void two_way_clear_input(cl_object strm) { - ecl_clear_input(TWO_WAY_STREAM_INPUT(strm)); + ecl_clear_input(TWO_WAY_STREAM_INPUT(strm)); } static void two_way_clear_output(cl_object strm) { - ecl_clear_output(TWO_WAY_STREAM_OUTPUT(strm)); + ecl_clear_output(TWO_WAY_STREAM_OUTPUT(strm)); } static void two_way_force_output(cl_object strm) { - ecl_force_output(TWO_WAY_STREAM_OUTPUT(strm)); + ecl_force_output(TWO_WAY_STREAM_OUTPUT(strm)); } static void two_way_finish_output(cl_object strm) { - ecl_finish_output(TWO_WAY_STREAM_OUTPUT(strm)); + ecl_finish_output(TWO_WAY_STREAM_OUTPUT(strm)); } static int two_way_interactive_p(cl_object strm) { - return ecl_interactive_stream_p(TWO_WAY_STREAM_INPUT(strm)); + return ecl_interactive_stream_p(TWO_WAY_STREAM_INPUT(strm)); } static cl_object two_way_element_type(cl_object strm) { - return ecl_stream_element_type(TWO_WAY_STREAM_INPUT(strm)); + return ecl_stream_element_type(TWO_WAY_STREAM_INPUT(strm)); } static int two_way_column(cl_object strm) { - return ecl_file_column(TWO_WAY_STREAM_OUTPUT(strm)); + return ecl_file_column(TWO_WAY_STREAM_OUTPUT(strm)); } static cl_object two_way_close(cl_object strm) { - if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) { - cl_close(1, TWO_WAY_STREAM_INPUT(strm)); - cl_close(1, TWO_WAY_STREAM_OUTPUT(strm)); - } - return generic_close(strm); + if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) { + cl_close(1, TWO_WAY_STREAM_INPUT(strm)); + cl_close(1, TWO_WAY_STREAM_OUTPUT(strm)); + } + return generic_close(strm); } const struct ecl_file_ops two_way_ops = { - two_way_write_byte8, - two_way_read_byte8, + two_way_write_byte8, + two_way_read_byte8, - two_way_write_byte, - two_way_read_byte, + two_way_write_byte, + two_way_read_byte, - two_way_read_char, - two_way_write_char, - two_way_unread_char, - two_way_peek_char, - - two_way_read_vector, - two_way_write_vector, - - two_way_listen, - two_way_clear_input, - two_way_clear_output, - two_way_finish_output, - two_way_force_output, - - generic_always_true, /* input_p */ - generic_always_true, /* output_p */ - two_way_interactive_p, - two_way_element_type, - - not_a_file_stream, /* length */ - generic_always_nil, /* get_position */ - generic_set_position, - two_way_column, - two_way_close + two_way_read_char, + two_way_write_char, + two_way_unread_char, + two_way_peek_char, + + two_way_read_vector, + two_way_write_vector, + + two_way_listen, + two_way_clear_input, + two_way_clear_output, + two_way_finish_output, + two_way_force_output, + + generic_always_true, /* input_p */ + generic_always_true, /* output_p */ + two_way_interactive_p, + two_way_element_type, + + not_a_file_stream, /* length */ + generic_always_nil, /* get_position */ + generic_set_position, + two_way_column, + two_way_close }; cl_object cl_make_two_way_stream(cl_object istrm, cl_object ostrm) { - cl_object strm; - if (!ecl_input_stream_p(istrm)) - not_an_input_stream(istrm); - if (!ecl_output_stream_p(ostrm)) - not_an_output_stream(ostrm); - strm = alloc_stream(); - strm->stream.format = cl_stream_external_format(istrm); - strm->stream.mode = (short)ecl_smm_two_way; - strm->stream.ops = duplicate_dispatch_table(&two_way_ops); - TWO_WAY_STREAM_INPUT(strm) = istrm; - TWO_WAY_STREAM_OUTPUT(strm) = ostrm; - @(return strm) + cl_object strm; + if (!ecl_input_stream_p(istrm)) + not_an_input_stream(istrm); + if (!ecl_output_stream_p(ostrm)) + not_an_output_stream(ostrm); + strm = alloc_stream(); + strm->stream.format = cl_stream_external_format(istrm); + strm->stream.mode = (short)ecl_smm_two_way; + strm->stream.ops = duplicate_dispatch_table(&two_way_ops); + TWO_WAY_STREAM_INPUT(strm) = istrm; + TWO_WAY_STREAM_OUTPUT(strm) = ostrm; + @(return strm); } cl_object cl_two_way_stream_input_stream(cl_object strm) { - unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm,ecl_smm_two_way)) - FEwrong_type_only_arg(@[two-way-stream-input-stream], - strm, @[two-way-stream]); - @(return TWO_WAY_STREAM_INPUT(strm)); + unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm,ecl_smm_two_way)) + FEwrong_type_only_arg(@[two-way-stream-input-stream], + strm, @[two-way-stream]); + @(return TWO_WAY_STREAM_INPUT(strm)); } cl_object cl_two_way_stream_output_stream(cl_object strm) { - unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_two_way)) - FEwrong_type_only_arg(@[two-way-stream-output-stream], - strm, @[two-way-stream]); - @(return TWO_WAY_STREAM_OUTPUT(strm)) + unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_two_way)) + FEwrong_type_only_arg(@[two-way-stream-output-stream], + strm, @[two-way-stream]); + @(return TWO_WAY_STREAM_OUTPUT(strm)); } /********************************************************************** @@ -1854,173 +1849,173 @@ static cl_index broadcast_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - cl_object l; - cl_index out = n; - for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { - out = ecl_write_byte8(ECL_CONS_CAR(l), c, n); - } - return out; + cl_object l; + cl_index out = n; + for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { + out = ecl_write_byte8(ECL_CONS_CAR(l), c, n); + } + return out; } static ecl_character broadcast_write_char(cl_object strm, ecl_character c) { - cl_object l; - for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { - ecl_write_char(c, ECL_CONS_CAR(l)); - } - return c; + cl_object l; + for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { + ecl_write_char(c, ECL_CONS_CAR(l)); + } + return c; } static void broadcast_write_byte(cl_object c, cl_object strm) { - cl_object l; - for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { - ecl_write_byte(c, ECL_CONS_CAR(l)); - } + cl_object l; + for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { + ecl_write_byte(c, ECL_CONS_CAR(l)); + } } static void broadcast_clear_output(cl_object strm) { - cl_object l; - for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { - ecl_clear_output(ECL_CONS_CAR(l)); - } + cl_object l; + for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { + ecl_clear_output(ECL_CONS_CAR(l)); + } } static void broadcast_force_output(cl_object strm) { - cl_object l; - for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { - ecl_force_output(ECL_CONS_CAR(l)); - } + cl_object l; + for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { + ecl_force_output(ECL_CONS_CAR(l)); + } } static void broadcast_finish_output(cl_object strm) { - cl_object l; - for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { - ecl_finish_output(ECL_CONS_CAR(l)); - } + cl_object l; + for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { + ecl_finish_output(ECL_CONS_CAR(l)); + } } static cl_object broadcast_element_type(cl_object strm) { - cl_object l = BROADCAST_STREAM_LIST(strm); - if (Null(l)) - return ECL_T; - return ecl_stream_element_type(ECL_CONS_CAR(l)); + cl_object l = BROADCAST_STREAM_LIST(strm); + if (Null(l)) + return ECL_T; + return ecl_stream_element_type(ECL_CONS_CAR(l)); } static cl_object broadcast_length(cl_object strm) { - cl_object l = BROADCAST_STREAM_LIST(strm); - if (Null(l)) - return ecl_make_fixnum(0); - return ecl_file_length(ECL_CONS_CAR(l)); + cl_object l = BROADCAST_STREAM_LIST(strm); + if (Null(l)) + return ecl_make_fixnum(0); + return ecl_file_length(ECL_CONS_CAR(l)); } static cl_object broadcast_get_position(cl_object strm) { - cl_object l = BROADCAST_STREAM_LIST(strm); - if (Null(l)) - return ecl_make_fixnum(0); - return ecl_file_position(ECL_CONS_CAR(l)); + cl_object l = BROADCAST_STREAM_LIST(strm); + if (Null(l)) + return ecl_make_fixnum(0); + return ecl_file_position(ECL_CONS_CAR(l)); } static cl_object broadcast_set_position(cl_object strm, cl_object pos) { - cl_object l = BROADCAST_STREAM_LIST(strm); - if (Null(l)) - return ECL_NIL; - return ecl_file_position_set(ECL_CONS_CAR(l), pos); + cl_object l = BROADCAST_STREAM_LIST(strm); + if (Null(l)) + return ECL_NIL; + return ecl_file_position_set(ECL_CONS_CAR(l), pos); } static int broadcast_column(cl_object strm) { - cl_object l = BROADCAST_STREAM_LIST(strm); - if (Null(l)) - return 0; - return ecl_file_column(ECL_CONS_CAR(l)); + cl_object l = BROADCAST_STREAM_LIST(strm); + if (Null(l)) + return 0; + return ecl_file_column(ECL_CONS_CAR(l)); } static cl_object broadcast_close(cl_object strm) { - if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) { - cl_mapc(2, @'close', BROADCAST_STREAM_LIST(strm)); - } - return generic_close(strm); + if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) { + cl_mapc(2, @'close', BROADCAST_STREAM_LIST(strm)); + } + return generic_close(strm); } const struct ecl_file_ops broadcast_ops = { - broadcast_write_byte8, - not_input_read_byte8, + broadcast_write_byte8, + not_input_read_byte8, - broadcast_write_byte, - not_input_read_byte, + broadcast_write_byte, + not_input_read_byte, - not_input_read_char, - broadcast_write_char, - not_input_unread_char, - generic_peek_char, - - generic_read_vector, - generic_write_vector, - - not_input_listen, - broadcast_force_output, /* clear_input */ /* FIXME! This is legacy behaviour */ - broadcast_clear_output, - broadcast_finish_output, - broadcast_force_output, - - generic_always_false, /* input_p */ - generic_always_true, /* output_p */ - generic_always_false, - broadcast_element_type, - - broadcast_length, - broadcast_get_position, - broadcast_set_position, - broadcast_column, - broadcast_close + not_input_read_char, + broadcast_write_char, + not_input_unread_char, + generic_peek_char, + + generic_read_vector, + generic_write_vector, + + not_input_listen, + broadcast_force_output, /* clear_input */ /* FIXME! This is legacy behaviour */ + broadcast_clear_output, + broadcast_finish_output, + broadcast_force_output, + + generic_always_false, /* input_p */ + generic_always_true, /* output_p */ + generic_always_false, + broadcast_element_type, + + broadcast_length, + broadcast_get_position, + broadcast_set_position, + broadcast_column, + broadcast_close }; @(defun make_broadcast_stream (&rest ap) - cl_object x, streams; - int i; + cl_object x, streams; + int i; @ - streams = ECL_NIL; - for (i = 0; i < narg; i++) { - x = ecl_va_arg(ap); - unlikely_if (!ecl_output_stream_p(x)) - not_an_output_stream(x); - streams = CONS(x, streams); - } - x = alloc_stream(); - x->stream.format = @':default'; - x->stream.ops = duplicate_dispatch_table(&broadcast_ops); - x->stream.mode = (short)ecl_smm_broadcast; - BROADCAST_STREAM_LIST(x) = cl_nreverse(streams); - @(return x) + streams = ECL_NIL; + for (i = 0; i < narg; i++) { + x = ecl_va_arg(ap); + unlikely_if (!ecl_output_stream_p(x)) + not_an_output_stream(x); + streams = CONS(x, streams); + } + x = alloc_stream(); + x->stream.format = @':default'; + x->stream.ops = duplicate_dispatch_table(&broadcast_ops); + x->stream.mode = (short)ecl_smm_broadcast; + BROADCAST_STREAM_LIST(x) = cl_nreverse(streams); + @(return x); @) cl_object cl_broadcast_stream_streams(cl_object strm) { - unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_broadcast)) - FEwrong_type_only_arg(@[broadcast-stream-streams], - strm, @[broadcast-stream]); - return cl_copy_list(BROADCAST_STREAM_LIST(strm)); + unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_broadcast)) + FEwrong_type_only_arg(@[broadcast-stream-streams], + strm, @[broadcast-stream]); + return cl_copy_list(BROADCAST_STREAM_LIST(strm)); } /********************************************************************** @@ -2030,189 +2025,189 @@ static cl_index echo_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - cl_index out = ecl_read_byte8(ECHO_STREAM_INPUT(strm), c, n); - return ecl_write_byte8(ECHO_STREAM_OUTPUT(strm), c, out); + cl_index out = ecl_read_byte8(ECHO_STREAM_INPUT(strm), c, n); + return ecl_write_byte8(ECHO_STREAM_OUTPUT(strm), c, out); } static cl_index echo_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - return ecl_write_byte8(ECHO_STREAM_OUTPUT(strm), c, n); + return ecl_write_byte8(ECHO_STREAM_OUTPUT(strm), c, n); } static void echo_write_byte(cl_object c, cl_object strm) { - ecl_write_byte(c, ECHO_STREAM_OUTPUT(strm)); + ecl_write_byte(c, ECHO_STREAM_OUTPUT(strm)); } static cl_object echo_read_byte(cl_object strm) { - cl_object out = ecl_read_byte(ECHO_STREAM_INPUT(strm)); - if (!Null(out)) ecl_write_byte(out, ECHO_STREAM_OUTPUT(strm)); - return out; + cl_object out = ecl_read_byte(ECHO_STREAM_INPUT(strm)); + if (!Null(out)) ecl_write_byte(out, ECHO_STREAM_OUTPUT(strm)); + return out; } static ecl_character echo_read_char(cl_object strm) { - ecl_character c = strm->stream.last_code[0]; - if (c == EOF) { - c = ecl_read_char(ECHO_STREAM_INPUT(strm)); - if (c != EOF) - ecl_write_char(c, ECHO_STREAM_OUTPUT(strm)); - } else { - strm->stream.last_code[0] = EOF; - ecl_read_char(ECHO_STREAM_INPUT(strm)); - } - return c; + ecl_character c = strm->stream.last_code[0]; + if (c == EOF) { + c = ecl_read_char(ECHO_STREAM_INPUT(strm)); + if (c != EOF) + ecl_write_char(c, ECHO_STREAM_OUTPUT(strm)); + } else { + strm->stream.last_code[0] = EOF; + ecl_read_char(ECHO_STREAM_INPUT(strm)); + } + return c; } static ecl_character echo_write_char(cl_object strm, ecl_character c) { - return ecl_write_char(c, ECHO_STREAM_OUTPUT(strm)); + return ecl_write_char(c, ECHO_STREAM_OUTPUT(strm)); } static void echo_unread_char(cl_object strm, ecl_character c) { - unlikely_if (strm->stream.last_code[0] != EOF) { - unread_twice(strm); - } - strm->stream.last_code[0] = c; - ecl_unread_char(c, ECHO_STREAM_INPUT(strm)); + unlikely_if (strm->stream.last_code[0] != EOF) { + unread_twice(strm); + } + strm->stream.last_code[0] = c; + ecl_unread_char(c, ECHO_STREAM_INPUT(strm)); } static ecl_character echo_peek_char(cl_object strm) { - ecl_character c = strm->stream.last_code[0]; - if (c == EOF) { - c = ecl_peek_char(ECHO_STREAM_INPUT(strm)); - } - return c; + ecl_character c = strm->stream.last_code[0]; + if (c == EOF) { + c = ecl_peek_char(ECHO_STREAM_INPUT(strm)); + } + return c; } static int echo_listen(cl_object strm) { - return ecl_listen_stream(ECHO_STREAM_INPUT(strm)); + return ecl_listen_stream(ECHO_STREAM_INPUT(strm)); } static void echo_clear_input(cl_object strm) { - ecl_clear_input(ECHO_STREAM_INPUT(strm)); + ecl_clear_input(ECHO_STREAM_INPUT(strm)); } static void echo_clear_output(cl_object strm) { - ecl_clear_output(ECHO_STREAM_OUTPUT(strm)); + ecl_clear_output(ECHO_STREAM_OUTPUT(strm)); } static void echo_force_output(cl_object strm) { - ecl_force_output(ECHO_STREAM_OUTPUT(strm)); + ecl_force_output(ECHO_STREAM_OUTPUT(strm)); } static void echo_finish_output(cl_object strm) { - ecl_finish_output(ECHO_STREAM_OUTPUT(strm)); + ecl_finish_output(ECHO_STREAM_OUTPUT(strm)); } static cl_object echo_element_type(cl_object strm) { - return ecl_stream_element_type(ECHO_STREAM_INPUT(strm)); + return ecl_stream_element_type(ECHO_STREAM_INPUT(strm)); } static int echo_column(cl_object strm) { - return ecl_file_column(ECHO_STREAM_OUTPUT(strm)); + return ecl_file_column(ECHO_STREAM_OUTPUT(strm)); } static cl_object echo_close(cl_object strm) { - if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) { - cl_close(1, ECHO_STREAM_INPUT(strm)); - cl_close(1, ECHO_STREAM_OUTPUT(strm)); - } - return generic_close(strm); + if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) { + cl_close(1, ECHO_STREAM_INPUT(strm)); + cl_close(1, ECHO_STREAM_OUTPUT(strm)); + } + return generic_close(strm); } const struct ecl_file_ops echo_ops = { - echo_write_byte8, - echo_read_byte8, + echo_write_byte8, + echo_read_byte8, - echo_write_byte, - echo_read_byte, + echo_write_byte, + echo_read_byte, - echo_read_char, - echo_write_char, - echo_unread_char, - echo_peek_char, - - generic_read_vector, - generic_write_vector, - - echo_listen, - echo_clear_input, - echo_clear_output, - echo_finish_output, - echo_force_output, - - generic_always_true, /* input_p */ - generic_always_true, /* output_p */ - generic_always_false, - echo_element_type, - - not_a_file_stream, /* length */ - generic_always_nil, /* get_position */ - generic_set_position, - echo_column, - echo_close + echo_read_char, + echo_write_char, + echo_unread_char, + echo_peek_char, + + generic_read_vector, + generic_write_vector, + + echo_listen, + echo_clear_input, + echo_clear_output, + echo_finish_output, + echo_force_output, + + generic_always_true, /* input_p */ + generic_always_true, /* output_p */ + generic_always_false, + echo_element_type, + + not_a_file_stream, /* length */ + generic_always_nil, /* get_position */ + generic_set_position, + echo_column, + echo_close }; cl_object cl_make_echo_stream(cl_object strm1, cl_object strm2) { - cl_object strm; - unlikely_if (!ecl_input_stream_p(strm1)) - not_an_input_stream(strm1); - unlikely_if (!ecl_output_stream_p(strm2)) - not_an_output_stream(strm2); - strm = alloc_stream(); - strm->stream.format = cl_stream_external_format(strm1); - strm->stream.mode = (short)ecl_smm_echo; - strm->stream.ops = duplicate_dispatch_table(&echo_ops); - ECHO_STREAM_INPUT(strm) = strm1; - ECHO_STREAM_OUTPUT(strm) = strm2; - @(return strm) + cl_object strm; + unlikely_if (!ecl_input_stream_p(strm1)) + not_an_input_stream(strm1); + unlikely_if (!ecl_output_stream_p(strm2)) + not_an_output_stream(strm2); + strm = alloc_stream(); + strm->stream.format = cl_stream_external_format(strm1); + strm->stream.mode = (short)ecl_smm_echo; + strm->stream.ops = duplicate_dispatch_table(&echo_ops); + ECHO_STREAM_INPUT(strm) = strm1; + ECHO_STREAM_OUTPUT(strm) = strm2; + @(return strm); } cl_object cl_echo_stream_input_stream(cl_object strm) { - unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_echo)) - FEwrong_type_only_arg(@[echo-stream-input-stream], - strm, @[echo-stream]); - @(return ECHO_STREAM_INPUT(strm)) + unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_echo)) + FEwrong_type_only_arg(@[echo-stream-input-stream], + strm, @[echo-stream]); + @(return ECHO_STREAM_INPUT(strm)); } cl_object cl_echo_stream_output_stream(cl_object strm) { - unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_echo)) - FEwrong_type_only_arg(@[echo-stream-output-stream], - strm, @[echo-stream]); - @(return ECHO_STREAM_OUTPUT(strm)) + unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_echo)) + FEwrong_type_only_arg(@[echo-stream-output-stream], + strm, @[echo-stream]); + @(return ECHO_STREAM_OUTPUT(strm)); } /********************************************************************** @@ -2222,140 +2217,140 @@ static cl_index concatenated_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - cl_object l = CONCATENATED_STREAM_LIST(strm); - cl_index out = 0; - while (out < n && !Null(l)) { - cl_index delta = ecl_read_byte8(ECL_CONS_CAR(l), c + out, n - out); - out += delta; - if (out == n) break; - CONCATENATED_STREAM_LIST(strm) = l = ECL_CONS_CDR(l); - } - return out; + cl_object l = CONCATENATED_STREAM_LIST(strm); + cl_index out = 0; + while (out < n && !Null(l)) { + cl_index delta = ecl_read_byte8(ECL_CONS_CAR(l), c + out, n - out); + out += delta; + if (out == n) break; + CONCATENATED_STREAM_LIST(strm) = l = ECL_CONS_CDR(l); + } + return out; } static cl_object concatenated_read_byte(cl_object strm) { - cl_object l = CONCATENATED_STREAM_LIST(strm); - cl_object c = ECL_NIL; - while (!Null(l)) { - c = ecl_read_byte(ECL_CONS_CAR(l)); - if (c != ECL_NIL) break; - CONCATENATED_STREAM_LIST(strm) = l = ECL_CONS_CDR(l); - } - return c; + cl_object l = CONCATENATED_STREAM_LIST(strm); + cl_object c = ECL_NIL; + while (!Null(l)) { + c = ecl_read_byte(ECL_CONS_CAR(l)); + if (c != ECL_NIL) break; + CONCATENATED_STREAM_LIST(strm) = l = ECL_CONS_CDR(l); + } + return c; } static ecl_character concatenated_read_char(cl_object strm) { - cl_object l = CONCATENATED_STREAM_LIST(strm); - ecl_character c = EOF; - while (!Null(l)) { - c = ecl_read_char(ECL_CONS_CAR(l)); - if (c != EOF) break; - CONCATENATED_STREAM_LIST(strm) = l = ECL_CONS_CDR(l); - } - return c; + cl_object l = CONCATENATED_STREAM_LIST(strm); + ecl_character c = EOF; + while (!Null(l)) { + c = ecl_read_char(ECL_CONS_CAR(l)); + if (c != EOF) break; + CONCATENATED_STREAM_LIST(strm) = l = ECL_CONS_CDR(l); + } + return c; } static void concatenated_unread_char(cl_object strm, ecl_character c) { - cl_object l = CONCATENATED_STREAM_LIST(strm); - unlikely_if (Null(l)) - unread_error(strm); - ecl_unread_char(c, ECL_CONS_CAR(l)); + cl_object l = CONCATENATED_STREAM_LIST(strm); + unlikely_if (Null(l)) + unread_error(strm); + ecl_unread_char(c, ECL_CONS_CAR(l)); } static int concatenated_listen(cl_object strm) { - cl_object l = CONCATENATED_STREAM_LIST(strm); - while (!Null(l)) { - int f = ecl_listen_stream(ECL_CONS_CAR(l)); - l = ECL_CONS_CDR(l); - if (f == ECL_LISTEN_EOF) { - CONCATENATED_STREAM_LIST(strm) = l; - } else { - return f; - } - } - return ECL_LISTEN_EOF; + cl_object l = CONCATENATED_STREAM_LIST(strm); + while (!Null(l)) { + int f = ecl_listen_stream(ECL_CONS_CAR(l)); + l = ECL_CONS_CDR(l); + if (f == ECL_LISTEN_EOF) { + CONCATENATED_STREAM_LIST(strm) = l; + } else { + return f; + } + } + return ECL_LISTEN_EOF; } static cl_object concatenated_close(cl_object strm) { - if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) { - cl_mapc(2, @'close', CONCATENATED_STREAM_LIST(strm)); - } - return generic_close(strm); + if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) { + cl_mapc(2, @'close', CONCATENATED_STREAM_LIST(strm)); + } + return generic_close(strm); } const struct ecl_file_ops concatenated_ops = { - not_output_write_byte8, - concatenated_read_byte8, + not_output_write_byte8, + concatenated_read_byte8, - not_output_write_byte, - concatenated_read_byte, + not_output_write_byte, + concatenated_read_byte, - concatenated_read_char, - not_output_write_char, - concatenated_unread_char, - generic_peek_char, - - generic_read_vector, - generic_write_vector, - - concatenated_listen, - generic_void, /* clear_input */ - not_output_clear_output, - not_output_finish_output, - not_output_force_output, - - generic_always_true, /* input_p */ - generic_always_false, /* output_p */ - generic_always_false, - broadcast_element_type, - - not_a_file_stream, /* length */ - generic_always_nil, /* get_position */ - generic_set_position, - generic_column, - concatenated_close + concatenated_read_char, + not_output_write_char, + concatenated_unread_char, + generic_peek_char, + + generic_read_vector, + generic_write_vector, + + concatenated_listen, + generic_void, /* clear_input */ + not_output_clear_output, + not_output_finish_output, + not_output_force_output, + + generic_always_true, /* input_p */ + generic_always_false, /* output_p */ + generic_always_false, + broadcast_element_type, + + not_a_file_stream, /* length */ + generic_always_nil, /* get_position */ + generic_set_position, + generic_column, + concatenated_close }; @(defun make_concatenated_stream (&rest ap) - cl_object x, streams; - int i; + cl_object x, streams; + int i; @ - streams = ECL_NIL; - for (i = 0; i < narg; i++) { - x = ecl_va_arg(ap); - unlikely_if (!ecl_input_stream_p(x)) - not_an_input_stream(x); - streams = CONS(x, streams); - } - x = alloc_stream(); - if (Null(streams)) { - x->stream.format = @':pass-through'; - } else { - x->stream.format = cl_stream_external_format(ECL_CONS_CAR(streams)); - } - x->stream.mode = (short)ecl_smm_concatenated; - x->stream.ops = duplicate_dispatch_table(&concatenated_ops); - CONCATENATED_STREAM_LIST(x) = cl_nreverse(streams); - @(return x) + streams = ECL_NIL; + for (i = 0; i < narg; i++) { + x = ecl_va_arg(ap); + unlikely_if (!ecl_input_stream_p(x)) + not_an_input_stream(x); + streams = CONS(x, streams); + } + x = alloc_stream(); + if (Null(streams)) { + x->stream.format = @':pass-through'; + } else { + x->stream.format = cl_stream_external_format(ECL_CONS_CAR(streams)); + } + x->stream.mode = (short)ecl_smm_concatenated; + x->stream.ops = duplicate_dispatch_table(&concatenated_ops); + CONCATENATED_STREAM_LIST(x) = cl_nreverse(streams); + @(return x); @) cl_object cl_concatenated_stream_streams(cl_object strm) { - unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_concatenated)) - FEwrong_type_only_arg(@[concatenated-stream-streams], - strm, @[concatenated-stream]); - return cl_copy_list(CONCATENATED_STREAM_LIST(strm)); + unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_concatenated)) + FEwrong_type_only_arg(@[concatenated-stream-streams], + strm, @[concatenated-stream]); + return cl_copy_list(CONCATENATED_STREAM_LIST(strm)); } /********************************************************************** @@ -2365,196 +2360,196 @@ static cl_index synonym_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - return ecl_read_byte8(SYNONYM_STREAM_STREAM(strm), c, n); + return ecl_read_byte8(SYNONYM_STREAM_STREAM(strm), c, n); } static cl_index synonym_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - return ecl_write_byte8(SYNONYM_STREAM_STREAM(strm), c, n); + return ecl_write_byte8(SYNONYM_STREAM_STREAM(strm), c, n); } static void synonym_write_byte(cl_object c, cl_object strm) { - ecl_write_byte(c, SYNONYM_STREAM_STREAM(strm)); + ecl_write_byte(c, SYNONYM_STREAM_STREAM(strm)); } static cl_object synonym_read_byte(cl_object strm) { - return ecl_read_byte(SYNONYM_STREAM_STREAM(strm)); + return ecl_read_byte(SYNONYM_STREAM_STREAM(strm)); } static ecl_character synonym_read_char(cl_object strm) { - return ecl_read_char(SYNONYM_STREAM_STREAM(strm)); + return ecl_read_char(SYNONYM_STREAM_STREAM(strm)); } static ecl_character synonym_write_char(cl_object strm, ecl_character c) { - return ecl_write_char(c, SYNONYM_STREAM_STREAM(strm)); + return ecl_write_char(c, SYNONYM_STREAM_STREAM(strm)); } static void synonym_unread_char(cl_object strm, ecl_character c) { - ecl_unread_char(c, SYNONYM_STREAM_STREAM(strm)); + ecl_unread_char(c, SYNONYM_STREAM_STREAM(strm)); } static ecl_character synonym_peek_char(cl_object strm) { - return ecl_peek_char(SYNONYM_STREAM_STREAM(strm)); + return ecl_peek_char(SYNONYM_STREAM_STREAM(strm)); } static cl_index synonym_read_vector(cl_object strm, cl_object data, cl_index start, cl_index n) { - strm = SYNONYM_STREAM_STREAM(strm); - return stream_dispatch_table(strm)->read_vector(strm, data, start, n); + strm = SYNONYM_STREAM_STREAM(strm); + return stream_dispatch_table(strm)->read_vector(strm, data, start, n); } static cl_index synonym_write_vector(cl_object strm, cl_object data, cl_index start, cl_index n) { - strm = SYNONYM_STREAM_STREAM(strm); - return stream_dispatch_table(strm)->write_vector(strm, data, start, n); + strm = SYNONYM_STREAM_STREAM(strm); + return stream_dispatch_table(strm)->write_vector(strm, data, start, n); } static int synonym_listen(cl_object strm) { - return ecl_listen_stream(SYNONYM_STREAM_STREAM(strm)); + return ecl_listen_stream(SYNONYM_STREAM_STREAM(strm)); } static void synonym_clear_input(cl_object strm) { - ecl_clear_input(SYNONYM_STREAM_STREAM(strm)); + ecl_clear_input(SYNONYM_STREAM_STREAM(strm)); } static void synonym_clear_output(cl_object strm) { - ecl_clear_output(SYNONYM_STREAM_STREAM(strm)); + ecl_clear_output(SYNONYM_STREAM_STREAM(strm)); } static void synonym_force_output(cl_object strm) { - ecl_force_output(SYNONYM_STREAM_STREAM(strm)); + ecl_force_output(SYNONYM_STREAM_STREAM(strm)); } static void synonym_finish_output(cl_object strm) { - ecl_finish_output(SYNONYM_STREAM_STREAM(strm)); + ecl_finish_output(SYNONYM_STREAM_STREAM(strm)); } static int synonym_input_p(cl_object strm) { - return ecl_input_stream_p(SYNONYM_STREAM_STREAM(strm)); + return ecl_input_stream_p(SYNONYM_STREAM_STREAM(strm)); } static int synonym_output_p(cl_object strm) { - return ecl_output_stream_p(SYNONYM_STREAM_STREAM(strm)); + return ecl_output_stream_p(SYNONYM_STREAM_STREAM(strm)); } static int synonym_interactive_p(cl_object strm) { - return ecl_interactive_stream_p(SYNONYM_STREAM_STREAM(strm)); + return ecl_interactive_stream_p(SYNONYM_STREAM_STREAM(strm)); } static cl_object synonym_element_type(cl_object strm) { - return ecl_stream_element_type(SYNONYM_STREAM_STREAM(strm)); + return ecl_stream_element_type(SYNONYM_STREAM_STREAM(strm)); } static cl_object synonym_length(cl_object strm) { - return ecl_file_length(SYNONYM_STREAM_STREAM(strm)); + return ecl_file_length(SYNONYM_STREAM_STREAM(strm)); } static cl_object synonym_get_position(cl_object strm) { - return ecl_file_position(SYNONYM_STREAM_STREAM(strm)); + return ecl_file_position(SYNONYM_STREAM_STREAM(strm)); } static cl_object synonym_set_position(cl_object strm, cl_object pos) { - return ecl_file_position_set(SYNONYM_STREAM_STREAM(strm), pos); + return ecl_file_position_set(SYNONYM_STREAM_STREAM(strm), pos); } static int synonym_column(cl_object strm) { - return ecl_file_column(SYNONYM_STREAM_STREAM(strm)); + return ecl_file_column(SYNONYM_STREAM_STREAM(strm)); } const struct ecl_file_ops synonym_ops = { - synonym_write_byte8, - synonym_read_byte8, + synonym_write_byte8, + synonym_read_byte8, - synonym_write_byte, - synonym_read_byte, + synonym_write_byte, + synonym_read_byte, - synonym_read_char, - synonym_write_char, - synonym_unread_char, - synonym_peek_char, - - synonym_read_vector, - synonym_write_vector, - - synonym_listen, - synonym_clear_input, - synonym_clear_output, - synonym_finish_output, - synonym_force_output, - - synonym_input_p, - synonym_output_p, - synonym_interactive_p, - synonym_element_type, - - synonym_length, - synonym_get_position, - synonym_set_position, - synonym_column, - generic_close + synonym_read_char, + synonym_write_char, + synonym_unread_char, + synonym_peek_char, + + synonym_read_vector, + synonym_write_vector, + + synonym_listen, + synonym_clear_input, + synonym_clear_output, + synonym_finish_output, + synonym_force_output, + + synonym_input_p, + synonym_output_p, + synonym_interactive_p, + synonym_element_type, + + synonym_length, + synonym_get_position, + synonym_set_position, + synonym_column, + generic_close }; cl_object cl_make_synonym_stream(cl_object sym) { - cl_object x; + cl_object x; - sym = ecl_check_cl_type(@'make-synonym-stream',sym,t_symbol); - x = alloc_stream(); - x->stream.ops = duplicate_dispatch_table(&synonym_ops); - x->stream.mode = (short)ecl_smm_synonym; - SYNONYM_STREAM_SYMBOL(x) = sym; - @(return x) + sym = ecl_check_cl_type(@'make-synonym-stream',sym,t_symbol); + x = alloc_stream(); + x->stream.ops = duplicate_dispatch_table(&synonym_ops); + x->stream.mode = (short)ecl_smm_synonym; + SYNONYM_STREAM_SYMBOL(x) = sym; + @(return x); } cl_object cl_synonym_stream_symbol(cl_object strm) { - unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_synonym)) - FEwrong_type_only_arg(@[synonym-stream-symbol], - strm, @[synonym-stream]); - @(return SYNONYM_STREAM_SYMBOL(strm)) + unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_synonym)) + FEwrong_type_only_arg(@[synonym-stream-symbol], + strm, @[synonym-stream]); + @(return SYNONYM_STREAM_SYMBOL(strm)); } /********************************************************************** @@ -2570,56 +2565,58 @@ static int safe_open(const char *filename, int flags, ecl_mode_t mode) { - const cl_env_ptr the_env = ecl_process_env(); - int output; - ecl_disable_interrupts_env(the_env); - output = open(filename, flags, mode); - ecl_enable_interrupts_env(the_env); - return output; + const cl_env_ptr the_env = ecl_process_env(); + int output; + ecl_disable_interrupts_env(the_env); + output = open(filename, flags, mode); + ecl_enable_interrupts_env(the_env); + return output; } static int safe_close(int f) { - const cl_env_ptr the_env = ecl_process_env(); - int output; - ecl_disable_interrupts_env(the_env); - output = close(f); - ecl_enable_interrupts_env(the_env); - return output; + const cl_env_ptr the_env = ecl_process_env(); + int output; + ecl_disable_interrupts_env(the_env); + output = close(f); + ecl_enable_interrupts_env(the_env); + return output; } static FILE * safe_fopen(const char *filename, const char *mode) { - const cl_env_ptr the_env = ecl_process_env(); - FILE *output; - ecl_disable_interrupts_env(the_env); - output = fopen(filename, mode); - ecl_enable_interrupts_env(the_env); - return output; + const cl_env_ptr the_env = ecl_process_env(); + FILE *output; + ecl_disable_interrupts_env(the_env); + output = fopen(filename, mode); + ecl_enable_interrupts_env(the_env); + return output; } static FILE * safe_fdopen(int fildes, const char *mode) { - const cl_env_ptr the_env = ecl_process_env(); - FILE *output; - ecl_disable_interrupts_env(the_env); - output = fdopen(fildes, mode); - ecl_enable_interrupts_env(the_env); - return output; + const cl_env_ptr the_env = ecl_process_env(); + FILE *output; + ecl_disable_interrupts_env(the_env); + output = fdopen(fildes, mode); + ecl_enable_interrupts_env(the_env); + return output; } static int safe_fclose(FILE *stream) { - const cl_env_ptr the_env = ecl_process_env(); - int output; - ecl_disable_interrupts_env(the_env); - output = fclose(stream); - ecl_enable_interrupts_env(the_env); - return output; + const cl_env_ptr the_env = ecl_process_env(); + int output; + /* If someone have closed our fd, do nothing. See #267. */ + unlikely_if (fileno(stream) == -1) return 0; + ecl_disable_interrupts_env(the_env); + output = fclose(stream); + ecl_enable_interrupts_env(the_env); + return output; } /********************************************************************** @@ -2629,96 +2626,96 @@ static cl_index consume_byte_stack(cl_object strm, unsigned char *c, cl_index n) { - cl_index out = 0; - while (n) { - cl_object l = strm->stream.byte_stack; - if (l == ECL_NIL) - return out + strm->stream.ops->read_byte8(strm, c, n); - *(c++) = ecl_fixnum(ECL_CONS_CAR(l)); - out++; - n--; - strm->stream.byte_stack = l = ECL_CONS_CDR(l); - } - return out; + cl_index out = 0; + while (n) { + cl_object l = strm->stream.byte_stack; + if (l == ECL_NIL) + return out + strm->stream.ops->read_byte8(strm, c, n); + *(c++) = ecl_fixnum(ECL_CONS_CAR(l)); + out++; + n--; + strm->stream.byte_stack = l = ECL_CONS_CDR(l); + } + return out; } static cl_index io_file_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - unlikely_if (strm->stream.byte_stack != ECL_NIL) { - return consume_byte_stack(strm, c, n); - } else { - int f = IO_FILE_DESCRIPTOR(strm); - cl_fixnum out = 0; - ecl_disable_interrupts(); - do { - out = read(f, c, sizeof(char)*n); - } while (out < 0 && restartable_io_error(strm, "read")); - ecl_enable_interrupts(); - return out; - } + unlikely_if (strm->stream.byte_stack != ECL_NIL) { + return consume_byte_stack(strm, c, n); + } else { + int f = IO_FILE_DESCRIPTOR(strm); + cl_fixnum out = 0; + ecl_disable_interrupts(); + do { + out = read(f, c, sizeof(char)*n); + } while (out < 0 && restartable_io_error(strm, "read")); + ecl_enable_interrupts(); + return out; + } } static cl_index output_file_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - int f = IO_FILE_DESCRIPTOR(strm); - cl_fixnum out; - ecl_disable_interrupts(); - do { - out = write(f, c, sizeof(char)*n); - } while (out < 0 && restartable_io_error(strm, "write")); - ecl_enable_interrupts(); - return out; + int f = IO_FILE_DESCRIPTOR(strm); + cl_fixnum out; + ecl_disable_interrupts(); + do { + out = write(f, c, sizeof(char)*n); + } while (out < 0 && restartable_io_error(strm, "write")); + ecl_enable_interrupts(); + return out; } static cl_index io_file_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - unlikely_if (strm->stream.byte_stack != ECL_NIL) { - /* Try to move to the beginning of the unread characters */ - cl_object aux = ecl_file_position(strm); - if (!Null(aux)) - ecl_file_position_set(strm, aux); - strm->stream.byte_stack = ECL_NIL; - } - return output_file_write_byte8(strm, c, n); + unlikely_if (strm->stream.byte_stack != ECL_NIL) { + /* Try to move to the beginning of the unread characters */ + cl_object aux = ecl_file_position(strm); + if (!Null(aux)) + ecl_file_position_set(strm, aux); + strm->stream.byte_stack = ECL_NIL; + } + return output_file_write_byte8(strm, c, n); } static int io_file_listen(cl_object strm) { - if (strm->stream.byte_stack != ECL_NIL) - return ECL_LISTEN_AVAILABLE; - if (strm->stream.flags & ECL_STREAM_MIGHT_SEEK) { - cl_env_ptr the_env = ecl_process_env(); - int f = IO_FILE_DESCRIPTOR(strm); - ecl_off_t disp, new; - ecl_disable_interrupts_env(the_env); - disp = lseek(f, 0, SEEK_CUR); - ecl_enable_interrupts_env(the_env); - if (disp != (ecl_off_t)-1) { - ecl_disable_interrupts_env(the_env); - new = lseek(f, 0, SEEK_END); - ecl_enable_interrupts_env(the_env); - lseek(f, disp, SEEK_SET); - if (new == disp) { - return ECL_LISTEN_NO_CHAR; - } else if (new != (ecl_off_t)-1) { - return ECL_LISTEN_AVAILABLE; - } - } - } - return file_listen(strm, IO_FILE_DESCRIPTOR(strm)); + if (strm->stream.byte_stack != ECL_NIL) + return ECL_LISTEN_AVAILABLE; + if (strm->stream.flags & ECL_STREAM_MIGHT_SEEK) { + cl_env_ptr the_env = ecl_process_env(); + int f = IO_FILE_DESCRIPTOR(strm); + ecl_off_t disp, new; + ecl_disable_interrupts_env(the_env); + disp = lseek(f, 0, SEEK_CUR); + ecl_enable_interrupts_env(the_env); + if (disp != (ecl_off_t)-1) { + ecl_disable_interrupts_env(the_env); + new = lseek(f, 0, SEEK_END); + ecl_enable_interrupts_env(the_env); + lseek(f, disp, SEEK_SET); + if (new == disp) { + return ECL_LISTEN_NO_CHAR; + } else if (new != (ecl_off_t)-1) { + return ECL_LISTEN_AVAILABLE; + } + } + } + return file_listen(strm, IO_FILE_DESCRIPTOR(strm)); } #if defined(ECL_MS_WINDOWS_HOST) static int isaconsole(int i) { - HANDLE h = (HANDLE)_get_osfhandle(i); - DWORD mode; - return !!GetConsoleMode(h, &mode); + HANDLE h = (HANDLE)_get_osfhandle(i); + DWORD mode; + return !!GetConsoleMode(h, &mode); } #define isatty isaconsole #endif @@ -2726,19 +2723,19 @@ static void io_file_clear_input(cl_object strm) { - int f = IO_FILE_DESCRIPTOR(strm); + int f = IO_FILE_DESCRIPTOR(strm); #if defined(ECL_MS_WINDOWS_HOST) - if (isatty(f)) { - /* Flushes Win32 console */ - if (!FlushConsoleInputBuffer((HANDLE)_get_osfhandle(f))) - FEwin32_error("FlushConsoleInputBuffer() failed", 0); - /* Do not stop here: the FILE structure needs also to be flushed */ - } -#endif - while (file_listen(strm, f) == ECL_LISTEN_AVAILABLE) { - ecl_character c = eformat_read_char(strm); - if (c == EOF) return; - } + if (isatty(f)) { + /* Flushes Win32 console */ + if (!FlushConsoleInputBuffer((HANDLE)_get_osfhandle(f))) + FEwin32_error("FlushConsoleInputBuffer() failed", 0); + /* Do not stop here: the FILE structure needs also to be flushed */ + } +#endif + while (file_listen(strm, f) == ECL_LISTEN_AVAILABLE) { + ecl_character c = eformat_read_char(strm); + if (c == EOF) return; + } } #define io_file_clear_output generic_void @@ -2748,573 +2745,573 @@ static int io_file_interactive_p(cl_object strm) { - int f = IO_FILE_DESCRIPTOR(strm); - return isatty(f); + int f = IO_FILE_DESCRIPTOR(strm); + return isatty(f); } static cl_object io_file_element_type(cl_object strm) { - return IO_FILE_ELT_TYPE(strm); + return IO_FILE_ELT_TYPE(strm); } static cl_object io_file_length(cl_object strm) { - int f = IO_FILE_DESCRIPTOR(strm); - cl_object output = ecl_file_len(f); - if (strm->stream.byte_size != 8) { - const cl_env_ptr the_env = ecl_process_env(); - cl_index bs = strm->stream.byte_size; - output = ecl_floor2(output, ecl_make_fixnum(bs/8)); - unlikely_if (ecl_nth_value(the_env, 1) != ecl_make_fixnum(0)) { - FEerror("File length is not on byte boundary", 0); - } - } - return output; + int f = IO_FILE_DESCRIPTOR(strm); + cl_object output = ecl_file_len(f); + if (strm->stream.byte_size != 8) { + const cl_env_ptr the_env = ecl_process_env(); + cl_index bs = strm->stream.byte_size; + output = ecl_floor2(output, ecl_make_fixnum(bs/8)); + unlikely_if (ecl_nth_value(the_env, 1) != ecl_make_fixnum(0)) { + FEerror("File length is not on byte boundary", 0); + } + } + return output; } static cl_object io_file_get_position(cl_object strm) { - cl_object output; - ecl_off_t offset; + cl_object output; + ecl_off_t offset; - int f = IO_FILE_DESCRIPTOR(strm); - if (isatty(f)) return(ECL_NIL); + int f = IO_FILE_DESCRIPTOR(strm); + if (isatty(f)) return(ECL_NIL); - ecl_disable_interrupts(); - offset = lseek(f, 0, SEEK_CUR); - ecl_enable_interrupts(); - unlikely_if (offset < 0) - if (errno == ESPIPE) - return(ECL_NIL); - else - io_error(strm); - if (sizeof(ecl_off_t) == sizeof(long)) { - output = ecl_make_integer(offset); - } else { - output = ecl_off_t_to_integer(offset); - } - { - /* If there are unread octets, we return the position at which - * these bytes begin! */ - cl_object l = strm->stream.byte_stack; - while (CONSP(l)) { - output = ecl_one_minus(output); - l = ECL_CONS_CDR(l); - } - } - if (strm->stream.byte_size != 8) { - output = ecl_floor2(output, ecl_make_fixnum(strm->stream.byte_size / 8)); - } - return output; + ecl_disable_interrupts(); + offset = lseek(f, 0, SEEK_CUR); + ecl_enable_interrupts(); + unlikely_if (offset < 0) + if (errno == ESPIPE) + return(ECL_NIL); + else + io_error(strm); + if (sizeof(ecl_off_t) == sizeof(long)) { + output = ecl_make_integer(offset); + } else { + output = ecl_off_t_to_integer(offset); + } + { + /* If there are unread octets, we return the position at which + * these bytes begin! */ + cl_object l = strm->stream.byte_stack; + while (CONSP(l)) { + output = ecl_one_minus(output); + l = ECL_CONS_CDR(l); + } + } + if (strm->stream.byte_size != 8) { + output = ecl_floor2(output, ecl_make_fixnum(strm->stream.byte_size / 8)); + } + return output; } static cl_object io_file_set_position(cl_object strm, cl_object large_disp) { - ecl_off_t disp; - int mode; - int f = IO_FILE_DESCRIPTOR(strm); - if (isatty(f)) return(ECL_NIL); - if (Null(large_disp)) { - disp = 0; - mode = SEEK_END; - } else { - if (strm->stream.byte_size != 8) { - large_disp = ecl_times(large_disp, - ecl_make_fixnum(strm->stream.byte_size / 8)); - } - disp = ecl_integer_to_off_t(large_disp); - mode = SEEK_SET; - } - disp = lseek(f, disp, mode); - return (disp == (ecl_off_t)-1)? ECL_NIL : ECL_T; + ecl_off_t disp; + int mode; + int f = IO_FILE_DESCRIPTOR(strm); + if (isatty(f)) return(ECL_NIL); + if (Null(large_disp)) { + disp = 0; + mode = SEEK_END; + } else { + if (strm->stream.byte_size != 8) { + large_disp = ecl_times(large_disp, + ecl_make_fixnum(strm->stream.byte_size / 8)); + } + disp = ecl_integer_to_off_t(large_disp); + mode = SEEK_SET; + } + disp = lseek(f, disp, mode); + return (disp == (ecl_off_t)-1)? ECL_NIL : ECL_T; } static int io_file_column(cl_object strm) { - return strm->stream.column; + return strm->stream.column; } static cl_object io_file_close(cl_object strm) { - int f = IO_FILE_DESCRIPTOR(strm); - int failed; - unlikely_if (f == STDOUT_FILENO) - FEerror("Cannot close the standard output", 0); - unlikely_if (f == STDIN_FILENO) - FEerror("Cannot close the standard input", 0); - failed = safe_close(f); - unlikely_if (failed < 0) - cannot_close(strm); - IO_FILE_DESCRIPTOR(strm) = -1; - return generic_close(strm); + int f = IO_FILE_DESCRIPTOR(strm); + int failed; + unlikely_if (f == STDOUT_FILENO) + FEerror("Cannot close the standard output", 0); + unlikely_if (f == STDIN_FILENO) + FEerror("Cannot close the standard input", 0); + failed = safe_close(f); + unlikely_if (failed < 0) + cannot_close(strm); + IO_FILE_DESCRIPTOR(strm) = -1; + return generic_close(strm); } static cl_index io_file_read_vector(cl_object strm, cl_object data, cl_index start, cl_index end) { - cl_elttype t = ecl_array_elttype(data); - if (start >= end) - return start; - if (t == ecl_aet_b8 || t == ecl_aet_i8) { - if (strm->stream.byte_size == 8) { - void *aux = data->vector.self.bc + start; - return start + strm->stream.ops->read_byte8(strm, aux, end-start); - } - } else if (t == ecl_aet_fix || t == ecl_aet_index) { - if (strm->stream.byte_size == sizeof(cl_fixnum)*8) { - void *aux = data->vector.self.fix + start; - cl_index bytes = (end - start) * sizeof(cl_fixnum); - bytes = strm->stream.ops->read_byte8(strm, aux, bytes); - return start + bytes / sizeof(cl_fixnum); - } - } - return generic_read_vector(strm, data, start, end); + cl_elttype t = ecl_array_elttype(data); + if (start >= end) + return start; + if (t == ecl_aet_b8 || t == ecl_aet_i8) { + if (strm->stream.byte_size == 8) { + void *aux = data->vector.self.bc + start; + return start + strm->stream.ops->read_byte8(strm, aux, end-start); + } + } else if (t == ecl_aet_fix || t == ecl_aet_index) { + if (strm->stream.byte_size == sizeof(cl_fixnum)*8) { + void *aux = data->vector.self.fix + start; + cl_index bytes = (end - start) * sizeof(cl_fixnum); + bytes = strm->stream.ops->read_byte8(strm, aux, bytes); + return start + bytes / sizeof(cl_fixnum); + } + } + return generic_read_vector(strm, data, start, end); } static cl_index io_file_write_vector(cl_object strm, cl_object data, cl_index start, cl_index end) { - cl_elttype t = ecl_array_elttype(data); - if (start >= end) - return start; - if (t == ecl_aet_b8 || t == ecl_aet_i8) { - if (strm->stream.byte_size == 8) { - void *aux = data->vector.self.bc + start; - return strm->stream.ops->write_byte8(strm, aux, end-start); - } - } else if (t == ecl_aet_fix || t == ecl_aet_index) { - if (strm->stream.byte_size == sizeof(cl_fixnum)*8) { - void *aux = data->vector.self.fix + start; - cl_index bytes = (end - start) * sizeof(cl_fixnum); - bytes = strm->stream.ops->write_byte8(strm, aux, bytes); - return start + bytes / sizeof(cl_fixnum); - } - } - return generic_write_vector(strm, data, start, end); + cl_elttype t = ecl_array_elttype(data); + if (start >= end) + return start; + if (t == ecl_aet_b8 || t == ecl_aet_i8) { + if (strm->stream.byte_size == 8) { + void *aux = data->vector.self.bc + start; + return strm->stream.ops->write_byte8(strm, aux, end-start); + } + } else if (t == ecl_aet_fix || t == ecl_aet_index) { + if (strm->stream.byte_size == sizeof(cl_fixnum)*8) { + void *aux = data->vector.self.fix + start; + cl_index bytes = (end - start) * sizeof(cl_fixnum); + bytes = strm->stream.ops->write_byte8(strm, aux, bytes); + return start + bytes / sizeof(cl_fixnum); + } + } + return generic_write_vector(strm, data, start, end); } const struct ecl_file_ops io_file_ops = { - io_file_write_byte8, - io_file_read_byte8, + io_file_write_byte8, + io_file_read_byte8, - generic_write_byte, - generic_read_byte, + generic_write_byte, + generic_read_byte, - eformat_read_char, - eformat_write_char, - eformat_unread_char, - generic_peek_char, - - io_file_read_vector, - io_file_write_vector, - - io_file_listen, - io_file_clear_input, - io_file_clear_output, - io_file_finish_output, - io_file_force_output, - - generic_always_true, /* input_p */ - generic_always_true, /* output_p */ - io_file_interactive_p, - io_file_element_type, - - io_file_length, - io_file_get_position, - io_file_set_position, - io_file_column, - io_file_close + eformat_read_char, + eformat_write_char, + eformat_unread_char, + generic_peek_char, + + io_file_read_vector, + io_file_write_vector, + + io_file_listen, + io_file_clear_input, + io_file_clear_output, + io_file_finish_output, + io_file_force_output, + + generic_always_true, /* input_p */ + generic_always_true, /* output_p */ + io_file_interactive_p, + io_file_element_type, + + io_file_length, + io_file_get_position, + io_file_set_position, + io_file_column, + io_file_close }; const struct ecl_file_ops output_file_ops = { - output_file_write_byte8, - not_input_read_byte8, + output_file_write_byte8, + not_input_read_byte8, - generic_write_byte, - not_input_read_byte, + generic_write_byte, + not_input_read_byte, - not_input_read_char, - eformat_write_char, - not_input_unread_char, - not_input_read_char, - - generic_read_vector, - io_file_write_vector, - - not_input_listen, - not_input_clear_input, - io_file_clear_output, - io_file_finish_output, - io_file_force_output, - - generic_always_false, /* input_p */ - generic_always_true, /* output_p */ - generic_always_false, - io_file_element_type, - - io_file_length, - io_file_get_position, - io_file_set_position, - io_file_column, - io_file_close + not_input_read_char, + eformat_write_char, + not_input_unread_char, + not_input_read_char, + + generic_read_vector, + io_file_write_vector, + + not_input_listen, + not_input_clear_input, + io_file_clear_output, + io_file_finish_output, + io_file_force_output, + + generic_always_false, /* input_p */ + generic_always_true, /* output_p */ + generic_always_false, + io_file_element_type, + + io_file_length, + io_file_get_position, + io_file_set_position, + io_file_column, + io_file_close }; const struct ecl_file_ops input_file_ops = { - not_output_write_byte8, - io_file_read_byte8, + not_output_write_byte8, + io_file_read_byte8, - not_output_write_byte, - generic_read_byte, + not_output_write_byte, + generic_read_byte, - eformat_read_char, - not_output_write_char, - eformat_unread_char, - generic_peek_char, - - io_file_read_vector, - generic_write_vector, - - io_file_listen, - io_file_clear_input, - not_output_clear_output, - not_output_finish_output, - not_output_force_output, - - generic_always_true, /* input_p */ - generic_always_false, /* output_p */ - io_file_interactive_p, - io_file_element_type, - - io_file_length, - io_file_get_position, - io_file_set_position, - generic_column, - io_file_close + eformat_read_char, + not_output_write_char, + eformat_unread_char, + generic_peek_char, + + io_file_read_vector, + generic_write_vector, + + io_file_listen, + io_file_clear_input, + not_output_clear_output, + not_output_finish_output, + not_output_force_output, + + generic_always_true, /* input_p */ + generic_always_false, /* output_p */ + io_file_interactive_p, + io_file_element_type, + + io_file_length, + io_file_get_position, + io_file_set_position, + generic_column, + io_file_close }; static int parse_external_format(cl_object stream, cl_object format, int flags) { - if (format == @':default') { - format = ecl_symbol_value(@'ext::*default-external-format*'); - } - if (CONSP(format)) { - flags = parse_external_format(stream, ECL_CONS_CDR(format), flags); - format = ECL_CONS_CAR(format); - } - if (format == ECL_T) { + if (format == @':default') { + format = ecl_symbol_value(@'ext::*default-external-format*'); + } + if (CONSP(format)) { + flags = parse_external_format(stream, ECL_CONS_CDR(format), flags); + format = ECL_CONS_CAR(format); + } + if (format == ECL_T) { #ifdef ECL_UNICODE - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UTF_8; + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UTF_8; #else - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_DEFAULT_FORMAT; + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_DEFAULT_FORMAT; #endif - } - if (format == ECL_NIL) { - return flags; - } - if (format == @':CR') { - return (flags | ECL_STREAM_CR) & ~ECL_STREAM_LF; - } - if (format == @':LF') { - return (flags | ECL_STREAM_LF) & ~ECL_STREAM_CR; - } - if (format == @':CRLF') { - return flags | (ECL_STREAM_CR+ECL_STREAM_LF); - } - if (format == @':LITTLE-ENDIAN') { - return flags | ECL_STREAM_LITTLE_ENDIAN; - } - if (format == @':BIG-ENDIAN') { - return flags & ~ECL_STREAM_LITTLE_ENDIAN; - } - if (format == @':pass-through') { + } + if (format == ECL_NIL) { + return flags; + } + if (format == @':CR') { + return (flags | ECL_STREAM_CR) & ~ECL_STREAM_LF; + } + if (format == @':LF') { + return (flags | ECL_STREAM_LF) & ~ECL_STREAM_CR; + } + if (format == @':CRLF') { + return flags | (ECL_STREAM_CR+ECL_STREAM_LF); + } + if (format == @':LITTLE-ENDIAN') { + return flags | ECL_STREAM_LITTLE_ENDIAN; + } + if (format == @':BIG-ENDIAN') { + return flags & ~ECL_STREAM_LITTLE_ENDIAN; + } + if (format == @':pass-through') { #ifdef ECL_UNICODE - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_LATIN_1; + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_LATIN_1; #else - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_DEFAULT_FORMAT; + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_DEFAULT_FORMAT; #endif - } + } #ifdef ECL_UNICODE PARSE_SYMBOLS: - if (format == @':UTF-8') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UTF_8; - } - if (format == @':UCS-2') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_2; - } - if (format == @':UCS-2BE') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_2BE; - } - if (format == @':UCS-2LE') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_2LE; - } - if (format == @':UCS-4') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_4; - } - if (format == @':UCS-4BE') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_4BE; - } - if (format == @':UCS-4LE') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_4LE; - } - if (format == @':ISO-8859-1') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_ISO_8859_1; - } - if (format == @':LATIN-1') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_LATIN_1; - } - if (format == @':US-ASCII') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_US_ASCII; - } - if (ECL_HASH_TABLE_P(format)) { - stream->stream.format_table = format; - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_USER_FORMAT; - } - if (ECL_SYMBOLP(format)) { - format = si_make_encoding(format); - if (ECL_SYMBOLP(format)) - goto PARSE_SYMBOLS; - stream->stream.format_table = format; - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_USER_FORMAT; - } + if (format == @':UTF-8') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UTF_8; + } + if (format == @':UCS-2') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_2; + } + if (format == @':UCS-2BE') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_2BE; + } + if (format == @':UCS-2LE') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_2LE; + } + if (format == @':UCS-4') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_4; + } + if (format == @':UCS-4BE') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_4BE; + } + if (format == @':UCS-4LE') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_4LE; + } + if (format == @':ISO-8859-1') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_ISO_8859_1; + } + if (format == @':LATIN-1') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_LATIN_1; + } + if (format == @':US-ASCII') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_US_ASCII; + } + if (ECL_HASH_TABLE_P(format)) { + stream->stream.format_table = format; + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_USER_FORMAT; + } + if (ECL_SYMBOLP(format)) { + format = si_make_encoding(format); + if (ECL_SYMBOLP(format)) + goto PARSE_SYMBOLS; + stream->stream.format_table = format; + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_USER_FORMAT; + } #endif - FEerror("Unknown or unsupported external format: ~A", 1, format); - return ECL_STREAM_DEFAULT_FORMAT; + FEerror("Unknown or unsupported external format: ~A", 1, format); + return ECL_STREAM_DEFAULT_FORMAT; } static void set_stream_elt_type(cl_object stream, cl_fixnum byte_size, int flags, cl_object external_format) { - cl_object t; - if (byte_size < 0) { - byte_size = -byte_size; - flags |= ECL_STREAM_SIGNED_BYTES; - t = @'signed-byte'; - } else { - flags &= ~ECL_STREAM_SIGNED_BYTES; - t = @'unsigned-byte'; - } - flags = parse_external_format(stream, external_format, flags); - stream->stream.ops->read_char = eformat_read_char; - stream->stream.ops->write_char = eformat_write_char; - switch (flags & ECL_STREAM_FORMAT) { - case ECL_STREAM_BINARY: - IO_STREAM_ELT_TYPE(stream) = cl_list(2, t, ecl_make_fixnum(byte_size)); - stream->stream.format = t; - stream->stream.ops->read_char = not_character_read_char; - stream->stream.ops->write_char = not_character_write_char; - break; + cl_object t; + if (byte_size < 0) { + byte_size = -byte_size; + flags |= ECL_STREAM_SIGNED_BYTES; + t = @'signed-byte'; + } else { + flags &= ~ECL_STREAM_SIGNED_BYTES; + t = @'unsigned-byte'; + } + flags = parse_external_format(stream, external_format, flags); + stream->stream.ops->read_char = eformat_read_char; + stream->stream.ops->write_char = eformat_write_char; + switch (flags & ECL_STREAM_FORMAT) { + case ECL_STREAM_BINARY: + IO_STREAM_ELT_TYPE(stream) = cl_list(2, t, ecl_make_fixnum(byte_size)); + stream->stream.format = t; + stream->stream.ops->read_char = not_character_read_char; + stream->stream.ops->write_char = not_character_write_char; + break; #ifdef ECL_UNICODE - /*case ECL_ISO_8859_1:*/ - case ECL_STREAM_LATIN_1: - IO_STREAM_ELT_TYPE(stream) = @'base-char'; - byte_size = 8; - stream->stream.format = @':latin-1'; - stream->stream.encoder = passthrough_encoder; - stream->stream.decoder = passthrough_decoder; - break; - case ECL_STREAM_UTF_8: - IO_STREAM_ELT_TYPE(stream) = @'character'; - byte_size = 8; - stream->stream.format = @':utf-8'; - stream->stream.encoder = utf_8_encoder; - stream->stream.decoder = utf_8_decoder; - break; - case ECL_STREAM_UCS_2: - IO_STREAM_ELT_TYPE(stream) = @'character'; - byte_size = 8*2; - stream->stream.format = @':ucs-2'; - stream->stream.encoder = ucs_2_encoder; - stream->stream.decoder = ucs_2_decoder; - break; - case ECL_STREAM_UCS_2BE: - IO_STREAM_ELT_TYPE(stream) = @'character'; - byte_size = 8*2; - if (flags & ECL_STREAM_LITTLE_ENDIAN) { - stream->stream.format = @':ucs-2le'; - stream->stream.encoder = ucs_2le_encoder; - stream->stream.decoder = ucs_2le_decoder; - } else { - stream->stream.format = @':ucs-2be'; - stream->stream.encoder = ucs_2be_encoder; - stream->stream.decoder = ucs_2be_decoder; - } - break; - case ECL_STREAM_UCS_4: - IO_STREAM_ELT_TYPE(stream) = @'character'; - byte_size = 8*4; - stream->stream.format = @':ucs-4be'; - stream->stream.encoder = ucs_4_encoder; - stream->stream.decoder = ucs_4_decoder; - break; - case ECL_STREAM_UCS_4BE: - IO_STREAM_ELT_TYPE(stream) = @'character'; - byte_size = 8*4; - if (flags & ECL_STREAM_LITTLE_ENDIAN) { - stream->stream.format = @':ucs-4le'; - stream->stream.encoder = ucs_4le_encoder; - stream->stream.decoder = ucs_4le_decoder; - } else { - stream->stream.format = @':ucs-4be'; - stream->stream.encoder = ucs_4be_encoder; - stream->stream.decoder = ucs_4be_decoder; - } - break; - case ECL_STREAM_USER_FORMAT: - IO_STREAM_ELT_TYPE(stream) = @'character'; - byte_size = 8; - stream->stream.format = stream->stream.format_table; - if (CONSP(stream->stream.format)) { - stream->stream.encoder = user_multistate_encoder; - stream->stream.decoder = user_multistate_decoder; - } else { - stream->stream.encoder = user_encoder; - stream->stream.decoder = user_decoder; - } - break; - case ECL_STREAM_US_ASCII: - IO_STREAM_ELT_TYPE(stream) = @'base-char'; - byte_size = 8; - stream->stream.format = @':us-ascii'; - stream->stream.encoder = ascii_encoder; - stream->stream.decoder = ascii_decoder; - break; + /*case ECL_ISO_8859_1:*/ + case ECL_STREAM_LATIN_1: + IO_STREAM_ELT_TYPE(stream) = @'base-char'; + byte_size = 8; + stream->stream.format = @':latin-1'; + stream->stream.encoder = passthrough_encoder; + stream->stream.decoder = passthrough_decoder; + break; + case ECL_STREAM_UTF_8: + IO_STREAM_ELT_TYPE(stream) = @'character'; + byte_size = 8; + stream->stream.format = @':utf-8'; + stream->stream.encoder = utf_8_encoder; + stream->stream.decoder = utf_8_decoder; + break; + case ECL_STREAM_UCS_2: + IO_STREAM_ELT_TYPE(stream) = @'character'; + byte_size = 8*2; + stream->stream.format = @':ucs-2'; + stream->stream.encoder = ucs_2_encoder; + stream->stream.decoder = ucs_2_decoder; + break; + case ECL_STREAM_UCS_2BE: + IO_STREAM_ELT_TYPE(stream) = @'character'; + byte_size = 8*2; + if (flags & ECL_STREAM_LITTLE_ENDIAN) { + stream->stream.format = @':ucs-2le'; + stream->stream.encoder = ucs_2le_encoder; + stream->stream.decoder = ucs_2le_decoder; + } else { + stream->stream.format = @':ucs-2be'; + stream->stream.encoder = ucs_2be_encoder; + stream->stream.decoder = ucs_2be_decoder; + } + break; + case ECL_STREAM_UCS_4: + IO_STREAM_ELT_TYPE(stream) = @'character'; + byte_size = 8*4; + stream->stream.format = @':ucs-4be'; + stream->stream.encoder = ucs_4_encoder; + stream->stream.decoder = ucs_4_decoder; + break; + case ECL_STREAM_UCS_4BE: + IO_STREAM_ELT_TYPE(stream) = @'character'; + byte_size = 8*4; + if (flags & ECL_STREAM_LITTLE_ENDIAN) { + stream->stream.format = @':ucs-4le'; + stream->stream.encoder = ucs_4le_encoder; + stream->stream.decoder = ucs_4le_decoder; + } else { + stream->stream.format = @':ucs-4be'; + stream->stream.encoder = ucs_4be_encoder; + stream->stream.decoder = ucs_4be_decoder; + } + break; + case ECL_STREAM_USER_FORMAT: + IO_STREAM_ELT_TYPE(stream) = @'character'; + byte_size = 8; + stream->stream.format = stream->stream.format_table; + if (CONSP(stream->stream.format)) { + stream->stream.encoder = user_multistate_encoder; + stream->stream.decoder = user_multistate_decoder; + } else { + stream->stream.encoder = user_encoder; + stream->stream.decoder = user_decoder; + } + break; + case ECL_STREAM_US_ASCII: + IO_STREAM_ELT_TYPE(stream) = @'base-char'; + byte_size = 8; + stream->stream.format = @':us-ascii'; + stream->stream.encoder = ascii_encoder; + stream->stream.decoder = ascii_decoder; + break; #else - case ECL_STREAM_DEFAULT_FORMAT: - IO_STREAM_ELT_TYPE(stream) = @'base-char'; - byte_size = 8; - stream->stream.format = @':pass-through'; - stream->stream.encoder = passthrough_encoder; - stream->stream.decoder = passthrough_decoder; - break; -#endif - default: - FEerror("Invalid or unsupported external format ~A with code ~D", - 2, external_format, ecl_make_fixnum(flags)); - } - t = @':LF'; - if (stream->stream.ops->write_char == eformat_write_char && - (flags & ECL_STREAM_CR)) { - if (flags & ECL_STREAM_LF) { - stream->stream.ops->read_char = eformat_read_char_crlf; - stream->stream.ops->write_char = eformat_write_char_crlf; - t = @':CRLF'; - } else { - stream->stream.ops->read_char = eformat_read_char_cr; - stream->stream.ops->write_char = eformat_write_char_cr; - t = @':CR'; - } - } - stream->stream.format = cl_list(2, stream->stream.format, t); - { - cl_object (*read_byte)(cl_object); - void (*write_byte)(cl_object,cl_object); - byte_size = (byte_size+7)&(~(cl_fixnum)7); - if (byte_size == 8) { - if (flags & ECL_STREAM_SIGNED_BYTES) { - read_byte = generic_read_byte_signed8; - write_byte = generic_write_byte_signed8; - } else { - read_byte = generic_read_byte_unsigned8; - write_byte = generic_write_byte_unsigned8; - } - } else if (flags & ECL_STREAM_LITTLE_ENDIAN) { - read_byte = generic_read_byte_le; - write_byte = generic_write_byte_le; - } else { - read_byte = generic_read_byte; - write_byte = generic_write_byte; - } - if (ecl_input_stream_p(stream)) { - stream->stream.ops->read_byte = read_byte; - } - if (ecl_output_stream_p(stream)) { - stream->stream.ops->write_byte = write_byte; - } - } - stream->stream.flags = flags; - stream->stream.byte_size = byte_size; + case ECL_STREAM_DEFAULT_FORMAT: + IO_STREAM_ELT_TYPE(stream) = @'base-char'; + byte_size = 8; + stream->stream.format = @':pass-through'; + stream->stream.encoder = passthrough_encoder; + stream->stream.decoder = passthrough_decoder; + break; +#endif + default: + FEerror("Invalid or unsupported external format ~A with code ~D", + 2, external_format, ecl_make_fixnum(flags)); + } + t = @':LF'; + if (stream->stream.ops->write_char == eformat_write_char && + (flags & ECL_STREAM_CR)) { + if (flags & ECL_STREAM_LF) { + stream->stream.ops->read_char = eformat_read_char_crlf; + stream->stream.ops->write_char = eformat_write_char_crlf; + t = @':CRLF'; + } else { + stream->stream.ops->read_char = eformat_read_char_cr; + stream->stream.ops->write_char = eformat_write_char_cr; + t = @':CR'; + } + } + stream->stream.format = cl_list(2, stream->stream.format, t); + { + cl_object (*read_byte)(cl_object); + void (*write_byte)(cl_object,cl_object); + byte_size = (byte_size+7)&(~(cl_fixnum)7); + if (byte_size == 8) { + if (flags & ECL_STREAM_SIGNED_BYTES) { + read_byte = generic_read_byte_signed8; + write_byte = generic_write_byte_signed8; + } else { + read_byte = generic_read_byte_unsigned8; + write_byte = generic_write_byte_unsigned8; + } + } else if (flags & ECL_STREAM_LITTLE_ENDIAN) { + read_byte = generic_read_byte_le; + write_byte = generic_write_byte_le; + } else { + read_byte = generic_read_byte; + write_byte = generic_write_byte; + } + if (ecl_input_stream_p(stream)) { + stream->stream.ops->read_byte = read_byte; + } + if (ecl_output_stream_p(stream)) { + stream->stream.ops->write_byte = write_byte; + } + } + stream->stream.flags = flags; + stream->stream.byte_size = byte_size; } cl_object si_stream_external_format_set(cl_object stream, cl_object format) { #ifdef ECL_CLOS_STREAMS - unlikely_if (ECL_INSTANCEP(stream)) { - FEerror("Cannot change external format of stream ~A", 1, stream); - } -#endif - switch (stream->stream.mode) { - case ecl_smm_input: - case ecl_smm_input_file: - case ecl_smm_output: - case ecl_smm_output_file: - case ecl_smm_io: - case ecl_smm_io_file: + unlikely_if (ECL_INSTANCEP(stream)) { + FEerror("Cannot change external format of stream ~A", 1, stream); + } +#endif + switch (stream->stream.mode) { + case ecl_smm_input: + case ecl_smm_input_file: + case ecl_smm_output: + case ecl_smm_output_file: + case ecl_smm_io: + case ecl_smm_io_file: #ifdef ECL_WSOCK - case ecl_smm_input_wsock: - case ecl_smm_output_wsock: - case ecl_smm_io_wsock: - case ecl_smm_io_wcon: -#endif - { - cl_object elt_type = ecl_stream_element_type(stream); - unlikely_if (elt_type != @'character' && - elt_type != @'base-char') - FEerror("Cannot change external format" - "of binary stream ~A", 1, stream); - set_stream_elt_type(stream, stream->stream.byte_size, - stream->stream.flags, format); - } - break; - default: - FEerror("Cannot change external format of stream ~A", 1, stream); - } - @(return) + case ecl_smm_input_wsock: + case ecl_smm_output_wsock: + case ecl_smm_io_wsock: + case ecl_smm_io_wcon: +#endif + { + cl_object elt_type = ecl_stream_element_type(stream); + unlikely_if (elt_type != @'character' && + elt_type != @'base-char') + FEerror("Cannot change external format" + "of binary stream ~A", 1, stream); + set_stream_elt_type(stream, stream->stream.byte_size, + stream->stream.flags, format); + } + break; + default: + FEerror("Cannot change external format of stream ~A", 1, stream); + } + @(return); } cl_object ecl_make_file_stream_from_fd(cl_object fname, int fd, enum ecl_smmode smm, cl_fixnum byte_size, int flags, cl_object external_format) { - cl_object stream = alloc_stream(); - switch(smm) { - case ecl_smm_input: - smm = ecl_smm_input_file; - case ecl_smm_input_file: - case ecl_smm_probe: - stream->stream.ops = duplicate_dispatch_table(&input_file_ops); - break; - case ecl_smm_output: - smm = ecl_smm_output_file; - case ecl_smm_output_file: - stream->stream.ops = duplicate_dispatch_table(&output_file_ops); - break; - case ecl_smm_io: - smm = ecl_smm_io_file; - case ecl_smm_io_file: - stream->stream.ops = duplicate_dispatch_table(&io_file_ops); - break; - default: - FEerror("make_stream: wrong mode", 0); - } - stream->stream.mode = (short)smm; - stream->stream.closed = 0; - set_stream_elt_type(stream, byte_size, flags, external_format); - IO_FILE_FILENAME(stream) = fname; /* not really used */ - stream->stream.column = 0; - IO_FILE_DESCRIPTOR(stream) = fd; - stream->stream.last_op = 0; - si_set_finalizer(stream, ECL_T); - return stream; + cl_object stream = alloc_stream(); + switch(smm) { + case ecl_smm_input: + smm = ecl_smm_input_file; + case ecl_smm_input_file: + case ecl_smm_probe: + stream->stream.ops = duplicate_dispatch_table(&input_file_ops); + break; + case ecl_smm_output: + smm = ecl_smm_output_file; + case ecl_smm_output_file: + stream->stream.ops = duplicate_dispatch_table(&output_file_ops); + break; + case ecl_smm_io: + smm = ecl_smm_io_file; + case ecl_smm_io_file: + stream->stream.ops = duplicate_dispatch_table(&io_file_ops); + break; + default: + FEerror("make_stream: wrong mode", 0); + } + stream->stream.mode = (short)smm; + stream->stream.closed = 0; + set_stream_elt_type(stream, byte_size, flags, external_format); + IO_FILE_FILENAME(stream) = fname; /* not really used */ + stream->stream.column = 0; + IO_FILE_DESCRIPTOR(stream) = fd; + stream->stream.last_op = 0; + si_set_finalizer(stream, ECL_T); + return stream; } /********************************************************************** @@ -3324,58 +3321,58 @@ static cl_index input_stream_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - unlikely_if (strm->stream.byte_stack != ECL_NIL) { - return consume_byte_stack(strm, c, n); - } else { - FILE *f = IO_STREAM_FILE(strm); - cl_fixnum out = 0; - ecl_disable_interrupts(); + unlikely_if (strm->stream.byte_stack != ECL_NIL) { + return consume_byte_stack(strm, c, n); + } else { + FILE *f = IO_STREAM_FILE(strm); + cl_fixnum out = 0; + ecl_disable_interrupts(); #ifdef FILE_CNT - do { - out = fread(c, sizeof(char), n, f); - } while (out < n && ferror(f) && restartable_io_error(strm, "fread")); + do { + out = fread(c, sizeof(char), n, f); + } while (out < n && ferror(f) && restartable_io_error(strm, "fread")); #else - /* We can't use fread here due to the buffering. It makes - impossible checking if we have some data available in the - buffer what renders listen returning incorrect result. */ - do { - out = read(fileno(f), c, sizeof(char)*n); - } while (out < 0 && restartable_io_error(strm, "read")); -#endif - ecl_enable_interrupts(); - return out; - } + /* We can't use fread here due to the buffering. It makes + impossible checking if we have some data available in the + buffer what renders listen returning incorrect result. */ + do { + out = read(fileno(f), c, sizeof(char)*n); + } while (out < 0 && restartable_io_error(strm, "read")); +#endif + ecl_enable_interrupts(); + return out; + } } static cl_index output_stream_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - cl_index out; - ecl_disable_interrupts(); - do { - out = fwrite(c, sizeof(char), n, IO_STREAM_FILE(strm)); - } while (out < n && restartable_io_error(strm, "fwrite")); - ecl_enable_interrupts(); - return out; + cl_index out; + ecl_disable_interrupts(); + do { + out = fwrite(c, sizeof(char), n, IO_STREAM_FILE(strm)); + } while (out < n && restartable_io_error(strm, "fwrite")); + ecl_enable_interrupts(); + return out; } static cl_index io_stream_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - /* When using the same stream for input and output operations, we have to - * use some file position operation before reading again. Besides this, if - * there were unread octets, we have to move to the position at the - * begining of them. - */ - if (strm->stream.byte_stack != ECL_NIL) { - cl_object aux = ecl_file_position(strm); - if (!Null(aux)) - ecl_file_position_set(strm, aux); - } else if (strm->stream.last_op > 0) { - ecl_fseeko(IO_STREAM_FILE(strm), 0, SEEK_CUR); - } - strm->stream.last_op = -1; - return output_stream_write_byte8(strm, c, n); + /* When using the same stream for input and output operations, we have to + * use some file position operation before reading again. Besides this, if + * there were unread octets, we have to move to the position at the + * begining of them. + */ + if (strm->stream.byte_stack != ECL_NIL) { + cl_object aux = ecl_file_position(strm); + if (!Null(aux)) + ecl_file_position_set(strm, aux); + } else if (strm->stream.last_op > 0) { + ecl_fseeko(IO_STREAM_FILE(strm), 0, SEEK_CUR); + } + strm->stream.last_op = -1; + return output_stream_write_byte8(strm, c, n); } static void io_stream_force_output(cl_object strm); @@ -3383,42 +3380,42 @@ static cl_index io_stream_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - /* When using the same stream for input and output operations, we have to - * flush the stream before reading. - */ - if (strm->stream.last_op < 0) { - io_stream_force_output(strm); - } - strm->stream.last_op = +1; - return input_stream_read_byte8(strm, c, n); + /* When using the same stream for input and output operations, we have to + * flush the stream before reading. + */ + if (strm->stream.last_op < 0) { + io_stream_force_output(strm); + } + strm->stream.last_op = +1; + return input_stream_read_byte8(strm, c, n); } static int io_stream_listen(cl_object strm) { - if (strm->stream.byte_stack != ECL_NIL) - return ECL_LISTEN_AVAILABLE; - return flisten(strm, IO_STREAM_FILE(strm)); + if (strm->stream.byte_stack != ECL_NIL) + return ECL_LISTEN_AVAILABLE; + return flisten(strm, IO_STREAM_FILE(strm)); } static void io_stream_clear_input(cl_object strm) { - FILE *fp = IO_STREAM_FILE(strm); + FILE *fp = IO_STREAM_FILE(strm); #if defined(ECL_MS_WINDOWS_HOST) - int f = fileno(fp); - if (isatty(f)) { - /* Flushes Win32 console */ - unlikely_if (!FlushConsoleInputBuffer((HANDLE)_get_osfhandle(f))) - FEwin32_error("FlushConsoleInputBuffer() failed", 0); - /* Do not stop here: the FILE structure needs also to be flushed */ - } -#endif - while (flisten(strm, fp) == ECL_LISTEN_AVAILABLE) { - ecl_disable_interrupts(); - getc(fp); - ecl_enable_interrupts(); - } + int f = fileno(fp); + if (isatty(f)) { + /* Flushes Win32 console */ + unlikely_if (!FlushConsoleInputBuffer((HANDLE)_get_osfhandle(f))) + FEwin32_error("FlushConsoleInputBuffer() failed", 0); + /* Do not stop here: the FILE structure needs also to be flushed */ + } +#endif + while (flisten(strm, fp) == ECL_LISTEN_AVAILABLE) { + ecl_disable_interrupts(); + getc(fp); + ecl_enable_interrupts(); + } } #define io_stream_clear_output generic_void @@ -3426,11 +3423,11 @@ static void io_stream_force_output(cl_object strm) { - FILE *f = IO_STREAM_FILE(strm); - ecl_disable_interrupts(); - while ((fflush(f) == EOF) && restartable_io_error(strm, "fflush")) - (void)0; - ecl_enable_interrupts(); + FILE *f = IO_STREAM_FILE(strm); + ecl_disable_interrupts(); + while ((fflush(f) == EOF) && restartable_io_error(strm, "fflush")) + (void)0; + ecl_enable_interrupts(); } #define io_stream_finish_output io_stream_force_output @@ -3438,109 +3435,109 @@ static int io_stream_interactive_p(cl_object strm) { - FILE *f = IO_STREAM_FILE(strm); - return isatty(fileno(f)); + FILE *f = IO_STREAM_FILE(strm); + return isatty(fileno(f)); } static cl_object io_stream_length(cl_object strm) { - FILE *f = IO_STREAM_FILE(strm); - cl_object output = ecl_file_len(fileno(f)); - if (strm->stream.byte_size != 8) { - const cl_env_ptr the_env = ecl_process_env(); - cl_index bs = strm->stream.byte_size; - output = ecl_floor2(output, ecl_make_fixnum(bs/8)); - unlikely_if (ecl_nth_value(the_env, 1) != ecl_make_fixnum(0)) { - FEerror("File length is not on byte boundary", 0); - } - } - return output; + FILE *f = IO_STREAM_FILE(strm); + cl_object output = ecl_file_len(fileno(f)); + if (strm->stream.byte_size != 8) { + const cl_env_ptr the_env = ecl_process_env(); + cl_index bs = strm->stream.byte_size; + output = ecl_floor2(output, ecl_make_fixnum(bs/8)); + unlikely_if (ecl_nth_value(the_env, 1) != ecl_make_fixnum(0)) { + FEerror("File length is not on byte boundary", 0); + } + } + return output; } static cl_object io_stream_get_position(cl_object strm) { - FILE *f = IO_STREAM_FILE(strm); - cl_object output; - ecl_off_t offset; - - ecl_disable_interrupts(); - offset = ecl_ftello(f); - ecl_enable_interrupts(); - if (offset < 0) - io_error(strm); - if (sizeof(ecl_off_t) == sizeof(long)) { - output = ecl_make_integer(offset); - } else { - output = ecl_off_t_to_integer(offset); - } - { - /* If there are unread octets, we return the position at which - * these bytes begin! */ - cl_object l = strm->stream.byte_stack; - while (CONSP(l)) { - output = ecl_one_minus(output); - l = ECL_CONS_CDR(l); - } - } - if (strm->stream.byte_size != 8) { - output = ecl_floor2(output, ecl_make_fixnum(strm->stream.byte_size / 8)); - } - return output; + FILE *f = IO_STREAM_FILE(strm); + cl_object output; + ecl_off_t offset; + + ecl_disable_interrupts(); + offset = ecl_ftello(f); + ecl_enable_interrupts(); + if (offset < 0) + io_error(strm); + if (sizeof(ecl_off_t) == sizeof(long)) { + output = ecl_make_integer(offset); + } else { + output = ecl_off_t_to_integer(offset); + } + { + /* If there are unread octets, we return the position at which + * these bytes begin! */ + cl_object l = strm->stream.byte_stack; + while (CONSP(l)) { + output = ecl_one_minus(output); + l = ECL_CONS_CDR(l); + } + } + if (strm->stream.byte_size != 8) { + output = ecl_floor2(output, ecl_make_fixnum(strm->stream.byte_size / 8)); + } + return output; } static cl_object io_stream_set_position(cl_object strm, cl_object large_disp) { - FILE *f = IO_STREAM_FILE(strm); - ecl_off_t disp; - int mode; - if (Null(large_disp)) { - disp = 0; - mode = SEEK_END; - } else { - if (strm->stream.byte_size != 8) { - large_disp = ecl_times(large_disp, - ecl_make_fixnum(strm->stream.byte_size / 8)); - } - disp = ecl_integer_to_off_t(large_disp); - mode = SEEK_SET; - } - ecl_disable_interrupts(); - mode = ecl_fseeko(f, disp, mode); - ecl_enable_interrupts(); - return mode? ECL_NIL : ECL_T; + FILE *f = IO_STREAM_FILE(strm); + ecl_off_t disp; + int mode; + if (Null(large_disp)) { + disp = 0; + mode = SEEK_END; + } else { + if (strm->stream.byte_size != 8) { + large_disp = ecl_times(large_disp, + ecl_make_fixnum(strm->stream.byte_size / 8)); + } + disp = ecl_integer_to_off_t(large_disp); + mode = SEEK_SET; + } + ecl_disable_interrupts(); + mode = ecl_fseeko(f, disp, mode); + ecl_enable_interrupts(); + return mode? ECL_NIL : ECL_T; } static int io_stream_column(cl_object strm) { - return strm->stream.column; + return strm->stream.column; } static cl_object io_stream_close(cl_object strm) { - FILE *f = IO_STREAM_FILE(strm); - int failed; - unlikely_if (f == stdout) - FEerror("Cannot close the standard output", 0); - unlikely_if (f == stdin) - FEerror("Cannot close the standard input", 0); - unlikely_if (f == NULL) - wrong_file_handler(strm); - if (ecl_output_stream_p(strm)) { - ecl_force_output(strm); - } - failed = safe_fclose(f); - unlikely_if (failed) - cannot_close(strm); + FILE *f = IO_STREAM_FILE(strm); + int failed; + unlikely_if (f == stdout) + FEerror("Cannot close the standard output", 0); + unlikely_if (f == stdin) + FEerror("Cannot close the standard input", 0); + unlikely_if (f == NULL) + wrong_file_handler(strm); + if (ecl_output_stream_p(strm)) { + ecl_force_output(strm); + } + failed = safe_fclose(f); + unlikely_if (failed) + cannot_close(strm); #if !defined(GBC_BOEHM) - ecl_dealloc(strm->stream.buffer); - IO_STREAM_FILE(strm) = NULL; + ecl_dealloc(strm->stream.buffer); + IO_STREAM_FILE(strm) = NULL; #endif - return generic_close(strm); + return generic_close(strm); } /* @@ -3551,102 +3548,102 @@ #define io_stream_write_vector io_file_write_vector const struct ecl_file_ops io_stream_ops = { - io_stream_write_byte8, - io_stream_read_byte8, + io_stream_write_byte8, + io_stream_read_byte8, - generic_write_byte, - generic_read_byte, + generic_write_byte, + generic_read_byte, - eformat_read_char, - eformat_write_char, - eformat_unread_char, - generic_peek_char, - - io_file_read_vector, - io_file_write_vector, - - io_stream_listen, - io_stream_clear_input, - io_stream_clear_output, - io_stream_finish_output, - io_stream_force_output, - - generic_always_true, /* input_p */ - generic_always_true, /* output_p */ - io_stream_interactive_p, - io_file_element_type, - - io_stream_length, - io_stream_get_position, - io_stream_set_position, - io_stream_column, - io_stream_close + eformat_read_char, + eformat_write_char, + eformat_unread_char, + generic_peek_char, + + io_file_read_vector, + io_file_write_vector, + + io_stream_listen, + io_stream_clear_input, + io_stream_clear_output, + io_stream_finish_output, + io_stream_force_output, + + generic_always_true, /* input_p */ + generic_always_true, /* output_p */ + io_stream_interactive_p, + io_file_element_type, + + io_stream_length, + io_stream_get_position, + io_stream_set_position, + io_stream_column, + io_stream_close }; const struct ecl_file_ops output_stream_ops = { - output_stream_write_byte8, - not_input_read_byte8, + output_stream_write_byte8, + not_input_read_byte8, - generic_write_byte, - not_input_read_byte, + generic_write_byte, + not_input_read_byte, - not_input_read_char, - eformat_write_char, - not_input_unread_char, - not_input_read_char, - - generic_read_vector, - io_file_write_vector, - - not_input_listen, - generic_void, - io_stream_clear_output, - io_stream_finish_output, - io_stream_force_output, - - generic_always_false, /* input_p */ - generic_always_true, /* output_p */ - generic_always_false, - io_file_element_type, - - io_stream_length, - io_stream_get_position, - io_stream_set_position, - io_stream_column, - io_stream_close + not_input_read_char, + eformat_write_char, + not_input_unread_char, + not_input_read_char, + + generic_read_vector, + io_file_write_vector, + + not_input_listen, + generic_void, + io_stream_clear_output, + io_stream_finish_output, + io_stream_force_output, + + generic_always_false, /* input_p */ + generic_always_true, /* output_p */ + generic_always_false, + io_file_element_type, + + io_stream_length, + io_stream_get_position, + io_stream_set_position, + io_stream_column, + io_stream_close }; const struct ecl_file_ops input_stream_ops = { - not_output_write_byte8, - input_stream_read_byte8, + not_output_write_byte8, + input_stream_read_byte8, - not_output_write_byte, - generic_read_byte, + not_output_write_byte, + generic_read_byte, - eformat_read_char, - not_output_write_char, - eformat_unread_char, - generic_peek_char, - - io_file_read_vector, - generic_write_vector, - - io_stream_listen, - io_stream_clear_input, - generic_void, - generic_void, - generic_void, - - generic_always_true, /* input_p */ - generic_always_false, /* output_p */ - io_stream_interactive_p, - io_file_element_type, - - io_stream_length, - io_stream_get_position, - io_stream_set_position, - generic_column, - io_stream_close + eformat_read_char, + not_output_write_char, + eformat_unread_char, + generic_peek_char, + + io_file_read_vector, + generic_write_vector, + + io_stream_listen, + io_stream_clear_input, + generic_void, + generic_void, + generic_void, + + generic_always_true, /* input_p */ + generic_always_false, /* output_p */ + io_stream_interactive_p, + io_file_element_type, + + io_stream_length, + io_stream_get_position, + io_stream_set_position, + generic_column, + io_stream_close }; /********************************************************************** @@ -3660,206 +3657,206 @@ static cl_index winsock_stream_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - cl_index len = 0; + cl_index len = 0; - unlikely_if (strm->stream.byte_stack != ECL_NIL) { - return consume_byte_stack(strm, c, n); - } - if(n > 0) { - SOCKET s = (SOCKET)IO_FILE_DESCRIPTOR(strm); - unlikely_if (INVALID_SOCKET == s) { - wrong_file_handler(strm); - } else { - ecl_disable_interrupts(); - len = recv(s, c, n, 0); - unlikely_if (len == SOCKET_ERROR) - wsock_error("Cannot read bytes from Windows " - "socket ~S.~%~A", strm); - ecl_enable_interrupts(); - } - } - return (len > 0) ? len : EOF; + unlikely_if (strm->stream.byte_stack != ECL_NIL) { + return consume_byte_stack(strm, c, n); + } + if(n > 0) { + SOCKET s = (SOCKET)IO_FILE_DESCRIPTOR(strm); + unlikely_if (INVALID_SOCKET == s) { + wrong_file_handler(strm); + } else { + ecl_disable_interrupts(); + len = recv(s, c, n, 0); + unlikely_if (len == SOCKET_ERROR) + wsock_error("Cannot read bytes from Windows " + "socket ~S.~%~A", strm); + ecl_enable_interrupts(); + } + } + return (len > 0) ? len : EOF; } static cl_index winsock_stream_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - cl_index out = 0; - unsigned char *endp; - unsigned char *p; - SOCKET s = (SOCKET)IO_FILE_DESCRIPTOR(strm); - unlikely_if (INVALID_SOCKET == s) { - wrong_file_handler(strm); - } else { - ecl_disable_interrupts(); - do { - cl_index res = send(s, c + out, n, 0); - unlikely_if (res == SOCKET_ERROR) { - wsock_error("Cannot write bytes to Windows" - " socket ~S.~%~A", strm); - break; /* stop writing */ - } else { - out += res; - n -= res; - } - } while (n > 0); - ecl_enable_interrupts(); - } - return out; + cl_index out = 0; + unsigned char *endp; + unsigned char *p; + SOCKET s = (SOCKET)IO_FILE_DESCRIPTOR(strm); + unlikely_if (INVALID_SOCKET == s) { + wrong_file_handler(strm); + } else { + ecl_disable_interrupts(); + do { + cl_index res = send(s, c + out, n, 0); + unlikely_if (res == SOCKET_ERROR) { + wsock_error("Cannot write bytes to Windows" + " socket ~S.~%~A", strm); + break; /* stop writing */ + } else { + out += res; + n -= res; + } + } while (n > 0); + ecl_enable_interrupts(); + } + return out; } static int winsock_stream_listen(cl_object strm) { - SOCKET s; - unlikely_if (strm->stream.byte_stack != ECL_NIL) { - return ECL_LISTEN_AVAILABLE; - } - s = (SOCKET)IO_FILE_DESCRIPTOR(strm); - unlikely_if (INVALID_SOCKET == s) { - wrong_file_handler(strm); - } - { - struct timeval tv = { 0, 0 }; - fd_set fds; - cl_index result; + SOCKET s; + unlikely_if (strm->stream.byte_stack != ECL_NIL) { + return ECL_LISTEN_AVAILABLE; + } + s = (SOCKET)IO_FILE_DESCRIPTOR(strm); + unlikely_if (INVALID_SOCKET == s) { + wrong_file_handler(strm); + } + { + struct timeval tv = { 0, 0 }; + fd_set fds; + cl_index result; - FD_ZERO( &fds ); - FD_SET(s, &fds); - ecl_disable_interrupts(); - result = select( 0, &fds, NULL, NULL, &tv ); - unlikely_if (result == SOCKET_ERROR) - wsock_error("Cannot listen on Windows " - "socket ~S.~%~A", strm ); - ecl_enable_interrupts(); - return ( result > 0 - ? ECL_LISTEN_AVAILABLE - : ECL_LISTEN_NO_CHAR ); - } + FD_ZERO( &fds ); + FD_SET(s, &fds); + ecl_disable_interrupts(); + result = select( 0, &fds, NULL, NULL, &tv ); + unlikely_if (result == SOCKET_ERROR) + wsock_error("Cannot listen on Windows " + "socket ~S.~%~A", strm ); + ecl_enable_interrupts(); + return ( result > 0 + ? ECL_LISTEN_AVAILABLE + : ECL_LISTEN_NO_CHAR ); + } } static void winsock_stream_clear_input(cl_object strm) { - while (winsock_stream_listen(strm) == ECL_LISTEN_AVAILABLE) { - eformat_read_char(strm); - } + while (winsock_stream_listen(strm) == ECL_LISTEN_AVAILABLE) { + eformat_read_char(strm); + } } static cl_object winsock_stream_close(cl_object strm) { - SOCKET s = (SOCKET) IO_FILE_DESCRIPTOR(strm); - int failed; - ecl_disable_interrupts(); - failed = closesocket(s); - ecl_enable_interrupts(); - unlikely_if (failed < 0) - cannot_close(strm); - IO_FILE_DESCRIPTOR(strm) = (int)INVALID_SOCKET; - return generic_close(strm); + SOCKET s = (SOCKET) IO_FILE_DESCRIPTOR(strm); + int failed; + ecl_disable_interrupts(); + failed = closesocket(s); + ecl_enable_interrupts(); + unlikely_if (failed < 0) + cannot_close(strm); + IO_FILE_DESCRIPTOR(strm) = (int)INVALID_SOCKET; + return generic_close(strm); } const struct ecl_file_ops winsock_stream_io_ops = { - winsock_stream_write_byte8, - winsock_stream_read_byte8, + winsock_stream_write_byte8, + winsock_stream_read_byte8, - generic_write_byte, - generic_read_byte, + generic_write_byte, + generic_read_byte, - eformat_read_char, - eformat_write_char, - eformat_unread_char, - generic_peek_char, - - generic_read_vector, - generic_write_vector, - - winsock_stream_listen, - winsock_stream_clear_input, - generic_void, - generic_void, - generic_void, - - generic_always_true, /* input_p */ - generic_always_true, /* output_p */ - generic_always_false, - winsock_stream_element_type, - - not_a_file_stream, - not_implemented_get_position, - not_implemented_set_position, - generic_column, + eformat_read_char, + eformat_write_char, + eformat_unread_char, + generic_peek_char, + + generic_read_vector, + generic_write_vector, + + winsock_stream_listen, + winsock_stream_clear_input, + generic_void, + generic_void, + generic_void, + + generic_always_true, /* input_p */ + generic_always_true, /* output_p */ + generic_always_false, + winsock_stream_element_type, + + not_a_file_stream, + not_implemented_get_position, + not_implemented_set_position, + generic_column, - winsock_stream_close + winsock_stream_close }; const struct ecl_file_ops winsock_stream_output_ops = { - winsock_stream_write_byte8, - not_input_read_byte8, + winsock_stream_write_byte8, + not_input_read_byte8, - generic_write_byte, - not_input_read_byte, + generic_write_byte, + not_input_read_byte, - not_input_read_char, - eformat_write_char, - not_input_unread_char, - generic_peek_char, - - generic_read_vector, - generic_write_vector, - - not_input_listen, - not_input_clear_input, - generic_void, - generic_void, - generic_void, - - generic_always_false, /* input_p */ - generic_always_true, /* output_p */ - generic_always_false, - winsock_stream_element_type, - - not_a_file_stream, - not_implemented_get_position, - not_implemented_set_position, - generic_column, + not_input_read_char, + eformat_write_char, + not_input_unread_char, + generic_peek_char, + + generic_read_vector, + generic_write_vector, + + not_input_listen, + not_input_clear_input, + generic_void, + generic_void, + generic_void, + + generic_always_false, /* input_p */ + generic_always_true, /* output_p */ + generic_always_false, + winsock_stream_element_type, + + not_a_file_stream, + not_implemented_get_position, + not_implemented_set_position, + generic_column, - winsock_stream_close + winsock_stream_close }; const struct ecl_file_ops winsock_stream_input_ops = { - not_output_write_byte8, - winsock_stream_read_byte8, + not_output_write_byte8, + winsock_stream_read_byte8, - not_output_write_byte, - generic_read_byte, + not_output_write_byte, + generic_read_byte, - eformat_read_char, - not_output_write_char, - eformat_unread_char, - generic_peek_char, - - generic_read_vector, - generic_write_vector, - - winsock_stream_listen, - winsock_stream_clear_input, - not_output_clear_output, - not_output_finish_output, - not_output_force_output, - - generic_always_true, /* input_p */ - generic_always_false, /* output_p */ - generic_always_false, - winsock_stream_element_type, - - not_a_file_stream, - not_implemented_get_position, - not_implemented_set_position, - generic_column, + eformat_read_char, + not_output_write_char, + eformat_unread_char, + generic_peek_char, + + generic_read_vector, + generic_write_vector, + + winsock_stream_listen, + winsock_stream_clear_input, + not_output_clear_output, + not_output_finish_output, + not_output_force_output, + + generic_always_true, /* input_p */ + generic_always_false, /* output_p */ + generic_always_false, + winsock_stream_element_type, + + not_a_file_stream, + not_implemented_get_position, + not_implemented_set_position, + generic_column, - winsock_stream_close + winsock_stream_close }; #endif @@ -3874,110 +3871,110 @@ static cl_index wcon_stream_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - unlikely_if (strm->stream.byte_stack != ECL_NIL) { - return consume_byte_stack(strm, c, n); - } else { - cl_index len = 0; - cl_env_ptr the_env = ecl_process_env(); - HANDLE h = (HANDLE)IO_FILE_DESCRIPTOR(strm); - DWORD nchars; - unsigned char aux[4]; - for (len = 0; len < n; ) { - int i, ok; - ecl_disable_interrupts_env(the_env); - ok = ReadConsole(h, &aux, 1, &nchars, NULL); - ecl_enable_interrupts_env(the_env); - unlikely_if (!ok) { - FEwin32_error("Cannot read from console", 0); - } - for (i = 0; i < nchars; i++) { - if (len < n) { - c[len++] = aux[i]; - } else { - strm->stream.byte_stack = - ecl_nconc(strm->stream.byte_stack, - ecl_list1(ecl_make_fixnum(aux[i]))); - } - } - } - return (len > 0) ? len : EOF; - } + unlikely_if (strm->stream.byte_stack != ECL_NIL) { + return consume_byte_stack(strm, c, n); + } else { + cl_index len = 0; + cl_env_ptr the_env = ecl_process_env(); + HANDLE h = (HANDLE)IO_FILE_DESCRIPTOR(strm); + DWORD nchars; + unsigned char aux[4]; + for (len = 0; len < n; ) { + int i, ok; + ecl_disable_interrupts_env(the_env); + ok = ReadConsole(h, &aux, 1, &nchars, NULL); + ecl_enable_interrupts_env(the_env); + unlikely_if (!ok) { + FEwin32_error("Cannot read from console", 0); + } + for (i = 0; i < nchars; i++) { + if (len < n) { + c[len++] = aux[i]; + } else { + strm->stream.byte_stack = + ecl_nconc(strm->stream.byte_stack, + ecl_list1(ecl_make_fixnum(aux[i]))); + } + } + } + return (len > 0) ? len : EOF; + } } static cl_index wcon_stream_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - HANDLE h = (HANDLE)IO_FILE_DESCRIPTOR(strm); - DWORD nchars; - unlikely_if(!WriteConsole(h, c, n, &nchars, NULL)) { - FEwin32_error("Cannot write to console.", 0); - } - return nchars; + HANDLE h = (HANDLE)IO_FILE_DESCRIPTOR(strm); + DWORD nchars; + unlikely_if(!WriteConsole(h, c, n, &nchars, NULL)) { + FEwin32_error("Cannot write to console.", 0); + } + return nchars; } static int wcon_stream_listen(cl_object strm) { - HANDLE h = (HANDLE)IO_FILE_DESCRIPTOR(strm); - INPUT_RECORD aux; - DWORD nevents; - do { - unlikely_if(!PeekConsoleInput(h, &aux, 1, &nevents)) - FEwin32_error("Cannot read from console.", 0); - if (nevents == 0) - return 0; - if (aux.EventType == KEY_EVENT) - return 1; - unlikely_if(!ReadConsoleInput(h, &aux, 1, &nevents)) - FEwin32_error("Cannot read from console.", 0); - } while (1); + HANDLE h = (HANDLE)IO_FILE_DESCRIPTOR(strm); + INPUT_RECORD aux; + DWORD nevents; + do { + unlikely_if(!PeekConsoleInput(h, &aux, 1, &nevents)) + FEwin32_error("Cannot read from console.", 0); + if (nevents == 0) + return 0; + if (aux.EventType == KEY_EVENT) + return 1; + unlikely_if(!ReadConsoleInput(h, &aux, 1, &nevents)) + FEwin32_error("Cannot read from console.", 0); + } while (1); } static void wcon_stream_clear_input(cl_object strm) { - FlushConsoleInputBuffer((HANDLE)IO_FILE_DESCRIPTOR(strm)); + FlushConsoleInputBuffer((HANDLE)IO_FILE_DESCRIPTOR(strm)); } static void wcon_stream_force_output(cl_object strm) { - DWORD nchars; - WriteConsole((HANDLE)IO_FILE_DESCRIPTOR(strm), 0, 0, &nchars, NULL); + DWORD nchars; + WriteConsole((HANDLE)IO_FILE_DESCRIPTOR(strm), 0, 0, &nchars, NULL); } const struct ecl_file_ops wcon_stream_io_ops = { - wcon_stream_write_byte8, - wcon_stream_read_byte8, + wcon_stream_write_byte8, + wcon_stream_read_byte8, - generic_write_byte, - generic_read_byte, + generic_write_byte, + generic_read_byte, - eformat_read_char, - eformat_write_char, - eformat_unread_char, - generic_peek_char, - - generic_read_vector, - generic_write_vector, - - wcon_stream_listen, - wcon_stream_clear_input, - generic_void, - wcon_stream_force_output, - wcon_stream_force_output, - - generic_always_true, /* input_p */ - generic_always_true, /* output_p */ - generic_always_false, - wcon_stream_element_type, - - not_a_file_stream, - not_implemented_get_position, - not_implemented_set_position, - generic_column, + eformat_read_char, + eformat_write_char, + eformat_unread_char, + generic_peek_char, + + generic_read_vector, + generic_write_vector, + + wcon_stream_listen, + wcon_stream_clear_input, + generic_void, + wcon_stream_force_output, + wcon_stream_force_output, + + generic_always_true, /* input_p */ + generic_always_true, /* output_p */ + generic_always_false, + wcon_stream_element_type, + + not_a_file_stream, + not_implemented_get_position, + not_implemented_set_position, + generic_column, - generic_close, + generic_close, }; #define CONTROL_Z 26 @@ -3987,22 +3984,22 @@ cl_fixnum byte_size, int flags, cl_object external_format) { - int desc = fileno(f); - cl_object output; - if (isatty(desc)) { - output = ecl_make_stream_from_FILE - (fname, - (void*)_get_osfhandle(desc), - ecl_smm_io_wcon, - byte_size, flags, - external_format); - output->stream.eof_char = CONTROL_Z; - } else { - output = ecl_make_stream_from_FILE - (fname, f, smm, byte_size, flags, - external_format); - } - return output; + int desc = fileno(f); + cl_object output; + if (isatty(desc)) { + output = ecl_make_stream_from_FILE + (fname, + (void*)_get_osfhandle(desc), + ecl_smm_io_wcon, + byte_size, flags, + external_format); + output->stream.eof_char = CONTROL_Z; + } else { + output = ecl_make_stream_from_FILE + (fname, f, smm, byte_size, flags, + external_format); + } + return output; } static cl_object @@ -4010,29 +4007,29 @@ cl_fixnum byte_size, int flags, cl_object external_format) { - cl_object output; - if (isatty(desc)) { - output = ecl_make_stream_from_FILE - (fname, - (void*)_get_osfhandle(desc), - ecl_smm_io_wcon, - byte_size, flags, - external_format); - output->stream.eof_char = CONTROL_Z; - } else { - /* Windows changes the newline characters for \r\n - * even when using read()/write() */ - if (ecl_option_values[ECL_OPT_USE_SETMODE_ON_FILES]) { - _setmode(desc, _O_BINARY); - } else { - external_format = ECL_CONS_CDR(external_format); - } - output = ecl_make_file_stream_from_fd - (fname, desc, smm, - byte_size, flags, - external_format); - } - return output; + cl_object output; + if (isatty(desc)) { + output = ecl_make_stream_from_FILE + (fname, + (void*)_get_osfhandle(desc), + ecl_smm_io_wcon, + byte_size, flags, + external_format); + output->stream.eof_char = CONTROL_Z; + } else { + /* Windows changes the newline characters for \r\n + * even when using read()/write() */ + if (ecl_option_values[ECL_OPT_USE_SETMODE_ON_FILES]) { + _setmode(desc, _O_BINARY); + } else { + external_format = ECL_CONS_CDR(external_format); + } + output = ecl_make_file_stream_from_fd + (fname, desc, smm, + byte_size, flags, + external_format); + } + return output; } #else #define maybe_make_windows_console_FILE ecl_make_stream_from_FILE @@ -4042,188 +4039,189 @@ cl_object si_set_buffering_mode(cl_object stream, cl_object buffer_mode_symbol) { - enum ecl_smmode mode = stream->stream.mode; - int buffer_mode; - - unlikely_if (!ECL_ANSI_STREAM_P(stream)) { - FEerror("Cannot set buffer of ~A", 1, stream); - } + enum ecl_smmode mode = stream->stream.mode; + int buffer_mode; - if (buffer_mode_symbol == @':none' || Null(buffer_mode_symbol)) - buffer_mode = _IONBF; - else if (buffer_mode_symbol == @':line' || buffer_mode_symbol == @':line-buffered') - buffer_mode = _IOLBF; - else if (buffer_mode_symbol == @':full' || buffer_mode_symbol == @':fully-buffered') - buffer_mode = _IOFBF; - else - FEerror("Not a valid buffering mode: ~A", 1, buffer_mode_symbol); - - if (mode == ecl_smm_output || mode == ecl_smm_io || mode == ecl_smm_input) { - FILE *fp = IO_STREAM_FILE(stream); - - if (buffer_mode != _IONBF) { - cl_index buffer_size = BUFSIZ; - char *new_buffer = ecl_alloc_atomic(buffer_size); - stream->stream.buffer = new_buffer; - setvbuf(fp, new_buffer, buffer_mode, buffer_size); - } else - setvbuf(fp, NULL, _IONBF, 0); - } - @(return stream) + unlikely_if (!ECL_ANSI_STREAM_P(stream)) { + FEerror("Cannot set buffer of ~A", 1, stream); + } + + if (buffer_mode_symbol == @':none' || Null(buffer_mode_symbol)) + buffer_mode = _IONBF; + else if (buffer_mode_symbol == @':line' || buffer_mode_symbol == @':line-buffered') + buffer_mode = _IOLBF; + else if (buffer_mode_symbol == @':full' || buffer_mode_symbol == @':fully-buffered') + buffer_mode = _IOFBF; + else + FEerror("Not a valid buffering mode: ~A", 1, buffer_mode_symbol); + + if (mode == ecl_smm_output || mode == ecl_smm_io || mode == ecl_smm_input) { + FILE *fp = IO_STREAM_FILE(stream); + + if (buffer_mode != _IONBF) { + cl_index buffer_size = BUFSIZ; + char *new_buffer = ecl_alloc_atomic(buffer_size); + stream->stream.buffer = new_buffer; + setvbuf(fp, new_buffer, buffer_mode, buffer_size); + } else + setvbuf(fp, NULL, _IONBF, 0); + } + @(return stream); } cl_object ecl_make_stream_from_FILE(cl_object fname, void *f, enum ecl_smmode smm, cl_fixnum byte_size, int flags, cl_object external_format) { - cl_object stream; - stream = alloc_stream(); - stream->stream.mode = (short)smm; - stream->stream.closed = 0; - switch (smm) { - case ecl_smm_io: - stream->stream.ops = duplicate_dispatch_table(&io_stream_ops); - break; - case ecl_smm_probe: - case ecl_smm_input: - stream->stream.ops = duplicate_dispatch_table(&input_stream_ops); - break; - case ecl_smm_output: - stream->stream.ops = duplicate_dispatch_table(&output_stream_ops); - break; + cl_object stream; + stream = alloc_stream(); + stream->stream.mode = (short)smm; + stream->stream.closed = 0; + switch (smm) { + case ecl_smm_io: + stream->stream.ops = duplicate_dispatch_table(&io_stream_ops); + break; + case ecl_smm_probe: + case ecl_smm_input: + stream->stream.ops = duplicate_dispatch_table(&input_stream_ops); + break; + case ecl_smm_output: + stream->stream.ops = duplicate_dispatch_table(&output_stream_ops); + break; #if defined(ECL_WSOCK) - case ecl_smm_input_wsock: - stream->stream.ops = duplicate_dispatch_table(&winsock_stream_input_ops); - break; - case ecl_smm_output_wsock: - stream->stream.ops = duplicate_dispatch_table(&winsock_stream_output_ops); - break; - case ecl_smm_io_wsock: - stream->stream.ops = duplicate_dispatch_table(&winsock_stream_io_ops); - break; - case ecl_smm_io_wcon: - stream->stream.ops = duplicate_dispatch_table(&wcon_stream_io_ops); - break; -#endif - default: - FEerror("Not a valid mode ~D for ecl_make_stream_from_FILE", 1, ecl_make_fixnum(smm)); - } - set_stream_elt_type(stream, byte_size, flags, external_format); - IO_STREAM_FILENAME(stream) = fname; /* not really used */ - stream->stream.column = 0; - IO_STREAM_FILE(stream) = f; - stream->stream.last_op = 0; - si_set_finalizer(stream, ECL_T); - return stream; + case ecl_smm_input_wsock: + stream->stream.ops = duplicate_dispatch_table(&winsock_stream_input_ops); + break; + case ecl_smm_output_wsock: + stream->stream.ops = duplicate_dispatch_table(&winsock_stream_output_ops); + break; + case ecl_smm_io_wsock: + stream->stream.ops = duplicate_dispatch_table(&winsock_stream_io_ops); + break; + case ecl_smm_io_wcon: + stream->stream.ops = duplicate_dispatch_table(&wcon_stream_io_ops); + break; +#endif + default: + FEerror("Not a valid mode ~D for ecl_make_stream_from_FILE", 1, ecl_make_fixnum(smm)); + } + set_stream_elt_type(stream, byte_size, flags, external_format); + IO_STREAM_FILENAME(stream) = fname; /* not really used */ + stream->stream.column = 0; + IO_STREAM_FILE(stream) = f; + stream->stream.last_op = 0; + si_set_finalizer(stream, ECL_T); + return stream; } cl_object ecl_make_stream_from_fd(cl_object fname, int fd, enum ecl_smmode smm, cl_fixnum byte_size, int flags, cl_object external_format) { - char *mode; /* file open mode */ - FILE *fp; /* file pointer */ - switch(smm) { - case ecl_smm_input: - mode = OPEN_R; - break; - case ecl_smm_output: - mode = OPEN_W; - break; - case ecl_smm_io: - mode = OPEN_RW; - break; + char *mode; /* file open mode */ + FILE *fp; /* file pointer */ + switch(smm) { + case ecl_smm_input: + mode = OPEN_R; + break; + case ecl_smm_output: + mode = OPEN_W; + break; + case ecl_smm_io: + mode = OPEN_RW; + break; #if defined(ECL_WSOCK) - case ecl_smm_input_wsock: - case ecl_smm_output_wsock: - case ecl_smm_io_wsock: - case ecl_smm_io_wcon: - break; -#endif - default: - FEerror("make_stream: wrong mode", 0); - } + case ecl_smm_input_wsock: + case ecl_smm_output_wsock: + case ecl_smm_io_wsock: + case ecl_smm_io_wcon: + break; +#endif + default: + FEerror("make_stream: wrong mode", 0); + } #if defined(ECL_WSOCK) - if (smm == ecl_smm_input_wsock || smm == ecl_smm_output_wsock || smm == ecl_smm_io_wsock || smm == ecl_smm_io_wcon) - fp = (FILE*)fd; - else - fp = safe_fdopen(fd, mode); + if (smm == ecl_smm_input_wsock || smm == ecl_smm_output_wsock || smm == ecl_smm_io_wsock || smm == ecl_smm_io_wcon) + fp = (FILE*)fd; + else + fp = safe_fdopen(fd, mode); #else - fp = safe_fdopen(fd, mode); + fp = safe_fdopen(fd, mode); #endif - if (fp == NULL) { - FElibc_error("Unable to create stream for file descriptor ~D", - 1, ecl_make_integer(fd)); - } - return ecl_make_stream_from_FILE(fname, fp, smm, byte_size, flags, - external_format); + if (fp == NULL) { + FElibc_error("Unable to create stream for file descriptor ~D", + 1, ecl_make_integer(fd)); + } + return ecl_make_stream_from_FILE(fname, fp, smm, byte_size, flags, + external_format); } int ecl_stream_to_handle(cl_object s, bool output) { BEGIN: - if (ecl_unlikely(!ECL_ANSI_STREAM_P(s))) - return -1; - switch ((enum ecl_smmode)s->stream.mode) { - case ecl_smm_input: - if (output) return -1; - return fileno(IO_STREAM_FILE(s)); - case ecl_smm_input_file: - if (output) return -1; - return IO_FILE_DESCRIPTOR(s); - case ecl_smm_output: - if (!output) return -1; - return fileno(IO_STREAM_FILE(s)); - case ecl_smm_output_file: - if (!output) return -1; - return IO_FILE_DESCRIPTOR(s); - case ecl_smm_io: - return fileno(IO_STREAM_FILE(s)); - case ecl_smm_io_file: - return IO_FILE_DESCRIPTOR(s); - case ecl_smm_synonym: - s = SYNONYM_STREAM_STREAM(s); - goto BEGIN; - case ecl_smm_two_way: - s = output? TWO_WAY_STREAM_OUTPUT(s) : TWO_WAY_STREAM_INPUT(s); - goto BEGIN; + if (ecl_unlikely(!ECL_ANSI_STREAM_P(s))) + return -1; + switch ((enum ecl_smmode)s->stream.mode) { + case ecl_smm_input: + if (output) return -1; + return fileno(IO_STREAM_FILE(s)); + case ecl_smm_input_file: + if (output) return -1; + return IO_FILE_DESCRIPTOR(s); + case ecl_smm_output: + if (!output) return -1; + return fileno(IO_STREAM_FILE(s)); + case ecl_smm_output_file: + if (!output) return -1; + return IO_FILE_DESCRIPTOR(s); + case ecl_smm_io: + return fileno(IO_STREAM_FILE(s)); + case ecl_smm_io_file: + return IO_FILE_DESCRIPTOR(s); + case ecl_smm_synonym: + s = SYNONYM_STREAM_STREAM(s); + goto BEGIN; + case ecl_smm_two_way: + s = output? TWO_WAY_STREAM_OUTPUT(s) : TWO_WAY_STREAM_INPUT(s); + goto BEGIN; #if defined(ECL_WSOCK) - case ecl_smm_input_wsock: - case ecl_smm_output_wsock: - case ecl_smm_io_wsock: + case ecl_smm_input_wsock: + case ecl_smm_output_wsock: + case ecl_smm_io_wsock: #endif #if defined(ECL_MS_WINDOWS_HOST) - case ecl_smm_io_wcon: + case ecl_smm_io_wcon: #endif - default: - return -1; - } + default: + return -1; + } } cl_object si_file_stream_fd(cl_object s) { - cl_object ret; - - unlikely_if (!ECL_ANSI_STREAM_P(s)) - FEerror("file_stream_fd: not a stream", 0); + cl_object ret; - switch ((enum ecl_smmode)s->stream.mode) { - case ecl_smm_input: - case ecl_smm_output: - case ecl_smm_io: - ret = ecl_make_fixnum(fileno(IO_STREAM_FILE(s))); - break; - case ecl_smm_input_file: - case ecl_smm_output_file: - case ecl_smm_io_file: - ret = ecl_make_fixnum(IO_FILE_DESCRIPTOR(s)); - break; - default: - ecl_internal_error("not a file stream"); - } - @(return ret); + unlikely_if (!ECL_FILE_STREAM_P(s)) { + not_a_file_stream(s); + } + + switch ((enum ecl_smmode)s->stream.mode) { + case ecl_smm_input: + case ecl_smm_output: + case ecl_smm_io: + ret = ecl_make_fixnum(fileno(IO_STREAM_FILE(s))); + break; + case ecl_smm_input_file: + case ecl_smm_output_file: + case ecl_smm_io_file: + ret = ecl_make_fixnum(IO_FILE_DESCRIPTOR(s)); + break; + default: + ecl_internal_error("not a file stream"); + } + @(return ret); } /********************************************************************** @@ -4233,154 +4231,154 @@ static cl_index seq_in_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - cl_fixnum curr_pos = SEQ_INPUT_POSITION(strm); - cl_fixnum last = SEQ_INPUT_LIMIT(strm); - cl_fixnum delta = last - curr_pos; - if (delta > 0) { - cl_object vector = SEQ_INPUT_VECTOR(strm); - if (delta > n) delta = n; - memcpy(c, vector->vector.self.bc + curr_pos, delta); - SEQ_INPUT_POSITION(strm) += delta; - return delta; - } - return 0; + cl_fixnum curr_pos = SEQ_INPUT_POSITION(strm); + cl_fixnum last = SEQ_INPUT_LIMIT(strm); + cl_fixnum delta = last - curr_pos; + if (delta > 0) { + cl_object vector = SEQ_INPUT_VECTOR(strm); + if (delta > n) delta = n; + memcpy(c, vector->vector.self.bc + curr_pos, delta); + SEQ_INPUT_POSITION(strm) += delta; + return delta; + } + return 0; } static void seq_in_unread_char(cl_object strm, ecl_character c) { - eformat_unread_char(strm, c); - SEQ_INPUT_POSITION(strm) -= ecl_length(strm->stream.byte_stack); - strm->stream.byte_stack = ECL_NIL; + eformat_unread_char(strm, c); + SEQ_INPUT_POSITION(strm) -= ecl_length(strm->stream.byte_stack); + strm->stream.byte_stack = ECL_NIL; } static int seq_in_listen(cl_object strm) { - if (SEQ_INPUT_POSITION(strm) < SEQ_INPUT_LIMIT(strm)) - return ECL_LISTEN_AVAILABLE; - else - return ECL_LISTEN_EOF; + if (SEQ_INPUT_POSITION(strm) < SEQ_INPUT_LIMIT(strm)) + return ECL_LISTEN_AVAILABLE; + else + return ECL_LISTEN_EOF; } static cl_object seq_in_get_position(cl_object strm) { - return ecl_make_unsigned_integer(SEQ_INPUT_POSITION(strm)); + return ecl_make_unsigned_integer(SEQ_INPUT_POSITION(strm)); } static cl_object seq_in_set_position(cl_object strm, cl_object pos) { - cl_fixnum disp; - if (Null(pos)) { - disp = SEQ_INPUT_LIMIT(strm); - } else { - disp = ecl_to_size(pos); - if (disp >= SEQ_INPUT_LIMIT(strm)) { - disp = SEQ_INPUT_LIMIT(strm); - } - } - SEQ_INPUT_POSITION(strm) = disp; - return ECL_T; + cl_fixnum disp; + if (Null(pos)) { + disp = SEQ_INPUT_LIMIT(strm); + } else { + disp = ecl_to_size(pos); + if (disp >= SEQ_INPUT_LIMIT(strm)) { + disp = SEQ_INPUT_LIMIT(strm); + } + } + SEQ_INPUT_POSITION(strm) = disp; + return ECL_T; } const struct ecl_file_ops seq_in_ops = { - not_output_write_byte8, - seq_in_read_byte8, + not_output_write_byte8, + seq_in_read_byte8, - not_output_write_byte, - generic_read_byte, + not_output_write_byte, + generic_read_byte, - eformat_read_char, - not_output_write_char, - seq_in_unread_char, - generic_peek_char, - - generic_read_vector, - generic_write_vector, - - seq_in_listen, - generic_void, /* clear-input */ - not_output_clear_output, - not_output_finish_output, - not_output_force_output, - - generic_always_true, /* input_p */ - generic_always_false, /* output_p */ - generic_always_false, - io_file_element_type, - - not_a_file_stream, /* length */ - seq_in_get_position, - seq_in_set_position, - generic_column, - generic_close + eformat_read_char, + not_output_write_char, + seq_in_unread_char, + generic_peek_char, + + generic_read_vector, + generic_write_vector, + + seq_in_listen, + generic_void, /* clear-input */ + not_output_clear_output, + not_output_finish_output, + not_output_force_output, + + generic_always_true, /* input_p */ + generic_always_false, /* output_p */ + generic_always_false, + io_file_element_type, + + not_a_file_stream, /* length */ + seq_in_get_position, + seq_in_set_position, + generic_column, + generic_close }; static cl_object make_sequence_input_stream(cl_object vector, cl_index istart, cl_index iend, - cl_object external_format) + cl_object external_format) { - cl_object strm; - cl_elttype type; - cl_object type_name; - int byte_size; - int flags = 0; - if (!ECL_VECTORP(vector) || - ((type = ecl_array_elttype(vector)) < ecl_aet_b8 && - type > ecl_aet_bc) || - ecl_aet_size[type] != 1) - { - FEerror("MAKE-SEQUENCE-INPUT-STREAM only accepts vectors whose element has a size of 1 byte.~%~A", 1, vector); - } - type_name = ecl_elttype_to_symbol(type); - byte_size = ecl_normalize_stream_element_type(type_name); - /* Character streams always get some external format. For binary - * sequences it has to be explicitly mentioned. */ - strm = alloc_stream(); - strm->stream.ops = duplicate_dispatch_table(&seq_in_ops); - strm->stream.mode = (short)ecl_smm_sequence_input; - if (!byte_size) { + cl_object strm; + cl_elttype type; + cl_object type_name; + int byte_size; + int flags = 0; + if (!ECL_VECTORP(vector) || + ((type = ecl_array_elttype(vector)) < ecl_aet_b8 && + type > ecl_aet_bc) || + ecl_aet_size[type] != 1) + { + FEerror("MAKE-SEQUENCE-INPUT-STREAM only accepts vectors whose element has a size of 1 byte.~%~A", 1, vector); + } + type_name = ecl_elttype_to_symbol(type); + byte_size = ecl_normalize_stream_element_type(type_name); + /* Character streams always get some external format. For binary + * sequences it has to be explicitly mentioned. */ + strm = alloc_stream(); + strm->stream.ops = duplicate_dispatch_table(&seq_in_ops); + strm->stream.mode = (short)ecl_smm_sequence_input; + if (!byte_size) { #if defined(ECL_UNICODE) - if (ECL_BASE_STRING_P(vector)) { - if (Null(external_format)) - external_format = @':default'; - } else { - if (Null(external_format)) { + if (ECL_BASE_STRING_P(vector)) { + if (Null(external_format)) + external_format = @':default'; + } else { + if (Null(external_format)) { # ifdef WORDS_BIGENDIAN - external_format = @':ucs-4be'; + external_format = @':ucs-4be'; # else - external_format = @':ucs-4le'; + external_format = @':ucs-4le'; # endif - } - } + } + } #else - if (Null(external_format)) { - external_format = @':default'; - } -#endif - } - set_stream_elt_type(strm, byte_size, flags, external_format); - /* Override byte size and elt type */ - if (byte_size) strm->stream.byte_size = byte_size; - SEQ_INPUT_VECTOR(strm) = vector; - SEQ_INPUT_POSITION(strm) = istart; - SEQ_INPUT_LIMIT(strm) = iend; - return strm; + if (Null(external_format)) { + external_format = @':default'; + } +#endif + } + set_stream_elt_type(strm, byte_size, flags, external_format); + /* Override byte size and elt type */ + if (byte_size) strm->stream.byte_size = byte_size; + SEQ_INPUT_VECTOR(strm) = vector; + SEQ_INPUT_POSITION(strm) = istart; + SEQ_INPUT_LIMIT(strm) = iend; + return strm; } @(defun ext::make_sequence_input_stream (vector &key (start ecl_make_fixnum(0)) (end ECL_NIL) (external_format ECL_NIL)) - cl_index_pair p; -@ - p = ecl_vector_start_end(@[ext::make-sequence-input-stream], - vector, start, end); - @(return make_sequence_input_stream(vector, p.start, p.end, - external_format)) -@) + cl_index_pair p; + @ + p = ecl_vector_start_end(@[ext::make-sequence-input-stream], + vector, start, end); + @(return make_sequence_input_stream(vector, p.start, p.end, + external_format)) + @) /********************************************************************** * SEQUENCE OUTPUT STREAMS @@ -4390,135 +4388,135 @@ seq_out_write_byte8(cl_object strm, unsigned char *c, cl_index n) { AGAIN: - { - cl_object vector = SEQ_OUTPUT_VECTOR(strm); - cl_fixnum curr_pos = SEQ_OUTPUT_POSITION(strm); - cl_fixnum last = vector->vector.dim; - cl_fixnum delta = last - curr_pos; - if (delta < n) { - /* Not enough space, enlarge */ - vector = _ecl_funcall3(@'adjust-array', vector, - ecl_ash(ecl_make_fixnum(last), 1)); - SEQ_OUTPUT_VECTOR(strm) = vector; - goto AGAIN; - } - memcpy(vector->vector.self.bc + curr_pos, c, n); - SEQ_OUTPUT_POSITION(strm) = curr_pos += n; - if (vector->vector.fillp < curr_pos) - vector->vector.fillp = curr_pos; - } - return n; + { + cl_object vector = SEQ_OUTPUT_VECTOR(strm); + cl_fixnum curr_pos = SEQ_OUTPUT_POSITION(strm); + cl_fixnum last = vector->vector.dim; + cl_fixnum delta = last - curr_pos; + if (delta < n) { + /* Not enough space, enlarge */ + vector = _ecl_funcall3(@'adjust-array', vector, + ecl_ash(ecl_make_fixnum(last), 1)); + SEQ_OUTPUT_VECTOR(strm) = vector; + goto AGAIN; + } + memcpy(vector->vector.self.bc + curr_pos, c, n); + SEQ_OUTPUT_POSITION(strm) = curr_pos += n; + if (vector->vector.fillp < curr_pos) + vector->vector.fillp = curr_pos; + } + return n; } static cl_object seq_out_get_position(cl_object strm) { - return ecl_make_unsigned_integer(SEQ_OUTPUT_POSITION(strm)); + return ecl_make_unsigned_integer(SEQ_OUTPUT_POSITION(strm)); } static cl_object seq_out_set_position(cl_object strm, cl_object pos) { - cl_object vector = SEQ_OUTPUT_VECTOR(strm); - cl_fixnum disp; - if (Null(pos)) { - disp = vector->vector.fillp; - } else { - disp = ecl_to_size(pos); - if (disp >= vector->vector.dim) { - disp = vector->vector.fillp; - } - } - SEQ_OUTPUT_POSITION(strm) = disp; - return ECL_T; + cl_object vector = SEQ_OUTPUT_VECTOR(strm); + cl_fixnum disp; + if (Null(pos)) { + disp = vector->vector.fillp; + } else { + disp = ecl_to_size(pos); + if (disp >= vector->vector.dim) { + disp = vector->vector.fillp; + } + } + SEQ_OUTPUT_POSITION(strm) = disp; + return ECL_T; } const struct ecl_file_ops seq_out_ops = { - seq_out_write_byte8, - not_input_read_byte8, + seq_out_write_byte8, + not_input_read_byte8, - generic_write_byte, - not_input_read_byte, + generic_write_byte, + not_input_read_byte, - not_input_read_char, - eformat_write_char, - not_input_unread_char, - generic_peek_char, - - generic_read_vector, - generic_write_vector, - - not_input_listen, - not_input_clear_input, - generic_void, /* clear-output */ - generic_void, /* finish-output */ - generic_void, /* force-output */ - - generic_always_false, /* input_p */ - generic_always_true, /* output_p */ - generic_always_false, - io_file_element_type, - - not_a_file_stream, /* length */ - seq_out_get_position, - seq_out_set_position, - generic_column, - generic_close + not_input_read_char, + eformat_write_char, + not_input_unread_char, + generic_peek_char, + + generic_read_vector, + generic_write_vector, + + not_input_listen, + not_input_clear_input, + generic_void, /* clear-output */ + generic_void, /* finish-output */ + generic_void, /* force-output */ + + generic_always_false, /* input_p */ + generic_always_true, /* output_p */ + generic_always_false, + io_file_element_type, + + not_a_file_stream, /* length */ + seq_out_get_position, + seq_out_set_position, + generic_column, + generic_close }; static cl_object make_sequence_output_stream(cl_object vector, cl_object external_format) { - cl_object strm; - cl_elttype type; - cl_object type_name; - int byte_size; - int flags = 0; - if (!ECL_VECTORP(vector) || - ((type = ecl_array_elttype(vector)) < ecl_aet_b8 && - type > ecl_aet_bc) || - ecl_aet_size[type] != 1) - { - FEerror("MAKE-SEQUENCE-OUTPUT-STREAM only accepts vectors whose element has a size of 1 byte.~%~A", 1, vector); - } - type_name = ecl_elttype_to_symbol(type); - byte_size = ecl_normalize_stream_element_type(type_name); - /* Character streams always get some external format. For binary - * sequences it has to be explicitly mentioned. */ - strm = alloc_stream(); - strm->stream.ops = duplicate_dispatch_table(&seq_out_ops); - strm->stream.mode = (short)ecl_smm_sequence_output; - if (!byte_size) { + cl_object strm; + cl_elttype type; + cl_object type_name; + int byte_size; + int flags = 0; + if (!ECL_VECTORP(vector) || + ((type = ecl_array_elttype(vector)) < ecl_aet_b8 && + type > ecl_aet_bc) || + ecl_aet_size[type] != 1) + { + FEerror("MAKE-SEQUENCE-OUTPUT-STREAM only accepts vectors whose element has a size of 1 byte.~%~A", 1, vector); + } + type_name = ecl_elttype_to_symbol(type); + byte_size = ecl_normalize_stream_element_type(type_name); + /* Character streams always get some external format. For binary + * sequences it has to be explicitly mentioned. */ + strm = alloc_stream(); + strm->stream.ops = duplicate_dispatch_table(&seq_out_ops); + strm->stream.mode = (short)ecl_smm_sequence_output; + if (!byte_size) { #if defined(ECL_UNICODE) - if (ECL_BASE_STRING_P(vector)) { - if (Null(external_format)) - external_format = @':default'; - } else { - if (Null(external_format)) { + if (ECL_BASE_STRING_P(vector)) { + if (Null(external_format)) + external_format = @':default'; + } else { + if (Null(external_format)) { # ifdef WORDS_BIGENDIAN - external_format = @':ucs-4be'; + external_format = @':ucs-4be'; # else - external_format = @':ucs-4le'; + external_format = @':ucs-4le'; # endif - } - } + } + } #else - if (Null(external_format)) { - external_format = @':default'; - } -#endif - } - set_stream_elt_type(strm, byte_size, flags, external_format); - /* Override byte size and elt type */ - if (byte_size) strm->stream.byte_size = byte_size; - SEQ_OUTPUT_VECTOR(strm) = vector; - SEQ_OUTPUT_POSITION(strm) = vector->vector.fillp; - return strm; + if (Null(external_format)) { + external_format = @':default'; + } +#endif + } + set_stream_elt_type(strm, byte_size, flags, external_format); + /* Override byte size and elt type */ + if (byte_size) strm->stream.byte_size = byte_size; + SEQ_OUTPUT_VECTOR(strm) = vector; + SEQ_OUTPUT_POSITION(strm) = vector->vector.fillp; + return strm; } @(defun ext::make_sequence_output_stream (vector &key (external_format ECL_NIL)) @ - @(return make_sequence_output_stream(vector, external_format)) + @(return make_sequence_output_stream(vector, external_format)); @) /********************************************************************** @@ -4528,151 +4526,151 @@ struct ecl_file_ops * duplicate_dispatch_table(const struct ecl_file_ops *ops) { - struct ecl_file_ops *new_ops = ecl_alloc_atomic(sizeof(*ops)); - *new_ops = *ops; - return new_ops; + struct ecl_file_ops *new_ops = ecl_alloc_atomic(sizeof(*ops)); + *new_ops = *ops; + return new_ops; } const struct ecl_file_ops * stream_dispatch_table(cl_object strm) { #ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) { - return &clos_stream_ops; - } -#endif - if (!ECL_ANSI_STREAM_P(strm)) - FEwrong_type_argument(@[stream], strm); - return (const struct ecl_file_ops *)strm->stream.ops; + if (ECL_INSTANCEP(strm)) { + return &clos_stream_ops; + } +#endif + if (!ECL_ANSI_STREAM_P(strm)) + FEwrong_type_argument(@[stream], strm); + return (const struct ecl_file_ops *)strm->stream.ops; } static cl_index ecl_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - return stream_dispatch_table(strm)->read_byte8(strm, c, n); + return stream_dispatch_table(strm)->read_byte8(strm, c, n); } static cl_index ecl_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - return stream_dispatch_table(strm)->write_byte8(strm, c, n); + return stream_dispatch_table(strm)->write_byte8(strm, c, n); } ecl_character ecl_read_char(cl_object strm) { - return stream_dispatch_table(strm)->read_char(strm); + return stream_dispatch_table(strm)->read_char(strm); } ecl_character ecl_read_char_noeof(cl_object strm) { - ecl_character c = ecl_read_char(strm); - if (c == EOF) - FEend_of_file(strm); - return c; + ecl_character c = ecl_read_char(strm); + if (c == EOF) + FEend_of_file(strm); + return c; } cl_object ecl_read_byte(cl_object strm) { - return stream_dispatch_table(strm)->read_byte(strm); + return stream_dispatch_table(strm)->read_byte(strm); } void ecl_write_byte(cl_object c, cl_object strm) { - stream_dispatch_table(strm)->write_byte(c, strm); + stream_dispatch_table(strm)->write_byte(c, strm); } ecl_character ecl_write_char(ecl_character c, cl_object strm) { - return stream_dispatch_table(strm)->write_char(strm, c); + return stream_dispatch_table(strm)->write_char(strm, c); } void ecl_unread_char(ecl_character c, cl_object strm) { - stream_dispatch_table(strm)->unread_char(strm, c); + stream_dispatch_table(strm)->unread_char(strm, c); } -int +bool ecl_listen_stream(cl_object strm) { - return stream_dispatch_table(strm)->listen(strm); + return stream_dispatch_table(strm)->listen(strm); } void ecl_clear_input(cl_object strm) { - stream_dispatch_table(strm)->clear_input(strm); + stream_dispatch_table(strm)->clear_input(strm); } void ecl_clear_output(cl_object strm) { - stream_dispatch_table(strm)->clear_output(strm); + stream_dispatch_table(strm)->clear_output(strm); } void ecl_force_output(cl_object strm) { - stream_dispatch_table(strm)->force_output(strm); + stream_dispatch_table(strm)->force_output(strm); } void ecl_finish_output(cl_object strm) { - stream_dispatch_table(strm)->finish_output(strm); + stream_dispatch_table(strm)->finish_output(strm); } int ecl_file_column(cl_object strm) { - return stream_dispatch_table(strm)->column(strm); + return stream_dispatch_table(strm)->column(strm); } cl_object ecl_file_length(cl_object strm) { - return stream_dispatch_table(strm)->length(strm); + return stream_dispatch_table(strm)->length(strm); } cl_object ecl_file_position(cl_object strm) { - return stream_dispatch_table(strm)->get_position(strm); + return stream_dispatch_table(strm)->get_position(strm); } cl_object ecl_file_position_set(cl_object strm, cl_object pos) { - return stream_dispatch_table(strm)->set_position(strm, pos); + return stream_dispatch_table(strm)->set_position(strm, pos); } bool ecl_input_stream_p(cl_object strm) { - return stream_dispatch_table(strm)->input_p(strm); + return stream_dispatch_table(strm)->input_p(strm); } bool ecl_output_stream_p(cl_object strm) { - return stream_dispatch_table(strm)->output_p(strm); + return stream_dispatch_table(strm)->output_p(strm); } cl_object ecl_stream_element_type(cl_object strm) { - return stream_dispatch_table(strm)->element_type(strm); + return stream_dispatch_table(strm)->element_type(strm); } -int +bool ecl_interactive_stream_p(cl_object strm) { - return stream_dispatch_table(strm)->interactive_p(strm); + return stream_dispatch_table(strm)->interactive_p(strm); } /* @@ -4687,7 +4685,7 @@ ecl_character ecl_peek_char(cl_object strm) { - return stream_dispatch_table(strm)->peek_char(strm); + return stream_dispatch_table(strm)->peek_char(strm); } /*******************************tl*************************************** @@ -4697,188 +4695,188 @@ void writestr_stream(const char *s, cl_object strm) { - while (*s != '\0') - ecl_write_char(*s++, strm); + while (*s != '\0') + ecl_write_char(*s++, strm); } static cl_index compute_char_size(cl_object stream, ecl_character c) { - unsigned char buffer[5]; - int l = 0; - if (c == ECL_CHAR_CODE_NEWLINE) { - int flags = stream->stream.flags; - if (flags & ECL_STREAM_CR) { - l += stream->stream.encoder(stream, buffer, ECL_CHAR_CODE_RETURN); - if (flags & ECL_STREAM_LF) - l += stream->stream.encoder(stream, buffer, - ECL_CHAR_CODE_LINEFEED); - } else { - l += stream->stream.encoder(stream, buffer, ECL_CHAR_CODE_LINEFEED); - } - } else { - l += stream->stream.encoder(stream, buffer, c); - } - return l; + unsigned char buffer[5]; + int l = 0; + if (c == ECL_CHAR_CODE_NEWLINE) { + int flags = stream->stream.flags; + if (flags & ECL_STREAM_CR) { + l += stream->stream.encoder(stream, buffer, ECL_CHAR_CODE_RETURN); + if (flags & ECL_STREAM_LF) + l += stream->stream.encoder(stream, buffer, + ECL_CHAR_CODE_LINEFEED); + } else { + l += stream->stream.encoder(stream, buffer, ECL_CHAR_CODE_LINEFEED); + } + } else { + l += stream->stream.encoder(stream, buffer, c); + } + return l; } cl_object cl_file_string_length(cl_object stream, cl_object string) { - cl_fixnum l = 0; - /* This is a stupid requirement from the spec. Why returning 1??? - * Why not simply leaving the value unspecified, as with other - * streams one cannot write to??? - */ + cl_fixnum l = 0; + /* This is a stupid requirement from the spec. Why returning 1??? + * Why not simply leaving the value unspecified, as with other + * streams one cannot write to??? + */ BEGIN: #ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(stream)) { - @(return ECL_NIL) - } -#endif - unlikely_if (!ECL_ANSI_STREAM_P(stream)) { - FEwrong_type_only_arg(@[file-string-length], stream, @[stream]); - } - if (stream->stream.mode == ecl_smm_broadcast) { - stream = BROADCAST_STREAM_LIST(stream); - if (Null(stream)) { - @(return ecl_make_fixnum(1)); - } else { - goto BEGIN; - } - } - unlikely_if (!ECL_FILE_STREAM_P(stream)) { - not_a_file_stream(stream); - } - switch (ecl_t_of(string)) { + if (ECL_INSTANCEP(stream)) { + @(return ECL_NIL); + } +#endif + unlikely_if (!ECL_ANSI_STREAM_P(stream)) { + FEwrong_type_only_arg(@[file-string-length], stream, @[stream]); + } + if (stream->stream.mode == ecl_smm_broadcast) { + stream = BROADCAST_STREAM_LIST(stream); + if (Null(stream)) { + @(return ecl_make_fixnum(1)); + } else { + goto BEGIN; + } + } + unlikely_if (!ECL_FILE_STREAM_P(stream)) { + not_a_file_stream(stream); + } + switch (ecl_t_of(string)) { #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: { - cl_index i; - for (i = 0; i < string->base_string.fillp; i++) { - l += compute_char_size(stream, ecl_char(string, i)); - } - break; - } - case t_character: - l = compute_char_size(stream, ECL_CHAR_CODE(string)); - break; - default: - FEwrong_type_nth_arg(@[file-string-length], 2, string, @[string]); - } - @(return ecl_make_fixnum(l)) + case t_base_string: { + cl_index i; + for (i = 0; i < string->base_string.fillp; i++) { + l += compute_char_size(stream, ecl_char(string, i)); + } + break; + } + case t_character: + l = compute_char_size(stream, ECL_CHAR_CODE(string)); + break; + default: + FEwrong_type_nth_arg(@[file-string-length], 2, string, @[string]); + } + @(return ecl_make_fixnum(l)); } cl_object si_do_write_sequence(cl_object seq, cl_object stream, cl_object s, cl_object e) { - const struct ecl_file_ops *ops; - cl_fixnum start,limit,end; + const struct ecl_file_ops *ops; + cl_fixnum start,limit,end; - /* Since we have called ecl_length(), we know that SEQ is a valid - sequence. Therefore, we only need to check the type of the - object, and seq == ECL_NIL i.f.f. t = t_symbol */ - limit = ecl_length(seq); - if (ecl_unlikely(!ECL_FIXNUMP(s) || - ((start = ecl_fixnum(s)) < 0) || - (start > limit))) { - FEwrong_type_key_arg(@[write-sequence], @[:start], s, - ecl_make_integer_type(ecl_make_fixnum(0), - ecl_make_fixnum(limit-1))); - } - if (e == ECL_NIL) { - end = limit; - } else if (ecl_unlikely(!ECL_FIXNUMP(e) || - ((end = ecl_fixnum(e)) < 0) || - (end > limit))) { - FEwrong_type_key_arg(@[write-sequence], @[:end], e, - ecl_make_integer_type(ecl_make_fixnum(0), - ecl_make_fixnum(limit))); - } - if (end <= start) { - goto OUTPUT; - } - ops = stream_dispatch_table(stream); - if (LISTP(seq)) { - cl_object elt_type = cl_stream_element_type(stream); - bool ischar = (elt_type == @'base-char') || (elt_type == @'character'); - cl_object s = ecl_nthcdr(start, seq); - loop_for_in(s) { - if (start < end) { - cl_object elt = CAR(s); - if (ischar) - ops->write_char(stream, ecl_char_code(elt)); - else - ops->write_byte(elt, stream); - start++; - } else { - goto OUTPUT; - } - } end_loop_for_in; - } else { - ops->write_vector(stream, seq, start, end); - } + /* Since we have called ecl_length(), we know that SEQ is a valid + sequence. Therefore, we only need to check the type of the + object, and seq == ECL_NIL i.f.f. t = t_symbol */ + limit = ecl_length(seq); + if (ecl_unlikely(!ECL_FIXNUMP(s) || + ((start = ecl_fixnum(s)) < 0) || + (start > limit))) { + FEwrong_type_key_arg(@[write-sequence], @[:start], s, + ecl_make_integer_type(ecl_make_fixnum(0), + ecl_make_fixnum(limit-1))); + } + if (e == ECL_NIL) { + end = limit; + } else if (ecl_unlikely(!ECL_FIXNUMP(e) || + ((end = ecl_fixnum(e)) < 0) || + (end > limit))) { + FEwrong_type_key_arg(@[write-sequence], @[:end], e, + ecl_make_integer_type(ecl_make_fixnum(0), + ecl_make_fixnum(limit))); + } + if (end <= start) { + goto OUTPUT; + } + ops = stream_dispatch_table(stream); + if (LISTP(seq)) { + cl_object elt_type = cl_stream_element_type(stream); + bool ischar = (elt_type == @'base-char') || (elt_type == @'character'); + cl_object s = ecl_nthcdr(start, seq); + loop_for_in(s) { + if (start < end) { + cl_object elt = CAR(s); + if (ischar) + ops->write_char(stream, ecl_char_code(elt)); + else + ops->write_byte(elt, stream); + start++; + } else { + goto OUTPUT; + } + } end_loop_for_in; + } else { + ops->write_vector(stream, seq, start, end); + } OUTPUT: - @(return seq); + @(return seq); } cl_object si_do_read_sequence(cl_object seq, cl_object stream, cl_object s, cl_object e) { - const struct ecl_file_ops *ops; - cl_fixnum start,limit,end; + const struct ecl_file_ops *ops; + cl_fixnum start,limit,end; - /* Since we have called ecl_length(), we know that SEQ is a valid - sequence. Therefore, we only need to check the type of the - object, and seq == ECL_NIL i.f.f. t = t_symbol */ - limit = ecl_length(seq); - if (ecl_unlikely(!ECL_FIXNUMP(s) || - ((start = ecl_fixnum(s)) < 0) || - (start > limit))) { - FEwrong_type_key_arg(@[read-sequence], @[:start], s, - ecl_make_integer_type(ecl_make_fixnum(0), - ecl_make_fixnum(limit-1))); - } - if (e == ECL_NIL) { - end = limit; - } else if (ecl_unlikely(!ECL_FIXNUMP(e) || - ((end = ecl_fixnum(e)) < 0) || - (end > limit))) { - FEwrong_type_key_arg(@[read-sequence], @[:end], e, - ecl_make_integer_type(ecl_make_fixnum(0), - ecl_make_fixnum(limit))); - } - if (end <= start) { - goto OUTPUT; - } - ops = stream_dispatch_table(stream); - if (LISTP(seq)) { - cl_object elt_type = cl_stream_element_type(stream); - bool ischar = (elt_type == @'base-char') || (elt_type == @'character'); - seq = ecl_nthcdr(start, seq); - loop_for_in(seq) { - if (start >= end) { - goto OUTPUT; - } else { - cl_object c; - if (ischar) { - int i = ops->read_char(stream); - if (i < 0) goto OUTPUT; - c = ECL_CODE_CHAR(i); - } else { - c = ops->read_byte(stream); - if (c == ECL_NIL) goto OUTPUT; - } - ECL_RPLACA(seq, c); - start++; - } - } end_loop_for_in; - } else { - start = ops->read_vector(stream, seq, start, end); - } + /* Since we have called ecl_length(), we know that SEQ is a valid + sequence. Therefore, we only need to check the type of the + object, and seq == ECL_NIL i.f.f. t = t_symbol */ + limit = ecl_length(seq); + if (ecl_unlikely(!ECL_FIXNUMP(s) || + ((start = ecl_fixnum(s)) < 0) || + (start > limit))) { + FEwrong_type_key_arg(@[read-sequence], @[:start], s, + ecl_make_integer_type(ecl_make_fixnum(0), + ecl_make_fixnum(limit-1))); + } + if (e == ECL_NIL) { + end = limit; + } else if (ecl_unlikely(!ECL_FIXNUMP(e) || + ((end = ecl_fixnum(e)) < 0) || + (end > limit))) { + FEwrong_type_key_arg(@[read-sequence], @[:end], e, + ecl_make_integer_type(ecl_make_fixnum(0), + ecl_make_fixnum(limit))); + } + if (end <= start) { + goto OUTPUT; + } + ops = stream_dispatch_table(stream); + if (LISTP(seq)) { + cl_object elt_type = cl_stream_element_type(stream); + bool ischar = (elt_type == @'base-char') || (elt_type == @'character'); + seq = ecl_nthcdr(start, seq); + loop_for_in(seq) { + if (start >= end) { + goto OUTPUT; + } else { + cl_object c; + if (ischar) { + int i = ops->read_char(stream); + if (i < 0) goto OUTPUT; + c = ECL_CODE_CHAR(i); + } else { + c = ops->read_byte(stream); + if (c == ECL_NIL) goto OUTPUT; + } + ECL_RPLACA(seq, c); + start++; + } + } end_loop_for_in; + } else { + start = ops->read_vector(stream, seq, start, end); + } OUTPUT: - @(return ecl_make_fixnum(start)) + @(return ecl_make_fixnum(start)); } /********************************************************************** @@ -4888,102 +4886,102 @@ cl_object si_file_column(cl_object strm) { - @(return ecl_make_fixnum(ecl_file_column(strm))) + @(return ecl_make_fixnum(ecl_file_column(strm))); } cl_object cl_file_length(cl_object strm) { - @(return ecl_file_length(strm)) + @(return ecl_file_length(strm)); } @(defun file-position (file_stream &o position) - cl_object output; + cl_object output; @ - if (Null(position)) { - output = ecl_file_position(file_stream); - } else { - if (position == @':start') { - position = ecl_make_fixnum(0); - } else if (position == @':end') { - position = ECL_NIL; - } - output = ecl_file_position_set(file_stream, position); - } - @(return output) + if (Null(position)) { + output = ecl_file_position(file_stream); + } else { + if (position == @':start') { + position = ecl_make_fixnum(0); + } else if (position == @':end') { + position = ECL_NIL; + } + output = ecl_file_position_set(file_stream, position); + } + @(return output); @) cl_object cl_input_stream_p(cl_object strm) { - @(return (ecl_input_stream_p(strm) ? ECL_T : ECL_NIL)) + @(return (ecl_input_stream_p(strm) ? ECL_T : ECL_NIL)); } cl_object cl_output_stream_p(cl_object strm) { - @(return (ecl_output_stream_p(strm) ? ECL_T : ECL_NIL)) + @(return (ecl_output_stream_p(strm) ? ECL_T : ECL_NIL)); } cl_object cl_interactive_stream_p(cl_object strm) { - @(return (stream_dispatch_table(strm)->interactive_p(strm)? ECL_T : ECL_NIL)) + @(return (stream_dispatch_table(strm)->interactive_p(strm)? ECL_T : ECL_NIL)); } cl_object cl_open_stream_p(cl_object strm) { - /* ANSI and Cltl2 specify that open-stream-p should work - on closed streams, and that a stream is only closed - when #'close has been applied on it */ + /* ANSI and Cltl2 specify that open-stream-p should work + on closed streams, and that a stream is only closed + when #'close has been applied on it */ #ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) { - return _ecl_funcall2(@'gray::open-stream-p', strm); - } -#endif - unlikely_if (!ECL_ANSI_STREAM_P(strm)) - FEwrong_type_only_arg(@'open-stream-p', strm, @'stream'); - @(return (strm->stream.closed ? ECL_NIL : ECL_T)) + if (ECL_INSTANCEP(strm)) { + return _ecl_funcall2(@'gray::open-stream-p', strm); + } +#endif + unlikely_if (!ECL_ANSI_STREAM_P(strm)) + FEwrong_type_only_arg(@'open-stream-p', strm, @'stream'); + @(return (strm->stream.closed ? ECL_NIL : ECL_T)); } cl_object cl_stream_element_type(cl_object strm) { - @(return ecl_stream_element_type(strm)) + @(return ecl_stream_element_type(strm)); } cl_object cl_stream_external_format(cl_object strm) { - cl_object output; - cl_type t; + cl_object output; + cl_type t; AGAIN: - t= ecl_t_of(strm); + t= ecl_t_of(strm); #ifdef ECL_CLOS_STREAMS - if (t == t_instance) - output = @':default'; - else -#endif - unlikely_if (t != t_stream) - FEwrong_type_only_arg(@[stream-external-format], strm, @[stream]); - if (strm->stream.mode == ecl_smm_synonym) { - strm = SYNONYM_STREAM_STREAM(strm); - goto AGAIN; - } - output = strm->stream.format; - @(return output) + if (t == t_instance) + output = @':default'; + else +#endif + unlikely_if (t != t_stream) + FEwrong_type_only_arg(@[stream-external-format], strm, @[stream]); + if (strm->stream.mode == ecl_smm_synonym) { + strm = SYNONYM_STREAM_STREAM(strm); + goto AGAIN; + } + output = strm->stream.format; + @(return output); } cl_object cl_streamp(cl_object strm) { #ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) { - return _ecl_funcall2(@'gray::streamp', strm); - } + if (ECL_INSTANCEP(strm)) { + return _ecl_funcall2(@'gray::streamp', strm); + } #endif - @(return (ECL_ANSI_STREAM_P(strm) ? ECL_T : ECL_NIL)) + @(return (ECL_ANSI_STREAM_P(strm) ? ECL_T : ECL_NIL)); } /********************************************************************** @@ -4993,12 +4991,12 @@ cl_object si_copy_stream(cl_object in, cl_object out) { - ecl_character c; - for (c = ecl_read_char(in); c != EOF; c = ecl_read_char(in)) { - ecl_write_char(c, out); - } - ecl_force_output(out); - @(return ECL_T) + ecl_character c; + for (c = ecl_read_char(in); c != EOF; c = ecl_read_char(in)) { + ecl_write_char(c, out); + } + ecl_force_output(out); + @(return ECL_T); } @@ -5009,46 +5007,46 @@ cl_fixnum ecl_normalize_stream_element_type(cl_object element_type) { - cl_fixnum sign = 0; - cl_index size; - if (element_type == @'signed-byte' || element_type == @'ext::integer8') { - return -8; - } else if (element_type == @'unsigned-byte' || element_type == @'ext::byte8') { - return 8; - } else if (element_type == @':default') { - return 0; - } else if (element_type == @'base-char' || element_type == @'character') { - return 0; - } else if (_ecl_funcall3(@'subtypep', element_type, @'character') != ECL_NIL) { - return 0; - } else if (_ecl_funcall3(@'subtypep', element_type, @'unsigned-byte') != ECL_NIL) { - sign = +1; - } else if (_ecl_funcall3(@'subtypep', element_type, @'signed-byte') != ECL_NIL) { - sign = -1; - } else { - FEerror("Not a valid stream element type: ~A", 1, element_type); - } - if (CONSP(element_type)) { - if (CAR(element_type) == @'unsigned-byte') - return ecl_to_size(cl_cadr(element_type)); - if (CAR(element_type) == @'signed-byte') - return -ecl_to_size(cl_cadr(element_type)); - } - for (size = 8; 1; size++) { - cl_object type; - type = cl_list(2, sign>0? @'unsigned-byte' : @'signed-byte', - ecl_make_fixnum(size)); - if (_ecl_funcall3(@'subtypep', element_type, type) != ECL_NIL) { - return size * sign; - } - } - FEerror("Not a valid stream element type: ~A", 1, element_type); + cl_fixnum sign = 0; + cl_index size; + if (element_type == @'signed-byte' || element_type == @'ext::integer8') { + return -8; + } else if (element_type == @'unsigned-byte' || element_type == @'ext::byte8') { + return 8; + } else if (element_type == @':default') { + return 0; + } else if (element_type == @'base-char' || element_type == @'character') { + return 0; + } else if (_ecl_funcall3(@'subtypep', element_type, @'character') != ECL_NIL) { + return 0; + } else if (_ecl_funcall3(@'subtypep', element_type, @'unsigned-byte') != ECL_NIL) { + sign = +1; + } else if (_ecl_funcall3(@'subtypep', element_type, @'signed-byte') != ECL_NIL) { + sign = -1; + } else { + FEerror("Not a valid stream element type: ~A", 1, element_type); + } + if (CONSP(element_type)) { + if (CAR(element_type) == @'unsigned-byte') + return ecl_to_size(cl_cadr(element_type)); + if (CAR(element_type) == @'signed-byte') + return -ecl_to_size(cl_cadr(element_type)); + } + for (size = 8; 1; size++) { + cl_object type; + type = cl_list(2, sign>0? @'unsigned-byte' : @'signed-byte', + ecl_make_fixnum(size)); + if (_ecl_funcall3(@'subtypep', element_type, type) != ECL_NIL) { + return size * sign; + } + } + FEerror("Not a valid stream element type: ~A", 1, element_type); } static void FEinvalid_option(cl_object option, cl_object value) { - FEerror("Invalid value op option ~A: ~A", 2, option, value); + FEerror("Invalid value op option ~A: ~A", 2, option, value); } cl_object @@ -5056,172 +5054,171 @@ cl_object if_does_not_exist, cl_fixnum byte_size, int flags, cl_object external_format) { - cl_object output; - int f; + cl_object output; + int f; #if defined(ECL_MS_WINDOWS_HOST) - ecl_mode_t mode = _S_IREAD | _S_IWRITE; + ecl_mode_t mode = _S_IREAD | _S_IWRITE; #else - ecl_mode_t mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH; + ecl_mode_t mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH; #endif - cl_object filename = si_coerce_to_filename(fn); - char *fname = (char*)filename->base_string.self; - bool appending = 0; - bool exists = si_file_kind(filename, ECL_T) != ECL_NIL; - if (smm == ecl_smm_input || smm == ecl_smm_probe) { - if (!exists) { - if (if_does_not_exist == @':error') { - FEcannot_open(fn); - } else if (if_does_not_exist == @':create') { - f = safe_open(fname, O_WRONLY|O_CREAT, mode); - unlikely_if (f < 0) FEcannot_open(fn); - safe_close(f); - } else if (Null(if_does_not_exist)) { - return ECL_NIL; - } else { - FEinvalid_option(@':if-does-not-exist', - if_does_not_exist); - } - } - f = safe_open(fname, O_RDONLY, mode); - unlikely_if (f < 0) FEcannot_open(fn); - } else if (smm == ecl_smm_output || smm == ecl_smm_io) { - int base = (smm == ecl_smm_output)? O_WRONLY : O_RDWR; - if (if_exists == @':new_version' && - if_does_not_exist == @':create') { - exists = 0; - if_does_not_exist = @':create'; - } - if (exists) { - if (if_exists == @':error') { - FEcannot_open(fn); - } else if (if_exists == @':rename') { - f = ecl_backup_open(fname, base|O_CREAT, mode); - unlikely_if (f < 0) FEcannot_open(fn); - } else if (if_exists == @':rename_and_delete' || - if_exists == @':new_version' || - if_exists == @':supersede') { - f = safe_open(fname, base|O_TRUNC, mode); - unlikely_if (f < 0) FEcannot_open(fn); - } else if (if_exists == @':overwrite' || if_exists == @':append') { - f = safe_open(fname, base, mode); - unlikely_if (f < 0) FEcannot_open(fn); - appending = (if_exists == @':append'); - } else if (Null(if_exists)) { - return ECL_NIL; - } else { - FEinvalid_option(@':if-exists', if_exists); - } - } else { - if (if_does_not_exist == @':error') { - FEcannot_open(fn); - } else if (if_does_not_exist == @':create') { - f = safe_open(fname, base | O_CREAT | O_TRUNC, mode); - unlikely_if (f < 0) FEcannot_open(fn); - } else if (Null(if_does_not_exist)) { - return ECL_NIL; - } else { - FEinvalid_option(@':if-does-not-exist', - if_does_not_exist); - } - } - } else { - FEerror("Illegal stream mode ~S", 1, ecl_make_fixnum(smm)); - } - if (flags & ECL_STREAM_C_STREAM) { - FILE *fp; - safe_close(f); - /* We do not use fdopen() because Windows seems to - * have problems with the resulting streams. Furthermore, even for - * output we open with w+ because we do not want to - * overwrite the file. */ - switch (smm) { - case ecl_smm_probe: - case ecl_smm_input: fp = safe_fopen(fname, OPEN_R); break; - case ecl_smm_output: - case ecl_smm_io: fp = safe_fopen(fname, OPEN_RW); break; - default:; /* never reached */ - } - output = ecl_make_stream_from_FILE(fn, fp, smm, byte_size, flags, - external_format); - si_set_buffering_mode(output, byte_size? @':full' : @':line'); - } else { - output = ecl_make_file_stream_from_fd(fn, f, smm, byte_size, flags, - external_format); - } - if (smm == ecl_smm_probe) { - cl_close(1, output); - } else { - output->stream.flags |= ECL_STREAM_MIGHT_SEEK; - si_set_finalizer(output, ECL_T); - /* Set file pointer to the correct position */ - ecl_file_position_set(output, appending? ECL_NIL : ecl_make_fixnum(0)); - } - return output; + cl_object filename = si_coerce_to_filename(fn); + char *fname = (char*)filename->base_string.self; + bool appending = 0; + bool exists = si_file_kind(filename, ECL_T) != ECL_NIL; + if (smm == ecl_smm_input || smm == ecl_smm_probe) { + if (!exists) { + if (if_does_not_exist == @':error') { + FEcannot_open(fn); + } else if (if_does_not_exist == @':create') { + f = safe_open(fname, O_WRONLY|O_CREAT, mode); + unlikely_if (f < 0) FEcannot_open(fn); + safe_close(f); + } else if (Null(if_does_not_exist)) { + return ECL_NIL; + } else { + FEinvalid_option(@':if-does-not-exist', + if_does_not_exist); + } + } + f = safe_open(fname, O_RDONLY, mode); + unlikely_if (f < 0) FEcannot_open(fn); + } else if (smm == ecl_smm_output || smm == ecl_smm_io) { + int base = (smm == ecl_smm_output)? O_WRONLY : O_RDWR; + if (if_exists == @':new_version' && + if_does_not_exist == @':create') { + exists = 0; + if_does_not_exist = @':create'; + } + if (exists) { + if (if_exists == @':error') { + FEcannot_open(fn); + } else if (if_exists == @':rename') { + f = ecl_backup_open(fname, base|O_CREAT, mode); + unlikely_if (f < 0) FEcannot_open(fn); + } else if (if_exists == @':rename_and_delete' || + if_exists == @':new_version' || + if_exists == @':supersede') { + f = safe_open(fname, base|O_TRUNC, mode); + unlikely_if (f < 0) FEcannot_open(fn); + } else if (if_exists == @':overwrite' || if_exists == @':append') { + f = safe_open(fname, base, mode); + unlikely_if (f < 0) FEcannot_open(fn); + appending = (if_exists == @':append'); + } else if (Null(if_exists)) { + return ECL_NIL; + } else { + FEinvalid_option(@':if-exists', if_exists); + } + } else { + if (if_does_not_exist == @':error') { + FEcannot_open(fn); + } else if (if_does_not_exist == @':create') { + f = safe_open(fname, base | O_CREAT | O_TRUNC, mode); + unlikely_if (f < 0) FEcannot_open(fn); + } else if (Null(if_does_not_exist)) { + return ECL_NIL; + } else { + FEinvalid_option(@':if-does-not-exist', + if_does_not_exist); + } + } + } else { + FEerror("Illegal stream mode ~S", 1, ecl_make_fixnum(smm)); + } + if (flags & ECL_STREAM_C_STREAM) { + FILE *fp; + safe_close(f); + /* We do not use fdopen() because Windows seems to + * have problems with the resulting streams. Furthermore, even for + * output we open with w+ because we do not want to + * overwrite the file. */ + switch (smm) { + case ecl_smm_probe: + case ecl_smm_input: fp = safe_fopen(fname, OPEN_R); break; + case ecl_smm_output: + case ecl_smm_io: fp = safe_fopen(fname, OPEN_RW); break; + default:; /* never reached */ + } + output = ecl_make_stream_from_FILE(fn, fp, smm, byte_size, flags, + external_format); + si_set_buffering_mode(output, byte_size? @':full' : @':line'); + } else { + output = ecl_make_file_stream_from_fd(fn, f, smm, byte_size, flags, + external_format); + } + if (smm == ecl_smm_probe) { + cl_close(1, output); + } else { + output->stream.flags |= ECL_STREAM_MIGHT_SEEK; + si_set_finalizer(output, ECL_T); + /* Set file pointer to the correct position */ + ecl_file_position_set(output, appending? ECL_NIL : ecl_make_fixnum(0)); + } + return output; } @(defun open (filename &key (direction @':input') - (element_type @'character') - (if_exists ECL_NIL iesp) - (if_does_not_exist ECL_NIL idnesp) - (external_format @':default') - (cstream ECL_T) + (element_type @'character') + (if_exists ECL_NIL iesp) + (if_does_not_exist ECL_NIL idnesp) + (external_format @':default') + (cstream ECL_T) &aux strm) - enum ecl_smmode smm; - int flags = 0; - cl_fixnum byte_size; + enum ecl_smmode smm; + int flags = 0; + cl_fixnum byte_size; @ - /* INV: ecl_open_stream() checks types */ - if (direction == @':input') { - smm = ecl_smm_input; - if (!idnesp) - if_does_not_exist = @':error'; - } else if (direction == @':output') { - smm = ecl_smm_output; - if (!iesp) - if_exists = @':new_version'; - if (!idnesp) { - if (if_exists == @':overwrite' || - if_exists == @':append') - if_does_not_exist = @':error'; - else - if_does_not_exist = @':create'; - } - } else if (direction == @':io') { - smm = ecl_smm_io; - if (!iesp) - if_exists = @':new_version'; - if (!idnesp) { - if (if_exists == @':overwrite' || - if_exists == @':append') - if_does_not_exist = @':error'; - else - if_does_not_exist = @':create'; - } - } else if (direction == @':probe') { - smm = ecl_smm_probe; - if (!idnesp) - if_does_not_exist = ECL_NIL; - } else { - FEerror("~S is an illegal DIRECTION for OPEN.", - 1, direction); - } - byte_size = ecl_normalize_stream_element_type(element_type); - if (byte_size != 0) { - external_format = ECL_NIL; - } - if (!Null(cstream)) { - flags |= ECL_STREAM_C_STREAM; - } - strm = ecl_open_stream(filename, smm, if_exists, if_does_not_exist, - byte_size, flags, external_format); - @(return strm) + /* INV: ecl_open_stream() checks types */ + if (direction == @':input') { + smm = ecl_smm_input; + if (!idnesp) + if_does_not_exist = @':error'; + } else if (direction == @':output') { + smm = ecl_smm_output; + if (!iesp) + if_exists = @':new_version'; + if (!idnesp) { + if (if_exists == @':overwrite' || + if_exists == @':append') + if_does_not_exist = @':error'; + else + if_does_not_exist = @':create'; + } + } else if (direction == @':io') { + smm = ecl_smm_io; + if (!iesp) + if_exists = @':new_version'; + if (!idnesp) { + if (if_exists == @':overwrite' || + if_exists == @':append') + if_does_not_exist = @':error'; + else + if_does_not_exist = @':create'; + } + } else if (direction == @':probe') { + smm = ecl_smm_probe; + if (!idnesp) + if_does_not_exist = ECL_NIL; + } else { + FEerror("~S is an illegal DIRECTION for OPEN.", + 1, direction); + } + byte_size = ecl_normalize_stream_element_type(element_type); + if (byte_size != 0) { + external_format = ECL_NIL; + } + if (!Null(cstream)) { + flags |= ECL_STREAM_C_STREAM; + } + strm = ecl_open_stream(filename, smm, if_exists, if_does_not_exist, + byte_size, flags, external_format); + @(return strm); @) - @(defun close (strm &key (abort @'nil')) @ - @(return stream_dispatch_table(strm)->close(strm)); + @(return stream_dispatch_table(strm)->close(strm)); @) /********************************************************************** @@ -5233,190 +5230,200 @@ { #if !defined(ECL_MS_WINDOWS_HOST) # if defined(HAVE_SELECT) - fd_set fds; - int retv; - struct timeval tv = { 0, 0 }; - /* - * Note that the following code is fragile. If the file is closed (/dev/null) - * then select() may return 1 (at least on OS X), so that we return a flag - * saying characters are available but will find none to read. See also the - * code in cl_clear_input(). - */ - FD_ZERO(&fds); - FD_SET(fileno, &fds); - retv = select(fileno + 1, &fds, NULL, NULL, &tv); - if (ecl_unlikely(retv < 0)) - file_libc_error(@[stream-error], stream, "Error while listening to stream.", 0); - else if (retv > 0) - return ECL_LISTEN_AVAILABLE; - else - return ECL_LISTEN_NO_CHAR; + fd_set fds; + int retv; + struct timeval tv = { 0, 0 }; + /* + * Note that the following code is fragile. If the file is closed (/dev/null) + * then select() may return 1 (at least on OS X), so that we return a flag + * saying characters are available but will find none to read. See also the + * code in cl_clear_input(). + */ + FD_ZERO(&fds); + FD_SET(fileno, &fds); + retv = select(fileno + 1, &fds, NULL, NULL, &tv); + if (ecl_unlikely(retv < 0)) + file_libc_error(@[stream-error], stream, "Error while listening to stream.", 0); + else if (retv > 0) + return ECL_LISTEN_AVAILABLE; + else + return ECL_LISTEN_NO_CHAR; # elif defined(FIONREAD) - { - long c = 0; - ioctl(fileno, FIONREAD, &c); - return (c > 0)? ECL_LISTEN_AVAILABLE : ECL_LISTEN_NO_CHAR; - } + { + long c = 0; + ioctl(fileno, FIONREAD, &c); + return (c > 0)? ECL_LISTEN_AVAILABLE : ECL_LISTEN_NO_CHAR; + } # endif /* FIONREAD */ #else - HANDLE hnd = (HANDLE)_get_osfhandle(fileno); - switch (GetFileType(hnd)) { - case FILE_TYPE_CHAR: { - DWORD dw, dw_read, cm; - if (GetNumberOfConsoleInputEvents(hnd, &dw)) { - unlikely_if (!GetConsoleMode(hnd, &cm)) - FEwin32_error("GetConsoleMode() failed", 0); - if (dw > 0) { - PINPUT_RECORD recs = (PINPUT_RECORD)GC_malloc(sizeof(INPUT_RECORD)*dw); - int i; - unlikely_if (!PeekConsoleInput(hnd, recs, dw, &dw_read)) - FEwin32_error("PeekConsoleInput failed()", 0); - if (dw_read > 0) { - if (cm & ENABLE_LINE_INPUT) { - for (i=0; i 0 ? ECL_LISTEN_AVAILABLE : ECL_LISTEN_NO_CHAR); - else if (GetLastError() == ERROR_BROKEN_PIPE) - return ECL_LISTEN_EOF; - else - FEwin32_error("PeekNamedPipe() failed", 0); - break; - } - default: - FEerror("Unsupported Windows file type: ~A", 1, ecl_make_fixnum(GetFileType(hnd))); - break; + HANDLE hnd = (HANDLE)_get_osfhandle(fileno); + switch (GetFileType(hnd)) { + case FILE_TYPE_CHAR: { + DWORD dw, dw_read, cm; + if (GetNumberOfConsoleInputEvents(hnd, &dw)) { + unlikely_if (!GetConsoleMode(hnd, &cm)) + FEwin32_error("GetConsoleMode() failed", 0); + if (dw > 0) { + PINPUT_RECORD recs = (PINPUT_RECORD)GC_malloc(sizeof(INPUT_RECORD)*dw); + int i; + unlikely_if (!PeekConsoleInput(hnd, recs, dw, &dw_read)) + FEwin32_error("PeekConsoleInput failed()", 0); + if (dw_read > 0) { + if (cm & ENABLE_LINE_INPUT) { + for (i=0; i 0 ? ECL_LISTEN_AVAILABLE : ECL_LISTEN_NO_CHAR); + else if (GetLastError() == ERROR_BROKEN_PIPE) + return ECL_LISTEN_EOF; + else + FEwin32_error("PeekNamedPipe() failed", 0); + break; + } + default: + FEerror("Unsupported Windows file type: ~A", 1, ecl_make_fixnum(GetFileType(hnd))); + break; + } #endif - return -3; + return -3; } static int flisten(cl_object stream, FILE *fp) { - int aux; - if (feof(fp)) - return ECL_LISTEN_EOF; + int aux; + if (feof(fp)) + return ECL_LISTEN_EOF; #ifdef FILE_CNT - if (FILE_CNT(fp) > 0) - return ECL_LISTEN_AVAILABLE; + if (FILE_CNT(fp) > 0) + return ECL_LISTEN_AVAILABLE; #endif - aux = file_listen(stream, fileno(fp)); - if (aux != -3) - return aux; - /* This code is portable, and implements the expected behavior for regular files. - It will fail on noninteractive streams. */ - { - /* regular file */ - ecl_off_t old_pos = ecl_ftello(fp), end_pos; - unlikely_if (ecl_fseeko(fp, 0, SEEK_END) != 0) - file_libc_error(@[file-error], stream, - "Unable to check file position", 0); - end_pos = ecl_ftello(fp); - unlikely_if (ecl_fseeko(fp, old_pos, SEEK_SET) != 0) - file_libc_error(@[file-error], stream, - "Unable to check file position", 0); - return (end_pos > old_pos ? ECL_LISTEN_AVAILABLE : ECL_LISTEN_EOF); - } - return !ECL_LISTEN_AVAILABLE; -} + aux = file_listen(stream, fileno(fp)); + if (aux != -3) + return aux; + /* This code is portable, and implements the expected behavior for regular files. + It will fail on noninteractive streams. */ + { + /* regular file */ + ecl_off_t old_pos = ecl_ftello(fp), end_pos; + unlikely_if (ecl_fseeko(fp, 0, SEEK_END) != 0) + file_libc_error(@[file-error], stream, + "Unable to check file position", 0); + end_pos = ecl_ftello(fp); + unlikely_if (ecl_fseeko(fp, old_pos, SEEK_SET) != 0) + file_libc_error(@[file-error], stream, + "Unable to check file position", 0); + return (end_pos > old_pos ? ECL_LISTEN_AVAILABLE : ECL_LISTEN_EOF); + } + return !ECL_LISTEN_AVAILABLE; +} + +/* Compilation of this function on some platforms may give a warning: + "right shift count >= width of type [-Werror=shift-count-overflow]" + but on these platforms this branch is never encountered. + FIXME: this can probably be conditionaly defined in #if … #endif */ cl_object ecl_off_t_to_integer(ecl_off_t offset) { - cl_object output; - if (sizeof(ecl_off_t) == sizeof(cl_fixnum)) { - output = ecl_make_integer(offset); - } else if (offset <= MOST_POSITIVE_FIXNUM) { - output = ecl_make_fixnum((cl_fixnum)offset); - } else { - cl_object y = _ecl_big_register0(); - if (sizeof(ECL_BIGNUM_LIMBS(y)[0]) == sizeof(cl_index)) { - ECL_BIGNUM_LIMBS(y)[0] = (cl_index)offset; - offset >>= ECL_FIXNUM_BITS; - ECL_BIGNUM_LIMBS(y)[1] = offset; - ECL_BIGNUM_SIZE(y) = offset? 2 : 1; - } else if (sizeof(ECL_BIGNUM_LIMBS(y)[0]) >= sizeof(ecl_off_t)) { - ECL_BIGNUM_LIMBS(y)[0] = offset; - ECL_BIGNUM_SIZE(y) = 1; - } - output = _ecl_big_register_normalize(y); - } - return output; -} + cl_object output; + if (sizeof(ecl_off_t) == sizeof(cl_fixnum)) { + output = ecl_make_integer(offset); + } else if (offset <= MOST_POSITIVE_FIXNUM) { + output = ecl_make_fixnum((cl_fixnum)offset); + } else { + cl_object y = _ecl_big_register0(); + if (sizeof(ECL_BIGNUM_LIMBS(y)[0]) == sizeof(cl_index)) { + ECL_BIGNUM_LIMBS(y)[0] = (cl_index)offset; + offset >>= ECL_FIXNUM_BITS; + ECL_BIGNUM_LIMBS(y)[1] = offset; + ECL_BIGNUM_SIZE(y) = offset? 2 : 1; + } else if (sizeof(ECL_BIGNUM_LIMBS(y)[0]) >= sizeof(ecl_off_t)) { + ECL_BIGNUM_LIMBS(y)[0] = offset; + ECL_BIGNUM_SIZE(y) = 1; + } + output = _ecl_big_register_normalize(y); + } + return output; +} + +/* Compilation of this function on some platforms may give a warning: + "left shift count >= width of type [-Werror=shift-count-overflow]" + but on these platforms this branch is never encountered. + FIXME: this can probably be conditionaly defined in #if … #endif */ ecl_off_t ecl_integer_to_off_t(cl_object offset) { - ecl_off_t output = 0; - if (sizeof(ecl_off_t) == sizeof(cl_fixnum)) { - output = fixint(offset); - } else if (ECL_FIXNUMP(offset)) { - output = fixint(offset); - } else if (ECL_BIGNUMP(offset)) { - if (sizeof(ECL_BIGNUM_LIMBS(offset)[0]) == sizeof(cl_index)) { - if (ECL_BIGNUM_SIZE(offset) > 2) { - goto ERROR; - } - if (ECL_BIGNUM_SIZE(offset) == 2) { - output = ECL_BIGNUM_LIMBS(offset)[1]; - output <<= ECL_FIXNUM_BITS; - } - output += ECL_BIGNUM_LIMBS(offset)[0]; - } else if (sizeof(ECL_BIGNUM_LIMBS(offset)[0]) >= sizeof(ecl_off_t)) { - if (ECL_BIGNUM_SIZE(offset) > 1) { - goto ERROR; - } - output = ECL_BIGNUM_LIMBS(offset)[0]; - } - } else { - ERROR: FEerror("Not a valid file offset: ~S", 1, offset); - } - return output; + ecl_off_t output = 0; + if (sizeof(ecl_off_t) == sizeof(cl_fixnum)) { + output = fixint(offset); + } else if (ECL_FIXNUMP(offset)) { + output = fixint(offset); + } else if (ECL_BIGNUMP(offset)) { + if (sizeof(ECL_BIGNUM_LIMBS(offset)[0]) == sizeof(cl_index)) { + if (ECL_BIGNUM_SIZE(offset) > 2) { + goto ERROR; + } + if (ECL_BIGNUM_SIZE(offset) == 2) { + output = ECL_BIGNUM_LIMBS(offset)[1]; + output <<= ECL_FIXNUM_BITS; + } + output += ECL_BIGNUM_LIMBS(offset)[0]; + } else if (sizeof(ECL_BIGNUM_LIMBS(offset)[0]) >= sizeof(ecl_off_t)) { + if (ECL_BIGNUM_SIZE(offset) > 1) { + goto ERROR; + } + output = ECL_BIGNUM_LIMBS(offset)[0]; + } + } else { + ERROR: FEerror("Not a valid file offset: ~S", 1, offset); + } + return output; } static cl_object alloc_stream() { - cl_object x = ecl_alloc_object(t_stream); - x->stream.closed = 0; - x->stream.file.descriptor = -1; - x->stream.object0 = - x->stream.object1 = OBJNULL; - x->stream.int0 = x->stream.int1 = 0; - x->stream.format = ECL_NIL; - x->stream.flags = 0; - x->stream.byte_size = 8; - x->stream.buffer = NULL; - x->stream.encoder = NULL; - x->stream.decoder = NULL; - x->stream.last_char = EOF; - x->stream.byte_stack = ECL_NIL; - x->stream.last_code[0] = x->stream.last_code[1] = EOF; - x->stream.eof_char = EOF; - return x; + cl_object x = ecl_alloc_object(t_stream); + x->stream.closed = 0; + x->stream.file.descriptor = -1; + x->stream.object0 = + x->stream.object1 = OBJNULL; + x->stream.int0 = x->stream.int1 = 0; + x->stream.format = ECL_NIL; + x->stream.flags = 0; + x->stream.byte_size = 8; + x->stream.buffer = NULL; + x->stream.encoder = NULL; + x->stream.decoder = NULL; + x->stream.last_char = EOF; + x->stream.byte_stack = ECL_NIL; + x->stream.last_code[0] = x->stream.last_code[1] = EOF; + x->stream.eof_char = EOF; + return x; } /********************************************************************** @@ -5426,166 +5433,167 @@ static cl_object not_a_file_stream(cl_object strm) { - return cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("~A is not an file stream"), - @':format-arguments', cl_list(1, strm), - @':expected-type', @'file-stream', - @':datum', strm); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("~A is not an file stream"), + @':format-arguments', cl_list(1, strm), + @':expected-type', @'file-stream', + @':datum', strm); } static void not_an_input_stream(cl_object strm) { - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("~A is not an input stream"), - @':format-arguments', cl_list(1, strm), - @':expected-type', - cl_list(2, @'satisfies', @'input-stream-p'), - @':datum', strm); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("~A is not an input stream"), + @':format-arguments', cl_list(1, strm), + @':expected-type', + cl_list(2, @'satisfies', @'input-stream-p'), + @':datum', strm); } static void not_an_output_stream(cl_object strm) { - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("~A is not an output stream"), - @':format-arguments', cl_list(1, strm), - @':expected-type', cl_list(2, @'satisfies', @'output-stream-p'), - @':datum', strm); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("~A is not an output stream"), + @':format-arguments', cl_list(1, strm), + @':expected-type', cl_list(2, @'satisfies', @'output-stream-p'), + @':datum', strm); } static void not_a_character_stream(cl_object s) { - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("~A is not a character stream"), - @':format-arguments', cl_list(1, s), - @':expected-type', @'character', - @':datum', cl_stream_element_type(s)); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("~A is not a character stream"), + @':format-arguments', cl_list(1, s), + @':expected-type', @'character', + @':datum', cl_stream_element_type(s)); } static void not_a_binary_stream(cl_object s) { - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("~A is not a binary stream"), - @':format-arguments', cl_list(1, s), - @':expected-type', @'integer', - @':datum', cl_stream_element_type(s)); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("~A is not a binary stream"), + @':format-arguments', cl_list(1, s), + @':expected-type', @'integer', + @':datum', cl_stream_element_type(s)); } static void cannot_close(cl_object stream) { - file_libc_error(@[file-error], stream, "Stream cannot be closed", 0); + file_libc_error(@[file-error], stream, "Stream cannot be closed", 0); } static void file_libc_error(cl_object error_type, cl_object stream, const char *msg, int narg, ...) { - ecl_va_list args; - cl_object rest, error = _ecl_strerror(errno); + ecl_va_list args; + cl_object rest, error = _ecl_strerror(errno); - ecl_va_start(args, narg, narg, 0); - rest = cl_grab_rest_args(args); + ecl_va_start(args, narg, narg, 0); + rest = cl_grab_rest_args(args); - si_signal_simple_error(4, (cl_object)(cl_symbols + ecl_fixnum(error_type)), Cnil, - make_constant_base_string("~?~%C library explanation: ~A."), - cl_list(3, make_constant_base_string(msg), rest, - error)); + si_signal_simple_error(4, (cl_object)(cl_symbols + ecl_fixnum(error_type)), Cnil, + make_constant_base_string("~?~%C library explanation: ~A."), + cl_list(3, make_constant_base_string(msg), rest, + error)); + _ecl_unexpected_return(); } static void unread_error(cl_object s) { - CEerror(ECL_T, "Error when using UNREAD-CHAR on stream ~D", 1, s); + CEerror(ECL_T, "Error when using UNREAD-CHAR on stream ~D", 1, s); } static void unread_twice(cl_object s) { - CEerror(ECL_T, "Used UNREAD-CHAR twice on stream ~D", 1, s); + CEerror(ECL_T, "Used UNREAD-CHAR twice on stream ~D", 1, s); } static void maybe_clearerr(cl_object strm) { - int t = strm->stream.mode; - if (t == ecl_smm_io || t == ecl_smm_output || t == ecl_smm_input) { - FILE *f = IO_STREAM_FILE(strm); - if (f != NULL) clearerr(f); - } + int t = strm->stream.mode; + if (t == ecl_smm_io || t == ecl_smm_output || t == ecl_smm_input) { + FILE *f = IO_STREAM_FILE(strm); + if (f != NULL) clearerr(f); + } } static int restartable_io_error(cl_object strm, const char *s) { - cl_env_ptr the_env = ecl_process_env(); - volatile int old_errno = errno; - /* ecl_disable_interrupts(); ** done by caller */ - maybe_clearerr(strm); - ecl_enable_interrupts_env(the_env); - if (old_errno == EINTR) { - return 1; - } else { - file_libc_error(@[stream-error], strm, - "C operation (~A) signaled an error.", - 1, ecl_make_constant_base_string(s, strlen(s))); - return 0; - } + cl_env_ptr the_env = ecl_process_env(); + volatile int old_errno = errno; + /* ecl_disable_interrupts(); ** done by caller */ + maybe_clearerr(strm); + ecl_enable_interrupts_env(the_env); + if (old_errno == EINTR) { + return 1; + } else { + file_libc_error(@[stream-error], strm, + "C operation (~A) signaled an error.", + 1, ecl_make_constant_base_string(s, strlen(s))); + return 0; + } } static void io_error(cl_object strm) { - cl_env_ptr the_env = ecl_process_env(); - /* ecl_disable_interrupts(); ** done by caller */ - maybe_clearerr(strm); - ecl_enable_interrupts_env(the_env); - file_libc_error(@[stream-error], strm, - "Read or write operation signaled an error", 0); + cl_env_ptr the_env = ecl_process_env(); + /* ecl_disable_interrupts(); ** done by caller */ + maybe_clearerr(strm); + ecl_enable_interrupts_env(the_env); + file_libc_error(@[stream-error], strm, + "Read or write operation signaled an error", 0); } static void wrong_file_handler(cl_object strm) { - FEerror("Internal error: stream ~S has no valid C file handler.", 1, strm); + FEerror("Internal error: stream ~S has no valid C file handler.", 1, strm); } #ifdef ECL_UNICODE static cl_index encoding_error(cl_object stream, unsigned char *buffer, ecl_character c) { - cl_object code = _ecl_funcall4(@'ext::encoding-error', stream, - cl_stream_external_format(stream), - ecl_make_integer(c)); - if (Null(code)) { - /* Output nothing */ - return 0; - } else { - /* Try with supplied character */ - return stream->stream.encoder(stream, buffer, ecl_char_code(code)); - } + cl_object code = _ecl_funcall4(@'ext::encoding-error', stream, + cl_stream_external_format(stream), + ecl_make_integer(c)); + if (Null(code)) { + /* Output nothing */ + return 0; + } else { + /* Try with supplied character */ + return stream->stream.encoder(stream, buffer, ecl_char_code(code)); + } } static ecl_character decoding_error(cl_object stream, unsigned char *buffer, int length) { - cl_object octets = ECL_NIL, code; - while (length > 0) { - octets = CONS(ecl_make_fixnum(buffer[--length]), octets); - } - code = _ecl_funcall4(@'ext::decoding-error', stream, - cl_stream_external_format(stream), - octets); - if (Null(code)) { - /* Go for next character */ - return stream->stream.decoder(stream); - } else { - /* Return supplied character */ - return ecl_char_code(code); - } + cl_object octets = ECL_NIL, code; + while (length > 0) { + octets = CONS(ecl_make_fixnum(buffer[--length]), octets); + } + code = _ecl_funcall4(@'ext::decoding-error', stream, + cl_stream_external_format(stream), + octets); + if (Null(code)) { + /* Go for next character */ + return stream->stream.decoder(stream); + } else { + /* Return supplied character */ + return ecl_char_code(code); + } } #endif @@ -5593,85 +5601,84 @@ static void wsock_error( const char *err_msg, cl_object strm ) { - char *msg; - cl_object msg_obj; - /* ecl_disable_interrupts(); ** done by caller */ - { - FormatMessage( FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER, - 0, WSAGetLastError(), 0, ( void* )&msg, 0, NULL ); - msg_obj = make_base_string_copy( msg ); - LocalFree( msg ); - } - ecl_enable_interrupts(); - FEerror( err_msg, 2, strm, msg_obj ); + char *msg; + cl_object msg_obj; + /* ecl_disable_interrupts(); ** done by caller */ + { + FormatMessage( FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER, + 0, WSAGetLastError(), 0, ( void* )&msg, 0, NULL ); + msg_obj = make_base_string_copy( msg ); + LocalFree( msg ); + } + ecl_enable_interrupts(); + FEerror( err_msg, 2, strm, msg_obj ); } #endif void init_file(void) { - int flags; - cl_object standard_input; - cl_object standard_output; - cl_object error_output; - cl_object aux; - cl_object null_stream; - cl_object external_format = ECL_NIL; + int flags; + cl_object standard_input; + cl_object standard_output; + cl_object error_output; + cl_object aux; + cl_object null_stream; + cl_object external_format = ECL_NIL; #if defined(ECL_MS_WINDOWS_HOST) # ifdef ECL_UNICODE - external_format = cl_list(2, @':latin-1', @':crlf'); - flags = 0; + external_format = cl_list(2, @':latin-1', @':crlf'); + flags = 0; # else - external_format = cl_list(2, @':crlf', @':pass-through'); - flags = ECL_STREAM_DEFAULT_FORMAT; + external_format = cl_list(2, @':crlf', @':pass-through'); + flags = ECL_STREAM_DEFAULT_FORMAT; # endif #else - flags = ECL_STREAM_DEFAULT_FORMAT; + flags = ECL_STREAM_DEFAULT_FORMAT; #endif - null_stream = ecl_make_stream_from_FILE(make_constant_base_string("/dev/null"), - NULL, ecl_smm_io, 8, flags, external_format); - generic_close(null_stream); - null_stream = cl_make_two_way_stream(null_stream, cl_make_broadcast_stream(0)); - cl_core.null_stream = null_stream; + null_stream = ecl_make_stream_from_FILE(make_constant_base_string("/dev/null"), + NULL, ecl_smm_io, 8, flags, external_format); + generic_close(null_stream); + null_stream = cl_make_two_way_stream(null_stream, cl_make_broadcast_stream(0)); + cl_core.null_stream = null_stream; - /* We choose C streams by default only when _not_ using threads. - * The reason is that C streams block on I/O operations. */ + /* We choose C streams by default only when _not_ using threads. + * The reason is that C streams block on I/O operations. */ #if !defined(ECL_THREADS) - standard_input = maybe_make_windows_console_FILE(make_constant_base_string("stdin"), - stdin, ecl_smm_input, 8, flags, external_format); - standard_output = maybe_make_windows_console_FILE(make_constant_base_string("stdout"), - stdout, ecl_smm_output, 8, flags, external_format); - error_output = maybe_make_windows_console_FILE(make_constant_base_string("stderr"), - stderr, ecl_smm_output, 8, flags, external_format); + standard_input = maybe_make_windows_console_FILE(make_constant_base_string("stdin"), + stdin, ecl_smm_input, 8, flags, external_format); + standard_output = maybe_make_windows_console_FILE(make_constant_base_string("stdout"), + stdout, ecl_smm_output, 8, flags, external_format); + error_output = maybe_make_windows_console_FILE(make_constant_base_string("stderr"), + stderr, ecl_smm_output, 8, flags, external_format); #else - standard_input = maybe_make_windows_console_fd(make_constant_base_string("stdin"), - STDIN_FILENO, ecl_smm_input_file, 8, flags, - external_format); - standard_output = maybe_make_windows_console_fd(make_constant_base_string("stdout"), - STDOUT_FILENO, ecl_smm_output_file, 8, flags, - external_format); - error_output = maybe_make_windows_console_fd(make_constant_base_string("stderr"), - STDERR_FILENO, ecl_smm_output_file, 8, flags, - external_format); -#endif - cl_core.standard_input = standard_input; - ECL_SET(@'ext::+process-standard-input+', standard_input); - ECL_SET(@'*standard-input*', standard_input); - cl_core.standard_output = standard_output; - ECL_SET(@'ext::+process-standard-output+', standard_output); - ECL_SET(@'*standard-output*', standard_output); - ECL_SET(@'*trace-output*', standard_output); - cl_core.error_output = error_output; - ECL_SET(@'ext::+process-error-output+', error_output); - ECL_SET(@'*error-output*', error_output); - - cl_core.terminal_io = aux - = cl_make_two_way_stream(standard_input, standard_output); - - ECL_SET(@'*terminal-io*', aux); - aux = cl_make_synonym_stream(@'*terminal-io*'); - ECL_SET(@'*query-io*', aux); - ECL_SET(@'*debug-io*', aux); + standard_input = maybe_make_windows_console_fd(make_constant_base_string("stdin"), + STDIN_FILENO, ecl_smm_input_file, 8, flags, + external_format); + standard_output = maybe_make_windows_console_fd(make_constant_base_string("stdout"), + STDOUT_FILENO, ecl_smm_output_file, 8, flags, + external_format); + error_output = maybe_make_windows_console_fd(make_constant_base_string("stderr"), + STDERR_FILENO, ecl_smm_output_file, 8, flags, + external_format); +#endif + cl_core.standard_input = standard_input; + ECL_SET(@'ext::+process-standard-input+', standard_input); + ECL_SET(@'*standard-input*', standard_input); + cl_core.standard_output = standard_output; + ECL_SET(@'ext::+process-standard-output+', standard_output); + ECL_SET(@'*standard-output*', standard_output); + ECL_SET(@'*trace-output*', standard_output); + cl_core.error_output = error_output; + ECL_SET(@'ext::+process-error-output+', error_output); + ECL_SET(@'*error-output*', error_output); + + cl_core.terminal_io = aux + = cl_make_two_way_stream(standard_input, standard_output); + + ECL_SET(@'*terminal-io*', aux); + aux = cl_make_synonym_stream(@'*terminal-io*'); + ECL_SET(@'*query-io*', aux); + ECL_SET(@'*debug-io*', aux); } - diff -Nru ecl-16.1.2/src/c/format.d ecl-16.1.3+ds/src/c/format.d --- ecl-16.1.2/src/c/format.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/format.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - format.c -- Format. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * format.d - format + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -65,33 +60,33 @@ #define CHAR 2 static const char *fmt_big_numeral[] = { - "thousand", - "million", - "billion", - "trillion", - "quadrillion", - "quintillion", - "sextillion", - "septillion", - "octillion" + "thousand", + "million", + "billion", + "trillion", + "quadrillion", + "quintillion", + "sextillion", + "septillion", + "octillion" }; static const char *fmt_numeral[] = { - "zero", "one", "two", "three", "four", - "five", "six", "seven", "eight", "nine", - "ten", "eleven", "twelve", "thirteen", "fourteen", - "fifteen", "sixteen", "seventeen", "eighteen", "nineteen", - "zero", "ten", "twenty", "thirty", "forty", - "fifty", "sixty", "seventy", "eighty", "ninety" + "zero", "one", "two", "three", "four", + "five", "six", "seven", "eight", "nine", + "ten", "eleven", "twelve", "thirteen", "fourteen", + "fifteen", "sixteen", "seventeen", "eighteen", "nineteen", + "zero", "ten", "twenty", "thirty", "forty", + "fifty", "sixty", "seventy", "eighty", "ninety" }; static const char *fmt_ordinal[] = { - "zeroth", "first", "second", "third", "fourth", - "fifth", "sixth", "seventh", "eighth", "ninth", - "tenth", "eleventh", "twelfth", "thirteenth", "fourteenth", - "fifteenth", "sixteenth", "seventeenth", "eighteenth", "nineteenth", - "zeroth", "tenth", "twentieth", "thirtieth", "fortieth", - "fiftieth", "sixtieth", "seventieth", "eightieth", "ninetieth" + "zeroth", "first", "second", "third", "fourth", + "fifth", "sixth", "seventh", "eighth", "ninth", + "tenth", "eleventh", "twelfth", "thirteenth", "fourteenth", + "fifteenth", "sixteenth", "seventeenth", "eighteenth", "nineteenth", + "zeroth", "tenth", "twentieth", "thirtieth", "fortieth", + "fiftieth", "sixtieth", "seventieth", "eightieth", "ninetieth" }; static void format(format_stack, cl_index, cl_index); @@ -100,309 +95,309 @@ static cl_object get_aux_stream(void) { - cl_env_ptr env = ecl_process_env(); - cl_object stream; + cl_env_ptr env = ecl_process_env(); + cl_object stream; - ecl_disable_interrupts_env(env); - if (env->fmt_aux_stream == ECL_NIL) { - stream = ecl_make_string_output_stream(64, 1); - } else { - stream = env->fmt_aux_stream; - env->fmt_aux_stream = ECL_NIL; - } - ecl_enable_interrupts_env(env); - return stream; + ecl_disable_interrupts_env(env); + if (env->fmt_aux_stream == ECL_NIL) { + stream = ecl_make_string_output_stream(64, 1); + } else { + stream = env->fmt_aux_stream; + env->fmt_aux_stream = ECL_NIL; + } + ecl_enable_interrupts_env(env); + return stream; } static void fmt_error(format_stack fmt, const char *s) { - cl_error(7, @'si::format-error', - @':format-control', make_constant_base_string(s), - @':control-string', fmt->ctl_str, - @':offset', ecl_make_fixnum(fmt->ctl_index)); + cl_error(7, @'si::format-error', + @':format-control', make_constant_base_string(s), + @':control-string', fmt->ctl_str, + @':offset', ecl_make_fixnum(fmt->ctl_index)); } static ecl_character tempstr(format_stack fmt, int s) { - return ecl_char(fmt->aux_string,s); + return ecl_char(fmt->aux_string,s); } static ecl_character ctl_advance(format_stack fmt) { - if (fmt->ctl_index >= fmt->ctl_end) - fmt_error(fmt, "unexpected end of control string"); - return ecl_char(fmt->ctl_str, fmt->ctl_index++); + if (fmt->ctl_index >= fmt->ctl_end) + fmt_error(fmt, "unexpected end of control string"); + return ecl_char(fmt->ctl_str, fmt->ctl_index++); } static void fmt_go(format_stack fmt, cl_fixnum n) { - cl_object p; - if (n < 0) - fmt_error(fmt, "can't goto"); - if ((p = ecl_nthcdr(n, fmt->args)) == ECL_NIL) - fmt_error(fmt, "can't goto"); - fmt->current = p; + cl_object p; + if (n < 0) + fmt_error(fmt, "can't goto"); + if ((p = ecl_nthcdr(n, fmt->args)) == ECL_NIL) + fmt_error(fmt, "can't goto"); + fmt->current = p; } static cl_index fmt_index(format_stack fmt) { - cl_object p = fmt->args, target = fmt->current; - cl_index n = 0; - if (target == ECL_NIL) - return ecl_length(p); - while (p != fmt->current) { - p = CDR(p); - if (p == ECL_NIL) - fmt_error(fmt, "Overflow"); - n++; - } - return n; + cl_object p = fmt->args, target = fmt->current; + cl_index n = 0; + if (target == ECL_NIL) + return ecl_length(p); + while (p != fmt->current) { + p = CDR(p); + if (p == ECL_NIL) + fmt_error(fmt, "Overflow"); + n++; + } + return n; } static cl_object fmt_back_up(format_stack fmt) { - fmt_go(fmt, fmt_index(fmt) - 1); + fmt_go(fmt, fmt_index(fmt) - 1); } static bool fmt_more_args_p(format_stack fmt) { - return fmt->current != ECL_NIL; + return fmt->current != ECL_NIL; } static cl_index fmt_args_left(format_stack fmt) { - return ecl_length(fmt->current); + return ecl_length(fmt->current); } static cl_object fmt_advance(format_stack fmt) { - cl_object output, l = fmt->current; - if (l == ECL_NIL) - fmt_error(fmt, "arguments exhausted"); - output = CAR(l); - fmt->current = CDR(l); - return output; + cl_object output, l = fmt->current; + if (l == ECL_NIL) + fmt_error(fmt, "arguments exhausted"); + output = CAR(l); + fmt->current = CDR(l); + return output; } static void fmt_set_arg_list(format_stack fmt, cl_object l) { - assert_type_proper_list(l); - fmt->current = fmt->args = cl_copy_list(l); + assert_type_proper_list(l); + fmt->current = fmt->args = cl_copy_list(l); } static int fmt_skip(format_stack fmt) { - ecl_character c; - int level = 0; + ecl_character c; + int level = 0; -LOOP: - if (ctl_advance(fmt) != '~') - goto LOOP; - for (;;) - switch (c = ctl_advance(fmt)) { - case '\'': - ctl_advance(fmt); - - case ',': - case '0': case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': - case '+': - case '-': - case 'v': case 'V': - case '#': - case ':': case '@@': - continue; - - default: - goto DIRECTIVE; - } - -DIRECTIVE: - switch (c) { - case '(': case '[': case '<': case '{': - level++; - break; - - case ')': case ']': case '>': case '}': - if (level == 0) - return(fmt->ctl_index); - else - --level; - break; - - case ';': - if (level == 0) - return(fmt->ctl_index); - break; - } - goto LOOP; + LOOP: + if (ctl_advance(fmt) != '~') + goto LOOP; + for (;;) + switch (c = ctl_advance(fmt)) { + case '\'': + ctl_advance(fmt); + + case ',': + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + case '+': + case '-': + case 'v': case 'V': + case '#': + case ':': case '@@': + continue; + + default: + goto DIRECTIVE; + } + + DIRECTIVE: + switch (c) { + case '(': case '[': case '<': case '{': + level++; + break; + + case ')': case ']': case '>': case '}': + if (level == 0) + return(fmt->ctl_index); + else + --level; + break; + + case ';': + if (level == 0) + return(fmt->ctl_index); + break; + } + goto LOOP; } static void ensure_param(format_stack fmt, int n) { - if (fmt->nparam > n) - fmt_error(fmt, "too many parameters"); - while (n-- > fmt->nparam) - fmt->param[n] = ECL_NIL; + if (fmt->nparam > n) + fmt_error(fmt, "too many parameters"); + while (n-- > fmt->nparam) + fmt->param[n] = ECL_NIL; } static void fmt_not_colon(format_stack fmt, bool colon) { - if (colon) - fmt_error(fmt, "illegal :"); + if (colon) + fmt_error(fmt, "illegal :"); } static void fmt_not_atsign(format_stack fmt, bool atsign) { - if (atsign) - fmt_error(fmt, "illegal @@"); + if (atsign) + fmt_error(fmt, "illegal @@"); } static void fmt_not_colon_atsign(format_stack fmt, bool colon, bool atsign) { - if (colon && atsign) - fmt_error(fmt, "illegal :@@"); + if (colon && atsign) + fmt_error(fmt, "illegal :@@"); } static cl_object set_param(format_stack fmt, int i, int t, cl_object v) { - if (i >= fmt->nparam || fmt->param[i] == ECL_NIL) - return v; - else if ((t != INT && t != CHAR) || - (t == INT && !cl_integerp(fmt->param[i])) || - (t == CHAR && !ECL_CHARACTERP(fmt->param[i]))) - fmt_error(fmt, "illegal parameter type"); - return fmt->param[i]; + if (i >= fmt->nparam || fmt->param[i] == ECL_NIL) + return v; + else if ((t != INT && t != CHAR) || + (t == INT && !cl_integerp(fmt->param[i])) || + (t == CHAR && !ECL_CHARACTERP(fmt->param[i]))) + fmt_error(fmt, "illegal parameter type"); + return fmt->param[i]; } static int set_param_positive(format_stack fmt, int i, const char *message) { - if (i >= fmt->nparam || fmt->param[i] == ECL_NIL) - return -1; - else if (cl_integerp(fmt->param[i]) == ECL_NIL) - fmt_error(fmt, "illegal parameter type"); - else { - cl_object p = fmt->param[i]; - if (ecl_minusp(p)) fmt_error(fmt, message); - return ecl_to_fix(p); - } + if (i >= fmt->nparam || fmt->param[i] == ECL_NIL) + return -1; + else if (cl_integerp(fmt->param[i]) == ECL_NIL) + fmt_error(fmt, "illegal parameter type"); + else { + cl_object p = fmt->param[i]; + if (ecl_minusp(p)) fmt_error(fmt, message); + return ecl_to_fix(p); + } } static void fmt_copy(format_stack fmt_copy, format_stack fmt) { - *fmt_copy = *fmt; + *fmt_copy = *fmt; } static void fmt_copy1(format_stack fmt_copy, format_stack fmt) { - fmt_copy->stream = fmt->stream; - fmt_copy->ctl_str = fmt->ctl_str; - fmt_copy->ctl_index = fmt->ctl_index; - fmt_copy->ctl_end = fmt->ctl_end; - fmt_copy->jmp_buf = fmt->jmp_buf; - fmt_copy->indents = fmt->indents; + fmt_copy->stream = fmt->stream; + fmt_copy->ctl_str = fmt->ctl_str; + fmt_copy->ctl_index = fmt->ctl_index; + fmt_copy->ctl_end = fmt->ctl_end; + fmt_copy->jmp_buf = fmt->jmp_buf; + fmt_copy->indents = fmt->indents; } static void fmt_prepare_aux_stream(format_stack fmt) { - fmt->aux_string->base_string.fillp = 0; - fmt->aux_stream->stream.int0 = ecl_file_column(fmt->stream); - fmt->aux_stream->stream.int1 = ecl_file_column(fmt->stream); + fmt->aux_string->base_string.fillp = 0; + fmt->aux_stream->stream.int0 = ecl_file_column(fmt->stream); + fmt->aux_stream->stream.int1 = ecl_file_column(fmt->stream); } static void fmt_ascii(format_stack fmt, bool colon, bool atsign) { - int mincol, colinc, minpad; - ecl_character padchar; - cl_object x; - int l, i; - - ensure_param(fmt, 4); - mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1))); - minpad = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); - padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' '))); - - fmt_prepare_aux_stream(fmt); - x = fmt_advance(fmt); - if (colon && Null(x)) - writestr_stream("()", fmt->aux_stream); - else if (mincol == 0 && minpad == 0) { - ecl_princ(x, fmt->stream); - return; - } else - ecl_princ(x, fmt->aux_stream); - l = fmt->aux_string->base_string.fillp; - for (i = minpad; l + i < mincol; i += colinc) - ; - if (!atsign) { - ecl_write_string(fmt->aux_string, fmt->stream); - while (i-- > 0) - ecl_write_char(padchar, fmt->stream); - } else { - while (i-- > 0) - ecl_write_char(padchar, fmt->stream); - ecl_write_string(fmt->aux_string, fmt->stream); - } + int mincol, colinc, minpad; + ecl_character padchar; + cl_object x; + int l, i; + + ensure_param(fmt, 4); + mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1))); + minpad = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); + padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' '))); + + fmt_prepare_aux_stream(fmt); + x = fmt_advance(fmt); + if (colon && Null(x)) + writestr_stream("()", fmt->aux_stream); + else if (mincol == 0 && minpad == 0) { + ecl_princ(x, fmt->stream); + return; + } else + ecl_princ(x, fmt->aux_stream); + l = fmt->aux_string->base_string.fillp; + for (i = minpad; l + i < mincol; i += colinc) + ; + if (!atsign) { + ecl_write_string(fmt->aux_string, fmt->stream); + while (i-- > 0) + ecl_write_char(padchar, fmt->stream); + } else { + while (i-- > 0) + ecl_write_char(padchar, fmt->stream); + ecl_write_string(fmt->aux_string, fmt->stream); + } } static void fmt_S_expression(format_stack fmt, bool colon, bool atsign) { - int mincol, colinc, minpad; - ecl_character padchar; - cl_object x; - int l, i; - - ensure_param(fmt, 4); - mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1))); - minpad = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); - padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' '))); - - fmt_prepare_aux_stream(fmt); - x = fmt_advance(fmt); - if (colon && Null(x)) - writestr_stream("()", fmt->aux_stream); - else if (mincol == 0 && minpad == 0) { - ecl_prin1(x, fmt->stream); - return; - } else - ecl_prin1(x, fmt->aux_stream); - l = fmt->aux_string->base_string.fillp; - for (i = minpad; l + i < mincol; i += colinc) - ; - if (!atsign) { - ecl_write_string(fmt->aux_string, fmt->stream); - while (i-- > 0) - ecl_write_char(padchar, fmt->stream); - } else { - while (i-- > 0) - ecl_write_char(padchar, fmt->stream); - ecl_write_string(fmt->aux_string, fmt->stream); - } + int mincol, colinc, minpad; + ecl_character padchar; + cl_object x; + int l, i; + + ensure_param(fmt, 4); + mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1))); + minpad = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); + padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' '))); + + fmt_prepare_aux_stream(fmt); + x = fmt_advance(fmt); + if (colon && Null(x)) + writestr_stream("()", fmt->aux_stream); + else if (mincol == 0 && minpad == 0) { + ecl_prin1(x, fmt->stream); + return; + } else + ecl_prin1(x, fmt->aux_stream); + l = fmt->aux_string->base_string.fillp; + for (i = minpad; l + i < mincol; i += colinc) + ; + if (!atsign) { + ecl_write_string(fmt->aux_string, fmt->stream); + while (i-- > 0) + ecl_write_char(padchar, fmt->stream); + } else { + while (i-- > 0) + ecl_write_char(padchar, fmt->stream); + ecl_write_string(fmt->aux_string, fmt->stream); + } } @@ -410,334 +405,334 @@ fmt_integer(format_stack fmt, cl_object x, bool colon, bool atsign, int radix, int mincol, ecl_character padchar, ecl_character commachar) { - const cl_env_ptr env = ecl_process_env(); - int l, l1; - int s; - - if (!ECL_FIXNUMP(x) && ecl_t_of(x) != t_bignum) { - fmt_prepare_aux_stream(fmt); - ecl_bds_bind(env, @'*print-escape*', ECL_NIL); - ecl_bds_bind(env, @'*print-base*', ecl_make_fixnum(radix)); - si_write_object(x, fmt->aux_stream); - ecl_bds_unwind_n(env, 2); - l = fmt->aux_string->base_string.fillp; - mincol -= l; - while (mincol-- > 0) - ecl_write_char(padchar, fmt->stream); - ecl_write_string(fmt->aux_string, fmt->stream); - return; - } - fmt_prepare_aux_stream(fmt); - ecl_bds_bind(env, @'*print-radix*', ECL_NIL); - ecl_bds_bind(env, @'*print-base*', ecl_make_fixnum(radix)); - si_write_object(x, fmt->aux_stream); - ecl_bds_unwind_n(env, 2); - l = l1 = fmt->aux_string->base_string.fillp; - s = 0; - if (tempstr(fmt, s) == '-') - --l1; - mincol -= l; - if (colon) - mincol -= (l1 - 1)/3; - if (atsign && tempstr(fmt, s) != '-') - --mincol; - while (mincol-- > 0) - ecl_write_char(padchar, fmt->stream); - if (tempstr(fmt, s) == '-') { - s++; - ecl_write_char('-', fmt->stream); - } else if (atsign) - ecl_write_char('+', fmt->stream); - while (l1-- > 0) { - ecl_write_char(tempstr(fmt, s++), fmt->stream); - if (colon && l1 > 0 && l1%3 == 0) - ecl_write_char(commachar, fmt->stream); - } + const cl_env_ptr env = ecl_process_env(); + int l, l1; + int s; + + if (!ECL_FIXNUMP(x) && ecl_t_of(x) != t_bignum) { + fmt_prepare_aux_stream(fmt); + ecl_bds_bind(env, @'*print-escape*', ECL_NIL); + ecl_bds_bind(env, @'*print-base*', ecl_make_fixnum(radix)); + si_write_object(x, fmt->aux_stream); + ecl_bds_unwind_n(env, 2); + l = fmt->aux_string->base_string.fillp; + mincol -= l; + while (mincol-- > 0) + ecl_write_char(padchar, fmt->stream); + ecl_write_string(fmt->aux_string, fmt->stream); + return; + } + fmt_prepare_aux_stream(fmt); + ecl_bds_bind(env, @'*print-radix*', ECL_NIL); + ecl_bds_bind(env, @'*print-base*', ecl_make_fixnum(radix)); + si_write_object(x, fmt->aux_stream); + ecl_bds_unwind_n(env, 2); + l = l1 = fmt->aux_string->base_string.fillp; + s = 0; + if (tempstr(fmt, s) == '-') + --l1; + mincol -= l; + if (colon) + mincol -= (l1 - 1)/3; + if (atsign && tempstr(fmt, s) != '-') + --mincol; + while (mincol-- > 0) + ecl_write_char(padchar, fmt->stream); + if (tempstr(fmt, s) == '-') { + s++; + ecl_write_char('-', fmt->stream); + } else if (atsign) + ecl_write_char('+', fmt->stream); + while (l1-- > 0) { + ecl_write_char(tempstr(fmt, s++), fmt->stream); + if (colon && l1 > 0 && l1%3 == 0) + ecl_write_char(commachar, fmt->stream); + } } static void fmt_decimal(format_stack fmt, bool colon, bool atsign) { - int mincol; - ecl_character padchar, commachar; + int mincol; + ecl_character padchar, commachar; - ensure_param(fmt, 3); - mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' '))); - commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(','))); - fmt_integer(fmt, fmt_advance(fmt), colon, atsign, - 10, mincol, padchar, commachar); + ensure_param(fmt, 3); + mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' '))); + commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(','))); + fmt_integer(fmt, fmt_advance(fmt), colon, atsign, + 10, mincol, padchar, commachar); } static void fmt_binary(format_stack fmt, bool colon, bool atsign) { - int mincol; - ecl_character padchar, commachar; + int mincol; + ecl_character padchar, commachar; - ensure_param(fmt, 3); - mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' '))); - commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(','))); - fmt_integer(fmt, fmt_advance(fmt), colon, atsign, - 2, mincol, padchar, commachar); + ensure_param(fmt, 3); + mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' '))); + commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(','))); + fmt_integer(fmt, fmt_advance(fmt), colon, atsign, + 2, mincol, padchar, commachar); } static void fmt_octal(format_stack fmt, bool colon, bool atsign) { - int mincol; - ecl_character padchar, commachar; + int mincol; + ecl_character padchar, commachar; - ensure_param(fmt, 3); - mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' '))); - commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(','))); - fmt_integer(fmt, fmt_advance(fmt), colon, atsign, - 8, mincol, padchar, commachar); + ensure_param(fmt, 3); + mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' '))); + commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(','))); + fmt_integer(fmt, fmt_advance(fmt), colon, atsign, + 8, mincol, padchar, commachar); } static void fmt_hexadecimal(format_stack fmt, bool colon, bool atsign) { - int mincol; - ecl_character padchar, commachar; + int mincol; + ecl_character padchar, commachar; - ensure_param(fmt, 3); - mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' '))); - commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(','))); - fmt_integer(fmt, fmt_advance(fmt), colon, atsign, - 16, mincol, padchar, commachar); + ensure_param(fmt, 3); + mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' '))); + commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(','))); + fmt_integer(fmt, fmt_advance(fmt), colon, atsign, + 16, mincol, padchar, commachar); } static void fmt_write_numeral(format_stack fmt, int s, int i) { - writestr_stream(fmt_numeral[tempstr(fmt, s) - '0' + i], fmt->stream); + writestr_stream(fmt_numeral[tempstr(fmt, s) - '0' + i], fmt->stream); } static void fmt_write_ordinal(format_stack fmt, int s, int i) { - writestr_stream(fmt_ordinal[tempstr(fmt, s) - '0' + i], fmt->stream); + writestr_stream(fmt_ordinal[tempstr(fmt, s) - '0' + i], fmt->stream); } static bool fmt_thousand(format_stack fmt, int s, int i, bool b, bool o, int t) { - if (i == 3 && tempstr(fmt, s) > '0') { - if (b) - ecl_write_char(' ', fmt->stream); - fmt_write_numeral(fmt, s, 0); - writestr_stream(" hundred", fmt->stream); - --i; - s++; - b = TRUE; - if (o && (s > t)) - writestr_stream("th", fmt->stream); - } - if (i == 3) { - --i; - s++; - } - if (i == 2 && tempstr(fmt, s) > '0') { - if (b) - ecl_write_char(' ', fmt->stream); - if (tempstr(fmt, s) == '1') { - if (o && (s + 2 > t)) - fmt_write_ordinal(fmt, ++s, 10); - else - fmt_write_numeral(fmt, ++s, 10); - return(TRUE); - } else { - if (o && (s + 1 > t)) - fmt_write_ordinal(fmt, s, 20); - else - fmt_write_numeral(fmt, s, 20); - s++; - if (tempstr(fmt, s) > '0') { - ecl_write_char('-', fmt->stream); - if (o && s + 1 > t) - fmt_write_ordinal(fmt, s, 0); - else - fmt_write_numeral(fmt, s, 0); - } - return(TRUE); - } - } - if (i == 2) - s++; - if (tempstr(fmt, s) > '0') { - if (b) - ecl_write_char(' ', fmt->stream); - if (o && s + 1 > t) - fmt_write_ordinal(fmt, s, 0); - else - fmt_write_numeral(fmt, s, 0); - return(TRUE); - } - return(b); + if (i == 3 && tempstr(fmt, s) > '0') { + if (b) + ecl_write_char(' ', fmt->stream); + fmt_write_numeral(fmt, s, 0); + writestr_stream(" hundred", fmt->stream); + --i; + s++; + b = TRUE; + if (o && (s > t)) + writestr_stream("th", fmt->stream); + } + if (i == 3) { + --i; + s++; + } + if (i == 2 && tempstr(fmt, s) > '0') { + if (b) + ecl_write_char(' ', fmt->stream); + if (tempstr(fmt, s) == '1') { + if (o && (s + 2 > t)) + fmt_write_ordinal(fmt, ++s, 10); + else + fmt_write_numeral(fmt, ++s, 10); + return(TRUE); + } else { + if (o && (s + 1 > t)) + fmt_write_ordinal(fmt, s, 20); + else + fmt_write_numeral(fmt, s, 20); + s++; + if (tempstr(fmt, s) > '0') { + ecl_write_char('-', fmt->stream); + if (o && s + 1 > t) + fmt_write_ordinal(fmt, s, 0); + else + fmt_write_numeral(fmt, s, 0); + } + return(TRUE); + } + } + if (i == 2) + s++; + if (tempstr(fmt, s) > '0') { + if (b) + ecl_write_char(' ', fmt->stream); + if (o && s + 1 > t) + fmt_write_ordinal(fmt, s, 0); + else + fmt_write_numeral(fmt, s, 0); + return(TRUE); + } + return(b); } static bool fmt_nonillion(format_stack fmt, int s, int i, bool b, bool o, int t) { - int j; + int j; - for (; i > 3; i -= j) { - b = fmt_thousand(fmt, s, j = (i+2)%3+1, b, FALSE, t); - if (j != 3 || tempstr(fmt, s) != '0' || - tempstr(fmt, s+1) != '0' || tempstr(fmt, s+2) != '0') { - ecl_write_char(' ', fmt->stream); - writestr_stream(fmt_big_numeral[(i - 1)/3 - 1], - fmt->stream); - s += j; - if (o && s > t) - writestr_stream("th", fmt->stream); - } else - s += j; - } - return(fmt_thousand(fmt, s, i, b, o, t)); + for (; i > 3; i -= j) { + b = fmt_thousand(fmt, s, j = (i+2)%3+1, b, FALSE, t); + if (j != 3 || tempstr(fmt, s) != '0' || + tempstr(fmt, s+1) != '0' || tempstr(fmt, s+2) != '0') { + ecl_write_char(' ', fmt->stream); + writestr_stream(fmt_big_numeral[(i - 1)/3 - 1], + fmt->stream); + s += j; + if (o && s > t) + writestr_stream("th", fmt->stream); + } else + s += j; + } + return(fmt_thousand(fmt, s, i, b, o, t)); } static void fmt_roman(format_stack fmt, int i, int one, int five, int ten, bool colon) { - int j; + int j; - if (i == 0) - return; - if ((!colon && i < 4) || (colon && i < 5)) - for (j = 0; j < i; j++) - ecl_write_char(one, fmt->stream); - else if (!colon && i == 4) { - ecl_write_char(one, fmt->stream); - ecl_write_char(five, fmt->stream); - } else if ((!colon && i < 9) || colon) { - ecl_write_char(five, fmt->stream); - for (j = 5; j < i; j++) - ecl_write_char(one, fmt->stream); - } else if (!colon && i == 9) { - ecl_write_char(one, fmt->stream); - ecl_write_char(ten, fmt->stream); - } + if (i == 0) + return; + if ((!colon && i < 4) || (colon && i < 5)) + for (j = 0; j < i; j++) + ecl_write_char(one, fmt->stream); + else if (!colon && i == 4) { + ecl_write_char(one, fmt->stream); + ecl_write_char(five, fmt->stream); + } else if ((!colon && i < 9) || colon) { + ecl_write_char(five, fmt->stream); + for (j = 5; j < i; j++) + ecl_write_char(one, fmt->stream); + } else if (!colon && i == 9) { + ecl_write_char(one, fmt->stream); + ecl_write_char(ten, fmt->stream); + } } static void fmt_radix(format_stack fmt, bool colon, bool atsign) { - const cl_env_ptr env = ecl_process_env(); - int radix, mincol; - ecl_character padchar, commachar; - cl_object x; - int i, j, k; - int s, t; - bool b; - - if (fmt->nparam == 0) { - x = fmt_advance(fmt); - assert_type_integer(x); - if (atsign) { - if (ECL_FIXNUMP(x)) - i = ecl_fixnum(x); - else - i = -1; - if ((!colon && (i <= 0 || i >= 4000)) || - (colon && (i <= 0 || i >= 5000))) { - fmt_integer(fmt, x, FALSE, FALSE, 10, 0, ' ', ','); - return; - } - fmt_roman(fmt, i/1000, 'M', '*', '*', colon); - fmt_roman(fmt, i%1000/100, 'C', 'D', 'M', colon); - fmt_roman(fmt, i%100/10, 'X', 'L', 'C', colon); - fmt_roman(fmt, i%10, 'I', 'V', 'X', colon); - return; - } - fmt_prepare_aux_stream(fmt); - ecl_bds_bind(env, @'*print-radix*', ECL_NIL); - ecl_bds_bind(env, @'*print-base*', ecl_make_fixnum(10)); - si_write_object(x, fmt->aux_stream); - ecl_bds_unwind_n(env, 2); - s = 0; - i = fmt->aux_string->base_string.fillp; - if (i == 1 && tempstr(fmt, s) == '0') { - writestr_stream("zero", fmt->stream); - if (colon) - writestr_stream("th", fmt->stream); - return; - } else if (tempstr(fmt, s) == '-') { - writestr_stream("minus ", fmt->stream); - --i; - s++; - } - t = fmt->aux_string->base_string.fillp; - for (; tempstr(fmt, --t) == '0' ;) ; - for (b = FALSE; i > 0; i -= j) { - b = fmt_nonillion(fmt, s, j = (i+29)%30+1, b, - i<=30&&colon, t); - s += j; - if (b && i > 30) { - for (k = (i - 1)/30; k > 0; --k) - writestr_stream(" nonillion", - fmt->stream); - if (colon && s > t) - writestr_stream("th", fmt->stream); - } - } - return; - } - ensure_param(fmt, 4); - radix = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(10))); - mincol = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(0))); - padchar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(' '))); - commachar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(','))); - x = fmt_advance(fmt); - assert_type_integer(x); - if (radix < 0 || radix > 36) - FEerror("~D is illegal as a radix.", 1, ecl_make_fixnum(radix)); - fmt_integer(fmt, x, colon, atsign, radix, mincol, padchar, commachar); + const cl_env_ptr env = ecl_process_env(); + int radix, mincol; + ecl_character padchar, commachar; + cl_object x; + int i, j, k; + int s, t; + bool b; + + if (fmt->nparam == 0) { + x = fmt_advance(fmt); + assert_type_integer(x); + if (atsign) { + if (ECL_FIXNUMP(x)) + i = ecl_fixnum(x); + else + i = -1; + if ((!colon && (i <= 0 || i >= 4000)) || + (colon && (i <= 0 || i >= 5000))) { + fmt_integer(fmt, x, FALSE, FALSE, 10, 0, ' ', ','); + return; + } + fmt_roman(fmt, i/1000, 'M', '*', '*', colon); + fmt_roman(fmt, i%1000/100, 'C', 'D', 'M', colon); + fmt_roman(fmt, i%100/10, 'X', 'L', 'C', colon); + fmt_roman(fmt, i%10, 'I', 'V', 'X', colon); + return; + } + fmt_prepare_aux_stream(fmt); + ecl_bds_bind(env, @'*print-radix*', ECL_NIL); + ecl_bds_bind(env, @'*print-base*', ecl_make_fixnum(10)); + si_write_object(x, fmt->aux_stream); + ecl_bds_unwind_n(env, 2); + s = 0; + i = fmt->aux_string->base_string.fillp; + if (i == 1 && tempstr(fmt, s) == '0') { + writestr_stream("zero", fmt->stream); + if (colon) + writestr_stream("th", fmt->stream); + return; + } else if (tempstr(fmt, s) == '-') { + writestr_stream("minus ", fmt->stream); + --i; + s++; + } + t = fmt->aux_string->base_string.fillp; + for (; tempstr(fmt, --t) == '0' ;) ; + for (b = FALSE; i > 0; i -= j) { + b = fmt_nonillion(fmt, s, j = (i+29)%30+1, b, + i<=30&&colon, t); + s += j; + if (b && i > 30) { + for (k = (i - 1)/30; k > 0; --k) + writestr_stream(" nonillion", + fmt->stream); + if (colon && s > t) + writestr_stream("th", fmt->stream); + } + } + return; + } + ensure_param(fmt, 4); + radix = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(10))); + mincol = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(0))); + padchar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(' '))); + commachar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(','))); + x = fmt_advance(fmt); + assert_type_integer(x); + if (radix < 0 || radix > 36) + FEerror("~D is illegal as a radix.", 1, ecl_make_fixnum(radix)); + fmt_integer(fmt, x, colon, atsign, radix, mincol, padchar, commachar); } static void fmt_plural(format_stack fmt, bool colon, bool atsign) { - ensure_param(fmt, 0); - if (colon) { - fmt_back_up(fmt); - } - if (ecl_eql(fmt_advance(fmt), ecl_make_fixnum(1))) { - if (atsign) - ecl_write_char('y', fmt->stream); - } - else - if (atsign) - writestr_stream("ies", fmt->stream); - else - ecl_write_char('s', fmt->stream); + ensure_param(fmt, 0); + if (colon) { + fmt_back_up(fmt); + } + if (ecl_eql(fmt_advance(fmt), ecl_make_fixnum(1))) { + if (atsign) + ecl_write_char('y', fmt->stream); + } + else + if (atsign) + writestr_stream("ies", fmt->stream); + else + ecl_write_char('s', fmt->stream); } static void fmt_character(format_stack fmt, bool colon, bool atsign) { - cl_object x; - cl_index i; + cl_object x; + cl_index i; - ensure_param(fmt, 0); - x = fmt_advance(fmt); - x = ecl_check_cl_type(@'format',x,t_character); - if (!colon && !atsign) { - ecl_write_char(ECL_CHAR_CODE(x), fmt->stream); - } else { - fmt_prepare_aux_stream(fmt); - ecl_prin1(x, fmt->aux_stream); - if (!colon && atsign) - i = 0; - else - i = 2; - for (; i < fmt->aux_string->base_string.fillp; i++) - ecl_write_char(tempstr(fmt, i), fmt->stream); - } + ensure_param(fmt, 0); + x = fmt_advance(fmt); + x = ecl_check_cl_type(@'format',x,t_character); + if (!colon && !atsign) { + ecl_write_char(ECL_CHAR_CODE(x), fmt->stream); + } else { + fmt_prepare_aux_stream(fmt); + ecl_prin1(x, fmt->aux_stream); + if (!colon && atsign) + i = 0; + else + i = 2; + for (; i < fmt->aux_string->base_string.fillp; i++) + ecl_write_char(tempstr(fmt, i), fmt->stream); + } } /* The floating point precision is required to make the @@ -785,1465 +780,1465 @@ static int edit_double(int n, DBL_TYPE d, int *sp, char *s, int *ep) { - char *exponent, buff[DBL_SIZE + 1]; - int length; + char *exponent, buff[DBL_SIZE + 1]; + int length; -ECL_WITHOUT_FPE_BEGIN { - unlikely_if (isnan(d) || !isfinite(d)) { - FEerror("Can't print a non-number.", 0); - } - if (n < -DBL_MAX_DIGITS) - n = DBL_MAX_DIGITS; - if (n < 0) { - DBL_TYPE aux; - n = -n; - do { - sprintf(buff, "%- *.*" EXP_STRING, n + 1 + 1 + DBL_EXPONENT_SIZE, n-1, d); - aux = strtod(buff, NULL); + ECL_WITHOUT_FPE_BEGIN { + unlikely_if (isnan(d) || !isfinite(d)) { + FEerror("Can't print a non-number.", 0); + } + if (n < -DBL_MAX_DIGITS) + n = DBL_MAX_DIGITS; + if (n < 0) { + DBL_TYPE aux; + n = -n; + do { + sprintf(buff, "%- *.*" EXP_STRING, n + 1 + 1 + DBL_EXPONENT_SIZE, n-1, d); + aux = strtod(buff, NULL); #ifdef ECL_LONG_FLOAT - if (n < LDBL_SIG) - aux = (double) aux; + if (n < LDBL_SIG) + aux = (double) aux; #endif - if (n < DBL_SIG) - aux = (float)aux; - n++; - } while (d != aux && n <= DBL_MAX_DIGITS); - n--; - } else { - sprintf(buff, "%- *.*" EXP_STRING, DBL_SIZE, - (n <= DBL_MAX_DIGITS)? (n-1) : (DBL_MAX_DIGITS-1), d); - } - exponent = strchr(buff, 'e'); - - /* Get the exponent */ - *ep = strtol(exponent+1, NULL, 10); - - /* Get the sign */ - *sp = (buff[0] == '-') ? -1 : +1; - - /* Get the digits of the mantissa */ - buff[2] = buff[1]; - - /* Get the actual number of digits in the mantissa */ - length = exponent - (buff + 2); - - /* The output consists of a string {d1,d2,d3,...,dn} - with all N digits of the mantissa. If we ask for more - digits than there are, the last ones are set to zero. */ - if (n <= length) { - memcpy(s, buff+2, n); - } else { - cl_index i; - memcpy(s, buff+2, length); - for (i = length; i < n; i++) - s[i] = '0'; - } - s[n] = '\0'; -} ECL_WITHOUT_FPE_END; + if (n < DBL_SIG) + aux = (float)aux; + n++; + } while (d != aux && n <= DBL_MAX_DIGITS); + n--; + } else { + sprintf(buff, "%- *.*" EXP_STRING, DBL_SIZE, + (n <= DBL_MAX_DIGITS)? (n-1) : (DBL_MAX_DIGITS-1), d); + } + exponent = strchr(buff, 'e'); + + /* Get the exponent */ + *ep = strtol(exponent+1, NULL, 10); + + /* Get the sign */ + *sp = (buff[0] == '-') ? -1 : +1; + + /* Get the digits of the mantissa */ + buff[2] = buff[1]; + + /* Get the actual number of digits in the mantissa */ + length = exponent - (buff + 2); + + /* The output consists of a string {d1,d2,d3,...,dn} + with all N digits of the mantissa. If we ask for more + digits than there are, the last ones are set to zero. */ + if (n <= length) { + memcpy(s, buff+2, n); + } else { + cl_index i; + memcpy(s, buff+2, length); + for (i = length; i < n; i++) + s[i] = '0'; + } + s[n] = '\0'; + } ECL_WITHOUT_FPE_END; - return length; + return length; } static void fmt_fix_float(format_stack fmt, bool colon, bool atsign) { - int w, d, k; - ecl_character overflowchar, padchar; - double f; - int sign; - char buff[256], *b, buff1[256]; - int exp; - int i, j; - cl_object x; - int n, m; - - b = buff1 + 1; - - fmt_not_colon(fmt, colon); - ensure_param(fmt, 5); - w = set_param_positive(fmt, 0, "illegal width"); - d = set_param_positive(fmt, 1, "illegal number of digits"); - k = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); - overflowchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR('\0'))); - padchar = ECL_CHAR_CODE(set_param(fmt, 4, CHAR, ECL_CODE_CHAR(' '))); - - x = fmt_advance(fmt); - if (ECL_FIXNUMP(x) || - ecl_t_of(x) == t_bignum || - ecl_t_of(x) == t_ratio) - x = ecl_make_single_float(ecl_to_float(x)); - if (!ECL_REAL_TYPE_P(ecl_t_of(x))) { - if (fmt->nparam > 1) fmt->nparam = 1; - fmt_back_up(fmt); - fmt_decimal(fmt, colon, atsign); - return; - } - if (ecl_t_of(x) == t_doublefloat) - n = 16; - else - n = 7; - f = ecl_to_double(x); - edit_double(n, f, &sign, buff, &exp); - if (exp + k > 100 || exp + k < -100 || d > 100) { - ecl_prin1(x, fmt->stream); - return; - } - if (d >= 0) - m = d + exp + k + 1; - else if (w >= 0) { - if (exp + k >= 0) - m = w - 1; - else - m = w + exp + k - 2; - if (sign < 0 || atsign) - --m; - if (m == 0) - m = 1; - } else - m = n; - if (m <= 0) { - if (m == 0 && buff[0] >= '5') { - exp++; - n = m = 1; - buff[0] = '1'; - } else - n = m = 0; - } else if (m < n) { - n = m; - edit_double(n, f, &sign, buff, &exp); - } - while (n >= 0) - if (buff[n - 1] == '0') - --n; - else - break; - exp += k; - j = 0; - if (exp >= 0) { - for (i = 0; i <= exp; i++) - b[j++] = i < n ? buff[i] : '0'; - b[j++] = '.'; - if (d >= 0) - for (m = i + d; i < m; i++) - b[j++] = i < n ? buff[i] : '0'; - else - for (; i < n; i++) - b[j++] = buff[i]; - } else { - b[j++] = '.'; - if (d >= 0) { - for (i = 0; i < (-exp) - 1 && i < d; i++) - b[j++] = '0'; - for (m = d - i, i = 0; i < m; i++) - b[j++] = i < n ? buff[i] : '0'; - } else if (n > 0) { - for (i = 0; i < (-exp) - 1; i++) - b[j++] = '0'; - for (i = 0; i < n; i++) - b[j++] = buff[i]; - } - } - b[j] = '\0'; - if (w >= 0) { - if (sign < 0 || atsign) - --w; - if (j > w && overflowchar != '\0') { - w = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - for (i = 0; i < w; i++) - ecl_write_char(overflowchar, fmt->stream); - return; - } - if (j < w && d < 0 && b[j-1] == '.') { - b[j++] = '0'; - b[j] = '\0'; - } - if (j < w && b[0] == '.') { - *--b = '0'; - j++; - } - for (i = j; i < w; i++) - ecl_write_char(padchar, fmt->stream); - } else { - if (b[0] == '.') { - *--b = '0'; - j++; - } - if (d < 0 && b[j-1] == '.') { - b[j++] = '0'; - b[j] = '\0'; - } - } - if (sign < 0) - ecl_write_char('-', fmt->stream); - else if (atsign) - ecl_write_char('+', fmt->stream); - writestr_stream(b, fmt->stream); + int w, d, k; + ecl_character overflowchar, padchar; + double f; + int sign; + char buff[256], *b, buff1[256]; + int exp; + int i, j; + cl_object x; + int n, m; + + b = buff1 + 1; + + fmt_not_colon(fmt, colon); + ensure_param(fmt, 5); + w = set_param_positive(fmt, 0, "illegal width"); + d = set_param_positive(fmt, 1, "illegal number of digits"); + k = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); + overflowchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR('\0'))); + padchar = ECL_CHAR_CODE(set_param(fmt, 4, CHAR, ECL_CODE_CHAR(' '))); + + x = fmt_advance(fmt); + if (ECL_FIXNUMP(x) || + ecl_t_of(x) == t_bignum || + ecl_t_of(x) == t_ratio) + x = ecl_make_single_float(ecl_to_float(x)); + if (!ECL_REAL_TYPE_P(ecl_t_of(x))) { + if (fmt->nparam > 1) fmt->nparam = 1; + fmt_back_up(fmt); + fmt_decimal(fmt, colon, atsign); + return; + } + if (ecl_t_of(x) == t_doublefloat) + n = 16; + else + n = 7; + f = ecl_to_double(x); + edit_double(n, f, &sign, buff, &exp); + if (exp + k > 100 || exp + k < -100 || d > 100) { + ecl_prin1(x, fmt->stream); + return; + } + if (d >= 0) + m = d + exp + k + 1; + else if (w >= 0) { + if (exp + k >= 0) + m = w - 1; + else + m = w + exp + k - 2; + if (sign < 0 || atsign) + --m; + if (m == 0) + m = 1; + } else + m = n; + if (m <= 0) { + if (m == 0 && buff[0] >= '5') { + exp++; + n = m = 1; + buff[0] = '1'; + } else + n = m = 0; + } else if (m < n) { + n = m; + edit_double(n, f, &sign, buff, &exp); + } + while (n >= 0) + if (buff[n - 1] == '0') + --n; + else + break; + exp += k; + j = 0; + if (exp >= 0) { + for (i = 0; i <= exp; i++) + b[j++] = i < n ? buff[i] : '0'; + b[j++] = '.'; + if (d >= 0) + for (m = i + d; i < m; i++) + b[j++] = i < n ? buff[i] : '0'; + else + for (; i < n; i++) + b[j++] = buff[i]; + } else { + b[j++] = '.'; + if (d >= 0) { + for (i = 0; i < (-exp) - 1 && i < d; i++) + b[j++] = '0'; + for (m = d - i, i = 0; i < m; i++) + b[j++] = i < n ? buff[i] : '0'; + } else if (n > 0) { + for (i = 0; i < (-exp) - 1; i++) + b[j++] = '0'; + for (i = 0; i < n; i++) + b[j++] = buff[i]; + } + } + b[j] = '\0'; + if (w >= 0) { + if (sign < 0 || atsign) + --w; + if (j > w && overflowchar != '\0') { + w = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + for (i = 0; i < w; i++) + ecl_write_char(overflowchar, fmt->stream); + return; + } + if (j < w && d < 0 && b[j-1] == '.') { + b[j++] = '0'; + b[j] = '\0'; + } + if (j < w && b[0] == '.') { + *--b = '0'; + j++; + } + for (i = j; i < w; i++) + ecl_write_char(padchar, fmt->stream); + } else { + if (b[0] == '.') { + *--b = '0'; + j++; + } + if (d < 0 && b[j-1] == '.') { + b[j++] = '0'; + b[j] = '\0'; + } + } + if (sign < 0) + ecl_write_char('-', fmt->stream); + else if (atsign) + ecl_write_char('+', fmt->stream); + writestr_stream(b, fmt->stream); } static int fmt_exponent_length(int e) { - int i; + int i; - if (e == 0) - return(1); - if (e < 0) - e = -e; - for (i = 0; e > 0; i++, e /= 10) - ; - return(i); + if (e == 0) + return(1); + if (e < 0) + e = -e; + for (i = 0; e > 0; i++, e /= 10) + ; + return(i); } static void fmt_exponent1(cl_object stream, int e) { - if (e == 0) - return; - fmt_exponent1(stream, e/10); - ecl_write_char('0' + e%10, stream); + if (e == 0) + return; + fmt_exponent1(stream, e/10); + ecl_write_char('0' + e%10, stream); } static void fmt_exponent(format_stack fmt, int e) { - if (e == 0) { - ecl_write_char('0', fmt->stream); - return; - } - if (e < 0) - e = -e; - fmt_exponent1(fmt->stream, e); + if (e == 0) { + ecl_write_char('0', fmt->stream); + return; + } + if (e < 0) + e = -e; + fmt_exponent1(fmt->stream, e); } static void fmt_exponential_float(format_stack fmt, bool colon, bool atsign) { - int w, d, e, k; - ecl_character overflowchar, padchar, exponentchar; - double f; - int sign; - char buff[256], *b, buff1[256]; - int exp; - int i, j; - cl_object x, y; - int n, m; - cl_type t; - - b = buff1 + 1; - - fmt_not_colon(fmt, colon); - ensure_param(fmt, 7); - w = set_param_positive(fmt, 0, "illegal width"); - d = set_param_positive(fmt, 1, "illegal number of digits"); - e = set_param_positive(fmt, 2, "illegal number of digits in exponent"); - k = ecl_to_fix(set_param(fmt, 3, INT, ecl_make_fixnum(1))); - overflowchar = ECL_CHAR_CODE(set_param(fmt, 4, CHAR, ECL_CODE_CHAR('\0'))); - padchar = ECL_CHAR_CODE(set_param(fmt, 5, CHAR, ECL_CODE_CHAR(' '))); - exponentchar = ECL_CHAR_CODE(set_param(fmt, 6, CHAR, ECL_CODE_CHAR('\0'))); - - x = fmt_advance(fmt); - if (ECL_FIXNUMP(x) || - ecl_t_of(x) == t_bignum || - ecl_t_of(x) == t_ratio) - x = ecl_make_single_float(ecl_to_float(x)); - if (!ECL_REAL_TYPE_P(ecl_t_of(x))) { - if (fmt->nparam > 1) fmt->nparam = 1; - fmt_back_up(fmt); - fmt_decimal(fmt, colon, atsign); - return; - } - if (ecl_t_of(x) == t_doublefloat) - n = 16; + int w, d, e, k; + ecl_character overflowchar, padchar, exponentchar; + double f; + int sign; + char buff[256], *b, buff1[256]; + int exp; + int i, j; + cl_object x, y; + int n, m; + cl_type t; + + b = buff1 + 1; + + fmt_not_colon(fmt, colon); + ensure_param(fmt, 7); + w = set_param_positive(fmt, 0, "illegal width"); + d = set_param_positive(fmt, 1, "illegal number of digits"); + e = set_param_positive(fmt, 2, "illegal number of digits in exponent"); + k = ecl_to_fix(set_param(fmt, 3, INT, ecl_make_fixnum(1))); + overflowchar = ECL_CHAR_CODE(set_param(fmt, 4, CHAR, ECL_CODE_CHAR('\0'))); + padchar = ECL_CHAR_CODE(set_param(fmt, 5, CHAR, ECL_CODE_CHAR(' '))); + exponentchar = ECL_CHAR_CODE(set_param(fmt, 6, CHAR, ECL_CODE_CHAR('\0'))); + + x = fmt_advance(fmt); + if (ECL_FIXNUMP(x) || + ecl_t_of(x) == t_bignum || + ecl_t_of(x) == t_ratio) + x = ecl_make_single_float(ecl_to_float(x)); + if (!ECL_REAL_TYPE_P(ecl_t_of(x))) { + if (fmt->nparam > 1) fmt->nparam = 1; + fmt_back_up(fmt); + fmt_decimal(fmt, colon, atsign); + return; + } + if (ecl_t_of(x) == t_doublefloat) + n = 16; + else + n = 7; + f = ecl_to_double(x); + edit_double(n, f, &sign, buff, &exp); + if (d >= 0) { + if (k > 0) { + if (!(k < d + 2)) + fmt_error(fmt, "illegal scale factor"); + m = d + 1; + } else { + if (!(k > -d)) + fmt_error(fmt, "illegal scale factor"); + m = d + k; + } + } else if (w >= 0) { + if (k > 0) + m = w - 1; + else + m = w + k - 1; + if (sign < 0 || atsign) + --m; + if (e >= 0) + m -= e + 2; + else + m -= fmt_exponent_length(e - k + 1) + 2; + } else + m = n; + if (m <= 0) { + if (m == 0 && buff[0] >= '5') { + exp++; + n = m = 1; + buff[0] = '1'; + } else + n = m = 0; + } else if (m < n) { + n = m; + edit_double(n, f, &sign, buff, &exp); + } + while (n >= 0) + if (buff[n - 1] == '0') + --n; + else + break; + exp = exp - k + 1; + j = 0; + if (k > 0) { + for (i = 0; i < k; i++) + b[j++] = i < n ? buff[i] : '0'; + b[j++] = '.'; + if (d >= 0) + for (m = i + (d - k + 1); i < m; i++) + b[j++] = i < n ? buff[i] : '0'; + else + for (; i < n; i++) + b[j++] = buff[i]; + } else { + b[j++] = '.'; + if (d >= 0) { + for (i = 0; i < -k && i < d; i++) + b[j++] = '0'; + for (m = d - i, i = 0; i < m; i++) + b[j++] = i < n ? buff[i] : '0'; + } else if (n > 0) { + for (i = 0; i < -k; i++) + b[j++] = '0'; + for (i = 0; i < n; i++) + b[j++] = buff[i]; + } + } + b[j] = '\0'; + if (w >= 0) { + if (sign < 0 || atsign) + --w; + i = fmt_exponent_length(exp); + if (e >= 0) { + if (i > e) { + if (overflowchar != '\0') + goto OVER; else - n = 7; - f = ecl_to_double(x); - edit_double(n, f, &sign, buff, &exp); - if (d >= 0) { - if (k > 0) { - if (!(k < d + 2)) - fmt_error(fmt, "illegal scale factor"); - m = d + 1; - } else { - if (!(k > -d)) - fmt_error(fmt, "illegal scale factor"); - m = d + k; - } - } else if (w >= 0) { - if (k > 0) - m = w - 1; - else - m = w + k - 1; - if (sign < 0 || atsign) - --m; - if (e >= 0) - m -= e + 2; - else - m -= fmt_exponent_length(e - k + 1) + 2; - } else - m = n; - if (m <= 0) { - if (m == 0 && buff[0] >= '5') { - exp++; - n = m = 1; - buff[0] = '1'; - } else - n = m = 0; - } else if (m < n) { - n = m; - edit_double(n, f, &sign, buff, &exp); - } - while (n >= 0) - if (buff[n - 1] == '0') - --n; - else - break; - exp = exp - k + 1; - j = 0; - if (k > 0) { - for (i = 0; i < k; i++) - b[j++] = i < n ? buff[i] : '0'; - b[j++] = '.'; - if (d >= 0) - for (m = i + (d - k + 1); i < m; i++) - b[j++] = i < n ? buff[i] : '0'; - else - for (; i < n; i++) - b[j++] = buff[i]; - } else { - b[j++] = '.'; - if (d >= 0) { - for (i = 0; i < -k && i < d; i++) - b[j++] = '0'; - for (m = d - i, i = 0; i < m; i++) - b[j++] = i < n ? buff[i] : '0'; - } else if (n > 0) { - for (i = 0; i < -k; i++) - b[j++] = '0'; - for (i = 0; i < n; i++) - b[j++] = buff[i]; - } - } - b[j] = '\0'; - if (w >= 0) { - if (sign < 0 || atsign) - --w; - i = fmt_exponent_length(exp); - if (e >= 0) { - if (i > e) { - if (overflowchar != '\0') - goto OVER; - else - e = i; - } - w -= e + 2; - } else - w -= i + 2; - if (j > w && overflowchar != '\0') - goto OVER; - if (j < w && b[0] == '.') { - *--b = '0'; - j++; - } - for (i = j; i < w; i++) - ecl_write_char(padchar, fmt->stream); - } else { - if (b[j-1] == '.') { - b[j++] = '0'; - b[j] = '\0'; - } - if (d < 0 && b[0] == '.') { - *--b = '0'; - j++; - } - } - if (sign < 0) - ecl_write_char('-', fmt->stream); - else if (atsign) - ecl_write_char('+', fmt->stream); - writestr_stream(b, fmt->stream); - y = ecl_symbol_value(@'*read-default-float-format*'); - if (exponentchar < 0) { - if (y == @'long-float') { + e = i; + } + w -= e + 2; + } else + w -= i + 2; + if (j > w && overflowchar != '\0') + goto OVER; + if (j < w && b[0] == '.') { + *--b = '0'; + j++; + } + for (i = j; i < w; i++) + ecl_write_char(padchar, fmt->stream); + } else { + if (b[j-1] == '.') { + b[j++] = '0'; + b[j] = '\0'; + } + if (d < 0 && b[0] == '.') { + *--b = '0'; + j++; + } + } + if (sign < 0) + ecl_write_char('-', fmt->stream); + else if (atsign) + ecl_write_char('+', fmt->stream); + writestr_stream(b, fmt->stream); + y = ecl_symbol_value(@'*read-default-float-format*'); + if (exponentchar < 0) { + if (y == @'long-float') { #ifdef ECL_LONG_FLOAT - t = t_longfloat; + t = t_longfloat; #else - t = t_doublefloat; + t = t_doublefloat; #endif - } else if (y == @'double-float') { - t = t_doublefloat; - } else if (y == @'single-float') { - t = t_singlefloat; - } else { - t = t_singlefloat; - } - if (ecl_t_of(x) == t) - exponentchar = 'E'; - else if (ecl_t_of(x) == t_singlefloat) - exponentchar = 'F'; + } else if (y == @'double-float') { + t = t_doublefloat; + } else if (y == @'single-float') { + t = t_singlefloat; + } else { + t = t_singlefloat; + } + if (ecl_t_of(x) == t) + exponentchar = 'E'; + else if (ecl_t_of(x) == t_singlefloat) + exponentchar = 'F'; #ifdef ECL_LONG_FLOAT - else if (ecl_t_of(x) == t_longfloat) - exponentchar = 'L'; + else if (ecl_t_of(x) == t_longfloat) + exponentchar = 'L'; #endif - else - exponentchar = 'D'; - } - ecl_write_char(exponentchar, fmt->stream); - if (exp < 0) - ecl_write_char('-', fmt->stream); - else - ecl_write_char('+', fmt->stream); - if (e >= 0) - for (i = e - fmt_exponent_length(exp); i > 0; --i) - ecl_write_char('0', fmt->stream); - fmt_exponent(fmt, exp); - return; - -OVER: - w = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - for (i = 0; i < w; i++) - ecl_write_char(overflowchar, fmt->stream); - return; + else + exponentchar = 'D'; + } + ecl_write_char(exponentchar, fmt->stream); + if (exp < 0) + ecl_write_char('-', fmt->stream); + else + ecl_write_char('+', fmt->stream); + if (e >= 0) + for (i = e - fmt_exponent_length(exp); i > 0; --i) + ecl_write_char('0', fmt->stream); + fmt_exponent(fmt, exp); + return; + + OVER: + w = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + for (i = 0; i < w; i++) + ecl_write_char(overflowchar, fmt->stream); + return; } static void fmt_general_float(format_stack fmt, bool colon, bool atsign) { - int w, d, e, k; - ecl_character overflowchar, padchar, exponentchar; - int sign, exp; - char buff[256]; - cl_object x; - int n, ee, ww, q, dd; - - fmt_not_colon(fmt, colon); - ensure_param(fmt, 7); - w = set_param_positive(fmt, 0, "illegal width"); - d = set_param_positive(fmt, 1, "illegal number of digits"); - e = set_param_positive(fmt, 2, "illegal number of digits in exponent"); - k = ecl_to_fix(set_param(fmt, 3, INT, ecl_make_fixnum(1))); - overflowchar = ECL_CHAR_CODE(set_param(fmt, 4, CHAR, ECL_CODE_CHAR('\0'))); - padchar = ECL_CHAR_CODE(set_param(fmt, 5, CHAR, ECL_CODE_CHAR(' '))); - exponentchar = ECL_CHAR_CODE(set_param(fmt, 6, CHAR, ECL_CODE_CHAR('\0'))); - - x = fmt_advance(fmt); - if (!ECL_REAL_TYPE_P(ecl_t_of(x))) { - if (fmt->nparam > 1) fmt->nparam = 1; - fmt_back_up(fmt); - fmt_decimal(fmt, colon, atsign); - return; - } - if (ecl_t_of(x) == t_doublefloat) - q = 16; - else - q = 7; - edit_double(q, ecl_to_double(x), &sign, buff, &exp); - n = exp + 1; - while (q >= 0) - if (buff[q - 1] == '0') - --q; - else - break; - if (e >= 0) - ee = e + 2; - else - ee = 4; - ww = w - ee; - if (d < 0) { - d = n < 7 ? n : 7; - d = q > d ? q : d; - } - dd = d - n; - if (0 <= dd && dd <= d) { - fmt->nparam = 5; - fmt->param[0] = ecl_make_fixnum(ww); - fmt->param[1] = ecl_make_fixnum(dd); - fmt->param[2] = ECL_NIL; - fmt->param[3] = fmt->param[4]; - fmt->param[4] = fmt->param[5]; - fmt_back_up(fmt); - fmt_fix_float(fmt, colon, atsign); - if (w >= 0) - while (ww++ < w) - ecl_write_char(padchar, fmt->stream); - return; - } - fmt->param[1] = ecl_make_fixnum(d); - fmt_back_up(fmt); - fmt_exponential_float(fmt, colon, atsign); + int w, d, e, k; + ecl_character overflowchar, padchar, exponentchar; + int sign, exp; + char buff[256]; + cl_object x; + int n, ee, ww, q, dd; + + fmt_not_colon(fmt, colon); + ensure_param(fmt, 7); + w = set_param_positive(fmt, 0, "illegal width"); + d = set_param_positive(fmt, 1, "illegal number of digits"); + e = set_param_positive(fmt, 2, "illegal number of digits in exponent"); + k = ecl_to_fix(set_param(fmt, 3, INT, ecl_make_fixnum(1))); + overflowchar = ECL_CHAR_CODE(set_param(fmt, 4, CHAR, ECL_CODE_CHAR('\0'))); + padchar = ECL_CHAR_CODE(set_param(fmt, 5, CHAR, ECL_CODE_CHAR(' '))); + exponentchar = ECL_CHAR_CODE(set_param(fmt, 6, CHAR, ECL_CODE_CHAR('\0'))); + + x = fmt_advance(fmt); + if (!ECL_REAL_TYPE_P(ecl_t_of(x))) { + if (fmt->nparam > 1) fmt->nparam = 1; + fmt_back_up(fmt); + fmt_decimal(fmt, colon, atsign); + return; + } + if (ecl_t_of(x) == t_doublefloat) + q = 16; + else + q = 7; + edit_double(q, ecl_to_double(x), &sign, buff, &exp); + n = exp + 1; + while (q >= 0) + if (buff[q - 1] == '0') + --q; + else + break; + if (e >= 0) + ee = e + 2; + else + ee = 4; + ww = w - ee; + if (d < 0) { + d = n < 7 ? n : 7; + d = q > d ? q : d; + } + dd = d - n; + if (0 <= dd && dd <= d) { + fmt->nparam = 5; + fmt->param[0] = ecl_make_fixnum(ww); + fmt->param[1] = ecl_make_fixnum(dd); + fmt->param[2] = ECL_NIL; + fmt->param[3] = fmt->param[4]; + fmt->param[4] = fmt->param[5]; + fmt_back_up(fmt); + fmt_fix_float(fmt, colon, atsign); + if (w >= 0) + while (ww++ < w) + ecl_write_char(padchar, fmt->stream); + return; + } + fmt->param[1] = ecl_make_fixnum(d); + fmt_back_up(fmt); + fmt_exponential_float(fmt, colon, atsign); } static void fmt_dollars_float(format_stack fmt, bool colon, bool atsign) { - int d, n, w; - ecl_character padchar; - double f; - int sign; - char buff[256]; - int exp; - int q, i; - cl_object x; - - ensure_param(fmt, 4); - d = set_param_positive(fmt, 0, "illegal number of digits"); - if (d < 0) d = 2; - n = set_param_positive(fmt, 1, "illegal number of digits"); - if (n < 0) n = 1; - w = set_param_positive(fmt, 2, "illegal width"); - if (w < 0) w = 0; - padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' '))); - x = fmt_advance(fmt); - if (!ECL_REAL_TYPE_P(ecl_t_of(x))) { - if (fmt->nparam < 3) - fmt->nparam = 0; - else { - fmt->nparam = 1; - fmt->param[0] = fmt->param[2]; - } - fmt_back_up(fmt); - fmt_decimal(fmt, colon, atsign); - return; - } - q = 7; - if (ecl_t_of(x) == t_doublefloat) - q = 16; - f = ecl_to_double(x); - edit_double(q, f, &sign, buff, &exp); - if ((q = exp + d + 1) > 0) - edit_double(q, f, &sign, buff, &exp); - exp++; - if (w > 100 || exp > 100 || exp < -100) { - fmt->nparam = 6; - fmt->param[0] = fmt->param[2]; - fmt->param[1] = ecl_make_fixnum(d + n - 1); - fmt->param[5] = fmt->param[3]; - fmt->param[2] = - fmt->param[3] = - fmt->param[4] = ECL_NIL; - fmt_back_up(fmt); - fmt_exponential_float(fmt, colon, atsign); - } - if (exp > n) - n = exp; - if (sign < 0 || atsign) - --w; - if (colon) { - if (sign < 0) - ecl_write_char('-', fmt->stream); - else if (atsign) - ecl_write_char('+', fmt->stream); - while (--w > n + d) - ecl_write_char(padchar, fmt->stream); - } else { - while (--w > n + d) - ecl_write_char(padchar, fmt->stream); - if (sign < 0) - ecl_write_char('-', fmt->stream); - else if (atsign) - ecl_write_char('+', fmt->stream); - } - for (i = n - exp; i > 0; --i) - ecl_write_char('0', fmt->stream); - for (i = 0; i < exp; i++) - ecl_write_char((i < q ? buff[i] : '0'), fmt->stream); - ecl_write_char('.', fmt->stream); - for (d += i; i < d; i++) - ecl_write_char((i < q ? buff[i] : '0'), fmt->stream); + int d, n, w; + ecl_character padchar; + double f; + int sign; + char buff[256]; + int exp; + int q, i; + cl_object x; + + ensure_param(fmt, 4); + d = set_param_positive(fmt, 0, "illegal number of digits"); + if (d < 0) d = 2; + n = set_param_positive(fmt, 1, "illegal number of digits"); + if (n < 0) n = 1; + w = set_param_positive(fmt, 2, "illegal width"); + if (w < 0) w = 0; + padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' '))); + x = fmt_advance(fmt); + if (!ECL_REAL_TYPE_P(ecl_t_of(x))) { + if (fmt->nparam < 3) + fmt->nparam = 0; + else { + fmt->nparam = 1; + fmt->param[0] = fmt->param[2]; + } + fmt_back_up(fmt); + fmt_decimal(fmt, colon, atsign); + return; + } + q = 7; + if (ecl_t_of(x) == t_doublefloat) + q = 16; + f = ecl_to_double(x); + edit_double(q, f, &sign, buff, &exp); + if ((q = exp + d + 1) > 0) + edit_double(q, f, &sign, buff, &exp); + exp++; + if (w > 100 || exp > 100 || exp < -100) { + fmt->nparam = 6; + fmt->param[0] = fmt->param[2]; + fmt->param[1] = ecl_make_fixnum(d + n - 1); + fmt->param[5] = fmt->param[3]; + fmt->param[2] = + fmt->param[3] = + fmt->param[4] = ECL_NIL; + fmt_back_up(fmt); + fmt_exponential_float(fmt, colon, atsign); + } + if (exp > n) + n = exp; + if (sign < 0 || atsign) + --w; + if (colon) { + if (sign < 0) + ecl_write_char('-', fmt->stream); + else if (atsign) + ecl_write_char('+', fmt->stream); + while (--w > n + d) + ecl_write_char(padchar, fmt->stream); + } else { + while (--w > n + d) + ecl_write_char(padchar, fmt->stream); + if (sign < 0) + ecl_write_char('-', fmt->stream); + else if (atsign) + ecl_write_char('+', fmt->stream); + } + for (i = n - exp; i > 0; --i) + ecl_write_char('0', fmt->stream); + for (i = 0; i < exp; i++) + ecl_write_char((i < q ? buff[i] : '0'), fmt->stream); + ecl_write_char('.', fmt->stream); + for (d += i; i < d; i++) + ecl_write_char((i < q ? buff[i] : '0'), fmt->stream); } static void fmt_percent(format_stack fmt, bool colon, bool atsign) { - int n, i; + int n, i; - ensure_param(fmt, 1); - n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); - fmt_not_colon(fmt, colon); - fmt_not_atsign(fmt, atsign); - while (n-- > 0) { - ecl_write_char('\n', fmt->stream); - if (n == 0) - for (i = fmt->indents; i > 0; --i) - ecl_write_char(' ', fmt->stream); - } + ensure_param(fmt, 1); + n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); + fmt_not_colon(fmt, colon); + fmt_not_atsign(fmt, atsign); + while (n-- > 0) { + ecl_write_char('\n', fmt->stream); + if (n == 0) + for (i = fmt->indents; i > 0; --i) + ecl_write_char(' ', fmt->stream); + } } static void fmt_ampersand(format_stack fmt, bool colon, bool atsign) { - int n; + int n; - ensure_param(fmt, 1); - n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); - fmt_not_colon(fmt, colon); - fmt_not_atsign(fmt, atsign); - if (n == 0) - return; - if (ecl_file_column(fmt->stream) != 0) - ecl_write_char('\n', fmt->stream); - while (--n > 0) - ecl_write_char('\n', fmt->stream); - fmt->indents = 0; + ensure_param(fmt, 1); + n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); + fmt_not_colon(fmt, colon); + fmt_not_atsign(fmt, atsign); + if (n == 0) + return; + if (ecl_file_column(fmt->stream) != 0) + ecl_write_char('\n', fmt->stream); + while (--n > 0) + ecl_write_char('\n', fmt->stream); + fmt->indents = 0; } static void fmt_bar(format_stack fmt, bool colon, bool atsign) { - int n; + int n; - ensure_param(fmt, 1); - n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); - fmt_not_colon(fmt, colon); - fmt_not_atsign(fmt, atsign); - while (n-- > 0) - ecl_write_char('\f', fmt->stream); + ensure_param(fmt, 1); + n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); + fmt_not_colon(fmt, colon); + fmt_not_atsign(fmt, atsign); + while (n-- > 0) + ecl_write_char('\f', fmt->stream); } static void fmt_tilde(format_stack fmt, bool colon, bool atsign) { - int n; + int n; - ensure_param(fmt, 1); - n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); - fmt_not_colon(fmt, colon); - fmt_not_atsign(fmt, atsign); - while (n-- > 0) - ecl_write_char('~', fmt->stream); + ensure_param(fmt, 1); + n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); + fmt_not_colon(fmt, colon); + fmt_not_atsign(fmt, atsign); + while (n-- > 0) + ecl_write_char('~', fmt->stream); } static void fmt_newline(format_stack fmt, bool colon, bool atsign) { - ensure_param(fmt, 0); - fmt_not_colon_atsign(fmt, colon, atsign); - if (atsign) - ecl_write_char('\n', fmt->stream); - while (fmt->ctl_index < fmt->ctl_end && isspace(ecl_char(fmt->ctl_str, fmt->ctl_index))) { - if (colon) - ecl_write_char(ecl_char(fmt->ctl_str, fmt->ctl_index), fmt->stream); - fmt->ctl_index++; - } + ensure_param(fmt, 0); + fmt_not_colon_atsign(fmt, colon, atsign); + if (atsign) + ecl_write_char('\n', fmt->stream); + while (fmt->ctl_index < fmt->ctl_end && isspace(ecl_char(fmt->ctl_str, fmt->ctl_index))) { + if (colon) + ecl_write_char(ecl_char(fmt->ctl_str, fmt->ctl_index), fmt->stream); + fmt->ctl_index++; + } } static void fmt_tabulate(format_stack fmt, bool colon, bool atsign) { - int colnum, colinc; - int c, i; + int colnum, colinc; + int c, i; - ensure_param(fmt, 2); - fmt_not_colon(fmt, colon); - colnum = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); - colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1))); - if (!atsign) { - c = ecl_file_column(fmt->stream); - if (c < 0) { - writestr_stream(" ", fmt->stream); - return; - } - if (c > colnum && colinc <= 0) - return; - while (c > colnum) - colnum += colinc; - for (i = colnum - c; i > 0; --i) - ecl_write_char(' ', fmt->stream); - } else { - for (i = colnum; i > 0; --i) - ecl_write_char(' ', fmt->stream); - c = ecl_file_column(fmt->stream); - if (c < 0 || colinc <= 0) - return; - colnum = 0; - while (c > colnum) - colnum += colinc; - for (i = colnum - c; i > 0; --i) - ecl_write_char(' ', fmt->stream); - } + ensure_param(fmt, 2); + fmt_not_colon(fmt, colon); + colnum = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); + colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1))); + if (!atsign) { + c = ecl_file_column(fmt->stream); + if (c < 0) { + writestr_stream(" ", fmt->stream); + return; + } + if (c > colnum && colinc <= 0) + return; + while (c > colnum) + colnum += colinc; + for (i = colnum - c; i > 0; --i) + ecl_write_char(' ', fmt->stream); + } else { + for (i = colnum; i > 0; --i) + ecl_write_char(' ', fmt->stream); + c = ecl_file_column(fmt->stream); + if (c < 0 || colinc <= 0) + return; + colnum = 0; + while (c > colnum) + colnum += colinc; + for (i = colnum - c; i > 0; --i) + ecl_write_char(' ', fmt->stream); + } } static void fmt_asterisk(format_stack fmt, bool colon, bool atsign) { - int n; + int n; - ensure_param(fmt, 1); - fmt_not_colon_atsign(fmt, colon, atsign); - if (atsign) { - n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - fmt_go(fmt, n); - } else if (colon) { - n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); - fmt_go(fmt, fmt_index(fmt) - n); - } else { - n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); - while (n-- > 0) - fmt_advance(fmt); - } + ensure_param(fmt, 1); + fmt_not_colon_atsign(fmt, colon, atsign); + if (atsign) { + n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + fmt_go(fmt, n); + } else if (colon) { + n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); + fmt_go(fmt, fmt_index(fmt) - n); + } else { + n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); + while (n-- > 0) + fmt_advance(fmt); + } } static void fmt_indirection(format_stack fmt, bool colon, bool atsign) { - cl_object s, l; - struct format_stack_struct fmt_old; - jmp_buf fmt_jmp_buf0; - int up_colon; - - ensure_param(fmt, 0); - fmt_not_colon(fmt, colon); - s = fmt_advance(fmt); - switch (ecl_t_of(s)) { + cl_object s, l; + struct format_stack_struct fmt_old; + jmp_buf fmt_jmp_buf0; + int up_colon; + + ensure_param(fmt, 0); + fmt_not_colon(fmt, colon); + s = fmt_advance(fmt); + switch (ecl_t_of(s)) { #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - break; - default: - fmt_error(fmt, "control string expected"); - } - if (atsign) { - fmt_copy(&fmt_old, fmt); - fmt->jmp_buf = &fmt_jmp_buf0; - fmt->ctl_str = s; - if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { - if (--up_colon) - fmt_error(fmt, "illegal ~~:^"); - } else - format(fmt, 0, s->base_string.fillp); - fmt_copy1(fmt, &fmt_old); - } else { - l = fmt_advance(fmt); - fmt_copy(&fmt_old, fmt); - fmt_set_arg_list(fmt, l); - fmt->jmp_buf = &fmt_jmp_buf0; - fmt->ctl_str = s; - if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { - if (--up_colon) - fmt_error(fmt, "illegal ~~:^"); - } else - format(fmt, 0, s->base_string.fillp); - fmt_copy(fmt, &fmt_old); - } + case t_base_string: + break; + default: + fmt_error(fmt, "control string expected"); + } + if (atsign) { + fmt_copy(&fmt_old, fmt); + fmt->jmp_buf = &fmt_jmp_buf0; + fmt->ctl_str = s; + if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { + if (--up_colon) + fmt_error(fmt, "illegal ~~:^"); + } else + format(fmt, 0, s->base_string.fillp); + fmt_copy1(fmt, &fmt_old); + } else { + l = fmt_advance(fmt); + fmt_copy(&fmt_old, fmt); + fmt_set_arg_list(fmt, l); + fmt->jmp_buf = &fmt_jmp_buf0; + fmt->ctl_str = s; + if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { + if (--up_colon) + fmt_error(fmt, "illegal ~~:^"); + } else + format(fmt, 0, s->base_string.fillp); + fmt_copy(fmt, &fmt_old); + } } static void fmt_case(format_stack fmt, bool colon, bool atsign) { - cl_object x; - cl_index i; - int j; - ecl_character c; - struct format_stack_struct fmt_old; - jmp_buf fmt_jmp_buf0; - int up_colon; - bool b; - - x = ecl_make_string_output_stream(64, 1); - i = fmt->ctl_index; - j = fmt_skip(fmt); - if (ecl_char(fmt->ctl_str, --j) != ')' || ecl_char(fmt->ctl_str, --j) != '~') - fmt_error(fmt, "~~) expected"); - fmt_copy(&fmt_old, fmt); - fmt->stream = x; - fmt->jmp_buf = &fmt_jmp_buf0; - if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) - ; - else - format(fmt, i, j); - fmt_copy1(fmt, &fmt_old); - x = STRING_OUTPUT_STRING(x); - if (!colon && !atsign) - for (i = 0; i < x->base_string.fillp; i++) { - if (ecl_upper_case_p(c = ecl_char(x, i))) - c = ecl_char_downcase(c); - ecl_write_char(c, fmt->stream); - } - else if (colon && !atsign) - for (b = TRUE, i = 0; i < x->base_string.fillp; i++) { - if (ecl_lower_case_p(c = ecl_char(x, i))) { - if (b) - c = ecl_char_upcase(c); - b = FALSE; - } else if (ecl_upper_case_p(c)) { - if (!b) - c = ecl_char_downcase(c); - b = FALSE; - } else if (ecl_digitp(c,10) == -1) - b = TRUE; - ecl_write_char(c, fmt->stream); - } - else if (!colon && atsign) - for (b = TRUE, i = 0; i < x->base_string.fillp; i++) { - if (ecl_lower_case_p(c = ecl_char(x, i))) { - if (b) - c = ecl_char_upcase(c); - b = FALSE; - } else if (ecl_upper_case_p(c)) { - if (!b) - c = ecl_char_downcase(c); - b = FALSE; - } - ecl_write_char(c, fmt->stream); - } - else - for (i = 0; i < x->base_string.fillp; i++) { - if (ecl_lower_case_p(c = ecl_char(x, i))) - c = ecl_char_upcase(c); - ecl_write_char(c, fmt->stream); - } - if (up_colon) - ecl_longjmp(*fmt->jmp_buf, up_colon); + cl_object x; + cl_index i; + int j; + ecl_character c; + struct format_stack_struct fmt_old; + jmp_buf fmt_jmp_buf0; + int up_colon; + bool b; + + x = ecl_make_string_output_stream(64, 1); + i = fmt->ctl_index; + j = fmt_skip(fmt); + if (ecl_char(fmt->ctl_str, --j) != ')' || ecl_char(fmt->ctl_str, --j) != '~') + fmt_error(fmt, "~~) expected"); + fmt_copy(&fmt_old, fmt); + fmt->stream = x; + fmt->jmp_buf = &fmt_jmp_buf0; + if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) + ; + else + format(fmt, i, j); + fmt_copy1(fmt, &fmt_old); + x = STRING_OUTPUT_STRING(x); + if (!colon && !atsign) + for (i = 0; i < x->base_string.fillp; i++) { + if (ecl_upper_case_p(c = ecl_char(x, i))) + c = ecl_char_downcase(c); + ecl_write_char(c, fmt->stream); + } + else if (colon && !atsign) + for (b = TRUE, i = 0; i < x->base_string.fillp; i++) { + if (ecl_lower_case_p(c = ecl_char(x, i))) { + if (b) + c = ecl_char_upcase(c); + b = FALSE; + } else if (ecl_upper_case_p(c)) { + if (!b) + c = ecl_char_downcase(c); + b = FALSE; + } else if (ecl_digitp(c,10) == -1) + b = TRUE; + ecl_write_char(c, fmt->stream); + } + else if (!colon && atsign) + for (b = TRUE, i = 0; i < x->base_string.fillp; i++) { + if (ecl_lower_case_p(c = ecl_char(x, i))) { + if (b) + c = ecl_char_upcase(c); + b = FALSE; + } else if (ecl_upper_case_p(c)) { + if (!b) + c = ecl_char_downcase(c); + b = FALSE; + } + ecl_write_char(c, fmt->stream); + } + else + for (i = 0; i < x->base_string.fillp; i++) { + if (ecl_lower_case_p(c = ecl_char(x, i))) + c = ecl_char_upcase(c); + ecl_write_char(c, fmt->stream); + } + if (up_colon) + ecl_longjmp(*fmt->jmp_buf, up_colon); } static void fmt_conditional(format_stack fmt, bool colon, bool atsign) { - int i, j, k; - cl_object x; - int n; - bool done; - struct format_stack_struct fmt_old; - - fmt_not_colon_atsign(fmt, colon, atsign); - if (colon) { - ensure_param(fmt, 0); - i = fmt->ctl_index; - j = fmt_skip(fmt); - if (ecl_char(fmt->ctl_str, --j) != ';' || ecl_char(fmt->ctl_str, --j) != '~') - fmt_error(fmt, "~~; expected"); - k = fmt_skip(fmt); - if (ecl_char(fmt->ctl_str, --k) != ']' || ecl_char(fmt->ctl_str, --k) != '~') - fmt_error(fmt, "~~] expected"); - if (Null(fmt_advance(fmt))) { - fmt_copy(&fmt_old, fmt); - format(fmt, i, j); - fmt_copy1(fmt, &fmt_old); - } else { - fmt_copy(&fmt_old, fmt); - format(fmt, j + 2, k); - fmt_copy1(fmt, &fmt_old); - } - } else if (atsign) { - i = fmt->ctl_index; - j = fmt_skip(fmt); - if (ecl_char(fmt->ctl_str, --j) != ']' || ecl_char(fmt->ctl_str, --j) != '~') - fmt_error(fmt, "~~] expected"); - if (Null(fmt_advance(fmt))) - ; - else { - fmt_back_up(fmt); - fmt_copy(&fmt_old, fmt); - format(fmt, i, j); - fmt_copy1(fmt, &fmt_old); - } - } else { - ensure_param(fmt, 1); - if (fmt->nparam == 0) { - x = fmt_advance(fmt); - if (!ECL_FIXNUMP(x)) - fmt_error(fmt, "illegal argument for conditional"); - n = ecl_fixnum(x); - } else - n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - i = fmt->ctl_index; - for (done = FALSE;; --n) { - j = fmt_skip(fmt); - for (k = j; ecl_char(fmt->ctl_str, --k) != '~';) - ; - if (n == 0) { - fmt_copy(&fmt_old, fmt); - format(fmt, i, k); - fmt_copy1(fmt, &fmt_old); - done = TRUE; - } - i = j; - if (ecl_char(fmt->ctl_str, --j) == ']') { - if (ecl_char(fmt->ctl_str, --j) != '~') - fmt_error(fmt, "~~] expected"); - return; - } - if (ecl_char(fmt->ctl_str, j) == ';') { - if (ecl_char(fmt->ctl_str, --j) == '~') - continue; - if (ecl_char(fmt->ctl_str, j) == ':') - goto ELSE; - } - fmt_error(fmt, "~~; or ~~] expected"); - } - ELSE: - if (ecl_char(fmt->ctl_str, --j) != '~') - fmt_error(fmt, "~~:; expected"); - j = fmt_skip(fmt); - if (ecl_char(fmt->ctl_str, --j) != ']' || ecl_char(fmt->ctl_str, --j) != '~') - fmt_error(fmt, "~~] expected"); - if (!done) { - fmt_copy(&fmt_old, fmt); - format(fmt, i, j); - fmt_copy1(fmt, &fmt_old); - } - } + int i, j, k; + cl_object x; + int n; + bool done; + struct format_stack_struct fmt_old; + + fmt_not_colon_atsign(fmt, colon, atsign); + if (colon) { + ensure_param(fmt, 0); + i = fmt->ctl_index; + j = fmt_skip(fmt); + if (ecl_char(fmt->ctl_str, --j) != ';' || ecl_char(fmt->ctl_str, --j) != '~') + fmt_error(fmt, "~~; expected"); + k = fmt_skip(fmt); + if (ecl_char(fmt->ctl_str, --k) != ']' || ecl_char(fmt->ctl_str, --k) != '~') + fmt_error(fmt, "~~] expected"); + if (Null(fmt_advance(fmt))) { + fmt_copy(&fmt_old, fmt); + format(fmt, i, j); + fmt_copy1(fmt, &fmt_old); + } else { + fmt_copy(&fmt_old, fmt); + format(fmt, j + 2, k); + fmt_copy1(fmt, &fmt_old); + } + } else if (atsign) { + i = fmt->ctl_index; + j = fmt_skip(fmt); + if (ecl_char(fmt->ctl_str, --j) != ']' || ecl_char(fmt->ctl_str, --j) != '~') + fmt_error(fmt, "~~] expected"); + if (Null(fmt_advance(fmt))) + ; + else { + fmt_back_up(fmt); + fmt_copy(&fmt_old, fmt); + format(fmt, i, j); + fmt_copy1(fmt, &fmt_old); + } + } else { + ensure_param(fmt, 1); + if (fmt->nparam == 0) { + x = fmt_advance(fmt); + if (!ECL_FIXNUMP(x)) + fmt_error(fmt, "illegal argument for conditional"); + n = ecl_fixnum(x); + } else + n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + i = fmt->ctl_index; + for (done = FALSE;; --n) { + j = fmt_skip(fmt); + for (k = j; ecl_char(fmt->ctl_str, --k) != '~';) + ; + if (n == 0) { + fmt_copy(&fmt_old, fmt); + format(fmt, i, k); + fmt_copy1(fmt, &fmt_old); + done = TRUE; + } + i = j; + if (ecl_char(fmt->ctl_str, --j) == ']') { + if (ecl_char(fmt->ctl_str, --j) != '~') + fmt_error(fmt, "~~] expected"); + return; + } + if (ecl_char(fmt->ctl_str, j) == ';') { + if (ecl_char(fmt->ctl_str, --j) == '~') + continue; + if (ecl_char(fmt->ctl_str, j) == ':') + goto ELSE; + } + fmt_error(fmt, "~~; or ~~] expected"); + } + ELSE: + if (ecl_char(fmt->ctl_str, --j) != '~') + fmt_error(fmt, "~~:; expected"); + j = fmt_skip(fmt); + if (ecl_char(fmt->ctl_str, --j) != ']' || ecl_char(fmt->ctl_str, --j) != '~') + fmt_error(fmt, "~~] expected"); + if (!done) { + fmt_copy(&fmt_old, fmt); + format(fmt, i, j); + fmt_copy1(fmt, &fmt_old); + } + } } static void fmt_iteration(format_stack fmt, bool colon, bool atsign) { - int n, i; - volatile int j; - bool colon_close = FALSE; - cl_object l; - struct format_stack_struct fmt_old; - jmp_buf fmt_jmp_buf0; - int up_colon; - - ensure_param(fmt, 1); - n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1000000))); - i = fmt->ctl_index; - j = fmt_skip(fmt); - if (ecl_char(fmt->ctl_str, --j) != '}') - fmt_error(fmt, "~~} expected"); - if (ecl_char(fmt->ctl_str, --j) == ':') { - colon_close = TRUE; - --j; - } - if (ecl_char(fmt->ctl_str, j) != '~') - fmt_error(fmt, "syntax error"); - if (!colon && !atsign) { - l = fmt_advance(fmt); - fmt_copy(&fmt_old, fmt); - fmt_set_arg_list(fmt, l); - fmt->jmp_buf = &fmt_jmp_buf0; - if (colon_close) - goto L1; - while (fmt_more_args_p(fmt)) { - L1: - if (n-- <= 0) - break; - if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { - if (--up_colon) - fmt_error(fmt, "illegal ~~:^"); - break; - } - format(fmt, i, j); - } - fmt_copy(fmt, &fmt_old); - } else if (colon && !atsign) { - int fl = 0; - volatile cl_object l0; - l0 = fmt_advance(fmt); - fmt_copy(&fmt_old, fmt); - for (l = l0; !ecl_endp(l); l = CDR(l)) - fl += ecl_length(CAR(l)); - fmt->jmp_buf = &fmt_jmp_buf0; - if (colon_close) - goto L2; - while (!ecl_endp(l0)) { - L2: - if (n-- <= 0) - break; - l = CAR(l0); - l0 = CDR(l0); - fmt_set_arg_list(fmt, l); - if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { - if (--up_colon) - break; - else - continue; - } - format(fmt, i, j); - } - fmt_copy(fmt, &fmt_old); - } else if (!colon && atsign) { - fmt_copy(&fmt_old, fmt); - fmt->jmp_buf = &fmt_jmp_buf0; - if (colon_close) - goto L3; - while (fmt_more_args_p(fmt)) { - L3: - if (n-- <= 0) - break; - if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { - if (--up_colon) - fmt_error(fmt, "illegal ~~:^"); - break; - } - format(fmt, i, j); - } - fmt_copy1(fmt, &fmt_old); - } else if (colon && atsign) { - if (colon_close) - goto L4; - while (fmt_more_args_p(fmt)) { - L4: - if (n-- <= 0) - break; - l = fmt_advance(fmt); - fmt_copy(&fmt_old, fmt); - fmt_set_arg_list(fmt, l); - fmt->jmp_buf = &fmt_jmp_buf0; - if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { - fmt_copy(fmt, &fmt_old); - if (--up_colon) - break; - else - continue; - } - format(fmt, i, j); - fmt_copy(fmt, &fmt_old); - } - } + int n, i; + volatile int j; + bool colon_close = FALSE; + cl_object l; + struct format_stack_struct fmt_old; + jmp_buf fmt_jmp_buf0; + int up_colon; + + ensure_param(fmt, 1); + n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1000000))); + i = fmt->ctl_index; + j = fmt_skip(fmt); + if (ecl_char(fmt->ctl_str, --j) != '}') + fmt_error(fmt, "~~} expected"); + if (ecl_char(fmt->ctl_str, --j) == ':') { + colon_close = TRUE; + --j; + } + if (ecl_char(fmt->ctl_str, j) != '~') + fmt_error(fmt, "syntax error"); + if (!colon && !atsign) { + l = fmt_advance(fmt); + fmt_copy(&fmt_old, fmt); + fmt_set_arg_list(fmt, l); + fmt->jmp_buf = &fmt_jmp_buf0; + if (colon_close) + goto L1; + while (fmt_more_args_p(fmt)) { + L1: + if (n-- <= 0) + break; + if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { + if (--up_colon) + fmt_error(fmt, "illegal ~~:^"); + break; + } + format(fmt, i, j); + } + fmt_copy(fmt, &fmt_old); + } else if (colon && !atsign) { + int fl = 0; + volatile cl_object l0; + l0 = fmt_advance(fmt); + fmt_copy(&fmt_old, fmt); + for (l = l0; !ecl_endp(l); l = CDR(l)) + fl += ecl_length(CAR(l)); + fmt->jmp_buf = &fmt_jmp_buf0; + if (colon_close) + goto L2; + while (!ecl_endp(l0)) { + L2: + if (n-- <= 0) + break; + l = CAR(l0); + l0 = CDR(l0); + fmt_set_arg_list(fmt, l); + if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { + if (--up_colon) + break; + else + continue; + } + format(fmt, i, j); + } + fmt_copy(fmt, &fmt_old); + } else if (!colon && atsign) { + fmt_copy(&fmt_old, fmt); + fmt->jmp_buf = &fmt_jmp_buf0; + if (colon_close) + goto L3; + while (fmt_more_args_p(fmt)) { + L3: + if (n-- <= 0) + break; + if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { + if (--up_colon) + fmt_error(fmt, "illegal ~~:^"); + break; + } + format(fmt, i, j); + } + fmt_copy1(fmt, &fmt_old); + } else if (colon && atsign) { + if (colon_close) + goto L4; + while (fmt_more_args_p(fmt)) { + L4: + if (n-- <= 0) + break; + l = fmt_advance(fmt); + fmt_copy(&fmt_old, fmt); + fmt_set_arg_list(fmt, l); + fmt->jmp_buf = &fmt_jmp_buf0; + if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { + fmt_copy(fmt, &fmt_old); + if (--up_colon) + break; + else + continue; + } + format(fmt, i, j); + fmt_copy(fmt, &fmt_old); + } + } } static void fmt_justification(format_stack fmt, volatile bool colon, bool atsign) { - int mincol, colinc; - ecl_character minpad, padchar; - volatile cl_object fields; - cl_object p; - struct format_stack_struct fmt_old; - jmp_buf fmt_jmp_buf0; - volatile int i, j, k, l, m, j0, l0; - int up_colon; - volatile cl_object special = ECL_NIL; - volatile int spare_spaces, line_length; - - ensure_param(fmt, 4); - mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1))); - minpad = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); - padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' '))); - - fields = ECL_NIL; - for (;;) { - cl_object this_field = ecl_make_string_output_stream(64, 1); - i = fmt->ctl_index; - j0 = j = fmt_skip(fmt); - while (ecl_char(fmt->ctl_str, --j) != '~') - ; - - fmt_copy(&fmt_old, fmt); - fmt->jmp_buf = &fmt_jmp_buf0; - if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { - if (--up_colon) - fmt_error(fmt, "illegal ~~:^"); - fmt_copy1(fmt, &fmt_old); - while (ecl_char(fmt->ctl_str, --j0) != '>') - j0 = fmt_skip(fmt); - if (ecl_char(fmt->ctl_str, --j0) != '~') - fmt_error(fmt, "~~> expected"); - break; - } - fmt->stream = this_field; - format(fmt, i, j); - fields = CONS(STRING_OUTPUT_STRING(this_field), fields); - fmt_copy1(fmt, &fmt_old); - - if (ecl_char(fmt->ctl_str, --j0) == '>') { - if (ecl_char(fmt->ctl_str, --j0) != '~') - fmt_error(fmt, "~~> expected"); - break; - } else if (ecl_char(fmt->ctl_str, j0) != ';') - fmt_error(fmt, "~~; expected"); - else if (ecl_char(fmt->ctl_str, --j0) == ':') { - if (ecl_length(fields) != 1 || !Null(special)) - fmt_error(fmt, "illegal ~~:;"); - special = CAR(fields); - fields = CDR(fields); - for (j = j0; ecl_char(fmt->ctl_str, j) != '~'; --j) - ; - fmt_copy(&fmt_old, fmt); - format(fmt, j, j0 + 2); - fmt_copy1(fmt, &fmt_old); - spare_spaces = fmt->spare_spaces; - line_length = fmt->line_length; - } else if (ecl_char(fmt->ctl_str, j0) != '~') - fmt_error(fmt, "~~; expected"); - } - /* - * Compute the length of items to be output. If the clause ~:; was - * found, the first item is not included. - */ - fields = cl_nreverse(fields); - for (p = fields, l = 0; p != ECL_NIL; p = CDR(p)) - l += CAR(p)->base_string.fillp; - /* - * Count the number of segments that need padding, "M". If the colon - * modifier, the first item needs padding. If the @@ modifier is - * present, the last modifier also needs padding. - */ - m = ecl_length(fields) - 1; - if (m <= 0 && !colon && !atsign) { - m = 0; - colon = TRUE; - } - if (colon) - m++; - if (atsign) - m++; - /* - * Count the minimal length in which the text fits. This length must - * the smallest integer of the form l = mincol + k * colinc. If the - * length exceeds the line length, the text before the ~:; is output - * first. - */ - l0 = l; - l += minpad * m; - for (k = 0; mincol + k * colinc < l; k++) - ; - l = mincol + k * colinc; - if (special != ECL_NIL && - ecl_file_column(fmt->stream) + l + spare_spaces > line_length) - ecl_princ(special, fmt->stream); - /* - * Output the text with the padding segments. The total number of - * padchars is kept in "l", and it is shared equally among all segments. - */ - l -= l0; - for (p = fields; p != ECL_NIL; p = CDR(p)) { - if (p != fields || colon) - for (j = l / m, l -= j, --m; j > 0; --j) - ecl_write_char(padchar, fmt->stream); - ecl_princ(CAR(p), fmt->stream); - } - if (atsign) - for (j = l; j > 0; --j) - ecl_write_char(padchar, fmt->stream); + int mincol, colinc; + ecl_character minpad, padchar; + volatile cl_object fields; + cl_object p; + struct format_stack_struct fmt_old; + jmp_buf fmt_jmp_buf0; + volatile int i, j, k, l, m, j0, l0; + int up_colon; + volatile cl_object special = ECL_NIL; + volatile int spare_spaces, line_length; + + ensure_param(fmt, 4); + mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1))); + minpad = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); + padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' '))); + + fields = ECL_NIL; + for (;;) { + cl_object this_field = ecl_make_string_output_stream(64, 1); + i = fmt->ctl_index; + j0 = j = fmt_skip(fmt); + while (ecl_char(fmt->ctl_str, --j) != '~') + ; + + fmt_copy(&fmt_old, fmt); + fmt->jmp_buf = &fmt_jmp_buf0; + if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { + if (--up_colon) + fmt_error(fmt, "illegal ~~:^"); + fmt_copy1(fmt, &fmt_old); + while (ecl_char(fmt->ctl_str, --j0) != '>') + j0 = fmt_skip(fmt); + if (ecl_char(fmt->ctl_str, --j0) != '~') + fmt_error(fmt, "~~> expected"); + break; + } + fmt->stream = this_field; + format(fmt, i, j); + fields = CONS(STRING_OUTPUT_STRING(this_field), fields); + fmt_copy1(fmt, &fmt_old); + + if (ecl_char(fmt->ctl_str, --j0) == '>') { + if (ecl_char(fmt->ctl_str, --j0) != '~') + fmt_error(fmt, "~~> expected"); + break; + } else if (ecl_char(fmt->ctl_str, j0) != ';') + fmt_error(fmt, "~~; expected"); + else if (ecl_char(fmt->ctl_str, --j0) == ':') { + if (ecl_length(fields) != 1 || !Null(special)) + fmt_error(fmt, "illegal ~~:;"); + special = CAR(fields); + fields = CDR(fields); + for (j = j0; ecl_char(fmt->ctl_str, j) != '~'; --j) + ; + fmt_copy(&fmt_old, fmt); + format(fmt, j, j0 + 2); + fmt_copy1(fmt, &fmt_old); + spare_spaces = fmt->spare_spaces; + line_length = fmt->line_length; + } else if (ecl_char(fmt->ctl_str, j0) != '~') + fmt_error(fmt, "~~; expected"); + } + /* + * Compute the length of items to be output. If the clause ~:; was + * found, the first item is not included. + */ + fields = cl_nreverse(fields); + for (p = fields, l = 0; p != ECL_NIL; p = CDR(p)) + l += CAR(p)->base_string.fillp; + /* + * Count the number of segments that need padding, "M". If the colon + * modifier, the first item needs padding. If the @@ modifier is + * present, the last modifier also needs padding. + */ + m = ecl_length(fields) - 1; + if (m <= 0 && !colon && !atsign) { + m = 0; + colon = TRUE; + } + if (colon) + m++; + if (atsign) + m++; + /* + * Count the minimal length in which the text fits. This length must + * the smallest integer of the form l = mincol + k * colinc. If the + * length exceeds the line length, the text before the ~:; is output + * first. + */ + l0 = l; + l += minpad * m; + for (k = 0; mincol + k * colinc < l; k++) + ; + l = mincol + k * colinc; + if (special != ECL_NIL && + ecl_file_column(fmt->stream) + l + spare_spaces > line_length) + ecl_princ(special, fmt->stream); + /* + * Output the text with the padding segments. The total number of + * padchars is kept in "l", and it is shared equally among all segments. + */ + l -= l0; + for (p = fields; p != ECL_NIL; p = CDR(p)) { + if (p != fields || colon) + for (j = l / m, l -= j, --m; j > 0; --j) + ecl_write_char(padchar, fmt->stream); + ecl_princ(CAR(p), fmt->stream); + } + if (atsign) + for (j = l; j > 0; --j) + ecl_write_char(padchar, fmt->stream); } static void fmt_up_and_out(format_stack fmt, bool colon, bool atsign) { - int i, j, k; + int i, j, k; - ensure_param(fmt, 3); - fmt_not_atsign(fmt, atsign); - if (fmt->nparam == 0) { - if (!fmt_more_args_p(fmt)) - ecl_longjmp(*fmt->jmp_buf, ++colon); - } else if (fmt->nparam == 1) { - i = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - if (i == 0) - ecl_longjmp(*fmt->jmp_buf, ++colon); - } else if (fmt->nparam == 2) { - i = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - j = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(0))); - if (i == j) - ecl_longjmp(*fmt->jmp_buf, ++colon); - } else { - i = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - j = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(0))); - k = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); - if (i <= j && j <= k) - ecl_longjmp(*fmt->jmp_buf, ++colon); - } + ensure_param(fmt, 3); + fmt_not_atsign(fmt, atsign); + if (fmt->nparam == 0) { + if (!fmt_more_args_p(fmt)) + ecl_longjmp(*fmt->jmp_buf, ++colon); + } else if (fmt->nparam == 1) { + i = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + if (i == 0) + ecl_longjmp(*fmt->jmp_buf, ++colon); + } else if (fmt->nparam == 2) { + i = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + j = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(0))); + if (i == j) + ecl_longjmp(*fmt->jmp_buf, ++colon); + } else { + i = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + j = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(0))); + k = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); + if (i <= j && j <= k) + ecl_longjmp(*fmt->jmp_buf, ++colon); + } } static void fmt_semicolon(format_stack fmt, bool colon, bool atsign) { - fmt_not_atsign(fmt, atsign); - if (!colon) - fmt_error(fmt, "~~:; expected"); - ensure_param(fmt, 2); - fmt->spare_spaces = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - fmt->line_length = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(72))); + fmt_not_atsign(fmt, atsign); + if (!colon) + fmt_error(fmt, "~~:; expected"); + ensure_param(fmt, 2); + fmt->spare_spaces = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + fmt->line_length = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(72))); } @(defun si::formatter-aux (strm string &rest args) @ - @(return doformat(narg, strm, string, args, TRUE)) + @(return doformat(narg, strm, string, args, TRUE)) @) static cl_object doformat(cl_narg narg, cl_object strm, cl_object string, ecl_va_list args, bool in_formatter) { - struct format_stack_struct fmt; - jmp_buf fmt_jmp_buf0; - int colon; - cl_object output = cl_grab_rest_args(args); - while(!ecl_stringp(string)) + struct format_stack_struct fmt; + jmp_buf fmt_jmp_buf0; + int colon; + cl_object output = cl_grab_rest_args(args); + while(!ecl_stringp(string)) #ifdef ECL_UNICODE - string = ecl_type_error(@'format', "argument", string, @'string'); + string = ecl_type_error(@'format', "argument", string, @'string'); #else - string = ecl_type_error(@'format', "argument", string, @'base-string'); + string = ecl_type_error(@'format', "argument", string, @'base-string'); #endif - fmt.stream = strm; - fmt_set_arg_list(&fmt, output); - fmt.jmp_buf = &fmt_jmp_buf0; - if (ecl_symbol_value(@'si::*indent-formatted-output*') != ECL_NIL) - fmt.indents = ecl_file_column(strm); - else - fmt.indents = 0; - fmt.ctl_str = string; - fmt.aux_stream = get_aux_stream(); - fmt.aux_string = STRING_OUTPUT_STRING(fmt.aux_stream); - if ((colon = ecl_setjmp(*fmt.jmp_buf))) { - if (--colon) - fmt_error(&fmt, "illegal ~~:^"); - } else { - format(&fmt, 0, string->base_string.fillp); - ecl_force_output(strm); - } - ecl_process_env()->fmt_aux_stream = fmt.aux_stream; - if (!in_formatter) - output = ECL_NIL; - return output; + fmt.stream = strm; + fmt_set_arg_list(&fmt, output); + fmt.jmp_buf = &fmt_jmp_buf0; + if (ecl_symbol_value(@'si::*indent-formatted-output*') != ECL_NIL) + fmt.indents = ecl_file_column(strm); + else + fmt.indents = 0; + fmt.ctl_str = string; + fmt.aux_stream = get_aux_stream(); + fmt.aux_string = STRING_OUTPUT_STRING(fmt.aux_stream); + if ((colon = ecl_setjmp(*fmt.jmp_buf))) { + if (--colon) + fmt_error(&fmt, "illegal ~~:^"); + } else { + format(&fmt, 0, string->base_string.fillp); + ecl_force_output(strm); + } + ecl_process_env()->fmt_aux_stream = fmt.aux_stream; + if (!in_formatter) + output = ECL_NIL; + return output; } static void format(format_stack fmt, cl_index start, cl_index end) { - ecl_character c; - cl_index i, n; - bool colon, atsign; - cl_object x; - - fmt->ctl_index = start; - fmt->ctl_end = end; - -LOOP: - if (fmt->ctl_index >= fmt->ctl_end) - return; - if ((c = ctl_advance(fmt)) != '~') { - ecl_write_char(c, fmt->stream); - goto LOOP; - } - n = 0; - for (;;) { - switch (c = ctl_advance(fmt)) { - case ',': - fmt->param[n] = ECL_NIL; - break; - - case '+': case '-': - case '0': case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': - i = fmt->ctl_index - 1; - do { - c = ctl_advance(fmt); - } while (ecl_digitp(c,10) != -1); - x = ecl_parse_integer(fmt->ctl_str, i, fmt->ctl_index, &i, 10); - INTEGER: - /* FIXME! A hack to solve the problem of bignums in arguments */ - if (x == OBJNULL || !ecl_numberp(x)) - fmt_error(fmt, "integer expected"); - if (ecl_number_compare(x, ecl_make_fixnum(FMT_VALUE_UPPER_LIMIT)) > 0) { - fmt->param[n] = ecl_make_fixnum(FMT_VALUE_UPPER_LIMIT); - } else if (ecl_number_compare(x, ecl_make_fixnum(FMT_VALUE_LOWER_LIMIT)) < 0) { - fmt->param[n] = ecl_make_fixnum(FMT_VALUE_LOWER_LIMIT); - } else { - fmt->param[n] = x; - } - if (ECL_FIXNUMP(x)) { - fmt->param[n] = x; - } else if (ecl_plusp(x)) { - fmt->param[n] = ecl_make_fixnum(MOST_POSITIVE_FIXNUM); - } else { - fmt->param[n] = ecl_make_fixnum(MOST_NEGATIVE_FIXNUM); - } - break; - - case '\'': - fmt->param[n] = ECL_CODE_CHAR(ctl_advance(fmt)); - c = ctl_advance(fmt); - break; - - case 'v': case 'V': - x = fmt_advance(fmt); - c = ctl_advance(fmt); - if (ecl_t_of(x) == t_character) { - fmt->param[n] = x; - } else { - goto INTEGER; - } - break; - - case '#': - fmt->param[n] = ecl_make_fixnum(fmt_args_left(fmt)); - c = ctl_advance(fmt); - break; - - default: - if (n > 0) - fmt_error(fmt, "illegal ,"); - else - goto DIRECTIVE; - } - n++; - if (n == FMT_MAX_PARAM) - fmt_error(fmt, "too many parameters"); - if (c != ',') - break; - } - -DIRECTIVE: - colon = atsign = FALSE; - if (c == ':') { - colon = TRUE; - c = ctl_advance(fmt); - } - if (c == '@@') { - atsign = TRUE; - c = ctl_advance(fmt); - } - fmt->nparam = n; - switch (c) { - case 'a': case 'A': - fmt_ascii(fmt, colon, atsign); - break; - - case 's': case 'S': - fmt_S_expression(fmt, colon, atsign); - break; - - case 'd': case 'D': - fmt_decimal(fmt, colon, atsign); - break; - - case 'b': case 'B': - fmt_binary(fmt, colon, atsign); - break; - - case 'o': case 'O': - fmt_octal(fmt, colon, atsign); - break; - - case 'x': case 'X': - fmt_hexadecimal(fmt, colon, atsign); - break; - - case 'r': case 'R': - fmt_radix(fmt, colon, atsign); - break; - - case 'p': case 'P': - fmt_plural(fmt, colon, atsign); - break; - - case 'c': case 'C': - fmt_character(fmt, colon, atsign); - break; - - case 'f': case 'F': - fmt_fix_float(fmt, colon, atsign); - break; - - case 'e': case 'E': - fmt_exponential_float(fmt, colon, atsign); - break; - - case 'g': case 'G': - fmt_general_float(fmt, colon, atsign); - break; - - case '$': - fmt_dollars_float(fmt, colon, atsign); - break; - - case '%': - fmt_percent(fmt, colon, atsign); - break; - - case '&': - fmt_ampersand(fmt, colon, atsign); - break; - - case '|': - fmt_bar(fmt, colon, atsign); - break; - - case '~': - fmt_tilde(fmt, colon, atsign); - break; - - case '\n': - case '\r': - fmt_newline(fmt, colon, atsign); - break; - - case 't': case 'T': - fmt_tabulate(fmt, colon, atsign); - break; - - case '*': - fmt_asterisk(fmt, colon, atsign); - break; - - case '?': - fmt_indirection(fmt, colon, atsign); - break; - - case '(': - fmt_case(fmt, colon, atsign); - break; - - case '[': - fmt_conditional(fmt, colon, atsign); - break; - - case '{': - fmt_iteration(fmt, colon, atsign); - break; - - case '<': - fmt_justification(fmt, colon, atsign); - break; - - case '^': - fmt_up_and_out(fmt, colon, atsign); - break; - - case ';': - fmt_semicolon(fmt, colon, atsign); - break; - - default: - fmt_error(fmt, "illegal directive"); - } - goto LOOP; + ecl_character c; + cl_index i, n; + bool colon, atsign; + cl_object x; + + fmt->ctl_index = start; + fmt->ctl_end = end; + + LOOP: + if (fmt->ctl_index >= fmt->ctl_end) + return; + if ((c = ctl_advance(fmt)) != '~') { + ecl_write_char(c, fmt->stream); + goto LOOP; + } + n = 0; + for (;;) { + switch (c = ctl_advance(fmt)) { + case ',': + fmt->param[n] = ECL_NIL; + break; + + case '+': case '-': + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + i = fmt->ctl_index - 1; + do { + c = ctl_advance(fmt); + } while (ecl_digitp(c,10) != -1); + x = ecl_parse_integer(fmt->ctl_str, i, fmt->ctl_index, &i, 10); + INTEGER: + /* FIXME! A hack to solve the problem of bignums in arguments */ + if (x == OBJNULL || !ecl_numberp(x)) + fmt_error(fmt, "integer expected"); + if (ecl_number_compare(x, ecl_make_fixnum(FMT_VALUE_UPPER_LIMIT)) > 0) { + fmt->param[n] = ecl_make_fixnum(FMT_VALUE_UPPER_LIMIT); + } else if (ecl_number_compare(x, ecl_make_fixnum(FMT_VALUE_LOWER_LIMIT)) < 0) { + fmt->param[n] = ecl_make_fixnum(FMT_VALUE_LOWER_LIMIT); + } else { + fmt->param[n] = x; + } + if (ECL_FIXNUMP(x)) { + fmt->param[n] = x; + } else if (ecl_plusp(x)) { + fmt->param[n] = ecl_make_fixnum(MOST_POSITIVE_FIXNUM); + } else { + fmt->param[n] = ecl_make_fixnum(MOST_NEGATIVE_FIXNUM); + } + break; + + case '\'': + fmt->param[n] = ECL_CODE_CHAR(ctl_advance(fmt)); + c = ctl_advance(fmt); + break; + + case 'v': case 'V': + x = fmt_advance(fmt); + c = ctl_advance(fmt); + if (ecl_t_of(x) == t_character) { + fmt->param[n] = x; + } else { + goto INTEGER; + } + break; + + case '#': + fmt->param[n] = ecl_make_fixnum(fmt_args_left(fmt)); + c = ctl_advance(fmt); + break; + + default: + if (n > 0) + fmt_error(fmt, "illegal ,"); + else + goto DIRECTIVE; + } + n++; + if (n == FMT_MAX_PARAM) + fmt_error(fmt, "too many parameters"); + if (c != ',') + break; + } + + DIRECTIVE: + colon = atsign = FALSE; + if (c == ':') { + colon = TRUE; + c = ctl_advance(fmt); + } + if (c == '@@') { + atsign = TRUE; + c = ctl_advance(fmt); + } + fmt->nparam = n; + switch (c) { + case 'a': case 'A': + fmt_ascii(fmt, colon, atsign); + break; + + case 's': case 'S': + fmt_S_expression(fmt, colon, atsign); + break; + + case 'd': case 'D': + fmt_decimal(fmt, colon, atsign); + break; + + case 'b': case 'B': + fmt_binary(fmt, colon, atsign); + break; + + case 'o': case 'O': + fmt_octal(fmt, colon, atsign); + break; + + case 'x': case 'X': + fmt_hexadecimal(fmt, colon, atsign); + break; + + case 'r': case 'R': + fmt_radix(fmt, colon, atsign); + break; + + case 'p': case 'P': + fmt_plural(fmt, colon, atsign); + break; + + case 'c': case 'C': + fmt_character(fmt, colon, atsign); + break; + + case 'f': case 'F': + fmt_fix_float(fmt, colon, atsign); + break; + + case 'e': case 'E': + fmt_exponential_float(fmt, colon, atsign); + break; + + case 'g': case 'G': + fmt_general_float(fmt, colon, atsign); + break; + + case '$': + fmt_dollars_float(fmt, colon, atsign); + break; + + case '%': + fmt_percent(fmt, colon, atsign); + break; + + case '&': + fmt_ampersand(fmt, colon, atsign); + break; + + case '|': + fmt_bar(fmt, colon, atsign); + break; + + case '~': + fmt_tilde(fmt, colon, atsign); + break; + + case '\n': + case '\r': + fmt_newline(fmt, colon, atsign); + break; + + case 't': case 'T': + fmt_tabulate(fmt, colon, atsign); + break; + + case '*': + fmt_asterisk(fmt, colon, atsign); + break; + + case '?': + fmt_indirection(fmt, colon, atsign); + break; + + case '(': + fmt_case(fmt, colon, atsign); + break; + + case '[': + fmt_conditional(fmt, colon, atsign); + break; + + case '{': + fmt_iteration(fmt, colon, atsign); + break; + + case '<': + fmt_justification(fmt, colon, atsign); + break; + + case '^': + fmt_up_and_out(fmt, colon, atsign); + break; + + case ';': + fmt_semicolon(fmt, colon, atsign); + break; + + default: + fmt_error(fmt, "illegal directive"); + } + goto LOOP; } #endif /* !ECL_CMU_FORMAT */ @(defun format (strm string &rest args) - cl_object output = ECL_NIL; - int null_strm = 0; + cl_object output = ECL_NIL; + int null_strm = 0; @ - if (Null(strm)) { + if (Null(strm)) { #ifdef ECL_UNICODE - strm = ecl_alloc_adjustable_extended_string(64); + strm = ecl_alloc_adjustable_extended_string(64); #else - strm = ecl_alloc_adjustable_base_string(64); + strm = ecl_alloc_adjustable_base_string(64); #endif - null_strm = 1; - } else if (strm == ECL_T) { - strm = ecl_symbol_value(@'*standard-output*'); - } - if (ecl_stringp(strm)) { - output = strm; - if (!ECL_ARRAY_HAS_FILL_POINTER_P(output)) { - cl_error(7, @'si::format-error', - @':format-control', - make_constant_base_string( -"Cannot output to a non adjustable string."), - @':control-string', string, - @':offset', ecl_make_fixnum(0)); - } - strm = si_make_string_output_stream_from_string(strm); - if (null_strm == 0) - output = ECL_NIL; - } - if (!Null(cl_functionp(string))) { - cl_apply(3, string, strm, cl_grab_rest_args(args)); - } else { + null_strm = 1; + } else if (strm == ECL_T) { + strm = ecl_symbol_value(@'*standard-output*'); + } + if (ecl_stringp(strm)) { + output = strm; + if (!ECL_ARRAY_HAS_FILL_POINTER_P(output)) { + cl_error(7, @'si::format-error', + @':format-control', + make_constant_base_string( + "Cannot output to a non adjustable string."), + @':control-string', string, + @':offset', ecl_make_fixnum(0)); + } + strm = si_make_string_output_stream_from_string(strm); + if (null_strm == 0) + output = ECL_NIL; + } + if (!Null(cl_functionp(string))) { + cl_apply(3, string, strm, cl_grab_rest_args(args)); + } else { #ifdef ECL_CMU_FORMAT - _ecl_funcall4(@'si::formatter-aux', strm, string, - cl_grab_rest_args(args)); + _ecl_funcall4(@'si::formatter-aux', strm, string, + cl_grab_rest_args(args)); #else - doformat(narg, strm, string, args, FALSE); + doformat(narg, strm, string, args, FALSE); #endif - } - output = cl_copy_seq(output); - @(return output) + } + output = cl_copy_seq(output); + @(return output); @) diff -Nru ecl-16.1.2/src/c/gbc.d ecl-16.1.3+ds/src/c/gbc.d --- ecl-16.1.2/src/c/gbc.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/gbc.d 1970-01-01 00:00:00.000000000 +0000 @@ -1,976 +0,0 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ - -/* - gbc.c -- Garbage collector. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi and William F. Schelter. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ - -#ifdef ECL_THREADS -#include -#endif -#include -#include -#include -#include -#include - -/******************************* EXPORTS ******************************/ - -bool GC_enable; - -/******************************* ------- ******************************/ - -/* - mark_table[m]:i represents word w = 128*m + 4*i, where m = addr-DATA_START. - Therefore m = w >> 7, i = (w / 4) % 32 = (w >> 2) & 0x1f. -*/ - -static int *mark_table; - -#define MTbit(x) ((ptr2int(x) >> 2) & 0x1f) -#define MTword(x) mark_table[((cl_ptr)x - heap_start) >> 7] -#define get_mark_bit(x) (MTword(x) >> MTbit(x) & 1) -#define set_mark_bit(x) (MTword(x) |= (1 << MTbit(x))) -#define clear_mark_bit(x) (MTword(x) ~= (~1 << MTbit(x))) - -#define VALID_DATA_ADDRESS(pp) \ - (!ECL_IMMEDIATE(pp) && (heap_start <= (cl_ptr)(pp)) && ((cl_ptr)(pp) < heap_end)) - -static bool debug = FALSE; -static int maxpage; - -#define GC_ROOT_MAX 200 -static cl_object *gc_root[GC_ROOT_MAX]; -static int gc_roots; - -static bool collect_blocks; - -static int gc_time; /* Beppe */ - -/* - We must register location, since value may be reassigned (e.g. malloc_list) - */ - -static void _mark_object(cl_object x); -static void _mark_contblock(void *p, cl_index s); -static void mark_cl_env(struct cl_env_struct *env); -extern void sigint (void); - -void -ecl_register_root(cl_object *p) -{ - if (gc_roots >= GC_ROOT_MAX) - ecl_internal_error("too many roots"); - gc_root[gc_roots++] = p; -} - -cl_object -si_gc(cl_object area) -{ - if (!GC_enabled()) - ecl_internal_error("GC is not enabled"); - if (Null(area)) - ecl_gc(t_cons); - else - ecl_gc(t_contiguous); - @(return) -} - -/*---------------------------------------------------------------------- - * Mark phase - *---------------------------------------------------------------------- - */ - -/* Whenever two arrays are linked together by displacement, - if one is live, the other will be made live */ -#define mark_displaced(ar) mark_object(ar) -#define mark_contblock(x,s) {if (collect_blocks) _mark_contblock(x,s); } -#if 1 -#define mark_object(x) if ((x != OBJNULL) && !ECL_IMMEDIATE(x)) _mark_object(x) -#define mark_next(a) if ((a != OBJNULL) && !ECL_IMMEDIATE(a)) { x=(a); goto BEGIN; } -#else -#define mark_object(x) _mark_object(x) -#define mark_next(a) x=(a); goto BEGIN -#endif - -/* We make bitvectors multiple of sizeof(int) in size allocated - Assume 8 = number of bits in char */ -#define W_SIZE (8*sizeof(int)) - -static void -_mark_object(cl_object x) -{ - cl_index i, j; - cl_object *p, y; - cl_ptr cp; -BEGIN: -#if 0 - /* We cannot get here because mark_object() and mark_next() already check this */ - if (ECL_IMMEDIATE(x)) return; /* fixnum, character or locative */ - if (x == OBJNULL) - return; -#endif - /* We need this, because sometimes we arrive to data structures - * which have been created in the C stack (t_frame in gfun.d, - * for instance) */ - if (!VALID_DATA_ADDRESS(x)) - return; - if (x->d.m) { - if (x->d.m == FREE) - ecl_internal_error("mark_object: pointer to free object."); - else - return; - } - x->d.m = TRUE; - - switch (ecl_t_of(x)) { - - case t_bignum: { - /* GMP may set num.alloc before actually allocating anything. - With these checks we make sure we do not move anything - we don't have to. Besides, we use big_dim as the size - of the object, because big_size might even be smaller. - */ - cl_ptr limbs = (cl_ptr)x->big.big_limbs; - cl_index size = x->big.big_dim * sizeof(mp_limb_t); - if (size) mark_contblock(limbs, size); - break; - } - case t_ratio: - mark_object(x->ratio.num); - mark_next(x->ratio.den); - break; - -#ifdef ECL_SSE2 - case t_sse_pack: -#endif - case t_singlefloat: - case t_doublefloat: -#ifdef ECL_LONG_FLOAT - case t_longfloat: -#endif - break; - - case t_complex: - mark_object(x->complex.imag); - mark_next(x->complex.real); - break; - - case t_character: - break; - - case t_symbol: - mark_object(x->symbol.hpack); - mark_object(x->symbol.name); - mark_object(x->symbol.plist); - mark_object(x->symbol.gfdef); - mark_next(x->symbol.value); - break; - - case t_package: - mark_object(x->pack.name); - mark_object(x->pack.nicknames); - mark_object(x->pack.shadowings); - mark_object(x->pack.uses); - mark_object(x->pack.usedby); - mark_object(x->pack.internal); - mark_next(x->pack.external); - break; - - case t_cons: - mark_object(CAR(x)); - mark_next(CDR(x)); - break; - - case t_hashtable: - mark_object(x->hash.rehash_size); - mark_object(x->hash.threshold); - if (x->hash.data == NULL) - break; - for (i = 0, j = x->hash.size; i < j; i++) { - mark_object(x->hash.data[i].key); - mark_object(x->hash.data[i].value); - } - mark_contblock(x->hash.data, j * sizeof(struct ecl_hashtable_entry)); - break; - - case t_array: - mark_contblock(x->array.dims, sizeof(x->array.dims[0])*x->array.rank); -#ifdef ECL_UNICODE - case t_string: -#endif - case t_vector: - if ((y = x->array.displaced) != ECL_NIL) - mark_displaced(y); - cp = (cl_ptr)x->array.self.t; - if (cp == NULL) - break; - switch ((cl_elttype)x->array.elttype) { -#ifdef ECL_UNICODE - case ecl_aet_ch: -#endif - case ecl_aet_object: - if (x->array.displaced == ECL_NIL || CAR(x->array.displaced) == ECL_NIL) { - i = x->vector.dim; - p = x->array.self.t; - goto MARK_DATA; - } - j = sizeof(cl_object)*x->array.dim; - break; - case ecl_aet_bc: - j = x->array.dim; - break; - case ecl_aet_bit: - j = sizeof(int) * ((x->vector.offset + x->vector.dim + W_SIZE -1)/W_SIZE); - break; - case ecl_aet_fix: - j = x->array.dim * sizeof(cl_fixnum); - break; - case ecl_aet_index: - j = x->array.dim * sizeof(cl_index); - break; - case ecl_aet_sf: - j = x->array.dim * sizeof(float); - break; - case ecl_aet_df: - j = x->array.dim * sizeof(double); - break; - case ecl_aet_b8: - j = x->array.dim * sizeof(uint8_t); - break; - case ecl_aet_i8: - j = x->array.dim * sizeof(int8_t); - break; - default: - ecl_internal_error("Allocation botch: unknown array element type"); - } - goto COPY_ARRAY; - case t_base_string: - if ((y = x->base_string.displaced) != ECL_NIL) - mark_displaced(y); - cp = x->base_string.self; - if (cp == NULL) - break; - j = x->base_string.dim+1; - COPY_ARRAY: - mark_contblock(cp, j); - break; - case t_bitvector: - if ((y = x->vector.displaced) != ECL_NIL) - mark_displaced(y); - cp = x->vector.self.bit; - if (cp == NULL) - break; - j= sizeof(int) * ((x->vector.offset + x->vector.dim + W_SIZE -1)/W_SIZE); - goto COPY_ARRAY; - case t_stream: - switch ((enum ecl_smmode)x->stream.mode) { - case ecl_smm_input: - case ecl_smm_output: - case ecl_smm_io: - case ecl_smm_probe: - mark_contblock(x->stream.buffer, BUFSIZ); - mark_object(x->stream.object0); - mark_next(x->stream.object1); - break; - - case ecl_smm_synonym: - mark_next(x->stream.object0); - break; - - case ecl_smm_broadcast: - case ecl_smm_concatenated: - mark_next(x->stream.object0); - break; - - case ecl_smm_two_way: - case ecl_smm_echo: - mark_object(x->stream.object0); - mark_next(x->stream.object1); - break; - - case ecl_smm_string_input: - case ecl_smm_string_output: - mark_next(x->stream.object0); - break; - - default: - ecl_internal_error("mark stream botch"); - } - break; - - case t_random: - break; - - case t_readtable: - if (x->readtable.table == NULL) - break; - mark_contblock((cl_ptr)(x->readtable.table), - RTABSIZE*sizeof(struct ecl_readtable_entry)); - for (i = 0; i < RTABSIZE; i++) { - cl_object *p = x->readtable.table[i].dispatch_table; - mark_object(x->readtable.table[i].macro); - if (p != NULL) { - mark_contblock(p, RTABSIZE*sizeof(cl_object)); - for (j = 0; j < RTABSIZE; j++) - mark_object(p[j]); - } - } - break; - - case t_pathname: - mark_object(x->pathname.host); - mark_object(x->pathname.device); - mark_object(x->pathname.version); - mark_object(x->pathname.name); - mark_object(x->pathname.type); - mark_next(x->pathname.directory); - break; - - case t_bytecodes: - mark_object(x->bytecodes.name); - mark_object(x->bytecodes.lex); - mark_object(x->bytecodes.specials); - mark_object(x->bytecodes.definition); - mark_contblock(x->bytecodes.code, x->bytecodes.code_size * sizeof(cl_opcode)); - mark_next(x->bytecodes.data); - break; - - case t_bclosure: - mark_object(x->bclosure.code); - mark_next(x->bclosure.lex); - break; - - case t_cfun: - case t_cfunfixed: - mark_object(x->cfun.block); - mark_next(x->cfun.name); - break; - - case t_cclosure: - mark_object(x->cfun.block); - mark_next(x->cclosure.env); - break; - -#ifdef ECL_THREADS - case t_process: -/* Already marked by malloc: x->process.env - */ - mark_object(x->process.name); - mark_object(x->process.interrupt); - mark_object(x->process.function); - mark_cl_env(x->process.env); - mark_next(x->process.args); - break; - case t_lock: - mark_next(x->lock.name); - mark_next(x->lock.holder); - break; - case t_condition_variable: - break; -#endif /* THREADS */ -#ifdef ECL_SEMAPHORES - case t_semaphore: - break; -#endif - case t_instance: - mark_object(x->instance.clas); - mark_object(x->instance.sig); - p = x->instance.slots; - i = x->instance.length; - goto MARK_DATA; - case t_codeblock: - mark_object(x->cblock.name); - mark_object(x->cblock.next); - mark_object(x->cblock.links); - p = x->cblock.temp_data; - if (p) { - i = x->cblock.temp_data_size; - mark_contblock(p, i * sizeof(cl_object)); - while (i-- > 0) - mark_object(p[i]); - } - i = x->cblock.data_size; - p = x->cblock.data; - goto MARK_DATA; - case t_foreign: - if (x->foreign.size) - mark_contblock(x->foreign.data, x->foreign.size); - mark_next(x->foreign.tag); - break; - MARK_DATA: - if (p) { - mark_contblock(p, i * sizeof(cl_object)); - while (i-- > 0) - mark_object(p[i]); - } - return; - default: - if (debug) - printf("\ttype = %d\n", ecl_t_of(x)); - ecl_internal_error("mark botch"); - } -} - -static void -mark_stack_conservative(cl_ptr bottom, cl_ptr top) -{ - int p, m; - cl_object x; - struct typemanager *tm; - cl_ptr j; - - if (debug) { printf("Traversing C stack .."); fflush(stdout); } - - /* On machines which align local pointers on multiple of 2 rather - than 4 we need to mark twice - - if (offset) mark_stack_conservative(bottom, ((char *) top) + offset, 0); - */ - for (j = bottom ; j < top ; j+=sizeof(cl_ptr)) { - cl_ptr aux = *((cl_ptr*)j); - /* improved Beppe: */ - if (VALID_DATA_ADDRESS(aux) && type_map[p = page(aux)] < (char)t_end) { - tm = tm_of((cl_type)type_map[p]); - x = (cl_object)(aux - (aux - pagetochar(p)) % tm->tm_size); - m = x->d.m; - if (m != FREE && m != TRUE) { - if (m) { - fprintf(stderr, - "** bad value %d of d.m in gc page %d skipping mark **", - m, p); fflush(stderr); - } else { - mark_object(x); - } - } - } - } - if (debug) { - printf(". done.\n"); fflush(stdout); - } -} - -static void -mark_cl_env(struct cl_env_struct *env) -{ - int i = 0; - cl_object where = 0; - ecl_bds_ptr bdp = 0; - ecl_frame_ptr frp = 0; - ecl_ihs_ptr ihs = 0; - - mark_contblock(env, sizeof(*env)); - - mark_object(env->lex_env); - - mark_contblock(env->stack, env->stack_size * sizeof(cl_object)); - mark_stack_conservative((cl_ptr)env->stack, (cl_ptr)env->stack_top); - - if ((bdp = env->bds_org)) { - mark_contblock(bdp, env->bds_size * sizeof(*bdp)); - for (; bdp <= env->bds_top; bdp++) { - mark_object(bdp->symbol); - mark_object(bdp->value); - } - } - mark_object(env->bindings_hash); - - if ((frp = env->frs_org)) { - mark_contblock(frp, env->frs_size * sizeof(*frp)); - for (; frp <= env->frs_top; frp++) { - mark_object(frp->frs_val); - } - } - - for (ihs = env->ihs_top; ihs; ihs = ihs->next) { - mark_object(ihs->function); - mark_object(ihs->lex_env); - } - - for (i=0; invalues; i++) - mark_object(env->values[i]); - - mark_object(env->string_pool); - - if (env->c_env) { - mark_object(env->c_env->variables); - mark_object(env->c_env->macros); - mark_object(env->c_env->constants); - } - - mark_object(env->fmt_aux_stream); - - mark_contblock(env->queue, sizeof(short) * ECL_PPRINT_QUEUE_SIZE); - mark_contblock(env->indent_stack, sizeof(short) * ECL_PPRINT_INDENTATION_STACK_SIZE); - - mark_object(env->big_register[0]); - mark_object(env->big_register[1]); - mark_object(env->big_register[2]); - -#ifdef ECL_THREADS - mark_object(env->method_hash_clear_list); -#endif - mark_object(env->method_hash); - mark_object(env->method_spec_vector); - -#ifdef ECL_THREADS -/* We should mark the stacks of the threads somehow!!! */ -#error "The old garbage collector does not support threads" -#else -# ifdef ECL_DOWN_STACK - mark_stack_conservative((cl_ptr)(&where), (cl_ptr)env->cs_org); -# else - mark_stack_conservative((cl_ptr)env->cs_org, (cl_ptr)(&where)); -# endif /* ECL_DOWN_STACK */ -#endif /* THREADS */ - -#ifdef ECL_FFICALL - mark_contblock(env->fficall, sizeof(struct ecl_fficall)); - mark_object(((struct ecl_fficall*)env->fficall)->cstring); -#endif -} - -static void -mark_phase(void) -{ - int i; - cl_object s; - - /* save registers on the stack */ - jmp_buf volatile registers; - ecl_setjmp(registers); - - /* mark registered symbols & keywords */ - for (i=0; isymbol.m = FALSE; - } - for (i=0; ivector.fillp; i++) { - cl_object dll = s->vector.self.t[i]; - if (dll->cblock.locked) { - mark_object(dll); - } - } - s->vector.elttype = ecl_aet_fix; - mark_object(s); - s->vector.elttype = ecl_aet_object; - } - mark_stack_conservative((cl_ptr)&cl_core, (cl_ptr)(&cl_core + 1)); - /* mark roots */ - for (i = 0; i < gc_roots; i++) - mark_object(*gc_root[i]); - -#ifdef ECL_THREADS - mark_object(cl_core.processes); -#else - mark_cl_env(&cl_env); -#endif -} - -static void -sweep_phase(void) -{ - register int i, j, k; - register cl_object x; - register cl_ptr p; - register struct typemanager *tm; - register cl_object f; - - ECL_NIL->symbol.m = FALSE; - ECL_T->symbol.m = FALSE; - - if (debug) - printf("type map\n"); - - for (i = 0; i < maxpage; i++) { - if (type_map[i] == (int)t_contiguous) { - if (debug) { - printf("-"); - continue; - } - } - if (type_map[i] >= (int)t_end) - continue; - - tm = tm_of((cl_type)type_map[i]); - - /* - general sweeper - */ - - if (debug) - printf("%c", tm->tm_name[0]); - - p = pagetochar(i); - f = tm->tm_free; - k = 0; - for (j = tm->tm_nppage; j > 0; --j, p += tm->tm_size) { - x = (cl_object)p; - if (x->d.m == FREE) - continue; - else if (x->d.m) { - x->d.m = FALSE; - continue; - } - /* INV: Make sure this is the same as in alloc_2.d */ - switch (x->d.t) { -#ifdef ENABLE_DLOPEN - case t_codeblock: - ecl_library_close(x); - break; -#endif - case t_stream: - if (!x->stream.closed) - cl_close(1, x); - break; -#ifdef ECL_THREADS - case t_lock: -#if defined(ECL_MS_WINDOWS_HOST) - CloseHandle(x->lock.mutex); -#else - pthread_mutex_destroy(&x->lock.mutex); -#endif - break; - case t_condition_variable: -#if defined(ECL_MS_WINDOWS_HOST) - CloseHandle(x->condition_variable.cv); -#else - pthread_cond_destroy(&x->condition_variable.cv); -#endif - break; -#endif -#ifdef ECL_SEMAPHORES - case t_semaphore: -#error "Unfinished" - break; -#endif - default:; - } - ((struct freelist *)x)->f_link = f; - x->d.m = FREE; - f = x; - k++; - } - tm->tm_free = f; - tm->tm_nfree += k; - tm->tm_nused -= k; - } - - if (debug) { - putchar('\n'); - fflush(stdout); - } -} - -static void -contblock_sweep_phase(void) -{ - register int i, j; - register cl_ptr s, e, p, q; - register struct contblock *cbp; - - cb_pointer = NULL; - ncb = 0; - for (i = 0; i < maxpage;) { - if (type_map[i] != (int)t_contiguous) { - i++; - continue; - } - for (j = i+1; - j < maxpage && type_map[j] == (int)t_contiguous; - j++) - ; - s = pagetochar(i); - e = pagetochar(j); - for (p = s; p < e;) { - if (get_mark_bit((int *)p)) { - p += 4; - continue; - } - q = p + 4; - while (q < e && !get_mark_bit((int *)q)) - q += 4; - ecl_dealloc(p); - p = q + 4; - } - i = j + 1; - } - - if (debug) { - for (cbp = cb_pointer; cbp != NULL; cbp = cbp->cb_link) - printf("0x%p %d\n", cbp, cbp->cb_size); - fflush(stdout); - } -} - -cl_object (*GC_enter_hook)() = NULL; -cl_object (*GC_exit_hook)() = NULL; - -void -ecl_gc(cl_type t) -{ - const cl_env_ptr env = ecl_process_env(); - int i, j; - int tm; - int gc_start = ecl_runtime(); - bool interrupts; - - if (!GC_enabled()) - return; - - GC_disable(); - - CL_NEWENV_BEGIN { - if (SYM_VAL(@'si::*gc-verbose*') != ECL_NIL) { - printf("\n[GC .."); - /* To use this should add entries in tm_table for reloc and contig. - fprintf(stdout, "\n[GC for %d %s pages ..", - tm_of(t)->tm_npage, - tm_table[(int)t].tm_name + 1); */ - fflush(stdout); - } - - debug = ecl_symbol_value(@'si::*gc-message*') != ECL_NIL; - - if (GC_enter_hook != NULL) - (*GC_enter_hook)(); - -#ifdef THREADS -#error "We need to stop all other threads" -#endif /* THREADS */ - - interrupts = env->disable_interrupts; - env->disable_interrupts = 1; - - collect_blocks = t > t_end; - if (collect_blocks) - cbgccount++; - else - tm_table[(int)t].tm_gccount++; - - if (debug) { - if (collect_blocks) - printf("GC entered for collecting blocks\n"); - else - printf("GC entered for collecting %s\n", tm_table[(int)t].tm_name); - fflush(stdout); - } - - maxpage = page(heap_end); - - if (collect_blocks) { - /* - 1 page = 512 word - 512 bit = 16 word - */ - int mark_table_size = maxpage * (LISP_PAGESIZE / 32); - extern void cl_resize_hole(cl_index); - - if (holepage < mark_table_size*sizeof(int)/LISP_PAGESIZE + 1) - new_holepage = mark_table_size*sizeof(int)/LISP_PAGESIZE + 1; - if (new_holepage < HOLEPAGE) - new_holepage = HOLEPAGE; - cl_resize_hole(new_holepage); - - mark_table = (int*)heap_end; - for (i = 0; i < mark_table_size; i++) - mark_table[i] = 0; - } - - if (debug) { - printf("mark phase\n"); - fflush(stdout); - tm = ecl_runtime(); - } - mark_phase(); - if (debug) { - printf("mark ended (%d)\n", ecl_runtime() - tm); - printf("sweep phase\n"); - fflush(stdout); - tm = ecl_runtime(); - } - sweep_phase(); - if (debug) { - printf("sweep ended (%d)\n", ecl_runtime() - tm); - fflush(stdout); - } - - if (t == t_contiguous) { - if (debug) { - printf("contblock sweep phase\n"); - fflush(stdout); - tm = ecl_runtime(); - } - contblock_sweep_phase(); - if (debug) - printf("contblock sweep ended (%d)\n", ecl_runtime() - tm); - } - - if (debug) { - for (i = 0, j = 0; i < (int)t_end; i++) { - if (tm_table[i].tm_type == (cl_type)i) { - printf("%13s: %8d used %8d free %4d/%d pages\n", - tm_table[i].tm_name, - tm_table[i].tm_nused, - tm_table[i].tm_nfree, - tm_table[i].tm_npage, - tm_table[i].tm_maxpage); - j += tm_table[i].tm_npage; - } else - printf("%13s: linked to %s\n", - tm_table[i].tm_name, - tm_table[(int)tm_table[i].tm_type].tm_name); - } - printf("contblock: %d blocks %d pages\n", ncb, ncbpage); - printf("hole: %d pages\n", holepage); - printf("GC ended\n"); - fflush(stdout); - } - - env->disable_interrupts = interrupts; - - if (GC_exit_hook != NULL) - (*GC_exit_hook)(); - - } CL_NEWENV_END; - - GC_enable(); - -#ifdef THREADS -#error "We need to activate all other threads again" -#endif /* THREADS */ - - gc_time += (gc_start = ecl_runtime() - gc_start); - - if (SYM_VAL(@'si::*gc-verbose*') != ECL_NIL) { - /* Don't use fprintf since on Linux it calls malloc() */ - printf(". finished in %.2f\"]", gc_start/60.0); - fflush(stdout); - } - - if (env->interrupt_pending) ecl_check_pending_interrupts(); -} - -/* - *---------------------------------------------------------------------- - * - * mark_contblock -- - * sets the mark bit for words from address p to address p+s. - * Both p and p+s are rounded to word boundaries. - * - * Results: - * none. - * - * Side effects: - * mark_table - * - *---------------------------------------------------------------------- - */ - -static void -_mark_contblock(void *x, cl_index s) -{ - cl_ptr p = x; - if (p >= heap_start && p < data_end) { - ptrdiff_t pg = page(p); - if ((cl_type)type_map[pg] == t_contiguous) { - cl_ptr q = p + s; - p = int2ptr(ptr2int(p) & ~3); - q = int2ptr(ptr2int(q + 3) & ~3); - for (; p < q; p+= 4) - set_mark_bit(p); - } - } -} - -/*---------------------------------------------------------------------- - * Utilities - *---------------------------------------------------------------------- - */ - -@(defun si::room-report () - int i; - cl_object *tl; -@ - the_env->nvalues = 8; - the_env->values[0] = ecl_make_fixnum(real_maxpage); - the_env->values[1] = ecl_make_fixnum(available_pages()); - the_env->values[2] = ecl_make_fixnum(ncbpage); - the_env->values[3] = ecl_make_fixnum(maxcbpage); - the_env->values[4] = ecl_make_fixnum(ncb); - the_env->values[5] = ecl_make_fixnum(cbgccount); - the_env->values[6] = ecl_make_fixnum(holepage); - the_env->values[7] = ECL_NIL; - tl = &the_env->values[7]; - for (i = 0; i < (int)t_end; i++) { - if (tm_table[i].tm_type == (cl_type)i) { - tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_nused), ECL_NIL)); - tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_nfree), ECL_NIL)); - tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_npage), ECL_NIL)); - tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_maxpage), ECL_NIL)); - tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_gccount), ECL_NIL)); - } else { - tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL)); - tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_type), ECL_NIL)); - tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL)); - tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL)); - tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL)); - } - } - return the_env->values[0]; -@) - -@(defun si::reset-gc-count () - int i; -@ - cbgccount = 0; - for (i = 0; i < (int)t_end; i++) - tm_table[i].tm_gccount = 0; - @(return) -@) - -@(defun si::gc-time () -@ - @(return ecl_make_fixnum(gc_time)) -@) - -cl_object -si_get_finalizer(cl_object o) -{ - @(return ECL_NIL) -} - -cl_object -si_set_finalizer(cl_object o, cl_object finalizer) -{ - @(return) -} - -void -init_GC(void) -{ - GC_enable(); - gc_time = 0; -} diff -Nru ecl-16.1.2/src/c/gbc-new.d ecl-16.1.3+ds/src/c/gbc-new.d --- ecl-16.1.2/src/c/gbc-new.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/gbc-new.d 1970-01-01 00:00:00.000000000 +0000 @@ -1,986 +0,0 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ - -/* - gbc.c -- Garbage collector. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi and William F. Schelter. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ - - -#include "ecl.h" -#include "page.h" - -/******************************* EXPORTS ******************************/ - -bool GC_enable; -int gc_time; /* Beppe */ - -/******************************* ------- ******************************/ - -/* - mark_table[m]:i represents word w = 128*m + 4*i, where m = addr-DATA_START. - Therefore m = w >> 7, i = (w / 4) % 32 = (w >> 2) & 0x1f. -*/ - -static int *mark_table; - -static void inline -set_mark_bit(void *x) { - int w = (int)x; - int m = (w - DATA_START) >> 7; - int i = (w >> 2) & 0x1f; - mark_table[m] |= (1 << i); -} -static int inline -get_mark_bit(void *x) { - int w = (int)x; - int m = (w - DATA_START) >> 7; - int i = (w >> 2) & 0x1f; - return (mark_table[m] >> i) & 1; -} - -#define inheap(pp) ((unsigned long)(pp) < (unsigned long)heap_end) -#define VALID_DATA_ADDRESS(pp) \ - !ECL_IMMEDIATE(pp) && (cl_index)DATA_START <= (cl_index)(pp) && (cl_index)(pp) < (cl_index)heap_end - -cl_object siVgc_verbose; -cl_object siVgc_message; - -static bool debug = FALSE; -static int maxpage; - -#define GC_ROOT_MAX 200 -static cl_object *gc_root[GC_ROOT_MAX]; -static int gc_roots; - -static bool collect_blocks; - -/* - We must register location, since value may be reassigned (e.g. malloc_list) - */ - -static void _mark_object (cl_object x); -static void _mark_contblock (void *p, size_t s); -extern void sigint (void); - -void -register_root(cl_object *p) -{ - if (gc_roots >= GC_ROOT_MAX) - error("too many roots"); - gc_root[gc_roots++] = p; -} - -@(defun gc (area) -@ - if (!GC_enabled()) - error("GC is not enabled"); - if (Null(area)) - gc(t_cons); - else - gc(t_contiguous); - @(return) -@) - -/*---------------------------------------------------------------------- - * Mark phase - *---------------------------------------------------------------------- - */ - -/* Whenever two arrays are linked together by displacement, - if one is live, the other will be made live */ -#define mark_displaced(ar) mark_object(ar) -#define mark_contblock(x,s) {if (collect_blocks) _mark_contblock(x,s); } -#if 1 -#define mark_object(x) if ((x != OBJNULL) && !ECL_IMMEDIATE(x)) _mark_object(x) -#define mark_next(a) if ((a != OBJNULL) && !ECL_IMMEDIATE(a)) { x=(a); goto BEGIN; } -#else -#define mark_object(x) _mark_object(x) -#define mark_next(a) x=(a); goto BEGIN -#endif - -/* We make bitvectors multiple of sizeof(int) in size allocated - Assume 8 = number of bits in char */ -#define W_SIZE (8*sizeof(int)) - -static void -_mark_object(cl_object x) -{ - size_t i, j; - cl_object *p, y; - char *cp; - - cs_check(x); -BEGIN: -#if 0 - /* We cannot get here because mark_object() and mark_next() already check this */ - if (ECL_IMMEDIATE(x)) return; /* fixnum, character or locative */ - if (x == OBJNULL) - return; -#endif - if (get_mark_bit(x)) - return; - set_mark_bit(x); - - switch (ecl_t_of(x)) { - - case t_bignum: -#ifdef WITH_GMP - if (collect_blocks) { - /* GMP may set num.alloc before actually allocating anything. - With these checks we make sure we do not move anything - we don't have to. Besides, we use big_dim as the size - of the object, because big_size might even be smaller. - */ - char *limbs = (char *)x->big.big_limbs; - size_t size = x->big.big_dim * sizeof(mp_limb_t); - if (size) mark_contblock(limbs, size); - } -#endif /* WITH_GMP */ - break; - - case t_ratio: - mark_object(x->ratio.num); - mark_next(x->ratio.den); - break; - -#ifdef ECL_SSE2 - case t_sse_pack: -#endif - case t_singlefloat: - case t_doublefloat: - break; - - case t_complex: - mark_object(x->complex.imag); - mark_next(x->complex.real); - break; - - case t_character: - break; - - case t_symbol: - mark_object(x->symbol.name); - mark_object(x->symbol.plist); - mark_object(ECL_SYM_FUN(x)); - mark_next(SYM_VAL(x)); - break; - - case t_package: - mark_object(x->pack.name); - mark_object(x->pack.nicknames); - mark_object(x->pack.shadowings); - mark_object(x->pack.uses); - mark_object(x->pack.usedby); - mark_object(x->pack.internal); - mark_next(x->pack.external); - break; - - case t_cons: - mark_object(CAR(x)); - mark_next(CDR(x)); - break; - - case t_hashtable: - mark_object(x->hash.rehash_size); - mark_object(x->hash.threshold); - if (x->hash.data == NULL) - break; - for (i = 0, j = x->hash.size; i < j; i++) { - mark_object(x->hash.data[i].key); - mark_object(x->hash.data[i].value); - } - mark_contblock(x->hash.data, j * sizeof(struct hashtable_entry)); - break; - - case t_array: - mark_contblock(x->array.dims, sizeof(x->array.dims[0])*x->array.rank); -#ifdef ECL_UNICODE - case t_string: -#endif - case t_vector: - if ((y = x->array.displaced) != ECL_NIL) - mark_displaced(y); - cp = (char *)x->array.self.t; - if (cp == NULL) - break; - switch ((enum aelttype)x->array.elttype) { -#ifdef ECL_UNICODE - case ecl_aet_ch: -#endif - case ecl_aet_object: - if (x->array.displaced == ECL_NIL || CAR(x->array.displaced) == ECL_NIL) { - cl_object *p = x->array.self.t; - cl_index i; - if (x->array.t == t_vector && x->vector.hasfillp) - i = x->vector.fillp; - else - i = x->vector.dim; - while (i-- > 0) - mark_object(p[i]); - } - j = sizeof(cl_object)*x->array.dim; - break; - case ecl_aet_bc: - j = x->array.dim; - break; - case ecl_aet_bit: - j = sizeof(int) * ((x->vector.offset + x->vector.dim + W_SIZE -1)/W_SIZE); - break; - case ecl_aet_fix: - j = x->array.dim * sizeof(cl_fixnum); - break; - case ecl_aet_sf: - j = x->array.dim * sizeof(float); - break; - case ecl_aet_df: - j = x->array.dim * sizeof(double); - break; - default: - error("Allocation botch: unknown array element type"); - } - goto COPY_ARRAY; - case t_base_string: - if ((y = x->base_string.displaced) != ECL_NIL) - mark_displaced(y); - cp = x->base_string.self; - if (cp == NULL) - break; - j = x->base_string.dim; - COPY_ARRAY: - mark_contblock(cp, j); - break; - case t_bitvector: - if ((y = x->vector.displaced) != ECL_NIL) - mark_displaced(y); - cp = x->vector.self.bit; - if (cp == NULL) - break; - j= sizeof(int) * ((x->vector.offset + x->vector.dim + W_SIZE -1)/W_SIZE); - goto COPY_ARRAY; - case t_stream: - switch ((enum smmode)x->stream.mode) { - case ecl_smm_closed: - /* Rest of fields are NULL */ - mark_next(x->stream.object1); - break; - case ecl_smm_input: - case ecl_smm_output: - case ecl_smm_io: - case ecl_smm_probe: - mark_object(x->stream.object0); - mark_object(x->stream.object1); - mark_contblock(x->stream.buffer, BUFSIZ); - break; - - case ecl_smm_synonym: - mark_next(x->stream.object0); - break; - - case ecl_smm_broadcast: - case ecl_smm_concatenated: - mark_next(x->stream.object0); - break; - - case ecl_smm_two_way: - case ecl_smm_echo: - mark_object(x->stream.object0); - mark_next(x->stream.object1); - break; - - case ecl_smm_string_input: - case ecl_smm_string_output: - mark_next(x->stream.object0); - break; - - default: - error("mark stream botch"); - } - break; - - case t_random: - break; - - case t_readtable: - if (x->readtable.table == NULL) - break; - mark_contblock((char *)(x->readtable.table), RTABSIZE*sizeof(struct readtable_entry)); - for (i = 0; i < RTABSIZE; i++) { - cl_object *p = x->readtable.table[i].dispatch_table; - mark_object(x->readtable.table[i].macro); - if (p != NULL) { - mark_contblock(p, RTABSIZE*sizeof(cl_object)); - for (j = 0; j < RTABSIZE; j++) - mark_object(p[j]); - } - } - break; - - case t_pathname: - mark_object(x->pathname.host); - mark_object(x->pathname.device); - mark_object(x->pathname.directory); - mark_object(x->pathname.name); - mark_object(x->pathname.type); - mark_object(x->pathname.version); - break; - - case t_bytecodes: { - cl_index i, size; - size = x->bytecodes.size; - mark_object(x->bytecodes.lex); - mark_contblock(x->bytecodes.data, size * sizeof(cl_object)); - for (i=0; ibytecodes.data[i]); - break; - } - case t_cfun: - mark_object(x->cfun.block); - mark_object(x->cfun.name); - break; - - case t_cclosure: - mark_object(x->cfun.block); - mark_object(x->cclosure.env); - break; - -#ifdef THREADS - case t_cont: - mark_next(x->cn.cn_thread); - break; - - case t_thread: -/* Already marked by malloc - mark_contblock(x->thread.data, x->thread.size); - */ - mark_next(x->thread.entry); - break; -#endif THREADS - case t_instance: - mark_object(x->instance.class); - p = x->instance.slots; - if (p == NULL) - break; - for (i = 0, j = x->instance.length; i < j; i++) - mark_object(p[i]); - mark_contblock(p, j*sizeof(cl_object)); - break; - - case t_gfun: - mark_object(x->gfun.name); - mark_object(x->gfun.method_hash); - mark_object(x->gfun.instance); - p = x->gfun.specializers; - if (p == NULL) - break; - for (i = 0, j = x->gfun.arg_no; i < j; i++) - mark_object(p[i]); - mark_contblock(p, j*sizeof(cl_object)); - break; - case t_codeblock: - mark_object(x->cblock.name); - mark_contblock(x->cblock.start, x->cblock.size); - if (x->cblock.data) { - cl_index i = x->cblock.data_size; - cl_object *p = x->cblock.data; - while (i--) - mark_object(p[i]); - } - break; - default: - if (debug) - printf("\ttype = %d\n", ecl_t_of(x)); - error("mark botch"); - } -} - -static void -mark_stack_conservative(int *top, int *bottom) -{ - int p, m; - cl_object x; - struct typemanager *tm; - register int *j; - - if (debug) { printf("Traversing C stack .."); fflush(stdout); } - - /* On machines which align local pointers on multiple of 2 rather - than 4 we need to mark twice - - if (offset) mark_stack_conservative(bottom, ((char *) top) + offset, 0); - */ - for (j = top ; j >= bottom ; j--) { - /* improved Beppe: */ - if (VALID_DATA_ADDRESS(*j) && type_map[p = page(*j)] < (char)t_end) { - tm = tm_of((enum type)type_map[p]); - x = (cl_object)(*j - (*j - (int)pagetochar(p)) % tm->tm_size); - if (!get_mark_bit(x)) - mark_object(x); - } - } - if (debug) {printf(". done.\n"); fflush(stdout); } -} - -static void -mark_phase(void) -{ - register int i; - register struct package *pp; - register ecl_bds_ptr bdp; - register ecl_frame_ptr frp; - register ecl_ihs_ptr ihsp; - - mark_object(ECL_NIL); - mark_object(ECL_T); - -#ifdef THREADS - { - pd *pdp; - lpd *old_clwp = clwp; - - for (pdp = running_head; pdp != (pd *)NULL; pdp = pdp->pd_next) { - - clwp = pdp->pd_lpd; -#endif THREADS - - for (i=0; ibds_sym); - mark_object(bdp->bds_val); - } - - for (frp = frs_org; frp <= frs_top; frp++) { - mark_object(frp->frs_val); - mark_object(frp->frs_lex); - } - - for (ihsp = ihs_org; ihsp <= ihs_top; ihsp++) { - mark_object(ihsp->ihs_function); - mark_object(ihsp->ihs_base); - } - - mark_object(lex_env); - -#ifdef THREADS - /* added to mark newly allocated objects */ - mark_object(clwp->lwp_alloc_temporary); - mark_object(clwp->lwp_fmt_temporary_stream); - mark_object(clwp->lwp_PRINTstream); - mark_object(clwp->lwp_PRINTcase); - mark_object(clwp->lwp_READtable); - mark_object(clwp->lwp_delimiting_char); - mark_object(clwp->lwp_token); - - /* (current-thread) can return it at any time - */ - mark_object(clwp->lwp_thread); -#endif THREADS - - /* now collect from the c-stack of the thread ... */ - - { int *where; - volatile jmp_buf buf; - - /* ensure flushing of register caches */ - if (ecl_setjmp(buf) == 0) ecl_longjmp(buf, 1); - -#ifdef THREADS - if (clwp != old_clwp) /* is not the executing stack */ -# ifdef __linux - where = (int *)pdp->pd_env[0].__jmpbuf[0].__sp; -# else - where = (int *)pdp->pd_env[JB_SP]; -# endif - else -#endif THREADS - where = (int *)&where ; - - /* If the locals of type object in a C function could be - aligned other than on multiples of sizeof (char *) - we would have to mark twice */ - - if (where > cs_org) - mark_stack_conservative(where, cs_org); - else - mark_stack_conservative(cs_org, where); - } -#ifdef THREADS - } - clwp = old_clwp; - } -#endif THREADS - - /* mark roots */ - for (i = 0; i < gc_roots; i++) - mark_object(*gc_root[i]); - - /* mark registered symbols & keywords */ - { - const struct keyword_info *k; - const struct symbol_info *s; - for (k = all_keywords; k->loc != NULL; k++) - mark_object(*(k->loc)); - for (s = all_symbols; s->loc != NULL; s++) - mark_object(*(s->loc)); - } - - if (debug) { - printf("symbol navigation\n"); - fflush(stdout); - } -} - -static void -sweep_phase(void) -{ - register int i, j, k; - register cl_object x; - register char *p; - register struct typemanager *tm; - register cl_object f; - - ECL_NIL->symbol.m = FALSE; - ECL_T->symbol.m = FALSE; - - if (debug) - printf("type map\n"); - - for (i = 0; i < maxpage; i++) { - if (type_map[i] == (int)t_contiguous) { - if (debug) { - printf("-"); - continue; - } - } - if (type_map[i] >= (int)t_end) - continue; - - tm = tm_of((enum type)type_map[i]); - - /* - general sweeper - */ - - if (debug) - printf("%c", tm->tm_name[0]); - - p = pagetochar(i); - f = tm->tm_free; - k = 0; - for (j = tm->tm_nppage; j > 0; --j, p += tm->tm_size) { - x = (cl_object)p; - if (!get_mark_bit(x)) { - ((struct freelist *)x)->f_link = f; - f = x; - k++; - } - } - tm->tm_free = f; - tm->tm_nfree += k; - tm->tm_nused -= k; - } - - if (debug) { - putchar('\n'); - fflush(stdout); - } -} - -static void -contblock_sweep_phase(void) -{ - register int i, j; - register char *s, *e, *p, *q; - register struct contblock *cbp; - - cb_pointer = NULL; - ncb = 0; - for (i = 0; i < maxpage;) { - if (type_map[i] != (int)t_contiguous) { - i++; - continue; - } - for (j = i+1; - j < maxpage && type_map[j] == (int)t_contiguous; - j++) - ; - s = pagetochar(i); - e = pagetochar(j); - for (p = s; p < e;) { - if (get_mark_bit((int *)p)) { - p += 4; - continue; - } - q = p + 4; - while (q < e && !get_mark_bit((int *)q)) - q += 4; - dealloc(p, q - p); - p = q + 4; - } - i = j + 1; - } - - if (debug) { - for (cbp = cb_pointer; cbp != NULL; cbp = cbp->cb_link) - printf("0x%p %d\n", cbp, cbp->cb_size); - fflush(stdout); - } -} - -cl_object (*GC_enter_hook)() = NULL; -cl_object (*GC_exit_hook)() = NULL; - - -#ifdef THREADS -/* - * We execute the GC routine in the main stack. - * The idea is to switch over the main stack that is stopped in the intha - * and to call the GC from there on garbage_parameter. Then you can switch - * back after. - * In addition the interrupt is disabled. - */ -static int i, j; -static sigjmp_buf old_env; -static int val; -static lpd *old_clwp; -static enum type t; -static bool stack_switched = FALSE; - -static enum type garbage_parameter; - -void -gc(enum type new_name) -{ - int tm; - int gc_start = runtime(); - - start_critical_section(); - t = new_name; - garbage_parameter = new_name; -#else - -void -gc(enum type t) -{ - int i, j; - int tm; - int gc_start = runtime(); -#endif THREADS - - if (!GC_enabled()) - return; - - if (SYM_VAL(siVgc_verbose) != ECL_NIL) { - printf("\n[GC .."); - /* To use this should add entries in tm_table for reloc and contig. - fprintf(stdout, "\n[GC for %d %s pages ..", - tm_of(t)->tm_npage, - tm_table[(int)t].tm_name + 1); */ - fflush(stdout); - } - - debug = symbol_value(siVgc_message) != ECL_NIL; - -#ifdef THREADS - if (clwp != &main_lpd) { - if (debug) { - printf("*STACK SWITCH*\n"); - fflush (stdout); - } - - stack_switched = TRUE; - val = sigsetjmp(old_env, 1); - if (val == 0) { - /* informations used by the garbage collector need to be updated */ -# ifdef __linux - running_head->pd_env[0].__jmpbuf[0].__sp = old_env[0].__jmpbuf[0].__sp; -# else - running_head->pd_env[JB_SP] = old_env[JB_SP]; -# endif - old_clwp = clwp; - Values = main_lpd.lwp_Values; - clwp = &main_lpd; - siglongjmp(main_pd.pd_env, 2); /* new line */ - } - } - - else val = 1; - - if (val == 1) { - -#endif THREADS - - if (GC_enter_hook != NULL) - (*GC_enter_hook)(0); - - interrupt_enable = FALSE; - - collect_blocks = t > t_end; - if (collect_blocks) - cbgccount++; - else - tm_table[(int)t].tm_gccount++; - - if (debug) { - if (collect_blocks) - printf("GC entered for collecting blocks\n"); - else - printf("GC entered for collecting %s\n", tm_table[(int)t].tm_name); - fflush(stdout); - } - - maxpage = page(heap_end); - - if (collect_blocks) { - /* - 1 page = 512 word - 512 bit = 16 word - */ - int mark_table_size = maxpage * (LISP_PAGESIZE / 32); - extern void resize_hole(size_t); - - if (holepage < mark_table_size*sizeof(int)/LISP_PAGESIZE + 1) - new_holepage = mark_table_size*sizeof(int)/LISP_PAGESIZE + 1; - if (new_holepage < HOLEPAGE) - new_holepage = HOLEPAGE; - resize_hole(new_holepage); - - mark_table = (int*)heap_end; - for (i = 0; i < mark_table_size; i++) - mark_table[i] = 0; - } - - if (debug) { - printf("mark phase\n"); - fflush(stdout); - tm = runtime(); - } - mark_phase(); - if (debug) { - printf("mark ended (%d)\n", runtime() - tm); - printf("sweep phase\n"); - fflush(stdout); - tm = runtime(); - } - sweep_phase(); - if (debug) { - printf("sweep ended (%d)\n", runtime() - tm); - fflush(stdout); - } - - if (t == t_contiguous) { - if (debug) { - printf("contblock sweep phase\n"); - fflush(stdout); - tm = runtime(); - } - contblock_sweep_phase(); - if (debug) - printf("contblock sweep ended (%d)\n", runtime() - tm); - } - - if (debug) { - for (i = 0, j = 0; i < (int)t_end; i++) { - if (tm_table[i].tm_type == (enum type)i) { - printf("%13s: %8d used %8d free %4d/%d pages\n", - tm_table[i].tm_name, - tm_table[i].tm_nused, - tm_table[i].tm_nfree, - tm_table[i].tm_npage, - tm_table[i].tm_maxpage); - j += tm_table[i].tm_npage; - } else - printf("%13s: linked to %s\n", - tm_table[i].tm_name, - tm_table[(int)tm_table[i].tm_type].tm_name); - } - printf("contblock: %d blocks %d pages\n", ncb, ncbpage); - printf("hole: %d pages\n", holepage); - printf("GC ended\n"); - fflush(stdout); - } - - interrupt_enable = TRUE; - - if (GC_exit_hook != NULL) - (*GC_exit_hook)(); - -#ifdef THREADS - - /* - * Back in the right stack - */ - - if (stack_switched) { - if (debug) { - printf("*STACK BACK*\n"); - fflush (stdout); - } - - stack_switched = FALSE; - - end_critical_section(); /* we get here from the GC call in scheduler */ - - clwp = old_clwp; - Values = clwp->lwp_Values; - siglongjmp(old_env, 2); - } - } -#endif THREADS - - gc_time += (gc_start = runtime() - gc_start); - - if (SYM_VAL(siVgc_verbose) != ECL_NIL) { - /* Don't use fprintf since on Linux it calls malloc() */ - printf(". finished in %.2f\"]", gc_start/60.0); - fflush(stdout); - } - -#ifdef unix - if (interrupt_flag) sigint(); -#endif unix - -#ifdef THREADS - end_critical_section(); -#endif THREADS -} - -/* - *---------------------------------------------------------------------- - * - * mark_contblock -- - * sets the mark bit for words from address p to address p+s. - * Both p and p+s are rounded to word boundaries. - * - * Results: - * none. - * - * Side effects: - * mark_table - * - *---------------------------------------------------------------------- - */ - -static void -_mark_contblock(void *x, size_t s) -{ - register char *p = x, *q; - register ptrdiff_t pg = page(p); - - if (pg < 0 || (enum type)type_map[pg] != t_contiguous) - return; -#if 1 - q = p + s; - p = (char *)((int)p&~3); - q = (char *)(((int)q+3)&~3); - for (; p < q; p+= 4) - set_mark_bit(p); -#elif 0 - { - int bit_start = ((int)p - DATA_START) >> 2; - int bit_end = ((int)p + s + 3 - DATA_START) >> 2; - int *w = &mark_table[bit_start >> 5]; - int b = bit_start & (32 - 1); - int mask = ~0 << b; - int bits = b + bit_end - bit_start; - while (bits >= 32) { - *w |= mask; - w++; - bits -= 32; - mask = ~0; - } - mask &= ~(~0 << bits); - *w |= mask; - } -#else - { - int bit_start = ((int)p - DATA_START) >> 2; - int bits = ((int)p + s + 3 - DATA_START) >> 2 - bit_start; - int mask = 1 << bit_start & (32 - 1); - int *w = &mark_table[bit_start >> 5]; - while (bits) { - *w |= mask; - mask <<= 1; - if (!mask) { - mask = 1; - w++; - } - } - } -#endif -} - -/*---------------------------------------------------------------------- - * Utilities - *---------------------------------------------------------------------- - */ - -@(defun si::room-report () - int i; - cl_object *tl; -@ - NValues = 8; - VALUES(0) = ecl_make_fixnum(real_maxpage); - VALUES(1) = ecl_make_fixnum(available_pages()); - VALUES(2) = ecl_make_fixnum(ncbpage); - VALUES(3) = ecl_make_fixnum(maxcbpage); - VALUES(4) = ecl_make_fixnum(ncb); - VALUES(5) = ecl_make_fixnum(cbgccount); - VALUES(6) = ecl_make_fixnum(holepage); - VALUES(7) = ECL_NIL; - tl = &VALUES(7); - for (i = 0; i < (int)t_end; i++) { - if (tm_table[i].tm_type == (enum type)i) { - tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_nused), ECL_NIL)); - tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_nfree), ECL_NIL)); - tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_npage), ECL_NIL)); - tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_maxpage), ECL_NIL)); - tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_gccount), ECL_NIL)); - } else { - tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL)); - tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_type), ECL_NIL)); - tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL)); - tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL)); - tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL)); - } - } - return VALUES(0); -@) - -@(defun si::reset-gc-count () - int i; -@ - cbgccount = 0; - for (i = 0; i < (int)t_end; i++) - tm_table[i].tm_gccount = 0; - @(return) -@) - -@(defun si::gc-time () -@ - @(return ecl_make_fixnum(gc_time)) -@) - -void -init_GC(void) -{ - register_root(&siVgc_verbose); - register_root(&siVgc_message); - siVgc_verbose = make_si_special("*GC-VERBOSE*", ECL_NIL); - siVgc_message = make_si_special("*GC-MESSAGE*", ECL_NIL); - GC_enable(); - gc_time = 0; -} diff -Nru ecl-16.1.2/src/c/gfun.d ecl-16.1.3+ds/src/c/gfun.d --- ecl-16.1.2/src/c/gfun.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/gfun.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - gfun.c -- Dispatch for generic functions. -*/ -/* - Copyright (c) 1990, Giuseppe Attardi. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * gfun.d - dispatch for generic functions + * + * Copyright (c) 1990 Giuseppe Attardi + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -26,282 +21,282 @@ cl_object FEnot_funcallable_fixed() { - cl_env_ptr env = ecl_process_env(); - cl_object fun = env->function; - FEerror("Not a funcallable instance ~A.", 1, fun); - @(return); + cl_env_ptr env = ecl_process_env(); + cl_object fun = env->function; + FEerror("Not a funcallable instance ~A.", 1, fun); + @(return); } cl_object FEnot_funcallable_vararg(cl_narg narg, ...) { - return FEnot_funcallable_fixed(); + return FEnot_funcallable_fixed(); } static cl_object user_function_dispatch(cl_narg narg, ...) { - int i; - cl_object output; - cl_env_ptr env = ecl_process_env(); - cl_object fun = env->function; - struct ecl_stack_frame frame_aux; - const cl_object frame = ecl_stack_frame_open(env, (cl_object)&frame_aux, narg); - ecl_va_list args; ecl_va_start(args, narg, narg, 0); - for (i = 0; i < narg; i++) { - ECL_STACK_FRAME_SET(frame, i, ecl_va_arg(args)); - } - fun = fun->instance.slots[fun->instance.length - 1]; - output = ecl_apply_from_stack_frame(frame, fun); - ecl_stack_frame_close(frame); - return output; + int i; + cl_object output; + cl_env_ptr env = ecl_process_env(); + cl_object fun = env->function; + struct ecl_stack_frame frame_aux; + const cl_object frame = ecl_stack_frame_open(env, (cl_object)&frame_aux, narg); + ecl_va_list args; ecl_va_start(args, narg, narg, 0); + for (i = 0; i < narg; i++) { + ECL_STACK_FRAME_SET(frame, i, ecl_va_arg(args)); + } + fun = fun->instance.slots[fun->instance.length - 1]; + output = ecl_apply_from_stack_frame(frame, fun); + ecl_stack_frame_close(frame); + return output; } static void reshape_instance(cl_object x, int delta) { - cl_fixnum size = x->instance.length + delta; - cl_object aux = ecl_allocate_instance(ECL_CLASS_OF(x), size); - /* Except for the different size, this must match si_copy_instance */ - aux->instance.sig = x->instance.sig; - memcpy(aux->instance.slots, x->instance.slots, - (delta < 0 ? aux->instance.length : x->instance.length) * - sizeof(cl_object)); - x->instance = aux->instance; + cl_fixnum size = x->instance.length + delta; + cl_object aux = ecl_allocate_instance(ECL_CLASS_OF(x), size); + /* Except for the different size, this must match si_copy_instance */ + aux->instance.sig = x->instance.sig; + memcpy(aux->instance.slots, x->instance.slots, + (delta < 0 ? aux->instance.length : x->instance.length) * + sizeof(cl_object)); + x->instance = aux->instance; } cl_object clos_set_funcallable_instance_function(cl_object x, cl_object function_or_t) { - if (ecl_unlikely(!ECL_INSTANCEP(x))) - FEwrong_type_nth_arg(@[clos::set-funcallable-instance-function], - 1, x, @[ext::instance]); - if (x->instance.isgf == ECL_USER_DISPATCH) { - reshape_instance(x, -1); - x->instance.isgf = ECL_NOT_FUNCALLABLE; - } - if (function_or_t == ECL_T) { - x->instance.isgf = ECL_STANDARD_DISPATCH; - x->instance.entry = generic_function_dispatch_vararg; - } else if (function_or_t == @'standard-generic-function') { - x->instance.isgf = ECL_RESTRICTED_DISPATCH; - x->instance.entry = generic_function_dispatch_vararg; - } else if (function_or_t == ECL_NIL) { - x->instance.isgf = ECL_NOT_FUNCALLABLE; - x->instance.entry = FEnot_funcallable_vararg; - } else if (function_or_t == @'clos::standard-optimized-reader-method') { - /* WARNING: We assume that f(a,...) behaves as f(a,b) */ - x->instance.isgf = ECL_READER_DISPATCH; - x->instance.entry = (cl_objectfn)ecl_slot_reader_dispatch; - } else if (function_or_t == @'clos::standard-optimized-writer-method') { - /* WARNING: We assume that f(a,...) behaves as f(a,b) */ - x->instance.isgf = ECL_WRITER_DISPATCH; - x->instance.entry = (cl_objectfn)ecl_slot_writer_dispatch; - } else if (Null(cl_functionp(function_or_t))) { - FEwrong_type_argument(@'function', function_or_t); - } else { - reshape_instance(x, +1); - x->instance.slots[x->instance.length - 1] = function_or_t; - x->instance.isgf = ECL_USER_DISPATCH; - x->instance.entry = user_function_dispatch; - } - @(return x) + if (ecl_unlikely(!ECL_INSTANCEP(x))) + FEwrong_type_nth_arg(@[clos::set-funcallable-instance-function], + 1, x, @[ext::instance]); + if (x->instance.isgf == ECL_USER_DISPATCH) { + reshape_instance(x, -1); + x->instance.isgf = ECL_NOT_FUNCALLABLE; + } + if (function_or_t == ECL_T) { + x->instance.isgf = ECL_STANDARD_DISPATCH; + x->instance.entry = generic_function_dispatch_vararg; + } else if (function_or_t == @'standard-generic-function') { + x->instance.isgf = ECL_RESTRICTED_DISPATCH; + x->instance.entry = generic_function_dispatch_vararg; + } else if (function_or_t == ECL_NIL) { + x->instance.isgf = ECL_NOT_FUNCALLABLE; + x->instance.entry = FEnot_funcallable_vararg; + } else if (function_or_t == @'clos::standard-optimized-reader-method') { + /* WARNING: We assume that f(a,...) behaves as f(a,b) */ + x->instance.isgf = ECL_READER_DISPATCH; + x->instance.entry = (cl_objectfn)ecl_slot_reader_dispatch; + } else if (function_or_t == @'clos::standard-optimized-writer-method') { + /* WARNING: We assume that f(a,...) behaves as f(a,b) */ + x->instance.isgf = ECL_WRITER_DISPATCH; + x->instance.entry = (cl_objectfn)ecl_slot_writer_dispatch; + } else if (Null(cl_functionp(function_or_t))) { + FEwrong_type_argument(@'function', function_or_t); + } else { + reshape_instance(x, +1); + x->instance.slots[x->instance.length - 1] = function_or_t; + x->instance.isgf = ECL_USER_DISPATCH; + x->instance.entry = user_function_dispatch; + } + @(return x); } cl_object si_generic_function_p(cl_object x) { - @(return ((ECL_INSTANCEP(x) && (x->instance.isgf))? ECL_T : ECL_NIL)) + @(return ((ECL_INSTANCEP(x) && (x->instance.isgf))? ECL_T : ECL_NIL)); } static cl_object fill_spec_vector(cl_object vector, cl_object frame, cl_object gf) { - cl_object *args = frame->frame.base; - cl_index narg = frame->frame.size; - cl_object spec_how_list = GFUN_SPEC(gf); - cl_object *argtype = vector->vector.self.t; - int spec_no = 1; - argtype[0] = gf; - loop_for_on_unsafe(spec_how_list) { - cl_object spec_how = ECL_CONS_CAR(spec_how_list); - cl_object spec_type = ECL_CONS_CAR(spec_how); - int spec_position = ecl_fixnum(ECL_CONS_CDR(spec_how)); - cl_object eql_spec; - unlikely_if (spec_position >= narg) - FEwrong_num_arguments(gf); - unlikely_if (spec_no >= vector->vector.dim) - ecl_internal_error("Too many arguments to fill_spec_vector()"); - /* Need to differentiate between EQL specializers and - class specializers, because the EQL value can be a - class, and may clash with a class specializer. - Store the cons cell containing the EQL value. */ - if (ECL_LISTP(spec_type) && - !Null(eql_spec = ecl_memql(args[spec_position], spec_type))) { - argtype[spec_no++] = eql_spec; - } else { - argtype[spec_no++] = cl_class_of(args[spec_position]); - } - - } end_loop_for_on_unsafe(spec_how_list); - vector->vector.fillp = spec_no; - return vector; + cl_object *args = frame->frame.base; + cl_index narg = frame->frame.size; + cl_object spec_how_list = GFUN_SPEC(gf); + cl_object *argtype = vector->vector.self.t; + int spec_no = 1; + argtype[0] = gf; + loop_for_on_unsafe(spec_how_list) { + cl_object spec_how = ECL_CONS_CAR(spec_how_list); + cl_object spec_type = ECL_CONS_CAR(spec_how); + int spec_position = ecl_fixnum(ECL_CONS_CDR(spec_how)); + cl_object eql_spec; + unlikely_if (spec_position >= narg) + FEwrong_num_arguments(gf); + unlikely_if (spec_no >= vector->vector.dim) + ecl_internal_error("Too many arguments to fill_spec_vector()"); + /* Need to differentiate between EQL specializers and + class specializers, because the EQL value can be a + class, and may clash with a class specializer. + Store the cons cell containing the EQL value. */ + if (ECL_LISTP(spec_type) && + !Null(eql_spec = ecl_memql(args[spec_position], spec_type))) { + argtype[spec_no++] = eql_spec; + } else { + argtype[spec_no++] = cl_class_of(args[spec_position]); + } + + } end_loop_for_on_unsafe(spec_how_list); + vector->vector.fillp = spec_no; + return vector; } static cl_object frame_to_list(cl_object frame) { - cl_object arglist, *p; - for (p = frame->frame.base + frame->frame.size, arglist = ECL_NIL; - p != frame->frame.base; ) { - arglist = CONS(*(--p), arglist); - } - return arglist; + cl_object arglist, *p; + for (p = frame->frame.base + frame->frame.size, arglist = ECL_NIL; + p != frame->frame.base; ) { + arglist = CONS(*(--p), arglist); + } + return arglist; } static cl_object frame_to_classes(cl_object frame) { - cl_object arglist, *p; - for (p = frame->frame.base + frame->frame.size, arglist = ECL_NIL; - p != frame->frame.base; ) { - arglist = CONS(cl_class_of(*(--p)), arglist); - } - return arglist; + cl_object arglist, *p; + for (p = frame->frame.base + frame->frame.size, arglist = ECL_NIL; + p != frame->frame.base; ) { + arglist = CONS(cl_class_of(*(--p)), arglist); + } + return arglist; } static cl_object generic_compute_applicable_method(cl_env_ptr env, cl_object frame, cl_object gf) { - /* method not cached */ - cl_object memoize; - cl_object methods = _ecl_funcall3(@'clos::compute-applicable-methods-using-classes', - gf, frame_to_classes(frame)); - unlikely_if (Null(memoize = env->values[1])) { - cl_object arglist = frame_to_list(frame); - methods = _ecl_funcall3(@'compute-applicable-methods', - gf, arglist); - unlikely_if (methods == ECL_NIL) { - env->values[1] = ECL_NIL; - return methods; - } - } - methods = clos_compute_effective_method_function(gf, GFUN_COMB(gf), methods); - env->values[1] = ECL_T; - return methods; + /* method not cached */ + cl_object memoize; + cl_object methods = _ecl_funcall3(@'clos::compute-applicable-methods-using-classes', + gf, frame_to_classes(frame)); + unlikely_if (Null(memoize = env->values[1])) { + cl_object arglist = frame_to_list(frame); + methods = _ecl_funcall3(@'compute-applicable-methods', + gf, arglist); + unlikely_if (methods == ECL_NIL) { + env->values[1] = ECL_NIL; + return methods; + } + } + methods = clos_compute_effective_method_function(gf, GFUN_COMB(gf), methods); + env->values[1] = ECL_T; + return methods; } static cl_object restricted_compute_applicable_method(cl_env_ptr env, cl_object frame, cl_object gf) { - /* method not cached */ - cl_object arglist = frame_to_list(frame); - cl_object methods = clos_std_compute_applicable_methods(gf, arglist); - unlikely_if (methods == ECL_NIL) { - env->values[1] = ECL_NIL; - return methods; - } - methods = clos_std_compute_effective_method(gf, GFUN_COMB(gf), methods); - env->values[1] = ECL_T; - return methods; + /* method not cached */ + cl_object arglist = frame_to_list(frame); + cl_object methods = clos_std_compute_applicable_methods(gf, arglist); + unlikely_if (methods == ECL_NIL) { + env->values[1] = ECL_NIL; + return methods; + } + methods = clos_std_compute_effective_method(gf, GFUN_COMB(gf), methods); + env->values[1] = ECL_T; + return methods; } static cl_object compute_applicable_method(cl_env_ptr env, cl_object frame, cl_object gf) { - if (gf->instance.isgf == ECL_RESTRICTED_DISPATCH) - return restricted_compute_applicable_method(env, frame, gf); - else - return generic_compute_applicable_method(env, frame, gf); + if (gf->instance.isgf == ECL_RESTRICTED_DISPATCH) + return restricted_compute_applicable_method(env, frame, gf); + else + return generic_compute_applicable_method(env, frame, gf); } cl_object _ecl_standard_dispatch(cl_object frame, cl_object gf) { - cl_object func, vector; - const cl_env_ptr env = frame->frame.env; - ecl_cache_ptr cache = env->method_cache; - ecl_cache_record_ptr e; - /* - * We have to copy the frame because it might be stored in cl_env.values - * which will be wiped out by the next function call. However this only - * happens when we cannot reuse the values in the C stack. - */ + cl_object func, vector; + const cl_env_ptr env = frame->frame.env; + ecl_cache_ptr cache = env->method_cache; + ecl_cache_record_ptr e; + /* + * We have to copy the frame because it might be stored in cl_env.values + * which will be wiped out by the next function call. However this only + * happens when we cannot reuse the values in the C stack. + */ #if !defined(ECL_USE_VARARG_AS_POINTER) - struct ecl_stack_frame frame_aux; - if (frame->frame.stack == (void*)0x1) { - const cl_object new_frame = (cl_object)&frame_aux; - ECL_STACK_FRAME_COPY(new_frame, frame); - frame = new_frame; - } + struct ecl_stack_frame frame_aux; + if (frame->frame.stack == (void*)0x1) { + const cl_object new_frame = (cl_object)&frame_aux; + ECL_STACK_FRAME_COPY(new_frame, frame); + frame = new_frame; + } #endif - vector = fill_spec_vector(cache->keys, frame, gf); + vector = fill_spec_vector(cache->keys, frame, gf); + e = ecl_search_cache(cache); + if (e->key != OBJNULL) { + func = e->value; + } else { + /* The keys and the cache may change while we + * compute the applicable methods. We must save + * the keys and recompute the cache location if + * it was filled. */ + cl_object keys = cl_copy_seq(vector); + func = compute_applicable_method(env, frame, gf); + if (env->values[1] != ECL_NIL) { + if (e->key != OBJNULL) { e = ecl_search_cache(cache); - if (e->key != OBJNULL) { - func = e->value; - } else { - /* The keys and the cache may change while we - * compute the applicable methods. We must save - * the keys and recompute the cache location if - * it was filled. */ - cl_object keys = cl_copy_seq(vector); - func = compute_applicable_method(env, frame, gf); - if (env->values[1] != ECL_NIL) { - if (e->key != OBJNULL) { - e = ecl_search_cache(cache); - } - e->key = keys; - e->value = func; - } - } - if (func == ECL_NIL) - func = cl_apply(3, @'no-applicable-method', gf, frame); - else - func = _ecl_funcall3(func, frame, ECL_NIL); + } + e->key = keys; + e->value = func; + } + } + if (func == ECL_NIL) + func = cl_apply(3, @'no-applicable-method', gf, frame); + else + func = _ecl_funcall3(func, frame, ECL_NIL); - /* Only need to close the copy */ + /* Only need to close the copy */ #if !defined(ECL_USE_VARARG_AS_POINTER) - if (frame == (cl_object)&frame_aux) - ecl_stack_frame_close(frame); + if (frame == (cl_object)&frame_aux) + ecl_stack_frame_close(frame); #endif - return func; + return func; } static cl_object generic_function_dispatch_vararg(cl_narg narg, ...) { - cl_object output; - ECL_STACK_FRAME_VARARGS_BEGIN(narg, narg, frame) { - output = _ecl_standard_dispatch(frame, frame->frame.env->function); - } ECL_STACK_FRAME_VARARGS_END(frame); - return output; + cl_object output; + ECL_STACK_FRAME_VARARGS_BEGIN(narg, narg, frame) { + output = _ecl_standard_dispatch(frame, frame->frame.env->function); + } ECL_STACK_FRAME_VARARGS_END(frame); + return output; } cl_object si_clear_gfun_hash(cl_object what) { - /* - * This function clears the generic function call hashes selectively. - * what = ECL_T means clear the hash completely - * what = generic function, means cleans only these entries - * If we work on a multithreaded environment, we simply enqueue these - * operations and wait for the destination thread to update its own hash. - */ - cl_env_ptr the_env = ecl_process_env(); + /* + * This function clears the generic function call hashes selectively. + * what = ECL_T means clear the hash completely + * what = generic function, means cleans only these entries + * If we work on a multithreaded environment, we simply enqueue these + * operations and wait for the destination thread to update its own hash. + */ + cl_env_ptr the_env = ecl_process_env(); #ifdef ECL_THREADS - cl_object list; - for (list = mp_all_processes(); !Null(list); list = ECL_CONS_CDR(list)) { - cl_object process = ECL_CONS_CAR(list); - struct cl_env_struct *env = process->process.env; - if (the_env != env) { - ecl_cache_remove_one(env->method_cache, what); - ecl_cache_remove_one(env->slot_cache, what); - } - } + cl_object list; + for (list = mp_all_processes(); !Null(list); list = ECL_CONS_CDR(list)) { + cl_object process = ECL_CONS_CAR(list); + struct cl_env_struct *env = process->process.env; + if (the_env != env) { + ecl_cache_remove_one(env->method_cache, what); + ecl_cache_remove_one(env->slot_cache, what); + } + } #endif - ecl_cache_remove_one(the_env->method_cache, what); - ecl_cache_remove_one(the_env->slot_cache, what); - ecl_return0(the_env); + ecl_cache_remove_one(the_env->method_cache, what); + ecl_cache_remove_one(the_env->slot_cache, what); + ecl_return0(the_env); } diff -Nru ecl-16.1.2/src/c/hash.d ecl-16.1.3+ds/src/c/hash.d --- ecl-16.1.2/src/c/hash.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/hash.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - hash.d -- Hash tables. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * hash.d - hash tables + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ /* for ECL_MATHERR_* */ #define ECL_INCLUDE_MATH_H @@ -32,235 +27,235 @@ static void ECL_INLINE assert_type_hash_table(cl_object function, cl_narg narg, cl_object p) { - unlikely_if (!ECL_HASH_TABLE_P(p)) - FEwrong_type_nth_arg(function, narg, p, @[hash-table]); + unlikely_if (!ECL_HASH_TABLE_P(p)) + FEwrong_type_nth_arg(function, narg, p, @[hash-table]); } static cl_hashkey _hash_eql(cl_hashkey h, cl_object x) { - switch (ecl_t_of(x)) { - case t_bignum: - return hash_string(h, (unsigned char*)ECL_BIGNUM_LIMBS(x), - labs(ECL_BIGNUM_SIZE(x)) * - sizeof(mp_limb_t)); - case t_ratio: - h = _hash_eql(h, x->ratio.num); - return _hash_eql(h, x->ratio.den); - case t_singlefloat: - return hash_string(h, (unsigned char*)&ecl_single_float(x), sizeof(ecl_single_float(x))); - case t_doublefloat: - return hash_string(h, (unsigned char*)&ecl_double_float(x), sizeof(ecl_double_float(x))); + switch (ecl_t_of(x)) { + case t_bignum: + return hash_string(h, (unsigned char*)ECL_BIGNUM_LIMBS(x), + labs(ECL_BIGNUM_SIZE(x)) * + sizeof(mp_limb_t)); + case t_ratio: + h = _hash_eql(h, x->ratio.num); + return _hash_eql(h, x->ratio.den); + case t_singlefloat: + return hash_string(h, (unsigned char*)&ecl_single_float(x), sizeof(ecl_single_float(x))); + case t_doublefloat: + return hash_string(h, (unsigned char*)&ecl_double_float(x), sizeof(ecl_double_float(x))); #ifdef ECL_LONG_FLOAT - case t_longfloat: { - /* We coerce to double because long double has extra bits - * that give rise to different hash key and are not - * meaningful */ - struct { double mantissa; int exponent; int sign; } aux; - aux.mantissa = frexpl(ecl_long_float(x), &aux.exponent); - aux.sign = (ecl_long_float(x) < 0)? -1: 1; - return hash_string(h, (unsigned char*)&aux, sizeof(aux)); - } + case t_longfloat: { + /* We coerce to double because long double has extra bits + * that give rise to different hash key and are not + * meaningful */ + struct { double mantissa; int exponent; int sign; } aux; + aux.mantissa = frexpl(ecl_long_float(x), &aux.exponent); + aux.sign = (ecl_long_float(x) < 0)? -1: 1; + return hash_string(h, (unsigned char*)&aux, sizeof(aux)); + } #endif - case t_complex: - h = _hash_eql(h, x->complex.real); - return _hash_eql(h, x->complex.imag); - case t_character: - return hash_word(h, ECL_CHAR_CODE(x)); + case t_complex: + h = _hash_eql(h, x->complex.real); + return _hash_eql(h, x->complex.imag); + case t_character: + return hash_word(h, ECL_CHAR_CODE(x)); #ifdef ECL_SSE2 - case t_sse_pack: - return hash_string(h, x->sse.data.b8, 16); + case t_sse_pack: + return hash_string(h, x->sse.data.b8, 16); #endif - default: - return hash_word(h, ((cl_hashkey)x >> 2)); - } + default: + return hash_word(h, ((cl_hashkey)x >> 2)); + } } static cl_hashkey _hash_equal(int depth, cl_hashkey h, cl_object x) { - switch (ecl_t_of(x)) { - case t_list: - if (Null(x)) { - return _hash_equal(depth, h, ECL_NIL_SYMBOL->symbol.name); - } - if (--depth == 0) { - return h; - } else { - h = _hash_equal(depth, h, ECL_CONS_CAR(x)); - return _hash_equal(depth, h, ECL_CONS_CDR(x)); - } - case t_symbol: - x = x->symbol.name; + switch (ecl_t_of(x)) { + case t_list: + if (Null(x)) { + return _hash_equal(depth, h, ECL_NIL_SYMBOL->symbol.name); + } + if (--depth == 0) { + return h; + } else { + h = _hash_equal(depth, h, ECL_CONS_CAR(x)); + return _hash_equal(depth, h, ECL_CONS_CDR(x)); + } + case t_symbol: + x = x->symbol.name; #ifdef ECL_UNICODE - case t_base_string: - return hash_base_string((ecl_base_char *)x->base_string.self, - x->base_string.fillp, h); - case t_string: - return hash_full_string(x->string.self, x->string.fillp, h); + case t_base_string: + return hash_base_string((ecl_base_char *)x->base_string.self, + x->base_string.fillp, h); + case t_string: + return hash_full_string(x->string.self, x->string.fillp, h); #else - case t_base_string: - return hash_string(h, (ecl_base_char *)x->base_string.self, - x->base_string.fillp); + case t_base_string: + return hash_string(h, (ecl_base_char *)x->base_string.self, + x->base_string.fillp); #endif - case t_pathname: - h = _hash_equal(0, h, x->pathname.directory); - h = _hash_equal(0, h, x->pathname.name); - h = _hash_equal(0, h, x->pathname.type); - h = _hash_equal(0, h, x->pathname.host); - h = _hash_equal(0, h, x->pathname.device); - return _hash_equal(0, h, x->pathname.version); - case t_bitvector: - /* Notice that we may round out some bits. We must do this - * because the fill pointer may be set in the middle of a byte. - * If so, the extra bits _must_ _not_ take part in the hash, - * because otherwise two bit arrays which are EQUAL might - * have different hash keys. */ - return hash_string(h, x->vector.self.bc, x->vector.fillp / 8); - case t_random: { - cl_object array = x->random.value; - return hash_string - (h, (unsigned char*)array->vector.self.b8, 4*624); - } + case t_pathname: + h = _hash_equal(0, h, x->pathname.directory); + h = _hash_equal(0, h, x->pathname.name); + h = _hash_equal(0, h, x->pathname.type); + h = _hash_equal(0, h, x->pathname.host); + h = _hash_equal(0, h, x->pathname.device); + return _hash_equal(0, h, x->pathname.version); + case t_bitvector: + /* Notice that we may round out some bits. We must do this + * because the fill pointer may be set in the middle of a byte. + * If so, the extra bits _must_ _not_ take part in the hash, + * because otherwise two bit arrays which are EQUAL might + * have different hash keys. */ + return hash_string(h, x->vector.self.bc, x->vector.fillp / 8); + case t_random: { + cl_object array = x->random.value; + return hash_string + (h, (unsigned char*)array->vector.self.b8, 4*624); + } #ifdef ECL_SIGNED_ZERO - case t_singlefloat: { - float f = ecl_single_float(x); - if (f == 0.0) f = 0.0; - return hash_string(h, (unsigned char*)&f, sizeof(f)); - } - case t_doublefloat: { - double f = ecl_double_float(x); - if (f == 0.0) f = 0.0; - return hash_string(h, (unsigned char*)&f, sizeof(f)); - } + case t_singlefloat: { + float f = ecl_single_float(x); + if (f == 0.0) f = 0.0; + return hash_string(h, (unsigned char*)&f, sizeof(f)); + } + case t_doublefloat: { + double f = ecl_double_float(x); + if (f == 0.0) f = 0.0; + return hash_string(h, (unsigned char*)&f, sizeof(f)); + } # ifdef ECL_LONG_FLOAT - case t_longfloat: { - /* We coerce to double because long double has extra bits - * that give rise to different hash key and are not - * meaningful */ - struct { double mantissa; int exponent; int sign; } aux; - aux.mantissa = frexpl(ecl_long_float(x), &aux.exponent); - aux.sign = (ecl_long_float(x) < 0)? -1: 1; - if (aux.mantissa == 0.0) aux.mantissa = 0.0; - return hash_string(h, (unsigned char*)&aux, sizeof(aux)); - } + case t_longfloat: { + /* We coerce to double because long double has extra bits + * that give rise to different hash key and are not + * meaningful */ + struct { double mantissa; int exponent; int sign; } aux; + aux.mantissa = frexpl(ecl_long_float(x), &aux.exponent); + aux.sign = (ecl_long_float(x) < 0)? -1: 1; + if (aux.mantissa == 0.0) aux.mantissa = 0.0; + return hash_string(h, (unsigned char*)&aux, sizeof(aux)); + } # endif - case t_complex: { - h = _hash_equal(depth, h, x->complex.real); - return _hash_equal(depth, h, x->complex.imag); - } + case t_complex: { + h = _hash_equal(depth, h, x->complex.real); + return _hash_equal(depth, h, x->complex.imag); + } #endif - default: - return _hash_eql(h, x); - } + default: + return _hash_eql(h, x); + } } static cl_hashkey _hash_equalp(int depth, cl_hashkey h, cl_object x) { - cl_index i, len; - switch (ecl_t_of(x)) { - case t_character: - return hash_word(h, ecl_char_upcase(ECL_CHAR_CODE(x))); - case t_list: - if (Null(x)) { - return _hash_equalp(depth, h, ECL_NIL_SYMBOL->symbol.name); - } - if (--depth == 0) { - return h; - } else { - h = _hash_equalp(depth, h, ECL_CONS_CAR(x)); - return _hash_equalp(depth, h, ECL_CONS_CDR(x)); - } + cl_index i, len; + switch (ecl_t_of(x)) { + case t_character: + return hash_word(h, ecl_char_upcase(ECL_CHAR_CODE(x))); + case t_list: + if (Null(x)) { + return _hash_equalp(depth, h, ECL_NIL_SYMBOL->symbol.name); + } + if (--depth == 0) { + return h; + } else { + h = _hash_equalp(depth, h, ECL_CONS_CAR(x)); + return _hash_equalp(depth, h, ECL_CONS_CDR(x)); + } #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - case t_vector: - case t_bitvector: - len = x->vector.fillp; - goto SCAN; - case t_array: - len = x->vector.dim; - SCAN: if (--depth) { - for (i = 0; i < len; i++) { - h = _hash_equalp(depth, h, ecl_aref_unsafe(x, i)); - } - } - return h; - case t_fixnum: - return hash_word(h, ecl_fixnum(x)); - case t_singlefloat: - /* FIXME! We should be more precise here! */ - return hash_word(h, (cl_index)ecl_single_float(x)); - case t_doublefloat: - /* FIXME! We should be more precise here! */ - return hash_word(h, (cl_index)ecl_double_float(x)); - case t_bignum: - /* FIXME! We should be more precise here! */ - return hash_string(h, (unsigned char*)x->big.big_num->_mp_d, - abs(x->big.big_num->_mp_size) * - sizeof(mp_limb_t)); - case t_ratio: - h = _hash_equalp(0, h, x->ratio.num); - return _hash_equalp(0, h, x->ratio.den); - case t_complex: - h = _hash_equalp(0, h, x->complex.real); - return _hash_equalp(0, h, x->complex.imag); - case t_instance: - case t_hashtable: - /* FIXME! We should be more precise here! */ - return hash_word(h, 42); - default: - return _hash_equal(depth, h, x); - } -} - -#define HASH_TABLE_LOOP(hkey,hvalue,h,HASH_TABLE_LOOP_TEST) { \ - cl_index hsize = hashtable->hash.size; \ - cl_index i = h % hsize, j = hsize, k; \ - for (k = 0; k < hsize; i = (i + 1) % hsize, k++) { \ - struct ecl_hashtable_entry *e = hashtable->hash.data + i; \ - cl_object hkey = e->key, hvalue = e->value; \ - if (hkey == OBJNULL) { \ - if (e->value == OBJNULL) { \ - if (j == hsize) \ - return e; \ - else \ - return hashtable->hash.data + j; \ - } else { \ - if (j == hsize) \ - j = i; \ - else if (j == i) \ - return e; \ - } \ - continue; \ - } \ - if (HASH_TABLE_LOOP_TEST) return hashtable->hash.data + i; \ - } \ - return hashtable->hash.data + j; \ -} + case t_base_string: + case t_vector: + case t_bitvector: + len = x->vector.fillp; + goto SCAN; + case t_array: + len = x->vector.dim; + SCAN: if (--depth) { + for (i = 0; i < len; i++) { + h = _hash_equalp(depth, h, ecl_aref_unsafe(x, i)); + } + } + return h; + case t_fixnum: + return hash_word(h, ecl_fixnum(x)); + case t_singlefloat: + /* FIXME! We should be more precise here! */ + return hash_word(h, (cl_index)ecl_single_float(x)); + case t_doublefloat: + /* FIXME! We should be more precise here! */ + return hash_word(h, (cl_index)ecl_double_float(x)); + case t_bignum: + /* FIXME! We should be more precise here! */ + return hash_string(h, (unsigned char*)x->big.big_num->_mp_d, + abs(x->big.big_num->_mp_size) * + sizeof(mp_limb_t)); + case t_ratio: + h = _hash_equalp(0, h, x->ratio.num); + return _hash_equalp(0, h, x->ratio.den); + case t_complex: + h = _hash_equalp(0, h, x->complex.real); + return _hash_equalp(0, h, x->complex.imag); + case t_instance: + case t_hashtable: + /* FIXME! We should be more precise here! */ + return hash_word(h, 42); + default: + return _hash_equal(depth, h, x); + } +} + +#define HASH_TABLE_LOOP(hkey,hvalue,h,HASH_TABLE_LOOP_TEST) { \ + cl_index hsize = hashtable->hash.size; \ + cl_index i = h % hsize, j = hsize, k; \ + for (k = 0; k < hsize; i = (i + 1) % hsize, k++) { \ + struct ecl_hashtable_entry *e = hashtable->hash.data + i; \ + cl_object hkey = e->key, hvalue = e->value; \ + if (hkey == OBJNULL) { \ + if (e->value == OBJNULL) { \ + if (j == hsize) \ + return e; \ + else \ + return hashtable->hash.data + j; \ + } else { \ + if (j == hsize) \ + j = i; \ + else if (j == i) \ + return e; \ + } \ + continue; \ + } \ + if (HASH_TABLE_LOOP_TEST) return hashtable->hash.data + i; \ + } \ + return hashtable->hash.data + j; \ + } #if 0 #define HASH_TABLE_SET(h,loop,compute_key,store_key) #else #define HASH_TABLE_SET(h,loop,compute_key,store_key) { \ - cl_hashkey h = compute_key; \ - struct ecl_hashtable_entry *e; \ - AGAIN: \ - e = loop(h, key, hashtable); \ - if (e->key == OBJNULL) { \ - cl_index i = hashtable->hash.entries + 1; \ - if (i >= hashtable->hash.limit) { \ - hashtable = ecl_extend_hashtable(hashtable); \ - goto AGAIN; \ - } \ - hashtable->hash.entries = i; \ - e->key = store_key; \ - } \ - e->value = value; \ - return hashtable; \ - } + cl_hashkey h = compute_key; \ + struct ecl_hashtable_entry *e; \ +AGAIN: \ + e = loop(h, key, hashtable); \ + if (e->key == OBJNULL) { \ + cl_index i = hashtable->hash.entries + 1; \ + if (i >= hashtable->hash.limit) { \ + hashtable = ecl_extend_hashtable(hashtable); \ + goto AGAIN; \ + } \ + hashtable->hash.entries = i; \ + e->key = store_key; \ + } \ + e->value = value; \ + return hashtable; \ + } #endif /* @@ -276,36 +271,36 @@ static struct ecl_hashtable_entry * _ecl_hash_loop_eq(cl_hashkey h, cl_object key, cl_object hashtable) { - HASH_TABLE_LOOP(hkey, hvalue, h, key == hkey); + HASH_TABLE_LOOP(hkey, hvalue, h, key == hkey); } static cl_object _ecl_gethash_eq(cl_object key, cl_object hashtable, cl_object def) { - cl_hashkey h = _hash_eq(key); - struct ecl_hashtable_entry *e = _ecl_hash_loop_eq(h, key, hashtable); - return (e->key == OBJNULL)? def : e->value; + cl_hashkey h = _hash_eq(key); + struct ecl_hashtable_entry *e = _ecl_hash_loop_eq(h, key, hashtable); + return (e->key == OBJNULL)? def : e->value; } static bool _ecl_remhash_eq(cl_object key, cl_object hashtable) { - cl_hashkey h = _hash_eq(key); - struct ecl_hashtable_entry *e = _ecl_hash_loop_eq(h, key, hashtable); - if (e->key == OBJNULL) { - return 0; - } else { - e->key = OBJNULL; - e->value = ECL_NIL; - hashtable->hash.entries--; - return 1; - } + cl_hashkey h = _hash_eq(key); + struct ecl_hashtable_entry *e = _ecl_hash_loop_eq(h, key, hashtable); + if (e->key == OBJNULL) { + return 0; + } else { + e->key = OBJNULL; + e->value = ECL_NIL; + hashtable->hash.entries--; + return 1; + } } static cl_object _ecl_sethash_eq(cl_object key, cl_object hashtable, cl_object value) { - HASH_TABLE_SET(h, _ecl_hash_loop_eq, _hash_eq(key), key); + HASH_TABLE_SET(h, _ecl_hash_loop_eq, _hash_eq(key), key); } /* @@ -315,36 +310,36 @@ static struct ecl_hashtable_entry * _ecl_hash_loop_eql(cl_hashkey h, cl_object key, cl_object hashtable) { - HASH_TABLE_LOOP(hkey, hvalue, h, ecl_eql(key, hkey)); + HASH_TABLE_LOOP(hkey, hvalue, h, ecl_eql(key, hkey)); } static cl_object _ecl_gethash_eql(cl_object key, cl_object hashtable, cl_object def) { - cl_hashkey h = _hash_eql(0, key); - struct ecl_hashtable_entry *e = _ecl_hash_loop_eql(h, key, hashtable); - return (e->key == OBJNULL)? def : e->value; + cl_hashkey h = _hash_eql(0, key); + struct ecl_hashtable_entry *e = _ecl_hash_loop_eql(h, key, hashtable); + return (e->key == OBJNULL)? def : e->value; } static cl_object _ecl_sethash_eql(cl_object key, cl_object hashtable, cl_object value) { - HASH_TABLE_SET(h, _ecl_hash_loop_eql, _hash_eql(0, key), key); + HASH_TABLE_SET(h, _ecl_hash_loop_eql, _hash_eql(0, key), key); } static bool _ecl_remhash_eql(cl_object key, cl_object hashtable) { - cl_hashkey h = _hash_eql(0, key); - struct ecl_hashtable_entry *e = _ecl_hash_loop_eql(h, key, hashtable); - if (e->key == OBJNULL) { - return 0; - } else { - e->key = OBJNULL; - e->value = ECL_NIL; - hashtable->hash.entries--; - return 1; - } + cl_hashkey h = _hash_eql(0, key); + struct ecl_hashtable_entry *e = _ecl_hash_loop_eql(h, key, hashtable); + if (e->key == OBJNULL) { + return 0; + } else { + e->key = OBJNULL; + e->value = ECL_NIL; + hashtable->hash.entries--; + return 1; + } } /* @@ -354,36 +349,36 @@ static struct ecl_hashtable_entry * _ecl_hash_loop_equal(cl_hashkey h, cl_object key, cl_object hashtable) { - HASH_TABLE_LOOP(hkey, hvalue, h, ecl_equal(key, hkey)); + HASH_TABLE_LOOP(hkey, hvalue, h, ecl_equal(key, hkey)); } static cl_object _ecl_gethash_equal(cl_object key, cl_object hashtable, cl_object def) { - cl_hashkey h = _hash_equal(3, 0, key); - struct ecl_hashtable_entry *e = _ecl_hash_loop_equal(h, key, hashtable); - return (e->key == OBJNULL)? def : e->value; + cl_hashkey h = _hash_equal(3, 0, key); + struct ecl_hashtable_entry *e = _ecl_hash_loop_equal(h, key, hashtable); + return (e->key == OBJNULL)? def : e->value; } static cl_object _ecl_sethash_equal(cl_object key, cl_object hashtable, cl_object value) { - HASH_TABLE_SET(h, _ecl_hash_loop_equal, _hash_equal(3, 0, key), key); + HASH_TABLE_SET(h, _ecl_hash_loop_equal, _hash_equal(3, 0, key), key); } static bool _ecl_remhash_equal(cl_object key, cl_object hashtable) { - cl_hashkey h = _hash_equal(3, 0, key); - struct ecl_hashtable_entry *e = _ecl_hash_loop_equal(h, key, hashtable); - if (e->key == OBJNULL) { - return 0; - } else { - e->key = OBJNULL; - e->value = ECL_NIL; - hashtable->hash.entries--; - return 1; - } + cl_hashkey h = _hash_equal(3, 0, key); + struct ecl_hashtable_entry *e = _ecl_hash_loop_equal(h, key, hashtable); + if (e->key == OBJNULL) { + return 0; + } else { + e->key = OBJNULL; + e->value = ECL_NIL; + hashtable->hash.entries--; + return 1; + } } /* @@ -393,36 +388,36 @@ static struct ecl_hashtable_entry * _ecl_hash_loop_equalp(cl_hashkey h, cl_object key, cl_object hashtable) { - HASH_TABLE_LOOP(hkey, hvalue, h, ecl_equalp(key, hkey)); + HASH_TABLE_LOOP(hkey, hvalue, h, ecl_equalp(key, hkey)); } static cl_object _ecl_gethash_equalp(cl_object key, cl_object hashtable, cl_object def) { - cl_hashkey h = _hash_equalp(3, 0, key); - struct ecl_hashtable_entry *e = _ecl_hash_loop_equalp(h, key, hashtable); - return (e->key == OBJNULL)? def : e->value; + cl_hashkey h = _hash_equalp(3, 0, key); + struct ecl_hashtable_entry *e = _ecl_hash_loop_equalp(h, key, hashtable); + return (e->key == OBJNULL)? def : e->value; } static cl_object _ecl_sethash_equalp(cl_object key, cl_object hashtable, cl_object value) { - HASH_TABLE_SET(h, _ecl_hash_loop_equalp, _hash_equalp(3, 0, key), key); + HASH_TABLE_SET(h, _ecl_hash_loop_equalp, _hash_equalp(3, 0, key), key); } static bool _ecl_remhash_equalp(cl_object key, cl_object hashtable) { - cl_hashkey h = _hash_equalp(3, 0, key); - struct ecl_hashtable_entry *e = _ecl_hash_loop_equalp(h, key, hashtable); - if (e->key == OBJNULL) { - return 0; - } else { - e->key = OBJNULL; - e->value = ECL_NIL; - hashtable->hash.entries--; - return 1; - } + cl_hashkey h = _hash_equalp(3, 0, key); + struct ecl_hashtable_entry *e = _ecl_hash_loop_equalp(h, key, hashtable); + if (e->key == OBJNULL) { + return 0; + } else { + e->key = OBJNULL; + e->value = ECL_NIL; + hashtable->hash.entries--; + return 1; + } } /* @@ -432,37 +427,37 @@ static struct ecl_hashtable_entry * _ecl_hash_loop_pack(cl_hashkey h, cl_object key, cl_object hashtable) { - cl_object ho = ecl_make_fixnum(h & 0xFFFFFFF); - HASH_TABLE_LOOP(hkey, hvalue, h, (ho==hkey) && ecl_string_eq(key,SYMBOL_NAME(hvalue))); + cl_object ho = ecl_make_fixnum(h & 0xFFFFFFF); + HASH_TABLE_LOOP(hkey, hvalue, h, (ho==hkey) && ecl_string_eq(key,SYMBOL_NAME(hvalue))); } static cl_object _ecl_gethash_pack(cl_object key, cl_object hashtable, cl_object def) { - cl_hashkey h = _hash_equal(3, 0, key); - struct ecl_hashtable_entry *e = _ecl_hash_loop_pack(h, key, hashtable); - return (e->key == OBJNULL)? def : e->value; + cl_hashkey h = _hash_equal(3, 0, key); + struct ecl_hashtable_entry *e = _ecl_hash_loop_pack(h, key, hashtable); + return (e->key == OBJNULL)? def : e->value; } static cl_object _ecl_sethash_pack(cl_object key, cl_object hashtable, cl_object value) { - HASH_TABLE_SET(h, _ecl_hash_loop_pack, _hash_equal(3, 0, key), ecl_make_fixnum(h & 0xFFFFFFF)); + HASH_TABLE_SET(h, _ecl_hash_loop_pack, _hash_equal(3, 0, key), ecl_make_fixnum(h & 0xFFFFFFF)); } static bool _ecl_remhash_pack(cl_object key, cl_object hashtable) { - cl_hashkey h = _hash_equal(3, 0, key); - struct ecl_hashtable_entry *e = _ecl_hash_loop_pack(h, key, hashtable); - if (e->key == OBJNULL) { - return 0; - } else { - e->key = OBJNULL; - e->value = ECL_NIL; - hashtable->hash.entries--; - return 1; - } + cl_hashkey h = _hash_equal(3, 0, key); + struct ecl_hashtable_entry *e = _ecl_hash_loop_pack(h, key, hashtable); + if (e->key == OBJNULL) { + return 0; + } else { + e->key = OBJNULL; + e->value = ECL_NIL; + hashtable->hash.entries--; + return 1; + } } /* @@ -475,172 +470,172 @@ #ifdef ECL_WEAK_HASH static cl_hashkey _ecl_hash_key(cl_object h, cl_object o) { - switch (h->hash.test) { - case ecl_htt_eq: return _hash_eq(o); - case ecl_htt_eql: return _hash_eql(0, o); - case ecl_htt_equal: return _hash_equal(3, 0, o); - case ecl_htt_equalp: - default: return _hash_equalp(3, 0, o); - } + switch (h->hash.test) { + case ecl_htt_eq: return _hash_eq(o); + case ecl_htt_eql: return _hash_eql(0, o); + case ecl_htt_equal: return _hash_equal(3, 0, o); + case ecl_htt_equalp: + default: return _hash_equalp(3, 0, o); + } } static void * normalize_weak_key_entry(struct ecl_hashtable_entry *e) { - return (void*)(e->key = e->key->weak.value); + return (void*)(e->key = e->key->weak.value); } static void * normalize_weak_value_entry(struct ecl_hashtable_entry *e) { - return (void*)(e->value = e->value->weak.value); + return (void*)(e->value = e->value->weak.value); } static void * normalize_weak_key_and_value_entry(struct ecl_hashtable_entry *e) { - if ((e->key = e->key->weak.value) && (e->value = e->value->weak.value)) - return (void*)e; - else - return 0; + if ((e->key = e->key->weak.value) && (e->value = e->value->weak.value)) + return (void*)e; + else + return 0; } static struct ecl_hashtable_entry copy_entry(struct ecl_hashtable_entry *e, cl_object h) { - if (e->key == OBJNULL) { - return *e; - } else { - struct ecl_hashtable_entry output = *e; - switch (h->hash.weak) { - case ecl_htt_weak_key: - if (GC_call_with_alloc_lock(normalize_weak_key_entry, - &output)) { - return output; - } - break; - case ecl_htt_weak_value: - if (GC_call_with_alloc_lock(normalize_weak_value_entry, - &output)) { - return output; - } - break; - case ecl_htt_weak_key_and_value: - if (GC_call_with_alloc_lock(normalize_weak_key_and_value_entry, - &output)) { - return output; - } - break; - case ecl_htt_not_weak: - default: - return output; - } - h->hash.entries--; - output.key = OBJNULL; - output.value = ECL_NIL; - return *e = output; - } + if (e->key == OBJNULL) { + return *e; + } else { + struct ecl_hashtable_entry output = *e; + switch (h->hash.weak) { + case ecl_htt_weak_key: + if (GC_call_with_alloc_lock((GC_fn_type)normalize_weak_key_entry, + &output)) { + return output; + } + break; + case ecl_htt_weak_value: + if (GC_call_with_alloc_lock((GC_fn_type)normalize_weak_value_entry, + &output)) { + return output; + } + break; + case ecl_htt_weak_key_and_value: + if (GC_call_with_alloc_lock((GC_fn_type)normalize_weak_key_and_value_entry, + &output)) { + return output; + } + break; + case ecl_htt_not_weak: + default: + return output; + } + h->hash.entries--; + output.key = OBJNULL; + output.value = ECL_NIL; + return *e = output; + } } static struct ecl_hashtable_entry * _ecl_weak_hash_loop(cl_hashkey h, cl_object key, cl_object hashtable, struct ecl_hashtable_entry *aux) { - cl_index hsize = hashtable->hash.size; - cl_index i = h % hsize, j = hsize, k; - for (k = 0; k < hsize; i = (i + 1) % hsize, k++) { - struct ecl_hashtable_entry *p = hashtable->hash.data + i; - struct ecl_hashtable_entry e = *aux = copy_entry(p, hashtable); - if (e.key == OBJNULL) { - if (e.value == OBJNULL) { - if (j == hsize) { - return p; - } else { - return hashtable->hash.data + j; - } - } else { - if (j == hsize) { - j = i; - } else if (j == i) { - return p; - } - } - continue; - } - switch (hashtable->hash.test) { - case ecl_htt_eq: - if (e.key == key) return p; - case ecl_htt_eql: - if (ecl_eql(e.key, key)) return p; - case ecl_htt_equal: - if (ecl_equal(e.key, key)) return p; - case ecl_htt_equalp: - if (ecl_equalp(e.key, key)) return p; - } + cl_index hsize = hashtable->hash.size; + cl_index i = h % hsize, j = hsize, k; + for (k = 0; k < hsize; i = (i + 1) % hsize, k++) { + struct ecl_hashtable_entry *p = hashtable->hash.data + i; + struct ecl_hashtable_entry e = *aux = copy_entry(p, hashtable); + if (e.key == OBJNULL) { + if (e.value == OBJNULL) { + if (j == hsize) { + return p; + } else { + return hashtable->hash.data + j; } - return hashtable->hash.data + j; + } else { + if (j == hsize) { + j = i; + } else if (j == i) { + return p; + } + } + continue; + } + switch (hashtable->hash.test) { + case ecl_htt_eq: + if (e.key == key) return p; + case ecl_htt_eql: + if (ecl_eql(e.key, key)) return p; + case ecl_htt_equal: + if (ecl_equal(e.key, key)) return p; + case ecl_htt_equalp: + if (ecl_equalp(e.key, key)) return p; + } + } + return hashtable->hash.data + j; } static cl_object _ecl_gethash_weak(cl_object key, cl_object hashtable, cl_object def) { - cl_hashkey h = _ecl_hash_key(hashtable, key); - struct ecl_hashtable_entry aux[1]; - _ecl_weak_hash_loop(h, key, hashtable, aux); - if (aux->key != OBJNULL) { - return aux->value; - } else { - return def; - } + cl_hashkey h = _ecl_hash_key(hashtable, key); + struct ecl_hashtable_entry aux[1]; + _ecl_weak_hash_loop(h, key, hashtable, aux); + if (aux->key != OBJNULL) { + return aux->value; + } else { + return def; + } } static cl_object _ecl_sethash_weak(cl_object key, cl_object hashtable, cl_object value) { - cl_hashkey h = _ecl_hash_key(hashtable, key); - struct ecl_hashtable_entry aux[1]; - struct ecl_hashtable_entry *e; + cl_hashkey h = _ecl_hash_key(hashtable, key); + struct ecl_hashtable_entry aux[1]; + struct ecl_hashtable_entry *e; AGAIN: - e = _ecl_weak_hash_loop(h, key, hashtable, aux); - if (aux->key == OBJNULL) { - cl_index i = hashtable->hash.entries + 1; - if (i >= hashtable->hash.limit) { - hashtable = ecl_extend_hashtable(hashtable); - goto AGAIN; - } - hashtable->hash.entries = i; - switch (hashtable->hash.weak) { - case ecl_htt_weak_key: - key = si_make_weak_pointer(key); - break; - case ecl_htt_weak_value: - value = si_make_weak_pointer(value); - break; - case ecl_htt_weak_key_and_value: - default: - key = si_make_weak_pointer(key); - value = si_make_weak_pointer(value); - break; - } - e->key = key; - } - e->value = value; - return hashtable; + e = _ecl_weak_hash_loop(h, key, hashtable, aux); + if (aux->key == OBJNULL) { + cl_index i = hashtable->hash.entries + 1; + if (i >= hashtable->hash.limit) { + hashtable = ecl_extend_hashtable(hashtable); + goto AGAIN; + } + hashtable->hash.entries = i; + switch (hashtable->hash.weak) { + case ecl_htt_weak_key: + key = si_make_weak_pointer(key); + break; + case ecl_htt_weak_value: + value = si_make_weak_pointer(value); + break; + case ecl_htt_weak_key_and_value: + default: + key = si_make_weak_pointer(key); + value = si_make_weak_pointer(value); + break; + } + e->key = key; + } + e->value = value; + return hashtable; } static bool _ecl_remhash_weak(cl_object key, cl_object hashtable) { - cl_hashkey h = _ecl_hash_key(hashtable, key); - struct ecl_hashtable_entry aux[1]; - struct ecl_hashtable_entry *e = - _ecl_weak_hash_loop(h, key, hashtable, aux); - if (aux->key != OBJNULL) { - hashtable->hash.entries--; - e->key = OBJNULL; - e->value = ECL_NIL; - return 1; - } else { - return 0; - } + cl_hashkey h = _ecl_hash_key(hashtable, key); + struct ecl_hashtable_entry aux[1]; + struct ecl_hashtable_entry *e = + _ecl_weak_hash_loop(h, key, hashtable, aux); + if (aux->key != OBJNULL) { + hashtable->hash.entries--; + e->key = OBJNULL; + e->value = ECL_NIL; + return 1; + } else { + return 0; + } } #endif @@ -652,134 +647,132 @@ cl_object ecl_gethash(cl_object key, cl_object hashtable) { - assert_type_hash_table(@[gethash], 2, hashtable); - return hashtable->hash.get(key, hashtable, OBJNULL); + assert_type_hash_table(@[gethash], 2, hashtable); + return hashtable->hash.get(key, hashtable, OBJNULL); } cl_object ecl_gethash_safe(cl_object key, cl_object hashtable, cl_object def) { - assert_type_hash_table(@[gethash], 2, hashtable); - return hashtable->hash.get(key, hashtable, def); + assert_type_hash_table(@[gethash], 2, hashtable); + return hashtable->hash.get(key, hashtable, def); } cl_object _ecl_sethash(cl_object key, cl_object hashtable, cl_object value) { - return hashtable->hash.set(key, hashtable, value); + return hashtable->hash.set(key, hashtable, value); } cl_object ecl_sethash(cl_object key, cl_object hashtable, cl_object value) { - assert_type_hash_table(@[si::hash-set], 2, hashtable); - hashtable = hashtable->hash.set(key, hashtable, value); - return hashtable; + assert_type_hash_table(@[si::hash-set], 2, hashtable); + hashtable = hashtable->hash.set(key, hashtable, value); + return hashtable; } cl_object ecl_extend_hashtable(cl_object hashtable) { - cl_object old, new; - cl_index old_size, new_size, i; - cl_object new_size_obj; - - assert_type_hash_table(@[si::hash-set], 2, hashtable); - old_size = hashtable->hash.size; - /* We do the computation with lisp datatypes, just in case the sizes contain - * weird numbers */ - if (ECL_FIXNUMP(hashtable->hash.rehash_size)) { - new_size_obj = ecl_plus(hashtable->hash.rehash_size, - ecl_make_fixnum(old_size)); - } else { - new_size_obj = ecl_times(hashtable->hash.rehash_size, - ecl_make_fixnum(old_size)); - new_size_obj = ecl_ceiling1(new_size_obj); - } - if (!ECL_FIXNUMP(new_size_obj)) { - /* New size is too large */ - new_size = old_size * 2; - } else { - new_size = ecl_fixnum(new_size_obj); - } - if (hashtable->hash.test == ecl_htt_pack) { - new = ecl_alloc_object(t_hashtable); - new->hash = hashtable->hash; - old = hashtable; - } else { - old = ecl_alloc_object(t_hashtable); - old->hash = hashtable->hash; - new = hashtable; - } - new->hash.data = NULL; /* for GC sake */ - new->hash.entries = 0; - new->hash.size = new_size; - new->hash.limit = new->hash.size * new->hash.factor; - new->hash.data = (struct ecl_hashtable_entry *) - ecl_alloc(new_size * sizeof(struct ecl_hashtable_entry)); - for (i = 0; i < new_size; i++) { - new->hash.data[i].key = OBJNULL; - new->hash.data[i].value = OBJNULL; - } - for (i = 0; i < old_size; i++) { - struct ecl_hashtable_entry e = - copy_entry(old->hash.data + i, old); - if (e.key != OBJNULL) { - new = new->hash.set(new->hash.test == ecl_htt_pack? - SYMBOL_NAME(e.value) : e.key, - new, e.value); - } - } - return new; + cl_object old, new; + cl_index old_size, new_size, i; + cl_object new_size_obj; + + assert_type_hash_table(@[si::hash-set], 2, hashtable); + old_size = hashtable->hash.size; + /* We do the computation with lisp datatypes, just in case the sizes contain + * weird numbers */ + if (ECL_FIXNUMP(hashtable->hash.rehash_size)) { + new_size_obj = ecl_plus(hashtable->hash.rehash_size, + ecl_make_fixnum(old_size)); + } else { + new_size_obj = ecl_times(hashtable->hash.rehash_size, + ecl_make_fixnum(old_size)); + new_size_obj = ecl_ceiling1(new_size_obj); + } + if (!ECL_FIXNUMP(new_size_obj)) { + /* New size is too large */ + new_size = old_size * 2; + } else { + new_size = ecl_fixnum(new_size_obj); + } + if (hashtable->hash.test == ecl_htt_pack) { + new = ecl_alloc_object(t_hashtable); + new->hash = hashtable->hash; + old = hashtable; + } else { + old = ecl_alloc_object(t_hashtable); + old->hash = hashtable->hash; + new = hashtable; + } + new->hash.data = NULL; /* for GC sake */ + new->hash.entries = 0; + new->hash.size = new_size; + new->hash.limit = new->hash.size * new->hash.factor; + new->hash.data = (struct ecl_hashtable_entry *) + ecl_alloc(new_size * sizeof(struct ecl_hashtable_entry)); + for (i = 0; i < new_size; i++) { + new->hash.data[i].key = OBJNULL; + new->hash.data[i].value = OBJNULL; + } + for (i = 0; i < old_size; i++) { + struct ecl_hashtable_entry e = + copy_entry(old->hash.data + i, old); + if (e.key != OBJNULL) { + new = new->hash.set(new->hash.test == ecl_htt_pack? + SYMBOL_NAME(e.value) : e.key, + new, e.value); + } + } + return new; } @(defun make_hash_table (&key (test @'eql') - (weakness ECL_NIL) - (size ecl_make_fixnum(1024)) - (rehash_size cl_core.rehash_size) - (rehash_threshold cl_core.rehash_threshold)) -@ -{ - cl_object hash = cl__make_hash_table(test, size, rehash_size, rehash_threshold); + (weakness ECL_NIL) + (size ecl_make_fixnum(1024)) + (rehash_size cl_core.rehash_size) + (rehash_threshold cl_core.rehash_threshold)) +@ { + cl_object hash = cl__make_hash_table(test, size, rehash_size, rehash_threshold); #ifdef ECL_WEAK_HASH - if (!Null(weakness)) { - if (weakness == @':key') { - hash->hash.weak = ecl_htt_weak_key; - } else if (weakness == @':value') { - hash->hash.weak = ecl_htt_weak_value; - } else if (weakness == @':key-and-value') { - hash->hash.weak = ecl_htt_weak_key_and_value; - } else { - FEwrong_type_key_arg(@[make-hash-table], - @[:weakness], - cl_list(5, @'member', - ECL_NIL, @':key', @':value', - @':key-and-value'), - weakness); - } - hash->hash.get = _ecl_gethash_weak; - hash->hash.set = _ecl_sethash_weak; - hash->hash.rem = _ecl_remhash_weak; - } + if (!Null(weakness)) { + if (weakness == @':key') { + hash->hash.weak = ecl_htt_weak_key; + } else if (weakness == @':value') { + hash->hash.weak = ecl_htt_weak_value; + } else if (weakness == @':key-and-value') { + hash->hash.weak = ecl_htt_weak_key_and_value; + } else { + FEwrong_type_key_arg(@[make-hash-table], + @[:weakness], + cl_list(5, @'member', + ECL_NIL, @':key', @':value', + @':key-and-value'), + weakness); + } + hash->hash.get = _ecl_gethash_weak; + hash->hash.set = _ecl_sethash_weak; + hash->hash.rem = _ecl_remhash_weak; + } #endif - @(return hash) -} -@) + @(return hash); +} @) static void do_clrhash(cl_object ht) { - /* - * Fill a hash with null pointers and ensure it does not have - * any entry. We separate this routine because it is needed - * both by clrhash and hash table initialization. - */ - cl_index i; - ht->hash.entries = 0; - for(i = 0; i < ht->hash.size; i++) { - ht->hash.data[i].key = OBJNULL; - ht->hash.data[i].value = OBJNULL; - } + /* + * Fill a hash with null pointers and ensure it does not have + * any entry. We separate this routine because it is needed + * both by clrhash and hash table initialization. + */ + cl_index i; + ht->hash.entries = 0; + for(i = 0; i < ht->hash.size; i++) { + ht->hash.data[i].key = OBJNULL; + ht->hash.data[i].value = OBJNULL; + } } ecl_def_ct_single_float(min_threshold, 0.1, static, const); @@ -788,364 +781,364 @@ cl__make_hash_table(cl_object test, cl_object size, cl_object rehash_size, cl_object rehash_threshold) { - int htt; - cl_index hsize; - cl_object h; - cl_object (*get)(cl_object, cl_object, cl_object); - cl_object (*set)(cl_object, cl_object, cl_object); - bool (*rem)(cl_object, cl_object); - /* - * Argument checking - */ - if (test == @'eq' || test == ECL_SYM_FUN(@'eq')) { - htt = ecl_htt_eq; - get = _ecl_gethash_eq; - set = _ecl_sethash_eq; - rem = _ecl_remhash_eq; - } else if (test == @'eql' || test == ECL_SYM_FUN(@'eql')) { - htt = ecl_htt_eql; - get = _ecl_gethash_eql; - set = _ecl_sethash_eql; - rem = _ecl_remhash_eql; - } else if (test == @'equal' || test == ECL_SYM_FUN(@'equal')) { - htt = ecl_htt_equal; - get = _ecl_gethash_equal; - set = _ecl_sethash_equal; - rem = _ecl_remhash_equal; - } else if (test == @'equalp' || test == ECL_SYM_FUN(@'equalp')) { - htt = ecl_htt_equalp; - get = _ecl_gethash_equalp; - set = _ecl_sethash_equalp; - rem = _ecl_remhash_equalp; - } else if (test == @'package') { - htt = ecl_htt_pack; - get = _ecl_gethash_pack; - set = _ecl_sethash_pack; - rem = _ecl_remhash_pack; - } else { - FEerror("~S is an illegal hash-table test function.", - 1, test); - } - if (ecl_unlikely(!ECL_FIXNUMP(size) || - ecl_fixnum_minusp(size) || - ecl_fixnum_geq(size,ecl_make_fixnum(ECL_ARRAY_TOTAL_LIMIT)))) { - FEwrong_type_key_arg(@[make-hash-table], @[:size], size, - ecl_make_integer_type(ecl_make_fixnum(0), - ecl_make_fixnum(ECL_ARRAY_TOTAL_LIMIT))); - } - hsize = ecl_fixnum(size); - if (hsize < 16) { - hsize = 16; - } + int htt; + cl_index hsize; + cl_object h; + cl_object (*get)(cl_object, cl_object, cl_object); + cl_object (*set)(cl_object, cl_object, cl_object); + bool (*rem)(cl_object, cl_object); + /* + * Argument checking + */ + if (test == @'eq' || test == ECL_SYM_FUN(@'eq')) { + htt = ecl_htt_eq; + get = _ecl_gethash_eq; + set = _ecl_sethash_eq; + rem = _ecl_remhash_eq; + } else if (test == @'eql' || test == ECL_SYM_FUN(@'eql')) { + htt = ecl_htt_eql; + get = _ecl_gethash_eql; + set = _ecl_sethash_eql; + rem = _ecl_remhash_eql; + } else if (test == @'equal' || test == ECL_SYM_FUN(@'equal')) { + htt = ecl_htt_equal; + get = _ecl_gethash_equal; + set = _ecl_sethash_equal; + rem = _ecl_remhash_equal; + } else if (test == @'equalp' || test == ECL_SYM_FUN(@'equalp')) { + htt = ecl_htt_equalp; + get = _ecl_gethash_equalp; + set = _ecl_sethash_equalp; + rem = _ecl_remhash_equalp; + } else if (test == @'package') { + htt = ecl_htt_pack; + get = _ecl_gethash_pack; + set = _ecl_sethash_pack; + rem = _ecl_remhash_pack; + } else { + FEerror("~S is an illegal hash-table test function.", + 1, test); + } + if (ecl_unlikely(!ECL_FIXNUMP(size) || + ecl_fixnum_minusp(size) || + ecl_fixnum_geq(size,ecl_make_fixnum(ECL_ARRAY_TOTAL_LIMIT)))) { + FEwrong_type_key_arg(@[make-hash-table], @[:size], size, + ecl_make_integer_type(ecl_make_fixnum(0), + ecl_make_fixnum(ECL_ARRAY_TOTAL_LIMIT))); + } + hsize = ecl_fixnum(size); + if (hsize < 16) { + hsize = 16; + } AGAIN: - if (ecl_minusp(rehash_size)) { - ERROR1: - rehash_size = - ecl_type_error(@'make-hash-table',"rehash-size", - rehash_size, - ecl_read_from_cstring("(OR (INTEGER 1 *) (FLOAT 0 (1)))")); - goto AGAIN; - } - if (floatp(rehash_size)) { - if (ecl_number_compare(rehash_size, ecl_make_fixnum(1)) < 0 || - ecl_minusp(rehash_size)) { - goto ERROR1; - } - rehash_size = ecl_make_double_float(ecl_to_double(rehash_size)); - } else if (!ECL_FIXNUMP(rehash_size)) { - goto ERROR1; - } - while (!ecl_numberp(rehash_threshold) || - ecl_minusp(rehash_threshold) || - ecl_number_compare(rehash_threshold, ecl_make_fixnum(1)) > 0) - { - rehash_threshold = - ecl_type_error(@'make-hash-table',"rehash-threshold", - rehash_threshold, - ecl_read_from_cstring("(REAL 0 1)")); - } - /* - * Build actual hash. - */ - h = ecl_alloc_object(t_hashtable); - h->hash.test = htt; - h->hash.weak = ecl_htt_not_weak; - h->hash.get = get; - h->hash.set = set; - h->hash.rem = rem; - h->hash.size = hsize; - h->hash.entries = 0; - h->hash.rehash_size = rehash_size; - h->hash.threshold = rehash_threshold; - rehash_threshold = cl_max(2, min_threshold, rehash_threshold); - h->hash.factor = ecl_to_double(rehash_threshold); - h->hash.limit = h->hash.size * h->hash.factor; - h->hash.data = NULL; /* for GC sake */ - h->hash.data = (struct ecl_hashtable_entry *) - ecl_alloc(hsize * sizeof(struct ecl_hashtable_entry)); - do_clrhash(h); - return h; + if (ecl_minusp(rehash_size)) { + ERROR1: + rehash_size = + ecl_type_error(@'make-hash-table',"rehash-size", + rehash_size, + ecl_read_from_cstring("(OR (INTEGER 1 *) (FLOAT 0 (1)))")); + goto AGAIN; + } + if (floatp(rehash_size)) { + if (ecl_number_compare(rehash_size, ecl_make_fixnum(1)) < 0 || + ecl_minusp(rehash_size)) { + goto ERROR1; + } + rehash_size = ecl_make_double_float(ecl_to_double(rehash_size)); + } else if (!ECL_FIXNUMP(rehash_size)) { + goto ERROR1; + } + while (!ecl_numberp(rehash_threshold) || + ecl_minusp(rehash_threshold) || + ecl_number_compare(rehash_threshold, ecl_make_fixnum(1)) > 0) + { + rehash_threshold = + ecl_type_error(@'make-hash-table',"rehash-threshold", + rehash_threshold, + ecl_read_from_cstring("(REAL 0 1)")); + } + /* + * Build actual hash. + */ + h = ecl_alloc_object(t_hashtable); + h->hash.test = htt; + h->hash.weak = ecl_htt_not_weak; + h->hash.get = get; + h->hash.set = set; + h->hash.rem = rem; + h->hash.size = hsize; + h->hash.entries = 0; + h->hash.rehash_size = rehash_size; + h->hash.threshold = rehash_threshold; + rehash_threshold = cl_max(2, min_threshold, rehash_threshold); + h->hash.factor = ecl_to_double(rehash_threshold); + h->hash.limit = h->hash.size * h->hash.factor; + h->hash.data = NULL; /* for GC sake */ + h->hash.data = (struct ecl_hashtable_entry *) + ecl_alloc(hsize * sizeof(struct ecl_hashtable_entry)); + do_clrhash(h); + return h; } cl_object cl_hash_table_p(cl_object ht) { - @(return (ECL_HASH_TABLE_P(ht) ? ECL_T : ECL_NIL)) + @(return (ECL_HASH_TABLE_P(ht) ? ECL_T : ECL_NIL)); } cl_object si_hash_table_weakness(cl_object ht) { - cl_object output = ECL_NIL; + cl_object output = ECL_NIL; #ifdef ECL_WEAK_HASH - switch (ht->hash.weak) { - case ecl_htt_weak_key: output = @':key'; break; - case ecl_htt_weak_value: output = @':value'; break; - case ecl_htt_weak_key_and_value: output = @':key-and-value'; break; - case ecl_htt_not_weak: default: output = ECL_NIL; break; - } + switch (ht->hash.weak) { + case ecl_htt_weak_key: output = @':key'; break; + case ecl_htt_weak_value: output = @':value'; break; + case ecl_htt_weak_key_and_value: output = @':key-and-value'; break; + case ecl_htt_not_weak: default: output = ECL_NIL; break; + } #endif - @(return output) + @(return output); } @(defun gethash (key ht &optional (no_value ECL_NIL)) -@ -{ - assert_type_hash_table(@[gethash], 2, ht); - { - cl_object v = ht->hash.get(key, ht, OBJNULL); - if (v != OBJNULL) { - @(return v ECL_T); - } else { - @(return no_value ECL_NIL); - } - } -} -@) + @ + { + assert_type_hash_table(@[gethash], 2, ht); + { + cl_object v = ht->hash.get(key, ht, OBJNULL); + if (v != OBJNULL) { + @(return v ECL_T); + } else { + @(return no_value ECL_NIL); + } + } + } + @) cl_object si_hash_set(cl_object key, cl_object ht, cl_object val) { - /* INV: ecl_sethash() checks the type of hashtable */ - ecl_sethash(key, ht, val); - @(return val) + /* INV: ecl_sethash() checks the type of hashtable */ + ecl_sethash(key, ht, val); + @(return val); } bool ecl_remhash(cl_object key, cl_object hashtable) { - assert_type_hash_table(@[remhash], 2, hashtable); - return hashtable->hash.rem(key, hashtable); + assert_type_hash_table(@[remhash], 2, hashtable); + return hashtable->hash.rem(key, hashtable); } cl_object cl_remhash(cl_object key, cl_object ht) { - /* INV: _ecl_remhash() checks the type of hashtable */ - @(return (ecl_remhash(key, ht)? ECL_T : ECL_NIL)); + /* INV: _ecl_remhash() checks the type of hashtable */ + @(return (ecl_remhash(key, ht)? ECL_T : ECL_NIL)); } cl_object cl_clrhash(cl_object ht) { - assert_type_hash_table(@[clrhash], 1, ht); - if (ht->hash.entries) { - do_clrhash(ht); - } - @(return ht) + assert_type_hash_table(@[clrhash], 1, ht); + if (ht->hash.entries) { + do_clrhash(ht); + } + @(return ht); } cl_object cl_hash_table_test(cl_object ht) { - cl_object output; - assert_type_hash_table(@[hash-table-test], 1, ht); - switch(ht->hash.test) { - case ecl_htt_eq: output = @'eq'; break; - case ecl_htt_eql: output = @'eql'; break; - case ecl_htt_equal: output = @'equal'; break; - case ecl_htt_equalp: output = @'equalp'; break; - case ecl_htt_pack: - default: output = @'equal'; - } - @(return output) + cl_object output; + assert_type_hash_table(@[hash-table-test], 1, ht); + switch(ht->hash.test) { + case ecl_htt_eq: output = @'eq'; break; + case ecl_htt_eql: output = @'eql'; break; + case ecl_htt_equal: output = @'equal'; break; + case ecl_htt_equalp: output = @'equalp'; break; + case ecl_htt_pack: + default: output = @'equal'; + } + @(return output); } cl_object cl_hash_table_size(cl_object ht) { - assert_type_hash_table(@[hash-table-size], 1, ht); - @(return ecl_make_fixnum(ht->hash.size)) + assert_type_hash_table(@[hash-table-size], 1, ht); + @(return ecl_make_fixnum(ht->hash.size)); } cl_index ecl_hash_table_count(cl_object ht) { - if (ht->hash.weak == ecl_htt_not_weak) { - return ht->hash.entries; - } else if (ht->hash.size) { - cl_index i, j; - for (i = j = 0; i < ht->hash.size; i++) { - struct ecl_hashtable_entry output = - copy_entry(ht->hash.data + i, ht); - if (output.key != OBJNULL) { - if (++j == ht->hash.size) - break; - } - } - return ht->hash.entries = j; - } else { - return 0; - } + if (ht->hash.weak == ecl_htt_not_weak) { + return ht->hash.entries; + } else if (ht->hash.size) { + cl_index i, j; + for (i = j = 0; i < ht->hash.size; i++) { + struct ecl_hashtable_entry output = + copy_entry(ht->hash.data + i, ht); + if (output.key != OBJNULL) { + if (++j == ht->hash.size) + break; + } + } + return ht->hash.entries = j; + } else { + return 0; + } } cl_object cl_hash_table_count(cl_object ht) { - assert_type_hash_table(@[hash-table-count], 1, ht); - @(return (ecl_make_fixnum(ecl_hash_table_count(ht)))) + assert_type_hash_table(@[hash-table-count], 1, ht); + @(return (ecl_make_fixnum(ecl_hash_table_count(ht)))); } static cl_object si_hash_table_iterate(cl_narg narg) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object env = the_env->function->cclosure.env; - cl_object index = CAR(env); - cl_object ht = CADR(env); - cl_fixnum i; - if (!Null(index)) { - i = ecl_fixnum(index); - if (i < 0) - i = -1; - for (; ++i < ht->hash.size; ) { - struct ecl_hashtable_entry e = - copy_entry(ht->hash.data + i, ht); - if (e.key != OBJNULL) { - cl_object ndx = ecl_make_fixnum(i); - ECL_RPLACA(env, ndx); - @(return ndx e.key e.value) - } - } - ECL_RPLACA(env, ECL_NIL); - } - @(return ECL_NIL) + const cl_env_ptr the_env = ecl_process_env(); + cl_object env = the_env->function->cclosure.env; + cl_object index = CAR(env); + cl_object ht = CADR(env); + cl_fixnum i; + if (!Null(index)) { + i = ecl_fixnum(index); + if (i < 0) + i = -1; + for (; ++i < ht->hash.size; ) { + struct ecl_hashtable_entry e = + copy_entry(ht->hash.data + i, ht); + if (e.key != OBJNULL) { + cl_object ndx = ecl_make_fixnum(i); + ECL_RPLACA(env, ndx); + @(return ndx e.key e.value); + } + } + ECL_RPLACA(env, ECL_NIL); + } + @(return ECL_NIL); } cl_object si_hash_table_iterator(cl_object ht) { - assert_type_hash_table(@[si::hash-table-iterator], 1, ht); - @(return ecl_make_cclosure_va((cl_objectfn)si_hash_table_iterate, - cl_list(2, ecl_make_fixnum(-1), ht), - @'si::hash-table-iterator')) + assert_type_hash_table(@[si::hash-table-iterator], 1, ht); + @(return ecl_make_cclosure_va((cl_objectfn)si_hash_table_iterate, + cl_list(2, ecl_make_fixnum(-1), ht), + @'si::hash-table-iterator')); } cl_object cl_hash_table_rehash_size(cl_object ht) { - assert_type_hash_table(@[hash-table-rehash-size], 1, ht); - @(return ht->hash.rehash_size) + assert_type_hash_table(@[hash-table-rehash-size], 1, ht); + @(return ht->hash.rehash_size); } cl_object cl_hash_table_rehash_threshold(cl_object ht) { - assert_type_hash_table(@[hash-table-rehash-threshold], 1, ht); - @(return ht->hash.threshold) + assert_type_hash_table(@[hash-table-rehash-threshold], 1, ht); + @(return ht->hash.threshold); } cl_object cl_sxhash(cl_object key) { - cl_index output = _hash_equal(3, 0, key); - const cl_index mask = ((cl_index)1 << (ECL_FIXNUM_BITS - 3)) - 1; - @(return ecl_make_fixnum(output & mask)) + cl_index output = _hash_equal(3, 0, key); + const cl_index mask = ((cl_index)1 << (ECL_FIXNUM_BITS - 3)) - 1; + @(return ecl_make_fixnum(output & mask)); } @(defun si::hash-eql (&rest args) - cl_index h; + cl_index h; @ - for (h = 0; narg; narg--) { - cl_object o = ecl_va_arg(args); - h = _hash_eql(h, o); - } - @(return ecl_make_fixnum(h)) + for (h = 0; narg; narg--) { + cl_object o = ecl_va_arg(args); + h = _hash_eql(h, o); + } + @(return ecl_make_fixnum(h)); @) @(defun si::hash-equal (&rest args) - cl_index h; + cl_index h; @ - for (h = 0; narg; narg--) { - cl_object o = ecl_va_arg(args); - h = _hash_equal(3, h, o); - } - @(return ecl_make_fixnum(h)) + for (h = 0; narg; narg--) { + cl_object o = ecl_va_arg(args); + h = _hash_equal(3, h, o); + } + @(return ecl_make_fixnum(h)); @) @(defun si::hash-equalp (&rest args) - cl_index h; + cl_index h; @ - for (h = 0; narg; narg--) { - cl_object o = ecl_va_arg(args); - h = _hash_equalp(3, h, o); - } - @(return ecl_make_fixnum(h)) + for (h = 0; narg; narg--) { + cl_object o = ecl_va_arg(args); + h = _hash_equalp(3, h, o); + } + @(return ecl_make_fixnum(h)); @) cl_object cl_maphash(cl_object fun, cl_object ht) { - cl_index i; + cl_index i; - assert_type_hash_table(@[maphash], 2, ht); - for (i = 0; i < ht->hash.size; i++) { - struct ecl_hashtable_entry e = ht->hash.data[i]; - if(e.key != OBJNULL) - funcall(3, fun, e.key, e.value); - } - @(return ECL_NIL) + assert_type_hash_table(@[maphash], 2, ht); + for (i = 0; i < ht->hash.size; i++) { + struct ecl_hashtable_entry e = ht->hash.data[i]; + if(e.key != OBJNULL) + funcall(3, fun, e.key, e.value); + } + @(return ECL_NIL); } cl_object si_hash_table_content(cl_object ht) { - cl_index i; - cl_object output = ECL_NIL; - assert_type_hash_table(@[ext::hash-table-content], 2, ht); - for (i = 0; i < ht->hash.size; i++) { - struct ecl_hashtable_entry e = ht->hash.data[i]; - if (e.key != OBJNULL) - output = ecl_cons(ecl_cons(e.key, e.value), output); - } - @(return output) + cl_index i; + cl_object output = ECL_NIL; + assert_type_hash_table(@[ext::hash-table-content], 2, ht); + for (i = 0; i < ht->hash.size; i++) { + struct ecl_hashtable_entry e = ht->hash.data[i]; + if (e.key != OBJNULL) + output = ecl_cons(ecl_cons(e.key, e.value), output); + } + @(return output); } cl_object si_hash_table_fill(cl_object ht, cl_object values) { - assert_type_hash_table(@[ext::hash-table-fill], 2, ht); - while (!Null(values)) { - cl_object pair = ecl_car(values); - cl_object key = ecl_car(pair); - cl_object value = ECL_CONS_CDR(pair); - values = ECL_CONS_CDR(values); - ecl_sethash(key, ht, value); - } - @(return ht) + assert_type_hash_table(@[ext::hash-table-fill], 2, ht); + while (!Null(values)) { + cl_object pair = ecl_car(values); + cl_object key = ecl_car(pair); + cl_object value = ECL_CONS_CDR(pair); + values = ECL_CONS_CDR(values); + ecl_sethash(key, ht, value); + } + @(return ht); } cl_object si_copy_hash_table(cl_object orig) { - cl_object hash; - hash = cl__make_hash_table(cl_hash_table_test(orig), - cl_hash_table_size(orig), - cl_hash_table_rehash_size(orig), - cl_hash_table_rehash_threshold(orig)); - memcpy(hash->hash.data, orig->hash.data, - orig->hash.size * sizeof(*orig->hash.data)); - hash->hash.entries = orig->hash.entries; - @(return hash) + cl_object hash; + hash = cl__make_hash_table(cl_hash_table_test(orig), + cl_hash_table_size(orig), + cl_hash_table_rehash_size(orig), + cl_hash_table_rehash_threshold(orig)); + memcpy(hash->hash.data, orig->hash.data, + orig->hash.size * sizeof(*orig->hash.data)); + hash->hash.entries = orig->hash.entries; + @(return hash); } diff -Nru ecl-16.1.2/src/c/instance.d ecl-16.1.3+ds/src/c/instance.d --- ecl-16.1.2/src/c/instance.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/instance.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,20 +1,15 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - instance.c -- CLOS interface. -*/ -/* - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * instance.d - CLOS interface + * + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -23,389 +18,391 @@ cl_object ecl_allocate_instance(cl_object clas, cl_index size) { - cl_object x = ecl_alloc_instance(size); - cl_index i; - ECL_CLASS_OF(x) = clas; - for (i = 0; i < size; i++) - x->instance.slots[i] = ECL_UNBOUND; - return x; + cl_object x = ecl_alloc_instance(size); + cl_index i; + ECL_CLASS_OF(x) = clas; + for (i = 0; i < size; i++) + x->instance.slots[i] = ECL_UNBOUND; + return x; } cl_object si_allocate_raw_instance(cl_object orig, cl_object clas, cl_object size) { - cl_object output = ecl_allocate_instance(clas, ecl_to_size(size)); - if (orig == ECL_NIL) { - orig = output; - } else { - orig->instance.clas = clas; - orig->instance.length = output->instance.length; - orig->instance.slots = output->instance.slots; - } - @(return orig) + cl_object output = ecl_allocate_instance(clas, ecl_to_size(size)); + if (orig == ECL_NIL) { + orig = output; + } else { + orig->instance.clas = clas; + orig->instance.length = output->instance.length; + orig->instance.slots = output->instance.slots; + } + @(return orig); } cl_object si_instance_sig(cl_object x) { - @(return x->instance.sig); + @(return x->instance.sig); } cl_object si_instance_sig_set(cl_object x) { - @(return (x->instance.sig = ECL_CLASS_SLOTS(ECL_CLASS_OF(x)))); + @(return (x->instance.sig = ECL_CLASS_SLOTS(ECL_CLASS_OF(x)))); } cl_object si_instance_class(cl_object x) { - if (ecl_unlikely(!ECL_INSTANCEP(x))) - FEwrong_type_only_arg(@[class-of], x, @[ext::instance]); - @(return ECL_CLASS_OF(x)) + if (ecl_unlikely(!ECL_INSTANCEP(x))) + FEwrong_type_only_arg(@[class-of], x, @[ext::instance]); + @(return ECL_CLASS_OF(x)); } cl_object si_instance_class_set(cl_object x, cl_object y) { - if (ecl_unlikely(!ECL_INSTANCEP(x))) - FEwrong_type_nth_arg(@[si::instance-class-set], 1, x, @[ext::instance]); - if (ecl_unlikely(!ECL_INSTANCEP(y))) - FEwrong_type_nth_arg(@[si::instance-class-set], 2, y, @[ext::instance]); - ECL_CLASS_OF(x) = y; - @(return x) + if (ecl_unlikely(!ECL_INSTANCEP(x))) + FEwrong_type_nth_arg(@[si::instance-class-set], 1, x, @[ext::instance]); + if (ecl_unlikely(!ECL_INSTANCEP(y))) + FEwrong_type_nth_arg(@[si::instance-class-set], 2, y, @[ext::instance]); + ECL_CLASS_OF(x) = y; + @(return x); } cl_object ecl_instance_ref(cl_object x, cl_fixnum i) { - if (ecl_unlikely(!ECL_INSTANCEP(x))) - FEwrong_type_nth_arg(@[si::instance-ref], 1, x, @[ext::instance]); - if (ecl_unlikely(i < 0 || i >= (cl_fixnum)x->instance.length)) - FEtype_error_index(x, i); - return(x->instance.slots[i]); + if (ecl_unlikely(!ECL_INSTANCEP(x))) + FEwrong_type_nth_arg(@[si::instance-ref], 1, x, @[ext::instance]); + if (ecl_unlikely(i < 0 || i >= (cl_fixnum)x->instance.length)) + FEtype_error_index(x, i); + return(x->instance.slots[i]); } cl_object si_instance_ref(cl_object x, cl_object index) { - cl_fixnum i; + cl_fixnum i; - if (ecl_unlikely(!ECL_INSTANCEP(x))) - FEwrong_type_nth_arg(@[si::instance-ref], 1, x, @[ext::instance]); - if (ecl_unlikely(!ECL_FIXNUMP(index))) - FEwrong_type_nth_arg(@[si::instance-ref], 2, index, @[fixnum]); - i = ecl_fixnum(index); - if (ecl_unlikely(i < 0 || i >= (cl_fixnum)x->instance.length)) - FEtype_error_index(x, i); - @(return x->instance.slots[i]) + if (ecl_unlikely(!ECL_INSTANCEP(x))) + FEwrong_type_nth_arg(@[si::instance-ref], 1, x, @[ext::instance]); + if (ecl_unlikely(!ECL_FIXNUMP(index))) + FEwrong_type_nth_arg(@[si::instance-ref], 2, index, @[fixnum]); + i = ecl_fixnum(index); + if (ecl_unlikely(i < 0 || i >= (cl_fixnum)x->instance.length)) + FEtype_error_index(x, i); + @(return x->instance.slots[i]); } cl_object clos_safe_instance_ref(cl_object x, cl_object index) { - cl_fixnum i; + cl_fixnum i; - if (ecl_unlikely(!ECL_INSTANCEP(x))) - FEwrong_type_nth_arg(@[si::instance-ref], 1, x, @[ext::instance]); - if (ecl_unlikely(!ECL_FIXNUMP(index))) - FEwrong_type_nth_arg(@[si::instance-ref], 2, index, @[fixnum]); - i = ecl_fixnum(index); - if (ecl_unlikely(i < 0 || i >= x->instance.length)) - FEtype_error_index(x, i); - x = x->instance.slots[i]; - if (ecl_unlikely(x == ECL_UNBOUND)) - x = _ecl_funcall4(@'slot-unbound', ECL_NIL, x, index); - @(return x) + if (ecl_unlikely(!ECL_INSTANCEP(x))) + FEwrong_type_nth_arg(@[si::instance-ref], 1, x, @[ext::instance]); + if (ecl_unlikely(!ECL_FIXNUMP(index))) + FEwrong_type_nth_arg(@[si::instance-ref], 2, index, @[fixnum]); + i = ecl_fixnum(index); + if (ecl_unlikely(i < 0 || i >= x->instance.length)) + FEtype_error_index(x, i); + x = x->instance.slots[i]; + if (ecl_unlikely(x == ECL_UNBOUND)) + x = _ecl_funcall4(@'slot-unbound', ECL_NIL, x, index); + @(return x); } cl_object ecl_instance_set(cl_object x, cl_fixnum i, cl_object v) { - if (ecl_unlikely(!ECL_INSTANCEP(x))) - FEwrong_type_nth_arg(@[si::instance-set], 1, x, @[ext::instance]); - if (ecl_unlikely(i >= x->instance.length || i < 0)) - FEtype_error_index(x, i); - x->instance.slots[i] = v; - return(v); + if (ecl_unlikely(!ECL_INSTANCEP(x))) + FEwrong_type_nth_arg(@[si::instance-set], 1, x, @[ext::instance]); + if (ecl_unlikely(i >= x->instance.length || i < 0)) + FEtype_error_index(x, i); + x->instance.slots[i] = v; + return(v); } cl_object si_instance_set(cl_object x, cl_object index, cl_object value) { - cl_fixnum i; + cl_fixnum i; - if (ecl_unlikely(!ECL_INSTANCEP(x))) - FEwrong_type_nth_arg(@[si::instance-set], 1, x, @[ext::instance]); - if (ecl_unlikely(!ECL_FIXNUMP(index))) - FEwrong_type_nth_arg(@[si::instance-set], 2, index, @[fixnum]); - i = ecl_fixnum(index); - if (ecl_unlikely(i >= (cl_fixnum)x->instance.length || i < 0)) - FEtype_error_index(x, i); - x->instance.slots[i] = value; - @(return value) + if (ecl_unlikely(!ECL_INSTANCEP(x))) + FEwrong_type_nth_arg(@[si::instance-set], 1, x, @[ext::instance]); + if (ecl_unlikely(!ECL_FIXNUMP(index))) + FEwrong_type_nth_arg(@[si::instance-set], 2, index, @[fixnum]); + i = ecl_fixnum(index); + if (ecl_unlikely(i >= (cl_fixnum)x->instance.length || i < 0)) + FEtype_error_index(x, i); + x->instance.slots[i] = value; + @(return value); } cl_object si_instancep(cl_object x) { - @(return (ECL_INSTANCEP(x) ? ecl_make_fixnum(x->instance.length) : ECL_NIL)) + @(return (ECL_INSTANCEP(x) ? ecl_make_fixnum(x->instance.length) : ECL_NIL)); } cl_object si_unbound() { - /* Returns an object that cannot be read or written and which - is used to represent an unitialized slot */ - @(return ECL_UNBOUND) + /* Returns an object that cannot be read or written and which + is used to represent an unitialized slot */ + @(return ECL_UNBOUND); } cl_object si_sl_boundp(cl_object x) { - @(return ((x == ECL_UNBOUND) ? ECL_NIL : ECL_T)) + @(return ((x == ECL_UNBOUND) ? ECL_NIL : ECL_T)); } cl_object si_sl_makunbound(cl_object x, cl_object index) { - cl_fixnum i; + cl_fixnum i; - if (ecl_unlikely(!ECL_INSTANCEP(x))) - FEwrong_type_nth_arg(@[si::sl-makunbound], 1, x, @[ext::instance]); - if (ecl_unlikely(!ECL_FIXNUMP(index))) - FEwrong_type_nth_arg(@[si::sl-makunbound], 2, index, @[fixnum]); - i = ecl_fixnum(index); - unlikely_if (i >= x->instance.length || i < 0) - FEtype_error_index(x, i); - x->instance.slots[i] = ECL_UNBOUND; - @(return x) + if (ecl_unlikely(!ECL_INSTANCEP(x))) + FEwrong_type_nth_arg(@[si::sl-makunbound], 1, x, @[ext::instance]); + if (ecl_unlikely(!ECL_FIXNUMP(index))) + FEwrong_type_nth_arg(@[si::sl-makunbound], 2, index, @[fixnum]); + i = ecl_fixnum(index); + unlikely_if (i >= x->instance.length || i < 0) + FEtype_error_index(x, i); + x->instance.slots[i] = ECL_UNBOUND; + @(return x); } cl_object si_copy_instance(cl_object x) { - cl_object y; + cl_object y; - if (ecl_unlikely(!ECL_INSTANCEP(x))) - FEwrong_type_nth_arg(@[si::copy-instance], 1, x, @[ext::instance]); - y = ecl_allocate_instance(x->instance.clas, x->instance.length); - y->instance.sig = x->instance.sig; - memcpy(y->instance.slots, x->instance.slots, - x->instance.length * sizeof(cl_object)); - @(return y) + if (ecl_unlikely(!ECL_INSTANCEP(x))) + FEwrong_type_nth_arg(@[si::copy-instance], 1, x, @[ext::instance]); + y = ecl_allocate_instance(x->instance.clas, x->instance.length); + y->instance.sig = x->instance.sig; + memcpy(y->instance.slots, x->instance.slots, + x->instance.length * sizeof(cl_object)); + @(return y); } @(defun find-class (name &optional (errorp ECL_T) env) - cl_object class, hash; + cl_object class, hash; @ - hash = ECL_SYM_VAL(the_env, @'si::*class-name-hash-table*'); - class = ecl_gethash_safe(name, hash, ECL_NIL); - if (class == ECL_NIL) { - if (!Null(errorp)) - FEerror("No class named ~S.", 1, name); - } - @(return class) + hash = ECL_SYM_VAL(the_env, @'si::*class-name-hash-table*'); + class = ecl_gethash_safe(name, hash, ECL_NIL); + if (class == ECL_NIL) { + if (!Null(errorp)) + FEerror("No class named ~S.", 1, name); + } + @(return class); @) cl_object ecl_slot_value(cl_object x, const char *slot) { - cl_object slot_name = ecl_read_from_cstring(slot); - return funcall(3, @'slot-value', x, slot_name); + cl_object slot_name = ecl_read_from_cstring(slot); + return funcall(3, @'slot-value', x, slot_name); } cl_object ecl_slot_value_set(cl_object x, const char *slot, cl_object value) { - cl_object slot_name = ecl_read_from_cstring(slot); - cl_object slot_setter = ecl_read_from_cstring("(SETF SLOT-VALUE)"); - return funcall(4, ecl_fdefinition(slot_setter), value, x, slot_name); + cl_object slot_name = ecl_read_from_cstring(slot); + cl_object slot_setter = ecl_read_from_cstring("(SETF SLOT-VALUE)"); + return funcall(4, ecl_fdefinition(slot_setter), value, x, slot_name); } /********************************************************************** * IMPORTANT: THE FOLLOWING LIST IS LINKED TO src/clos/builtin.lsp **********************************************************************/ enum ecl_built_in_classes { - ECL_BUILTIN_T = 0, - ECL_BUILTIN_SEQUENCE, - ECL_BUILTIN_LIST, - ECL_BUILTIN_CONS, - ECL_BUILTIN_ARRAY, - ECL_BUILTIN_VECTOR, - ECL_BUILTIN_STRING, + ECL_BUILTIN_T = 0, + ECL_BUILTIN_SEQUENCE, + ECL_BUILTIN_LIST, + ECL_BUILTIN_CONS, + ECL_BUILTIN_ARRAY, + ECL_BUILTIN_VECTOR, + ECL_BUILTIN_STRING, #ifdef ECL_UNICODE - ECL_BUILTIN_BASE_STRING, + ECL_BUILTIN_BASE_STRING, #endif - ECL_BUILTIN_BIT_VECTOR, - ECL_BUILTIN_STREAM, - ECL_BUILTIN_ANSI_STREAM, - ECL_BUILTIN_FILE_STREAM, - ECL_BUILTIN_ECHO_STREAM, - ECL_BUILTIN_STRING_STREAM, - ECL_BUILTIN_TWO_WAY_STREAM, - ECL_BUILTIN_SYNONYM_STREAM, - ECL_BUILTIN_BROADCAST_STREAM, - ECL_BUILTIN_CONCATENATED_STREAM, - ECL_BUILTIN_SEQUENCE_STREAM, - ECL_BUILTIN_CHARACTER, - ECL_BUILTIN_NUMBER, - ECL_BUILTIN_REAL, - ECL_BUILTIN_RATIONAL, - ECL_BUILTIN_INTEGER, - ECL_BUILTIN_FIXNUM, - ECL_BUILTIN_BIGNUM, - ECL_BUILTIN_RATIO, - ECL_BUILTIN_FLOAT, - ECL_BUILTIN_SINGLE_FLOAT, - ECL_BUILTIN_DOUBLE_FLOAT, - ECL_BUILTIN_COMPLEX, - ECL_BUILTIN_SYMBOL, - ECL_BUILTIN_NULL, - ECL_BUILTIN_KEYWORD, - ECL_BUILTIN_PACKAGE, - ECL_BUILTIN_FUNCTION, - ECL_BUILTIN_PATHNAME, - ECL_BUILTIN_LOGICAL_PATHNAME, - ECL_BUILTIN_HASH_TABLE, - ECL_BUILTIN_RANDOM_STATE, - ECL_BUILTIN_READTABLE, - ECL_BUILTIN_CODE_BLOCK, - ECL_BUILTIN_FOREIGN_DATA, - ECL_BUILTIN_FRAME, - ECL_BUILTIN_WEAK_POINTER + ECL_BUILTIN_BIT_VECTOR, + ECL_BUILTIN_STREAM, + ECL_BUILTIN_ANSI_STREAM, + ECL_BUILTIN_FILE_STREAM, + ECL_BUILTIN_ECHO_STREAM, + ECL_BUILTIN_STRING_STREAM, + ECL_BUILTIN_TWO_WAY_STREAM, + ECL_BUILTIN_SYNONYM_STREAM, + ECL_BUILTIN_BROADCAST_STREAM, + ECL_BUILTIN_CONCATENATED_STREAM, + ECL_BUILTIN_SEQUENCE_STREAM, + ECL_BUILTIN_CHARACTER, + ECL_BUILTIN_NUMBER, + ECL_BUILTIN_REAL, + ECL_BUILTIN_RATIONAL, + ECL_BUILTIN_INTEGER, + ECL_BUILTIN_FIXNUM, + ECL_BUILTIN_BIGNUM, + ECL_BUILTIN_RATIO, + ECL_BUILTIN_FLOAT, + ECL_BUILTIN_SINGLE_FLOAT, + ECL_BUILTIN_DOUBLE_FLOAT, + ECL_BUILTIN_COMPLEX, + ECL_BUILTIN_SYMBOL, + ECL_BUILTIN_NULL, + ECL_BUILTIN_KEYWORD, + ECL_BUILTIN_PACKAGE, + ECL_BUILTIN_FUNCTION, + ECL_BUILTIN_PATHNAME, + ECL_BUILTIN_LOGICAL_PATHNAME, + ECL_BUILTIN_HASH_TABLE, + ECL_BUILTIN_RANDOM_STATE, + ECL_BUILTIN_READTABLE, + ECL_BUILTIN_CODE_BLOCK, + ECL_BUILTIN_FOREIGN_DATA, + ECL_BUILTIN_FRAME, + ECL_BUILTIN_WEAK_POINTER #ifdef ECL_THREADS - , - ECL_BUILTIN_PROCESS, - ECL_BUILTIN_LOCK, - ECL_BUILTIN_RWLOCK, - ECL_BUILTIN_CONDITION_VARIABLE, - ECL_BUILTIN_SEMAPHORE, - ECL_BUILTIN_BARRIER, - ECL_BUILTIN_MAILBOX + , + ECL_BUILTIN_PROCESS, + ECL_BUILTIN_LOCK, + ECL_BUILTIN_RWLOCK, + ECL_BUILTIN_CONDITION_VARIABLE, + ECL_BUILTIN_SEMAPHORE, + ECL_BUILTIN_BARRIER, + ECL_BUILTIN_MAILBOX #endif #ifdef ECL_SSE2 - , ECL_BUILTIN_SSE_PACK + , ECL_BUILTIN_SSE_PACK #endif }; cl_object cl_class_of(cl_object x) { - size_t index; - switch (ecl_t_of(x)) { - case t_instance: - @(return ECL_CLASS_OF(x)) - case t_fixnum: - index = ECL_BUILTIN_FIXNUM; break; - case t_bignum: - index = ECL_BUILTIN_BIGNUM; break; - case t_ratio: - index = ECL_BUILTIN_RATIO; break; - case t_singlefloat: - index = ECL_BUILTIN_SINGLE_FLOAT; break; - case t_doublefloat: - index = ECL_BUILTIN_DOUBLE_FLOAT; break; + size_t index; + switch (ecl_t_of(x)) { + case t_instance: + @(return ECL_CLASS_OF(x)); + case t_fixnum: + index = ECL_BUILTIN_FIXNUM; break; + case t_bignum: + index = ECL_BUILTIN_BIGNUM; break; + case t_ratio: + index = ECL_BUILTIN_RATIO; break; + case t_singlefloat: + index = ECL_BUILTIN_SINGLE_FLOAT; break; + case t_doublefloat: + index = ECL_BUILTIN_DOUBLE_FLOAT; break; #ifdef ECL_LONG_FLOAT - case t_longfloat: - index = ECL_BUILTIN_FLOAT; break; - /* XXX index = ECL_BUILTIN_LONG_FLOAT; break; */ + case t_longfloat: + index = ECL_BUILTIN_FLOAT; break; + /* XXX index = ECL_BUILTIN_LONG_FLOAT; break; */ #endif - case t_complex: - index = ECL_BUILTIN_COMPLEX; break; - case t_character: - index = ECL_BUILTIN_CHARACTER; break; - case t_symbol: - if (x->symbol.hpack == cl_core.keyword_package) - index = ECL_BUILTIN_KEYWORD; - else - index = ECL_BUILTIN_SYMBOL; - break; - case t_package: - index = ECL_BUILTIN_PACKAGE; break; - case t_list: - index = Null(x)? ECL_BUILTIN_NULL : ECL_BUILTIN_CONS; break; - case t_hashtable: - index = ECL_BUILTIN_HASH_TABLE; break; - case t_array: - index = ECL_BUILTIN_ARRAY; break; - case t_vector: - index = ECL_BUILTIN_VECTOR; break; + case t_complex: + index = ECL_BUILTIN_COMPLEX; break; + case t_character: + index = ECL_BUILTIN_CHARACTER; break; + case t_symbol: + if (x->symbol.hpack == cl_core.keyword_package) + index = ECL_BUILTIN_KEYWORD; + else + index = ECL_BUILTIN_SYMBOL; + break; + case t_package: + index = ECL_BUILTIN_PACKAGE; break; + case t_list: + index = Null(x)? ECL_BUILTIN_NULL : ECL_BUILTIN_CONS; break; + case t_hashtable: + index = ECL_BUILTIN_HASH_TABLE; break; + case t_array: + index = ECL_BUILTIN_ARRAY; break; + case t_vector: + index = ECL_BUILTIN_VECTOR; break; #ifdef ECL_UNICODE - case t_string: - index = ECL_BUILTIN_STRING; break; - case t_base_string: - index = ECL_BUILTIN_BASE_STRING; break; + case t_string: + index = ECL_BUILTIN_STRING; break; + case t_base_string: + index = ECL_BUILTIN_BASE_STRING; break; #else - case t_base_string: - index = ECL_BUILTIN_STRING; break; + case t_base_string: + index = ECL_BUILTIN_STRING; break; #endif - case t_bitvector: - index = ECL_BUILTIN_BIT_VECTOR; break; - case t_stream: - switch (x->stream.mode) { - case ecl_smm_synonym: index = ECL_BUILTIN_SYNONYM_STREAM; break; - case ecl_smm_broadcast: index = ECL_BUILTIN_BROADCAST_STREAM; break; - case ecl_smm_concatenated: index = ECL_BUILTIN_CONCATENATED_STREAM; break; - case ecl_smm_two_way: index = ECL_BUILTIN_TWO_WAY_STREAM; break; - case ecl_smm_string_input: - case ecl_smm_string_output: index = ECL_BUILTIN_STRING_STREAM; break; - case ecl_smm_echo: index = ECL_BUILTIN_ECHO_STREAM; break; - case ecl_smm_sequence_input: - case ecl_smm_sequence_output: index = ECL_BUILTIN_SEQUENCE_STREAM; break; - default: index = ECL_BUILTIN_FILE_STREAM; break; - } - break; - case t_readtable: - index = ECL_BUILTIN_READTABLE; break; - case t_pathname: - index = ECL_BUILTIN_PATHNAME; break; - case t_random: - index = ECL_BUILTIN_RANDOM_STATE; break; - case t_bytecodes: - case t_bclosure: - case t_cfun: - case t_cfunfixed: - case t_cclosure: - index = ECL_BUILTIN_FUNCTION; break; + case t_bitvector: + index = ECL_BUILTIN_BIT_VECTOR; break; + case t_stream: + switch (x->stream.mode) { + case ecl_smm_synonym: index = ECL_BUILTIN_SYNONYM_STREAM; break; + case ecl_smm_broadcast: index = ECL_BUILTIN_BROADCAST_STREAM; break; + case ecl_smm_concatenated: index = ECL_BUILTIN_CONCATENATED_STREAM; break; + case ecl_smm_two_way: index = ECL_BUILTIN_TWO_WAY_STREAM; break; + case ecl_smm_string_input: + case ecl_smm_string_output: index = ECL_BUILTIN_STRING_STREAM; break; + case ecl_smm_echo: index = ECL_BUILTIN_ECHO_STREAM; break; + case ecl_smm_sequence_input: + case ecl_smm_sequence_output: index = ECL_BUILTIN_SEQUENCE_STREAM; break; + default: index = ECL_BUILTIN_FILE_STREAM; break; + } + break; + case t_readtable: + index = ECL_BUILTIN_READTABLE; break; + case t_pathname: + index = ECL_BUILTIN_PATHNAME; break; + case t_random: + index = ECL_BUILTIN_RANDOM_STATE; break; + case t_bytecodes: + case t_bclosure: + case t_cfun: + case t_cfunfixed: + case t_cclosure: + index = ECL_BUILTIN_FUNCTION; break; #ifdef ECL_THREADS - case t_process: - index = ECL_BUILTIN_PROCESS; break; - case t_lock: - index = ECL_BUILTIN_LOCK; break; - case t_condition_variable: - index = ECL_BUILTIN_CONDITION_VARIABLE; break; - case t_semaphore: - index = ECL_BUILTIN_SEMAPHORE; break; - case t_barrier: - index = ECL_BUILTIN_BARRIER; break; - case t_mailbox: - index = ECL_BUILTIN_MAILBOX; break; + case t_process: + index = ECL_BUILTIN_PROCESS; break; + case t_lock: + index = ECL_BUILTIN_LOCK; break; + case t_rwlock: + index = ECL_BUILTIN_RWLOCK; break; + case t_condition_variable: + index = ECL_BUILTIN_CONDITION_VARIABLE; break; + case t_semaphore: + index = ECL_BUILTIN_SEMAPHORE; break; + case t_barrier: + index = ECL_BUILTIN_BARRIER; break; + case t_mailbox: + index = ECL_BUILTIN_MAILBOX; break; #endif - case t_codeblock: - index = ECL_BUILTIN_CODE_BLOCK; break; - case t_foreign: - index = ECL_BUILTIN_FOREIGN_DATA; break; - case t_frame: - index = ECL_BUILTIN_FRAME; break; - case t_weak_pointer: - index = ECL_BUILTIN_WEAK_POINTER; break; + case t_codeblock: + index = ECL_BUILTIN_CODE_BLOCK; break; + case t_foreign: + index = ECL_BUILTIN_FOREIGN_DATA; break; + case t_frame: + index = ECL_BUILTIN_FRAME; break; + case t_weak_pointer: + index = ECL_BUILTIN_WEAK_POINTER; break; #ifdef ECL_SSE2 - case t_sse_pack: - index = ECL_BUILTIN_SSE_PACK; break; + case t_sse_pack: + index = ECL_BUILTIN_SSE_PACK; break; #endif - default: - ecl_internal_error("not a lisp data object"); - } - { - /* We have to be careful because +builtin-classes+ might be empty! */ - /* In any case, since +builtin-classes+ is a constant, we may - * optimize the slot access */ - cl_object v = @'clos::+builtin-classes+'->symbol.value; - cl_object output = Null(v)? - cl_find_class(1,@'t') : - v->vector.self.t[index]; - @(return output) - } + default: + ecl_internal_error("not a lisp data object"); + } + { + /* We have to be careful because +builtin-classes+ might be empty! */ + /* In any case, since +builtin-classes+ is a constant, we may + * optimize the slot access */ + cl_object v = @'clos::+builtin-classes+'->symbol.value; + cl_object output = Null(v)? + cl_find_class(1,@'t') : + v->vector.self.t[index]; + @(return output); + } } diff -Nru ecl-16.1.2/src/c/interpreter.d ecl-16.1.3+ds/src/c/interpreter.d --- ecl-16.1.2/src/c/interpreter.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/interpreter.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - interpreter.c -- Bytecode interpreter. -*/ -/* - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * interpreter.d - bytecode interpreter + * + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -28,142 +23,142 @@ cl_object * ecl_stack_set_size(cl_env_ptr env, cl_index tentative_new_size) { - cl_index top = env->stack_top - env->stack; - cl_object *new_stack, *old_stack; - cl_index safety_area = ecl_option_values[ECL_OPT_LISP_STACK_SAFETY_AREA]; - cl_index new_size = tentative_new_size + 2*safety_area; - - /* Round to page size */ - new_size = (new_size + (LISP_PAGESIZE-1))/LISP_PAGESIZE * new_size; - - if (ecl_unlikely(top > new_size)) { - FEerror("Internal error: cannot shrink stack below stack top.",0); - } - - old_stack = env->stack; - new_stack = (cl_object *)ecl_alloc_atomic(new_size * sizeof(cl_object)); - - ecl_disable_interrupts_env(env); - memcpy(new_stack, old_stack, env->stack_size * sizeof(cl_object)); - env->stack_size = new_size; - env->stack_limit_size = new_size - 2*safety_area; - env->stack = new_stack; - env->stack_top = env->stack + top; - env->stack_limit = env->stack + (new_size - 2*safety_area); - ecl_enable_interrupts_env(env); - - /* A stack always has at least one element. This is assumed by cl__va_start - * and friends, which take a sp=0 to have no arguments. - */ - if (top == 0) { - *(env->stack_top++) = ecl_make_fixnum(0); - } - return env->stack_top; + cl_index top = env->stack_top - env->stack; + cl_object *new_stack, *old_stack; + cl_index safety_area = ecl_option_values[ECL_OPT_LISP_STACK_SAFETY_AREA]; + cl_index new_size = tentative_new_size + 2*safety_area; + + /* Round to page size */ + new_size = (new_size + (LISP_PAGESIZE-1))/LISP_PAGESIZE * new_size; + + if (ecl_unlikely(top > new_size)) { + FEerror("Internal error: cannot shrink stack below stack top.",0); + } + + old_stack = env->stack; + new_stack = (cl_object *)ecl_alloc_atomic(new_size * sizeof(cl_object)); + + ecl_disable_interrupts_env(env); + memcpy(new_stack, old_stack, env->stack_size * sizeof(cl_object)); + env->stack_size = new_size; + env->stack_limit_size = new_size - 2*safety_area; + env->stack = new_stack; + env->stack_top = env->stack + top; + env->stack_limit = env->stack + (new_size - 2*safety_area); + ecl_enable_interrupts_env(env); + + /* A stack always has at least one element. This is assumed by cl__va_start + * and friends, which take a sp=0 to have no arguments. + */ + if (top == 0) { + *(env->stack_top++) = ecl_make_fixnum(0); + } + return env->stack_top; } void FEstack_underflow(void) { - FEerror("Internal error: stack underflow.",0); + FEerror("Internal error: stack underflow.",0); } void FEstack_advance(void) { - FEerror("Internal error: stack advance beyond current point.",0); + FEerror("Internal error: stack advance beyond current point.",0); } cl_object * ecl_stack_grow(cl_env_ptr env) { - return ecl_stack_set_size(env, env->stack_size + env->stack_size / 2); + return ecl_stack_set_size(env, env->stack_size + env->stack_size / 2); } cl_index ecl_stack_push_values(cl_env_ptr env) { - cl_index i = env->nvalues; - cl_object *b = env->stack_top; - cl_object *p = b + i; - if (p >= env->stack_limit) { - b = ecl_stack_grow(env); - p = b + i; - } - env->stack_top = p; - memcpy(b, env->values, i * sizeof(cl_object)); - return i; + cl_index i = env->nvalues; + cl_object *b = env->stack_top; + cl_object *p = b + i; + if (p >= env->stack_limit) { + b = ecl_stack_grow(env); + p = b + i; + } + env->stack_top = p; + memcpy(b, env->values, i * sizeof(cl_object)); + return i; } void ecl_stack_pop_values(cl_env_ptr env, cl_index n) { - cl_object *p = env->stack_top - n; - if (ecl_unlikely(p < env->stack)) - FEstack_underflow(); - env->nvalues = n; - env->stack_top = p; - memcpy(env->values, p, n * sizeof(cl_object)); + cl_object *p = env->stack_top - n; + if (ecl_unlikely(p < env->stack)) + FEstack_underflow(); + env->nvalues = n; + env->stack_top = p; + memcpy(env->values, p, n * sizeof(cl_object)); } cl_object ecl_stack_frame_open(cl_env_ptr env, cl_object f, cl_index size) { - cl_object *base = env->stack_top; - if (size) { - if ((env->stack_limit - base) < size) { - base = ecl_stack_set_size(env, env->stack_size + size); - } - } - f->frame.t = t_frame; - f->frame.stack = env->stack; - f->frame.base = base; - f->frame.size = size; - f->frame.env = env; - env->stack_top = (base + size); - return f; + cl_object *base = env->stack_top; + if (size) { + if ((env->stack_limit - base) < size) { + base = ecl_stack_set_size(env, env->stack_size + size); + } + } + f->frame.t = t_frame; + f->frame.stack = env->stack; + f->frame.base = base; + f->frame.size = size; + f->frame.env = env; + env->stack_top = (base + size); + return f; } void ecl_stack_frame_push(cl_object f, cl_object o) { - cl_env_ptr env = f->frame.env; - cl_object *top = env->stack_top; - if (top >= env->stack_limit) { - top = ecl_stack_grow(env); - } - *top = o; - env->stack_top = ++top; - f->frame.base = top - (++(f->frame.size)); - f->frame.stack = env->stack; + cl_env_ptr env = f->frame.env; + cl_object *top = env->stack_top; + if (top >= env->stack_limit) { + top = ecl_stack_grow(env); + } + *top = o; + env->stack_top = ++top; + f->frame.base = top - (++(f->frame.size)); + f->frame.stack = env->stack; } void ecl_stack_frame_push_values(cl_object f) { - cl_env_ptr env = f->frame.env; - ecl_stack_push_values(env); - f->frame.base = env->stack_top - (f->frame.size += env->nvalues); - f->frame.stack = env->stack; + cl_env_ptr env = f->frame.env; + ecl_stack_push_values(env); + f->frame.base = env->stack_top - (f->frame.size += env->nvalues); + f->frame.stack = env->stack; } cl_object ecl_stack_frame_pop_values(cl_object f) { - cl_env_ptr env = f->frame.env; - cl_index n = f->frame.size % ECL_MULTIPLE_VALUES_LIMIT; - cl_object o; - env->nvalues = n; - env->values[0] = o = ECL_NIL; - while (n--) { - env->values[n] = o = f->frame.base[n]; - } - return o; + cl_env_ptr env = f->frame.env; + cl_index n = f->frame.size % ECL_MULTIPLE_VALUES_LIMIT; + cl_object o; + env->nvalues = n; + env->values[0] = o = ECL_NIL; + while (n--) { + env->values[n] = o = f->frame.base[n]; + } + return o; } void ecl_stack_frame_close(cl_object f) { - if (f->frame.stack) { - ECL_STACK_SET_INDEX(f->frame.env, f->frame.base - f->frame.stack); - } + if (f->frame.stack) { + ECL_STACK_SET_INDEX(f->frame.env, f->frame.base - f->frame.stack); + } } /* ------------------------------ LEXICAL ENV. ------------------------------ */ @@ -175,10 +170,10 @@ static cl_object ecl_lex_env_get_record(register cl_object env, register int s) { - do { - if (s-- == 0) return ECL_CONS_CAR(env); - env = ECL_CONS_CDR(env); - } while(1); + do { + if (s-- == 0) return ECL_CONS_CAR(env); + env = ECL_CONS_CDR(env); + } while(1); } #define ecl_lex_env_get_var(env,x) ECL_CONS_CDR(ecl_lex_env_get_record(env,x)) @@ -191,33 +186,33 @@ cl_object _ecl_bytecodes_dispatch_vararg(cl_narg narg, ...) { - cl_object output; - ECL_STACK_FRAME_VARARGS_BEGIN(narg, narg, frame) { - output = ecl_interpret(frame, ECL_NIL, frame->frame.env->function); - } ECL_STACK_FRAME_VARARGS_END(frame); - return output; + cl_object output; + ECL_STACK_FRAME_VARARGS_BEGIN(narg, narg, frame) { + output = ecl_interpret(frame, ECL_NIL, frame->frame.env->function); + } ECL_STACK_FRAME_VARARGS_END(frame); + return output; } cl_object _ecl_bclosure_dispatch_vararg(cl_narg narg, ...) { - cl_object output; - ECL_STACK_FRAME_VARARGS_BEGIN(narg, narg, frame) { - cl_object fun = frame->frame.env->function; - output = ecl_interpret(frame, fun->bclosure.lex, fun->bclosure.code); - } ECL_STACK_FRAME_VARARGS_END(frame); - return output; + cl_object output; + ECL_STACK_FRAME_VARARGS_BEGIN(narg, narg, frame) { + cl_object fun = frame->frame.env->function; + output = ecl_interpret(frame, fun->bclosure.lex, fun->bclosure.code); + } ECL_STACK_FRAME_VARARGS_END(frame); + return output; } static cl_object close_around(cl_object fun, cl_object lex) { - cl_object v = ecl_alloc_object(t_bclosure); - if (ecl_t_of(fun) != t_bytecodes) - FEerror("!!!", 0); - v->bclosure.code = fun; - v->bclosure.lex = lex; - v->bclosure.entry = _ecl_bclosure_dispatch_vararg; - return v; + cl_object v = ecl_alloc_object(t_bclosure); + if (ecl_t_of(fun) != t_bytecodes) + FEerror("!!!", 0); + v->bclosure.code = fun; + v->bclosure.lex = lex; + v->bclosure.entry = _ecl_bclosure_dispatch_vararg; + return v; } #define SETUP_ENV(the_env) { ihs.lex_env = lex_env; } @@ -230,13 +225,13 @@ * lexical environment needs to be saved. */ -#define INTERPRET_FUNCALL(reg0, the_env, frame, narg, fun) { \ - cl_index __n = narg; \ - SETUP_ENV(the_env); \ - frame.stack = the_env->stack; \ - frame.base = the_env->stack_top - (frame.size = __n); \ - reg0 = ecl_apply_from_stack_frame((cl_object)&frame, fun); \ - the_env->stack_top -= __n; } +#define INTERPRET_FUNCALL(reg0, the_env, frame, narg, fun) { \ + cl_index __n = narg; \ + SETUP_ENV(the_env); \ + frame.stack = the_env->stack; \ + frame.base = the_env->stack_top - (frame.size = __n); \ + reg0 = ecl_apply_from_stack_frame((cl_object)&frame, fun); \ + the_env->stack_top -= __n; } static void too_many_arguments(cl_object bytecodes, cl_object frame) ecl_attr_noreturn; static void odd_number_of_keywords(cl_object bytecodes) ecl_attr_noreturn; @@ -245,25 +240,25 @@ static void too_many_arguments(register cl_object bytecodes, register cl_object frame) { - FEprogram_error("Too many arguments passed to " - "function ~A~&Argument list: ~S", - 2, bytecodes, cl_apply(2, @'list', frame)); + FEprogram_error("Too many arguments passed to " + "function ~A~&Argument list: ~S", + 2, bytecodes, cl_apply(2, @'list', frame)); } static void odd_number_of_keywords(register cl_object bytecodes) { - FEprogram_error("Function ~A called with odd number " - "of keyword arguments.", - 1, bytecodes); + FEprogram_error("Function ~A called with odd number " + "of keyword arguments.", + 1, bytecodes); } static void unknown_keyword(register cl_object bytecodes, register cl_object frame) { - FEprogram_error("Unknown keyword argument passed to function ~S.~&" - "Argument list: ~S", 2, bytecodes, - cl_apply(2, @'list', frame)); + FEprogram_error("Unknown keyword argument passed to function ~S.~&" + "Argument list: ~S", 2, bytecodes, + cl_apply(2, @'list', frame)); } /* -------------------- THE INTERPRETER -------------------- */ @@ -271,1008 +266,1008 @@ cl_object ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) { - ECL_OFFSET_TABLE - const cl_env_ptr the_env = frame->frame.env; - volatile cl_index frame_index = 0; - cl_opcode *vector = (cl_opcode*)bytecodes->bytecodes.code; - cl_object *data = bytecodes->bytecodes.data->vector.self.t; - cl_object reg0 = ECL_NIL, reg1 = ECL_NIL, lex_env = env; - cl_index narg; - struct ecl_stack_frame frame_aux; - volatile struct ecl_ihs_frame ihs; - - /* INV: bytecodes is of type t_bytecodes */ - - ecl_cs_check(the_env, ihs); - ecl_ihs_push(the_env, &ihs, bytecodes, lex_env); - frame_aux.t = t_frame; - frame_aux.stack = frame_aux.base = 0; - frame_aux.size = 0; - frame_aux.env = the_env; + ECL_OFFSET_TABLE + const cl_env_ptr the_env = frame->frame.env; + volatile cl_index frame_index = 0; + cl_opcode *vector = (cl_opcode*)bytecodes->bytecodes.code; + cl_object *data = bytecodes->bytecodes.data->vector.self.t; + cl_object reg0 = ECL_NIL, reg1 = ECL_NIL, lex_env = env; + cl_index narg; + struct ecl_stack_frame frame_aux; + volatile struct ecl_ihs_frame ihs; + + /* INV: bytecodes is of type t_bytecodes */ + + ecl_cs_check(the_env, ihs); + ecl_ihs_push(the_env, &ihs, bytecodes, lex_env); + frame_aux.t = t_frame; + frame_aux.stack = frame_aux.base = 0; + frame_aux.size = 0; + frame_aux.env = the_env; BEGIN: - BEGIN_SWITCH { - CASE(OP_NOP); { - reg0 = ECL_NIL; - the_env->nvalues = 0; - THREAD_NEXT; - } - /* OP_QUOTE - Sets REG0 to an immediate value. - */ - CASE(OP_QUOTE); { - GET_DATA(reg0, vector, data); - THREAD_NEXT; - } - /* OP_VAR n{arg}, var{symbol} - Sets REG0 to the value of the n-th local. - VAR is the name of the variable for readability purposes. - */ - CASE(OP_VAR); { - int lex_env_index; - GET_OPARG(lex_env_index, vector); - reg0 = ecl_lex_env_get_var(lex_env, lex_env_index); - THREAD_NEXT; - } - - /* OP_VARS var{symbol} - Sets REG0 to the value of the symbol VAR. - VAR should be either a special variable or a constant. - */ - CASE(OP_VARS); { - cl_object var_name; - GET_DATA(var_name, vector, data); - reg0 = ECL_SYM_VAL(the_env, var_name); - if (ecl_unlikely(reg0 == OBJNULL)) - FEunbound_variable(var_name); - THREAD_NEXT; - } - - /* OP_CONS, OP_CAR, OP_CDR, etc - Inlined forms for some functions which act on reg0 and stack. - */ - - CASE(OP_CONS); { - cl_object car = ECL_STACK_POP_UNSAFE(the_env); - reg0 = CONS(car, reg0); - THREAD_NEXT; - } - - CASE(OP_CAR); { - if (ecl_unlikely(!LISTP(reg0))) - FEwrong_type_only_arg(@[car], reg0, @[cons]); - reg0 = CAR(reg0); - THREAD_NEXT; - } - - CASE(OP_CDR); { - if (ecl_unlikely(!LISTP(reg0))) - FEwrong_type_only_arg(@[cdr], reg0, @[cons]); - reg0 = CDR(reg0); - THREAD_NEXT; - } - - CASE(OP_LIST); - reg0 = ecl_list1(reg0); - - CASE(OP_LISTA); { - cl_index n; - GET_OPARG(n, vector); - while (--n) { - reg0 = CONS(ECL_STACK_POP_UNSAFE(the_env), reg0); - } - THREAD_NEXT; - } - - CASE(OP_INT); { - cl_fixnum n; - GET_OPARG(n, vector); - reg0 = ecl_make_fixnum(n); - THREAD_NEXT; - } - - CASE(OP_PINT); { - cl_fixnum n; - GET_OPARG(n, vector); - ECL_STACK_PUSH(the_env, ecl_make_fixnum(n)); - THREAD_NEXT; - } - - /* OP_PUSH - Pushes the object in VALUES(0). - */ - CASE(OP_PUSH); { - ECL_STACK_PUSH(the_env, reg0); - THREAD_NEXT; - } - /* OP_PUSHV n{arg} - Pushes the value of the n-th local onto the stack. - */ - CASE(OP_PUSHV); { - int lex_env_index; - GET_OPARG(lex_env_index, vector); - ECL_STACK_PUSH(the_env, ecl_lex_env_get_var(lex_env, lex_env_index)); - THREAD_NEXT; - } - - /* OP_PUSHVS var{symbol} - Pushes the value of the symbol VAR onto the stack. - VAR should be either a special variable or a constant. - */ - CASE(OP_PUSHVS); { - cl_object var_name, value; - GET_DATA(var_name, vector, data); - value = ECL_SYM_VAL(the_env, var_name); - if (ecl_unlikely(value == OBJNULL)) - FEunbound_variable(var_name); - ECL_STACK_PUSH(the_env, value); - THREAD_NEXT; - } - - /* OP_PUSHQ value{object} - Pushes "value" onto the stack. - */ - CASE(OP_PUSHQ); { - cl_object aux; - GET_DATA(aux, vector, data); - ECL_STACK_PUSH(the_env, aux); - THREAD_NEXT; - } - - CASE(OP_CALLG1); { - cl_object s; - cl_objectfn f; - GET_DATA(s, vector, data); - f = ecl_function_dispatch(the_env, ECL_SYM_FUN(s)); - SETUP_ENV(the_env); - reg0 = f(1, reg0); - THREAD_NEXT; - } - - CASE(OP_CALLG2); { - cl_object s; - cl_objectfn f; - GET_DATA(s, vector, data); - f = ecl_function_dispatch(the_env, ECL_SYM_FUN(s)); - SETUP_ENV(the_env); - reg0 = f(2, ECL_STACK_POP_UNSAFE(the_env), reg0); - THREAD_NEXT; - } - - /* OP_CALL n{arg} - Calls the function in REG0 with N arguments which - have been deposited in the stack. The first output value - is pushed on the stack. - */ - CASE(OP_CALL); { - GET_OPARG(narg, vector); - goto DO_CALL; - } - - /* OP_CALLG n{arg}, name{arg} - Calls the function NAME with N arguments which have been - deposited in the stack. The first output value is pushed on - the stack. - */ - CASE(OP_CALLG); { - GET_OPARG(narg, vector); - GET_DATA(reg0, vector, data); - goto DO_CALL; - } - - /* OP_FCALL n{arg} - Calls a function in the stack with N arguments which - have been also deposited in the stack. The output values - are left in VALUES(...) - */ - CASE(OP_FCALL); { - GET_OPARG(narg, vector); - reg0 = ECL_STACK_REF(the_env,-narg-1); - goto DO_CALL; - } - - /* OP_MCALL - Similar to FCALL, but gets the number of arguments from - the stack (They all have been deposited by OP_PUSHVALUES) - */ - CASE(OP_MCALL); { - narg = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); - reg0 = ECL_STACK_REF(the_env,-narg-1); - goto DO_CALL; - } - - DO_CALL: { - cl_object x = reg0; - cl_object frame = (cl_object)&frame_aux; - frame_aux.size = narg; - frame_aux.base = the_env->stack_top - narg; - SETUP_ENV(the_env); - AGAIN: - if (ecl_unlikely(reg0 == OBJNULL || reg0 == ECL_NIL)) - FEundefined_function(x); - switch (ecl_t_of(reg0)) { - case t_cfunfixed: - if (ecl_unlikely(narg != (cl_index)reg0->cfunfixed.narg)) - FEwrong_num_arguments(reg0); - reg0 = APPLY_fixed(narg, reg0->cfunfixed.entry_fixed, - frame_aux.base); - break; - case t_cfun: - reg0 = APPLY(narg, reg0->cfun.entry, frame_aux.base); - break; - case t_cclosure: - the_env->function = reg0; - reg0 = APPLY(narg, reg0->cclosure.entry, frame_aux.base); - break; - case t_instance: - switch (reg0->instance.isgf) { - case ECL_STANDARD_DISPATCH: - case ECL_RESTRICTED_DISPATCH: - reg0 = _ecl_standard_dispatch(frame, reg0); - break; - case ECL_USER_DISPATCH: - reg0 = reg0->instance.slots[reg0->instance.length - 1]; - goto AGAIN; - case ECL_READER_DISPATCH: - case ECL_WRITER_DISPATCH: - the_env->function = reg0; - reg0 = APPLY(narg, reg0->instance.entry, frame_aux.base); - break; - default: - FEinvalid_function(reg0); - } - break; - case t_symbol: - if (ecl_unlikely(reg0->symbol.stype & ecl_stp_macro)) - FEundefined_function(x); - reg0 = ECL_SYM_FUN(reg0); - goto AGAIN; - case t_bytecodes: - reg0 = ecl_interpret(frame, ECL_NIL, reg0); - break; - case t_bclosure: - reg0 = ecl_interpret(frame, reg0->bclosure.lex, reg0->bclosure.code); - break; - default: - FEinvalid_function(reg0); - } - ECL_STACK_POP_N_UNSAFE(the_env, narg); - THREAD_NEXT; - } - - /* OP_POP - Pops a singe value pushed by a OP_PUSH* operator. - */ - CASE(OP_POP); { - reg0 = ECL_STACK_POP_UNSAFE(the_env); - THREAD_NEXT; - } - /* OP_POP1 - Pops a singe value pushed by a OP_PUSH* operator, ignoring it. - */ - CASE(OP_POP1); { - (void)ECL_STACK_POP_UNSAFE(the_env); - THREAD_NEXT; - } - /* OP_POPREQ - Checks the arguments list. If there are remaining arguments, - REG0 = T and the value is on the stack, otherwise REG0 = NIL. - */ - CASE(OP_POPREQ); { - if (ecl_unlikely(frame_index >= frame->frame.size)) { - FEwrong_num_arguments(bytecodes->bytecodes.name); - } - reg0 = frame->frame.base[frame_index++]; - THREAD_NEXT; - } - /* OP_POPOPT - Checks the arguments list. If there are remaining arguments, - REG0 = T and the value is on the stack, otherwise REG0 = NIL. - */ - CASE(OP_POPOPT); { - if (frame_index >= frame->frame.size) { - reg0 = ECL_NIL; - } else { - ECL_STACK_PUSH(the_env,frame->frame.base[frame_index++]); - reg0 = ECL_T; - } - THREAD_NEXT; - } - /* OP_NOMORE - No more arguments. - */ - CASE(OP_NOMORE); { - if (ecl_unlikely(frame_index < frame->frame.size)) - too_many_arguments(bytecodes, frame); - THREAD_NEXT; - } - /* OP_POPREST - Makes a list out of the remaining arguments. - */ - CASE(OP_POPREST); { - cl_object *first = frame->frame.base + frame_index; - cl_object *last = frame->frame.base + frame->frame.size; - for (reg0 = ECL_NIL; last > first; ) { - reg0 = CONS(*(--last), reg0); - } - THREAD_NEXT; - } - /* OP_PUSHKEYS {names-list} - Checks the stack frame for keyword arguments. - */ - CASE(OP_PUSHKEYS); { - cl_object keys_list, aok, *first, *last; - cl_index count; - GET_DATA(keys_list, vector, data); - first = frame->frame.base + frame_index; - count = frame->frame.size - frame_index; - last = first + count; - if (ecl_unlikely(count & 1)) { - odd_number_of_keywords(bytecodes); - } - aok = ECL_CONS_CAR(keys_list); - for (; (keys_list = ECL_CONS_CDR(keys_list), !Null(keys_list)); ) { - cl_object name = ECL_CONS_CAR(keys_list); - cl_object flag = ECL_NIL; - cl_object value = ECL_NIL; - cl_object *p = first; - for (; p != last; ++p) { - if (*(p++) == name) { - count -= 2; - if (flag == ECL_NIL) { - flag = ECL_T; - value = *p; - } - } - } - if (flag != ECL_NIL) ECL_STACK_PUSH(the_env, value); - ECL_STACK_PUSH(the_env, flag); - } - if (count) { - if (Null(aok)) { - int aok = 0, mask = 1; - cl_object *p = first; - for (; p != last; ++p) { - if (*(p++) == @':allow-other-keys') { - if (!Null(*p)) aok |= mask; - mask <<= 1; - count -= 2; - } - } - if (ecl_unlikely(count && (aok & 1) == 0)) { - unknown_keyword(bytecodes, frame); - } - } - } - THREAD_NEXT; - } - /* OP_EXIT - Marks the end of a high level construct (BLOCK, CATCH...) - or a function. - */ - CASE(OP_EXIT); { - ecl_ihs_pop(the_env); - return reg0; - } - /* OP_FLET nfun{arg}, fun1{object} - ... - OP_UNBIND nfun + BEGIN_SWITCH { + CASE(OP_NOP); { + reg0 = ECL_NIL; + the_env->nvalues = 0; + THREAD_NEXT; + } + /* OP_QUOTE + Sets REG0 to an immediate value. + */ + CASE(OP_QUOTE); { + GET_DATA(reg0, vector, data); + THREAD_NEXT; + } + /* OP_VAR n{arg}, var{symbol} + Sets REG0 to the value of the n-th local. + VAR is the name of the variable for readability purposes. + */ + CASE(OP_VAR); { + int lex_env_index; + GET_OPARG(lex_env_index, vector); + reg0 = ecl_lex_env_get_var(lex_env, lex_env_index); + THREAD_NEXT; + } + + /* OP_VARS var{symbol} + Sets REG0 to the value of the symbol VAR. + VAR should be either a special variable or a constant. + */ + CASE(OP_VARS); { + cl_object var_name; + GET_DATA(var_name, vector, data); + reg0 = ECL_SYM_VAL(the_env, var_name); + if (ecl_unlikely(reg0 == OBJNULL)) + FEunbound_variable(var_name); + THREAD_NEXT; + } + + /* OP_CONS, OP_CAR, OP_CDR, etc + Inlined forms for some functions which act on reg0 and stack. + */ + + CASE(OP_CONS); { + cl_object car = ECL_STACK_POP_UNSAFE(the_env); + reg0 = CONS(car, reg0); + THREAD_NEXT; + } + + CASE(OP_CAR); { + if (ecl_unlikely(!LISTP(reg0))) + FEwrong_type_only_arg(@[car], reg0, @[cons]); + reg0 = CAR(reg0); + THREAD_NEXT; + } + + CASE(OP_CDR); { + if (ecl_unlikely(!LISTP(reg0))) + FEwrong_type_only_arg(@[cdr], reg0, @[cons]); + reg0 = CDR(reg0); + THREAD_NEXT; + } + + CASE(OP_LIST); + reg0 = ecl_list1(reg0); + + CASE(OP_LISTA); { + cl_index n; + GET_OPARG(n, vector); + while (--n) { + reg0 = CONS(ECL_STACK_POP_UNSAFE(the_env), reg0); + } + THREAD_NEXT; + } + + CASE(OP_INT); { + cl_fixnum n; + GET_OPARG(n, vector); + reg0 = ecl_make_fixnum(n); + THREAD_NEXT; + } + + CASE(OP_PINT); { + cl_fixnum n; + GET_OPARG(n, vector); + ECL_STACK_PUSH(the_env, ecl_make_fixnum(n)); + THREAD_NEXT; + } + + /* OP_PUSH + Pushes the object in VALUES(0). + */ + CASE(OP_PUSH); { + ECL_STACK_PUSH(the_env, reg0); + THREAD_NEXT; + } + /* OP_PUSHV n{arg} + Pushes the value of the n-th local onto the stack. + */ + CASE(OP_PUSHV); { + int lex_env_index; + GET_OPARG(lex_env_index, vector); + ECL_STACK_PUSH(the_env, ecl_lex_env_get_var(lex_env, lex_env_index)); + THREAD_NEXT; + } + + /* OP_PUSHVS var{symbol} + Pushes the value of the symbol VAR onto the stack. + VAR should be either a special variable or a constant. + */ + CASE(OP_PUSHVS); { + cl_object var_name, value; + GET_DATA(var_name, vector, data); + value = ECL_SYM_VAL(the_env, var_name); + if (ecl_unlikely(value == OBJNULL)) + FEunbound_variable(var_name); + ECL_STACK_PUSH(the_env, value); + THREAD_NEXT; + } + + /* OP_PUSHQ value{object} + Pushes "value" onto the stack. + */ + CASE(OP_PUSHQ); { + cl_object aux; + GET_DATA(aux, vector, data); + ECL_STACK_PUSH(the_env, aux); + THREAD_NEXT; + } + + CASE(OP_CALLG1); { + cl_object s; + cl_objectfn f; + GET_DATA(s, vector, data); + f = ecl_function_dispatch(the_env, ECL_SYM_FUN(s)); + SETUP_ENV(the_env); + reg0 = f(1, reg0); + THREAD_NEXT; + } + + CASE(OP_CALLG2); { + cl_object s; + cl_objectfn f; + GET_DATA(s, vector, data); + f = ecl_function_dispatch(the_env, ECL_SYM_FUN(s)); + SETUP_ENV(the_env); + reg0 = f(2, ECL_STACK_POP_UNSAFE(the_env), reg0); + THREAD_NEXT; + } + + /* OP_CALL n{arg} + Calls the function in REG0 with N arguments which + have been deposited in the stack. The first output value + is pushed on the stack. + */ + CASE(OP_CALL); { + GET_OPARG(narg, vector); + goto DO_CALL; + } + + /* OP_CALLG n{arg}, name{arg} + Calls the function NAME with N arguments which have been + deposited in the stack. The first output value is pushed on + the stack. + */ + CASE(OP_CALLG); { + GET_OPARG(narg, vector); + GET_DATA(reg0, vector, data); + goto DO_CALL; + } + + /* OP_FCALL n{arg} + Calls a function in the stack with N arguments which + have been also deposited in the stack. The output values + are left in VALUES(...) + */ + CASE(OP_FCALL); { + GET_OPARG(narg, vector); + reg0 = ECL_STACK_REF(the_env,-narg-1); + goto DO_CALL; + } + + /* OP_MCALL + Similar to FCALL, but gets the number of arguments from + the stack (They all have been deposited by OP_PUSHVALUES) + */ + CASE(OP_MCALL); { + narg = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); + reg0 = ECL_STACK_REF(the_env,-narg-1); + goto DO_CALL; + } + + DO_CALL: { + cl_object x = reg0; + cl_object frame = (cl_object)&frame_aux; + frame_aux.size = narg; + frame_aux.base = the_env->stack_top - narg; + SETUP_ENV(the_env); + AGAIN: + if (ecl_unlikely(reg0 == OBJNULL || reg0 == ECL_NIL)) + FEundefined_function(x); + switch (ecl_t_of(reg0)) { + case t_cfunfixed: + if (ecl_unlikely(narg != (cl_index)reg0->cfunfixed.narg)) + FEwrong_num_arguments(reg0); + reg0 = APPLY_fixed(narg, reg0->cfunfixed.entry_fixed, + frame_aux.base); + break; + case t_cfun: + reg0 = APPLY(narg, reg0->cfun.entry, frame_aux.base); + break; + case t_cclosure: + the_env->function = reg0; + reg0 = APPLY(narg, reg0->cclosure.entry, frame_aux.base); + break; + case t_instance: + switch (reg0->instance.isgf) { + case ECL_STANDARD_DISPATCH: + case ECL_RESTRICTED_DISPATCH: + reg0 = _ecl_standard_dispatch(frame, reg0); + break; + case ECL_USER_DISPATCH: + reg0 = reg0->instance.slots[reg0->instance.length - 1]; + goto AGAIN; + case ECL_READER_DISPATCH: + case ECL_WRITER_DISPATCH: + the_env->function = reg0; + reg0 = APPLY(narg, reg0->instance.entry, frame_aux.base); + break; + default: + FEinvalid_function(reg0); + } + break; + case t_symbol: + if (ecl_unlikely(reg0->symbol.stype & ecl_stp_macro)) + FEundefined_function(x); + reg0 = ECL_SYM_FUN(reg0); + goto AGAIN; + case t_bytecodes: + reg0 = ecl_interpret(frame, ECL_NIL, reg0); + break; + case t_bclosure: + reg0 = ecl_interpret(frame, reg0->bclosure.lex, reg0->bclosure.code); + break; + default: + FEinvalid_function(reg0); + } + ECL_STACK_POP_N_UNSAFE(the_env, narg); + THREAD_NEXT; + } + + /* OP_POP + Pops a singe value pushed by a OP_PUSH* operator. + */ + CASE(OP_POP); { + reg0 = ECL_STACK_POP_UNSAFE(the_env); + THREAD_NEXT; + } + /* OP_POP1 + Pops a singe value pushed by a OP_PUSH* operator, ignoring it. + */ + CASE(OP_POP1); { + (void)ECL_STACK_POP_UNSAFE(the_env); + THREAD_NEXT; + } + /* OP_POPREQ + Checks the arguments list. If there are remaining arguments, + REG0 = T and the value is on the stack, otherwise REG0 = NIL. + */ + CASE(OP_POPREQ); { + if (ecl_unlikely(frame_index >= frame->frame.size)) { + FEwrong_num_arguments(bytecodes->bytecodes.name); + } + reg0 = frame->frame.base[frame_index++]; + THREAD_NEXT; + } + /* OP_POPOPT + Checks the arguments list. If there are remaining arguments, + REG0 = T and the value is on the stack, otherwise REG0 = NIL. + */ + CASE(OP_POPOPT); { + if (frame_index >= frame->frame.size) { + reg0 = ECL_NIL; + } else { + ECL_STACK_PUSH(the_env,frame->frame.base[frame_index++]); + reg0 = ECL_T; + } + THREAD_NEXT; + } + /* OP_NOMORE + No more arguments. + */ + CASE(OP_NOMORE); { + if (ecl_unlikely(frame_index < frame->frame.size)) + too_many_arguments(bytecodes, frame); + THREAD_NEXT; + } + /* OP_POPREST + Makes a list out of the remaining arguments. + */ + CASE(OP_POPREST); { + cl_object *first = frame->frame.base + frame_index; + cl_object *last = frame->frame.base + frame->frame.size; + for (reg0 = ECL_NIL; last > first; ) { + reg0 = CONS(*(--last), reg0); + } + THREAD_NEXT; + } + /* OP_PUSHKEYS {names-list} + Checks the stack frame for keyword arguments. + */ + CASE(OP_PUSHKEYS); { + cl_object keys_list, aok, *first, *last; + cl_index count; + GET_DATA(keys_list, vector, data); + first = frame->frame.base + frame_index; + count = frame->frame.size - frame_index; + last = first + count; + if (ecl_unlikely(count & 1)) { + odd_number_of_keywords(bytecodes); + } + aok = ECL_CONS_CAR(keys_list); + for (; (keys_list = ECL_CONS_CDR(keys_list), !Null(keys_list)); ) { + cl_object name = ECL_CONS_CAR(keys_list); + cl_object flag = ECL_NIL; + cl_object value = ECL_NIL; + cl_object *p = first; + for (; p != last; ++p) { + if (*(p++) == name) { + count -= 2; + if (flag == ECL_NIL) { + flag = ECL_T; + value = *p; + } + } + } + if (flag != ECL_NIL) ECL_STACK_PUSH(the_env, value); + ECL_STACK_PUSH(the_env, flag); + } + if (count) { + if (Null(aok)) { + int aok = 0, mask = 1; + cl_object *p = first; + for (; p != last; ++p) { + if (*(p++) == @':allow-other-keys') { + if (!Null(*p)) aok |= mask; + mask <<= 1; + count -= 2; + } + } + if (ecl_unlikely(count && (aok & 1) == 0)) { + unknown_keyword(bytecodes, frame); + } + } + } + THREAD_NEXT; + } + /* OP_EXIT + Marks the end of a high level construct (BLOCK, CATCH...) + or a function. + */ + CASE(OP_EXIT); { + ecl_ihs_pop(the_env); + return reg0; + } + /* OP_FLET nfun{arg}, fun1{object} + ... + OP_UNBIND nfun - Executes the enclosed code in a lexical enviroment extended with - the functions "fun1" ... "funn". Note that we only record the - index of the first function: the others are after this one. - Note that nfun > 0. - */ - CASE(OP_FLET); { - int nfun; - cl_object old_lex; - GET_OPARG(nfun, vector); - /* Copy the environment so that functions get it without references - to themselves, and then add new closures to the environment. */ - old_lex = lex_env; - do { - cl_object f; - GET_DATA(f, vector, data); - f = close_around(f, old_lex); - lex_env = bind_function(lex_env, f->bytecodes.name, f); - } while (--nfun); - THREAD_NEXT; - } - /* OP_LABELS nfun{arg} - fun1{object} - ... - funn{object} - ... - OP_UNBIND n - - Executes the enclosed code in a lexical enviroment extended with - the functions "fun1" ... "funn". - */ - CASE(OP_LABELS); { - cl_index nfun; - GET_OPARG(nfun, vector); - /* Build up a new environment with all functions */ - { - cl_index i = nfun; - do { - cl_object f; - GET_DATA(f, vector, data); - lex_env = bind_function(lex_env, f->bytecodes.name, f); - } while (--i); - } - /* Update the closures so that all functions can call each other */ - { - cl_object l = lex_env; - do { - ECL_RPLACA(l, close_around(ECL_CONS_CAR(l), lex_env)); - l = ECL_CONS_CDR(l); - } while (--nfun); - } - THREAD_NEXT; - } - /* OP_LFUNCTION n{arg}, function-name{symbol} - Calls the local or global function with N arguments - which have been deposited in the stack. - */ - CASE(OP_LFUNCTION); { - int lex_env_index; - GET_OPARG(lex_env_index, vector); - reg0 = ecl_lex_env_get_fun(lex_env, lex_env_index); - THREAD_NEXT; - } - - /* OP_FUNCTION name{symbol} - Extracts the function associated to a symbol. The function - may be defined in the global environment or in the local - environment. This last value takes precedence. - */ - CASE(OP_FUNCTION); { - GET_DATA(reg0, vector, data); - reg0 = ecl_fdefinition(reg0); - THREAD_NEXT; - } - - /* OP_CLOSE name{symbol} - Extracts the function associated to a symbol. The function - may be defined in the global environment or in the local - environment. This last value takes precedence. - */ - CASE(OP_CLOSE); { - GET_DATA(reg0, vector, data); - reg0 = close_around(reg0, lex_env); - THREAD_NEXT; - } - /* OP_GO n{arg}, tag-ndx{arg} - Jumps to the tag which is defined for the tagbody - frame registered at the n-th position in the lexical - environment. TAG-NDX is the number of tag in the list. - */ - CASE(OP_GO); { - cl_index lex_env_index; - cl_fixnum tag_ndx; - GET_OPARG(lex_env_index, vector); - GET_OPARG(tag_ndx, vector); - cl_go(ecl_lex_env_get_tag(lex_env, lex_env_index), - ecl_make_fixnum(tag_ndx)); - THREAD_NEXT; - } - /* OP_RETURN n{arg} - Returns from the block whose record in the lexical environment - occuppies the n-th position. - */ - CASE(OP_RETURN); { - int lex_env_index; - cl_object block_record; - GET_OPARG(lex_env_index, vector); - /* record = (id . name) */ - block_record = ecl_lex_env_get_record(lex_env, lex_env_index); - the_env->values[0] = reg0; - cl_return_from(ECL_CONS_CAR(block_record), - ECL_CONS_CDR(block_record)); - THREAD_NEXT; - } - /* OP_THROW - Jumps to an enclosing CATCH form whose tag matches the one - of the THROW. The tag is taken from the stack, while the - output values are left in VALUES(...). - */ - CASE(OP_THROW); { - cl_object tag_name = ECL_STACK_POP_UNSAFE(the_env); - the_env->values[0] = reg0; - cl_throw(tag_name); - THREAD_NEXT; - } - /* OP_JMP label{arg} - OP_JNIL label{arg} - OP_JT label{arg} - OP_JEQ value{object}, label{arg} - OP_JNEQ value{object}, label{arg} - Direct or conditional jumps. The conditional jumps are made - comparing with the value of REG0. - */ - CASE(OP_JMP); { - cl_oparg jump; - GET_OPARG(jump, vector); - vector += jump - OPARG_SIZE; - THREAD_NEXT; - } - CASE(OP_JNIL); { - cl_oparg jump; - GET_OPARG(jump, vector); - if (Null(reg0)) - vector += jump - OPARG_SIZE; - THREAD_NEXT; - } - CASE(OP_JT); { - cl_oparg jump; - GET_OPARG(jump, vector); - if (!Null(reg0)) - vector += jump - OPARG_SIZE; - THREAD_NEXT; - } - CASE(OP_JEQL); { - cl_oparg value, jump; - GET_OPARG(value, vector); - GET_OPARG(jump, vector); - if (ecl_eql(reg0, data[value])) - vector += jump - OPARG_SIZE; - THREAD_NEXT; - } - CASE(OP_JNEQL); { - cl_oparg value, jump; - GET_OPARG(value, vector); - GET_OPARG(jump, vector); - if (!ecl_eql(reg0, data[value])) - vector += jump - OPARG_SIZE; - THREAD_NEXT; - } - - CASE(OP_ENDP); - if (ecl_unlikely(!LISTP(reg0))) - FEwrong_type_only_arg(@[endp], reg0, @[list]); - CASE(OP_NOT); { - reg0 = (reg0 == ECL_NIL)? ECL_T : ECL_NIL; - THREAD_NEXT; - } - - /* OP_UNBIND n{arg} - Undo "n" local bindings. - */ - CASE(OP_UNBIND); { - cl_oparg n; - GET_OPARG(n, vector); - while (n--) - lex_env = ECL_CONS_CDR(lex_env); - THREAD_NEXT; - } - /* OP_UNBINDS n{arg} - Undo "n" bindings of special variables. - */ - CASE(OP_UNBINDS); { - cl_oparg n; - GET_OPARG(n, vector); - ecl_bds_unwind_n(the_env, n); - THREAD_NEXT; - } - /* OP_BIND name{symbol} - OP_PBIND name{symbol} - OP_VBIND nvalue{arg}, name{symbol} - OP_BINDS name{symbol} - OP_PBINDS name{symbol} - OP_VBINDS nvalue{arg}, name{symbol} - Binds a lexical or special variable to the the - value of REG0, the first value of the stack (PBIND) or - to a given value in the values array. - */ - CASE(OP_BIND); { - cl_object var_name; - GET_DATA(var_name, vector, data); - lex_env = bind_var(lex_env, var_name, reg0); - THREAD_NEXT; - } - CASE(OP_PBIND); { - cl_object var_name; - GET_DATA(var_name, vector, data); - lex_env = bind_var(lex_env, var_name, ECL_STACK_POP_UNSAFE(the_env)); - THREAD_NEXT; - } - CASE(OP_VBIND); { - cl_index n; - cl_object var_name; - GET_OPARG(n, vector); - GET_DATA(var_name, vector, data); - lex_env = bind_var(lex_env, var_name, - (n < the_env->nvalues) ? the_env->values[n] : ECL_NIL); - THREAD_NEXT; - } - CASE(OP_BINDS); { - cl_object var_name; - GET_DATA(var_name, vector, data); - ecl_bds_bind(the_env, var_name, reg0); - THREAD_NEXT; - } - CASE(OP_PBINDS); { - cl_object var_name; - GET_DATA(var_name, vector, data); - ecl_bds_bind(the_env, var_name, ECL_STACK_POP_UNSAFE(the_env)); - THREAD_NEXT; - } - CASE(OP_VBINDS); { - cl_index n; - cl_object var_name; - GET_OPARG(n, vector); - GET_DATA(var_name, vector, data); - ecl_bds_bind(the_env, var_name, - (n < the_env->nvalues) ? the_env->values[n] : ECL_NIL); - THREAD_NEXT; - } - /* OP_SETQ n{arg} - OP_PSETQ n{arg} - OP_SETQS var-name{symbol} - OP_PSETQS var-name{symbol} - OP_VSETQ n{arg}, nvalue{arg} - OP_VSETQS var-name{symbol}, nvalue{arg} - Sets either the n-th local or a special variable VAR-NAME, - to either the value in REG0 (OP_SETQ[S]) or to the - first value on the stack (OP_PSETQ[S]), or to a given - value from the multiple values array (OP_VSETQ[S]). Note - that NVALUE > 0 strictly. - */ - CASE(OP_SETQ); { - int lex_env_index; - GET_OPARG(lex_env_index, vector); - ecl_lex_env_set_var(lex_env, lex_env_index, reg0); - THREAD_NEXT; - } - CASE(OP_SETQS); { - cl_object var; - GET_DATA(var, vector, data); - /* INV: Not NIL, and of type t_symbol */ - if (ecl_unlikely(var->symbol.stype & ecl_stp_constant)) - FEassignment_to_constant(var); - ECL_SETQ(the_env, var, reg0); - THREAD_NEXT; - } - CASE(OP_PSETQ); { - int lex_env_index; - GET_OPARG(lex_env_index, vector); - ecl_lex_env_set_var(lex_env, lex_env_index, - ECL_STACK_POP_UNSAFE(the_env)); - THREAD_NEXT; - } - CASE(OP_PSETQS); { - cl_object var; - GET_DATA(var, vector, data); - /* INV: Not NIL, and of type t_symbol */ - ECL_SETQ(the_env, var, ECL_STACK_POP_UNSAFE(the_env)); - THREAD_NEXT; - } - CASE(OP_VSETQ); { - cl_index lex_env_index; - cl_oparg index; - GET_OPARG(lex_env_index, vector); - GET_OPARG(index, vector); - ecl_lex_env_set_var(lex_env, lex_env_index, - (index >= the_env->nvalues)? ECL_NIL : the_env->values[index]); - THREAD_NEXT; - } - CASE(OP_VSETQS); { - cl_object var, v; - cl_oparg index; - GET_DATA(var, vector, data); - GET_OPARG(index, vector); - v = (index >= the_env->nvalues)? ECL_NIL : the_env->values[index]; - ECL_SETQ(the_env, var, v); - THREAD_NEXT; - } + Executes the enclosed code in a lexical enviroment extended with + the functions "fun1" ... "funn". Note that we only record the + index of the first function: the others are after this one. + Note that nfun > 0. + */ + CASE(OP_FLET); { + int nfun; + cl_object old_lex; + GET_OPARG(nfun, vector); + /* Copy the environment so that functions get it without references + to themselves, and then add new closures to the environment. */ + old_lex = lex_env; + do { + cl_object f; + GET_DATA(f, vector, data); + f = close_around(f, old_lex); + lex_env = bind_function(lex_env, f->bytecodes.name, f); + } while (--nfun); + THREAD_NEXT; + } + /* OP_LABELS nfun{arg} + fun1{object} + ... + funn{object} + ... + OP_UNBIND n + + Executes the enclosed code in a lexical enviroment extended with + the functions "fun1" ... "funn". + */ + CASE(OP_LABELS); { + cl_index nfun; + GET_OPARG(nfun, vector); + /* Build up a new environment with all functions */ + { + cl_index i = nfun; + do { + cl_object f; + GET_DATA(f, vector, data); + lex_env = bind_function(lex_env, f->bytecodes.name, f); + } while (--i); + } + /* Update the closures so that all functions can call each other */ + { + cl_object l = lex_env; + do { + ECL_RPLACA(l, close_around(ECL_CONS_CAR(l), lex_env)); + l = ECL_CONS_CDR(l); + } while (--nfun); + } + THREAD_NEXT; + } + /* OP_LFUNCTION n{arg}, function-name{symbol} + Calls the local or global function with N arguments + which have been deposited in the stack. + */ + CASE(OP_LFUNCTION); { + int lex_env_index; + GET_OPARG(lex_env_index, vector); + reg0 = ecl_lex_env_get_fun(lex_env, lex_env_index); + THREAD_NEXT; + } + + /* OP_FUNCTION name{symbol} + Extracts the function associated to a symbol. The function + may be defined in the global environment or in the local + environment. This last value takes precedence. + */ + CASE(OP_FUNCTION); { + GET_DATA(reg0, vector, data); + reg0 = ecl_fdefinition(reg0); + THREAD_NEXT; + } + + /* OP_CLOSE name{symbol} + Extracts the function associated to a symbol. The function + may be defined in the global environment or in the local + environment. This last value takes precedence. + */ + CASE(OP_CLOSE); { + GET_DATA(reg0, vector, data); + reg0 = close_around(reg0, lex_env); + THREAD_NEXT; + } + /* OP_GO n{arg}, tag-ndx{arg} + Jumps to the tag which is defined for the tagbody + frame registered at the n-th position in the lexical + environment. TAG-NDX is the number of tag in the list. + */ + CASE(OP_GO); { + cl_index lex_env_index; + cl_fixnum tag_ndx; + GET_OPARG(lex_env_index, vector); + GET_OPARG(tag_ndx, vector); + cl_go(ecl_lex_env_get_tag(lex_env, lex_env_index), + ecl_make_fixnum(tag_ndx)); + THREAD_NEXT; + } + /* OP_RETURN n{arg} + Returns from the block whose record in the lexical environment + occuppies the n-th position. + */ + CASE(OP_RETURN); { + int lex_env_index; + cl_object block_record; + GET_OPARG(lex_env_index, vector); + /* record = (id . name) */ + block_record = ecl_lex_env_get_record(lex_env, lex_env_index); + the_env->values[0] = reg0; + cl_return_from(ECL_CONS_CAR(block_record), + ECL_CONS_CDR(block_record)); + THREAD_NEXT; + } + /* OP_THROW + Jumps to an enclosing CATCH form whose tag matches the one + of the THROW. The tag is taken from the stack, while the + output values are left in VALUES(...). + */ + CASE(OP_THROW); { + cl_object tag_name = ECL_STACK_POP_UNSAFE(the_env); + the_env->values[0] = reg0; + cl_throw(tag_name); + THREAD_NEXT; + } + /* OP_JMP label{arg} + OP_JNIL label{arg} + OP_JT label{arg} + OP_JEQ value{object}, label{arg} + OP_JNEQ value{object}, label{arg} + Direct or conditional jumps. The conditional jumps are made + comparing with the value of REG0. + */ + CASE(OP_JMP); { + cl_oparg jump; + GET_OPARG(jump, vector); + vector += jump - OPARG_SIZE; + THREAD_NEXT; + } + CASE(OP_JNIL); { + cl_oparg jump; + GET_OPARG(jump, vector); + if (Null(reg0)) + vector += jump - OPARG_SIZE; + THREAD_NEXT; + } + CASE(OP_JT); { + cl_oparg jump; + GET_OPARG(jump, vector); + if (!Null(reg0)) + vector += jump - OPARG_SIZE; + THREAD_NEXT; + } + CASE(OP_JEQL); { + cl_oparg value, jump; + GET_OPARG(value, vector); + GET_OPARG(jump, vector); + if (ecl_eql(reg0, data[value])) + vector += jump - OPARG_SIZE; + THREAD_NEXT; + } + CASE(OP_JNEQL); { + cl_oparg value, jump; + GET_OPARG(value, vector); + GET_OPARG(jump, vector); + if (!ecl_eql(reg0, data[value])) + vector += jump - OPARG_SIZE; + THREAD_NEXT; + } + + CASE(OP_ENDP); + if (ecl_unlikely(!LISTP(reg0))) + FEwrong_type_only_arg(@[endp], reg0, @[list]); + CASE(OP_NOT); { + reg0 = (reg0 == ECL_NIL)? ECL_T : ECL_NIL; + THREAD_NEXT; + } + + /* OP_UNBIND n{arg} + Undo "n" local bindings. + */ + CASE(OP_UNBIND); { + cl_oparg n; + GET_OPARG(n, vector); + while (n--) + lex_env = ECL_CONS_CDR(lex_env); + THREAD_NEXT; + } + /* OP_UNBINDS n{arg} + Undo "n" bindings of special variables. + */ + CASE(OP_UNBINDS); { + cl_oparg n; + GET_OPARG(n, vector); + ecl_bds_unwind_n(the_env, n); + THREAD_NEXT; + } + /* OP_BIND name{symbol} + OP_PBIND name{symbol} + OP_VBIND nvalue{arg}, name{symbol} + OP_BINDS name{symbol} + OP_PBINDS name{symbol} + OP_VBINDS nvalue{arg}, name{symbol} + Binds a lexical or special variable to the the + value of REG0, the first value of the stack (PBIND) or + to a given value in the values array. + */ + CASE(OP_BIND); { + cl_object var_name; + GET_DATA(var_name, vector, data); + lex_env = bind_var(lex_env, var_name, reg0); + THREAD_NEXT; + } + CASE(OP_PBIND); { + cl_object var_name; + GET_DATA(var_name, vector, data); + lex_env = bind_var(lex_env, var_name, ECL_STACK_POP_UNSAFE(the_env)); + THREAD_NEXT; + } + CASE(OP_VBIND); { + cl_index n; + cl_object var_name; + GET_OPARG(n, vector); + GET_DATA(var_name, vector, data); + lex_env = bind_var(lex_env, var_name, + (n < the_env->nvalues) ? the_env->values[n] : ECL_NIL); + THREAD_NEXT; + } + CASE(OP_BINDS); { + cl_object var_name; + GET_DATA(var_name, vector, data); + ecl_bds_bind(the_env, var_name, reg0); + THREAD_NEXT; + } + CASE(OP_PBINDS); { + cl_object var_name; + GET_DATA(var_name, vector, data); + ecl_bds_bind(the_env, var_name, ECL_STACK_POP_UNSAFE(the_env)); + THREAD_NEXT; + } + CASE(OP_VBINDS); { + cl_index n; + cl_object var_name; + GET_OPARG(n, vector); + GET_DATA(var_name, vector, data); + ecl_bds_bind(the_env, var_name, + (n < the_env->nvalues) ? the_env->values[n] : ECL_NIL); + THREAD_NEXT; + } + /* OP_SETQ n{arg} + OP_PSETQ n{arg} + OP_SETQS var-name{symbol} + OP_PSETQS var-name{symbol} + OP_VSETQ n{arg}, nvalue{arg} + OP_VSETQS var-name{symbol}, nvalue{arg} + Sets either the n-th local or a special variable VAR-NAME, + to either the value in REG0 (OP_SETQ[S]) or to the + first value on the stack (OP_PSETQ[S]), or to a given + value from the multiple values array (OP_VSETQ[S]). Note + that NVALUE > 0 strictly. + */ + CASE(OP_SETQ); { + int lex_env_index; + GET_OPARG(lex_env_index, vector); + ecl_lex_env_set_var(lex_env, lex_env_index, reg0); + THREAD_NEXT; + } + CASE(OP_SETQS); { + cl_object var; + GET_DATA(var, vector, data); + /* INV: Not NIL, and of type t_symbol */ + if (ecl_unlikely(var->symbol.stype & ecl_stp_constant)) + FEassignment_to_constant(var); + ECL_SETQ(the_env, var, reg0); + THREAD_NEXT; + } + CASE(OP_PSETQ); { + int lex_env_index; + GET_OPARG(lex_env_index, vector); + ecl_lex_env_set_var(lex_env, lex_env_index, + ECL_STACK_POP_UNSAFE(the_env)); + THREAD_NEXT; + } + CASE(OP_PSETQS); { + cl_object var; + GET_DATA(var, vector, data); + /* INV: Not NIL, and of type t_symbol */ + ECL_SETQ(the_env, var, ECL_STACK_POP_UNSAFE(the_env)); + THREAD_NEXT; + } + CASE(OP_VSETQ); { + cl_index lex_env_index; + cl_oparg index; + GET_OPARG(lex_env_index, vector); + GET_OPARG(index, vector); + ecl_lex_env_set_var(lex_env, lex_env_index, + (index >= the_env->nvalues)? ECL_NIL : the_env->values[index]); + THREAD_NEXT; + } + CASE(OP_VSETQS); { + cl_object var, v; + cl_oparg index; + GET_DATA(var, vector, data); + GET_OPARG(index, vector); + v = (index >= the_env->nvalues)? ECL_NIL : the_env->values[index]; + ECL_SETQ(the_env, var, v); + THREAD_NEXT; + } - /* OP_BLOCK constant - OP_DO - OP_CATCH - - OP_FRAME label{arg} - ... - OP_EXIT_FRAME - label: - */ - - CASE(OP_BLOCK); { - GET_DATA(reg0, vector, data); - reg1 = ecl_make_fixnum(the_env->frame_id++); - lex_env = bind_frame(lex_env, reg1, reg0); - THREAD_NEXT; - } - CASE(OP_DO); { - reg0 = ECL_NIL; - reg1 = ecl_make_fixnum(the_env->frame_id++); - lex_env = bind_frame(lex_env, reg1, reg0); - THREAD_NEXT; - } - CASE(OP_CATCH); { - reg1 = reg0; - lex_env = bind_frame(lex_env, reg1, reg0); - THREAD_NEXT; - } - CASE(OP_FRAME); { - cl_opcode *exit; - GET_LABEL(exit, vector); - ECL_STACK_PUSH(the_env, lex_env); - ECL_STACK_PUSH(the_env, (cl_object)exit); - if (ecl_frs_push(the_env,reg1) == 0) { - THREAD_NEXT; - } else { - reg0 = the_env->values[0]; - vector = (cl_opcode *)ECL_STACK_REF(the_env,-1); /* FIXME! */ - lex_env = ECL_STACK_REF(the_env,-2); - goto DO_EXIT_FRAME; - } - } - /* OP_FRAMEID 0 - OP_TAGBODY n{arg} - label1 - ... - labeln - label1: - ... - labeln: - ... - OP_EXIT_TAGBODY - - High level construct for the TAGBODY form. - */ - CASE(OP_TAGBODY); { - int n; - GET_OPARG(n, vector); - ECL_STACK_PUSH(the_env, lex_env); - ECL_STACK_PUSH(the_env, (cl_object)vector); /* FIXME! */ - vector += n * OPARG_SIZE; - if (ecl_frs_push(the_env,reg1) != 0) { - /* Wait here for gotos. Each goto sets - VALUES(0) to an integer which ranges from 0 - to ntags-1, depending on the tag. These - numbers are indices into the jump table and - are computed at compile time. */ - cl_opcode *table = (cl_opcode *)ECL_STACK_REF(the_env,-1); - lex_env = ECL_STACK_REF(the_env,-2); - table = table + ecl_fixnum(the_env->values[0]) * OPARG_SIZE; - vector = table + *(cl_oparg *)table; - } - THREAD_NEXT; - } - CASE(OP_EXIT_TAGBODY); { - reg0 = ECL_NIL; - } - CASE(OP_EXIT_FRAME); { - DO_EXIT_FRAME: - ecl_frs_pop(the_env); - ECL_STACK_POP_N_UNSAFE(the_env, 2); - lex_env = ECL_CONS_CDR(lex_env); - THREAD_NEXT; - } - CASE(OP_NIL); { - reg0 = ECL_NIL; - THREAD_NEXT; - } - CASE(OP_PUSHNIL); { - ECL_STACK_PUSH(the_env, ECL_NIL); - THREAD_NEXT; - } - CASE(OP_VALUEREG0); { - the_env->nvalues = 1; - THREAD_NEXT; - } - - /* OP_PUSHVALUES - Pushes the values output by the last form, plus the number - of values. - */ - PUSH_VALUES: - CASE(OP_PUSHVALUES); { - cl_index i = the_env->nvalues; - ECL_STACK_PUSH_N(the_env, i+1); - the_env->values[0] = reg0; - memcpy(&ECL_STACK_REF(the_env, -(i+1)), the_env->values, i * sizeof(cl_object)); - ECL_STACK_REF(the_env, -1) = ecl_make_fixnum(the_env->nvalues); - THREAD_NEXT; - } - /* OP_PUSHMOREVALUES - Adds more values to the ones pushed by OP_PUSHVALUES. - */ - CASE(OP_PUSHMOREVALUES); { - cl_index n = ecl_fixnum(ECL_STACK_REF(the_env,-1)); - cl_index i = the_env->nvalues; - ECL_STACK_PUSH_N(the_env, i); - the_env->values[0] = reg0; - memcpy(&ECL_STACK_REF(the_env, -(i+1)), the_env->values, i * sizeof(cl_object)); - ECL_STACK_REF(the_env, -1) = ecl_make_fixnum(n + i); - THREAD_NEXT; - } - /* OP_POPVALUES - Pops all values pushed by a OP_PUSHVALUES operator. - */ - CASE(OP_POPVALUES); { - cl_object *dest = the_env->values; - int n = the_env->nvalues = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); - if (n == 0) { - *dest = reg0 = ECL_NIL; - THREAD_NEXT; - } else if (n == 1) { - *dest = reg0 = ECL_STACK_POP_UNSAFE(the_env); - THREAD_NEXT; - } else { - ECL_STACK_POP_N_UNSAFE(the_env,n); - memcpy(dest, &ECL_STACK_REF(the_env,0), n * sizeof(cl_object)); - reg0 = *dest; - THREAD_NEXT; - } - } - /* OP_VALUES n{arg} - Pop N values from the stack and store them in VALUES(...) - Note that N is strictly > 0. - */ - CASE(OP_VALUES); { - cl_fixnum n; - GET_OPARG(n, vector); - the_env->nvalues = n; - ECL_STACK_POP_N_UNSAFE(the_env, n); - memcpy(the_env->values, &ECL_STACK_REF(the_env, 0), n * sizeof(cl_object)); - reg0 = the_env->values[0]; - THREAD_NEXT; - } - /* OP_NTHVAL - Set VALUES(0) to the N-th value of the VALUES(...) list. - The index N-th is extracted from the top of the stack. - */ - CASE(OP_NTHVAL); { - cl_fixnum n = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); - if (ecl_unlikely(n < 0)) { - FEerror("Wrong index passed to NTH-VAL", 1, ecl_make_fixnum(n)); - } else if ((cl_index)n >= the_env->nvalues) { - reg0 = ECL_NIL; - } else if (n) { - reg0 = the_env->values[n]; - } - THREAD_NEXT; - } - /* OP_PROTECT label - ... ; code to be protected and whose value is output - OP_PROTECT_NORMAL - label: - ... ; code executed at exit - OP_PROTECT_EXIT - - High level construct for UNWIND-PROTECT. The first piece of code is - executed and its output value is saved. Then the second piece of code - is executed and the output values restored. The second piece of code - is always executed, even if a THROW, RETURN or GO happen within the - first piece of code. - */ - CASE(OP_PROTECT); { - cl_opcode *exit; - GET_LABEL(exit, vector); - ECL_STACK_PUSH(the_env, lex_env); - ECL_STACK_PUSH(the_env, (cl_object)exit); - if (ecl_frs_push(the_env,ECL_PROTECT_TAG) != 0) { - ecl_frs_pop(the_env); - vector = (cl_opcode *)ECL_STACK_POP_UNSAFE(the_env); - lex_env = ECL_STACK_POP_UNSAFE(the_env); - reg0 = the_env->values[0]; - ECL_STACK_PUSH(the_env, ecl_make_fixnum(the_env->nlj_fr - the_env->frs_top)); - goto PUSH_VALUES; - } - THREAD_NEXT; - } - CASE(OP_PROTECT_NORMAL); { - ecl_bds_unwind(the_env, the_env->frs_top->frs_bds_top_index); - ecl_frs_pop(the_env); - (void)ECL_STACK_POP_UNSAFE(the_env); - lex_env = ECL_STACK_POP_UNSAFE(the_env); - ECL_STACK_PUSH(the_env, ecl_make_fixnum(1)); - goto PUSH_VALUES; - } - CASE(OP_PROTECT_EXIT); { - volatile cl_fixnum n = the_env->nvalues = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); - while (n--) - the_env->values[n] = ECL_STACK_POP_UNSAFE(the_env); - reg0 = the_env->values[0]; - n = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); - if (n <= 0) - ecl_unwind(the_env, the_env->frs_top + n); - THREAD_NEXT; - } - - /* OP_PROGV bindings{list} - ... - OP_EXIT - Execute the code enclosed with the special variables in BINDINGS - set to the values in the list which was passed in VALUES(0). - */ - CASE(OP_PROGV); { - cl_object values = reg0; - cl_object vars = ECL_STACK_POP_UNSAFE(the_env); - cl_index n = ecl_progv(the_env, vars, values); - ECL_STACK_PUSH(the_env, ecl_make_fixnum(n)); - THREAD_NEXT; - } - CASE(OP_EXIT_PROGV); { - cl_index n = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); - ecl_bds_unwind(the_env, n); - THREAD_NEXT; - } - CASE(OP_CSET); { - cl_object *p; - GET_DATA_PTR(p, vector, data); - *p = reg0; - THREAD_NEXT; - } - - CASE(OP_STEPIN); { - cl_object form; - cl_object a = ECL_SYM_VAL(the_env, @'si::*step-action*'); - cl_index n; - GET_DATA(form, vector, data); - SETUP_ENV(the_env); - the_env->values[0] = reg0; - n = ecl_stack_push_values(the_env); - if (a == ECL_T) { - /* We are stepping in, but must first ask the user - * what to do. */ - ECL_SETQ(the_env, @'si::*step-level*', - cl_1P(ECL_SYM_VAL(the_env, @'si::*step-level*'))); - ECL_STACK_PUSH(the_env, form); - INTERPRET_FUNCALL(form, the_env, frame_aux, 1, @'si::stepper'); - } else if (a != ECL_NIL) { - /* The user told us to step over. *step-level* contains - * an integer number that, when it becomes 0, means - * that we have finished stepping over. */ - ECL_SETQ(the_env, @'si::*step-action*', cl_1P(a)); - } else { - /* We are not inside a STEP form. This should - * actually never happen. */ - } - ecl_stack_pop_values(the_env, n); - reg0 = the_env->values[0]; - THREAD_NEXT; - } - CASE(OP_STEPCALL); { - /* We are going to call a function. However, we would - * like to step _in_ the function. STEPPER takes care of - * that. */ - cl_fixnum n; - GET_OPARG(n, vector); - SETUP_ENV(the_env); - if (ECL_SYM_VAL(the_env, @'si::*step-action*') == ECL_T) { - ECL_STACK_PUSH(the_env, reg0); - INTERPRET_FUNCALL(reg0, the_env, frame_aux, 1, @'si::stepper'); - } - INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, reg0); - } - CASE(OP_STEPOUT); { - cl_object a = ECL_SYM_VAL(the_env, @'si::*step-action*'); - cl_index n; - SETUP_ENV(the_env); - the_env->values[0] = reg0; - n = ecl_stack_push_values(the_env); - if (a == ECL_T) { - /* We exit one stepping level */ - ECL_SETQ(the_env, @'si::*step-level*', - cl_1M(ECL_SYM_VAL(the_env, @'si::*step-level*'))); - } else if (a == ecl_make_fixnum(0)) { - /* We are back to the level in which the user - * selected to step over. */ - ECL_SETQ(the_env, @'si::*step-action*', ECL_T); - } else if (a != ECL_NIL) { - ECL_SETQ(the_env, @'si::*step-action*', cl_1M(a)); - } else { - /* Not stepping, nothing to be done. */ - } - ecl_stack_pop_values(the_env, n); - reg0 = the_env->values[0]; - THREAD_NEXT; - } - } + /* OP_BLOCK constant + OP_DO + OP_CATCH + + OP_FRAME label{arg} + ... + OP_EXIT_FRAME + label: + */ + + CASE(OP_BLOCK); { + GET_DATA(reg0, vector, data); + reg1 = ecl_make_fixnum(the_env->frame_id++); + lex_env = bind_frame(lex_env, reg1, reg0); + THREAD_NEXT; + } + CASE(OP_DO); { + reg0 = ECL_NIL; + reg1 = ecl_make_fixnum(the_env->frame_id++); + lex_env = bind_frame(lex_env, reg1, reg0); + THREAD_NEXT; + } + CASE(OP_CATCH); { + reg1 = reg0; + lex_env = bind_frame(lex_env, reg1, reg0); + THREAD_NEXT; + } + CASE(OP_FRAME); { + cl_opcode *exit; + GET_LABEL(exit, vector); + ECL_STACK_PUSH(the_env, lex_env); + ECL_STACK_PUSH(the_env, (cl_object)exit); + if (ecl_frs_push(the_env,reg1) == 0) { + THREAD_NEXT; + } else { + reg0 = the_env->values[0]; + vector = (cl_opcode *)ECL_STACK_REF(the_env,-1); /* FIXME! */ + lex_env = ECL_STACK_REF(the_env,-2); + goto DO_EXIT_FRAME; + } + } + /* OP_FRAMEID 0 + OP_TAGBODY n{arg} + label1 + ... + labeln + label1: + ... + labeln: + ... + OP_EXIT_TAGBODY + + High level construct for the TAGBODY form. + */ + CASE(OP_TAGBODY); { + int n; + GET_OPARG(n, vector); + ECL_STACK_PUSH(the_env, lex_env); + ECL_STACK_PUSH(the_env, (cl_object)vector); /* FIXME! */ + vector += n * OPARG_SIZE; + if (ecl_frs_push(the_env,reg1) != 0) { + /* Wait here for gotos. Each goto sets + VALUES(0) to an integer which ranges from 0 + to ntags-1, depending on the tag. These + numbers are indices into the jump table and + are computed at compile time. */ + cl_opcode *table = (cl_opcode *)ECL_STACK_REF(the_env,-1); + lex_env = ECL_STACK_REF(the_env,-2); + table = table + ecl_fixnum(the_env->values[0]) * OPARG_SIZE; + vector = table + *(cl_oparg *)table; + } + THREAD_NEXT; + } + CASE(OP_EXIT_TAGBODY); { + reg0 = ECL_NIL; + } + CASE(OP_EXIT_FRAME); { + DO_EXIT_FRAME: + ecl_frs_pop(the_env); + ECL_STACK_POP_N_UNSAFE(the_env, 2); + lex_env = ECL_CONS_CDR(lex_env); + THREAD_NEXT; + } + CASE(OP_NIL); { + reg0 = ECL_NIL; + THREAD_NEXT; + } + CASE(OP_PUSHNIL); { + ECL_STACK_PUSH(the_env, ECL_NIL); + THREAD_NEXT; + } + CASE(OP_VALUEREG0); { + the_env->nvalues = 1; + THREAD_NEXT; + } + + /* OP_PUSHVALUES + Pushes the values output by the last form, plus the number + of values. + */ + PUSH_VALUES: + CASE(OP_PUSHVALUES); { + cl_index i = the_env->nvalues; + ECL_STACK_PUSH_N(the_env, i+1); + the_env->values[0] = reg0; + memcpy(&ECL_STACK_REF(the_env, -(i+1)), the_env->values, i * sizeof(cl_object)); + ECL_STACK_REF(the_env, -1) = ecl_make_fixnum(the_env->nvalues); + THREAD_NEXT; + } + /* OP_PUSHMOREVALUES + Adds more values to the ones pushed by OP_PUSHVALUES. + */ + CASE(OP_PUSHMOREVALUES); { + cl_index n = ecl_fixnum(ECL_STACK_REF(the_env,-1)); + cl_index i = the_env->nvalues; + ECL_STACK_PUSH_N(the_env, i); + the_env->values[0] = reg0; + memcpy(&ECL_STACK_REF(the_env, -(i+1)), the_env->values, i * sizeof(cl_object)); + ECL_STACK_REF(the_env, -1) = ecl_make_fixnum(n + i); + THREAD_NEXT; + } + /* OP_POPVALUES + Pops all values pushed by a OP_PUSHVALUES operator. + */ + CASE(OP_POPVALUES); { + cl_object *dest = the_env->values; + int n = the_env->nvalues = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); + if (n == 0) { + *dest = reg0 = ECL_NIL; + THREAD_NEXT; + } else if (n == 1) { + *dest = reg0 = ECL_STACK_POP_UNSAFE(the_env); + THREAD_NEXT; + } else { + ECL_STACK_POP_N_UNSAFE(the_env,n); + memcpy(dest, &ECL_STACK_REF(the_env,0), n * sizeof(cl_object)); + reg0 = *dest; + THREAD_NEXT; + } + } + /* OP_VALUES n{arg} + Pop N values from the stack and store them in VALUES(...) + Note that N is strictly > 0. + */ + CASE(OP_VALUES); { + cl_fixnum n; + GET_OPARG(n, vector); + the_env->nvalues = n; + ECL_STACK_POP_N_UNSAFE(the_env, n); + memcpy(the_env->values, &ECL_STACK_REF(the_env, 0), n * sizeof(cl_object)); + reg0 = the_env->values[0]; + THREAD_NEXT; + } + /* OP_NTHVAL + Set VALUES(0) to the N-th value of the VALUES(...) list. + The index N-th is extracted from the top of the stack. + */ + CASE(OP_NTHVAL); { + cl_fixnum n = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); + if (ecl_unlikely(n < 0)) { + FEerror("Wrong index passed to NTH-VAL", 1, ecl_make_fixnum(n)); + } else if ((cl_index)n >= the_env->nvalues) { + reg0 = ECL_NIL; + } else if (n) { + reg0 = the_env->values[n]; + } + THREAD_NEXT; + } + /* OP_PROTECT label + ... ; code to be protected and whose value is output + OP_PROTECT_NORMAL + label: + ... ; code executed at exit + OP_PROTECT_EXIT + + High level construct for UNWIND-PROTECT. The first piece of code is + executed and its output value is saved. Then the second piece of code + is executed and the output values restored. The second piece of code + is always executed, even if a THROW, RETURN or GO happen within the + first piece of code. + */ + CASE(OP_PROTECT); { + cl_opcode *exit; + GET_LABEL(exit, vector); + ECL_STACK_PUSH(the_env, lex_env); + ECL_STACK_PUSH(the_env, (cl_object)exit); + if (ecl_frs_push(the_env,ECL_PROTECT_TAG) != 0) { + ecl_frs_pop(the_env); + vector = (cl_opcode *)ECL_STACK_POP_UNSAFE(the_env); + lex_env = ECL_STACK_POP_UNSAFE(the_env); + reg0 = the_env->values[0]; + ECL_STACK_PUSH(the_env, ecl_make_fixnum(the_env->nlj_fr - the_env->frs_top)); + goto PUSH_VALUES; + } + THREAD_NEXT; + } + CASE(OP_PROTECT_NORMAL); { + ecl_bds_unwind(the_env, the_env->frs_top->frs_bds_top_index); + ecl_frs_pop(the_env); + (void)ECL_STACK_POP_UNSAFE(the_env); + lex_env = ECL_STACK_POP_UNSAFE(the_env); + ECL_STACK_PUSH(the_env, ecl_make_fixnum(1)); + goto PUSH_VALUES; + } + CASE(OP_PROTECT_EXIT); { + volatile cl_fixnum n = the_env->nvalues = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); + while (n--) + the_env->values[n] = ECL_STACK_POP_UNSAFE(the_env); + reg0 = the_env->values[0]; + n = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); + if (n <= 0) + ecl_unwind(the_env, the_env->frs_top + n); + THREAD_NEXT; + } + + /* OP_PROGV bindings{list} + ... + OP_EXIT + Execute the code enclosed with the special variables in BINDINGS + set to the values in the list which was passed in VALUES(0). + */ + CASE(OP_PROGV); { + cl_object values = reg0; + cl_object vars = ECL_STACK_POP_UNSAFE(the_env); + cl_index n = ecl_progv(the_env, vars, values); + ECL_STACK_PUSH(the_env, ecl_make_fixnum(n)); + THREAD_NEXT; + } + CASE(OP_EXIT_PROGV); { + cl_index n = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); + ecl_bds_unwind(the_env, n); + THREAD_NEXT; + } + CASE(OP_CSET); { + cl_object *p; + GET_DATA_PTR(p, vector, data); + *p = reg0; + THREAD_NEXT; + } + + CASE(OP_STEPIN); { + cl_object form; + cl_object a = ECL_SYM_VAL(the_env, @'si::*step-action*'); + cl_index n; + GET_DATA(form, vector, data); + SETUP_ENV(the_env); + the_env->values[0] = reg0; + n = ecl_stack_push_values(the_env); + if (a == ECL_T) { + /* We are stepping in, but must first ask the user + * what to do. */ + ECL_SETQ(the_env, @'si::*step-level*', + cl_1P(ECL_SYM_VAL(the_env, @'si::*step-level*'))); + ECL_STACK_PUSH(the_env, form); + INTERPRET_FUNCALL(form, the_env, frame_aux, 1, @'si::stepper'); + } else if (a != ECL_NIL) { + /* The user told us to step over. *step-level* contains + * an integer number that, when it becomes 0, means + * that we have finished stepping over. */ + ECL_SETQ(the_env, @'si::*step-action*', cl_1P(a)); + } else { + /* We are not inside a STEP form. This should + * actually never happen. */ + } + ecl_stack_pop_values(the_env, n); + reg0 = the_env->values[0]; + THREAD_NEXT; + } + CASE(OP_STEPCALL); { + /* We are going to call a function. However, we would + * like to step _in_ the function. STEPPER takes care of + * that. */ + cl_fixnum n; + GET_OPARG(n, vector); + SETUP_ENV(the_env); + if (ECL_SYM_VAL(the_env, @'si::*step-action*') == ECL_T) { + ECL_STACK_PUSH(the_env, reg0); + INTERPRET_FUNCALL(reg0, the_env, frame_aux, 1, @'si::stepper'); + } + INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, reg0); + } + CASE(OP_STEPOUT); { + cl_object a = ECL_SYM_VAL(the_env, @'si::*step-action*'); + cl_index n; + SETUP_ENV(the_env); + the_env->values[0] = reg0; + n = ecl_stack_push_values(the_env); + if (a == ECL_T) { + /* We exit one stepping level */ + ECL_SETQ(the_env, @'si::*step-level*', + cl_1M(ECL_SYM_VAL(the_env, @'si::*step-level*'))); + } else if (a == ecl_make_fixnum(0)) { + /* We are back to the level in which the user + * selected to step over. */ + ECL_SETQ(the_env, @'si::*step-action*', ECL_T); + } else if (a != ECL_NIL) { + ECL_SETQ(the_env, @'si::*step-action*', cl_1M(a)); + } else { + /* Not stepping, nothing to be done. */ + } + ecl_stack_pop_values(the_env, n); + reg0 = the_env->values[0]; + THREAD_NEXT; + } + } } @(defun si::interpreter-stack () @ - @(return ECL_NIL) + @(return ECL_NIL); @) diff -Nru ecl-16.1.2/src/c/iso_latin_names.h ecl-16.1.3+ds/src/c/iso_latin_names.h --- ecl-16.1.2/src/c/iso_latin_names.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/iso_latin_names.h 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - iso_latin_names.h -- character names in ISO-LATIN-1 -*/ -/* - Copyright (c) 2008, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * iso_latin_names.h - character names in ISO-LATIN-1 + * + * Copyright (c) 2008 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ ecl_def_string_array(char_names,static,const) = { ecl_def_string_array_elt("Nul"), diff -Nru ecl-16.1.2/src/c/list.d ecl-16.1.3+ds/src/c/list.d --- ecl-16.1.2/src/c/list.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/list.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,34 +1,29 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - list.d -- List manipulating routines. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * list.d - list manipulating routines + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include struct cl_test { - bool (*test_c_function)(struct cl_test *, cl_object); - cl_object (*key_c_function)(struct cl_test *, cl_object); - cl_env_ptr env; - cl_object key_function; - cl_objectfn key_fn; - cl_object test_function; - cl_objectfn test_fn; - cl_object item_compared; + bool (*test_c_function)(struct cl_test *, cl_object); + cl_object (*key_c_function)(struct cl_test *, cl_object); + cl_env_ptr env; + cl_object key_function; + cl_objectfn key_fn; + cl_object test_function; + cl_objectfn test_fn; + cl_object item_compared; }; static cl_object subst(struct cl_test *t, cl_object new_obj, cl_object tree); @@ -44,183 +39,183 @@ static bool test_compare(struct cl_test *t, cl_object x) { - x = KEY(t,x); - t->env->function = t->test_function; - return t->test_fn(2, t->item_compared, x) != ECL_NIL; + x = KEY(t,x); + t->env->function = t->test_function; + return t->test_fn(2, t->item_compared, x) != ECL_NIL; } static bool test_compare_not(struct cl_test *t, cl_object x) { - x = KEY(t,x); - t->env->function = t->test_function; - return t->test_fn(2, t->item_compared, x) == ECL_NIL; + x = KEY(t,x); + t->env->function = t->test_function; + return t->test_fn(2, t->item_compared, x) == ECL_NIL; } static bool test_eq(struct cl_test *t, cl_object x) { - return (t->item_compared == KEY(t,x)); + return (t->item_compared == KEY(t,x)); } static bool test_eql(struct cl_test *t, cl_object x) { - return ecl_eql(t->item_compared, KEY(t,x)); + return ecl_eql(t->item_compared, KEY(t,x)); } static bool test_equal(struct cl_test *t, cl_object x) { - return ecl_equal(t->item_compared, KEY(t,x)); + return ecl_equal(t->item_compared, KEY(t,x)); } static bool test_equalp(struct cl_test *t, cl_object x) { - return ecl_equalp(t->item_compared, KEY(t,x)); + return ecl_equalp(t->item_compared, KEY(t,x)); } static cl_object key_function(struct cl_test *t, cl_object x) { - t->env->function = t->key_function; - return t->key_fn(1,x); + t->env->function = t->key_function; + return t->key_fn(1,x); } static cl_object key_identity(struct cl_test *t, cl_object x) { - return x; + return x; } static void setup_test(struct cl_test *t, cl_object item, cl_object test, cl_object test_not, cl_object key) { - cl_env_ptr env = t->env = ecl_process_env(); - t->item_compared = item; - if (test != ECL_NIL) { - if (test_not != ECL_NIL) - FEerror("Both :TEST and :TEST-NOT are specified.", 0); - t->test_function = test = si_coerce_to_function(test); - if (test == ECL_SYM_FUN(@'eq')) { - t->test_c_function = test_eq; - } else if (test == ECL_SYM_FUN(@'eql')) { - t->test_c_function = test_eql; - } else if (test == ECL_SYM_FUN(@'equal')) { - t->test_c_function = test_equal; - } else if (test == ECL_SYM_FUN(@'equalp')) { - t->test_c_function = test_equalp; - } else { - t->test_c_function = test_compare; - t->test_fn = ecl_function_dispatch(env, test); - t->test_function = env->function; - } - } else if (test_not != ECL_NIL) { - t->test_c_function = test_compare_not; - test_not = si_coerce_to_function(test_not); - t->test_fn = ecl_function_dispatch(env, test_not); - t->test_function = env->function; - } else { - t->test_c_function = test_eql; - } - if (key != ECL_NIL) { - key = si_coerce_to_function(key); - t->key_fn = ecl_function_dispatch(env, key); - t->key_function = env->function; - t->key_c_function = key_function; - } else { - t->key_c_function = key_identity; - } + cl_env_ptr env = t->env = ecl_process_env(); + t->item_compared = item; + if (test != ECL_NIL) { + if (test_not != ECL_NIL) + FEerror("Both :TEST and :TEST-NOT are specified.", 0); + t->test_function = test = si_coerce_to_function(test); + if (test == ECL_SYM_FUN(@'eq')) { + t->test_c_function = test_eq; + } else if (test == ECL_SYM_FUN(@'eql')) { + t->test_c_function = test_eql; + } else if (test == ECL_SYM_FUN(@'equal')) { + t->test_c_function = test_equal; + } else if (test == ECL_SYM_FUN(@'equalp')) { + t->test_c_function = test_equalp; + } else { + t->test_c_function = test_compare; + t->test_fn = ecl_function_dispatch(env, test); + t->test_function = env->function; + } + } else if (test_not != ECL_NIL) { + t->test_c_function = test_compare_not; + test_not = si_coerce_to_function(test_not); + t->test_fn = ecl_function_dispatch(env, test_not); + t->test_function = env->function; + } else { + t->test_c_function = test_eql; + } + if (key != ECL_NIL) { + key = si_coerce_to_function(key); + t->key_fn = ecl_function_dispatch(env, key); + t->key_function = env->function; + t->key_c_function = key_function; + } else { + t->key_c_function = key_identity; + } } @(defun list (&rest args) - cl_object head = ECL_NIL; + cl_object head = ECL_NIL; @ - if (narg--) { - cl_object tail = head = ecl_list1(ecl_va_arg(args)); - while (narg--) { - cl_object cons = ecl_list1(ecl_va_arg(args)); - ECL_RPLACD(tail, cons); - tail = cons; - } - } - @(return head) + if (narg--) { + cl_object tail = head = ecl_list1(ecl_va_arg(args)); + while (narg--) { + cl_object cons = ecl_list1(ecl_va_arg(args)); + ECL_RPLACD(tail, cons); + tail = cons; + } + } + @(return head); @) @(defun list* (&rest args) - cl_object head; + cl_object head; @ - if (narg == 0) - FEwrong_num_arguments(@[list*]); - head = ecl_va_arg(args); - if (--narg) { - cl_object tail = head = ecl_list1(head); - while (--narg) { - cl_object cons = ecl_list1(ecl_va_arg(args)); - ECL_RPLACD(tail, cons); - tail = cons; - } - ECL_RPLACD(tail, ecl_va_arg(args)); - } - @(return head) + if (narg == 0) + FEwrong_num_arguments(@[list*]); + head = ecl_va_arg(args); + if (--narg) { + cl_object tail = head = ecl_list1(head); + while (--narg) { + cl_object cons = ecl_list1(ecl_va_arg(args)); + ECL_RPLACD(tail, cons); + tail = cons; + } + ECL_RPLACD(tail, ecl_va_arg(args)); + } + @(return head); @) static cl_object * append_into(cl_object head, cl_object *tail, cl_object l) { - if (!Null(*tail)) { - /* (APPEND '(1 . 2) 3) */ - FEtype_error_proper_list(head); - } - while (CONSP(l)) { - cl_object cons = ecl_list1(ECL_CONS_CAR(l)); - *tail = cons; - tail = &ECL_CONS_CDR(cons); - l = ECL_CONS_CDR(l); - } - *tail = l; - return tail; + if (!Null(*tail)) { + /* (APPEND '(1 . 2) 3) */ + FEtype_error_proper_list(head); + } + while (CONSP(l)) { + cl_object cons = ecl_list1(ECL_CONS_CAR(l)); + *tail = cons; + tail = &ECL_CONS_CDR(cons); + l = ECL_CONS_CDR(l); + } + *tail = l; + return tail; } @(defun append (&rest rest) - cl_object head = ECL_NIL, *tail = &head; + cl_object head = ECL_NIL, *tail = &head; @ - for (; narg > 1; narg--) { - cl_object other = ecl_va_arg(rest); - tail = append_into(head, tail, other); - } - if (narg) { - if (!Null(*tail)) { - /* (APPEND '(1 . 2) 3) */ - FEtype_error_proper_list(head); - } - *tail = ecl_va_arg(rest); - } - @(return head) + for (; narg > 1; narg--) { + cl_object other = ecl_va_arg(rest); + tail = append_into(head, tail, other); + } + if (narg) { + if (!Null(*tail)) { + /* (APPEND '(1 . 2) 3) */ + FEtype_error_proper_list(head); + } + *tail = ecl_va_arg(rest); + } + @(return head); @) cl_object ecl_append(cl_object x, cl_object y) { - cl_object head = ECL_NIL; - cl_object *tail = &head; - if (!Null(x)) { - tail = append_into(head, tail, x); - } - if (!Null(*tail)) { - /* (APPEND '(1 . 2) 3) */ - FEtype_error_proper_list(head); - } - *tail = y; - return head; -} - -#define LENTH(n) (cl_object x) { \ - const cl_env_ptr the_env = ecl_process_env(); \ - ecl_return1(the_env, ecl_nth(n, x)); \ - } + cl_object head = ECL_NIL; + cl_object *tail = &head; + if (!Null(x)) { + tail = append_into(head, tail, x); + } + if (!Null(*tail)) { + /* (APPEND '(1 . 2) 3) */ + FEtype_error_proper_list(head); + } + *tail = y; + return head; +} + +#define LENTH(n) (cl_object x) { \ + const cl_env_ptr the_env = ecl_process_env(); \ + ecl_return1(the_env, ecl_nth(n, x)); \ + } cl_object @fifth LENTH(4) cl_object @sixth LENTH(5) cl_object @seventh LENTH(6) @@ -232,826 +227,833 @@ static bool tree_equal(struct cl_test *t, cl_object x, cl_object y) { -BEGIN: - if (CONSP(x)) { - if (CONSP(y)) { - if (tree_equal(t, ECL_CONS_CAR(x), ECL_CONS_CAR(y))) { - x = ECL_CONS_CDR(x); - y = ECL_CONS_CDR(y); - goto BEGIN; - } else { - return(FALSE); - } - } else { - return(FALSE); - } - } else { - t->item_compared = x; - if (TEST(t, y)) - return(TRUE); - else - return(FALSE); - } + BEGIN: + if (CONSP(x)) { + if (CONSP(y)) { + if (tree_equal(t, ECL_CONS_CAR(x), ECL_CONS_CAR(y))) { + x = ECL_CONS_CDR(x); + y = ECL_CONS_CDR(y); + goto BEGIN; + } else { + return(FALSE); + } + } else { + return(FALSE); + } + } else { + t->item_compared = x; + if (TEST(t, y)) + return(TRUE); + else + return(FALSE); + } } @(defun tree_equal (x y &key test test_not) - struct cl_test t; - cl_object output; + struct cl_test t; + cl_object output; @ - setup_test(&t, ECL_NIL, test, test_not, ECL_NIL); - output = tree_equal(&t, x, y)? ECL_T : ECL_NIL; - close_test(&t); - @(return output) + setup_test(&t, ECL_NIL, test, test_not, ECL_NIL); + output = tree_equal(&t, x, y)? ECL_T : ECL_NIL; + close_test(&t); + @(return output); @) cl_object cl_endp(cl_object x) { - cl_object output = ECL_NIL; - if (Null(x)) { - output = ECL_T; - } else if (ecl_unlikely(!LISTP(x))) { - FEwrong_type_only_arg(@[endp], x, @[list]); - } - @(return output); + cl_object output = ECL_NIL; + if (Null(x)) { + output = ECL_T; + } else if (ecl_unlikely(!LISTP(x))) { + FEwrong_type_only_arg(@[endp], x, @[list]); + } + @(return output); } bool ecl_endp(cl_object x) { - if (Null(x)) { - return TRUE; - } else if (ecl_unlikely(!LISTP(x))) { - FEwrong_type_only_arg(@[endp], x, @[list]); - } - return FALSE; + if (Null(x)) { + return TRUE; + } else if (ecl_unlikely(!LISTP(x))) { + FEwrong_type_only_arg(@[endp], x, @[list]); + } + return FALSE; } cl_object cl_list_length(cl_object x) { - cl_fixnum n; - cl_object fast, slow; - /* INV: A list's length always fits in a fixnum */ - fast = slow = x; - for (n = 0; !Null(fast); n++, fast = ECL_CONS_CDR(fast)) { - if (ecl_unlikely(!LISTP(fast))) { - FEtype_error_list(fast); - } - if (n & 1) { - /* Circular list? */ - if (slow == fast) @(return ECL_NIL); - slow = ECL_CONS_CDR(slow); - } - } - @(return ecl_make_fixnum(n)); + cl_fixnum n; + cl_object fast, slow; + /* INV: A list's length always fits in a fixnum */ + fast = slow = x; + for (n = 0; !Null(fast); n++, fast = ECL_CONS_CDR(fast)) { + if (ecl_unlikely(!LISTP(fast))) { + FEtype_error_list(fast); + } + if (n & 1) { + /* Circular list? */ + if (slow == fast) @(return ECL_NIL); + slow = ECL_CONS_CDR(slow); + } + } + @(return ecl_make_fixnum(n)); } cl_object si_proper_list_p(cl_object x) { - cl_fixnum n; - cl_object fast, slow, test = ECL_T; - /* INV: A list's length always fits in a fixnum */ - fast = slow = x; - for (n = 0; !Null(fast); n++, fast = ECL_CONS_CDR(fast)) { - if (!LISTP(fast)) { - test = ECL_NIL; - break; - } - if (n & 1) { - /* Circular list? */ - if (slow == fast) { - test = ECL_NIL; - break; - } - slow = ECL_CONS_CDR(slow); - } - } - @(return test); + cl_fixnum n; + cl_object fast, slow, test = ECL_T; + /* INV: A list's length always fits in a fixnum */ + fast = slow = x; + for (n = 0; !Null(fast); n++, fast = ECL_CONS_CDR(fast)) { + if (!LISTP(fast)) { + test = ECL_NIL; + break; + } + if (n & 1) { + /* Circular list? */ + if (slow == fast) { + test = ECL_NIL; + break; + } + slow = ECL_CONS_CDR(slow); + } + } + @(return test); } cl_object cl_nth(cl_object n, cl_object x) { - @(return ecl_nth(ecl_to_size(n), x)) + @(return ecl_nth(ecl_to_size(n), x)); } cl_object ecl_nth(cl_fixnum n, cl_object x) { - if (n < 0) - FEtype_error_index(x, n); - /* INV: No need to check for circularity since we visit - at most `n' conses */ - for (; n > 0 && CONSP(x); n--) - x = ECL_CONS_CDR(x); - if (Null(x)) - return ECL_NIL; - if (!LISTP(x)) - FEtype_error_list(x); - return ECL_CONS_CAR(x); + if (n < 0) + FEtype_error_index(x, n); + /* INV: No need to check for circularity since we visit + at most `n' conses */ + for (; n > 0 && CONSP(x); n--) + x = ECL_CONS_CDR(x); + if (Null(x)) + return ECL_NIL; + if (!LISTP(x)) + FEtype_error_list(x); + return ECL_CONS_CAR(x); } cl_object cl_nthcdr(cl_object n, cl_object x) { - @(return ecl_nthcdr(ecl_to_size(n), x)) + @(return ecl_nthcdr(ecl_to_size(n), x)); } cl_object ecl_nthcdr(cl_fixnum n, cl_object x) { - if (n < 0) - FEtype_error_index(x, n); - while (n-- > 0 && !Null(x)) { - if (LISTP(x)) { - x = ECL_CONS_CDR(x); - } else { - FEtype_error_list(x); - } - } - return x; + if (n < 0) + FEtype_error_index(x, n); + while (n-- > 0 && !Null(x)) { + if (LISTP(x)) { + x = ECL_CONS_CDR(x); + } else { + FEtype_error_list(x); + } + } + return x; } cl_object ecl_last(cl_object l, cl_index n) { - /* The algorithm is very simple. We run over the list with - * two pointers, "l" and "r". The separation between both - * must be "n", so that when "l" finds no more conses, "r" - * contains the output. */ - cl_object r; - for (r = l; n && CONSP(r); n--, r = ECL_CONS_CDR(r)) - ; - /* If "l" has not moved, we have to ensure that it is a list */ - if (r == l) { - if (!LISTP(r)) FEtype_error_list(l); - while (CONSP(r)) { - r = ECL_CONS_CDR(r); - } - return r; - } else if (n == 0) { - while (CONSP(r)) { - r = ECL_CONS_CDR(r); - l = ECL_CONS_CDR(l); - } - return l; - } else { - return l; - } + /* The algorithm is very simple. We run over the list with + * two pointers, "l" and "r". The separation between both + * must be "n", so that when "l" finds no more conses, "r" + * contains the output. */ + cl_object r; + for (r = l; n && CONSP(r); n--, r = ECL_CONS_CDR(r)) + ; + /* If "l" has not moved, we have to ensure that it is a list */ + if (r == l) { + if (!LISTP(r)) FEtype_error_list(l); + while (CONSP(r)) { + r = ECL_CONS_CDR(r); + } + return r; + } else if (n == 0) { + while (CONSP(r)) { + r = ECL_CONS_CDR(r); + l = ECL_CONS_CDR(l); + } + return l; + } else { + return l; + } } @(defun last (l &optional (k ecl_make_fixnum(1))) @ - if (ecl_t_of(k) == t_bignum) - @(return l) - @(return ecl_last(l, ecl_to_size(k))) + if (ecl_t_of(k) == t_bignum) { + @(return l); + } + @(return ecl_last(l, ecl_to_size(k))); @) @(defun make_list (size &key initial_element &aux x) - cl_fixnum i; + cl_fixnum i; @ - /* INV: ecl_to_size() signals a type-error if SIZE is not a integer >=0 */ - i = ecl_to_size(size); - while (i-- > 0) - x = CONS(initial_element, x); - @(return x) + /* INV: ecl_to_size() signals a type-error if SIZE is not a integer >=0 */ + i = ecl_to_size(size); + while (i-- > 0) + x = CONS(initial_element, x); + @(return x); @) cl_object cl_copy_list(cl_object x) { - cl_object copy; - if (ecl_unlikely(!LISTP(x))) { - FEwrong_type_only_arg(@[copy-list], x, @[list]); - } - copy = ECL_NIL; - if (!Null(x)) { - cl_object tail = copy = ecl_list1(CAR(x)); - while (x = ECL_CONS_CDR(x), CONSP(x)) { - cl_object cons = ecl_list1(ECL_CONS_CAR(x)); - ECL_RPLACD(tail, cons); - tail = cons; - } - ECL_RPLACD(tail, x); - } - @(return copy); + cl_object copy; + if (ecl_unlikely(!LISTP(x))) { + FEwrong_type_only_arg(@[copy-list], x, @[list]); + } + copy = ECL_NIL; + if (!Null(x)) { + cl_object tail = copy = ecl_list1(CAR(x)); + while (x = ECL_CONS_CDR(x), CONSP(x)) { + cl_object cons = ecl_list1(ECL_CONS_CAR(x)); + ECL_RPLACD(tail, cons); + tail = cons; + } + ECL_RPLACD(tail, x); + } + @(return copy); } static cl_object duplicate_pairs(cl_object x) { - cl_object p = ECL_CONS_CAR(x); - if (CONSP(p)) - p = CONS(ECL_CONS_CAR(p), ECL_CONS_CDR(p)); - return ecl_list1(p); + cl_object p = ECL_CONS_CAR(x); + if (CONSP(p)) + p = CONS(ECL_CONS_CAR(p), ECL_CONS_CDR(p)); + return ecl_list1(p); } cl_object cl_copy_alist(cl_object x) { - cl_object copy; - if (ecl_unlikely(!LISTP(x))) { - FEwrong_type_only_arg(@[copy-alist], x, @[list]); - } - copy = ECL_NIL; - if (!Null(x)) { - cl_object tail = copy = duplicate_pairs(x); - while (x = ECL_CONS_CDR(x), !Null(x)) { - if (!LISTP(x)) { - FEtype_error_list(x); - } else { - cl_object cons = duplicate_pairs(x); - tail = ECL_RPLACD(tail, cons); - tail = cons; - } - } - } - @(return copy); + cl_object copy; + if (ecl_unlikely(!LISTP(x))) { + FEwrong_type_only_arg(@[copy-alist], x, @[list]); + } + copy = ECL_NIL; + if (!Null(x)) { + cl_object tail = copy = duplicate_pairs(x); + while (x = ECL_CONS_CDR(x), !Null(x)) { + if (!LISTP(x)) { + FEtype_error_list(x); + } else { + cl_object cons = duplicate_pairs(x); + tail = ECL_RPLACD(tail, cons); + tail = cons; + } + } + } + @(return copy); } static cl_object do_copy_tree(cl_object x) { - if (CONSP(x)) { - x = CONS(do_copy_tree(ECL_CONS_CAR(x)), - do_copy_tree(ECL_CONS_CDR(x))); - } - return x; + if (CONSP(x)) { + x = CONS(do_copy_tree(ECL_CONS_CAR(x)), + do_copy_tree(ECL_CONS_CDR(x))); + } + return x; } cl_object cl_copy_tree(cl_object x) { - @(return do_copy_tree(x)) + @(return do_copy_tree(x)); } cl_object cl_revappend(cl_object x, cl_object y) { - loop_for_in(x) { - y = CONS(ECL_CONS_CAR(x),y); - } end_loop_for_in; - @(return y) + loop_for_in(x) { + y = CONS(ECL_CONS_CAR(x),y); + } end_loop_for_in; + @(return y); } @(defun nconc (&rest lists) - cl_object head = ECL_NIL, tail = ECL_NIL; + cl_object head = ECL_NIL, tail = ECL_NIL; @ - while (narg--) { - cl_object new_tail, other = ecl_va_arg(lists); - if (Null(other)) { - new_tail = tail; - } else if (CONSP(other)) { - new_tail = ecl_last(other, 1); - } else { - if (narg) FEtype_error_list(other); - new_tail = tail; - } - if (Null(head)) { - head = other; - } else { - ECL_RPLACD(tail, other); - } - tail = new_tail; - } - @(return head) + while (narg--) { + cl_object new_tail, other = ecl_va_arg(lists); + if (Null(other)) { + new_tail = tail; + } else if (CONSP(other)) { + new_tail = ecl_last(other, 1); + } else { + if (narg) FEtype_error_list(other); + new_tail = tail; + } + if (Null(head)) { + head = other; + } else { + ECL_RPLACD(tail, other); + } + tail = new_tail; + } + @(return head); @) cl_object ecl_nconc(cl_object l, cl_object y) { - if (Null(l)) { - return y; - } else { - ECL_RPLACD(ecl_last(l, 1), y); - return l; - } + if (Null(l)) { + return y; + } else { + ECL_RPLACD(ecl_last(l, 1), y); + return l; + } } cl_object cl_nreconc(cl_object l, cl_object y) { - cl_object x, z; - /* INV: when a circular list is "reconc'ed", the pointer ends - up at the beginning of the original list, hence we need no - slow pointer */ - for (x = l; !Null(x); ) { - if (!LISTP(x)) FEtype_error_list(x); - z = x; - x = ECL_CONS_CDR(x); - if (x == l) FEcircular_list(l); - ECL_RPLACD(z, y); - y = z; - } - @(return y) + cl_object x, z; + /* INV: when a circular list is "reconc'ed", the pointer ends + up at the beginning of the original list, hence we need no + slow pointer */ + for (x = l; !Null(x); ) { + if (!LISTP(x)) FEtype_error_list(x); + z = x; + x = ECL_CONS_CDR(x); + if (x == l) FEcircular_list(l); + ECL_RPLACD(z, y); + y = z; + } + @(return y); } cl_object ecl_butlast(cl_object l, cl_index n) { - /* See LAST for details on this algorithm */ - cl_object r; - for (r = l; n && CONSP(r); n--, r = ECL_CONS_CDR(r)) - ; - if (Null(r)) { - return ECL_NIL; - } else if (!LISTP(r)) { - /* We reach here either because l is shorter than n conses, - * or because it is not a list */ - if (r == l) FEtype_error_list(r); - return ECL_NIL; - } else { - /* We reach here because l has at least n conses and - * thus we can take CAR(l) */ - cl_object head, tail; - head = tail = ecl_list1(CAR(l)); - while (l = ECL_CONS_CDR(l), r = ECL_CONS_CDR(r), CONSP(r)) { - cl_object cons = ecl_list1(ECL_CONS_CAR(l)); - ECL_RPLACD(tail, cons); - tail = cons; - } - return head; - } + /* See LAST for details on this algorithm */ + cl_object r; + for (r = l; n && CONSP(r); n--, r = ECL_CONS_CDR(r)) + ; + if (Null(r)) { + return ECL_NIL; + } else if (!LISTP(r)) { + /* We reach here either because l is shorter than n conses, + * or because it is not a list */ + if (r == l) FEtype_error_list(r); + return ECL_NIL; + } else { + /* We reach here because l has at least n conses and + * thus we can take CAR(l) */ + cl_object head, tail; + head = tail = ecl_list1(CAR(l)); + while (l = ECL_CONS_CDR(l), r = ECL_CONS_CDR(r), CONSP(r)) { + cl_object cons = ecl_list1(ECL_CONS_CAR(l)); + ECL_RPLACD(tail, cons); + tail = cons; + } + return head; + } } @(defun butlast (lis &optional (nn ecl_make_fixnum(1))) -@ - /* INV: No list has more than MOST_POSITIVE_FIXNUM elements */ - if (ecl_t_of(nn) == t_bignum) - @(return ECL_NIL); - /* INV: ecl_to_size() signals a type-error if NN is not an integer >=0 */ - @(return ecl_butlast(lis, ecl_to_size(nn))) + @ + /* INV: No list has more than MOST_POSITIVE_FIXNUM elements */ + if (ecl_t_of(nn) == t_bignum) { + @(return ECL_NIL); + } + /* INV: ecl_to_size() signals a type-error if NN is not an integer >=0 */ + @(return ecl_butlast(lis, ecl_to_size(nn))); @) cl_object ecl_nbutlast(cl_object l, cl_index n) { - cl_object r; - if (ecl_unlikely(!LISTP(l))) - FEwrong_type_only_arg(@[nbutlast], l, @[list]); - for (n++, r = l; n && CONSP(r); n--, r = ECL_CONS_CDR(r)) - ; - if (n == 0) { - cl_object tail = l; - while (CONSP(r)) { - tail = ECL_CONS_CDR(tail); - r = ECL_CONS_CDR(r); - } - ECL_RPLACD(tail, ECL_NIL); - return l; - } - return ECL_NIL; + cl_object r; + if (ecl_unlikely(!LISTP(l))) + FEwrong_type_only_arg(@[nbutlast], l, @[list]); + for (n++, r = l; n && CONSP(r); n--, r = ECL_CONS_CDR(r)) + ; + if (n == 0) { + cl_object tail = l; + while (CONSP(r)) { + tail = ECL_CONS_CDR(tail); + r = ECL_CONS_CDR(r); + } + ECL_RPLACD(tail, ECL_NIL); + return l; + } + return ECL_NIL; } @(defun nbutlast (lis &optional (nn ecl_make_fixnum(1))) @ - /* INV: No list has more than MOST_POSITIVE_FIXNUM elements */ - if (ecl_t_of(nn) == t_bignum) - @(return ECL_NIL) - /* INV: ecl_to_size() signas a type-error if NN is not an integer >=0 */ - @(return ecl_nbutlast(lis, ecl_to_size(nn))) + /* INV: No list has more than MOST_POSITIVE_FIXNUM elements */ + if (ecl_t_of(nn) == t_bignum) { + @(return ECL_NIL); + } + /* INV: ecl_to_size() signas a type-error if NN is not an integer >=0 */ + @(return ecl_nbutlast(lis, ecl_to_size(nn))); @) cl_object cl_ldiff(cl_object x, cl_object y) { - cl_object head = ECL_NIL; - if (ecl_unlikely(!LISTP(x))) { - FEwrong_type_only_arg(@[ldiff], x, @[list]); - } - /* Here we use that, if X or Y are CONS, then (EQL X Y) - * only when X == Y */ - if (!Null(x) && (x != y)) { - cl_object tail = head = ecl_list1(ECL_CONS_CAR(x)); - while (1) { - x = ECL_CONS_CDR(x); - if (!CONSP(x)) { - if (!ecl_eql(x, y)) { - ECL_RPLACD(tail, x); - } - break; - } else if (x == y) { - break; - } else { - cl_object cons = ecl_list1(ECL_CONS_CAR(x)); - ECL_RPLACD(tail, cons); - tail = cons; - } - } - } - @(return head) + cl_object head = ECL_NIL; + if (ecl_unlikely(!LISTP(x))) { + FEwrong_type_only_arg(@[ldiff], x, @[list]); + } + /* Here we use that, if X or Y are CONS, then (EQL X Y) + * only when X == Y */ + if (!Null(x) && (x != y)) { + cl_object tail = head = ecl_list1(ECL_CONS_CAR(x)); + while (1) { + x = ECL_CONS_CDR(x); + if (!CONSP(x)) { + if (!ecl_eql(x, y)) { + ECL_RPLACD(tail, x); + } + break; + } else if (x == y) { + break; + } else { + cl_object cons = ecl_list1(ECL_CONS_CAR(x)); + ECL_RPLACD(tail, cons); + tail = cons; + } + } + } + @(return head); } cl_object cl_rplaca(cl_object x, cl_object v) { - if (ecl_unlikely(!CONSP(x))) - FEwrong_type_nth_arg(@[rplaca], 1, x, @[cons]); - ECL_RPLACA(x, v); - @(return x) + if (ecl_unlikely(!CONSP(x))) + FEwrong_type_nth_arg(@[rplaca], 1, x, @[cons]); + ECL_RPLACA(x, v); + @(return x); } cl_object cl_rplacd(cl_object x, cl_object v) { - if (ecl_unlikely(!CONSP(x))) - FEwrong_type_nth_arg(@[rplacd], 1, x, @[cons]); - ECL_RPLACD(x, v); - @(return x) + if (ecl_unlikely(!CONSP(x))) + FEwrong_type_nth_arg(@[rplacd], 1, x, @[cons]); + ECL_RPLACD(x, v); + @(return x); } @(defun subst (new_obj old_obj tree &key test test_not key) - struct cl_test t; - cl_object output; + struct cl_test t; + cl_object output; @ - setup_test(&t, old_obj, test, test_not, key); - output = subst(&t, new_obj, tree); - close_test(&t); - @(return output) + setup_test(&t, old_obj, test, test_not, key); + output = subst(&t, new_obj, tree); + close_test(&t); + @(return output); @) static cl_object subst(struct cl_test *t, cl_object new_obj, cl_object tree) { - if (TEST(t, tree)) { - return new_obj; - } else if (ECL_ATOM(tree)) { - return tree; - } else { - cl_object head, tail = ECL_NIL; - do { - cl_object cons = subst(t, new_obj, ECL_CONS_CAR(tree)); - cons = ecl_cons(cons, tree = ECL_CONS_CDR(tree)); - if (Null(tail)) { - head = cons; - } else { - ECL_RPLACD(tail, cons); - } - tail = cons; - if (TEST(t, tree)) { - ECL_RPLACD(tail, new_obj); - return head; - } - } while (CONSP(tree)); - return head; - } + if (TEST(t, tree)) { + return new_obj; + } else if (ECL_ATOM(tree)) { + return tree; + } else { + cl_object head, tail = ECL_NIL; + do { + cl_object cons = subst(t, new_obj, ECL_CONS_CAR(tree)); + cons = ecl_cons(cons, tree = ECL_CONS_CDR(tree)); + if (Null(tail)) { + head = cons; + } else { + ECL_RPLACD(tail, cons); + } + tail = cons; + if (TEST(t, tree)) { + ECL_RPLACD(tail, new_obj); + return head; + } + } while (CONSP(tree)); + return head; + } } @(defun nsubst (new_obj old_obj tree &key test test_not key) - struct cl_test t; + struct cl_test t; @ - setup_test(&t, old_obj, test, test_not, key); - tree = nsubst(&t, new_obj, tree); - close_test(&t); - @(return tree) + setup_test(&t, old_obj, test, test_not, key); + tree = nsubst(&t, new_obj, tree); + close_test(&t); + @(return tree); @) static cl_object nsubst_cons(struct cl_test *t, cl_object new_obj, cl_object tree) { - cl_object l = tree; - do { - cl_object o = ECL_CONS_CAR(l); - if (TEST(t, o)) { - ECL_RPLACA(l, new_obj); - } else if (CONSP(o)) { - nsubst_cons(t, new_obj, o); - } - o = ECL_CONS_CDR(l); - if (TEST(t, o)) { - ECL_RPLACD(l, new_obj); - return tree; - } - l = o; - } while (CONSP(l)); - return tree; + cl_object l = tree; + do { + cl_object o = ECL_CONS_CAR(l); + if (TEST(t, o)) { + ECL_RPLACA(l, new_obj); + } else if (CONSP(o)) { + nsubst_cons(t, new_obj, o); + } + o = ECL_CONS_CDR(l); + if (TEST(t, o)) { + ECL_RPLACD(l, new_obj); + return tree; + } + l = o; + } while (CONSP(l)); + return tree; } static cl_object nsubst(struct cl_test *t, cl_object new_obj, cl_object tree) { - if (TEST(t, tree)) - return new_obj; - if (CONSP(tree)) - return nsubst_cons(t, new_obj, tree); - return tree; + if (TEST(t, tree)) + return new_obj; + if (CONSP(tree)) + return nsubst_cons(t, new_obj, tree); + return tree; } @(defun sublis (alist tree &key test test_not key) - /* t[0] is the test for the objects in the tree, configured - with test, test_not and key. t[1] is the test for searching - in the association list. - */ - struct cl_test t[2]; + /* t[0] is the test for the objects in the tree, configured + with test, test_not and key. t[1] is the test for searching + in the association list. + */ + struct cl_test t[2]; @ - setup_test(t, ECL_NIL, ECL_NIL, ECL_NIL, key); - setup_test(t+1, ECL_NIL, test, test_not, ECL_NIL); - tree = sublis(t, alist, tree); - close_test(t+1); - close_test(t); - @(return tree) + setup_test(t, ECL_NIL, ECL_NIL, ECL_NIL, key); + setup_test(t+1, ECL_NIL, test, test_not, ECL_NIL); + tree = sublis(t, alist, tree); + close_test(t+1); + close_test(t); + @(return tree); @) /* - Sublis(alist, tree) returns - result of substituting tree by alist. + Sublis(alist, tree) returns + result of substituting tree by alist. */ static cl_object sublis(struct cl_test *t, cl_object alist, cl_object tree) { - cl_object node; - t[1].item_compared = KEY(t, tree); - node = do_assoc(t+1, alist); - if (!Null(node)) { - return ECL_CONS_CDR(node); - } - if (CONSP(tree)) { - tree = CONS(sublis(t, alist, ECL_CONS_CAR(tree)), - sublis(t, alist, ECL_CONS_CDR(tree))); - } - return tree; + cl_object node; + t[1].item_compared = KEY(t, tree); + node = do_assoc(t+1, alist); + if (!Null(node)) { + return ECL_CONS_CDR(node); + } + if (CONSP(tree)) { + tree = CONS(sublis(t, alist, ECL_CONS_CAR(tree)), + sublis(t, alist, ECL_CONS_CDR(tree))); + } + return tree; } @(defun nsublis (alist tree &key test test_not key) - /* t[0] is the test for the objects in the tree, configured - with test, test_not and key. t[1] is the test for searching - in the association list. - */ - struct cl_test t[2]; + /* t[0] is the test for the objects in the tree, configured + with test, test_not and key. t[1] is the test for searching + in the association list. + */ + struct cl_test t[2]; @ - setup_test(t, ECL_NIL, ECL_NIL, ECL_NIL, key); - setup_test(t+1, ECL_NIL, test, test_not, ECL_NIL); - tree = nsublis(t, alist, tree); - close_test(t+1); - close_test(t); - @(return tree) + setup_test(t, ECL_NIL, ECL_NIL, ECL_NIL, key); + setup_test(t+1, ECL_NIL, test, test_not, ECL_NIL); + tree = nsublis(t, alist, tree); + close_test(t+1); + close_test(t); + @(return tree); @) /* - Nsublis(alist, treep) stores - the result of substiting *treep by alist - to *treep. + Nsublis(alist, treep) stores + the result of substiting *treep by alist + to *treep. */ static cl_object nsublis(struct cl_test *t, cl_object alist, cl_object tree) { - cl_object node; - t[1].item_compared = KEY(t, tree); - node = do_assoc(t+1, alist); - if (!Null(node)) { - return ECL_CONS_CDR(node); - } - if (CONSP(tree)) { - ECL_RPLACA(tree, nsublis(t, alist, ECL_CONS_CAR(tree))); - ECL_RPLACD(tree, nsublis(t, alist, ECL_CONS_CDR(tree))); - } - return tree; + cl_object node; + t[1].item_compared = KEY(t, tree); + node = do_assoc(t+1, alist); + if (!Null(node)) { + return ECL_CONS_CDR(node); + } + if (CONSP(tree)) { + ECL_RPLACA(tree, nsublis(t, alist, ECL_CONS_CAR(tree))); + ECL_RPLACD(tree, nsublis(t, alist, ECL_CONS_CDR(tree))); + } + return tree; } @(defun member (item list &key test test_not key) - struct cl_test t; + struct cl_test t; @ - setup_test(&t, item, test, test_not, key); - loop_for_in(list) { - if (TEST(&t, ECL_CONS_CAR(list))) - break; - } end_loop_for_in; - close_test(&t); - @(return list) + setup_test(&t, item, test, test_not, key); + loop_for_in(list) { + if (TEST(&t, ECL_CONS_CAR(list))) + break; + } end_loop_for_in; + close_test(&t); + @(return list); @) bool ecl_member_eq(cl_object x, cl_object l) { - loop_for_in(l) { - if (x == ECL_CONS_CAR(l)) - return(TRUE); - } end_loop_for_in; - return(FALSE); + loop_for_in(l) { + if (x == ECL_CONS_CAR(l)) + return(TRUE); + } end_loop_for_in; + return(FALSE); } cl_object si_memq(cl_object x, cl_object l) { - loop_for_in(l) { - if (x == ECL_CONS_CAR(l)) - @(return l) - } end_loop_for_in; - @(return ECL_NIL) + loop_for_in(l) { + if (x == ECL_CONS_CAR(l)) { + @(return l); + } + } end_loop_for_in; + @(return ECL_NIL); } /* Added for use by the compiler, instead of open coding them. Beppe */ cl_object ecl_memql(cl_object x, cl_object l) { - loop_for_in(l) { - if (ecl_eql(x, ECL_CONS_CAR(l))) - return(l); - } end_loop_for_in; - return(ECL_NIL); + loop_for_in(l) { + if (ecl_eql(x, ECL_CONS_CAR(l))) + return(l); + } end_loop_for_in; + return(ECL_NIL); } cl_object ecl_member(cl_object x, cl_object l) { - loop_for_in(l) { - if (ecl_equal(x, ECL_CONS_CAR(l))) - return(l); - } end_loop_for_in; - return(ECL_NIL); + loop_for_in(l) { + if (ecl_equal(x, ECL_CONS_CAR(l))) + return(l); + } end_loop_for_in; + return(ECL_NIL); } /* End of addition. Beppe */ cl_object si_member1(cl_object item, cl_object list, cl_object test, cl_object test_not, cl_object key) { - struct cl_test t; + struct cl_test t; - if (key != ECL_NIL) - item = funcall(2, key, item); - setup_test(&t, item, test, test_not, key); - loop_for_in(list) { - if (TEST(&t, ECL_CONS_CAR(list))) - break; - } end_loop_for_in; - close_test(&t); - @(return list) + if (key != ECL_NIL) + item = funcall(2, key, item); + setup_test(&t, item, test, test_not, key); + loop_for_in(list) { + if (TEST(&t, ECL_CONS_CAR(list))) + break; + } end_loop_for_in; + close_test(&t); + @(return list); } cl_object cl_tailp(cl_object y, cl_object x) { - loop_for_on(x) { - if (ecl_eql(x, y)) @(return ECL_T); - } end_loop_for_on(x); - return cl_eql(x, y); + loop_for_on(x) { + if (ecl_eql(x, y)) { + @(return ECL_T); + } + } end_loop_for_on(x); + return cl_eql(x, y); } @(defun adjoin (item list &key test test_not key) - cl_object output; + cl_object output; @ - if (narg < 2) - FEwrong_num_arguments(@[adjoin]); - output = @si::member1(item, list, test, test_not, key); - if (Null(output)) - output = CONS(item, list); - else - output = list; - @(return output) + if (narg < 2) + FEwrong_num_arguments(@[adjoin]); + output = @si::member1(item, list, test, test_not, key); + if (Null(output)) + output = CONS(item, list); + else + output = list; + @(return output); @) cl_object cl_cons(cl_object x, cl_object y) { - @(return CONS(x, y)) + @(return CONS(x, y)); } cl_object cl_acons(cl_object x, cl_object y, cl_object z) { - @(return CONS(CONS(x, y), z)) + @(return CONS(CONS(x, y), z)); } @(defun pairlis (keys data &optional a_list) - cl_object k, d; + cl_object k, d; @ - k = keys; - d = data; - loop_for_in(k) { - if (ecl_endp(d)) - goto error; - a_list = CONS(CONS(ECL_CONS_CAR(k), ECL_CONS_CAR(d)), a_list); - d = CDR(d); - } end_loop_for_in; - if (!ecl_endp(d)) -error: FEerror("The keys ~S and the data ~S are not of the same length", - 2, keys, data); - @(return a_list) + k = keys; + d = data; + loop_for_in(k) { + if (ecl_endp(d)) + goto error; + a_list = CONS(CONS(ECL_CONS_CAR(k), ECL_CONS_CAR(d)), a_list); + d = CDR(d); + } end_loop_for_in; + if (!ecl_endp(d)) + error: + FEerror("The keys ~S and the data ~S are not of the same length", + 2, keys, data); + @(return a_list); @) @(defun assoc (item a_list &key test test_not key) - struct cl_test t; + struct cl_test t; @ - setup_test(&t, item, test, test_not, key); - a_list = do_assoc(&t, a_list); - close_test(&t); - @(return a_list) + setup_test(&t, item, test, test_not, key); + a_list = do_assoc(&t, a_list); + close_test(&t); + @(return a_list); @) static cl_object do_assoc(struct cl_test *t, cl_object a_list) { - loop_for_in(a_list) { - cl_object pair = ECL_CONS_CAR(a_list); - if (!Null(pair)) { - if (!LISTP(pair)) - FEtype_error_list(pair); - if (TEST(t, ECL_CONS_CAR(pair))) - return pair; - } - } end_loop_for_in; - return ECL_NIL; + loop_for_in(a_list) { + cl_object pair = ECL_CONS_CAR(a_list); + if (!Null(pair)) { + if (!LISTP(pair)) + FEtype_error_list(pair); + if (TEST(t, ECL_CONS_CAR(pair))) + return pair; + } + } end_loop_for_in; + return ECL_NIL; } @(defun rassoc (item a_list &key test test_not key) - struct cl_test t; + struct cl_test t; @ - setup_test(&t, item, test, test_not, key); - loop_for_in(a_list) { - cl_object pair = ECL_CONS_CAR(a_list); - if (!Null(pair)) { - if (!LISTP(pair)) - FEtype_error_list(pair); - if (TEST(&t, ECL_CONS_CDR(pair))) { - a_list = pair; - break; - } - } - } end_loop_for_in; - close_test(&t); - @(return a_list) + setup_test(&t, item, test, test_not, key); + loop_for_in(a_list) { + cl_object pair = ECL_CONS_CAR(a_list); + if (!Null(pair)) { + if (!LISTP(pair)) + FEtype_error_list(pair); + if (TEST(&t, ECL_CONS_CDR(pair))) { + a_list = pair; + break; + } + } + } end_loop_for_in; + close_test(&t); + @(return a_list); @) cl_object ecl_remove_eq(cl_object x, cl_object l) { - cl_object head = ECL_NIL, tail = ECL_NIL; - loop_for_on_unsafe(l) { - if (ECL_CONS_CAR(l) != x) { - cl_object cons = ecl_list1(ECL_CONS_CAR(l)); - if (Null(tail)) { - head = tail = cons; - } else { - ECL_RPLACD(tail, cons); - tail = cons; - } - } - } end_loop_for_on_unsafe(l); - return head; + cl_object head = ECL_NIL, tail = ECL_NIL; + loop_for_on_unsafe(l) { + if (ECL_CONS_CAR(l) != x) { + cl_object cons = ecl_list1(ECL_CONS_CAR(l)); + if (Null(tail)) { + head = tail = cons; + } else { + ECL_RPLACD(tail, cons); + tail = cons; + } + } + } end_loop_for_on_unsafe(l); + return head; } cl_object ecl_delete_eq(cl_object x, cl_object l) { - cl_object head = l; - cl_object *p = &head; - while (!ECL_ATOM(l)) { - if (ECL_CONS_CAR(l) == x) { - *p = l = ECL_CONS_CDR(l); - } else { - p = &ECL_CONS_CDR(l); - l = *p; - } - } - return head; + cl_object head = l; + cl_object *p = &head; + while (!ECL_ATOM(l)) { + if (ECL_CONS_CAR(l) == x) { + *p = l = ECL_CONS_CDR(l); + } else { + p = &ECL_CONS_CDR(l); + l = *p; + } + } + return head; } /* Added for use by the compiler, instead of open coding them. Beppe */ cl_object ecl_assq(cl_object x, cl_object l) { - loop_for_in(l) { - cl_object pair = ECL_CONS_CAR(l); - if (x == CAR(pair)) - return pair; - } end_loop_for_in; - return(ECL_NIL); + loop_for_in(l) { + cl_object pair = ECL_CONS_CAR(l); + if (x == CAR(pair)) + return pair; + } end_loop_for_in; + return(ECL_NIL); } cl_object ecl_assql(cl_object x, cl_object l) { - loop_for_in(l) { - cl_object pair = ECL_CONS_CAR(l); - if (ecl_eql(x, CAR(pair))) - return pair; - } end_loop_for_in; - return(ECL_NIL); + loop_for_in(l) { + cl_object pair = ECL_CONS_CAR(l); + if (ecl_eql(x, CAR(pair))) + return pair; + } end_loop_for_in; + return(ECL_NIL); } cl_object ecl_assoc(cl_object x, cl_object l) { - loop_for_in(l) { - cl_object pair = ECL_CONS_CAR(l); - if (ecl_equal(x, CAR(pair))) - return pair; - } end_loop_for_in; - return(ECL_NIL); + loop_for_in(l) { + cl_object pair = ECL_CONS_CAR(l); + if (ecl_equal(x, CAR(pair))) + return pair; + } end_loop_for_in; + return(ECL_NIL); } cl_object ecl_assqlp(cl_object x, cl_object l) { - loop_for_in(l) { - cl_object pair = ECL_CONS_CAR(l); - if (ecl_equalp(x, CAR(pair))) - return pair; - } end_loop_for_in; - return(ECL_NIL); + loop_for_in(l) { + cl_object pair = ECL_CONS_CAR(l); + if (ecl_equalp(x, CAR(pair))) + return pair; + } end_loop_for_in; + return(ECL_NIL); } /* End of addition. Beppe */ diff -Nru ecl-16.1.2/src/c/load.d ecl-16.1.3+ds/src/c/load.d --- ecl-16.1.2/src/c/load.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/load.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,20 +1,15 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - load.d -- Binary loader (contains also open_fasl_data). -*/ -/* - Copyright (c) 1990, Giuseppe Attardi and William F. Schelter. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * load.d - binary loader (contains also open_fasl_data) + * + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -25,280 +20,285 @@ si_load_binary(cl_object filename, cl_object verbose, cl_object print, cl_object external_format) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object block, map, array; - cl_object basename; - cl_object init_prefix, prefix; - cl_object output; - - /* We need the full pathname */ - filename = cl_truename(filename); - - /* Try to load shared object file */ - block = ecl_library_open(filename, 1); - if (block->cblock.handle == NULL) { - output = ecl_library_error(block); - goto OUTPUT; - } - - /* Fist try to call "init_CODE()" */ - init_prefix = _ecl_library_default_entry(); - block->cblock.entry = - ecl_library_symbol(block, (char *)init_prefix->base_string.self, 0); - if (block->cblock.entry != NULL) - goto GO_ON; - - /* Next try to call "init_FILE()" where FILE is the file name */ - prefix = ecl_symbol_value(@'si::*init-function-prefix*'); - init_prefix = _ecl_library_init_prefix(); - if (Null(prefix)) { - prefix = init_prefix; - } else { - prefix = @si::base-string-concatenate(3, - init_prefix, - prefix, - make_constant_base_string("_")); - } - basename = cl_pathname_name(1,filename); - basename = @si::base-string-concatenate(2, prefix, @string-upcase(1, funcall(4, @'nsubstitute', ECL_CODE_CHAR('_'), ECL_CODE_CHAR('-'), basename))); - block->cblock.entry = ecl_library_symbol(block, (char*)basename->base_string.self, 0); - - if (block->cblock.entry == NULL) { - output = ecl_library_error(block); - ecl_library_close(block); - goto OUTPUT; - } - -GO_ON: - /* Finally, perform initialization */ - ecl_init_module(block, (void (*)(cl_object))(block->cblock.entry)); - output = ECL_NIL; -OUTPUT: - ecl_return1(the_env, output); + const cl_env_ptr the_env = ecl_process_env(); + cl_object block, map, array; + cl_object basename; + cl_object init_prefix, prefix; + cl_object output; + + /* We need the full pathname */ + filename = cl_truename(filename); + + /* Try to load shared object file */ + block = ecl_library_open(filename, 1); + if (block->cblock.handle == NULL) { + output = ecl_library_error(block); + goto OUTPUT; + } + + /* Fist try to call "init_CODE()" */ + init_prefix = _ecl_library_default_entry(); + block->cblock.entry = + ecl_library_symbol(block, (char *)init_prefix->base_string.self, 0); + if (block->cblock.entry != NULL) + goto GO_ON; + + /* Next try to call "init_FILE()" where FILE is the file name */ + prefix = ecl_symbol_value(@'si::*init-function-prefix*'); + init_prefix = _ecl_library_init_prefix(); + if (Null(prefix)) { + prefix = init_prefix; + } else { + prefix = @si::base-string-concatenate(3, + init_prefix, + prefix, + make_constant_base_string("_")); + } + basename = cl_pathname_name(1,filename); + basename = @si::base-string-concatenate(2, prefix, @string-upcase(1, funcall(4, @'nsubstitute', ECL_CODE_CHAR('_'), ECL_CODE_CHAR('-'), basename))); + block->cblock.entry = ecl_library_symbol(block, (char*)basename->base_string.self, 0); + + if (block->cblock.entry == NULL) { + output = ecl_library_error(block); + ecl_library_close(block); + goto OUTPUT; + } + + GO_ON: + /* Finally, perform initialization */ + ecl_init_module(block, (void (*)(cl_object))(block->cblock.entry)); + output = ECL_NIL; + OUTPUT: + ecl_return1(the_env, output); } #endif /* !ENABLE_DLOPEN */ cl_object si_load_source(cl_object source, cl_object verbose, cl_object print, cl_object external_format) { - cl_env_ptr the_env = ecl_process_env(); - cl_object x, strm; + cl_env_ptr the_env = ecl_process_env(); + cl_object x, strm; - /* Source may be either a stream or a filename */ - if (ecl_t_of(source) != t_pathname && ecl_t_of(source) != t_base_string) { - /* INV: if "source" is not a valid stream, file.d will complain */ - strm = source; - } else { - strm = ecl_open_stream(source, ecl_smm_input, ECL_NIL, ECL_NIL, 8, - ECL_STREAM_C_STREAM, external_format); - if (Null(strm)) - @(return ECL_NIL) + /* Source may be either a stream or a filename */ + if (ecl_t_of(source) != t_pathname && ecl_t_of(source) != t_base_string) { + /* INV: if "source" is not a valid stream, file.d will complain */ + strm = source; + } + else { + strm = ecl_open_stream(source, ecl_smm_input, ECL_NIL, ECL_NIL, 8, + ECL_STREAM_C_STREAM, external_format); + if (Null(strm)) { + @(return ECL_NIL); + } + } + ECL_UNWIND_PROTECT_BEGIN(the_env) { + cl_object form_index = ecl_make_fixnum(0); + cl_object pathname = ECL_SYM_VAL(the_env, @'*load-pathname*'); + cl_object location = CONS(pathname, form_index); + ecl_bds_bind(the_env, @'ext::*source-location*', location); + for (;;) { + form_index = ecl_file_position(strm); + ECL_RPLACD(location, form_index); + x = si_read_object_or_ignore(strm, OBJNULL); + if (x == OBJNULL) + break; + if (the_env->nvalues) { + si_eval_with_env(1, x); + if (print != ECL_NIL) { + @write(1, x); + @terpri(0); } - ECL_UNWIND_PROTECT_BEGIN(the_env) { - cl_object form_index = ecl_make_fixnum(0); - cl_object pathname = ECL_SYM_VAL(the_env, @'*load-pathname*'); - cl_object location = CONS(pathname, form_index); - ecl_bds_bind(the_env, @'ext::*source-location*', location); - for (;;) { - form_index = ecl_file_position(strm); - ECL_RPLACD(location, form_index); - x = si_read_object_or_ignore(strm, OBJNULL); - if (x == OBJNULL) - break; - if (the_env->nvalues) { - si_eval_with_env(1, x); - if (print != ECL_NIL) { - @write(1, x); - @terpri(0); - } - } - } - ecl_bds_unwind1(the_env); - } ECL_UNWIND_PROTECT_EXIT { - /* We do not want to come back here if close_stream fails, - therefore, first we frs_pop() current jump point, then - try to close the stream, and then jump to next catch - point */ - if (strm != source) - cl_close(3, strm, @':abort', @'t'); - } ECL_UNWIND_PROTECT_END; - @(return ECL_NIL) + } + } + ecl_bds_unwind1(the_env); + } ECL_UNWIND_PROTECT_EXIT { + /* We do not want to come back here if close_stream fails, + therefore, first we frs_pop() current jump point, then + try to close the stream, and then jump to next catch + point */ + if (strm != source) + cl_close(3, strm, @':abort', @'t'); + } ECL_UNWIND_PROTECT_END; + @(return ECL_NIL); } cl_object si_load_bytecodes(cl_object source, cl_object verbose, cl_object print, cl_object external_format) { - cl_env_ptr env = ecl_process_env(); - cl_object forms, strm; - cl_object old_eptbc = env->packages_to_be_created; - - /* Source may be either a stream or a filename */ - if (ecl_t_of(source) != t_pathname && ecl_t_of(source) != t_base_string) { - /* INV: if "source" is not a valid stream, file.d will complain */ - strm = source; - } else { - strm = ecl_open_stream(source, ecl_smm_input, ECL_NIL, ECL_NIL, 8, - ECL_STREAM_C_STREAM, external_format); - if (Null(strm)) - @(return ECL_NIL) - } - ECL_UNWIND_PROTECT_BEGIN(env) { - { - cl_object progv_list = ECL_SYM_VAL(env, @'si::+ecl-syntax-progv-list+'); - cl_index bds_ndx = ecl_progv(env, ECL_CONS_CAR(progv_list), - ECL_CONS_CDR(progv_list)); - env->packages_to_be_created_p = ECL_T; - forms = cl_read(1, strm); - env->packages_to_be_created_p = ECL_NIL; - ecl_bds_unwind(env, bds_ndx); - } - while (!Null(forms)) { - if (ECL_LISTP(forms)) { - cl_object x = ECL_CONS_CAR(forms); - forms = ECL_CONS_CDR(forms); - if (ecl_t_of(x) == t_bytecodes) { - _ecl_funcall1(x); - continue; - } - } - FEerror("Corrupt bytecodes file ~S", 1, source); - } - { - cl_object x; - x = cl_set_difference(2, env->packages_to_be_created, old_eptbc); - old_eptbc = env->packages_to_be_created; - unlikely_if (!Null(x)) { - CEerror(ECL_T, - Null(ECL_CONS_CDR(x))? - "Package ~A referenced in " - "compiled file~& ~A~&but has not been created": - "The packages~& ~A~&were referenced in " - "compiled file~& ~A~&but have not been created", - 2, x, source); - } - } - } ECL_UNWIND_PROTECT_EXIT { - /* We do not want to come back here if close_stream fails, - therefore, first we frs_pop() current jump point, then - try to close the stream, and then jump to next catch - point */ - if (strm != source) - cl_close(3, strm, @':abort', @'t'); - } ECL_UNWIND_PROTECT_END; - @(return ECL_NIL) + cl_env_ptr env = ecl_process_env(); + cl_object forms, strm; + cl_object old_eptbc = env->packages_to_be_created; + + /* Source may be either a stream or a filename */ + if (ecl_t_of(source) != t_pathname && ecl_t_of(source) != t_base_string) { + /* INV: if "source" is not a valid stream, file.d will complain */ + strm = source; + } else { + strm = ecl_open_stream(source, ecl_smm_input, ECL_NIL, ECL_NIL, 8, + ECL_STREAM_C_STREAM, external_format); + if (Null(strm)) { + @(return ECL_NIL); + } + } + ECL_UNWIND_PROTECT_BEGIN(env) { + { + cl_object progv_list = ECL_SYM_VAL(env, @'si::+ecl-syntax-progv-list+'); + cl_index bds_ndx = ecl_progv(env, ECL_CONS_CAR(progv_list), + ECL_CONS_CDR(progv_list)); + env->packages_to_be_created_p = ECL_T; + forms = cl_read(1, strm); + env->packages_to_be_created_p = ECL_NIL; + ecl_bds_unwind(env, bds_ndx); + } + while (!Null(forms)) { + if (ECL_LISTP(forms)) { + cl_object x = ECL_CONS_CAR(forms); + forms = ECL_CONS_CDR(forms); + if (ecl_t_of(x) == t_bytecodes) { + _ecl_funcall1(x); + continue; + } + } + FEerror("Corrupt bytecodes file ~S", 1, source); + } + { + cl_object x; + x = cl_set_difference(2, env->packages_to_be_created, old_eptbc); + old_eptbc = env->packages_to_be_created; + unlikely_if (!Null(x)) { + CEerror(ECL_T, + Null(ECL_CONS_CDR(x))? + "Package ~A referenced in " + "compiled file~& ~A~&but has not been created": + "The packages~& ~A~&were referenced in " + "compiled file~& ~A~&but have not been created", + 2, x, source); + } + } + } ECL_UNWIND_PROTECT_EXIT { + /* We do not want to come back here if close_stream fails, + therefore, first we frs_pop() current jump point, then + try to close the stream, and then jump to next catch + point */ + if (strm != source) + cl_close(3, strm, @':abort', @'t'); + } ECL_UNWIND_PROTECT_END; + @(return ECL_NIL); } @(defun load (source &key (verbose ecl_symbol_value(@'*load-verbose*')) - (print ecl_symbol_value(@'*load-print*')) - (if_does_not_exist @':error') - (external_format @':default') - (search_list ecl_symbol_value(@'si::*load-search-list*')) + (print ecl_symbol_value(@'*load-print*')) + (if_does_not_exist @':error') + (external_format @':default') + (search_list ecl_symbol_value(@'si::*load-search-list*')) &aux pathname pntype hooks filename function ok) - bool not_a_filename = 0; + bool not_a_filename = 0; @ - /* If source is a stream, read conventional lisp code from it */ - if (ecl_t_of(source) != t_pathname && !ecl_stringp(source)) { - /* INV: if "source" is not a valid stream, file.d will complain */ - filename = source; - function = ECL_NIL; - not_a_filename = 1; - goto NOT_A_FILENAME; - } - /* INV: coerce_to_file_pathname() creates a fresh new pathname object */ - source = cl_merge_pathnames(1, source); - pathname = coerce_to_file_pathname(source); - pntype = pathname->pathname.type; - + /* If source is a stream, read conventional lisp code from it */ + if (ecl_t_of(source) != t_pathname && !ecl_stringp(source)) { + /* INV: if "source" is not a valid stream, file.d will complain */ + filename = source; + function = ECL_NIL; + not_a_filename = 1; + goto NOT_A_FILENAME; + } + /* INV: coerce_to_file_pathname() creates a fresh new pathname object */ + source = cl_merge_pathnames(1, source); + pathname = coerce_to_file_pathname(source); + pntype = pathname->pathname.type; + + filename = ECL_NIL; + hooks = ecl_symbol_value(@'ext::*load-hooks*'); + if (Null(pathname->pathname.directory) && + Null(pathname->pathname.host) && + Null(pathname->pathname.device) && + !Null(search_list)) + { + loop_for_in(search_list) { + cl_object d = CAR(search_list); + cl_object f = cl_merge_pathnames(2, pathname, d); + cl_object ok = cl_load(11, f, @':verbose', verbose, + @':print', print, + @':if-does-not-exist', ECL_NIL, + @':external-format', external_format, + @':search-list', ECL_NIL); + if (!Null(ok)) { + @(return ok); + } + } end_loop_for_in; + } + if (!Null(pntype) && (pntype != @':wild')) { + /* If filename already has an extension, make sure + that the file exists */ + cl_object kind; + filename = si_coerce_to_filename(pathname); + kind = si_file_kind(filename, ECL_T); + if (kind != @':file' && kind != @':special') { + filename = ECL_NIL; + } else { + function = cl_cdr(ecl_assoc(pathname->pathname.type, hooks)); + } + } else loop_for_in(hooks) { + /* Otherwise try with known extensions until a matching + file is found */ + cl_object kind; + filename = pathname; + filename->pathname.type = CAAR(hooks); + function = CDAR(hooks); + kind = si_file_kind(filename, ECL_T); + if (kind == @':file' || kind == @':special') + break; + else filename = ECL_NIL; - hooks = ecl_symbol_value(@'ext::*load-hooks*'); - if (Null(pathname->pathname.directory) && - Null(pathname->pathname.host) && - Null(pathname->pathname.device) && - !Null(search_list)) - { - loop_for_in(search_list) { - cl_object d = CAR(search_list); - cl_object f = cl_merge_pathnames(2, pathname, d); - cl_object ok = cl_load(11, f, @':verbose', verbose, - @':print', print, - @':if-does-not-exist', ECL_NIL, - @':external-format', external_format, - @':search-list', ECL_NIL); - if (!Null(ok)) { - @(return ok); - } - } end_loop_for_in; - } - if (!Null(pntype) && (pntype != @':wild')) { - /* If filename already has an extension, make sure - that the file exists */ - cl_object kind; - filename = si_coerce_to_filename(pathname); - kind = si_file_kind(filename, ECL_T); - if (kind != @':file' && kind != @':special') { - filename = ECL_NIL; - } else { - function = cl_cdr(ecl_assoc(pathname->pathname.type, hooks)); - } - } else loop_for_in(hooks) { - /* Otherwise try with known extensions until a matching - file is found */ - cl_object kind; - filename = pathname; - filename->pathname.type = CAAR(hooks); - function = CDAR(hooks); - kind = si_file_kind(filename, ECL_T); - if (kind == @':file' || kind == @':special') - break; - else - filename = ECL_NIL; - } end_loop_for_in; - if (Null(filename)) { - if (Null(if_does_not_exist)) - @(return ECL_NIL) - else - FEcannot_open(source); - } -NOT_A_FILENAME: - if (verbose != ECL_NIL) { - cl_format(3, ECL_T, make_constant_base_string("~&;;; Loading ~s~%"), - filename); - } - ecl_bds_bind(the_env, @'*package*', ecl_symbol_value(@'*package*')); - ecl_bds_bind(the_env, @'*readtable*', ecl_symbol_value(@'*readtable*')); - ecl_bds_bind(the_env, @'*load-pathname*', not_a_filename? ECL_NIL : source); - ecl_bds_bind(the_env, @'*load-truename*', - not_a_filename? ECL_NIL : (filename = cl_truename(filename))); - if (!Null(function)) { - ok = funcall(5, function, filename, verbose, print, external_format); - } else { + } end_loop_for_in; + if (Null(filename)) { + if (Null(if_does_not_exist)) { + @(return ECL_NIL); + } + else { + FEcannot_open(source); + } + } + NOT_A_FILENAME: + if (verbose != ECL_NIL) { + cl_format(3, ECL_T, make_constant_base_string("~&;;; Loading ~s~%"), + filename); + } + ecl_bds_bind(the_env, @'*package*', ecl_symbol_value(@'*package*')); + ecl_bds_bind(the_env, @'*readtable*', ecl_symbol_value(@'*readtable*')); + ecl_bds_bind(the_env, @'*load-pathname*', not_a_filename? ECL_NIL : source); + ecl_bds_bind(the_env, @'*load-truename*', + not_a_filename? ECL_NIL : (filename = cl_truename(filename))); + if (!Null(function)) { + ok = funcall(5, function, filename, verbose, print, external_format); + } else { #if 0 /* defined(ENABLE_DLOPEN) && !defined(ECL_MS_WINDOWS_HOST)*/ - /* - * DISABLED BECAUSE OF SECURITY ISSUES! - * In systems where we can do this, we try to load the file - * as a binary. When it fails, we will revert to source - * loading below. Is this safe? Well, it depends on whether - * your op.sys. checks integrity of binary exectables or - * just loads _anything_. - */ - if (not_a_filename) { - ok = ECL_T; - } else { - ok = si_load_binary(filename, verbose, print); - } - if (!Null(ok)) + /* + * DISABLED BECAUSE OF SECURITY ISSUES! + * In systems where we can do this, we try to load the file + * as a binary. When it fails, we will revert to source + * loading below. Is this safe? Well, it depends on whether + * your op.sys. checks integrity of binary exectables or + * just loads _anything_. + */ + if (not_a_filename) { + ok = ECL_T; + } else { + ok = si_load_binary(filename, verbose, print); + } + if (!Null(ok)) #endif - ok = si_load_source(filename, verbose, print, external_format); - } - ecl_bds_unwind_n(the_env, 4); - if (!Null(ok)) - FEerror("LOAD: Could not load file ~S (Error: ~S)", - 2, filename, ok); - if (print != ECL_NIL) { - cl_format(3, ECL_T, make_constant_base_string("~&;;; Loading ~s~%"), - filename); - } - @(return filename) + ok = si_load_source(filename, verbose, print, external_format); + } + ecl_bds_unwind_n(the_env, 4); + if (!Null(ok)) + FEerror("LOAD: Could not load file ~S (Error: ~S)", + 2, filename, ok); + if (print != ECL_NIL) { + cl_format(3, ECL_T, make_constant_base_string("~&;;; Loading ~s~%"), + filename); + } + @(return filename); @) diff -Nru ecl-16.1.2/src/c/macros.d ecl-16.1.3+ds/src/c/macros.d --- ecl-16.1.2/src/c/macros.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/macros.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - macros.c -- Macros. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * macros.d -- macros + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -47,145 +42,146 @@ static cl_object search_symbol_macro(cl_object name, cl_object env) { - for (env = CAR(env); env != ECL_NIL; env = CDR(env)) { - cl_object record = CAR(env); - if (CONSP(record) && CAR(record) == name) { - if (CADR(record) == @'si::symbol-macro') - return CADDR(record); - return ECL_NIL; - } - } - return si_get_sysprop(name, @'si::symbol-macro'); + for (env = CAR(env); env != ECL_NIL; env = CDR(env)) { + cl_object record = CAR(env); + if (CONSP(record) && CAR(record) == name) { + if (CADR(record) == @'si::symbol-macro') + return CADDR(record); + return ECL_NIL; + } + } + return si_get_sysprop(name, @'si::symbol-macro'); } static cl_object search_macro_function(cl_object name, cl_object env) { - int type = ecl_symbol_type(name); - if (env != ECL_NIL) { - /* When the environment has been produced by the - compiler, there might be atoms/symbols signalling - closure and block boundaries. */ - while (!Null(env = CDR(env))) { - cl_object record = CAR(env); - if (CONSP(record) && CAR(record) == name) { - cl_object tag = CADR(record); - if (tag == @'si::macro') - return CADDR(record); - if (tag == @'function') - return ECL_NIL; - break; - } - } - } - if (type & ecl_stp_macro) { - return ECL_SYM_FUN(name); - } else { - return ECL_NIL; - } + int type = ecl_symbol_type(name); + if (env != ECL_NIL) { + /* When the environment has been produced by the + compiler, there might be atoms/symbols signalling + closure and block boundaries. */ + while (!Null(env = CDR(env))) { + cl_object record = CAR(env); + if (CONSP(record) && CAR(record) == name) { + cl_object tag = CADR(record); + if (tag == @'si::macro') + return CADDR(record); + if (tag == @'function') + return ECL_NIL; + break; + } + } + } + if (type & ecl_stp_macro) { + return ECL_SYM_FUN(name); + } else { + return ECL_NIL; + } } @(defun macro_function (sym &optional env) @ - @(return (search_macro_function(sym, env))) + @(return (search_macro_function(sym, env))); @) /* - Analyze a form and expand it once if it is a macro form. - VALUES(0) contains either the expansion or the original form. - VALUES(1) is true when there was a macroexpansion. + Analyze a form and expand it once if it is a macro form. + VALUES(0) contains either the expansion or the original form. + VALUES(1) is true when there was a macroexpansion. */ @(defun macroexpand_1 (form &optional (env ECL_NIL)) - cl_object exp_fun = ECL_NIL; + cl_object exp_fun = ECL_NIL; @ - if (ECL_ATOM(form)) { - if (ECL_SYMBOLP(form)) - exp_fun = search_symbol_macro(form, env); - } else { - cl_object head = CAR(form); - if (ECL_SYMBOLP(head)) - exp_fun = search_macro_function(head, env); - } - if (!Null(exp_fun)) { - cl_object hook = ecl_symbol_value(@'*macroexpand-hook*'); - if (hook == @'funcall') - form = _ecl_funcall3(exp_fun, form, env); - else - form = _ecl_funcall4(hook, exp_fun, form, env); - } - @(return form exp_fun) + if (ECL_ATOM(form)) { + if (ECL_SYMBOLP(form)) + exp_fun = search_symbol_macro(form, env); + } else { + cl_object head = CAR(form); + if (ECL_SYMBOLP(head)) + exp_fun = search_macro_function(head, env); + } + if (!Null(exp_fun)) { + cl_object hook = ecl_symbol_value(@'*macroexpand-hook*'); + if (hook == @'funcall') + form = _ecl_funcall3(exp_fun, form, env); + else + form = _ecl_funcall4(hook, exp_fun, form, env); + } + @(return form exp_fun); @) /* - Expands a form as many times as possible and returns the - finally expanded form. + Expands a form as many times as possible and returns the + finally expanded form. */ @(defun macroexpand (form &optional env) - cl_object done, old_form; + cl_object done, old_form; @ - done = ECL_NIL; - do { - form = cl_macroexpand_1(2, old_form = form, env); - if (ecl_nth_value(the_env, 1) == ECL_NIL) { - break; - } else if (old_form == form) { - FEerror("Infinite loop when expanding macro form ~A", 1, old_form); - } else { - done = ECL_T; - } - } while (1); - @(return form done) + done = ECL_NIL; + do { + form = cl_macroexpand_1(2, old_form = form, env); + if (ecl_nth_value(the_env, 1) == ECL_NIL) { + break; + } else if (old_form == form) { + FEerror("Infinite loop when expanding macro form ~A", 1, old_form); + } else { + done = ECL_T; + } + } while (1); + @(return form done); @) static cl_object or_macro(cl_object whole, cl_object env) { - cl_object output = ECL_NIL; - whole = CDR(whole); - if (Null(whole)) /* (OR) => NIL */ - @(return ECL_NIL); - while (!Null(CDR(whole))) { - output = CONS(CONS(CAR(whole), ECL_NIL), output); - whole = CDR(whole); - } - if (Null(output)) /* (OR form1) => form1 */ - @(return CAR(whole)); - /* (OR form1 ... formn forml) => (COND (form1) ... (formn) (t forml)) */ - output = CONS(cl_list(2, ECL_T, CAR(whole)), output); - @(return CONS(@'cond', cl_nreverse(output))) + cl_object output = ECL_NIL; + whole = CDR(whole); + if (Null(whole)) /* (OR) => NIL */ + @(return ECL_NIL); + while (!Null(CDR(whole))) { + output = CONS(CONS(CAR(whole), ECL_NIL), output); + whole = CDR(whole); + } + if (Null(output)) { /* (OR form1) => form1 */ + @(return CAR(whole)); + } + /* (OR form1 ... formn forml) => (COND (form1) ... (formn) (t forml)) */ + output = CONS(cl_list(2, ECL_T, CAR(whole)), output); + @(return CONS(@'cond', cl_nreverse(output))); } static cl_object expand_and(cl_object whole) { - if (Null(whole)) - return ECL_T; - if (Null(CDR(whole))) - return CAR(whole); - return cl_list(3, @'if', CAR(whole), expand_and(CDR(whole))); + if (Null(whole)) + return ECL_T; + if (Null(CDR(whole))) + return CAR(whole); + return cl_list(3, @'if', CAR(whole), expand_and(CDR(whole))); } static cl_object and_macro(cl_object whole, cl_object env) { - @(return expand_and(CDR(whole))) + @(return expand_and(CDR(whole))); } static cl_object when_macro(cl_object whole, cl_object env) { - cl_object args = CDR(whole); - if (ecl_unlikely(ecl_endp(args))) - FEprogram_error_noreturn("Syntax error: ~S.", 1, whole); - return cl_list(3, @'if', CAR(args), CONS(@'progn', CDR(args))); + cl_object args = CDR(whole); + if (ecl_unlikely(ecl_endp(args))) + FEprogram_error_noreturn("Syntax error: ~S.", 1, whole); + return cl_list(3, @'if', CAR(args), CONS(@'progn', CDR(args))); } void init_macros(void) { - ECL_SET(@'*macroexpand-hook*', @'funcall'); - ecl_def_c_macro(@'or', or_macro, 2); - ecl_def_c_macro(@'and', and_macro, 2); - ecl_def_c_macro(@'when', when_macro, 2); + ECL_SET(@'*macroexpand-hook*', @'funcall'); + ecl_def_c_macro(@'or', or_macro, 2); + ecl_def_c_macro(@'and', and_macro, 2); + ecl_def_c_macro(@'when', when_macro, 2); } diff -Nru ecl-16.1.2/src/c/main.d ecl-16.1.3+ds/src/c/main.d --- ecl-16.1.2/src/c/main.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/main.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - main.c -- -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * main.d - ecl boot proccess + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ /******************************** IMPORTS *****************************/ @@ -78,36 +73,36 @@ static char **ARGV; cl_fixnum ecl_option_values[ECL_OPT_LIMIT+1] = { #ifdef GBC_BOEHM_GENGC - 1, /* ECL_OPT_INCREMENTAL_GC */ + 1, /* ECL_OPT_INCREMENTAL_GC */ #else - 0, /* ECL_OPT_INCREMENTAL_GC */ + 0, /* ECL_OPT_INCREMENTAL_GC */ #endif - 1, /* ECL_OPT_TRAP_SIGSEGV */ - 1, /* ECL_OPT_TRAP_SIGFPE */ - 1, /* ECL_OPT_TRAP_SIGINT */ - 1, /* ECL_OPT_TRAP_SIGILL */ - 1, /* ECL_OPT_TRAP_SIGBUS */ - 1, /* ECL_OPT_TRAP_SIGPIPE */ - 1, /* ECL_OPT_TRAP_SIGCHLD */ - 1, /* ECL_OPT_TRAP_INTERRUPT_SIGNAL */ - 1, /* ECL_OPT_SIGNAL_HANDLING_THREAD */ - 16, /* ECL_OPT_SIGNAL_QUEUE_SIZE */ - 0, /* ECL_OPT_BOOTED */ - 8192, /* ECL_OPT_BIND_STACK_SIZE */ - 1024, /* ECL_OPT_BIND_STACK_SAFETY_AREA */ - 2048, /* ECL_OPT_FRAME_STACK_SIZE */ - 128, /* ECL_OPT_FRAME_STACK_SAFETY_AREA */ - 32768, /* ECL_OPT_LISP_STACK_SIZE */ - 128, /* ECL_OPT_LISP_STACK_SAFETY_AREA */ - 128*sizeof(cl_index)*1024, /* ECL_OPT_C_STACK_SIZE */ - 4*sizeof(cl_index)*1024, /* ECL_OPT_C_STACK_SAFETY_AREA */ - 1, /* ECL_OPT_SIGALTSTACK_SIZE */ - HEAP_SIZE_DEFAULT, /* ECL_OPT_HEAP_SIZE */ - 1024*1024, /* ECL_OPT_HEAP_SAFETY_AREA */ - 0, /* ECL_OPT_THREAD_INTERRUPT_SIGNAL */ - 1, /* ECL_OPT_SET_GMP_MEMORY_FUNCTIONS */ - 1, /* ECL_OPT_USE_SETMODE_ON_FILES */ - 0}; + 1, /* ECL_OPT_TRAP_SIGSEGV */ + 1, /* ECL_OPT_TRAP_SIGFPE */ + 1, /* ECL_OPT_TRAP_SIGINT */ + 1, /* ECL_OPT_TRAP_SIGILL */ + 1, /* ECL_OPT_TRAP_SIGBUS */ + 1, /* ECL_OPT_TRAP_SIGPIPE */ + 1, /* ECL_OPT_TRAP_SIGCHLD */ + 1, /* ECL_OPT_TRAP_INTERRUPT_SIGNAL */ + 1, /* ECL_OPT_SIGNAL_HANDLING_THREAD */ + 16, /* ECL_OPT_SIGNAL_QUEUE_SIZE */ + 0, /* ECL_OPT_BOOTED */ + 8192, /* ECL_OPT_BIND_STACK_SIZE */ + 1024, /* ECL_OPT_BIND_STACK_SAFETY_AREA */ + 2048, /* ECL_OPT_FRAME_STACK_SIZE */ + 128, /* ECL_OPT_FRAME_STACK_SAFETY_AREA */ + 32768, /* ECL_OPT_LISP_STACK_SIZE */ + 128, /* ECL_OPT_LISP_STACK_SAFETY_AREA */ + 128*sizeof(cl_index)*1024, /* ECL_OPT_C_STACK_SIZE */ + 4*sizeof(cl_index)*1024, /* ECL_OPT_C_STACK_SAFETY_AREA */ + 1, /* ECL_OPT_SIGALTSTACK_SIZE */ + HEAP_SIZE_DEFAULT, /* ECL_OPT_HEAP_SIZE */ + 1024*1024, /* ECL_OPT_HEAP_SAFETY_AREA */ + 0, /* ECL_OPT_THREAD_INTERRUPT_SIGNAL */ + 1, /* ECL_OPT_SET_GMP_MEMORY_FUNCTIONS */ + 1, /* ECL_OPT_USE_SETMODE_ON_FILES */ + 0}; #if !defined(GBC_BOEHM) static char stdin_buf[BUFSIZ]; @@ -117,101 +112,97 @@ cl_fixnum ecl_get_option(int option) { - if (option >= ECL_OPT_LIMIT || option < 0) { - FEerror("Invalid boot option ~D", 1, ecl_make_fixnum(option)); - } - return ecl_option_values[option]; + if (option >= ECL_OPT_LIMIT || option < 0) { + FEerror("Invalid boot option ~D", 1, ecl_make_fixnum(option)); + } + return ecl_option_values[option]; } void ecl_set_option(int option, cl_fixnum value) { - if (option > ECL_OPT_LIMIT || option < 0) { - FEerror("Invalid boot option ~D", 1, ecl_make_fixnum(option)); - } else { - if (option < ECL_OPT_BOOTED && - ecl_option_values[ECL_OPT_BOOTED]) { - FEerror("Cannot change option ~D while ECL is running", - 1, ecl_make_fixnum(option)); - } - ecl_option_values[option] = value; - } + if (option > ECL_OPT_LIMIT || option < 0) { + FEerror("Invalid boot option ~D", 1, ecl_make_fixnum(option)); + } else { + if (option < ECL_OPT_BOOTED && + ecl_option_values[ECL_OPT_BOOTED]) { + FEerror("Cannot change option ~D while ECL is running", + 1, ecl_make_fixnum(option)); + } + ecl_option_values[option] = value; + } } void ecl_init_env(cl_env_ptr env) { - env->c_env = NULL; + env->c_env = NULL; #if defined(ECL_THREADS) - env->cleanup = 0; + env->cleanup = 0; #else - env->own_process = ECL_NIL; + env->own_process = ECL_NIL; #endif - env->string_pool = ECL_NIL; + env->string_pool = ECL_NIL; - env->stack = NULL; - env->stack_top = NULL; - env->stack_limit = NULL; - env->stack_size = 0; - ecl_stack_set_size(env, ecl_option_values[ECL_OPT_LISP_STACK_SIZE]); + env->stack = NULL; + env->stack_top = NULL; + env->stack_limit = NULL; + env->stack_size = 0; + ecl_stack_set_size(env, ecl_option_values[ECL_OPT_LISP_STACK_SIZE]); #if !defined(ECL_CMU_FORMAT) - env->fmt_aux_stream = ecl_make_string_output_stream(64, 1); + env->fmt_aux_stream = ecl_make_string_output_stream(64, 1); #endif #ifdef HAVE_LIBFFI - env->ffi_args_limit = 0; - env->ffi_types = 0; - env->ffi_values = 0; - env->ffi_values_ptrs = 0; -#endif -#ifdef ECL_DYNAMIC_FFI - env->fficall = ecl_alloc(sizeof(struct ecl_fficall)); - ((struct ecl_fficall*)env->fficall)->registers = 0; -#endif - - env->method_cache = ecl_make_cache(64, 4096); - env->slot_cache = ecl_make_cache(3, 4096); - env->pending_interrupt = ECL_NIL; - { - int size = ecl_option_values[ECL_OPT_SIGNAL_QUEUE_SIZE]; - env->signal_queue = cl_make_list(1, ecl_make_fixnum(size)); - } - - init_stacks(env); - - { - int i; - for (i = 0; i < 3; i++) { - cl_object x = ecl_alloc_object(t_bignum); - _ecl_big_init2(x, ECL_BIG_REGISTER_SIZE); - env->big_register[i] = x; - } - } - - env->trap_fpe_bits = 0; - - env->packages_to_be_created = ECL_NIL; - env->packages_to_be_created_p = ECL_NIL; - env->fault_address = env; + env->ffi_args_limit = 0; + env->ffi_types = 0; + env->ffi_values = 0; + env->ffi_values_ptrs = 0; +#endif + + env->method_cache = ecl_make_cache(64, 4096); + env->slot_cache = ecl_make_cache(3, 4096); + env->pending_interrupt = ECL_NIL; + { + int size = ecl_option_values[ECL_OPT_SIGNAL_QUEUE_SIZE]; + env->signal_queue = cl_make_list(1, ecl_make_fixnum(size)); + } + + init_stacks(env); + + { + int i; + for (i = 0; i < 3; i++) { + cl_object x = ecl_alloc_object(t_bignum); + _ecl_big_init2(x, ECL_BIG_REGISTER_SIZE); + env->big_register[i] = x; + } + } + + env->trap_fpe_bits = 0; + + env->packages_to_be_created = ECL_NIL; + env->packages_to_be_created_p = ECL_NIL; + env->fault_address = env; } void _ecl_dealloc_env(cl_env_ptr env) { - /* - * Environment cleanup. This is only required when the environment is - * allocated using mmap or some other method. We could do more, cleaning - * up stacks, etc, but we actually do not do it because that would need - * a lisp environment set up -- the allocator assumes one -- and we - * may have already cleaned up the value of ecl_process_env() - */ + /* + * Environment cleanup. This is only required when the environment is + * allocated using mmap or some other method. We could do more, cleaning + * up stacks, etc, but we actually do not do it because that would need + * a lisp environment set up -- the allocator assumes one -- and we + * may have already cleaned up the value of ecl_process_env() + */ #if defined(ECL_USE_MPROTECT) - if (munmap(env, sizeof(*env))) - ecl_internal_error("Unable to deallocate environment structure."); + if (munmap(env, sizeof(*env))) + ecl_internal_error("Unable to deallocate environment structure."); #else # if defined(ECL_USE_GUARD_PAGE) - if (VirtualFree(env, sizeof(*env), MEM_RELEASE)) - ecl_internal_error("Unable to deallocate environment structure."); + if (!VirtualFree(env, 0, MEM_RELEASE)) + ecl_internal_error("Unable to deallocate environment structure."); # endif #endif } @@ -219,78 +210,78 @@ cl_env_ptr _ecl_alloc_env(cl_env_ptr parent) { - /* - * Allocates the lisp environment for a thread. Depending on which - * mechanism we use for detecting delayed signals, we may allocate - * the environment using mmap or the garbage collector. - */ - cl_env_ptr output; + /* + * Allocates the lisp environment for a thread. Depending on which + * mechanism we use for detecting delayed signals, we may allocate + * the environment using mmap or the garbage collector. + */ + cl_env_ptr output; #if defined(ECL_USE_MPROTECT) - output = mmap(0, sizeof(*output), PROT_READ | PROT_WRITE, - MAP_ANON | MAP_PRIVATE, -1, 0); - if (output == MAP_FAILED) - ecl_internal_error("Unable to allocate environment structure."); + output = (cl_env_ptr) mmap(0, sizeof(*output), PROT_READ | PROT_WRITE, + MAP_ANON | MAP_PRIVATE, -1, 0); + if (output == MAP_FAILED) + ecl_internal_error("Unable to allocate environment structure."); #else # if defined(ECL_USE_GUARD_PAGE) - output = VirtualAlloc(0, sizeof(*output), MEM_COMMIT, - PAGE_READWRITE); - if (output == NULL) - ecl_internal_error("Unable to allocate environment structure."); + output = VirtualAlloc(0, sizeof(*output), MEM_COMMIT, + PAGE_READWRITE); + if (output == NULL) + ecl_internal_error("Unable to allocate environment structure."); # else - static struct cl_env_struct first_env; - if (!ecl_option_values[ECL_OPT_BOOTED]) { - /* We have not set up any environment. Hence, we cannot call ecl_alloc() - * because it will need to stop interrupts and currently we rely on - * the environment for that */ - output = ecl_alloc_unprotected(sizeof(*output)); - } else { - output = ecl_alloc(sizeof(*output)); - } + static struct cl_env_struct first_env; + if (!ecl_option_values[ECL_OPT_BOOTED]) { + /* We have not set up any environment. Hence, we cannot call ecl_alloc() + * because it will need to stop interrupts and currently we rely on + * the environment for that */ + output = ecl_alloc_unprotected(sizeof(*output)); + } else { + output = ecl_alloc(sizeof(*output)); + } # endif #endif - { - size_t bytes = cl_core.default_sigmask_bytes; - if (bytes == 0) { - output->default_sigmask = 0; - } else if (parent) { - output->default_sigmask = ecl_alloc_atomic(bytes); - memcpy(output->default_sigmask, - parent->default_sigmask, - bytes); - } else { - output->default_sigmask = cl_core.default_sigmask; - } - } - /* - * An uninitialized environment _always_ disables interrupts. They - * are activated later on by the thread entry point or init_unixint(). - */ - output->disable_interrupts = 1; - output->pending_interrupt = ECL_NIL; - output->signal_queue_spinlock = ECL_NIL; - return output; + { + size_t bytes = cl_core.default_sigmask_bytes; + if (bytes == 0) { + output->default_sigmask = 0; + } else if (parent) { + output->default_sigmask = ecl_alloc_atomic(bytes); + memcpy(output->default_sigmask, + parent->default_sigmask, + bytes); + } else { + output->default_sigmask = cl_core.default_sigmask; + } + } + /* + * An uninitialized environment _always_ disables interrupts. They + * are activated later on by the thread entry point or init_unixint(). + */ + output->disable_interrupts = 1; + output->pending_interrupt = ECL_NIL; + output->signal_queue_spinlock = ECL_NIL; + return output; } void cl_shutdown(void) { - if (ecl_option_values[ECL_OPT_BOOTED] > 0) { - cl_object l = ecl_symbol_value(@'si::*exit-hooks*'); - cl_object form = cl_list(2, @'funcall', ECL_NIL); - while (CONSP(l)) { - ecl_elt_set(form, 1, ECL_CONS_CAR(l)); - si_safe_eval(3, form, ECL_NIL, OBJNULL); - l = CDR(l); - ECL_SET(@'si::*exit-hooks*', l); - } + if (ecl_option_values[ECL_OPT_BOOTED] > 0) { + cl_object l = ecl_symbol_value(@'si::*exit-hooks*'); + cl_object form = cl_list(2, @'funcall', ECL_NIL); + while (CONSP(l)) { + ecl_elt_set(form, 1, ECL_CONS_CAR(l)); + si_safe_eval(3, form, ECL_NIL, OBJNULL); + l = CDR(l); + ECL_SET(@'si::*exit-hooks*', l); + } #ifdef ENABLE_DLOPEN - ecl_library_close_all(); + ecl_library_close_all(); #endif #ifdef TCP - ecl_tcp_close_all(); + ecl_tcp_close_all(); #endif - } - ecl_set_option(ECL_OPT_BOOTED, -1); + } + ecl_set_option(ECL_OPT_BOOTED, -1); } ecl_def_ct_single_float(default_rehash_size,1.5f,static,const); @@ -353,96 +344,96 @@ ecl_def_ct_complex(flt_imag_two,&flt_zero_data,&flt_two_data,static,const); struct cl_core_struct cl_core = { - ECL_NIL, /* packages */ - ECL_NIL, /* lisp_package */ - ECL_NIL, /* user_package */ - ECL_NIL, /* keyword_package */ - ECL_NIL, /* system_package */ - ECL_NIL, /* ext_package */ - ECL_NIL, /* clos_package */ + ECL_NIL, /* packages */ + ECL_NIL, /* lisp_package */ + ECL_NIL, /* user_package */ + ECL_NIL, /* keyword_package */ + ECL_NIL, /* system_package */ + ECL_NIL, /* ext_package */ + ECL_NIL, /* clos_package */ # ifdef ECL_CLOS_STREAMS - ECL_NIL, /* gray_package */ + ECL_NIL, /* gray_package */ # endif - ECL_NIL, /* mp_package */ - ECL_NIL, /* c_package */ - ECL_NIL, /* ffi_package */ - - ECL_NIL, /* pathname_translations */ - ECL_NIL, /* library_pathname */ - - ECL_NIL, /* terminal_io */ - ECL_NIL, /* null_stream */ - ECL_NIL, /* standard_input */ - ECL_NIL, /* standard_output */ - ECL_NIL, /* error_output */ - ECL_NIL, /* standard_readtable */ - ECL_NIL, /* dispatch_reader */ - ECL_NIL, /* default_dispatch_macro */ - - ECL_NIL, /* char_names */ - (cl_object)&str_empty_data, /* null_string */ - - (cl_object)&plus_half_data, /* plus_half */ - (cl_object)&minus_half_data, /* minus_half */ - (cl_object)&flt_imag_unit_data, /* imag_unit */ - (cl_object)&flt_imag_unit_neg_data, /* minus_imag_unit */ - (cl_object)&flt_imag_two_data, /* imag_two */ - (cl_object)&flt_zero_data, /* singlefloat_zero */ - (cl_object)&dbl_zero_data, /* doublefloat_zero */ - (cl_object)&flt_zero_neg_data, /* singlefloat_minus_zero */ - (cl_object)&dbl_zero_neg_data, /* doublefloat_minus_zero */ + ECL_NIL, /* mp_package */ + ECL_NIL, /* c_package */ + ECL_NIL, /* ffi_package */ + + ECL_NIL, /* pathname_translations */ + ECL_NIL, /* library_pathname */ + + ECL_NIL, /* terminal_io */ + ECL_NIL, /* null_stream */ + ECL_NIL, /* standard_input */ + ECL_NIL, /* standard_output */ + ECL_NIL, /* error_output */ + ECL_NIL, /* standard_readtable */ + ECL_NIL, /* dispatch_reader */ + ECL_NIL, /* default_dispatch_macro */ + + ECL_NIL, /* char_names */ + (cl_object)&str_empty_data, /* null_string */ + + (cl_object)&plus_half_data, /* plus_half */ + (cl_object)&minus_half_data, /* minus_half */ + (cl_object)&flt_imag_unit_data, /* imag_unit */ + (cl_object)&flt_imag_unit_neg_data, /* minus_imag_unit */ + (cl_object)&flt_imag_two_data, /* imag_two */ + (cl_object)&flt_zero_data, /* singlefloat_zero */ + (cl_object)&dbl_zero_data, /* doublefloat_zero */ + (cl_object)&flt_zero_neg_data, /* singlefloat_minus_zero */ + (cl_object)&dbl_zero_neg_data, /* doublefloat_minus_zero */ #ifdef ECL_LONG_FLOAT - (cl_object)&ldbl_zero_data, /* longfloat_zero */ - (cl_object)&ldbl_zero_neg_data, /* longfloat_minus_zero */ + (cl_object)&ldbl_zero_data, /* longfloat_zero */ + (cl_object)&ldbl_zero_neg_data, /* longfloat_minus_zero */ #endif - (cl_object)&str_G_data, /* gensym_prefix */ - (cl_object)&str_T_data, /* gentemp_prefix */ - ecl_make_fixnum(0), /* gentemp_counter */ + (cl_object)&str_G_data, /* gensym_prefix */ + (cl_object)&str_T_data, /* gentemp_prefix */ + ecl_make_fixnum(0), /* gentemp_counter */ - ECL_NIL, /* Jan1st1970UT */ + ECL_NIL, /* Jan1st1970UT */ - ECL_NIL, /* system_properties */ - ECL_NIL, /* setf_definition */ + ECL_NIL, /* system_properties */ + ECL_NIL, /* setf_definition */ #ifdef ECL_THREADS - ECL_NIL, /* processes */ - ECL_NIL, /* processes_spinlock */ - ECL_NIL, /* global_lock */ - ECL_NIL, /* error_lock */ - ECL_NIL, /* global_env_lock */ -#endif - /* LIBRARIES is an adjustable vector of objects. It behaves as - a vector of weak pointers thanks to the magic in - gbc.d/alloc_2.d */ - ECL_NIL, /* libraries */ - - 0, /* max_heap_size */ - ECL_NIL, /* bytes_consed */ - ECL_NIL, /* gc_counter */ - 0, /* gc_stats */ - 0, /* path_max */ + ECL_NIL, /* processes */ + ECL_NIL, /* processes_spinlock */ + ECL_NIL, /* global_lock */ + ECL_NIL, /* error_lock */ + ECL_NIL, /* global_env_lock */ +#endif + /* LIBRARIES is an adjustable vector of objects. It behaves as + a vector of weak pointers thanks to the magic in + gbc.d/alloc_2.d */ + ECL_NIL, /* libraries */ + + 0, /* max_heap_size */ + ECL_NIL, /* bytes_consed */ + ECL_NIL, /* gc_counter */ + 0, /* gc_stats */ + 0, /* path_max */ #ifdef GBC_BOEHM - NULL, /* safety_region */ + NULL, /* safety_region */ #endif - NULL, /* default_sigmask */ - 0, /* default_sigmask_bytes */ + NULL, /* default_sigmask */ + 0, /* default_sigmask_bytes */ #ifdef ECL_THREADS - 0, /* last_var_index */ - ECL_NIL, /* reused_indices */ + 0, /* last_var_index */ + ECL_NIL, /* reused_indices */ #endif - (cl_object)&str_slash_data, /* slash */ + (cl_object)&str_slash_data, /* slash */ - ECL_NIL, /* compiler_dispatch */ + ECL_NIL, /* compiler_dispatch */ - (cl_object)&default_rehash_size_data, /* rehash_size */ - (cl_object)&default_rehash_threshold_data, /* rehash_threshold */ + (cl_object)&default_rehash_size_data, /* rehash_size */ + (cl_object)&default_rehash_threshold_data, /* rehash_threshold */ - ECL_NIL, /* external_processes */ - ECL_NIL, /* external_processes_lock */ - ECL_NIL /* known_signals */ + ECL_NIL, /* external_processes */ + ECL_NIL, /* external_processes_lock */ + ECL_NIL /* known_signals */ }; #if !defined(ECL_MS_WINDOWS_HOST) @@ -451,501 +442,507 @@ static void maybe_fix_console_stream(cl_object stream) { - DWORD cp = GetConsoleCP(); - const char *encoding; - cl_object external_format; - int i; - static const struct { - int code; - const char *name; - } known_cp[] = { - {874, "WINDOWS-CP874"}, - {932, "WINDOWS-CP932"}, - {936, "WINDOWS-CP936"}, - {949, "WINDOWS-CP949"}, - {950, "WINDOWS-CP950"}, - {1200, "WINDOWS-CP1200"}, - {1201, "WINDOWS-CP1201"}, - {1250, "WINDOWS-CP1250"}, - {1251, "WINDOWS-CP1251"}, - {1252, "WINDOWS-CP1252"}, - {1253, "WINDOWS-CP1253"}, - {1254, "WINDOWS-CP1254"}, - {1255, "WINDOWS-CP1255"}, - {1256, "WINDOWS-CP1256"}, - {1257, "WINDOWS-CP1257"}, - {1258, "WINDOWS-CP1258"}, - {65001, "UTF8"}, - {0,"LATIN-1"} - }; - if (stream->stream.mode != ecl_smm_io_wcon) - return; - for (i = 0; known_cp[i].code && known_cp[i].code != cp; i++) - {} - external_format = cl_list(2, ecl_make_keyword(known_cp[i].name), - @':crlf'); - si_stream_external_format_set(stream, external_format); - stream->stream.eof_char = 26; + DWORD cp = GetConsoleCP(); + const char *encoding; + cl_object external_format; + int i; + static const struct { + int code; + const char *name; + } known_cp[] = { + {874, "WINDOWS-CP874"}, + {932, "WINDOWS-CP932"}, + {936, "WINDOWS-CP936"}, + {949, "WINDOWS-CP949"}, + {950, "WINDOWS-CP950"}, + {1200, "WINDOWS-CP1200"}, + {1201, "WINDOWS-CP1201"}, + {1250, "WINDOWS-CP1250"}, + {1251, "WINDOWS-CP1251"}, + {1252, "WINDOWS-CP1252"}, + {1253, "WINDOWS-CP1253"}, + {1254, "WINDOWS-CP1254"}, + {1255, "WINDOWS-CP1255"}, + {1256, "WINDOWS-CP1256"}, + {1257, "WINDOWS-CP1257"}, + {1258, "WINDOWS-CP1258"}, + {65001, "UTF8"}, + {0,"LATIN-1"} + }; + if (stream->stream.mode != ecl_smm_io_wcon) + return; + for (i = 0; known_cp[i].code && known_cp[i].code != cp; i++) + {} + external_format = cl_list(2, ecl_make_keyword(known_cp[i].name), + @':crlf'); + si_stream_external_format_set(stream, external_format); + stream->stream.eof_char = 26; } #endif int cl_boot(int argc, char **argv) { - cl_object aux; - cl_object features; - int i; - cl_env_ptr env; - - i = ecl_option_values[ECL_OPT_BOOTED]; - if (i) { - if (i < 0) { - /* We have called cl_shutdown and want to use ECL again. */ - ecl_set_option(ECL_OPT_BOOTED, 1); - } - return 1; - } + cl_object aux; + cl_object features; + int i; + cl_env_ptr env; + + i = ecl_option_values[ECL_OPT_BOOTED]; + if (i) { + if (i < 0) { + /* We have called cl_shutdown and want to use ECL again. */ + ecl_set_option(ECL_OPT_BOOTED, 1); + } + return 1; + } - /*ecl_set_option(ECL_OPT_SIGNAL_HANDLING_THREAD, 0);*/ + /*ecl_set_option(ECL_OPT_SIGNAL_HANDLING_THREAD, 0);*/ #if !defined(GBC_BOEHM) - setbuf(stdin, stdin_buf); - setbuf(stdout, stdout_buf); + setbuf(stdin, stdin_buf); + setbuf(stdout, stdout_buf); #endif - ARGC = argc; - ARGV = argv; - ecl_self = argv[0]; - - init_unixint(0); - init_alloc(); - GC_disable(); - env = _ecl_alloc_env(0); + ARGC = argc; + ARGV = argv; + ecl_self = argv[0]; + + init_unixint(0); + init_alloc(); + GC_disable(); + env = _ecl_alloc_env(0); #ifdef ECL_THREADS - init_threads(env); + init_threads(env); #else - cl_env_p = env; + cl_env_p = env; #endif - /* - * 1) Initialize symbols and packages - */ - - ECL_NIL_SYMBOL->symbol.t = t_symbol; - ECL_NIL_SYMBOL->symbol.dynamic = 0; - ECL_NIL_SYMBOL->symbol.value = ECL_NIL; - ECL_NIL_SYMBOL->symbol.name = str_NIL; - ECL_NIL_SYMBOL->symbol.gfdef = ECL_NIL; - ECL_NIL_SYMBOL->symbol.plist = ECL_NIL; - ECL_NIL_SYMBOL->symbol.hpack = ECL_NIL; - ECL_NIL_SYMBOL->symbol.stype = ecl_stp_constant; + /* + * 1) Initialize symbols and packages + */ + + ECL_NIL_SYMBOL->symbol.t = t_symbol; + ECL_NIL_SYMBOL->symbol.dynamic = 0; + ECL_NIL_SYMBOL->symbol.value = ECL_NIL; + ECL_NIL_SYMBOL->symbol.name = str_NIL; + ECL_NIL_SYMBOL->symbol.gfdef = ECL_NIL; + ECL_NIL_SYMBOL->symbol.plist = ECL_NIL; + ECL_NIL_SYMBOL->symbol.hpack = ECL_NIL; + ECL_NIL_SYMBOL->symbol.stype = ecl_stp_constant; #ifdef ECL_THREADS - ECL_NIL_SYMBOL->symbol.binding = ECL_MISSING_SPECIAL_BINDING; + ECL_NIL_SYMBOL->symbol.binding = ECL_MISSING_SPECIAL_BINDING; #endif - cl_num_symbols_in_core=1; + cl_num_symbols_in_core=1; - ECL_T->symbol.t = (short)t_symbol; - ECL_T->symbol.dynamic = 0; - ECL_T->symbol.value = ECL_T; - ECL_T->symbol.name = str_T; - ECL_T->symbol.gfdef = ECL_NIL; - ECL_T->symbol.plist = ECL_NIL; - ECL_T->symbol.hpack = ECL_NIL; - ECL_T->symbol.stype = ecl_stp_constant; + ECL_T->symbol.t = (short)t_symbol; + ECL_T->symbol.dynamic = 0; + ECL_T->symbol.value = ECL_T; + ECL_T->symbol.name = str_T; + ECL_T->symbol.gfdef = ECL_NIL; + ECL_T->symbol.plist = ECL_NIL; + ECL_T->symbol.hpack = ECL_NIL; + ECL_T->symbol.stype = ecl_stp_constant; #ifdef ECL_THREADS - ECL_T->symbol.binding = ECL_MISSING_SPECIAL_BINDING; + ECL_T->symbol.binding = ECL_MISSING_SPECIAL_BINDING; #endif - cl_num_symbols_in_core=2; + cl_num_symbols_in_core=2; #ifdef NO_PATH_MAX - cl_core.path_max = sysconf(_PC_PATH_MAX); + cl_core.path_max = sysconf(_PC_PATH_MAX); #else - cl_core.path_max = MAXPATHLEN; + cl_core.path_max = MAXPATHLEN; #endif - env->packages_to_be_created = ECL_NIL; - cl_core.lisp_package = - ecl_make_package(str_common_lisp, - cl_list(2, str_cl, str_LISP), - ECL_NIL); - cl_core.user_package = - ecl_make_package(str_common_lisp_user, - cl_list(2, str_cl_user, str_user), - ecl_list1(cl_core.lisp_package)); - cl_core.keyword_package = - ecl_make_package(str_keyword, ECL_NIL, ECL_NIL); - cl_core.ext_package = - ecl_make_package(str_ext, ECL_NIL, - ecl_list1(cl_core.lisp_package)); - cl_core.system_package = - ecl_make_package(str_si, - cl_list(2,str_system,str_sys), - cl_list(2,cl_core.ext_package, - cl_core.lisp_package)); - cl_core.c_package = - ecl_make_package(str_c, - ecl_list1(str_compiler), - ecl_list1(cl_core.lisp_package)); - cl_core.clos_package = - ecl_make_package(str_clos, - ecl_list1(str_mop), - ecl_list1(cl_core.lisp_package)); - cl_core.mp_package = - ecl_make_package(str_mp, - ecl_list1(str_multiprocessing), - ecl_list1(cl_core.lisp_package)); + env->packages_to_be_created = ECL_NIL; + cl_core.lisp_package = + ecl_make_package(str_common_lisp, + cl_list(2, str_cl, str_LISP), + ECL_NIL); + cl_core.user_package = + ecl_make_package(str_common_lisp_user, + cl_list(2, str_cl_user, str_user), + ecl_list1(cl_core.lisp_package)); + cl_core.keyword_package = + ecl_make_package(str_keyword, ECL_NIL, ECL_NIL); + cl_core.ext_package = + ecl_make_package(str_ext, ECL_NIL, + ecl_list1(cl_core.lisp_package)); + cl_core.system_package = + ecl_make_package(str_si, + cl_list(2,str_system,str_sys), + cl_list(2,cl_core.ext_package, + cl_core.lisp_package)); + cl_core.c_package = + ecl_make_package(str_c, + ecl_list1(str_compiler), + ecl_list1(cl_core.lisp_package)); + cl_core.clos_package = + ecl_make_package(str_clos, + ecl_list1(str_mop), + ecl_list1(cl_core.lisp_package)); + cl_core.mp_package = + ecl_make_package(str_mp, + ecl_list1(str_multiprocessing), + ecl_list1(cl_core.lisp_package)); #ifdef ECL_CLOS_STREAMS - cl_core.gray_package = ecl_make_package(str_gray, ECL_NIL, - CONS(cl_core.lisp_package, ECL_NIL)); + cl_core.gray_package = ecl_make_package(str_gray, ECL_NIL, + CONS(cl_core.lisp_package, ECL_NIL)); #endif - cl_core.ffi_package = - ecl_make_package(str_ffi, - ECL_NIL, - cl_list(3,cl_core.lisp_package, - cl_core.system_package, - cl_core.ext_package)); - - ECL_NIL_SYMBOL->symbol.hpack = cl_core.lisp_package; - cl_import2(ECL_NIL, cl_core.lisp_package); - cl_export2(ECL_NIL, cl_core.lisp_package); - - ECL_T->symbol.hpack = cl_core.lisp_package; - cl_import2(ECL_T, cl_core.lisp_package); - cl_export2(ECL_T, cl_core.lisp_package); - - /* At exit, clean up */ - atexit(cl_shutdown); - - /* These must come _after_ the packages and NIL/T have been created */ - init_all_symbols(); - - /* - * Initialize the per-thread data. - * This cannot come later, because some routines need the - * frame stack immediately (for instance SI:PATHNAME-TRANSLATIONS). - */ - init_big(); - ecl_init_env(env); - ecl_cs_set_org(env); + cl_core.ffi_package = + ecl_make_package(str_ffi, + ECL_NIL, + cl_list(3,cl_core.lisp_package, + cl_core.system_package, + cl_core.ext_package)); + + ECL_NIL_SYMBOL->symbol.hpack = cl_core.lisp_package; + cl_import2(ECL_NIL, cl_core.lisp_package); + cl_export2(ECL_NIL, cl_core.lisp_package); + + ECL_T->symbol.hpack = cl_core.lisp_package; + cl_import2(ECL_T, cl_core.lisp_package); + cl_export2(ECL_T, cl_core.lisp_package); + + /* At exit, clean up */ + atexit(cl_shutdown); + + /* These must come _after_ the packages and NIL/T have been created */ + init_all_symbols(); + + /* + * Initialize the per-thread data. + * This cannot come later, because some routines need the + * frame stack immediately (for instance SI:PATHNAME-TRANSLATIONS). + */ + init_big(); + ecl_init_env(env); + ecl_cs_set_org(env); #if !defined(GBC_BOEHM) - /* We need this because a lot of stuff is to be created */ - init_GC(); + /* We need this because a lot of stuff is to be created */ + init_GC(); #endif - GC_enable(); + GC_enable(); - /* - * Initialize default pathnames - */ + /* + * Initialize default pathnames + */ #if 1 - ECL_SET(@'*default-pathname-defaults*', si_getcwd(0)); + ECL_SET(@'*default-pathname-defaults*', si_getcwd(0)); #else - ECL_SET(@'*default-pathname-defaults*', - ecl_make_pathname(ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL, @':local')); + ECL_SET(@'*default-pathname-defaults*', + ecl_make_pathname(ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL, @':local')); #endif #ifdef ECL_THREADS - env->bindings_array = si_make_vector(ECL_T, ecl_make_fixnum(1024), - ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL); - si_fill_array_with_elt(env->bindings_array, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL); - env->thread_local_bindings_size = env->bindings_array->vector.dim; - env->thread_local_bindings = env->bindings_array->vector.self.t; - ECL_SET(@'mp::*current-process*', env->own_process); -#endif - - /* - * Load character names. The following hash table is a map - * from names to character codes and viceversa. Note that we - * need EQUALP because it has to be case insensitive. - */ - cl_core.char_names = aux = - cl__make_hash_table(@'equalp', ecl_make_fixnum(128), /* size */ - cl_core.rehash_size, - cl_core.rehash_threshold); - for (i = 0; char_names[i].elt.self; i++) { - cl_object name = (cl_object)(char_names + i); - cl_object code = ecl_make_fixnum(i); - ecl_sethash(name, aux, code); - ecl_sethash(code, aux, name); - } - for (i = 0; i < extra_char_names_size; i++) { - cl_object name = (cl_object)(extra_char_names + i); - cl_object code = ecl_make_fixnum(extra_char_codes[i]); - ecl_sethash(name, aux, code); - } - - /* - * Initialize logical pathname translations. This must come after - * the character database has been filled. - */ - @si::pathname-translations(2,str_sys, - ecl_list1(cl_list(2,str_star_dot_star, - str_rel_star_dot_star))); - - /* - * Initialize constants (strings, numbers and time). - */ - cl_core.system_properties = - cl__make_hash_table(@'equal', ecl_make_fixnum(1024), /* size */ - cl_core.rehash_size, - cl_core.rehash_threshold); - cl_core.setf_definitions = - cl__make_hash_table(@'eq', ecl_make_fixnum(256), /* size */ - cl_core.rehash_size, - cl_core.rehash_threshold); - - ECL_SET(@'*random-state*', ecl_make_random_state(ECL_T)); - - ECL_SET(@'ffi::c-int-max', ecl_make_integer(INT_MAX)); - ECL_SET(@'ffi::c-int-min', ecl_make_integer(INT_MIN)); - ECL_SET(@'ffi::c-long-max', ecl_make_integer(LONG_MAX)); - ECL_SET(@'ffi::c-long-min', ecl_make_integer(LONG_MIN)); - ECL_SET(@'ffi::c-uint-max', ecl_make_unsigned_integer(UINT_MAX)); - ECL_SET(@'ffi::c-ulong-max', ecl_make_unsigned_integer(ULONG_MAX)); + env->bindings_array = si_make_vector(ECL_T, ecl_make_fixnum(1024), + ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL); + si_fill_array_with_elt(env->bindings_array, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL); + env->thread_local_bindings_size = env->bindings_array->vector.dim; + env->thread_local_bindings = env->bindings_array->vector.self.t; + ECL_SET(@'mp::*current-process*', env->own_process); +#endif + + /* + * Load character names. The following hash table is a map + * from names to character codes and viceversa. Note that we + * need EQUALP because it has to be case insensitive. + */ + cl_core.char_names = aux = + cl__make_hash_table(@'equalp', ecl_make_fixnum(128), /* size */ + cl_core.rehash_size, + cl_core.rehash_threshold); + for (i = 0; char_names[i].elt.self; i++) { + cl_object name = (cl_object)(char_names + i); + cl_object code = ecl_make_fixnum(i); + ecl_sethash(name, aux, code); + ecl_sethash(code, aux, name); + } + for (i = 0; i < extra_char_names_size; i++) { + cl_object name = (cl_object)(extra_char_names + i); + cl_object code = ecl_make_fixnum(extra_char_codes[i]); + ecl_sethash(name, aux, code); + } + + /* + * Initialize logical pathname translations. This must come after + * the character database has been filled. + */ + @si::pathname-translations(2,str_sys, + ecl_list1(cl_list(2,str_star_dot_star, + str_rel_star_dot_star))); + + /* + * Initialize constants (strings, numbers and time). + */ + cl_core.system_properties = + cl__make_hash_table(@'equal', ecl_make_fixnum(1024), /* size */ + cl_core.rehash_size, + cl_core.rehash_threshold); + cl_core.setf_definitions = + cl__make_hash_table(@'eq', ecl_make_fixnum(256), /* size */ + cl_core.rehash_size, + cl_core.rehash_threshold); + + ECL_SET(@'*random-state*', ecl_make_random_state(ECL_T)); + + ECL_SET(@'ffi::c-int-max', ecl_make_integer(INT_MAX)); + ECL_SET(@'ffi::c-int-min', ecl_make_integer(INT_MIN)); + ECL_SET(@'ffi::c-long-max', ecl_make_integer(LONG_MAX)); + ECL_SET(@'ffi::c-long-min', ecl_make_integer(LONG_MIN)); + ECL_SET(@'ffi::c-uint-max', ecl_make_unsigned_integer(UINT_MAX)); + ECL_SET(@'ffi::c-ulong-max', ecl_make_unsigned_integer(ULONG_MAX)); #ifdef ecl_long_long_t - ECL_SET(@'ffi::c-long-long-max', ecl_make_long_long(LLONG_MAX)); - ECL_SET(@'ffi::c-ulong-long-max', ecl_make_ulong_long(ULLONG_MAX)); + ECL_SET(@'ffi::c-long-long-max', ecl_make_long_long(LLONG_MAX)); + ECL_SET(@'ffi::c-ulong-long-max', ecl_make_ulong_long(ULLONG_MAX)); #endif - init_unixtime(); + init_unixtime(); - /* - * Initialize I/O subsystem. - */ - init_file(); - init_read(); + /* + * Initialize I/O subsystem. + */ + init_file(); + init_read(); - ECL_SET(@'*print-case*', @':upcase'); + ECL_SET(@'*print-case*', @':upcase'); - /* - * Set up hooks for LOAD, errors and macros. - */ + /* + * Set up hooks for LOAD, errors and macros. + */ #ifdef ECL_THREADS - ECL_SET(@'mp::+load-compile-lock+', - ecl_make_lock(@'mp::+load-compile-lock+', 1)); + ECL_SET(@'mp::+load-compile-lock+', + ecl_make_lock(@'mp::+load-compile-lock+', 1)); #endif - aux = cl_list( #ifdef ENABLE_DLOPEN - 11, + aux = cl_list(11, + CONS(ECL_NIL, @'si::load-source'), CONS(str_fas, @'si::load-binary'), CONS(str_fasl, @'si::load-binary'), CONS(str_fasb, @'si::load-binary'), CONS(str_FASB, @'si::load-binary'), + CONS(str_lsp, @'si::load-source'), + CONS(str_lisp, @'si::load-source'), + CONS(str_LSP, @'si::load-source'), + CONS(str_LISP, @'si::load-source'), + CONS(str_fasc, @'si::load-bytecodes'), + CONS(str_FASC, @'si::load-bytecodes')); #else - 7, -#endif + aux = cl_list(7, + CONS(ECL_NIL, @'si::load-source'), CONS(str_lsp, @'si::load-source'), CONS(str_lisp, @'si::load-source'), CONS(str_LSP, @'si::load-source'), CONS(str_LISP, @'si::load-source'), CONS(str_fasc, @'si::load-bytecodes'), - CONS(str_FASC, @'si::load-bytecodes'), - CONS(ECL_NIL, @'si::load-source')); - ECL_SET(@'ext::*load-hooks*', aux); - init_error(); - init_macros(); - init_compiler(); - - /* - * Set up infrastructure for CLOS. - */ - ECL_SET(@'si::*class-name-hash-table*', - cl__make_hash_table(@'eq', ecl_make_fixnum(1024), /* size */ - cl_core.rehash_size, - cl_core.rehash_threshold)); - - /* - * Features. - */ - - ECL_SET(@'LAMBDA-LIST-KEYWORDS', - cl_list(8, @'&optional', @'&rest', @'&key', @'&allow-other-keys', - @'&aux', @'&whole', @'&environment', @'&body')); - - for (i = 0, features = ECL_NIL; feature_names[i].elt.self; i++) { - int flag; - cl_object name = (cl_object)(feature_names + i); - cl_object key = ecl_intern(name, cl_core.keyword_package, &flag); - features = CONS(key, features); - } - - ECL_SET(@'*features*', features); - - ECL_SET(@'*package*', cl_core.lisp_package); - - /* This has to come before init_LSP/CLOS, because we need - * ecl_clear_compiler_properties() to work in init_CLOS(). */ - ecl_set_option(ECL_OPT_BOOTED, 1); - - ecl_init_module(OBJNULL,init_lib_LSP); - - if (cl_fboundp(@'ext::make-encoding') != ECL_NIL) { - maybe_fix_console_stream(cl_core.standard_input); - maybe_fix_console_stream(cl_core.standard_output); - maybe_fix_console_stream(cl_core.error_output); - } - - /* Jump to top level */ - ECL_SET(@'*package*', cl_core.user_package); - init_unixint(1); - return 1; + CONS(str_FASC, @'si::load-bytecodes')); +#endif + ECL_SET(@'ext::*load-hooks*', aux); + init_error(); + init_macros(); + init_compiler(); + + /* + * Set up infrastructure for CLOS. + */ + ECL_SET(@'si::*class-name-hash-table*', + cl__make_hash_table(@'eq', ecl_make_fixnum(1024), /* size */ + cl_core.rehash_size, + cl_core.rehash_threshold)); + + /* + * Features. + */ + + ECL_SET(@'LAMBDA-LIST-KEYWORDS', + cl_list(8, @'&optional', @'&rest', @'&key', @'&allow-other-keys', + @'&aux', @'&whole', @'&environment', @'&body')); + + for (i = 0, features = ECL_NIL; feature_names[i].elt.self; i++) { + int flag; + cl_object name = (cl_object)(feature_names + i); + cl_object key = ecl_intern(name, cl_core.keyword_package, &flag); + features = CONS(key, features); + } + + ECL_SET(@'*features*', features); + + ECL_SET(@'*package*', cl_core.lisp_package); + + /* This has to come before init_LSP/CLOS, because we need + * ecl_clear_compiler_properties() to work in init_CLOS(). */ + ecl_set_option(ECL_OPT_BOOTED, 1); + + ecl_init_module(OBJNULL,init_lib_LSP); + + if (cl_fboundp(@'ext::make-encoding') != ECL_NIL) { + maybe_fix_console_stream(cl_core.standard_input); + maybe_fix_console_stream(cl_core.standard_output); + maybe_fix_console_stream(cl_core.error_output); + } + + /* Jump to top level */ + ECL_SET(@'*package*', cl_core.user_package); + init_unixint(1); + return 1; } /************************* ENVIRONMENT ROUTINES ***********************/ @(defun ext::quit (&optional (code ecl_make_fixnum(0)) (kill_all_threads ECL_T)) -@ -{ +@ { #ifdef ECL_THREADS - if (!Null(kill_all_threads)) { - cl_object this = the_env->own_process; - cl_object p, all_threads = mp_all_processes(); - for (p = all_threads; !Null(p); p = ECL_CONS_CDR(p)) { - cl_object process = ECL_CONS_CAR(p); - if (process != this) - mp_process_kill(process); - } - for (p = all_threads; !Null(p); p = ECL_CONS_CDR(p)) { - cl_object process = ECL_CONS_CAR(p); - if (process != this) - mp_process_join(process); - } - /* FIXME! We need to do this because of a problem in GC - * When the thread exits, sometimes the dyld library gets - * called, and if we call dlopen() at the same time we - * cause ECL to hang */ - ecl_musleep(1e-3, 1); - } -#endif - ECL_SET(@'ext::*program-exit-code*', code); - if (the_env->frs_org <= the_env->frs_top) - ecl_unwind(the_env, the_env->frs_org); - si_exit(1, code); -} + if (!Null(kill_all_threads)) { + cl_object this_process = the_env->own_process; + cl_object p, all_threads = mp_all_processes(); + for (p = all_threads; !Null(p); p = ECL_CONS_CDR(p)) { + cl_object process = ECL_CONS_CAR(p); + if (process != this_process) + mp_process_kill(process); + } + for (p = all_threads; !Null(p); p = ECL_CONS_CDR(p)) { + cl_object process = ECL_CONS_CAR(p); + if (process != this_process) + mp_process_join(process); + } + /* FIXME! We need to do this because of a problem in GC + * When the thread exits, sometimes the dyld library gets + * called, and if we call dlopen() at the same time we + * cause ECL to hang */ + ecl_musleep(1e-3, 1); + } +#endif + ECL_SET(@'ext::*program-exit-code*', code); + if (the_env->frs_org <= the_env->frs_top) + ecl_unwind(the_env, the_env->frs_org); + si_exit(1, code); + } @) @(defun ext::exit (&optional (code ECL_SYM_VAL(ecl_process_env(),@'ext::*program-exit-code*'))) @ - cl_shutdown(); - exit(ECL_FIXNUMP(code)? ecl_fixnum(code) : 0); + cl_shutdown(); + exit(ECL_FIXNUMP(code)? ecl_fixnum(code) : 0); @) cl_object si_argc() { - @(return ecl_make_fixnum(ARGC)) + @(return ecl_make_fixnum(ARGC)); } cl_object si_argv(cl_object index) { - if (ECL_FIXNUMP(index)) { - cl_fixnum i = ecl_fixnum(index); - if (i >= 0 && i < ARGC) - @(return make_base_string_copy(ARGV[i])); - } - FEerror("Illegal argument index: ~S.", 1, index); + if (ECL_FIXNUMP(index)) { + cl_fixnum i = ecl_fixnum(index); + if (i >= 0 && i < ARGC) { + @(return make_base_string_copy(ARGV[i])); + } + } + FEerror("Illegal argument index: ~S.", 1, index); } cl_object si_getenv(cl_object var) { - const char *value; + const char *value; - /* Strings have to be null terminated base strings */ - var = si_copy_to_simple_base_string(var); - value = getenv((char*)var->base_string.self); - @(return ((value == NULL)? ECL_NIL : make_base_string_copy(value))) + /* Strings have to be null terminated base strings */ + var = si_copy_to_simple_base_string(var); + value = getenv((char*)var->base_string.self); + @(return ((value == NULL)? ECL_NIL : make_base_string_copy(value))); } #if defined(HAVE_SETENV) || defined(HAVE_PUTENV) cl_object si_setenv(cl_object var, cl_object value) { - const cl_env_ptr the_env = ecl_process_env(); - cl_fixnum ret_val; + const cl_env_ptr the_env = ecl_process_env(); + cl_fixnum ret_val; - /* Strings have to be null terminated base strings */ - var = si_copy_to_simple_base_string(var); - if (value == ECL_NIL) { + /* Strings have to be null terminated base strings */ + var = si_copy_to_simple_base_string(var); + if (value == ECL_NIL) { #ifdef HAVE_SETENV - /* Remove the variable when setting to nil, so that - * (si:setenv "foo" nil), then (si:getenv "foo) returns - * the right thing. */ - unsetenv((char*)var->base_string.self); + /* Remove the variable when setting to nil, so that + * (si:setenv "foo" nil), then (si:getenv "foo) returns + * the right thing. */ + unsetenv((char*)var->base_string.self); #else #if defined(ECL_MS_WINDOWS_HOST) - si_setenv(var, cl_core.null_string); + si_setenv(var, cl_core.null_string); #else - putenv((char*)var->base_string.self); + putenv((char*)var->base_string.self); #endif #endif - ret_val = 0; - } else { + ret_val = 0; + } else { #ifdef HAVE_SETENV - value = si_copy_to_simple_base_string(value); - ret_val = setenv((char*)var->base_string.self, - (char*)value->base_string.self, 1); -#else - value = cl_format(4, ECL_NIL, make_constant_base_string("~A=~A"), var, - value); - value = si_copy_to_simple_base_string(value); - putenv((char*)value->base_string.self); -#endif - } - if (ret_val == -1) - CEerror(ECL_T, "SI:SETENV failed: insufficient space in environment.", - 1, ECL_NIL); - ecl_return1(the_env, value); + value = si_copy_to_simple_base_string(value); + ret_val = setenv((char*)var->base_string.self, + (char*)value->base_string.self, 1); +#else + value = cl_format(4, ECL_NIL, make_constant_base_string("~A=~A"), var, + value); + value = si_copy_to_simple_base_string(value); + putenv((char*)value->base_string.self); +#endif + } + if (ret_val == -1) + CEerror(ECL_T, "SI:SETENV failed: insufficient space in environment.", + 1, ECL_NIL); + ecl_return1(the_env, value); } #endif cl_object si_environ(void) { - cl_object output = ECL_NIL; + cl_object output = ECL_NIL; #ifdef HAVE_ENVIRON - char **p; - extern char **environ; - for (p = environ; *p; p++) { - output = CONS(make_constant_base_string(*p), output); - } - output = cl_nreverse(output); + char **p; + extern char **environ; + for (p = environ; *p; p++) { + output = CONS(make_constant_base_string(*p), output); + } + output = cl_nreverse(output); #else # if defined(ECL_MS_WINDOWS_HOST) - LPTCH p; - for (p = GetEnvironmentStrings(); *p; ) { - output = CONS(make_constant_base_string(p), output); - do { (void)0; } while (*(p++)); - } - output = cl_nreverse(output); + LPTCH p; + for (p = GetEnvironmentStrings(); *p; ) { + output = CONS(make_constant_base_string(p), output); + do { (void)0; } while (*(p++)); + } + output = cl_nreverse(output); # endif #endif /* HAVE_ENVIRON */ - @(return output) + @(return output); } cl_object si_pointer(cl_object x) { - const cl_env_ptr the_env = ecl_process_env(); - ecl_return1(the_env, ecl_make_unsigned_integer((cl_index)x)); + const cl_env_ptr the_env = ecl_process_env(); + ecl_return1(the_env, ecl_make_unsigned_integer((cl_index)x)); } #if defined(ECL_MS_WINDOWS_HOST) void ecl_get_commandline_args(int* argc, char*** argv) { - LPWSTR *wArgs; - int i; + LPWSTR *wArgs; + int i; - if (argc == NULL || argv == NULL) - return; + if (argc == NULL || argv == NULL) + return; - wArgs = CommandLineToArgvW(GetCommandLineW(), argc); - *argv = (char**)malloc(sizeof(char*)*(*argc)); - for (i=0; i<*argc; i++) { - int len = wcslen(wArgs[i]); - (*argv)[i] = (char*)malloc(2*(len+1)); - wcstombs((*argv)[i], wArgs[i], len+1); - } - LocalFree(wArgs); + wArgs = CommandLineToArgvW(GetCommandLineW(), argc); + *argv = (char**)malloc(sizeof(char*)*(*argc)); + for (i=0; i<*argc; i++) { + int len = wcslen(wArgs[i]); + (*argv)[i] = (char*)malloc(2*(len+1)); + wcstombs((*argv)[i], wArgs[i], len+1); + } + LocalFree(wArgs); } #endif diff -Nru ecl-16.1.2/src/c/Makefile.in ecl-16.1.3+ds/src/c/Makefile.in --- ecl-16.1.2/src/c/Makefile.in 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/Makefile.in 1970-01-01 00:00:00.000000000 +0000 @@ -1,164 +0,0 @@ -# -*- Mode: Makefile; indent-tabs-mode: nil -*- -# vim: set filetype=makefile tabstop=8 shiftwidth=4 expandtab: - -# -# Makefile for ECL core library -# -top_srcdir= @top_srcdir@ -srcdir = @srcdir@ -VPATH = @srcdir@ - -# Programs used by "make": -# -CC = @CC@ -TRUE_CC = $(CC) -CFLAGS = -I. -I@true_builddir@ -I$(srcdir) -I../ecl/gc -DECL_API -DECL_NO_LEGACY @CPPFLAGS@ @CFLAGS@ @ECL_CFLAGS@ -c - -# The following flags could be added and used by GCC -# -Wall -W -Wfloat-equal -Wundef -Wendif-labels -Wpointer-arith -Wcast-align \ -# -Wwrite-strings -Wconversion -Wsign-compare -Wmissing-prototypes \ -# -Wredundant-decls -Wunreachable-code -Winline - -SHELL = /bin/sh -RM = @RM@ -EXE = @EXEEXT@ -DPP = ./dpp$(EXE) -RANLIB = @RANLIB@ -AR = @AR@ - -# Data for installation -# -INSTALL = @INSTALL@ -INSTALL_DATA = @INSTALL_DATA@ -prefix=@prefix@ -exec_prefix=@exec_prefix@ -libdir=@libdir@ -includedir=@includedir@ - -# Files - -HDIR = ../ecl -HFILES = $(HDIR)/config.h $(HDIR)/ecl.h $(HDIR)/ecl-cmp.h\ - $(HDIR)/object.h $(HDIR)/cs.h $(HDIR)/stacks.h\ - $(HDIR)/external.h $(HDIR)/cons.h $(HDIR)/legacy.h\ - $(HDIR)/number.h $(HDIR)/page.h $(HDIR)/unify.h -OBJS = main.o symbol.o package.o cons.o list.o\ - apply.o eval.o interpreter.o compiler.o disassembler.o \ - instance.o gfun.o clos/cache.o clos/accessor.o \ - reference.o character.o\ - file.o read.o print.o error.o string.o cfun.o\ - reader/parse_integer.o reader/parse_number.o \ - printer/float_to_digits.o printer/float_to_string.o \ - printer/integer_to_string.o printer/write_ugly.o \ - printer/write_object.o printer/write_symbol.o \ - printer/write_array.o printer/write_list.o printer/write_code.o \ - printer/write_sse.o printer/print_unreadable.o \ - ffi/libraries.o ffi/backtrace.o ffi/mmap.o ffi/cdata.o \ - numbers/cos.o numbers/sin.o numbers/tan.o numbers/atan.o \ - numbers/cosh.o numbers/sinh.o numbers/tanh.o \ - numbers/exp.o numbers/expt.o numbers/log.o \ - numbers/sqrt.o numbers/abs.o \ - numbers/zerop.o numbers/plusp.o numbers/minusp.o \ - numbers/negate.o numbers/conjugate.o \ - numbers/one_plus.o numbers/one_minus.o \ - numbers/plus.o numbers/minus.o numbers/times.o numbers/divide.o \ - numbers/number_compare.o numbers/number_equalp.o numbers/minmax.o \ - numbers/floor.o numbers/ceiling.o numbers/round.o numbers/truncate.o \ - typespec.o assignment.o \ - predicate.o number.o\ - num_pred.o num_arith.o num_co.o\ - num_log.o num_rand.o array.o vector_push.o sequence.o cmpaux.o\ - macros.o backq.o stacks.o \ - time.o unixint.o\ - mapfun.o multival.o hash.o format.o pathname.o\ - structure.o load.o unixfsys.o unixsys.o \ - serialize.o ffi.o sse2.o @EXTRA_OBJS@ threads/atomic.o - -.SUFFIXES: .c .o .d .s -.PHONY: all - -all: $(DPP) ../libeclmin.a ../cinit.o - -.d.c: $(DPP) - if test -f ../CROSS-DPP ; then ../CROSS-DPP $< $@ ; else $(DPP) $< $@ ; fi -.d.o: $(DPP) - if test -f ../CROSS-DPP ; then ../CROSS-DPP $< $@.c ; else $(DPP) $< $@.c ; fi - $(CC) -DECLDIR="\"@ecldir@\"" $(CFLAGS) -o $@ $@.c -.c.o: - $(CC) -DECLDIR="\"@ecldir@\"" $(CFLAGS) -o $@ $< -.d.s: $(HFILES) - if test -f ../CROSS-DPP ; then ../CROSS-DPP $< $@.c ; else $(DPP) $< $@.c ; fi - $(CC) -DECLDIR="\"@ecldir@\"" $(CFLAGS) -S -o $@ $@.c -#.c.o: $(HFILES) -# $(CC) -DECLDIR="\"@ecldir@\"" $(CFLAGS) -o $@ $< -apply_x86.c: $(srcdir)/arch/apply_x86.d $(DPP) $(HFILES) - if test -f ../CROSS-DPP ; then \ - ../CROSS-DPP $(srcdir)/arch/apply_x86.d $@ ; \ - else $(DPP) $(srcdir)/arch/apply_x86.d $@ ; \ - fi -ffi_x86.c: $(srcdir)/arch/ffi_x86.d $(DPP) $(HFILES) - if test -f ../CROSS-DPP ; then \ - ../CROSS-DPP $(srcdir)/arch/ffi_x86.d $@ ; \ - else $(DPP) $(srcdir)/arch/ffi_x86.d $@ ; \ - fi -ffi_x86_64.c: $(srcdir)/arch/ffi_x86_64.d $(DPP) $(HFILES) - if test -f ../CROSS-DPP ; then \ - ../CROSS-DPP $(srcdir)/arch/ffi_x86_64.d $@ ; \ - else $(DPP) $(srcdir)/arch/ffi_x86_64.d $@ ; \ - fi - -../libeclmin.a: $(OBJS) all_symbols.o all_symbols2.o - $(RM) $@ - $(AR) cr $@ $(OBJS) - $(RANLIB) $@ - -clean: - $(RM) $(DPP) *.c *.h $(OBJS) all_symbols.o all_symbols2.o ../libecl.a cinit.o core a.out tmp.c - -# Build rules - -$(DPP): $(srcdir)/dpp.c $(srcdir)/symbols_list2.h - if test -f ../CROSS-DPP; then touch dpp; else \ - $(TRUE_CC) -I$(srcdir) -I@true_builddir@ -I./ $(srcdir)/dpp.c @CPPFLAGS@ @CFLAGS@ @ECL_CFLAGS@ -o $@ ; \ - fi - -$(OBJS): $(DPP) -# -# symbols_list2.h is built this way to allow for an atomic replacement of -# the file. Otherwise we have problem when doing concurrent builds with -# rsync updates of the source tree. -# -$(srcdir)/symbols_list2.h: $(srcdir)/symbols_list.h Makefile - cat $(srcdir)/symbols_list.h | \ - sed -e 's%{\([A-Z ]*.*".*"\),[^,]*,[ ]*NULL,.*}%{\1,NULL}%g' \ - -e 's%{\([A-Z ]*.*".*"\),[^,]*,[ ]*\([^,]*\),.*}%{\1,"\2"}%g' \ - -e 's%{NULL.*%{NULL,NULL}};%' | \ - sed -e 's%"\(IF_[A-Z0-9]*\)(\([^)]*\))"%\1("\2")%g' > tmp.h - mv tmp.h $@ - -# -# GCC might break this code -# -gbc.o: gbc.c $(HFILES) - $(CC) $(CFLAGS) -O0 gbc.c -o $@ -# -# This reduces the overhead of jumping to other functions -# -apply.c: $(DPP) -apply.o: apply.c $(HFILES) $(HDIR)/cs.h - $(CC) $(CFLAGS) apply.c -o $@ -# -# These files are interrelated -# -all_symbols.c: $(DPP) -all_symbols.o: all_symbols.c - $(CC) $(CFLAGS) -I./ all_symbols.c -o $@ -all_symbols2.o: all_symbols.c - $(CC) $(CFLAGS) -DECL_FINAL -I./ all_symbols.c -o $@ - -# -# This is in another directory -# -cinit.c: $(DPP) -../cinit.o: cinit.c $(HFILES) - $(CC) $(CFLAGS) -I./ cinit.c -o $@ diff -Nru ecl-16.1.2/src/c/mapfun.d ecl-16.1.3+ds/src/c/mapfun.d --- ecl-16.1.2/src/c/mapfun.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/mapfun.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,177 +1,171 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - mapfun.c -- Mapping. -*/ -/* - Copyright (c) 1993, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ - + * mapfun.d - mapping + * + * Copyright (c) 1993 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include #include -#define PREPARE_MAP(env, list, cdrs_frame, cars_frame, narg) \ - struct ecl_stack_frame frames_aux[2]; \ - const cl_object cdrs_frame = (cl_object)frames_aux; \ - const cl_object cars_frame = (cl_object)(frames_aux+1); \ - ECL_STACK_FRAME_FROM_VA_LIST(env,cdrs_frame,list); \ - ECL_STACK_FRAME_COPY(cars_frame, cdrs_frame); \ - narg = cars_frame->frame.size; \ - if (ecl_unlikely(narg == 0)) { \ - FEprogram_error_noreturn("MAP*: Too few arguments", 0); \ - } +#define PREPARE_MAP(env, list, cdrs_frame, cars_frame, narg) \ + struct ecl_stack_frame frames_aux[2]; \ + const cl_object cdrs_frame = (cl_object)frames_aux; \ + const cl_object cars_frame = (cl_object)(frames_aux+1); \ + ECL_STACK_FRAME_FROM_VA_LIST(env,cdrs_frame,list); \ + ECL_STACK_FRAME_COPY(cars_frame, cdrs_frame); \ + narg = cars_frame->frame.size; \ + if (ecl_unlikely(narg == 0)) { \ + FEprogram_error_noreturn("MAP*: Too few arguments", 0); \ + } @(defun mapcar (fun &rest lists) - cl_object res, *val = &res; + cl_object res, *val = &res; @ { - PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg); - res = ECL_NIL; - while (TRUE) { - cl_index i; - for (i = 0; i < narg; i++) { - cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i); - if (ecl_unlikely(!LISTP(cdr))) - FEwrong_type_nth_arg(@[mapcar], i+2, cdr, @[list]); - if (Null(cdr)) { - ecl_stack_frame_close(cars_frame); - ecl_stack_frame_close(cdrs_frame); - @(return res) - } - ECL_STACK_FRAME_SET(cars_frame, i, ECL_CONS_CAR(cdr)); - ECL_STACK_FRAME_SET(cdrs_frame, i, ECL_CONS_CDR(cdr)); - } - *val = ecl_list1(ecl_apply_from_stack_frame(cars_frame, fun)); - val = &ECL_CONS_CDR(*val); - } + PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg); + res = ECL_NIL; + while (TRUE) { + cl_index i; + for (i = 0; i < narg; i++) { + cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i); + if (ecl_unlikely(!LISTP(cdr))) + FEwrong_type_nth_arg(@[mapcar], i+2, cdr, @[list]); + if (Null(cdr)) { + ecl_stack_frame_close(cars_frame); + ecl_stack_frame_close(cdrs_frame); + @(return res) + } + ECL_STACK_FRAME_SET(cars_frame, i, ECL_CONS_CAR(cdr)); + ECL_STACK_FRAME_SET(cdrs_frame, i, ECL_CONS_CDR(cdr)); + } + *val = ecl_list1(ecl_apply_from_stack_frame(cars_frame, fun)); + val = &ECL_CONS_CDR(*val); + } } @) @(defun maplist (fun &rest lists) - cl_object res, *val = &res; + cl_object res, *val = &res; @ { - PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg); - res = ECL_NIL; - while (TRUE) { - cl_index i; - for (i = 0; i < narg; i++) { - cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i); - if (ecl_unlikely(!LISTP(cdr))) - FEwrong_type_nth_arg(@[maplist], i+2, cdr, @[list]); - if (Null(cdr)) { - ecl_stack_frame_close(cars_frame); - ecl_stack_frame_close(cdrs_frame); - @(return res) - } - ECL_STACK_FRAME_SET(cars_frame, i, cdr); - ECL_STACK_FRAME_SET(cdrs_frame, i, ECL_CONS_CDR(cdr)); - } - *val = ecl_list1(ecl_apply_from_stack_frame(cars_frame, fun)); - val = &ECL_CONS_CDR(*val); - } + PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg); + res = ECL_NIL; + while (TRUE) { + cl_index i; + for (i = 0; i < narg; i++) { + cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i); + if (ecl_unlikely(!LISTP(cdr))) + FEwrong_type_nth_arg(@[maplist], i+2, cdr, @[list]); + if (Null(cdr)) { + ecl_stack_frame_close(cars_frame); + ecl_stack_frame_close(cdrs_frame); + @(return res) + } + ECL_STACK_FRAME_SET(cars_frame, i, cdr); + ECL_STACK_FRAME_SET(cdrs_frame, i, ECL_CONS_CDR(cdr)); + } + *val = ecl_list1(ecl_apply_from_stack_frame(cars_frame, fun)); + val = &ECL_CONS_CDR(*val); + } } @) @(defun mapc (fun &rest lists) - cl_object onelist; + cl_object onelist; @ { - PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg); - onelist = ECL_STACK_FRAME_REF(cdrs_frame, 0); - while (TRUE) { - cl_index i; - for (i = 0; i < narg; i++) { - cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i); - if (ecl_unlikely(!LISTP(cdr))) - FEwrong_type_nth_arg(@[mapc], i+2, cdr, @[list]); - if (Null(cdr)) { - ecl_stack_frame_close(cars_frame); - ecl_stack_frame_close(cdrs_frame); - @(return onelist) - } - ECL_STACK_FRAME_SET(cars_frame, i, ECL_CONS_CAR(cdr)); - ECL_STACK_FRAME_SET(cdrs_frame, i, ECL_CONS_CDR(cdr)); - } - ecl_apply_from_stack_frame(cars_frame, fun); - } + PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg); + onelist = ECL_STACK_FRAME_REF(cdrs_frame, 0); + while (TRUE) { + cl_index i; + for (i = 0; i < narg; i++) { + cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i); + if (ecl_unlikely(!LISTP(cdr))) + FEwrong_type_nth_arg(@[mapc], i+2, cdr, @[list]); + if (Null(cdr)) { + ecl_stack_frame_close(cars_frame); + ecl_stack_frame_close(cdrs_frame); + @(return onelist) + } + ECL_STACK_FRAME_SET(cars_frame, i, ECL_CONS_CAR(cdr)); + ECL_STACK_FRAME_SET(cdrs_frame, i, ECL_CONS_CDR(cdr)); + } + ecl_apply_from_stack_frame(cars_frame, fun); + } } @) @(defun mapl (fun &rest lists) - cl_object onelist; + cl_object onelist; @ { - PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg); - onelist = ECL_STACK_FRAME_REF(cdrs_frame, 0); - while (TRUE) { - cl_index i; - for (i = 0; i < narg; i++) { - cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i); - if (ecl_unlikely(!LISTP(cdr))) - FEwrong_type_nth_arg(@[mapl], i+2, cdr, @[list]); - if (Null(cdr)) { - ecl_stack_frame_close(cars_frame); - ecl_stack_frame_close(cdrs_frame); - @(return onelist) - } - ECL_STACK_FRAME_SET(cars_frame, i, cdr); - ECL_STACK_FRAME_SET(cdrs_frame, i, ECL_CONS_CDR(cdr)); - } - ecl_apply_from_stack_frame(cars_frame, fun); - } + PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg); + onelist = ECL_STACK_FRAME_REF(cdrs_frame, 0); + while (TRUE) { + cl_index i; + for (i = 0; i < narg; i++) { + cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i); + if (ecl_unlikely(!LISTP(cdr))) + FEwrong_type_nth_arg(@[mapl], i+2, cdr, @[list]); + if (Null(cdr)) { + ecl_stack_frame_close(cars_frame); + ecl_stack_frame_close(cdrs_frame); + @(return onelist) + } + ECL_STACK_FRAME_SET(cars_frame, i, cdr); + ECL_STACK_FRAME_SET(cdrs_frame, i, ECL_CONS_CDR(cdr)); + } + ecl_apply_from_stack_frame(cars_frame, fun); + } } @) @(defun mapcan (fun &rest lists) - cl_object res, *val = &res; + cl_object res, *val = &res; @ { - PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg); - res = ECL_NIL; - while (TRUE) { - cl_index i; - for (i = 0; i < narg; i++) { - cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i); - if (ecl_unlikely(!LISTP(cdr))) - FEwrong_type_nth_arg(@[mapcan], i+2, cdr, @[list]); - if (Null(cdr)) { - ecl_stack_frame_close(cars_frame); - ecl_stack_frame_close(cdrs_frame); - @(return res) - } - ECL_STACK_FRAME_SET(cars_frame, i, ECL_CONS_CAR(cdr)); - ECL_STACK_FRAME_SET(cdrs_frame, i, ECL_CONS_CDR(cdr)); - } - *val = ecl_apply_from_stack_frame(cars_frame, fun); - while (CONSP(*val)) - val = &ECL_CONS_CDR(*val); - } + PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg); + res = ECL_NIL; + while (TRUE) { + cl_index i; + for (i = 0; i < narg; i++) { + cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i); + if (ecl_unlikely(!LISTP(cdr))) + FEwrong_type_nth_arg(@[mapcan], i+2, cdr, @[list]); + if (Null(cdr)) { + ecl_stack_frame_close(cars_frame); + ecl_stack_frame_close(cdrs_frame); + @(return res) + } + ECL_STACK_FRAME_SET(cars_frame, i, ECL_CONS_CAR(cdr)); + ECL_STACK_FRAME_SET(cdrs_frame, i, ECL_CONS_CDR(cdr)); + } + *val = ecl_apply_from_stack_frame(cars_frame, fun); + while (CONSP(*val)) + val = &ECL_CONS_CDR(*val); + } } @) @(defun mapcon (fun &rest lists) - cl_object res, *val = &res; + cl_object res, *val = &res; @ { - PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg); - res = ECL_NIL; - while (TRUE) { - cl_index i; - for (i = 0; i < narg; i++) { - cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i); - if (ecl_unlikely(!LISTP(cdr))) - FEwrong_type_nth_arg(@[mapcon], i+2, cdr, @[list]); - if (Null(cdr)) { - ecl_stack_frame_close(cars_frame); - ecl_stack_frame_close(cdrs_frame); - @(return res) - } - ECL_STACK_FRAME_SET(cars_frame, i, cdr); - ECL_STACK_FRAME_SET(cdrs_frame, i, ECL_CONS_CDR(cdr)); - } - *val = ecl_apply_from_stack_frame(cars_frame, fun); - while (CONSP(*val)) - val = &ECL_CONS_CDR(*val); - } + PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg); + res = ECL_NIL; + while (TRUE) { + cl_index i; + for (i = 0; i < narg; i++) { + cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i); + if (ecl_unlikely(!LISTP(cdr))) + FEwrong_type_nth_arg(@[mapcon], i+2, cdr, @[list]); + if (Null(cdr)) { + ecl_stack_frame_close(cars_frame); + ecl_stack_frame_close(cdrs_frame); + @(return res) + } + ECL_STACK_FRAME_SET(cars_frame, i, cdr); + ECL_STACK_FRAME_SET(cdrs_frame, i, ECL_CONS_CDR(cdr)); + } + *val = ecl_apply_from_stack_frame(cars_frame, fun); + while (CONSP(*val)) + val = &ECL_CONS_CDR(*val); + } } @) diff -Nru ecl-16.1.2/src/c/multival.d ecl-16.1.3+ds/src/c/multival.d --- ecl-16.1.2/src/c/multival.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/multival.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,55 +1,49 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - multival.c -- Multiple Values. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - - ECoLisp 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. - - See file '../Copyright' for full details. -*/ - + * multival.d -- multiple values + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @(defun values (&rest args) - cl_object output; + cl_object output; @ - unlikely_if (narg > ECL_MULTIPLE_VALUES_LIMIT) - FEerror("Too many values in VALUES",0); - the_env->nvalues = narg; - output = ECL_NIL; - if (narg) { - int i = 0; - do { - the_env->values[i] = ecl_va_arg(args); - } while (++i < narg); - output = the_env->values[0]; - } - return output; + unlikely_if (narg > ECL_MULTIPLE_VALUES_LIMIT) + FEerror("Too many values in VALUES",0); + the_env->nvalues = narg; + output = ECL_NIL; + if (narg) { + int i = 0; + do { + the_env->values[i] = ecl_va_arg(args); + } while (++i < narg); + output = the_env->values[0]; + } + return output; @) cl_object cl_values_list(cl_object list) { - cl_env_ptr the_env = ecl_process_env(); - int i; - the_env->values[0] = ECL_NIL; - for (i = 0; !Null(list); list=ECL_CONS_CDR(list)) { - unlikely_if (!LISTP(list)) - FEtype_error_list(list); - unlikely_if (i == ECL_MULTIPLE_VALUES_LIMIT) - FEerror("Too many values in VALUES-LIST",0); - the_env->values[i++] = ECL_CONS_CAR(list); - } - the_env->nvalues = i; - return the_env->values[0]; + cl_env_ptr the_env = ecl_process_env(); + int i; + the_env->values[0] = ECL_NIL; + for (i = 0; !Null(list); list=ECL_CONS_CDR(list)) { + unlikely_if (!LISTP(list)) + FEtype_error_list(list); + unlikely_if (i == ECL_MULTIPLE_VALUES_LIMIT) + FEerror("Too many values in VALUES-LIST",0); + the_env->values[i++] = ECL_CONS_CAR(list); + } + the_env->nvalues = i; + return the_env->values[0]; } diff -Nru ecl-16.1.2/src/c/newhash.h ecl-16.1.3+ds/src/c/newhash.h --- ecl-16.1.2/src/c/newhash.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/newhash.h 2016-12-19 10:25:00.000000000 +0000 @@ -15,71 +15,71 @@ */ #define GOLDEN_RATIO 0x9e3779b97f4a7c13L #define mix(a,b,c) \ - { \ - a=a-b; a=a-c; a=a^(c>>43); \ - b=b-c; b=b-a; b=b^(a<<9); \ - c=c-a; c=c-b; c=c^(b>>8); \ - a=a-b; a=a-c; a=a^(c>>38); \ - b=b-c; b=b-a; b=b^(a<<23); \ - c=c-a; c=c-b; c=c^(b>>5); \ - a=a-b; a=a-c; a=a^(c>>35); \ - b=b-c; b=b-a; b=b^(a<<49); \ - c=c-a; c=c-b; c=c^(b>>11); \ - a=a-b; a=a-c; a=a^(c>>12); \ - b=b-c; b=b-a; b=b^(a<<18); \ - c=c-a; c=c-b; c=c^(b>>22); \ - } + { \ + a=a-b; a=a-c; a=a^(c>>43); \ + b=b-c; b=b-a; b=b^(a<<9); \ + c=c-a; c=c-b; c=c^(b>>8); \ + a=a-b; a=a-c; a=a^(c>>38); \ + b=b-c; b=b-a; b=b^(a<<23); \ + c=c-a; c=c-b; c=c^(b>>5); \ + a=a-b; a=a-c; a=a^(c>>35); \ + b=b-c; b=b-a; b=b^(a<<49); \ + c=c-a; c=c-b; c=c^(b>>11); \ + a=a-b; a=a-c; a=a^(c>>12); \ + b=b-c; b=b-a; b=b^(a<<18); \ + c=c-a; c=c-b; c=c^(b>>22); \ + } #define extract_word(k) \ - (k[0]+((cl_index)k[1]<<8)+((cl_index)k[2]<<16)+((cl_index)k[3]<<24)+ \ - ((cl_index)k[4]<<32)+((cl_index)k[5]<<40)+((cl_index)k[6]<<48)+ \ - ((cl_index)k[7]<<52)) + (k[0]+((cl_index)k[1]<<8)+((cl_index)k[2]<<16)+((cl_index)k[3]<<24)+ \ + ((cl_index)k[4]<<32)+((cl_index)k[5]<<40)+((cl_index)k[6]<<48)+ \ + ((cl_index)k[7]<<52)) static cl_index hash_string(cl_index initval, const unsigned char *k, cl_index length) { - register cl_index a = GOLDEN_RATIO, b = GOLDEN_RATIO, c = initval; - register cl_index len; - for (len = length; len >= 24; len -= 24) { - a += extract_word(k); k+=8; - b += extract_word(k); k+=8; - c += extract_word(k); k+=8; - mix(a,b,c); - } - - /*------------------------------------- handle the last 11 bytes */ - c += length; - switch(len) { - /* all the case statements fall through */ - case 23: c+=((cl_index)k[22]<<52); - case 22: c+=((cl_index)k[21]<<48); - case 21: c+=((cl_index)k[20]<<40); - case 20: c+=((cl_index)k[19]<<32); - case 19: c+=((cl_index)k[18]<<24); - case 18: c+=((cl_index)k[17]<<16); - case 17: c+=((cl_index)k[16]<<8); - /* the first byte of c is reserved for the length */ - case 16: b+=((cl_index)k[15]<<52); - case 15: b+=((cl_index)k[14]<<48); - case 14: b+=((cl_index)k[13]<<40); - case 13: b+=((cl_index)k[12]<<32); - case 12: b+=((cl_index)k[11]<<24); - case 11: b+=((cl_index)k[10]<<16); - case 10: b+=((cl_index)k[9]<<8); - case 9 : b+=k[8]; - case 8 : a+=((cl_index)k[7]<<52); - case 7 : a+=((cl_index)k[6]<<48); - case 6 : a+=((cl_index)k[5]<<40); - case 5 : a+=((cl_index)k[4]<<32); - case 4 : a+=((cl_index)k[3]<<24); - case 3 : a+=((cl_index)k[2]<<16); - case 2 : a+=((cl_index)k[1]<<8); - case 1 : a+=k[0]; - /* case 0: nothing left to add */ - } - mix(a,b,c); - /*-------------------------------------------- report the result */ - return c; + register cl_index a = GOLDEN_RATIO, b = GOLDEN_RATIO, c = initval; + register cl_index len; + for (len = length; len >= 24; len -= 24) { + a += extract_word(k); k+=8; + b += extract_word(k); k+=8; + c += extract_word(k); k+=8; + mix(a,b,c); + } + + /*------------------------------------- handle the last 11 bytes */ + c += length; + switch(len) { + /* all the case statements fall through */ + case 23: c+=((cl_index)k[22]<<52); + case 22: c+=((cl_index)k[21]<<48); + case 21: c+=((cl_index)k[20]<<40); + case 20: c+=((cl_index)k[19]<<32); + case 19: c+=((cl_index)k[18]<<24); + case 18: c+=((cl_index)k[17]<<16); + case 17: c+=((cl_index)k[16]<<8); + /* the first byte of c is reserved for the length */ + case 16: b+=((cl_index)k[15]<<52); + case 15: b+=((cl_index)k[14]<<48); + case 14: b+=((cl_index)k[13]<<40); + case 13: b+=((cl_index)k[12]<<32); + case 12: b+=((cl_index)k[11]<<24); + case 11: b+=((cl_index)k[10]<<16); + case 10: b+=((cl_index)k[9]<<8); + case 9 : b+=k[8]; + case 8 : a+=((cl_index)k[7]<<52); + case 7 : a+=((cl_index)k[6]<<48); + case 6 : a+=((cl_index)k[5]<<40); + case 5 : a+=((cl_index)k[4]<<32); + case 4 : a+=((cl_index)k[3]<<24); + case 3 : a+=((cl_index)k[2]<<16); + case 2 : a+=((cl_index)k[1]<<8); + case 1 : a+=k[0]; + /* case 0: nothing left to add */ + } + mix(a,b,c); + /*-------------------------------------------- report the result */ + return c; } #else @@ -89,97 +89,98 @@ #define GOLDEN_RATIO 0x9e3779b9L #define mix(a,b,c) \ - { \ - a -= b; a -= c; a ^= (c>>13); \ - b -= c; b -= a; b ^= (a<<8); \ - c -= a; c -= b; c ^= (b>>13); \ - a -= b; a -= c; a ^= (c>>12); \ - b -= c; b -= a; b ^= (a<<16); \ - c -= a; c -= b; c ^= (b>>5); \ - a -= b; a -= c; a ^= (c>>3); \ - b -= c; b -= a; b ^= (a<<10); \ - c -= a; c -= b; c ^= (b>>15); \ - } + { \ + a -= b; a -= c; a ^= (c>>13); \ + b -= c; b -= a; b ^= (a<<8); \ + c -= a; c -= b; c ^= (b>>13); \ + a -= b; a -= c; a ^= (c>>12); \ + b -= c; b -= a; b ^= (a<<16); \ + c -= a; c -= b; c ^= (b>>5); \ + a -= b; a -= c; a ^= (c>>3); \ + b -= c; b -= a; b ^= (a<<10); \ + c -= a; c -= b; c ^= (b>>15); \ + } + #define extract_word(k) \ - (k[0]+((cl_index)k[1]<<8)+((cl_index)k[2]<<16)+((cl_index)k[3]<<24)) + (k[0]+((cl_index)k[1]<<8)+((cl_index)k[2]<<16)+((cl_index)k[3]<<24)) static cl_index hash_string(cl_index initval, const unsigned char *k, cl_index length) { - register cl_index a = GOLDEN_RATIO, b = GOLDEN_RATIO, c = initval; - register cl_index len; - for (len = length; len >= 12; len -= 12) { - a += extract_word(k); k += 4; - b += extract_word(k); k += 4; - c += extract_word(k); k += 4; - mix(a,b,c); - } - - /*------------------------------------- handle the last 11 bytes */ - c += length; - switch(len) { - /* all the case statements fall through */ - case 11: c+=((cl_index)k[10]<<24); - case 10: c+=((cl_index)k[9]<<16); - case 9 : c+=((cl_index)k[8]<<8); - /* the first byte of c is reserved for the length */ - case 8 : b+=((cl_index)k[7]<<24); - case 7 : b+=((cl_index)k[6]<<16); - case 6 : b+=((cl_index)k[5]<<8); - case 5 : b+=k[4]; - case 4 : a+=((cl_index)k[3]<<24); - case 3 : a+=((cl_index)k[2]<<16); - case 2 : a+=((cl_index)k[1]<<8); - case 1 : a+=k[0]; - /* case 0: nothing left to add */ - } - mix(a,b,c); - /*-------------------------------------------- report the result */ - return c; + register cl_index a = GOLDEN_RATIO, b = GOLDEN_RATIO, c = initval; + register cl_index len; + for (len = length; len >= 12; len -= 12) { + a += extract_word(k); k += 4; + b += extract_word(k); k += 4; + c += extract_word(k); k += 4; + mix(a,b,c); + } + + /*------------------------------------- handle the last 11 bytes */ + c += length; + switch(len) { + /* all the case statements fall through */ + case 11: c+=((cl_index)k[10]<<24); + case 10: c+=((cl_index)k[9]<<16); + case 9 : c+=((cl_index)k[8]<<8); + /* the first byte of c is reserved for the length */ + case 8 : b+=((cl_index)k[7]<<24); + case 7 : b+=((cl_index)k[6]<<16); + case 6 : b+=((cl_index)k[5]<<8); + case 5 : b+=k[4]; + case 4 : a+=((cl_index)k[3]<<24); + case 3 : a+=((cl_index)k[2]<<16); + case 2 : a+=((cl_index)k[1]<<8); + case 1 : a+=k[0]; + /* case 0: nothing left to add */ + } + mix(a,b,c); + /*-------------------------------------------- report the result */ + return c; } #endif static cl_index hash_word(cl_index c, cl_index w) { - cl_index a = w + GOLDEN_RATIO, b = GOLDEN_RATIO; - mix(a, b, c); - return c; + cl_index a = w + GOLDEN_RATIO, b = GOLDEN_RATIO; + mix(a, b, c); + return c; } static cl_index hash_base_string(const ecl_base_char *s, cl_index len, cl_index h) { - cl_index a = GOLDEN_RATIO, b = GOLDEN_RATIO, i; - for (i = len; i >= 3; i -= 3) { - a += *s; s++; - b += *s; s++; - h += *s; s++; - mix(a, b, h); - } - switch (i) { - case 2: a += *s; s++; - case 1: b += *s; - default: h += len; - } - mix(a, b, h); - return h; + cl_index a = GOLDEN_RATIO, b = GOLDEN_RATIO, i; + for (i = len; i >= 3; i -= 3) { + a += *s; s++; + b += *s; s++; + h += *s; s++; + mix(a, b, h); + } + switch (i) { + case 2: a += *s; s++; + case 1: b += *s; + default: h += len; + } + mix(a, b, h); + return h; } #ifdef ECL_UNICODE static cl_index hash_full_string(const ecl_character *s, cl_index len, cl_index h) { - cl_index a = GOLDEN_RATIO, b = GOLDEN_RATIO, i; - for (i = len; i >= 3; i -= 3) { - a += (*s); s++; - b += (*s); s++; - h += (*s); s++; - mix(a, b, h); - } - switch (i) { - case 2: a += (*s); s++; - case 1: b += (*s); - default: h += len; - } - mix(a, b, h); - return h; + cl_index a = GOLDEN_RATIO, b = GOLDEN_RATIO, i; + for (i = len; i >= 3; i -= 3) { + a += (*s); s++; + b += (*s); s++; + h += (*s); s++; + mix(a, b, h); + } + switch (i) { + case 2: a += (*s); s++; + case 1: b += (*s); + default: h += len; + } + mix(a, b, h); + return h; } #endif diff -Nru ecl-16.1.2/src/c/num_arith.d ecl-16.1.3+ds/src/c/num_arith.d --- ecl-16.1.2/src/c/num_arith.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/num_arith.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,20 +1,15 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - num_arith.c -- Arithmetic operations -*/ -/* - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * num_arith.d - arithmetic operations + * + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -23,91 +18,93 @@ cl_object ecl_integer_divide(cl_object x, cl_object y) { - cl_type tx, ty; + cl_type tx, ty; - tx = ecl_t_of(x); - ty = ecl_t_of(y); - if (tx == t_fixnum) { - if (ty == t_fixnum) { - if (y == ecl_make_fixnum(0)) - FEdivision_by_zero(x, y); - return ecl_make_fixnum(ecl_fixnum(x) / ecl_fixnum(y)); - } else if (ty == t_bignum) { - return _ecl_fix_divided_by_big(ecl_fixnum(x), y); - } else { - FEwrong_type_nth_arg(@[round], 2, y, @[integer]); - } - } - if (tx == t_bignum) { - if (ty == t_bignum) { - return _ecl_big_divided_by_big(x, y); - } else if (ty == t_fixnum) { - return _ecl_big_divided_by_fix(x, ecl_fixnum(y)); - } else { - FEwrong_type_nth_arg(@[round], 2, y, @[integer]); - } - } - FEwrong_type_nth_arg(@[round], 1, x, @[integer]); + tx = ecl_t_of(x); + ty = ecl_t_of(y); + if (tx == t_fixnum) { + if (ty == t_fixnum) { + if (y == ecl_make_fixnum(0)) + FEdivision_by_zero(x, y); + return ecl_make_fixnum(ecl_fixnum(x) / ecl_fixnum(y)); + } else if (ty == t_bignum) { + return _ecl_fix_divided_by_big(ecl_fixnum(x), y); + } else { + FEwrong_type_nth_arg(@[round], 2, y, @[integer]); + } + } + if (tx == t_bignum) { + if (ty == t_bignum) { + return _ecl_big_divided_by_big(x, y); + } else if (ty == t_fixnum) { + return _ecl_big_divided_by_fix(x, ecl_fixnum(y)); + } else { + FEwrong_type_nth_arg(@[round], 2, y, @[integer]); + } + } + FEwrong_type_nth_arg(@[round], 1, x, @[integer]); } @(defun gcd (&rest nums) - cl_object gcd; + cl_object gcd; @ - if (narg == 0) - @(return ecl_make_fixnum(0)) - /* INV: ecl_gcd() checks types */ - gcd = ecl_va_arg(nums); - if (narg == 1) { - assert_type_integer(gcd); - @(return (ecl_minusp(gcd) ? ecl_negate(gcd) : gcd)) - } - while (--narg) - gcd = ecl_gcd(gcd, ecl_va_arg(nums)); - @(return gcd) + if (narg == 0) { + @(return ecl_make_fixnum(0)); + } + /* INV: ecl_gcd() checks types */ + gcd = ecl_va_arg(nums); + if (narg == 1) { + assert_type_integer(gcd); + @(return (ecl_minusp(gcd) ? ecl_negate(gcd) : gcd)); + } + while (--narg) + gcd = ecl_gcd(gcd, ecl_va_arg(nums)); + @(return gcd); @) cl_object ecl_gcd(cl_object x, cl_object y) { - ECL_WITH_TEMP_BIGNUM(x_big,1); - ECL_WITH_TEMP_BIGNUM(y_big,1); + ECL_WITH_TEMP_BIGNUM(x_big,1); + ECL_WITH_TEMP_BIGNUM(y_big,1); - switch (ecl_t_of(x)) { - case t_fixnum: - _ecl_big_set_fixnum(x_big, ecl_fixnum(x)); - x = x_big; - case t_bignum: - break; - default: - FEwrong_type_nth_arg(@[gcd], 1, x, @[integer]); - } - switch (ecl_t_of(y)) { - case t_fixnum: - _ecl_big_set_fixnum(y_big, ecl_fixnum(y)); - y = y_big; - case t_bignum: - break; - default: - FEwrong_type_nth_arg(@[gcd], 2, y, @[integer]); - } - return _ecl_big_gcd(x, y); + switch (ecl_t_of(x)) { + case t_fixnum: + _ecl_big_set_fixnum(x_big, ecl_fixnum(x)); + x = x_big; + case t_bignum: + break; + default: + FEwrong_type_nth_arg(@[gcd], 1, x, @[integer]); + } + switch (ecl_t_of(y)) { + case t_fixnum: + _ecl_big_set_fixnum(y_big, ecl_fixnum(y)); + y = y_big; + case t_bignum: + break; + default: + FEwrong_type_nth_arg(@[gcd], 2, y, @[integer]); + } + return _ecl_big_gcd(x, y); } @(defun lcm (&rest nums) - cl_object lcm; + cl_object lcm; @ - if (narg == 0) - @(return ecl_make_fixnum(1)) - /* INV: ecl_gcd() checks types. By placing `numi' before `lcm' in - this call, we make sure that errors point to `numi' */ - lcm = ecl_va_arg(nums); - assert_type_integer(lcm); - while (narg-- > 1) { - cl_object numi = ecl_va_arg(nums); - cl_object t = ecl_times(lcm, numi); - cl_object g = ecl_gcd(numi, lcm); - if (g != ecl_make_fixnum(0)) - lcm = ecl_divide(t, g); - } - @(return (ecl_minusp(lcm) ? ecl_negate(lcm) : lcm)) + if (narg == 0) { + @(return ecl_make_fixnum(1)); + } + /* INV: ecl_gcd() checks types. By placing `numi' before `lcm' in + this call, we make sure that errors point to `numi' */ + lcm = ecl_va_arg(nums); + assert_type_integer(lcm); + while (narg-- > 1) { + cl_object numi = ecl_va_arg(nums); + cl_object t = ecl_times(lcm, numi); + cl_object g = ecl_gcd(numi, lcm); + if (g != ecl_make_fixnum(0)) + lcm = ecl_divide(t, g); + } + @(return (ecl_minusp(lcm) ? ecl_negate(lcm) : lcm)); @) diff -Nru ecl-16.1.2/src/c/number.d ecl-16.1.3+ds/src/c/number.d --- ecl-16.1.2/src/c/number.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/number.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - number.c -- constructing numbers. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * number.d - constructing numbers + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -39,114 +34,114 @@ * X, where the status of the FPE control word is changed by * printf. We have two alternatives. */ -# define DO_DETECT_FPE(f) do { \ - unlikely_if (isnan(f)) ecl_deliver_fpe(FE_INVALID); \ - unlikely_if (!isfinite(f)) ecl_deliver_fpe(FE_OVERFLOW); \ - } while (0) +# define DO_DETECT_FPE(f) do { \ + unlikely_if (isnan(f)) ecl_deliver_fpe(FE_INVALID); \ + unlikely_if (!isfinite(f)) ecl_deliver_fpe(FE_OVERFLOW); \ + } while (0) #endif #if !ECL_CAN_INLINE cl_fixnum ecl_to_fix(cl_object f) { - if (ecl_unlikely(!ECL_FIXNUMP(f))) - FEtype_error_fixnum(f); - return ecl_fixnum(f); + if (ecl_unlikely(!ECL_FIXNUMP(f))) + FEtype_error_fixnum(f); + return ecl_fixnum(f); } cl_index ecl_to_size(cl_object f) { - cl_fixnum aux; - if (ecl_likely(ECL_FIXNUMP(f))) { - cl_fixnum aux = ecl_fixnum(f); - if (ecl_likely(aux >= 0)) - return aux; - } - FEtype_error_size(f); + cl_fixnum aux; + if (ecl_likely(ECL_FIXNUMP(f))) { + cl_fixnum aux = ecl_fixnum(f); + if (ecl_likely(aux >= 0)) + return aux; + } + FEtype_error_size(f); } #endif /* !ECL_CAN_INLINE */ cl_object ecl_make_integer(cl_fixnum l) { - if (l > MOST_POSITIVE_FIXNUM || l < MOST_NEGATIVE_FIXNUM) { - cl_object z = _ecl_big_register0(); - _ecl_big_set_fixnum(z, l); - return _ecl_big_register_copy(z); - } - return ecl_make_fixnum(l); + if (l > MOST_POSITIVE_FIXNUM || l < MOST_NEGATIVE_FIXNUM) { + cl_object z = _ecl_big_register0(); + _ecl_big_set_fixnum(z, l); + return _ecl_big_register_copy(z); + } + return ecl_make_fixnum(l); } cl_object ecl_make_unsigned_integer(cl_index l) { - if (l > MOST_POSITIVE_FIXNUM) { - cl_object z = _ecl_big_register0(); - _ecl_big_set_index(z, l); - return _ecl_big_register_copy(z); - } - return ecl_make_fixnum(l); + if (l > MOST_POSITIVE_FIXNUM) { + cl_object z = _ecl_big_register0(); + _ecl_big_set_index(z, l); + return _ecl_big_register_copy(z); + } + return ecl_make_fixnum(l); } int ecl_to_bit(cl_object x) { - if (ecl_unlikely((x != ecl_make_fixnum(0)) && (x != ecl_make_fixnum(1)))) - FEwrong_type_nth_arg(@[coerce], 1, x, @[bit]); - return x == ecl_make_fixnum(1); + if (ecl_unlikely((x != ecl_make_fixnum(0)) && (x != ecl_make_fixnum(1)))) + FEwrong_type_nth_arg(@[coerce], 1, x, @[bit]); + return x == ecl_make_fixnum(1); } ecl_uint8_t ecl_to_uint8_t(cl_object x) { - if (ecl_likely(ECL_FIXNUMP(x))) { - cl_fixnum aux = ecl_fixnum(x); - if (ecl_likely(aux >= 0 && aux <= 255)) - return (ecl_uint8_t)aux; - } - FEwrong_type_argument(cl_list(2, @'unsigned-byte', ecl_make_fixnum(8)), - x); + if (ecl_likely(ECL_FIXNUMP(x))) { + cl_fixnum aux = ecl_fixnum(x); + if (ecl_likely(aux >= 0 && aux <= 255)) + return (ecl_uint8_t)aux; + } + FEwrong_type_argument(cl_list(2, @'unsigned-byte', ecl_make_fixnum(8)), + x); } ecl_int8_t ecl_to_int8_t(cl_object x) { - if (ecl_likely(ECL_FIXNUMP(x))) { - cl_fixnum aux = ecl_fixnum(x); - if (ecl_likely(aux >= -128 && aux <= 127)) - return (ecl_uint8_t)aux; - } - FEwrong_type_argument(cl_list(2, @'signed-byte', ecl_make_fixnum(8)), - x); + if (ecl_likely(ECL_FIXNUMP(x))) { + cl_fixnum aux = ecl_fixnum(x); + if (ecl_likely(aux >= -128 && aux <= 127)) + return (ecl_uint8_t)aux; + } + FEwrong_type_argument(cl_list(2, @'signed-byte', ecl_make_fixnum(8)), + x); } unsigned short ecl_to_ushort(cl_object x) { - const unsigned short ushort_max = USHRT_MAX; - if (ecl_likely(ECL_FIXNUMP(x))) { - cl_fixnum y = ecl_fixnum(x); - if (ecl_likely(y >= 0 && y <= ushort_max)) { - return (unsigned short)y; - } - } - FEwrong_type_argument(cl_list(3,@'integer', - ecl_make_fixnum(0), - ecl_make_fixnum(ushort_max)), - x); + const unsigned short ushort_max = USHRT_MAX; + if (ecl_likely(ECL_FIXNUMP(x))) { + cl_fixnum y = ecl_fixnum(x); + if (ecl_likely(y >= 0 && y <= ushort_max)) { + return (unsigned short)y; + } + } + FEwrong_type_argument(cl_list(3,@'integer', + ecl_make_fixnum(0), + ecl_make_fixnum(ushort_max)), + x); } short ecl_to_short(cl_object x) { - const short short_min = SHRT_MIN; - const short short_max = SHRT_MAX; - if (ecl_likely(ECL_FIXNUMP(x))) { - cl_fixnum y = ecl_fixnum(x); - if (ecl_likely(y >= short_min && y <= short_max)) { - return (short)y; - } - } - FEwrong_type_argument(cl_list(3,@'integer', - ecl_make_fixnum(short_min), - ecl_make_fixnum(short_max)), - x); + const short short_min = SHRT_MIN; + const short short_max = SHRT_MAX; + if (ecl_likely(ECL_FIXNUMP(x))) { + cl_fixnum y = ecl_fixnum(x); + if (ecl_likely(y >= short_min && y <= short_max)) { + return (short)y; + } + } + FEwrong_type_argument(cl_list(3,@'integer', + ecl_make_fixnum(short_min), + ecl_make_fixnum(short_max)), + x); } #if ECL_FIXNUM_BITS < 32 @@ -156,143 +151,143 @@ #ifdef ecl_uint16_t ecl_uint16_t ecl_to_uint16_t(cl_object x) { - const uint16_t uint16_max = 0xFFFFL; - if (ecl_likely(ECL_FIXNUMP(x))) { - cl_fixnum y = ecl_fixnum(x); - if (ecl_likely(y >= 0 && y <= uint16_max)) { - return (ecl_uint16_t)y; - } - } - FEwrong_type_argument(cl_list(3,@'integer', - ecl_make_fixnum(0), - ecl_make_fixnum(uint16_max)), - x); + const uint16_t uint16_max = 0xFFFFL; + if (ecl_likely(ECL_FIXNUMP(x))) { + cl_fixnum y = ecl_fixnum(x); + if (ecl_likely(y >= 0 && y <= uint16_max)) { + return (ecl_uint16_t)y; + } + } + FEwrong_type_argument(cl_list(3,@'integer', + ecl_make_fixnum(0), + ecl_make_fixnum(uint16_max)), + x); } ecl_int16_t ecl_to_int16_t(cl_object x) { - const int16_t int16_min = -0x8000; - const int16_t int16_max = 0x7FFF; - if (ecl_likely(ECL_FIXNUMP(x))) { - cl_fixnum y = ecl_fixnum(x); - if (ecl_likely(y >= int16_min && y <= int16_max)) { - return (ecl_int16_t)y; - } - } - FEwrong_type_argument(cl_list(3,@'integer', - ecl_make_fixnum(int16_min), - ecl_make_fixnum(int16_max)), - x); + const int16_t int16_min = -0x8000; + const int16_t int16_max = 0x7FFF; + if (ecl_likely(ECL_FIXNUMP(x))) { + cl_fixnum y = ecl_fixnum(x); + if (ecl_likely(y >= int16_min && y <= int16_max)) { + return (ecl_int16_t)y; + } + } + FEwrong_type_argument(cl_list(3,@'integer', + ecl_make_fixnum(int16_min), + ecl_make_fixnum(int16_max)), + x); } #endif /* ecl_uint16_t */ #if defined(ecl_uint32_t) && (ECL_FIXNUM_BITS > 32) ecl_uint32_t ecl_to_uint32_t(cl_object x) { - const uint32_t uint32_max = 0xFFFFFFFFUL; - if (ecl_likely(ECL_FIXNUMP(x))) { - cl_fixnum y = ecl_fixnum(x); - if (ecl_likely(y >= 0 && y <= uint32_max)) { - return (ecl_uint32_t)y; - } - } - FEwrong_type_argument(cl_list(3,@'integer',ecl_make_fixnum(0), - ecl_make_unsigned_integer(uint32_max)), - x); + const uint32_t uint32_max = 0xFFFFFFFFUL; + if (ecl_likely(ECL_FIXNUMP(x))) { + cl_fixnum y = ecl_fixnum(x); + if (ecl_likely(y >= 0 && y <= uint32_max)) { + return (ecl_uint32_t)y; + } + } + FEwrong_type_argument(cl_list(3,@'integer',ecl_make_fixnum(0), + ecl_make_unsigned_integer(uint32_max)), + x); } ecl_int32_t ecl_to_int32_t(cl_object x) { - const int32_t int32_min = -0x80000000L; - const int32_t int32_max = 0x7FFFFFFFL; - if (ecl_likely(ECL_FIXNUMP(x))) { - cl_fixnum y = ecl_fixnum(x); - if (ecl_likely(y >= int32_min && y <= int32_max)) { - return (ecl_int32_t)y; - } - } - FEwrong_type_argument(cl_list(3,@'integer', - ecl_make_integer(int32_min), - ecl_make_integer(int32_max)), - x); + const int32_t int32_min = -0x80000000L; + const int32_t int32_max = 0x7FFFFFFFL; + if (ecl_likely(ECL_FIXNUMP(x))) { + cl_fixnum y = ecl_fixnum(x); + if (ecl_likely(y >= int32_min && y <= int32_max)) { + return (ecl_int32_t)y; + } + } + FEwrong_type_argument(cl_list(3,@'integer', + ecl_make_integer(int32_min), + ecl_make_integer(int32_max)), + x); } #endif /* ecl_uint32_t */ #if defined(ecl_uint64_t) && (ECL_FIXNUM_BITS < 64) ecl_uint64_t ecl_to_uint64_t(cl_object x) { - if (!ecl_minusp(x)) { - if (ECL_FIXNUMP(x)) { - return (ecl_uint64_t)ecl_fixnum(x); - } else if (!ECL_BIGNUMP(x)) { - (void)0; - } else if (mpz_fits_ulong_p(x->big.big_num)) { - return (ecl_uint64_t)mpz_get_ui(x->big.big_num); - } else { - cl_object copy = _ecl_big_register0(); - mpz_fdiv_q_2exp(copy->big.big_num, x->big.big_num, 32); - if (mpz_fits_ulong_p(copy->big.big_num)) { - volatile ecl_uint64_t output; - output = (ecl_uint64_t)mpz_get_ui(copy->big.big_num); - output = (output << 32) + - (ecl_uint64_t)mpz_get_ui(x->big.big_num); - _ecl_big_register_free(copy); - return output; - } - } - } - FEwrong_type_argument(cl_list(3,@'integer',ecl_make_fixnum(0), - ecl_one_minus(ecl_ash(ecl_make_fixnum(1), 64))), - x); + if (!ecl_minusp(x)) { + if (ECL_FIXNUMP(x)) { + return (ecl_uint64_t)ecl_fixnum(x); + } else if (!ECL_BIGNUMP(x)) { + (void)0; + } else if (mpz_fits_ulong_p(x->big.big_num)) { + return (ecl_uint64_t)mpz_get_ui(x->big.big_num); + } else { + cl_object copy = _ecl_big_register0(); + mpz_fdiv_q_2exp(copy->big.big_num, x->big.big_num, 32); + if (mpz_fits_ulong_p(copy->big.big_num)) { + volatile ecl_uint64_t output; + output = (ecl_uint64_t)mpz_get_ui(copy->big.big_num); + output = (output << 32) + + (ecl_uint64_t)mpz_get_ui(x->big.big_num); + _ecl_big_register_free(copy); + return output; + } + } + } + FEwrong_type_argument(cl_list(3,@'integer',ecl_make_fixnum(0), + ecl_one_minus(ecl_ash(ecl_make_fixnum(1), 64))), + x); } ecl_int64_t ecl_to_int64_t(cl_object x) { - if (ECL_FIXNUMP(x)) { - return (ecl_int64_t)ecl_fixnum(x); - } else if (!ECL_BIGNUMP(x)) { - (void)0; - } else if (mpz_fits_slong_p(x->big.big_num)) { - return (ecl_int64_t)mpz_get_si(x->big.big_num); - } else { - cl_object copy = _ecl_big_register0(); - mpz_fdiv_q_2exp(copy->big.big_num, x->big.big_num, 32); - if (mpz_fits_slong_p(copy->big.big_num)) { - ecl_int64_t output; - output = (ecl_int64_t)mpz_get_si(copy->big.big_num); - mpz_fdiv_r_2exp(copy->big.big_num, x->big.big_num, 32); - return (output << 32) + mpz_get_ui(copy->big.big_num); - } - } - FEwrong_type_argument(cl_list(3,@'integer', - ecl_negate(ecl_ash(ecl_make_fixnum(1), 63)), - ecl_one_minus(ecl_ash(ecl_make_fixnum(1), 63))), - x); + if (ECL_FIXNUMP(x)) { + return (ecl_int64_t)ecl_fixnum(x); + } else if (!ECL_BIGNUMP(x)) { + (void)0; + } else if (mpz_fits_slong_p(x->big.big_num)) { + return (ecl_int64_t)mpz_get_si(x->big.big_num); + } else { + cl_object copy = _ecl_big_register0(); + mpz_fdiv_q_2exp(copy->big.big_num, x->big.big_num, 32); + if (mpz_fits_slong_p(copy->big.big_num)) { + ecl_int64_t output; + output = (ecl_int64_t)mpz_get_si(copy->big.big_num); + mpz_fdiv_r_2exp(copy->big.big_num, x->big.big_num, 32); + return (output << 32) + mpz_get_ui(copy->big.big_num); + } + } + FEwrong_type_argument(cl_list(3,@'integer', + ecl_negate(ecl_ash(ecl_make_fixnum(1), 63)), + ecl_one_minus(ecl_ash(ecl_make_fixnum(1), 63))), + x); } cl_object ecl_make_uint64_t(ecl_uint64_t i) { - if (i <= MOST_POSITIVE_FIXNUM) { - return ecl_make_fixnum(i); - } else if (i <= ~(ecl_uint32_t)0) { - return ecl_make_uint32_t(i); - } else { - cl_object aux = ecl_make_uint32_t(i >> 32); - return cl_logior(2, ecl_ash(aux, 32), - ecl_make_uint32_t((ecl_uint32_t)i)); - } + if (i <= MOST_POSITIVE_FIXNUM) { + return ecl_make_fixnum(i); + } else if (i <= ~(ecl_uint32_t)0) { + return ecl_make_uint32_t(i); + } else { + cl_object aux = ecl_make_uint32_t(i >> 32); + return cl_logior(2, ecl_ash(aux, 32), + ecl_make_uint32_t((ecl_uint32_t)i)); + } } cl_object ecl_make_int64_t(ecl_int64_t i) { - if (i >= MOST_NEGATIVE_FIXNUM && i <= MOST_POSITIVE_FIXNUM) { - return ecl_make_fixnum(i); - } else { - cl_object aux = ecl_make_int32_t(i >> 32); - return cl_logior(2, ecl_ash(aux, 32), ecl_make_uint32_t((ecl_uint32_t)i)); - } + if (i >= MOST_NEGATIVE_FIXNUM && i <= MOST_POSITIVE_FIXNUM) { + return ecl_make_fixnum(i); + } else { + cl_object aux = ecl_make_int32_t(i >> 32); + return cl_logior(2, ecl_ash(aux, 32), ecl_make_uint32_t((ecl_uint32_t)i)); + } } #endif /* ecl_uint64_t */ @@ -300,123 +295,123 @@ # if defined(ecl_uint32_t) && ECL_LONG_LONG_BITS == 32 ecl_ulong_long_t ecl_to_ulong_long(cl_object x) { - return (ecl_ulong_long_t)ecl_to_uint32_t(x); + return (ecl_ulong_long_t)ecl_to_uint32_t(x); } ecl_long_long_t ecl_to_long_long(cl_object x) { - return (ecl_long_long_t)ecl_to_int32_t(x); + return (ecl_long_long_t)ecl_to_int32_t(x); } cl_object ecl_make_ulong_long(ecl_ulong_long_t i) { - return ecl_make_uint32_t(i); + return ecl_make_uint32_t(i); } cl_object ecl_make_long_long(ecl_long_long_t i) { - return ecl_make_int32_t(i); + return ecl_make_int32_t(i); } # else # if defined(ecl_uint64_t) && ECL_LONG_LONG_BITS == 64 ecl_ulong_long_t ecl_to_ulong_long(cl_object x) { - return (ecl_ulong_long_t)ecl_to_uint64_t(x); + return (ecl_ulong_long_t)ecl_to_uint64_t(x); } ecl_long_long_t ecl_to_long_long(cl_object x) { - return (ecl_long_long_t)ecl_to_int64_t(x); + return (ecl_long_long_t)ecl_to_int64_t(x); } cl_object ecl_make_ulong_long(ecl_ulong_long_t i) { - return ecl_make_uint64_t(i); + return ecl_make_uint64_t(i); } cl_object ecl_make_long_long(ecl_long_long_t i) { - return ecl_make_int64_t(i); + return ecl_make_int64_t(i); } # else ecl_ulong_long_t ecl_to_ulong_long(cl_object x) { - if (!ecl_minusp(x)) { - if (ECL_FIXNUMP(x)) { - return (ecl_ulong_long_t)ecl_fixnum(x); - } else if (!ECL_BIGNUMP(x)) { - (void)0; - } else if (mpz_fits_ulong_p(x->big.big_num)) { - return (ecl_ulong_long_t)mpz_get_ui(x->big.big_num); - } else { - cl_object copy = _ecl_big_register0(); - int i = ECL_LONG_LONG_BITS - ECL_FIXNUM_BITS; - mpz_fdiv_q_2exp(copy->bit.big_num, x->big.big_num, i); - if (mpz_fits_ulong_p(copy->big.big_num)) { - volatile ecl_ulong_long_t output; - output = mpz_get_ui(copy->big.big_num); - for (i -= ECL_FIXNUM_BITS; i; - i-= ECL_FIXNUM_BITS) { - output = (output << ECL_FIXNUM_BITS); - output += mpz_get_ui(x->big.big_num); - } - return output; - } - } - } - FEwrong_type_argument(cl_list(3,@'integer',ecl_make_fixnum(0), - ecl_one_minus(ecl_ash(ecl_make_fixnum(1), - ECL_LONG_LONG_BITS))), - x); + if (!ecl_minusp(x)) { + if (ECL_FIXNUMP(x)) { + return (ecl_ulong_long_t)ecl_fixnum(x); + } else if (!ECL_BIGNUMP(x)) { + (void)0; + } else if (mpz_fits_ulong_p(x->big.big_num)) { + return (ecl_ulong_long_t)mpz_get_ui(x->big.big_num); + } else { + cl_object copy = _ecl_big_register0(); + int i = ECL_LONG_LONG_BITS - ECL_FIXNUM_BITS; + mpz_fdiv_q_2exp(copy->bit.big_num, x->big.big_num, i); + if (mpz_fits_ulong_p(copy->big.big_num)) { + volatile ecl_ulong_long_t output; + output = mpz_get_ui(copy->big.big_num); + for (i -= ECL_FIXNUM_BITS; i; + i-= ECL_FIXNUM_BITS) { + output = (output << ECL_FIXNUM_BITS); + output += mpz_get_ui(x->big.big_num); + } + return output; + } + } + } + FEwrong_type_argument(cl_list(3,@'integer',ecl_make_fixnum(0), + ecl_one_minus(ecl_ash(ecl_make_fixnum(1), + ECL_LONG_LONG_BITS))), + x); } ecl_long_long_t ecl_to_long_long(cl_object x) { - if (ECL_FIXNUMP(x)) { - return (ecl_long_long_t)ecl_fixnum(x); - } else if (!ECL_BIGNUMP(x)) { - (void)0; - } else if (mpz_fits_slong_p(x->big.big_num)) { - return (ecl_long_long_t)mpz_get_si(x->big.big_num); - } else { - cl_object copy = _ecl_big_register0(); - int i = ECL_LONG_LONG_BITS - ECL_FIXNUM_BITS; - mpz_fdiv_q_2exp(copy->bit.big_num, x->big.big_num, i); - if (mpz_fits_ulong_p(copy->big.big_num)) { - volatile ecl_long_long_t output; - output = mpz_get_si(copy->big.big_num); - for (i -= ECL_FIXNUM_BITS; i; i-= ECL_FIXNUM_BITS) { - output = (output << ECL_FIXNUM_BITS); - output += mpz_get_ui(x->big.big_num); - } - return output; - } - } - FEwrong_type_argument(cl_list(3,@'integer', - ecl_negate(ecl_ash(ecl_make_fixnum(1), ECL_LONG_LONG_BITS-1)), - ecl_one_minus(ecl_ash(ecl_make_fixnum(1), ECL_LONG_LONG_BITS-1))), - x); + if (ECL_FIXNUMP(x)) { + return (ecl_long_long_t)ecl_fixnum(x); + } else if (!ECL_BIGNUMP(x)) { + (void)0; + } else if (mpz_fits_slong_p(x->big.big_num)) { + return (ecl_long_long_t)mpz_get_si(x->big.big_num); + } else { + cl_object copy = _ecl_big_register0(); + int i = ECL_LONG_LONG_BITS - ECL_FIXNUM_BITS; + mpz_fdiv_q_2exp(copy->bit.big_num, x->big.big_num, i); + if (mpz_fits_ulong_p(copy->big.big_num)) { + volatile ecl_long_long_t output; + output = mpz_get_si(copy->big.big_num); + for (i -= ECL_FIXNUM_BITS; i; i-= ECL_FIXNUM_BITS) { + output = (output << ECL_FIXNUM_BITS); + output += mpz_get_ui(x->big.big_num); + } + return output; + } + } + FEwrong_type_argument(cl_list(3,@'integer', + ecl_negate(ecl_ash(ecl_make_fixnum(1), ECL_LONG_LONG_BITS-1)), + ecl_one_minus(ecl_ash(ecl_make_fixnum(1), ECL_LONG_LONG_BITS-1))), + x); } cl_object ecl_make_ulong_long(ecl_ulong_long_t i) { - if (i <= MOST_POSITIVE_FIXNUM) { - return ecl_make_fixnum(i); - } else if (i <= ~(ecl_uint32_t)0) { - return ecl_make_uint32_t(i); - } else { - cl_object aux = ecl_make_uint32_t(i >> 32); - return cl_logior(2, ecl_ash(aux, 32), - ecl_make_uint32_t((ecl_uint32_t)i)); - } + if (i <= MOST_POSITIVE_FIXNUM) { + return ecl_make_fixnum(i); + } else if (i <= ~(ecl_uint32_t)0) { + return ecl_make_uint32_t(i); + } else { + cl_object aux = ecl_make_uint32_t(i >> 32); + return cl_logior(2, ecl_ash(aux, 32), + ecl_make_uint32_t((ecl_uint32_t)i)); + } } cl_object ecl_make_long_long(ecl_long_long_t i) { - if (i >= MOST_NEGATIVE_FIXNUM && i <= MOST_POSITIVE_FIXNUM) { - return ecl_make_fixnum(i); - } else { - cl_object aux = ecl_make_int32_t(i >> 32); - return cl_logior(2, ecl_ash(aux, 32), ecl_make_uint32_t((ecl_uint32_t)i)); - } + if (i >= MOST_NEGATIVE_FIXNUM && i <= MOST_POSITIVE_FIXNUM) { + return ecl_make_fixnum(i); + } else { + cl_object aux = ecl_make_int32_t(i >> 32); + return cl_logior(2, ecl_ash(aux, 32), ecl_make_uint32_t((ecl_uint32_t)i)); + } } # endif # endif @@ -425,499 +420,508 @@ cl_object ecl_make_ratio(cl_object num, cl_object den) { - cl_object g, r; + cl_object g, r; - /* INV: the arguments NUM & DEN are integers */ - if (den == ecl_make_fixnum(0)) - FEdivision_by_zero(num, den); - if (num == ecl_make_fixnum(0) || den == ecl_make_fixnum(1)) - return(num); - if (ecl_minusp(den)) { - num = ecl_negate(num); - den = ecl_negate(den); - } - g = ecl_gcd(num, den); - if (g != ecl_make_fixnum(1)) { - num = ecl_integer_divide(num, g); - den = ecl_integer_divide(den, g); - } - if (den == ecl_make_fixnum(1)) - return num; - if (den == ecl_make_fixnum(-1)) - return ecl_negate(num); - r = ecl_alloc_object(t_ratio); - r->ratio.num = num; - r->ratio.den = den; - return(r); + /* INV: the arguments NUM & DEN are integers */ + if (den == ecl_make_fixnum(0)) + FEdivision_by_zero(num, den); + if (num == ecl_make_fixnum(0) || den == ecl_make_fixnum(1)) + return(num); + if (ecl_minusp(den)) { + num = ecl_negate(num); + den = ecl_negate(den); + } + g = ecl_gcd(num, den); + if (g != ecl_make_fixnum(1)) { + num = ecl_integer_divide(num, g); + den = ecl_integer_divide(den, g); + } + if (den == ecl_make_fixnum(1)) + return num; + if (den == ecl_make_fixnum(-1)) + return ecl_negate(num); + r = ecl_alloc_object(t_ratio); + r->ratio.num = num; + r->ratio.den = den; + return(r); } void ecl_deliver_fpe(int status) { - cl_env_ptr env = ecl_process_env(); - int bits = status & env->trap_fpe_bits; - feclearexcept(FE_ALL_EXCEPT); - if (bits) { - cl_object condition; - if (bits & FE_DIVBYZERO) - condition = @'division-by-zero'; - else if (bits & FE_INVALID) - condition = @'floating-point-invalid-operation'; - else if (bits & FE_OVERFLOW) - condition = @'floating-point-overflow'; - else if (bits & FE_UNDERFLOW) - condition = @'floating-point-underflow'; - else if (bits & FE_INEXACT) - condition = @'floating-point-inexact'; - else - condition = @'arithmetic-error'; - cl_error(1, condition); - } + cl_env_ptr env = ecl_process_env(); + int bits = status & env->trap_fpe_bits; + feclearexcept(FE_ALL_EXCEPT); + if (bits) { + cl_object condition; + if (bits & FE_DIVBYZERO) + condition = @'division-by-zero'; + else if (bits & FE_INVALID) + condition = @'floating-point-invalid-operation'; + else if (bits & FE_OVERFLOW) + condition = @'floating-point-overflow'; + else if (bits & FE_UNDERFLOW) + condition = @'floating-point-underflow'; + else if (bits & FE_INEXACT) + condition = @'floating-point-inexact'; + else + condition = @'arithmetic-error'; + cl_error(1, condition); + } } cl_object ecl_make_single_float(float f) { - cl_object x; + cl_object x; - DO_DETECT_FPE(f); - if (f == (float)0.0) { + DO_DETECT_FPE(f); + if (f == (float)0.0) { #if defined(ECL_SIGNED_ZERO) - if (signbit(f)) - return cl_core.singlefloat_minus_zero; + if (signbit(f)) + return cl_core.singlefloat_minus_zero; #endif - return cl_core.singlefloat_zero; - } - x = ecl_alloc_object(t_singlefloat); - ecl_single_float(x) = f; - return(x); + return cl_core.singlefloat_zero; + } + x = ecl_alloc_object(t_singlefloat); + ecl_single_float(x) = f; + return(x); } cl_object ecl_make_double_float(double f) { - cl_object x; + cl_object x; - DO_DETECT_FPE(f); - if (f == (double)0.0) { + DO_DETECT_FPE(f); + if (f == (double)0.0) { #if defined(ECL_SIGNED_ZERO) - if (signbit(f)) - return cl_core.doublefloat_minus_zero; + if (signbit(f)) + return cl_core.doublefloat_minus_zero; #endif - return cl_core.doublefloat_zero; - } - x = ecl_alloc_object(t_doublefloat); - ecl_double_float(x) = f; - return(x); + return cl_core.doublefloat_zero; + } + x = ecl_alloc_object(t_doublefloat); + ecl_double_float(x) = f; + return(x); } #ifdef ECL_LONG_FLOAT cl_object ecl_make_long_float(long double f) { - cl_object x; + cl_object x; - DO_DETECT_FPE(f); - if (f == (long double)0.0) { + DO_DETECT_FPE(f); + if (f == (long double)0.0) { #if defined(ECL_SIGNED_ZERO) - if (signbit(f)) - return cl_core.longfloat_minus_zero; + if (signbit(f)) + return cl_core.longfloat_minus_zero; #endif - return cl_core.longfloat_zero; - } - x = ecl_alloc_object(t_longfloat); - x->longfloat.value = f; - return x; + return cl_core.longfloat_zero; + } + x = ecl_alloc_object(t_longfloat); + x->longfloat.value = f; + return x; } #endif cl_object ecl_make_complex(cl_object r, cl_object i) { - cl_object c; - cl_type ti; + cl_object c; + cl_type ti; AGAIN: - ti = ecl_t_of(i); - /* Both R and I are promoted to a common type */ - switch (ecl_t_of(r)) { - case t_fixnum: - case t_bignum: - case t_ratio: - switch (ti) { - case t_fixnum: - if (i == ecl_make_fixnum(0)) - return(r); - case t_bignum: - case t_ratio: - break; - case t_singlefloat: - r = ecl_make_single_float((float)ecl_to_double(r)); - break; - case t_doublefloat: - r = ecl_make_double_float(ecl_to_double(r)); - break; -#ifdef ECL_LONG_FLOAT - case t_longfloat: - r = ecl_make_long_float(ecl_to_double(r)); - break; -#endif - default: - i = ecl_type_error(@'complex',"imaginary part", i, @'real'); - goto AGAIN; - } - break; - case t_singlefloat: - switch (ti) { - case t_fixnum: - case t_bignum: - case t_ratio: - i = ecl_make_single_float((float)ecl_to_double(i)); - break; - case t_singlefloat: - break; - case t_doublefloat: - r = ecl_make_double_float((double)(ecl_single_float(r))); - break; -#ifdef ECL_LONG_FLOAT - case t_longfloat: - r = ecl_make_long_float((long double)ecl_single_float(r)); - break; -#endif - default: - i = ecl_type_error(@'complex',"imaginary part", i, @'real'); - goto AGAIN; - } - break; - case t_doublefloat: - switch (ti) { - case t_fixnum: - case t_bignum: - case t_ratio: - case t_singlefloat: - i = ecl_make_double_float(ecl_to_double(i)); - case t_doublefloat: - break; -#ifdef ECL_LONG_FLOAT - case t_longfloat: - r = ecl_make_long_float((long double)ecl_double_float(r)); - break; -#endif - default: - i = ecl_type_error(@'complex',"imaginary part", i, @'real'); - goto AGAIN; - } - break; -#ifdef ECL_LONG_FLOAT - case t_longfloat: - if (ti != t_longfloat) - i = ecl_make_long_float((long double)ecl_to_double(i)); - break; -#endif - default: - r = ecl_type_error(@'complex',"real part", r, @'real'); - goto AGAIN; - - } - c = ecl_alloc_object(t_complex); - c->complex.real = r; - c->complex.imag = i; - return(c); + ti = ecl_t_of(i); + /* Both R and I are promoted to a common type */ + switch (ecl_t_of(r)) { + case t_fixnum: + case t_bignum: + case t_ratio: + switch (ti) { + case t_fixnum: + if (i == ecl_make_fixnum(0)) + return(r); + case t_bignum: + case t_ratio: + break; + case t_singlefloat: + r = ecl_make_single_float((float)ecl_to_double(r)); + break; + case t_doublefloat: + r = ecl_make_double_float(ecl_to_double(r)); + break; +#ifdef ECL_LONG_FLOAT + case t_longfloat: + r = ecl_make_long_float(ecl_to_double(r)); + break; +#endif + default: + i = ecl_type_error(@'complex',"imaginary part", i, @'real'); + goto AGAIN; + } + break; + case t_singlefloat: + switch (ti) { + case t_fixnum: + case t_bignum: + case t_ratio: + i = ecl_make_single_float((float)ecl_to_double(i)); + break; + case t_singlefloat: + break; + case t_doublefloat: + r = ecl_make_double_float((double)(ecl_single_float(r))); + break; +#ifdef ECL_LONG_FLOAT + case t_longfloat: + r = ecl_make_long_float((long double)ecl_single_float(r)); + break; +#endif + default: + i = ecl_type_error(@'complex',"imaginary part", i, @'real'); + goto AGAIN; + } + break; + case t_doublefloat: + switch (ti) { + case t_fixnum: + case t_bignum: + case t_ratio: + case t_singlefloat: + i = ecl_make_double_float(ecl_to_double(i)); + case t_doublefloat: + break; +#ifdef ECL_LONG_FLOAT + case t_longfloat: + r = ecl_make_long_float((long double)ecl_double_float(r)); + break; +#endif + default: + i = ecl_type_error(@'complex',"imaginary part", i, @'real'); + goto AGAIN; + } + break; +#ifdef ECL_LONG_FLOAT + case t_longfloat: + if (ti != t_longfloat) + i = ecl_make_long_float((long double)ecl_to_double(i)); + break; +#endif + default: + r = ecl_type_error(@'complex',"real part", r, @'real'); + goto AGAIN; + + } + c = ecl_alloc_object(t_complex); + c->complex.real = r; + c->complex.imag = i; + return(c); } static cl_object into_bignum(cl_object bignum, cl_object integer) { - if (ECL_FIXNUMP(integer)) { - _ecl_big_set_fixnum(bignum, ecl_fixnum(integer)); - } else { - mpz_set(bignum->big.big_num, integer->big.big_num); - } - return bignum; + if (ECL_FIXNUMP(integer)) { + _ecl_big_set_fixnum(bignum, ecl_fixnum(integer)); + } else { + mpz_set(bignum->big.big_num, integer->big.big_num); + } + return bignum; } static cl_fixnum remove_zeros(cl_object *integer) { - cl_object buffer = into_bignum(_ecl_big_register0(), *integer); - unsigned long den_twos = mpz_scan1(buffer->big.big_num, 0); - if (den_twos < ULONG_MAX) { - mpz_div_2exp(buffer->big.big_num, buffer->big.big_num, den_twos); - *integer = _ecl_big_register_normalize(buffer); - return -den_twos; - } else { - _ecl_big_register_free(buffer); - return 0; - } + cl_object buffer = into_bignum(_ecl_big_register0(), *integer); + unsigned long den_twos = mpz_scan1(buffer->big.big_num, 0); + if (den_twos < ULONG_MAX) { + mpz_div_2exp(buffer->big.big_num, buffer->big.big_num, den_twos); + *integer = _ecl_big_register_normalize(buffer); + return -den_twos; + } else { + _ecl_big_register_free(buffer); + return 0; + } } static cl_object prepare_ratio_to_float(cl_object num, cl_object den, int digits, cl_fixnum *scaleout) { - /* We have to cook our own routine because GMP does not round. - * The recipe is simple: we multiply the numberator by a large - * enough number so that the division by the denominator fits - * the floating point number. The result is scaled back by the - * appropriate exponent. - */ - /* Scale down the denominator, eliminating the zeros - * so that we have smaller operands. - */ - cl_fixnum scale = remove_zeros(&den); - cl_fixnum num_size = ecl_integer_length(num); - cl_fixnum delta = ecl_integer_length(den) - num_size; - scale -= delta; - { - cl_fixnum adjust = digits + delta + 1; - if (adjust > 0) { - num = ecl_ash(num, adjust); - } else if (adjust < 0) { - den = ecl_ash(den, -adjust); - } + /* We have to cook our own routine because GMP does not round. + * The recipe is simple: we multiply the numberator by a large + * enough number so that the division by the denominator fits + * the floating point number. The result is scaled back by the + * appropriate exponent. + */ + /* Scale down the denominator, eliminating the zeros + * so that we have smaller operands. + */ + cl_fixnum scale = remove_zeros(&den); + cl_fixnum num_size = ecl_integer_length(num); + cl_fixnum delta = ecl_integer_length(den) - num_size; + scale -= delta; + { + cl_fixnum adjust = digits + delta + 1; + if (adjust > 0) { + num = ecl_ash(num, adjust); + } else if (adjust < 0) { + den = ecl_ash(den, -adjust); + } + } + do { + const cl_env_ptr the_env = ecl_process_env(); + cl_object fraction = ecl_truncate2(num, den); + cl_object rem = ecl_nth_value(the_env, 1); + cl_fixnum len = ecl_integer_length(fraction); + if ((len - digits) == 1) { + if (ecl_oddp(fraction)) { + cl_object one = ecl_minusp(num)? + ecl_make_fixnum(-1) : + ecl_make_fixnum(1); + if (rem == ecl_make_fixnum(0)) { + if (cl_logbitp(ecl_make_fixnum(1), fraction) + != ECL_NIL) + fraction = ecl_plus(fraction, one); + } else { + fraction = ecl_plus(fraction, one); } - do { - const cl_env_ptr the_env = ecl_process_env(); - cl_object fraction = ecl_truncate2(num, den); - cl_object rem = ecl_nth_value(the_env, 1); - cl_fixnum len = ecl_integer_length(fraction); - if ((len - digits) == 1) { - if (ecl_oddp(fraction)) { - cl_object one = ecl_minusp(num)? - ecl_make_fixnum(-1) : - ecl_make_fixnum(1); - if (rem == ecl_make_fixnum(0)) { - if (cl_logbitp(ecl_make_fixnum(1), fraction) - != ECL_NIL) - fraction = ecl_plus(fraction, one); - } else { - fraction = ecl_plus(fraction, one); - } - } - *scaleout = scale - (digits + 1); - return fraction; - } - den = ecl_ash(den, 1); - scale++; - } while (1); + } + *scaleout = scale - (digits + 1); + return fraction; + } + den = ecl_ash(den, 1); + scale++; + } while (1); } #if 0 /* Unused, we do not have ecl_to_float() */ static float ratio_to_float(cl_object num, cl_object den) { - cl_fixnum scale; - cl_object bits = prepare_ratio_to_float(num, den, FLT_MANT_DIG, &scale); + cl_fixnum scale; + cl_object bits = prepare_ratio_to_float(num, den, FLT_MANT_DIG, &scale); #if (FIXNUM_BITS-ECL_TAG_BITS) >= FLT_MANT_DIG - /* The output of prepare_ratio_to_float will always fit an integer */ - float output = ecl_fixnum(bits); + /* The output of prepare_ratio_to_float will always fit an integer */ + float output = ecl_fixnum(bits); #else - float output = ECL_FIXNUMP(bits)? ecl_fixnum(bits) : _ecl_big_to_double(bits); + float output = ECL_FIXNUMP(bits)? ecl_fixnum(bits) : _ecl_big_to_double(bits); #endif - return ldexpf(output, scale); + return ldexpf(output, scale); } #endif static double ratio_to_double(cl_object num, cl_object den) { - cl_fixnum scale; - cl_object bits = prepare_ratio_to_float(num, den, DBL_MANT_DIG, &scale); + cl_fixnum scale; + cl_object bits = prepare_ratio_to_float(num, den, DBL_MANT_DIG, &scale); #if (FIXNUM_BITS-ECL_TAG_BITS) >= DBL_MANT_DIG - /* The output of prepare_ratio_to_float will always fit an integer */ - double output = ecl_fixnum(bits); + /* The output of prepare_ratio_to_float will always fit an integer */ + double output = ecl_fixnum(bits); #else - double output = ECL_FIXNUMP(bits)? ecl_fixnum(bits) : _ecl_big_to_double(bits); + double output = ECL_FIXNUMP(bits)? ecl_fixnum(bits) : _ecl_big_to_double(bits); #endif - return ldexp(output, scale); + return ldexp(output, scale); } #ifdef ECL_LONG_FLOAT static long double ratio_to_long_double(cl_object num, cl_object den) { - cl_fixnum scale; - cl_object bits = prepare_ratio_to_float(num, den, LDBL_MANT_DIG, &scale); + cl_fixnum scale; + cl_object bits = prepare_ratio_to_float(num, den, LDBL_MANT_DIG, &scale); #if (FIXNUM_BITS-ECL_TAG_BITS) >= LDBL_MANT_DIG - /* The output of prepare_ratio_to_float will always fit an integer */ - long double output = ecl_fixnum(bits); + /* The output of prepare_ratio_to_float will always fit an integer */ + long double output = ecl_fixnum(bits); #else - long double output = ECL_FIXNUMP(bits)? - (long double)ecl_fixnum(bits) : - _ecl_big_to_long_double(bits); + long double output = ECL_FIXNUMP(bits)? + (long double)ecl_fixnum(bits) : + _ecl_big_to_long_double(bits); #endif - return ldexpl(output, scale); + return ldexpl(output, scale); } #endif /* ECL_LONG_FLOAT */ float ecl_to_float(cl_object x) { - if (ECL_FIXNUMP(x)) return(ecl_fixnum(x)); /* Immediate fixnum */ + if (ECL_FIXNUMP(x)) return(ecl_fixnum(x)); /* Immediate fixnum */ - switch (ecl_t_of(x)) { - case t_fixnum: - return (float)ecl_fixnum(x); - case t_bignum: - return (float)ratio_to_double(x, ecl_make_fixnum(1)); - case t_ratio: - return (float)ratio_to_double(x->ratio.num, x->ratio.den); - case t_singlefloat: - return ecl_single_float(x); - case t_doublefloat: - return (float)ecl_double_float(x); -#ifdef ECL_LONG_FLOAT - case t_longfloat: - return (float)ecl_long_float(x); -#endif - default: - FEwrong_type_nth_arg(@[coerce], 1, x, @[real]); - } + switch (ecl_t_of(x)) { + case t_fixnum: + return (float)ecl_fixnum(x); + case t_bignum: + return (float)ratio_to_double(x, ecl_make_fixnum(1)); + case t_ratio: + return (float)ratio_to_double(x->ratio.num, x->ratio.den); + case t_singlefloat: + return ecl_single_float(x); + case t_doublefloat: + return (float)ecl_double_float(x); +#ifdef ECL_LONG_FLOAT + case t_longfloat: + return (float)ecl_long_float(x); +#endif + default: + FEwrong_type_nth_arg(@[coerce], 1, x, @[real]); + } } double ecl_to_double(cl_object x) { - switch(ecl_t_of(x)) { - case t_fixnum: - return((double)(ecl_fixnum(x))); - case t_bignum: - return ratio_to_double(x, ecl_make_fixnum(1)); - case t_ratio: - return ratio_to_double(x->ratio.num, x->ratio.den); - case t_singlefloat: - return (double)ecl_single_float(x); - case t_doublefloat: - return(ecl_double_float(x)); -#ifdef ECL_LONG_FLOAT - case t_longfloat: - return (double)ecl_long_float(x); -#endif - default: - FEwrong_type_nth_arg(@[coerce], 1, x, @[real]); - } + switch(ecl_t_of(x)) { + case t_fixnum: + return((double)(ecl_fixnum(x))); + case t_bignum: + return ratio_to_double(x, ecl_make_fixnum(1)); + case t_ratio: + return ratio_to_double(x->ratio.num, x->ratio.den); + case t_singlefloat: + return (double)ecl_single_float(x); + case t_doublefloat: + return(ecl_double_float(x)); +#ifdef ECL_LONG_FLOAT + case t_longfloat: + return (double)ecl_long_float(x); +#endif + default: + FEwrong_type_nth_arg(@[coerce], 1, x, @[real]); + } } #ifdef ECL_LONG_FLOAT long double ecl_to_long_double(cl_object x) { - switch(ecl_t_of(x)) { - case t_fixnum: - return (long double)ecl_fixnum(x); - case t_bignum: - return ratio_to_long_double(x, ecl_make_fixnum(1)); - case t_ratio: - return ratio_to_long_double(x->ratio.num, x->ratio.den); - case t_singlefloat: - return (long double)ecl_single_float(x); - case t_doublefloat: - return (long double)ecl_double_float(x); - case t_longfloat: - return ecl_long_float(x); - default: - FEwrong_type_nth_arg(@[coerce], 1, x, @[real]); - } + switch(ecl_t_of(x)) { + case t_fixnum: + return (long double)ecl_fixnum(x); + case t_bignum: + return ratio_to_long_double(x, ecl_make_fixnum(1)); + case t_ratio: + return ratio_to_long_double(x->ratio.num, x->ratio.den); + case t_singlefloat: + return (long double)ecl_single_float(x); + case t_doublefloat: + return (long double)ecl_double_float(x); + case t_longfloat: + return ecl_long_float(x); + default: + FEwrong_type_nth_arg(@[coerce], 1, x, @[real]); + } } #endif cl_object cl_rational(cl_object x) { - double d; + double d; AGAIN: - switch (ecl_t_of(x)) { - case t_fixnum: - case t_bignum: - case t_ratio: - break; - case t_singlefloat: - d = ecl_single_float(x); - goto GO_ON; - case t_doublefloat: - d = ecl_double_float(x); - GO_ON: if (d == 0) { - x = ecl_make_fixnum(0); - } else { - int e; - d = frexp(d, &e); - e -= DBL_MANT_DIG; - x = _ecl_double_to_integer(ldexp(d, DBL_MANT_DIG)); - if (e != 0) { - x = ecl_times(ecl_expt(ecl_make_fixnum(FLT_RADIX), - ecl_make_fixnum(e)), - x); - } - } - break; -#ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double d = ecl_long_float(x); - if (d == 0) { - x = ecl_make_fixnum(0); - } else { - int e; - d = frexpl(d, &e); - e -= LDBL_MANT_DIG; - d = ldexpl(d, LDBL_MANT_DIG); - x = _ecl_long_double_to_integer(d); - if (e != 0) { - x = ecl_times(ecl_expt(ecl_make_fixnum(FLT_RADIX), - ecl_make_fixnum(e)), - x); - } - } - break; - } -#endif - default: - x = ecl_type_error(@'rational',"argument",x,@'number'); - goto AGAIN; - } - @(return x) + switch (ecl_t_of(x)) { + case t_fixnum: + case t_bignum: + case t_ratio: + break; + case t_singlefloat: + d = ecl_single_float(x); + goto GO_ON; + case t_doublefloat: + d = ecl_double_float(x); + GO_ON: if (d == 0) { + x = ecl_make_fixnum(0); + } else { + int e; + d = frexp(d, &e); + e -= DBL_MANT_DIG; + x = _ecl_double_to_integer(ldexp(d, DBL_MANT_DIG)); + if (e != 0) { + x = ecl_times(ecl_expt(ecl_make_fixnum(FLT_RADIX), + ecl_make_fixnum(e)), + x); + } + } + break; +#ifdef ECL_LONG_FLOAT + case t_longfloat: { + long double d = ecl_long_float(x); + if (d == 0) { + x = ecl_make_fixnum(0); + } else { + int e; + d = frexpl(d, &e); + e -= LDBL_MANT_DIG; + d = ldexpl(d, LDBL_MANT_DIG); + x = _ecl_long_double_to_integer(d); + if (e != 0) { + x = ecl_times(ecl_expt(ecl_make_fixnum(FLT_RADIX), + ecl_make_fixnum(e)), + x); + } + } + break; + } +#endif + default: + x = ecl_type_error(@'rational',"argument",x,@'number'); + goto AGAIN; + } + @(return x); } #ifdef ECL_LONG_FLOAT cl_object _ecl_long_double_to_integer(long double d0) { - const int fb = ECL_FIXNUM_BITS - 3; - int e; - long double d = frexpl(d0, &e); - if (e <= fb) { - return ecl_make_fixnum((cl_fixnum)d0); - } else if (e > LDBL_MANT_DIG) { - return ecl_ash(_ecl_long_double_to_integer(ldexp(d, LDBL_MANT_DIG)), - e - LDBL_MANT_DIG); - } else { - long double d1 = floorl(d = ldexpl(d, fb)); - int newe = e - fb; - cl_object o = ecl_ash(_ecl_long_double_to_integer(d1), newe); - long double d2 = ldexpl(d - d1, newe); - if (d2) o = ecl_plus(o, _ecl_long_double_to_integer(d2)); - return o; - } + const int fb = ECL_FIXNUM_BITS - 3; + int e; + long double d = frexpl(d0, &e); + if (e <= fb) { + return ecl_make_fixnum((cl_fixnum)d0); + } else if (e > LDBL_MANT_DIG) { + return ecl_ash(_ecl_long_double_to_integer(ldexp(d, LDBL_MANT_DIG)), + e - LDBL_MANT_DIG); + } else { + long double d1 = floorl(d = ldexpl(d, fb)); + int newe = e - fb; + cl_object o = ecl_ash(_ecl_long_double_to_integer(d1), newe); + long double d2 = ldexpl(d - d1, newe); + if (d2) o = ecl_plus(o, _ecl_long_double_to_integer(d2)); + return o; + } } #endif cl_object _ecl_double_to_integer(double d) { - if (d <= MOST_POSITIVE_FIXNUM && d >= MOST_NEGATIVE_FIXNUM) - return ecl_make_fixnum((cl_fixnum)d); - else { - cl_object z = _ecl_big_register0(); - _ecl_big_set_d(z, d); - return _ecl_big_register_copy(z); - } + if (d <= MOST_POSITIVE_FIXNUM && d >= MOST_NEGATIVE_FIXNUM) + return ecl_make_fixnum((cl_fixnum)d); + else { + cl_object z = _ecl_big_register0(); + _ecl_big_set_d(z, d); + return _ecl_big_register_copy(z); + } } cl_object _ecl_float_to_integer(float d) { - if (d <= MOST_POSITIVE_FIXNUM && d >= MOST_NEGATIVE_FIXNUM) - return ecl_make_fixnum((cl_fixnum)d); - else { - cl_object z = _ecl_big_register0(); - _ecl_big_set_d(z, d); - return _ecl_big_register_copy(z); - } + if (d <= MOST_POSITIVE_FIXNUM && d >= MOST_NEGATIVE_FIXNUM) + return ecl_make_fixnum((cl_fixnum)d); + else { + cl_object z = _ecl_big_register0(); + _ecl_big_set_d(z, d); + return _ecl_big_register_copy(z); + } +} + +#ifdef ECL_IEEE_FP +cl_object +si_nan() { + cl_object x = ecl_alloc_object(t_doublefloat); + ecl_double_float(x) = NAN; + return x; } +#endif /* ECL_IEEE_FP */ diff -Nru ecl-16.1.2/src/c/numbers/abs.d ecl-16.1.3+ds/src/c/numbers/abs.d --- ecl-16.1.2/src/c/numbers/abs.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/abs.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - abs.d -- Absolute value. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * abs.d - absolute value + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #define ECL_INCLUDE_MATH_H @@ -26,73 +21,73 @@ cl_object cl_abs(cl_object x) { - @(return ecl_abs(x)); + @(return ecl_abs(x)); } static cl_object ecl_abs_fixnum(cl_object x) { - return ecl_fixnum_minusp(x)? ecl_make_integer(-ecl_fixnum(x)) : x; + return ecl_fixnum_minusp(x)? ecl_make_integer(-ecl_fixnum(x)) : x; } static cl_object ecl_abs_bignum(cl_object x) { - return (_ecl_big_sign(x) < 0)? _ecl_big_negate(x) : x; + return (_ecl_big_sign(x) < 0)? _ecl_big_negate(x) : x; } static cl_object ecl_abs_rational(cl_object x) { - return (ecl_minusp(x->ratio.num))? - ecl_make_ratio(ecl_negate(x->ratio.num), x->ratio.den) : x; + return (ecl_minusp(x->ratio.num))? + ecl_make_ratio(ecl_negate(x->ratio.num), x->ratio.den) : x; } static cl_object ecl_abs_single_float(cl_object x) { - float f = ecl_single_float(x); - return (f < 0)? ecl_make_single_float(-f) : x; + float f = ecl_single_float(x); + return (f < 0)? ecl_make_single_float(-f) : x; } static cl_object ecl_abs_double_float(cl_object x) { - double f = ecl_double_float(x); - return (f < 0)? ecl_make_double_float(-f) : x; + double f = ecl_double_float(x); + return (f < 0)? ecl_make_double_float(-f) : x; } #ifdef ECL_LONG_FLOAT static cl_object ecl_abs_long_float(cl_object x) { - long double f = ecl_long_float(x); - return (f < 0)? ecl_make_long_float(-f) : x; + long double f = ecl_long_float(x); + return (f < 0)? ecl_make_long_float(-f) : x; } #endif static cl_object ecl_abs_complex(cl_object x) { - /* Compute sqrt(r*r + i*i) carefully to prevent overflow. - * Assume |i| >= |r|. Then sqrt(i*i + r*r) = |i|*sqrt(1 +(r/i)^2). - */ - cl_object r = ecl_abs(x->complex.real); - cl_object i = ecl_abs(x->complex.imag); - int comparison; - comparison = ecl_number_compare(r, i); - if (comparison == 0) { - r = ecl_times(r, r); - return ecl_sqrt(ecl_plus(r, r)); - } else { - if (comparison > 0) { - cl_object aux = i; - i = r; r = aux; - } - r = ecl_divide(r, i); - r = ecl_plus(ecl_make_fixnum(1), ecl_times(r, r)); - return ecl_times(cl_sqrt(r), i); - } + /* Compute sqrt(r*r + i*i) carefully to prevent overflow. + * Assume |i| >= |r|. Then sqrt(i*i + r*r) = |i|*sqrt(1 +(r/i)^2). + */ + cl_object r = ecl_abs(x->complex.real); + cl_object i = ecl_abs(x->complex.imag); + int comparison; + comparison = ecl_number_compare(r, i); + if (comparison == 0) { + r = ecl_times(r, r); + return ecl_sqrt(ecl_plus(r, r)); + } else { + if (comparison > 0) { + cl_object aux = i; + i = r; r = aux; + } + r = ecl_divide(r, i); + r = ecl_plus(ecl_make_fixnum(1), ecl_times(r, r)); + return ecl_times(cl_sqrt(r), i); + } } MATH_DEF_DISPATCH1_NE(abs, @[abs], @[number], diff -Nru ecl-16.1.2/src/c/numbers/atan.d ecl-16.1.3+ds/src/c/numbers/atan.d --- ecl-16.1.2/src/c/numbers/atan.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/atan.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - atan1.d -- Trascendental functions: arc tangent -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * atan1.d - Trascendental functions: arc tangent + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #define ECL_INCLUDE_MATH_H #include @@ -27,136 +22,138 @@ static double ecl_atan2_double(double y, double x) { - if (signbit(x)) { - if (signbit(y)) { - return -ECL_PI_D + atan(-y / -x); - } else if (y == 0) { - return ECL_PI_D; - } else { - return ECL_PI_D - atan(y / -x); - } - } else if (x == 0) { - if (signbit(y)) { - return -ECL_PI2_D; - } else if (y == 0) { - return x / y; /* Produces a NaN */ - } else { - return ECL_PI2_D; - } - } else { - if (signbit(y)) { - return -atan(-y / x); - } else if (y == 0) { - return (double)0; - } else { - return atan(y / x); - } - } + if (signbit(x)) { + if (signbit(y)) { + return -ECL_PI_D + atan(-y / -x); + } else if (y == 0) { + return ECL_PI_D; + } else { + return ECL_PI_D - atan(y / -x); + } + } else if (x == 0) { + if (signbit(y)) { + return -ECL_PI2_D; + } else if (y == 0) { + return x / y; /* Produces a NaN */ + } else { + return ECL_PI2_D; + } + } else { + if (signbit(y)) { + return -atan(-y / x); + } else if (y == 0) { + return (double)0; + } else { + return atan(y / x); + } + } } #ifdef ECL_LONG_FLOAT static long double ecl_atan2_long_double(long double y, long double x) { - if (signbit(x)) { - if (signbit(y)) { - return -ECL_PI_L + atanl(-y / -x); - } else if (y == 0) { - return ECL_PI_L; - } else { - return ECL_PI_L - atanl(y / -x); - } - } else if (x == 0) { - if (signbit(y)) { - return -ECL_PI2_L; - } else if (y == 0) { - return x / y; /* Produces a NaN */ - } else { - return ECL_PI2_L; - } - } else { - if (signbit(y)) { - return -atanl(-y / x); - } else if (y == 0) { - return (long double)0; - } else { - return atanl(y / x); - } - } + if (signbit(x)) { + if (signbit(y)) { + return -ECL_PI_L + atanl(-y / -x); + } else if (y == 0) { + return ECL_PI_L; + } else { + return ECL_PI_L - atanl(y / -x); + } + } else if (x == 0) { + if (signbit(y)) { + return -ECL_PI2_L; + } else if (y == 0) { + return x / y; /* Produces a NaN */ + } else { + return ECL_PI2_L; + } + } else { + if (signbit(y)) { + return -atanl(-y / x); + } else if (y == 0) { + return (long double)0; + } else { + return atanl(y / x); + } + } } #endif cl_object ecl_atan2(cl_object y, cl_object x) { - cl_object output; - ECL_MATHERR_CLEAR; - { + cl_object output; + ECL_MATHERR_CLEAR; + { #ifdef ECL_LONG_FLOAT - int tx = ecl_t_of(x); - int ty = ecl_t_of(y); - if (tx < ty) - tx = ty; - if (tx == t_longfloat) { - long double d = ecl_atan2_long_double(ecl_to_long_double(y), - ecl_to_long_double(x)); - output = ecl_make_long_float(d); - } else { - double dx = ecl_to_double(x); - double dy = ecl_to_double(y); - double dz = ecl_atan2_double(dy, dx); - if (tx == t_doublefloat) { - output = ecl_make_double_float(dz); - } else { - output = ecl_make_single_float(dz); - } - } + int tx = ecl_t_of(x); + int ty = ecl_t_of(y); + if (tx < ty) + tx = ty; + if (tx == t_longfloat) { + long double d = ecl_atan2_long_double(ecl_to_long_double(y), + ecl_to_long_double(x)); + output = ecl_make_long_float(d); + } else { + double dx = ecl_to_double(x); + double dy = ecl_to_double(y); + double dz = ecl_atan2_double(dy, dx); + if (tx == t_doublefloat) { + output = ecl_make_double_float(dz); + } else { + output = ecl_make_single_float(dz); + } + } #else - double dy = ecl_to_double(y); - double dx = ecl_to_double(x); - double dz = ecl_atan2_double(dy, dx); - if (ECL_DOUBLE_FLOAT_P(x) || ECL_DOUBLE_FLOAT_P(y)) { - output = ecl_make_double_float(dz); - } else { - output = ecl_make_single_float(dz); - } + double dy = ecl_to_double(y); + double dx = ecl_to_double(x); + double dz = ecl_atan2_double(dy, dx); + if (ECL_DOUBLE_FLOAT_P(x) || ECL_DOUBLE_FLOAT_P(y)) { + output = ecl_make_double_float(dz); + } else { + output = ecl_make_single_float(dz); + } #endif - } - ECL_MATHERR_TEST; - return output; + } + ECL_MATHERR_TEST; + return output; } cl_object ecl_atan1(cl_object y) { - if (ECL_COMPLEXP(y)) { + if (ECL_COMPLEXP(y)) { #if 0 /* ANSI states it should be this first part */ - cl_object z = ecl_times(cl_core.imag_unit, y); - z = ecl_plus(ecl_log1(ecl_one_plus(z)), - ecl_log1(ecl_minus(ecl_make_fixnum(1), z))); - z = ecl_divide(z, ecl_times(ecl_make_fixnum(2), - cl_core.imag_unit)); + cl_object z = ecl_times(cl_core.imag_unit, y); + z = ecl_plus(ecl_log1(ecl_one_plus(z)), + ecl_log1(ecl_minus(ecl_make_fixnum(1), z))); + z = ecl_divide(z, ecl_times(ecl_make_fixnum(2), + cl_core.imag_unit)); #else - cl_object z1, z = ecl_times(cl_core.imag_unit, y); - z = ecl_one_plus(z); - z1 = ecl_times(y, y); - z1 = ecl_one_plus(z1); - z1 = ecl_sqrt(z1); - z = ecl_divide(z, z1); - z = ecl_log1(z); - z = ecl_times(cl_core.minus_imag_unit, z); + cl_object z1, z = ecl_times(cl_core.imag_unit, y); + z = ecl_one_plus(z); + z1 = ecl_times(y, y); + z1 = ecl_one_plus(z1); + z1 = ecl_sqrt(z1); + z = ecl_divide(z, z1); + z = ecl_log1(z); + z = ecl_times(cl_core.minus_imag_unit, z); #endif /* ANSI */ - return z; - } else { - return ecl_atan2(y, ecl_make_fixnum(1)); - } + return z; + } else { + return ecl_atan2(y, ecl_make_fixnum(1)); + } } @(defun atan (x &optional (y OBJNULL)) -@ /* INV: type check in ecl_atan() & ecl_atan2() */ - /* FIXME ecl_atan() and ecl_atan2() produce generic errors - without recovery and function information. */ - if (y == OBJNULL) - @(return ecl_atan1(x)) - @(return ecl_atan2(x, y)) -@) + @ + /* INV: type check in ecl_atan() & ecl_atan2() */ + /* FIXME ecl_atan() and ecl_atan2() produce generic errors + without recovery and function information. */ + if (y == OBJNULL) { + @(return ecl_atan1(x)); + } + @(return ecl_atan2(x, y)); + @) diff -Nru ecl-16.1.2/src/c/numbers/ceiling.d ecl-16.1.3+ds/src/c/numbers/ceiling.d --- ecl-16.1.2/src/c/numbers/ceiling.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/ceiling.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - ceiling.d -- Implementation of CL:CEILING -*/ -/* - Copyright (c) 2010, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../../Copyright' for full details. -*/ + * ceiling.d - implementation of CL:CEILING + * + * Copyright (c) 2010 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #define ECL_INCLUDE_MATH_H #include @@ -24,214 +19,214 @@ #include @(defun ceiling (x &optional (y OBJNULL)) -@ - if (narg == 1) - return ecl_ceiling1(x); - else - return ecl_ceiling2(x, y); -@) + @ + if (narg == 1) + return ecl_ceiling1(x); + else + return ecl_ceiling2(x, y); + @) cl_object ecl_ceiling1(cl_object x) { - cl_object v0, v1; - switch (ecl_t_of(x)) { - case t_fixnum: - case t_bignum: - v0 = x; - v1 = ecl_make_fixnum(0); - break; - case t_ratio: { - const cl_env_ptr the_env = ecl_process_env(); - v0 = ecl_ceiling2(x->ratio.num, x->ratio.den); - v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), x->ratio.den); - break; - } - case t_singlefloat: { - float d = ecl_single_float(x); - float y = ceilf(d); - v0 = _ecl_float_to_integer(y); - v1 = ecl_make_single_float(d - y); - break; - } - case t_doublefloat: { - double d = ecl_double_float(x); - double y = ceil(d); - v0 = _ecl_double_to_integer(y); - v1 = ecl_make_double_float(d - y); - break; - } + cl_object v0, v1; + switch (ecl_t_of(x)) { + case t_fixnum: + case t_bignum: + v0 = x; + v1 = ecl_make_fixnum(0); + break; + case t_ratio: { + const cl_env_ptr the_env = ecl_process_env(); + v0 = ecl_ceiling2(x->ratio.num, x->ratio.den); + v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), x->ratio.den); + break; + } + case t_singlefloat: { + float d = ecl_single_float(x); + float y = ceilf(d); + v0 = _ecl_float_to_integer(y); + v1 = ecl_make_single_float(d - y); + break; + } + case t_doublefloat: { + double d = ecl_double_float(x); + double y = ceil(d); + v0 = _ecl_double_to_integer(y); + v1 = ecl_make_double_float(d - y); + break; + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double d = ecl_long_float(x); - long double y = ceill(d); - v0 = _ecl_long_double_to_integer(y); - v1 = ecl_make_long_float(d - y); - break; - } + case t_longfloat: { + long double d = ecl_long_float(x); + long double y = ceill(d); + v0 = _ecl_long_double_to_integer(y); + v1 = ecl_make_long_float(d - y); + break; + } #endif - default: - FEwrong_type_nth_arg(@[ceiling],1,x,@[real]); - } - @(return v0 v1) + default: + FEwrong_type_nth_arg(@[ceiling],1,x,@[real]); + } + @(return v0 v1); } cl_object ecl_ceiling2(cl_object x, cl_object y) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object v0, v1; - cl_type ty; - ty = ecl_t_of(y); - if (ecl_unlikely(!ECL_REAL_TYPE_P(ty))) { - FEwrong_type_nth_arg(@[ceiling],2, y, @[real]); - } - switch(ecl_t_of(x)) { - case t_fixnum: - switch(ty) { - case t_fixnum: { /* FIX / FIX */ - cl_fixnum a = ecl_fixnum(x); cl_fixnum b = ecl_fixnum(y); - cl_fixnum q = a / b; cl_fixnum r = a % b; - if ((r^b) > 0 && r) { /* same signs and some remainder */ - v0 = ecl_make_fixnum(q+1); - v1 = ecl_make_fixnum(r-b); - } else { - v0 = ecl_make_fixnum(q); - v1 = ecl_make_fixnum(r); - } - break; - } - case t_bignum: { /* FIX / BIG */ - /* We must perform the division because there is the - * pathological case - * x = MOST_NEGATIVE_FIXNUM - * y = - MOST_NEGATIVE_FIXNUM - */ - ECL_WITH_TEMP_BIGNUM(bx,4); - _ecl_big_set_fixnum(bx, ecl_fixnum(x)); - v0 = _ecl_big_ceiling(bx, y, &v1); - break; - } - case t_ratio: /* FIX / RAT */ - v0 = ecl_ceiling2(ecl_times(x, y->ratio.den), y->ratio.num); - v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), y->ratio.den); - break; - case t_singlefloat: { /* FIX / SF */ - float n = ecl_single_float(y); - float p = ecl_fixnum(x)/n; - float q = ceilf(p); - v0 = _ecl_float_to_integer(q); - v1 = ecl_make_single_float(p*n - q*n); - break; - } - case t_doublefloat: { /* FIX / DF */ - double n = ecl_double_float(y); - double p = ecl_fixnum(x)/n; - double q = ceil(p); - v0 = _ecl_double_to_integer(q); - v1 = ecl_make_double_float(p*n - q*n); - break; - } + const cl_env_ptr the_env = ecl_process_env(); + cl_object v0, v1; + cl_type ty; + ty = ecl_t_of(y); + if (ecl_unlikely(!ECL_REAL_TYPE_P(ty))) { + FEwrong_type_nth_arg(@[ceiling],2, y, @[real]); + } + switch(ecl_t_of(x)) { + case t_fixnum: + switch(ty) { + case t_fixnum: { /* FIX / FIX */ + cl_fixnum a = ecl_fixnum(x); cl_fixnum b = ecl_fixnum(y); + cl_fixnum q = a / b; cl_fixnum r = a % b; + if ((r^b) > 0 && r) { /* same signs and some remainder */ + v0 = ecl_make_fixnum(q+1); + v1 = ecl_make_fixnum(r-b); + } else { + v0 = ecl_make_fixnum(q); + v1 = ecl_make_fixnum(r); + } + break; + } + case t_bignum: { /* FIX / BIG */ + /* We must perform the division because there is the + * pathological case + * x = MOST_NEGATIVE_FIXNUM + * y = - MOST_NEGATIVE_FIXNUM + */ + ECL_WITH_TEMP_BIGNUM(bx,4); + _ecl_big_set_fixnum(bx, ecl_fixnum(x)); + v0 = _ecl_big_ceiling(bx, y, &v1); + break; + } + case t_ratio: /* FIX / RAT */ + v0 = ecl_ceiling2(ecl_times(x, y->ratio.den), y->ratio.num); + v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), y->ratio.den); + break; + case t_singlefloat: { /* FIX / SF */ + float n = ecl_single_float(y); + float p = ecl_fixnum(x)/n; + float q = ceilf(p); + v0 = _ecl_float_to_integer(q); + v1 = ecl_make_single_float(p*n - q*n); + break; + } + case t_doublefloat: { /* FIX / DF */ + double n = ecl_double_float(y); + double p = ecl_fixnum(x)/n; + double q = ceil(p); + v0 = _ecl_double_to_integer(q); + v1 = ecl_make_double_float(p*n - q*n); + break; + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { /* FIX / LF */ - long double n = ecl_long_float(y); - long double p = ecl_fixnum(x)/n; - long double q = ceill(p); - v0 = _ecl_long_double_to_integer(q); - v1 = ecl_make_long_float(p*n - q*n); - break; - } + case t_longfloat: { /* FIX / LF */ + long double n = ecl_long_float(y); + long double p = ecl_fixnum(x)/n; + long double q = ceill(p); + v0 = _ecl_long_double_to_integer(q); + v1 = ecl_make_long_float(p*n - q*n); + break; + } #endif - default: - (void)0; /*Never reached */ - } - break; - case t_bignum: - switch(ecl_t_of(y)) { - case t_fixnum: { /* BIG / FIX */ - ECL_WITH_TEMP_BIGNUM(by,4); - _ecl_big_set_fixnum(by, ecl_fixnum(y)); - v0 = _ecl_big_ceiling(x, by, &v1); - break; - } - case t_bignum: { /* BIG / BIG */ - v0 = _ecl_big_ceiling(x, y, &v1); - break; - } - case t_ratio: /* BIG / RAT */ - v0 = ecl_ceiling2(ecl_times(x, y->ratio.den), y->ratio.num); - v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), y->ratio.den); - break; - case t_singlefloat: { /* BIG / SF */ - float n = ecl_single_float(y); - float p = _ecl_big_to_double(x)/n; - float q = ceilf(p); - v0 = _ecl_float_to_integer(q); - v1 = ecl_make_single_float(p*n - q*n); - break; - } - case t_doublefloat: { /* BIG / DF */ - double n = ecl_double_float(y); - double p = _ecl_big_to_double(x)/n; - double q = ceil(p); - v0 = _ecl_double_to_integer(q); - v1 = ecl_make_double_float(p*n - q*n); - break; - } + default: + (void)0; /*Never reached */ + } + break; + case t_bignum: + switch(ecl_t_of(y)) { + case t_fixnum: { /* BIG / FIX */ + ECL_WITH_TEMP_BIGNUM(by,4); + _ecl_big_set_fixnum(by, ecl_fixnum(y)); + v0 = _ecl_big_ceiling(x, by, &v1); + break; + } + case t_bignum: { /* BIG / BIG */ + v0 = _ecl_big_ceiling(x, y, &v1); + break; + } + case t_ratio: /* BIG / RAT */ + v0 = ecl_ceiling2(ecl_times(x, y->ratio.den), y->ratio.num); + v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), y->ratio.den); + break; + case t_singlefloat: { /* BIG / SF */ + float n = ecl_single_float(y); + float p = _ecl_big_to_double(x)/n; + float q = ceilf(p); + v0 = _ecl_float_to_integer(q); + v1 = ecl_make_single_float(p*n - q*n); + break; + } + case t_doublefloat: { /* BIG / DF */ + double n = ecl_double_float(y); + double p = _ecl_big_to_double(x)/n; + double q = ceil(p); + v0 = _ecl_double_to_integer(q); + v1 = ecl_make_double_float(p*n - q*n); + break; + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { /* BIG / LF */ - long double n = ecl_long_float(y); - long double p = _ecl_big_to_double(x)/n; - long double q = ceill(p); - v0 = _ecl_long_double_to_integer(q); - v1 = ecl_make_long_float(p*n - q*n); - break; - } + case t_longfloat: { /* BIG / LF */ + long double n = ecl_long_float(y); + long double p = _ecl_big_to_double(x)/n; + long double q = ceill(p); + v0 = _ecl_long_double_to_integer(q); + v1 = ecl_make_long_float(p*n - q*n); + break; + } #endif - default: - (void)0; /*Never reached */ - } - break; - case t_ratio: - switch(ecl_t_of(y)) { - case t_ratio: /* RAT / RAT */ - v0 = ecl_ceiling2(ecl_times(x->ratio.num, y->ratio.den), - ecl_times(x->ratio.den, y->ratio.num)); - v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), ecl_times(x->ratio.den, y->ratio.den)); - break; - default: /* RAT / ANY */ - v0 = ecl_ceiling2(x->ratio.num, ecl_times(x->ratio.den, y)); - v1 = ecl_divide(ecl_nth_value(the_env, 1), x->ratio.den); - } - break; - case t_singlefloat: { /* SF / ANY */ - float n = ecl_to_double(y); - float p = ecl_single_float(x)/n; - float q = ceilf(p); - v0 = _ecl_float_to_integer(q); - v1 = ecl_make_single_float(p*n - q*n); - break; - } - case t_doublefloat: { /* DF / ANY */ - double n = ecl_to_double(y); - double p = ecl_double_float(x)/n; - double q = ceil(p); - v0 = _ecl_double_to_integer(q); - v1 = ecl_make_double_float(p*n - q*n); - break; - } + default: + (void)0; /*Never reached */ + } + break; + case t_ratio: + switch(ecl_t_of(y)) { + case t_ratio: /* RAT / RAT */ + v0 = ecl_ceiling2(ecl_times(x->ratio.num, y->ratio.den), + ecl_times(x->ratio.den, y->ratio.num)); + v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), ecl_times(x->ratio.den, y->ratio.den)); + break; + default: /* RAT / ANY */ + v0 = ecl_ceiling2(x->ratio.num, ecl_times(x->ratio.den, y)); + v1 = ecl_divide(ecl_nth_value(the_env, 1), x->ratio.den); + } + break; + case t_singlefloat: { /* SF / ANY */ + float n = ecl_to_double(y); + float p = ecl_single_float(x)/n; + float q = ceilf(p); + v0 = _ecl_float_to_integer(q); + v1 = ecl_make_single_float(p*n - q*n); + break; + } + case t_doublefloat: { /* DF / ANY */ + double n = ecl_to_double(y); + double p = ecl_double_float(x)/n; + double q = ceil(p); + v0 = _ecl_double_to_integer(q); + v1 = ecl_make_double_float(p*n - q*n); + break; + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { /* LF / ANY */ - long double n = ecl_to_long_double(y); - long double p = ecl_long_float(x)/n; - long double q = ceill(p); - v0 = _ecl_long_double_to_integer(q); - v1 = ecl_make_long_float(p*n - q*n); - break; - } + case t_longfloat: { /* LF / ANY */ + long double n = ecl_to_long_double(y); + long double p = ecl_long_float(x)/n; + long double q = ceill(p); + v0 = _ecl_long_double_to_integer(q); + v1 = ecl_make_long_float(p*n - q*n); + break; + } #endif - default: - FEwrong_type_nth_arg(@[ceiling], 1, x, @[real]); - } - ecl_return2(the_env, v0, v1); + default: + FEwrong_type_nth_arg(@[ceiling], 1, x, @[real]); + } + ecl_return2(the_env, v0, v1); } diff -Nru ecl-16.1.2/src/c/numbers/conjugate.d ecl-16.1.3+ds/src/c/numbers/conjugate.d --- ecl-16.1.2/src/c/numbers/conjugate.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/conjugate.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - conjugate.d -- Trascendental functions: conjugateine -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * conjugate.d - trascendental functions: conjugateine + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -23,19 +18,19 @@ cl_object cl_conjugate(cl_object x) { - @(return ecl_conjugate(x)); + @(return ecl_conjugate(x)); } static cl_object ecl_conjugate_real(cl_object x) { - return x; + return x; } static cl_object ecl_conjugate_complex(cl_object x) { - return ecl_make_complex(x->complex.real, ecl_negate(x->complex.imag)); + return ecl_make_complex(x->complex.real, ecl_negate(x->complex.imag)); } MATH_DEF_DISPATCH1_NE(conjugate, @[conjugate], @[number], diff -Nru ecl-16.1.2/src/c/numbers/cos.d ecl-16.1.3+ds/src/c/numbers/cos.d --- ecl-16.1.2/src/c/numbers/cos.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/cos.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - cos.d -- Trascendental functions: cosine -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * cos.d - trascendental functions: cosine + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #define ECL_INCLUDE_MATH_H #include @@ -27,46 +22,46 @@ cl_object cl_cos(cl_object x) { - @(return ecl_cos(x)); + @(return ecl_cos(x)); } static cl_object ecl_cos_rational(cl_object x) { - return ecl_make_single_float(cosf(ecl_to_float(x))); + return ecl_make_single_float(cosf(ecl_to_float(x))); } static cl_object ecl_cos_single_float(cl_object x) { - return ecl_make_single_float(cosf(ecl_single_float(x))); + return ecl_make_single_float(cosf(ecl_single_float(x))); } static cl_object ecl_cos_double_float(cl_object x) { - return ecl_make_double_float(cos(ecl_double_float(x))); + return ecl_make_double_float(cos(ecl_double_float(x))); } #ifdef ECL_LONG_FLOAT static cl_object ecl_cos_long_float(cl_object x) { - return ecl_make_long_float(cosl(ecl_long_float(x))); + return ecl_make_long_float(cosl(ecl_long_float(x))); } #endif static cl_object ecl_cos_complex(cl_object x) { - /* z = x + I y - cos(z) = cosh(I z) = cosh(-y + I x) - */ - cl_object dx = x->complex.real; - cl_object dy = x->complex.imag; - cl_object a = ecl_times(ecl_cos(dx), ecl_cosh(dy)); - cl_object b = ecl_times(ecl_negate(ecl_sin(dx)), ecl_sinh(dy)); - return ecl_make_complex(a, b); + /* z = x + I y + cos(z) = cosh(I z) = cosh(-y + I x) + */ + cl_object dx = x->complex.real; + cl_object dy = x->complex.imag; + cl_object a = ecl_times(ecl_cos(dx), ecl_cosh(dy)); + cl_object b = ecl_times(ecl_negate(ecl_sin(dx)), ecl_sinh(dy)); + return ecl_make_complex(a, b); } MATH_DEF_DISPATCH1(cos, @[cos], @[number], diff -Nru ecl-16.1.2/src/c/numbers/cosh.d ecl-16.1.3+ds/src/c/numbers/cosh.d --- ecl-16.1.2/src/c/numbers/cosh.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/cosh.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - cosh.d -- Trascendental functions: hyperbolic cosine -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * ecl_constants.h - contstant values for all_symbols.d + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #define ECL_INCLUDE_MATH_H #include @@ -27,49 +22,49 @@ cl_object cl_cosh(cl_object x) { - @(return ecl_cosh(x)); + @(return ecl_cosh(x)); } static cl_object ecl_cosh_rational(cl_object x) { - return ecl_make_single_float(coshf(ecl_to_float(x))); + return ecl_make_single_float(coshf(ecl_to_float(x))); } static cl_object ecl_cosh_single_float(cl_object x) { - return ecl_make_single_float(coshf(ecl_single_float(x))); + return ecl_make_single_float(coshf(ecl_single_float(x))); } static cl_object ecl_cosh_double_float(cl_object x) { - return ecl_make_double_float(cosh(ecl_double_float(x))); + return ecl_make_double_float(cosh(ecl_double_float(x))); } #ifdef ECL_LONG_FLOAT static cl_object ecl_cosh_long_float(cl_object x) { - return ecl_make_long_float(coshl(ecl_long_float(x))); + return ecl_make_long_float(coshl(ecl_long_float(x))); } #endif static cl_object ecl_cosh_complex(cl_object x) { - /* - z = x + I y - cosh(z) = (exp(z)+exp(-z))/2 - = (exp(x)*(cos(y)+Isin(y))+exp(-x)*(cos(y)-Isin(y)))/2 - = cosh(x)*cos(y) + Isinh(x)*sin(y); - */ - cl_object dx = x->complex.real; - cl_object dy = x->complex.imag; - cl_object a = ecl_times(ecl_cosh(dx), ecl_cos(dy)); - cl_object b = ecl_times(ecl_sinh(dx), ecl_sin(dy)); - return ecl_make_complex(a, b); + /* + z = x + I y + cosh(z) = (exp(z)+exp(-z))/2 + = (exp(x)*(cos(y)+Isin(y))+exp(-x)*(cos(y)-Isin(y)))/2 + = cosh(x)*cos(y) + Isinh(x)*sin(y); + */ + cl_object dx = x->complex.real; + cl_object dy = x->complex.imag; + cl_object a = ecl_times(ecl_cosh(dx), ecl_cos(dy)); + cl_object b = ecl_times(ecl_sinh(dx), ecl_sin(dy)); + return ecl_make_complex(a, b); } MATH_DEF_DISPATCH1(cosh, @[cosh], @[number], diff -Nru ecl-16.1.2/src/c/numbers/divide.d ecl-16.1.3+ds/src/c/numbers/divide.d --- ecl-16.1.2/src/c/numbers/divide.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/divide.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,180 +1,178 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - divde.d -- Implementation of CL:/ -*/ -/* - Copyright (c) 2010, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../../Copyright' for full details. -*/ + * divde.d - implementation of CL:/ + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @(defun / (num &rest nums) -@ - /* INV: type check is in ecl_divide() */ - if (narg == 0) - FEwrong_num_arguments(@[/]); - if (narg == 1) - @(return ecl_divide(ecl_make_fixnum(1), num)) - while (--narg) - num = ecl_divide(num, ecl_va_arg(nums)); - @(return num) -@) + @ + /* INV: type check is in ecl_divide() */ + if (narg == 0) + FEwrong_num_arguments(@[/]); + if (narg == 1) { + @(return ecl_divide(ecl_make_fixnum(1), num)); + } + while (--narg) + num = ecl_divide(num, ecl_va_arg(nums)); + @(return num); + @) #ifdef MATH_DISPATCH2_BEGIN static cl_object complex_divide(cl_object ar, cl_object ai, cl_object br, cl_object bi) { - /* #C(z1 z2) = #C(xr xi) * #C(yr -yi) */ - cl_object z1 = ecl_plus(ecl_times(ar, br), ecl_times(ai, bi)); - cl_object z2 = ecl_minus(ecl_times(ai, br), ecl_times(ar, bi)); - cl_object absB = ecl_plus(ecl_times(br, br), ecl_times(bi, bi)); - return ecl_make_complex(ecl_divide(z1, absB), ecl_divide(z2, absB)); + /* #C(z1 z2) = #C(xr xi) * #C(yr -yi) */ + cl_object z1 = ecl_plus(ecl_times(ar, br), ecl_times(ai, bi)); + cl_object z2 = ecl_minus(ecl_times(ai, br), ecl_times(ar, bi)); + cl_object absB = ecl_plus(ecl_times(br, br), ecl_times(bi, bi)); + return ecl_make_complex(ecl_divide(z1, absB), ecl_divide(z2, absB)); } cl_object ecl_divide(cl_object x, cl_object y) { -MATH_DISPATCH2_BEGIN(x,y) -{ - CASE_FIXNUM_FIXNUM; - CASE_BIGNUM_FIXNUM { - if (y == ecl_make_fixnum(0)) - FEdivision_by_zero(x, y); - } - CASE_FIXNUM_BIGNUM; - CASE_BIGNUM_BIGNUM { - return ecl_make_ratio(x, y); - } - CASE_FIXNUM_RATIO; - CASE_BIGNUM_RATIO { - return ecl_make_ratio(ecl_times(x, y->ratio.den), - y->ratio.num); - } - CASE_FIXNUM_SINGLE_FLOAT { - return ecl_make_single_float(ecl_fixnum(x) / ecl_single_float(y)); - } - CASE_FIXNUM_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_fixnum(x) / ecl_double_float(y)); - } - CASE_BIGNUM_SINGLE_FLOAT; - CASE_RATIO_SINGLE_FLOAT { - return ecl_make_single_float(ecl_to_float(x) / ecl_single_float(y)); - } - CASE_BIGNUM_DOUBLE_FLOAT; - CASE_RATIO_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_to_double(x) / ecl_double_float(y)); - } - CASE_RATIO_FIXNUM { - if (y == ecl_make_fixnum(0)) { - FEdivision_by_zero(x,y); - } - } - CASE_RATIO_BIGNUM { - cl_object z = ecl_times(x->ratio.den, y); - return ecl_make_ratio(x->ratio.num, z); - } - CASE_RATIO_RATIO { - cl_object num = ecl_times(x->ratio.num,y->ratio.den); - cl_object den = ecl_times(x->ratio.den,y->ratio.num); - return ecl_make_ratio(num, den); - } - CASE_SINGLE_FLOAT_FIXNUM { - return ecl_make_single_float(ecl_single_float(x) / ecl_fixnum(y)); - } - CASE_SINGLE_FLOAT_BIGNUM; - CASE_SINGLE_FLOAT_RATIO { - return ecl_make_single_float(ecl_single_float(x) / ecl_to_float(y)); - } - CASE_SINGLE_FLOAT_SINGLE_FLOAT { - return ecl_make_single_float(ecl_single_float(x) / ecl_single_float(y)); - } - CASE_SINGLE_FLOAT_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_single_float(x) / ecl_double_float(y)); - } - CASE_DOUBLE_FLOAT_FIXNUM { - return ecl_make_double_float(ecl_double_float(x) / ecl_fixnum(y)); - } - CASE_DOUBLE_FLOAT_BIGNUM; - CASE_DOUBLE_FLOAT_RATIO { - return ecl_make_double_float(ecl_double_float(x) / ecl_to_double(y)); - } - CASE_DOUBLE_FLOAT_SINGLE_FLOAT { - return ecl_make_double_float(ecl_double_float(x) / ecl_single_float(y)); - } - CASE_DOUBLE_FLOAT_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_double_float(x) / ecl_double_float(y)); - } + MATH_DISPATCH2_BEGIN(x,y) + { + CASE_FIXNUM_FIXNUM; + CASE_BIGNUM_FIXNUM { + if (y == ecl_make_fixnum(0)) + FEdivision_by_zero(x, y); + } + CASE_FIXNUM_BIGNUM; + CASE_BIGNUM_BIGNUM { + return ecl_make_ratio(x, y); + } + CASE_FIXNUM_RATIO; + CASE_BIGNUM_RATIO { + return ecl_make_ratio(ecl_times(x, y->ratio.den), + y->ratio.num); + } + CASE_FIXNUM_SINGLE_FLOAT { + return ecl_make_single_float(ecl_fixnum(x) / ecl_single_float(y)); + } + CASE_FIXNUM_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_fixnum(x) / ecl_double_float(y)); + } + CASE_BIGNUM_SINGLE_FLOAT; + CASE_RATIO_SINGLE_FLOAT { + return ecl_make_single_float(ecl_to_float(x) / ecl_single_float(y)); + } + CASE_BIGNUM_DOUBLE_FLOAT; + CASE_RATIO_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_to_double(x) / ecl_double_float(y)); + } + CASE_RATIO_FIXNUM { + if (y == ecl_make_fixnum(0)) { + FEdivision_by_zero(x,y); + } + } + CASE_RATIO_BIGNUM { + cl_object z = ecl_times(x->ratio.den, y); + return ecl_make_ratio(x->ratio.num, z); + } + CASE_RATIO_RATIO { + cl_object num = ecl_times(x->ratio.num,y->ratio.den); + cl_object den = ecl_times(x->ratio.den,y->ratio.num); + return ecl_make_ratio(num, den); + } + CASE_SINGLE_FLOAT_FIXNUM { + return ecl_make_single_float(ecl_single_float(x) / ecl_fixnum(y)); + } + CASE_SINGLE_FLOAT_BIGNUM; + CASE_SINGLE_FLOAT_RATIO { + return ecl_make_single_float(ecl_single_float(x) / ecl_to_float(y)); + } + CASE_SINGLE_FLOAT_SINGLE_FLOAT { + return ecl_make_single_float(ecl_single_float(x) / ecl_single_float(y)); + } + CASE_SINGLE_FLOAT_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_single_float(x) / ecl_double_float(y)); + } + CASE_DOUBLE_FLOAT_FIXNUM { + return ecl_make_double_float(ecl_double_float(x) / ecl_fixnum(y)); + } + CASE_DOUBLE_FLOAT_BIGNUM; + CASE_DOUBLE_FLOAT_RATIO { + return ecl_make_double_float(ecl_double_float(x) / ecl_to_double(y)); + } + CASE_DOUBLE_FLOAT_SINGLE_FLOAT { + return ecl_make_double_float(ecl_double_float(x) / ecl_single_float(y)); + } + CASE_DOUBLE_FLOAT_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_double_float(x) / ecl_double_float(y)); + } #ifdef ECL_LONG_FLOAT - CASE_FIXNUM_LONG_FLOAT { - return ecl_make_long_float(ecl_fixnum(x) / ecl_long_float(y)); - } - CASE_BIGNUM_LONG_FLOAT; - CASE_RATIO_LONG_FLOAT { - return ecl_make_long_float(ecl_to_long_double(x) / ecl_long_float(y)); - } - CASE_SINGLE_FLOAT_LONG_FLOAT { - return ecl_make_long_float(ecl_single_float(x) / ecl_long_float(y)); - } - CASE_DOUBLE_FLOAT_LONG_FLOAT { - return ecl_make_long_float(ecl_double_float(x) / ecl_long_float(y)); - } - CASE_LONG_FLOAT_FIXNUM { - return ecl_make_long_float(ecl_long_float(x) / ecl_fixnum(y)); - } - CASE_LONG_FLOAT_BIGNUM; - CASE_LONG_FLOAT_RATIO { - return ecl_make_long_float(ecl_long_float(x) / ecl_to_long_double(y)); - } - CASE_LONG_FLOAT_SINGLE_FLOAT { - return ecl_make_long_float(ecl_long_float(x) / ecl_single_float(y)); - } - CASE_LONG_FLOAT_DOUBLE_FLOAT { - return ecl_make_long_float(ecl_long_float(x) / ecl_double_float(y)); - } - CASE_LONG_FLOAT_LONG_FLOAT { - return ecl_make_long_float(ecl_long_float(x) / ecl_long_float(y)); - } - CASE_LONG_FLOAT_COMPLEX { - goto COMPLEX_Y; - } - CASE_COMPLEX_LONG_FLOAT; { - goto COMPLEX_X; - } + CASE_FIXNUM_LONG_FLOAT { + return ecl_make_long_float(ecl_fixnum(x) / ecl_long_float(y)); + } + CASE_BIGNUM_LONG_FLOAT; + CASE_RATIO_LONG_FLOAT { + return ecl_make_long_float(ecl_to_long_double(x) / ecl_long_float(y)); + } + CASE_SINGLE_FLOAT_LONG_FLOAT { + return ecl_make_long_float(ecl_single_float(x) / ecl_long_float(y)); + } + CASE_DOUBLE_FLOAT_LONG_FLOAT { + return ecl_make_long_float(ecl_double_float(x) / ecl_long_float(y)); + } + CASE_LONG_FLOAT_FIXNUM { + return ecl_make_long_float(ecl_long_float(x) / ecl_fixnum(y)); + } + CASE_LONG_FLOAT_BIGNUM; + CASE_LONG_FLOAT_RATIO { + return ecl_make_long_float(ecl_long_float(x) / ecl_to_long_double(y)); + } + CASE_LONG_FLOAT_SINGLE_FLOAT { + return ecl_make_long_float(ecl_long_float(x) / ecl_single_float(y)); + } + CASE_LONG_FLOAT_DOUBLE_FLOAT { + return ecl_make_long_float(ecl_long_float(x) / ecl_double_float(y)); + } + CASE_LONG_FLOAT_LONG_FLOAT { + return ecl_make_long_float(ecl_long_float(x) / ecl_long_float(y)); + } + CASE_LONG_FLOAT_COMPLEX { + goto COMPLEX_Y; + } + CASE_COMPLEX_LONG_FLOAT; { + goto COMPLEX_X; + } #endif - CASE_COMPLEX_FIXNUM; - CASE_COMPLEX_BIGNUM; - CASE_COMPLEX_RATIO; - CASE_COMPLEX_SINGLE_FLOAT; - CASE_COMPLEX_DOUBLE_FLOAT; COMPLEX_X: { - return ecl_make_complex(ecl_divide(x->complex.real, y), - ecl_divide(x->complex.imag, y)); - } - CASE_BIGNUM_COMPLEX; - CASE_RATIO_COMPLEX; - CASE_SINGLE_FLOAT_COMPLEX; - CASE_DOUBLE_FLOAT_COMPLEX; - CASE_FIXNUM_COMPLEX { - COMPLEX_Y: - return complex_divide(x, ecl_make_fixnum(0), y->complex.real, y->complex.imag); - } - CASE_COMPLEX_COMPLEX { - return complex_divide(x->complex.real, x->complex.imag, - y->complex.real, y->complex.imag); - } - CASE_UNKNOWN(@[/],x,y,@[number]); -} -MATH_DISPATCH2_END; + CASE_COMPLEX_FIXNUM; + CASE_COMPLEX_BIGNUM; + CASE_COMPLEX_RATIO; + CASE_COMPLEX_SINGLE_FLOAT; + CASE_COMPLEX_DOUBLE_FLOAT; COMPLEX_X: { + return ecl_make_complex(ecl_divide(x->complex.real, y), + ecl_divide(x->complex.imag, y)); + } + CASE_BIGNUM_COMPLEX; + CASE_RATIO_COMPLEX; + CASE_SINGLE_FLOAT_COMPLEX; + CASE_DOUBLE_FLOAT_COMPLEX; + CASE_FIXNUM_COMPLEX { + COMPLEX_Y: + return complex_divide(x, ecl_make_fixnum(0), y->complex.real, y->complex.imag); + } + CASE_COMPLEX_COMPLEX { + return complex_divide(x->complex.real, x->complex.imag, + y->complex.real, y->complex.imag); + } + CASE_UNKNOWN(@[/],x,y,@[number]); + } + MATH_DISPATCH2_END; } #else @@ -182,146 +180,146 @@ cl_object ecl_divide(cl_object x, cl_object y) { - cl_object z, z1, z2; + cl_object z, z1, z2; - switch (ecl_t_of(x)) { - case t_fixnum: - case t_bignum: - switch (ecl_t_of(y)) { - case t_fixnum: - if (y == ecl_make_fixnum(0)) - FEdivision_by_zero(x, y); - case t_bignum: - if (ecl_minusp(y) == TRUE) { - x = ecl_negate(x); - y = ecl_negate(y); - } - return ecl_make_ratio(x, y); - case t_ratio: - z = ecl_times(x, y->ratio.den); - return ecl_make_ratio(z, y->ratio.num); - case t_singlefloat: - return ecl_make_single_float(ecl_to_double(x) / ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_to_double(x) / ecl_double_float(y)); + switch (ecl_t_of(x)) { + case t_fixnum: + case t_bignum: + switch (ecl_t_of(y)) { + case t_fixnum: + if (y == ecl_make_fixnum(0)) + FEdivision_by_zero(x, y); + case t_bignum: + if (ecl_minusp(y) == TRUE) { + x = ecl_negate(x); + y = ecl_negate(y); + } + return ecl_make_ratio(x, y); + case t_ratio: + z = ecl_times(x, y->ratio.den); + return ecl_make_ratio(z, y->ratio.num); + case t_singlefloat: + return ecl_make_single_float(ecl_to_double(x) / ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_to_double(x) / ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_to_double(x) / ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_to_double(x) / ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[/], 2, y, @[number]); - } - case t_ratio: - switch (ecl_t_of(y)) { - case t_fixnum: - if (y == ecl_make_fixnum(0)) - FEdivision_by_zero(x, y); - case t_bignum: - z = ecl_times(x->ratio.den, y); - return ecl_make_ratio(x->ratio.num, z); - case t_ratio: - z = ecl_times(x->ratio.num,y->ratio.den); - z1 = ecl_times(x->ratio.den,y->ratio.num); - return ecl_make_ratio(z, z1); - case t_singlefloat: - return ecl_make_single_float(ecl_to_double(x) / ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_to_double(x) / ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[/], 2, y, @[number]); + } + case t_ratio: + switch (ecl_t_of(y)) { + case t_fixnum: + if (y == ecl_make_fixnum(0)) + FEdivision_by_zero(x, y); + case t_bignum: + z = ecl_times(x->ratio.den, y); + return ecl_make_ratio(x->ratio.num, z); + case t_ratio: + z = ecl_times(x->ratio.num,y->ratio.den); + z1 = ecl_times(x->ratio.den,y->ratio.num); + return ecl_make_ratio(z, z1); + case t_singlefloat: + return ecl_make_single_float(ecl_to_double(x) / ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_to_double(x) / ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_to_double(x) / ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_to_double(x) / ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[/], 2, y, @[number]); - } - case t_singlefloat: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_single_float(ecl_single_float(x) / ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_single_float(ecl_single_float(x) / ecl_to_double(y)); - case t_singlefloat: - return ecl_make_single_float(ecl_single_float(x) / ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_single_float(x) / ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[/], 2, y, @[number]); + } + case t_singlefloat: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_single_float(ecl_single_float(x) / ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_single_float(ecl_single_float(x) / ecl_to_double(y)); + case t_singlefloat: + return ecl_make_single_float(ecl_single_float(x) / ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_single_float(x) / ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_single_float(x) / ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_single_float(x) / ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[/], 2, y, @[number]); - } - case t_doublefloat: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_double_float(ecl_double_float(x) / ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_double_float(ecl_double_float(x) / ecl_to_double(y)); - case t_singlefloat: - return ecl_make_double_float(ecl_double_float(x) / ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_double_float(x) / ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[/], 2, y, @[number]); + } + case t_doublefloat: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_double_float(ecl_double_float(x) / ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_double_float(ecl_double_float(x) / ecl_to_double(y)); + case t_singlefloat: + return ecl_make_double_float(ecl_double_float(x) / ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_double_float(x) / ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_double_float(x) / ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_double_float(x) / ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[/], 2, y, @[number]); - } + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[/], 2, y, @[number]); + } #ifdef ECL_LONG_FLOAT - case t_longfloat: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_long_float(ecl_long_float(x) / ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_long_float(ecl_long_float(x) / ecl_to_double(y)); - case t_singlefloat: - return ecl_make_long_float(ecl_long_float(x) / ecl_single_float(y)); - case t_doublefloat: - return ecl_make_long_float(ecl_long_float(x) / ecl_double_float(y)); - case t_longfloat: - return ecl_make_long_float(ecl_long_float(x) / ecl_long_float(y)); - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[/], 2, y, @[number]); - } + case t_longfloat: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_long_float(ecl_long_float(x) / ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_long_float(ecl_long_float(x) / ecl_to_double(y)); + case t_singlefloat: + return ecl_make_long_float(ecl_long_float(x) / ecl_single_float(y)); + case t_doublefloat: + return ecl_make_long_float(ecl_long_float(x) / ecl_double_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_long_float(x) / ecl_long_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[/], 2, y, @[number]); + } #endif - case t_complex: - if (ecl_t_of(y) != t_complex) { - z1 = ecl_divide(x->complex.real, y); - z2 = ecl_divide(x->complex.imag, y); - return ecl_make_complex(z1, z2); - } else if (1) { - /* #C(z1 z2) = #C(xr xi) * #C(yr -yi) */ - z1 = ecl_plus(ecl_times(x->complex.real, y->complex.real), - ecl_times(x->complex.imag, y->complex.imag)); - z2 = ecl_minus(ecl_times(x->complex.imag, y->complex.real), - ecl_times(x->complex.real, y->complex.imag)); - } else { - COMPLEX: /* INV: x is real, y is complex */ - /* #C(z1 z2) = x * #C(yr -yi) */ - z1 = ecl_times(x, y->complex.real); - z2 = ecl_negate(ecl_times(x, y->complex.imag)); - } - z = ecl_plus(ecl_times(y->complex.real, y->complex.real), - ecl_times(y->complex.imag, y->complex.imag)); - z = ecl_make_complex(ecl_divide(z1, z), ecl_divide(z2, z)); - return(z); - default: - FEwrong_type_nth_arg(@[/], 1, x, @[number]); - } + case t_complex: + if (ecl_t_of(y) != t_complex) { + z1 = ecl_divide(x->complex.real, y); + z2 = ecl_divide(x->complex.imag, y); + return ecl_make_complex(z1, z2); + } else if (1) { + /* #C(z1 z2) = #C(xr xi) * #C(yr -yi) */ + z1 = ecl_plus(ecl_times(x->complex.real, y->complex.real), + ecl_times(x->complex.imag, y->complex.imag)); + z2 = ecl_minus(ecl_times(x->complex.imag, y->complex.real), + ecl_times(x->complex.real, y->complex.imag)); + } else { + COMPLEX: /* INV: x is real, y is complex */ + /* #C(z1 z2) = x * #C(yr -yi) */ + z1 = ecl_times(x, y->complex.real); + z2 = ecl_negate(ecl_times(x, y->complex.imag)); + } + z = ecl_plus(ecl_times(y->complex.real, y->complex.real), + ecl_times(y->complex.imag, y->complex.imag)); + z = ecl_make_complex(ecl_divide(z1, z), ecl_divide(z2, z)); + return(z); + default: + FEwrong_type_nth_arg(@[/], 1, x, @[number]); + } } #endif diff -Nru ecl-16.1.2/src/c/numbers/exp.d ecl-16.1.3+ds/src/c/numbers/exp.d --- ecl-16.1.2/src/c/numbers/exp.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/exp.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - sinh.d -- Trascendental functions: exponential -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * sinh.d - trascendental functions: exponential + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #define ECL_INCLUDE_MATH_H #include @@ -27,45 +22,45 @@ cl_object cl_exp(cl_object x) { - @(return ecl_exp(x)); + @(return ecl_exp(x)); } static cl_object ecl_exp_rational(cl_object x) { - return ecl_make_single_float(expf(ecl_to_float(x))); + return ecl_make_single_float(expf(ecl_to_float(x))); } static cl_object ecl_exp_single_float(cl_object x) { - return ecl_make_single_float(expf(ecl_single_float(x))); + return ecl_make_single_float(expf(ecl_single_float(x))); } static cl_object ecl_exp_double_float(cl_object x) { - return ecl_make_double_float(exp(ecl_double_float(x))); + return ecl_make_double_float(exp(ecl_double_float(x))); } #ifdef ECL_LONG_FLOAT static cl_object ecl_exp_long_float(cl_object x) { - return ecl_make_long_float(expl(ecl_long_float(x))); + return ecl_make_long_float(expl(ecl_long_float(x))); } #endif static cl_object ecl_exp_complex(cl_object x) { - cl_object y, y1; - y = x->complex.imag; - x = ecl_exp(x->complex.real); - y1 = ecl_cos(y); - y = ecl_sin(y); - y = ecl_make_complex(y1, y); - return ecl_times(x, y); + cl_object y, y1; + y = x->complex.imag; + x = ecl_exp(x->complex.real); + y1 = ecl_cos(y); + y = ecl_sin(y); + y = ecl_make_complex(y1, y); + return ecl_times(x, y); } MATH_DEF_DISPATCH1(exp, @[exp], @[number], diff -Nru ecl-16.1.2/src/c/numbers/expt.d ecl-16.1.3+ds/src/c/numbers/expt.d --- ecl-16.1.2/src/c/numbers/expt.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/expt.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - expt.d -- Exponentiate. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. + * expt.d - exponentiate + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - See file '../Copyright' for full details. -*/ #define ECL_INCLUDE_MATH_H #include @@ -31,22 +27,22 @@ cl_fixnum ecl_fixnum_expt(cl_fixnum x, cl_fixnum y) { - cl_fixnum z = 1; - while (y > 0) - if (y%2 == 0) { - x *= x; - y /= 2; - } else { - z *= x; - --y; - } - return(z); + cl_fixnum z = 1; + while (y > 0) + if (y%2 == 0) { + x *= x; + y /= 2; + } else { + z *= x; + --y; + } + return(z); } cl_object cl_expt(cl_object x, cl_object y) { - @(return ecl_expt(x, y)); + @(return ecl_expt(x, y)); } ecl_def_ct_single_float(singlefloat_one,1,static,const); @@ -58,79 +54,79 @@ static cl_object expt_zero(cl_object x, cl_object y) { - cl_type ty, tx; - cl_object z; - ty = ecl_t_of(y); - tx = ecl_t_of(x); - if (ecl_unlikely(!ECL_NUMBER_TYPE_P(tx))) { - FEwrong_type_nth_arg(@[expt], 1, x, @[number]); - } - /* INV: The most specific numeric types come first. */ - switch ((ty > tx)? ty : tx) { - case t_fixnum: - case t_bignum: - case t_ratio: - return ecl_make_fixnum(1); - case t_singlefloat: - return singlefloat_one; - case t_doublefloat: - return doublefloat_one; + cl_type ty, tx; + cl_object z; + ty = ecl_t_of(y); + tx = ecl_t_of(x); + if (ecl_unlikely(!ECL_NUMBER_TYPE_P(tx))) { + FEwrong_type_nth_arg(@[expt], 1, x, @[number]); + } + /* INV: The most specific numeric types come first. */ + switch ((ty > tx)? ty : tx) { + case t_fixnum: + case t_bignum: + case t_ratio: + return ecl_make_fixnum(1); + case t_singlefloat: + return singlefloat_one; + case t_doublefloat: + return doublefloat_one; #ifdef ECL_LONG_FLOAT - case t_longfloat: - return longfloat_one; + case t_longfloat: + return longfloat_one; #endif - case t_complex: - z = expt_zero((tx == t_complex)? x->complex.real : x, - (ty == t_complex)? y->complex.real : y); - return ecl_make_complex(z, ecl_make_fixnum(0)); - default: - /* We will never reach this */ - abort(); - } + case t_complex: + z = expt_zero((tx == t_complex)? x->complex.real : x, + (ty == t_complex)? y->complex.real : y); + return ecl_make_complex(z, ecl_make_fixnum(0)); + default: + /* We will never reach this */ + abort(); + } } cl_object ecl_expt(cl_object x, cl_object y) { - cl_type ty, tx; - cl_object z; - if (ecl_unlikely(ecl_zerop(y))) { - return expt_zero(x, y); - } - ty = ecl_t_of(y); - tx = ecl_t_of(x); - if (ecl_unlikely(!ECL_NUMBER_TYPE_P(tx))) { - FEwrong_type_nth_arg(@[expt], 1, x, @[number]); - } - if (ecl_zerop(x)) { - z = ecl_times(x, y); - if (!ecl_plusp(ty==t_complex?y->complex.real:y)) - z = ecl_divide(ecl_make_fixnum(1), z); - } else if (ty != t_fixnum && ty != t_bignum) { - /* The following could be just - z = ecl_log1(x); - however, Maxima expects EXPT to have double accuracy - when the first argument is integer and the second - is double-float */ - z = ecl_log1(ecl_times(x, expt_zero(x, y))); - z = ecl_times(z, y); - z = ecl_exp(z); - } else if (ecl_minusp(y)) { - z = ecl_negate(y); - z = ecl_expt(x, z); - z = ecl_divide(ecl_make_fixnum(1), z); - } else { - ECL_MATHERR_CLEAR; - z = ecl_make_fixnum(1); - do { - /* INV: ecl_integer_divide outputs an integer */ - if (!ecl_evenp(y)) - z = ecl_times(z, x); - y = ecl_integer_divide(y, ecl_make_fixnum(2)); - if (ecl_zerop(y)) break; - x = ecl_times(x, x); - } while (1); - ECL_MATHERR_TEST; - } - return z; + cl_type ty, tx; + cl_object z; + if (ecl_unlikely(ecl_zerop(y))) { + return expt_zero(x, y); + } + ty = ecl_t_of(y); + tx = ecl_t_of(x); + if (ecl_unlikely(!ECL_NUMBER_TYPE_P(tx))) { + FEwrong_type_nth_arg(@[expt], 1, x, @[number]); + } + if (ecl_zerop(x)) { + z = ecl_times(x, y); + if (!ecl_plusp(ty==t_complex?y->complex.real:y)) + z = ecl_divide(ecl_make_fixnum(1), z); + } else if (ty != t_fixnum && ty != t_bignum) { + /* The following could be just + z = ecl_log1(x); + however, Maxima expects EXPT to have double accuracy + when the first argument is integer and the second + is double-float */ + z = ecl_log1(ecl_times(x, expt_zero(x, y))); + z = ecl_times(z, y); + z = ecl_exp(z); + } else if (ecl_minusp(y)) { + z = ecl_negate(y); + z = ecl_expt(x, z); + z = ecl_divide(ecl_make_fixnum(1), z); + } else { + ECL_MATHERR_CLEAR; + z = ecl_make_fixnum(1); + do { + /* INV: ecl_integer_divide outputs an integer */ + if (!ecl_evenp(y)) + z = ecl_times(z, x); + y = ecl_integer_divide(y, ecl_make_fixnum(2)); + if (ecl_zerop(y)) break; + x = ecl_times(x, x); + } while (1); + ECL_MATHERR_TEST; + } + return z; } diff -Nru ecl-16.1.2/src/c/numbers/float_fix_compare.d ecl-16.1.3+ds/src/c/numbers/float_fix_compare.d --- ecl-16.1.2/src/c/numbers/float_fix_compare.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/float_fix_compare.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - num_comp.c -- Comparisons on numbers. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * ecnum_comp.c - comparisons on numbers + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ /* * In Common Lisp, comparisons between floats and integers are performed @@ -28,50 +23,50 @@ static int double_fix_compare(cl_fixnum n, double d) { - if ((double)n < d) { - return -1; - } else if ((double)n > d) { - return +1; - } else if (sizeof(double) > sizeof(cl_fixnum)) { - return 0; - } else { - /* When we reach here, the double type has no - * significant decimal part. However, as explained - * above, the double type is too small and integers - * may coerce to the same double number giving a false - * positive. Hence we perform the comparison in - * integer space. */ - cl_fixnum m = d; - if (n == m) { - return 0; - } else if (n > m) { - return +1; - } else { - return -1; - } - } + if ((double)n < d) { + return -1; + } else if ((double)n > d) { + return +1; + } else if (sizeof(double) > sizeof(cl_fixnum)) { + return 0; + } else { + /* When we reach here, the double type has no + * significant decimal part. However, as explained + * above, the double type is too small and integers + * may coerce to the same double number giving a false + * positive. Hence we perform the comparison in + * integer space. */ + cl_fixnum m = d; + if (n == m) { + return 0; + } else if (n > m) { + return +1; + } else { + return -1; + } + } } #ifdef ECL_LONG_FLOAT static int long_double_fix_compare(cl_fixnum n, long double d) { - if ((long double)n < d) { - return -1; - } else if ((long double)n > d) { - return +1; - } else if (sizeof(long double) > sizeof(cl_fixnum)) { - return 0; - } else { - cl_fixnum m = d; - if (n == m) { - return 0; - } else if (n > m) { - return +1; - } else { - return -1; - } - } + if ((long double)n < d) { + return -1; + } else if ((long double)n > d) { + return +1; + } else if (sizeof(long double) > sizeof(cl_fixnum)) { + return 0; + } else { + cl_fixnum m = d; + if (n == m) { + return 0; + } else if (n > m) { + return +1; + } else { + return -1; + } + } } #endif diff -Nru ecl-16.1.2/src/c/numbers/floor.d ecl-16.1.3+ds/src/c/numbers/floor.d --- ecl-16.1.2/src/c/numbers/floor.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/floor.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - floor.d -- Implementation of CL:FLOOR -*/ -/* - Copyright (c) 2010, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../../Copyright' for full details. -*/ + * ecfloor.d - implementation of CL:FLOOR + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #define ECL_INCLUDE_MATH_H #include @@ -25,233 +22,233 @@ #include @(defun floor (x &optional (y OBJNULL)) -@ - if (narg == 1) - return ecl_floor1(x); - else - return ecl_floor2(x, y); -@) + @ + if (narg == 1) + return ecl_floor1(x); + else + return ecl_floor2(x, y); + @) cl_object ecl_floor1(cl_object x) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object v0, v1; - switch (ecl_t_of(x)) { - case t_fixnum: - case t_bignum: - v0 = x; - v1 = ecl_make_fixnum(0); - break; - case t_ratio: - v0 = ecl_floor2(x->ratio.num, x->ratio.den); - v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), x->ratio.den); - break; - case t_singlefloat: { - float d = ecl_single_float(x); - float y = floorf(d); - v0 = _ecl_float_to_integer(y); - v1 = ecl_make_single_float(d - y); - break; - } - case t_doublefloat: { - double d = ecl_double_float(x); - double y = floor(d); - v0 = _ecl_double_to_integer(y); - v1 = ecl_make_double_float(d - y); - break; - } + const cl_env_ptr the_env = ecl_process_env(); + cl_object v0, v1; + switch (ecl_t_of(x)) { + case t_fixnum: + case t_bignum: + v0 = x; + v1 = ecl_make_fixnum(0); + break; + case t_ratio: + v0 = ecl_floor2(x->ratio.num, x->ratio.den); + v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), x->ratio.den); + break; + case t_singlefloat: { + float d = ecl_single_float(x); + float y = floorf(d); + v0 = _ecl_float_to_integer(y); + v1 = ecl_make_single_float(d - y); + break; + } + case t_doublefloat: { + double d = ecl_double_float(x); + double y = floor(d); + v0 = _ecl_double_to_integer(y); + v1 = ecl_make_double_float(d - y); + break; + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double d = ecl_long_float(x); - long double y = floorl(d); - v0 = _ecl_long_double_to_integer(y); - v1 = ecl_make_long_float(d - y); - break; - } -#endif - default: - FEwrong_type_nth_arg(@[floor],1,x,@[real]); - } - ecl_return2(the_env, v0, v1); + case t_longfloat: { + long double d = ecl_long_float(x); + long double y = floorl(d); + v0 = _ecl_long_double_to_integer(y); + v1 = ecl_make_long_float(d - y); + break; + } +#endif + default: + FEwrong_type_nth_arg(@[floor],1,x,@[real]); + } + ecl_return2(the_env, v0, v1); } cl_object ecl_floor2(cl_object x, cl_object y) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object v0, v1; -MATH_DISPATCH2_BEGIN(x,y) -{ - CASE_FIXNUM_FIXNUM { - cl_fixnum a = ecl_fixnum(x), b = ecl_fixnum(y); - cl_fixnum q = a / b, r = a % b; - if ((r^b) < 0 && r) { /* opposite sign and some remainder*/ - v0 = ecl_make_fixnum(q-1); - v1 = ecl_make_fixnum(r+b); - } else { - v0 = ecl_make_fixnum(q); - v1 = ecl_make_fixnum(r); - } - break; - } - CASE_FIXNUM_BIGNUM { - /* We must perform the division because there is the - * pathological case - * x = MOST_NEGATIVE_FIXNUM - * y = - MOST_NEGATIVE_FIXNUM - */ - ECL_WITH_TEMP_BIGNUM(bx,4); - _ecl_big_set_fixnum(bx, ecl_fixnum(x)); - v0 = _ecl_big_floor(bx, y, &v1); - break; - } - CASE_FIXNUM_RATIO { - v0 = ecl_floor2(ecl_times(x, y->ratio.den), y->ratio.num); - v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), y->ratio.den); - break; - } - CASE_FIXNUM_SINGLE_FLOAT { - float n = ecl_single_float(y); - float p = ecl_fixnum(x) / n; - float q = floorf(p); - v0 = _ecl_float_to_integer(q); - v1 = ecl_make_single_float((p - q)*n); - break; - } - CASE_FIXNUM_DOUBLE_FLOAT { - double n = ecl_double_float(y); - double p = ecl_fixnum(x) / n; - double q = floor(p); - v0 = _ecl_double_to_integer(q); - v1 = ecl_make_double_float((p - q)*n); - break; - } + const cl_env_ptr the_env = ecl_process_env(); + cl_object v0, v1; + MATH_DISPATCH2_BEGIN(x,y) + { + CASE_FIXNUM_FIXNUM { + cl_fixnum a = ecl_fixnum(x), b = ecl_fixnum(y); + cl_fixnum q = a / b, r = a % b; + if ((r^b) < 0 && r) { /* opposite sign and some remainder*/ + v0 = ecl_make_fixnum(q-1); + v1 = ecl_make_fixnum(r+b); + } else { + v0 = ecl_make_fixnum(q); + v1 = ecl_make_fixnum(r); + } + break; + } + CASE_FIXNUM_BIGNUM { + /* We must perform the division because there is the + * pathological case + * x = MOST_NEGATIVE_FIXNUM + * y = - MOST_NEGATIVE_FIXNUM + */ + ECL_WITH_TEMP_BIGNUM(bx,4); + _ecl_big_set_fixnum(bx, ecl_fixnum(x)); + v0 = _ecl_big_floor(bx, y, &v1); + break; + } + CASE_FIXNUM_RATIO { + v0 = ecl_floor2(ecl_times(x, y->ratio.den), y->ratio.num); + v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), y->ratio.den); + break; + } + CASE_FIXNUM_SINGLE_FLOAT { + float n = ecl_single_float(y); + float p = ecl_fixnum(x) / n; + float q = floorf(p); + v0 = _ecl_float_to_integer(q); + v1 = ecl_make_single_float((p - q)*n); + break; + } + CASE_FIXNUM_DOUBLE_FLOAT { + double n = ecl_double_float(y); + double p = ecl_fixnum(x) / n; + double q = floor(p); + v0 = _ecl_double_to_integer(q); + v1 = ecl_make_double_float((p - q)*n); + break; + } #ifdef ECL_LONG_FLOAT - CASE_FIXNUM_LONG_FLOAT { /* FIX / LF */ - long double n = ecl_long_float(y); - long double p = ecl_fixnum(x) / n; - long double q = floorl(p); - v0 = _ecl_long_double_to_integer(q); - v1 = ecl_make_long_float((p - q)*n); - break; - } -#endif - CASE_BIGNUM_FIXNUM { - ECL_WITH_TEMP_BIGNUM(by,4); - _ecl_big_set_fixnum(by, ecl_fixnum(y)); - v0 = _ecl_big_floor(x, by, &v1); - break; - } - CASE_BIGNUM_BIGNUM { - v0 = _ecl_big_floor(x, y, &v1); - break; - } - CASE_BIGNUM_RATIO { - v0 = ecl_floor2(ecl_times(x, y->ratio.den), y->ratio.num); - v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), y->ratio.den); - break; - } - CASE_BIGNUM_SINGLE_FLOAT { - float n = ecl_single_float(y); - float p = _ecl_big_to_double(x) / n; - float q = floorf(p); - v0 = _ecl_float_to_integer(q); - v1 = ecl_make_single_float((p - q)*n); - break; - } - CASE_BIGNUM_DOUBLE_FLOAT { - double n = ecl_double_float(y); - double p = _ecl_big_to_double(x) / n; - double q = floor(p); - v0 = _ecl_double_to_integer(q); - v1 = ecl_make_double_float((p - q)*n); - break; - } + CASE_FIXNUM_LONG_FLOAT { /* FIX / LF */ + long double n = ecl_long_float(y); + long double p = ecl_fixnum(x) / n; + long double q = floorl(p); + v0 = _ecl_long_double_to_integer(q); + v1 = ecl_make_long_float((p - q)*n); + break; + } +#endif + CASE_BIGNUM_FIXNUM { + ECL_WITH_TEMP_BIGNUM(by,4); + _ecl_big_set_fixnum(by, ecl_fixnum(y)); + v0 = _ecl_big_floor(x, by, &v1); + break; + } + CASE_BIGNUM_BIGNUM { + v0 = _ecl_big_floor(x, y, &v1); + break; + } + CASE_BIGNUM_RATIO { + v0 = ecl_floor2(ecl_times(x, y->ratio.den), y->ratio.num); + v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), y->ratio.den); + break; + } + CASE_BIGNUM_SINGLE_FLOAT { + float n = ecl_single_float(y); + float p = _ecl_big_to_double(x) / n; + float q = floorf(p); + v0 = _ecl_float_to_integer(q); + v1 = ecl_make_single_float((p - q)*n); + break; + } + CASE_BIGNUM_DOUBLE_FLOAT { + double n = ecl_double_float(y); + double p = _ecl_big_to_double(x) / n; + double q = floor(p); + v0 = _ecl_double_to_integer(q); + v1 = ecl_make_double_float((p - q)*n); + break; + } #ifdef ECL_LONG_FLOAT - CASE_BIGNUM_LONG_FLOAT { - long double n = ecl_long_float(y); - long double p = _ecl_big_to_double(x) / n; - long double q = floorl(p); - v0 = _ecl_long_double_to_integer(q); - v1 = ecl_make_long_float((p - q)*n); - break; - } -#endif - CASE_RATIO_RATIO { - v0 = ecl_floor2(ecl_times(x->ratio.num, y->ratio.den), - ecl_times(x->ratio.den, y->ratio.num)); - v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), ecl_times(x->ratio.den, y->ratio.den)); - break; - } - CASE_RATIO_FIXNUM; - CASE_RATIO_BIGNUM; - CASE_RATIO_SINGLE_FLOAT; + CASE_BIGNUM_LONG_FLOAT { + long double n = ecl_long_float(y); + long double p = _ecl_big_to_double(x) / n; + long double q = floorl(p); + v0 = _ecl_long_double_to_integer(q); + v1 = ecl_make_long_float((p - q)*n); + break; + } +#endif + CASE_RATIO_RATIO { + v0 = ecl_floor2(ecl_times(x->ratio.num, y->ratio.den), + ecl_times(x->ratio.den, y->ratio.num)); + v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), ecl_times(x->ratio.den, y->ratio.den)); + break; + } + CASE_RATIO_FIXNUM; + CASE_RATIO_BIGNUM; + CASE_RATIO_SINGLE_FLOAT; #ifdef ECL_LONG_FLOAT - CASE_RATIO_LONG_FLOAT; + CASE_RATIO_LONG_FLOAT; #endif - CASE_RATIO_DOUBLE_FLOAT { - v0 = ecl_floor2(x->ratio.num, ecl_times(x->ratio.den, y)); - v1 = ecl_divide(ecl_nth_value(the_env, 1), x->ratio.den); - break; - } - - CASE_SINGLE_FLOAT_FIXNUM; - CASE_SINGLE_FLOAT_BIGNUM; - CASE_SINGLE_FLOAT_RATIO; - CASE_SINGLE_FLOAT_DOUBLE_FLOAT; + CASE_RATIO_DOUBLE_FLOAT { + v0 = ecl_floor2(x->ratio.num, ecl_times(x->ratio.den, y)); + v1 = ecl_divide(ecl_nth_value(the_env, 1), x->ratio.den); + break; + } + + CASE_SINGLE_FLOAT_FIXNUM; + CASE_SINGLE_FLOAT_BIGNUM; + CASE_SINGLE_FLOAT_RATIO; + CASE_SINGLE_FLOAT_DOUBLE_FLOAT; #ifdef ECL_LONG_FLOAT - CASE_SINGLE_FLOAT_LONG_FLOAT; + CASE_SINGLE_FLOAT_LONG_FLOAT; #endif - CASE_SINGLE_FLOAT_SINGLE_FLOAT { - float n = ecl_to_double(y); - float p = ecl_single_float(x)/n; - float q = floorf(p); - v0 = _ecl_float_to_integer(q); - /* We cannot factor these two multiplications because - * if we have signed zeros (1 - 1) * (-1) = -0 while - * 1*(-1) - 1*(-1) = +0 */ - v1 = ecl_make_single_float(p*n - q*n); - break; - } - CASE_DOUBLE_FLOAT_FIXNUM; - CASE_DOUBLE_FLOAT_BIGNUM; - CASE_DOUBLE_FLOAT_RATIO; - CASE_DOUBLE_FLOAT_SINGLE_FLOAT; + CASE_SINGLE_FLOAT_SINGLE_FLOAT { + float n = ecl_to_double(y); + float p = ecl_single_float(x)/n; + float q = floorf(p); + v0 = _ecl_float_to_integer(q); + /* We cannot factor these two multiplications because + * if we have signed zeros (1 - 1) * (-1) = -0 while + * 1*(-1) - 1*(-1) = +0 */ + v1 = ecl_make_single_float(p*n - q*n); + break; + } + CASE_DOUBLE_FLOAT_FIXNUM; + CASE_DOUBLE_FLOAT_BIGNUM; + CASE_DOUBLE_FLOAT_RATIO; + CASE_DOUBLE_FLOAT_SINGLE_FLOAT; #ifdef ECL_LONG_FLOAT - CASE_DOUBLE_FLOAT_LONG_FLOAT; + CASE_DOUBLE_FLOAT_LONG_FLOAT; #endif - CASE_DOUBLE_FLOAT_DOUBLE_FLOAT { - double n = ecl_to_double(y); - double p = ecl_double_float(x)/n; - double q = floor(p); - v0 = _ecl_double_to_integer(q); - v1 = ecl_make_double_float(p*n - q*n); - break; - } + CASE_DOUBLE_FLOAT_DOUBLE_FLOAT { + double n = ecl_to_double(y); + double p = ecl_double_float(x)/n; + double q = floor(p); + v0 = _ecl_double_to_integer(q); + v1 = ecl_make_double_float(p*n - q*n); + break; + } #ifdef ECL_LONG_FLOAT - CASE_LONG_FLOAT_FIXNUM; - CASE_LONG_FLOAT_BIGNUM; - CASE_LONG_FLOAT_RATIO; - CASE_LONG_FLOAT_SINGLE_FLOAT; - CASE_LONG_FLOAT_DOUBLE_FLOAT; - CASE_LONG_FLOAT_LONG_FLOAT { - long double n = ecl_to_long_double(y); - long double p = ecl_long_float(x)/n; - long double q = floorl(p); - v0 = _ecl_long_double_to_integer(q); - v1 = ecl_make_long_float(p*n - q*n); - break; - } -#endif - default: DISPATCH2_ERROR: { - if (!ecl_realp(x)) - FEwrong_type_nth_arg(@[floor], 1, x, @[real]); - else - FEwrong_type_nth_arg(@[floor], 2, y, @[real]); - } -} -MATH_DISPATCH2_END; - ecl_return2(the_env, v0, v1); + CASE_LONG_FLOAT_FIXNUM; + CASE_LONG_FLOAT_BIGNUM; + CASE_LONG_FLOAT_RATIO; + CASE_LONG_FLOAT_SINGLE_FLOAT; + CASE_LONG_FLOAT_DOUBLE_FLOAT; + CASE_LONG_FLOAT_LONG_FLOAT { + long double n = ecl_to_long_double(y); + long double p = ecl_long_float(x)/n; + long double q = floorl(p); + v0 = _ecl_long_double_to_integer(q); + v1 = ecl_make_long_float(p*n - q*n); + break; + } +#endif + default: DISPATCH2_ERROR: { + if (!ecl_realp(x)) + FEwrong_type_nth_arg(@[floor], 1, x, @[real]); + else + FEwrong_type_nth_arg(@[floor], 2, y, @[real]); + } + } + MATH_DISPATCH2_END; + ecl_return2(the_env, v0, v1); } diff -Nru ecl-16.1.2/src/c/numbers/log.d ecl-16.1.3+ds/src/c/numbers/log.d --- ecl-16.1.2/src/c/numbers/log.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/log.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - log1.d -- Trascendental functions: log(x) -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. + * eclog1.d - trascendental functions: log(x) + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - See file '../Copyright' for full details. -*/ #define ECL_INCLUDE_MATH_H #include @@ -27,85 +23,85 @@ static cl_object ecl_log1_complex_inner(cl_object r, cl_object i) { - cl_object a = ecl_abs(r); - cl_object p = ecl_abs(i); - int rel = ecl_number_compare(a, p); - if (rel > 0) { - cl_object aux = p; - p = a; a = aux; - } else if (rel == 0) { - /* if a == p, - * log(sqrt(a^2+p^2)) = log(2a^2)/2 - */ - a = ecl_times(a, a); - a = ecl_divide(ecl_log1(ecl_plus(a, a)), ecl_make_fixnum(2)); - goto OUTPUT; - } - /* For the real part of the output we use the formula - * log(sqrt(p^2 + a^2)) = log(sqrt(p^2*(1 + (a/p)^2))) - * = log(p) + log(1 + (a/p)^2)/2; */ - a = ecl_divide(a, p); - a = ecl_plus(ecl_divide(ecl_log1p(ecl_times(a,a)), ecl_make_fixnum(2)), - ecl_log1(p)); + cl_object a = ecl_abs(r); + cl_object p = ecl_abs(i); + int rel = ecl_number_compare(a, p); + if (rel > 0) { + cl_object aux = p; + p = a; a = aux; + } else if (rel == 0) { + /* if a == p, + * log(sqrt(a^2+p^2)) = log(2a^2)/2 + */ + a = ecl_times(a, a); + a = ecl_divide(ecl_log1(ecl_plus(a, a)), ecl_make_fixnum(2)); + goto OUTPUT; + } + /* For the real part of the output we use the formula + * log(sqrt(p^2 + a^2)) = log(sqrt(p^2*(1 + (a/p)^2))) + * = log(p) + log(1 + (a/p)^2)/2; */ + a = ecl_divide(a, p); + a = ecl_plus(ecl_divide(ecl_log1p(ecl_times(a,a)), ecl_make_fixnum(2)), + ecl_log1(p)); OUTPUT: - p = ecl_atan2(i, r); - return ecl_make_complex(a, p); + p = ecl_atan2(i, r); + return ecl_make_complex(a, p); } static cl_object ecl_log1_bignum(cl_object x) { - if (ecl_minusp(x)) { - return ecl_log1_complex_inner(x, ecl_make_fixnum(0)); - } else { - cl_fixnum l = ecl_integer_length(x) - 1; - cl_object r = ecl_make_ratio(x, ecl_ash(ecl_make_fixnum(1), l)); - float d = logf(ecl_to_float(r)) + l * logf(2.0); - return ecl_make_single_float(d); - } + if (ecl_minusp(x)) { + return ecl_log1_complex_inner(x, ecl_make_fixnum(0)); + } else { + cl_fixnum l = ecl_integer_length(x) - 1; + cl_object r = ecl_make_ratio(x, ecl_ash(ecl_make_fixnum(1), l)); + float d = logf(ecl_to_float(r)) + l * logf(2.0); + return ecl_make_single_float(d); + } } static cl_object ecl_log1_rational(cl_object x) { - float f = ecl_to_float(x); - if (f < 0) return ecl_log1_complex_inner(x, ecl_make_fixnum(0)); - return ecl_make_single_float(logf(ecl_to_float(x))); + float f = ecl_to_float(x); + if (f < 0) return ecl_log1_complex_inner(x, ecl_make_fixnum(0)); + return ecl_make_single_float(logf(ecl_to_float(x))); } static cl_object ecl_log1_single_float(cl_object x) { - float f = ecl_single_float(x); - if (isnan(f)) return x; - if (f < 0) return ecl_log1_complex_inner(x, ecl_make_fixnum(0)); - return ecl_make_single_float(logf(f)); + float f = ecl_single_float(x); + if (isnan(f)) return x; + if (f < 0) return ecl_log1_complex_inner(x, ecl_make_fixnum(0)); + return ecl_make_single_float(logf(f)); } static cl_object ecl_log1_double_float(cl_object x) { - double f = ecl_double_float(x); - if (isnan(f)) return x; - if (f < 0) return ecl_log1_complex_inner(x, ecl_make_fixnum(0)); - return ecl_make_double_float(log(f)); + double f = ecl_double_float(x); + if (isnan(f)) return x; + if (f < 0) return ecl_log1_complex_inner(x, ecl_make_fixnum(0)); + return ecl_make_double_float(log(f)); } #ifdef ECL_LONG_FLOAT static cl_object ecl_log1_long_float(cl_object x) { - long double f = ecl_long_float(x); - if (isnan(f)) return x; - if (f < 0) return ecl_log1_complex_inner(x, ecl_make_fixnum(0)); - return ecl_make_long_float(logl(f)); + long double f = ecl_long_float(x); + if (isnan(f)) return x; + if (f < 0) return ecl_log1_complex_inner(x, ecl_make_fixnum(0)); + return ecl_make_long_float(logl(f)); } #endif static cl_object ecl_log1_complex(cl_object x) { - return ecl_log1_complex_inner(x->complex.real, x->complex.imag); + return ecl_log1_complex_inner(x->complex.real, x->complex.imag); } MATH_DEF_DISPATCH1(log1, @[log], @[number], @@ -116,27 +112,28 @@ cl_object ecl_log2(cl_object x, cl_object y) { - return ecl_divide(ecl_log1(y), ecl_log1(x)); + return ecl_divide(ecl_log1(y), ecl_log1(x)); } @(defun log (x &optional (y OBJNULL)) -@ /* INV: type check in ecl_log1() and ecl_log2() */ - if (y == OBJNULL) - @(return ecl_log1(x)) - @(return ecl_log2(y, x)) -@) + @ /* INV: type check in ecl_log1() and ecl_log2() */ + if (y == OBJNULL) { + @(return ecl_log1(x)); + } + @(return ecl_log2(y, x)) + @) #ifndef HAVE_LOG1P double log1p(double x) { - double u = 1.0 + x; - if (u == 1) { - return 0.0; - } else { - return (log(u) * x)/(u - 1.0); - } + double u = 1.0 + x; + if (u == 1) { + return 0.0; + } else { + return (log(u) * x)/(u - 1.0); + } } #endif @@ -144,12 +141,12 @@ float log1pf(float x) { - float u = (float)1 + x; - if (u == 1) { - return (float)0; - } else { - return (logf(u) * x)/(u - (float)1); - } + float u = (float)1 + x; + if (u == 1) { + return (float)0; + } else { + return (logf(u) * x)/(u - (float)1); + } } #endif @@ -157,68 +154,68 @@ long double log1pl(long double x) { - long double u = (long double)1 + x; - if (u == 1) { - return (long double)1; - } else { - return (logl(u) * x)/(u - (long double)1); - } + long double u = (long double)1 + x; + if (u == 1) { + return (long double)1; + } else { + return (logl(u) * x)/(u - (long double)1); + } } #endif cl_object si_log1p(cl_object x) { - @(return ecl_log1p(x)); + @(return ecl_log1p(x)); } static cl_object ecl_log1p_simple(cl_object x) { - return ecl_log1_complex_inner(ecl_one_plus(x), ecl_make_fixnum(0)); + return ecl_log1_complex_inner(ecl_one_plus(x), ecl_make_fixnum(0)); } static cl_object ecl_log1p_rational(cl_object x) { - float f = ecl_to_float(x); - if (f < -1) return ecl_log1p_simple(x); - return ecl_make_single_float(log1pf(ecl_to_float(x))); + float f = ecl_to_float(x); + if (f < -1) return ecl_log1p_simple(x); + return ecl_make_single_float(log1pf(ecl_to_float(x))); } static cl_object ecl_log1p_single_float(cl_object x) { - float f = ecl_single_float(x); - if (isnan(f)) return x; - if (f < -1) return ecl_log1p_simple(x); - return ecl_make_single_float(log1pf(f)); + float f = ecl_single_float(x); + if (isnan(f)) return x; + if (f < -1) return ecl_log1p_simple(x); + return ecl_make_single_float(log1pf(f)); } static cl_object ecl_log1p_double_float(cl_object x) { - double f = ecl_double_float(x); - if (isnan(f)) return x; - if (f < -1) return ecl_log1p_simple(x); - return ecl_make_double_float(log1p(f)); + double f = ecl_double_float(x); + if (isnan(f)) return x; + if (f < -1) return ecl_log1p_simple(x); + return ecl_make_double_float(log1p(f)); } #ifdef ECL_LONG_FLOAT static cl_object ecl_log1p_long_float(cl_object x) { - long double f = ecl_long_float(x); - if (isnan(f)) return x; - if (f < -1) return ecl_log1p_simple(x); - return ecl_make_long_float(log1pl(f)); + long double f = ecl_long_float(x); + if (isnan(f)) return x; + if (f < -1) return ecl_log1p_simple(x); + return ecl_make_long_float(log1pl(f)); } #endif static cl_object ecl_log1p_complex(cl_object x) { - return ecl_log1_complex_inner(ecl_one_plus(x->complex.real), x->complex.imag); + return ecl_log1_complex_inner(ecl_one_plus(x->complex.real), x->complex.imag); } MATH_DEF_DISPATCH1(log1p, @[si::log1p], @[number], diff -Nru ecl-16.1.2/src/c/numbers/minmax.d ecl-16.1.3+ds/src/c/numbers/minmax.d --- ecl-16.1.2/src/c/numbers/minmax.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/minmax.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,48 +1,43 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - minmax.c -- number sorting. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * minmax.c - number sorting + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include @(defun max (max &rest nums) -@ - /* INV: type check occurs in ecl_number_compare() for the rest of - numbers, but for the first argument it happens in ecl_zerop(). */ - if (narg-- == 1) { - ecl_zerop(max); - } else do { - cl_object numi = ecl_va_arg(nums); - if (ecl_number_compare(max, numi) < 0) - max = numi; - } while (--narg); - @(return max) -@) + @ + /* INV: type check occurs in ecl_number_compare() for the rest of + numbers, but for the first argument it happens in ecl_zerop(). */ + if (narg-- == 1) { + ecl_zerop(max); + } else do { + cl_object numi = ecl_va_arg(nums); + if (ecl_number_compare(max, numi) < 0) + max = numi; + } while (--narg); + @(return max); + @) @(defun min (min &rest nums) -@ - /* INV: type check occurs in ecl_number_compare() for the rest of - numbers, but for the first argument it happens in ecl_zerop(). */ - if (narg-- == 1) { - ecl_zerop(min); - } else do { - cl_object numi = ecl_va_arg(nums); - if (ecl_number_compare(min, numi) > 0) - min = numi; - } while (--narg); - @(return min) -@) + @ + /* INV: type check occurs in ecl_number_compare() for the rest of + numbers, but for the first argument it happens in ecl_zerop(). */ + if (narg-- == 1) { + ecl_zerop(min); + } else do { + cl_object numi = ecl_va_arg(nums); + if (ecl_number_compare(min, numi) > 0) + min = numi; + } while (--narg); + @(return min); + @) diff -Nru ecl-16.1.2/src/c/numbers/minus.d ecl-16.1.3+ds/src/c/numbers/minus.d --- ecl-16.1.2/src/c/numbers/minus.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/minus.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,177 +1,176 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - minus.d -- Implementation of CL:- -*/ -/* - Copyright (c) 2010, Juan Jose Garcia Ripoll. - - ECL 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. + * ecminus.d - implementation of CL:- + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - See file '../../Copyright' for full details. -*/ #include #include @(defun - (num &rest nums) - cl_object diff; -@ - /* INV: argument type check in number_{negate,minus}() */ - if (narg == 1) - @(return ecl_negate(num)) - for (diff = num; --narg; ) - diff = ecl_minus(diff, ecl_va_arg(nums)); - @(return diff) -@) + cl_object diff; + @ + /* INV: argument type check in number_{negate,minus}() */ + if (narg == 1) { + @(return ecl_negate(num)); + } + for (diff = num; --narg; ) + diff = ecl_minus(diff, ecl_va_arg(nums)); + @(return diff); + @) #ifdef MATH_DISPATCH2_BEGIN cl_object ecl_minus(cl_object x, cl_object y) { -MATH_DISPATCH2_BEGIN(x,y) -{ - CASE_FIXNUM_FIXNUM { - return ecl_make_integer(ecl_fixnum(x) - ecl_fixnum(y)); - } - CASE_FIXNUM_BIGNUM { - return _ecl_fix_minus_big(ecl_fixnum(x), y); - } - CASE_FIXNUM_RATIO; - CASE_BIGNUM_RATIO { - cl_object z = ecl_times(x, y->ratio.den); - z = ecl_minus(z, y->ratio.num); - return ecl_make_ratio(z, y->ratio.den); - } - CASE_FIXNUM_SINGLE_FLOAT { - return ecl_make_single_float(ecl_fixnum(x) - ecl_single_float(y)); - } - CASE_FIXNUM_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_fixnum(x) - ecl_double_float(y)); - } - CASE_BIGNUM_FIXNUM { - return _ecl_big_plus_fix(x, -ecl_fixnum(y)); - } - CASE_BIGNUM_BIGNUM { - return _ecl_big_minus_big(x, y); - } - CASE_BIGNUM_SINGLE_FLOAT; - CASE_RATIO_SINGLE_FLOAT { - return ecl_make_single_float(ecl_to_float(x) - ecl_single_float(y)); - } - CASE_BIGNUM_DOUBLE_FLOAT; - CASE_RATIO_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_to_double(x) - ecl_double_float(y)); - } - CASE_RATIO_FIXNUM; - CASE_RATIO_BIGNUM { - cl_object z = ecl_times(x->ratio.den, y); - z = ecl_minus(x->ratio.num, z); - return ecl_make_ratio(z, x->ratio.den); - } - CASE_RATIO_RATIO { - cl_object z1 = ecl_times(x->ratio.num,y->ratio.den); - cl_object z = ecl_times(x->ratio.den,y->ratio.num); - z = ecl_minus(z1, z); - z1 = ecl_times(x->ratio.den,y->ratio.den); - return ecl_make_ratio(z, z1); - } - CASE_SINGLE_FLOAT_FIXNUM { - return ecl_make_single_float(ecl_single_float(x) - ecl_fixnum(y)); - } - CASE_SINGLE_FLOAT_BIGNUM; - CASE_SINGLE_FLOAT_RATIO { - return ecl_make_single_float(ecl_single_float(x) - ecl_to_float(y)); - } - CASE_SINGLE_FLOAT_SINGLE_FLOAT { - return ecl_make_single_float(ecl_single_float(x) - ecl_single_float(y)); - } - CASE_SINGLE_FLOAT_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_single_float(x) - ecl_double_float(y)); - } - CASE_DOUBLE_FLOAT_FIXNUM { - return ecl_make_double_float(ecl_double_float(x) - ecl_fixnum(y)); - } - CASE_DOUBLE_FLOAT_BIGNUM; - CASE_DOUBLE_FLOAT_RATIO { - return ecl_make_double_float(ecl_double_float(x) - ecl_to_double(y)); - } - CASE_DOUBLE_FLOAT_SINGLE_FLOAT { - return ecl_make_double_float(ecl_double_float(x) - ecl_single_float(y)); - } - CASE_DOUBLE_FLOAT_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_double_float(x) - ecl_double_float(y)); - } + MATH_DISPATCH2_BEGIN(x,y) + { + CASE_FIXNUM_FIXNUM { + return ecl_make_integer(ecl_fixnum(x) - ecl_fixnum(y)); + } + CASE_FIXNUM_BIGNUM { + return _ecl_fix_minus_big(ecl_fixnum(x), y); + } + CASE_FIXNUM_RATIO; + CASE_BIGNUM_RATIO { + cl_object z = ecl_times(x, y->ratio.den); + z = ecl_minus(z, y->ratio.num); + return ecl_make_ratio(z, y->ratio.den); + } + CASE_FIXNUM_SINGLE_FLOAT { + return ecl_make_single_float(ecl_fixnum(x) - ecl_single_float(y)); + } + CASE_FIXNUM_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_fixnum(x) - ecl_double_float(y)); + } + CASE_BIGNUM_FIXNUM { + return _ecl_big_plus_fix(x, -ecl_fixnum(y)); + } + CASE_BIGNUM_BIGNUM { + return _ecl_big_minus_big(x, y); + } + CASE_BIGNUM_SINGLE_FLOAT; + CASE_RATIO_SINGLE_FLOAT { + return ecl_make_single_float(ecl_to_float(x) - ecl_single_float(y)); + } + CASE_BIGNUM_DOUBLE_FLOAT; + CASE_RATIO_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_to_double(x) - ecl_double_float(y)); + } + CASE_RATIO_FIXNUM; + CASE_RATIO_BIGNUM { + cl_object z = ecl_times(x->ratio.den, y); + z = ecl_minus(x->ratio.num, z); + return ecl_make_ratio(z, x->ratio.den); + } + CASE_RATIO_RATIO { + cl_object z1 = ecl_times(x->ratio.num,y->ratio.den); + cl_object z = ecl_times(x->ratio.den,y->ratio.num); + z = ecl_minus(z1, z); + z1 = ecl_times(x->ratio.den,y->ratio.den); + return ecl_make_ratio(z, z1); + } + CASE_SINGLE_FLOAT_FIXNUM { + return ecl_make_single_float(ecl_single_float(x) - ecl_fixnum(y)); + } + CASE_SINGLE_FLOAT_BIGNUM; + CASE_SINGLE_FLOAT_RATIO { + return ecl_make_single_float(ecl_single_float(x) - ecl_to_float(y)); + } + CASE_SINGLE_FLOAT_SINGLE_FLOAT { + return ecl_make_single_float(ecl_single_float(x) - ecl_single_float(y)); + } + CASE_SINGLE_FLOAT_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_single_float(x) - ecl_double_float(y)); + } + CASE_DOUBLE_FLOAT_FIXNUM { + return ecl_make_double_float(ecl_double_float(x) - ecl_fixnum(y)); + } + CASE_DOUBLE_FLOAT_BIGNUM; + CASE_DOUBLE_FLOAT_RATIO { + return ecl_make_double_float(ecl_double_float(x) - ecl_to_double(y)); + } + CASE_DOUBLE_FLOAT_SINGLE_FLOAT { + return ecl_make_double_float(ecl_double_float(x) - ecl_single_float(y)); + } + CASE_DOUBLE_FLOAT_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_double_float(x) - ecl_double_float(y)); + } #ifdef ECL_LONG_FLOAT - CASE_FIXNUM_LONG_FLOAT { - return ecl_make_long_float(ecl_fixnum(x) - ecl_long_float(y)); - } - CASE_BIGNUM_LONG_FLOAT { - return ecl_make_long_float(ecl_to_long_double(x) - ecl_long_float(y)); - } - CASE_RATIO_LONG_FLOAT { - return ecl_make_long_float(ecl_to_long_double(x) - ecl_long_float(y)); - } - CASE_SINGLE_FLOAT_LONG_FLOAT { - return ecl_make_long_float(ecl_single_float(x) - ecl_long_float(y)); - } - CASE_DOUBLE_FLOAT_LONG_FLOAT { - return ecl_make_long_float(ecl_double_float(x) - ecl_long_float(y)); - } - CASE_LONG_FLOAT_FIXNUM { - return ecl_make_long_float(ecl_long_float(x) - ecl_fixnum(y)); - } - CASE_LONG_FLOAT_BIGNUM; - CASE_LONG_FLOAT_RATIO { - return ecl_make_long_float(ecl_long_float(x) - ecl_to_long_double(y)); - } - CASE_LONG_FLOAT_SINGLE_FLOAT { - return ecl_make_long_float(ecl_long_float(x) - ecl_single_float(y)); - } - CASE_LONG_FLOAT_DOUBLE_FLOAT { - return ecl_make_long_float(ecl_long_float(x) - ecl_double_float(y)); - } - CASE_LONG_FLOAT_LONG_FLOAT { - return ecl_make_long_float(ecl_long_float(x) - ecl_long_float(y)); - } - CASE_LONG_FLOAT_COMPLEX { - goto COMPLEX_Y; - } - CASE_COMPLEX_LONG_FLOAT; { - goto COMPLEX_X; - } + CASE_FIXNUM_LONG_FLOAT { + return ecl_make_long_float(ecl_fixnum(x) - ecl_long_float(y)); + } + CASE_BIGNUM_LONG_FLOAT { + return ecl_make_long_float(ecl_to_long_double(x) - ecl_long_float(y)); + } + CASE_RATIO_LONG_FLOAT { + return ecl_make_long_float(ecl_to_long_double(x) - ecl_long_float(y)); + } + CASE_SINGLE_FLOAT_LONG_FLOAT { + return ecl_make_long_float(ecl_single_float(x) - ecl_long_float(y)); + } + CASE_DOUBLE_FLOAT_LONG_FLOAT { + return ecl_make_long_float(ecl_double_float(x) - ecl_long_float(y)); + } + CASE_LONG_FLOAT_FIXNUM { + return ecl_make_long_float(ecl_long_float(x) - ecl_fixnum(y)); + } + CASE_LONG_FLOAT_BIGNUM; + CASE_LONG_FLOAT_RATIO { + return ecl_make_long_float(ecl_long_float(x) - ecl_to_long_double(y)); + } + CASE_LONG_FLOAT_SINGLE_FLOAT { + return ecl_make_long_float(ecl_long_float(x) - ecl_single_float(y)); + } + CASE_LONG_FLOAT_DOUBLE_FLOAT { + return ecl_make_long_float(ecl_long_float(x) - ecl_double_float(y)); + } + CASE_LONG_FLOAT_LONG_FLOAT { + return ecl_make_long_float(ecl_long_float(x) - ecl_long_float(y)); + } + CASE_LONG_FLOAT_COMPLEX { + goto COMPLEX_Y; + } + CASE_COMPLEX_LONG_FLOAT; { + goto COMPLEX_X; + } #endif - CASE_COMPLEX_FIXNUM; - CASE_COMPLEX_BIGNUM; - CASE_COMPLEX_RATIO; - CASE_COMPLEX_SINGLE_FLOAT; - CASE_COMPLEX_DOUBLE_FLOAT { - COMPLEX_X: - return ecl_make_complex(ecl_minus(x->complex.real, y), - x->complex.imag); - } - CASE_BIGNUM_COMPLEX; - CASE_RATIO_COMPLEX; - CASE_SINGLE_FLOAT_COMPLEX; - CASE_DOUBLE_FLOAT_COMPLEX; - CASE_FIXNUM_COMPLEX { - COMPLEX_Y: - return ecl_make_complex(ecl_minus(x, y->complex.real), - ecl_negate(y->complex.imag)); - } - CASE_COMPLEX_COMPLEX { - cl_object z = ecl_minus(x->complex.real, y->complex.real); - cl_object z1 = ecl_minus(x->complex.imag, y->complex.imag); - return ecl_make_complex(z, z1); - } - CASE_UNKNOWN(@[-],x,y,@[number]); -} -MATH_DISPATCH2_END; + CASE_COMPLEX_FIXNUM; + CASE_COMPLEX_BIGNUM; + CASE_COMPLEX_RATIO; + CASE_COMPLEX_SINGLE_FLOAT; + CASE_COMPLEX_DOUBLE_FLOAT { + COMPLEX_X: + return ecl_make_complex(ecl_minus(x->complex.real, y), + x->complex.imag); + } + CASE_BIGNUM_COMPLEX; + CASE_RATIO_COMPLEX; + CASE_SINGLE_FLOAT_COMPLEX; + CASE_DOUBLE_FLOAT_COMPLEX; + CASE_FIXNUM_COMPLEX { + COMPLEX_Y: + return ecl_make_complex(ecl_minus(x, y->complex.real), + ecl_negate(y->complex.imag)); + } + CASE_COMPLEX_COMPLEX { + cl_object z = ecl_minus(x->complex.real, y->complex.real); + cl_object z1 = ecl_minus(x->complex.imag, y->complex.imag); + return ecl_make_complex(z, z1); + } + CASE_UNKNOWN(@[-],x,y,@[number]); + } + MATH_DISPATCH2_END; } #else @@ -179,157 +178,157 @@ cl_object ecl_minus(cl_object x, cl_object y) { - cl_fixnum i, j, k; - cl_object z, z1; + cl_fixnum i, j, k; + cl_object z, z1; - switch (ecl_t_of(x)) { - case t_fixnum: - switch(ecl_t_of(y)) { - case t_fixnum: - return ecl_make_integer(ecl_fixnum(x) - ecl_fixnum(y)); - case t_bignum: - return _ecl_fix_minus_big(ecl_fixnum(x), y); - case t_ratio: - z = ecl_times(x, y->ratio.den); - z = ecl_minus(z, y->ratio.num); - return ecl_make_ratio(z, y->ratio.den); - case t_singlefloat: - return ecl_make_single_float(ecl_fixnum(x) - ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_fixnum(x) - ecl_double_float(y)); + switch (ecl_t_of(x)) { + case t_fixnum: + switch(ecl_t_of(y)) { + case t_fixnum: + return ecl_make_integer(ecl_fixnum(x) - ecl_fixnum(y)); + case t_bignum: + return _ecl_fix_minus_big(ecl_fixnum(x), y); + case t_ratio: + z = ecl_times(x, y->ratio.den); + z = ecl_minus(z, y->ratio.num); + return ecl_make_ratio(z, y->ratio.den); + case t_singlefloat: + return ecl_make_single_float(ecl_fixnum(x) - ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_fixnum(x) - ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_fixnum(x) - ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_fixnum(x) - ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[-], 2, y, @[number]); - } - case t_bignum: - switch (ecl_t_of(y)) { - case t_fixnum: - return _ecl_big_plus_fix(x, -ecl_fixnum(y)); - case t_bignum: - return _ecl_big_minus_big(x, y); - case t_ratio: - z = ecl_times(x, y->ratio.den); - z = ecl_minus(z, y->ratio.num); - return ecl_make_ratio(z, y->ratio.den); - case t_singlefloat: - return ecl_make_single_float(ecl_to_double(x) - ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_to_double(x) - ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[-], 2, y, @[number]); + } + case t_bignum: + switch (ecl_t_of(y)) { + case t_fixnum: + return _ecl_big_plus_fix(x, -ecl_fixnum(y)); + case t_bignum: + return _ecl_big_minus_big(x, y); + case t_ratio: + z = ecl_times(x, y->ratio.den); + z = ecl_minus(z, y->ratio.num); + return ecl_make_ratio(z, y->ratio.den); + case t_singlefloat: + return ecl_make_single_float(ecl_to_double(x) - ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_to_double(x) - ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_to_double(x) - ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_to_double(x) - ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[-], 2, y, @[number]); - } - case t_ratio: - switch (ecl_t_of(y)) { - case t_fixnum: - case t_bignum: - z = ecl_times(x->ratio.den, y); - z = ecl_minus(x->ratio.num, z); - return ecl_make_ratio(z, x->ratio.den); - case t_ratio: - z = ecl_times(x->ratio.num,y->ratio.den); - z1 = ecl_times(x->ratio.den,y->ratio.num); - z = ecl_minus(z, z1); - z1 = ecl_times(x->ratio.den,y->ratio.den); - return ecl_make_ratio(z, z1); - case t_singlefloat: - return ecl_make_single_float(ecl_to_double(x) - ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_to_double(x) - ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[-], 2, y, @[number]); + } + case t_ratio: + switch (ecl_t_of(y)) { + case t_fixnum: + case t_bignum: + z = ecl_times(x->ratio.den, y); + z = ecl_minus(x->ratio.num, z); + return ecl_make_ratio(z, x->ratio.den); + case t_ratio: + z = ecl_times(x->ratio.num,y->ratio.den); + z1 = ecl_times(x->ratio.den,y->ratio.num); + z = ecl_minus(z, z1); + z1 = ecl_times(x->ratio.den,y->ratio.den); + return ecl_make_ratio(z, z1); + case t_singlefloat: + return ecl_make_single_float(ecl_to_double(x) - ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_to_double(x) - ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_to_double(x) - ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_to_double(x) - ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[-], 2, y, @[number]); - } - case t_singlefloat: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_single_float(ecl_single_float(x) - ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_single_float(ecl_single_float(x) - ecl_to_double(y)); - case t_singlefloat: - return ecl_make_single_float(ecl_single_float(x) - ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_single_float(x) - ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[-], 2, y, @[number]); + } + case t_singlefloat: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_single_float(ecl_single_float(x) - ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_single_float(ecl_single_float(x) - ecl_to_double(y)); + case t_singlefloat: + return ecl_make_single_float(ecl_single_float(x) - ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_single_float(x) - ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_single_float(x) - ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_single_float(x) - ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[-], 2, y, @[number]); - } - case t_doublefloat: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_double_float(ecl_double_float(x) - ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_double_float(ecl_double_float(x) - ecl_to_double(y)); - case t_singlefloat: - return ecl_make_double_float(ecl_double_float(x) - ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_double_float(x) - ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[-], 2, y, @[number]); + } + case t_doublefloat: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_double_float(ecl_double_float(x) - ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_double_float(ecl_double_float(x) - ecl_to_double(y)); + case t_singlefloat: + return ecl_make_double_float(ecl_double_float(x) - ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_double_float(x) - ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_double_float(x) - ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_double_float(x) - ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[-], 2, y, @[number]); - } + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[-], 2, y, @[number]); + } #ifdef ECL_LONG_FLOAT - case t_longfloat: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_long_float(ecl_long_float(x) - fix(y)); - case t_bignum: - case t_ratio: - return ecl_make_long_float(ecl_long_float(x) - ecl_to_double(y)); - case t_singlefloat: - return ecl_make_long_float(ecl_long_float(x) - ecl_single_float(y)); - case t_doublefloat: - return ecl_make_long_float(ecl_long_float(x) - ecl_double_float(y)); - case t_longfloat: - return ecl_make_long_float(ecl_long_float(x) - ecl_long_float(y)); - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[-], 2, y, @[number]); - } + case t_longfloat: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_long_float(ecl_long_float(x) - fix(y)); + case t_bignum: + case t_ratio: + return ecl_make_long_float(ecl_long_float(x) - ecl_to_double(y)); + case t_singlefloat: + return ecl_make_long_float(ecl_long_float(x) - ecl_single_float(y)); + case t_doublefloat: + return ecl_make_long_float(ecl_long_float(x) - ecl_double_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_long_float(x) - ecl_long_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[-], 2, y, @[number]); + } #endif - COMPLEX: - return ecl_make_complex(ecl_minus(x, y->complex.real), - ecl_negate(y->complex.imag)); - case t_complex: - if (ecl_t_of(y) != t_complex) { - z = ecl_minus(x->complex.real, y); - z1 = x->complex.imag; - } else { - z = ecl_minus(x->complex.real, y->complex.real); - z1 = ecl_minus(x->complex.imag, y->complex.imag); - } - return ecl_make_complex(z, z1); - default: - FEwrong_type_nth_arg(@[-], 1, x, @[number]); - } + COMPLEX: + return ecl_make_complex(ecl_minus(x, y->complex.real), + ecl_negate(y->complex.imag)); + case t_complex: + if (ecl_t_of(y) != t_complex) { + z = ecl_minus(x->complex.real, y); + z1 = x->complex.imag; + } else { + z = ecl_minus(x->complex.real, y->complex.real); + z1 = ecl_minus(x->complex.imag, y->complex.imag); + } + return ecl_make_complex(z, z1); + default: + FEwrong_type_nth_arg(@[-], 1, x, @[number]); + } } #endif diff -Nru ecl-16.1.2/src/c/numbers/minusp.d ecl-16.1.3+ds/src/c/numbers/minusp.d --- ecl-16.1.2/src/c/numbers/minusp.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/minusp.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,65 +1,60 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - minusp.d -- Implementation of CL:MINUSP -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * minusp.d - implementation of CL:MINUSP + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include cl_object cl_minusp(cl_object x) -{ /* INV: ecl_minusp() checks type */ - @(return (ecl_minusp(x) ? ECL_T : ECL_NIL)) +{ /* INV: ecl_minusp() checks type */ + @(return (ecl_minusp(x) ? ECL_T : ECL_NIL)); } static int ecl_minusp_fixnum(cl_object x) { - return ecl_fixnum_minusp(x); + return ecl_fixnum_minusp(x); } static int ecl_minusp_big(cl_object x) { - return _ecl_big_sign(x) < 0; + return _ecl_big_sign(x) < 0; } static int ecl_minusp_ratio(cl_object x) { - return ecl_minusp(x->ratio.num); + return ecl_minusp(x->ratio.num); } static int ecl_minusp_single_float(cl_object x) { - return ecl_single_float(x) < 0; + return ecl_single_float(x) < 0; } static int ecl_minusp_double_float(cl_object x) { - return ecl_double_float(x) < 0; + return ecl_double_float(x) < 0; } #ifdef ECL_LONG_FLOAT static int ecl_minusp_long_float(cl_object x) { - return ecl_long_float(x) < 0; + return ecl_long_float(x) < 0; } #endif diff -Nru ecl-16.1.2/src/c/numbers/negate.d ecl-16.1.3+ds/src/c/numbers/negate.d --- ecl-16.1.2/src/c/numbers/negate.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/negate.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - negate.d -- Trascendental functions: negateine -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * negate.d - trascendental functions: negateine + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -23,46 +18,46 @@ static cl_object ecl_negate_fix(cl_object x) { - return ecl_make_integer(-ecl_fixnum(x)); + return ecl_make_integer(-ecl_fixnum(x)); } static cl_object ecl_negate_big(cl_object x) { - return _ecl_big_negate(x); + return _ecl_big_negate(x); } static cl_object ecl_negate_ratio(cl_object x) { - return ecl_make_ratio(ecl_negate(x->ratio.num), x->ratio.den); + return ecl_make_ratio(ecl_negate(x->ratio.num), x->ratio.den); } static cl_object ecl_negate_single_float(cl_object x) { - return ecl_make_single_float(-ecl_single_float(x)); + return ecl_make_single_float(-ecl_single_float(x)); } static cl_object ecl_negate_double_float(cl_object x) { - return ecl_make_double_float(-ecl_double_float(x)); + return ecl_make_double_float(-ecl_double_float(x)); } #ifdef ECL_LONG_FLOAT static cl_object ecl_negate_long_float(cl_object x) { - return ecl_make_long_float(-ecl_long_float(x)); + return ecl_make_long_float(-ecl_long_float(x)); } #endif static cl_object ecl_negate_complex(cl_object x) { - return ecl_make_complex(ecl_negate(x->complex.real), - ecl_negate(x->complex.imag)); + return ecl_make_complex(ecl_negate(x->complex.real), + ecl_negate(x->complex.imag)); } MATH_DEF_DISPATCH1_NE(negate, @[-], @[number], diff -Nru ecl-16.1.2/src/c/numbers/number_compare.d ecl-16.1.3+ds/src/c/numbers/number_compare.d --- ecl-16.1.2/src/c/numbers/number_compare.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/number_compare.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,208 +1,217 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - number_compare.c -- number comparison. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. + * number_compare.d - number comparison + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - See file '../Copyright' for full details. -*/ #include #include #include "numbers/float_fix_compare.d" /* - The value of ecl_number_compare(x, y) is - - -1 if x < y - 0 if x = y - 1 if x > y. - - If x or y is not real, it fails. + * + * The value of ecl_number_compare(x, y) is + * + * -1 if x < y + * 0 if x = y + * 1 if x > y. + * + * If x or y is not real, it fails. */ int ecl_number_compare(cl_object x, cl_object y) { - cl_fixnum ix, iy; - double dx, dy; + cl_fixnum ix, iy; + double dx, dy; #ifdef ECL_LONG_FLOAT - long double ldx, ldy; + long double ldx, ldy; #endif - cl_type ty; + cl_type ty; BEGIN: - ty = ecl_t_of(y); - switch (ecl_t_of(x)) { - case t_fixnum: - ix = ecl_fixnum(x); - switch (ty) { - case t_fixnum: - iy = ecl_fixnum(y); - if (ix < iy) - return(-1); - else return(ix != iy); - case t_bignum: - /* INV: (= x y) can't be zero since fixnum != bignum */ - return _ecl_big_sign(y) < 0? 1 : -1; - case t_ratio: - x = ecl_times(x, y->ratio.den); - y = y->ratio.num; - return(ecl_number_compare(x, y)); - case t_singlefloat: - return double_fix_compare(ix, ecl_single_float(y)); - case t_doublefloat: - return double_fix_compare(ix, ecl_double_float(y)); -#ifdef ECL_LONG_FLOAT - case t_longfloat: - return long_double_fix_compare(ix, ecl_long_float(y)); -#endif - default: - FEwrong_type_nth_arg(@[<], 2, y, @[real]); - } - case t_bignum: - switch (ty) { - case t_fixnum: - return _ecl_big_sign(x) < 0 ? -1 : 1; - case t_bignum: - return(_ecl_big_compare(x, y)); - case t_ratio: - x = ecl_times(x, y->ratio.den); - y = y->ratio.num; - return(ecl_number_compare(x, y)); - case t_singlefloat: - case t_doublefloat: -#ifdef ECL_LONG_FLOAT - case t_longfloat: -#endif - y = cl_rational(y); - goto BEGIN; - default: - FEwrong_type_nth_arg(@[<], 2, y, @[real]); - } - case t_ratio: - switch (ty) { - case t_fixnum: - case t_bignum: - y = ecl_times(y, x->ratio.den); - x = x->ratio.num; - return(ecl_number_compare(x, y)); - case t_ratio: - return(ecl_number_compare(ecl_times(x->ratio.num, - y->ratio.den), - ecl_times(y->ratio.num, - x->ratio.den))); - case t_singlefloat: - case t_doublefloat: -#ifdef ECL_LONG_FLOAT - case t_longfloat: -#endif - y = cl_rational(y); - goto BEGIN; - default: - FEwrong_type_nth_arg(@[<], 2, y, @[real]); - } - case t_singlefloat: - dx = (double)(ecl_single_float(x)); - goto DOUBLEFLOAT0; - case t_doublefloat: - dx = ecl_double_float(x); - DOUBLEFLOAT0: - switch (ty) { - case t_fixnum: - return -double_fix_compare(ecl_fixnum(y), dx); - case t_bignum: - case t_ratio: - x = cl_rational(x); - goto BEGIN; - case t_singlefloat: - dy = (double)(ecl_single_float(y)); - break; - case t_doublefloat: - dy = ecl_double_float(y); - break; -#ifdef ECL_LONG_FLOAT - case t_longfloat: - ldx = dx; - ldy = ecl_long_float(y); - goto LONGFLOAT; -#endif - default: - FEwrong_type_nth_arg(@[<], 2, y, @[real]); - } - DOUBLEFLOAT: - if (dx == dy) - return(0); - else if (dx < dy) - return(-1); - else - return(1); -#ifdef ECL_LONG_FLOAT - case t_longfloat: - ldx = ecl_long_float(x); - switch (ty) { - case t_fixnum: - return -long_double_fix_compare(ecl_fixnum(y), ldx); - case t_bignum: - case t_ratio: - x = cl_rational(x); - goto BEGIN; - case t_singlefloat: - ldy = ecl_single_float(y); - break; - case t_doublefloat: - ldy = ecl_double_float(y); - break; - case t_longfloat: - ldy = ecl_long_float(y); - break; - default: - FEwrong_type_nth_arg(@[<], 2, y, @[real]); - } - LONGFLOAT: - if (ldx == ldy) - return 0; - else if (ldx < ldy) - return -1; - else - return 1; - break; -#endif - default: - FEwrong_type_nth_arg(@[<], 1, x, @[real]); - } + ty = ecl_t_of(y); + switch (ecl_t_of(x)) { + case t_fixnum: + ix = ecl_fixnum(x); + switch (ty) { + case t_fixnum: + iy = ecl_fixnum(y); + if (ix < iy) + return(-1); + else return(ix != iy); + case t_bignum: + /* INV: (= x y) can't be zero since fixnum != bignum */ + return _ecl_big_sign(y) < 0? 1 : -1; + case t_ratio: + x = ecl_times(x, y->ratio.den); + y = y->ratio.num; + return(ecl_number_compare(x, y)); + case t_singlefloat: + return double_fix_compare(ix, ecl_single_float(y)); + case t_doublefloat: + return double_fix_compare(ix, ecl_double_float(y)); +#ifdef ECL_LONG_FLOAT + case t_longfloat: + return long_double_fix_compare(ix, ecl_long_float(y)); +#endif + default: + FEwrong_type_nth_arg(@[<], 2, y, @[real]); + } + case t_bignum: + switch (ty) { + case t_fixnum: + return _ecl_big_sign(x) < 0 ? -1 : 1; + case t_bignum: + return(_ecl_big_compare(x, y)); + case t_ratio: + x = ecl_times(x, y->ratio.den); + y = y->ratio.num; + return(ecl_number_compare(x, y)); + case t_singlefloat: + case t_doublefloat: +#ifdef ECL_LONG_FLOAT + case t_longfloat: +#endif +#ifdef ECL_IEEE_FP + if (ecl_float_infinity_p(y)) + return(ecl_number_compare(ecl_make_fixnum(0), y)); +#endif + y = cl_rational(y); + goto BEGIN; + default: + FEwrong_type_nth_arg(@[<], 2, y, @[real]); + } + case t_ratio: + switch (ty) { + case t_fixnum: + case t_bignum: + y = ecl_times(y, x->ratio.den); + x = x->ratio.num; + return(ecl_number_compare(x, y)); + case t_ratio: + return(ecl_number_compare(ecl_times(x->ratio.num, + y->ratio.den), + ecl_times(y->ratio.num, + x->ratio.den))); + case t_singlefloat: + case t_doublefloat: +#ifdef ECL_LONG_FLOAT + case t_longfloat: +#endif +#ifdef ECL_IEEE_FP + if (ecl_float_infinity_p(y)) + return(ecl_number_compare(ecl_make_fixnum(0), y)); +#endif + y = cl_rational(y); + goto BEGIN; + default: + FEwrong_type_nth_arg(@[<], 2, y, @[real]); + } + case t_singlefloat: + dx = (double)(ecl_single_float(x)); + goto DOUBLEFLOAT0; + case t_doublefloat: + dx = ecl_double_float(x); + DOUBLEFLOAT0: + switch (ty) { + case t_fixnum: + return -double_fix_compare(ecl_fixnum(y), dx); + case t_bignum: + case t_ratio: +#ifdef ECL_IEEE_FP + if (ecl_float_infinity_p(x)) + return(ecl_number_compare(x, ecl_make_fixnum(0))); +#endif + x = cl_rational(x); + goto BEGIN; + case t_singlefloat: + dy = (double)(ecl_single_float(y)); + break; + case t_doublefloat: + dy = ecl_double_float(y); + break; +#ifdef ECL_LONG_FLOAT + case t_longfloat: + ldx = dx; + ldy = ecl_long_float(y); + goto LONGFLOAT; +#endif + default: + FEwrong_type_nth_arg(@[<], 2, y, @[real]); + } + DOUBLEFLOAT: + if (dx == dy) + return(0); + else if (dx < dy) + return(-1); + else + return(1); +#ifdef ECL_LONG_FLOAT + case t_longfloat: + ldx = ecl_long_float(x); + switch (ty) { + case t_fixnum: + return -long_double_fix_compare(ecl_fixnum(y), ldx); + case t_bignum: + case t_ratio: + x = cl_rational(x); + goto BEGIN; + case t_singlefloat: + ldy = ecl_single_float(y); + break; + case t_doublefloat: + ldy = ecl_double_float(y); + break; + case t_longfloat: + ldy = ecl_long_float(y); + break; + default: + FEwrong_type_nth_arg(@[<], 2, y, @[real]); + } + LONGFLOAT: + if (ldx == ldy) + return 0; + else if (ldx < ldy) + return -1; + else + return 1; + break; +#endif + default: + FEwrong_type_nth_arg(@[<], 1, x, @[real]); + } } static cl_object monotonic(int s, int t, int narg, ecl_va_list nums) { - cl_object c, d; + cl_object c, d; - if (narg == 0) - FEwrong_num_arguments_anonym(); - /* INV: type check occurs in ecl_number_compare() */ - for (c = ecl_va_arg(nums); --narg; c = d) { - d = ecl_va_arg(nums); - if (s*ecl_number_compare(d, c) < t) - return1(ECL_NIL); - } - return1(ECL_T); + if (narg == 0) + FEwrong_num_arguments_anonym(); + /* INV: type check occurs in ecl_number_compare() */ + for (c = ecl_va_arg(nums); --narg; c = d) { + d = ecl_va_arg(nums); + if (s*ecl_number_compare(d, c) < t) + return1(ECL_NIL); + } + return1(ECL_T); } -#define MONOTONIC(i, j) (cl_narg narg, ...) \ -{ ecl_va_list nums; ecl_va_start(nums, narg, narg, 0); \ - return monotonic(i, j, narg, nums); } +#define MONOTONIC(i, j) (cl_narg narg, ...) \ + { ecl_va_list nums; ecl_va_start(nums, narg, narg, 0); \ + return monotonic(i, j, narg, nums); } cl_object @<= MONOTONIC( 1, 0) -cl_object @>= MONOTONIC(-1, 0) -cl_object @< MONOTONIC( 1, 1) -cl_object @> MONOTONIC(-1, 1) + cl_object @>= MONOTONIC(-1, 0) + cl_object @< MONOTONIC( 1, 1) + cl_object @> MONOTONIC(-1, 1) diff -Nru ecl-16.1.2/src/c/numbers/number_equalp.d ecl-16.1.3+ds/src/c/numbers/number_equalp.d --- ecl-16.1.2/src/c/numbers/number_equalp.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/number_equalp.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,195 +1,193 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - number_compare.c -- number comparison and sorting. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. + * number_compare.c - number comparison and sorting + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - See file '../Copyright' for full details. -*/ #include #include #include "numbers/float_fix_compare.d" @(defun = (num &rest nums) - int i; -@ - /* ANSI: Need not signal error for 1 argument */ - /* INV: For >= 2 arguments, ecl_number_equalp() performs checks */ - for (i = 1; i < narg; i++) - if (!ecl_number_equalp(num, ecl_va_arg(nums))) - @(return ECL_NIL) - @(return ECL_T) -@) + int i; + @ + /* ANSI: Need not signal error for 1 argument */ + /* INV: For >= 2 arguments, ecl_number_equalp() performs checks */ + for (i = 1; i < narg; i++) + if (!ecl_number_equalp(num, ecl_va_arg(nums))) { + @(return ECL_NIL); + } + @(return ECL_T); + @) /* Returns 1 if both numbers compare to equal */ int ecl_number_equalp(cl_object x, cl_object y) { - double dx; - /* INV: (= fixnum bignum) => 0 */ - /* INV: (= fixnum ratio) => 0 */ - /* INV: (= bignum ratio) => 0 */ + double dx; + /* INV: (= fixnum bignum) => 0 */ + /* INV: (= fixnum ratio) => 0 */ + /* INV: (= bignum ratio) => 0 */ BEGIN: - switch (ecl_t_of(x)) { - case t_fixnum: - switch (ecl_t_of(y)) { - case t_fixnum: - return x == y; - case t_bignum: - case t_ratio: - return 0; - case t_singlefloat: - return double_fix_compare(ecl_fixnum(x), ecl_single_float(y)) == 0; - case t_doublefloat: - return double_fix_compare(ecl_fixnum(x), ecl_double_float(y)) == 0; -#ifdef ECL_LONG_FLOAT - case t_longfloat: - return long_double_fix_compare(ecl_fixnum(x), ecl_long_float(y)) == 0; -#endif - case t_complex: - goto Y_COMPLEX; - default: - FEwrong_type_nth_arg(@[=], 2, y, @[number]); - } - case t_bignum: - switch (ecl_t_of(y)) { - case t_fixnum: - return 0; - case t_bignum: - return _ecl_big_compare(x, y)==0; - case t_ratio: - return 0; - case t_singlefloat: - case t_doublefloat: -#ifdef ECL_LONG_FLOAT - case t_longfloat: -#endif - y = cl_rational(y); - goto BEGIN; - case t_complex: - goto Y_COMPLEX; - default: - FEwrong_type_nth_arg(@[=], 2, y, @[number]); - } - case t_ratio: - switch (ecl_t_of(y)) { - case t_fixnum: - case t_bignum: - return 0; - case t_ratio: - return (ecl_number_equalp(x->ratio.num, y->ratio.num) && - ecl_number_equalp(x->ratio.den, y->ratio.den)); - case t_singlefloat: - case t_doublefloat: -#ifdef ECL_LONG_FLOAT - case t_longfloat: -#endif - y = cl_rational(y); - goto BEGIN; - case t_complex: - goto Y_COMPLEX; - default: - FEwrong_type_nth_arg(@[=], 2, y, @[number]); - } - case t_singlefloat: - dx = ecl_single_float(x); - goto FLOAT_ECL; - case t_doublefloat: - dx = ecl_double_float(x); - FLOAT_ECL: - switch (ecl_t_of(y)) { - case t_fixnum: - return double_fix_compare(ecl_fixnum(y), dx) == 0; - case t_bignum: - case t_ratio: - x = cl_rational(x); - goto BEGIN; - case t_singlefloat: - return dx == ecl_single_float(y); - case t_doublefloat: - return dx == ecl_double_float(y); -#ifdef ECL_LONG_FLOAT - case t_longfloat: - return dx == ecl_long_float(y); -#endif - case t_complex: - goto Y_COMPLEX; - default: - FEwrong_type_nth_arg(@[=], 2, y, @[number]); - } -#ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double dx = ecl_long_float(x); - switch (ecl_t_of(y)) { - case t_fixnum: - return long_double_fix_compare(ecl_fixnum(y), dx) == 0; - case t_bignum: - case t_ratio: - x = cl_rational(x); - goto BEGIN; - case t_singlefloat: - return dx == ecl_single_float(y); - case t_doublefloat: - return dx == ecl_double_float(y); - case t_longfloat: - return dx == ecl_long_float(y); - case t_complex: - goto Y_COMPLEX; - default: - FEwrong_type_nth_arg(@[=], 2, y, @[number]); - } - } -#endif - Y_COMPLEX: - if (!ecl_zerop(y->complex.imag)) - return 0; - return ecl_number_equalp(x, y->complex.real); - case t_complex: - switch (ecl_t_of(y)) { - case t_complex: - return (ecl_number_equalp(x->complex.real, y->complex.real) && - ecl_number_equalp(x->complex.imag, y->complex.imag)); - case t_fixnum: case t_bignum: case t_ratio: - case t_singlefloat: case t_doublefloat: -#ifdef ECL_LONG_FLOAT - case t_longfloat: -#endif - if (ecl_zerop(x->complex.imag)) - return ecl_number_equalp(x->complex.real, y) != 0; - else - return 0; - default: - FEwrong_type_nth_arg(@[=], 2, y, @[number]); - } - default: - FEwrong_type_nth_arg(@[=], 1, x, @[number]); - } + switch (ecl_t_of(x)) { + case t_fixnum: + switch (ecl_t_of(y)) { + case t_fixnum: + return x == y; + case t_bignum: + case t_ratio: + return 0; + case t_singlefloat: + return double_fix_compare(ecl_fixnum(x), ecl_single_float(y)) == 0; + case t_doublefloat: + return double_fix_compare(ecl_fixnum(x), ecl_double_float(y)) == 0; +#ifdef ECL_LONG_FLOAT + case t_longfloat: + return long_double_fix_compare(ecl_fixnum(x), ecl_long_float(y)) == 0; +#endif + case t_complex: + goto Y_COMPLEX; + default: + FEwrong_type_nth_arg(@[=], 2, y, @[number]); + } + case t_bignum: + switch (ecl_t_of(y)) { + case t_fixnum: + return 0; + case t_bignum: + return _ecl_big_compare(x, y)==0; + case t_ratio: + return 0; + case t_singlefloat: + case t_doublefloat: +#ifdef ECL_LONG_FLOAT + case t_longfloat: +#endif + y = cl_rational(y); + goto BEGIN; + case t_complex: + goto Y_COMPLEX; + default: + FEwrong_type_nth_arg(@[=], 2, y, @[number]); + } + case t_ratio: + switch (ecl_t_of(y)) { + case t_fixnum: + case t_bignum: + return 0; + case t_ratio: + return (ecl_number_equalp(x->ratio.num, y->ratio.num) && + ecl_number_equalp(x->ratio.den, y->ratio.den)); + case t_singlefloat: + case t_doublefloat: +#ifdef ECL_LONG_FLOAT + case t_longfloat: +#endif + y = cl_rational(y); + goto BEGIN; + case t_complex: + goto Y_COMPLEX; + default: + FEwrong_type_nth_arg(@[=], 2, y, @[number]); + } + case t_singlefloat: + dx = ecl_single_float(x); + goto FLOAT_ECL; + case t_doublefloat: + dx = ecl_double_float(x); + FLOAT_ECL: + switch (ecl_t_of(y)) { + case t_fixnum: + return double_fix_compare(ecl_fixnum(y), dx) == 0; + case t_bignum: + case t_ratio: + x = cl_rational(x); + goto BEGIN; + case t_singlefloat: + return dx == ecl_single_float(y); + case t_doublefloat: + return dx == ecl_double_float(y); +#ifdef ECL_LONG_FLOAT + case t_longfloat: + return dx == ecl_long_float(y); +#endif + case t_complex: + goto Y_COMPLEX; + default: + FEwrong_type_nth_arg(@[=], 2, y, @[number]); + } +#ifdef ECL_LONG_FLOAT + case t_longfloat: { + long double dx = ecl_long_float(x); + switch (ecl_t_of(y)) { + case t_fixnum: + return long_double_fix_compare(ecl_fixnum(y), dx) == 0; + case t_bignum: + case t_ratio: + x = cl_rational(x); + goto BEGIN; + case t_singlefloat: + return dx == ecl_single_float(y); + case t_doublefloat: + return dx == ecl_double_float(y); + case t_longfloat: + return dx == ecl_long_float(y); + case t_complex: + goto Y_COMPLEX; + default: + FEwrong_type_nth_arg(@[=], 2, y, @[number]); + } + } +#endif + Y_COMPLEX: + if (!ecl_zerop(y->complex.imag)) + return 0; + return ecl_number_equalp(x, y->complex.real); + case t_complex: + switch (ecl_t_of(y)) { + case t_complex: + return (ecl_number_equalp(x->complex.real, y->complex.real) && + ecl_number_equalp(x->complex.imag, y->complex.imag)); + case t_fixnum: case t_bignum: case t_ratio: + case t_singlefloat: case t_doublefloat: +#ifdef ECL_LONG_FLOAT + case t_longfloat: +#endif + if (ecl_zerop(x->complex.imag)) + return ecl_number_equalp(x->complex.real, y) != 0; + else + return 0; + default: + FEwrong_type_nth_arg(@[=], 2, y, @[number]); + } + default: + FEwrong_type_nth_arg(@[=], 1, x, @[number]); + } } @(defun /= (&rest nums &aux numi) - int i, j; -@ - if (narg == 0) - FEwrong_num_arguments_anonym(); - numi = ecl_va_arg(nums); - for (i = 2; i<=narg; i++) { - ecl_va_list numb; - ecl_va_start(numb, narg, narg, 0); - numi = ecl_va_arg(nums); - for (j = 1; j #include @@ -23,48 +19,48 @@ static cl_object ecl_one_minus_fix(cl_object x) { - if (x == ecl_make_fixnum(MOST_NEGATIVE_FIXNUM)) - return ecl_make_integer(MOST_NEGATIVE_FIXNUM-1); - return (cl_object)((cl_fixnum)x - ((cl_fixnum)ecl_make_fixnum(1) - ECL_FIXNUM_TAG)); + if (x == ecl_make_fixnum(MOST_NEGATIVE_FIXNUM)) + return ecl_make_integer(MOST_NEGATIVE_FIXNUM-1); + return (cl_object)((cl_fixnum)x - ((cl_fixnum)ecl_make_fixnum(1) - ECL_FIXNUM_TAG)); } static cl_object ecl_one_minus_big(cl_object x) { - return ecl_minus(x, ecl_make_fixnum(1)); + return ecl_minus(x, ecl_make_fixnum(1)); } static cl_object ecl_one_minus_ratio(cl_object x) { - return ecl_make_ratio(ecl_minus(x->ratio.num,x->ratio.den), x->ratio.den); + return ecl_make_ratio(ecl_minus(x->ratio.num,x->ratio.den), x->ratio.den); } static cl_object ecl_one_minus_single_float(cl_object x) { - return ecl_make_single_float(ecl_single_float(x) - 1); + return ecl_make_single_float(ecl_single_float(x) - 1); } static cl_object ecl_one_minus_double_float(cl_object x) { - return ecl_make_double_float(ecl_double_float(x) - 1); + return ecl_make_double_float(ecl_double_float(x) - 1); } #ifdef ECL_LONG_FLOAT static cl_object ecl_one_minus_long_float(cl_object x) { - return ecl_make_long_float(ecl_long_float(x) - 1); + return ecl_make_long_float(ecl_long_float(x) - 1); } #endif static cl_object ecl_one_minus_complex(cl_object x) { - return ecl_make_complex(ecl_one_minus(x->complex.real), - x->complex.imag); + return ecl_make_complex(ecl_one_minus(x->complex.real), + x->complex.imag); } MATH_DEF_DISPATCH1_NE(one_minus, @[1-], @[number], @@ -77,6 +73,5 @@ cl_object @1-(cl_object x) { /* INV: type check is in ecl_one_minus() */ - @(return ecl_one_minus(x)) + @(return ecl_one_minus(x)); } - diff -Nru ecl-16.1.2/src/c/numbers/one_plus.d ecl-16.1.3+ds/src/c/numbers/one_plus.d --- ecl-16.1.2/src/c/numbers/one_plus.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/one_plus.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - one_plus.d -- Implementation of CL:1+ -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. + * one_plus.d - implementation of CL:1+ + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - See file '../Copyright' for full details. -*/ #include #include @@ -23,48 +19,48 @@ static cl_object ecl_one_plus_fix(cl_object x) { - if (x == ecl_make_fixnum(MOST_POSITIVE_FIXNUM)) - return ecl_make_integer(MOST_POSITIVE_FIXNUM+1); - return (cl_object)((cl_fixnum)x + ((cl_fixnum)ecl_make_fixnum(1) - ECL_FIXNUM_TAG)); + if (x == ecl_make_fixnum(MOST_POSITIVE_FIXNUM)) + return ecl_make_integer(MOST_POSITIVE_FIXNUM+1); + return (cl_object)((cl_fixnum)x + ((cl_fixnum)ecl_make_fixnum(1) - ECL_FIXNUM_TAG)); } static cl_object ecl_one_plus_big(cl_object x) { - return ecl_plus(x, ecl_make_fixnum(1)); + return ecl_plus(x, ecl_make_fixnum(1)); } static cl_object ecl_one_plus_ratio(cl_object x) { - return ecl_make_ratio(ecl_plus(x->ratio.num,x->ratio.den), x->ratio.den); + return ecl_make_ratio(ecl_plus(x->ratio.num,x->ratio.den), x->ratio.den); } static cl_object ecl_one_plus_single_float(cl_object x) { - return ecl_make_single_float(ecl_single_float(x) + 1); + return ecl_make_single_float(ecl_single_float(x) + 1); } static cl_object ecl_one_plus_double_float(cl_object x) { - return ecl_make_double_float(ecl_double_float(x) + 1); + return ecl_make_double_float(ecl_double_float(x) + 1); } #ifdef ECL_LONG_FLOAT static cl_object ecl_one_plus_long_float(cl_object x) { - return ecl_make_long_float(ecl_long_float(x) + 1); + return ecl_make_long_float(ecl_long_float(x) + 1); } #endif static cl_object ecl_one_plus_complex(cl_object x) { - return ecl_make_complex(ecl_one_plus(x->complex.real), - x->complex.imag); + return ecl_make_complex(ecl_one_plus(x->complex.real), + x->complex.imag); } MATH_DEF_DISPATCH1_NE(one_plus, @[1+], @[number], @@ -77,6 +73,6 @@ cl_object @1+(cl_object x) { - /* INV: type check is in ecl_one_plus() */ - @(return ecl_one_plus(x)) + /* INV: type check is in ecl_one_plus() */ + @(return ecl_one_plus(x)); } diff -Nru ecl-16.1.2/src/c/numbers/plus.d ecl-16.1.3+ds/src/c/numbers/plus.d --- ecl-16.1.2/src/c/numbers/plus.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/plus.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,175 +1,173 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - plus.d -- Implementation of CL:+ -*/ -/* - Copyright (c) 2010, Juan Jose Garcia Ripoll. - - ECL 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. + * plus.d - implementation of CL:+ + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - See file '../../Copyright' for full details. -*/ #include #include @(defun + (&rest nums) - cl_object sum = ecl_make_fixnum(0); -@ - /* INV: type check is in ecl_plus() */ - while (narg--) - sum = ecl_plus(sum, ecl_va_arg(nums)); - @(return sum) -@) + cl_object sum = ecl_make_fixnum(0); + @ + /* INV: type check is in ecl_plus() */ + while (narg--) + sum = ecl_plus(sum, ecl_va_arg(nums)); + @(return sum) + @) #ifdef MATH_DISPATCH2_BEGIN cl_object ecl_plus(cl_object x, cl_object y) { -MATH_DISPATCH2_BEGIN(x,y) -{ - CASE_FIXNUM_FIXNUM { - return ecl_make_integer(ecl_fixnum(x) + ecl_fixnum(y)); - } - CASE_FIXNUM_BIGNUM { - return _ecl_big_plus_fix(y, ecl_fixnum(x)); - } - CASE_FIXNUM_RATIO; - CASE_BIGNUM_RATIO { - cl_object z = ecl_times(x, y->ratio.den); - z = ecl_plus(z, y->ratio.num); - return ecl_make_ratio(z, y->ratio.den); - } - CASE_FIXNUM_SINGLE_FLOAT { - return ecl_make_single_float(ecl_fixnum(x) + ecl_single_float(y)); - } - CASE_FIXNUM_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_fixnum(x) + ecl_double_float(y)); - } - CASE_BIGNUM_FIXNUM { - return _ecl_big_plus_fix(x, ecl_fixnum(y)); - } - CASE_BIGNUM_BIGNUM { - return _ecl_big_plus_big(x, y); - } - CASE_BIGNUM_SINGLE_FLOAT; - CASE_RATIO_SINGLE_FLOAT { - return ecl_make_single_float(ecl_to_float(x) + ecl_single_float(y)); - } - CASE_BIGNUM_DOUBLE_FLOAT; - CASE_RATIO_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_to_double(x) + ecl_double_float(y)); - } - CASE_RATIO_FIXNUM; - CASE_RATIO_BIGNUM { - cl_object z = ecl_times(x->ratio.den, y); - z = ecl_plus(x->ratio.num, z); - return ecl_make_ratio(z, x->ratio.den); - } - CASE_RATIO_RATIO { - cl_object z1 = ecl_times(x->ratio.num,y->ratio.den); - cl_object z = ecl_times(x->ratio.den,y->ratio.num); - z = ecl_plus(z1, z); - z1 = ecl_times(x->ratio.den,y->ratio.den); - return ecl_make_ratio(z, z1); - } - CASE_SINGLE_FLOAT_FIXNUM { - return ecl_make_single_float(ecl_single_float(x) + ecl_fixnum(y)); - } - CASE_SINGLE_FLOAT_BIGNUM; - CASE_SINGLE_FLOAT_RATIO { - return ecl_make_single_float(ecl_single_float(x) + ecl_to_float(y)); - } - CASE_SINGLE_FLOAT_SINGLE_FLOAT { - return ecl_make_single_float(ecl_single_float(x) + ecl_single_float(y)); - } - CASE_SINGLE_FLOAT_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_single_float(x) + ecl_double_float(y)); - } - CASE_DOUBLE_FLOAT_FIXNUM { - return ecl_make_double_float(ecl_double_float(x) + ecl_fixnum(y)); - } - CASE_DOUBLE_FLOAT_BIGNUM; - CASE_DOUBLE_FLOAT_RATIO { - return ecl_make_double_float(ecl_double_float(x) + ecl_to_double(y)); - } - CASE_DOUBLE_FLOAT_SINGLE_FLOAT { - return ecl_make_double_float(ecl_double_float(x) + ecl_single_float(y)); - } - CASE_DOUBLE_FLOAT_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_double_float(x) + ecl_double_float(y)); - } + MATH_DISPATCH2_BEGIN(x,y) + { + CASE_FIXNUM_FIXNUM { + return ecl_make_integer(ecl_fixnum(x) + ecl_fixnum(y)); + } + CASE_FIXNUM_BIGNUM { + return _ecl_big_plus_fix(y, ecl_fixnum(x)); + } + CASE_FIXNUM_RATIO; + CASE_BIGNUM_RATIO { + cl_object z = ecl_times(x, y->ratio.den); + z = ecl_plus(z, y->ratio.num); + return ecl_make_ratio(z, y->ratio.den); + } + CASE_FIXNUM_SINGLE_FLOAT { + return ecl_make_single_float(ecl_fixnum(x) + ecl_single_float(y)); + } + CASE_FIXNUM_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_fixnum(x) + ecl_double_float(y)); + } + CASE_BIGNUM_FIXNUM { + return _ecl_big_plus_fix(x, ecl_fixnum(y)); + } + CASE_BIGNUM_BIGNUM { + return _ecl_big_plus_big(x, y); + } + CASE_BIGNUM_SINGLE_FLOAT; + CASE_RATIO_SINGLE_FLOAT { + return ecl_make_single_float(ecl_to_float(x) + ecl_single_float(y)); + } + CASE_BIGNUM_DOUBLE_FLOAT; + CASE_RATIO_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_to_double(x) + ecl_double_float(y)); + } + CASE_RATIO_FIXNUM; + CASE_RATIO_BIGNUM { + cl_object z = ecl_times(x->ratio.den, y); + z = ecl_plus(x->ratio.num, z); + return ecl_make_ratio(z, x->ratio.den); + } + CASE_RATIO_RATIO { + cl_object z1 = ecl_times(x->ratio.num,y->ratio.den); + cl_object z = ecl_times(x->ratio.den,y->ratio.num); + z = ecl_plus(z1, z); + z1 = ecl_times(x->ratio.den,y->ratio.den); + return ecl_make_ratio(z, z1); + } + CASE_SINGLE_FLOAT_FIXNUM { + return ecl_make_single_float(ecl_single_float(x) + ecl_fixnum(y)); + } + CASE_SINGLE_FLOAT_BIGNUM; + CASE_SINGLE_FLOAT_RATIO { + return ecl_make_single_float(ecl_single_float(x) + ecl_to_float(y)); + } + CASE_SINGLE_FLOAT_SINGLE_FLOAT { + return ecl_make_single_float(ecl_single_float(x) + ecl_single_float(y)); + } + CASE_SINGLE_FLOAT_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_single_float(x) + ecl_double_float(y)); + } + CASE_DOUBLE_FLOAT_FIXNUM { + return ecl_make_double_float(ecl_double_float(x) + ecl_fixnum(y)); + } + CASE_DOUBLE_FLOAT_BIGNUM; + CASE_DOUBLE_FLOAT_RATIO { + return ecl_make_double_float(ecl_double_float(x) + ecl_to_double(y)); + } + CASE_DOUBLE_FLOAT_SINGLE_FLOAT { + return ecl_make_double_float(ecl_double_float(x) + ecl_single_float(y)); + } + CASE_DOUBLE_FLOAT_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_double_float(x) + ecl_double_float(y)); + } #ifdef ECL_LONG_FLOAT - CASE_FIXNUM_LONG_FLOAT { - return ecl_make_long_float(ecl_fixnum(x) + ecl_long_float(y)); - } - CASE_BIGNUM_LONG_FLOAT { - return ecl_make_long_float(ecl_to_long_double(x) + ecl_long_float(y)); - } - CASE_RATIO_LONG_FLOAT { - return ecl_make_long_float(ecl_to_long_double(x) + ecl_long_float(y)); - } - CASE_SINGLE_FLOAT_LONG_FLOAT { - return ecl_make_long_float(ecl_single_float(x) + ecl_long_float(y)); - } - CASE_DOUBLE_FLOAT_LONG_FLOAT { - return ecl_make_long_float(ecl_double_float(x) + ecl_long_float(y)); - } - CASE_LONG_FLOAT_FIXNUM { - return ecl_make_long_float(ecl_long_float(x) + ecl_fixnum(y)); - } - CASE_LONG_FLOAT_BIGNUM; - CASE_LONG_FLOAT_RATIO { - return ecl_make_long_float(ecl_long_float(x) + ecl_to_long_double(y)); - } - CASE_LONG_FLOAT_SINGLE_FLOAT { - return ecl_make_long_float(ecl_long_float(x) + ecl_single_float(y)); - } - CASE_LONG_FLOAT_DOUBLE_FLOAT { - return ecl_make_long_float(ecl_long_float(x) + ecl_double_float(y)); - } - CASE_LONG_FLOAT_LONG_FLOAT { - return ecl_make_long_float(ecl_long_float(x) + ecl_long_float(y)); - } - CASE_LONG_FLOAT_COMPLEX { - goto COMPLEX_Y; - } - CASE_COMPLEX_LONG_FLOAT; { - goto COMPLEX_X; - } + CASE_FIXNUM_LONG_FLOAT { + return ecl_make_long_float(ecl_fixnum(x) + ecl_long_float(y)); + } + CASE_BIGNUM_LONG_FLOAT { + return ecl_make_long_float(ecl_to_long_double(x) + ecl_long_float(y)); + } + CASE_RATIO_LONG_FLOAT { + return ecl_make_long_float(ecl_to_long_double(x) + ecl_long_float(y)); + } + CASE_SINGLE_FLOAT_LONG_FLOAT { + return ecl_make_long_float(ecl_single_float(x) + ecl_long_float(y)); + } + CASE_DOUBLE_FLOAT_LONG_FLOAT { + return ecl_make_long_float(ecl_double_float(x) + ecl_long_float(y)); + } + CASE_LONG_FLOAT_FIXNUM { + return ecl_make_long_float(ecl_long_float(x) + ecl_fixnum(y)); + } + CASE_LONG_FLOAT_BIGNUM; + CASE_LONG_FLOAT_RATIO { + return ecl_make_long_float(ecl_long_float(x) + ecl_to_long_double(y)); + } + CASE_LONG_FLOAT_SINGLE_FLOAT { + return ecl_make_long_float(ecl_long_float(x) + ecl_single_float(y)); + } + CASE_LONG_FLOAT_DOUBLE_FLOAT { + return ecl_make_long_float(ecl_long_float(x) + ecl_double_float(y)); + } + CASE_LONG_FLOAT_LONG_FLOAT { + return ecl_make_long_float(ecl_long_float(x) + ecl_long_float(y)); + } + CASE_LONG_FLOAT_COMPLEX { + goto COMPLEX_Y; + } + CASE_COMPLEX_LONG_FLOAT; { + goto COMPLEX_X; + } #endif - CASE_COMPLEX_FIXNUM; - CASE_COMPLEX_BIGNUM; - CASE_COMPLEX_RATIO; - CASE_COMPLEX_SINGLE_FLOAT; - CASE_COMPLEX_DOUBLE_FLOAT; COMPLEX_X: { - cl_object aux = x; - x = y; y = aux; - goto COMPLEX_Y; - } - CASE_BIGNUM_COMPLEX; - CASE_RATIO_COMPLEX; - CASE_SINGLE_FLOAT_COMPLEX; - CASE_DOUBLE_FLOAT_COMPLEX; - CASE_FIXNUM_COMPLEX { - COMPLEX_Y: - return ecl_make_complex(ecl_plus(x, y->complex.real), - y->complex.imag); - } - CASE_COMPLEX_COMPLEX { - cl_object z = ecl_plus(x->complex.real, y->complex.real); - cl_object z1 = ecl_plus(x->complex.imag, y->complex.imag); - return ecl_make_complex(z, z1); - } - CASE_UNKNOWN(@[+],x,y,@[number]); -} -MATH_DISPATCH2_END; + CASE_COMPLEX_FIXNUM; + CASE_COMPLEX_BIGNUM; + CASE_COMPLEX_RATIO; + CASE_COMPLEX_SINGLE_FLOAT; + CASE_COMPLEX_DOUBLE_FLOAT; COMPLEX_X: { + cl_object aux = x; + x = y; y = aux; + goto COMPLEX_Y; + } + CASE_BIGNUM_COMPLEX; + CASE_RATIO_COMPLEX; + CASE_SINGLE_FLOAT_COMPLEX; + CASE_DOUBLE_FLOAT_COMPLEX; + CASE_FIXNUM_COMPLEX { + COMPLEX_Y: + return ecl_make_complex(ecl_plus(x, y->complex.real), + y->complex.imag); + } + CASE_COMPLEX_COMPLEX { + cl_object z = ecl_plus(x->complex.real, y->complex.real); + cl_object z1 = ecl_plus(x->complex.imag, y->complex.imag); + return ecl_make_complex(z, z1); + } + CASE_UNKNOWN(@[+],x,y,@[number]); + } + MATH_DISPATCH2_END; } #else @@ -177,155 +175,155 @@ cl_object ecl_plus(cl_object x, cl_object y) { - cl_fixnum i, j; - cl_object z, z1; + cl_fixnum i, j; + cl_object z, z1; - switch (ecl_t_of(x)) { - case t_fixnum: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_integer(ecl_fixnum(x) + ecl_fixnum(y)); - case t_bignum: - return _ecl_big_plus_fix(y, ecl_fixnum(x)); - case t_ratio: - z = ecl_times(x, y->ratio.den); - z = ecl_plus(z, y->ratio.num); - return ecl_make_ratio(z, y->ratio.den); - case t_singlefloat: - return ecl_make_single_float(ecl_fixnum(x) + ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_fixnum(x) + ecl_double_float(y)); + switch (ecl_t_of(x)) { + case t_fixnum: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_integer(ecl_fixnum(x) + ecl_fixnum(y)); + case t_bignum: + return _ecl_big_plus_fix(y, ecl_fixnum(x)); + case t_ratio: + z = ecl_times(x, y->ratio.den); + z = ecl_plus(z, y->ratio.num); + return ecl_make_ratio(z, y->ratio.den); + case t_singlefloat: + return ecl_make_single_float(ecl_fixnum(x) + ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_fixnum(x) + ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_fixnum(x) + ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_fixnum(x) + ecl_long_float(y)); #endif - case t_complex: - COMPLEX: /* INV: x is real, y is complex */ - return ecl_make_complex(ecl_plus(x, y->complex.real), - y->complex.imag); - default: - FEwrong_type_nth_arg(@[+], 2, y, @[number]); - } - case t_bignum: - switch (ecl_t_of(y)) { - case t_fixnum: - return _ecl_big_plus_fix(x, ecl_fixnum(y)); - case t_bignum: - return _ecl_big_plus_big(x, y); - case t_ratio: - z = ecl_times(x, y->ratio.den); - z = ecl_plus(z, y->ratio.num); - return ecl_make_ratio(z, y->ratio.den); - case t_singlefloat: - return ecl_make_single_float(ecl_to_double(x) + ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_to_double(x) + ecl_double_float(y)); + case t_complex: + COMPLEX: /* INV: x is real, y is complex */ + return ecl_make_complex(ecl_plus(x, y->complex.real), + y->complex.imag); + default: + FEwrong_type_nth_arg(@[+], 2, y, @[number]); + } + case t_bignum: + switch (ecl_t_of(y)) { + case t_fixnum: + return _ecl_big_plus_fix(x, ecl_fixnum(y)); + case t_bignum: + return _ecl_big_plus_big(x, y); + case t_ratio: + z = ecl_times(x, y->ratio.den); + z = ecl_plus(z, y->ratio.num); + return ecl_make_ratio(z, y->ratio.den); + case t_singlefloat: + return ecl_make_single_float(ecl_to_double(x) + ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_to_double(x) + ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_to_double(x) + ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_to_double(x) + ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[+], 2, y, @[number]); - } - case t_ratio: - switch (ecl_t_of(y)) { - case t_fixnum: - case t_bignum: - z = ecl_times(x->ratio.den, y); - z = ecl_plus(x->ratio.num, z); - return ecl_make_ratio(z, x->ratio.den); - case t_ratio: - z1 = ecl_times(x->ratio.num,y->ratio.den); - z = ecl_times(x->ratio.den,y->ratio.num); - z = ecl_plus(z1, z); - z1 = ecl_times(x->ratio.den,y->ratio.den); - return ecl_make_ratio(z, z1); - case t_singlefloat: - return ecl_make_single_float(ecl_to_double(x) + ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_to_double(x) + ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[+], 2, y, @[number]); + } + case t_ratio: + switch (ecl_t_of(y)) { + case t_fixnum: + case t_bignum: + z = ecl_times(x->ratio.den, y); + z = ecl_plus(x->ratio.num, z); + return ecl_make_ratio(z, x->ratio.den); + case t_ratio: + z1 = ecl_times(x->ratio.num,y->ratio.den); + z = ecl_times(x->ratio.den,y->ratio.num); + z = ecl_plus(z1, z); + z1 = ecl_times(x->ratio.den,y->ratio.den); + return ecl_make_ratio(z, z1); + case t_singlefloat: + return ecl_make_single_float(ecl_to_double(x) + ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_to_double(x) + ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_to_double(x) + ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_to_double(x) + ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[+], 2, y, @[number]); - } - case t_singlefloat: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_single_float(ecl_single_float(x) + ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_single_float(ecl_single_float(x) + ecl_to_double(y)); - case t_singlefloat: - return ecl_make_single_float(ecl_single_float(x) + ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_single_float(x) + ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[+], 2, y, @[number]); + } + case t_singlefloat: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_single_float(ecl_single_float(x) + ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_single_float(ecl_single_float(x) + ecl_to_double(y)); + case t_singlefloat: + return ecl_make_single_float(ecl_single_float(x) + ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_single_float(x) + ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_single_float(x) + ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_single_float(x) + ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[+], 2, y, @[number]); - } - case t_doublefloat: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_double_float(ecl_double_float(x) + ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_double_float(ecl_double_float(x) + ecl_to_double(y)); - case t_singlefloat: - return ecl_make_double_float(ecl_double_float(x) + ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_double_float(x) + ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[+], 2, y, @[number]); + } + case t_doublefloat: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_double_float(ecl_double_float(x) + ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_double_float(ecl_double_float(x) + ecl_to_double(y)); + case t_singlefloat: + return ecl_make_double_float(ecl_double_float(x) + ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_double_float(x) + ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_double_float(x) + ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_double_float(x) + ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[+], 2, y, @[number]); - } + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[+], 2, y, @[number]); + } #ifdef ECL_LONG_FLOAT - case t_longfloat: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_long_float(ecl_long_float(x) + ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_long_float(ecl_long_float(x) + ecl_to_double(y)); - case t_singlefloat: - return ecl_make_long_float(ecl_long_float(x) + ecl_single_float(y)); - case t_doublefloat: - return ecl_make_long_float(ecl_long_float(x) + ecl_double_float(y)); - case t_longfloat: - return ecl_make_long_float(ecl_long_float(x) + ecl_long_float(y)); - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[+], 2, y, @[number]); - } + case t_longfloat: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_long_float(ecl_long_float(x) + ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_long_float(ecl_long_float(x) + ecl_to_double(y)); + case t_singlefloat: + return ecl_make_long_float(ecl_long_float(x) + ecl_single_float(y)); + case t_doublefloat: + return ecl_make_long_float(ecl_long_float(x) + ecl_double_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_long_float(x) + ecl_long_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[+], 2, y, @[number]); + } #endif - case t_complex: - if (ecl_t_of(y) != t_complex) { - cl_object aux = x; - x = y; y = aux; - goto COMPLEX; - } - z = ecl_plus(x->complex.real, y->complex.real); - z1 = ecl_plus(x->complex.imag, y->complex.imag); - return ecl_make_complex(z, z1); - default: - FEwrong_type_nth_arg(@[+], 1, x, @[number]); - } + case t_complex: + if (ecl_t_of(y) != t_complex) { + cl_object aux = x; + x = y; y = aux; + goto COMPLEX; + } + z = ecl_plus(x->complex.real, y->complex.real); + z1 = ecl_plus(x->complex.imag, y->complex.imag); + return ecl_make_complex(z, z1); + default: + FEwrong_type_nth_arg(@[+], 1, x, @[number]); + } } #endif diff -Nru ecl-16.1.2/src/c/numbers/plusp.d ecl-16.1.3+ds/src/c/numbers/plusp.d --- ecl-16.1.2/src/c/numbers/plusp.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/plusp.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - plusp.d -- Implementation of CL:PLUSP -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. + * plusp.d - implementation of CL:PLUSP + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - See file '../Copyright' for full details. -*/ #include #include @@ -23,43 +19,43 @@ cl_object cl_plusp(cl_object x) { /* INV: ecl_plusp() checks type */ - @(return (ecl_plusp(x) ? ECL_T : ECL_NIL)) + @(return (ecl_plusp(x) ? ECL_T : ECL_NIL)); } static int ecl_plusp_fixnum(cl_object x) { - return ecl_fixnum_plusp(x); + return ecl_fixnum_plusp(x); } static int ecl_plusp_big(cl_object x) { - return _ecl_big_sign(x) > 0; + return _ecl_big_sign(x) > 0; } static int ecl_plusp_ratio(cl_object x) { - return ecl_plusp(x->ratio.num); + return ecl_plusp(x->ratio.num); } static int ecl_plusp_single_float(cl_object x) { - return ecl_single_float(x) > 0; + return ecl_single_float(x) > 0; } static int ecl_plusp_double_float(cl_object x) { - return ecl_double_float(x) > 0; + return ecl_double_float(x) > 0; } #ifdef ECL_LONG_FLOAT static int ecl_plusp_long_float(cl_object x) { - return ecl_long_float(x) > 0; + return ecl_long_float(x) > 0; } #endif diff -Nru ecl-16.1.2/src/c/numbers/round.d ecl-16.1.3+ds/src/c/numbers/round.d --- ecl-16.1.2/src/c/numbers/round.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/round.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - round.d -- Implementation of CL:ROUND -*/ -/* - Copyright (c) 2010, Juan Jose Garcia Ripoll. - - ECL 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. + * round.d - implementation of CL:ROUND + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - See file '../../Copyright' for full details. -*/ #define ECL_INCLUDE_MATH_H #include @@ -26,142 +24,142 @@ #include @(defun round (x &optional (y OBJNULL)) -@ - if (narg == 1) - return ecl_round1(x); - else - return ecl_round2(x, y); -@) + @ + if (narg == 1) + return ecl_round1(x); + else + return ecl_round2(x, y); + @) static cl_object number_remainder(cl_object x, cl_object y, cl_object q) { - cl_object z; + cl_object z; - z = ecl_times(q, y); - z = ecl_minus(x, z); - return(z); + z = ecl_times(q, y); + z = ecl_minus(x, z); + return(z); } static double round_double(double d) { - if (d >= 0) { - double q = floor(d += 0.5); - if (q == d) { - int i = (int)fmod(q, 10); - if (i & 1) { - return q-1; - } - } - return q; - } else { - return -round_double(-d); - } + if (d >= 0) { + double q = floor(d += 0.5); + if (q == d) { + int i = (int)fmod(q, 10); + if (i & 1) { + return q-1; + } + } + return q; + } else { + return -round_double(-d); + } } #ifdef ECL_LONG_FLOAT static long double round_long_double(long double d) { - if (d >= 0) { - long double q = floorl(d += 0.5); - if (q == d) { - int i = (int)fmodl(q, 10); - if (i & 1) { - return q-1; - } - } - return q; - } else { - return -round_long_double(-d); - } + if (d >= 0) { + long double q = floorl(d += 0.5); + if (q == d) { + int i = (int)fmodl(q, 10); + if (i & 1) { + return q-1; + } + } + return q; + } else { + return -round_long_double(-d); + } } #endif static cl_object ecl_round2_integer(const cl_env_ptr the_env, cl_object x, cl_object y, cl_object q) { - cl_object q1 = ecl_integer_divide(q->ratio.num, q->ratio.den); - cl_object r = ecl_minus(q, q1); - if (ecl_minusp(r)) { - int c = ecl_number_compare(cl_core.minus_half, r); - if (c > 0 || (c == 0 && ecl_oddp(q1))) { - q1 = ecl_one_minus(q1); - } - } else { - int c = ecl_number_compare(r, cl_core.plus_half); - if (c > 0 || (c == 0 && ecl_oddp(q1))) { - q1 = ecl_one_plus(q1); - } - } - r = number_remainder(x, y, q1); - ecl_return2(the_env, q1, r); + cl_object q1 = ecl_integer_divide(q->ratio.num, q->ratio.den); + cl_object r = ecl_minus(q, q1); + if (ecl_minusp(r)) { + int c = ecl_number_compare(cl_core.minus_half, r); + if (c > 0 || (c == 0 && ecl_oddp(q1))) { + q1 = ecl_one_minus(q1); + } + } else { + int c = ecl_number_compare(r, cl_core.plus_half); + if (c > 0 || (c == 0 && ecl_oddp(q1))) { + q1 = ecl_one_plus(q1); + } + } + r = number_remainder(x, y, q1); + ecl_return2(the_env, q1, r); } cl_object ecl_round1(cl_object x) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object v0, v1; - switch (ecl_t_of(x)) { - case t_fixnum: - case t_bignum: - v0 = x; - v1 = ecl_make_fixnum(0); - break; - case t_ratio: - v0 = ecl_round2_integer(the_env, x->ratio.num, x->ratio.den, x); - v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), x->ratio.den); - break; - case t_singlefloat: { - float d = ecl_single_float(x); - float q = round_double(d); - v0 = _ecl_float_to_integer(q); - v1 = ecl_make_single_float(d - q); - break; - } - case t_doublefloat: { - double d = ecl_double_float(x); - double q = round_double(d); - v0 = _ecl_double_to_integer(q); - v1 = ecl_make_double_float(d - q); - break; - } + const cl_env_ptr the_env = ecl_process_env(); + cl_object v0, v1; + switch (ecl_t_of(x)) { + case t_fixnum: + case t_bignum: + v0 = x; + v1 = ecl_make_fixnum(0); + break; + case t_ratio: + v0 = ecl_round2_integer(the_env, x->ratio.num, x->ratio.den, x); + v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), x->ratio.den); + break; + case t_singlefloat: { + float d = ecl_single_float(x); + float q = round_double(d); + v0 = _ecl_float_to_integer(q); + v1 = ecl_make_single_float(d - q); + break; + } + case t_doublefloat: { + double d = ecl_double_float(x); + double q = round_double(d); + v0 = _ecl_double_to_integer(q); + v1 = ecl_make_double_float(d - q); + break; + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double d = ecl_long_float(x); - long double q = round_long_double(d); - v0 = _ecl_long_double_to_integer(q); - v1 = ecl_make_long_float(d - q); - break; - } + case t_longfloat: { + long double d = ecl_long_float(x); + long double q = round_long_double(d); + v0 = _ecl_long_double_to_integer(q); + v1 = ecl_make_long_float(d - q); + break; + } #endif - default: - FEwrong_type_nth_arg(@[round],1,x,@[real]); - } - ecl_return2(the_env, v0, v1); + default: + FEwrong_type_nth_arg(@[round],1,x,@[real]); + } + ecl_return2(the_env, v0, v1); } cl_object ecl_round2(cl_object x, cl_object y) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object v0, v1; - cl_object q; - - q = ecl_divide(x, y); - switch (ecl_t_of(q)) { - case t_fixnum: - case t_bignum: - v0 = q; - v1 = ecl_make_fixnum(0); - break; - case t_ratio: - return ecl_round2_integer(the_env, x, y, q); - default: - v0 = q = ecl_round1(q); - v1 = number_remainder(x, y, q); - } - ecl_return2(the_env, v0, v1); + const cl_env_ptr the_env = ecl_process_env(); + cl_object v0, v1; + cl_object q; + + q = ecl_divide(x, y); + switch (ecl_t_of(q)) { + case t_fixnum: + case t_bignum: + v0 = q; + v1 = ecl_make_fixnum(0); + break; + case t_ratio: + return ecl_round2_integer(the_env, x, y, q); + default: + v0 = q = ecl_round1(q); + v1 = number_remainder(x, y, q); + } + ecl_return2(the_env, v0, v1); } diff -Nru ecl-16.1.2/src/c/numbers/sin.d ecl-16.1.3+ds/src/c/numbers/sin.d --- ecl-16.1.2/src/c/numbers/sin.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/sin.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - sin.d -- Trascendental functions: sine -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. + * sin.d - trascendental functions: sine + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - See file '../Copyright' for full details. -*/ #define ECL_INCLUDE_MATH_H #include @@ -27,48 +23,48 @@ cl_object cl_sin(cl_object x) { - @(return ecl_sin(x)); + @(return ecl_sin(x)); } static cl_object ecl_sin_rational(cl_object x) { - return ecl_make_single_float(sinf(ecl_to_float(x))); + return ecl_make_single_float(sinf(ecl_to_float(x))); } static cl_object ecl_sin_single_float(cl_object x) { - return ecl_make_single_float(sinf(ecl_single_float(x))); + return ecl_make_single_float(sinf(ecl_single_float(x))); } static cl_object ecl_sin_double_float(cl_object x) { - return ecl_make_double_float(sin(ecl_double_float(x))); + return ecl_make_double_float(sin(ecl_double_float(x))); } #ifdef ECL_LONG_FLOAT static cl_object ecl_sin_long_float(cl_object x) { - return ecl_make_long_float(sinl(ecl_long_float(x))); + return ecl_make_long_float(sinl(ecl_long_float(x))); } #endif static cl_object ecl_sin_complex(cl_object x) { - /* - z = x + I y - z = x + I y - sin(z) = sinh(I z) = sinh(-y + I x) - */ - cl_object dx = x->complex.real; - cl_object dy = x->complex.imag; - cl_object a = ecl_times(ecl_sin(dx), ecl_cosh(dy)); - cl_object b = ecl_times(ecl_cos(dx), ecl_sinh(dy)); - return ecl_make_complex(a, b); + /* + z = x + I y + z = x + I y + sin(z) = sinh(I z) = sinh(-y + I x) + */ + cl_object dx = x->complex.real; + cl_object dy = x->complex.imag; + cl_object a = ecl_times(ecl_sin(dx), ecl_cosh(dy)); + cl_object b = ecl_times(ecl_cos(dx), ecl_sinh(dy)); + return ecl_make_complex(a, b); } MATH_DEF_DISPATCH1(sin, @[sin], @[number], diff -Nru ecl-16.1.2/src/c/numbers/sinh.d ecl-16.1.3+ds/src/c/numbers/sinh.d --- ecl-16.1.2/src/c/numbers/sinh.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/sinh.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - sinh.d -- Trascendental functions: hyperbolic sine -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. + * sinh.d - trascendental functions: hyperbolic sine + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - See file '../Copyright' for full details. -*/ #define ECL_INCLUDE_MATH_H #include @@ -27,49 +23,49 @@ cl_object cl_sinh(cl_object x) { - @(return ecl_sinh(x)); + @(return ecl_sinh(x)); } static cl_object ecl_sinh_rational(cl_object x) { - return ecl_make_single_float(sinhf(ecl_to_float(x))); + return ecl_make_single_float(sinhf(ecl_to_float(x))); } static cl_object ecl_sinh_single_float(cl_object x) { - return ecl_make_single_float(sinhf(ecl_single_float(x))); + return ecl_make_single_float(sinhf(ecl_single_float(x))); } static cl_object ecl_sinh_double_float(cl_object x) { - return ecl_make_double_float(sinh(ecl_double_float(x))); + return ecl_make_double_float(sinh(ecl_double_float(x))); } #ifdef ECL_LONG_FLOAT static cl_object ecl_sinh_long_float(cl_object x) { - return ecl_make_long_float(sinhl(ecl_long_float(x))); + return ecl_make_long_float(sinhl(ecl_long_float(x))); } #endif static cl_object ecl_sinh_complex(cl_object x) { - /* - z = x + I y - sinh(z) = (exp(z)-exp(-z))/2 - = (exp(x)*(cos(y)+Isin(y))-exp(-x)*(cos(y)-Isin(y)))/2 - = sinh(x)*cos(y) + Icosh(x)*sin(y); - */ - cl_object dx = x->complex.real; - cl_object dy = x->complex.imag; - cl_object a = ecl_times(ecl_sinh(dx), ecl_cos(dy)); - cl_object b = ecl_times(ecl_cosh(dx), ecl_sin(dy)); - return ecl_make_complex(a, b); + /* + z = x + I y + sinh(z) = (exp(z)-exp(-z))/2 + = (exp(x)*(cos(y)+Isin(y))-exp(-x)*(cos(y)-Isin(y)))/2 + = sinh(x)*cos(y) + Icosh(x)*sin(y); + */ + cl_object dx = x->complex.real; + cl_object dy = x->complex.imag; + cl_object a = ecl_times(ecl_sinh(dx), ecl_cos(dy)); + cl_object b = ecl_times(ecl_cosh(dx), ecl_sin(dy)); + return ecl_make_complex(a, b); } MATH_DEF_DISPATCH1(sinh, @[sinh], @[number], diff -Nru ecl-16.1.2/src/c/numbers/sqrt.d ecl-16.1.3+ds/src/c/numbers/sqrt.d --- ecl-16.1.2/src/c/numbers/sqrt.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/sqrt.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - sqrt.d -- Square root. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. + * sqrt.d - square root + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - See file '../Copyright' for full details. -*/ #define ECL_INCLUDE_MATH_H #include @@ -27,62 +23,62 @@ cl_object cl_sqrt(cl_object x) { - @(return ecl_sqrt(x)); + @(return ecl_sqrt(x)); } static cl_object ecl_sqrt_rational(cl_object x) { - if (ecl_minusp(x)) { - x = ecl_sqrt_rational(ecl_negate(x)); - return ecl_make_complex(ecl_make_fixnum(0), x); - } else { - return ecl_make_single_float(sqrtf(ecl_to_float(x))); - } + if (ecl_minusp(x)) { + x = ecl_sqrt_rational(ecl_negate(x)); + return ecl_make_complex(ecl_make_fixnum(0), x); + } else { + return ecl_make_single_float(sqrtf(ecl_to_float(x))); + } } static cl_object ecl_sqrt_single_float(cl_object x) { - float f = ecl_single_float(x); - if (f < 0) { - return ecl_make_complex(ecl_make_fixnum(0), - ecl_make_single_float(sqrtf(-f))); - } else { - return ecl_make_single_float(sqrtf(f)); - } + float f = ecl_single_float(x); + if (f < 0) { + return ecl_make_complex(ecl_make_fixnum(0), + ecl_make_single_float(sqrtf(-f))); + } else { + return ecl_make_single_float(sqrtf(f)); + } } static cl_object ecl_sqrt_double_float(cl_object x) { - double f = ecl_double_float(x); - if (f < 0) { - return ecl_make_complex(ecl_make_fixnum(0), - ecl_make_double_float(sqrt(-f))); - } else { - return ecl_make_double_float(sqrt(f)); - } + double f = ecl_double_float(x); + if (f < 0) { + return ecl_make_complex(ecl_make_fixnum(0), + ecl_make_double_float(sqrt(-f))); + } else { + return ecl_make_double_float(sqrt(f)); + } } #ifdef ECL_LONG_FLOAT static cl_object ecl_sqrt_long_float(cl_object x) { - long double f = ecl_long_float(x); - if (f < 0) { - return ecl_make_complex(ecl_make_fixnum(0), - ecl_make_long_float(sqrtl(-f))); - } else { - return ecl_make_long_float(sqrtl(f)); - } + long double f = ecl_long_float(x); + if (f < 0) { + return ecl_make_complex(ecl_make_fixnum(0), + ecl_make_long_float(sqrtl(-f))); + } else { + return ecl_make_long_float(sqrtl(f)); + } } #endif static cl_object ecl_sqrt_complex(cl_object x) { - return ecl_expt(x, cl_core.plus_half); + return ecl_expt(x, cl_core.plus_half); } MATH_DEF_DISPATCH1(sqrt, @[sqrt], @[number], diff -Nru ecl-16.1.2/src/c/numbers/tan.d ecl-16.1.3+ds/src/c/numbers/tan.d --- ecl-16.1.2/src/c/numbers/tan.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/tan.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - tan.d -- Trascendental functions: tangent -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. + * tan.d - trascendental functions: tangent + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - See file '../Copyright' for full details. -*/ #define ECL_INCLUDE_MATH_H #include @@ -41,41 +37,41 @@ cl_object cl_tan(cl_object x) { - @(return ecl_tan(x)); + @(return ecl_tan(x)); } static cl_object ecl_tan_rational(cl_object x) { - return ecl_make_single_float(safe_tanf(ecl_to_float(x))); + return ecl_make_single_float(safe_tanf(ecl_to_float(x))); } static cl_object ecl_tan_single_float(cl_object x) { - return ecl_make_single_float(safe_tanf(ecl_single_float(x))); + return ecl_make_single_float(safe_tanf(ecl_single_float(x))); } static cl_object ecl_tan_double_float(cl_object x) { - return ecl_make_double_float(tan(ecl_double_float(x))); + return ecl_make_double_float(tan(ecl_double_float(x))); } #ifdef ECL_LONG_FLOAT static cl_object ecl_tan_long_float(cl_object x) { - return ecl_make_long_float(tanl(ecl_long_float(x))); + return ecl_make_long_float(tanl(ecl_long_float(x))); } #endif static cl_object ecl_tan_complex(cl_object x) { - cl_object a = ecl_sin(x); - cl_object b = ecl_cos(x); - return ecl_divide(a, b); + cl_object a = ecl_sin(x); + cl_object b = ecl_cos(x); + return ecl_divide(a, b); } MATH_DEF_DISPATCH1(tan, @[tan], @[number], diff -Nru ecl-16.1.2/src/c/numbers/tanh.d ecl-16.1.3+ds/src/c/numbers/tanh.d --- ecl-16.1.2/src/c/numbers/tanh.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/tanh.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - tanh.d -- Trascendental functions: hyperbolic tangent -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. + * tanh.d - trascendental functions: hyperbolic tangent + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - See file '../Copyright' for full details. -*/ #define ECL_INCLUDE_MATH_H #include @@ -27,41 +23,41 @@ cl_object cl_tanh(cl_object x) { - @(return ecl_tanh(x)); + @(return ecl_tanh(x)); } static cl_object ecl_tanh_rational(cl_object x) { - return ecl_make_single_float(tanhf(ecl_to_float(x))); + return ecl_make_single_float(tanhf(ecl_to_float(x))); } static cl_object ecl_tanh_single_float(cl_object x) { - return ecl_make_single_float(tanhf(ecl_single_float(x))); + return ecl_make_single_float(tanhf(ecl_single_float(x))); } static cl_object ecl_tanh_double_float(cl_object x) { - return ecl_make_double_float(tanh(ecl_double_float(x))); + return ecl_make_double_float(tanh(ecl_double_float(x))); } #ifdef ECL_LONG_FLOAT static cl_object ecl_tanh_long_float(cl_object x) { - return ecl_make_long_float(tanhl(ecl_long_float(x))); + return ecl_make_long_float(tanhl(ecl_long_float(x))); } #endif static cl_object ecl_tanh_complex(cl_object x) { - cl_object a = ecl_sinh(x); - cl_object b = ecl_cosh(x); - return ecl_divide(a, b); + cl_object a = ecl_sinh(x); + cl_object b = ecl_cosh(x); + return ecl_divide(a, b); } MATH_DEF_DISPATCH1(tanh, @[tanh], @[number], diff -Nru ecl-16.1.2/src/c/numbers/times.d ecl-16.1.3+ds/src/c/numbers/times.d --- ecl-16.1.2/src/c/numbers/times.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/times.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,175 +1,173 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - times.d -- Implementation of CL:* -*/ -/* - Copyright (c) 2010, Juan Jose Garcia Ripoll. - - ECL 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. + * times.d - implementation of CL:* + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - See file '../../Copyright' for full details. -*/ #include #include @(defun * (&rest nums) - cl_object prod = ecl_make_fixnum(1); -@ - /* INV: type check in ecl_times() */ - while (narg--) - prod = ecl_times(prod, ecl_va_arg(nums)); - @(return prod) -@) + cl_object prod = ecl_make_fixnum(1); + @ + /* INV: type check in ecl_times() */ + while (narg--) + prod = ecl_times(prod, ecl_va_arg(nums)); + @(return prod); + @) #ifdef MATH_DISPATCH2_BEGIN cl_object ecl_times(cl_object x, cl_object y) { -MATH_DISPATCH2_BEGIN(x,y) -{ - CASE_FIXNUM_FIXNUM { - return _ecl_fix_times_fix(ecl_fixnum(x), ecl_fixnum(y)); - } - CASE_FIXNUM_BIGNUM { - return _ecl_big_times_fix(y, ecl_fixnum(x)); - } - CASE_FIXNUM_RATIO; - CASE_BIGNUM_RATIO { - return ecl_make_ratio(ecl_times(x, y->ratio.num), - y->ratio.den); - } - CASE_FIXNUM_SINGLE_FLOAT { - return ecl_make_single_float(ecl_fixnum(x) * ecl_single_float(y)); - } - CASE_FIXNUM_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_fixnum(x) * ecl_double_float(y)); - } - CASE_BIGNUM_FIXNUM { - return _ecl_big_times_fix(x, ecl_fixnum(y)); - } - CASE_BIGNUM_BIGNUM { - return _ecl_big_times_big(x, y); - } - CASE_BIGNUM_SINGLE_FLOAT { - return ecl_make_single_float(ecl_to_float(x) * ecl_single_float(y)); - } - CASE_BIGNUM_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_to_double(x) * ecl_double_float(y)); - } - CASE_RATIO_FIXNUM; - CASE_RATIO_BIGNUM { - cl_object z = ecl_times(x->ratio.num, y); - return ecl_make_ratio(z, x->ratio.den); - } - CASE_RATIO_RATIO { - cl_object num = ecl_times(x->ratio.num,y->ratio.num); - cl_object den = ecl_times(x->ratio.den,y->ratio.den); - return ecl_make_ratio(num, den); - } - CASE_RATIO_SINGLE_FLOAT { - return ecl_make_single_float(ecl_to_float(x) * ecl_single_float(y)); - } - CASE_RATIO_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_to_double(x) * ecl_double_float(y)); - } - CASE_SINGLE_FLOAT_FIXNUM { - return ecl_make_single_float(ecl_single_float(x) * ecl_fixnum(y)); - } - CASE_SINGLE_FLOAT_BIGNUM; - CASE_SINGLE_FLOAT_RATIO { - return ecl_make_single_float(ecl_single_float(x) * ecl_to_float(y)); - } - CASE_SINGLE_FLOAT_SINGLE_FLOAT { - return ecl_make_single_float(ecl_single_float(x) * ecl_single_float(y)); - } - CASE_SINGLE_FLOAT_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_single_float(x) * ecl_double_float(y)); - } - CASE_DOUBLE_FLOAT_FIXNUM { - return ecl_make_double_float(ecl_double_float(x) * ecl_fixnum(y)); - } - CASE_DOUBLE_FLOAT_BIGNUM; - CASE_DOUBLE_FLOAT_RATIO { - return ecl_make_double_float(ecl_double_float(x) * ecl_to_double(y)); - } - CASE_DOUBLE_FLOAT_SINGLE_FLOAT { - return ecl_make_double_float(ecl_double_float(x) * ecl_single_float(y)); - } - CASE_DOUBLE_FLOAT_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_double_float(x) * ecl_double_float(y)); - } + MATH_DISPATCH2_BEGIN(x,y) + { + CASE_FIXNUM_FIXNUM { + return _ecl_fix_times_fix(ecl_fixnum(x), ecl_fixnum(y)); + } + CASE_FIXNUM_BIGNUM { + return _ecl_big_times_fix(y, ecl_fixnum(x)); + } + CASE_FIXNUM_RATIO; + CASE_BIGNUM_RATIO { + return ecl_make_ratio(ecl_times(x, y->ratio.num), + y->ratio.den); + } + CASE_FIXNUM_SINGLE_FLOAT { + return ecl_make_single_float(ecl_fixnum(x) * ecl_single_float(y)); + } + CASE_FIXNUM_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_fixnum(x) * ecl_double_float(y)); + } + CASE_BIGNUM_FIXNUM { + return _ecl_big_times_fix(x, ecl_fixnum(y)); + } + CASE_BIGNUM_BIGNUM { + return _ecl_big_times_big(x, y); + } + CASE_BIGNUM_SINGLE_FLOAT { + return ecl_make_single_float(ecl_to_float(x) * ecl_single_float(y)); + } + CASE_BIGNUM_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_to_double(x) * ecl_double_float(y)); + } + CASE_RATIO_FIXNUM; + CASE_RATIO_BIGNUM { + cl_object z = ecl_times(x->ratio.num, y); + return ecl_make_ratio(z, x->ratio.den); + } + CASE_RATIO_RATIO { + cl_object num = ecl_times(x->ratio.num,y->ratio.num); + cl_object den = ecl_times(x->ratio.den,y->ratio.den); + return ecl_make_ratio(num, den); + } + CASE_RATIO_SINGLE_FLOAT { + return ecl_make_single_float(ecl_to_float(x) * ecl_single_float(y)); + } + CASE_RATIO_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_to_double(x) * ecl_double_float(y)); + } + CASE_SINGLE_FLOAT_FIXNUM { + return ecl_make_single_float(ecl_single_float(x) * ecl_fixnum(y)); + } + CASE_SINGLE_FLOAT_BIGNUM; + CASE_SINGLE_FLOAT_RATIO { + return ecl_make_single_float(ecl_single_float(x) * ecl_to_float(y)); + } + CASE_SINGLE_FLOAT_SINGLE_FLOAT { + return ecl_make_single_float(ecl_single_float(x) * ecl_single_float(y)); + } + CASE_SINGLE_FLOAT_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_single_float(x) * ecl_double_float(y)); + } + CASE_DOUBLE_FLOAT_FIXNUM { + return ecl_make_double_float(ecl_double_float(x) * ecl_fixnum(y)); + } + CASE_DOUBLE_FLOAT_BIGNUM; + CASE_DOUBLE_FLOAT_RATIO { + return ecl_make_double_float(ecl_double_float(x) * ecl_to_double(y)); + } + CASE_DOUBLE_FLOAT_SINGLE_FLOAT { + return ecl_make_double_float(ecl_double_float(x) * ecl_single_float(y)); + } + CASE_DOUBLE_FLOAT_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_double_float(x) * ecl_double_float(y)); + } #ifdef ECL_LONG_FLOAT - CASE_FIXNUM_LONG_FLOAT { - return ecl_make_long_float(ecl_fixnum(x) * ecl_long_float(y)); - } - CASE_BIGNUM_LONG_FLOAT; - CASE_RATIO_LONG_FLOAT { - return ecl_make_long_float(ecl_to_long_double(x) * ecl_long_float(y)); - } - CASE_SINGLE_FLOAT_LONG_FLOAT { - return ecl_make_long_float(ecl_single_float(x) * ecl_long_float(y)); - } - CASE_DOUBLE_FLOAT_LONG_FLOAT { - return ecl_make_long_float(ecl_double_float(x) * ecl_long_float(y)); - } - CASE_LONG_FLOAT_FIXNUM { - return ecl_make_long_float(ecl_long_float(x) * ecl_fixnum(y)); - } - CASE_LONG_FLOAT_BIGNUM; - CASE_LONG_FLOAT_RATIO { - return ecl_make_long_float(ecl_long_float(x) * ecl_to_long_double(y)); - } - CASE_LONG_FLOAT_SINGLE_FLOAT { - return ecl_make_long_float(ecl_long_float(x) * ecl_single_float(y)); - } - CASE_LONG_FLOAT_DOUBLE_FLOAT { - return ecl_make_long_float(ecl_long_float(x) * ecl_double_float(y)); - } - CASE_LONG_FLOAT_LONG_FLOAT { - return ecl_make_long_float(ecl_long_float(x) * ecl_long_float(y)); - } - CASE_LONG_FLOAT_COMPLEX { - goto COMPLEX_Y; - } - CASE_COMPLEX_LONG_FLOAT; { - goto COMPLEX_X; - } + CASE_FIXNUM_LONG_FLOAT { + return ecl_make_long_float(ecl_fixnum(x) * ecl_long_float(y)); + } + CASE_BIGNUM_LONG_FLOAT; + CASE_RATIO_LONG_FLOAT { + return ecl_make_long_float(ecl_to_long_double(x) * ecl_long_float(y)); + } + CASE_SINGLE_FLOAT_LONG_FLOAT { + return ecl_make_long_float(ecl_single_float(x) * ecl_long_float(y)); + } + CASE_DOUBLE_FLOAT_LONG_FLOAT { + return ecl_make_long_float(ecl_double_float(x) * ecl_long_float(y)); + } + CASE_LONG_FLOAT_FIXNUM { + return ecl_make_long_float(ecl_long_float(x) * ecl_fixnum(y)); + } + CASE_LONG_FLOAT_BIGNUM; + CASE_LONG_FLOAT_RATIO { + return ecl_make_long_float(ecl_long_float(x) * ecl_to_long_double(y)); + } + CASE_LONG_FLOAT_SINGLE_FLOAT { + return ecl_make_long_float(ecl_long_float(x) * ecl_single_float(y)); + } + CASE_LONG_FLOAT_DOUBLE_FLOAT { + return ecl_make_long_float(ecl_long_float(x) * ecl_double_float(y)); + } + CASE_LONG_FLOAT_LONG_FLOAT { + return ecl_make_long_float(ecl_long_float(x) * ecl_long_float(y)); + } + CASE_LONG_FLOAT_COMPLEX { + goto COMPLEX_Y; + } + CASE_COMPLEX_LONG_FLOAT; { + goto COMPLEX_X; + } #endif - CASE_COMPLEX_FIXNUM; - CASE_COMPLEX_BIGNUM; - CASE_COMPLEX_RATIO; - CASE_COMPLEX_SINGLE_FLOAT; - CASE_COMPLEX_DOUBLE_FLOAT; COMPLEX_X: { - cl_object aux = x; - x = y; y = aux; - goto COMPLEX_Y; - } - CASE_BIGNUM_COMPLEX; - CASE_RATIO_COMPLEX; - CASE_SINGLE_FLOAT_COMPLEX; - CASE_DOUBLE_FLOAT_COMPLEX; - CASE_FIXNUM_COMPLEX { - COMPLEX_Y: - return ecl_make_complex(ecl_times(x, y->complex.real), - ecl_times(x, y->complex.imag)); - } - CASE_COMPLEX_COMPLEX { - cl_object z11 = ecl_times(x->complex.real, y->complex.real); - cl_object z12 = ecl_times(x->complex.imag, y->complex.imag); - cl_object z21 = ecl_times(x->complex.imag, y->complex.real); - cl_object z22 = ecl_times(x->complex.real, y->complex.imag); - return ecl_make_complex(ecl_minus(z11, z12), ecl_plus(z21, z22)); - } - CASE_UNKNOWN(@[*],x,y,@[number]); -} -MATH_DISPATCH2_END; + CASE_COMPLEX_FIXNUM; + CASE_COMPLEX_BIGNUM; + CASE_COMPLEX_RATIO; + CASE_COMPLEX_SINGLE_FLOAT; + CASE_COMPLEX_DOUBLE_FLOAT; COMPLEX_X: { + cl_object aux = x; + x = y; y = aux; + goto COMPLEX_Y; + } + CASE_BIGNUM_COMPLEX; + CASE_RATIO_COMPLEX; + CASE_SINGLE_FLOAT_COMPLEX; + CASE_DOUBLE_FLOAT_COMPLEX; + CASE_FIXNUM_COMPLEX { + COMPLEX_Y: + return ecl_make_complex(ecl_times(x, y->complex.real), + ecl_times(x, y->complex.imag)); + } + CASE_COMPLEX_COMPLEX { + cl_object z11 = ecl_times(x->complex.real, y->complex.real); + cl_object z12 = ecl_times(x->complex.imag, y->complex.imag); + cl_object z21 = ecl_times(x->complex.imag, y->complex.real); + cl_object z22 = ecl_times(x->complex.real, y->complex.imag); + return ecl_make_complex(ecl_minus(z11, z12), ecl_plus(z21, z22)); + } + CASE_UNKNOWN(@[*],x,y,@[number]); + } + MATH_DISPATCH2_END; } #else @@ -177,162 +175,162 @@ cl_object ecl_times(cl_object x, cl_object y) { - cl_object z, z1; + cl_object z, z1; - switch (ecl_t_of(x)) { - case t_fixnum: - switch (ecl_t_of(y)) { - case t_fixnum: - return _ecl_fix_times_fix(ecl_fixnum(x),ecl_fixnum(y)); - case t_bignum: - return _ecl_big_times_fix(y, ecl_fixnum(x)); - case t_ratio: - z = ecl_times(x, y->ratio.num); - return ecl_make_ratio(z, y->ratio.den); - case t_singlefloat: - return ecl_make_single_float(ecl_fixnum(x) * ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_fixnum(x) * ecl_double_float(y)); + switch (ecl_t_of(x)) { + case t_fixnum: + switch (ecl_t_of(y)) { + case t_fixnum: + return _ecl_fix_times_fix(ecl_fixnum(x),ecl_fixnum(y)); + case t_bignum: + return _ecl_big_times_fix(y, ecl_fixnum(x)); + case t_ratio: + z = ecl_times(x, y->ratio.num); + return ecl_make_ratio(z, y->ratio.den); + case t_singlefloat: + return ecl_make_single_float(ecl_fixnum(x) * ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_fixnum(x) * ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_fixnum(x) * ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_fixnum(x) * ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[*], 2, y, @[number]); - } - case t_bignum: - switch (ecl_t_of(y)) { - case t_fixnum: - return _ecl_big_times_fix(x, ecl_fixnum(y)); - case t_bignum: - return _ecl_big_times_big(x, y); - case t_ratio: - z = ecl_times(x, y->ratio.num); - return ecl_make_ratio(z, y->ratio.den); - case t_singlefloat: - return ecl_make_single_float(ecl_to_double(x) * ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_to_double(x) * ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[*], 2, y, @[number]); + } + case t_bignum: + switch (ecl_t_of(y)) { + case t_fixnum: + return _ecl_big_times_fix(x, ecl_fixnum(y)); + case t_bignum: + return _ecl_big_times_big(x, y); + case t_ratio: + z = ecl_times(x, y->ratio.num); + return ecl_make_ratio(z, y->ratio.den); + case t_singlefloat: + return ecl_make_single_float(ecl_to_double(x) * ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_to_double(x) * ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_to_double(x) * ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_to_double(x) * ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[*], 2, y, @[number]); - } - case t_ratio: - switch (ecl_t_of(y)) { - case t_fixnum: - case t_bignum: - z = ecl_times(x->ratio.num, y); - return ecl_make_ratio(z, x->ratio.den); - case t_ratio: - z = ecl_times(x->ratio.num,y->ratio.num); - z1 = ecl_times(x->ratio.den,y->ratio.den); - return ecl_make_ratio(z, z1); - case t_singlefloat: - return ecl_make_single_float(ecl_to_double(x) * ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_to_double(x) * ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[*], 2, y, @[number]); + } + case t_ratio: + switch (ecl_t_of(y)) { + case t_fixnum: + case t_bignum: + z = ecl_times(x->ratio.num, y); + return ecl_make_ratio(z, x->ratio.den); + case t_ratio: + z = ecl_times(x->ratio.num,y->ratio.num); + z1 = ecl_times(x->ratio.den,y->ratio.den); + return ecl_make_ratio(z, z1); + case t_singlefloat: + return ecl_make_single_float(ecl_to_double(x) * ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_to_double(x) * ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_to_double(x) * ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_to_double(x) * ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[*], 2, y, @[number]); - } - case t_singlefloat: { - float fx = ecl_single_float(x); - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_single_float(fx * ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_single_float(fx * ecl_to_double(y)); - case t_singlefloat: - return ecl_make_single_float(fx * ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(fx * ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[*], 2, y, @[number]); + } + case t_singlefloat: { + float fx = ecl_single_float(x); + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_single_float(fx * ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_single_float(fx * ecl_to_double(y)); + case t_singlefloat: + return ecl_make_single_float(fx * ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(fx * ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(fx * ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(fx * ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[*], 2, y, @[number]); - } - } - case t_doublefloat: { - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_double_float(ecl_double_float(x) * ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_double_float(ecl_double_float(x) * ecl_to_double(y)); - case t_singlefloat: - return ecl_make_double_float(ecl_double_float(x) * ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_double_float(x) * ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[*], 2, y, @[number]); + } + } + case t_doublefloat: { + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_double_float(ecl_double_float(x) * ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_double_float(ecl_double_float(x) * ecl_to_double(y)); + case t_singlefloat: + return ecl_make_double_float(ecl_double_float(x) * ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_double_float(x) * ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_double_float(x) * ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_double_float(x) * ecl_long_float(y)); #endif - case t_complex: { - COMPLEX: /* INV: x is real, y is complex */ - return ecl_make_complex(ecl_times(x, y->complex.real), - ecl_times(x, y->complex.imag)); - } - default: - FEwrong_type_nth_arg(@[*], 2, y, @[number]); - } - } + case t_complex: { + COMPLEX: /* INV: x is real, y is complex */ + return ecl_make_complex(ecl_times(x, y->complex.real), + ecl_times(x, y->complex.imag)); + } + default: + FEwrong_type_nth_arg(@[*], 2, y, @[number]); + } + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double lx = ecl_long_float(x); - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_long_float(lx * ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_long_float(lx * ecl_to_double(y)); - case t_singlefloat: - return ecl_make_long_float(lx * ecl_single_float(y)); - case t_doublefloat: - return ecl_make_long_float(lx * ecl_double_float(y)); - case t_longfloat: - return ecl_make_long_float(lx * ecl_long_float(y)); - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[*], 2, y, @[number]); - } - } + case t_longfloat: { + long double lx = ecl_long_float(x); + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_long_float(lx * ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_long_float(lx * ecl_to_double(y)); + case t_singlefloat: + return ecl_make_long_float(lx * ecl_single_float(y)); + case t_doublefloat: + return ecl_make_long_float(lx * ecl_double_float(y)); + case t_longfloat: + return ecl_make_long_float(lx * ecl_long_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[*], 2, y, @[number]); + } + } #endif - case t_complex: - { - cl_object z11, z12, z21, z22; - - if (ecl_t_of(y) != t_complex) { - cl_object aux = x; - x = y; y = aux; - goto COMPLEX; - } - z11 = ecl_times(x->complex.real, y->complex.real); - z12 = ecl_times(x->complex.imag, y->complex.imag); - z21 = ecl_times(x->complex.imag, y->complex.real); - z22 = ecl_times(x->complex.real, y->complex.imag); - return ecl_make_complex(ecl_minus(z11, z12), ecl_plus(z21, z22)); - } - default: - FEwrong_type_nth_arg(@[*], 1, x, @[number]); - } + case t_complex: + { + cl_object z11, z12, z21, z22; + + if (ecl_t_of(y) != t_complex) { + cl_object aux = x; + x = y; y = aux; + goto COMPLEX; + } + z11 = ecl_times(x->complex.real, y->complex.real); + z12 = ecl_times(x->complex.imag, y->complex.imag); + z21 = ecl_times(x->complex.imag, y->complex.real); + z22 = ecl_times(x->complex.real, y->complex.imag); + return ecl_make_complex(ecl_minus(z11, z12), ecl_plus(z21, z22)); + } + default: + FEwrong_type_nth_arg(@[*], 1, x, @[number]); + } } #endif diff -Nru ecl-16.1.2/src/c/numbers/truncate.d ecl-16.1.3+ds/src/c/numbers/truncate.d --- ecl-16.1.2/src/c/numbers/truncate.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/truncate.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - truncate.d -- Implementation of CL:TRUNCATE -*/ -/* - Copyright (c) 2010, Juan Jose Garcia Ripoll. - - ECL 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. + * truncate.d - implementation of CL:TRUNCATE + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - See file '../../Copyright' for full details. -*/ #define ECL_INCLUDE_MATH_H #include @@ -27,63 +25,63 @@ cl_object ecl_truncate1(cl_object x) { - cl_object v0, v1; - switch (ecl_t_of(x)) { - case t_fixnum: - case t_bignum: - v0 = x; - v1 = ecl_make_fixnum(0); - break; - case t_ratio: - if (ecl_plusp(x->ratio.num)) - return ecl_floor1(x); - else - return ecl_ceiling1(x); - case t_singlefloat: { - float d = ecl_single_float(x); - float y = d > 0? floorf(d) : ceilf(d); - v0 = _ecl_float_to_integer(y); - v1 = ecl_make_single_float(d - y); - break; - } - case t_doublefloat: { - double d = ecl_double_float(x); - double y = d > 0? floor(d) : ceil(d); - v0 = _ecl_double_to_integer(y); - v1 = ecl_make_double_float(d - y); - break; - } + cl_object v0, v1; + switch (ecl_t_of(x)) { + case t_fixnum: + case t_bignum: + v0 = x; + v1 = ecl_make_fixnum(0); + break; + case t_ratio: + if (ecl_plusp(x->ratio.num)) + return ecl_floor1(x); + else + return ecl_ceiling1(x); + case t_singlefloat: { + float d = ecl_single_float(x); + float y = d > 0? floorf(d) : ceilf(d); + v0 = _ecl_float_to_integer(y); + v1 = ecl_make_single_float(d - y); + break; + } + case t_doublefloat: { + double d = ecl_double_float(x); + double y = d > 0? floor(d) : ceil(d); + v0 = _ecl_double_to_integer(y); + v1 = ecl_make_double_float(d - y); + break; + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double d = ecl_long_float(x); - long double y = d > 0? floorl(d) : ceill(d); - v0 = _ecl_long_double_to_integer(y); - v1 = ecl_make_long_float(d - y); - break; - } + case t_longfloat: { + long double d = ecl_long_float(x); + long double y = d > 0? floorl(d) : ceill(d); + v0 = _ecl_long_double_to_integer(y); + v1 = ecl_make_long_float(d - y); + break; + } #endif - default: - FEwrong_type_nth_arg(@[truncate],1,x,@[real]); - } - { - const cl_env_ptr the_env = ecl_process_env(); - ecl_return2(the_env, v0, v1); - } + default: + FEwrong_type_nth_arg(@[truncate],1,x,@[real]); + } + { + const cl_env_ptr the_env = ecl_process_env(); + ecl_return2(the_env, v0, v1); + } } cl_object ecl_truncate2(cl_object x, cl_object y) { - if (ecl_plusp(x) != ecl_plusp(y)) - return ecl_ceiling2(x, y); - else - return ecl_floor2(x, y); + if (ecl_plusp(x) != ecl_plusp(y)) + return ecl_ceiling2(x, y); + else + return ecl_floor2(x, y); } @(defun truncate (x &optional (y OBJNULL)) -@ - if (narg == 1) - return ecl_truncate1(x); - else - return ecl_truncate2(x, y); -@) + @ + if (narg == 1) + return ecl_truncate1(x); + else + return ecl_truncate2(x, y); + @) diff -Nru ecl-16.1.2/src/c/numbers/zerop.d ecl-16.1.3+ds/src/c/numbers/zerop.d --- ecl-16.1.2/src/c/numbers/zerop.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/numbers/zerop.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - zerop.d -- Implementation of CL:ZEROP -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. + * zerop.d - implementation of CL:ZEROP + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - See file '../Copyright' for full details. -*/ #include #include @@ -23,44 +19,44 @@ cl_object cl_zerop(cl_object x) { /* INV: ecl_zerop() checks type */ - @(return (ecl_zerop(x) ? ECL_T : ECL_NIL)) + @(return (ecl_zerop(x) ? ECL_T : ECL_NIL)); } static int ecl_zerop_fixnum(cl_object x) { - return x == ecl_make_fixnum(0); + return x == ecl_make_fixnum(0); } static int ecl_zerop_ratio(cl_object x) { - return 0; + return 0; } static int ecl_zerop_single_float(cl_object x) { - return ecl_single_float(x) == 0; + return ecl_single_float(x) == 0; } static int ecl_zerop_double_float(cl_object x) { - return ecl_double_float(x) == 0; + return ecl_double_float(x) == 0; } #ifdef ECL_LONG_FLOAT static int ecl_zerop_long_float(cl_object x) { - return ecl_long_float(x) == 0; + return ecl_long_float(x) == 0; } #endif static int ecl_zerop_complex(cl_object x) { - return ecl_zerop(x->complex.real) && ecl_zerop(x->complex.imag); + return ecl_zerop(x->complex.real) && ecl_zerop(x->complex.imag); } MATH_DEF_DISPATCH1_BOOL(zerop, @[zerop], @[number], diff -Nru ecl-16.1.2/src/c/num_co.d ecl-16.1.3+ds/src/c/num_co.d --- ecl-16.1.2/src/c/num_co.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/num_co.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,27 +1,22 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - num_co.c -- Operations on floating-point numbers. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * num_co.d - operations on floating-point numbers + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ /* - IMPLEMENTATION-DEPENDENT + IMPLEMENTATION-DEPENDENT - This file contains those functions - that know the representation of floating-point numbers. + This file contains those functions + that know the representation of floating-point numbers. */ #define ECL_INCLUDE_MATH_H @@ -48,439 +43,439 @@ otherwise coerce to same float type as second arg */ @(defun float (x &optional (y OBJNULL)) - cl_type ty, tx; -@ - if (y != OBJNULL) { - ty = ecl_t_of(y); - } else { - ty = t_singlefloat; - } - switch (tx = ecl_t_of(x)) { - case t_singlefloat: - case t_doublefloat: -#ifdef ECL_LONG_FLOAT - case t_longfloat: -#endif - if (y == OBJNULL || ty == tx) - break; - case t_fixnum: - case t_bignum: - case t_ratio: - switch (ty) { - case t_singlefloat: - x = ecl_make_single_float(ecl_to_double(x)); break; - case t_doublefloat: - x = ecl_make_double_float(ecl_to_double(x)); break; -#ifdef ECL_LONG_FLOAT - case t_longfloat: - x = ecl_make_long_float(ecl_to_long_double(x)); break; -#endif - default: - FEwrong_type_nth_arg(@[float],2,y,@[float]); - } - break; - default: - FEwrong_type_nth_arg(@[float],1,x,@[real]); - } - @(return x) -@) + cl_type ty, tx; + @ + if (y != OBJNULL) { + ty = ecl_t_of(y); + } else { + ty = t_singlefloat; + } + switch (tx = ecl_t_of(x)) { + case t_singlefloat: + case t_doublefloat: +#ifdef ECL_LONG_FLOAT + case t_longfloat: +#endif + if (y == OBJNULL || ty == tx) + break; + case t_fixnum: + case t_bignum: + case t_ratio: + switch (ty) { + case t_singlefloat: + x = ecl_make_single_float(ecl_to_double(x)); break; + case t_doublefloat: + x = ecl_make_double_float(ecl_to_double(x)); break; +#ifdef ECL_LONG_FLOAT + case t_longfloat: + x = ecl_make_long_float(ecl_to_long_double(x)); break; +#endif + default: + FEwrong_type_nth_arg(@[float],2,y,@[float]); + } + break; + default: + FEwrong_type_nth_arg(@[float],1,x,@[real]); + } + @(return x) + @) cl_object cl_numerator(cl_object x) { - switch (ecl_t_of(x)) { - case t_ratio: - x = x->ratio.num; - break; - case t_fixnum: - case t_bignum: - break; - default: - FEwrong_type_nth_arg(@[numerator],1,x,@[rational]); - } - @(return x) -} + switch (ecl_t_of(x)) { + case t_ratio: + x = x->ratio.num; + break; + case t_fixnum: + case t_bignum: + break; + default: + FEwrong_type_nth_arg(@[numerator],1,x,@[rational]); + } + @(return x) + } cl_object cl_denominator(cl_object x) { - switch (ecl_t_of(x)) { - case t_ratio: - x = x->ratio.den; - break; - case t_fixnum: - case t_bignum: - x = ecl_make_fixnum(1); - break; - default: - FEwrong_type_nth_arg(@[numerator],1,x,@[rational]); - } - @(return x) -} + switch (ecl_t_of(x)) { + case t_ratio: + x = x->ratio.den; + break; + case t_fixnum: + case t_bignum: + x = ecl_make_fixnum(1); + break; + default: + FEwrong_type_nth_arg(@[numerator],1,x,@[rational]); + } + @(return x) + } cl_object cl_mod(cl_object x, cl_object y) { - const cl_env_ptr the_env = ecl_process_env(); - /* INV: #'floor always outputs two values */ - @floor(2, x, y); - ecl_return1(the_env, the_env->values[1]); + const cl_env_ptr the_env = ecl_process_env(); + /* INV: #'floor always outputs two values */ + @floor(2, x, y); + ecl_return1(the_env, the_env->values[1]); } cl_object cl_rem(cl_object x, cl_object y) { - const cl_env_ptr the_env = ecl_process_env(); - @truncate(2, x, y); - ecl_return1(the_env, the_env->values[1]); + const cl_env_ptr the_env = ecl_process_env(); + @truncate(2, x, y); + ecl_return1(the_env, the_env->values[1]); } cl_object cl_decode_float(cl_object x) { - const cl_env_ptr the_env = ecl_process_env(); - int e, s; - cl_type tx = ecl_t_of(x); - float f; - - switch (tx) { - case t_singlefloat: { - f = ecl_single_float(x); - if (f >= 0.0) { - s = 1; - } else { - f = -f; - s = 0; - } - f = frexpf(f, &e); - x = ecl_make_single_float(f); - break; - } - case t_doublefloat: { - double d = ecl_double_float(x); - if (d >= 0.0) { - s = 1; - } else { - d = -d; - s = 0; - } - d = frexp(d, &e); - x = ecl_make_double_float(d); - break; - } -#ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double d = ecl_long_float(x); - if (d >= 0.0) - s = 1; - else { - d = -d; - s = 0; - } - d = frexpl(d, &e); - x = ecl_make_long_float(d); - break; - } -#endif - default: - FEwrong_type_nth_arg(@[decode-float],1,x,@[float]); - } - ecl_return3(the_env, x, ecl_make_fixnum(e), ecl_make_single_float(s)); + const cl_env_ptr the_env = ecl_process_env(); + int e, s; + cl_type tx = ecl_t_of(x); + float f; + + switch (tx) { + case t_singlefloat: { + f = ecl_single_float(x); + if (f >= 0.0) { + s = 1; + } else { + f = -f; + s = 0; + } + f = frexpf(f, &e); + x = ecl_make_single_float(f); + break; + } + case t_doublefloat: { + double d = ecl_double_float(x); + if (d >= 0.0) { + s = 1; + } else { + d = -d; + s = 0; + } + d = frexp(d, &e); + x = ecl_make_double_float(d); + break; + } +#ifdef ECL_LONG_FLOAT + case t_longfloat: { + long double d = ecl_long_float(x); + if (d >= 0.0) + s = 1; + else { + d = -d; + s = 0; + } + d = frexpl(d, &e); + x = ecl_make_long_float(d); + break; + } +#endif + default: + FEwrong_type_nth_arg(@[decode-float],1,x,@[float]); + } + ecl_return3(the_env, x, ecl_make_fixnum(e), ecl_make_single_float(s)); } cl_object cl_scale_float(cl_object x, cl_object y) { - const cl_env_ptr the_env = ecl_process_env(); - cl_fixnum k; + const cl_env_ptr the_env = ecl_process_env(); + cl_fixnum k; - if (ECL_FIXNUMP(y)) { - k = ecl_fixnum(y); - } else { - FEwrong_type_nth_arg(@[scale-float],2,y,@[fixnum]); - } - switch (ecl_t_of(x)) { - case t_singlefloat: - x = ecl_make_single_float(ldexpf(ecl_single_float(x), k)); - break; - case t_doublefloat: - x = ecl_make_double_float(ldexp(ecl_double_float(x), k)); - break; -#ifdef ECL_LONG_FLOAT - case t_longfloat: - x = ecl_make_long_float(ldexpl(ecl_long_float(x), k)); - break; -#endif - default: - FEwrong_type_nth_arg(@[scale-float],1,x,@[float]); - } - ecl_return1(the_env, x); + if (ECL_FIXNUMP(y)) { + k = ecl_fixnum(y); + } else { + FEwrong_type_nth_arg(@[scale-float],2,y,@[fixnum]); + } + switch (ecl_t_of(x)) { + case t_singlefloat: + x = ecl_make_single_float(ldexpf(ecl_single_float(x), k)); + break; + case t_doublefloat: + x = ecl_make_double_float(ldexp(ecl_double_float(x), k)); + break; +#ifdef ECL_LONG_FLOAT + case t_longfloat: + x = ecl_make_long_float(ldexpl(ecl_long_float(x), k)); + break; +#endif + default: + FEwrong_type_nth_arg(@[scale-float],1,x,@[float]); + } + ecl_return1(the_env, x); } cl_object cl_float_radix(cl_object x) { - const cl_env_ptr the_env = ecl_process_env(); - if (ecl_unlikely(cl_floatp(x) != ECL_T)) { - FEwrong_type_nth_arg(@[float-radix],1,x,@[float]); - } - ecl_return1(the_env, ecl_make_fixnum(FLT_RADIX)); + const cl_env_ptr the_env = ecl_process_env(); + if (ecl_unlikely(cl_floatp(x) != ECL_T)) { + FEwrong_type_nth_arg(@[float-radix],1,x,@[float]); + } + ecl_return1(the_env, ecl_make_fixnum(FLT_RADIX)); } int ecl_signbit(cl_object x) { - switch (ecl_t_of(x)) { - case t_singlefloat: - return signbit(ecl_single_float(x)); - case t_doublefloat: - return signbit(ecl_double_float(x)); -#ifdef ECL_LONG_FLOAT - case t_longfloat: - return signbit(ecl_long_float(x)); -#endif - default: - FEwrong_type_nth_arg(@[float-sign],1,x,@[float]); - } + switch (ecl_t_of(x)) { + case t_singlefloat: + return signbit(ecl_single_float(x)); + case t_doublefloat: + return signbit(ecl_double_float(x)); +#ifdef ECL_LONG_FLOAT + case t_longfloat: + return signbit(ecl_long_float(x)); +#endif + default: + FEwrong_type_nth_arg(@[float-sign],1,x,@[float]); + } } @(defun float_sign (x &optional (y x yp)) - int negativep; -@ - if (!yp) { - y = cl_float(2, ecl_make_fixnum(1), x); - } - negativep = ecl_signbit(x); - switch (ecl_t_of(y)) { - case t_singlefloat: { - float f = ecl_single_float(y); - if (signbit(f) != negativep) y = ecl_make_single_float(-f); - break; - } - case t_doublefloat: { - double f = ecl_double_float(y); - if (signbit(f) != negativep) y = ecl_make_double_float(-f); - break; - } -#ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double f = ecl_long_float(y); - if (signbit(f) != negativep) y = ecl_make_long_float(-f); - break; - } -#endif - default: - FEwrong_type_nth_arg(@[float-sign],2,y,@[float]); - } - @(return y); -@) + int negativep; + @ + if (!yp) { + y = cl_float(2, ecl_make_fixnum(1), x); + } + negativep = ecl_signbit(x); + switch (ecl_t_of(y)) { + case t_singlefloat: { + float f = ecl_single_float(y); + if (signbit(f) != negativep) y = ecl_make_single_float(-f); + break; + } + case t_doublefloat: { + double f = ecl_double_float(y); + if (signbit(f) != negativep) y = ecl_make_double_float(-f); + break; + } +#ifdef ECL_LONG_FLOAT + case t_longfloat: { + long double f = ecl_long_float(y); + if (signbit(f) != negativep) y = ecl_make_long_float(-f); + break; + } +#endif + default: + FEwrong_type_nth_arg(@[float-sign],2,y,@[float]); + } + @(return y); + @) cl_object cl_float_digits(cl_object x) { - const cl_env_ptr the_env = ecl_process_env(); - switch (ecl_t_of(x)) { - case t_singlefloat: - x = ecl_make_fixnum(FLT_MANT_DIG); - break; - case t_doublefloat: - x = ecl_make_fixnum(DBL_MANT_DIG); - break; -#ifdef ECL_LONG_FLOAT - case t_longfloat: - x = ecl_make_fixnum(LDBL_MANT_DIG); - break; -#endif - default: - FEwrong_type_nth_arg(@[float-digits],1,x,@[float]); - } - ecl_return1(the_env, x); + const cl_env_ptr the_env = ecl_process_env(); + switch (ecl_t_of(x)) { + case t_singlefloat: + x = ecl_make_fixnum(FLT_MANT_DIG); + break; + case t_doublefloat: + x = ecl_make_fixnum(DBL_MANT_DIG); + break; +#ifdef ECL_LONG_FLOAT + case t_longfloat: + x = ecl_make_fixnum(LDBL_MANT_DIG); + break; +#endif + default: + FEwrong_type_nth_arg(@[float-digits],1,x,@[float]); + } + ecl_return1(the_env, x); } cl_object cl_float_precision(cl_object x) { - const cl_env_ptr the_env = ecl_process_env(); - int precision; - switch (ecl_t_of(x)) { - case t_singlefloat: { - float f = ecl_single_float(x); - if (f == 0.0) { - precision = 0; - } else { - int exp; - frexpf(f, &exp); - if (exp >= FLT_MIN_EXP) { - precision = FLT_MANT_DIG; - } else { - precision = FLT_MANT_DIG - (FLT_MIN_EXP - exp); - } - } - break; - } - case t_doublefloat: { - double f = ecl_double_float(x); - if (f == 0.0) { - precision = 0; - } else { - int exp; - frexp(f, &exp); - if (exp >= DBL_MIN_EXP) { - precision = DBL_MANT_DIG; - } else { - precision = DBL_MANT_DIG - (DBL_MIN_EXP - exp); - } - } - break; - } -#ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double f = ecl_long_float(x); - if (f == 0.0) { - precision = 0; - } else { - int exp; - frexp(f, &exp); - if (exp >= LDBL_MIN_EXP) { - precision = LDBL_MANT_DIG; - } else { - precision = LDBL_MANT_DIG - (LDBL_MIN_EXP - exp); - } - } - break; - } -#endif - default: - FEwrong_type_nth_arg(@[float-precision],1,x,@[float]); - } - ecl_return1(the_env, ecl_make_fixnum(precision)); + const cl_env_ptr the_env = ecl_process_env(); + int precision; + switch (ecl_t_of(x)) { + case t_singlefloat: { + float f = ecl_single_float(x); + if (f == 0.0) { + precision = 0; + } else { + int exp; + frexpf(f, &exp); + if (exp >= FLT_MIN_EXP) { + precision = FLT_MANT_DIG; + } else { + precision = FLT_MANT_DIG - (FLT_MIN_EXP - exp); + } + } + break; + } + case t_doublefloat: { + double f = ecl_double_float(x); + if (f == 0.0) { + precision = 0; + } else { + int exp; + frexp(f, &exp); + if (exp >= DBL_MIN_EXP) { + precision = DBL_MANT_DIG; + } else { + precision = DBL_MANT_DIG - (DBL_MIN_EXP - exp); + } + } + break; + } +#ifdef ECL_LONG_FLOAT + case t_longfloat: { + long double f = ecl_long_float(x); + if (f == 0.0) { + precision = 0; + } else { + int exp; + frexp(f, &exp); + if (exp >= LDBL_MIN_EXP) { + precision = LDBL_MANT_DIG; + } else { + precision = LDBL_MANT_DIG - (LDBL_MIN_EXP - exp); + } + } + break; + } +#endif + default: + FEwrong_type_nth_arg(@[float-precision],1,x,@[float]); + } + ecl_return1(the_env, ecl_make_fixnum(precision)); } cl_object cl_integer_decode_float(cl_object x) { - const cl_env_ptr the_env = ecl_process_env(); - int e, s = 1; + const cl_env_ptr the_env = ecl_process_env(); + int e, s = 1; - switch (ecl_t_of(x)) { + switch (ecl_t_of(x)) { #ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double d = ecl_long_float(x); - if (signbit(d)) { - s = -1; - d = -d; - } - if (d == 0.0) { - e = 0; - x = ecl_make_fixnum(0); - } else { - d = frexpl(d, &e); - x = _ecl_long_double_to_integer(ldexpl(d, LDBL_MANT_DIG)); - e -= LDBL_MANT_DIG; - } - break; - } -#endif - case t_doublefloat: { - double d = ecl_double_float(x); - if (signbit(d)) { - s = -1; - d = -d; - } - if (d == 0.0) { - e = 0; - x = ecl_make_fixnum(0); - } else { - d = frexp(d, &e); - x = _ecl_double_to_integer(ldexp(d, DBL_MANT_DIG)); - e -= DBL_MANT_DIG; - } - break; - } - case t_singlefloat: { - float d = ecl_single_float(x); - if (signbit(d)) { - s = -1; - d = -d; - } - if (d == 0.0) { - e = 0; - x = ecl_make_fixnum(0); - } else { - d = frexpf(d, &e); - x = _ecl_double_to_integer(ldexp(d, FLT_MANT_DIG)); - e -= FLT_MANT_DIG; - } - break; - } - default: - FEwrong_type_nth_arg(@[integer-decode-float],1,x,@[float]); - } - ecl_return3(the_env, x, ecl_make_fixnum(e), ecl_make_fixnum(s)); + case t_longfloat: { + long double d = ecl_long_float(x); + if (signbit(d)) { + s = -1; + d = -d; + } + if (d == 0.0) { + e = 0; + x = ecl_make_fixnum(0); + } else { + d = frexpl(d, &e); + x = _ecl_long_double_to_integer(ldexpl(d, LDBL_MANT_DIG)); + e -= LDBL_MANT_DIG; + } + break; + } +#endif + case t_doublefloat: { + double d = ecl_double_float(x); + if (signbit(d)) { + s = -1; + d = -d; + } + if (d == 0.0) { + e = 0; + x = ecl_make_fixnum(0); + } else { + d = frexp(d, &e); + x = _ecl_double_to_integer(ldexp(d, DBL_MANT_DIG)); + e -= DBL_MANT_DIG; + } + break; + } + case t_singlefloat: { + float d = ecl_single_float(x); + if (signbit(d)) { + s = -1; + d = -d; + } + if (d == 0.0) { + e = 0; + x = ecl_make_fixnum(0); + } else { + d = frexpf(d, &e); + x = _ecl_double_to_integer(ldexp(d, FLT_MANT_DIG)); + e -= FLT_MANT_DIG; + } + break; + } + default: + FEwrong_type_nth_arg(@[integer-decode-float],1,x,@[float]); + } + ecl_return3(the_env, x, ecl_make_fixnum(e), ecl_make_fixnum(s)); } @(defun complex (r &optional (i ecl_make_fixnum(0))) -@ /* INV: ecl_make_complex() checks types */ - @(return ecl_make_complex(r, i)) -@) + @ /* INV: ecl_make_complex() checks types */ + @(return ecl_make_complex(r, i)) + @) cl_object cl_realpart(cl_object x) { - switch (ecl_t_of(x)) { - case t_fixnum: - case t_bignum: - case t_ratio: - case t_singlefloat: - case t_doublefloat: -#ifdef ECL_LONG_FLOAT - case t_longfloat: -#endif - break; - case t_complex: - x = x->complex.real; - break; - default: - FEwrong_type_nth_arg(@[realpart],1,x,@[number]); - } - @(return x) + switch (ecl_t_of(x)) { + case t_fixnum: + case t_bignum: + case t_ratio: + case t_singlefloat: + case t_doublefloat: +#ifdef ECL_LONG_FLOAT + case t_longfloat: +#endif + break; + case t_complex: + x = x->complex.real; + break; + default: + FEwrong_type_nth_arg(@[realpart],1,x,@[number]); + } + @(return x); } cl_object cl_imagpart(cl_object x) { - switch (ecl_t_of(x)) { - case t_fixnum: - case t_bignum: - case t_ratio: - x = ecl_make_fixnum(0); - break; - case t_singlefloat: - if (signbit(ecl_single_float(x))) - x = cl_core.singlefloat_minus_zero; - else - x = cl_core.singlefloat_zero; - break; - case t_doublefloat: - if (signbit(ecl_double_float(x))) - x = cl_core.doublefloat_minus_zero; - else - x = cl_core.doublefloat_zero; - break; -#ifdef ECL_LONG_FLOAT - case t_longfloat: - if (signbit(ecl_long_float(x))) - x = cl_core.longfloat_minus_zero; - else - x = cl_core.longfloat_zero; - break; -#endif - case t_complex: - x = x->complex.imag; - break; - default: - FEwrong_type_nth_arg(@[imagpart],1,x,@[number]); - } - @(return x) + switch (ecl_t_of(x)) { + case t_fixnum: + case t_bignum: + case t_ratio: + x = ecl_make_fixnum(0); + break; + case t_singlefloat: + if (signbit(ecl_single_float(x))) + x = cl_core.singlefloat_minus_zero; + else + x = cl_core.singlefloat_zero; + break; + case t_doublefloat: + if (signbit(ecl_double_float(x))) + x = cl_core.doublefloat_minus_zero; + else + x = cl_core.doublefloat_zero; + break; +#ifdef ECL_LONG_FLOAT + case t_longfloat: + if (signbit(ecl_long_float(x))) + x = cl_core.longfloat_minus_zero; + else + x = cl_core.longfloat_zero; + break; +#endif + case t_complex: + x = x->complex.imag; + break; + default: + FEwrong_type_nth_arg(@[imagpart],1,x,@[number]); + } + @(return x); } diff -Nru ecl-16.1.2/src/c/num_log.d ecl-16.1.3+ds/src/c/num_log.d --- ecl-16.1.2/src/c/num_log.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/num_log.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - num_log.c -- Logical operations on numbers. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * num_log.c - logical operations on numbers + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -28,610 +23,615 @@ static cl_fixnum ior_op(cl_fixnum i, cl_fixnum j) { - return(i | j); + return(i | j); } static cl_fixnum xor_op(cl_fixnum i, cl_fixnum j) { - return(i ^ j); + return(i ^ j); } static cl_fixnum and_op(cl_fixnum i, cl_fixnum j) { - return(i & j); + return(i & j); } static cl_fixnum eqv_op(cl_fixnum i, cl_fixnum j) { - return(~(i ^ j)); + return(~(i ^ j)); } static cl_fixnum nand_op(cl_fixnum i, cl_fixnum j) { - return(~(i & j)); + return(~(i & j)); } static cl_fixnum nor_op(cl_fixnum i, cl_fixnum j) { - return(~(i | j)); + return(~(i | j)); } static cl_fixnum andc1_op(cl_fixnum i, cl_fixnum j) { - return((~i) & j); + return((~i) & j); } static cl_fixnum andc2_op(cl_fixnum i, cl_fixnum j) { - return(i & (~j)); + return(i & (~j)); } static cl_fixnum orc1_op(cl_fixnum i, cl_fixnum j) { - return((~i) | j); + return((~i) | j); } static cl_fixnum orc2_op(cl_fixnum i, cl_fixnum j) { - return(i | (~j)); + return(i | (~j)); } static cl_fixnum b_clr_op(cl_fixnum i, cl_fixnum j) { - return(0); + return(0); } static cl_fixnum b_set_op(cl_fixnum i, cl_fixnum j) { - return(-1); + return(-1); } static cl_fixnum b_1_op(cl_fixnum i, cl_fixnum j) { - return(i); + return(i); } static cl_fixnum b_2_op(cl_fixnum i, cl_fixnum j) { - return(j); + return(j); } static cl_fixnum b_c1_op(cl_fixnum i, cl_fixnum j) { - return(~i); + return(~i); } static cl_fixnum b_c2_op(cl_fixnum i, cl_fixnum j) { - return(~j); + return(~j); } typedef cl_fixnum (*bit_operator)(cl_fixnum, cl_fixnum); static bit_operator fixnum_operations[16] = { - b_clr_op, - and_op, - andc2_op, - b_1_op, - andc1_op, - b_2_op, - xor_op, - ior_op, - nor_op, - eqv_op, - b_c2_op, - orc2_op, - b_c1_op, - orc1_op, - nand_op, - b_set_op}; + b_clr_op, + and_op, + andc2_op, + b_1_op, + andc1_op, + b_2_op, + xor_op, + ior_op, + nor_op, + eqv_op, + b_c2_op, + orc2_op, + b_c1_op, + orc1_op, + nand_op, + b_set_op}; static cl_object log_op(cl_narg narg, int op, ecl_va_list ARGS) { - cl_object x, y; - /* FIXME! This can be optimized */ - x = ecl_va_arg(ARGS); - if (narg-- == 1) { - assert_type_integer(x); - } else { - do { - y = ecl_va_arg(ARGS); - x = ecl_boole(op, x, y); - } while (--narg); - } - return x; + cl_object x, y; + /* FIXME! This can be optimized */ + x = ecl_va_arg(ARGS); + if (narg-- == 1) { + assert_type_integer(x); + } else { + do { + y = ecl_va_arg(ARGS); + x = ecl_boole(op, x, y); + } while (--narg); + } + return x; } cl_object ecl_boole(int op, cl_object x, cl_object y) { - switch (ecl_t_of(x)) { - case t_fixnum: - switch (ecl_t_of(y)) { - case t_fixnum: { - cl_fixnum z = fixnum_operations[op](ecl_fixnum(x), ecl_fixnum(y)); - return ecl_make_fixnum(z); - } - case t_bignum: { - cl_object x_copy = _ecl_big_register0(); - _ecl_big_set_fixnum(x_copy, ecl_fixnum(x)); - (_ecl_big_boole_operator(op))(x_copy, x_copy, y); - return _ecl_big_register_normalize(x_copy); - } - default: - FEwrong_type_nth_arg(@[boole], 2, y, @[integer]); - } - break; - case t_bignum: { - cl_object x_copy = _ecl_big_register0(); - switch (ecl_t_of(y)) { - case t_fixnum: { - cl_object z = _ecl_big_register1(); - _ecl_big_set_fixnum(z,ecl_fixnum(y)); - (_ecl_big_boole_operator(op))(x_copy, x, z); - _ecl_big_register_free(z); - break; - } - case t_bignum: - (_ecl_big_boole_operator(op))(x_copy, x, y); - break; - default: - FEwrong_type_nth_arg(@[boole], 2, y, @[integer]); - } - return _ecl_big_register_normalize(x_copy); - } - default: - FEwrong_type_nth_arg(@[boole], 1, x, @[integer]); - } - return x; + switch (ecl_t_of(x)) { + case t_fixnum: + switch (ecl_t_of(y)) { + case t_fixnum: { + cl_fixnum z = fixnum_operations[op](ecl_fixnum(x), ecl_fixnum(y)); + return ecl_make_fixnum(z); + } + case t_bignum: { + cl_object x_copy = _ecl_big_register0(); + _ecl_big_set_fixnum(x_copy, ecl_fixnum(x)); + (_ecl_big_boole_operator(op))(x_copy, x_copy, y); + return _ecl_big_register_normalize(x_copy); + } + default: + FEwrong_type_nth_arg(@[boole], 2, y, @[integer]); + } + break; + case t_bignum: { + cl_object x_copy = _ecl_big_register0(); + switch (ecl_t_of(y)) { + case t_fixnum: { + cl_object z = _ecl_big_register1(); + _ecl_big_set_fixnum(z,ecl_fixnum(y)); + (_ecl_big_boole_operator(op))(x_copy, x, z); + _ecl_big_register_free(z); + break; + } + case t_bignum: + (_ecl_big_boole_operator(op))(x_copy, x, y); + break; + default: + FEwrong_type_nth_arg(@[boole], 2, y, @[integer]); + } + return _ecl_big_register_normalize(x_copy); + } + default: + FEwrong_type_nth_arg(@[boole], 1, x, @[integer]); + } + return x; } cl_object cl_lognot(cl_object x) { - return @logxor(2,x,ecl_make_fixnum(-1)); + return @logxor(2,x,ecl_make_fixnum(-1)); } static cl_fixnum count_bits(cl_object x) { - cl_fixnum count; + cl_fixnum count; - switch (ecl_t_of(x)) { - case t_fixnum: { - cl_fixnum i = ecl_fixnum(x); - cl_fixnum j = (i < 0) ? ~i : i; - for (count=0 ; j ; j >>= 1) - if (j & 1) count++; - break; - } - case t_bignum: - if (_ecl_big_sign(x) >= 0) - count = mpz_popcount(x->big.big_num); - else { - cl_object z = _ecl_big_register0(); - mpz_com(z->big.big_num, x->big.big_num); - count = mpz_popcount(z->big.big_num); - _ecl_big_register_free(z); - } - break; - default: - FEwrong_type_only_arg(@[logcount], x, @[integer]); - } - return count; + switch (ecl_t_of(x)) { + case t_fixnum: { + cl_fixnum i = ecl_fixnum(x); + cl_fixnum j = (i < 0) ? ~i : i; + for (count=0 ; j ; j >>= 1) + if (j & 1) count++; + break; + } + case t_bignum: + if (_ecl_big_sign(x) >= 0) + count = mpz_popcount(x->big.big_num); + else { + cl_object z = _ecl_big_register0(); + mpz_com(z->big.big_num, x->big.big_num); + count = mpz_popcount(z->big.big_num); + _ecl_big_register_free(z); + } + break; + default: + FEwrong_type_only_arg(@[logcount], x, @[integer]); + } + return count; } /* - Left shift if w > 0, right shift if w < 0. - */ + Left shift if w > 0, right shift if w < 0. +*/ cl_object ecl_ash(cl_object x, cl_fixnum w) { - cl_object y; + cl_object y; - if (w == 0) - return(x); - y = _ecl_big_register0(); - if (w < 0) { - cl_index bits = -w; - if (ECL_FIXNUMP(x)) { - /* The result of shifting a number further than the number - * of digits it has is unpredictable in C. For instance, GCC - * on intel masks out all bits of "bits" beyond the 5 and - * it may happen that a shift of 37 becomes a shift of 5. - * Furthermore, in general, shifting negative numbers leads - * to implementation-specific results :-/ - */ - cl_fixnum y = ecl_fixnum(x); - if (bits >= ECL_FIXNUM_BITS) { - y = (y < 0)? -1 : 0; - } else { - y >>= bits; - } - return ecl_make_fixnum(y); - } - mpz_div_2exp(y->big.big_num, x->big.big_num, bits); - } else { - if (ECL_FIXNUMP(x)) { - _ecl_big_set_fixnum(y, ecl_fixnum(x)); - x = y; - } - mpz_mul_2exp(y->big.big_num, x->big.big_num, (unsigned long)w); - } - return _ecl_big_register_normalize(y); + if (w == 0) + return(x); + y = _ecl_big_register0(); + if (w < 0) { + cl_index bits = -w; + if (ECL_FIXNUMP(x)) { + /* The result of shifting a number further than the number + * of digits it has is unpredictable in C. For instance, GCC + * on intel masks out all bits of "bits" beyond the 5 and + * it may happen that a shift of 37 becomes a shift of 5. + * Furthermore, in general, shifting negative numbers leads + * to implementation-specific results :-/ + */ + cl_fixnum y = ecl_fixnum(x); + if (bits >= ECL_FIXNUM_BITS) { + y = (y < 0)? -1 : 0; + } else { + y >>= bits; + } + return ecl_make_fixnum(y); + } + mpz_div_2exp(y->big.big_num, x->big.big_num, bits); + } else { + if (ECL_FIXNUMP(x)) { + _ecl_big_set_fixnum(y, ecl_fixnum(x)); + x = y; + } + mpz_mul_2exp(y->big.big_num, x->big.big_num, (unsigned long)w); + } + return _ecl_big_register_normalize(y); } int ecl_fixnum_bit_length(cl_fixnum i) { - int count; - if (i < 0) - i = ~i; - for (count = 0; i && (count < ECL_FIXNUM_BITS); i >>= 1, count++) - ; - return count; + int count; + if (i < 0) + i = ~i; + for (count = 0; i && (count < ECL_FIXNUM_BITS); i >>= 1, count++) + ; + return count; } @(defun logior (&rest nums) @ - if (narg == 0) - @(return ecl_make_fixnum(0)) - /* INV: log_op() checks types and outputs first argument as default. */ - @(return log_op(narg, ECL_BOOLIOR, nums)) + if (narg == 0) + @(return ecl_make_fixnum(0)) + /* INV: log_op() checks types and outputs first argument as default. */ + @(return log_op(narg, ECL_BOOLIOR, nums)); @) @(defun logxor (&rest nums) @ - if (narg == 0) - @(return ecl_make_fixnum(0)) - /* INV: log_op() checks types and outputs first argument as default. */ - @(return log_op(narg, ECL_BOOLXOR, nums)) + if (narg == 0) { + @(return ecl_make_fixnum(0)); + } + /* INV: log_op() checks types and outputs first argument as default. */ + @(return log_op(narg, ECL_BOOLXOR, nums)); @) @(defun logand (&rest nums) @ - if (narg == 0) - @(return ecl_make_fixnum(-1)) - /* INV: log_op() checks types and outputs first argument as default. */ - @(return log_op(narg, ECL_BOOLAND, nums)) + if (narg == 0) { + @(return ecl_make_fixnum(-1)); + } + /* INV: log_op() checks types and outputs first argument as default. */ + @(return log_op(narg, ECL_BOOLAND, nums)); @) @(defun logeqv (&rest nums) @ - if (narg == 0) - @(return ecl_make_fixnum(-1)) - /* INV: log_op() checks types and outputs first argument as default. */ - @(return log_op(narg, ECL_BOOLEQV, nums)) + if (narg == 0) { + @(return ecl_make_fixnum(-1)); + } + /* INV: log_op() checks types and outputs first argument as default. */ + @(return log_op(narg, ECL_BOOLEQV, nums)); @) cl_object cl_lognand(cl_object x, cl_object y) { - @(return ecl_boole(ECL_BOOLNAND, x, y)) + @(return ecl_boole(ECL_BOOLNAND, x, y)); } cl_object cl_lognor(cl_object x, cl_object y) { - @(return ecl_boole(ECL_BOOLNOR, x, y)) + @(return ecl_boole(ECL_BOOLNOR, x, y)); } cl_object cl_logandc1(cl_object x, cl_object y) { - @(return ecl_boole(ECL_BOOLANDC1, x, y)) + @(return ecl_boole(ECL_BOOLANDC1, x, y)); } cl_object cl_logandc2(cl_object x, cl_object y) { - @(return ecl_boole(ECL_BOOLANDC2, x, y)) + @(return ecl_boole(ECL_BOOLANDC2, x, y)); } cl_object cl_logorc1(cl_object x, cl_object y) { - @(return ecl_boole(ECL_BOOLORC1, x, y)) + @(return ecl_boole(ECL_BOOLORC1, x, y)); } cl_object cl_logorc2(cl_object x, cl_object y) { - @(return ecl_boole(ECL_BOOLORC2, x, y)) + @(return ecl_boole(ECL_BOOLORC2, x, y)); } static int coerce_to_logical_operator(cl_object o) { - cl_fixnum op; - op = ecl_to_fix(o); - if (op < 0 || op > ECL_BOOLSET) - FEerror("~S is an invalid logical operator.", 1, o); - return op; + cl_fixnum op; + op = ecl_to_fix(o); + if (op < 0 || op > ECL_BOOLSET) + FEerror("~S is an invalid logical operator.", 1, o); + return op; } cl_object cl_boole(cl_object o, cl_object x, cl_object y) { - /* INV: log_op2() checks types */ - @(return ecl_boole(coerce_to_logical_operator(o), x, y)) + /* INV: log_op2() checks types */ + @(return ecl_boole(coerce_to_logical_operator(o), x, y)); } cl_object cl_logbitp(cl_object p, cl_object x) { - bool i; + bool i; - assert_type_integer(x); - if (ECL_FIXNUMP(p)) { - cl_index n = ecl_to_size(p); - if (ECL_FIXNUMP(x)) { - cl_fixnum y = ecl_fixnum(x); - if (n >= ECL_FIXNUM_BITS) { - i = (y < 0); - } else { - i = ((y >> n) & 1); - } - } else { - i = mpz_tstbit(x->big.big_num, n); - } - } else { - assert_type_non_negative_integer(p); - if (ECL_FIXNUMP(x)) - i = (ecl_fixnum(x) < 0); - else - i = (_ecl_big_sign(x) < 0); - } - @(return (i ? ECL_T : ECL_NIL)) + assert_type_integer(x); + if (ECL_FIXNUMP(p)) { + cl_index n = ecl_to_size(p); + if (ECL_FIXNUMP(x)) { + cl_fixnum y = ecl_fixnum(x); + if (n >= ECL_FIXNUM_BITS) { + i = (y < 0); + } else { + i = ((y >> n) & 1); + } + } else { + i = mpz_tstbit(x->big.big_num, n); + } + } else { + assert_type_non_negative_integer(p); + if (ECL_FIXNUMP(x)) + i = (ecl_fixnum(x) < 0); + else + i = (_ecl_big_sign(x) < 0); + } + @(return (i ? ECL_T : ECL_NIL)); } cl_object cl_ash(cl_object x, cl_object y) { - cl_object r; - int sign_x; + cl_object r; + int sign_x; - assert_type_integer(x); - assert_type_integer(y); - if (ECL_FIXNUMP(y)) - r = ecl_ash(x, ecl_fixnum(y)); - else { - /* - bit position represented by bignum is probably - out of our address space. So, result is returned - according to sign of integer. - */ - if (ECL_FIXNUMP(x)) - if (ecl_fixnum_minusp(x)) - sign_x = -1; - else if (x == ecl_make_fixnum(0)) - sign_x = 0; - else - sign_x = 1; - else - sign_x = _ecl_big_sign(x); - if (_ecl_big_sign(y) < 0) - if (sign_x < 0) - r = ecl_make_fixnum(-1); - else - r = ecl_make_fixnum(0); - else if (sign_x == 0) - r = x; - else - FEerror("Insufficient memory.", 0); - } - @(return r) + assert_type_integer(x); + assert_type_integer(y); + if (ECL_FIXNUMP(y)) + r = ecl_ash(x, ecl_fixnum(y)); + else { + /* + bit position represented by bignum is probably + out of our address space. So, result is returned + according to sign of integer. + */ + if (ECL_FIXNUMP(x)) + if (ecl_fixnum_minusp(x)) + sign_x = -1; + else if (x == ecl_make_fixnum(0)) + sign_x = 0; + else + sign_x = 1; + else + sign_x = _ecl_big_sign(x); + if (_ecl_big_sign(y) < 0) + if (sign_x < 0) + r = ecl_make_fixnum(-1); + else + r = ecl_make_fixnum(0); + else if (sign_x == 0) + r = x; + else + FEerror("Insufficient memory.", 0); + } + @(return r); } cl_object cl_logcount(cl_object x) { - @(return ecl_make_fixnum(count_bits(x))) + @(return ecl_make_fixnum(count_bits(x))); } cl_index ecl_integer_length(cl_object x) { - int count; - cl_fixnum i; + int count; + cl_fixnum i; - switch (ecl_t_of(x)) { - case t_fixnum: - i = ecl_fixnum(x); - count = ecl_fixnum_bit_length(i); - break; - case t_bignum: - if (_ecl_big_sign(x) < 0) - x = cl_lognot(x); - count = mpz_sizeinbase(x->big.big_num, 2); - break; - default: - FEwrong_type_only_arg(@[integer-length], x, @[integer]); - } - return count; + switch (ecl_t_of(x)) { + case t_fixnum: + i = ecl_fixnum(x); + count = ecl_fixnum_bit_length(i); + break; + case t_bignum: + if (_ecl_big_sign(x) < 0) + x = cl_lognot(x); + count = mpz_sizeinbase(x->big.big_num, 2); + break; + default: + FEwrong_type_only_arg(@[integer-length], x, @[integer]); + } + return count; } cl_object cl_integer_length(cl_object x) { - @(return ecl_make_fixnum(ecl_integer_length(x))) + @(return ecl_make_fixnum(ecl_integer_length(x))); } cl_object si_bit_array_op(cl_object o, cl_object x, cl_object y, cl_object r) { - cl_fixnum i, j, n, d; - cl_object r0; - bit_operator op; - bool replace = FALSE; - int xi, yi, ri; - byte *xp, *yp, *rp; - int xo, yo, ro; - - if (ecl_t_of(x) == t_bitvector) { - d = x->vector.dim; - xp = x->vector.self.bit; - xo = x->vector.offset; - if (ecl_t_of(y) != t_bitvector) - goto ERROR; - if (d != y->vector.dim) - goto ERROR; - yp = y->vector.self.bit; - yo = y->vector.offset; - if (r == ECL_T) - r = x; - if (r != ECL_NIL) { - if (ecl_t_of(r) != t_bitvector) - goto ERROR; - if (r->vector.dim != d) - goto ERROR; - i = (r->vector.self.bit - xp)*8 + (r->vector.offset - xo); - if ((i > 0 && i < d) || (i < 0 && -i < d)) { - r0 = r; - r = ECL_NIL; - replace = TRUE; - goto L1; - } - i = (r->vector.self.bit - yp)*8 + (r->vector.offset - yo); - if ((i > 0 && i < d) || (i < 0 && -i < d)) { - r0 = r; - r = ECL_NIL; - replace = TRUE; - } - } - L1: - if (Null(r)) { - r = ecl_alloc_simple_vector(d, ecl_aet_bit); - } - } else { - if (ecl_t_of(x) != t_array) - goto ERROR; - if ((cl_elttype)x->array.elttype != ecl_aet_bit) - goto ERROR; - d = x->array.dim; - xp = x->vector.self.bit; - xo = x->vector.offset; - if (ecl_t_of(y) != t_array) - goto ERROR; - if ((cl_elttype)y->array.elttype != ecl_aet_bit) - goto ERROR; - if (x->array.rank != y->array.rank) - goto ERROR; - yp = y->vector.self.bit; - yo = y->vector.offset; - for (i = 0; i < x->array.rank; i++) - if (x->array.dims[i] != y->array.dims[i]) - goto ERROR; - if (r == ECL_T) - r = x; - if (r != ECL_NIL) { - if (ecl_t_of(r) != t_array) - goto ERROR; - if ((cl_elttype)r->array.elttype != ecl_aet_bit) - goto ERROR; - if (r->array.rank != x->array.rank) - goto ERROR; - for (i = 0; i < x->array.rank; i++) - if (r->array.dims[i] != x->array.dims[i]) - goto ERROR; - i = (r->vector.self.bit - xp)*8 + (r->vector.offset - xo); - if ((i > 0 && i < d) || (i < 0 && -i < d)) { - r0 = r; - r = ECL_NIL; - replace = TRUE; - goto L2; - } - i = (r->vector.self.bit - yp)*8 + (r->vector.offset - yo); - if ((i > 0 && i < d) || (i < 0 && -i < d)) { - r0 = r; - r = ECL_NIL; - replace = TRUE; - } - } - L2: - if (Null(r)) { - r = ecl_alloc_object(t_array); - r->array.self.t = NULL; - r->array.displaced = ECL_NIL; - r->array.rank = x->array.rank; - r->array.dims = x->array.dims; - r->array.elttype = ecl_aet_bit; - r->array.dim = x->array.dim; - r->array.flags = 0; /* no fill pointer, not adjustable */ - ecl_array_allocself(r); - } - } - rp = r->vector.self.bit; - ro = r->vector.offset; - op = fixnum_operations[coerce_to_logical_operator(o)]; - -#define set_high(place, nbits, value) \ - (place)=((place)&~(-0400>>(nbits)))|((value)&(-0400>>(nbits))) - -#define set_low(place, nbits, value) \ - (place)=((place)&(-0400>>(8-(nbits))))|((value)&~(-0400>>(8-(nbits)))) - -#define extract_byte(integer, pointer, index, offset) \ - (integer) = (pointer)[(index)+1] & 0377; \ - (integer) = ((pointer)[index]<<(offset))|((integer)>>(8-(offset))) - -#define store_byte(pointer, index, offset, value) \ - set_low((pointer)[index], 8-(offset), (value)>>(offset)); \ - set_high((pointer)[(index)+1], offset, (value)<<(8-(offset))) - - if (xo == 0 && yo == 0 && ro == 0) { - for (n = d/8, i = 0; i < n; i++) - rp[i] = (*op)(xp[i], yp[i]); - if ((j = d%8) > 0) - set_high(rp[n], j, (*op)(xp[n], yp[n])); - if (!replace) - @(return r) - } else { - for (n = d/8, i = 0; i <= n; i++) { - extract_byte(xi, xp, i, xo); - extract_byte(yi, yp, i, yo); - if (i == n) { - if ((j = d%8) == 0) - break; - extract_byte(ri, rp, n, ro); - set_high(ri, j, (*op)(xi, yi)); - } else - ri = (*op)(xi, yi); - store_byte(rp, i, ro, ri); - } - if (!replace) - @(return r) - } - rp = r0->vector.self.bit; - ro = r0->vector.offset; - for (n = d/8, i = 0; i <= n; i++) { - if (i == n) { - if ((j = d%8) == 0) - break; - extract_byte(ri, rp, n, ro); - set_high(ri, j, r->vector.self.bit[n]); - } else - ri = r->vector.self.bit[i]; - store_byte(rp, i, ro, ri); - } - @(return r0) -ERROR: - FEerror("Illegal arguments for bit-array operation.", 0); + cl_fixnum i, j, n, d; + cl_object r0; + bit_operator op; + bool replace = FALSE; + int xi, yi, ri; + byte *xp, *yp, *rp; + int xo, yo, ro; + + if (ecl_t_of(x) == t_bitvector) { + d = x->vector.dim; + xp = x->vector.self.bit; + xo = x->vector.offset; + if (ecl_t_of(y) != t_bitvector) + goto ERROR; + if (d != y->vector.dim) + goto ERROR; + yp = y->vector.self.bit; + yo = y->vector.offset; + if (r == ECL_T) + r = x; + if (r != ECL_NIL) { + if (ecl_t_of(r) != t_bitvector) + goto ERROR; + if (r->vector.dim != d) + goto ERROR; + i = (r->vector.self.bit - xp)*8 + (r->vector.offset - xo); + if ((i > 0 && i < d) || (i < 0 && -i < d)) { + r0 = r; + r = ECL_NIL; + replace = TRUE; + goto L1; + } + i = (r->vector.self.bit - yp)*8 + (r->vector.offset - yo); + if ((i > 0 && i < d) || (i < 0 && -i < d)) { + r0 = r; + r = ECL_NIL; + replace = TRUE; + } + } + L1: + if (Null(r)) { + r = ecl_alloc_simple_vector(d, ecl_aet_bit); + } + } else { + if (ecl_t_of(x) != t_array) + goto ERROR; + if ((cl_elttype)x->array.elttype != ecl_aet_bit) + goto ERROR; + d = x->array.dim; + xp = x->vector.self.bit; + xo = x->vector.offset; + if (ecl_t_of(y) != t_array) + goto ERROR; + if ((cl_elttype)y->array.elttype != ecl_aet_bit) + goto ERROR; + if (x->array.rank != y->array.rank) + goto ERROR; + yp = y->vector.self.bit; + yo = y->vector.offset; + for (i = 0; i < x->array.rank; i++) + if (x->array.dims[i] != y->array.dims[i]) + goto ERROR; + if (r == ECL_T) + r = x; + if (r != ECL_NIL) { + if (ecl_t_of(r) != t_array) + goto ERROR; + if ((cl_elttype)r->array.elttype != ecl_aet_bit) + goto ERROR; + if (r->array.rank != x->array.rank) + goto ERROR; + for (i = 0; i < x->array.rank; i++) + if (r->array.dims[i] != x->array.dims[i]) + goto ERROR; + i = (r->vector.self.bit - xp)*8 + (r->vector.offset - xo); + if ((i > 0 && i < d) || (i < 0 && -i < d)) { + r0 = r; + r = ECL_NIL; + replace = TRUE; + goto L2; + } + i = (r->vector.self.bit - yp)*8 + (r->vector.offset - yo); + if ((i > 0 && i < d) || (i < 0 && -i < d)) { + r0 = r; + r = ECL_NIL; + replace = TRUE; + } + } + L2: + if (Null(r)) { + r = ecl_alloc_object(t_array); + r->array.self.t = NULL; + r->array.displaced = ECL_NIL; + r->array.rank = x->array.rank; + r->array.dims = x->array.dims; + r->array.elttype = ecl_aet_bit; + r->array.dim = x->array.dim; + r->array.flags = 0; /* no fill pointer, not adjustable */ + ecl_array_allocself(r); + } + } + rp = r->vector.self.bit; + ro = r->vector.offset; + op = fixnum_operations[coerce_to_logical_operator(o)]; + +#define set_high(place, nbits, value) \ + (place)=((place)&~(-0400>>(nbits)))|((value)&(-0400>>(nbits))) + +#define set_low(place, nbits, value) \ + (place)=((place)&(-0400>>(8-(nbits))))|((value)&~(-0400>>(8-(nbits)))) + +#define extract_byte(integer, pointer, index, offset) \ + (integer) = (pointer)[(index)+1] & 0377; \ + (integer) = ((pointer)[index]<<(offset))|((integer)>>(8-(offset))) + +#define store_byte(pointer, index, offset, value) \ + set_low((pointer)[index], 8-(offset), (value)>>(offset)); \ + set_high((pointer)[(index)+1], offset, (value)<<(8-(offset))) + + if (xo == 0 && yo == 0 && ro == 0) { + for (n = d/8, i = 0; i < n; i++) + rp[i] = (*op)(xp[i], yp[i]); + if ((j = d%8) > 0) + set_high(rp[n], j, (*op)(xp[n], yp[n])); + if (!replace) { + @(return r); + } + } else { + for (n = d/8, i = 0; i <= n; i++) { + extract_byte(xi, xp, i, xo); + extract_byte(yi, yp, i, yo); + if (i == n) { + if ((j = d%8) == 0) + break; + extract_byte(ri, rp, n, ro); + set_high(ri, j, (*op)(xi, yi)); + } else + ri = (*op)(xi, yi); + store_byte(rp, i, ro, ri); + } + if (!replace) { + @(return r); + } + } + rp = r0->vector.self.bit; + ro = r0->vector.offset; + for (n = d/8, i = 0; i <= n; i++) { + if (i == n) { + if ((j = d%8) == 0) + break; + extract_byte(ri, rp, n, ro); + set_high(ri, j, r->vector.self.bit[n]); + } else + ri = r->vector.self.bit[i]; + store_byte(rp, i, ro, ri); + } + @(return r0); + ERROR: + FEerror("Illegal arguments for bit-array operation.", 0); } diff -Nru ecl-16.1.2/src/c/num_pred.d ecl-16.1.3+ds/src/c/num_pred.d --- ecl-16.1.2/src/c/num_pred.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/num_pred.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - num_pred.c -- Predicates on numbers. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * num_pred.d - predicates on numbers + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #define ECL_INCLUDE_MATH_H #include @@ -25,66 +20,78 @@ int ecl_oddp(cl_object x) { - if (ECL_FIXNUMP(x)) - return ecl_fixnum(x) & 1; - unlikely_if (!ECL_BIGNUMP(x)) - FEwrong_type_only_arg(@[oddp], x, @[integer]); - return _ecl_big_odd_p(x); + if (ECL_FIXNUMP(x)) + return ecl_fixnum(x) & 1; + unlikely_if (!ECL_BIGNUMP(x)) + FEwrong_type_only_arg(@[oddp], x, @[integer]); + return _ecl_big_odd_p(x); } int ecl_evenp(cl_object x) { - if (ECL_FIXNUMP(x)) - return ~ecl_fixnum(x) & 1; - unlikely_if (!ECL_BIGNUMP(x)) - FEwrong_type_only_arg(@[evenp], x, @[integer]); - return _ecl_big_even_p(x); + if (ECL_FIXNUMP(x)) + return ~ecl_fixnum(x) & 1; + unlikely_if (!ECL_BIGNUMP(x)) + FEwrong_type_only_arg(@[evenp], x, @[integer]); + return _ecl_big_even_p(x); } cl_object cl_oddp(cl_object x) { /* INV: ecl_oddp() checks type */ - @(return (ecl_oddp(x) ? ECL_T : ECL_NIL)) + @(return (ecl_oddp(x) ? ECL_T : ECL_NIL)); } cl_object cl_evenp(cl_object x) { /* INV: ecl_evenp() checks_type */ - @(return (ecl_evenp(x) ? ECL_T : ECL_NIL)) + @(return (ecl_evenp(x) ? ECL_T : ECL_NIL)); } cl_object si_float_nan_p(cl_object x) { - @(return (ecl_float_nan_p(x)? ECL_T : ECL_NIL)) + @(return (ecl_float_nan_p(x)? ECL_T : ECL_NIL)); } cl_object si_float_infinity_p(cl_object x) { - @(return (ecl_float_infinity_p(x)? ECL_T : ECL_NIL)) + @(return (ecl_float_infinity_p(x)? ECL_T : ECL_NIL)); } bool ecl_float_nan_p(cl_object x) { - return !ecl_number_equalp(x,x); + return !ecl_number_equalp(x,x); +/* switch (ecl_t_of(x)) { */ +/* case t_singlefloat: */ +/* return !isnan(ecl_single_float(x)); */ +/* case t_doublefloat: */ +/* return !isnan(ecl_double_float(x)); */ +/* #ifdef ECL_LONG_FLOAT */ +/* case t_longfloat: */ +/* return !isnan(ecl_long_float(x)); */ +/* #endif */ +/* default: */ +/* return 0; */ +/* } */ } bool ecl_float_infinity_p(cl_object x) { - switch (ecl_t_of(x)) { - case t_singlefloat: - return !isfinite(ecl_single_float(x)); - case t_doublefloat: - return !isfinite(ecl_double_float(x)); + switch (ecl_t_of(x)) { + case t_singlefloat: + return !isfinite(ecl_single_float(x)); + case t_doublefloat: + return !isfinite(ecl_double_float(x)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return !isfinite(ecl_long_float(x)); + case t_longfloat: + return !isfinite(ecl_long_float(x)); #endif - default: - return 0; - } + default: + return 0; + } } diff -Nru ecl-16.1.2/src/c/num_rand.d ecl-16.1.3+ds/src/c/num_rand.d --- ecl-16.1.2/src/c/num_rand.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/num_rand.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,22 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - num_rand.c -- Random numbers. -n*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - Copyright (c) 2015, Daniel Kochmański. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * num_rand.d - random numbers + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * Copyright (c) 2016 Daniel Kochmański + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -31,6 +26,9 @@ # include /* it isn't pulled in by fcntl.h */ #endif +#ifdef _MSC_VER +#include +#endif /* * Mersenne-Twister random number generator @@ -49,71 +47,71 @@ #define LOWER_MASK 0x7FFFFFFFULL /* least significant 31 bits */ #define ulong uint64_t -static cl_object +cl_object init_genrand(ulong seed) { - cl_object array = ecl_alloc_simple_vector((MT_N + 1), ecl_aet_b64); - ulong *mt = array->vector.self.b64; - int j; - mt[0] = seed; - for (j=1; j> 62)) + j); + int j; + cl_object array = ecl_alloc_simple_vector((MT_N + 1), ecl_aet_b64); + ulong *mt = array->vector.self.b64; + mt[0] = seed; + for (j=1; j> 62)) + j); - mt[MT_N] = MT_N+1; - return array; + mt[MT_N] = MT_N+1; + return array; } static ulong generate_int64(cl_object state) { - static mag01[2]={0x0UL, MATRIX_A}; - ulong y; - ulong *mt = state->vector.self.b64; - - if (mt[MT_N] >= MT_N) { - /* refresh data */ - int kk; - for (kk=0; kk < (MT_N - MT_M); kk++) { - y = (mt[kk] & UPPER_MASK) | (mt[kk+1] & LOWER_MASK); - mt[kk] = mt[kk + MT_M] ^ (y >> 1) ^ mag01[y & 0x1ULL]; - } - for (; kk < (MT_N - 1); kk++) { - y = (mt[kk] & UPPER_MASK) | (mt[kk+1] & LOWER_MASK); - mt[kk] = mt[kk+(MT_M-MT_N)] ^ (y >> 1) ^ mag01[y & 0x1ULL]; - } - y = (mt[MT_N-1] & UPPER_MASK) | (mt[0] & LOWER_MASK); - mt[MT_N-1] = mt[MT_M-1] ^ (y >> 1) ^ mag01[y & 0x1ULL]; - mt[MT_N] = 0; - } - /* get random 64 bit num */ - y = mt[mt[MT_N]++]; - /* Tempering */ - y ^= (y >> 29) & 0x5555555555555555ULL; - y ^= (y << 17) & 0x71D67FFFEDA60000ULL; - y ^= (y << 37) & 0xFFF7EEE000000000ULL; - y ^= (y >> 43); + static ulong mag01[2]={0x0UL, MATRIX_A}; + ulong y; + ulong *mt = state->vector.self.b64; + + if (mt[MT_N] >= MT_N) { + /* refresh data */ + int kk; + for (kk=0; kk < (MT_N - MT_M); kk++) { + y = (mt[kk] & UPPER_MASK) | (mt[kk+1] & LOWER_MASK); + mt[kk] = mt[kk + MT_M] ^ (y >> 1) ^ mag01[y & 0x1ULL]; + } + for (; kk < (MT_N - 1); kk++) { + y = (mt[kk] & UPPER_MASK) | (mt[kk+1] & LOWER_MASK); + mt[kk] = mt[kk+(MT_M-MT_N)] ^ (y >> 1) ^ mag01[y & 0x1ULL]; + } + y = (mt[MT_N-1] & UPPER_MASK) | (mt[0] & LOWER_MASK); + mt[MT_N-1] = mt[MT_M-1] ^ (y >> 1) ^ mag01[y & 0x1ULL]; + mt[MT_N] = 0; + } + /* get random 64 bit num */ + y = mt[mt[MT_N]++]; + /* Tempering */ + y ^= (y >> 29) & 0x5555555555555555ULL; + y ^= (y << 17) & 0x71D67FFFEDA60000ULL; + y ^= (y << 37) & 0xFFF7EEE000000000ULL; + y ^= (y >> 43); - return y; + return y; } static double generate_double(cl_object state) { - return (generate_int64(state) >> 11) * (1.0 / 9007199254740991.0); + return (generate_int64(state) >> 11) * (1.0 / 9007199254740991.0); } static mp_limb_t generate_limb(cl_object state) { #if GMP_LIMB_BITS <= 32 - return generate_int64(state); + return generate_int64(state); #else # if GMP_LIMB_BITS <= 64 - return generate_int64(state); + return generate_int64(state); # else # if GMP_LIMB_BITS <= 128 - mp_limb_t high = generate_int64(state); - return (high << 64) | generate_int64(state); + mp_limb_t high = generate_int64(state); + return (high << 64) | generate_int64(state); # endif # endif #endif @@ -131,73 +129,73 @@ #define LOWER_MASK 0x7fffffffUL /* least significant r bits */ #define ulong uint32_t -static cl_object +cl_object init_genrand(ulong seed) { - cl_object array = ecl_alloc_simple_vector((MT_N + 1), ecl_aet_b32); - ulong *mt = array->vector.self.b32; - int j; - mt[0] = seed; - for (j=1; j < MT_N; j++) - mt[j] = (1812433253UL * (mt[j-1] ^ (mt[j-1] >> 30)) + j); + cl_object array = ecl_alloc_simple_vector((MT_N + 1), ecl_aet_b32); + ulong *mt = array->vector.self.b32; + int j; + mt[0] = seed; + for (j=1; j < MT_N; j++) + mt[j] = (1812433253UL * (mt[j-1] ^ (mt[j-1] >> 30)) + j); - mt[MT_N] = MT_N+1; - return array; + mt[MT_N] = MT_N+1; + return array; } static ulong generate_int32(cl_object state) { - static mag01[2]={0x0UL, MATRIX_A}; - ulong y; - ulong *mt = state->vector.self.b32; - if (mt[MT_N] >= MT_N) { - /* refresh data */ - int kk; - for (kk=0; kk < (MT_N - MT_M); kk++) { - y = (mt[kk] & UPPER_MASK) | (mt[kk+1] & LOWER_MASK); - mt[kk] = mt[kk + MT_M] ^ (y >> 1) ^ mag01[y & 0x1UL]; - } - for (; kk < (MT_N - 1); kk++) { - y = (mt[kk] & UPPER_MASK) | (mt[kk+1] & LOWER_MASK); - mt[kk] = mt[kk+(MT_M-MT_N)] ^ (y >> 1) ^ mag01[y & 0x1UL]; - } - y = (mt[MT_N-1] & UPPER_MASK) | (mt[0] & LOWER_MASK); - mt[MT_N-1] = mt[MT_M-1] ^ (y >> 1) ^ mag01[y & 0x1UL]; - mt[MT_N] = 0; - } - /* get random 32 bit num */ - y = mt[mt[MT_N]++]; - /* Tempering */ - y ^= (y >> 11); - y ^= (y << 7) & 0x9d2c5680UL; - y ^= (y << 15) & 0xefc60000UL; - y ^= (y >> 18); - return y; + static ulong mag01[2]={0x0UL, MATRIX_A}; + ulong y; + ulong *mt = state->vector.self.b32; + if (mt[MT_N] >= MT_N) { + /* refresh data */ + int kk; + for (kk=0; kk < (MT_N - MT_M); kk++) { + y = (mt[kk] & UPPER_MASK) | (mt[kk+1] & LOWER_MASK); + mt[kk] = mt[kk + MT_M] ^ (y >> 1) ^ mag01[y & 0x1UL]; + } + for (; kk < (MT_N - 1); kk++) { + y = (mt[kk] & UPPER_MASK) | (mt[kk+1] & LOWER_MASK); + mt[kk] = mt[kk+(MT_M-MT_N)] ^ (y >> 1) ^ mag01[y & 0x1UL]; + } + y = (mt[MT_N-1] & UPPER_MASK) | (mt[0] & LOWER_MASK); + mt[MT_N-1] = mt[MT_M-1] ^ (y >> 1) ^ mag01[y & 0x1UL]; + mt[MT_N] = 0; + } + /* get random 32 bit num */ + y = mt[mt[MT_N]++]; + /* Tempering */ + y ^= (y >> 11); + y ^= (y << 7) & 0x9d2c5680UL; + y ^= (y << 15) & 0xefc60000UL; + y ^= (y >> 18); + return y; } static double generate_double(cl_object state) { - return generate_int32(state) * (1.0 / 4294967296.0); + return generate_int32(state) * (1.0 / 4294967296.0); } static mp_limb_t generate_limb(cl_object state) { #if GMP_LIMB_BITS <= 32 - return generate_int32(state); + return generate_int32(state); #else # if GMP_LIMB_BITS <= 64 - mp_limb_t high = generate_int32(state); - return (high << 32) | generate_int32(state); + mp_limb_t high = generate_int32(state); + return (high << 32) | generate_int32(state); # else # if GMP_LIMB_BITS <= 128 - mp_limb_t word0 = generate_int32(state); - mp_limb_t word1 = generate_int32(state); - mp_limb_t word2 = generate_int32(state); - mp_limb_t word3 = generate_int32(state); - return (word3 << 96) | (word3 << 64) | (word1 << 32) || word0; + mp_limb_t word0 = generate_int32(state); + mp_limb_t word1 = generate_int32(state); + mp_limb_t word2 = generate_int32(state); + mp_limb_t word3 = generate_int32(state); + return (word3 << 96) | (word3 << 64) | (word1 << 32) || word0; # endif # endif #endif @@ -207,129 +205,142 @@ cl_object init_random_state(void) { - ulong seed; + ulong seed; #if !defined(ECL_MS_WINDOWS_HOST) - /* fopen() might read full 4kB blocks and discard - * a lot of entropy, so use open() */ - int file_handler = open("/dev/urandom", O_RDONLY); - if (file_handler != -1) { - read(file_handler, &seed, sizeof(ulong)); - close(file_handler); - } else + /* fopen() might read full 4kB blocks and discard + * a lot of entropy, so use open() */ + int file_handler = open("/dev/urandom", O_RDONLY); + if (file_handler != -1) { + read(file_handler, &seed, sizeof(ulong)); + close(file_handler); + } else #endif - { - /* cant get urandom, use crappy source */ - /* and/or fill rest of area */ - seed = (rand() + time(0)); - } + { + /* cant get urandom, use crappy source */ + /* and/or fill rest of area */ + seed = (rand() + time(0)); + } - return init_genrand(seed); + return init_genrand(seed); } static cl_object random_integer(cl_object limit, cl_object state) { - cl_index bit_length = ecl_integer_length(limit); - cl_object buffer; - if (bit_length <= ECL_FIXNUM_BITS) - bit_length = ECL_FIXNUM_BITS; - buffer = ecl_ash(ecl_make_fixnum(1), bit_length); - for (bit_length = mpz_size(buffer->big.big_num); bit_length; ) { - ECL_BIGNUM_LIMBS(buffer)[--bit_length] = - generate_limb(state); - } - return cl_mod(buffer, limit); + cl_index bit_length = ecl_integer_length(limit); + cl_object buffer; + if (bit_length <= ECL_FIXNUM_BITS) + bit_length = ECL_FIXNUM_BITS; + buffer = ecl_ash(ecl_make_fixnum(1), bit_length); + for (bit_length = mpz_size(buffer->big.big_num); bit_length; ) { + ECL_BIGNUM_LIMBS(buffer)[--bit_length] = + generate_limb(state); + } + return cl_mod(buffer, limit); } static cl_object rando(cl_object x, cl_object rs) { - cl_object z; - if (!ecl_plusp(x)) { - goto ERROR; - } - switch (ecl_t_of(x)) { - case t_fixnum: + cl_object z; + if (!ecl_plusp(x)) { + goto ERROR; + } + switch (ecl_t_of(x)) { + case t_fixnum: #if ECL_FIXNUM_BITS <= 32 - z = ecl_make_fixnum(generate_int32(rs->random.value) % ecl_fixnum(x)); - break; + z = ecl_make_fixnum(generate_int32(rs->random.value) % ecl_fixnum(x)); + break; #endif - case t_bignum: - z = random_integer(x, rs->random.value); - break; - case t_singlefloat: - z = ecl_make_single_float(ecl_single_float(x) * - (float)generate_double(rs->random.value)); - break; - case t_doublefloat: - z = ecl_make_double_float(ecl_double_float(x) * - generate_double(rs->random.value)); - break; + case t_bignum: + z = random_integer(x, rs->random.value); + break; + case t_singlefloat: + z = ecl_make_single_float(ecl_single_float(x) * + (float)generate_double(rs->random.value)); + break; + case t_doublefloat: + z = ecl_make_double_float(ecl_double_float(x) * + generate_double(rs->random.value)); + break; #ifdef ECL_LONG_FLOAT - case t_longfloat: - z = ecl_make_long_float(ecl_long_float(x) * - (long double)generate_double(rs->random.value)); - break; + case t_longfloat: + z = ecl_make_long_float(ecl_long_float(x) * + (long double)generate_double(rs->random.value)); + break; #endif - default: ERROR: { - const char *type = "(OR (INTEGER (0) *) (FLOAT (0) *))"; - FEwrong_type_nth_arg(@[random],1,x, ecl_read_from_cstring(type)); - } - } - return z; + default: ERROR: { + const char *type = "(OR (INTEGER (0) *) (FLOAT (0) *))"; + FEwrong_type_nth_arg(@[random],1,x, ecl_read_from_cstring(type)); + } + } + return z; } cl_object ecl_make_random_state(cl_object rs) { - cl_object z = ecl_alloc_object(t_random); - if (rs == ECL_T) { - z->random.value = init_random_state(); - return z; - } - - if (Null(rs)) - rs = ecl_symbol_value(@'*random-state*'); - - switch (ecl_t_of(rs)) { - case t_random: - z->random.value = cl_copy_seq(rs->random.value); - break; - case t_vector: - z->random.value = cl_copy_seq(rs); - break; - case t_fixnum: - /* XXX: If we'll decide to use 64-bit algorithm for - appropriate platforms then this will be replaced - with ecl_to_ulong_long from number.d, which takes - widest available type (32 or 64 bit) - automatically. */ - z->random.value = init_genrand(ecl_fixnum(rs)); - break; - default: { - const char *type - = "(OR RANDOM-STATE (SIMPLE-VECTOR *) (INTEGER 0 *))"; - FEwrong_type_only_arg(@[make-random-state], rs, - ecl_read_from_cstring(type)); - } - } + cl_object z = ecl_alloc_object(t_random); + const char *type + = "(OR RANDOM-STATE FIXNUM (MEMBER T NIL))"; + + if (rs == ECL_T) { + z->random.value = init_random_state(); + return z; + } else if (Null(rs)) { + rs = ecl_symbol_value(@'*random-state*'); + z->random.value = cl_copy_seq(rs->random.value); + return z; + } + + switch (ecl_t_of(rs)) { + case t_random: + z->random.value = cl_copy_seq(rs->random.value); + break; + case t_fixnum: + z->random.value = init_genrand(ecl_fixnum(rs)); + break; + case t_vector: /* intentionaly undocumented (only for internal use) */ +#if ECL_FIXNUM_BITS > 32 + if (rs->vector.dim == 313 && rs->vector.elttype == ecl_aet_b64) { + z = ecl_alloc_object(t_random); + z->random.value = cl_copy_seq(rs); + break; + } +#else /* 32 bit version */ + if (rs->vector.dim == 625 && rs->vector.elttype == ecl_aet_b32) { + z = ecl_alloc_object(t_random); + z->random.value = cl_copy_seq(rs); + break; + } +#endif + default: + FEwrong_type_only_arg(@[make-random-state], rs, + ecl_read_from_cstring(type)); + } - return(z); + return z; } @(defun random (x &optional (rs ecl_symbol_value(@'*random-state*'))) @ - rs = ecl_check_cl_type(@'random', rs, t_random); - @(return rando(x, rs)); + rs = ecl_check_cl_type(@'random', rs, t_random); + @(return rando(x, rs)); @) @(defun make_random_state (&optional (rs ECL_NIL)) @ - @(return ecl_make_random_state(rs)) + @(return ecl_make_random_state(rs)); @) cl_object cl_random_state_p(cl_object x) { - @(return (ECL_RANDOM_STATE_P(x) ? ECL_T : ECL_NIL)) + @(return (ECL_RANDOM_STATE_P(x) ? ECL_T : ECL_NIL)); +} + +cl_object +si_random_state_array(cl_object rs) { + ecl_check_cl_type(@'ext::random-state-array', rs, t_random); + return rs->random.value; } diff -Nru ecl-16.1.2/src/c/package.d ecl-16.1.3+ds/src/c/package.d --- ecl-16.1.2/src/c/package.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/package.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - package.d -- Packages. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * package.d - packages + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -41,38 +36,38 @@ static void FEpackage_error(const char *message, cl_object package, int narg, ...) { - ecl_va_list args; - ecl_va_start(args, narg, narg, 0); - si_signal_simple_error(6, - @'package-error', - ECL_NIL, /* not correctable */ - make_constant_base_string(message), /* format control */ - narg? cl_grab_rest_args(args) : cl_list(1,package), /* format args */ - @':package', package); /* extra arguments */ + ecl_va_list args; + ecl_va_start(args, narg, narg, 0); + si_signal_simple_error(6, + @'package-error', + ECL_NIL, /* not correctable */ + make_constant_base_string(message), /* format control */ + narg? cl_grab_rest_args(args) : cl_list(1,package), /* format args */ + @':package', package); /* extra arguments */ } void CEpackage_error(const char *message, const char *continue_message, cl_object package, int narg, ...) { - ecl_va_list args; - ecl_va_start(args, narg, narg, 0); - si_signal_simple_error(6, - @'package-error', - make_constant_base_string(continue_message), - make_constant_base_string(message), /* format control */ - narg? cl_grab_rest_args(args) : cl_list(1,package), - @':package', package); + ecl_va_list args; + ecl_va_start(args, narg, narg, 0); + si_signal_simple_error(6, + @'package-error', + make_constant_base_string(continue_message), + make_constant_base_string(message), /* format control */ + narg? cl_grab_rest_args(args) : cl_list(1,package), + @':package', package); } static bool member_string_eq(cl_object x, cl_object l) { - /* INV: l is a proper list */ - loop_for_on_unsafe(l) { - if (ecl_string_eq(x, ECL_CONS_CAR(l))) - return TRUE; - } end_loop_for_on_unsafe(l); - return FALSE; + /* INV: l is a proper list */ + loop_for_on_unsafe(l) { + if (ecl_string_eq(x, ECL_CONS_CAR(l))) + return TRUE; + } end_loop_for_on_unsafe(l); + return FALSE; } #if defined(__cplusplus) || (defined(__GNUC__) && !defined(__STRICT_ANSI__)) @@ -84,1025 +79,1054 @@ static INLINE void symbol_remove_package(cl_object s, cl_object p) { - if (Null(s)) - s = ECL_NIL_SYMBOL; - if (s->symbol.hpack == p) - s->symbol.hpack = ECL_NIL; + if (Null(s)) + s = ECL_NIL_SYMBOL; + if (s->symbol.hpack == p) + s->symbol.hpack = ECL_NIL; } static INLINE void symbol_add_package(cl_object s, cl_object p) { - if (Null(s)) - s = ECL_NIL_SYMBOL; - if (s->symbol.hpack == ECL_NIL) - s->symbol.hpack = p; + if (Null(s)) + s = ECL_NIL_SYMBOL; + if (s->symbol.hpack == ECL_NIL) + s->symbol.hpack = p; } /* - ecl_make_package(n, ns, ul) makes a package with name n, - which must be a string or a symbol, - and nicknames ns, which must be a list of strings or symbols, - and uses packages in list ul, which must be a list of packages - or package names i.e. strings or symbols. + ecl_make_package(n, ns, ul) makes a package with name n, + which must be a string or a symbol, + and nicknames ns, which must be a list of strings or symbols, + and uses packages in list ul, which must be a list of packages + or package names i.e. strings or symbols. */ static cl_object make_package_hashtable() { - return cl__make_hash_table(@'package', /* package hash table */ - ecl_make_fixnum(128), /* initial size */ - cl_core.rehash_size, - cl_core.rehash_threshold); + return cl__make_hash_table(@'package', /* package hash table */ + ecl_make_fixnum(128), /* initial size */ + cl_core.rehash_size, + cl_core.rehash_threshold); } static cl_object alloc_package(cl_object name) { - cl_object p = ecl_alloc_object(t_package); - p->pack.internal = make_package_hashtable(); - p->pack.external = make_package_hashtable(); - p->pack.name = name; - p->pack.nicknames = ECL_NIL; - p->pack.shadowings = ECL_NIL; - p->pack.uses = ECL_NIL; - p->pack.usedby = ECL_NIL; - p->pack.locked = FALSE; - return p; + cl_object p = ecl_alloc_object(t_package); + p->pack.internal = make_package_hashtable(); + p->pack.external = make_package_hashtable(); + p->pack.name = name; + p->pack.nicknames = ECL_NIL; + p->pack.shadowings = ECL_NIL; + p->pack.uses = ECL_NIL; + p->pack.usedby = ECL_NIL; + p->pack.locked = FALSE; + return p; } cl_object _ecl_package_to_be_created(const cl_env_ptr env, cl_object name) { - cl_object package = ecl_assoc(name, env->packages_to_be_created); - if (Null(package)) { - const cl_env_ptr env = ecl_process_env(); - package = alloc_package(name); - env->packages_to_be_created = - cl_acons(name, package, env->packages_to_be_created); - } else { - package = ECL_CONS_CDR(package); - } - return package; + cl_object package = ecl_assoc(name, env->packages_to_be_created); + if (Null(package)) { + const cl_env_ptr env = ecl_process_env(); + package = alloc_package(name); + env->packages_to_be_created = + cl_acons(name, package, env->packages_to_be_created); + } else { + package = ECL_CONS_CDR(package); + } + return package; } static cl_object find_pending_package(cl_env_ptr env, cl_object name, cl_object nicknames) { - if (ecl_option_values[ECL_OPT_BOOTED]) { - cl_object l = env->packages_to_be_created; - while (!Null(l)) { - cl_object pair = ECL_CONS_CAR(l); - cl_object other_name = ECL_CONS_CAR(pair); - if (ecl_equal(other_name, name) || - _ecl_funcall5(@'member', other_name, nicknames, - @':test', @'string=') != ECL_NIL) - { - cl_object x = ECL_CONS_CDR(pair); - env->packages_to_be_created = - ecl_remove_eq(pair, - env->packages_to_be_created); - return x; - } - l = ECL_CONS_CDR(l); - } - } - return ECL_NIL; + if (ecl_option_values[ECL_OPT_BOOTED]) { + cl_object l = env->packages_to_be_created; + while (!Null(l)) { + cl_object pair = ECL_CONS_CAR(l); + cl_object other_name = ECL_CONS_CAR(pair); + if (ecl_equal(other_name, name) || + _ecl_funcall5(@'member', other_name, nicknames, + @':test', @'string=') != ECL_NIL) + { + cl_object x = ECL_CONS_CDR(pair); + env->packages_to_be_created = + ecl_remove_eq(pair, + env->packages_to_be_created); + return x; + } + l = ECL_CONS_CDR(l); + } + } + return ECL_NIL; } static cl_object process_nicknames(cl_object nicknames) { - cl_object l; - nicknames = cl_copy_list(nicknames); - for (l = nicknames; l != ECL_NIL; l = ECL_CONS_CDR(l)) - ECL_RPLACA(l, cl_string(ECL_CONS_CAR(l))); - return nicknames; + cl_object l; + nicknames = cl_copy_list(nicknames); + for (l = nicknames; l != ECL_NIL; l = ECL_CONS_CDR(l)) + ECL_RPLACA(l, cl_string(ECL_CONS_CAR(l))); + return nicknames; } static cl_object process_package_list(cl_object packages) { - cl_object l; - packages = cl_copy_list(packages); - for (l = packages; l != ECL_NIL; l = ECL_CONS_CDR(l)) - ECL_RPLACA(l, si_coerce_to_package(ECL_CONS_CAR(l))); - return packages; + cl_object l; + packages = cl_copy_list(packages); + for (l = packages; l != ECL_NIL; l = ECL_CONS_CDR(l)) + ECL_RPLACA(l, si_coerce_to_package(ECL_CONS_CAR(l))); + return packages; } cl_object ecl_make_package(cl_object name, cl_object nicknames, cl_object use_list) { - const cl_env_ptr env = ecl_process_env(); - cl_object x, other = ECL_NIL; + const cl_env_ptr env = ecl_process_env(); + cl_object x, other = ECL_NIL; - /* Type checking, coercions, and the like, happen before we - * acquire the lock */ - name = cl_string(name); - nicknames = process_nicknames(nicknames); - use_list = process_package_list(use_list); - - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(env) { - /* Find a similarly named package in the list of - * packages to be created and use it or try to build a - * new package */ - x = find_pending_package(env, name, nicknames); - if (Null(x)) { - other = ecl_find_package_nolock(name); - if (other != ECL_NIL) { - goto OUTPUT; - } else { - x = alloc_package(name); - } - } - loop_for_in(nicknames) { - cl_object nick = ECL_CONS_CAR(nicknames); - other = ecl_find_package_nolock(nick); - if (other != ECL_NIL) { - name = nick; - goto OUTPUT; - } - x->pack.nicknames = CONS(nick, x->pack.nicknames); - } end_loop_for_in; - loop_for_in(use_list) { - cl_object y = ECL_CONS_CAR(use_list); - x->pack.uses = CONS(y, x->pack.uses); - y->pack.usedby = CONS(x, y->pack.usedby); - } end_loop_for_in; - /* Finally, add it to the list of packages */ - cl_core.packages = CONS(x, cl_core.packages); - OUTPUT: - (void)0; - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; - if (!Null(other)) { - CEpackage_error("A package with the name ~A already exists.", - "Return existing package", - other, 1, name); - return other; - } - return x; + /* Type checking, coercions, and the like, happen before we + * acquire the lock */ + name = cl_string(name); + nicknames = process_nicknames(nicknames); + use_list = process_package_list(use_list); + + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(env) { + /* Find a similarly named package in the list of + * packages to be created and use it or try to build a + * new package */ + x = find_pending_package(env, name, nicknames); + if (Null(x)) { + other = ecl_find_package_nolock(name); + if (other != ECL_NIL) { + goto OUTPUT; + } else { + x = alloc_package(name); + } + } + loop_for_in(nicknames) { + cl_object nick = ECL_CONS_CAR(nicknames); + other = ecl_find_package_nolock(nick); + if (other != ECL_NIL) { + name = nick; + goto OUTPUT; + } + x->pack.nicknames = CONS(nick, x->pack.nicknames); + } end_loop_for_in; + loop_for_in(use_list) { + cl_object y = ECL_CONS_CAR(use_list); + x->pack.uses = CONS(y, x->pack.uses); + y->pack.usedby = CONS(x, y->pack.usedby); + } end_loop_for_in; + /* Finally, add it to the list of packages */ + cl_core.packages = CONS(x, cl_core.packages); + OUTPUT: + (void)0; + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + if (!Null(other)) { + CEpackage_error("A package with the name ~A already exists.", + "Return existing package", + other, 1, name); + return other; + } + return x; } cl_object ecl_rename_package(cl_object x, cl_object name, cl_object nicknames) { - bool error; + bool error; - name = cl_string(name); - nicknames = process_nicknames(nicknames); - x = si_coerce_to_package(x); - if (x->pack.locked) { - CEpackage_error("Cannot rename locked package ~S.", - "Ignore lock and proceed", x, 0); - } - nicknames = ecl_cons(name, nicknames); - error = 0; - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { - cl_object l; - for (l = nicknames; l != ECL_NIL; l = ECL_CONS_CDR(l)) { - cl_object nick = ECL_CONS_CAR(l); - cl_object p = ecl_find_package_nolock(nick); - if ((p != ECL_NIL) && (p != x)) { - name = nick; - error = 1; - break; - } - } - if (!error) { - x->pack.name = name; - x->pack.nicknames = ECL_CONS_CDR(nicknames); - } - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; - if (error) { - FEpackage_error("A package with name ~S already exists.", x, - 1, name); - } - return x; + name = cl_string(name); + nicknames = process_nicknames(nicknames); + x = si_coerce_to_package(x); + if (x->pack.locked + && ECL_SYM_VAL(ecl_process_env(), + @'si::*ignore-package-locks*') == ECL_NIL) { + CEpackage_error("Cannot rename locked package ~S.", + "Ignore lock and proceed", x, 0); + } + nicknames = ecl_cons(name, nicknames); + error = 0; + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + cl_object l; + for (l = nicknames; l != ECL_NIL; l = ECL_CONS_CDR(l)) { + cl_object nick = ECL_CONS_CAR(l); + cl_object p = ecl_find_package_nolock(nick); + if ((p != ECL_NIL) && (p != x)) { + name = nick; + error = 1; + break; + } + } + if (!error) { + x->pack.name = name; + x->pack.nicknames = ECL_CONS_CDR(nicknames); + } + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + if (error) { + FEpackage_error("A package with name ~S already exists.", x, + 1, name); + } + return x; } /* - ecl_find_package_nolock(n) seaches for a package with name n, where n is - a valid string designator, or simply outputs n if it is a - package. - - This is not a locking routine and someone may replace the list of - packages while we are scanning it. Nevertheless, the list IS NOT - be destructively modified, which means that we are on the safe side. - Routines which need to ensure that the package list remains constant - should enforce a global lock with PACKAGE_OP_LOCK(). + ecl_find_package_nolock(n) seaches for a package with name n, where n is + a valid string designator, or simply outputs n if it is a + package. + + This is not a locking routine and someone may replace the list of + packages while we are scanning it. Nevertheless, the list IS NOT + be destructively modified, which means that we are on the safe side. + Routines which need to ensure that the package list remains constant + should enforce a global lock with PACKAGE_OP_LOCK(). */ cl_object ecl_find_package_nolock(cl_object name) { - cl_object l, p; + cl_object l, p; - if (ECL_PACKAGEP(name)) - return name; - name = cl_string(name); - l = cl_core.packages; - loop_for_on_unsafe(l) { - p = ECL_CONS_CAR(l); - if (ecl_string_eq(name, p->pack.name)) - return p; - if (member_string_eq(name, p->pack.nicknames)) - return p; - } end_loop_for_on_unsafe(l); + if (ECL_PACKAGEP(name)) + return name; + name = cl_string(name); + l = cl_core.packages; + loop_for_on_unsafe(l) { + p = ECL_CONS_CAR(l); + if (ecl_string_eq(name, p->pack.name)) + return p; + if (member_string_eq(name, p->pack.nicknames)) + return p; + } end_loop_for_on_unsafe(l); #ifdef ECL_RELATIVE_PACKAGE_NAMES - /* Note that this function may actually be called _before_ symbols are set up - * are bound! */ - if (ecl_option_values[ECL_OPT_BOOTED] && - ECL_SYM_VAL(ecl_process_env(), @'si::*relative-package-names*') != ECL_NIL) { - return si_find_relative_package(1, name); - } + /* Note that this function may actually be called _before_ symbols are set up + * are bound! */ + if (ecl_option_values[ECL_OPT_BOOTED] && + ECL_SYM_VAL(ecl_process_env(), @'si::*relative-package-names*') != ECL_NIL) { + return si_find_relative_package(1, name); + } #endif - return ECL_NIL; + return ECL_NIL; } cl_object ecl_find_package(const char *p) { - ecl_def_ct_base_string(pack_name,p,strlen(p),,); - return cl_find_package(pack_name); + ecl_def_ct_base_string(pack_name,p,strlen(p),,); + return cl_find_package(pack_name); } cl_object si_coerce_to_package(cl_object p) { - /* INV: ecl_find_package_nolock() signals an error if "p" is neither a package - nor a string */ - cl_object pp = ecl_find_package_nolock(p); - if (Null(pp)) { - FEpackage_error("There exists no package with name ~S", p, 0); - } - @(return pp); + /* INV: ecl_find_package_nolock() signals an error if "p" is neither a package + nor a string */ + cl_object pp = ecl_find_package_nolock(p); + if (Null(pp)) { + FEpackage_error("There exists no package with name ~S", p, 0); + } + @(return pp); } cl_object ecl_current_package(void) { - cl_object x = ecl_symbol_value(@'*package*'); - unlikely_if (!ECL_PACKAGEP(x)) { - const cl_env_ptr env = ecl_process_env(); - ECL_SETQ(env, @'*package*', cl_core.user_package); - FEerror("The value of *PACKAGE*, ~S, was not a package", - 1, x); - } - return x; + cl_object x = ecl_symbol_value(@'*package*'); + unlikely_if (!ECL_PACKAGEP(x)) { + const cl_env_ptr env = ecl_process_env(); + ECL_SETQ(env, @'*package*', cl_core.user_package); + FEerror("The value of *PACKAGE*, ~S, was not a package", + 1, x); + } + return x; } /* - Ecl_Intern(st, p) interns string st in package p. + Ecl_Intern(st, p) interns string st in package p. */ cl_object _ecl_intern(const char *s, cl_object p) { - int intern_flag; - cl_object str = make_constant_base_string(s); - return ecl_intern(str, p, &intern_flag); + int intern_flag; + cl_object str = make_constant_base_string(s); + return ecl_intern(str, p, &intern_flag); } cl_object ecl_intern(cl_object name, cl_object p, int *intern_flag) { - cl_object s; - bool error, ignore_error = 0; + cl_object s; + bool error, ignore_error = 0; - if (ecl_unlikely(!ECL_STRINGP(name))) - FEwrong_type_nth_arg(@[intern], 1, name, @[string]); - p = si_coerce_to_package(p); + if (ecl_unlikely(!ECL_STRINGP(name))) + FEwrong_type_nth_arg(@[intern], 1, name, @[string]); + p = si_coerce_to_package(p); AGAIN: - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { - s = find_symbol_inner(name, p, intern_flag); - if (*intern_flag) { - error = 0; - } else if (p->pack.locked && !ignore_error) { - error = 1; - } else { - s = cl_make_symbol(name); - s->symbol.hpack = p; - *intern_flag = 0; - if (p == cl_core.keyword_package) { - ecl_symbol_type_set(s, ecl_symbol_type(s) | ecl_stp_constant); - ECL_SET(s, s); - p->pack.external = - _ecl_sethash(name, p->pack.external, s); - } else { - p->pack.internal = - _ecl_sethash(name, p->pack.internal, s); - } - error = 0; - } - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; - if (error) { - CEpackage_error("Cannot intern symbol ~S in locked package ~S.", - "Ignore lock and proceed", p, 2, name, p); - ignore_error = 1; - goto AGAIN; - } - return s; + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + s = find_symbol_inner(name, p, intern_flag); + if (*intern_flag) { + error = 0; + } else if (p->pack.locked + && !ignore_error + && ECL_SYM_VAL(ecl_process_env(), + @'si::*ignore-package-locks*') == ECL_NIL) { + error = 1; + } else { + s = cl_make_symbol(name); + s->symbol.hpack = p; + *intern_flag = 0; + if (p == cl_core.keyword_package) { + ecl_symbol_type_set(s, ecl_symbol_type(s) | ecl_stp_constant); + ECL_SET(s, s); + p->pack.external = + _ecl_sethash(name, p->pack.external, s); + } else { + p->pack.internal = + _ecl_sethash(name, p->pack.internal, s); + } + error = 0; + } + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + if (error) { + CEpackage_error("Cannot intern symbol ~S in locked package ~S.", + "Ignore lock and proceed", p, 2, name, p); + ignore_error = 1; + goto AGAIN; + } + return s; } /* - find_symbol_inner(st, len, p) searches for string st of length - len in package p. + find_symbol_inner(st, len, p) searches for string st of length + len in package p. */ static cl_object find_symbol_inner(cl_object name, cl_object p, int *intern_flag) { - cl_object s, ul; + cl_object s, ul; - s = ecl_gethash_safe(name, p->pack.external, OBJNULL); - if (s != OBJNULL) { - *intern_flag = ECL_EXTERNAL; - goto OUTPUT; - } - if (p == cl_core.keyword_package) - goto NOTHING; - s = ecl_gethash_safe(name, p->pack.internal, OBJNULL); - if (s != OBJNULL) { - *intern_flag = ECL_INTERNAL; - goto OUTPUT; - } - ul = p->pack.uses; - loop_for_on_unsafe(ul) { - s = ecl_gethash_safe(name, ECL_CONS_CAR(ul)->pack.external, OBJNULL); - if (s != OBJNULL) { - *intern_flag = ECL_INHERITED; - goto OUTPUT; - } - } end_loop_for_on_unsafe(ul); + s = ecl_gethash_safe(name, p->pack.external, OBJNULL); + if (s != OBJNULL) { + *intern_flag = ECL_EXTERNAL; + goto OUTPUT; + } + if (p == cl_core.keyword_package) + goto NOTHING; + s = ecl_gethash_safe(name, p->pack.internal, OBJNULL); + if (s != OBJNULL) { + *intern_flag = ECL_INTERNAL; + goto OUTPUT; + } + ul = p->pack.uses; + loop_for_on_unsafe(ul) { + s = ecl_gethash_safe(name, ECL_CONS_CAR(ul)->pack.external, OBJNULL); + if (s != OBJNULL) { + *intern_flag = ECL_INHERITED; + goto OUTPUT; + } + } end_loop_for_on_unsafe(ul); NOTHING: - *intern_flag = 0; - s = ECL_NIL; + *intern_flag = 0; + s = ECL_NIL; OUTPUT: - return s; + return s; } cl_object ecl_find_symbol(cl_object n, cl_object p, int *intern_flag) { - cl_object s; - if (ecl_unlikely(!ECL_STRINGP(n))) - FEwrong_type_nth_arg(@[find-symbol], 1, n, @[string]); - p = si_coerce_to_package(p); - ECL_WITH_GLOBAL_ENV_RDLOCK_BEGIN(ecl_process_env()) { - s = find_symbol_inner(n, p, intern_flag); - } ECL_WITH_GLOBAL_ENV_RDLOCK_END; - return s; + cl_object s; + if (ecl_unlikely(!ECL_STRINGP(n))) + FEwrong_type_nth_arg(@[find-symbol], 1, n, @[string]); + p = si_coerce_to_package(p); + ECL_WITH_GLOBAL_ENV_RDLOCK_BEGIN(ecl_process_env()) { + s = find_symbol_inner(n, p, intern_flag); + } ECL_WITH_GLOBAL_ENV_RDLOCK_END; + return s; } static cl_object potential_unintern_conflict(cl_object name, cl_object s, cl_object p) { - cl_object x = OBJNULL; - cl_object l = p->pack.uses; - loop_for_on_unsafe(l) { - cl_object other_p = ECL_CONS_CAR(l); - cl_object y = ecl_gethash_safe(name, other_p->pack.external, OBJNULL); - if (y != OBJNULL) { - if (x == OBJNULL) { - x = y; - } else if (x != y) { - return ecl_cons(x, y); - } - } - } end_loop_for_on_unsafe(l); - return ECL_NIL; + cl_object x = OBJNULL; + cl_object l = p->pack.uses; + loop_for_on_unsafe(l) { + cl_object other_p = ECL_CONS_CAR(l); + cl_object y = ecl_gethash_safe(name, other_p->pack.external, OBJNULL); + if (y != OBJNULL) { + if (x == OBJNULL) { + x = y; + } else if (x != y) { + return ecl_cons(x, y); + } + } + } end_loop_for_on_unsafe(l); + return ECL_NIL; } bool ecl_unintern(cl_object s, cl_object p) { - cl_object conflict; - bool output = FALSE; - cl_object name = ecl_symbol_name(s); - - p = si_coerce_to_package(p); - if (p->pack.locked) { - CEpackage_error("Cannot unintern symbol ~S from locked package ~S.", - "Ignore lock and proceed", p, 2, s, p); - } - conflict = ECL_NIL; - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { - cl_object hash = p->pack.internal; - cl_object x = ecl_gethash_safe(name, hash, OBJNULL); - if (x != s) { - hash = p->pack.external; - x = ecl_gethash_safe(name, hash, OBJNULL); - if (x != s) - goto OUTPUT; - } - if (ecl_member_eq(s, p->pack.shadowings)) { - conflict = potential_unintern_conflict(name, s, p); - if (conflict != ECL_NIL) { - goto OUTPUT; - } - p->pack.shadowings = ecl_remove_eq(s, p->pack.shadowings); - } - ecl_remhash(name, hash); - symbol_remove_package(s, p); - output = TRUE; - OUTPUT: - (void)0; - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; - if (conflict != ECL_NIL) { - FEpackage_error("Cannot unintern the shadowing symbol ~S~%" - "from ~S,~%" - "because ~S and ~S will cause~%" - "a name conflict.", p, 4, s, p, - ECL_CONS_CAR(conflict), ECL_CONS_CDR(conflict)); - } - return output; + cl_object conflict; + bool output = FALSE; + cl_object name = ecl_symbol_name(s); + + p = si_coerce_to_package(p); + if (p->pack.locked + && ECL_SYM_VAL(ecl_process_env(), + @'si::*ignore-package-locks*') == ECL_NIL) { + CEpackage_error("Cannot unintern symbol ~S from locked package ~S.", + "Ignore lock and proceed", p, 2, s, p); + } + conflict = ECL_NIL; + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + cl_object hash = p->pack.internal; + cl_object x = ecl_gethash_safe(name, hash, OBJNULL); + if (x != s) { + hash = p->pack.external; + x = ecl_gethash_safe(name, hash, OBJNULL); + if (x != s) + goto OUTPUT; + } + if (ecl_member_eq(s, p->pack.shadowings)) { + conflict = potential_unintern_conflict(name, s, p); + if (conflict != ECL_NIL) { + goto OUTPUT; + } + p->pack.shadowings = ecl_remove_eq(s, p->pack.shadowings); + } + ecl_remhash(name, hash); + symbol_remove_package(s, p); + output = TRUE; + OUTPUT: + (void)0; + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + if (conflict != ECL_NIL) { + FEpackage_error("Cannot unintern the shadowing symbol ~S~%" + "from ~S,~%" + "because ~S and ~S will cause~%" + "a name conflict.", p, 4, s, p, + ECL_CONS_CAR(conflict), ECL_CONS_CDR(conflict)); + } + return output; } static cl_object potential_export_conflict(cl_object name, cl_object s, cl_object p) { - cl_object l = p->pack.usedby; - loop_for_on_unsafe(l) { - int intern_flag; - cl_object other_p = ECL_CONS_CAR(l); - cl_object x = find_symbol_inner(name, other_p, &intern_flag); - if (intern_flag && s != x && - !ecl_member_eq(x, other_p->pack.shadowings)) { - return other_p; - } - } end_loop_for_on_unsafe(l); - return ECL_NIL; + cl_object l = p->pack.usedby; + loop_for_on_unsafe(l) { + int intern_flag; + cl_object other_p = ECL_CONS_CAR(l); + cl_object x = find_symbol_inner(name, other_p, &intern_flag); + if (intern_flag && s != x && + !ecl_member_eq(x, other_p->pack.shadowings)) { + return other_p; + } + } end_loop_for_on_unsafe(l); + return ECL_NIL; } void cl_export2(cl_object s, cl_object p) { - int intern_flag, error; - cl_object other_p, name = ecl_symbol_name(s); - p = si_coerce_to_package(p); - if (p->pack.locked) - CEpackage_error("Cannot export symbol ~S from locked package ~S.", - "Ignore lock and proceed", p, 2, s, p); + int intern_flag, error; + cl_object other_p, name = ecl_symbol_name(s); + p = si_coerce_to_package(p); + if (p->pack.locked + && ECL_SYM_VAL(ecl_process_env(), + @'si::*ignore-package-locks*') == ECL_NIL) + CEpackage_error("Cannot export symbol ~S from locked package ~S.", + "Ignore lock and proceed", p, 2, s, p); AGAIN: - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { - cl_object x = find_symbol_inner(name, p, &intern_flag); - if (!intern_flag) { - error = 1; - } else if (x != s) { - error = 2; - } else if (intern_flag == ECL_EXTERNAL) { - error = 0; - } else if ((other_p = potential_export_conflict(name, s, p)) != ECL_NIL) { - error = 3; - } else { - if (intern_flag == ECL_INTERNAL) - ecl_remhash(name, p->pack.internal); - p->pack.external = _ecl_sethash(name, p->pack.external, s); - error = 0; - } - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; - if (error == 1) { - CEpackage_error("The symbol ~S is not accessible from ~S " - "and cannot be exported.", - "Import the symbol in the package and proceed.", - p, 2, s, p); - cl_import2(s, p); - goto AGAIN; - } else if (error == 2) { - FEpackage_error("Cannot export the symbol ~S from ~S,~%" - "because there is already a symbol with the same name~%" - "in the package.", p, 2, s, p); - } else if (error == 3) { - FEpackage_error("Cannot export the symbol ~S~%" - "from ~S,~%" - "because it will cause a name conflict~%" - "in ~S.", p, 3, s, p, other_p); - } + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + cl_object x = find_symbol_inner(name, p, &intern_flag); + if (!intern_flag) { + error = 1; + } else if (x != s) { + error = 2; + } else if (intern_flag == ECL_EXTERNAL) { + error = 0; + } else if ((other_p = potential_export_conflict(name, s, p)) != ECL_NIL) { + error = 3; + } else { + if (intern_flag == ECL_INTERNAL) + ecl_remhash(name, p->pack.internal); + p->pack.external = _ecl_sethash(name, p->pack.external, s); + error = 0; + } + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + if (error == 1) { + CEpackage_error("The symbol ~S is not accessible from ~S " + "and cannot be exported.", + "Import the symbol in the package and proceed.", + p, 2, s, p); + cl_import2(s, p); + goto AGAIN; + } else if (error == 2) { + FEpackage_error("Cannot export the symbol ~S from ~S,~%" + "because there is already a symbol with the same name~%" + "in the package.", p, 2, s, p); + } else if (error == 3) { + FEpackage_error("Cannot export the symbol ~S~%" + "from ~S,~%" + "because it will cause a name conflict~%" + "in ~S.", p, 3, s, p, other_p); + } } cl_object cl_delete_package(cl_object p) { - cl_object hash, l; - cl_index i; - - /* 1) Try to remove the package from the global list */ - p = ecl_find_package_nolock(p); - if (Null(p)) { - CEpackage_error("Package ~S not found. Cannot delete it.", - "Ignore error and continue", p, 0); - @(return ECL_NIL); - } - if (p->pack.locked) - CEpackage_error("Cannot delete locked package ~S.", - "Ignore lock and proceed", p, 0); - if (p == cl_core.lisp_package || p == cl_core.keyword_package) { - FEpackage_error("Cannot remove package ~S", p, 0); - } - - /* 2) Now remove the package from the other packages that use it - * and empty the package. - */ - if (Null(p->pack.name)) { - @(return ECL_NIL) - } - while (!Null(l = p->pack.uses)) { - ecl_unuse_package(ECL_CONS_CAR(l), p); - } - while (!Null(l = p->pack.usedby)) { - ecl_unuse_package(p, ECL_CONS_CAR(l)); - } + cl_object hash, l; + cl_index i; - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { - for (hash = p->pack.internal, i = 0; i < hash->hash.size; i++) - if (hash->hash.data[i].key != OBJNULL) { - cl_object s = hash->hash.data[i].value; - symbol_remove_package(s, p); - } - cl_clrhash(p->pack.internal); - for (hash = p->pack.external, i = 0; i < hash->hash.size; i++) - if (hash->hash.data[i].key != OBJNULL) { - cl_object s = hash->hash.data[i].value; - symbol_remove_package(s, p); - } - cl_clrhash(p->pack.external); - p->pack.shadowings = ECL_NIL; - p->pack.name = ECL_NIL; - /* 2) Only at the end, remove the package from the list of packages. */ - cl_core.packages = ecl_remove_eq(p, cl_core.packages); - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; - @(return ECL_T) + /* 1) Try to remove the package from the global list */ + p = ecl_find_package_nolock(p); + if (Null(p)) { + CEpackage_error("Package ~S not found. Cannot delete it.", + "Ignore error and continue", p, 0); + @(return ECL_NIL); + } + if (p->pack.locked + && ECL_SYM_VAL(ecl_process_env(), + @'si::*ignore-package-locks*') == ECL_NIL) + CEpackage_error("Cannot delete locked package ~S.", + "Ignore lock and proceed", p, 0); + if (p == cl_core.lisp_package || p == cl_core.keyword_package) { + FEpackage_error("Cannot remove package ~S", p, 0); + } + + /* 2) Now remove the package from the other packages that use it + * and empty the package. + */ + if (Null(p->pack.name)) { + @(return ECL_NIL); + } + while (!Null(l = p->pack.uses)) { + ecl_unuse_package(ECL_CONS_CAR(l), p); + } + while (!Null(l = p->pack.usedby)) { + ecl_unuse_package(p, ECL_CONS_CAR(l)); + } + + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + for (hash = p->pack.internal, i = 0; i < hash->hash.size; i++) + if (hash->hash.data[i].key != OBJNULL) { + cl_object s = hash->hash.data[i].value; + symbol_remove_package(s, p); + } + cl_clrhash(p->pack.internal); + for (hash = p->pack.external, i = 0; i < hash->hash.size; i++) + if (hash->hash.data[i].key != OBJNULL) { + cl_object s = hash->hash.data[i].value; + symbol_remove_package(s, p); + } + cl_clrhash(p->pack.external); + p->pack.shadowings = ECL_NIL; + p->pack.name = ECL_NIL; + /* 2) Only at the end, remove the package from the list of packages. */ + cl_core.packages = ecl_remove_eq(p, cl_core.packages); + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + @(return ECL_T); } void cl_unexport2(cl_object s, cl_object p) { - cl_object name = ecl_symbol_name(s); - bool error; - p = si_coerce_to_package(p); - if (p == cl_core.keyword_package) { - FEpackage_error("Cannot unexport a symbol from the keyword package.", - cl_core.keyword_package, 0); - } - if (p->pack.locked) { - CEpackage_error("Cannot unexport symbol ~S from locked package ~S.", - "Ignore lock and proceed", p, 2, s, p); - } - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { - int intern_flag; - cl_object x = find_symbol_inner(name, p, &intern_flag); - if (intern_flag == 0 || x != s) { - error = 1; - } else if (intern_flag != ECL_EXTERNAL) { - /* According to ANSI & Cltl, internal symbols are - ignored in unexport */ - error = 0; - } else { - ecl_remhash(name, p->pack.external); - p->pack.internal = _ecl_sethash(name, p->pack.internal, s); - error = 0; - } - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; - if (error) { - FEpackage_error("Cannot unexport ~S because it does not " - "belong to package ~S.", - p, 2, s, p); - } + cl_object name = ecl_symbol_name(s); + bool error; + p = si_coerce_to_package(p); + if (p == cl_core.keyword_package) { + FEpackage_error("Cannot unexport a symbol from the keyword package.", + cl_core.keyword_package, 0); + } + if (p->pack.locked + && ECL_SYM_VAL(ecl_process_env(), + @'si::*ignore-package-locks*') == ECL_NIL) { + CEpackage_error("Cannot unexport symbol ~S from locked package ~S.", + "Ignore lock and proceed", p, 2, s, p); + } + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + int intern_flag; + cl_object x = find_symbol_inner(name, p, &intern_flag); + if (intern_flag == 0 || x != s) { + error = 1; + } else if (intern_flag != ECL_EXTERNAL) { + /* According to ANSI & Cltl, internal symbols are + ignored in unexport */ + error = 0; + } else { + ecl_remhash(name, p->pack.external); + p->pack.internal = _ecl_sethash(name, p->pack.internal, s); + error = 0; + } + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + if (error) { + FEpackage_error("Cannot unexport ~S because it does not " + "belong to package ~S.", + p, 2, s, p); + } } void cl_import2(cl_object s, cl_object p) { - int intern_flag, error, ignore_error = 0; - cl_object name = ecl_symbol_name(s); - p = si_coerce_to_package(p); - if (p->pack.locked) { - CEpackage_error("Cannot import symbol ~S into locked package ~S.", - "Ignore lock and proceed", p, 2, s, p); - } - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { - cl_object x = find_symbol_inner(name, p, &intern_flag); - if (intern_flag) { - if (x != s && !ignore_error) { - error = 1; - goto OUTPUT; - } - if (intern_flag == ECL_INTERNAL || intern_flag == ECL_EXTERNAL) { - error = 0; - goto OUTPUT; - } - } - p->pack.internal = _ecl_sethash(name, p->pack.internal, s); - symbol_add_package(s, p); - error = 0; - OUTPUT: - (void)0; - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; - if (error) { - CEpackage_error("Cannot import the symbol ~S " - "from package ~A,~%" - "because there is already a symbol with the same name~%" - "in the package.", - "Ignore conflict and proceed", p, 2, s, p); - ignore_error = 1; - } + int intern_flag, error, ignore_error = 0; + cl_object name = ecl_symbol_name(s); + p = si_coerce_to_package(p); + if (p->pack.locked + && ECL_SYM_VAL(ecl_process_env(), + @'si::*ignore-package-locks*') == ECL_NIL) { + CEpackage_error("Cannot import symbol ~S into locked package ~S.", + "Ignore lock and proceed", p, 2, s, p); + } + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + cl_object x = find_symbol_inner(name, p, &intern_flag); + if (intern_flag) { + if (x != s && !ignore_error) { + error = 1; + goto OUTPUT; + } + if (intern_flag == ECL_INTERNAL || intern_flag == ECL_EXTERNAL) { + error = 0; + goto OUTPUT; + } + } + p->pack.internal = _ecl_sethash(name, p->pack.internal, s); + symbol_add_package(s, p); + error = 0; + OUTPUT: + (void)0; + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + if (error) { + CEpackage_error("Cannot import the symbol ~S " + "from package ~A,~%" + "because there is already a symbol with the same name~%" + "in the package.", + "Ignore conflict and proceed", p, 2, s, p); + ignore_error = 1; + } } void ecl_shadowing_import(cl_object s, cl_object p) { - int intern_flag; - cl_object x; - cl_object name = ecl_symbol_name(s); - p = si_coerce_to_package(p); - if (p->pack.locked) - CEpackage_error("Cannot shadowing-import symbol ~S into " - "locked package ~S.", - "Ignore lock and proceed", p, 2, s, p); - - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { - x = find_symbol_inner(name, p, &intern_flag); - if (intern_flag && intern_flag != ECL_INHERITED) { - if (x == s) { - if (!ecl_member_eq(x, p->pack.shadowings)) - p->pack.shadowings - = CONS(x, p->pack.shadowings); - goto OUTPUT; - } - if(ecl_member_eq(x, p->pack.shadowings)) - p->pack.shadowings = - ecl_remove_eq(x, p->pack.shadowings); - if (intern_flag == ECL_INTERNAL) - ecl_remhash(name, p->pack.internal); - else - ecl_remhash(name, p->pack.external); - symbol_remove_package(x, p); - } - p->pack.shadowings = CONS(s, p->pack.shadowings); - p->pack.internal = _ecl_sethash(name, p->pack.internal, s); - OUTPUT: - (void)0; - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + int intern_flag; + cl_object x; + cl_object name = ecl_symbol_name(s); + p = si_coerce_to_package(p); + if (p->pack.locked + && ECL_SYM_VAL(ecl_process_env(), + @'si::*ignore-package-locks*') == ECL_NIL) + CEpackage_error("Cannot shadowing-import symbol ~S into " + "locked package ~S.", + "Ignore lock and proceed", p, 2, s, p); + + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + x = find_symbol_inner(name, p, &intern_flag); + if (intern_flag && intern_flag != ECL_INHERITED) { + if (x == s) { + if (!ecl_member_eq(x, p->pack.shadowings)) + p->pack.shadowings + = CONS(x, p->pack.shadowings); + goto OUTPUT; + } + if(ecl_member_eq(x, p->pack.shadowings)) + p->pack.shadowings = + ecl_remove_eq(x, p->pack.shadowings); + if (intern_flag == ECL_INTERNAL) + ecl_remhash(name, p->pack.internal); + else + ecl_remhash(name, p->pack.external); + symbol_remove_package(x, p); + } + p->pack.shadowings = CONS(s, p->pack.shadowings); + p->pack.internal = _ecl_sethash(name, p->pack.internal, s); + OUTPUT: + (void)0; + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; } void ecl_shadow(cl_object s, cl_object p) { - int intern_flag; - cl_object x; + int intern_flag; + cl_object x; - /* Contrary to CLTL, in ANSI CL, SHADOW operates on strings. */ - s = cl_string(s); - p = si_coerce_to_package(p); - if (p->pack.locked) - CEpackage_error("Cannot shadow symbol ~S in locked package ~S.", - "Ignore lock and proceed", p, 2, s, p); - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { - x = find_symbol_inner(s, p, &intern_flag); - if (intern_flag != ECL_INTERNAL && intern_flag != ECL_EXTERNAL) { - x = cl_make_symbol(s); - p->pack.internal = _ecl_sethash(s, p->pack.internal, x); - x->symbol.hpack = p; - } - p->pack.shadowings = CONS(x, p->pack.shadowings); - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + /* Contrary to CLTL, in ANSI CL, SHADOW operates on strings. */ + s = cl_string(s); + p = si_coerce_to_package(p); + if (p->pack.locked + && ECL_SYM_VAL(ecl_process_env(), + @'si::*ignore-package-locks*') == ECL_NIL) + CEpackage_error("Cannot shadow symbol ~S in locked package ~S.", + "Ignore lock and proceed", p, 2, s, p); + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + x = find_symbol_inner(s, p, &intern_flag); + if (intern_flag != ECL_INTERNAL && intern_flag != ECL_EXTERNAL) { + x = cl_make_symbol(s); + p->pack.internal = _ecl_sethash(s, p->pack.internal, x); + x->symbol.hpack = p; + } + p->pack.shadowings = CONS(x, p->pack.shadowings); + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; } void ecl_use_package(cl_object x, cl_object p) { - struct ecl_hashtable_entry *hash_entries; - cl_index i, hash_length; - cl_object here, there, name; - int intern_flag, error = 0; - - x = si_coerce_to_package(x); - if (x == cl_core.keyword_package) - FEpackage_error("Cannot use keyword package.", - cl_core.keyword_package, 0); - p = si_coerce_to_package(p); - if (p == x) - return; - if (ecl_member_eq(x, p->pack.uses)) - return; - if (p == cl_core.keyword_package) - FEpackage_error("Cannot apply USE-PACKAGE on keyword package.", - cl_core.keyword_package, 0); - if (p->pack.locked) - CEpackage_error("Cannot use package ~S in locked package ~S.", - "Ignore lock and proceed", - p, 2, x, p); - - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { - hash_entries = x->pack.external->hash.data; - hash_length = x->pack.external->hash.size; - for (i = 0, error = 0; i < hash_length; i++) { - if (hash_entries[i].key != OBJNULL) { - here = hash_entries[i].value; - name = ecl_symbol_name(here); - there = find_symbol_inner(name, p, &intern_flag); - if (intern_flag && here != there - && ! ecl_member_eq(there, p->pack.shadowings)) { - error = 1; - break; - } - } - } - if (!error) { - p->pack.uses = CONS(x, p->pack.uses); - x->pack.usedby = CONS(p, x->pack.usedby); - } - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; - if (error) { - FEpackage_error("Cannot use ~S~%" - "from ~S,~%" - "because ~S and ~S will cause~%" - "a name conflict.", p, 4, x, p, here, there); - } + struct ecl_hashtable_entry *hash_entries; + cl_index i, hash_length; + cl_object here, there, name; + int intern_flag, error = 0; + + x = si_coerce_to_package(x); + if (x == cl_core.keyword_package) + FEpackage_error("Cannot use keyword package.", + cl_core.keyword_package, 0); + p = si_coerce_to_package(p); + if (p == x) + return; + if (ecl_member_eq(x, p->pack.uses)) + return; + if (p == cl_core.keyword_package) + FEpackage_error("Cannot apply USE-PACKAGE on keyword package.", + cl_core.keyword_package, 0); + if (p->pack.locked + && ECL_SYM_VAL(ecl_process_env(), + @'si::*ignore-package-locks*') == ECL_NIL) + CEpackage_error("Cannot use package ~S in locked package ~S.", + "Ignore lock and proceed", + p, 2, x, p); + + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + hash_entries = x->pack.external->hash.data; + hash_length = x->pack.external->hash.size; + for (i = 0, error = 0; i < hash_length; i++) { + if (hash_entries[i].key != OBJNULL) { + here = hash_entries[i].value; + name = ecl_symbol_name(here); + there = find_symbol_inner(name, p, &intern_flag); + if (intern_flag && here != there + && ! ecl_member_eq(there, p->pack.shadowings)) { + error = 1; + break; + } + } + } + if (!error) { + p->pack.uses = CONS(x, p->pack.uses); + x->pack.usedby = CONS(p, x->pack.usedby); + } + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + if (error) { + FEpackage_error("Cannot use ~S~%" + "from ~S,~%" + "because ~S and ~S will cause~%" + "a name conflict.", p, 4, x, p, here, there); + } } void ecl_unuse_package(cl_object x, cl_object p) { - x = si_coerce_to_package(x); - p = si_coerce_to_package(p); - if (p->pack.locked) - CEpackage_error("Cannot unuse package ~S from locked package ~S.", - "Ignore lock and proceed", - p, 2, x, p); - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { - p->pack.uses = ecl_remove_eq(x, p->pack.uses); - x->pack.usedby = ecl_remove_eq(p, x->pack.usedby); - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + x = si_coerce_to_package(x); + p = si_coerce_to_package(p); + if (p->pack.locked + && ECL_SYM_VAL(ecl_process_env(), + @'si::*ignore-package-locks*') == ECL_NIL) + CEpackage_error("Cannot unuse package ~S from locked package ~S.", + "Ignore lock and proceed", + p, 2, x, p); + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + p->pack.uses = ecl_remove_eq(x, p->pack.uses); + x->pack.usedby = ecl_remove_eq(p, x->pack.usedby); + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; } @(defun make_package (pack_name &key nicknames (use CONS(cl_core.lisp_package, ECL_NIL))) @ - /* INV: ecl_make_package() performs type checking */ - @(return ecl_make_package(pack_name, nicknames, use)) + /* INV: ecl_make_package() performs type checking */ + @(return ecl_make_package(pack_name, nicknames, use)); @) cl_object si_select_package(cl_object pack_name) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object p = si_coerce_to_package(pack_name); - ecl_return1(the_env, ECL_SETQ(the_env, @'*package*', p)); + const cl_env_ptr the_env = ecl_process_env(); + cl_object p = si_coerce_to_package(pack_name); + ecl_return1(the_env, ECL_SETQ(the_env, @'*package*', p)); } cl_object cl_find_package(cl_object p) { - @(return ecl_find_package_nolock(p)) + @(return ecl_find_package_nolock(p)); } cl_object cl_package_name(cl_object p) { - /* FIXME: name should be a fresh one */ - p = si_coerce_to_package(p); - @(return p->pack.name) + /* FIXME: name should be a fresh one */ + p = si_coerce_to_package(p); + @(return p->pack.name); } cl_object cl_package_nicknames(cl_object p) { - /* FIXME: list should be a fresh one */ - p = si_coerce_to_package(p); - @(return p->pack.nicknames) + /* FIXME: list should be a fresh one */ + p = si_coerce_to_package(p); + @(return p->pack.nicknames); } @(defun rename_package (pack new_name &o new_nicknames) @ - /* INV: ecl_rename_package() type checks and coerces pack to package */ - @(return ecl_rename_package(pack, new_name, new_nicknames)) + /* INV: ecl_rename_package() type checks and coerces pack to package */ + @(return ecl_rename_package(pack, new_name, new_nicknames)); @) cl_object cl_package_use_list(cl_object p) { - return cl_copy_list(si_coerce_to_package(p)->pack.uses); + return cl_copy_list(si_coerce_to_package(p)->pack.uses); } cl_object cl_package_used_by_list(cl_object p) { - return cl_copy_list(si_coerce_to_package(p)->pack.usedby); + return cl_copy_list(si_coerce_to_package(p)->pack.usedby); } cl_object cl_package_shadowing_symbols(cl_object p) { - return cl_copy_list(si_coerce_to_package(p)->pack.shadowings); + return cl_copy_list(si_coerce_to_package(p)->pack.shadowings); } cl_object si_package_lock(cl_object p, cl_object t) { - bool previous; - p = si_coerce_to_package(p); - previous = p->pack.locked; - p->pack.locked = (t != ECL_NIL); - @(return (previous? ECL_T : ECL_NIL)) + bool previous; + p = si_coerce_to_package(p); + previous = p->pack.locked; + p->pack.locked = (t != ECL_NIL); + @(return (previous? ECL_T : ECL_NIL)); } cl_object cl_list_all_packages() { - return cl_copy_list(cl_core.packages); + return cl_copy_list(cl_core.packages); } @(defun intern (strng &optional (p ecl_current_package()) &aux sym) - int intern_flag; + int intern_flag; @ - sym = ecl_intern(strng, p, &intern_flag); - if (intern_flag == ECL_INTERNAL) - @(return sym @':internal') - if (intern_flag == ECL_EXTERNAL) - @(return sym @':external') - if (intern_flag == ECL_INHERITED) - @(return sym @':inherited') - @(return sym ECL_NIL) + sym = ecl_intern(strng, p, &intern_flag); + if (intern_flag == ECL_INTERNAL) { + @(return sym @':internal'); + } + if (intern_flag == ECL_EXTERNAL) { + @(return sym @':external'); + } + if (intern_flag == ECL_INHERITED) { + @(return sym @':inherited'); + } + @(return sym ECL_NIL); @) @(defun find_symbol (strng &optional (p ecl_current_package())) - cl_object x; - int intern_flag; + cl_object x; + int intern_flag; @ - x = ecl_find_symbol(strng, p, &intern_flag); - if (intern_flag == ECL_INTERNAL) - @(return x @':internal') - if (intern_flag == ECL_EXTERNAL) - @(return x @':external') - if (intern_flag == ECL_INHERITED) - @(return x @':inherited') - @(return ECL_NIL ECL_NIL) + x = ecl_find_symbol(strng, p, &intern_flag); + if (intern_flag == ECL_INTERNAL) { + @(return x @':internal'); + } + if (intern_flag == ECL_EXTERNAL) { + @(return x @':external'); + } + if (intern_flag == ECL_INHERITED) { + @(return x @':inherited'); + } + @(return ECL_NIL ECL_NIL); @) @(defun unintern (symbl &optional (p ecl_current_package())) @ - @(return (ecl_unintern(symbl, p) ? ECL_T : ECL_NIL)) + @(return (ecl_unintern(symbl, p) ? ECL_T : ECL_NIL)); @) @(defun export (symbols &o (pack ecl_current_package())) @ - switch (ecl_t_of(symbols)) { - case t_symbol: - cl_export2(symbols, pack); - break; - case t_list: - pack = si_coerce_to_package(pack); - loop_for_in(symbols) { - cl_export2(ECL_CONS_CAR(symbols), pack); - } end_loop_for_in; - break; - default: - FEwrong_type_nth_arg(@[export],1,symbols, - cl_list(3,@'or',@'symbol',@'list')); - } - @(return ECL_T) + switch (ecl_t_of(symbols)) { + case t_symbol: + cl_export2(symbols, pack); + break; + case t_list: + pack = si_coerce_to_package(pack); + loop_for_in(symbols) { + cl_export2(ECL_CONS_CAR(symbols), pack); + } end_loop_for_in; + break; + default: + FEwrong_type_nth_arg(@[export],1,symbols, + cl_list(3,@'or',@'symbol',@'list')); + } + @(return ECL_T); @) @(defun unexport (symbols &o (pack ecl_current_package())) @ - switch (ecl_t_of(symbols)) { - case t_symbol: - cl_unexport2(symbols, pack); - break; - case t_list: - pack = si_coerce_to_package(pack); - loop_for_in(symbols) { - cl_unexport2(ECL_CONS_CAR(symbols), pack); - } end_loop_for_in; - break; - default: - FEwrong_type_nth_arg(@[unexport],1,symbols, - cl_list(3,@'or',@'symbol',@'list')); - } - @(return ECL_T) + switch (ecl_t_of(symbols)) { + case t_symbol: + cl_unexport2(symbols, pack); + break; + case t_list: + pack = si_coerce_to_package(pack); + loop_for_in(symbols) { + cl_unexport2(ECL_CONS_CAR(symbols), pack); + } end_loop_for_in; + break; + default: + FEwrong_type_nth_arg(@[unexport],1,symbols, + cl_list(3,@'or',@'symbol',@'list')); + } + @(return ECL_T); @) @(defun import (symbols &o (pack ecl_current_package())) @ - switch (ecl_t_of(symbols)) { - case t_symbol: - cl_import2(symbols, pack); - break; - case t_list: - pack = si_coerce_to_package(pack); - loop_for_in(symbols) { - cl_import2(ECL_CONS_CAR(symbols), pack); - } end_loop_for_in; - break; - default: - FEwrong_type_nth_arg(@[import],1,symbols, - cl_list(3,@'or',@'symbol',@'list')); - } - @(return ECL_T) + switch (ecl_t_of(symbols)) { + case t_symbol: + cl_import2(symbols, pack); + break; + case t_list: + pack = si_coerce_to_package(pack); + loop_for_in(symbols) { + cl_import2(ECL_CONS_CAR(symbols), pack); + } end_loop_for_in; + break; + default: + FEwrong_type_nth_arg(@[import],1,symbols, + cl_list(3,@'or',@'symbol',@'list')); + } + @(return ECL_T); @) @(defun shadowing_import (symbols &o (pack ecl_current_package())) @ - switch (ecl_t_of(symbols)) { - case t_symbol: - ecl_shadowing_import(symbols, pack); - break; - case t_list: - pack = si_coerce_to_package(pack); - loop_for_in(symbols) { - ecl_shadowing_import(ECL_CONS_CAR(symbols), pack); - } end_loop_for_in; - break; - default: - FEwrong_type_nth_arg(@[shadowing-import],1,symbols, - cl_list(3,@'or',@'symbol',@'list')); - } - @(return ECL_T) + switch (ecl_t_of(symbols)) { + case t_symbol: + ecl_shadowing_import(symbols, pack); + break; + case t_list: + pack = si_coerce_to_package(pack); + loop_for_in(symbols) { + ecl_shadowing_import(ECL_CONS_CAR(symbols), pack); + } end_loop_for_in; + break; + default: + FEwrong_type_nth_arg(@[shadowing-import],1,symbols, + cl_list(3,@'or',@'symbol',@'list')); + } + @(return ECL_T); @) @(defun shadow (symbols &o (pack ecl_current_package())) @ - switch (ecl_t_of(symbols)) { + switch (ecl_t_of(symbols)) { #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - case t_symbol: - case t_character: - /* Arguments to SHADOW may be: string designators ... */ - ecl_shadow(symbols, pack); - break; - case t_list: - /* ... or lists of string designators */ - pack = si_coerce_to_package(pack); - loop_for_in(symbols) { - ecl_shadow(ECL_CONS_CAR(symbols), pack); - } end_loop_for_in; - break; - default: - FEwrong_type_nth_arg(@[shadow],1,symbols, - cl_list(3,@'or',@'symbol',@'list')); - } - @(return ECL_T) + case t_base_string: + case t_symbol: + case t_character: + /* Arguments to SHADOW may be: string designators ... */ + ecl_shadow(symbols, pack); + break; + case t_list: + /* ... or lists of string designators */ + pack = si_coerce_to_package(pack); + loop_for_in(symbols) { + ecl_shadow(ECL_CONS_CAR(symbols), pack); + } end_loop_for_in; + break; + default: + FEwrong_type_nth_arg(@[shadow],1,symbols, + cl_list(3,@'or',@'symbol',@'list')); + } + @(return ECL_T); @) @(defun use_package (pack &o (pa ecl_current_package())) @ - switch (ecl_t_of(pack)) { - case t_symbol: - case t_character: - case t_base_string: + switch (ecl_t_of(pack)) { + case t_symbol: + case t_character: + case t_base_string: #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_package: - ecl_use_package(pack, pa); - break; - case t_list: - pa = si_coerce_to_package(pa); - loop_for_in(pack) { - ecl_use_package(ECL_CONS_CAR(pack), pa); - } end_loop_for_in; - break; - default: - FEwrong_type_nth_arg(@[use-package], 1, pack, - ecl_read_from_cstring("(OR SYMBOL CHARACTER STRING LIST PACKAGE)")); - } - @(return ECL_T) + case t_package: + ecl_use_package(pack, pa); + break; + case t_list: + pa = si_coerce_to_package(pa); + loop_for_in(pack) { + ecl_use_package(ECL_CONS_CAR(pack), pa); + } end_loop_for_in; + break; + default: + FEwrong_type_nth_arg(@[use-package], 1, pack, + ecl_read_from_cstring("(OR SYMBOL CHARACTER STRING LIST PACKAGE)")); + } + @(return ECL_T); @) @(defun unuse_package (pack &o (pa ecl_current_package())) @ - switch (ecl_t_of(pack)) { - case t_symbol: - case t_character: - case t_base_string: + switch (ecl_t_of(pack)) { + case t_symbol: + case t_character: + case t_base_string: #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_package: - ecl_unuse_package(pack, pa); - break; - case t_list: - pa = si_coerce_to_package(pa); - loop_for_in(pack) { - ecl_unuse_package(ECL_CONS_CAR(pack), pa); - } end_loop_for_in; - break; - default: - FEwrong_type_nth_arg(@[unuse-package], 1, pack, - ecl_read_from_cstring("(OR SYMBOL CHARACTER STRING LIST PACKAGE)")); - } - @(return ECL_T) + case t_package: + ecl_unuse_package(pack, pa); + break; + case t_list: + pa = si_coerce_to_package(pa); + loop_for_in(pack) { + ecl_unuse_package(ECL_CONS_CAR(pack), pa); + } end_loop_for_in; + break; + default: + FEwrong_type_nth_arg(@[unuse-package], 1, pack, + ecl_read_from_cstring("(OR SYMBOL CHARACTER STRING LIST PACKAGE)")); + } + @(return ECL_T); @) cl_object si_package_hash_tables(cl_object p) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object he, hi, u; - unlikely_if (!ECL_PACKAGEP(p)) - FEwrong_type_only_arg(@[si::package-hash-tables], p, @[package]); - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(the_env) { - he = si_copy_hash_table(p->pack.external); - hi = si_copy_hash_table(p->pack.internal); - u = cl_copy_list(p->pack.uses); - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; - @(return he hi u) + const cl_env_ptr the_env = ecl_process_env(); + cl_object he, hi, u; + unlikely_if (!ECL_PACKAGEP(p)) + FEwrong_type_only_arg(@[si::package-hash-tables], p, @[package]); + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(the_env) { + he = si_copy_hash_table(p->pack.external); + hi = si_copy_hash_table(p->pack.internal); + u = cl_copy_list(p->pack.uses); + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + @(return he hi u); } diff -Nru ecl-16.1.2/src/c/pathname.d ecl-16.1.3+ds/src/c/pathname.d --- ecl-16.1.2/src/c/pathname.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/pathname.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,27 +1,22 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - pathname.d -- Pathnames. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - Copyright (c) 2015, Daniel Kochmański. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * pathname.d - pathnames + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * Copyright (c) 2015 Daniel Kochmański + * + * See file 'LICENSE' for the copyright details. + * + */ /* - O.S. DEPENDENT + O.S. DEPENDENT - This file contains those functions that interpret namestrings. + This file contains those functions that interpret namestrings. */ #include @@ -45,214 +40,214 @@ static cl_object normalize_case(cl_object path, cl_object cas) { - if (cas == @':local') { - if (path->pathname.logical) - return @':upcase'; - return @':downcase'; - } else if (cas == @':common' || cas == @':downcase' || cas == @':upcase') { - return cas; - } else { - FEerror("Not a valid pathname case :~%~A", 1, cas); - } + if (cas == @':local') { + if (path->pathname.logical) + return @':upcase'; + return @':downcase'; + } else if (cas == @':common' || cas == @':downcase' || cas == @':upcase') { + return cas; + } else { + FEerror("Not a valid pathname case :~%~A", 1, cas); + } } static bool in_local_case_p(cl_object str, cl_object cas) { - if (cas == @':downcase') - return ecl_string_case(str) < 0; - return 1; + if (cas == @':downcase') + return ecl_string_case(str) < 0; + return 1; } static bool in_antilocal_case_p(cl_object str, cl_object cas) { - if (cas == @':downcase') - return ecl_string_case(str) > 0; - return 0; + if (cas == @':downcase') + return ecl_string_case(str) > 0; + return 0; } static cl_object to_local_case(cl_object str, cl_object cas) { - if (cas == @':downcase') - return cl_string_downcase(1, str); - return cl_string_upcase(1, str); + if (cas == @':downcase') + return cl_string_downcase(1, str); + return cl_string_upcase(1, str); } static cl_object host_case(cl_object host) { - if (Null(host)) - return @':local'; - if (ecl_logical_hostname_p(host)) - return @':upcase'; - return @':downcase'; + if (Null(host)) + return @':local'; + if (ecl_logical_hostname_p(host)) + return @':upcase'; + return @':downcase'; } static cl_object to_antilocal_case(cl_object str, cl_object cas) { - if (cas == @':downcase') - return cl_string_upcase(1, str); - return cl_string_upcase(1, str); + if (cas == @':downcase') + return cl_string_upcase(1, str); + return cl_string_upcase(1, str); } static cl_object translate_from_common(cl_object str, cl_object tocase) { - int string_case = ecl_string_case(str); - if (string_case > 0) { /* ALL_UPPER */ - return to_local_case(str, tocase); - } else if (string_case < 0) { /* ALL_LOWER */ - return to_antilocal_case(str, tocase); - } else { /* Mixed case goes unchanged */ - return str; - } + int string_case = ecl_string_case(str); + if (string_case > 0) { /* ALL_UPPER */ + return to_local_case(str, tocase); + } else if (string_case < 0) { /* ALL_LOWER */ + return to_antilocal_case(str, tocase); + } else { /* Mixed case goes unchanged */ + return str; + } } static cl_object translate_to_common(cl_object str, cl_object fromcase) { - if (in_local_case_p(str, fromcase)) { - return cl_string_upcase(1, str); - } else if (in_antilocal_case_p(str, fromcase)) { - return cl_string_downcase(1, str); - } else { - return str; - } + if (in_local_case_p(str, fromcase)) { + return cl_string_upcase(1, str); + } else if (in_antilocal_case_p(str, fromcase)) { + return cl_string_downcase(1, str); + } else { + return str; + } } static cl_object translate_component_case(cl_object str, cl_object fromcase, cl_object tocase) { - /* Pathnames may contain some other objects, such as symbols, - * numbers, etc, which need not be translated */ - if (str == OBJNULL) { - return str; - } else if (!ECL_STRINGP(str)) { - return str; - } else if (tocase == fromcase) { - return str; - } else if (tocase == @':common') { - return translate_to_common(str, fromcase); - } else if (fromcase == @':common') { - return translate_from_common(str, tocase); - } else { - str = translate_to_common(str, fromcase); - return translate_from_common(str, tocase); - } + /* Pathnames may contain some other objects, such as symbols, + * numbers, etc, which need not be translated */ + if (str == OBJNULL) { + return str; + } else if (!ECL_STRINGP(str)) { + return str; + } else if (tocase == fromcase) { + return str; + } else if (tocase == @':common') { + return translate_to_common(str, fromcase); + } else if (fromcase == @':common') { + return translate_from_common(str, tocase); + } else { + str = translate_to_common(str, fromcase); + return translate_from_common(str, tocase); + } } static cl_object translate_list_case(cl_object list, cl_object fromcase, cl_object tocase) { - /* If the argument is really a list, translate all strings in it and - * return this new list, else assume it is a string and translate it. - */ - if (!CONSP(list)) { - return translate_component_case(list, fromcase, tocase); - } else { - cl_object l; - list = cl_copy_list(list); - for (l = list; !ecl_endp(l); l = CDR(l)) { - /* It is safe to pass anything to translate_component_case, - * because it will only transform strings, leaving other - * object (such as symbols) unchanged.*/ - cl_object name = ECL_CONS_CAR(l); - name = ECL_LISTP(name)? - translate_list_case(name, fromcase, tocase) : - translate_component_case(name, fromcase, tocase); - ECL_RPLACA(l, name); - } - return list; - } + /* If the argument is really a list, translate all strings in it and + * return this new list, else assume it is a string and translate it. + */ + if (!CONSP(list)) { + return translate_component_case(list, fromcase, tocase); + } else { + cl_object l; + list = cl_copy_list(list); + for (l = list; !ecl_endp(l); l = CDR(l)) { + /* It is safe to pass anything to translate_component_case, + * because it will only transform strings, leaving other + * object (such as symbols) unchanged.*/ + cl_object name = ECL_CONS_CAR(l); + name = ECL_LISTP(name)? + translate_list_case(name, fromcase, tocase) : + translate_component_case(name, fromcase, tocase); + ECL_RPLACA(l, name); + } + return list; + } } static void push_substring(cl_object buffer, cl_object string, cl_index start, cl_index end) { - string = cl_string(string); - while (start < end) { - ecl_string_push_extend(buffer, ecl_char(string, start)); - start++; - } + string = cl_string(string); + while (start < end) { + ecl_string_push_extend(buffer, ecl_char(string, start)); + start++; + } } static void push_string(cl_object buffer, cl_object string) { - push_substring(buffer, string, 0, ecl_length(string)); + push_substring(buffer, string, 0, ecl_length(string)); } static cl_object destructively_check_directory(cl_object directory, bool logical, bool delete_back) { - /* This function performs two tasks - * 1) It ensures that the list is a valid directory list - * 2) It ensures that all strings in the list are valid C strings without fill pointer - * All strings are copied, thus avoiding problems with the user modifying the - * list that was passed to MAKE-PATHNAME. - * 3) Redundant :back are removed. - */ - /* INV: directory is always a list */ - cl_object ptr; - int i; - - if (!LISTP(directory)) - return @':error'; - if (Null(directory)) - return directory; - if (ECL_CONS_CAR(directory) != @':absolute' && - ECL_CONS_CAR(directory) != @':relative') - return @':error'; + /* This function performs two tasks + * 1) It ensures that the list is a valid directory list + * 2) It ensures that all strings in the list are valid C strings without fill pointer + * All strings are copied, thus avoiding problems with the user modifying the + * list that was passed to MAKE-PATHNAME. + * 3) Redundant :back are removed. + */ + /* INV: directory is always a list */ + cl_object ptr; + int i; + + if (!LISTP(directory)) + return @':error'; + if (Null(directory)) + return directory; + if (ECL_CONS_CAR(directory) != @':absolute' && + ECL_CONS_CAR(directory) != @':relative') + return @':error'; BEGIN: - for (i=0, ptr=directory; CONSP(ptr); ptr = ECL_CONS_CDR(ptr), i++) { - cl_object item = ECL_CONS_CAR(ptr); - if (item == @':back') { - if (i == 0) - return @':error'; - item = ecl_nth(i-1, directory); - if (item == @':absolute' || item == @':wild-inferiors') - return @':error'; - if (delete_back && i >= 2) { - cl_object next = ECL_CONS_CDR(ptr); - ptr = ecl_nthcdr(i-2, directory); - ECL_RPLACD(ptr, next); - i = i-2; - } - } else if (item == @':up') { - if (i == 0) - return @':error'; - item = ecl_nth(i-1, directory); - if (item == @':absolute' || item == @':wild-inferiors') - return @':error'; - } else if (item == @':relative' || item == @':absolute') { - if (i > 0) - return @':error'; - } else if (ecl_stringp(item)) { - cl_index l = ecl_length(item); - item = cl_copy_seq(item); - ECL_RPLACA(ptr, item); - if (logical) - continue; - if (l && ecl_char(item,0) == '.') { - if (l == 1) { - /* Single dot */ - if (i == 0) - return @':error'; - ECL_RPLACD(ecl_nthcdr(--i, directory), - ECL_CONS_CDR(ptr)); - } else if (l == 2 && ecl_char(item,1) == '.') { - ECL_RPLACA(ptr, @':up'); - goto BEGIN; - } - } - } else if (item != @':wild' && item != @':wild-inferiors') { - return @':error'; - } - } - return directory; + for (i=0, ptr=directory; CONSP(ptr); ptr = ECL_CONS_CDR(ptr), i++) { + cl_object item = ECL_CONS_CAR(ptr); + if (item == @':back') { + if (i == 0) + return @':error'; + item = ecl_nth(i-1, directory); + if (item == @':absolute' || item == @':wild-inferiors') + return @':error'; + if (delete_back && i >= 2) { + cl_object next = ECL_CONS_CDR(ptr); + ptr = ecl_nthcdr(i-2, directory); + ECL_RPLACD(ptr, next); + i = i-2; + } + } else if (item == @':up') { + if (i == 0) + return @':error'; + item = ecl_nth(i-1, directory); + if (item == @':absolute' || item == @':wild-inferiors') + return @':error'; + } else if (item == @':relative' || item == @':absolute') { + if (i > 0) + return @':error'; + } else if (ecl_stringp(item)) { + cl_index l = ecl_length(item); + item = cl_copy_seq(item); + ECL_RPLACA(ptr, item); + if (logical) + continue; + if (l && ecl_char(item,0) == '.') { + if (l == 1) { + /* Single dot */ + if (i == 0) + return @':error'; + ECL_RPLACD(ecl_nthcdr(--i, directory), + ECL_CONS_CDR(ptr)); + } else if (l == 2 && ecl_char(item,1) == '.') { + ECL_RPLACA(ptr, @':up'); + goto BEGIN; + } + } + } else if (item != @':wild' && item != @':wild-inferiors') { + return @':error'; + } + } + return directory; } cl_object @@ -260,119 +255,119 @@ cl_object name, cl_object type, cl_object version, cl_object fromcase) { - cl_object x, p, component; + cl_object x, p, component; - p = ecl_alloc_object(t_pathname); - if (ecl_stringp(host)) - p->pathname.logical = ecl_logical_hostname_p(host); - else if (host == ECL_NIL) - p->pathname.logical = FALSE; - else { - x = directory; - component = @':host'; - goto ERROR; - } - if (device != ECL_NIL && device != @':unspecific' && - !(!p->pathname.logical && ecl_stringp(device))) { - x = device; - component = @':device'; - goto ERROR; - } - if (name != ECL_NIL && name != @':wild' && !ecl_stringp(name)) { - x = name; - component = @':name'; - goto ERROR; - } - if (type != ECL_NIL && type != @':unspecific' && type != @':wild' && !ecl_stringp(type)) { - x = type; - component = @':type'; - goto ERROR; - } - if (version != @':unspecific' && version != @':newest' && - version != @':wild' && version != ECL_NIL && !ECL_FIXNUMP(version)) - { - x = version; - component = @':version'; - ERROR: FEerror("~s is not a valid pathname-~a component", 2, x, component); - } - switch (ecl_t_of(directory)) { + p = ecl_alloc_object(t_pathname); + if (ecl_stringp(host)) + p->pathname.logical = ecl_logical_hostname_p(host); + else if (host == ECL_NIL) + p->pathname.logical = FALSE; + else { + x = directory; + component = @':host'; + goto ERROR; + } + if (device != ECL_NIL && device != @':unspecific' && + !(!p->pathname.logical && ecl_stringp(device))) { + x = device; + component = @':device'; + goto ERROR; + } + if (name != ECL_NIL && name != @':wild' && !ecl_stringp(name)) { + x = name; + component = @':name'; + goto ERROR; + } + if (type != ECL_NIL && type != @':unspecific' && type != @':wild' && !ecl_stringp(type)) { + x = type; + component = @':type'; + goto ERROR; + } + if (version != @':unspecific' && version != @':newest' && + version != @':wild' && version != ECL_NIL && !ECL_FIXNUMP(version)) + { + x = version; + component = @':version'; + ERROR: FEerror("~s is not a valid pathname-~a component", 2, x, component); + } + switch (ecl_t_of(directory)) { #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - directory = cl_list(2, @':absolute', directory); - break; - case t_symbol: - if (directory == @':wild') { - directory = cl_list(2, @':absolute', @':wild-inferiors'); - break; - } - x = directory; - component = @':directory'; - goto ERROR; - case t_list: - directory = cl_copy_list(directory); - break; - default: - x = directory; - component = @':directory'; - goto ERROR; - } - p->pathname.host = host; - { - cl_object tocase = normalize_case(p, @':local'); - if (p->pathname.logical) - fromcase = @':common'; - else - fromcase = normalize_case(p, fromcase); - p->pathname.host = - translate_component_case(host, fromcase, tocase); - p->pathname.device = - translate_component_case(device, fromcase, tocase); - p->pathname.directory = - directory = - translate_list_case(directory, fromcase, tocase); - p->pathname.name = - translate_component_case(name, fromcase, tocase); - p->pathname.type = - translate_component_case(type, fromcase, tocase); - p->pathname.version = version; - } - directory = destructively_check_directory(directory, p->pathname.logical, 0); - unlikely_if (directory == @':error') { - cl_error(3, @'file-error', @':pathname', p); - } - p->pathname.directory = directory; - return(p); + case t_base_string: + directory = cl_list(2, @':absolute', directory); + break; + case t_symbol: + if (directory == @':wild') { + directory = cl_list(2, @':absolute', @':wild-inferiors'); + break; + } + x = directory; + component = @':directory'; + goto ERROR; + case t_list: + directory = cl_copy_list(directory); + break; + default: + x = directory; + component = @':directory'; + goto ERROR; + } + p->pathname.host = host; + { + cl_object tocase = normalize_case(p, @':local'); + if (p->pathname.logical) + fromcase = @':common'; + else + fromcase = normalize_case(p, fromcase); + p->pathname.host = + translate_component_case(host, fromcase, tocase); + p->pathname.device = + translate_component_case(device, fromcase, tocase); + p->pathname.directory = + directory = + translate_list_case(directory, fromcase, tocase); + p->pathname.name = + translate_component_case(name, fromcase, tocase); + p->pathname.type = + translate_component_case(type, fromcase, tocase); + p->pathname.version = version; + } + directory = destructively_check_directory(directory, p->pathname.logical, 0); + unlikely_if (directory == @':error') { + cl_error(3, @'file-error', @':pathname', p); + } + p->pathname.directory = directory; + return(p); } static cl_object tilde_expand(cl_object pathname) { - /* - * If the pathname is a physical one, without hostname, without device - * and the first element is either a tilde '~' or '~' followed by - * a user name, we merge the user homedir pathname with this one. - */ - cl_object directory, head; - if (pathname->pathname.logical || pathname->pathname.host != ECL_NIL - || pathname->pathname.device != ECL_NIL) { - return pathname; - } - directory = pathname->pathname.directory; - if (!CONSP(directory) || ECL_CONS_CAR(directory) != @':relative' - || ECL_CONS_CDR(directory) == ECL_NIL) { - return pathname; - } - head = CADR(directory); - if (ecl_stringp(head) && ecl_length(head) > 0 && - ecl_char(head,0) == '~') { - /* Remove the tilde component */ - ECL_RPLACD(directory, CDDR(directory)); - pathname = cl_merge_pathnames(2, pathname, - ecl_homedir_pathname(head)); - } - return pathname; + /* + * If the pathname is a physical one, without hostname, without device + * and the first element is either a tilde '~' or '~' followed by + * a user name, we merge the user homedir pathname with this one. + */ + cl_object directory, head; + if (pathname->pathname.logical || pathname->pathname.host != ECL_NIL + || pathname->pathname.device != ECL_NIL) { + return pathname; + } + directory = pathname->pathname.directory; + if (!CONSP(directory) || ECL_CONS_CAR(directory) != @':relative' + || ECL_CONS_CDR(directory) == ECL_NIL) { + return pathname; + } + head = CADR(directory); + if (ecl_stringp(head) && ecl_length(head) > 0 && + ecl_char(head,0) == '~') { + /* Remove the tilde component */ + ECL_RPLACD(directory, CDDR(directory)); + pathname = cl_merge_pathnames(2, pathname, + ecl_homedir_pathname(head)); + } + return pathname; } #define WORD_INCLUDE_DELIM 1 @@ -387,7 +382,7 @@ static cl_object make_one(cl_object s, cl_index start, cl_index end) { - return cl_subseq(3, s, ecl_make_fixnum(start), ecl_make_fixnum(end)); + return cl_subseq(3, s, ecl_make_fixnum(start), ecl_make_fixnum(end)); } static int is_colon(int c) { return c == ':'; } @@ -411,80 +406,80 @@ parse_word(cl_object s, delim_fn delim, int flags, cl_index start, cl_index end, cl_index *end_of_word) { - cl_index i, j, last_delim = end; - bool wild_inferiors = FALSE; + cl_index i, j, last_delim = end; + bool wild_inferiors = FALSE; - i = j = start; - for (; i < end; i++) { - bool valid_char; - cl_index c = ecl_char(s, i); - if (delim(c)) { - if ((i == start) && (flags & WORD_ALLOW_LEADING_DOT)) { - /* Leading dot is included */ - continue; - } - last_delim = i; - if (!(flags & WORD_SEARCH_LAST_DOT)) { - break; - } - } - if (c == '*') { - if (!(flags & WORD_ALLOW_ASTERISK)) - valid_char = FALSE; /* Asterisks not allowed in this word */ - else { - wild_inferiors = (i > start && ecl_char(s, i-1) == '*'); - valid_char = TRUE; /* single "*" */ - } - } else if (c == ';' && (flags & WORD_DISALLOW_SEMICOLON)) { - valid_char = 0; - } else if (c == '/' && (flags & WORD_DISALLOW_SLASH)) { - valid_char = 0; - } else { - valid_char = c != 0; - } - if (!valid_char) { - *end_of_word = start; - return @':error'; - } - } - if (i > last_delim) { - /* Go back to the position of the last delimiter */ - i = last_delim; - } - if (i < end) { - *end_of_word = i+1; - } else { - *end_of_word = end; - /* We have reached the end of the string without finding - the proper delimiter */ - if (flags & WORD_INCLUDE_DELIM) { - *end_of_word = start; - return ECL_NIL; - } - } - switch(i-j) { - case 0: - if (flags & WORD_EMPTY_IS_NIL) - return ECL_NIL; - return cl_core.null_string; - case 1: - if (ecl_char(s,j) == '*') - return @':wild'; - break; - case 2: { - cl_index c0 = ecl_char(s,j); - cl_index c1 = ecl_char(s,j+1); - if (c0 == '*' && c1 == '*') - return @':wild-inferiors'; - if (!(flags & WORD_LOGICAL) && c0 == '.' && c1 == '.') - return @':up'; - break; - } - default: - if (wild_inferiors) /* '**' surrounded by other characters */ - return @':error'; - } - return make_one(s, j, i); + i = j = start; + for (; i < end; i++) { + bool valid_char; + cl_index c = ecl_char(s, i); + if (delim(c)) { + if ((i == start) && (flags & WORD_ALLOW_LEADING_DOT)) { + /* Leading dot is included */ + continue; + } + last_delim = i; + if (!(flags & WORD_SEARCH_LAST_DOT)) { + break; + } + } + if (c == '*') { + if (!(flags & WORD_ALLOW_ASTERISK)) + valid_char = FALSE; /* Asterisks not allowed in this word */ + else { + wild_inferiors = (i > start && ecl_char(s, i-1) == '*'); + valid_char = TRUE; /* single "*" */ + } + } else if (c == ';' && (flags & WORD_DISALLOW_SEMICOLON)) { + valid_char = 0; + } else if (c == '/' && (flags & WORD_DISALLOW_SLASH)) { + valid_char = 0; + } else { + valid_char = c != 0; + } + if (!valid_char) { + *end_of_word = start; + return @':error'; + } + } + if (i > last_delim) { + /* Go back to the position of the last delimiter */ + i = last_delim; + } + if (i < end) { + *end_of_word = i+1; + } else { + *end_of_word = end; + /* We have reached the end of the string without finding + the proper delimiter */ + if (flags & WORD_INCLUDE_DELIM) { + *end_of_word = start; + return ECL_NIL; + } + } + switch(i-j) { + case 0: + if (flags & WORD_EMPTY_IS_NIL) + return ECL_NIL; + return cl_core.null_string; + case 1: + if (ecl_char(s,j) == '*') + return @':wild'; + break; + case 2: { + cl_index c0 = ecl_char(s,j); + cl_index c1 = ecl_char(s,j+1); + if (c0 == '*' && c1 == '*') + return @':wild-inferiors'; + if (!(flags & WORD_LOGICAL) && c0 == '.' && c1 == '.') + return @':up'; + break; + } + default: + if (wild_inferiors) /* '**' surrounded by other characters */ + return @':error'; + } + return make_one(s, j, i); } /* @@ -500,37 +495,37 @@ parse_directories(cl_object s, int flags, cl_index start, cl_index end, cl_index *end_of_dir) { - cl_index i, j; - cl_object path = ECL_NIL; - delim_fn delim = (flags & WORD_LOGICAL) ? is_semicolon : is_slash; - - flags |= WORD_INCLUDE_DELIM | WORD_ALLOW_ASTERISK; - *end_of_dir = start; - for (i = j = start; i < end; j = i) { - cl_object part = parse_word(s, delim, flags, j, end, &i); - if (part == @':error' || part == ECL_NIL) - break; - if (part == cl_core.null_string) { /* "/", ";" */ - if (j != start) { - if (flags & WORD_LOGICAL) - return @':error'; - *end_of_dir = i; - continue; - } - part = (flags & WORD_LOGICAL) ? @':relative' : @':absolute'; - } - *end_of_dir = i; - path = ecl_cons(part, path); - } - return cl_nreverse(path); + cl_index i, j; + cl_object path = ECL_NIL; + delim_fn delim = (flags & WORD_LOGICAL) ? is_semicolon : is_slash; + + flags |= WORD_INCLUDE_DELIM | WORD_ALLOW_ASTERISK; + *end_of_dir = start; + for (i = j = start; i < end; j = i) { + cl_object part = parse_word(s, delim, flags, j, end, &i); + if (part == @':error' || part == ECL_NIL) + break; + if (part == cl_core.null_string) { /* "/", ";" */ + if (j != start) { + if (flags & WORD_LOGICAL) + return @':error'; + *end_of_dir = i; + continue; + } + part = (flags & WORD_LOGICAL) ? @':relative' : @':absolute'; + } + *end_of_dir = i; + path = ecl_cons(part, path); + } + return cl_nreverse(path); } bool ecl_logical_hostname_p(cl_object host) { - if (!ecl_stringp(host)) - return FALSE; - return !Null(@assoc(4, host, cl_core.pathname_translations, @':test', @'string-equal')); + if (!ecl_stringp(host)) + return FALSE; + return !Null(@assoc(4, host, cl_core.pathname_translations, @':test', @'string-equal')); } /* @@ -563,281 +558,285 @@ ecl_parse_namestring(cl_object s, cl_index start, cl_index end, cl_index *ep, cl_object default_host) { - cl_object host, device, path, name, type, aux, version; - bool logical; + cl_object host, device, path, name, type, aux, version; + bool logical; - if (start == end) { - host = device = path = name = type = aux = version = @'nil'; - logical = 0; - goto make_it; - } - /* We first try parsing as logical-pathname. In case of - * failure, physical-pathname parsing is performed only when - * there is no supplied *logical* host name. All other failures - * result in ECL_NIL as output. - */ - host = parse_word(s, is_colon, WORD_LOGICAL | WORD_INCLUDE_DELIM | - WORD_DISALLOW_SEMICOLON, start, end, ep); - if (default_host != ECL_NIL) { - if (host == ECL_NIL || host == @':error') - host = default_host; - } - if (!ecl_logical_hostname_p(host)) - goto physical; - /* - * Logical pathname format: - * [logical-hostname:][;][logical-directory-component;][pathname-name][.pathname-type] - */ - logical = TRUE; - device = @':unspecific'; - path = parse_directories(s, WORD_LOGICAL, *ep, end, ep); - if (CONSP(path)) { - if (ECL_CONS_CAR(path) != @':relative' && - ECL_CONS_CAR(path) != @':absolute') - path = CONS(@':absolute', path); - path = destructively_check_directory(path, TRUE, FALSE); - } else { - path = CONS(@':absolute', path); - } - if (path == @':error') - return ECL_NIL; - name = parse_word(s, is_dot, WORD_LOGICAL | WORD_ALLOW_ASTERISK | - WORD_EMPTY_IS_NIL, *ep, end, ep); - if (name == @':error') - return ECL_NIL; - type = ECL_NIL; - version = ECL_NIL; - if (*ep == start || ecl_char(s, *ep-1) != '.') - goto make_it; - type = parse_word(s, is_dot, WORD_LOGICAL | WORD_ALLOW_ASTERISK | - WORD_EMPTY_IS_NIL, *ep, end, ep); - if (type == @':error') - return ECL_NIL; - if (*ep == start || ecl_char(s, *ep-1) != '.') - goto make_it; - aux = parse_word(s, is_null, WORD_LOGICAL | WORD_ALLOW_ASTERISK | - WORD_EMPTY_IS_NIL, *ep, end, ep); - if (aux == @':error') { - return ECL_NIL; - } else if (ECL_SYMBOLP(aux)) { - version = aux; - } else { - const cl_env_ptr the_env = ecl_process_env(); - cl_object parsed_length; - version = cl_parse_integer(3, aux, @':junk-allowed', ECL_T); - parsed_length = ecl_nth_value(the_env, 1); - if (ecl_fixnum(parsed_length) == ecl_length(aux) && - cl_integerp(version) != ECL_NIL && ecl_plusp(version)) - ; - else if (cl_string_equal(2, aux, @':newest') != ECL_NIL) - version = @':newest'; - else - return ECL_NIL; - } - goto make_it; + if (start == end) { + host = device = path = name = type = aux = version = @'nil'; + logical = 0; + goto make_it; + } + /* We first try parsing as logical-pathname. In case of + * failure, physical-pathname parsing is performed only when + * there is no supplied *logical* host name. All other failures + * result in ECL_NIL as output. + */ + host = parse_word(s, is_colon, WORD_LOGICAL | WORD_INCLUDE_DELIM | + WORD_DISALLOW_SEMICOLON, start, end, ep); + if (default_host != ECL_NIL) { + if (host == ECL_NIL || host == @':error') + host = default_host; + } + if (!ecl_logical_hostname_p(host)) + goto physical; + /* + * Logical pathname format: + * [logical-hostname:][;][logical-directory-component;][pathname-name][.pathname-type] + */ + logical = TRUE; + device = @':unspecific'; + path = parse_directories(s, WORD_LOGICAL, *ep, end, ep); + if (CONSP(path)) { + if (ECL_CONS_CAR(path) != @':relative' && + ECL_CONS_CAR(path) != @':absolute') + path = CONS(@':absolute', path); + path = destructively_check_directory(path, TRUE, FALSE); + } else { + path = CONS(@':absolute', path); + } + if (path == @':error') + return ECL_NIL; + name = parse_word(s, is_dot, WORD_LOGICAL | WORD_ALLOW_ASTERISK | + WORD_EMPTY_IS_NIL, *ep, end, ep); + if (name == @':error') + return ECL_NIL; + type = ECL_NIL; + version = ECL_NIL; + if (*ep == start || ecl_char(s, *ep-1) != '.') + goto make_it; + type = parse_word(s, is_dot, WORD_LOGICAL | WORD_ALLOW_ASTERISK | + WORD_EMPTY_IS_NIL, *ep, end, ep); + if (type == @':error') + return ECL_NIL; + if (*ep == start || ecl_char(s, *ep-1) != '.') + goto make_it; + aux = parse_word(s, is_null, WORD_LOGICAL | WORD_ALLOW_ASTERISK | + WORD_EMPTY_IS_NIL, *ep, end, ep); + if (aux == @':error') { + return ECL_NIL; + } else if (ECL_SYMBOLP(aux)) { + version = aux; + } else { + const cl_env_ptr the_env = ecl_process_env(); + cl_object parsed_length; + version = cl_parse_integer(3, aux, @':junk-allowed', ECL_T); + parsed_length = ecl_nth_value(the_env, 1); + if (ecl_fixnum(parsed_length) == ecl_length(aux) && + cl_integerp(version) != ECL_NIL && ecl_plusp(version)) + ; + else if (cl_string_equal(2, aux, @':newest') != ECL_NIL) + version = @':newest'; + else + return ECL_NIL; + } + goto make_it; physical: - /* - * Physical pathname format: - * [[device:[//hostname]]/][directory-component/]*[pathname-name][.pathname-type] - */ - logical = FALSE; - /* We only parse a hostname when the device was present. This - * requisite is a bit stupid and only applies to the Unix port, - * where "//home/" is equivalent to "/home" However, in Windows - * we need "//FOO/" to be separately handled, for it is a shared - * resource. - */ + /* + * Physical pathname format: + * [[device:[//hostname]]/][directory-component/]*[pathname-name][.pathname-type] + */ + logical = FALSE; + /* We only parse a hostname when the device was present. This + * requisite is a bit stupid and only applies to the Unix port, + * where "//home/" is equivalent to "/home" However, in Windows + * we need "//FOO/" to be separately handled, for it is a shared + * resource. + */ #if defined(ECL_MS_WINDOWS_HOST) - if ((start+1 <= end) && is_slash(ecl_char(s, start))) { - device = ECL_NIL; - goto maybe_parse_host; - } + if ((start+1 <= end) && is_slash(ecl_char(s, start))) { + device = ECL_NIL; + goto maybe_parse_host; + } #endif - device = parse_word(s, is_colon, WORD_INCLUDE_DELIM | WORD_EMPTY_IS_NIL | - WORD_DISALLOW_SLASH, start, end, ep); - if (device == @':error' || device == ECL_NIL) { - device = ECL_NIL; - host = ECL_NIL; - goto done_device_and_host; - } - if (!ecl_stringp(device)) { - return ECL_NIL; - } + device = parse_word(s, is_colon, WORD_INCLUDE_DELIM | WORD_EMPTY_IS_NIL | + WORD_DISALLOW_SLASH, start, end, ep); + if (device == @':error' || device == ECL_NIL) { + device = ECL_NIL; + host = ECL_NIL; + goto done_device_and_host; + } + if (!ecl_stringp(device)) { + return ECL_NIL; + } maybe_parse_host: - /* Files have no effective device. */ - if (@string-equal(2, device, @':file') == ECL_T) - device = ECL_NIL; - start = *ep; + /* Files have no effective device. */ + if (@string-equal(2, device, @':file') == ECL_T) + device = ECL_NIL; + start = *ep; + host = ECL_NIL; + if ((start+2) <= end && is_slash(ecl_char(s, start)) && + is_slash(ecl_char(s, start+1))) + { + host = parse_word(s, is_slash, WORD_EMPTY_IS_NIL, + start+2, end, ep); + if (host == @':error') { host = ECL_NIL; - if ((start+2) <= end && is_slash(ecl_char(s, start)) && - is_slash(ecl_char(s, start+1))) - { - host = parse_word(s, is_slash, WORD_EMPTY_IS_NIL, - start+2, end, ep); - if (host == @':error') { - host = ECL_NIL; - } else if (host != ECL_NIL) { - if (!ecl_stringp(host)) - return ECL_NIL; - start = *ep; - if (is_slash(ecl_char(s,--start))) - *ep = start; - } - } - if (ecl_length(device) == 0) - device = ECL_NIL; - done_device_and_host: - path = parse_directories(s, 0, *ep, end, ep); - if (CONSP(path)) { - if (ECL_CONS_CAR(path) != @':relative' && - ECL_CONS_CAR(path) != @':absolute') - path = CONS(@':relative', path); - path = destructively_check_directory(path, FALSE, FALSE); - } - if (path == @':error') - return ECL_NIL; + } else if (host != ECL_NIL) { + if (!ecl_stringp(host)) + return ECL_NIL; start = *ep; - name = parse_word(s, is_dot, - WORD_ALLOW_LEADING_DOT | WORD_SEARCH_LAST_DOT | - WORD_ALLOW_ASTERISK | WORD_EMPTY_IS_NIL, - start, end, ep); - if (name == @':error') - return ECL_NIL; - if ((*ep - start) <= 1 || ecl_char(s, *ep-1) != '.') { - type = ECL_NIL; - } else { - type = parse_word(s, is_null, WORD_ALLOW_ASTERISK, *ep, end, ep); - if (type == @':error') - return ECL_NIL; - } - version = (name != ECL_NIL || type != ECL_NIL) ? @':newest' : ECL_NIL; + if (is_slash(ecl_char(s,--start))) + *ep = start; + } + } + if (ecl_length(device) == 0) + device = ECL_NIL; + done_device_and_host: + path = parse_directories(s, 0, *ep, end, ep); + if (CONSP(path)) { + if (ECL_CONS_CAR(path) != @':relative' && + ECL_CONS_CAR(path) != @':absolute') + path = CONS(@':relative', path); + path = destructively_check_directory(path, FALSE, FALSE); + } + if (path == @':error') + return ECL_NIL; + start = *ep; + name = parse_word(s, is_dot, + WORD_ALLOW_LEADING_DOT | WORD_SEARCH_LAST_DOT | + WORD_ALLOW_ASTERISK | WORD_EMPTY_IS_NIL, + start, end, ep); + if (name == @':error') + return ECL_NIL; + if ((*ep - start) <= 1 || ecl_char(s, *ep-1) != '.') { + type = ECL_NIL; + } else { + type = parse_word(s, is_null, WORD_ALLOW_ASTERISK, *ep, end, ep); + if (type == @':error') + return ECL_NIL; + } + version = (name != ECL_NIL || type != ECL_NIL) ? @':newest' : ECL_NIL; make_it: - if (*ep >= end) *ep = end; - path = ecl_make_pathname(host, device, path, name, type, version, - @':local'); - path->pathname.logical = logical; - return tilde_expand(path); + if (*ep >= end) *ep = end; + path = ecl_make_pathname(host, device, path, name, type, version, + @':local'); + path->pathname.logical = logical; + return tilde_expand(path); } cl_object si_default_pathname_defaults(void) { - /* This routine outputs the value of *default-pathname-defaults* - * coerced to type PATHNAME. Special care is taken so that we do - * not enter an infinite loop when using PARSE-NAMESTRING, because - * this routine might itself try to use the value of this variable. */ - cl_object path = ecl_symbol_value(@'*default-pathname-defaults*'); - unlikely_if (!ECL_PATHNAMEP(path)) { - const cl_env_ptr the_env = ecl_process_env(); - ecl_bds_bind(the_env, @'*default-pathname-defaults*', si_getcwd(0)); - FEwrong_type_key_arg(@[pathname], @[*default-pathname-defaults*], - path, @'pathname'); - } - @(return path) + /* This routine outputs the value of *default-pathname-defaults* + * coerced to type PATHNAME. Special care is taken so that we do + * not enter an infinite loop when using PARSE-NAMESTRING, because + * this routine might itself try to use the value of this variable. */ + cl_object path = ecl_symbol_value(@'*default-pathname-defaults*'); + unlikely_if (!ECL_PATHNAMEP(path)) { + const cl_env_ptr the_env = ecl_process_env(); + ecl_bds_bind(the_env, @'*default-pathname-defaults*', si_getcwd(0)); + FEwrong_type_key_arg(@[pathname], @[*default-pathname-defaults*], + path, @'pathname'); + } + @(return path); } cl_object cl_pathname(cl_object x) { -L: - switch (ecl_t_of(x)) { + L: + switch (ecl_t_of(x)) { #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - x = cl_parse_namestring(1, x); - case t_pathname: - break; - case t_stream: - switch ((enum ecl_smmode)x->stream.mode) { - case ecl_smm_input: - case ecl_smm_output: - case ecl_smm_probe: - case ecl_smm_io: - case ecl_smm_input_file: - case ecl_smm_output_file: - case ecl_smm_io_file: - x = IO_STREAM_FILENAME(x); - goto L; - case ecl_smm_synonym: - x = SYNONYM_STREAM_STREAM(x); - goto L; - default: - ;/* Fall through to error message */ - } - default: { - const char *type = "(OR FILE-STREAM STRING PATHNAME)"; - FEwrong_type_only_arg(@[pathname], x, ecl_read_from_cstring(type)); - } - } - @(return x) + case t_base_string: + x = cl_parse_namestring(1, x); + case t_pathname: + break; + case t_stream: + switch ((enum ecl_smmode)x->stream.mode) { + case ecl_smm_input: + case ecl_smm_output: + case ecl_smm_probe: + case ecl_smm_io: + case ecl_smm_input_file: + case ecl_smm_output_file: + case ecl_smm_io_file: + x = IO_STREAM_FILENAME(x); + goto L; + case ecl_smm_synonym: + x = SYNONYM_STREAM_STREAM(x); + goto L; + default: + ;/* Fall through to error message */ + } + default: { + const char *type = "(OR FILE-STREAM STRING PATHNAME)"; + FEwrong_type_only_arg(@[pathname], x, ecl_read_from_cstring(type)); + } + } + @(return x); } cl_object cl_logical_pathname(cl_object x) { - x = cl_pathname(x); - if (!x->pathname.logical) { - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("~S cannot be coerced to a logical pathname."), - @':format-arguments', cl_list(1, x), - @':expected-type', @'logical-pathname', - @':datum', x); - } - @(return x); + x = cl_pathname(x); + if (!x->pathname.logical) { + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("~S cannot be coerced to a logical pathname."), + @':format-arguments', cl_list(1, x), + @':expected-type', @'logical-pathname', + @':datum', x); + } + @(return x); } /* FIXME! WILD-PATHNAME-P is missing! */ @(defun wild-pathname-p (pathname &optional component) - bool checked = 0; + bool checked = 0; @ - pathname = cl_pathname(pathname); - if (component == ECL_NIL || component == @':host') { - if (pathname->pathname.host == @':wild') - @(return ECL_T); - checked = 1; - } - if (component == ECL_NIL || component == @':device') { - if (pathname->pathname.device == @':wild') - @(return ECL_T); - checked = 1; - } - if (component == ECL_NIL || component == @':version') { - if (pathname->pathname.version == @':wild') - @(return ECL_T); - checked = 1; - } - if (component == ECL_NIL || component == @':name') { - cl_object name = pathname->pathname.name; - if (name != ECL_NIL && - (name == @':wild' || ecl_wild_string_p(name))) - @(return ECL_T); - checked = 1; - } - if (component == ECL_NIL || component == @':type') { - cl_object name = pathname->pathname.type; - if (name != ECL_NIL && - (name == @':wild' || ecl_wild_string_p(name))) - @(return ECL_T); - checked = 1; - } - if (component == ECL_NIL || component == @':directory') { - cl_object list = pathname->pathname.directory; - checked = 1; - loop_for_on_unsafe(list) { - cl_object name = ECL_CONS_CAR(list); - if (name != ECL_NIL && - (name == @':wild' || name == @':wild-inferiors' || - ecl_wild_string_p(name))) - { - @(return ECL_T) - } - } end_loop_for_on_unsafe(list); - } - if (checked == 0) { - FEerror("~A is not a valid pathname component", 1, component); - } - @(return ECL_NIL) + pathname = cl_pathname(pathname); + if (component == ECL_NIL || component == @':host') { + if (pathname->pathname.host == @':wild') { + @(return ECL_T); + } + checked = 1; + } + if (component == ECL_NIL || component == @':device') { + if (pathname->pathname.device == @':wild') { + @(return ECL_T); + } + checked = 1; + } + if (component == ECL_NIL || component == @':version') { + if (pathname->pathname.version == @':wild') { + @(return ECL_T); + } + checked = 1; + } + if (component == ECL_NIL || component == @':name') { + cl_object name = pathname->pathname.name; + if (name != ECL_NIL && + (name == @':wild' || ecl_wild_string_p(name))) { + @(return ECL_T); + } + checked = 1; + } + if (component == ECL_NIL || component == @':type') { + cl_object name = pathname->pathname.type; + if (name != ECL_NIL && + (name == @':wild' || ecl_wild_string_p(name))) { + @(return ECL_T); + } + checked = 1; + } + if (component == ECL_NIL || component == @':directory') { + cl_object list = pathname->pathname.directory; + checked = 1; + loop_for_on_unsafe(list) { + cl_object name = ECL_CONS_CAR(list); + if (name != ECL_NIL && + (name == @':wild' || name == @':wild-inferiors' || + ecl_wild_string_p(name))) { + @(return ECL_T); + } + } end_loop_for_on_unsafe(list); + } + if (checked == 0) { + FEerror("~A is not a valid pathname component", 1, component); + } + @(return ECL_NIL); @) /* @@ -850,22 +849,22 @@ cl_object coerce_to_file_pathname(cl_object pathname) { - pathname = coerce_to_physical_pathname(pathname); - pathname = cl_merge_pathnames(1, pathname); + pathname = coerce_to_physical_pathname(pathname); + pathname = cl_merge_pathnames(1, pathname); #if 0 #if !defined(cygwin) && !defined(ECL_MS_WINDOWS_HOST) - if (pathname->pathname.device != ECL_NIL) - FEerror("Device ~S not yet supported.", 1, - pathname->pathname.device); - if (pathname->pathname.host != ECL_NIL) - FEerror("Access to remote files not yet supported.", 0); + if (pathname->pathname.device != ECL_NIL) + FEerror("Device ~S not yet supported.", 1, + pathname->pathname.device); + if (pathname->pathname.host != ECL_NIL) + FEerror("Access to remote files not yet supported.", 0); #endif #endif - if (pathname->pathname.directory == ECL_NIL || - ECL_CONS_CAR(pathname->pathname.directory) == @':relative') { - pathname = cl_merge_pathnames(2, pathname, si_getcwd(0)); - } - return pathname; + if (pathname->pathname.directory == ECL_NIL || + ECL_CONS_CAR(pathname->pathname.directory) == @':relative') { + pathname = cl_merge_pathnames(2, pathname, si_getcwd(0)); + } + return pathname; } /* @@ -875,10 +874,10 @@ cl_object coerce_to_physical_pathname(cl_object x) { - x = cl_pathname(x); - if (x->pathname.logical) - return cl_translate_logical_pathname(1, x); - return x; + x = cl_pathname(x); + if (x->pathname.logical) + return cl_translate_logical_pathname(1, x); + return x; } /* @@ -890,35 +889,35 @@ cl_object si_coerce_to_filename(cl_object pathname_orig) { - cl_object namestring, pathname; + cl_object namestring, pathname; - /* We always go through the pathname representation and thus - * cl_namestring() always outputs a fresh new string */ - pathname = coerce_to_file_pathname(pathname_orig); - if (cl_wild_pathname_p(1,pathname) != ECL_NIL) - cl_error(3, @'file-error', @':pathname', pathname_orig); - namestring = ecl_namestring(pathname, - ECL_NAMESTRING_TRUNCATE_IF_ERROR | - ECL_NAMESTRING_FORCE_BASE_STRING); - if (namestring == ECL_NIL) { - FEerror("Pathname without a physical namestring:" - "~% :HOST ~A" - "~% :DEVICE ~A" - "~% :DIRECTORY ~A" - "~% :NAME ~A" - "~% :TYPE ~A" - "~% :VERSION ~A", - 6, pathname_orig->pathname.host, - pathname_orig->pathname.device, - pathname_orig->pathname.directory, - pathname_orig->pathname.name, - pathname_orig->pathname.type, - pathname_orig->pathname.version); - } - if (cl_core.path_max != -1 && - ecl_length(namestring) >= cl_core.path_max - 16) - FEerror("Too long filename: ~S.", 1, namestring); - return namestring; + /* We always go through the pathname representation and thus + * cl_namestring() always outputs a fresh new string */ + pathname = coerce_to_file_pathname(pathname_orig); + if (cl_wild_pathname_p(1,pathname) != ECL_NIL) + cl_error(3, @'file-error', @':pathname', pathname_orig); + namestring = ecl_namestring(pathname, + ECL_NAMESTRING_TRUNCATE_IF_ERROR | + ECL_NAMESTRING_FORCE_BASE_STRING); + if (namestring == ECL_NIL) { + FEerror("Pathname without a physical namestring:" + "~% :HOST ~A" + "~% :DEVICE ~A" + "~% :DIRECTORY ~A" + "~% :NAME ~A" + "~% :TYPE ~A" + "~% :VERSION ~A", + 6, pathname_orig->pathname.host, + pathname_orig->pathname.device, + pathname_orig->pathname.directory, + pathname_orig->pathname.name, + pathname_orig->pathname.type, + pathname_orig->pathname.version); + } + if (cl_core.path_max != -1 && + ecl_length(namestring) >= cl_core.path_max - 16) + FEerror("Too long filename: ~S.", 1, namestring); + return namestring; } #define default_device(host) ECL_NIL @@ -926,437 +925,436 @@ cl_object ecl_merge_pathnames(cl_object path, cl_object defaults, cl_object default_version) { - cl_object host, device, directory, name, type, version; - cl_object tocase; + cl_object host, device, directory, name, type, version; + cl_object tocase; - defaults = cl_pathname(defaults); - path = cl_parse_namestring(1, path, ECL_NIL, defaults); - if (Null(host = path->pathname.host)) - host = defaults->pathname.host; - tocase = host_case(host); - if (Null(path->pathname.device)) { - if (Null(path->pathname.host)) - device = cl_pathname_device(3, defaults, @':case', tocase); - else if (path->pathname.host == defaults->pathname.host) - device = defaults->pathname.device; - else - device = default_device(path->pathname.host); - } else { - device = path->pathname.device; - } - if (Null(path->pathname.directory)) { - directory = cl_pathname_directory(3, defaults, @':case', tocase); - } else if (ECL_CONS_CAR(path->pathname.directory) == @':absolute') { - directory = path->pathname.directory; - } else if (!Null(defaults->pathname.directory)) { - directory = ecl_append(cl_pathname_directory(3, defaults, - @':case', tocase), - CDR(path->pathname.directory)); - /* Eliminate redundant :back */ - directory = destructively_check_directory(directory, TRUE, TRUE); - } else { - directory = path->pathname.directory; - } - if (Null(name = path->pathname.name)) { - name = cl_pathname_name(3, defaults, @':case', tocase); - } - if (Null(type = path->pathname.type)) { - type = cl_pathname_type(3, defaults, @':case', tocase); - } - version = path->pathname.version; - if (Null(path->pathname.name)) { - if (Null(version)) - version = defaults->pathname.version; - } - if (Null(version)) { - version = default_version; - } - if (default_version == @':default') { - if (Null(name) && Null(type)) { - version = ECL_NIL; - } else { - version = @':newest'; - } - } - /* - In this implementation, version is not considered - */ - defaults = ecl_make_pathname(host, device, directory, name, - type, version, tocase); - return defaults; + defaults = cl_pathname(defaults); + path = cl_parse_namestring(1, path, ECL_NIL, defaults); + if (Null(host = path->pathname.host)) + host = defaults->pathname.host; + tocase = host_case(host); + if (Null(path->pathname.device)) { + if (Null(path->pathname.host)) + device = cl_pathname_device(3, defaults, @':case', tocase); + else if (path->pathname.host == defaults->pathname.host) + device = defaults->pathname.device; + else + device = default_device(path->pathname.host); + } else { + device = path->pathname.device; + } + if (Null(path->pathname.directory)) { + directory = cl_pathname_directory(3, defaults, @':case', tocase); + } else if (ECL_CONS_CAR(path->pathname.directory) == @':absolute') { + directory = path->pathname.directory; + } else if (!Null(defaults->pathname.directory)) { + directory = ecl_append(cl_pathname_directory(3, defaults, + @':case', tocase), + CDR(path->pathname.directory)); + /* Eliminate redundant :back */ + directory = destructively_check_directory(directory, TRUE, TRUE); + } else { + directory = path->pathname.directory; + } + if (Null(name = path->pathname.name)) { + name = cl_pathname_name(3, defaults, @':case', tocase); + } + if (Null(type = path->pathname.type)) { + type = cl_pathname_type(3, defaults, @':case', tocase); + } + version = path->pathname.version; + if (Null(path->pathname.name)) { + if (Null(version)) + version = defaults->pathname.version; + } + if (Null(version)) { + version = default_version; + } + if (default_version == @':default') { + if (Null(name) && Null(type)) { + version = ECL_NIL; + } else { + version = @':newest'; + } + } + /* + In this implementation, version is not considered + */ + defaults = ecl_make_pathname(host, device, directory, name, + type, version, tocase); + return defaults; } /* - ecl_namestring(x, flag) converts a pathname to a namestring. - if flag is true, then the pathname may be coerced to the requirements - of the filesystem, removing fields that have no meaning (such as - version, or type, etc); otherwise, when it is not possible to - produce a readable representation of the pathname, NIL is returned. + ecl_namestring(x, flag) converts a pathname to a namestring. + if flag is true, then the pathname may be coerced to the requirements + of the filesystem, removing fields that have no meaning (such as + version, or type, etc); otherwise, when it is not possible to + produce a readable representation of the pathname, NIL is returned. */ cl_object ecl_namestring(cl_object x, int flags) { - bool logical; - cl_object l, y; - cl_object buffer, host; - bool truncate_if_unreadable = flags & ECL_NAMESTRING_TRUNCATE_IF_ERROR; - - x = cl_pathname(x); - - /* INV: Pathnames can only be created by mergin, parsing namestrings - * or using ecl_make_pathname(). In all of these cases ECL will complain - * at creation time if the pathname has wrong components. - */ - buffer = ecl_make_string_output_stream(128, 1); - logical = x->pathname.logical; - host = x->pathname.host; - if (logical) { - if ((y = x->pathname.device) != @':unspecific' && - truncate_if_unreadable) - return ECL_NIL; - if (host != ECL_NIL) { - si_do_write_sequence(host, buffer, ecl_make_fixnum(0), ECL_NIL); - writestr_stream(":", buffer); - } - } else { - if ((y = x->pathname.device) != ECL_NIL) { - si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL); - writestr_stream(":", buffer); - } - if (host != ECL_NIL) { + bool logical; + cl_object l, y; + cl_object buffer, host; + bool truncate_if_unreadable = flags & ECL_NAMESTRING_TRUNCATE_IF_ERROR; + + x = cl_pathname(x); + + /* INV: Pathnames can only be created by mergin, parsing namestrings + * or using ecl_make_pathname(). In all of these cases ECL will complain + * at creation time if the pathname has wrong components. + */ + buffer = ecl_make_string_output_stream(128, 1); + logical = x->pathname.logical; + host = x->pathname.host; + if (logical) { + if ((y = x->pathname.device) != @':unspecific' && + truncate_if_unreadable) + return ECL_NIL; + if (host != ECL_NIL) { + si_do_write_sequence(host, buffer, ecl_make_fixnum(0), ECL_NIL); + writestr_stream(":", buffer); + } + } else { + if ((y = x->pathname.device) != ECL_NIL) { + si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL); + writestr_stream(":", buffer); + } + if (host != ECL_NIL) { #if !defined(ECL_MS_WINDOWS_HOST) - if (y == ECL_NIL) { - writestr_stream("file:", buffer); - } + if (y == ECL_NIL) { + writestr_stream("file:", buffer); + } #endif - writestr_stream("//", buffer); - si_do_write_sequence(host, buffer, ecl_make_fixnum(0), ECL_NIL); - } - } - l = x->pathname.directory; - if (ecl_endp(l)) - goto NO_DIRECTORY; - y = ECL_CONS_CAR(l); - if (y == @':relative') { - if (logical) - ecl_write_char(';', buffer); - } else { - if (!logical) - ecl_write_char(DIR_SEPARATOR, buffer); - } - l = ECL_CONS_CDR(l); - loop_for_in(l) { - y = ECL_CONS_CAR(l); - if (y == @':up') { - writestr_stream("..", buffer); - } else if (y == @':wild') { - writestr_stream("*", buffer); - } else if (y == @':wild-inferiors') { - writestr_stream("**", buffer); - } else if (y != @':back') { - si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL); - } else { - /* Directory :back has no namestring representation */ - return ECL_NIL; - } - ecl_write_char(logical? ';' : DIR_SEPARATOR, buffer); - } end_loop_for_in; -NO_DIRECTORY: - if (ecl_file_position(buffer) == ecl_make_fixnum(0)) { - if ((ecl_stringp(x->pathname.name) && - ecl_member_char(':', x->pathname.name)) || - (ecl_stringp(x->pathname.type) && - ecl_member_char(':', x->pathname.type))) - writestr_stream(":", buffer); - } - y = x->pathname.name; - if (y != ECL_NIL) { - if (y == @':wild') { - writestr_stream("*", buffer); - } else { - si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL); - } - } else if (!logical && !Null(x->pathname.type)) { - /* #P".txt" is :NAME = ".txt" :TYPE = NIL and - hence :NAME = NIL and :TYPE != NIL does not have - a printed representation */ - return ECL_NIL; - } - y = x->pathname.type; - if (y == @':unspecific') { - return ECL_NIL; - } else if (y != ECL_NIL) { - if (y == @':wild') { - writestr_stream(".*", buffer); - } else { - writestr_stream(".", buffer); - si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL); - } - } - y = x->pathname.version; - if (logical) { - if (y != ECL_NIL) { - writestr_stream(".", buffer); - if (y == @':wild') { - writestr_stream("*", buffer); - } else if (y == @':newest') { - si_do_write_sequence(ecl_symbol_name(y), buffer, - ecl_make_fixnum(0), ECL_NIL); - } else { - /* Since the printer is not reentrant, - * we cannot use cl_write and friends. - */ - int n = ecl_fixnum(y), i; - char b[ECL_FIXNUM_BITS / 2]; - for (i = 0; n; i++) { - b[i] = n%10 + '0'; - n = n/10; - } - if (i == 0) - b[i++] = '0'; - while (i--) { - ecl_write_char(b[i], buffer); - } - } - } - } else if (!truncate_if_unreadable) { - /* Namestrings of physical pathnames have restrictions... */ - if (Null(x->pathname.name) && Null(x->pathname.type)) { - /* Directories cannot have a version number */ - if (y != ECL_NIL) - return ECL_NIL; - } else if (y != @':newest') { - /* Filenames have an implicit version :newest */ - return ECL_NIL; - } - } - buffer = cl_get_output_stream_string(buffer); + writestr_stream("//", buffer); + si_do_write_sequence(host, buffer, ecl_make_fixnum(0), ECL_NIL); + } + } + l = x->pathname.directory; + if (ecl_endp(l)) + goto NO_DIRECTORY; + y = ECL_CONS_CAR(l); + if (y == @':relative') { + if (logical) + ecl_write_char(';', buffer); + } else { + if (!logical) + ecl_write_char(DIR_SEPARATOR, buffer); + } + l = ECL_CONS_CDR(l); + loop_for_in(l) { + y = ECL_CONS_CAR(l); + if (y == @':up') { + writestr_stream("..", buffer); + } else if (y == @':wild') { + writestr_stream("*", buffer); + } else if (y == @':wild-inferiors') { + writestr_stream("**", buffer); + } else if (y != @':back') { + si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL); + } else { + /* Directory :back has no namestring representation */ + return ECL_NIL; + } + ecl_write_char(logical? ';' : DIR_SEPARATOR, buffer); + } end_loop_for_in; + NO_DIRECTORY: + if (ecl_file_position(buffer) == ecl_make_fixnum(0)) { + if ((ecl_stringp(x->pathname.name) && + ecl_member_char(':', x->pathname.name)) || + (ecl_stringp(x->pathname.type) && + ecl_member_char(':', x->pathname.type))) + writestr_stream(":", buffer); + } + y = x->pathname.name; + if (y != ECL_NIL) { + if (y == @':wild') { + writestr_stream("*", buffer); + } else { + si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL); + } + } else if (!logical && !Null(x->pathname.type)) { + /* #P".txt" is :NAME = ".txt" :TYPE = NIL and + hence :NAME = NIL and :TYPE != NIL does not have + a printed representation */ + return ECL_NIL; + } + y = x->pathname.type; + if (y == @':unspecific') { + return ECL_NIL; + } else if (y != ECL_NIL) { + if (y == @':wild') { + writestr_stream(".*", buffer); + } else { + writestr_stream(".", buffer); + si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL); + } + } + y = x->pathname.version; + if (logical) { + if (y != ECL_NIL) { + writestr_stream(".", buffer); + if (y == @':wild') { + writestr_stream("*", buffer); + } else if (y == @':newest') { + si_do_write_sequence(ecl_symbol_name(y), buffer, + ecl_make_fixnum(0), ECL_NIL); + } else { + /* Since the printer is not reentrant, + * we cannot use cl_write and friends. + */ + int n = ecl_fixnum(y), i; + char b[ECL_FIXNUM_BITS / 2]; + for (i = 0; n; i++) { + b[i] = n%10 + '0'; + n = n/10; + } + if (i == 0) + b[i++] = '0'; + while (i--) { + ecl_write_char(b[i], buffer); + } + } + } + } else if (!truncate_if_unreadable) { + /* Namestrings of physical pathnames have restrictions... */ + if (Null(x->pathname.name) && Null(x->pathname.type)) { + /* Directories cannot have a version number */ + if (y != ECL_NIL) + return ECL_NIL; + } else if (y != @':newest') { + /* Filenames have an implicit version :newest */ + return ECL_NIL; + } + } + buffer = cl_get_output_stream_string(buffer); #ifdef ECL_UNICODE - if (ECL_EXTENDED_STRING_P(buffer) && - (flags & ECL_NAMESTRING_FORCE_BASE_STRING)) { - unlikely_if (!ecl_fits_in_base_string(buffer)) - FEerror("The filesystem does not accept filenames " - "with extended characters: ~S", - 1, buffer); - buffer = si_copy_to_simple_base_string(buffer); - } + if (ECL_EXTENDED_STRING_P(buffer) && + (flags & ECL_NAMESTRING_FORCE_BASE_STRING)) { + unlikely_if (!ecl_fits_in_base_string(buffer)) + FEerror("The filesystem does not accept filenames " + "with extended characters: ~S", + 1, buffer); + buffer = si_copy_to_simple_base_string(buffer); + } #endif - return buffer; + return buffer; } cl_object cl_namestring(cl_object x) { - @(return ecl_namestring(x, ECL_NAMESTRING_TRUNCATE_IF_ERROR)) + @(return ecl_namestring(x, ECL_NAMESTRING_TRUNCATE_IF_ERROR)); } @(defun parse_namestring (thing - &o host (defaults si_default_pathname_defaults()) - &k (start ecl_make_fixnum(0)) end junk_allowed - &a output) + &o host (defaults si_default_pathname_defaults()) + &k (start ecl_make_fixnum(0)) end junk_allowed + &a output) @ - if (host != ECL_NIL) { - host = cl_string(host); - } - if (!ecl_stringp(thing)) { - output = cl_pathname(thing); - } else { - cl_object default_host = host; - cl_index_pair p; - cl_index ee; - if (default_host == ECL_NIL && defaults != ECL_NIL) { - defaults = cl_pathname(defaults); - default_host = defaults->pathname.host; - } - p = ecl_vector_start_end(@[parse-namestring], thing, start, end); - output = ecl_parse_namestring(thing, p.start, p.end, &ee, default_host); - start = ecl_make_fixnum(ee); - if (output == ECL_NIL || ee != p.end) { - if (Null(junk_allowed)) { - FEparse_error("Cannot parse the namestring ~S~%" - "from ~S to ~S.", ECL_NIL, - 3, thing, start, end); - } - goto OUTPUT; - } - } - if (host != ECL_NIL && !ecl_equal(output->pathname.host, host)) { - FEerror("The pathname ~S does not contain the required host ~S.", - 2, thing, host); - } - OUTPUT: - @(return output start) + if (host != ECL_NIL) { + host = cl_string(host); + } + if (!ecl_stringp(thing)) { + output = cl_pathname(thing); + } else { + cl_object default_host = host; + cl_index_pair p; + cl_index ee; + if (default_host == ECL_NIL && defaults != ECL_NIL) { + defaults = cl_pathname(defaults); + default_host = defaults->pathname.host; + } + p = ecl_vector_start_end(@[parse-namestring], thing, start, end); + output = ecl_parse_namestring(thing, p.start, p.end, &ee, default_host); + start = ecl_make_fixnum(ee); + if (output == ECL_NIL || ee != p.end) { + if (Null(junk_allowed)) { + FEparse_error("Cannot parse the namestring ~S~%" + "from ~S to ~S.", ECL_NIL, + 3, thing, start, end); + } + goto OUTPUT; + } + } + if (host != ECL_NIL && !ecl_equal(output->pathname.host, host)) { + FEerror("The pathname ~S does not contain the required host ~S.", + 2, thing, host); + } + OUTPUT: + @(return output start); @) @(defun merge_pathnames (path - &o (defaults si_default_pathname_defaults()) - (default_version @':newest')) + &o (defaults si_default_pathname_defaults()) + (default_version @':newest')) @ - path = cl_pathname(path); - defaults = cl_pathname(defaults); - @(return ecl_merge_pathnames(path, defaults, default_version)) + path = cl_pathname(path); + defaults = cl_pathname(defaults); + @(return ecl_merge_pathnames(path, defaults, default_version)); @) @(defun make_pathname (&key (host ECL_NIL hostp) (device ECL_NIL devicep) - (directory ECL_NIL directoryp) - (name ECL_NIL namep) (type ECL_NIL typep) (version ECL_NIL versionp) - ((:case scase) @':local') - defaults + (directory ECL_NIL directoryp) + (name ECL_NIL namep) (type ECL_NIL typep) (version ECL_NIL versionp) + ((:case scase) @':local') + defaults &aux x) @ - if (Null(defaults)) { - defaults = si_default_pathname_defaults(); - defaults = ecl_make_pathname(defaults->pathname.host, - ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL, - @':local'); - } else { - defaults = cl_pathname(defaults); - } - if (!hostp) host = defaults->pathname.host; - x = ecl_make_pathname(host, device, directory, name, type, version, scase); - if (!devicep) x->pathname.device = defaults->pathname.device; - if (!directoryp) x->pathname.directory = defaults->pathname.directory; - if (!namep) x->pathname.name = defaults->pathname.name; - if (!typep) x->pathname.type = defaults->pathname.type; - if (!versionp) x->pathname.version = defaults->pathname.version; + if (Null(defaults)) { + defaults = si_default_pathname_defaults(); + defaults = ecl_make_pathname(defaults->pathname.host, + ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL, + @':local'); + } else { + defaults = cl_pathname(defaults); + } + if (!hostp) host = defaults->pathname.host; + x = ecl_make_pathname(host, device, directory, name, type, version, scase); + if (!devicep) x->pathname.device = defaults->pathname.device; + if (!directoryp) x->pathname.directory = defaults->pathname.directory; + if (!namep) x->pathname.name = defaults->pathname.name; + if (!typep) x->pathname.type = defaults->pathname.type; + if (!versionp) x->pathname.version = defaults->pathname.version; - @(return x) + @(return x); @) cl_object cl_pathnamep(cl_object pname) { - @(return (ECL_PATHNAMEP(pname) ? ECL_T : ECL_NIL)) + @(return (ECL_PATHNAMEP(pname) ? ECL_T : ECL_NIL)); } cl_object si_logical_pathname_p(cl_object pname) { - @(return ((ECL_PATHNAMEP(pname) && pname->pathname.logical)? - ECL_T : ECL_NIL)) + @(return ((ECL_PATHNAMEP(pname) && pname->pathname.logical)? + ECL_T : ECL_NIL)); } @(defun pathname_host (pname &key ((:case scase) @':local')) @ - pname = cl_pathname(pname); - @(return translate_component_case(pname->pathname.host, - normalize_case(pname, @':local'), - normalize_case(pname, scase))) + pname = cl_pathname(pname); + @(return translate_component_case(pname->pathname.host, + normalize_case(pname, @':local'), + normalize_case(pname, scase))); @) @(defun pathname_device (pname &key ((:case scase) @':local')) @ - pname = cl_pathname(pname); - @(return translate_component_case(pname->pathname.device, - normalize_case(pname, @':local'), - normalize_case(pname, scase))) + pname = cl_pathname(pname); + @(return translate_component_case(pname->pathname.device, + normalize_case(pname, @':local'), + normalize_case(pname, scase))); @) @(defun pathname_directory (pname &key ((:case scase) @':local')) @ - pname = cl_pathname(pname); - @(return translate_list_case(pname->pathname.directory, - normalize_case(pname, @':local'), - normalize_case(pname, scase))) + pname = cl_pathname(pname); + @(return translate_list_case(pname->pathname.directory, + normalize_case(pname, @':local'), + normalize_case(pname, scase))); @) @(defun pathname_name(pname &key ((:case scase) @':local')) @ - pname = cl_pathname(pname); - @(return translate_component_case(pname->pathname.name, - normalize_case(pname, @':local'), - normalize_case(pname, scase))) + pname = cl_pathname(pname); + @(return translate_component_case(pname->pathname.name, + normalize_case(pname, @':local'), + normalize_case(pname, scase))); @) @(defun pathname_type(pname &key ((:case scase) @':local')) @ - pname = cl_pathname(pname); - @(return translate_component_case(pname->pathname.type, - normalize_case(pname, @':local'), - normalize_case(pname, scase))) + pname = cl_pathname(pname); + @(return translate_component_case(pname->pathname.type, + normalize_case(pname, @':local'), + normalize_case(pname, scase))); @) cl_object cl_pathname_version(cl_object pname) { - pname = cl_pathname(pname); - @(return pname->pathname.version) + pname = cl_pathname(pname); + @(return pname->pathname.version); } cl_object cl_file_namestring(cl_object pname) { - pname = cl_pathname(pname); - @(return ecl_namestring(ecl_make_pathname(ECL_NIL, ECL_NIL, ECL_NIL, - pname->pathname.name, - pname->pathname.type, - pname->pathname.version, - @':local'), - ECL_NAMESTRING_TRUNCATE_IF_ERROR)) + pname = cl_pathname(pname); + @(return ecl_namestring(ecl_make_pathname(ECL_NIL, ECL_NIL, ECL_NIL, + pname->pathname.name, + pname->pathname.type, + pname->pathname.version, + @':local'), + ECL_NAMESTRING_TRUNCATE_IF_ERROR)); } cl_object cl_directory_namestring(cl_object pname) { - pname = cl_pathname(pname); - @(return ecl_namestring(ecl_make_pathname(ECL_NIL, ECL_NIL, - pname->pathname.directory, - ECL_NIL, ECL_NIL, ECL_NIL, - @':local'), - ECL_NAMESTRING_TRUNCATE_IF_ERROR)) + pname = cl_pathname(pname); + @(return ecl_namestring(ecl_make_pathname(ECL_NIL, ECL_NIL, + pname->pathname.directory, + ECL_NIL, ECL_NIL, ECL_NIL, + @':local'), + ECL_NAMESTRING_TRUNCATE_IF_ERROR)); } cl_object cl_host_namestring(cl_object pname) { - pname = cl_pathname(pname); - pname = pname->pathname.host; - if (Null(pname) || pname == @':wild') - pname = cl_core.null_string; - @(return pname) + pname = cl_pathname(pname); + pname = pname->pathname.host; + if (Null(pname) || pname == @':wild') + pname = cl_core.null_string; + @(return pname); } #define EN_MATCH(p1,p2,el) (ecl_equalp(p1->pathname.el, p2->pathname.el)? ECL_NIL : p1->pathname.el) @(defun enough_namestring (path - &o (defaults si_default_pathname_defaults())) - cl_object newpath, pathdir, defaultdir, fname; + &o (defaults si_default_pathname_defaults())) + cl_object newpath, pathdir, defaultdir, fname; @ - defaults = cl_pathname(defaults); - path = cl_pathname(path); - pathdir = path->pathname.directory; - defaultdir = defaults->pathname.directory; - if (Null(pathdir)) { - pathdir = ecl_list1(@':relative'); - } else if (Null(defaultdir)) { - /* The defaults pathname does not have a directory. */ - } else if (ECL_CONS_CAR(pathdir) == @':relative') { - /* The pathname is relative to the default one one, so we just output the - original one */ - } else { - /* The new pathname is an absolute one. We compare it with the defaults - and if they have some common elements, we just output the remaining ones. */ - cl_object dir_begin = funcall(5, @'mismatch', pathdir, defaultdir, - @':test', @'equal'); - if (dir_begin == ECL_NIL) { - pathdir = ECL_NIL; - } else if (dir_begin == cl_length(defaultdir)) { - pathdir = funcall(3, @'subseq', pathdir, dir_begin); - pathdir = CONS(@':relative', pathdir); - } - } - fname = EN_MATCH(path, defaults, name); - if (fname == ECL_NIL) fname = path->pathname.name; - /* Create a path with all elements that do not match the default */ - newpath - = ecl_make_pathname(EN_MATCH(path, defaults, host), - EN_MATCH(path, defaults, device), - pathdir, fname, - EN_MATCH(path, defaults, type), - EN_MATCH(path, defaults, version), - @':local'); - newpath->pathname.logical = path->pathname.logical; - @(return ecl_namestring(newpath, ECL_NAMESTRING_TRUNCATE_IF_ERROR)) + defaults = cl_pathname(defaults); + path = cl_pathname(path); + pathdir = path->pathname.directory; + defaultdir = defaults->pathname.directory; + if (Null(pathdir)) { + pathdir = ecl_list1(@':relative'); + } else if (Null(defaultdir)) { + /* The defaults pathname does not have a directory. */ + } else if (ECL_CONS_CAR(pathdir) == @':relative') { + /* The pathname is relative to the default one one, so we just output the + original one */ + } else { + /* The new pathname is an absolute one. We compare it with the defaults + and if they have some common elements, we just output the remaining ones. */ + cl_object dir_begin = funcall(5, @'mismatch', pathdir, defaultdir, + @':test', @'equal'); + if (dir_begin == ECL_NIL) { + pathdir = ECL_NIL; + } else if (dir_begin == cl_length(defaultdir)) { + pathdir = funcall(3, @'subseq', pathdir, dir_begin); + pathdir = CONS(@':relative', pathdir); + } + } + fname = EN_MATCH(path, defaults, name); + if (fname == ECL_NIL) fname = path->pathname.name; + /* Create a path with all elements that do not match the default */ + newpath = ecl_make_pathname(EN_MATCH(path, defaults, host), + EN_MATCH(path, defaults, device), + pathdir, fname, + EN_MATCH(path, defaults, type), + EN_MATCH(path, defaults, version), + @':local'); + newpath->pathname.logical = path->pathname.logical; + @(return ecl_namestring(newpath, ECL_NAMESTRING_TRUNCATE_IF_ERROR)); @) #undef EN_MATCH @@ -1365,15 +1363,15 @@ bool ecl_wild_string_p(cl_object item) { - if (ECL_STRINGP(item)) { - cl_index i, l = ecl_length(item); - for (i = 0; i < l; i++) { - ecl_character c = ecl_char(item, i); - if (c == '\\' || c == '*' || c == '?') - return 1; - } - } - return 0; + if (ECL_STRINGP(item)) { + cl_index i, l = ecl_length(item); + for (i = 0; i < l; i++) { + ecl_character c = ecl_char(item, i); + if (c == '\\' || c == '*' || c == '?') + return 1; + } + } + return 0; } /* @@ -1385,123 +1383,123 @@ ecl_string_match(cl_object s, cl_index j, cl_index ls, cl_object p, cl_index i, cl_index lp) { - while (i < lp) { - cl_index cp = ecl_char(p, i); - switch (cp) { - case '*': { - /* An asterisk in the pattern matches any - * number of characters. We try the shortest - * sequence that matches. */ - cl_index cn = 0, next; - for (next = i+1; - next < lp && ((cn = ecl_char(p, next)) == '*'); - next++) - ; - if (next == lp) { - return TRUE; - } - while (j < ls) { - if (ecl_string_match(s, j, ls, p, next, lp)) { - return TRUE; - } - j++; - } - return FALSE; - break; - } - case '?': - /* Match any character */ - if (j > ls) return FALSE; - i++; j++; - break; - case '\\': - /* Interpret a pattern character literally. - Trailing slash is interpreted as a slash. */ - if (++i >= lp) i--; - default: - if ((j >= ls) || (cp != ecl_char(s, j))) { - /* Either there are no characters left in "s" - * or the next character does not match. */ - return FALSE; - } - i++; j++; - } - } - /* At the end all characters should have been matched */ - return (j >= ls); + while (i < lp) { + cl_index cp = ecl_char(p, i); + switch (cp) { + case '*': { + /* An asterisk in the pattern matches any + * number of characters. We try the shortest + * sequence that matches. */ + cl_index cn = 0, next; + for (next = i+1; + next < lp && ((cn = ecl_char(p, next)) == '*'); + next++) + ; + if (next == lp) { + return TRUE; + } + while (j < ls) { + if (ecl_string_match(s, j, ls, p, next, lp)) { + return TRUE; + } + j++; + } + return FALSE; + break; + } + case '?': + /* Match any character */ + if (j > ls) return FALSE; + i++; j++; + break; + case '\\': + /* Interpret a pattern character literally. + Trailing slash is interpreted as a slash. */ + if (++i >= lp) i--; + default: + if ((j >= ls) || (cp != ecl_char(s, j))) { + /* Either there are no characters left in "s" + * or the next character does not match. */ + return FALSE; + } + i++; j++; + } + } + /* At the end all characters should have been matched */ + return (j >= ls); } static bool path_item_match(cl_object a, cl_object mask) { - if (mask == @':wild') - return TRUE; - /* If a component in the tested path is a wildcard field, this - can only be matched by the same wildcard field in the mask */ - if (!ecl_stringp(a) || mask == ECL_NIL) - return (a == mask); - if (!ecl_stringp(mask)) - FEerror("~S is not supported as mask for pathname-match-p", 1, mask); - return ecl_string_match(a, 0, ecl_length(a), - mask, 0, ecl_length(mask)); + if (mask == @':wild') + return TRUE; + /* If a component in the tested path is a wildcard field, this + can only be matched by the same wildcard field in the mask */ + if (!ecl_stringp(a) || mask == ECL_NIL) + return (a == mask); + if (!ecl_stringp(mask)) + FEerror("~S is not supported as mask for pathname-match-p", 1, mask); + return ecl_string_match(a, 0, ecl_length(a), + mask, 0, ecl_length(mask)); } static bool path_list_match(cl_object a, cl_object mask) { - cl_object item_mask; - while (!ecl_endp(mask)) { - item_mask = CAR(mask); - mask = CDR(mask); - if (item_mask == @':wild-inferiors') { - if (ecl_endp(mask)) - return TRUE; - while (!ecl_endp(a)) { - if (path_list_match(a, mask)) - return TRUE; - a = CDR(a); - } - return FALSE; - } else if (ecl_endp(a)) { - /* A NIL directory should match against :absolute - or :relative, in order to perform suitable translations. */ - if (item_mask != @':absolute' && item_mask != @':relative') - return FALSE; - } else if (!path_item_match(CAR(a), item_mask)) { - return FALSE; - } else { - a = CDR(a); - } - } - if (!ecl_endp(a)) - return FALSE; + cl_object item_mask; + while (!ecl_endp(mask)) { + item_mask = CAR(mask); + mask = CDR(mask); + if (item_mask == @':wild-inferiors') { + if (ecl_endp(mask)) return TRUE; + while (!ecl_endp(a)) { + if (path_list_match(a, mask)) + return TRUE; + a = CDR(a); + } + return FALSE; + } else if (ecl_endp(a)) { + /* A NIL directory should match against :absolute + or :relative, in order to perform suitable translations. */ + if (item_mask != @':absolute' && item_mask != @':relative') + return FALSE; + } else if (!path_item_match(CAR(a), item_mask)) { + return FALSE; + } else { + a = CDR(a); + } + } + if (!ecl_endp(a)) + return FALSE; + return TRUE; } cl_object cl_pathname_match_p(cl_object path, cl_object mask) { - cl_object output = ECL_NIL; - path = cl_pathname(path); - mask = cl_pathname(mask); - if (path->pathname.logical != mask->pathname.logical) - goto OUTPUT; + cl_object output = ECL_NIL; + path = cl_pathname(path); + mask = cl_pathname(mask); + if (path->pathname.logical != mask->pathname.logical) + goto OUTPUT; #if 0 - /* INV: This was checked in the calling routine */ - if (!path_item_match(path->pathname.host, mask->pathname.host)) - goto OUTPUT; + /* INV: This was checked in the calling routine */ + if (!path_item_match(path->pathname.host, mask->pathname.host)) + goto OUTPUT; #endif - /* Missing components default to :WILD */ - if (!Null(mask->pathname.directory) && - !path_list_match(path->pathname.directory, mask->pathname.directory)) - goto OUTPUT; - if (!path_item_match(path->pathname.name, mask->pathname.name)) - goto OUTPUT; - if (!path_item_match(path->pathname.type, mask->pathname.type)) - goto OUTPUT; - if (Null(mask->pathname.version) || - path_item_match(path->pathname.version, mask->pathname.version)) - output = ECL_T; + /* Missing components default to :WILD */ + if (!Null(mask->pathname.directory) && + !path_list_match(path->pathname.directory, mask->pathname.directory)) + goto OUTPUT; + if (!path_item_match(path->pathname.name, mask->pathname.name)) + goto OUTPUT; + if (!path_item_match(path->pathname.type, mask->pathname.type)) + goto OUTPUT; + if (Null(mask->pathname.version) || + path_item_match(path->pathname.version, mask->pathname.version)) + output = ECL_T; OUTPUT: - @(return output) + @(return output); } /* --------------- PATHNAME TRANSLATIONS ------------------ */ @@ -1509,304 +1507,302 @@ static cl_object coerce_to_from_pathname(cl_object x, cl_object host) { - switch (ecl_t_of(x)) { + switch (ecl_t_of(x)) { #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - x = cl_parse_namestring(2, x, host); - case t_pathname: - if (x->pathname.logical) - return x; - default: - FEerror("~S is not a valid from-pathname translation", 1, x); - } + case t_base_string: + x = cl_parse_namestring(2, x, host); + case t_pathname: + if (x->pathname.logical) + return x; + default: + FEerror("~S is not a valid from-pathname translation", 1, x); + } } @(defun si::pathname-translations (host &optional (set OBJNULL)) - cl_index parsed_len, len; - cl_object pair, l; + cl_index parsed_len, len; + cl_object pair, l; @ - /* Check that host is a valid host name */ - if (ecl_unlikely(!ECL_STRINGP(host))) - FEwrong_type_nth_arg(@[si::pathname-translations], 1, host, @[string]); - host = cl_string_upcase(1, host); - len = ecl_length(host); - parse_word(host, is_null, WORD_LOGICAL, 0, len, &parsed_len); - if (parsed_len < len) { - FEerror("Wrong host syntax ~S", 1, host); - } - /* Find its translation list */ - pair = @assoc(4, host, cl_core.pathname_translations, @':test', @'string-equal'); - if (set == OBJNULL) { - @(return ((pair == ECL_NIL)? ECL_NIL : CADR(pair))); - } - /* Set the new translation list */ - if (ecl_unlikely(!LISTP(set))) { - FEwrong_type_nth_arg(@[si::pathname-translations], 2, set, @[list]); - } - if (pair == ECL_NIL) { - pair = CONS(host, CONS(ECL_NIL, ECL_NIL)); - cl_core.pathname_translations = CONS(pair, cl_core.pathname_translations); - } - for (l = set, set = ECL_NIL; !ecl_endp(l); l = CDR(l)) { - cl_object item = CAR(l); - cl_object from = coerce_to_from_pathname(cl_car(item), host); - cl_object to = cl_pathname(cl_cadr(item)); - set = CONS(CONS(from, CONS(to, ECL_NIL)), set); - } - set = cl_nreverse(set); - ECL_RPLACA(ECL_CONS_CDR(pair), set); - @(return set) + /* Check that host is a valid host name */ + if (ecl_unlikely(!ECL_STRINGP(host))) + FEwrong_type_nth_arg(@[si::pathname-translations], 1, host, @[string]); + host = cl_string_upcase(1, host); + len = ecl_length(host); + parse_word(host, is_null, WORD_LOGICAL, 0, len, &parsed_len); + if (parsed_len < len) { + FEerror("Wrong host syntax ~S", 1, host); + } + /* Find its translation list */ + pair = @assoc(4, host, cl_core.pathname_translations, @':test', @'string-equal'); + if (set == OBJNULL) { + @(return ((pair == ECL_NIL)? ECL_NIL : CADR(pair))); + } + /* Set the new translation list */ + if (ecl_unlikely(!LISTP(set))) { + FEwrong_type_nth_arg(@[si::pathname-translations], 2, set, @[list]); + } + if (pair == ECL_NIL) { + pair = CONS(host, CONS(ECL_NIL, ECL_NIL)); + cl_core.pathname_translations = CONS(pair, cl_core.pathname_translations); + } + for (l = set, set = ECL_NIL; !ecl_endp(l); l = CDR(l)) { + cl_object item = CAR(l); + cl_object from = coerce_to_from_pathname(cl_car(item), host); + cl_object to = cl_pathname(cl_cadr(item)); + set = CONS(CONS(from, CONS(to, ECL_NIL)), set); + } + set = cl_nreverse(set); + ECL_RPLACA(ECL_CONS_CDR(pair), set); + @(return set); @) static cl_object find_wilds(cl_object l, cl_object source, cl_object match) { - cl_index i, j, k, ls, lm; + cl_index i, j, k, ls, lm; - if (match == @':wild') - return ecl_list1(source); - if (!ecl_stringp(match) || !ecl_stringp(source)) { - if (match != source) - return @':error'; - return l; - } - ls = ecl_length(source); - lm = ecl_length(match); - for(i = j = 0; i < ls && j < lm; ) { - cl_index pattern_char = ecl_char(match,j); - if (pattern_char == '*') { - for (j++, k = i; - k < ls && ecl_char(source,k) != pattern_char; - k++) - ; - l = CONS(make_one(source, i, k), l); - i = k; - continue; - } - if (ecl_char(source,i) != pattern_char) - return @':error'; - i++, j++; - } - if (i < ls || j < lm) - return @':error'; - return l; + if (match == @':wild') + return ecl_list1(source); + if (!ecl_stringp(match) || !ecl_stringp(source)) { + if (match != source) + return @':error'; + return l; + } + ls = ecl_length(source); + lm = ecl_length(match); + for(i = j = 0; i < ls && j < lm; ) { + cl_index pattern_char = ecl_char(match,j); + if (pattern_char == '*') { + for (j++, k = i; + k < ls && ecl_char(source,k) != pattern_char; + k++) + ; + l = CONS(make_one(source, i, k), l); + i = k; + continue; + } + if (ecl_char(source,i) != pattern_char) + return @':error'; + i++, j++; + } + if (i < ls || j < lm) + return @':error'; + return l; } static cl_object find_list_wilds(cl_object a, cl_object mask) { - cl_object l = ECL_NIL, l2; + cl_object l = ECL_NIL, l2; - while (!ecl_endp(mask)) { - cl_object item_mask = CAR(mask); - mask = CDR(mask); - if (item_mask == @':wild-inferiors') { - l2 = ECL_NIL; - while (!path_list_match(a, mask)) { - if (ecl_endp(a)) - return @':error'; - l2 = CONS(CAR(a),l2); - a = CDR(a); - } - l = CONS(l2, l); - } else if (ecl_endp(a)) { - /* A NIL directory should match against :absolute - or :relative, in order to perform suitable translations. */ - if (item_mask != @':absolute' && item_mask != @':relative') - return @':error'; - } else { - l2 = find_wilds(l, CAR(a), item_mask); - if (l == @':error') - return @':error'; - if (!Null(l2)) - l = CONS(l2, l); - a = CDR(a); - } - } - return @nreverse(l); + while (!ecl_endp(mask)) { + cl_object item_mask = CAR(mask); + mask = CDR(mask); + if (item_mask == @':wild-inferiors') { + l2 = ECL_NIL; + while (!path_list_match(a, mask)) { + if (ecl_endp(a)) + return @':error'; + l2 = CONS(CAR(a),l2); + a = CDR(a); + } + l = CONS(l2, l); + } else if (ecl_endp(a)) { + /* A NIL directory should match against :absolute + or :relative, in order to perform suitable translations. */ + if (item_mask != @':absolute' && item_mask != @':relative') + return @':error'; + } else { + l2 = find_wilds(l, CAR(a), item_mask); + if (l == @':error') + return @':error'; + if (!Null(l2)) + l = CONS(l2, l); + a = CDR(a); + } + } + return @nreverse(l); } static cl_object copy_wildcards(cl_object *wilds_list, cl_object pattern) { - cl_index i, l, j; - bool new_string; - cl_object wilds = *wilds_list, token; - - if (pattern == @':wild') { - if (ecl_endp(wilds)) - return @':error'; - pattern = CAR(wilds); - *wilds_list = CDR(wilds); - return pattern; - } - if (pattern == @':wild-inferiors') - return @':error'; - if (!ecl_stringp(pattern)) - return pattern; - - new_string = FALSE; - l = ecl_length(pattern); - token = si_get_buffer_string(); - for (j = i = 0; i < l; ) { - cl_index c = ecl_char(pattern, i); - if (c != '*') { - i++; - continue; - } - if (i != j) { - push_substring(token, pattern, j, i); - } - new_string = TRUE; - if (ecl_endp(wilds)) { - return @':error'; - } - push_string(token, CAR(wilds)); - wilds = CDR(wilds); - j = i++; - } - /* Only create a new string when needed */ - if (new_string) { - pattern = cl_copy_seq(token); - } - si_put_buffer_string(token); - *wilds_list = wilds; - return pattern; + cl_index i, l, j; + bool new_string; + cl_object wilds = *wilds_list, token; + + if (pattern == @':wild') { + if (ecl_endp(wilds)) + return @':error'; + pattern = CAR(wilds); + *wilds_list = CDR(wilds); + return pattern; + } + if (pattern == @':wild-inferiors') + return @':error'; + if (!ecl_stringp(pattern)) + return pattern; + + new_string = FALSE; + l = ecl_length(pattern); + token = si_get_buffer_string(); + for (j = i = 0; i < l; ) { + cl_index c = ecl_char(pattern, i); + if (c != '*') { + i++; + continue; + } + if (i != j) { + push_substring(token, pattern, j, i); + } + new_string = TRUE; + if (ecl_endp(wilds)) { + return @':error'; + } + push_string(token, CAR(wilds)); + wilds = CDR(wilds); + j = i++; + } + /* Only create a new string when needed */ + if (new_string) { + pattern = cl_copy_seq(token); + } + si_put_buffer_string(token); + *wilds_list = wilds; + return pattern; } static cl_object copy_list_wildcards(cl_object *wilds, cl_object to) { - cl_object l = ECL_NIL; + cl_object l = ECL_NIL; - while (!ecl_endp(to)) { - cl_object d, mask = CAR(to); - if (mask == @':wild-inferiors') { - cl_object list = *wilds; - if (ecl_endp(list)) - return @':error'; - else { - cl_object dirlist = CAR(list); - if (CONSP(dirlist)) - l = ecl_append(CAR(list), l); - else if (!Null(CAR(list))) - return @':error'; - } - *wilds = CDR(list); - } else { - d = copy_wildcards(wilds, CAR(to)); - if (d == @':error') - return d; - l = CONS(d, l); - } - to = CDR(to); - } - if (CONSP(l)) - l = @nreverse(l); - return l; + while (!ecl_endp(to)) { + cl_object d, mask = CAR(to); + if (mask == @':wild-inferiors') { + cl_object list = *wilds; + if (ecl_endp(list)) + return @':error'; + else { + cl_object dirlist = CAR(list); + if (CONSP(dirlist)) + l = ecl_append(CAR(list), l); + else if (!Null(CAR(list))) + return @':error'; + } + *wilds = CDR(list); + } else { + d = copy_wildcards(wilds, CAR(to)); + if (d == @':error') + return d; + l = CONS(d, l); + } + to = CDR(to); + } + if (CONSP(l)) + l = @nreverse(l); + return l; } @(defun translate-pathname (source from to &key ((:case scase) @':local')) - cl_object wilds, d; - cl_object host, device, directory, name, type, version; - cl_object fromcase, tocase; + cl_object wilds, d; + cl_object host, device, directory, name, type, version; + cl_object fromcase, tocase; @ - /* The pathname from which we get the data */ - source = cl_pathname(source); - /* The mask applied to the source pathname */ - from = cl_pathname(from); - fromcase = normalize_case(from, @':local'); - /* The pattern which says what the output should look like */ - to = cl_pathname(to); - tocase = normalize_case(to, @':local'); - - if (source->pathname.logical != from->pathname.logical) - goto error; - - /* Match host names */ - if (cl_string_equal(2, source->pathname.host, from->pathname.host) == ECL_NIL) - goto error; - host = to->pathname.host; - - /* Logical pathnames do not have devices. We just overwrite it. */ - device = to->pathname.device; - - /* Match directories */ - wilds = find_list_wilds(source->pathname.directory, - from->pathname.directory); - if (wilds == @':error') goto error; - if (Null(to->pathname.directory)) { - /* Missing components are replaced */ - d = translate_list_case(source->pathname.directory, fromcase, tocase); - } else { - wilds = translate_list_case(wilds, fromcase, tocase); - d = copy_list_wildcards(&wilds, to->pathname.directory); - if (d == @':error') goto error; - if (wilds != ECL_NIL) goto error2; - } - directory = d; - - /* Match name */ - wilds = find_wilds(ECL_NIL, source->pathname.name, from->pathname.name); - if (wilds == @':error') goto error2; - if (Null(to->pathname.name)) { - d = translate_component_case(source->pathname.name, fromcase, tocase); - } else { - wilds = translate_list_case(wilds, fromcase, tocase); - d = copy_wildcards(&wilds, to->pathname.name); - if (d == @':error') goto error; - if (wilds != ECL_NIL) goto error2; - } - name = d; - - /* Match type */ - wilds = find_wilds(ECL_NIL, source->pathname.type, from->pathname.type); - if (wilds == @':error') goto error2; - if (Null(to->pathname.type)) { - d = translate_component_case(source->pathname.type, fromcase, tocase); - } else { - wilds = translate_list_case(wilds, fromcase, tocase); - d = copy_wildcards(&wilds, to->pathname.type); - if (d == @':error') goto error; - if (wilds != ECL_NIL) goto error2; - } - type = d; - - /* Match version */ - version = to->pathname.version; - if (from->pathname.version == @':wild') { - if (to->pathname.version == @':wild') { - version = source->pathname.version; - } - } - @(return ecl_make_pathname(host, device, directory, name, type, - version, tocase)); + /* The pathname from which we get the data */ + source = cl_pathname(source); + /* The mask applied to the source pathname */ + from = cl_pathname(from); + fromcase = normalize_case(from, @':local'); + /* The pattern which says what the output should look like */ + to = cl_pathname(to); + tocase = normalize_case(to, @':local'); + + if (source->pathname.logical != from->pathname.logical) + goto error; + + /* Match host names */ + if (cl_string_equal(2, source->pathname.host, from->pathname.host) == ECL_NIL) + goto error; + host = to->pathname.host; + + /* Logical pathnames do not have devices. We just overwrite it. */ + device = to->pathname.device; + + /* Match directories */ + wilds = find_list_wilds(source->pathname.directory, + from->pathname.directory); + if (wilds == @':error') goto error; + if (Null(to->pathname.directory)) { + /* Missing components are replaced */ + d = translate_list_case(source->pathname.directory, fromcase, tocase); + } else { + wilds = translate_list_case(wilds, fromcase, tocase); + d = copy_list_wildcards(&wilds, to->pathname.directory); + if (d == @':error') goto error; + if (wilds != ECL_NIL) goto error2; + } + directory = d; + + /* Match name */ + wilds = find_wilds(ECL_NIL, source->pathname.name, from->pathname.name); + if (wilds == @':error') goto error2; + if (Null(to->pathname.name)) { + d = translate_component_case(source->pathname.name, fromcase, tocase); + } else { + wilds = translate_list_case(wilds, fromcase, tocase); + d = copy_wildcards(&wilds, to->pathname.name); + if (d == @':error') goto error; + if (wilds != ECL_NIL) goto error2; + } + name = d; + + /* Match type */ + wilds = find_wilds(ECL_NIL, source->pathname.type, from->pathname.type); + if (wilds == @':error') goto error2; + if (Null(to->pathname.type)) { + d = translate_component_case(source->pathname.type, fromcase, tocase); + } else { + wilds = translate_list_case(wilds, fromcase, tocase); + d = copy_wildcards(&wilds, to->pathname.type); + if (d == @':error') goto error; + if (wilds != ECL_NIL) goto error2; + } + type = d; + + /* Match version */ + version = to->pathname.version; + if (from->pathname.version == @':wild') { + if (to->pathname.version == @':wild') { + version = source->pathname.version; + } + } + @(return ecl_make_pathname(host, device, directory, name, type, + version, tocase)); error: - FEerror("~S is not a specialization of path ~S", 2, source, from); + FEerror("~S is not a specialization of path ~S", 2, source, from); error2: - FEerror("Number of wildcards in ~S do not match ~S", 2, from, to); + FEerror("Number of wildcards in ~S do not match ~S", 2, from, to); @) @(defun translate-logical-pathname (source &key) - cl_object l, pair; - cl_object pathname; + cl_object l, pair; + cl_object pathname; @ - pathname = cl_pathname(source); + pathname = cl_pathname(source); begin: - if (!pathname->pathname.logical) { - @(return pathname) - } - l = @si::pathname-translations(1, pathname->pathname.host); - for(; !ecl_endp(l); l = CDR(l)) { - pair = CAR(l); - if (!Null(cl_pathname_match_p(pathname, CAR(pair)))) { - pathname = cl_translate_pathname(3, pathname, - CAR(pair), - CADR(pair)); - goto begin; - } - } - FEerror("~S admits no logical pathname translations", 1, pathname); + if (!pathname->pathname.logical) { + @(return pathname); + } + l = @si::pathname-translations(1, pathname->pathname.host); + for(; !ecl_endp(l); l = CDR(l)) { + pair = CAR(l); + if (!Null(cl_pathname_match_p(pathname, CAR(pair)))) { + pathname = cl_translate_pathname(3, pathname, CAR(pair), CADR(pair)); + goto begin; + } + } + FEerror("~S admits no logical pathname translations", 1, pathname); @) diff -Nru ecl-16.1.2/src/c/predicate.d ecl-16.1.3+ds/src/c/predicate.d --- ecl-16.1.2/src/c/predicate.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/predicate.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - predicate.c -- Predicates. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * predicate.d - predicates + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #define ECL_INCLUDE_MATH_H @@ -25,224 +20,224 @@ cl_object cl_identity(cl_object x) { - @(return x) + @(return x); } cl_object cl_null(cl_object x) { - @(return (Null(x) ? ECL_T : ECL_NIL)) + @(return (Null(x) ? ECL_T : ECL_NIL)); } cl_object cl_symbolp(cl_object x) { - @(return (ECL_SYMBOLP(x) ? ECL_T : ECL_NIL)) + @(return (ECL_SYMBOLP(x) ? ECL_T : ECL_NIL)); } cl_object cl_atom(cl_object x) { - @(return (ECL_ATOM(x) ? ECL_T : ECL_NIL)) + @(return (ECL_ATOM(x) ? ECL_T : ECL_NIL)); } cl_object cl_consp(cl_object x) { - @(return (CONSP(x) ? ECL_T : ECL_NIL)) + @(return (CONSP(x) ? ECL_T : ECL_NIL)); } cl_object cl_listp(cl_object x) { - @(return ((Null(x) || CONSP(x)) ? ECL_T : ECL_NIL)) + @(return ((Null(x) || CONSP(x)) ? ECL_T : ECL_NIL)); } cl_object cl_numberp(cl_object x) { - cl_type t = ecl_t_of(x); - @(return (ECL_NUMBER_TYPE_P(t) ? ECL_T : ECL_NIL)) + cl_type t = ecl_t_of(x); + @(return (ECL_NUMBER_TYPE_P(t) ? ECL_T : ECL_NIL)); } /* Used in compiled code */ bool ecl_numberp(cl_object x) { - cl_type t = ecl_t_of(x); - return ECL_NUMBER_TYPE_P(t); + cl_type t = ecl_t_of(x); + return ECL_NUMBER_TYPE_P(t); } cl_object cl_integerp(cl_object x) { - cl_type t = ecl_t_of(x); - @(return ((t == t_fixnum || t == t_bignum) ? ECL_T : ECL_NIL)) + cl_type t = ecl_t_of(x); + @(return ((t == t_fixnum || t == t_bignum) ? ECL_T : ECL_NIL)); } cl_object cl_rationalp(cl_object x) { - cl_type t = ecl_t_of(x); - @(return ((t == t_fixnum || t == t_bignum || t == t_ratio) ? ECL_T : ECL_NIL)) + cl_type t = ecl_t_of(x); + @(return ((t == t_fixnum || t == t_bignum || t == t_ratio) ? ECL_T : ECL_NIL)); } cl_object cl_floatp(cl_object x) { - @(return (floatp(x)? ECL_T : ECL_NIL)) + @(return (floatp(x)? ECL_T : ECL_NIL)); } bool floatp(cl_object x) { - cl_type t = ecl_t_of(x); - return (t == t_singlefloat) || (t == t_doublefloat) + cl_type t = ecl_t_of(x); + return (t == t_singlefloat) || (t == t_doublefloat) #ifdef ECL_LONG_FLOAT - || (t == t_longfloat) + || (t == t_longfloat) #endif - ; + ; } cl_object cl_realp(cl_object x) { - cl_type t = ecl_t_of(x); - @(return (ECL_REAL_TYPE_P(t) ? ECL_T : ECL_NIL)) + cl_type t = ecl_t_of(x); + @(return (ECL_REAL_TYPE_P(t) ? ECL_T : ECL_NIL)); } bool ecl_realp(cl_object x) { - cl_type t = ecl_t_of(x); - return ECL_REAL_TYPE_P(t); + cl_type t = ecl_t_of(x); + return ECL_REAL_TYPE_P(t); } cl_object cl_complexp(cl_object x) { - @(return (ECL_COMPLEXP(x) ? ECL_T : ECL_NIL)) + @(return (ECL_COMPLEXP(x) ? ECL_T : ECL_NIL)); } cl_object cl_characterp(cl_object x) { - @(return (ECL_CHARACTERP(x) ? ECL_T : ECL_NIL)) + @(return (ECL_CHARACTERP(x) ? ECL_T : ECL_NIL)); } #ifdef ECL_UNICODE cl_object si_base_char_p(cl_object c) { - @(return ((ECL_CHARACTERP(c) && ECL_BASE_CHAR_P(c))? ECL_T : ECL_NIL)) + @(return ((ECL_CHARACTERP(c) && ECL_BASE_CHAR_P(c))? ECL_T : ECL_NIL)); } #endif bool ecl_stringp(cl_object x) { - cl_type t = ecl_t_of(x); + cl_type t = ecl_t_of(x); #ifdef ECL_UNICODE - return t == t_base_string || t == t_string; + return t == t_base_string || t == t_string; #else - return t == t_base_string; + return t == t_base_string; #endif } cl_object cl_stringp(cl_object x) { - @(return (ECL_STRINGP(x)? ECL_T : ECL_NIL)) + @(return (ECL_STRINGP(x)? ECL_T : ECL_NIL)); } cl_object cl_bit_vector_p(cl_object x) { - @(return (ECL_BIT_VECTOR_P(x) ? ECL_T : ECL_NIL)) + @(return (ECL_BIT_VECTOR_P(x) ? ECL_T : ECL_NIL)); } cl_object cl_vectorp(cl_object x) { - @(return (ECL_VECTORP(x) ? ECL_T : ECL_NIL)) + @(return (ECL_VECTORP(x) ? ECL_T : ECL_NIL)); } cl_object cl_simple_string_p(cl_object x) { - @(return ((ECL_STRINGP(x) && - !ECL_ADJUSTABLE_ARRAY_P(x) && - !ECL_ARRAY_HAS_FILL_POINTER_P(x) && - Null(CAR(x->base_string.displaced))) ? ECL_T : ECL_NIL)) + @(return ((ECL_STRINGP(x) && + !ECL_ADJUSTABLE_ARRAY_P(x) && + !ECL_ARRAY_HAS_FILL_POINTER_P(x) && + Null(CAR(x->base_string.displaced))) ? ECL_T : ECL_NIL)); } #ifdef ECL_UNICODE cl_object si_base_string_p(cl_object x) { - @(return (ECL_BASE_STRING_P(x) ? ECL_T : ECL_NIL)) + @(return (ECL_BASE_STRING_P(x) ? ECL_T : ECL_NIL)); } #endif cl_object cl_simple_bit_vector_p(cl_object x) { - @(return ((ECL_BIT_VECTOR_P(x) && - !ECL_ADJUSTABLE_ARRAY_P(x) && - !ECL_ARRAY_HAS_FILL_POINTER_P(x) && - Null(CAR(x->vector.displaced))) ? ECL_T : ECL_NIL)) + @(return ((ECL_BIT_VECTOR_P(x) && + !ECL_ADJUSTABLE_ARRAY_P(x) && + !ECL_ARRAY_HAS_FILL_POINTER_P(x) && + Null(CAR(x->vector.displaced))) ? ECL_T : ECL_NIL)); } cl_object cl_simple_vector_p(cl_object x) { - cl_type t = ecl_t_of(x); - @(return ((t == t_vector && - !ECL_ADJUSTABLE_ARRAY_P(x) && - !ECL_ARRAY_HAS_FILL_POINTER_P(x) && - Null(CAR(x->vector.displaced)) && - (cl_elttype)x->vector.elttype == ecl_aet_object) ? ECL_T : ECL_NIL)) + cl_type t = ecl_t_of(x); + @(return ((t == t_vector && + !ECL_ADJUSTABLE_ARRAY_P(x) && + !ECL_ARRAY_HAS_FILL_POINTER_P(x) && + Null(CAR(x->vector.displaced)) && + (cl_elttype)x->vector.elttype == ecl_aet_object) ? ECL_T : ECL_NIL)); } cl_object cl_arrayp(cl_object x) { - @(return (ECL_ARRAYP(x) ? ECL_T : ECL_NIL)) + @(return (ECL_ARRAYP(x) ? ECL_T : ECL_NIL)); } cl_object cl_packagep(cl_object x) { - @(return (ECL_PACKAGEP(x) ? ECL_T : ECL_NIL)) + @(return (ECL_PACKAGEP(x) ? ECL_T : ECL_NIL)); } cl_object cl_functionp(cl_object x) { - cl_type t; - cl_object output; + cl_type t; + cl_object output; - t = ecl_t_of(x); - if (t == t_bytecodes || t == t_bclosure || t == t_cfun - || t == t_cfunfixed || t == t_cclosure - || (t == t_instance && x->instance.isgf)) - output = ECL_T; - else - output = ECL_NIL; - @(return output) + t = ecl_t_of(x); + if (t == t_bytecodes || t == t_bclosure || t == t_cfun + || t == t_cfunfixed || t == t_cclosure + || (t == t_instance && x->instance.isgf)) + output = ECL_T; + else + output = ECL_NIL; + @(return output); } cl_object cl_compiled_function_p(cl_object x) { - cl_type t = ecl_t_of(x); - @(return ((t == t_bytecodes || t == t_bclosure || t == t_cfun - || t == t_cfunfixed || t == t_cclosure) ? ECL_T : ECL_NIL)) -} + cl_type t = ecl_t_of(x); + @(return ((t == t_bytecodes || t == t_bclosure || t == t_cfun + || t == t_cfunfixed || t == t_cclosure) ? ECL_T : ECL_NIL)) + } cl_object cl_eq(cl_object x, cl_object y) { - @(return ((x == y) ? ECL_T : ECL_NIL)) + @(return ((x == y) ? ECL_T : ECL_NIL)); } /* @@ -262,267 +257,267 @@ #if !defined(ECL_SIGNED_ZERO) && !defined(ECL_IEEE_FP) # define FLOAT_EQL(a,b,type) return (a) == (b) #else -# define FLOAT_EQL(a,b,type) { \ - type xa = (a), xb = (b); \ - if (xa == xb) { \ - return signbit(xa) == signbit(xb); \ - } else if (isnan(xa) || isnan(xb)) { \ - return !memcmp(&xa, &xb, sizeof(type)); \ - } else { \ - return 0; \ - } } +# define FLOAT_EQL(a,b,type) { \ + type xa = (a), xb = (b); \ + if (xa == xb) { \ + return signbit(xa) == signbit(xb); \ + } else if (isnan(xa) || isnan(xb)) { \ + return !memcmp(&xa, &xb, sizeof(type)); \ + } else { \ + return 0; \ + } } #endif bool ecl_eql(cl_object x, cl_object y) { - if (x == y) - return TRUE; - if (ECL_IMMEDIATE(x) || ECL_IMMEDIATE(y)) - return FALSE; - if (x->d.t != y->d.t) - return FALSE; - switch (x->d.t) { - case t_bignum: - return (_ecl_big_compare(x, y) == 0); - case t_ratio: - return (ecl_eql(x->ratio.num, y->ratio.num) && - ecl_eql(x->ratio.den, y->ratio.den)); - case t_singlefloat: - FLOAT_EQL(ecl_single_float(x), ecl_single_float(y), float); - case t_doublefloat: - FLOAT_EQL(ecl_double_float(x), ecl_double_float(y), double); + if (x == y) + return TRUE; + if (ECL_IMMEDIATE(x) || ECL_IMMEDIATE(y)) + return FALSE; + if (x->d.t != y->d.t) + return FALSE; + switch (x->d.t) { + case t_bignum: + return (_ecl_big_compare(x, y) == 0); + case t_ratio: + return (ecl_eql(x->ratio.num, y->ratio.num) && + ecl_eql(x->ratio.den, y->ratio.den)); + case t_singlefloat: + FLOAT_EQL(ecl_single_float(x), ecl_single_float(y), float); + case t_doublefloat: + FLOAT_EQL(ecl_double_float(x), ecl_double_float(y), double); #ifdef ECL_LONG_FLOAT - case t_longfloat: - FLOAT_EQL(ecl_long_float(x), ecl_long_float(y), long double); + case t_longfloat: + FLOAT_EQL(ecl_long_float(x), ecl_long_float(y), long double); #endif - case t_complex: - return (ecl_eql(x->complex.real, y->complex.real) && - ecl_eql(x->complex.imag, y->complex.imag)); + case t_complex: + return (ecl_eql(x->complex.real, y->complex.real) && + ecl_eql(x->complex.imag, y->complex.imag)); #ifdef ECL_SSE2 - case t_sse_pack: - return !memcmp(x->sse.data.b8, y->sse.data.b8, 16); + case t_sse_pack: + return !memcmp(x->sse.data.b8, y->sse.data.b8, 16); #endif - default: - return FALSE; - } + default: + return FALSE; + } } cl_object cl_eql(cl_object x, cl_object y) { - @(return (ecl_eql(x, y) ? ECL_T : ECL_NIL)) + @(return (ecl_eql(x, y) ? ECL_T : ECL_NIL)); } bool ecl_equal(register cl_object x, cl_object y) { - cl_type tx, ty; -BEGIN: - if (x==y) - return(TRUE); - tx = ecl_t_of(x); - ty = ecl_t_of(y); - switch (tx) { - case t_list: - if (Null(x) || Null(y)) { - /* If X is NIL, then X and Y must be EQ */ - return FALSE; - } - if (tx != ty || !ecl_equal(CAR(x), CAR(y))) - return FALSE; - x = CDR(x); - y = CDR(y); - goto BEGIN; - case t_symbol: - case t_vector: - case t_array: - case t_fixnum: - return FALSE; - case t_bignum: - return (tx == ty) && (_ecl_big_compare(x,y) == 0); - case t_ratio: - return (tx == ty) && ecl_eql(x->ratio.num, y->ratio.num) && - ecl_eql(x->ratio.den, y->ratio.den); - case t_singlefloat: { - if (tx != ty) return 0; - FLOAT_EQL(ecl_single_float(x), ecl_single_float(y), float); - } - case t_doublefloat: { - if (tx != ty) return 0; - FLOAT_EQL(ecl_double_float(x), ecl_double_float(y), double); - } + cl_type tx, ty; + BEGIN: + if (x==y) + return(TRUE); + tx = ecl_t_of(x); + ty = ecl_t_of(y); + switch (tx) { + case t_list: + if (Null(x) || Null(y)) { + /* If X is NIL, then X and Y must be EQ */ + return FALSE; + } + if (tx != ty || !ecl_equal(CAR(x), CAR(y))) + return FALSE; + x = CDR(x); + y = CDR(y); + goto BEGIN; + case t_symbol: + case t_vector: + case t_array: + case t_fixnum: + return FALSE; + case t_bignum: + return (tx == ty) && (_ecl_big_compare(x,y) == 0); + case t_ratio: + return (tx == ty) && ecl_eql(x->ratio.num, y->ratio.num) && + ecl_eql(x->ratio.den, y->ratio.den); + case t_singlefloat: { + if (tx != ty) return 0; + FLOAT_EQL(ecl_single_float(x), ecl_single_float(y), float); + } + case t_doublefloat: { + if (tx != ty) return 0; + FLOAT_EQL(ecl_double_float(x), ecl_double_float(y), double); + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { - if (tx != ty) return 0; - FLOAT_EQL(ecl_long_float(x), ecl_long_float(y), long double); - } -#endif - case t_complex: - return (tx == ty) && ecl_eql(x->complex.real, y->complex.real) && - ecl_eql(x->complex.imag, y->complex.imag); - case t_character: - return (tx == ty) && (ECL_CHAR_CODE(x) == ECL_CHAR_CODE(y)); - case t_base_string: + case t_longfloat: { + if (tx != ty) return 0; + FLOAT_EQL(ecl_long_float(x), ecl_long_float(y), long double); + } +#endif + case t_complex: + return (tx == ty) && ecl_eql(x->complex.real, y->complex.real) && + ecl_eql(x->complex.imag, y->complex.imag); + case t_character: + return (tx == ty) && (ECL_CHAR_CODE(x) == ECL_CHAR_CODE(y)); + case t_base_string: #ifdef ECL_UNICODE - case t_string: - if (ty != t_base_string && ty != t_string) - return FALSE; + case t_string: + if (ty != t_base_string && ty != t_string) + return FALSE; #else - if (ty != t_base_string) - return FALSE; + if (ty != t_base_string) + return FALSE; #endif - return ecl_string_eq(x, y); - case t_bitvector: { - cl_index i, ox, oy; - if (ty != tx) - return FALSE; - if (x->vector.fillp != y->vector.fillp) - return(FALSE); - ox = x->vector.offset; - oy = y->vector.offset; - for (i = 0; i < x->vector.fillp; i++) - if((x->vector.self.bit[(i+ox)/8] & (0200>>(i+ox)%8)) - !=(y->vector.self.bit[(i+oy)/8] & (0200>>(i+oy)%8))) - return(FALSE); - return(TRUE); - } - case t_pathname: - return ty == tx && - ecl_equal(x->pathname.host, y->pathname.host) && - ecl_equal(x->pathname.device, y->pathname.device) && - ecl_equal(x->pathname.directory, y->pathname.directory) && - ecl_equal(x->pathname.name, y->pathname.name) && - ecl_equal(x->pathname.type, y->pathname.type) && - ecl_equal(x->pathname.version, y->pathname.version); - case t_foreign: - return (tx == ty) && (x->foreign.data == y->foreign.data); - default: - return FALSE; - } + return ecl_string_eq(x, y); + case t_bitvector: { + cl_index i, ox, oy; + if (ty != tx) + return FALSE; + if (x->vector.fillp != y->vector.fillp) + return(FALSE); + ox = x->vector.offset; + oy = y->vector.offset; + for (i = 0; i < x->vector.fillp; i++) + if((x->vector.self.bit[(i+ox)/8] & (0200>>(i+ox)%8)) + !=(y->vector.self.bit[(i+oy)/8] & (0200>>(i+oy)%8))) + return(FALSE); + return(TRUE); + } + case t_pathname: + return ty == tx && + ecl_equal(x->pathname.host, y->pathname.host) && + ecl_equal(x->pathname.device, y->pathname.device) && + ecl_equal(x->pathname.directory, y->pathname.directory) && + ecl_equal(x->pathname.name, y->pathname.name) && + ecl_equal(x->pathname.type, y->pathname.type) && + ecl_equal(x->pathname.version, y->pathname.version); + case t_foreign: + return (tx == ty) && (x->foreign.data == y->foreign.data); + default: + return FALSE; + } } cl_object cl_equal(cl_object x, cl_object y) { - @(return (ecl_equal(x, y) ? ECL_T : ECL_NIL)) + @(return (ecl_equal(x, y) ? ECL_T : ECL_NIL)); } bool ecl_equalp(cl_object x, cl_object y) { - cl_type tx, ty; - cl_index j; -BEGIN: - if (x == y) - return TRUE; - tx = ecl_t_of(x); - ty = ecl_t_of(y); - - switch (tx) { - case t_fixnum: - case t_bignum: - case t_ratio: - case t_singlefloat: - case t_doublefloat: + cl_type tx, ty; + cl_index j; + BEGIN: + if (x == y) + return TRUE; + tx = ecl_t_of(x); + ty = ecl_t_of(y); + + switch (tx) { + case t_fixnum: + case t_bignum: + case t_ratio: + case t_singlefloat: + case t_doublefloat: #ifdef ECL_LONG_FLOAT - case t_longfloat: + case t_longfloat: #endif - case t_complex: - return ECL_NUMBER_TYPE_P(ty) && ecl_number_equalp(x, y); - case t_vector: - case t_base_string: - case t_bitvector: + case t_complex: + return ECL_NUMBER_TYPE_P(ty) && ecl_number_equalp(x, y); + case t_vector: + case t_base_string: + case t_bitvector: #ifdef ECL_UNICODE - case t_string: - if (ty != t_vector && ty != t_base_string && ty != t_bitvector - && ty != t_string) - return FALSE; + case t_string: + if (ty != t_vector && ty != t_base_string && ty != t_bitvector + && ty != t_string) + return FALSE; #else - if (ty != t_vector && ty != t_base_string && ty != t_bitvector) - return FALSE; + if (ty != t_vector && ty != t_base_string && ty != t_bitvector) + return FALSE; #endif - j = x->vector.fillp; - if (j != y->vector.fillp) - return FALSE; - goto ARRAY; - case t_array: - if (ty != t_array || x->array.rank != y->array.rank) - return FALSE; - if (x->array.rank > 1) { - cl_index i = 0; - for (i = 0; i < x->array.rank; i++) - if (x->array.dims[i] != y->array.dims[i]) - return(FALSE); - } - if (x->array.dim != y->array.dim) - return(FALSE); - j=x->array.dim; - ARRAY: { - cl_index i; - for (i = 0; i < j; i++) - if (!ecl_equalp(ecl_aref_unsafe(x, i), ecl_aref_unsafe(y, i))) - return(FALSE); - return(TRUE); - } - case t_character: - return (ty == tx) && ecl_char_equal(x, y); - case t_list: - if ((tx != ty) || Null(x) || Null(y)) { - /* X is NIL but it is not EQ to Y */ - return FALSE; - } - if (!ecl_equalp(CAR(x), CAR(y))) - return(FALSE); - x = CDR(x); - y = CDR(y); - goto BEGIN; - case t_instance: { - cl_index i; - if ((ty != tx) || (ECL_CLASS_OF(x) != ECL_CLASS_OF(y))) - return(FALSE); - for (i = 0; i < x->instance.length; i++) - if (!ecl_equalp(x->instance.slots[i], y->instance.slots[i])) - return(FALSE); - return(TRUE); - } - case t_pathname: - return (tx == ty) && ecl_equal(x, y); - case t_hashtable: { - if (tx != ty || - x->hash.entries != y->hash.entries || - x->hash.test != y->hash.test) - return(FALSE); - { - cl_env_ptr env = ecl_process_env(); - cl_object iterator = si_hash_table_iterator(x); - do { - cl_object ndx = _ecl_funcall1(iterator); - if (Null(ndx)) { - return TRUE; - } else { - cl_object key = env->values[1]; - if (ecl_gethash_safe(key, y, OBJNULL) == OBJNULL) - return FALSE; - } - } while (1); - } - } - case t_random: - return (tx == ty) && ecl_equalp(x->random.value, y->random.value); - default: - return ecl_eql(x,y); + j = x->vector.fillp; + if (j != y->vector.fillp) + return FALSE; + goto ARRAY; + case t_array: + if (ty != t_array || x->array.rank != y->array.rank) + return FALSE; + if (x->array.rank > 1) { + cl_index i = 0; + for (i = 0; i < x->array.rank; i++) + if (x->array.dims[i] != y->array.dims[i]) + return(FALSE); + } + if (x->array.dim != y->array.dim) + return(FALSE); + j=x->array.dim; + ARRAY: { + cl_index i; + for (i = 0; i < j; i++) + if (!ecl_equalp(ecl_aref_unsafe(x, i), ecl_aref_unsafe(y, i))) + return(FALSE); + return(TRUE); + } + case t_character: + return (ty == tx) && ecl_char_equal(x, y); + case t_list: + if ((tx != ty) || Null(x) || Null(y)) { + /* X is NIL but it is not EQ to Y */ + return FALSE; + } + if (!ecl_equalp(CAR(x), CAR(y))) + return(FALSE); + x = CDR(x); + y = CDR(y); + goto BEGIN; + case t_instance: { + cl_index i; + if ((ty != tx) || (ECL_CLASS_OF(x) != ECL_CLASS_OF(y))) + return(FALSE); + for (i = 0; i < x->instance.length; i++) + if (!ecl_equalp(x->instance.slots[i], y->instance.slots[i])) + return(FALSE); + return(TRUE); + } + case t_pathname: + return (tx == ty) && ecl_equal(x, y); + case t_hashtable: { + if (tx != ty || + x->hash.entries != y->hash.entries || + x->hash.test != y->hash.test) + return(FALSE); + { + cl_env_ptr env = ecl_process_env(); + cl_object iterator = si_hash_table_iterator(x); + do { + cl_object ndx = _ecl_funcall1(iterator); + if (Null(ndx)) { + return TRUE; + } else { + cl_object key = env->values[1]; + if (ecl_gethash_safe(key, y, OBJNULL) == OBJNULL) + return FALSE; } + } while (1); + } + } + case t_random: + return (tx == ty) && ecl_equalp(x->random.value, y->random.value); + default: + return ecl_eql(x,y); + } } cl_object cl_equalp(cl_object x, cl_object y) { - @(return (ecl_equalp(x, y) ? ECL_T : ECL_NIL)) + @(return (ecl_equalp(x, y) ? ECL_T : ECL_NIL)); } cl_object si_fixnump(cl_object x) { - @(return (ECL_FIXNUMP(x) ? ECL_T : ECL_NIL)) + @(return (ECL_FIXNUMP(x) ? ECL_T : ECL_NIL)); } diff -Nru ecl-16.1.2/src/c/print.d ecl-16.1.3+ds/src/c/print.d --- ecl-16.1.2/src/c/print.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/print.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - print.d -- Print. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. + * print.d - print + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - See file '../Copyright' for full details. -*/ #include #include #include @@ -23,388 +19,389 @@ cl_object _ecl_stream_or_default_output(cl_object stream) { - if (Null(stream)) - return ecl_symbol_value(@'*standard-output*'); - else if (stream == ECL_T) - return ecl_symbol_value(@'*terminal-io*'); - return stream; + if (Null(stream)) + return ecl_symbol_value(@'*standard-output*'); + else if (stream == ECL_T) + return ecl_symbol_value(@'*terminal-io*'); + return stream; } int ecl_print_base(void) { - cl_object object = ecl_symbol_value(@'*print-base*'); - cl_fixnum base; - unlikely_if (!ECL_FIXNUMP(object) || (base = ecl_fixnum(object)) < 2 || base > 36) { - ECL_SETQ(ecl_process_env(), @'*print-base*', ecl_make_fixnum(10)); - FEerror("The value of *PRINT-BASE*~% ~S~%" - "is not of the expected type (INTEGER 2 36)", 1, object); - } - return base; + cl_object object = ecl_symbol_value(@'*print-base*'); + cl_fixnum base; + unlikely_if (!ECL_FIXNUMP(object) || (base = ecl_fixnum(object)) < 2 || base > 36) { + ECL_SETQ(ecl_process_env(), @'*print-base*', ecl_make_fixnum(10)); + FEerror("The value of *PRINT-BASE*~% ~S~%" + "is not of the expected type (INTEGER 2 36)", 1, object); + } + return base; } cl_fixnum ecl_print_level(void) { - cl_object object = ecl_symbol_value(@'*print-level*'); - cl_fixnum level; - if (object == ECL_NIL) { - level = MOST_POSITIVE_FIXNUM; - } else if (ECL_FIXNUMP(object)) { - level = ecl_fixnum(object); - if (level < 0) { - ERROR: ECL_SETQ(ecl_process_env(), @'*print-level*', ECL_NIL); - FEerror("The value of *PRINT-LEVEL*~% ~S~%" - "is not of the expected type (OR NULL (INTEGER 0 *))", - 1, object); - } - } else if (ecl_unlikely(!ECL_BIGNUMP(object))) { - goto ERROR; - } else { - level = MOST_POSITIVE_FIXNUM; - } - return level; + cl_object object = ecl_symbol_value(@'*print-level*'); + cl_fixnum level; + if (object == ECL_NIL) { + level = MOST_POSITIVE_FIXNUM; + } else if (ECL_FIXNUMP(object)) { + level = ecl_fixnum(object); + if (level < 0) { + ERROR: ECL_SETQ(ecl_process_env(), @'*print-level*', ECL_NIL); + FEerror("The value of *PRINT-LEVEL*~% ~S~%" + "is not of the expected type (OR NULL (INTEGER 0 *))", + 1, object); + } + } else if (ecl_unlikely(!ECL_BIGNUMP(object))) { + goto ERROR; + } else { + level = MOST_POSITIVE_FIXNUM; + } + return level; } cl_fixnum ecl_print_length(void) { - cl_object object = ecl_symbol_value(@'*print-length*'); - cl_fixnum length; - if (object == ECL_NIL) { - length = MOST_POSITIVE_FIXNUM; - } else if (ECL_FIXNUMP(object)) { - length = ecl_fixnum(object); - unlikely_if (length < 0) { - ERROR: ECL_SETQ(ecl_process_env(), @'*print-length*', ECL_NIL); - FEerror("The value of *PRINT-LENGTH*~% ~S~%" - "is not of the expected type (OR NULL (INTEGER 0 *))", - 1, object); - } - } else if (ecl_unlikely(!ECL_BIGNUMP(object))) { - goto ERROR; - } else { - length = MOST_POSITIVE_FIXNUM; - } - return length; + cl_object object = ecl_symbol_value(@'*print-length*'); + cl_fixnum length; + if (object == ECL_NIL) { + length = MOST_POSITIVE_FIXNUM; + } else if (ECL_FIXNUMP(object)) { + length = ecl_fixnum(object); + unlikely_if (length < 0) { + ERROR: ECL_SETQ(ecl_process_env(), @'*print-length*', ECL_NIL); + FEerror("The value of *PRINT-LENGTH*~% ~S~%" + "is not of the expected type (OR NULL (INTEGER 0 *))", + 1, object); + } + } else if (ecl_unlikely(!ECL_BIGNUMP(object))) { + goto ERROR; + } else { + length = MOST_POSITIVE_FIXNUM; + } + return length; } bool ecl_print_radix(void) { - return ecl_symbol_value(@'*print-radix*') != ECL_NIL; + return ecl_symbol_value(@'*print-radix*') != ECL_NIL; } cl_object ecl_print_case(void) { - cl_object output = ecl_symbol_value(@'*print-case*'); - unlikely_if (output != @':upcase' && - output != @':downcase' && - output != @':capitalize') - { - ECL_SETQ(ecl_process_env(), @'*print-case*', @':downcase'); - FEerror("The value of *PRINT-CASE*~% ~S~%" - "is not of the expected type " - "(MEMBER :UPCASE :DOWNCASE :CAPITALIZE)", 1, output); - } - return output; + cl_object output = ecl_symbol_value(@'*print-case*'); + unlikely_if (output != @':upcase' && + output != @':downcase' && + output != @':capitalize') + { + ECL_SETQ(ecl_process_env(), @'*print-case*', @':downcase'); + FEerror("The value of *PRINT-CASE*~% ~S~%" + "is not of the expected type " + "(MEMBER :UPCASE :DOWNCASE :CAPITALIZE)", 1, output); + } + return output; } bool ecl_print_gensym(void) { - return ecl_symbol_value(@'*print-gensym*') != ECL_NIL; + return ecl_symbol_value(@'*print-gensym*') != ECL_NIL; } bool ecl_print_array(void) { - return ecl_symbol_value(@'*print-array*') != ECL_NIL; + return ecl_symbol_value(@'*print-array*') != ECL_NIL; } bool ecl_print_readably(void) { - return ecl_symbol_value(@'*print-readably*') != ECL_NIL; + return ecl_symbol_value(@'*print-readably*') != ECL_NIL; } bool ecl_print_escape(void) { - return ecl_symbol_value(@'*print-escape*') != ECL_NIL; + return ecl_symbol_value(@'*print-escape*') != ECL_NIL; } bool ecl_print_circle(void) { - return ecl_symbol_value(@'*print-circle*') != ECL_NIL; + return ecl_symbol_value(@'*print-circle*') != ECL_NIL; } @(defun write (x &key ((:stream strm) ECL_NIL) - (array ecl_symbol_value(@'*print-array*')) - (base ecl_symbol_value(@'*print-base*')) - ((:case cas) ecl_symbol_value(@'*print-case*')) - (circle ecl_symbol_value(@'*print-circle*')) - (escape ecl_symbol_value(@'*print-escape*')) - (gensym ecl_symbol_value(@'*print-gensym*')) - (length ecl_symbol_value(@'*print-length*')) - (level ecl_symbol_value(@'*print-level*')) - (lines ecl_symbol_value(@'*print-lines*')) - (miser_width ecl_symbol_value(@'*print-miser-width*')) - (pprint_dispatch ecl_symbol_value(@'*print-pprint-dispatch*')) - (pretty ecl_symbol_value(@'*print-pretty*')) - (radix ecl_symbol_value(@'*print-radix*')) - (readably ecl_symbol_value(@'*print-readably*')) - (right_margin ecl_symbol_value(@'*print-right-margin*'))) -@{ - ecl_bds_bind(the_env, @'*print-array*', array); - ecl_bds_bind(the_env, @'*print-base*', base); - ecl_bds_bind(the_env, @'*print-case*', cas); - ecl_bds_bind(the_env, @'*print-circle*', circle); - ecl_bds_bind(the_env, @'*print-escape*', escape); - ecl_bds_bind(the_env, @'*print-gensym*', gensym); - ecl_bds_bind(the_env, @'*print-level*', level); - ecl_bds_bind(the_env, @'*print-length*', length); - ecl_bds_bind(the_env, @'*print-lines*', lines); - ecl_bds_bind(the_env, @'*print-miser-width*', miser_width); - ecl_bds_bind(the_env, @'*print-pprint-dispatch*', pprint_dispatch); - ecl_bds_bind(the_env, @'*print-pretty*', pretty); - ecl_bds_bind(the_env, @'*print-radix*', radix); - ecl_bds_bind(the_env, @'*print-readably*', readably); - ecl_bds_bind(the_env, @'*print-right-margin*', right_margin); - - strm = _ecl_stream_or_default_output(strm); - si_write_object(x, strm); - ecl_force_output(strm); - - ecl_bds_unwind_n(the_env, 15); - @(return x) -@) + (array ecl_symbol_value(@'*print-array*')) + (base ecl_symbol_value(@'*print-base*')) + ((:case cas) ecl_symbol_value(@'*print-case*')) + (circle ecl_symbol_value(@'*print-circle*')) + (escape ecl_symbol_value(@'*print-escape*')) + (gensym ecl_symbol_value(@'*print-gensym*')) + (length ecl_symbol_value(@'*print-length*')) + (level ecl_symbol_value(@'*print-level*')) + (lines ecl_symbol_value(@'*print-lines*')) + (miser_width ecl_symbol_value(@'*print-miser-width*')) + (pprint_dispatch ecl_symbol_value(@'*print-pprint-dispatch*')) + (pretty ecl_symbol_value(@'*print-pretty*')) + (radix ecl_symbol_value(@'*print-radix*')) + (readably ecl_symbol_value(@'*print-readably*')) + (right_margin ecl_symbol_value(@'*print-right-margin*'))) + @ + ecl_bds_bind(the_env, @'*print-array*', array); + ecl_bds_bind(the_env, @'*print-base*', base); + ecl_bds_bind(the_env, @'*print-case*', cas); + ecl_bds_bind(the_env, @'*print-circle*', circle); + ecl_bds_bind(the_env, @'*print-escape*', escape); + ecl_bds_bind(the_env, @'*print-gensym*', gensym); + ecl_bds_bind(the_env, @'*print-level*', level); + ecl_bds_bind(the_env, @'*print-length*', length); + ecl_bds_bind(the_env, @'*print-lines*', lines); + ecl_bds_bind(the_env, @'*print-miser-width*', miser_width); + ecl_bds_bind(the_env, @'*print-pprint-dispatch*', pprint_dispatch); + ecl_bds_bind(the_env, @'*print-pretty*', pretty); + ecl_bds_bind(the_env, @'*print-radix*', radix); + ecl_bds_bind(the_env, @'*print-readably*', readably); + ecl_bds_bind(the_env, @'*print-right-margin*', right_margin); + + strm = _ecl_stream_or_default_output(strm); + si_write_object(x, strm); + ecl_force_output(strm); + + ecl_bds_unwind_n(the_env, 15); + @(return x); + @) @(defun prin1 (obj &optional strm) -@ - ecl_prin1(obj, strm); - @(return obj) -@) + @ + ecl_prin1(obj, strm); + @(return obj); + @) @(defun print (obj &optional strm) -@ - ecl_print(obj, strm); - @(return obj) -@) + @ + ecl_print(obj, strm); + @(return obj); + @) @(defun pprint (obj &optional strm) -@ - strm = _ecl_stream_or_default_output(strm); - ecl_bds_bind(the_env, @'*print-escape*', ECL_T); - ecl_bds_bind(the_env, @'*print-pretty*', ECL_T); - ecl_write_char('\n', strm); - si_write_object(obj, strm); - ecl_force_output(strm); - ecl_bds_unwind_n(the_env, 2); - @(return) -@) + @ + strm = _ecl_stream_or_default_output(strm); + ecl_bds_bind(the_env, @'*print-escape*', ECL_T); + ecl_bds_bind(the_env, @'*print-pretty*', ECL_T); + ecl_write_char('\n', strm); + si_write_object(obj, strm); + ecl_force_output(strm); + ecl_bds_unwind_n(the_env, 2); + @(return); + @) @(defun princ (obj &optional strm) -@ - ecl_princ(obj, strm); - @(return obj) -@) + @ + ecl_princ(obj, strm); + @(return obj); + @) @(defun write-char (c &optional strm) -@ - /* INV: ecl_char_code() checks the type of `c' */ - strm = _ecl_stream_or_default_output(strm); - c = ECL_CODE_CHAR(ecl_write_char(ecl_char_code(c), strm)); - @(return c) -@) + @ + /* INV: ecl_char_code() checks the type of `c' */ + strm = _ecl_stream_or_default_output(strm); + c = ECL_CODE_CHAR(ecl_write_char(ecl_char_code(c), strm)); + @(return c); + @) @(defun write-string (strng &o strm &k (start ecl_make_fixnum(0)) end) -@ - unlikely_if (!ECL_STRINGP(strng)) - FEwrong_type_nth_arg(@[write-string], 1, strng, @[string]); - strm = _ecl_stream_or_default_output(strm); + @ + unlikely_if (!ECL_STRINGP(strng)) + FEwrong_type_nth_arg(@[write-string], 1, strng, @[string]); + strm = _ecl_stream_or_default_output(strm); #ifdef ECL_CLOS_STREAMS - if (!ECL_ANSI_STREAM_P(strm)) - _ecl_funcall5(@'gray::stream-write-string', strm, strng, start, end); - else + if (!ECL_ANSI_STREAM_P(strm)) + _ecl_funcall5(@'gray::stream-write-string', strm, strng, start, end); + else #endif - si_do_write_sequence(strng, strm, start, end); - @(return strng) -@) + si_do_write_sequence(strng, strm, start, end); + @(return strng); + @) @(defun write-line (strng &o strm &k (start ecl_make_fixnum(0)) end) -@ - unlikely_if (!ECL_STRINGP(strng)) - FEwrong_type_nth_arg(@[write-line], 1, strng, @[string]); - strm = _ecl_stream_or_default_output(strm); + @ + unlikely_if (!ECL_STRINGP(strng)) + FEwrong_type_nth_arg(@[write-line], 1, strng, @[string]); + strm = _ecl_stream_or_default_output(strm); #ifdef ECL_CLOS_STREAMS - if (!ECL_ANSI_STREAM_P(strm)) - _ecl_funcall5(@'gray::stream-write-string', strm, strng, - start, end); - else + if (!ECL_ANSI_STREAM_P(strm)) + _ecl_funcall5(@'gray::stream-write-string', strm, strng, + start, end); + else #endif - si_do_write_sequence(strng, strm, start, end); - ecl_terpri(strm); - @(return strng) -@) + si_do_write_sequence(strng, strm, start, end); + ecl_terpri(strm); + @(return strng); + @) @(defun terpri (&optional strm) -@ - ecl_terpri(strm); - @(return ECL_NIL) -@) + @ + ecl_terpri(strm); + @(return ECL_NIL); + @) @(defun fresh-line (&optional strm) -@ - strm = _ecl_stream_or_default_output(strm); + @ + strm = _ecl_stream_or_default_output(strm); #ifdef ECL_CLOS_STREAMS - if (!ECL_ANSI_STREAM_P(strm)) { - return _ecl_funcall2(@'gray::stream-fresh-line', strm); - } + if (!ECL_ANSI_STREAM_P(strm)) { + return _ecl_funcall2(@'gray::stream-fresh-line', strm); + } #endif - if (ecl_file_column(strm) == 0) - @(return ECL_NIL) - ecl_write_char('\n', strm); - ecl_force_output(strm); - @(return ECL_T) -@) + if (ecl_file_column(strm) == 0) { + @(return ECL_NIL); + } + ecl_write_char('\n', strm); + ecl_force_output(strm); + @(return ECL_T); + @) @(defun finish-output (&o strm) -@ - strm = _ecl_stream_or_default_output(strm); + @ + strm = _ecl_stream_or_default_output(strm); #ifdef ECL_CLOS_STREAMS - if (!ECL_ANSI_STREAM_P(strm)) { - return _ecl_funcall2(@'gray::stream-finish-output', strm); - } + if (!ECL_ANSI_STREAM_P(strm)) { + return _ecl_funcall2(@'gray::stream-finish-output', strm); + } #endif - ecl_force_output(strm); - @(return ECL_NIL) -@) + ecl_force_output(strm); + @(return ECL_NIL); + @) @(defun force-output (&o strm) -@ - strm = _ecl_stream_or_default_output(strm); - ecl_force_output(strm); - @(return ECL_NIL) -@) + @ + strm = _ecl_stream_or_default_output(strm); + ecl_force_output(strm); + @(return ECL_NIL); + @) @(defun clear-output (&o strm) -@ - strm = _ecl_stream_or_default_output(strm); - ecl_clear_output(strm); - @(return ECL_NIL) -@) + @ + strm = _ecl_stream_or_default_output(strm); + ecl_clear_output(strm); + @(return ECL_NIL); + @) cl_object cl_write_byte(cl_object integer, cl_object binary_output_stream) { - ecl_write_byte(integer, binary_output_stream); - @(return integer) + ecl_write_byte(integer, binary_output_stream); + @(return integer); } @(defun write-sequence (sequence stream &key (start ecl_make_fixnum(0)) end) -@ + @ #ifdef ECL_CLOS_STREAMS - if (!ECL_ANSI_STREAM_P(stream)) { - return _ecl_funcall5(@'gray::stream-write-sequence', - stream, sequence, start, end); - } else + if (!ECL_ANSI_STREAM_P(stream)) { + return _ecl_funcall5(@'gray::stream-write-sequence', + stream, sequence, start, end); + } else #endif - return si_do_write_sequence(sequence, stream, start, end); -@) + return si_do_write_sequence(sequence, stream, start, end); + @) cl_object ecl_princ(cl_object obj, cl_object strm) { - const cl_env_ptr the_env = ecl_process_env(); - strm = _ecl_stream_or_default_output(strm); - ecl_bds_bind(the_env, @'*print-escape*', ECL_NIL); - ecl_bds_bind(the_env, @'*print-readably*', ECL_NIL); - si_write_object(obj, strm); - ecl_bds_unwind_n(the_env, 2); - return obj; + const cl_env_ptr the_env = ecl_process_env(); + strm = _ecl_stream_or_default_output(strm); + ecl_bds_bind(the_env, @'*print-escape*', ECL_NIL); + ecl_bds_bind(the_env, @'*print-readably*', ECL_NIL); + si_write_object(obj, strm); + ecl_bds_unwind_n(the_env, 2); + return obj; } cl_object ecl_prin1(cl_object obj, cl_object strm) { - const cl_env_ptr the_env = ecl_process_env(); - strm = _ecl_stream_or_default_output(strm); - ecl_bds_bind(the_env, @'*print-escape*', ECL_T); - si_write_object(obj, strm); - ecl_force_output(strm); - ecl_bds_unwind1(the_env); - return obj; + const cl_env_ptr the_env = ecl_process_env(); + strm = _ecl_stream_or_default_output(strm); + ecl_bds_bind(the_env, @'*print-escape*', ECL_T); + si_write_object(obj, strm); + ecl_force_output(strm); + ecl_bds_unwind1(the_env); + return obj; } cl_object ecl_print(cl_object obj, cl_object strm) { - strm = _ecl_stream_or_default_output(strm); - ecl_terpri(strm); - ecl_prin1(obj, strm); - ecl_princ_char(' ', strm); - return obj; + strm = _ecl_stream_or_default_output(strm); + ecl_terpri(strm); + ecl_prin1(obj, strm); + ecl_princ_char(' ', strm); + return obj; } cl_object ecl_terpri(cl_object strm) { - strm = _ecl_stream_or_default_output(strm); + strm = _ecl_stream_or_default_output(strm); #ifdef ECL_CLOS_STREAMS - if (!ECL_ANSI_STREAM_P(strm)) { - return _ecl_funcall2(@'gray::stream-terpri', strm); - } + if (!ECL_ANSI_STREAM_P(strm)) { + return _ecl_funcall2(@'gray::stream-terpri', strm); + } #endif - ecl_write_char('\n', strm); - ecl_force_output(strm); - return(ECL_NIL); + ecl_write_char('\n', strm); + ecl_force_output(strm); + return(ECL_NIL); } void ecl_write_string(cl_object strng, cl_object strm) { - cl_index i; + cl_index i; - strm = _ecl_stream_or_default_output(strm); - switch(ecl_t_of(strng)) { + strm = _ecl_stream_or_default_output(strm); + switch(ecl_t_of(strng)) { #ifdef ECL_UNICODE - case t_string: - for (i = 0; i < strng->string.fillp; i++) - ecl_write_char(strng->string.self[i], strm); - break; + case t_string: + for (i = 0; i < strng->string.fillp; i++) + ecl_write_char(strng->string.self[i], strm); + break; #endif - case t_base_string: - for (i = 0; i < strng->base_string.fillp; i++) - ecl_write_char(strng->base_string.self[i], strm); - break; - default: - FEwrong_type_nth_arg(@[write-string], 1, strng, @[string]); - } + case t_base_string: + for (i = 0; i < strng->base_string.fillp; i++) + ecl_write_char(strng->base_string.self[i], strm); + break; + default: + FEwrong_type_nth_arg(@[write-string], 1, strng, @[string]); + } - ecl_force_output(strm); + ecl_force_output(strm); } /* - THE ULTRA-SPECIAL-DINNER-SERVICE OPTIMIZATION + THE ULTRA-SPECIAL-DINNER-SERVICE OPTIMIZATION */ void ecl_princ_str(const char *s, cl_object strm) { - strm = _ecl_stream_or_default_output(strm); - writestr_stream(s, strm); + strm = _ecl_stream_or_default_output(strm); + writestr_stream(s, strm); } int ecl_princ_char(int c, cl_object strm) { - strm = _ecl_stream_or_default_output(strm); - ecl_write_char(c, strm); - if (c == '\n') { - ecl_force_output(strm); - } - return c; + strm = _ecl_stream_or_default_output(strm); + ecl_write_char(c, strm); + if (c == '\n') { + ecl_force_output(strm); + } + return c; } diff -Nru ecl-16.1.2/src/c/printer/float_string_old.d ecl-16.1.3+ds/src/c/printer/float_string_old.d --- ecl-16.1.2/src/c/printer/float_string_old.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/printer/float_string_old.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,16 +1,13 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - Copyright (c) 2010, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../../Copyright' for full details. -*/ + * + * Copyright (c) 2010 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -92,19 +89,19 @@ static bool large_mantissa(cl_object r, cl_object mp, cl_object s) { - return ecl_greatereq(ecl_plus(ecl_ash(r,1), mp), - ecl_ash(s, 1)); + return ecl_greatereq(ecl_plus(ecl_ash(r,1), mp), + ecl_ash(s, 1)); } static cl_fixnum assert_floating_point_width(cl_object width) { - if (!ECL_FIXNUMP(width) || ecl_lower(width,ecl_make_fixnum(1))) { - FEerror("Invalid number of floating point digits." - "~%~A~%is not an integer within bounds", - 1, width); - } - return ecl_fixnum(width); + if (!ECL_FIXNUMP(width) || ecl_lower(width,ecl_make_fixnum(1))) { + FEerror("Invalid number of floating point digits." + "~%~A~%is not an integer within bounds", + 1, width); + } + return ecl_fixnum(width); } static cl_object @@ -112,207 +109,207 @@ cl_object fraction, cl_object exponent, cl_object precision, cl_object width, cl_object fdigits, cl_object scale, cl_object fmin) { - cl_object r = fraction; - cl_object s = ecl_make_fixnum(1); - cl_object mm = s; - cl_object mp = s; - cl_fixnum i, k = 0, digits = 0, decpnt = 0, cutoff = 0; - cl_object u; - char *buffer; - bool roundup = 0, cutoffp = 0, low = 0, high = 0; - - if (Null(digits_string)) { - digits_string = si_make_vector(@'base-char', ecl_make_fixnum(10), - ECL_T /* adjustable */, - ecl_make_fixnum(0) /* fill pointer */, - ECL_NIL /* displacement */, - ECL_NIL /* displ. offset */); - } - /* Represent fraction as r/s, error bounds as m+/s and m-/s. - * Rational arithmetic avoids loss of precision in subsequent - * calculations. - */ - { - int sign = ecl_number_compare(exponent, ecl_make_fixnum(0)); - if (sign > 0) { - r = cl_ash(fraction, exponent); - mm = cl_ash(ecl_make_fixnum(1), exponent); - mp = mm; - } else if (sign < 0) { - s = cl_ash(ecl_make_fixnum(1), ecl_negate(exponent)); - } - } - /* Adjust error bounds m+ and m- for unequal gaps */ - if (ecl_number_equalp(fraction, cl_ash(ecl_make_fixnum(1), precision))) { - mp = ecl_ash(mm, 1); - r = ecl_ash(r, 1); - s = ecl_ash(s, 1); - } - /* Scale value by requested amount and update error bounds */ - if (!Null(scale)) { - if (ecl_minusp(scale)) { - cl_object factor = cl_expt(ecl_make_fixnum(10), - ecl_negate(scale)); - s = ecl_times(s, factor); - } else { - cl_object factor = cl_expt(ecl_make_fixnum(10), scale); - r = ecl_times(r, factor); - mm = ecl_times(mm, factor); - mp = ecl_times(mp, factor); - } - } - while (ecl_lower(r, ecl_ceiling2(s, ecl_make_fixnum(10)))) { - k--; - r = ecl_times(r, ecl_make_fixnum(10)); - mm = ecl_times(r, ecl_make_fixnum(10)); - mp = ecl_times(r, ecl_make_fixnum(10)); - } - do { - /* Ensure mantissa (r + m+)/s is smaller than one */ - while (large_mantissa(r, mp, s)) { - s = ecl_times(s, ecl_make_fixnum(10)); - k++; - } - /* Determine the number of digits to generate */ - if (!Null(fdigits)) { - cutoffp = 1; - cutoff = assert_floating_point_width(width); - } else if (!Null(width)) { - cutoffp = 1; - cutoff = assert_floating_point_width(width); - if (k < 0) { - cutoff = cutoff - 1; - } else { - cutoff = cutoff - k + 1; - } - } - /* ... and ensure it is never less than fmin */ - if (cutoffp) { - cl_fixnum a, i; - cl_object y; - if (!Null(fmin)) { - cl_fixnum f = assert_floating_point_width(fmin); - if (cutoff < f) - cutoff = f; - } - /* If we decided to cut off digit generation before precision - * has been exhausted, rounding the last digit may cause a - * carry propagation. We can prevent this, preserving - * left-to-right digit generation, with a few magical - * adjustments to m- and m+. Of course, correct rounding is - * also preserved. */ - a = k - cutoff; - y = s; - if (a < 0) { - for (i = 0, a = -a; i < a; i++) { - y = ecl_ceiling2(y, ecl_make_fixnum(10)); - } - } else { - for (i = 0, a = -a; i < a; i++) { - y = ecl_times(y, ecl_make_fixnum(10)); - } - } - mm = cl_max(2, y, mm); - mp = cl_max(2, y, mp); - roundup = ecl_number_equalp(mp, y); - } - } while (large_mantissa(r, mp, s)); - /* Zero-fill before fraction if no integer part */ - if (k < 0) { - decpnt = digits; - ecl_string_push_extend(digits_string, '.'); - for (i = k; i; i++) { - digits++; - ecl_string_push_extend(digits_string, '0'); - } - } - /* Generate least significant digits */ - do { - int sign; - if (--k == -1) { - ecl_string_push_extend(digits_string, '.'); - decpnt = digits; - } - u = ecl_truncate2(ecl_times(r, ecl_make_fixnum(10)), s); - r = VALUES(1); - mm = ecl_times(mm, ecl_make_fixnum(10)); - mp = ecl_times(mp, ecl_make_fixnum(10)); - low = ecl_lower(ecl_ash(r,1), mm); - sign = ecl_number_compare(ecl_ash(r,1), ecl_minus(ecl_ash(s,1),mp)); - high = roundup? (sign >= 0) : (sign > 0); - /* stop when either precision is exhausted or we have printed as many - * fraction digits as permitted */ - if (low || high || (cutoffp && (k + cutoff <= 0))) - break; - ecl_string_push_extend(digits_string, ecl_digit_char(ecl_fixnum(u), 10)); - digits++; - } while(1); - /* If cutof occured before first digit, then no digits generated at all */ - if (!cutoffp || (k + cutoff) >= 0) { - /* Last digit may need rounding */ - int digit = ecl_fixnum(u); - if (low && !high) - digit = ecl_fixnum(u); - else if (high && !low) - digit = ecl_fixnum(u)+1; - else if (ecl_lower(ecl_ash(r,1), s)) - digit = ecl_fixnum(u); - else - digit = ecl_fixnum(u) + 1; - ecl_string_push_extend(digits_string, ecl_digit_char(digit, 10)); - digits++; - } - /* Zero-fill after integer part if no fraction */ - if (k >= 0) { - for (i = 0; i < k; i++) { - ecl_string_push_extend(digits_string, '0'); - digits++; - } - ecl_string_push_extend(digits_string, '.'); - decpnt = digits; - } - /* Add trailing zeroes to pad fraction if fdigits needed */ - if (!Null(fdigits)) { - cl_fixnum f = assert_floating_point_width(fdigits) - (digits - decpnt); - for (i = 0; i < f; i++) { - ecl_string_push_extend(digits_string, '0'); - digits++; - } - } - /* All done */ - @(return - digits_string - ecl_make_fixnum(1+digits) - ((decpnt == 0)? ECL_T : ECL_NIL) - ((decpnt == digits)? ECL_T : ECL_NIL) - ecl_make_fixnum(decpnt)) + cl_object r = fraction; + cl_object s = ecl_make_fixnum(1); + cl_object mm = s; + cl_object mp = s; + cl_fixnum i, k = 0, digits = 0, decpnt = 0, cutoff = 0; + cl_object u; + char *buffer; + bool roundup = 0, cutoffp = 0, low = 0, high = 0; + + if (Null(digits_string)) { + digits_string = si_make_vector(@'base-char', ecl_make_fixnum(10), + ECL_T /* adjustable */, + ecl_make_fixnum(0) /* fill pointer */, + ECL_NIL /* displacement */, + ECL_NIL /* displ. offset */); + } + /* Represent fraction as r/s, error bounds as m+/s and m-/s. + * Rational arithmetic avoids loss of precision in subsequent + * calculations. + */ + { + int sign = ecl_number_compare(exponent, ecl_make_fixnum(0)); + if (sign > 0) { + r = cl_ash(fraction, exponent); + mm = cl_ash(ecl_make_fixnum(1), exponent); + mp = mm; + } else if (sign < 0) { + s = cl_ash(ecl_make_fixnum(1), ecl_negate(exponent)); + } + } + /* Adjust error bounds m+ and m- for unequal gaps */ + if (ecl_number_equalp(fraction, cl_ash(ecl_make_fixnum(1), precision))) { + mp = ecl_ash(mm, 1); + r = ecl_ash(r, 1); + s = ecl_ash(s, 1); + } + /* Scale value by requested amount and update error bounds */ + if (!Null(scale)) { + if (ecl_minusp(scale)) { + cl_object factor = cl_expt(ecl_make_fixnum(10), + ecl_negate(scale)); + s = ecl_times(s, factor); + } else { + cl_object factor = cl_expt(ecl_make_fixnum(10), scale); + r = ecl_times(r, factor); + mm = ecl_times(mm, factor); + mp = ecl_times(mp, factor); + } + } + while (ecl_lower(r, ecl_ceiling2(s, ecl_make_fixnum(10)))) { + k--; + r = ecl_times(r, ecl_make_fixnum(10)); + mm = ecl_times(r, ecl_make_fixnum(10)); + mp = ecl_times(r, ecl_make_fixnum(10)); + } + do { + /* Ensure mantissa (r + m+)/s is smaller than one */ + while (large_mantissa(r, mp, s)) { + s = ecl_times(s, ecl_make_fixnum(10)); + k++; + } + /* Determine the number of digits to generate */ + if (!Null(fdigits)) { + cutoffp = 1; + cutoff = assert_floating_point_width(width); + } else if (!Null(width)) { + cutoffp = 1; + cutoff = assert_floating_point_width(width); + if (k < 0) { + cutoff = cutoff - 1; + } else { + cutoff = cutoff - k + 1; + } + } + /* ... and ensure it is never less than fmin */ + if (cutoffp) { + cl_fixnum a, i; + cl_object y; + if (!Null(fmin)) { + cl_fixnum f = assert_floating_point_width(fmin); + if (cutoff < f) + cutoff = f; + } + /* If we decided to cut off digit generation before precision + * has been exhausted, rounding the last digit may cause a + * carry propagation. We can prevent this, preserving + * left-to-right digit generation, with a few magical + * adjustments to m- and m+. Of course, correct rounding is + * also preserved. */ + a = k - cutoff; + y = s; + if (a < 0) { + for (i = 0, a = -a; i < a; i++) { + y = ecl_ceiling2(y, ecl_make_fixnum(10)); + } + } else { + for (i = 0, a = -a; i < a; i++) { + y = ecl_times(y, ecl_make_fixnum(10)); + } + } + mm = cl_max(2, y, mm); + mp = cl_max(2, y, mp); + roundup = ecl_number_equalp(mp, y); + } + } while (large_mantissa(r, mp, s)); + /* Zero-fill before fraction if no integer part */ + if (k < 0) { + decpnt = digits; + ecl_string_push_extend(digits_string, '.'); + for (i = k; i; i++) { + digits++; + ecl_string_push_extend(digits_string, '0'); + } + } + /* Generate least significant digits */ + do { + int sign; + if (--k == -1) { + ecl_string_push_extend(digits_string, '.'); + decpnt = digits; + } + u = ecl_truncate2(ecl_times(r, ecl_make_fixnum(10)), s); + r = VALUES(1); + mm = ecl_times(mm, ecl_make_fixnum(10)); + mp = ecl_times(mp, ecl_make_fixnum(10)); + low = ecl_lower(ecl_ash(r,1), mm); + sign = ecl_number_compare(ecl_ash(r,1), ecl_minus(ecl_ash(s,1),mp)); + high = roundup? (sign >= 0) : (sign > 0); + /* stop when either precision is exhausted or we have printed as many + * fraction digits as permitted */ + if (low || high || (cutoffp && (k + cutoff <= 0))) + break; + ecl_string_push_extend(digits_string, ecl_digit_char(ecl_fixnum(u), 10)); + digits++; + } while(1); + /* If cutof occured before first digit, then no digits generated at all */ + if (!cutoffp || (k + cutoff) >= 0) { + /* Last digit may need rounding */ + int digit = ecl_fixnum(u); + if (low && !high) + digit = ecl_fixnum(u); + else if (high && !low) + digit = ecl_fixnum(u)+1; + else if (ecl_lower(ecl_ash(r,1), s)) + digit = ecl_fixnum(u); + else + digit = ecl_fixnum(u) + 1; + ecl_string_push_extend(digits_string, ecl_digit_char(digit, 10)); + digits++; + } + /* Zero-fill after integer part if no fraction */ + if (k >= 0) { + for (i = 0; i < k; i++) { + ecl_string_push_extend(digits_string, '0'); + digits++; + } + ecl_string_push_extend(digits_string, '.'); + decpnt = digits; + } + /* Add trailing zeroes to pad fraction if fdigits needed */ + if (!Null(fdigits)) { + cl_fixnum f = assert_floating_point_width(fdigits) - (digits - decpnt); + for (i = 0; i < f; i++) { + ecl_string_push_extend(digits_string, '0'); + digits++; + } + } + /* All done */ + @(return + digits_string + ecl_make_fixnum(1+digits) + ((decpnt == 0)? ECL_T : ECL_NIL) + ((decpnt == digits)? ECL_T : ECL_NIL) + ecl_make_fixnum(decpnt)); } ecl_def_ct_base_string(str_dot,".",1,static,const); @(defun ext::float-string (string x &optional width fdigits scale fmin) -@ -{ - if (ecl_zerop(x)) { - if (Null(fdigits)) { - cl_object s = cl_make_string(3, ecl_one_plus(fdigits), - @':initial-element', - ECL_CODE_CHAR('0')); - ecl_char_set(s, 0, '.'); - @(return s cl_length(s) ECL_T cl_zerop(fdigits) ecl_make_fixnum(0)); - } else { - @(return str_dot ecl_make_fixnum(1) ECL_T ECL_T ecl_make_fixnum(0)); - } - } else { - cl_object sig = cl_integer_decode_float(x); - cl_object exp = VALUES(1); - cl_object precision = cl_float_precision(x); - cl_object digits = cl_float_digits(x); - cl_object fudge = ecl_minus(digits, precision); - cl_object w = Null(width)? ECL_NIL : cl_max(2, width, ecl_make_fixnum(1)); - return float_string(string, cl_ash(sig, ecl_negate(fudge)), - ecl_plus(exp, fudge), precision, w, - fdigits, scale, fmin); - } -} -@) + @ + { + if (ecl_zerop(x)) { + if (Null(fdigits)) { + cl_object s = cl_make_string(3, ecl_one_plus(fdigits), + @':initial-element', + ECL_CODE_CHAR('0')); + ecl_char_set(s, 0, '.'); + @(return s cl_length(s) ECL_T cl_zerop(fdigits) ecl_make_fixnum(0)); + } else { + @(return str_dot ecl_make_fixnum(1) ECL_T ECL_T ecl_make_fixnum(0)); + } + } else { + cl_object sig = cl_integer_decode_float(x); + cl_object exp = VALUES(1); + cl_object precision = cl_float_precision(x); + cl_object digits = cl_float_digits(x); + cl_object fudge = ecl_minus(digits, precision); + cl_object w = Null(width)? ECL_NIL : cl_max(2, width, ecl_make_fixnum(1)); + return float_string(string, cl_ash(sig, ecl_negate(fudge)), + ecl_plus(exp, fudge), precision, w, + fdigits, scale, fmin); + } + } + @) diff -Nru ecl-16.1.2/src/c/printer/float_to_digits.d ecl-16.1.3+ds/src/c/printer/float_to_digits.d --- ecl-16.1.2/src/c/printer/float_to_digits.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/printer/float_to_digits.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,16 +1,13 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - Copyright (c) 2010, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../../Copyright' for full details. -*/ + * + * Copyright (c) 2010 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #define ECL_INCLUDE_MATH_H #include @@ -21,201 +18,201 @@ #define EXPT_RADIX(x) ecl_ash(ecl_make_fixnum(1),x) typedef struct { - cl_object r; - cl_object s; - cl_object mm; - cl_object mp; - bool high_ok; - bool low_ok; + cl_object r; + cl_object s; + cl_object mm; + cl_object mp; + bool high_ok; + bool low_ok; } float_approx; static cl_object times2(cl_object x) { - return ecl_plus(x, x); + return ecl_plus(x, x); } static float_approx * setup(cl_object number, float_approx *approx) { - cl_object f = cl_integer_decode_float(number); - cl_fixnum e = ecl_fixnum(VALUES(1)), min_e; - bool limit_f = 0; - switch (ecl_t_of(number)) { - case t_singlefloat: - min_e = FLT_MIN_EXP; - limit_f = (number->SF.SFVAL == - ldexpf(FLT_RADIX, FLT_MANT_DIG-1)); - break; - case t_doublefloat: - min_e = DBL_MIN_EXP; - limit_f = (number->DF.DFVAL == - ldexp(FLT_RADIX, DBL_MANT_DIG-1)); - break; + cl_object f = cl_integer_decode_float(number); + cl_fixnum e = ecl_fixnum(VALUES(1)), min_e; + bool limit_f = 0; + switch (ecl_t_of(number)) { + case t_singlefloat: + min_e = FLT_MIN_EXP; + limit_f = (number->SF.SFVAL == + ldexpf(FLT_RADIX, FLT_MANT_DIG-1)); + break; + case t_doublefloat: + min_e = DBL_MIN_EXP; + limit_f = (number->DF.DFVAL == + ldexp(FLT_RADIX, DBL_MANT_DIG-1)); + break; #ifdef ECL_LONG_FLOAT - case t_longfloat: - min_e = LDBL_MIN_EXP; - limit_f = (number->longfloat.value == - ldexpl(FLT_RADIX, LDBL_MANT_DIG-1)); + case t_longfloat: + min_e = LDBL_MIN_EXP; + limit_f = (number->longfloat.value == + ldexpl(FLT_RADIX, LDBL_MANT_DIG-1)); #endif - } - approx->low_ok = approx->high_ok = ecl_evenp(f); - if (e > 0) { - cl_object be = EXPT_RADIX(e); - if (limit_f) { - cl_object be1 = ecl_times(be, ecl_make_fixnum(FLT_RADIX)); - approx->r = times2(ecl_times(f, be1)); - approx->s = ecl_make_fixnum(FLT_RADIX*2); - approx->mm = be; - approx->mp = be1; - } else { - approx->r = times2(ecl_times(f, be)); - approx->s = ecl_make_fixnum(2); - approx->mm = be; - approx->mp = be; - } - } else if (!limit_f || (e == min_e)) { - approx->r = times2(f); - approx->s = times2(EXPT_RADIX(-e)); - approx->mp = ecl_make_fixnum(1); - approx->mm = ecl_make_fixnum(1); - } else { - approx->r = times2(ecl_make_fixnum(FLT_RADIX)); - approx->s = times2(EXPT_RADIX(1-e)); - approx->mp = ecl_make_fixnum(FLT_RADIX); - approx->mm = ecl_make_fixnum(1); - } - return approx; + } + approx->low_ok = approx->high_ok = ecl_evenp(f); + if (e > 0) { + cl_object be = EXPT_RADIX(e); + if (limit_f) { + cl_object be1 = ecl_times(be, ecl_make_fixnum(FLT_RADIX)); + approx->r = times2(ecl_times(f, be1)); + approx->s = ecl_make_fixnum(FLT_RADIX*2); + approx->mm = be; + approx->mp = be1; + } else { + approx->r = times2(ecl_times(f, be)); + approx->s = ecl_make_fixnum(2); + approx->mm = be; + approx->mp = be; + } + } else if (!limit_f || (e == min_e)) { + approx->r = times2(f); + approx->s = times2(EXPT_RADIX(-e)); + approx->mp = ecl_make_fixnum(1); + approx->mm = ecl_make_fixnum(1); + } else { + approx->r = times2(ecl_make_fixnum(FLT_RADIX)); + approx->s = times2(EXPT_RADIX(1-e)); + approx->mp = ecl_make_fixnum(FLT_RADIX); + approx->mm = ecl_make_fixnum(1); + } + return approx; } static cl_fixnum scale(float_approx *approx) { - cl_fixnum k = 0; - cl_object x = ecl_plus(approx->r, approx->mp); - int sign; - do { - sign = ecl_number_compare(x, approx->s); - if (approx->high_ok) { - if (sign < 0) - break; - } else { - if (sign <= 0) - break; - } - approx->s = ecl_times(approx->s, PRINT_BASE); - k++; - } while(1); - do { - x = ecl_times(x, PRINT_BASE); - sign = ecl_number_compare(x, approx->s); - if (approx->high_ok) { - if (sign >= 0) - break; - } else { - if (sign > 0) - break; - } - k--; - approx->r = ecl_times(approx->r, PRINT_BASE); - approx->mm = ecl_times(approx->mm, PRINT_BASE); - approx->mp = ecl_times(approx->mp, PRINT_BASE); - } while(1); - return k; + cl_fixnum k = 0; + cl_object x = ecl_plus(approx->r, approx->mp); + int sign; + do { + sign = ecl_number_compare(x, approx->s); + if (approx->high_ok) { + if (sign < 0) + break; + } else { + if (sign <= 0) + break; + } + approx->s = ecl_times(approx->s, PRINT_BASE); + k++; + } while(1); + do { + x = ecl_times(x, PRINT_BASE); + sign = ecl_number_compare(x, approx->s); + if (approx->high_ok) { + if (sign >= 0) + break; + } else { + if (sign > 0) + break; + } + k--; + approx->r = ecl_times(approx->r, PRINT_BASE); + approx->mm = ecl_times(approx->mm, PRINT_BASE); + approx->mp = ecl_times(approx->mp, PRINT_BASE); + } while(1); + return k; } static cl_object generate(cl_object digits, float_approx *approx) { - cl_object d, x; - cl_fixnum digit; - bool tc1, tc2; - do { - d = ecl_truncate2(ecl_times(approx->r, PRINT_BASE), approx->s); - approx->r = VALUES(1); - approx->mp = ecl_times(approx->mp, PRINT_BASE); - approx->mm = ecl_times(approx->mm, PRINT_BASE); - tc1 = approx->low_ok? - ecl_lowereq(approx->r, approx->mm) : - ecl_lower(approx->r, approx->mm); - x = ecl_plus(approx->r, approx->mp); - tc2 = approx->high_ok? - ecl_greatereq(x, approx->s) : - ecl_greater(x, approx->s); - if (tc1 || tc2) { - break; - } - ecl_string_push_extend(digits, ecl_digit_char(ecl_fixnum(d), 10)); - } while (1); - if (tc2 && !tc1) { - digit = ecl_fixnum(d) + 1; - } else if (tc1 && !tc2) { - digit = ecl_fixnum(d); - } else if (ecl_lower(times2(approx->r), approx->s)) { - digit = ecl_fixnum(d); - } else { - digit = ecl_fixnum(d) + 1; - } - ecl_string_push_extend(digits, ecl_digit_char(digit, 10)); - return digits; + cl_object d, x; + cl_fixnum digit; + bool tc1, tc2; + do { + d = ecl_truncate2(ecl_times(approx->r, PRINT_BASE), approx->s); + approx->r = VALUES(1); + approx->mp = ecl_times(approx->mp, PRINT_BASE); + approx->mm = ecl_times(approx->mm, PRINT_BASE); + tc1 = approx->low_ok? + ecl_lowereq(approx->r, approx->mm) : + ecl_lower(approx->r, approx->mm); + x = ecl_plus(approx->r, approx->mp); + tc2 = approx->high_ok? + ecl_greatereq(x, approx->s) : + ecl_greater(x, approx->s); + if (tc1 || tc2) { + break; + } + ecl_string_push_extend(digits, ecl_digit_char(ecl_fixnum(d), 10)); + } while (1); + if (tc2 && !tc1) { + digit = ecl_fixnum(d) + 1; + } else if (tc1 && !tc2) { + digit = ecl_fixnum(d); + } else if (ecl_lower(times2(approx->r), approx->s)) { + digit = ecl_fixnum(d); + } else { + digit = ecl_fixnum(d) + 1; + } + ecl_string_push_extend(digits, ecl_digit_char(digit, 10)); + return digits; } static void change_precision(float_approx *approx, cl_object position, cl_object relativep) { - cl_fixnum pos; - if (Null(position)) - return; - pos = ecl_fixnum(position); - if (!Null(relativep)) { - cl_object k = ecl_make_fixnum(0); - cl_object l = ecl_make_fixnum(1); - while (ecl_lower(ecl_times(approx->s, l), - ecl_plus(approx->r, approx->mp))) { - k = ecl_one_plus(k); - l = ecl_times(l, PRINT_BASE); - } - position = ecl_minus(k, position); - { - cl_object e1 = cl_expt(PRINT_BASE, position); - cl_object e2 = ecl_divide(e1, ecl_make_fixnum(2)); - cl_object e3 = cl_expt(PRINT_BASE, k); - if (ecl_greatereq(ecl_plus(approx->r, ecl_times(approx->s, e1)), - ecl_times(approx->s, e2))) - position = ecl_one_minus(position); - } - } - { - cl_object x = ecl_times(approx->s, cl_expt(PRINT_BASE, position)); - cl_object e = ecl_divide(x, ecl_make_fixnum(2)); - cl_object low = cl_max(2, approx->mm, e); - cl_object high = cl_max(2, approx->mp, e); - if (ecl_lowereq(approx->mm, low)) { - approx->mm = low; - approx->low_ok = 1; - } - if (ecl_lowereq(approx->mp, high)) { - approx->mp = high; - approx->high_ok = 1; - } - } + cl_fixnum pos; + if (Null(position)) + return; + pos = ecl_fixnum(position); + if (!Null(relativep)) { + cl_object k = ecl_make_fixnum(0); + cl_object l = ecl_make_fixnum(1); + while (ecl_lower(ecl_times(approx->s, l), + ecl_plus(approx->r, approx->mp))) { + k = ecl_one_plus(k); + l = ecl_times(l, PRINT_BASE); + } + position = ecl_minus(k, position); + { + cl_object e1 = cl_expt(PRINT_BASE, position); + cl_object e2 = ecl_divide(e1, ecl_make_fixnum(2)); + cl_object e3 = cl_expt(PRINT_BASE, k); + if (ecl_greatereq(ecl_plus(approx->r, ecl_times(approx->s, e1)), + ecl_times(approx->s, e2))) + position = ecl_one_minus(position); + } + } + { + cl_object x = ecl_times(approx->s, cl_expt(PRINT_BASE, position)); + cl_object e = ecl_divide(x, ecl_make_fixnum(2)); + cl_object low = cl_max(2, approx->mm, e); + cl_object high = cl_max(2, approx->mp, e); + if (ecl_lowereq(approx->mm, low)) { + approx->mm = low; + approx->low_ok = 1; + } + if (ecl_lowereq(approx->mp, high)) { + approx->mp = high; + approx->high_ok = 1; + } + } } cl_object si_float_to_digits(cl_object digits, cl_object number, cl_object position, cl_object relativep) { - cl_fixnum k; - float_approx approx[1]; - setup(number, approx); - change_precision(approx, position, relativep); - k = scale(approx); - if (Null(digits)) - digits = si_make_vector(@'base-char', ecl_make_fixnum(10), - ECL_T /* adjustable */, - ecl_make_fixnum(0) /* fill pointer */, - ECL_NIL /* displacement */, - ECL_NIL /* displ. offset */); - generate(digits, approx); - @(return ecl_make_fixnum(k) digits) + cl_fixnum k; + float_approx approx[1]; + setup(number, approx); + change_precision(approx, position, relativep); + k = scale(approx); + if (Null(digits)) + digits = si_make_vector(@'base-char', ecl_make_fixnum(10), + ECL_T /* adjustable */, + ecl_make_fixnum(0) /* fill pointer */, + ECL_NIL /* displacement */, + ECL_NIL /* displ. offset */); + generate(digits, approx); + @(return ecl_make_fixnum(k) digits); } diff -Nru ecl-16.1.2/src/c/printer/float_to_string.d ecl-16.1.3+ds/src/c/printer/float_to_string.d --- ecl-16.1.2/src/c/printer/float_to_string.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/printer/float_to_string.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,16 +1,13 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - Copyright (c) 2010, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../../Copyright' for full details. -*/ + * + * Copyright (c) 2010 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #define ECL_INCLUDE_MATH_H #include @@ -20,39 +17,39 @@ cl_object _ecl_ensure_buffer(cl_object buffer, cl_fixnum length) { - if (Null(buffer)) { - buffer = si_make_vector(@'base-char', ecl_make_fixnum(length), - ECL_T /* adjustable */, - ecl_make_fixnum(0) /* fill pointer */, - ECL_NIL /* displacement */, - ECL_NIL /* displ. offset */); - } - return buffer; + if (Null(buffer)) { + buffer = si_make_vector(@'base-char', ecl_make_fixnum(length), + ECL_T /* adjustable */, + ecl_make_fixnum(0) /* fill pointer */, + ECL_NIL /* displacement */, + ECL_NIL /* displ. offset */); + } + return buffer; } void _ecl_string_push_c_string(cl_object s, const char *c) { - for (; *c; c++) { - ecl_string_push_extend(s, *c); - } + for (; *c; c++) { + ecl_string_push_extend(s, *c); + } } static void insert_char(cl_object buffer, cl_index where, cl_fixnum c) { - cl_fixnum end = buffer->base_string.fillp; - ecl_string_push_extend(buffer, '.'); - ecl_copy_subarray(buffer, where+1, buffer, where, end - where); - ecl_char_set(buffer, where, c); + cl_fixnum end = buffer->base_string.fillp; + ecl_string_push_extend(buffer, '.'); + ecl_copy_subarray(buffer, where+1, buffer, where, end - where); + ecl_char_set(buffer, where, c); } static cl_object push_base_string(cl_object buffer, cl_object s) { - buffer = _ecl_ensure_buffer(buffer, s->base_string.fillp); - _ecl_string_push_c_string(buffer, (char *)s->base_string.self); - return buffer; + buffer = _ecl_ensure_buffer(buffer, s->base_string.fillp); + _ecl_string_push_c_string(buffer, (char *)s->base_string.self); + return buffer; } /********************************************************************** @@ -62,72 +59,72 @@ static void print_float_exponent(cl_object buffer, cl_object number, cl_fixnum exp) { - cl_object r = ecl_symbol_value(@'*read-default-float-format*'); - cl_fixnum e; - switch (ecl_t_of(number)) { - case t_singlefloat: - e = (r == @'single-float' || r == @'short-float')? 'e' : 'f'; - break; + cl_object r = ecl_symbol_value(@'*read-default-float-format*'); + cl_fixnum e; + switch (ecl_t_of(number)) { + case t_singlefloat: + e = (r == @'single-float' || r == @'short-float')? 'e' : 'f'; + break; #ifdef ECL_LONG_FLOAT - case t_longfloat: - e = (r == @'long-float') ? 'e' : 'l'; - break; - case t_doublefloat: - e = (r == @'double-float')? 'e' : 'd'; - break; + case t_longfloat: + e = (r == @'long-float') ? 'e' : 'l'; + break; + case t_doublefloat: + e = (r == @'double-float')? 'e' : 'd'; + break; #else - case t_doublefloat: - e = (r == @'double-float' || r == @'long-float')? 'e' : 'd'; - break; + case t_doublefloat: + e = (r == @'double-float' || r == @'long-float')? 'e' : 'd'; + break; #endif - } - if (e != 'e' || exp != 0) { - ecl_string_push_extend(buffer, e); - si_integer_to_string(buffer, ecl_make_fixnum(exp), ecl_make_fixnum(10), - ECL_NIL, ECL_NIL); - } + } + if (e != 'e' || exp != 0) { + ecl_string_push_extend(buffer, e); + si_integer_to_string(buffer, ecl_make_fixnum(exp), ecl_make_fixnum(10), + ECL_NIL, ECL_NIL); + } } cl_object si_float_to_string_free(cl_object buffer_or_nil, cl_object number, cl_object e_min, cl_object e_max) { - cl_fixnum base, e; - cl_object exp, buffer; + cl_fixnum base, e; + cl_object exp, buffer; - if (ecl_float_nan_p(number)) { - cl_object s = funcall(2, @'ext::float-nan-string', number); - @(return push_base_string(buffer_or_nil, si_coerce_to_base_string(s))); - } else if (ecl_float_infinity_p(number)) { - cl_object s = funcall(2, @'ext::float-infinity-string', number); - @(return push_base_string(buffer_or_nil, si_coerce_to_base_string(s))); - } - base = ecl_length(buffer_or_nil); - exp = si_float_to_digits(buffer_or_nil, number, ECL_NIL, ECL_NIL); - buffer = VALUES(1); - e = ecl_fixnum(exp); - - if (ecl_signbit(number)) { - insert_char(buffer, base++, '-'); - } - /* Do we have to print in exponent notation? */ - if (ecl_lowereq(exp, e_min) || ecl_lowereq(e_max, exp)) { - insert_char(buffer, base+1, '.'); - print_float_exponent(buffer, number, e-1); - } else if (e > 0) { - cl_fixnum l = buffer->base_string.fillp - base; - while (l++ <= e) { - ecl_string_push_extend(buffer, '0'); - } - insert_char(buffer, base+e, '.'); - print_float_exponent(buffer, number, 0); - } else { - insert_char(buffer, base++, '0'); - insert_char(buffer, base++, '.'); - for (e = -e; e; e--) { - insert_char(buffer, base++, '0'); - } - print_float_exponent(buffer, number, 0); - } - @(return buffer); + if (ecl_float_nan_p(number)) { + cl_object s = funcall(2, @'ext::float-nan-string', number); + @(return push_base_string(buffer_or_nil, si_coerce_to_base_string(s))); + } else if (ecl_float_infinity_p(number)) { + cl_object s = funcall(2, @'ext::float-infinity-string', number); + @(return push_base_string(buffer_or_nil, si_coerce_to_base_string(s))); + } + base = ecl_length(buffer_or_nil); + exp = si_float_to_digits(buffer_or_nil, number, ECL_NIL, ECL_NIL); + buffer = VALUES(1); + e = ecl_fixnum(exp); + + if (ecl_signbit(number)) { + insert_char(buffer, base++, '-'); + } + /* Do we have to print in exponent notation? */ + if (ecl_lowereq(exp, e_min) || ecl_lowereq(e_max, exp)) { + insert_char(buffer, base+1, '.'); + print_float_exponent(buffer, number, e-1); + } else if (e > 0) { + cl_fixnum l = buffer->base_string.fillp - base; + while (l++ <= e) { + ecl_string_push_extend(buffer, '0'); + } + insert_char(buffer, base+e, '.'); + print_float_exponent(buffer, number, 0); + } else { + insert_char(buffer, base++, '0'); + insert_char(buffer, base++, '.'); + for (e = -e; e; e--) { + insert_char(buffer, base++, '0'); + } + print_float_exponent(buffer, number, 0); + } + @(return buffer); } diff -Nru ecl-16.1.2/src/c/printer/print_unreadable.d ecl-16.1.3+ds/src/c/printer/print_unreadable.d --- ecl-16.1.2/src/c/printer/print_unreadable.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/printer/print_unreadable.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - print_unreadable.d -- helper for print-unreadable-object macro -*/ -/* - Copyright (c) 2010, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * print_unreadable.d - helper for print-unreadable-object macro + * + * Copyright (c) 2010 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -21,64 +16,64 @@ void _ecl_write_addr(cl_object x, cl_object stream) { - cl_fixnum i, j; + cl_fixnum i, j; - i = (cl_index)x; - for (j = sizeof(i)*8-4; j >= 0; j -= 4) { - int k = (i>>j) & 0xf; - if (k < 10) - ecl_write_char('0' + k, stream); - else - ecl_write_char('a' + k - 10, stream); - } + i = (cl_index)x; + for (j = sizeof(i)*8-4; j >= 0; j -= 4) { + int k = (i>>j) & 0xf; + if (k < 10) + ecl_write_char('0' + k, stream); + else + ecl_write_char('a' + k - 10, stream); + } } void _ecl_write_unreadable(cl_object x, const char *prefix, cl_object name, cl_object stream) { - if (ecl_print_readably()) - FEprint_not_readable(x); - ecl_write_char('#', stream); - ecl_write_char('<', stream); - writestr_stream(prefix, stream); - ecl_write_char(' ', stream); - if (!Null(name)) { - si_write_ugly_object(name, stream); - } else { - _ecl_write_addr(x, stream); - } - ecl_write_char('>', stream); + if (ecl_print_readably()) + FEprint_not_readable(x); + ecl_write_char('#', stream); + ecl_write_char('<', stream); + writestr_stream(prefix, stream); + ecl_write_char(' ', stream); + if (!Null(name)) { + si_write_ugly_object(name, stream); + } else { + _ecl_write_addr(x, stream); + } + ecl_write_char('>', stream); } cl_object si_print_unreadable_object_function(cl_object o, cl_object stream, cl_object type, cl_object id, cl_object function) { - if (ecl_print_readably()) - FEprint_not_readable(o); - stream = _ecl_stream_or_default_output(stream); - if (ecl_print_level() == 0) { - ecl_write_char('#', stream); - } else { - writestr_stream("#<", stream); - if (!Null(type)) { - cl_index i, l; - type = cl_type_of(o); - if (!ECL_SYMBOLP(type)) { - type = @'standard-object'; - } - type = type->symbol.name; - for (i = 0, l = ecl_length(type); i < l; i++) - ecl_write_char(ecl_char_downcase(ecl_char(type, i)), stream); - ecl_write_char(' ', stream); - } - if (!Null(function)) { - _ecl_funcall1(function); - } - if (!Null(id)) { - ecl_write_char(' ', stream); - _ecl_write_addr(o, stream); - } - ecl_write_char('>', stream); - } - @(return ECL_NIL) + if (ecl_print_readably()) + FEprint_not_readable(o); + stream = _ecl_stream_or_default_output(stream); + if (ecl_print_level() == 0) { + ecl_write_char('#', stream); + } else { + writestr_stream("#<", stream); + if (!Null(type)) { + cl_index i, l; + type = cl_type_of(o); + if (!ECL_SYMBOLP(type)) { + type = @'standard-object'; + } + type = type->symbol.name; + for (i = 0, l = ecl_length(type); i < l; i++) + ecl_write_char(ecl_char_downcase(ecl_char(type, i)), stream); + ecl_write_char(' ', stream); + } + if (!Null(function)) { + _ecl_funcall1(function); + } + if (!Null(id)) { + ecl_write_char(' ', stream); + _ecl_write_addr(o, stream); + } + ecl_write_char('>', stream); + } + @(return ECL_NIL); } diff -Nru ecl-16.1.2/src/c/printer/write_array.d ecl-16.1.3+ds/src/c/printer/write_array.d --- ecl-16.1.2/src/c/printer/write_array.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/printer/write_array.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - write_array.d -- File interface. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * write_array.d - file interface + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -23,186 +18,186 @@ static void write_array_inner(bool vector, cl_object x, cl_object stream) { - cl_env_ptr env = ecl_process_env(); - const cl_index *adims; - cl_index subscripts[ECL_ARRAY_RANK_LIMIT]; - cl_fixnum n, j, m, k, i; - cl_fixnum print_length; - cl_fixnum print_level; - bool readably = ecl_print_readably(); - - if (vector) { - adims = &x->vector.fillp; - n = 1; - } else { - adims = x->array.dims; - n = x->array.rank; - } - if (readably) { - print_length = MOST_POSITIVE_FIXNUM; - print_level = MOST_POSITIVE_FIXNUM; - } else { - if (!ecl_print_array()) { - writestr_stream(vector? "#', stream); - return; - } - print_level = ecl_print_level(); - print_length = ecl_print_length(); - } - ecl_write_char('#', stream); - if (print_level == 0) - return; - if (readably) { - ecl_write_char('A', stream); - ecl_write_char('(', stream); - si_write_object(ecl_elttype_to_symbol(ecl_array_elttype(x)), stream); - ecl_write_char(' ', stream); - if (n > 0) { - ecl_write_char('(', stream); - for (j=0; j= n) { - /* We can write the elements of the array */ - print_level -= n; - ecl_bds_bind(env, @'*print-level*', ecl_make_fixnum(print_level)); - } else { - /* The elements of the array are not printed */ - n = print_level; - print_level = -1; - } - for (j = 0; j < n; j++) - subscripts[j] = 0; - for (m = 0, j = 0;;) { - for (i = j; i < n; i++) { - if (subscripts[i] == 0) { - ecl_write_char('(', stream); - if (adims[i] == 0) { - ecl_write_char(')', stream); - j = i-1; - k = 0; - goto INC; - } - } - if (subscripts[i] > 0) - ecl_write_char(' ', stream); - if (subscripts[i] >= print_length) { - writestr_stream("...)", stream); - k=adims[i]-subscripts[i]; - subscripts[i] = 0; - for (j = i+1; j < n; j++) - k *= adims[j]; - j = i-1; - goto INC; - } - } - /* FIXME: This conses! */ - if (print_level >= 0) - si_write_object(ecl_aref_unsafe(x, m), stream); - else - ecl_write_char('#', stream); - j = n-1; - k = 1; - - INC: - while (j >= 0) { - if (++subscripts[j] < adims[j]) - break; - subscripts[j] = 0; - ecl_write_char(')', stream); - --j; - } - if (j < 0) - break; - m += k; - } - if (print_level >= 0) { - ecl_bds_unwind1(env); - } - if (readably) { - ecl_write_char(')', stream); - } + cl_env_ptr env = ecl_process_env(); + const cl_index *adims; + cl_index subscripts[ECL_ARRAY_RANK_LIMIT]; + cl_fixnum n, j, m, k, i; + cl_fixnum print_length; + cl_fixnum print_level; + bool readably = ecl_print_readably(); + + if (vector) { + adims = &x->vector.fillp; + n = 1; + } else { + adims = x->array.dims; + n = x->array.rank; + } + if (readably) { + print_length = MOST_POSITIVE_FIXNUM; + print_level = MOST_POSITIVE_FIXNUM; + } else { + if (!ecl_print_array()) { + writestr_stream(vector? "#', stream); + return; + } + print_level = ecl_print_level(); + print_length = ecl_print_length(); + } + ecl_write_char('#', stream); + if (print_level == 0) + return; + if (readably) { + ecl_write_char('A', stream); + ecl_write_char('(', stream); + si_write_object(ecl_elttype_to_symbol(ecl_array_elttype(x)), stream); + ecl_write_char(' ', stream); + if (n > 0) { + ecl_write_char('(', stream); + for (j=0; j= n) { + /* We can write the elements of the array */ + print_level -= n; + ecl_bds_bind(env, @'*print-level*', ecl_make_fixnum(print_level)); + } else { + /* The elements of the array are not printed */ + n = print_level; + print_level = -1; + } + for (j = 0; j < n; j++) + subscripts[j] = 0; + for (m = 0, j = 0;;) { + for (i = j; i < n; i++) { + if (subscripts[i] == 0) { + ecl_write_char('(', stream); + if (adims[i] == 0) { + ecl_write_char(')', stream); + j = i-1; + k = 0; + goto INC; + } + } + if (subscripts[i] > 0) + ecl_write_char(' ', stream); + if (subscripts[i] >= print_length) { + writestr_stream("...)", stream); + k=adims[i]-subscripts[i]; + subscripts[i] = 0; + for (j = i+1; j < n; j++) + k *= adims[j]; + j = i-1; + goto INC; + } + } + /* FIXME: This conses! */ + if (print_level >= 0) + si_write_object(ecl_aref_unsafe(x, m), stream); + else + ecl_write_char('#', stream); + j = n-1; + k = 1; + + INC: + while (j >= 0) { + if (++subscripts[j] < adims[j]) + break; + subscripts[j] = 0; + ecl_write_char(')', stream); + --j; + } + if (j < 0) + break; + m += k; + } + if (print_level >= 0) { + ecl_bds_unwind1(env); + } + if (readably) { + ecl_write_char(')', stream); + } } void _ecl_write_array(cl_object x, cl_object stream) { - write_array_inner(0, x, stream); + write_array_inner(0, x, stream); } void _ecl_write_vector(cl_object x, cl_object stream) { - write_array_inner(1, x, stream); + write_array_inner(1, x, stream); } #ifdef ECL_UNICODE void _ecl_write_string(cl_object x, cl_object stream) { - cl_index ndx; - if (!ecl_print_escape() && !ecl_print_readably()) { - for (ndx = 0; ndx < x->string.fillp; ndx++) - ecl_write_char(x->string.self[ndx], stream); - } else { - ecl_write_char('"', stream); - for (ndx = 0; ndx < x->string.fillp; ndx++) { - ecl_character c = x->string.self[ndx]; - if (c == '"' || c == '\\') - ecl_write_char('\\', stream); - ecl_write_char(c, stream); - } - ecl_write_char('"', stream); - } + cl_index ndx; + if (!ecl_print_escape() && !ecl_print_readably()) { + for (ndx = 0; ndx < x->string.fillp; ndx++) + ecl_write_char(x->string.self[ndx], stream); + } else { + ecl_write_char('"', stream); + for (ndx = 0; ndx < x->string.fillp; ndx++) { + ecl_character c = x->string.self[ndx]; + if (c == '"' || c == '\\') + ecl_write_char('\\', stream); + ecl_write_char(c, stream); + } + ecl_write_char('"', stream); + } } #endif void _ecl_write_base_string(cl_object x, cl_object stream) { - cl_index ndx; - if (!ecl_print_escape() && !ecl_print_readably()) { - for (ndx = 0; ndx < x->base_string.fillp; ndx++) - ecl_write_char(x->base_string.self[ndx], stream); - } else { - ecl_write_char('"', stream); - for (ndx = 0; ndx < x->base_string.fillp; ndx++) { - int c = x->base_string.self[ndx]; - if (c == '"' || c == '\\') - ecl_write_char('\\', stream); - ecl_write_char(c, stream); - } - ecl_write_char('"', stream); - } + cl_index ndx; + if (!ecl_print_escape() && !ecl_print_readably()) { + for (ndx = 0; ndx < x->base_string.fillp; ndx++) + ecl_write_char(x->base_string.self[ndx], stream); + } else { + ecl_write_char('"', stream); + for (ndx = 0; ndx < x->base_string.fillp; ndx++) { + int c = x->base_string.self[ndx]; + if (c == '"' || c == '\\') + ecl_write_char('\\', stream); + ecl_write_char(c, stream); + } + ecl_write_char('"', stream); + } } void _ecl_write_bitvector(cl_object x, cl_object stream) { - if (!ecl_print_array() && !ecl_print_readably()) { - writestr_stream("#', stream); - } else { - cl_index ndx; - writestr_stream("#*", stream); - for (ndx = 0; ndx < x->vector.fillp; ndx++) - if (x->vector.self.bit[(ndx+x->vector.offset)/8] & (0200 >> (ndx+x->vector.offset)%8)) - ecl_write_char('1', stream); - else - ecl_write_char('0', stream); - } + if (!ecl_print_array() && !ecl_print_readably()) { + writestr_stream("#', stream); + } else { + cl_index ndx; + writestr_stream("#*", stream); + for (ndx = 0; ndx < x->vector.fillp; ndx++) + if (x->vector.self.bit[(ndx+x->vector.offset)/8] & (0200 >> (ndx+x->vector.offset)%8)) + ecl_write_char('1', stream); + else + ecl_write_char('0', stream); + } } diff -Nru ecl-16.1.2/src/c/printer/write_code.d ecl-16.1.3+ds/src/c/printer/write_code.d --- ecl-16.1.2/src/c/printer/write_code.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/printer/write_code.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - write_list.d -- ugly printer for bytecodes and functions -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * write_list.d - ugly printer for bytecodes and functions + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -24,49 +19,49 @@ void _ecl_write_bytecodes(cl_object x, cl_object stream) { - if (ecl_print_readably()) { - cl_index i; - cl_object lex = ECL_NIL; - cl_object code_l=ECL_NIL; - for ( i=x->bytecodes.code_size-1 ; i<(cl_index)(-1l) ; i-- ) - code_l = ecl_cons(ecl_make_fixnum(((cl_opcode*)(x->bytecodes.code))[i]), code_l); - writestr_stream("#Y", stream); - si_write_ugly_object(cl_list(7, x->bytecodes.name, lex, - ECL_NIL /* x->bytecodes.definition */, - code_l, x->bytecodes.data, - x->bytecodes.file, - x->bytecodes.file_position), - stream); - } else { - cl_object name = x->bytecodes.name; - writestr_stream("#', stream); - } + if (ecl_print_readably()) { + cl_index i; + cl_object lex = ECL_NIL; + cl_object code_l=ECL_NIL; + for ( i=x->bytecodes.code_size-1 ; i<(cl_index)(-1l) ; i-- ) + code_l = ecl_cons(ecl_make_fixnum(((cl_opcode*)(x->bytecodes.code))[i]), code_l); + writestr_stream("#Y", stream); + si_write_ugly_object(cl_list(7, x->bytecodes.name, lex, + ECL_NIL /* x->bytecodes.definition */, + code_l, x->bytecodes.data, + x->bytecodes.file, + x->bytecodes.file_position), + stream); + } else { + cl_object name = x->bytecodes.name; + writestr_stream("#', stream); + } } void _ecl_write_bclosure(cl_object x, cl_object stream) { - if (ecl_print_readably()) { - cl_object lex = x->bclosure.lex; - if (Null(lex)) { - _ecl_write_bytecodes(x->bclosure.code, stream); - } else { - writestr_stream("#Y", stream); - si_write_ugly_object(cl_list(2, x->bclosure.code, lex), - stream); - } - } else { - cl_object name = x->bytecodes.name; - writestr_stream("#', stream); - } + if (ecl_print_readably()) { + cl_object lex = x->bclosure.lex; + if (Null(lex)) { + _ecl_write_bytecodes(x->bclosure.code, stream); + } else { + writestr_stream("#Y", stream); + si_write_ugly_object(cl_list(2, x->bclosure.code, lex), + stream); + } + } else { + cl_object name = x->bytecodes.name; + writestr_stream("#', stream); + } } diff -Nru ecl-16.1.2/src/c/printer/write_list.d ecl-16.1.3+ds/src/c/printer/write_list.d --- ecl-16.1.2/src/c/printer/write_list.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/printer/write_list.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - write_list.d -- ugly printer for lists -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * write_list.d - ugly printer for lists + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -23,98 +18,98 @@ void _ecl_write_list(cl_object x, cl_object stream) { - const cl_env_ptr env = ecl_process_env(); - bool circle; - cl_fixnum print_level, print_length; - cl_index i; - cl_object y; - if (Null(x)) { - _ecl_write_symbol(x, stream); - return; - } - if (CAR(x) == @'si::#!') { - writestr_stream("#!", stream); - x = CDR(x); - si_write_object(x, stream); - return; - } - if (CONSP(CDR(x)) && Null(CDDR(x))) { - if (CAR(x) == @'quote') { - ecl_write_char('\'', stream); - x = CADR(x); - si_write_object(x, stream); - return; - } - if (CAR(x) == @'function') { - ecl_write_char('#', stream); - ecl_write_char('\'', stream); - x = CADR(x); - si_write_object(x, stream); - return; - } - if (CAR(x) == @'si::quasiquote') { - ecl_write_char('`', stream); - x = CADR(x); - si_write_object(x, stream); - return; - } - if (CAR(x) == @'si::unquote') { - ecl_write_char(',', stream); - x = CADR(x); - si_write_object(x, stream); - return; - } - if (CAR(x) == @'si::unquote-splice') { - writestr_stream(",@@", stream); - x = CADR(x); - si_write_object(x, stream); - return; - } - if (CAR(x) == @'si::unquote-nsplice') { - writestr_stream(",.", stream); - x = CADR(x); - si_write_object(x, stream); - return; - } - } - circle = ecl_print_circle(); - if (ecl_print_readably()) { - print_level = MOST_POSITIVE_FIXNUM; - print_length = MOST_POSITIVE_FIXNUM; - } else { - print_level = ecl_print_level(); - print_length = ecl_print_length(); - } - if (print_level == 0) { - ecl_write_char('#', stream); - return; - } - ecl_bds_bind(env, @'*print-level*', ecl_make_fixnum(print_level-1)); - ecl_write_char('(', stream); - for (i = 0; ; i++) { - if (i >= print_length) { - writestr_stream("...", stream); - break; - } - y = CAR(x); - x = CDR(x); - si_write_object(y, stream); - /* FIXME! */ - if (x == OBJNULL || ECL_ATOM(x) || - (circle && _ecl_will_print_as_hash(x))) - { - if (x != ECL_NIL) { - ecl_write_char(' ', stream); - writestr_stream(". ", stream); - si_write_object(x, stream); - } - break; - } - if (i == 0 && y != OBJNULL && ecl_t_of(y) == t_symbol) - ecl_write_char(' ', stream); - else - ecl_write_char(' ', stream); - } - ecl_write_char(')', stream); - ecl_bds_unwind1(env); + const cl_env_ptr env = ecl_process_env(); + bool circle; + cl_fixnum print_level, print_length; + cl_index i; + cl_object y; + if (Null(x)) { + _ecl_write_symbol(x, stream); + return; + } + if (CAR(x) == @'si::#!') { + writestr_stream("#!", stream); + x = CDR(x); + si_write_object(x, stream); + return; + } + if (CONSP(CDR(x)) && Null(CDDR(x))) { + if (CAR(x) == @'quote') { + ecl_write_char('\'', stream); + x = CADR(x); + si_write_object(x, stream); + return; + } + if (CAR(x) == @'function') { + ecl_write_char('#', stream); + ecl_write_char('\'', stream); + x = CADR(x); + si_write_object(x, stream); + return; + } + if (CAR(x) == @'si::quasiquote') { + ecl_write_char('`', stream); + x = CADR(x); + si_write_object(x, stream); + return; + } + if (CAR(x) == @'si::unquote') { + ecl_write_char(',', stream); + x = CADR(x); + si_write_object(x, stream); + return; + } + if (CAR(x) == @'si::unquote-splice') { + writestr_stream(",@@", stream); + x = CADR(x); + si_write_object(x, stream); + return; + } + if (CAR(x) == @'si::unquote-nsplice') { + writestr_stream(",.", stream); + x = CADR(x); + si_write_object(x, stream); + return; + } + } + circle = ecl_print_circle(); + if (ecl_print_readably()) { + print_level = MOST_POSITIVE_FIXNUM; + print_length = MOST_POSITIVE_FIXNUM; + } else { + print_level = ecl_print_level(); + print_length = ecl_print_length(); + } + if (print_level == 0) { + ecl_write_char('#', stream); + return; + } + ecl_bds_bind(env, @'*print-level*', ecl_make_fixnum(print_level-1)); + ecl_write_char('(', stream); + for (i = 0; ; i++) { + if (i >= print_length) { + writestr_stream("...", stream); + break; + } + y = CAR(x); + x = CDR(x); + si_write_object(y, stream); + /* FIXME! */ + if (x == OBJNULL || ECL_ATOM(x) || + (circle && _ecl_will_print_as_hash(x))) + { + if (x != ECL_NIL) { + ecl_write_char(' ', stream); + writestr_stream(". ", stream); + si_write_object(x, stream); + } + break; + } + if (i == 0 && y != OBJNULL && ecl_t_of(y) == t_symbol) + ecl_write_char(' ', stream); + else + ecl_write_char(' ', stream); + } + ecl_write_char(')', stream); + ecl_bds_unwind1(env); } diff -Nru ecl-16.1.2/src/c/printer/write_object.d ecl-16.1.3+ds/src/c/printer/write_object.d --- ecl-16.1.2/src/c/printer/write_object.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/printer/write_object.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - write_object.d -- basic printer routine. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * write_object.d - basic printer routine + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -24,18 +19,18 @@ bool _ecl_will_print_as_hash(cl_object x) { - cl_object circle_counter = ecl_symbol_value(@'si::*circle-counter*'); - cl_object circle_stack = ecl_symbol_value(@'si::*circle-stack*'); - cl_object code = ecl_gethash_safe(x, circle_stack, OBJNULL); - if (ECL_FIXNUMP(circle_counter)) { - return !(code == OBJNULL || code == ECL_NIL); - } else if (code == OBJNULL) { - /* Was not found before */ - _ecl_sethash(x, circle_stack, ECL_NIL); - return 0; - } else { - return 1; - } + cl_object circle_counter = ecl_symbol_value(@'si::*circle-counter*'); + cl_object circle_stack = ecl_symbol_value(@'si::*circle-stack*'); + cl_object code = ecl_gethash_safe(x, circle_stack, OBJNULL); + if (ECL_FIXNUMP(circle_counter)) { + return !(code == OBJNULL || code == ECL_NIL); + } else if (code == OBJNULL) { + /* Was not found before */ + _ecl_sethash(x, circle_stack, ECL_NIL); + return 0; + } else { + return 1; + } } /* To print circular structures, we traverse the structure by adding @@ -44,106 +39,106 @@ After the visit we squeeze out all the non circular elements. The flags is used during printing to distinguish between the first visit to the element. - */ +*/ static cl_fixnum search_print_circle(cl_object x) { - cl_object circle_counter = ecl_symbol_value(@'si::*circle-counter*'); - cl_object circle_stack = ecl_symbol_value(@'si::*circle-stack*'); - cl_object code; - - if (!ECL_FIXNUMP(circle_counter)) { - code = ecl_gethash_safe(x, circle_stack, OBJNULL); - if (code == OBJNULL) { - /* Was not found before */ - _ecl_sethash(x, circle_stack, ECL_NIL); - return 0; - } else if (code == ECL_NIL) { - /* This object is referenced twice */ - _ecl_sethash(x, circle_stack, ECL_T); - return 1; - } else { - return 2; - } - } else { - code = ecl_gethash_safe(x, circle_stack, OBJNULL); - if (code == OBJNULL || code == ECL_NIL) { - /* Is not referenced or was not found before */ - /* _ecl_sethash(x, circle_stack, ECL_NIL); */ - return 0; - } else if (code == ECL_T) { - /* This object is referenced twice, but has no code yet */ - cl_fixnum new_code = ecl_fixnum(circle_counter) + 1; - circle_counter = ecl_make_fixnum(new_code); - _ecl_sethash(x, circle_stack, circle_counter); - ECL_SETQ(ecl_process_env(), @'si::*circle-counter*', - circle_counter); - return -new_code; - } else { - return ecl_fixnum(code); - } - } + cl_object circle_counter = ecl_symbol_value(@'si::*circle-counter*'); + cl_object circle_stack = ecl_symbol_value(@'si::*circle-stack*'); + cl_object code; + + if (!ECL_FIXNUMP(circle_counter)) { + code = ecl_gethash_safe(x, circle_stack, OBJNULL); + if (code == OBJNULL) { + /* Was not found before */ + _ecl_sethash(x, circle_stack, ECL_NIL); + return 0; + } else if (code == ECL_NIL) { + /* This object is referenced twice */ + _ecl_sethash(x, circle_stack, ECL_T); + return 1; + } else { + return 2; + } + } else { + code = ecl_gethash_safe(x, circle_stack, OBJNULL); + if (code == OBJNULL || code == ECL_NIL) { + /* Is not referenced or was not found before */ + /* _ecl_sethash(x, circle_stack, ECL_NIL); */ + return 0; + } else if (code == ECL_T) { + /* This object is referenced twice, but has no code yet */ + cl_fixnum new_code = ecl_fixnum(circle_counter) + 1; + circle_counter = ecl_make_fixnum(new_code); + _ecl_sethash(x, circle_stack, circle_counter); + ECL_SETQ(ecl_process_env(), @'si::*circle-counter*', + circle_counter); + return -new_code; + } else { + return ecl_fixnum(code); + } + } } cl_object si_write_object(cl_object x, cl_object stream) { - bool circle; + bool circle; #ifdef ECL_CMU_FORMAT - if (ecl_symbol_value(@'*print-pretty*') != ECL_NIL) { - cl_object f = _ecl_funcall2(@'pprint-dispatch', x); - if (VALUES(1) != ECL_NIL) { - _ecl_funcall3(f, stream, x); - goto OUTPUT; - } - } + if (ecl_symbol_value(@'*print-pretty*') != ECL_NIL) { + cl_object f = _ecl_funcall2(@'pprint-dispatch', x); + if (VALUES(1) != ECL_NIL) { + _ecl_funcall3(f, stream, x); + goto OUTPUT; + } + } #endif /* ECL_CMU_FORMAT */ - circle = ecl_print_circle(); - if (circle && !Null(x) && !ECL_FIXNUMP(x) && !ECL_CHARACTERP(x) && - (LISTP(x) || (x->d.t != t_symbol) || (Null(x->symbol.hpack)))) - { - cl_object circle_counter; - cl_fixnum code; - circle_counter = ecl_symbol_value(@'si::*circle-counter*'); - if (circle_counter == ECL_NIL) { - cl_env_ptr env = ecl_process_env(); - cl_object hash = - cl__make_hash_table(@'eq', - ecl_make_fixnum(1024), - cl_core.rehash_size, - cl_core.rehash_threshold); - ecl_bds_bind(env, @'si::*circle-counter*', ECL_T); - ecl_bds_bind(env, @'si::*circle-stack*', hash); - si_write_object(x, cl_core.null_stream); - ECL_SETQ(env, @'si::*circle-counter*', ecl_make_fixnum(0)); - si_write_object(x, stream); - cl_clrhash(hash); - ecl_bds_unwind_n(env, 2); - goto OUTPUT; - } - code = search_print_circle(x); - if (!ECL_FIXNUMP(circle_counter)) { - /* We are only inspecting the object to be printed. */ - /* Only run X if it was not referenced before */ - if (code != 0) - goto OUTPUT; - } else if (code == 0) { - /* Object is not referenced twice */ - } else if (code < 0) { - /* Object is referenced twice. We print its definition */ - ecl_write_char('#', stream); - _ecl_write_fixnum(-code, stream); - ecl_write_char('=', stream); - } else { - /* Second reference to the object */ - ecl_write_char('#', stream); - _ecl_write_fixnum(code, stream); - ecl_write_char('#', stream); - goto OUTPUT; - } - } - return si_write_ugly_object(x, stream); + circle = ecl_print_circle(); + if (circle && !Null(x) && !ECL_FIXNUMP(x) && !ECL_CHARACTERP(x) && + (LISTP(x) || (x->d.t != t_symbol) || (Null(x->symbol.hpack)))) + { + cl_object circle_counter; + cl_fixnum code; + circle_counter = ecl_symbol_value(@'si::*circle-counter*'); + if (circle_counter == ECL_NIL) { + cl_env_ptr env = ecl_process_env(); + cl_object hash = + cl__make_hash_table(@'eq', + ecl_make_fixnum(1024), + cl_core.rehash_size, + cl_core.rehash_threshold); + ecl_bds_bind(env, @'si::*circle-counter*', ECL_T); + ecl_bds_bind(env, @'si::*circle-stack*', hash); + si_write_object(x, cl_core.null_stream); + ECL_SETQ(env, @'si::*circle-counter*', ecl_make_fixnum(0)); + si_write_object(x, stream); + cl_clrhash(hash); + ecl_bds_unwind_n(env, 2); + goto OUTPUT; + } + code = search_print_circle(x); + if (!ECL_FIXNUMP(circle_counter)) { + /* We are only inspecting the object to be printed. */ + /* Only run X if it was not referenced before */ + if (code != 0) + goto OUTPUT; + } else if (code == 0) { + /* Object is not referenced twice */ + } else if (code < 0) { + /* Object is referenced twice. We print its definition */ + ecl_write_char('#', stream); + _ecl_write_fixnum(-code, stream); + ecl_write_char('=', stream); + } else { + /* Second reference to the object */ + ecl_write_char('#', stream); + _ecl_write_fixnum(code, stream); + ecl_write_char('#', stream); + goto OUTPUT; + } + } + return si_write_ugly_object(x, stream); OUTPUT: - @(return x) + @(return x); } diff -Nru ecl-16.1.2/src/c/printer/write_sse.d ecl-16.1.3+ds/src/c/printer/write_sse.d --- ecl-16.1.2/src/c/printer/write_sse.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/printer/write_sse.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,100 +1,96 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - write_list.d -- ugly printer for SSE types -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * write_sse.d - ugly printer for SSE types + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ +#ifdef ECL_SSE2 #include #include -#ifdef ECL_SSE2 + static int is_all_FF(void *ptr, int size) { - int i; - for (i = 0; i < size; i++) - if (((unsigned char*)ptr)[i] != 0xFF) - return 0; - return 1; + int i; + for (i = 0; i < size; i++) + if (((unsigned char*)ptr)[i] != 0xFF) + return 0; + return 1; } static void write_sse_float(float v, cl_object stream) { - if (is_all_FF(&v, sizeof(float))) { - writestr_stream(" TRUE", stream); - } else { - ecl_write_char(' ', stream); - si_write_ugly_object(ecl_make_single_float(v), stream); - } + if (is_all_FF(&v, sizeof(float))) { + writestr_stream(" TRUE", stream); + } else { + ecl_write_char(' ', stream); + si_write_ugly_object(ecl_make_single_float(v), stream); + } } static void write_sse_double(double v, cl_object stream) { - if (is_all_FF(&v, sizeof(double))) - writestr_stream(" TRUE", stream); - else { - ecl_write_char(' ', stream); - si_write_ugly_object(ecl_make_double_float(v), stream); - } + if (is_all_FF(&v, sizeof(double))) + writestr_stream(" TRUE", stream); + else { + ecl_write_char(' ', stream); + si_write_ugly_object(ecl_make_double_float(v), stream); + } } static void write_sse_pack(cl_object x, cl_object stream) { - int i; - cl_elttype etype = x->sse.elttype; - cl_object mode = ecl_symbol_value(@'ext::*sse-pack-print-mode*'); - - if (mode != ECL_NIL) { - if (mode == @':float') etype = ecl_aet_sf; - else if (mode == @':double') etype = ecl_aet_df; - else etype = ecl_aet_b8; - } - - switch (etype) { - case ecl_aet_sf: - for (i = 0; i < 4; i++) - write_sse_float(x->sse.data.sf[i], stream); - break; - case ecl_aet_df: - write_sse_double(x->sse.data.df[0], stream); - write_sse_double(x->sse.data.df[1], stream); - break; - default: { - cl_object buffer = si_get_buffer_string(); - for (i = 0; i < 16; i++) { - ecl_string_push_extend(buffer, ' '); - if (i%4 == 0) ecl_string_push_extend(buffer, ' '); - si_integer_to_string(buffer, ecl_make_fixnum(x->sse.data.b8[i]), - ecl_make_fixnum(16), ECL_NIL, ECL_NIL); - } - si_do_write_sequence(buffer, stream, ecl_make_fixnum(0), ECL_NIL); - si_put_buffer_string(buffer); - break; - } - } + int i; + cl_elttype etype = x->sse.elttype; + cl_object mode = ecl_symbol_value(@'ext::*sse-pack-print-mode*'); + + if (mode != ECL_NIL) { + if (mode == @':float') etype = ecl_aet_sf; + else if (mode == @':double') etype = ecl_aet_df; + else etype = ecl_aet_b8; + } + + switch (etype) { + case ecl_aet_sf: + for (i = 0; i < 4; i++) + write_sse_float(x->sse.data.sf[i], stream); + break; + case ecl_aet_df: + write_sse_double(x->sse.data.df[0], stream); + write_sse_double(x->sse.data.df[1], stream); + break; + default: { + cl_object buffer = si_get_buffer_string(); + for (i = 0; i < 16; i++) { + ecl_string_push_extend(buffer, ' '); + if (i%4 == 0) ecl_string_push_extend(buffer, ' '); + si_integer_to_string(buffer, ecl_make_fixnum(x->sse.data.b8[i]), + ecl_make_fixnum(16), ECL_NIL, ECL_NIL); + } + si_do_write_sequence(buffer, stream, ecl_make_fixnum(0), ECL_NIL); + si_put_buffer_string(buffer); + break; + } + } } void _ecl_write_sse(cl_object x, cl_object stream) { - if (ecl_print_readably()) FEprint_not_readable(x); - writestr_stream("#', stream); + if (ecl_print_readably()) FEprint_not_readable(x); + writestr_stream("#', stream); } #endif diff -Nru ecl-16.1.2/src/c/printer/write_symbol.d ecl-16.1.3+ds/src/c/printer/write_symbol.d --- ecl-16.1.2/src/c/printer/write_symbol.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/printer/write_symbol.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - write_symbol.d -- print a symbol. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * write_symbol.d - print a symbol + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -23,48 +18,48 @@ static bool potential_number_p(cl_object s, int base) { - /* See ANSI 2.3.1.1 */ - static cl_index i, l; - ecl_character c; - /* A potential number must contain at least one digit */ - bool some_digit = FALSE; - - l = s->base_string.fillp; - if (l == 0) - return FALSE; - c = ecl_char(s, 0); - - /* A potential number must begin with a digit, sign or - extension character (^ _) */ - if (ecl_digitp(c,base) >= 0) - some_digit = TRUE; - else if (c != '+' && c != '-' && c != '^' && c != '_') - return FALSE; - - /* A potential number cannot end with a sign */ - c = ecl_char(s, l-1); - if (c == '+' || c == '-') - return FALSE; - - for (i = 1; i < l; i++) { - c = ecl_char(s, i); - /* It can only contain digits, signs, ratio markers, - * extension characters and number markers. Number - * markers are letters, but two adjacent letters fail - * to be a number marker. */ - if (ecl_digitp(c, base) >= 0) { - some_digit = TRUE; - } else if (c == '+' || c == '-' || - c == '/' || c == '.' || c == '^' || c == '_') { - continue; - } else if (ecl_alpha_char_p(c) && - (((i+1) >= l) || !ecl_alpha_char_p(ecl_char(s, i+1)))) { - continue; - } else { - return FALSE; - } - } - return some_digit; + /* See ANSI 2.3.1.1 */ + static cl_index i, l; + ecl_character c; + /* A potential number must contain at least one digit */ + bool some_digit = FALSE; + + l = s->base_string.fillp; + if (l == 0) + return FALSE; + c = ecl_char(s, 0); + + /* A potential number must begin with a digit, sign or + extension character (^ _) */ + if (ecl_digitp(c,base) >= 0) + some_digit = TRUE; + else if (c != '+' && c != '-' && c != '^' && c != '_') + return FALSE; + + /* A potential number cannot end with a sign */ + c = ecl_char(s, l-1); + if (c == '+' || c == '-') + return FALSE; + + for (i = 1; i < l; i++) { + c = ecl_char(s, i); + /* It can only contain digits, signs, ratio markers, + * extension characters and number markers. Number + * markers are letters, but two adjacent letters fail + * to be a number marker. */ + if (ecl_digitp(c, base) >= 0) { + some_digit = TRUE; + } else if (c == '+' || c == '-' || + c == '/' || c == '.' || c == '^' || c == '_') { + continue; + } else if (ecl_alpha_char_p(c) && + (((i+1) >= l) || !ecl_alpha_char_p(ecl_char(s, i+1)))) { + continue; + } else { + return FALSE; + } + } + return some_digit; } #define needs_to_be_inverted(s) (ecl_string_case(s) != 0) @@ -72,149 +67,148 @@ static bool all_dots(cl_object s) { - cl_index i; - for (i = 0; i < s->base_string.fillp; i++) - if (ecl_char(s, i) != '.') - return 0; - return 1; + cl_index i; + for (i = 0; i < s->base_string.fillp; i++) + if (ecl_char(s, i) != '.') + return 0; + return 1; } static bool needs_to_be_escaped(cl_object s, cl_object readtable, cl_object print_case) { - int action = readtable->readtable.read_case; - cl_index i; - if (potential_number_p(s, ecl_print_base())) - return 1; - /* The value of *PRINT-ESCAPE* is T. We need to check whether the - * symbol name S needs to be escaped. This will happen if it has some - * strange character, or if it has a lowercase character (because such - * a character cannot be read with the standard readtable) or if the - * string has to be escaped according to readtable case and the rules - * of 22.1.3.3.2. */ - for (i = 0; i < s->base_string.fillp; i++) { - int c = ecl_char(s, i); - int syntax = ecl_readtable_get(readtable, c, 0); - if (syntax != cat_constituent || - ecl_invalid_character_p(c) || - (c) == ':') - return 1; - if ((action == ecl_case_downcase) && ecl_upper_case_p(c)) - return 1; - if (ecl_lower_case_p(c)) - return 1; - } - return 0; + int action = readtable->readtable.read_case; + cl_index i; + if (potential_number_p(s, ecl_print_base())) + return 1; + /* The value of *PRINT-ESCAPE* is T. We need to check whether the + * symbol name S needs to be escaped. This will happen if it has some + * strange character, or if it has a lowercase character (because such + * a character cannot be read with the standard readtable) or if the + * string has to be escaped according to readtable case and the rules + * of 22.1.3.3.2. */ + for (i = 0; i < s->base_string.fillp; i++) { + int c = ecl_char(s, i); + int syntax = ecl_readtable_get(readtable, c, 0); + if (syntax != cat_constituent || + ecl_invalid_character_p(c) || + (c) == ':') + return 1; + if ((action == ecl_case_downcase) && ecl_upper_case_p(c)) + return 1; + if (ecl_lower_case_p(c)) + return 1; + } + return 0; } static void write_symbol_string(cl_object s, int action, cl_object print_case, cl_object stream, bool escape) { - cl_index i; - bool capitalize; - if (action == ecl_case_invert) { - if (!needs_to_be_inverted(s)) - action = ecl_case_preserve; - } - if (escape) - ecl_write_char('|', stream); - capitalize = 1; - for (i = 0; i < s->base_string.fillp; i++) { - int c = ecl_char(s, i); - if (escape) { - if (c == '|' || c == '\\') { - ecl_write_char('\\', stream); - } - } else if (action != ecl_case_preserve) { - if (ecl_upper_case_p(c)) { - if ((action == ecl_case_invert) || - ((action == ecl_case_upcase) && - ((print_case == @':downcase') || - ((print_case == @':capitalize') && !capitalize)))) - { - c = ecl_char_downcase(c); - } - capitalize = 0; - } else if (ecl_lower_case_p(c)) { - if ((action == ecl_case_invert) || - ((action == ecl_case_downcase) && - ((print_case == @':upcase') || - ((print_case == @':capitalize') && capitalize)))) - { - c = ecl_char_upcase(c); - } - capitalize = 0; - } else { - capitalize = !ecl_alphanumericp(c); - } - } - ecl_write_char(c, stream); - } - if (escape) - ecl_write_char('|', stream); + cl_index i; + bool capitalize; + if (action == ecl_case_invert) { + if (!needs_to_be_inverted(s)) + action = ecl_case_preserve; + } + if (escape) + ecl_write_char('|', stream); + capitalize = 1; + for (i = 0; i < s->base_string.fillp; i++) { + int c = ecl_char(s, i); + if (escape) { + if (c == '|' || c == '\\') { + ecl_write_char('\\', stream); + } + } else if (action != ecl_case_preserve) { + if (ecl_upper_case_p(c)) { + if ((action == ecl_case_invert) || + ((action == ecl_case_upcase) && + ((print_case == @':downcase') || + ((print_case == @':capitalize') && !capitalize)))) + { + c = ecl_char_downcase(c); + } + capitalize = 0; + } else if (ecl_lower_case_p(c)) { + if ((action == ecl_case_invert) || + ((action == ecl_case_downcase) && + ((print_case == @':upcase') || + ((print_case == @':capitalize') && capitalize)))) + { + c = ecl_char_upcase(c); + } + capitalize = 0; + } else { + capitalize = !ecl_alphanumericp(c); + } + } + ecl_write_char(c, stream); + } + if (escape) + ecl_write_char('|', stream); } static bool forced_print_package(cl_object package) { - cl_object print_package = ecl_symbol_value(@'si::*print-package*'); - return !Null(print_package) && (print_package != package); + cl_object print_package = ecl_symbol_value(@'si::*print-package*'); + return !Null(print_package) && (print_package != package); } void _ecl_write_symbol(cl_object x, cl_object stream) { - cl_object readtable = ecl_current_readtable(); - cl_object print_case = ecl_print_case(); - cl_object package; - cl_object name; - int intern_flag; - bool print_readably = ecl_print_readably(); - bool forced_package = 0; - - if (Null(x)) { - package = ECL_NIL_SYMBOL->symbol.hpack; - name = ECL_NIL_SYMBOL->symbol.name; - } else { - package = x->symbol.hpack; - name = x->symbol.name; - } - - if (!print_readably && !ecl_print_escape()) { - write_symbol_string(name, readtable->readtable.read_case, - print_case, stream, 0); - return; - } - /* From here on, print-escape is true which means that it should - * be possible to recover the same symbol by reading it with - * the standard readtable (which has readtable-case = :UPCASE) - */ - if (Null(package)) { - if (print_readably || ecl_print_gensym()) - writestr_stream("#:", stream); - } else if (package == cl_core.keyword_package) { - ecl_write_char(':', stream); - } else if ((forced_package = forced_print_package(package)) - || ecl_find_symbol(name, ecl_current_package(), &intern_flag) != x - || (intern_flag == 0)) - { - cl_object name = package->pack.name; - write_symbol_string(name, readtable->readtable.read_case, - print_case, stream, - needs_to_be_escaped(name, readtable, print_case)); - if (ecl_find_symbol(ecl_symbol_name(x), package, &intern_flag) != x) - ecl_internal_error("can't print symbol"); - if (intern_flag == ECL_INTERNAL || forced_package) { - writestr_stream("::", stream); - } else if (intern_flag == ECL_EXTERNAL) { - ecl_write_char(':', stream); - } else { - FEerror("Pathological symbol --- cannot print.", 0); - } - } - write_symbol_string(name, readtable->readtable.read_case, print_case, stream, - needs_to_be_escaped(name, readtable, print_case) || - all_dots(name)); + cl_object readtable = ecl_current_readtable(); + cl_object print_case = ecl_print_case(); + cl_object package; + cl_object name; + int intern_flag; + bool print_readably = ecl_print_readably(); + bool forced_package = 0; + + if (Null(x)) { + package = ECL_NIL_SYMBOL->symbol.hpack; + name = ECL_NIL_SYMBOL->symbol.name; + } else { + package = x->symbol.hpack; + name = x->symbol.name; + } + + if (!print_readably && !ecl_print_escape()) { + write_symbol_string(name, readtable->readtable.read_case, + print_case, stream, 0); + return; + } + /* From here on, print-escape is true which means that it should + * be possible to recover the same symbol by reading it with + * the standard readtable (which has readtable-case = :UPCASE) + */ + if (Null(package)) { + if (print_readably || ecl_print_gensym()) + writestr_stream("#:", stream); + } else if (package == cl_core.keyword_package) { + ecl_write_char(':', stream); + } else if ((forced_package = forced_print_package(package)) + || ecl_find_symbol(name, ecl_current_package(), &intern_flag) != x + || (intern_flag == 0)) + { + cl_object name = package->pack.name; + write_symbol_string(name, readtable->readtable.read_case, + print_case, stream, + needs_to_be_escaped(name, readtable, print_case)); + if (ecl_find_symbol(ecl_symbol_name(x), package, &intern_flag) != x) + ecl_internal_error("can't print symbol"); + if (intern_flag == ECL_INTERNAL || forced_package) { + writestr_stream("::", stream); + } else if (intern_flag == ECL_EXTERNAL) { + ecl_write_char(':', stream); + } else { + FEerror("Pathological symbol --- cannot print.", 0); + } + } + write_symbol_string(name, readtable->readtable.read_case, print_case, stream, + needs_to_be_escaped(name, readtable, print_case) || + all_dots(name)); } - diff -Nru ecl-16.1.2/src/c/printer/write_ugly.d ecl-16.1.3+ds/src/c/printer/write_ugly.d --- ecl-16.1.2/src/c/printer/write_ugly.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/printer/write_ugly.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - print.d -- Print. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * write_ugly.d - ugly printer + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -29,363 +24,369 @@ static void write_readable_pathname(cl_object path, cl_object stream) { - cl_object l = - cl_list(15, @'make-pathname', - @':host', path->pathname.host, - @':device', path->pathname.device, - @':directory', - _ecl_funcall2(@'ext::maybe-quote', path->pathname.directory), - @':name', path->pathname.name, - @':type', path->pathname.type, - @':version', path->pathname.version, - @':defaults', ECL_NIL); - writestr_stream("#.", stream); - si_write_object(l, stream); + cl_object l = + cl_list(15, @'make-pathname', + @':host', path->pathname.host, + @':device', path->pathname.device, + @':directory', + _ecl_funcall2(@'ext::maybe-quote', path->pathname.directory), + @':name', path->pathname.name, + @':type', path->pathname.type, + @':version', path->pathname.version, + @':defaults', ECL_NIL); + writestr_stream("#.", stream); + si_write_object(l, stream); } static void write_pathname(cl_object path, cl_object stream) { - cl_object namestring = ecl_namestring(path, 0); - bool readably = ecl_print_readably(); - if (namestring == ECL_NIL) { - if (readably) { - write_readable_pathname(path, stream); - return; - } - namestring = ecl_namestring(path, 1); - if (namestring == ECL_NIL) { - writestr_stream("#", stream); - return; - } - } - if (readably || ecl_print_escape()) - writestr_stream("#P", stream); - si_write_ugly_object(namestring, stream); + cl_object namestring = ecl_namestring(path, 0); + bool readably = ecl_print_readably(); + if (namestring == ECL_NIL) { + if (readably) { + write_readable_pathname(path, stream); + return; + } + namestring = ecl_namestring(path, 1); + if (namestring == ECL_NIL) { + writestr_stream("#", stream); + return; + } + } + if (readably || ecl_print_escape()) + writestr_stream("#P", stream); + si_write_ugly_object(namestring, stream); } static void write_integer(cl_object number, cl_object stream) { - cl_object s = si_get_buffer_string(); - int print_base = ecl_print_base(); - si_integer_to_string(s, number, - ecl_make_fixnum(print_base), - ecl_symbol_value(@'*print-radix*'), - ECL_T /* decimal syntax */); - si_do_write_sequence(s, stream, ecl_make_fixnum(0), ECL_NIL); - si_put_buffer_string(s); + cl_object s = si_get_buffer_string(); + int print_base = ecl_print_base(); + si_integer_to_string(s, number, + ecl_make_fixnum(print_base), + ecl_symbol_value(@'*print-radix*'), + ECL_T /* decimal syntax */); + si_do_write_sequence(s, stream, ecl_make_fixnum(0), ECL_NIL); + si_put_buffer_string(s); } void _ecl_write_fixnum(cl_fixnum i, cl_object stream) { - cl_object s = si_get_buffer_string(); - si_integer_to_string(s, ecl_make_fixnum(i), ecl_make_fixnum(10), ECL_NIL, ECL_NIL); - si_do_write_sequence(s, stream, ecl_make_fixnum(0), ECL_NIL); - si_put_buffer_string(s); + cl_object s = si_get_buffer_string(); + si_integer_to_string(s, ecl_make_fixnum(i), ecl_make_fixnum(10), ECL_NIL, ECL_NIL); + si_do_write_sequence(s, stream, ecl_make_fixnum(0), ECL_NIL); + si_put_buffer_string(s); } static void write_ratio(cl_object r, cl_object stream) { - cl_object s = si_get_buffer_string(); - int print_base = ecl_print_base(); - si_integer_to_string(s, r->ratio.num, ecl_make_fixnum(print_base), - ecl_symbol_value(@'*print-radix*'), - ECL_NIL /* decimal syntax */); - ecl_string_push_extend(s, '/'); - si_integer_to_string(s, r->ratio.den, - ecl_make_fixnum(print_base), - ECL_NIL, ECL_NIL); - si_do_write_sequence(s, stream, ecl_make_fixnum(0), ECL_NIL); - si_put_buffer_string(s); + cl_object s = si_get_buffer_string(); + int print_base = ecl_print_base(); + si_integer_to_string(s, r->ratio.num, ecl_make_fixnum(print_base), + ecl_symbol_value(@'*print-radix*'), + ECL_NIL /* decimal syntax */); + ecl_string_push_extend(s, '/'); + si_integer_to_string(s, r->ratio.den, + ecl_make_fixnum(print_base), + ECL_NIL, ECL_NIL); + si_do_write_sequence(s, stream, ecl_make_fixnum(0), ECL_NIL); + si_put_buffer_string(s); } static void write_complex(cl_object x, cl_object stream) { - writestr_stream("#C(", stream); - si_write_ugly_object(x->complex.real, stream); - ecl_write_char(' ', stream); - si_write_ugly_object(x->complex.imag, stream); - ecl_write_char(')', stream); + writestr_stream("#C(", stream); + si_write_ugly_object(x->complex.real, stream); + ecl_write_char(' ', stream); + si_write_ugly_object(x->complex.imag, stream); + ecl_write_char(')', stream); } static void write_float(cl_object f, cl_object stream) { - cl_object s = si_get_buffer_string(); - s = si_float_to_string_free(s, f, ecl_make_fixnum(-3), ecl_make_fixnum(8)); - si_do_write_sequence(s, stream, ecl_make_fixnum(0), ECL_NIL); - si_put_buffer_string(s); + cl_object s = si_get_buffer_string(); + s = si_float_to_string_free(s, f, ecl_make_fixnum(-3), ecl_make_fixnum(8)); + si_do_write_sequence(s, stream, ecl_make_fixnum(0), ECL_NIL); + si_put_buffer_string(s); } static void write_character(cl_object x, cl_object stream) { - int i = ECL_CHAR_CODE(x); - if (!ecl_print_escape() && !ecl_print_readably()) { - ecl_write_char(i, stream); - } else { - writestr_stream("#\\", stream); - if (i < 32 || i >= 127) { - cl_object name = cl_char_name(ECL_CODE_CHAR(i)); - writestr_stream((char*)name->base_string.self, stream); - } else { - ecl_write_char(i, stream); - } - } + int i = ECL_CHAR_CODE(x); + if (!ecl_print_escape() && !ecl_print_readably()) { + ecl_write_char(i, stream); + } else { + writestr_stream("#\\", stream); + if (i < 32 || i >= 127) { + cl_object name = cl_char_name(ECL_CODE_CHAR(i)); + writestr_stream((char*)name->base_string.self, stream); + } else { + ecl_write_char(i, stream); + } + } } static void write_package(cl_object x, cl_object stream) { - if (ecl_print_readably()) FEprint_not_readable(x); - writestr_stream("#<", stream); - si_write_ugly_object(x->pack.name, stream); - writestr_stream(" package>", stream); + if (ecl_print_readably()) FEprint_not_readable(x); + writestr_stream("#<", stream); + si_write_ugly_object(x->pack.name, stream); + writestr_stream(" package>", stream); } static void write_hashtable(cl_object x, cl_object stream) { - if (ecl_print_readably() && !Null(ecl_symbol_value(@'*read-eval*'))) { - cl_object make = - cl_list(9, @'make-hash-table', - @':size', cl_hash_table_size(x), - @':rehash-size', cl_hash_table_rehash_size(x), - @':rehash-threshold', cl_hash_table_rehash_threshold(x), - @':test', cl_list(2, @'quote', cl_hash_table_test(x))); - cl_object init = - cl_list(3, @'ext::hash-table-fill', make, - cl_list(2, @'quote', si_hash_table_content(x))); - writestr_stream("#.", stream); - si_write_ugly_object(init, stream); - } else { - _ecl_write_unreadable(x, "hash-table", ECL_NIL, stream); - } + if (ecl_print_readably() && !Null(ecl_symbol_value(@'*read-eval*'))) { + cl_object make = + cl_list(9, @'make-hash-table', + @':size', cl_hash_table_size(x), + @':rehash-size', cl_hash_table_rehash_size(x), + @':rehash-threshold', cl_hash_table_rehash_threshold(x), + @':test', cl_list(2, @'quote', cl_hash_table_test(x))); + cl_object init = + cl_list(3, @'ext::hash-table-fill', make, + cl_list(2, @'quote', si_hash_table_content(x))); + writestr_stream("#.", stream); + si_write_ugly_object(init, stream); + } else { + _ecl_write_unreadable(x, "hash-table", ECL_NIL, stream); + } } static void write_random(cl_object x, cl_object stream) { - if (ecl_print_readably()) { - writestr_stream("#$", stream); - _ecl_write_vector(x->random.value, stream); - } else { - _ecl_write_unreadable(x->random.value, "random-state", ECL_NIL, stream); - } + if (ecl_print_readably()) { + writestr_stream("#$", stream); + _ecl_write_vector(x->random.value, stream); + } else { + _ecl_write_unreadable(x->random.value, "random-state", ECL_NIL, stream); + } } static void write_stream(cl_object x, cl_object stream) { - const char *prefix; - cl_object tag; - union cl_lispunion str; + const char *prefix; + cl_object tag; + union cl_lispunion str; #ifdef ECL_UNICODE - ecl_character buffer[10]; + ecl_character buffer[10]; #else - ecl_base_char buffer[10]; + ecl_base_char buffer[10]; #endif - switch ((enum ecl_smmode)x->stream.mode) { - case ecl_smm_input_file: - prefix = "closed input file"; - tag = IO_STREAM_FILENAME(x); - break; - case ecl_smm_input: - prefix = "closed input stream"; - tag = IO_STREAM_FILENAME(x); - break; - case ecl_smm_output_file: - prefix = "closed output file"; - tag = IO_STREAM_FILENAME(x); - break; - case ecl_smm_output: - prefix = "closed output stream"; - tag = IO_STREAM_FILENAME(x); - break; + switch ((enum ecl_smmode)x->stream.mode) { + case ecl_smm_input_file: + prefix = "closed input file"; + tag = IO_STREAM_FILENAME(x); + break; + case ecl_smm_input: + prefix = "closed input stream"; + tag = IO_STREAM_FILENAME(x); + break; + case ecl_smm_output_file: + prefix = "closed output file"; + tag = IO_STREAM_FILENAME(x); + break; + case ecl_smm_output: + prefix = "closed output stream"; + tag = IO_STREAM_FILENAME(x); + break; #ifdef ECL_MS_WINDOWS_HOST - case ecl_smm_input_wsock: - prefix = "closed input win32 socket stream"; - tag = IO_STREAM_FILENAME(x); - break; - case ecl_smm_output_wsock: - prefix = "closed output win32 socket stream"; - tag = IO_STREAM_FILENAME(x); - break; - case ecl_smm_io_wsock: - prefix = "closed i/o win32 socket stream"; - tag = IO_STREAM_FILENAME(x); - break; - case ecl_smm_io_wcon: - prefix = "closed i/o win32 console stream"; - tag = IO_STREAM_FILENAME(x); - break; + case ecl_smm_input_wsock: + prefix = "closed input win32 socket stream"; + tag = IO_STREAM_FILENAME(x); + break; + case ecl_smm_output_wsock: + prefix = "closed output win32 socket stream"; + tag = IO_STREAM_FILENAME(x); + break; + case ecl_smm_io_wsock: + prefix = "closed i/o win32 socket stream"; + tag = IO_STREAM_FILENAME(x); + break; + case ecl_smm_io_wcon: + prefix = "closed i/o win32 console stream"; + tag = IO_STREAM_FILENAME(x); + break; #endif - case ecl_smm_io_file: - prefix = "closed io file"; - tag = IO_STREAM_FILENAME(x); - break; - case ecl_smm_io: - prefix = "closed io stream"; - tag = IO_STREAM_FILENAME(x); - break; - case ecl_smm_probe: - prefix = "closed probe stream"; - tag = IO_STREAM_FILENAME(x); - break; - case ecl_smm_synonym: - prefix = "closed synonym stream to"; - tag = SYNONYM_STREAM_SYMBOL(x); - break; - case ecl_smm_broadcast: - prefix = "closed broadcast stream"; - tag = ECL_NIL; - break; - case ecl_smm_concatenated: - prefix = "closed concatenated stream"; - tag = ECL_NIL; - break; - case ecl_smm_two_way: - prefix = "closed two-way stream"; - tag = ECL_NIL; - break; - case ecl_smm_echo: - prefix = "closed echo stream"; - tag = ECL_NIL; - break; - case ecl_smm_string_input: { - cl_object text = x->stream.object0; - cl_index ndx, l = ecl_length(text); - for (ndx = 0; (ndx < 8) && (ndx < l); ndx++) { - buffer[ndx] = ecl_char(text, ndx); - } - if (l > ndx) { - buffer[ndx-1] = '.'; - buffer[ndx-2] = '.'; - buffer[ndx-3] = '.'; - } - buffer[ndx++] = 0; - prefix = "closed string-input stream from"; - tag = &str; + case ecl_smm_io_file: + prefix = "closed io file"; + tag = IO_STREAM_FILENAME(x); + break; + case ecl_smm_io: + prefix = "closed io stream"; + tag = IO_STREAM_FILENAME(x); + break; + case ecl_smm_probe: + prefix = "closed probe stream"; + tag = IO_STREAM_FILENAME(x); + break; + case ecl_smm_synonym: + prefix = "closed synonym stream to"; + tag = SYNONYM_STREAM_SYMBOL(x); + break; + case ecl_smm_broadcast: + prefix = "closed broadcast stream"; + tag = ECL_NIL; + break; + case ecl_smm_concatenated: + prefix = "closed concatenated stream"; + tag = ECL_NIL; + break; + case ecl_smm_two_way: + prefix = "closed two-way stream"; + tag = ECL_NIL; + break; + case ecl_smm_echo: + prefix = "closed echo stream"; + tag = ECL_NIL; + break; + case ecl_smm_string_input: { + cl_object text = x->stream.object0; + cl_index ndx, l = ecl_length(text); + for (ndx = 0; (ndx < 8) && (ndx < l); ndx++) { + buffer[ndx] = ecl_char(text, ndx); + } + if (l > ndx) { + buffer[ndx-1] = '.'; + buffer[ndx-2] = '.'; + buffer[ndx-3] = '.'; + } + buffer[ndx++] = 0; + prefix = "closed string-input stream from"; + tag = &str; #ifdef ECL_UNICODE - tag->string.t = t_string; - tag->string.self = buffer; + tag->string.t = t_string; + tag->string.self = buffer; #else - tag->base_string.t = t_base_string; - tag->base_string.self = buffer; + tag->base_string.t = t_base_string; + tag->base_string.self = buffer; #endif - tag->base_string.dim = ndx; - tag->base_string.fillp = ndx-1; - break; - } - case ecl_smm_string_output: - prefix = "closed string-output stream"; - tag = ECL_NIL; - break; - case ecl_smm_sequence_input: - prefix = "closed sequence-input stream"; - tag = ECL_NIL; - break; - case ecl_smm_sequence_output: - prefix = "closed sequence-output stream"; - tag = ECL_NIL; - break; - default: - ecl_internal_error("illegal stream mode"); - } - if (!x->stream.closed) - prefix = prefix + 7; - _ecl_write_unreadable(x, prefix, tag, stream); + tag->base_string.dim = ndx; + tag->base_string.fillp = ndx-1; + break; + } + case ecl_smm_string_output: + prefix = "closed string-output stream"; + tag = ECL_NIL; + break; + case ecl_smm_sequence_input: + prefix = "closed sequence-input stream"; + tag = ECL_NIL; + break; + case ecl_smm_sequence_output: + prefix = "closed sequence-output stream"; + tag = ECL_NIL; + break; + default: + ecl_internal_error("illegal stream mode"); + } + if (!x->stream.closed) + prefix = prefix + 7; + _ecl_write_unreadable(x, prefix, tag, stream); } static void write_instance(cl_object x, cl_object stream) { - _ecl_funcall3(@'print-object', x, stream); + _ecl_funcall3(@'print-object', x, stream); } static void write_readtable(cl_object x, cl_object stream) { - _ecl_write_unreadable(x, "readtable", ECL_NIL, stream); + _ecl_write_unreadable(x, "readtable", ECL_NIL, stream); } static void write_cfun(cl_object x, cl_object stream) { - _ecl_write_unreadable(x, "compiled-function", x->cfun.name, stream); + _ecl_write_unreadable(x, "compiled-function", x->cfun.name, stream); } static void write_codeblock(cl_object x, cl_object stream) { - _ecl_write_unreadable(x, "codeblock", x->cblock.name, stream); + _ecl_write_unreadable(x, "codeblock", x->cblock.name, stream); } static void write_cclosure(cl_object x, cl_object stream) { - _ecl_write_unreadable(x, "compiled-closure", ECL_NIL, stream); + _ecl_write_unreadable(x, "compiled-closure", ECL_NIL, stream); } static void write_foreign(cl_object x, cl_object stream) { - _ecl_write_unreadable(x, "foreign", x->foreign.tag, stream); + _ecl_write_unreadable(x, "foreign", x->foreign.tag, stream); } static void write_frame(cl_object x, cl_object stream) { - _ecl_write_unreadable(x, "frame", ecl_make_fixnum(x->frame.size), stream); + _ecl_write_unreadable(x, "frame", ecl_make_fixnum(x->frame.size), stream); } static void write_weak_pointer(cl_object x, cl_object stream) { - _ecl_write_unreadable(x, "weak-pointer", ECL_NIL, stream); + _ecl_write_unreadable(x, "weak-pointer", ECL_NIL, stream); } #ifdef ECL_THREADS static void write_process(cl_object x, cl_object stream) { - _ecl_write_unreadable(x, "process", x->process.name, stream); + _ecl_write_unreadable(x, "process", x->process.name, stream); } static void write_lock(cl_object x, cl_object stream) { - const char *prefix = x->lock.recursive? - "lock" : "lock (nonrecursive)"; - _ecl_write_unreadable(x, prefix, x->lock.name, stream); + const char *prefix = x->lock.recursive? + "lock" : "lock (nonrecursive)"; + _ecl_write_unreadable(x, prefix, x->lock.name, stream); +} + +static void +write_rwlock(cl_object x, cl_object stream) +{ + _ecl_write_unreadable(x, "rwlock", x->rwlock.name, stream); } static void write_condition_variable(cl_object x, cl_object stream) { - _ecl_write_unreadable(x, "semaphore", ECL_NIL, stream); + _ecl_write_unreadable(x, "semaphore", ECL_NIL, stream); } static void write_semaphore(cl_object x, cl_object stream) { - _ecl_write_unreadable(x, "semaphore", ECL_NIL, stream); + _ecl_write_unreadable(x, "semaphore", ECL_NIL, stream); } static void write_barrier(cl_object x, cl_object stream) { - _ecl_write_unreadable(x, "barrier", ECL_NIL, stream); + _ecl_write_unreadable(x, "barrier", ECL_NIL, stream); } static void write_mailbox(cl_object x, cl_object stream) { - _ecl_write_unreadable(x, "mailbox", ECL_NIL, stream); + _ecl_write_unreadable(x, "mailbox", ECL_NIL, stream); } #endif /* ECL_THREADS */ @@ -393,75 +394,75 @@ static void write_illegal(cl_object x, cl_object stream) { - _ecl_write_unreadable(x, "illegal pointer", ECL_NIL, stream); + _ecl_write_unreadable(x, "illegal pointer", ECL_NIL, stream); } typedef void (*printer)(cl_object x, cl_object stream); static printer dispatch[FREE+1] = { - 0 /* t_start = 0 */, - _ecl_write_list, /* t_list = 1 */ - write_character, /* t_character = 2 */ - write_integer, /* t_fixnum = 3 */ - write_integer, /* t_bignum = 4 */ - write_ratio, /* t_ratio */ - /* write_float, */ /* t_shortfloat */ - write_float, /* t_singlefloat */ - write_float, /* t_doublefloat */ + 0 /* t_start = 0 */, + _ecl_write_list, /* t_list = 1 */ + write_character, /* t_character = 2 */ + write_integer, /* t_fixnum = 3 */ + write_integer, /* t_bignum = 4 */ + write_ratio, /* t_ratio */ + /* write_float, */ /* t_shortfloat */ + write_float, /* t_singlefloat */ + write_float, /* t_doublefloat */ #ifdef ECL_LONG_FLOAT - write_float, /* t_longfloat */ + write_float, /* t_longfloat */ #endif - write_complex, /* t_complex */ - _ecl_write_symbol, /* t_symbol */ - write_package, /* t_package */ - write_hashtable, /* t_hashtable */ - _ecl_write_array, /* t_array */ - _ecl_write_vector, /* t_vector */ + write_complex, /* t_complex */ + _ecl_write_symbol, /* t_symbol */ + write_package, /* t_package */ + write_hashtable, /* t_hashtable */ + _ecl_write_array, /* t_array */ + _ecl_write_vector, /* t_vector */ #ifdef ECL_UNICODE - _ecl_write_string, /* t_string */ + _ecl_write_string, /* t_string */ #endif - _ecl_write_base_string, /* t_base_string */ - _ecl_write_bitvector, /* t_bitvector */ - write_stream, /* t_stream */ - write_random, /* t_random */ - write_readtable, /* t_readtable */ - write_pathname, /* t_pathname */ - _ecl_write_bytecodes, /* t_bytecodes */ - _ecl_write_bclosure, /* t_bclosure */ - write_cfun, /* t_cfun */ - write_cfun, /* t_cfunfixed */ - write_cclosure, /* t_cclosure */ - write_instance, /* t_instance */ + _ecl_write_base_string, /* t_base_string */ + _ecl_write_bitvector, /* t_bitvector */ + write_stream, /* t_stream */ + write_random, /* t_random */ + write_readtable, /* t_readtable */ + write_pathname, /* t_pathname */ + _ecl_write_bytecodes, /* t_bytecodes */ + _ecl_write_bclosure, /* t_bclosure */ + write_cfun, /* t_cfun */ + write_cfun, /* t_cfunfixed */ + write_cclosure, /* t_cclosure */ + write_instance, /* t_instance */ #ifdef ECL_THREADS - write_process, /* t_process */ - write_lock, /* t_lock */ - write_lock, /* t_rwlock */ - write_condition_variable, /* t_condition_variable */ - write_semaphore, /* t_semaphore */ - write_barrier, /* t_barrier */ - write_mailbox, /* t_mailbox */ + write_process, /* t_process */ + write_lock, /* t_lock */ + write_rwlock, /* t_rwlock */ + write_condition_variable, /* t_condition_variable */ + write_semaphore, /* t_semaphore */ + write_barrier, /* t_barrier */ + write_mailbox, /* t_mailbox */ #endif - write_codeblock, /* t_codeblock */ - write_foreign, /* t_foreign */ - write_frame, /* t_frame */ - write_weak_pointer, /* t_weak_pointer */ + write_codeblock, /* t_codeblock */ + write_foreign, /* t_foreign */ + write_frame, /* t_frame */ + write_weak_pointer, /* t_weak_pointer */ #ifdef ECL_SSE2 - _ecl_write_sse, /* t_sse_pack */ + _ecl_write_sse, /* t_sse_pack */ #endif - /* t_end */ + /* t_end */ }; cl_object si_write_ugly_object(cl_object x, cl_object stream) { - if (x == OBJNULL) { - if (ecl_print_readably()) - FEprint_not_readable(x); - writestr_stream("#", stream); - } else { - int t = ecl_t_of(x); - printer f = (t >= t_end)? write_illegal : dispatch[t]; - f(x, stream); - } - @(return x) + if (x == OBJNULL) { + if (ecl_print_readably()) + FEprint_not_readable(x); + writestr_stream("#", stream); + } else { + int t = ecl_t_of(x); + printer f = (t >= t_end)? write_illegal : dispatch[t]; + f(x, stream); + } + @(return x); } diff -Nru ecl-16.1.2/src/c/read.d ecl-16.1.3+ds/src/c/read.d --- ecl-16.1.2/src/c/read.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/read.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - read.d -- Read. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * read.d - reader + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #define ECL_INCLUDE_MATH_H #include @@ -57,54 +52,54 @@ cl_object si_get_buffer_string() { - const cl_env_ptr env = ecl_process_env(); - cl_object pool = env->string_pool; - cl_object output; - if (pool == ECL_NIL) { + const cl_env_ptr env = ecl_process_env(); + cl_object pool = env->string_pool; + cl_object output; + if (pool == ECL_NIL) { #ifdef ECL_UNICODE - output = ecl_alloc_adjustable_extended_string(ECL_BUFFER_STRING_SIZE); + output = ecl_alloc_adjustable_extended_string(ECL_BUFFER_STRING_SIZE); #else - output = ecl_alloc_adjustable_base_string(ECL_BUFFER_STRING_SIZE); + output = ecl_alloc_adjustable_base_string(ECL_BUFFER_STRING_SIZE); #endif - } else { - output = CAR(pool); - env->string_pool = CDR(pool); - } - TOKEN_STRING_FILLP(output) = 0; - @(return output) + } else { + output = CAR(pool); + env->string_pool = CDR(pool); + } + TOKEN_STRING_FILLP(output) = 0; + @(return output); } cl_object si_put_buffer_string(cl_object string) { - if (string != ECL_NIL) { - const cl_env_ptr env = ecl_process_env(); - cl_object pool = env->string_pool; - cl_index l = 0; - if (pool != ECL_NIL) { - /* We store the size of the pool in the string index */ - l = TOKEN_STRING_FILLP(ECL_CONS_CAR(pool)); - } - if (l < ECL_MAX_STRING_POOL_SIZE) { - /* Ok, by ignoring the following code, here we - * are doing like SBCL: we simply grow the - * input buffer and do not care about its - * size. */ + if (string != ECL_NIL) { + const cl_env_ptr env = ecl_process_env(); + cl_object pool = env->string_pool; + cl_index l = 0; + if (pool != ECL_NIL) { + /* We store the size of the pool in the string index */ + l = TOKEN_STRING_FILLP(ECL_CONS_CAR(pool)); + } + if (l < ECL_MAX_STRING_POOL_SIZE) { + /* Ok, by ignoring the following code, here we + * are doing like SBCL: we simply grow the + * input buffer and do not care about its + * size. */ #if 0 - if (TOKEN_STRING_DIM(string) > 32*ECL_BUFFER_STRING_SIZE) { - /* String has been enlarged. Cut it. */ + if (TOKEN_STRING_DIM(string) > 32*ECL_BUFFER_STRING_SIZE) { + /* String has been enlarged. Cut it. */ #ifdef ECL_UNICODE - string = ecl_alloc_adjustable_extended_string(ECL_BUFFER_STRING_SIZE); + string = ecl_alloc_adjustable_extended_string(ECL_BUFFER_STRING_SIZE); #else - string = ecl_alloc_adjustable_base_string(ECL_BUFFER_STRING_SIZE); + string = ecl_alloc_adjustable_base_string(ECL_BUFFER_STRING_SIZE); #endif - } + } #endif - TOKEN_STRING_FILLP(string) = l+1; - env->string_pool = CONS(string, pool); - } - } - @(return) + TOKEN_STRING_FILLP(string) = l+1; + env->string_pool = CONS(string, pool); + } + } + @(return); } static void extra_argument (int c, cl_object stream, cl_object d); @@ -114,15 +109,15 @@ cl_object ecl_read_object_non_recursive(cl_object in) { - cl_object x; - const cl_env_ptr env = ecl_process_env(); + cl_object x; + const cl_env_ptr env = ecl_process_env(); - ecl_bds_bind(env, @'si::*sharp-eq-context*', ECL_NIL); - ecl_bds_bind(env, @'si::*backq-level*', ecl_make_fixnum(0)); - x = ecl_read_object(in); - x = patch_sharp(env, x); - ecl_bds_unwind_n(env, 2); - return x; + ecl_bds_bind(env, @'si::*sharp-eq-context*', ECL_NIL); + ecl_bds_bind(env, @'si::*backq-level*', ecl_make_fixnum(0)); + x = ecl_read_object(in); + x = patch_sharp(env, x); + ecl_bds_unwind_n(env, 2); + return x; } /* @@ -135,316 +130,316 @@ static void invert_buffer_case(cl_object x, cl_object escape_list, int sign) { - cl_fixnum high_limit, low_limit; - cl_fixnum i = TOKEN_STRING_FILLP(x)-1; - do { - if (escape_list != ECL_NIL) { - cl_object escape_interval = CAR(escape_list); - high_limit = ecl_fixnum(CAR(escape_interval)); - low_limit = ecl_fixnum(CDR(escape_interval)); - escape_list = CDR(escape_list); - } else { - high_limit = low_limit = -1; - } - for (; i > high_limit; i--) { - /* The character is not escaped */ - int c = TOKEN_STRING_CHAR(x,i); - if (ecl_upper_case_p(c) && (sign < 0)) { - c = ecl_char_downcase(c); - } else if (ecl_lower_case_p(c) && (sign > 0)) { - c = ecl_char_upcase(c); - } - TOKEN_STRING_CHAR_SET(x,i,c); - } - for (; i > low_limit; i--) { - /* The character is within an escaped interval */ - ; - } - } while (i >= 0); + cl_fixnum high_limit, low_limit; + cl_fixnum i = TOKEN_STRING_FILLP(x)-1; + do { + if (escape_list != ECL_NIL) { + cl_object escape_interval = CAR(escape_list); + high_limit = ecl_fixnum(CAR(escape_interval)); + low_limit = ecl_fixnum(CDR(escape_interval)); + escape_list = CDR(escape_list); + } else { + high_limit = low_limit = -1; + } + for (; i > high_limit; i--) { + /* The character is not escaped */ + int c = TOKEN_STRING_CHAR(x,i); + if (ecl_upper_case_p(c) && (sign < 0)) { + c = ecl_char_downcase(c); + } else if (ecl_lower_case_p(c) && (sign > 0)) { + c = ecl_char_upcase(c); + } + TOKEN_STRING_CHAR_SET(x,i,c); + } + for (; i > low_limit; i--) { + /* The character is within an escaped interval */ + ; + } + } while (i >= 0); } static cl_object ecl_read_object_with_delimiter(cl_object in, int delimiter, int flags, enum ecl_chattrib a) { - cl_object x, token; - int c, base; - cl_object p; - cl_index length, i; - int colon, intern_flag; - bool external_symbol; - cl_env_ptr the_env = ecl_process_env(); - cl_object rtbl = ecl_current_readtable(); - enum ecl_readtable_case read_case = rtbl->readtable.read_case; - cl_object escape_list; /* intervals of escaped characters */ - cl_fixnum upcase; /* # uppercase characters - # downcase characters */ - cl_fixnum count; /* number of unescaped characters */ - bool suppress = read_suppress; - if (a != cat_constituent) { - c = 0; - goto LOOP; - } -BEGIN: - do { - c = ecl_read_char(in); - if (c == delimiter) { - the_env->nvalues = 0; - return OBJNULL; - } - if (c == EOF) - FEend_of_file(in); - a = ecl_readtable_get(rtbl, c, &x); - } while (a == cat_whitespace); - if ((a == cat_terminating || a == cat_non_terminating) && - (flags != ECL_READ_ONLY_TOKEN)) { - cl_object o; - if (ECL_HASH_TABLE_P(x)) { - o = dispatch_macro_character(x, in, c); - } else { - o = _ecl_funcall3(x, in, ECL_CODE_CHAR(c)); - } - if (the_env->nvalues == 0) { - if (flags == ECL_READ_RETURN_IGNORABLE) - return ECL_NIL; - goto BEGIN; - } - unlikely_if (the_env->nvalues > 1) { - FEerror("The readmacro ~S returned ~D values.", - 2, x, ecl_make_fixnum(the_env->nvalues)); - } - return o; - } -LOOP: - p = escape_list = ECL_NIL; - upcase = count = length = 0; - external_symbol = colon = 0; - token = si_get_buffer_string(); - for (;;) { - if (c == ':' && (flags != ECL_READ_ONLY_TOKEN) && - a == cat_constituent) { - colon++; - goto NEXT; - } - if (colon > 2) { - while (colon--) { - ecl_string_push_extend(token, ':'); - length++; - } - } else if (colon) { - external_symbol = (colon == 1); - TOKEN_STRING_CHAR_SET(token,length,'\0'); - /* If the readtable case was :INVERT and all non-escaped characters - * had the same case, we revert their case. */ - if (read_case == ecl_case_invert && count != 0) { - if (upcase == count) { - invert_buffer_case(token, escape_list, -1); - } else if (upcase == -count) { - invert_buffer_case(token, escape_list, +1); - } - } - if (length == 0) { - p = cl_core.keyword_package; - external_symbol = 0; - } else { - p = ecl_find_package_nolock(token); - } - if (Null(p) && !suppress) { - /* When loading binary files, we sometimes must create - symbols whose package has not yet been maked. We - allow it, but later on in ecl_init_module we make sure that - all referenced packages have been properly built. - */ - cl_object name = cl_copy_seq(token); - unlikely_if (Null(the_env->packages_to_be_created_p)) { - FEerror("There is no package with the name ~A.", - 1, name); - } - p = _ecl_package_to_be_created(the_env, name); - } - TOKEN_STRING_FILLP(token) = length = 0; - upcase = count = colon = 0; - escape_list = ECL_NIL; - } - if (a == cat_single_escape) { - c = ecl_read_char_noeof(in); - a = cat_constituent; - if (read_case == ecl_case_invert) { - escape_list = CONS(CONS(ecl_make_fixnum(length), - ecl_make_fixnum(length-1)), - escape_list); - } else { - escape_list = ECL_T; - } - ecl_string_push_extend(token, c); - length++; - goto NEXT; - } - if (a == cat_multiple_escape) { - cl_index begin = length; - for (;;) { - c = ecl_read_char_noeof(in); - a = ecl_readtable_get(rtbl, c, NULL); - if (a == cat_single_escape) { - c = ecl_read_char_noeof(in); - a = cat_constituent; - } else if (a == cat_multiple_escape) - break; - ecl_string_push_extend(token, c); - length++; - } - if (read_case == ecl_case_invert) { - escape_list = CONS(CONS(ecl_make_fixnum(begin), - ecl_make_fixnum(length-1)), - escape_list); - } else { - escape_list = ECL_T; - } - goto NEXT; - } - if (a == cat_whitespace || a == cat_terminating) { - ecl_unread_char(c, in); - break; - } - unlikely_if (ecl_invalid_character_p(c)) { - FEreader_error("Found invalid character ~:C", in, - 1, ECL_CODE_CHAR(c)); - } - if (read_case != ecl_case_preserve) { - if (ecl_upper_case_p(c)) { - upcase++; - count++; - if (read_case == ecl_case_downcase) - c = ecl_char_downcase(c); - } else if (ecl_lower_case_p(c)) { - upcase--; - count++; - if (read_case == ecl_case_upcase) - c = ecl_char_upcase(c); - } - } - ecl_string_push_extend(token, c); - length++; - NEXT: - c = ecl_read_char(in); - if (c == EOF) - break; - a = ecl_readtable_get(rtbl, c, NULL); - } - - if (suppress) { - x = ECL_NIL; - goto OUTPUT; - } - - /* If there are some escaped characters, it must be a symbol */ - if ((flags == ECL_READ_ONLY_TOKEN) || p != ECL_NIL || - escape_list != ECL_NIL || length == 0) - goto SYMBOL; - - /* The case in which the buffer is full of dots has to be especial cased */ - if (length == 1 && TOKEN_STRING_CHAR_CMP(token,0,'.')) { - if (flags == ECL_READ_LIST_DOT) { - x = @'si::.'; - goto OUTPUT; - } else { - FEreader_error("Dots appeared illegally.", in, 0); - } - } else { - int i; - for (i = 0; i < length; i++) { - if (!TOKEN_STRING_CHAR_CMP(token,i,'.')) - goto MAYBE_NUMBER; - } - FEreader_error("Dots appeared illegally.", in, 0); - } + cl_object x, token; + int c, base; + cl_object p; + cl_index length, i; + int colon, intern_flag; + bool external_symbol; + cl_env_ptr the_env = ecl_process_env(); + cl_object rtbl = ecl_current_readtable(); + enum ecl_readtable_case read_case = rtbl->readtable.read_case; + cl_object escape_list; /* intervals of escaped characters */ + cl_fixnum upcase; /* # uppercase characters - # downcase characters */ + cl_fixnum count; /* number of unescaped characters */ + bool suppress = read_suppress; + if (a != cat_constituent) { + c = 0; + goto LOOP; + } + BEGIN: + do { + c = ecl_read_char(in); + if (c == delimiter) { + the_env->nvalues = 0; + return OBJNULL; + } + if (c == EOF) + FEend_of_file(in); + a = ecl_readtable_get(rtbl, c, &x); + } while (a == cat_whitespace); + if ((a == cat_terminating || a == cat_non_terminating) && + (flags != ECL_READ_ONLY_TOKEN)) { + cl_object o; + if (ECL_HASH_TABLE_P(x)) { + o = dispatch_macro_character(x, in, c); + } else { + o = _ecl_funcall3(x, in, ECL_CODE_CHAR(c)); + } + if (the_env->nvalues == 0) { + if (flags == ECL_READ_RETURN_IGNORABLE) + return ECL_NIL; + goto BEGIN; + } + unlikely_if (the_env->nvalues > 1) { + FEerror("The readmacro ~S returned ~D values.", + 2, x, ecl_make_fixnum(the_env->nvalues)); + } + return o; + } + LOOP: + p = escape_list = ECL_NIL; + upcase = count = length = 0; + external_symbol = colon = 0; + token = si_get_buffer_string(); + for (;;) { + if (c == ':' && (flags != ECL_READ_ONLY_TOKEN) && + a == cat_constituent) { + colon++; + goto NEXT; + } + if (colon > 2) { + while (colon--) { + ecl_string_push_extend(token, ':'); + length++; + } + } else if (colon) { + external_symbol = (colon == 1); + TOKEN_STRING_CHAR_SET(token,length,'\0'); + /* If the readtable case was :INVERT and all non-escaped characters + * had the same case, we revert their case. */ + if (read_case == ecl_case_invert && count != 0) { + if (upcase == count) { + invert_buffer_case(token, escape_list, -1); + } else if (upcase == -count) { + invert_buffer_case(token, escape_list, +1); + } + } + if (length == 0) { + p = cl_core.keyword_package; + external_symbol = 0; + } else { + p = ecl_find_package_nolock(token); + } + if (Null(p) && !suppress) { + /* When loading binary files, we sometimes must create + symbols whose package has not yet been maked. We + allow it, but later on in ecl_init_module we make sure that + all referenced packages have been properly built. + */ + cl_object name = cl_copy_seq(token); + unlikely_if (Null(the_env->packages_to_be_created_p)) { + FEerror("There is no package with the name ~A.", + 1, name); + } + p = _ecl_package_to_be_created(the_env, name); + } + TOKEN_STRING_FILLP(token) = length = 0; + upcase = count = colon = 0; + escape_list = ECL_NIL; + } + if (a == cat_single_escape) { + c = ecl_read_char_noeof(in); + a = cat_constituent; + if (read_case == ecl_case_invert) { + escape_list = CONS(CONS(ecl_make_fixnum(length), + ecl_make_fixnum(length-1)), + escape_list); + } else { + escape_list = ECL_T; + } + ecl_string_push_extend(token, c); + length++; + goto NEXT; + } + if (a == cat_multiple_escape) { + cl_index begin = length; + for (;;) { + c = ecl_read_char_noeof(in); + a = ecl_readtable_get(rtbl, c, NULL); + if (a == cat_single_escape) { + c = ecl_read_char_noeof(in); + a = cat_constituent; + } else if (a == cat_multiple_escape) + break; + ecl_string_push_extend(token, c); + length++; + } + if (read_case == ecl_case_invert) { + escape_list = CONS(CONS(ecl_make_fixnum(begin), + ecl_make_fixnum(length-1)), + escape_list); + } else { + escape_list = ECL_T; + } + goto NEXT; + } + if (a == cat_whitespace || a == cat_terminating) { + ecl_unread_char(c, in); + break; + } + unlikely_if (ecl_invalid_character_p(c)) { + FEreader_error("Found invalid character ~:C", in, + 1, ECL_CODE_CHAR(c)); + } + if (read_case != ecl_case_preserve) { + if (ecl_upper_case_p(c)) { + upcase++; + count++; + if (read_case == ecl_case_downcase) + c = ecl_char_downcase(c); + } else if (ecl_lower_case_p(c)) { + upcase--; + count++; + if (read_case == ecl_case_upcase) + c = ecl_char_upcase(c); + } + } + ecl_string_push_extend(token, c); + length++; + NEXT: + c = ecl_read_char(in); + if (c == EOF) + break; + a = ecl_readtable_get(rtbl, c, NULL); + } + + if (suppress) { + x = ECL_NIL; + goto OUTPUT; + } + + /* If there are some escaped characters, it must be a symbol */ + if ((flags == ECL_READ_ONLY_TOKEN) || p != ECL_NIL || + escape_list != ECL_NIL || length == 0) + goto SYMBOL; + + /* The case in which the buffer is full of dots has to be especial cased */ + if (length == 1 && TOKEN_STRING_CHAR_CMP(token,0,'.')) { + if (flags == ECL_READ_LIST_DOT) { + x = @'si::.'; + goto OUTPUT; + } else { + FEreader_error("Dots appeared illegally.", in, 0); + } + } else { + int i; + for (i = 0; i < length; i++) { + if (!TOKEN_STRING_CHAR_CMP(token,i,'.')) + goto MAYBE_NUMBER; + } + FEreader_error("Dots appeared illegally.", in, 0); + } MAYBE_NUMBER: - /* Here we try to parse a number from the content of the buffer */ - base = ecl_current_read_base(); - if ((base <= 10) && ecl_alpha_char_p(TOKEN_STRING_CHAR(token,0))) - goto SYMBOL; - x = ecl_parse_number(token, 0, TOKEN_STRING_FILLP(token), &i, base); - unlikely_if (x == ECL_NIL) - FEreader_error("Syntax error when reading number.~%Offending string: ~S.", - in, 1, token); - if (x != OBJNULL && length == i) - goto OUTPUT; + /* Here we try to parse a number from the content of the buffer */ + base = ecl_current_read_base(); + if ((base <= 10) && ecl_alpha_char_p(TOKEN_STRING_CHAR(token,0))) + goto SYMBOL; + x = ecl_parse_number(token, 0, TOKEN_STRING_FILLP(token), &i, base); + unlikely_if (x == ECL_NIL) + FEreader_error("Syntax error when reading number.~%Offending string: ~S.", + in, 1, token); + if (x != OBJNULL && length == i) + goto OUTPUT; SYMBOL: - if (flags == ECL_READ_ONLY_TOKEN) { - the_env->nvalues = 1; - return token; - } - - /*TOKEN_STRING_CHAR_SET(token,length,'\0');*/ - /* If the readtable case was :INVERT and all non-escaped characters - * had the same case, we revert their case. */ - if (read_case == ecl_case_invert && count != 0) { - if (upcase == count) { - invert_buffer_case(token, escape_list, -1); - } else if (upcase == -count) { - invert_buffer_case(token, escape_list, +1); - } - } - if (external_symbol) { - x = ecl_find_symbol(token, p, &intern_flag); - unlikely_if (intern_flag != ECL_EXTERNAL) { - FEerror("Cannot find the external symbol ~A in ~S.", - 2, cl_copy_seq(token), p); - } - } else { - if (p == ECL_NIL) { - p = ecl_current_package(); - } - /* INV: cl_make_symbol() copies the string */ - x = ecl_intern(token, p, &intern_flag); - } + if (flags == ECL_READ_ONLY_TOKEN) { + the_env->nvalues = 1; + return token; + } + + /*TOKEN_STRING_CHAR_SET(token,length,'\0');*/ + /* If the readtable case was :INVERT and all non-escaped characters + * had the same case, we revert their case. */ + if (read_case == ecl_case_invert && count != 0) { + if (upcase == count) { + invert_buffer_case(token, escape_list, -1); + } else if (upcase == -count) { + invert_buffer_case(token, escape_list, +1); + } + } + if (external_symbol) { + x = ecl_find_symbol(token, p, &intern_flag); + unlikely_if (intern_flag != ECL_EXTERNAL) { + FEerror("Cannot find the external symbol ~A in ~S.", + 2, cl_copy_seq(token), p); + } + } else { + if (p == ECL_NIL) { + p = ecl_current_package(); + } + /* INV: cl_make_symbol() copies the string */ + x = ecl_intern(token, p, &intern_flag); + } OUTPUT: - si_put_buffer_string(token); - the_env->nvalues = 1; - return x; + si_put_buffer_string(token); + the_env->nvalues = 1; + return x; } /* - ecl_read_object(in) reads an object from stream in. - This routine corresponds to COMMON Lisp function READ. + ecl_read_object(in) reads an object from stream in. + This routine corresponds to COMMON Lisp function READ. */ cl_object ecl_read_object(cl_object in) { - return ecl_read_object_with_delimiter(in, EOF, 0, cat_constituent); + return ecl_read_object_with_delimiter(in, EOF, 0, cat_constituent); } cl_object si_read_object_or_ignore(cl_object in, cl_object eof) { - cl_object x; - const cl_env_ptr env = ecl_process_env(); + cl_object x; + const cl_env_ptr env = ecl_process_env(); - ecl_bds_bind(env, @'si::*sharp-eq-context*', ECL_NIL); - ecl_bds_bind(env, @'si::*backq-level*', ecl_make_fixnum(0)); - x = ecl_read_object_with_delimiter(in, EOF, ECL_READ_RETURN_IGNORABLE, - cat_constituent); - if (x == OBJNULL) { - env->nvalues = 1; - x = eof; - } else if (env->nvalues) { - x = patch_sharp(env, x); - } - ecl_bds_unwind_n(env, 2); - return x; + ecl_bds_bind(env, @'si::*sharp-eq-context*', ECL_NIL); + ecl_bds_bind(env, @'si::*backq-level*', ecl_make_fixnum(0)); + x = ecl_read_object_with_delimiter(in, EOF, ECL_READ_RETURN_IGNORABLE, + cat_constituent); + if (x == OBJNULL) { + env->nvalues = 1; + x = eof; + } else if (env->nvalues) { + x = patch_sharp(env, x); + } + ecl_bds_unwind_n(env, 2); + return x; } static cl_object right_parenthesis_reader(cl_object in, cl_object character) { - FEreader_error("Unmatched right parenthesis, #\\)", in, 0); + FEreader_error("Unmatched right parenthesis, #\\)", in, 0); } static cl_object left_parenthesis_reader(cl_object in, cl_object character) { - const char c = ')'; - @(return do_read_delimited_list(c, in, 0)) + const char c = ')'; + @(return do_read_delimited_list(c, in, 0)); } /* @@ -454,326 +449,326 @@ static cl_object comma_reader(cl_object in, cl_object c) { - cl_object x, y; - const cl_env_ptr env = ecl_process_env(); - cl_fixnum backq_level = ecl_fixnum(ECL_SYM_VAL(env, @'si::*backq-level*')); - - unlikely_if (backq_level <= 0) - FEreader_error("A comma has appeared out of a backquote.", in, 0); - /* Read character & complain at EOF */ - c = cl_peek_char(2,ECL_NIL,in); - if (c == ECL_CODE_CHAR('@@')) { - x = @'si::unquote-splice'; - ecl_read_char(in); - } else if (c == ECL_CODE_CHAR('.')) { - x = @'si::unquote-nsplice'; - ecl_read_char(in); - } else { - x = @'si::unquote'; - } - ECL_SETQ(env, @'si::*backq-level*', ecl_make_fixnum(backq_level-1)); - y = ecl_read_object(in); - ECL_SETQ(env, @'si::*backq-level*', ecl_make_fixnum(backq_level)); - return cl_list(2, x, y); + cl_object x, y; + const cl_env_ptr env = ecl_process_env(); + cl_fixnum backq_level = ecl_fixnum(ECL_SYM_VAL(env, @'si::*backq-level*')); + + unlikely_if (backq_level <= 0) + FEreader_error("A comma has appeared out of a backquote.", in, 0); + /* Read character & complain at EOF */ + c = cl_peek_char(2,ECL_NIL,in); + if (c == ECL_CODE_CHAR('@@')) { + x = @'si::unquote-splice'; + ecl_read_char(in); + } else if (c == ECL_CODE_CHAR('.')) { + x = @'si::unquote-nsplice'; + ecl_read_char(in); + } else { + x = @'si::unquote'; + } + ECL_SETQ(env, @'si::*backq-level*', ecl_make_fixnum(backq_level-1)); + y = ecl_read_object(in); + ECL_SETQ(env, @'si::*backq-level*', ecl_make_fixnum(backq_level)); + return cl_list(2, x, y); } static cl_object backquote_reader(cl_object in, cl_object c) { - const cl_env_ptr the_env = ecl_process_env(); - cl_fixnum backq_level = ecl_fixnum(ECL_SYM_VAL(the_env, @'si::*backq-level*')); - ECL_SETQ(the_env, @'si::*backq-level*', ecl_make_fixnum(backq_level+1)); - c = ecl_read_object(in); - ECL_SETQ(the_env, @'si::*backq-level*', ecl_make_fixnum(backq_level)); - unlikely_if (c == OBJNULL) - FEend_of_file(in); + const cl_env_ptr the_env = ecl_process_env(); + cl_fixnum backq_level = ecl_fixnum(ECL_SYM_VAL(the_env, @'si::*backq-level*')); + ECL_SETQ(the_env, @'si::*backq-level*', ecl_make_fixnum(backq_level+1)); + c = ecl_read_object(in); + ECL_SETQ(the_env, @'si::*backq-level*', ecl_make_fixnum(backq_level)); + unlikely_if (c == OBJNULL) + FEend_of_file(in); #if 0 - @(return cl_macroexpand_1(2, cl_list(2, @'si::quasiquote', in), ECL_NIL)); + @(return cl_macroexpand_1(2, cl_list(2, @'si::quasiquote', in), ECL_NIL));; #else - @(return cl_list(2,@'si::quasiquote',c)) + @(return cl_list(2,@'si::quasiquote',c)); #endif } /* - read_constituent(in) reads a sequence of constituent characters from - stream in and places it in token. As a help, it returns TRUE - or FALSE depending on the value of *READ-SUPPRESS*. + read_constituent(in) reads a sequence of constituent characters from + stream in and places it in token. As a help, it returns TRUE + or FALSE depending on the value of *READ-SUPPRESS*. */ static cl_object read_constituent(cl_object in) { - int store = !read_suppress; - cl_object rtbl = ecl_current_readtable(); - bool not_first = 0; - cl_object token = si_get_buffer_string(); - do { - int c = ecl_read_char(in); - enum ecl_chattrib c_cat; - if (c == EOF) { - break; - } - c_cat = ecl_readtable_get(rtbl, c, NULL); - if (c_cat == cat_constituent || - ((c_cat == cat_non_terminating) && not_first)) - { - if (store) { - ecl_string_push_extend(token, c); - } - } else { - ecl_unread_char(c, in); - break; - } - not_first = 1; - } while(1); - return (read_suppress)? ECL_NIL : token; + int store = !read_suppress; + cl_object rtbl = ecl_current_readtable(); + bool not_first = 0; + cl_object token = si_get_buffer_string(); + do { + int c = ecl_read_char(in); + enum ecl_chattrib c_cat; + if (c == EOF) { + break; + } + c_cat = ecl_readtable_get(rtbl, c, NULL); + if (c_cat == cat_constituent || + ((c_cat == cat_non_terminating) && not_first)) + { + if (store) { + ecl_string_push_extend(token, c); + } + } else { + ecl_unread_char(c, in); + break; + } + not_first = 1; + } while(1); + return (read_suppress)? ECL_NIL : token; } static cl_object double_quote_reader(cl_object in, cl_object c) { - int delim = ECL_CHAR_CODE(c); - cl_object rtbl = ecl_current_readtable(); - cl_object token = si_get_buffer_string(); - cl_object output; - for (;;) { - int c = ecl_read_char_noeof(in); - if (c == delim) - break; - else if (ecl_readtable_get(rtbl, c, NULL) == cat_single_escape) - c = ecl_read_char_noeof(in); - ecl_string_push_extend(token, c); - } - - /* Must be kept a (SIMPLE-ARRAY CHARACTERS (*)), see - * http://sourceforge.net/p/ecls/mailman/message/32272388/ */ - output = cl_copy_seq(token); - si_put_buffer_string(token); - @(return output) + int delim = ECL_CHAR_CODE(c); + cl_object rtbl = ecl_current_readtable(); + cl_object token = si_get_buffer_string(); + cl_object output; + for (;;) { + int c = ecl_read_char_noeof(in); + if (c == delim) + break; + else if (ecl_readtable_get(rtbl, c, NULL) == cat_single_escape) + c = ecl_read_char_noeof(in); + ecl_string_push_extend(token, c); + } + + /* Must be kept a (SIMPLE-ARRAY CHARACTERS (*)), see + * http://sourceforge.net/p/ecls/mailman/message/32272388/ */ + output = cl_copy_seq(token); + si_put_buffer_string(token); + @(return output); } static cl_object dispatch_reader_fun(cl_object in, cl_object dc) { - cl_object readtable = ecl_current_readtable(); - cl_object dispatch_table; - int c = ecl_char_code(dc); - ecl_readtable_get(readtable, c, &dispatch_table); - unlikely_if (!ECL_HASH_TABLE_P(dispatch_table)) - FEreader_error("~C is not a dispatching macro character", - in, 1, dc); - return dispatch_macro_character(dispatch_table, in, c); + cl_object readtable = ecl_current_readtable(); + cl_object dispatch_table; + int c = ecl_char_code(dc); + ecl_readtable_get(readtable, c, &dispatch_table); + unlikely_if (!ECL_HASH_TABLE_P(dispatch_table)) + FEreader_error("~C is not a dispatching macro character", + in, 1, dc); + return dispatch_macro_character(dispatch_table, in, c); } static cl_object dispatch_macro_character(cl_object table, cl_object in, int c) { - cl_object arg; - int d; - c = ecl_read_char_noeof(in); - d = ecl_digitp(c, 10); - if (d >= 0) { - cl_fixnum i = 0; - do { - i = 10*i + d; - c = ecl_read_char_noeof(in); - d = ecl_digitp(c, 10); - } while (d >= 0); - arg = ecl_make_fixnum(i); - } else { - arg = ECL_NIL; - } - { - cl_object dc = ECL_CODE_CHAR(c); - cl_object fun = ecl_gethash_safe(dc, table, ECL_NIL); - unlikely_if (Null(fun)) { - FEreader_error("No dispatch function defined " - "for character ~S", - in, 1, dc); - } - return _ecl_funcall4(fun, in, dc, arg); - } + cl_object arg; + int d; + c = ecl_read_char_noeof(in); + d = ecl_digitp(c, 10); + if (d >= 0) { + cl_fixnum i = 0; + do { + i = 10*i + d; + c = ecl_read_char_noeof(in); + d = ecl_digitp(c, 10); + } while (d >= 0); + arg = ecl_make_fixnum(i); + } else { + arg = ECL_NIL; + } + { + cl_object dc = ECL_CODE_CHAR(c); + cl_object fun = ecl_gethash_safe(dc, table, ECL_NIL); + unlikely_if (Null(fun)) { + FEreader_error("No dispatch function defined " + "for character ~S", + in, 1, dc); + } + return _ecl_funcall4(fun, in, dc, arg); + } } static cl_object single_quote_reader(cl_object in, cl_object c) { - c = ecl_read_object(in); - unlikely_if (c == OBJNULL) - FEend_of_file(in); - @(return cl_list(2, @'quote', c)) + c = ecl_read_object(in); + unlikely_if (c == OBJNULL) + FEend_of_file(in); + @(return cl_list(2, @'quote', c)); } static cl_object void_reader(cl_object in, cl_object c) { - /* no result */ - @(return) + /* no result */ + @(return); } static cl_object semicolon_reader(cl_object in, cl_object c) { - int auxc; + int auxc; - do - auxc = ecl_read_char(in); - while (auxc != '\n' && auxc != EOF); - /* no result */ - @(return) + do + auxc = ecl_read_char(in); + while (auxc != '\n' && auxc != EOF); + /* no result */ + @(return); } /* - sharpmacro routines + sharpmacro routines */ static cl_object sharp_C_reader(cl_object in, cl_object c, cl_object d) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object x, real, imag; + const cl_env_ptr the_env = ecl_process_env(); + cl_object x, real, imag; - if (d != ECL_NIL && !read_suppress) - extra_argument('C', in, d); - x = ecl_read_object(in); - unlikely_if (x == OBJNULL) - FEend_of_file(in); - if (read_suppress) - @(return ECL_NIL); - unlikely_if (!ECL_CONSP(x) || ecl_length(x) != 2) - FEreader_error("Reader macro #C should be followed by a list", - in, 0); - real = CAR(x); - imag = CADR(x); - /* INV: ecl_make_complex() checks its types. When reading circular - structures, we cannot check the types of the elements, and we - must build the complex number by hand. */ - if ((CONSP(real) || CONSP(imag)) && - !Null(ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*'))) - { - x = ecl_alloc_object(t_complex); - x->complex.real = real; - x->complex.imag = imag; - } else { - x = ecl_make_complex(real, imag); - } - @(return x) + if (d != ECL_NIL && !read_suppress) + extra_argument('C', in, d); + x = ecl_read_object(in); + unlikely_if (x == OBJNULL) + FEend_of_file(in); + if (read_suppress) + @(return ECL_NIL); + unlikely_if (!ECL_CONSP(x) || ecl_length(x) != 2) + FEreader_error("Reader macro #C should be followed by a list", + in, 0); + real = CAR(x); + imag = CADR(x); + /* INV: ecl_make_complex() checks its types. When reading circular + structures, we cannot check the types of the elements, and we + must build the complex number by hand. */ + if ((CONSP(real) || CONSP(imag)) && + !Null(ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*'))) + { + x = ecl_alloc_object(t_complex); + x->complex.real = real; + x->complex.imag = imag; + } else { + x = ecl_make_complex(real, imag); + } + @(return x); } static cl_object sharp_backslash_reader(cl_object in, cl_object c, cl_object d) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object token; - if (d != ECL_NIL && !read_suppress) { - unlikely_if (!ECL_FIXNUMP(d) || d != ecl_make_fixnum(0)) { - FEreader_error("~S is an illegal CHAR-FONT.", in, 1, d); - } - } - token = ecl_read_object_with_delimiter(in, EOF, ECL_READ_ONLY_TOKEN, - cat_single_escape); - if (token == ECL_NIL) { - c = ECL_NIL; - } else if (TOKEN_STRING_FILLP(token) == 1) { - c = ECL_CODE_CHAR(TOKEN_STRING_CHAR(token,0)); - } else if (TOKEN_STRING_FILLP(token) == 2 && TOKEN_STRING_CHAR_CMP(token,0,'^')) { - /* #\^x */ - c = ECL_CODE_CHAR(TOKEN_STRING_CHAR(token,1) & 037); - } else { - cl_object nc = cl_name_char(token); - unlikely_if (Null(nc)) { - FEreader_error("~S is an illegal character name.", in, 1, token); - } - c = nc; - } - si_put_buffer_string(token); - ecl_return1(the_env, c); + const cl_env_ptr the_env = ecl_process_env(); + cl_object token; + if (d != ECL_NIL && !read_suppress) { + unlikely_if (!ECL_FIXNUMP(d) || d != ecl_make_fixnum(0)) { + FEreader_error("~S is an illegal CHAR-FONT.", in, 1, d); + } + } + token = ecl_read_object_with_delimiter(in, EOF, ECL_READ_ONLY_TOKEN, + cat_single_escape); + if (token == ECL_NIL) { + c = ECL_NIL; + } else if (TOKEN_STRING_FILLP(token) == 1) { + c = ECL_CODE_CHAR(TOKEN_STRING_CHAR(token,0)); + } else if (TOKEN_STRING_FILLP(token) == 2 && TOKEN_STRING_CHAR_CMP(token,0,'^')) { + /* #\^x */ + c = ECL_CODE_CHAR(TOKEN_STRING_CHAR(token,1) & 037); + } else { + cl_object nc = cl_name_char(token); + unlikely_if (Null(nc)) { + FEreader_error("~S is an illegal character name.", in, 1, token); + } + c = nc; + } + si_put_buffer_string(token); + ecl_return1(the_env, c); } static cl_object sharp_single_quote_reader(cl_object in, cl_object c, cl_object d) { - bool suppress = read_suppress; - if(d != ECL_NIL && !suppress) - extra_argument('\'', in, d); - c = ecl_read_object(in); - unlikely_if (c == OBJNULL) { - FEend_of_file(in); - } else if (suppress) { - c = ECL_NIL; - } else { - c = cl_list(2, @'function', c); - } - @(return c) + bool suppress = read_suppress; + if(d != ECL_NIL && !suppress) + extra_argument('\'', in, d); + c = ecl_read_object(in); + unlikely_if (c == OBJNULL) { + FEend_of_file(in); + } else if (suppress) { + c = ECL_NIL; + } else { + c = cl_list(2, @'function', c); + } + @(return c); } static cl_object sharp_Y_reader(cl_object in, cl_object c, cl_object d) { - cl_index i; - cl_object x, rv, nth, lex; - - if (d != ECL_NIL && !read_suppress) - extra_argument('C', in, d); - x = ecl_read_object(in); - unlikely_if (x == OBJNULL) { - FEend_of_file(in); - } - if (read_suppress) { - @(return ECL_NIL); - } - unlikely_if (!ECL_CONSP(x) || ecl_length(x) < 5) { - FEreader_error("Reader macro #Y should be followed by a list", - in, 0); - } - - if (ecl_length(x) == 2) { - rv = ecl_alloc_object(t_bclosure); - rv->bclosure.code = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - rv->bclosure.lex = ECL_CONS_CAR(x); - rv->bclosure.entry = _ecl_bclosure_dispatch_vararg; - @(return rv); - } - - rv = ecl_alloc_object(t_bytecodes); - - rv->bytecodes.name = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - - lex = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); + cl_index i; + cl_object x, rv, nth, lex; - rv->bytecodes.definition = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - - nth = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - rv->bytecodes.code_size = ecl_to_fix(cl_list_length(nth)); - rv->bytecodes.code = ecl_alloc_atomic(rv->bytecodes.code_size * sizeof(uint16_t)); - for ( i=0; !ecl_endp(nth) ; i++, nth=ECL_CONS_CDR(nth) ) - ((cl_opcode*)(rv->bytecodes.code))[i] = ecl_to_fix(ECL_CONS_CAR(nth)); - - nth = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - rv->bytecodes.data = nth; + if (d != ECL_NIL && !read_suppress) + extra_argument('C', in, d); + x = ecl_read_object(in); + unlikely_if (x == OBJNULL) { + FEend_of_file(in); + } + if (read_suppress) { + @(return ECL_NIL); + } + unlikely_if (!ECL_CONSP(x) || ecl_length(x) < 5) { + FEreader_error("Reader macro #Y should be followed by a list", + in, 0); + } + + if (ecl_length(x) == 2) { + rv = ecl_alloc_object(t_bclosure); + rv->bclosure.code = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + rv->bclosure.lex = ECL_CONS_CAR(x); + rv->bclosure.entry = _ecl_bclosure_dispatch_vararg; + @(return rv); + } + + rv = ecl_alloc_object(t_bytecodes); + + rv->bytecodes.name = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + + lex = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + + rv->bytecodes.definition = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + + nth = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + rv->bytecodes.code_size = ecl_to_fix(cl_list_length(nth)); + rv->bytecodes.code = ecl_alloc_atomic(rv->bytecodes.code_size * sizeof(uint16_t)); + for ( i=0; !ecl_endp(nth) ; i++, nth=ECL_CONS_CDR(nth) ) + ((cl_opcode*)(rv->bytecodes.code))[i] = ecl_to_fix(ECL_CONS_CAR(nth)); + + nth = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + rv->bytecodes.data = nth; + + if (ECL_ATOM(x)) { + nth = ECL_NIL; + } else { + nth = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + } + rv->bytecodes.file = nth; + if (ECL_ATOM(x)) { + nth = ecl_make_fixnum(0); + } else { + nth = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + } + rv->bytecodes.file_position = nth; - if (ECL_ATOM(x)) { - nth = ECL_NIL; - } else { - nth = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - } - rv->bytecodes.file = nth; - if (ECL_ATOM(x)) { - nth = ecl_make_fixnum(0); - } else { - nth = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - } - rv->bytecodes.file_position = nth; - - rv->bytecodes.entry = _ecl_bytecodes_dispatch_vararg; - @(return rv); + rv->bytecodes.entry = _ecl_bytecodes_dispatch_vararg; + @(return rv); } #define QUOTE 1 @@ -793,295 +788,296 @@ cl_object si_make_backq_vector(cl_object d, cl_object data, cl_object in) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object v, last; - cl_index dim, i; - if (Null(d)) { - dim = ecl_length(data); - } else { - dim = ecl_fixnum(d); - } - v = ecl_alloc_simple_vector(dim, ecl_aet_object); - for (i = 0, last = ECL_NIL; i < dim; i++) { - if (data == ECL_NIL) { - /* ... we fill the vector with the last element read (or NIL). */ - for (; i < dim; i++) { - ecl_aset_unsafe(v, i, last); - } - break; - } - ecl_aset_unsafe(v, i, last = ecl_car(data)); - data = ECL_CONS_CDR(data); - } - unlikely_if (data != ECL_NIL) { - if (in != ECL_NIL) { - FEreader_error("Vector larger than specified length," - "~D.", in, 1, d); - } else { - FEerror("Vector larger than specified length, ~D", 1, d); - } - } - ecl_return1(the_env, v); + const cl_env_ptr the_env = ecl_process_env(); + cl_object v, last; + cl_index dim, i; + if (Null(d)) { + dim = ecl_length(data); + } else { + dim = ecl_fixnum(d); + } + v = ecl_alloc_simple_vector(dim, ecl_aet_object); + for (i = 0, last = ECL_NIL; i < dim; i++) { + if (data == ECL_NIL) { + /* ... we fill the vector with the last element read (or NIL). */ + for (; i < dim; i++) { + ecl_aset_unsafe(v, i, last); + } + break; + } + ecl_aset_unsafe(v, i, last = ecl_car(data)); + data = ECL_CONS_CDR(data); + } + unlikely_if (data != ECL_NIL) { + if (in != ECL_NIL) { + FEreader_error("Vector larger than specified length," + "~D.", in, 1, d); + } else { + FEerror("Vector larger than specified length, ~D", 1, d); + } + } + ecl_return1(the_env, v); } static cl_object sharp_left_parenthesis_reader(cl_object in, cl_object c, cl_object d) { - extern int _cl_backq_car(cl_object *); - const cl_env_ptr the_env = ecl_process_env(); - cl_object v; - unlikely_if (!Null(d) && - (!ECL_FIXNUMP(d) || ecl_fixnum_minusp(d) || - ecl_fixnum_greater(d, ecl_make_fixnum(ECL_ARRAY_DIMENSION_LIMIT)))) - { - FEreader_error("Invalid dimension size ~D in #()", in, 1, d); - } - if (ecl_fixnum_plusp(ECL_SYM_VAL(the_env, @'si::*backq-level*'))) { - /* First case: ther might be unquoted elements in the vector. - * Then we just create a form that generates the vector. - */ - cl_object x = do_read_delimited_list(')', in, 1); - cl_index a = _cl_backq_car(&x); - if (a != QUOTE) { - v = cl_list(2, @'si::unquote', - cl_list(4, @'si::make-backq-vector', d, x, ECL_NIL)); - } else { - return si_make_backq_vector(d, x, in); - } - } else if (read_suppress) { - /* Second case: *read-suppress* = t, we ignore the data */ - do_read_delimited_list(')', in, 1); - v = ECL_NIL; - } else if (Null(d)) { - /* Third case: no dimension provided. Read a list and - coerce it to vector. */ - return si_make_backq_vector(d, do_read_delimited_list(')', in, 1), in); - } else { - /* Finally: Both dimension and data are provided. The - amount of data cannot exceed the length, but it may - be smaller, and in that case...*/ - cl_object last; - cl_index dim = ecl_fixnum(d), i; - v = ecl_alloc_simple_vector(dim, ecl_aet_object); - for (i = 0, last = ECL_NIL;; i++) { - cl_object aux = ecl_read_object_with_delimiter(in, ')', 0, - cat_constituent); - if (aux == OBJNULL) - break; - unlikely_if (i >= dim) { - FEreader_error("Vector larger than specified length," - "~D.", in, 1, d); - } - ecl_aset_unsafe(v, i, last = aux); - } - /* ... we fill the vector with the last element read (or NIL). */ - for (; i < dim; i++) { - ecl_aset_unsafe(v, i, last); - } - } - @(return v) + extern int _cl_backq_car(cl_object *); + const cl_env_ptr the_env = ecl_process_env(); + cl_object v; + unlikely_if (!Null(d) && + (!ECL_FIXNUMP(d) || ecl_fixnum_minusp(d) || + ecl_fixnum_greater(d, ecl_make_fixnum(ECL_ARRAY_DIMENSION_LIMIT)))) + { + FEreader_error("Invalid dimension size ~D in #()", in, 1, d); + } + if (ecl_fixnum_plusp(ECL_SYM_VAL(the_env, @'si::*backq-level*'))) { + /* First case: ther might be unquoted elements in the vector. + * Then we just create a form that generates the vector. + */ + cl_object x = do_read_delimited_list(')', in, 1); + cl_index a = _cl_backq_car(&x); + if (a != QUOTE) { + v = cl_list(2, @'si::unquote', + cl_list(4, @'si::make-backq-vector', d, x, ECL_NIL)); + } else { + return si_make_backq_vector(d, x, in); + } + } else if (read_suppress) { + /* Second case: *read-suppress* = t, we ignore the data */ + do_read_delimited_list(')', in, 1); + v = ECL_NIL; + } else if (Null(d)) { + /* Third case: no dimension provided. Read a list and + coerce it to vector. */ + return si_make_backq_vector(d, do_read_delimited_list(')', in, 1), in); + } else { + /* Finally: Both dimension and data are provided. The + amount of data cannot exceed the length, but it may + be smaller, and in that case...*/ + cl_object last; + cl_index dim = ecl_fixnum(d), i; + v = ecl_alloc_simple_vector(dim, ecl_aet_object); + for (i = 0, last = ECL_NIL;; i++) { + cl_object aux = ecl_read_object_with_delimiter(in, ')', 0, + cat_constituent); + if (aux == OBJNULL) + break; + unlikely_if (i >= dim) { + FEreader_error("Vector larger than specified length," + "~D.", in, 1, d); + } + ecl_aset_unsafe(v, i, last = aux); + } + /* ... we fill the vector with the last element read (or NIL). */ + for (; i < dim; i++) { + ecl_aset_unsafe(v, i, last); + } + } + @(return v); } static cl_object sharp_asterisk_reader(cl_object in, cl_object c, cl_object d) { - cl_env_ptr env = ecl_process_env(); - cl_index sp = ECL_STACK_INDEX(env); - cl_object last, elt, x; - cl_index dim, dimcount, i; - cl_object rtbl = ecl_current_readtable(); - enum ecl_chattrib a; - - if (read_suppress) { - read_constituent(in); - @(return ECL_NIL) - } - for (dimcount = 0 ;; dimcount++) { - int x = ecl_read_char(in); - if (x == EOF) - break; - a = ecl_readtable_get(rtbl, x, NULL); - if (a == cat_terminating || a == cat_whitespace) { - ecl_unread_char(x, in); - break; - } - unlikely_if (a == cat_single_escape || a == cat_multiple_escape || - (x != '0' && x != '1')) - { - FEreader_error("Character ~:C is not allowed after #*", - in, 1, ECL_CODE_CHAR(x)); - } - ECL_STACK_PUSH(env, ecl_make_fixnum(x == '1')); - } - if (Null(d)) { - dim = dimcount; - } else { - unlikely_if (!ECL_FIXNUMP(d) || ((dim = ecl_fixnum(d)) < 0) || - (dim > ECL_ARRAY_DIMENSION_LIMIT)) - { - FEreader_error("Wrong vector dimension size ~D in #*.", - in, 1, d); - } - unlikely_if (dimcount > dim) - FEreader_error("Too many elements in #*.", in, 0); - unlikely_if (dim && (dimcount == 0)) - FEreader_error("Cannot fill the bit-vector #*.", in, 0); - } - last = ECL_STACK_REF(env,-1); - x = ecl_alloc_simple_vector(dim, ecl_aet_bit); - for (i = 0; i < dim; i++) { - elt = (i < dimcount) ? env->stack[sp+i] : last; - if (elt == ecl_make_fixnum(0)) - x->vector.self.bit[i/CHAR_BIT] &= ~(0200 >> i%CHAR_BIT); - else - x->vector.self.bit[i/CHAR_BIT] |= 0200 >> i%CHAR_BIT; - } - ECL_STACK_POP_N_UNSAFE(env, dimcount); - @(return x) + cl_env_ptr env = ecl_process_env(); + cl_index sp = ECL_STACK_INDEX(env); + cl_object last, elt, x; + cl_index dim, dimcount, i; + cl_object rtbl = ecl_current_readtable(); + enum ecl_chattrib a; + + if (read_suppress) { + read_constituent(in); + @(return ECL_NIL); + } + for (dimcount = 0 ;; dimcount++) { + int x = ecl_read_char(in); + if (x == EOF) + break; + a = ecl_readtable_get(rtbl, x, NULL); + if (a == cat_terminating || a == cat_whitespace) { + ecl_unread_char(x, in); + break; + } + unlikely_if (a == cat_single_escape || a == cat_multiple_escape || + (x != '0' && x != '1')) + { + FEreader_error("Character ~:C is not allowed after #*", + in, 1, ECL_CODE_CHAR(x)); + } + ECL_STACK_PUSH(env, ecl_make_fixnum(x == '1')); + } + if (Null(d)) { + dim = dimcount; + } else { + unlikely_if (!ECL_FIXNUMP(d) || ((dim = ecl_fixnum(d)) < 0) || + (dim > ECL_ARRAY_DIMENSION_LIMIT)) + { + FEreader_error("Wrong vector dimension size ~D in #*.", + in, 1, d); + } + unlikely_if (dimcount > dim) + FEreader_error("Too many elements in #*.", in, 0); + unlikely_if (dim && (dimcount == 0)) + FEreader_error("Cannot fill the bit-vector #*.", in, 0); + } + last = ECL_STACK_REF(env,-1); + x = ecl_alloc_simple_vector(dim, ecl_aet_bit); + for (i = 0; i < dim; i++) { + elt = (i < dimcount) ? env->stack[sp+i] : last; + if (elt == ecl_make_fixnum(0)) + x->vector.self.bit[i/CHAR_BIT] &= ~(0200 >> i%CHAR_BIT); + else + x->vector.self.bit[i/CHAR_BIT] |= 0200 >> i%CHAR_BIT; + } + ECL_STACK_POP_N_UNSAFE(env, dimcount); + @(return x); } static cl_object sharp_colon_reader(cl_object in, cl_object ch, cl_object d) { - cl_object rtbl = ecl_current_readtable(); - enum ecl_chattrib a; - bool escape_flag; - int c; - cl_object output, token; - - if (d != ECL_NIL && !read_suppress) - extra_argument(':', in, d); + cl_object rtbl = ecl_current_readtable(); + enum ecl_chattrib a; + bool escape_flag; + int c; + cl_object output, token; + + if (d != ECL_NIL && !read_suppress) + extra_argument(':', in, d); + c = ecl_read_char_noeof(in); + a = ecl_readtable_get(rtbl, c, NULL); + escape_flag = FALSE; + token = si_get_buffer_string(); + goto L; + for (;;) { + ecl_string_push_extend(token, c); + K: + c = ecl_read_char(in); + if (c == EOF) + goto M; + a = ecl_readtable_get(rtbl, c, NULL); + L: + if (a == cat_single_escape) { + c = ecl_read_char_noeof(in); + a = cat_constituent; + escape_flag = TRUE; + } else if (a == cat_multiple_escape) { + escape_flag = TRUE; + for (;;) { c = ecl_read_char_noeof(in); a = ecl_readtable_get(rtbl, c, NULL); - escape_flag = FALSE; - token = si_get_buffer_string(); - goto L; - for (;;) { - ecl_string_push_extend(token, c); - K: - c = ecl_read_char(in); - if (c == EOF) - goto M; - a = ecl_readtable_get(rtbl, c, NULL); - L: - if (a == cat_single_escape) { - c = ecl_read_char_noeof(in); - a = cat_constituent; - escape_flag = TRUE; - } else if (a == cat_multiple_escape) { - escape_flag = TRUE; - for (;;) { - c = ecl_read_char_noeof(in); - a = ecl_readtable_get(rtbl, c, NULL); - if (a == cat_single_escape) { - c = ecl_read_char_noeof(in); - a = cat_constituent; - } else if (a == cat_multiple_escape) - break; - ecl_string_push_extend(token, c); - } - goto K; - } else if (ecl_lower_case_p(c)) - c = ecl_char_upcase(c); - if (a == cat_whitespace || a == cat_terminating) - break; - } - ecl_unread_char(c, in); - -M: - if (read_suppress) { - output = ECL_NIL; - } else { - output = cl_make_symbol(token); - } - si_put_buffer_string(token); - @(return output) + if (a == cat_single_escape) { + c = ecl_read_char_noeof(in); + a = cat_constituent; + } else if (a == cat_multiple_escape) + break; + ecl_string_push_extend(token, c); + } + goto K; + } else if (ecl_lower_case_p(c)) + c = ecl_char_upcase(c); + if (a == cat_whitespace || a == cat_terminating) + break; + } + ecl_unread_char(c, in); + + M: + if (read_suppress) { + output = ECL_NIL; + } else { + output = cl_make_symbol(token); + } + si_put_buffer_string(token); + @(return output); } static cl_object sharp_dot_reader(cl_object in, cl_object c, cl_object d) { - const cl_env_ptr env = ecl_process_env(); - if (d != ECL_NIL && !read_suppress) - extra_argument('.', in, d); - c = ecl_read_object(in); - unlikely_if (c == OBJNULL) - FEend_of_file(in); - if (read_suppress) - @(return ECL_NIL); - unlikely_if (ecl_symbol_value(@'*read-eval*') == ECL_NIL) - FEreader_error("Cannot evaluate the form #.~A", in, 1, c); - /* FIXME! We should do something here to ensure that the #. - * only uses the #n# that have been defined */ - c = patch_sharp(env, c); - c = si_eval_with_env(1, c); - @(return c) + const cl_env_ptr env = ecl_process_env(); + if (d != ECL_NIL && !read_suppress) + extra_argument('.', in, d); + c = ecl_read_object(in); + unlikely_if (c == OBJNULL) + FEend_of_file(in); + if (read_suppress) { + @(return ECL_NIL); + } + unlikely_if (ecl_symbol_value(@'*read-eval*') == ECL_NIL) + FEreader_error("Cannot evaluate the form #.~A", in, 1, c); + /* FIXME! We should do something here to ensure that the #. + * only uses the #n# that have been defined */ + c = patch_sharp(env, c); + c = si_eval_with_env(1, c); + @(return c); } static cl_object read_number(cl_object in, int radix, cl_object macro_char) { - cl_index i; - cl_object x; - cl_object token = read_constituent(in); - if (token == ECL_NIL) { - x = ECL_NIL; - } else { - x = ecl_parse_number(token, 0, TOKEN_STRING_FILLP(token), &i, radix); - unlikely_if (x == OBJNULL || x == ECL_NIL || - i != TOKEN_STRING_FILLP(token)) - { - FEreader_error("Cannot parse the #~A readmacro.", in, 1, - macro_char); - } - unlikely_if (cl_rationalp(x) == ECL_NIL) { - FEreader_error("The float ~S appeared after the #~A readmacro.", - in, 2, x, macro_char); - } - si_put_buffer_string(token); - } - return x; + cl_index i; + cl_object x; + cl_object token = read_constituent(in); + if (token == ECL_NIL) { + x = ECL_NIL; + } else { + x = ecl_parse_number(token, 0, TOKEN_STRING_FILLP(token), &i, radix); + unlikely_if (x == OBJNULL || x == ECL_NIL || + i != TOKEN_STRING_FILLP(token)) + { + FEreader_error("Cannot parse the #~A readmacro.", in, 1, + macro_char); + } + unlikely_if (cl_rationalp(x) == ECL_NIL) { + FEreader_error("The float ~S appeared after the #~A readmacro.", + in, 2, x, macro_char); + } + si_put_buffer_string(token); + } + return x; } static cl_object sharp_B_reader(cl_object in, cl_object c, cl_object d) { - if(d != ECL_NIL && !read_suppress) - extra_argument('B', in, d); - @(return (read_number(in, 2, ECL_CODE_CHAR('B')))) + if(d != ECL_NIL && !read_suppress) + extra_argument('B', in, d); + @(return (read_number(in, 2, ECL_CODE_CHAR('B')))); } static cl_object sharp_O_reader(cl_object in, cl_object c, cl_object d) { - if(d != ECL_NIL && !read_suppress) - extra_argument('O', in, d); - @(return (read_number(in, 8, ECL_CODE_CHAR('O')))) + if(d != ECL_NIL && !read_suppress) + extra_argument('O', in, d); + @(return (read_number(in, 8, ECL_CODE_CHAR('O')))); } static cl_object sharp_X_reader(cl_object in, cl_object c, cl_object d) { - if(d != ECL_NIL && !read_suppress) - extra_argument('X', in, d); - @(return (read_number(in, 16, ECL_CODE_CHAR('X')))) + if(d != ECL_NIL && !read_suppress) + extra_argument('X', in, d); + @(return (read_number(in, 16, ECL_CODE_CHAR('X')))); } static cl_object sharp_R_reader(cl_object in, cl_object c, cl_object d) { - int radix; - if (read_suppress) { - radix = 10; - } else unlikely_if (!ECL_FIXNUMP(d)) { - FEreader_error("No radix was supplied in the #R readmacro.", in, 0); - } else { - radix = ecl_fixnum(d); - unlikely_if (radix > 36 || radix < 2) { - FEreader_error("~S is an illegal radix.", in, 1, d); - } - } - @(return (read_number(in, radix, ECL_CODE_CHAR('R')))) + int radix; + if (read_suppress) { + radix = 10; + } else unlikely_if (!ECL_FIXNUMP(d)) { + FEreader_error("No radix was supplied in the #R readmacro.", in, 0); + } else { + radix = ecl_fixnum(d); + unlikely_if (radix > 36 || radix < 2) { + FEreader_error("~S is an illegal radix.", in, 1, d); + } + } + @(return (read_number(in, radix, ECL_CODE_CHAR('R')))); } #define sharp_A_reader void_reader @@ -1090,228 +1086,230 @@ static cl_object sharp_eq_reader(cl_object in, cl_object c, cl_object d) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object pair, value; - cl_object sharp_eq_context = ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*'); - - if (read_suppress) @(return); - unlikely_if (Null(d)) { - FEreader_error("The #= readmacro requires an argument.", in, 0); - } - unlikely_if (ecl_assq(d, sharp_eq_context) != ECL_NIL) { - FEreader_error("Duplicate definitions for #~D=.", in, 1, d); - } - pair = CONS(d, OBJNULL); - ECL_SETQ(the_env, @'si::*sharp-eq-context*', CONS(pair, sharp_eq_context)); - value = ecl_read_object(in); - unlikely_if (value == pair) { - FEreader_error("#~D# is defined by itself.", in, 1, d); - } - ECL_RPLACD(pair, value); - ecl_return1(the_env, value); + const cl_env_ptr the_env = ecl_process_env(); + cl_object pair, value; + cl_object sharp_eq_context = ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*'); + + if (read_suppress) { + @(return); + } + unlikely_if (Null(d)) { + FEreader_error("The #= readmacro requires an argument.", in, 0); + } + unlikely_if (ecl_assq(d, sharp_eq_context) != ECL_NIL) { + FEreader_error("Duplicate definitions for #~D=.", in, 1, d); + } + pair = CONS(d, OBJNULL); + ECL_SETQ(the_env, @'si::*sharp-eq-context*', CONS(pair, sharp_eq_context)); + value = ecl_read_object(in); + unlikely_if (value == pair) { + FEreader_error("#~D# is defined by itself.", in, 1, d); + } + ECL_RPLACD(pair, value); + ecl_return1(the_env, value); } static cl_object sharp_sharp_reader(cl_object in, cl_object c, cl_object d) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object pair; + const cl_env_ptr the_env = ecl_process_env(); + cl_object pair; - if (read_suppress) - ecl_return1(the_env, ECL_NIL); - unlikely_if (Null(d)) { - FEreader_error("The ## readmacro requires an argument.", in, 0); - } - pair = ecl_assq(d, ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*')); - unlikely_if (pair == ECL_NIL) { - FEreader_error("#~D# is undefined.", in, 1, d); - } else { - cl_object value = ECL_CONS_CDR(pair); - ecl_return1(the_env, (value == OBJNULL)? pair : value); - } + if (read_suppress) + ecl_return1(the_env, ECL_NIL); + unlikely_if (Null(d)) { + FEreader_error("The ## readmacro requires an argument.", in, 0); + } + pair = ecl_assq(d, ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*')); + unlikely_if (pair == ECL_NIL) { + FEreader_error("#~D# is undefined.", in, 1, d); + } else { + cl_object value = ECL_CONS_CDR(pair); + ecl_return1(the_env, (value == OBJNULL)? pair : value); + } } static cl_object do_patch_sharp(cl_object x, cl_object table) #if 1 { - /* The hash table maintains an association as follows: - * - * [1] object -> itself - * The object has been processed by patch_sharp, us as it is. - * [2] object -> nothing - * The object has to be processed by do_patch_sharp. - * [3] (# . object) -> object - * This is the value of a #n# statement. The object migt - * or might not yet be processed by do_patch_sharp(). - */ + /* The hash table maintains an association as follows: + * + * [1] object -> itself + * The object has been processed by patch_sharp, us as it is. + * [2] object -> nothing + * The object has to be processed by do_patch_sharp. + * [3] (# . object) -> object + * This is the value of a #n# statement. The object migt + * or might not yet be processed by do_patch_sharp(). + */ AGAIN: - switch (ecl_t_of(x)) { - case t_list: { - cl_object y; - if (Null(x)) - return x; - y = ecl_gethash_safe(x, table, table); - if (y == table) { - /* case [2] */ - break; - } else if (y == x) { - /* case [1] */ - return x; - } else { - /* case [3] */ - x = y; - goto AGAIN; - } - } - case t_vector: - case t_array: - case t_complex: - case t_bclosure: - case t_bytecodes: { - cl_object y = ecl_gethash_safe(x, table, table); - if (y == table) { - /* case [2] */ - break; - } - /* it can only be case [1] */ - } - default: - return x; - } - /* We eagerly mark the object as processed, to avoid infinite - * recursion. */ - _ecl_sethash(x, table, x); - switch (ecl_t_of(x)) { - case t_list: - ECL_RPLACA(x, do_patch_sharp(ECL_CONS_CAR(x), table)); - ECL_RPLACD(x, do_patch_sharp(ECL_CONS_CDR(x), table)); - break; - case t_vector: - if (x->vector.elttype == ecl_aet_object) { - cl_index i; - for (i = 0; i < x->vector.fillp; i++) - x->vector.self.t[i] = - do_patch_sharp(x->vector.self.t[i], table); - } - break; - case t_array: - if (x->vector.elttype == ecl_aet_object) { - cl_index i, j = x->array.dim; - for (i = 0; i < j; i++) - x->array.self.t[i] = - do_patch_sharp(x->array.self.t[i], table); - } - break; - case t_complex: { - cl_object r = do_patch_sharp(x->complex.real, table); - cl_object i = do_patch_sharp(x->complex.imag, table); - if (r != x->complex.real || i != x->complex.imag) { - cl_object c = ecl_make_complex(r, i); - x->complex = c->complex; - } - break; - } - case t_bclosure: { - x->bclosure.lex = do_patch_sharp(x->bclosure.lex, table); - x = x->bclosure.code = do_patch_sharp(x->bclosure.code, table); - break; - } - case t_bytecodes: { - x->bytecodes.name = do_patch_sharp(x->bytecodes.name, table); - x->bytecodes.definition = do_patch_sharp(x->bytecodes.definition, table); - x->bytecodes.data = do_patch_sharp(x->bytecodes.data, table); - break; - } - default:; - } - return x; + switch (ecl_t_of(x)) { + case t_list: { + cl_object y; + if (Null(x)) + return x; + y = ecl_gethash_safe(x, table, table); + if (y == table) { + /* case [2] */ + break; + } else if (y == x) { + /* case [1] */ + return x; + } else { + /* case [3] */ + x = y; + goto AGAIN; + } + } + case t_vector: + case t_array: + case t_complex: + case t_bclosure: + case t_bytecodes: { + cl_object y = ecl_gethash_safe(x, table, table); + if (y == table) { + /* case [2] */ + break; + } + /* it can only be case [1] */ + } + default: + return x; + } + /* We eagerly mark the object as processed, to avoid infinite + * recursion. */ + _ecl_sethash(x, table, x); + switch (ecl_t_of(x)) { + case t_list: + ECL_RPLACA(x, do_patch_sharp(ECL_CONS_CAR(x), table)); + ECL_RPLACD(x, do_patch_sharp(ECL_CONS_CDR(x), table)); + break; + case t_vector: + if (x->vector.elttype == ecl_aet_object) { + cl_index i; + for (i = 0; i < x->vector.fillp; i++) + x->vector.self.t[i] = + do_patch_sharp(x->vector.self.t[i], table); + } + break; + case t_array: + if (x->vector.elttype == ecl_aet_object) { + cl_index i, j = x->array.dim; + for (i = 0; i < j; i++) + x->array.self.t[i] = + do_patch_sharp(x->array.self.t[i], table); + } + break; + case t_complex: { + cl_object r = do_patch_sharp(x->complex.real, table); + cl_object i = do_patch_sharp(x->complex.imag, table); + if (r != x->complex.real || i != x->complex.imag) { + cl_object c = ecl_make_complex(r, i); + x->complex = c->complex; + } + break; + } + case t_bclosure: { + x->bclosure.lex = do_patch_sharp(x->bclosure.lex, table); + x = x->bclosure.code = do_patch_sharp(x->bclosure.code, table); + break; + } + case t_bytecodes: { + x->bytecodes.name = do_patch_sharp(x->bytecodes.name, table); + x->bytecodes.definition = do_patch_sharp(x->bytecodes.definition, table); + x->bytecodes.data = do_patch_sharp(x->bytecodes.data, table); + break; + } + default:; + } + return x; } #else { - switch (ecl_t_of(x)) { - case t_list: - if (Null(x)) - return x; - case t_vector: - case t_array: - case t_complex: - case t_bclosure: - case t_bytecodes: { - cl_object y = ecl_gethash_safe(x, table, table); - if (y == table) - break; - x = y; - } - default: - return x; - } - switch (ecl_t_of(x)) { - case t_list: - ECL_RPLACA(x, do_patch_sharp(ECL_CONS_CAR(x), table)); - ECL_RPLACD(x, do_patch_sharp(ECL_CONS_CDR(x), table)); - break; - case t_vector: - if (x->vector.elttype == ecl_aet_object) { - cl_index i; - for (i = 0; i < x->vector.fillp; i++) - x->vector.self.t[i] = - do_patch_sharp(x->vector.self.t[i], table); - } - break; - case t_array: - if (x->vector.elttype == ecl_aet_object) { - cl_index i, j = x->array.dim; - for (i = 0; i < j; i++) - x->array.self.t[i] = - do_patch_sharp(x->array.self.t[i], table); - } - break; - case t_complex: { - cl_object r = do_patch_sharp(x->complex.real, table); - cl_object i = do_patch_sharp(x->complex.imag, table); - if (r != x->complex.real || i != x->complex.imag) { - cl_object c = ecl_make_complex(r, i); - x->complex = c->complex; - } - break; - } - case t_bclosure: { - x->bclosure.lex = do_patch_sharp(x->bclosure.lex, table); - x = x->bclosure.code = do_patch_sharp(x->bclosure.code, table); - break; - } - case t_bytecodes: { - x->bytecodes.name = do_patch_sharp(x->bytecodes.name, table); - x->bytecodes.definition = do_patch_sharp(x->bytecodes.definition, table); - x->bytecodes.data = do_patch_sharp(x->bytecodes.data, table); - break; - } - default:; - } - _ecl_sethash(x, table, x); - return x; + switch (ecl_t_of(x)) { + case t_list: + if (Null(x)) + return x; + case t_vector: + case t_array: + case t_complex: + case t_bclosure: + case t_bytecodes: { + cl_object y = ecl_gethash_safe(x, table, table); + if (y == table) + break; + x = y; + } + default: + return x; + } + switch (ecl_t_of(x)) { + case t_list: + ECL_RPLACA(x, do_patch_sharp(ECL_CONS_CAR(x), table)); + ECL_RPLACD(x, do_patch_sharp(ECL_CONS_CDR(x), table)); + break; + case t_vector: + if (x->vector.elttype == ecl_aet_object) { + cl_index i; + for (i = 0; i < x->vector.fillp; i++) + x->vector.self.t[i] = + do_patch_sharp(x->vector.self.t[i], table); + } + break; + case t_array: + if (x->vector.elttype == ecl_aet_object) { + cl_index i, j = x->array.dim; + for (i = 0; i < j; i++) + x->array.self.t[i] = + do_patch_sharp(x->array.self.t[i], table); + } + break; + case t_complex: { + cl_object r = do_patch_sharp(x->complex.real, table); + cl_object i = do_patch_sharp(x->complex.imag, table); + if (r != x->complex.real || i != x->complex.imag) { + cl_object c = ecl_make_complex(r, i); + x->complex = c->complex; + } + break; + } + case t_bclosure: { + x->bclosure.lex = do_patch_sharp(x->bclosure.lex, table); + x = x->bclosure.code = do_patch_sharp(x->bclosure.code, table); + break; + } + case t_bytecodes: { + x->bytecodes.name = do_patch_sharp(x->bytecodes.name, table); + x->bytecodes.definition = do_patch_sharp(x->bytecodes.definition, table); + x->bytecodes.data = do_patch_sharp(x->bytecodes.data, table); + break; + } + default:; + } + _ecl_sethash(x, table, x); + return x; } #endif static cl_object patch_sharp(const cl_env_ptr the_env, cl_object x) { - cl_object pairs = ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*'); - if (pairs == ECL_NIL) { - return x; - } else { - cl_object table = - cl__make_hash_table(@'eq', ecl_make_fixnum(20), /* size */ - cl_core.rehash_size, - cl_core.rehash_threshold); - do { - cl_object pair = ECL_CONS_CAR(pairs); - _ecl_sethash(pair, table, ECL_CONS_CDR(pair)); - pairs = ECL_CONS_CDR(pairs); - } while (pairs != ECL_NIL); - return do_patch_sharp(x, table); - } + cl_object pairs = ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*'); + if (pairs == ECL_NIL) { + return x; + } else { + cl_object table = + cl__make_hash_table(@'eq', ecl_make_fixnum(20), /* size */ + cl_core.rehash_size, + cl_core.rehash_threshold); + do { + cl_object pair = ECL_CONS_CAR(pairs); + _ecl_sethash(pair, table, ECL_CONS_CDR(pair)); + pairs = ECL_CONS_CDR(pairs); + } while (pairs != ECL_NIL); + return do_patch_sharp(x, table); + } } #define sharp_plus_reader void_reader @@ -1323,739 +1321,744 @@ static cl_object sharp_vertical_bar_reader(cl_object in, cl_object ch, cl_object d) { - int c; - int level = 0; + int c; + int level = 0; - if (d != ECL_NIL && !read_suppress) - extra_argument('|', in, d); - for (;;) { - c = ecl_read_char_noeof(in); - L: - if (c == '#') { - c = ecl_read_char_noeof(in); - if (c == '|') - level++; - } else if (c == '|') { - c = ecl_read_char_noeof(in); - if (c == '#') { - if (level == 0) - break; - else - --level; - } else - goto L; - } - } - @(return) - /* no result */ + if (d != ECL_NIL && !read_suppress) + extra_argument('|', in, d); + for (;;) { + c = ecl_read_char_noeof(in); + L: + if (c == '#') { + c = ecl_read_char_noeof(in); + if (c == '|') + level++; + } else if (c == '|') { + c = ecl_read_char_noeof(in); + if (c == '#') { + if (level == 0) + break; + else + --level; + } else + goto L; + } + } + /* no result */ + @(return); } static cl_object default_dispatch_macro_fun(cl_object in, cl_object c, cl_object d) { - FEreader_error("No dispatch function defined for character ~s.", in, 1, c); + FEreader_error("No dispatch function defined for character ~s.", in, 1, c); } /* - #P" ... " returns the pathname with namestring ... . + #P" ... " returns the pathname with namestring ... . */ static cl_object sharp_P_reader(cl_object in, cl_object c, cl_object d) { - bool suppress = read_suppress; - if (d != ECL_NIL && !suppress) - extra_argument('P', in, d); - d = ecl_read_object(in); - if (suppress) { - d = ECL_NIL; - } else { - d = cl_parse_namestring(3, d, ECL_NIL, ECL_NIL); - } - @(return d) + bool suppress = read_suppress; + if (d != ECL_NIL && !suppress) + extra_argument('P', in, d); + d = ecl_read_object(in); + if (suppress) { + d = ECL_NIL; + } else { + d = cl_parse_namestring(3, d, ECL_NIL, ECL_NIL); + } + @(return d); } /* - #$ fixnum returns a random-state with the fixnum - as its content. + #$ fixnum returns a random-state with the fixnum + as its content. */ static cl_object sharp_dollar_reader(cl_object in, cl_object c, cl_object d) { - cl_object rs; - if (d != ECL_NIL && !read_suppress) - extra_argument('$', in, d); - c = ecl_read_object(in); - rs = ecl_make_random_state(c); - @(return rs) + cl_object rs; + if (d != ECL_NIL && !read_suppress) + extra_argument('$', in, d); + c = ecl_read_object(in); + rs = ecl_make_random_state(c); + + @(return rs); } /* - readtable routines + readtable routines */ static void ECL_INLINE assert_type_readtable(cl_object function, cl_narg narg, cl_object p) { - unlikely_if (!ECL_READTABLEP(p)) { - FEwrong_type_nth_arg(function, narg, p, @[readtable]); - } + unlikely_if (!ECL_READTABLEP(p)) { + FEwrong_type_nth_arg(function, narg, p, @[readtable]); + } } cl_object ecl_copy_readtable(cl_object from, cl_object to) { - struct ecl_readtable_entry *from_rtab, *to_rtab; - cl_index i; - size_t entry_bytes = sizeof(struct ecl_readtable_entry); - size_t total_bytes = entry_bytes * RTABSIZE; - cl_object output; - - assert_type_readtable(@[copy-readtable], 1, from); - /* For the sake of garbage collector and thread safety we - * create an incomplete object and only copy to the destination - * at the end in a more or less "atomic" (meaning "fast") way. - */ - output = ecl_alloc_object(t_readtable); - output->readtable.locked = 0; - output->readtable.table = to_rtab = (struct ecl_readtable_entry *) - ecl_alloc_align(total_bytes, entry_bytes); - from_rtab = from->readtable.table; - memcpy(to_rtab, from_rtab, total_bytes); - for (i = 0; i < RTABSIZE; i++) { - cl_object d = from_rtab[i].dispatch; - if (ECL_HASH_TABLE_P(d)) { - d = si_copy_hash_table(d); - } - to_rtab[i].dispatch = d; - } - output->readtable.read_case = from->readtable.read_case; + struct ecl_readtable_entry *from_rtab, *to_rtab; + cl_index i; + size_t entry_bytes = sizeof(struct ecl_readtable_entry); + size_t total_bytes = entry_bytes * RTABSIZE; + cl_object output; + + assert_type_readtable(@[copy-readtable], 1, from); + /* For the sake of garbage collector and thread safety we + * create an incomplete object and only copy to the destination + * at the end in a more or less "atomic" (meaning "fast") way. + */ + output = ecl_alloc_object(t_readtable); + output->readtable.locked = 0; + output->readtable.table = to_rtab = (struct ecl_readtable_entry *) + ecl_alloc_align(total_bytes, entry_bytes); + from_rtab = from->readtable.table; + memcpy(to_rtab, from_rtab, total_bytes); + for (i = 0; i < RTABSIZE; i++) { + cl_object d = from_rtab[i].dispatch; + if (ECL_HASH_TABLE_P(d)) { + d = si_copy_hash_table(d); + } + to_rtab[i].dispatch = d; + } + output->readtable.read_case = from->readtable.read_case; #ifdef ECL_UNICODE - if (!Null(from->readtable.hash)) { - output->readtable.hash = si_copy_hash_table(from->readtable.hash); - } else { - output->readtable.hash = ECL_NIL; - } + if (!Null(from->readtable.hash)) { + output->readtable.hash = si_copy_hash_table(from->readtable.hash); + } else { + output->readtable.hash = ECL_NIL; + } #endif - if (!Null(to)) { - assert_type_readtable(@[copy-readtable], 2, to); - to->readtable = output->readtable; - output = to; - } - return output; + if (!Null(to)) { + assert_type_readtable(@[copy-readtable], 2, to); + to->readtable = output->readtable; + output = to; + } + return output; } cl_object ecl_current_readtable(void) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object r; + const cl_env_ptr the_env = ecl_process_env(); + cl_object r; - /* INV: *readtable* always has a value */ - r = ECL_SYM_VAL(the_env, @'*readtable*'); - unlikely_if (!ECL_READTABLEP(r)) { - ECL_SETQ(the_env, @'*readtable*', cl_core.standard_readtable); - FEerror("The value of *READTABLE*, ~S, was not a readtable.", - 1, r); - } - return r; + /* INV: *readtable* always has a value */ + r = ECL_SYM_VAL(the_env, @'*readtable*'); + unlikely_if (!ECL_READTABLEP(r)) { + ECL_SETQ(the_env, @'*readtable*', cl_core.standard_readtable); + FEerror("The value of *READTABLE*, ~S, was not a readtable.", + 1, r); + } + return r; } int ecl_current_read_base(void) { - const cl_env_ptr the_env = ecl_process_env(); - /* INV: *READ-BASE* always has a value */ - cl_object x = ECL_SYM_VAL(the_env, @'*read-base*'); - cl_fixnum b; - - unlikely_if (!ECL_FIXNUMP(x) || ((b = ecl_fixnum(x)) < 2) || (b > 36)) - { - ECL_SETQ(the_env, @'*read-base*', ecl_make_fixnum(10)); - FEerror("The value of *READ-BASE*~& ~S~%" - "is not in the range (INTEGER 2 36)", 1, x); - } - return b; + const cl_env_ptr the_env = ecl_process_env(); + /* INV: *READ-BASE* always has a value */ + cl_object x = ECL_SYM_VAL(the_env, @'*read-base*'); + cl_fixnum b; + + unlikely_if (!ECL_FIXNUMP(x) || ((b = ecl_fixnum(x)) < 2) || (b > 36)) + { + ECL_SETQ(the_env, @'*read-base*', ecl_make_fixnum(10)); + FEerror("The value of *READ-BASE*~& ~S~%" + "is not in the range (INTEGER 2 36)", 1, x); + } + return b; } char ecl_current_read_default_float_format(void) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object x; + const cl_env_ptr the_env = ecl_process_env(); + cl_object x; - /* INV: *READ-DEFAULT-FLOAT-FORMAT* is always bound to something */ - x = ECL_SYM_VAL(the_env, @'*read-default-float-format*'); - if (x == @'single-float' || x == @'short-float') - return 'F'; - if (x == @'double-float') - return 'D'; - if (x == @'long-float') { + /* INV: *READ-DEFAULT-FLOAT-FORMAT* is always bound to something */ + x = ECL_SYM_VAL(the_env, @'*read-default-float-format*'); + if (x == @'single-float' || x == @'short-float') + return 'F'; + if (x == @'double-float') + return 'D'; + if (x == @'long-float') { #ifdef ECL_LONG_FLOAT - return 'L'; + return 'L'; #else - return 'D'; + return 'D'; #endif - } - ECL_SETQ(the_env, @'*read-default-float-format*', @'single-float'); - FEerror("The value of *READ-DEFAULT-FLOAT-FORMAT*~& ~S~%" - "is not one of (SINGLE-FLOAT SHORT-FLOAT DOUBLE-FLOAT LONG-FLOAT)", - 1, x); + } + ECL_SETQ(the_env, @'*read-default-float-format*', @'single-float'); + FEerror("The value of *READ-DEFAULT-FLOAT-FORMAT*~& ~S~%" + "is not one of (SINGLE-FLOAT SHORT-FLOAT DOUBLE-FLOAT LONG-FLOAT)", + 1, x); } static cl_object stream_or_default_input(cl_object stream) { - const cl_env_ptr the_env = ecl_process_env(); - if (Null(stream)) - return ECL_SYM_VAL(the_env, @'*standard-input*'); - if (stream == ECL_T) - return ECL_SYM_VAL(the_env, @'*terminal-io*'); - return stream; + const cl_env_ptr the_env = ecl_process_env(); + if (Null(stream)) + return ECL_SYM_VAL(the_env, @'*standard-input*'); + if (stream == ECL_T) + return ECL_SYM_VAL(the_env, @'*terminal-io*'); + return stream; } @(defun read (&optional (strm ECL_NIL) (eof_errorp ECL_T) eof_value recursivep) - cl_object x; -@ - strm = stream_or_default_input(strm); - if (Null(recursivep)) { - x = ecl_read_object_non_recursive(strm); - } else { - x = ecl_read_object(strm); - } - if (x == OBJNULL) { - if (Null(eof_errorp)) - @(return eof_value) - FEend_of_file(strm); - } - /* Skip whitespace characters, but stop at beginning of new line or token */ - if (Null(recursivep)) { - cl_object rtbl = ecl_current_readtable(); - int c = ecl_read_char(strm); - if (c != EOF && (ecl_readtable_get(rtbl, c, NULL) != cat_whitespace)) { - ecl_unread_char(c, strm); - } - } - @(return x) -@) + cl_object x; + @ + strm = stream_or_default_input(strm); + if (Null(recursivep)) { + x = ecl_read_object_non_recursive(strm); + } else { + x = ecl_read_object(strm); + } + if (x == OBJNULL) { + if (Null(eof_errorp)) { + @(return eof_value); + } + FEend_of_file(strm); + } + /* Skip whitespace characters, but stop at beginning of new line or token */ + if (Null(recursivep)) { + cl_object rtbl = ecl_current_readtable(); + int c = ecl_read_char(strm); + if (c != EOF && (ecl_readtable_get(rtbl, c, NULL) != cat_whitespace)) { + ecl_unread_char(c, strm); + } + } + @(return x); + @) @(defun read_preserving_whitespace - (&optional (strm ECL_NIL) - (eof_errorp ECL_T) - eof_value - recursivep) - cl_object x; -@ - strm = stream_or_default_input(strm); - if (Null(recursivep)) { - x = ecl_read_object_non_recursive(strm); - } else { - x = ecl_read_object(strm); - } - if (x == OBJNULL) { - if (Null(eof_errorp)) - @(return eof_value) - FEend_of_file(strm); - } - @(return x) -@) + (&optional (strm ECL_NIL) + (eof_errorp ECL_T) + eof_value + recursivep) + cl_object x; + @ + strm = stream_or_default_input(strm); + if (Null(recursivep)) { + x = ecl_read_object_non_recursive(strm); + } else { + x = ecl_read_object(strm); + } + if (x == OBJNULL) { + if (Null(eof_errorp)) + @(return eof_value); + FEend_of_file(strm); + } + @(return x); + @) static cl_object do_read_delimited_list(int d, cl_object in, bool proper_list) { - int after_dot = 0; - bool suppress = read_suppress; - cl_object x, y = ECL_NIL; - cl_object *p = &y; - do { - x = ecl_read_object_with_delimiter(in, d, ECL_READ_LIST_DOT, - cat_constituent); - if (x == OBJNULL) { - /* End of the list. */ - unlikely_if (after_dot == 1) { - /* Something like (1 . ) */ - FEreader_error("Object missing after a list dot", in, 0); - } - return y; - } else if (x == @'si::.') { - unlikely_if (proper_list) { - FEreader_error("A dotted list was found where a proper list was expected.", in, 0); - } - unlikely_if (p == &y) { - /* Something like (. 2) */ - FEreader_error("A dot appeared after a left parenthesis.", in, 0); - } - unlikely_if (after_dot) { - /* Something like (1 . . 2) */ - FEreader_error("Two dots appeared consecutively.", in, 0); - } - after_dot = 1; - } else if (after_dot) { - unlikely_if (after_dot++ > 1) { - /* Something like (1 . 2 3) */ - FEreader_error("Too many objects after a list dot", in, 0); - } - *p = x; - } else if (!suppress) { - *p = ecl_list1(x); - p = &ECL_CONS_CDR(*p); - } - } while (1); + int after_dot = 0; + bool suppress = read_suppress; + cl_object x, y = ECL_NIL; + cl_object *p = &y; + do { + x = ecl_read_object_with_delimiter(in, d, ECL_READ_LIST_DOT, + cat_constituent); + if (x == OBJNULL) { + /* End of the list. */ + unlikely_if (after_dot == 1) { + /* Something like (1 . ) */ + FEreader_error("Object missing after a list dot", in, 0); + } + return y; + } else if (x == @'si::.') { + unlikely_if (proper_list) { + FEreader_error("A dotted list was found where a proper list was expected.", in, 0); + } + unlikely_if (p == &y) { + /* Something like (. 2) */ + FEreader_error("A dot appeared after a left parenthesis.", in, 0); + } + unlikely_if (after_dot) { + /* Something like (1 . . 2) */ + FEreader_error("Two dots appeared consecutively.", in, 0); + } + after_dot = 1; + } else if (after_dot) { + unlikely_if (after_dot++ > 1) { + /* Something like (1 . 2 3) */ + FEreader_error("Too many objects after a list dot", in, 0); + } + *p = x; + } else if (!suppress) { + *p = ecl_list1(x); + p = &ECL_CONS_CDR(*p); + } + } while (1); } @(defun read_delimited_list (d &optional (strm ECL_NIL) recursivep) - cl_object l; - int delimiter; -@ - delimiter = ecl_char_code(d); - strm = stream_or_default_input(strm); - if (!Null(recursivep)) { - l = do_read_delimited_list(delimiter, strm, 1); - } else { - ecl_bds_bind(the_env, @'si::*sharp-eq-context*', ECL_NIL); - ecl_bds_bind(the_env, @'si::*backq-level*', ecl_make_fixnum(0)); - l = do_read_delimited_list(delimiter, strm, 1); - l = patch_sharp(the_env, l); - ecl_bds_unwind_n(the_env, 2); - } - @(return l) -@) + cl_object l; + int delimiter; + @ + delimiter = ecl_char_code(d); + strm = stream_or_default_input(strm); + if (!Null(recursivep)) { + l = do_read_delimited_list(delimiter, strm, 1); + } else { + ecl_bds_bind(the_env, @'si::*sharp-eq-context*', ECL_NIL); + ecl_bds_bind(the_env, @'si::*backq-level*', ecl_make_fixnum(0)); + l = do_read_delimited_list(delimiter, strm, 1); + l = patch_sharp(the_env, l); + ecl_bds_unwind_n(the_env, 2); + } + @(return l); + @) @(defun read_line (&optional (strm ECL_NIL) (eof_errorp ECL_T) eof_value recursivep) - int c; - cl_object token, value0, value1; -@ - strm = stream_or_default_input(strm); + int c; + cl_object token, value0, value1; + @ + strm = stream_or_default_input(strm); #ifdef ECL_CLOS_STREAMS - if (!ECL_ANSI_STREAM_P(strm)) { - value0 = _ecl_funcall2(@'gray::stream-read-line', strm); - value1 = ecl_nth_value(the_env, 1); - if (!Null(value1)) { - if (!Null(eof_errorp)) - FEend_of_file(strm); - value0 = eof_value; - value1 = ECL_T; - } - goto OUTPUT; - } + if (!ECL_ANSI_STREAM_P(strm)) { + value0 = _ecl_funcall2(@'gray::stream-read-line', strm); + value1 = ecl_nth_value(the_env, 1); + if (!Null(value1)) { + if (!Null(eof_errorp)) + FEend_of_file(strm); + value0 = eof_value; + value1 = ECL_T; + } + goto OUTPUT; + } #endif - token = si_get_buffer_string(); - do { - c = ecl_read_char(strm); - if (c == EOF || c == '\n') - break; - ecl_string_push_extend(token, c); - } while(1); - if (c == EOF && TOKEN_STRING_FILLP(token) == 0) { - if (!Null(eof_errorp)) - FEend_of_file(strm); - value0 = eof_value; - value1 = ECL_T; - } else { + token = si_get_buffer_string(); + do { + c = ecl_read_char(strm); + if (c == EOF || c == '\n') + break; + ecl_string_push_extend(token, c); + } while(1); + if (c == EOF && TOKEN_STRING_FILLP(token) == 0) { + if (!Null(eof_errorp)) + FEend_of_file(strm); + value0 = eof_value; + value1 = ECL_T; + } else { #ifdef ECL_NEWLINE_IS_CRLF /* From \r\n, ignore \r */ - if (TOKEN_STRING_FILLP(token) > 0 && - TOKEN_STRING_CHAR_CMP(token,TOKEN_STRING_FILLP(token)-1,'\r')) - TOKEN_STRING_FILLP(token)--; + if (TOKEN_STRING_FILLP(token) > 0 && + TOKEN_STRING_CHAR_CMP(token,TOKEN_STRING_FILLP(token)-1,'\r')) + TOKEN_STRING_FILLP(token)--; #endif #ifdef ECL_NEWLINE_IS_LFCR /* From \n\r, ignore \r */ - ecl_read_char(strm); + ecl_read_char(strm); #endif - value0 = cl_copy_seq(token); - value1 = (c == EOF? ECL_T : ECL_NIL); - } - si_put_buffer_string(token); + value0 = cl_copy_seq(token); + value1 = (c == EOF? ECL_T : ECL_NIL); + } + si_put_buffer_string(token); OUTPUT: - @(return value0 value1) -@) + @(return value0 value1); + @) @(defun read-char (&optional (strm ECL_NIL) (eof_errorp ECL_T) eof_value recursivep) - int c; - cl_object output; -@ - strm = stream_or_default_input(strm); - c = ecl_read_char(strm); - if (c != EOF) - output = ECL_CODE_CHAR(c); - else if (Null(eof_errorp)) - output = eof_value; - else - FEend_of_file(strm); - @(return output) -@) + int c; + cl_object output; + @ + strm = stream_or_default_input(strm); + c = ecl_read_char(strm); + if (c != EOF) + output = ECL_CODE_CHAR(c); + else if (Null(eof_errorp)) + output = eof_value; + else + FEend_of_file(strm); + @(return output); + @) @(defun unread_char (c &optional (strm ECL_NIL)) -@ - /* INV: unread_char() checks the type `c' */ - strm = stream_or_default_input(strm); - ecl_unread_char(ecl_char_code(c), strm); - @(return ECL_NIL) -@) + @ + /* INV: unread_char() checks the type `c' */ + strm = stream_or_default_input(strm); + ecl_unread_char(ecl_char_code(c), strm); + @(return ECL_NIL); + @) @(defun peek-char (&optional peek_type (strm ECL_NIL) (eof_errorp ECL_T) eof_value recursivep) - int c; - cl_object rtbl = ecl_current_readtable(); -@ - strm = stream_or_default_input(strm); + int c; + cl_object rtbl = ecl_current_readtable(); + @ + strm = stream_or_default_input(strm); + c = ecl_peek_char(strm); + if (c != EOF && !Null(peek_type)) { + if (peek_type == ECL_T) { + do { + /* If the character is not a whitespace, output */ + if (ecl_readtable_get(rtbl, c, NULL) != cat_whitespace) + break; + /* Otherwise, read the whitespace and peek the + * next character */ + ecl_read_char(strm); c = ecl_peek_char(strm); - if (c != EOF && !Null(peek_type)) { - if (peek_type == ECL_T) { - do { - /* If the character is not a whitespace, output */ - if (ecl_readtable_get(rtbl, c, NULL) != cat_whitespace) - break; - /* Otherwise, read the whitespace and peek the - * next character */ - ecl_read_char(strm); - c = ecl_peek_char(strm); - } while (c != EOF); - } else { - do { - /* If the character belongs to the given class, - * we're done. */ - if (ecl_char_eq(ECL_CODE_CHAR(c), peek_type)) - break; - /* Otherwise, consume the character and - * peek the next one. */ - ecl_read_char(strm); - c = ecl_peek_char(strm); - } while (c != EOF); - } - } - if (c != EOF) { - eof_value = ECL_CODE_CHAR(c); - } else if (!Null(eof_errorp)) { - FEend_of_file(strm); - } - @(return eof_value) -@) + } while (c != EOF); + } else { + do { + /* If the character belongs to the given class, + * we're done. */ + if (ecl_char_eq(ECL_CODE_CHAR(c), peek_type)) + break; + /* Otherwise, consume the character and + * peek the next one. */ + ecl_read_char(strm); + c = ecl_peek_char(strm); + } while (c != EOF); + } + } + if (c != EOF) { + eof_value = ECL_CODE_CHAR(c); + } else if (!Null(eof_errorp)) { + FEend_of_file(strm); + } + @(return eof_value); + @) @(defun listen (&optional (strm ECL_NIL)) -@ - strm = stream_or_default_input(strm); - @(return ((ecl_listen_stream(strm) == ECL_LISTEN_AVAILABLE)? ECL_T : ECL_NIL)) -@) + @ + strm = stream_or_default_input(strm); + @(return ((ecl_listen_stream(strm) == ECL_LISTEN_AVAILABLE)? ECL_T : ECL_NIL)); + @) @(defun read_char_no_hang (&optional (strm ECL_NIL) (eof_errorp ECL_T) eof_value recursivep) - int f; -@ - strm = stream_or_default_input(strm); + int f; + @ + strm = stream_or_default_input(strm); #ifdef ECL_CLOS_STREAMS - if (!ECL_ANSI_STREAM_P(strm)) { - cl_object output = - _ecl_funcall2(@'gray::stream-read-char-no-hang', strm); - if (output == @':eof') - goto END_OF_FILE; - @(return output); - } + if (!ECL_ANSI_STREAM_P(strm)) { + cl_object output = + _ecl_funcall2(@'gray::stream-read-char-no-hang', strm); + if (output == @':eof') + goto END_OF_FILE; + @(return output); + } #endif - f = ecl_listen_stream(strm); - if (f == ECL_LISTEN_AVAILABLE) { - int c = ecl_read_char(strm); - if (c != EOF) { - @(return ECL_CODE_CHAR(c)); - } - } else if (f == ECL_LISTEN_NO_CHAR) { - @(return @'nil'); - } - /* We reach here if there was an EOF */ - END_OF_FILE: - if (Null(eof_errorp)) - @(return eof_value) - else - FEend_of_file(strm); -@) + f = ecl_listen_stream(strm); + if (f == ECL_LISTEN_AVAILABLE) { + int c = ecl_read_char(strm); + if (c != EOF) { + @(return ECL_CODE_CHAR(c)); + } + } else if (f == ECL_LISTEN_NO_CHAR) { + @(return @'nil'); + } + /* We reach here if there was an EOF */ + END_OF_FILE: + if (Null(eof_errorp)) { + @(return eof_value); + } + else { + FEend_of_file(strm); + } + @) @(defun clear_input (&optional (strm ECL_NIL)) -@ - strm = stream_or_default_input(strm); - ecl_clear_input(strm); - @(return ECL_NIL) -@) + @ + strm = stream_or_default_input(strm); + ecl_clear_input(strm); + @(return ECL_NIL); + @) @(defun read_byte (binary_input_stream &optional (eof_errorp ECL_T) eof_value) - cl_object c; -@ - c = ecl_read_byte(binary_input_stream); - if (c == ECL_NIL) { - if (Null(eof_errorp)) - @(return eof_value) - else - FEend_of_file(binary_input_stream); - } - @(return c) -@) + cl_object c; + @ + c = ecl_read_byte(binary_input_stream); + if (c == ECL_NIL) { + if (Null(eof_errorp)) { + @(return eof_value); + } + else + FEend_of_file(binary_input_stream); + } + @(return c); + @) @(defun read_sequence (sequence stream &key (start ecl_make_fixnum(0)) end) -@ + @ #ifdef ECL_CLOS_STREAMS - if (!ECL_ANSI_STREAM_P(stream)) - return funcall(5, @'gray::stream-read-sequence', stream, sequence, start, end); - else + if (!ECL_ANSI_STREAM_P(stream)) + return funcall(5, @'gray::stream-read-sequence', stream, sequence, start, end); + else #endif - return si_do_read_sequence(sequence, stream, start, end); -@) + return si_do_read_sequence(sequence, stream, start, end); + @) @(defun copy_readtable (&o (from ecl_current_readtable()) to) -@ - if (Null(from)) { - to = ecl_copy_readtable(cl_core.standard_readtable, to); - } else { - to = ecl_copy_readtable(from, to); - } - @(return to) -@) + @ + if (Null(from)) { + to = ecl_copy_readtable(cl_core.standard_readtable, to); + } else { + to = ecl_copy_readtable(from, to); + } + @(return to); + @) cl_object cl_readtable_case(cl_object r) { - assert_type_readtable(@[readtable-case], 1, r); - switch (r->readtable.read_case) { - case ecl_case_upcase: r = @':upcase'; break; - case ecl_case_downcase: r = @':downcase'; break; - case ecl_case_invert: r = @':invert'; break; - case ecl_case_preserve: r = @':preserve'; - } - @(return r) + assert_type_readtable(@[readtable-case], 1, r); + switch (r->readtable.read_case) { + case ecl_case_upcase: r = @':upcase'; break; + case ecl_case_downcase: r = @':downcase'; break; + case ecl_case_invert: r = @':invert'; break; + case ecl_case_preserve: r = @':preserve'; + } + @(return r); } static void error_locked_readtable(cl_object r) { - cl_error(2, - make_constant_base_string("Cannot modify locked readtable ~A."), - r); + cl_error(2, + make_constant_base_string("Cannot modify locked readtable ~A."), + r); } cl_object si_readtable_case_set(cl_object r, cl_object mode) { - assert_type_readtable(@[readtable-case], 1, r); - if (r->readtable.locked) { - error_locked_readtable(r); - } - if (mode == @':upcase') { - r->readtable.read_case = ecl_case_upcase; - } else if (mode == @':downcase') { - r->readtable.read_case = ecl_case_downcase; - } else if (mode == @':preserve') { - r->readtable.read_case = ecl_case_preserve; - } else if (mode == @':invert') { - r->readtable.read_case = ecl_case_invert; - } else { - const char *type = "(member :upcase :downcase :preserve :invert)"; - FEwrong_type_nth_arg(@[si::readtable-case-set], 2, - mode, ecl_read_from_cstring(type)); - } - @(return mode) + assert_type_readtable(@[readtable-case], 1, r); + if (r->readtable.locked) { + error_locked_readtable(r); + } + if (mode == @':upcase') { + r->readtable.read_case = ecl_case_upcase; + } else if (mode == @':downcase') { + r->readtable.read_case = ecl_case_downcase; + } else if (mode == @':preserve') { + r->readtable.read_case = ecl_case_preserve; + } else if (mode == @':invert') { + r->readtable.read_case = ecl_case_invert; + } else { + const char *type = "(member :upcase :downcase :preserve :invert)"; + FEwrong_type_nth_arg(@[si::readtable-case-set], 2, + mode, ecl_read_from_cstring(type)); + } + @(return mode); } cl_object cl_readtablep(cl_object readtable) { - @(return (ECL_READTABLEP(readtable) ? ECL_T : ECL_NIL)) + @(return (ECL_READTABLEP(readtable) ? ECL_T : ECL_NIL)); } int ecl_readtable_get(cl_object readtable, int c, cl_object *macro_or_table) { - cl_object m; - enum ecl_chattrib cat; + cl_object m; + enum ecl_chattrib cat; #ifdef ECL_UNICODE - if (c >= RTABSIZE) { - cl_object hash = readtable->readtable.hash; - cat = cat_constituent; - m = ECL_NIL; - if (!Null(hash)) { - cl_object pair = ecl_gethash_safe(ECL_CODE_CHAR(c), hash, ECL_NIL); - if (!Null(pair)) { - cat = ecl_fixnum(ECL_CONS_CAR(pair)); - m = ECL_CONS_CDR(pair); - } - } - } else + if (c >= RTABSIZE) { + cl_object hash = readtable->readtable.hash; + cat = cat_constituent; + m = ECL_NIL; + if (!Null(hash)) { + cl_object pair = ecl_gethash_safe(ECL_CODE_CHAR(c), hash, ECL_NIL); + if (!Null(pair)) { + cat = ecl_fixnum(ECL_CONS_CAR(pair)); + m = ECL_CONS_CDR(pair); + } + } + } else #endif - { - m = readtable->readtable.table[c].dispatch; - cat = readtable->readtable.table[c].syntax_type; - } - if (macro_or_table) *macro_or_table = m; - return cat; + { + m = readtable->readtable.table[c].dispatch; + cat = readtable->readtable.table[c].syntax_type; + } + if (macro_or_table) *macro_or_table = m; + return cat; } void ecl_readtable_set(cl_object readtable, int c, enum ecl_chattrib cat, - cl_object macro_or_table) + cl_object macro_or_table) { - if (readtable->readtable.locked) { - error_locked_readtable(readtable); - } + if (readtable->readtable.locked) { + error_locked_readtable(readtable); + } #ifdef ECL_UNICODE - if (c >= RTABSIZE) { - cl_object hash = readtable->readtable.hash; - if (Null(hash)) { - hash = cl__make_hash_table(@'eql', ecl_make_fixnum(128), - cl_core.rehash_size, - cl_core.rehash_threshold); - readtable->readtable.hash = hash; - } - _ecl_sethash(ECL_CODE_CHAR(c), hash, - CONS(ecl_make_fixnum(cat), macro_or_table)); - } else + if (c >= RTABSIZE) { + cl_object hash = readtable->readtable.hash; + if (Null(hash)) { + hash = cl__make_hash_table(@'eql', ecl_make_fixnum(128), + cl_core.rehash_size, + cl_core.rehash_threshold); + readtable->readtable.hash = hash; + } + _ecl_sethash(ECL_CODE_CHAR(c), hash, + CONS(ecl_make_fixnum(cat), macro_or_table)); + } else #endif - { - readtable->readtable.table[c].dispatch = macro_or_table; - readtable->readtable.table[c].syntax_type = cat; - } + { + readtable->readtable.table[c].dispatch = macro_or_table; + readtable->readtable.table[c].syntax_type = cat; + } } bool ecl_invalid_character_p(int c) { - return (c <= 32) || (c == 127); + return (c <= 32) || (c == 127); } @(defun set_syntax_from_char (tochr fromchr &o (tordtbl ecl_current_readtable()) - fromrdtbl) - enum ecl_chattrib cat; - cl_object dispatch; - cl_fixnum fc, tc; -@ - if (tordtbl->readtable.locked) { - error_locked_readtable(tordtbl); - } - if (Null(fromrdtbl)) - fromrdtbl = cl_core.standard_readtable; - assert_type_readtable(@[readtable-case], 1, tordtbl); - assert_type_readtable(@[readtable-case], 2, fromrdtbl); - fc = ecl_char_code(fromchr); - tc = ecl_char_code(tochr); - - cat = ecl_readtable_get(fromrdtbl, fc, &dispatch); - if (ECL_READTABLEP(dispatch)) { - dispatch = si_copy_hash_table(dispatch); - } - ecl_readtable_set(tordtbl, tc, cat, dispatch); - @(return ECL_T) -@) + fromrdtbl) + enum ecl_chattrib cat; + cl_object dispatch; + cl_fixnum fc, tc; + @ + if (tordtbl->readtable.locked) { + error_locked_readtable(tordtbl); + } + if (Null(fromrdtbl)) + fromrdtbl = cl_core.standard_readtable; + assert_type_readtable(@[readtable-case], 1, tordtbl); + assert_type_readtable(@[readtable-case], 2, fromrdtbl); + fc = ecl_char_code(fromchr); + tc = ecl_char_code(tochr); + + cat = ecl_readtable_get(fromrdtbl, fc, &dispatch); + if (ECL_READTABLEP(dispatch)) { + dispatch = si_copy_hash_table(dispatch); + } + ecl_readtable_set(tordtbl, tc, cat, dispatch); + @(return ECL_T); + @) @(defun set_macro_character (c function &optional non_terminating_p (readtable ecl_current_readtable())) -@ - ecl_readtable_set(readtable, ecl_char_code(c), - Null(non_terminating_p)? - cat_terminating : - cat_non_terminating, - function); - @(return ECL_T) -@) + @ + ecl_readtable_set(readtable, ecl_char_code(c), + Null(non_terminating_p)? + cat_terminating : + cat_non_terminating, + function); + @(return ECL_T); + @) @(defun get_macro_character (c &optional (readtable ecl_current_readtable())) - enum ecl_chattrib cat; - cl_object dispatch; -@ - if (Null(readtable)) - readtable = cl_core.standard_readtable; - cat = ecl_readtable_get(readtable, ecl_char_code(c), &dispatch); - if (ECL_HASH_TABLE_P(dispatch)) - dispatch = cl_core.dispatch_reader; - @(return dispatch ((cat == cat_non_terminating)? ECL_T : ECL_NIL)) -@) + enum ecl_chattrib cat; + cl_object dispatch; + @ + if (Null(readtable)) + readtable = cl_core.standard_readtable; + cat = ecl_readtable_get(readtable, ecl_char_code(c), &dispatch); + if (ECL_HASH_TABLE_P(dispatch)) + dispatch = cl_core.dispatch_reader; + @(return dispatch ((cat == cat_non_terminating)? ECL_T : ECL_NIL)); + @) @(defun make_dispatch_macro_character (chr - &optional non_terminating_p (readtable ecl_current_readtable())) - enum ecl_chattrib cat; - cl_object table; - int c; -@ - assert_type_readtable(@[make-dispatch-macro-character], 3, readtable); - c = ecl_char_code(chr); - cat = Null(non_terminating_p)? cat_terminating : cat_non_terminating; - table = cl__make_hash_table(@'eql', ecl_make_fixnum(128), - cl_core.rehash_size, - cl_core.rehash_threshold); - ecl_readtable_set(readtable, c, cat, table); - @(return ECL_T) -@) + &optional non_terminating_p (readtable ecl_current_readtable())) + enum ecl_chattrib cat; + cl_object table; + int c; + @ + assert_type_readtable(@[make-dispatch-macro-character], 3, readtable); + c = ecl_char_code(chr); + cat = Null(non_terminating_p)? cat_terminating : cat_non_terminating; + table = cl__make_hash_table(@'eql', ecl_make_fixnum(128), + cl_core.rehash_size, + cl_core.rehash_threshold); + ecl_readtable_set(readtable, c, cat, table); + @(return ECL_T); + @) @(defun set_dispatch_macro_character (dspchr subchr fnc - &optional (readtable ecl_current_readtable())) - cl_object table; - cl_fixnum subcode; -@ - assert_type_readtable(@[set-dispatch-macro-character], 4, readtable); - ecl_readtable_get(readtable, ecl_char_code(dspchr), &table); - unlikely_if (readtable->readtable.locked) { - error_locked_readtable(readtable); - } - unlikely_if (!ECL_HASH_TABLE_P(table)) { - FEerror("~S is not a dispatch character.", 1, dspchr); - } - subcode = ecl_char_code(subchr); - if (Null(fnc)) { - ecl_remhash(ECL_CODE_CHAR(subcode), table); - } else { - _ecl_sethash(ECL_CODE_CHAR(subcode), table, fnc); - } - if (ecl_lower_case_p(subcode)) { - subcode = ecl_char_upcase(subcode); - } else if (ecl_upper_case_p(subcode)) { - subcode = ecl_char_downcase(subcode); - } - if (Null(fnc)) { - ecl_remhash(ECL_CODE_CHAR(subcode), table); - } else { - _ecl_sethash(ECL_CODE_CHAR(subcode), table, fnc); - } - @(return ECL_T) -@) + &optional (readtable ecl_current_readtable())) + cl_object table; + cl_fixnum subcode; + @ + assert_type_readtable(@[set-dispatch-macro-character], 4, readtable); + ecl_readtable_get(readtable, ecl_char_code(dspchr), &table); + unlikely_if (readtable->readtable.locked) { + error_locked_readtable(readtable); + } + unlikely_if (!ECL_HASH_TABLE_P(table)) { + FEerror("~S is not a dispatch character.", 1, dspchr); + } + subcode = ecl_char_code(subchr); + if (Null(fnc)) { + ecl_remhash(ECL_CODE_CHAR(subcode), table); + } else { + _ecl_sethash(ECL_CODE_CHAR(subcode), table, fnc); + } + if (ecl_lower_case_p(subcode)) { + subcode = ecl_char_upcase(subcode); + } else if (ecl_upper_case_p(subcode)) { + subcode = ecl_char_downcase(subcode); + } + if (Null(fnc)) { + ecl_remhash(ECL_CODE_CHAR(subcode), table); + } else { + _ecl_sethash(ECL_CODE_CHAR(subcode), table, fnc); + } + @(return ECL_T); + @) @(defun get_dispatch_macro_character (dspchr subchr - &optional (readtable ecl_current_readtable())) - cl_object table; - cl_fixnum c; -@ - if (Null(readtable)) { - readtable = cl_core.standard_readtable; - } - assert_type_readtable(@[get-dispatch-macro-character], 3, readtable); - c = ecl_char_code(dspchr); - ecl_readtable_get(readtable, c, &table); - unlikely_if (!ECL_HASH_TABLE_P(table)) { - FEerror("~S is not a dispatch character.", 1, dspchr); - } - c = ecl_char_code(subchr); - - /* Since macro characters may take a number as argument, it is - not allowed to turn digits into dispatch macro characters */ - if (ecl_digitp(c, 10) >= 0) - @(return ECL_NIL) - @(return ecl_gethash_safe(subchr, table, ECL_NIL)) -@) + &optional (readtable ecl_current_readtable())) + cl_object table; + cl_fixnum c; + @ + if (Null(readtable)) { + readtable = cl_core.standard_readtable; + } + assert_type_readtable(@[get-dispatch-macro-character], 3, readtable); + c = ecl_char_code(dspchr); + ecl_readtable_get(readtable, c, &table); + unlikely_if (!ECL_HASH_TABLE_P(table)) { + FEerror("~S is not a dispatch character.", 1, dspchr); + } + c = ecl_char_code(subchr); + + /* Since macro characters may take a number as argument, it is + not allowed to turn digits into dispatch macro characters */ + if (ecl_digitp(c, 10) >= 0) + @(return ECL_NIL); + @(return ecl_gethash_safe(subchr, table, ECL_NIL)); + @) cl_object si_standard_readtable() { - @(return cl_core.standard_readtable) + @(return cl_core.standard_readtable); } @(defun ext::readtable-lock (r &optional yesno) - cl_object output; -@ - assert_type_readtable(@[ext::readtable-lock], 1, r); - output = (r->readtable.locked)? ECL_T : ECL_NIL; - if (narg > 1) { - r->readtable.locked = !Null(yesno); - } - @(return output) -@) + cl_object output; + @ + assert_type_readtable(@[ext::readtable-lock], 1, r); + output = (r->readtable.locked)? ECL_T : ECL_NIL; + if (narg > 1) { + r->readtable.locked = !Null(yesno); + } + @(return output); + @) static void extra_argument(int c, cl_object stream, cl_object d) { - FEreader_error("~S is an extra argument for the #~C readmacro.", - stream, 2, d, ECL_CODE_CHAR(c)); + FEreader_error("~S is an extra argument for the #~C readmacro.", + stream, 2, d, ECL_CODE_CHAR(c)); } @@ -2065,221 +2068,221 @@ void init_read(void) { - struct ecl_readtable_entry *rtab; - cl_object r; - int i; - - cl_core.standard_readtable = r = ecl_alloc_object(t_readtable); - r->readtable.locked = 0; - r->readtable.read_case = ecl_case_upcase; - r->readtable.table = rtab - = (struct ecl_readtable_entry *) - ecl_alloc(RTABSIZE * sizeof(struct ecl_readtable_entry)); - for (i = 0; i < RTABSIZE; i++) { - rtab[i].syntax_type = cat_constituent; - rtab[i].dispatch = ECL_NIL; - } + struct ecl_readtable_entry *rtab; + cl_object r; + int i; + + cl_core.standard_readtable = r = ecl_alloc_object(t_readtable); + r->readtable.locked = 0; + r->readtable.read_case = ecl_case_upcase; + r->readtable.table = rtab + = (struct ecl_readtable_entry *) + ecl_alloc(RTABSIZE * sizeof(struct ecl_readtable_entry)); + for (i = 0; i < RTABSIZE; i++) { + rtab[i].syntax_type = cat_constituent; + rtab[i].dispatch = ECL_NIL; + } #ifdef ECL_UNICODE - r->readtable.hash = ECL_NIL; + r->readtable.hash = ECL_NIL; #endif - cl_core.dispatch_reader = make_cf2(dispatch_reader_fun); + cl_core.dispatch_reader = make_cf2(dispatch_reader_fun); - ecl_readtable_set(r, '\t', cat_whitespace, ECL_NIL); - ecl_readtable_set(r, '\n', cat_whitespace, ECL_NIL); - ecl_readtable_set(r, '\f', cat_whitespace, ECL_NIL); - ecl_readtable_set(r, '\r', cat_whitespace, ECL_NIL); - ecl_readtable_set(r, ' ', cat_whitespace, ECL_NIL); - - ecl_readtable_set(r, '"', cat_terminating, - make_cf2(double_quote_reader)); - - ecl_readtable_set(r, '\'', cat_terminating, - make_cf2(single_quote_reader)); - ecl_readtable_set(r, '(', cat_terminating, - make_cf2(left_parenthesis_reader)); - ecl_readtable_set(r, ')', cat_terminating, - make_cf2(right_parenthesis_reader)); - ecl_readtable_set(r, ',', cat_terminating, - make_cf2(comma_reader)); - ecl_readtable_set(r, ';', cat_terminating, - make_cf2(semicolon_reader)); - ecl_readtable_set(r, '\\', cat_single_escape, ECL_NIL); - ecl_readtable_set(r, '`', cat_terminating, - make_cf2(backquote_reader)); - ecl_readtable_set(r, '|', cat_multiple_escape, ECL_NIL); - - cl_core.default_dispatch_macro = make_cf3(default_dispatch_macro_fun); - - cl_make_dispatch_macro_character(3, ECL_CODE_CHAR('#'), - ECL_T /* non terminating */, r); - - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('C'), - make_cf3(sharp_C_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('\\'), - make_cf3(sharp_backslash_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('\''), - make_cf3(sharp_single_quote_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('('), - make_cf3(sharp_left_parenthesis_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('*'), - make_cf3(sharp_asterisk_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR(':'), - make_cf3(sharp_colon_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('.'), - make_cf3(sharp_dot_reader), r); - /* Used for fasload only. */ - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('B'), - make_cf3(sharp_B_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('O'), - make_cf3(sharp_O_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('X'), - make_cf3(sharp_X_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('R'), - make_cf3(sharp_R_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('A'), - @'si::sharp-a-reader', r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('S'), - @'si::sharp-s-reader', r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('P'), - make_cf3(sharp_P_reader), r); - - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('='), - make_cf3(sharp_eq_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('#'), - make_cf3(sharp_sharp_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('+'), - make_cf3(sharp_plus_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('-'), - make_cf3(sharp_minus_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('|'), - make_cf3(sharp_vertical_bar_reader), r); - /* This is specific to this implementation */ - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('$'), - make_cf3(sharp_dollar_reader), r); - /* This is specific to this implementation */ - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('Y'), - make_cf3(sharp_Y_reader), r); - /* This is specific to this implementation: ignore BOM */ + ecl_readtable_set(r, '\t', cat_whitespace, ECL_NIL); + ecl_readtable_set(r, '\n', cat_whitespace, ECL_NIL); + ecl_readtable_set(r, '\f', cat_whitespace, ECL_NIL); + ecl_readtable_set(r, '\r', cat_whitespace, ECL_NIL); + ecl_readtable_set(r, ' ', cat_whitespace, ECL_NIL); + + ecl_readtable_set(r, '"', cat_terminating, + make_cf2(double_quote_reader)); + + ecl_readtable_set(r, '\'', cat_terminating, + make_cf2(single_quote_reader)); + ecl_readtable_set(r, '(', cat_terminating, + make_cf2(left_parenthesis_reader)); + ecl_readtable_set(r, ')', cat_terminating, + make_cf2(right_parenthesis_reader)); + ecl_readtable_set(r, ',', cat_terminating, + make_cf2(comma_reader)); + ecl_readtable_set(r, ';', cat_terminating, + make_cf2(semicolon_reader)); + ecl_readtable_set(r, '\\', cat_single_escape, ECL_NIL); + ecl_readtable_set(r, '`', cat_terminating, + make_cf2(backquote_reader)); + ecl_readtable_set(r, '|', cat_multiple_escape, ECL_NIL); + + cl_core.default_dispatch_macro = make_cf3(default_dispatch_macro_fun); + + cl_make_dispatch_macro_character(3, ECL_CODE_CHAR('#'), + ECL_T /* non terminating */, r); + + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('C'), + make_cf3(sharp_C_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('\\'), + make_cf3(sharp_backslash_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('\''), + make_cf3(sharp_single_quote_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('('), + make_cf3(sharp_left_parenthesis_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('*'), + make_cf3(sharp_asterisk_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR(':'), + make_cf3(sharp_colon_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('.'), + make_cf3(sharp_dot_reader), r); + /* Used for fasload only. */ + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('B'), + make_cf3(sharp_B_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('O'), + make_cf3(sharp_O_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('X'), + make_cf3(sharp_X_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('R'), + make_cf3(sharp_R_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('A'), + @'si::sharp-a-reader', r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('S'), + @'si::sharp-s-reader', r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('P'), + make_cf3(sharp_P_reader), r); + + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('='), + make_cf3(sharp_eq_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('#'), + make_cf3(sharp_sharp_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('+'), + make_cf3(sharp_plus_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('-'), + make_cf3(sharp_minus_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('|'), + make_cf3(sharp_vertical_bar_reader), r); + /* This is specific to this implementation */ + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('$'), + make_cf3(sharp_dollar_reader), r); + /* This is specific to this implementation */ + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('Y'), + make_cf3(sharp_Y_reader), r); + /* This is specific to this implementation: ignore BOM */ #ifdef ECL_UNICODE - ecl_readtable_set(r, 0xfeff, cat_whitespace, ECL_NIL); + ecl_readtable_set(r, 0xfeff, cat_whitespace, ECL_NIL); #endif - /* Lock the standard read table so that we do not have to make copies - * to keep it unchanged */ - r->readtable.locked = 1; - - init_backq(); - - ECL_SET(@'*readtable*', - r=ecl_copy_readtable(cl_core.standard_readtable, ECL_NIL)); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('!'), - ECL_NIL, r); - ECL_SET(@'*read-default-float-format*', @'single-float'); - - { - cl_object var, val; - var = cl_list(24, - @'*print-pprint-dispatch*', /* See end of pprint.lsp */ - @'*print-array*', - @'*print-base*', - @'*print-case*', - @'*print-circle*', - @'*print-escape*', - @'*print-gensym*', - @'*print-length*', - @'*print-level*', - @'*print-lines*', - @'*print-miser-width*', - @'*print-pretty*', - @'*print-radix*', - @'*print-readably*', - @'*print-right-margin*', - @'*read-base*', - @'*read-default-float-format*', - @'*read-eval*', - @'*read-suppress*', - @'*readtable*', - @'si::*print-package*', - @'si::*print-structure*', - @'si::*sharp-eq-context*', - @'si::*circle-counter*'); - val = cl_list(24, - /**pprint-dispatch-table**/ ECL_NIL, - /**print-array**/ ECL_T, - /**print-base**/ ecl_make_fixnum(10), - /**print-case**/ @':downcase', - /**print-circle**/ ECL_T, - /**print-escape**/ ECL_T, - /**print-gensym**/ ECL_T, - /**print-length**/ ECL_NIL, - /**print-level**/ ECL_NIL, - /**print-lines**/ ECL_NIL, - /**print-miser-width**/ ECL_NIL, - /**print-pretty**/ ECL_NIL, - /**print-radix**/ ECL_NIL, - /**print-readably**/ ECL_T, - /**print-right-margin**/ ECL_NIL, - /**read-base**/ ecl_make_fixnum(10), - /**read-default-float-format**/ @'single-float', - /**read-eval**/ ECL_T, - /**read-suppress**/ ECL_NIL, - /**readtable**/ cl_core.standard_readtable, - /*si::*print-package**/ cl_core.lisp_package, - /*si::*print-structure**/ ECL_T, - /*si::*sharp-eq-context**/ ECL_NIL, - /*si::*cicle-counter**/ ECL_NIL); - ECL_SET(@'si::+ecl-syntax-progv-list+', CONS(var,val)); - var = cl_list(23, - @'*print-pprint-dispatch*', /* See end of pprint.lsp */ - @'*print-array*', - @'*print-base*', - @'*print-case*', - @'*print-circle*', - @'*print-escape*', - @'*print-gensym*', - @'*print-length*', - @'*print-level*', - @'*print-lines*', - @'*print-miser-width*', - @'*print-pretty*', - @'*print-radix*', - @'*print-readably*', - @'*print-right-margin*', - @'*read-base*', - @'*read-default-float-format*', - @'*read-eval*', - @'*read-suppress*', - @'*readtable*', - @'*package*', - @'si::*sharp-eq-context*', - @'si::*circle-counter*'); - val = cl_list(23, - /**pprint-dispatch-table**/ ECL_NIL, - /**print-array**/ ECL_T, - /**print-base**/ ecl_make_fixnum(10), - /**print-case**/ @':upcase', - /**print-circle**/ ECL_NIL, - /**print-escape**/ ECL_T, - /**print-gensym**/ ECL_T, - /**print-length**/ ECL_NIL, - /**print-level**/ ECL_NIL, - /**print-lines**/ ECL_NIL, - /**print-miser-width**/ ECL_NIL, - /**print-pretty**/ ECL_NIL, - /**print-radix**/ ECL_NIL, - /**print-readably**/ ECL_T, - /**print-right-margin**/ ECL_NIL, - /**read-base**/ ecl_make_fixnum(10), - /**read-default-float-format**/ @'single-float', - /**read-eval**/ ECL_T, - /**read-suppress**/ ECL_NIL, - /**readtable**/ cl_core.standard_readtable, - /**package**/ cl_core.user_package, - /*si::*sharp-eq-context**/ ECL_NIL, - /*si::*cicle-counter**/ ECL_NIL); - ECL_SET(@'si::+io-syntax-progv-list+', CONS(var,val)); - } + /* Lock the standard read table so that we do not have to make copies + * to keep it unchanged */ + r->readtable.locked = 1; + + init_backq(); + + ECL_SET(@'*readtable*', + r=ecl_copy_readtable(cl_core.standard_readtable, ECL_NIL)); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('!'), + ECL_NIL, r); + ECL_SET(@'*read-default-float-format*', @'single-float'); + + { + cl_object var, val; + var = cl_list(24, + @'*print-pprint-dispatch*', /* See end of pprint.lsp */ + @'*print-array*', + @'*print-base*', + @'*print-case*', + @'*print-circle*', + @'*print-escape*', + @'*print-gensym*', + @'*print-length*', + @'*print-level*', + @'*print-lines*', + @'*print-miser-width*', + @'*print-pretty*', + @'*print-radix*', + @'*print-readably*', + @'*print-right-margin*', + @'*read-base*', + @'*read-default-float-format*', + @'*read-eval*', + @'*read-suppress*', + @'*readtable*', + @'si::*print-package*', + @'si::*print-structure*', + @'si::*sharp-eq-context*', + @'si::*circle-counter*'); + val = cl_list(24, + /**pprint-dispatch-table**/ ECL_NIL, + /**print-array**/ ECL_T, + /**print-base**/ ecl_make_fixnum(10), + /**print-case**/ @':downcase', + /**print-circle**/ ECL_T, + /**print-escape**/ ECL_T, + /**print-gensym**/ ECL_T, + /**print-length**/ ECL_NIL, + /**print-level**/ ECL_NIL, + /**print-lines**/ ECL_NIL, + /**print-miser-width**/ ECL_NIL, + /**print-pretty**/ ECL_NIL, + /**print-radix**/ ECL_NIL, + /**print-readably**/ ECL_T, + /**print-right-margin**/ ECL_NIL, + /**read-base**/ ecl_make_fixnum(10), + /**read-default-float-format**/ @'single-float', + /**read-eval**/ ECL_T, + /**read-suppress**/ ECL_NIL, + /**readtable**/ cl_core.standard_readtable, + /*si::*print-package**/ cl_core.lisp_package, + /*si::*print-structure**/ ECL_T, + /*si::*sharp-eq-context**/ ECL_NIL, + /*si::*cicle-counter**/ ECL_NIL); + ECL_SET(@'si::+ecl-syntax-progv-list+', CONS(var,val)); + var = cl_list(23, + @'*print-pprint-dispatch*', /* See end of pprint.lsp */ + @'*print-array*', + @'*print-base*', + @'*print-case*', + @'*print-circle*', + @'*print-escape*', + @'*print-gensym*', + @'*print-length*', + @'*print-level*', + @'*print-lines*', + @'*print-miser-width*', + @'*print-pretty*', + @'*print-radix*', + @'*print-readably*', + @'*print-right-margin*', + @'*read-base*', + @'*read-default-float-format*', + @'*read-eval*', + @'*read-suppress*', + @'*readtable*', + @'*package*', + @'si::*sharp-eq-context*', + @'si::*circle-counter*'); + val = cl_list(23, + /**pprint-dispatch-table**/ ECL_NIL, + /**print-array**/ ECL_T, + /**print-base**/ ecl_make_fixnum(10), + /**print-case**/ @':upcase', + /**print-circle**/ ECL_NIL, + /**print-escape**/ ECL_T, + /**print-gensym**/ ECL_T, + /**print-length**/ ECL_NIL, + /**print-level**/ ECL_NIL, + /**print-lines**/ ECL_NIL, + /**print-miser-width**/ ECL_NIL, + /**print-pretty**/ ECL_NIL, + /**print-radix**/ ECL_NIL, + /**print-readably**/ ECL_T, + /**print-right-margin**/ ECL_NIL, + /**read-base**/ ecl_make_fixnum(10), + /**read-default-float-format**/ @'single-float', + /**read-eval**/ ECL_T, + /**read-suppress**/ ECL_NIL, + /**readtable**/ cl_core.standard_readtable, + /**package**/ cl_core.user_package, + /*si::*sharp-eq-context**/ ECL_NIL, + /*si::*cicle-counter**/ ECL_NIL); + ECL_SET(@'si::+io-syntax-progv-list+', CONS(var,val)); + } } /* @@ -2297,178 +2300,178 @@ make_one_data_stream(const cl_object string) { #ifdef ECL_UNICODE - return si_make_sequence_input_stream(3, string, @':external-format', - @':utf-8'); + return si_make_sequence_input_stream(3, string, @':external-format', + @':utf-8'); #else - return ecl_make_string_input_stream(string, 0, ecl_length(string)); + return ecl_make_string_input_stream(string, 0, ecl_length(string)); #endif } static cl_object make_data_stream(const cl_object *data) { - if (data == 0 || data[0] == NULL) { - return cl_core.null_stream; - } - if (data[1] == NULL) { - return make_one_data_stream(data[0]); - } else { - cl_object stream_list = ECL_NIL; - cl_index i; - for (i = 0; data[i]; i++) { - cl_object s = make_one_data_stream(data[i]); - stream_list = ecl_cons(s, stream_list); - } - return cl_apply(2, @'make-concatenated-stream', - cl_nreverse(stream_list)); - } + if (data == 0 || data[0] == NULL) { + return cl_core.null_stream; + } + if (data[1] == NULL) { + return make_one_data_stream(data[0]); + } else { + cl_object stream_list = ECL_NIL; + cl_index i; + for (i = 0; data[i]; i++) { + cl_object s = make_one_data_stream(data[i]); + stream_list = ecl_cons(s, stream_list); + } + return cl_apply(2, @'make-concatenated-stream', + cl_nreverse(stream_list)); + } } cl_object ecl_init_module(cl_object block, void (*entry_point)(cl_object)) { - const cl_env_ptr env = ecl_process_env(); - volatile cl_object old_eptbc = env->packages_to_be_created; - volatile cl_object x; - cl_index i, len, perm_len, temp_len; - cl_object in; - cl_object *VV = NULL, *VVtemp = NULL; - - if (block == NULL) - block = ecl_make_codeblock(); - block->cblock.entry = entry_point; - - in = OBJNULL; - ECL_UNWIND_PROTECT_BEGIN(env) { - cl_index bds_ndx; - cl_object progv_list; - - ecl_bds_bind(env, @'si::*cblock*', block); - env->packages_to_be_created_p = ECL_T; - - /* Communicate the library which Cblock we are using, and get - * back the amount of data to be processed. - */ - (*entry_point)(block); - perm_len = block->cblock.data_size; - temp_len = block->cblock.temp_data_size; - len = perm_len + temp_len; - - if (block->cblock.data_text == 0) { - if (len) { - /* Code from COMPILE uses data in *compiler-constants* */ - cl_object v = ECL_SYM_VAL(env,@'si::*compiler-constants*'); - unlikely_if (ecl_t_of(v) != t_vector || - v->vector.dim != len || - v->vector.elttype != ecl_aet_object) - FEerror("Internal error: corrupted data in " - "si::*compiler-constants*", 0); - VV = block->cblock.data = v->vector.self.t; - VVtemp = block->cblock.temp_data = NULL; - } - goto NO_DATA_LABEL; - } - if (len == 0) { - VV = VVtemp = NULL; - goto NO_DATA_LABEL; - } + const cl_env_ptr env = ecl_process_env(); + volatile cl_object old_eptbc = env->packages_to_be_created; + volatile cl_object x; + cl_index i, len, perm_len, temp_len; + cl_object in; + cl_object *VV = NULL, *VVtemp = NULL; + + if (block == NULL) + block = ecl_make_codeblock(); + block->cblock.entry = entry_point; + + in = OBJNULL; + ECL_UNWIND_PROTECT_BEGIN(env) { + cl_index bds_ndx; + cl_object progv_list; + + ecl_bds_bind(env, @'si::*cblock*', block); + env->packages_to_be_created_p = ECL_T; + + /* Communicate the library which Cblock we are using, and get + * back the amount of data to be processed. + */ + (*entry_point)(block); + perm_len = block->cblock.data_size; + temp_len = block->cblock.temp_data_size; + len = perm_len + temp_len; + + if (block->cblock.data_text == 0) { + if (len) { + /* Code from COMPILE uses data in *compiler-constants* */ + cl_object v = ECL_SYM_VAL(env,@'si::*compiler-constants*'); + unlikely_if (ecl_t_of(v) != t_vector || + v->vector.dim != len || + v->vector.elttype != ecl_aet_object) + FEerror("Internal error: corrupted data in " + "si::*compiler-constants*", 0); + VV = block->cblock.data = v->vector.self.t; + VVtemp = block->cblock.temp_data = NULL; + } + goto NO_DATA_LABEL; + } + if (len == 0) { + VV = VVtemp = NULL; + goto NO_DATA_LABEL; + } #ifdef ECL_DYNAMIC_VV - VV = block->cblock.data = perm_len? (cl_object *)ecl_alloc(perm_len * sizeof(cl_object)) : NULL; + VV = block->cblock.data = perm_len? (cl_object *)ecl_alloc(perm_len * sizeof(cl_object)) : NULL; #else - VV = block->cblock.data; + VV = block->cblock.data; #endif - memset(VV, 0, perm_len * sizeof(*VV)); + memset(VV, 0, perm_len * sizeof(*VV)); - VVtemp = block->cblock.temp_data = temp_len? (cl_object *)ecl_alloc(temp_len * sizeof(cl_object)) : NULL; - memset(VVtemp, 0, temp_len * sizeof(*VVtemp)); + VVtemp = block->cblock.temp_data = temp_len? (cl_object *)ecl_alloc(temp_len * sizeof(cl_object)) : NULL; + memset(VVtemp, 0, temp_len * sizeof(*VVtemp)); - /* Read all data for the library */ + /* Read all data for the library */ #ifdef ECL_EXTERNALIZABLE - { - cl_object v = ecl_deserialize(block->cblock.data_text); - unlikely_if (v->vector.dim < len) - FEreader_error("Not enough data while loading" - "binary file", in, 0); - memcpy(VV, v->vector.self.t, len * sizeof(cl_object)); - } + { + cl_object v = ecl_deserialize(block->cblock.data_text); + unlikely_if (v->vector.dim < len) + FEreader_error("Not enough data while loading" + "binary file", in, 0); + memcpy(VV, v->vector.self.t, len * sizeof(cl_object)); + } #else - in = make_data_stream(block->cblock.data_text); - progv_list = ECL_SYM_VAL(env, @'si::+ecl-syntax-progv-list+'); - bds_ndx = ecl_progv(env, ECL_CONS_CAR(progv_list), - ECL_CONS_CDR(progv_list)); - for (i = 0 ; i < len; i++) { - x = ecl_read_object(in); - if (x == OBJNULL) - break; - if (i < perm_len) - VV[i] = x; - else - VVtemp[i-perm_len] = x; - } - if (!Null(ECL_SYM_VAL(env, @'si::*sharp-eq-context*'))) { - while (i--) { - if (i < perm_len) { - VV[i] = patch_sharp(env, VV[i]); - } else { - VVtemp[i-perm_len] = patch_sharp(env, VVtemp[i-perm_len]); - } - } - } - ecl_bds_unwind(env, bds_ndx); - unlikely_if (i < len) - FEreader_error("Not enough data while loading" - "binary file", in, 0); - cl_close(1,in); - in = OBJNULL; + in = make_data_stream(block->cblock.data_text); + progv_list = ECL_SYM_VAL(env, @'si::+ecl-syntax-progv-list+'); + bds_ndx = ecl_progv(env, ECL_CONS_CAR(progv_list), + ECL_CONS_CDR(progv_list)); + for (i = 0 ; i < len; i++) { + x = ecl_read_object(in); + if (x == OBJNULL) + break; + if (i < perm_len) + VV[i] = x; + else + VVtemp[i-perm_len] = x; + } + if (!Null(ECL_SYM_VAL(env, @'si::*sharp-eq-context*'))) { + while (i--) { + if (i < perm_len) { + VV[i] = patch_sharp(env, VV[i]); + } else { + VVtemp[i-perm_len] = patch_sharp(env, VVtemp[i-perm_len]); + } + } + } + ecl_bds_unwind(env, bds_ndx); + unlikely_if (i < len) + FEreader_error("Not enough data while loading" + "binary file", in, 0); + cl_close(1,in); + in = OBJNULL; #endif - NO_DATA_LABEL: - env->packages_to_be_created_p = ECL_NIL; + NO_DATA_LABEL: + env->packages_to_be_created_p = ECL_NIL; - assert(block->cblock.cfuns_size == 0 || VV != NULL); - for (i = 0; i < block->cblock.cfuns_size; i++) { - const struct ecl_cfun *prototype = block->cblock.cfuns+i; - cl_index fname_location = ecl_fixnum(prototype->block); - cl_object fname = VV[fname_location]; - cl_index location = ecl_fixnum(prototype->name); - cl_object position = prototype->file_position; - int narg = prototype->narg; - VV[location] = narg<0? - ecl_make_cfun_va((cl_objectfn)prototype->entry, - fname, block) : - ecl_make_cfun((cl_objectfn_fixed)prototype->entry, - fname, block, narg); - /* Add source file info */ - if (position != ecl_make_fixnum(-1)) { - ecl_set_function_source_file_info(VV[location], - block->cblock.source, - position); - } - } - /* Execute top-level code */ - (*entry_point)(OBJNULL); - x = cl_set_difference(2, env->packages_to_be_created, old_eptbc); - old_eptbc = env->packages_to_be_created; - unlikely_if (!Null(x)) { - CEerror(ECL_T, - Null(ECL_CONS_CDR(x))? - "Package ~A referenced in " - "compiled file~& ~A~&but has not been created": - "The packages~& ~A~&were referenced in " - "compiled file~& ~A~&but have not been created", - 2, x, block->cblock.name); - } - if (VVtemp) { - block->cblock.temp_data = NULL; - block->cblock.temp_data_size = 0; - ecl_dealloc(VVtemp); - } - ecl_bds_unwind1(env); - } ECL_UNWIND_PROTECT_EXIT { - if (in != OBJNULL) - cl_close(1,in); - env->packages_to_be_created = old_eptbc; - env->packages_to_be_created_p = ECL_NIL; - } ECL_UNWIND_PROTECT_END; + assert(block->cblock.cfuns_size == 0 || VV != NULL); + for (i = 0; i < block->cblock.cfuns_size; i++) { + const struct ecl_cfun *prototype = block->cblock.cfuns+i; + cl_index fname_location = ecl_fixnum(prototype->block); + cl_object fname = VV[fname_location]; + cl_index location = ecl_fixnum(prototype->name); + cl_object position = prototype->file_position; + int narg = prototype->narg; + VV[location] = narg<0? + ecl_make_cfun_va((cl_objectfn)prototype->entry, + fname, block) : + ecl_make_cfun((cl_objectfn_fixed)prototype->entry, + fname, block, narg); + /* Add source file info */ + if (position != ecl_make_fixnum(-1)) { + ecl_set_function_source_file_info(VV[location], + block->cblock.source, + position); + } + } + /* Execute top-level code */ + (*entry_point)(OBJNULL); + x = cl_set_difference(2, env->packages_to_be_created, old_eptbc); + old_eptbc = env->packages_to_be_created; + unlikely_if (!Null(x)) { + CEerror(ECL_T, + Null(ECL_CONS_CDR(x))? + "Package ~A referenced in " + "compiled file~& ~A~&but has not been created": + "The packages~& ~A~&were referenced in " + "compiled file~& ~A~&but have not been created", + 2, x, block->cblock.name); + } + if (VVtemp) { + block->cblock.temp_data = NULL; + block->cblock.temp_data_size = 0; + ecl_dealloc(VVtemp); + } + ecl_bds_unwind1(env); + } ECL_UNWIND_PROTECT_EXIT { + if (in != OBJNULL) + cl_close(1,in); + env->packages_to_be_created = old_eptbc; + env->packages_to_be_created_p = ECL_NIL; + } ECL_UNWIND_PROTECT_END; - return block; + return block; } diff -Nru ecl-16.1.2/src/c/reader/parse_integer.d ecl-16.1.3+ds/src/c/reader/parse_integer.d --- ecl-16.1.2/src/c/reader/parse_integer.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/reader/parse_integer.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,18 +1,15 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../../Copyright' for full details. -*/ + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -24,93 +21,95 @@ ecl_parse_integer(cl_object str, cl_index start, cl_index end, cl_index *ep, unsigned int radix) { - int sign, d; - cl_object integer_part, output; - cl_index i, c; - - if (start >= end || !basep(radix)) { - *ep = start; - return OBJNULL; - } - sign = 1; - c = ecl_char(str, start); - if (c == '+') { - start++; - } else if (c == '-') { - sign = -1; - start++; - } - integer_part = _ecl_big_register0(); - _ecl_big_set_ui(integer_part, 0); - for (i = start; i < end; i++) { - c = ecl_char(str, i); - d = ecl_digitp(c, radix); - if (d < 0) { - break; - } - _ecl_big_mul_ui(integer_part, integer_part, radix); - _ecl_big_add_ui(integer_part, integer_part, d); - } - if (sign < 0) { - _ecl_big_complement(integer_part, integer_part); - } - output = _ecl_big_register_normalize(integer_part); - *ep = i; - return (i == start)? OBJNULL : output; + int sign, d; + cl_object integer_part, output; + cl_index i, c; + + if (start >= end || !basep(radix)) { + *ep = start; + return OBJNULL; + } + sign = 1; + c = ecl_char(str, start); + if (c == '+') { + start++; + } else if (c == '-') { + sign = -1; + start++; + } + integer_part = _ecl_big_register0(); + _ecl_big_set_ui(integer_part, 0); + for (i = start; i < end; i++) { + c = ecl_char(str, i); + d = ecl_digitp(c, radix); + if (d < 0) { + break; + } + _ecl_big_mul_ui(integer_part, integer_part, radix); + _ecl_big_add_ui(integer_part, integer_part, d); + } + if (sign < 0) { + _ecl_big_complement(integer_part, integer_part); + } + output = _ecl_big_register_normalize(integer_part); + *ep = i; + return (i == start)? OBJNULL : output; } @(defun parse_integer (strng &key (start ecl_make_fixnum(0)) - end - (radix ecl_make_fixnum(10)) - junk_allowed + end + (radix ecl_make_fixnum(10)) + junk_allowed &aux x) - cl_index s, e, ep; - cl_object rtbl = ecl_current_readtable(); -@ { - unlikely_if (!ECL_STRINGP(strng)) { - FEwrong_type_nth_arg(@[parse-integer], 1, strng, @[string]); - } - unlikely_if (!ECL_FIXNUMP(radix) || - ecl_fixnum_lower(radix, ecl_make_fixnum(2)) || - ecl_fixnum_greater(radix, ecl_make_fixnum(36))) + cl_index s, e, ep; + cl_object rtbl = ecl_current_readtable(); + @ { + unlikely_if (!ECL_STRINGP(strng)) { + FEwrong_type_nth_arg(@[parse-integer], 1, strng, @[string]); + } + unlikely_if (!ECL_FIXNUMP(radix) || + ecl_fixnum_lower(radix, ecl_make_fixnum(2)) || + ecl_fixnum_greater(radix, ecl_make_fixnum(36))) + { + FEerror("~S is an illegal radix.", 1, radix); + } + { + cl_index_pair p = + ecl_vector_start_end(@[parse-integer], strng, start, end); + s = p.start; + e = p.end; + } + while (s < e && + ecl_readtable_get(rtbl, ecl_char(strng, s), NULL) == cat_whitespace) { + s++; + } + if (s >= e) { + if (junk_allowed != ECL_NIL) { + @(return ECL_NIL ecl_make_fixnum(s)); + } + else { + goto CANNOT_PARSE; + } + } + x = ecl_parse_integer(strng, s, e, &ep, ecl_fixnum(radix)); + if (x == OBJNULL) { + if (junk_allowed != ECL_NIL) { + @(return ECL_NIL ecl_make_fixnum(ep)); + } else { + goto CANNOT_PARSE; + } + } + if (junk_allowed != ECL_NIL) { + @(return x ecl_make_fixnum(ep)); + } + for (s = ep; s < e; s++) { + unlikely_if (ecl_readtable_get(rtbl, ecl_char(strng, s), NULL) + != cat_whitespace) { - FEerror("~S is an illegal radix.", 1, radix); - } - { - cl_index_pair p = - ecl_vector_start_end(@[parse-integer], strng, start, end); - s = p.start; - e = p.end; - } - while (s < e && - ecl_readtable_get(rtbl, ecl_char(strng, s), NULL) == cat_whitespace) { - s++; - } - if (s >= e) { - if (junk_allowed != ECL_NIL) - @(return ECL_NIL ecl_make_fixnum(s)) - else - goto CANNOT_PARSE; - } - x = ecl_parse_integer(strng, s, e, &ep, ecl_fixnum(radix)); - if (x == OBJNULL) { - if (junk_allowed != ECL_NIL) { - @(return ECL_NIL ecl_make_fixnum(ep)); - } else { - goto CANNOT_PARSE; - } - } - if (junk_allowed != ECL_NIL) { - @(return x ecl_make_fixnum(ep)); - } - for (s = ep; s < e; s++) { - unlikely_if (ecl_readtable_get(rtbl, ecl_char(strng, s), NULL) - != cat_whitespace) - { -CANNOT_PARSE: FEparse_error("Cannot parse an integer in the string ~S.", - ECL_NIL, 1, strng); - } + CANNOT_PARSE: FEparse_error("Cannot parse an integer in the string ~S.", + ECL_NIL, 1, strng); } - @(return x ecl_make_fixnum(e)); -} @) + } + @(return x ecl_make_fixnum(e)); + } @) diff -Nru ecl-16.1.2/src/c/reader/parse_number.d ecl-16.1.3+ds/src/c/reader/parse_number.d --- ecl-16.1.2/src/c/reader/parse_number.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/reader/parse_number.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,227 +1,226 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../../Copyright' for full details. -*/ + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include static bool exponent_charp(cl_fixnum c) { - return (c == 'e') || (c == 'E') || (c == 'f') || (c == 'F') || - (c == 's') || (c == 'S') || (c == 'd') || (c == 'D') || - (c == 'l') || (c == 'L'); + return (c == 'e') || (c == 'E') || (c == 'f') || (c == 'F') || + (c == 's') || (c == 'S') || (c == 'd') || (c == 'D') || + (c == 'l') || (c == 'L'); } static cl_object expt10(cl_index expt) { - cl_object accum = _ecl_big_register0(); - cl_object factor = _ecl_big_register1(); - _ecl_big_set_ui(accum, 1); - _ecl_big_set_ui(factor, 10); - for (; expt; expt >>= 1) { - if (expt & 1) { - _ecl_big_mul(accum, accum, factor); - } - _ecl_big_mul(factor, factor, factor); - } - _ecl_big_register_free(factor); - return _ecl_big_register_normalize(accum); + cl_object accum = _ecl_big_register0(); + cl_object factor = _ecl_big_register1(); + _ecl_big_set_ui(accum, 1); + _ecl_big_set_ui(factor, 10); + for (; expt; expt >>= 1) { + if (expt & 1) { + _ecl_big_mul(accum, accum, factor); + } + _ecl_big_mul(factor, factor, factor); + } + _ecl_big_register_free(factor); + return _ecl_big_register_normalize(accum); } static cl_object infinity(cl_index exp_char, int sign) { - cl_object var; - switch (exp_char) { - case 'e': case 'E': - return infinity(ecl_current_read_default_float_format(), sign); - case 's': case 'S': - case 'f': case 'F': - var = (sign<0)? - @'ext::single-float-negative-infinity' : - @'ext::single-float-positive-infinity'; - break; - case 'l': case 'L': -#ifdef ECL_LONG_FLOAT - var = (sign<0)? - @'ext::long-float-negative-infinity' : - @'ext::long-float-positive-infinity'; - break; -#endif - case 'd': case 'D': - var = (sign<0)? - @'ext::double-float-negative-infinity' : - @'ext::double-float-positive-infinity'; - break; - default: - return OBJNULL; - } - return ecl_symbol_value(var); + cl_object var; + switch (exp_char) { +#ifdef ECL_IEEE_FP + case 'e': case 'E': + return infinity(ecl_current_read_default_float_format(), sign); + case 's': case 'S': + case 'f': case 'F': + var = (sign<0)? + @'ext::single-float-negative-infinity' : + @'ext::single-float-positive-infinity'; + break; + case 'l': case 'L': +# ifdef ECL_LONG_FLOAT + var = (sign<0)? + @'ext::long-float-negative-infinity' : + @'ext::long-float-positive-infinity'; + break; +# endif + case 'd': case 'D': + var = (sign<0)? + @'ext::double-float-negative-infinity' : + @'ext::double-float-positive-infinity'; + break; +#endif /* ECL_IEEE_FP */ + default: + return OBJNULL; + } + return ecl_symbol_value(var); } static cl_object make_float(cl_object num, cl_object exp, cl_index exp_char, int sign) { - if (!ECL_FIXNUMP(exp)) { - return infinity(exp_char, sign); - } else { - cl_fixnum fix_exp = ecl_fixnum(exp); - if (fix_exp > 0) { - num = ecl_times(num, expt10(fix_exp)); - } else if (fix_exp < 0) { - num = ecl_divide(num, expt10(-fix_exp)); - } - } + if (!ECL_FIXNUMP(exp)) { + return infinity(exp_char, sign); + } else { + cl_fixnum fix_exp = ecl_fixnum(exp); + if (fix_exp > 0) { + num = ecl_times(num, expt10(fix_exp)); + } else if (fix_exp < 0) { + num = ecl_divide(num, expt10(-fix_exp)); + } + } AGAIN: - switch (exp_char) { - case 'e': case 'E': - exp_char = ecl_current_read_default_float_format(); - goto AGAIN; - case 's': case 'S': - case 'f': case 'F': - return ecl_make_single_float(sign * ecl_to_double(num)); - case 'l': case 'L': + switch (exp_char) { + case 'e': case 'E': + exp_char = ecl_current_read_default_float_format(); + goto AGAIN; + case 's': case 'S': + case 'f': case 'F': + return ecl_make_single_float(sign * ecl_to_double(num)); + case 'l': case 'L': #ifdef ECL_LONG_FLOAT - return ecl_make_long_float(sign * ecl_to_long_double(num)); + return ecl_make_long_float(sign * ecl_to_long_double(num)); #endif - case 'd': case 'D': { - return ecl_make_double_float(sign * ecl_to_double(num)); - } - default: - return OBJNULL; - } + case 'd': case 'D': { + return ecl_make_double_float(sign * ecl_to_double(num)); + } + default: + return OBJNULL; + } } /* - ecl_parse_number(str, start, end, ep, radix) parses C string str - up to (but not including) str[end] - using radix as the radix for the rational number. - (For floating numbers, the radix is ignored and replaced with 10) - When parsing succeeds, - the index of the next character is assigned to *ep, - and the number is returned as a lisp data object. - If not, OBJNULL is returned. + ecl_parse_number(str, start, end, ep, radix) parses C string str + up to (but not including) str[end] + using radix as the radix for the rational number. + (For floating numbers, the radix is ignored and replaced with 10) + When parsing succeeds, + the index of the next character is assigned to *ep, + and the number is returned as a lisp data object. + If not, OBJNULL is returned. */ cl_object ecl_parse_number(cl_object str, cl_index start, cl_index end, cl_index *ep, unsigned int radix) { - int sign = -1, d; - cl_index c, i, decimal = end; - cl_object num = _ecl_big_register0(); - bool some_digit = 0; - if (end <= start || radix > 36) { - *ep = start; - return OBJNULL; - } + int sign = -1, d; + cl_index c, i, decimal = end; + cl_object num = _ecl_big_register0(); + bool some_digit = 0; + if (end <= start || radix > 36) { + *ep = start; + return OBJNULL; + } AGAIN: - _ecl_big_set_ui(num, 0); - c = ecl_char(str, i = start); - sign = 1; - if (c == '+') { - if (++i == end) goto NOT_A_NUMBER; - c = ecl_char(str, i); - } else if (c == '-') { - sign = -1; - if (++i == end) goto NOT_A_NUMBER; - c = ecl_char(str, i); - } - if (c == '/') { - goto NOT_A_NUMBER; - } - for (; i < end; i++) { - c = ecl_char(str, i); - if (c == '/') { - cl_object den; - if (sign < 0) _ecl_big_complement(num, num); - num = _ecl_big_register_normalize(num); - c = ecl_char(str, ++i); - if (ecl_digitp(c, radix) < 0) - goto NOT_A_NUMBER; - den = ecl_parse_integer(str, i, end, ep, radix); - if (den == OBJNULL || (*ep < end)) { - return OBJNULL; - } else if (den == ecl_make_fixnum(0)) { - return ECL_NIL; - } else { - return ecl_make_ratio(num, den); - } - } else if (c == '.') { - if (decimal <= i) { - goto NOT_A_NUMBER; - } - if (radix != 10) { - radix = 10; - goto AGAIN; - } - /* For a number xxxx.1234...nEyyy - * we have stored in num the number xxxx1234...n and - * will get in the exponent yyy. What we do is to simply - * shift the exponent by -n. */ - decimal = i+1; - } else if ((d = ecl_digitp(c, radix)) >= 0) { - _ecl_big_mul_ui(num, num, radix); - _ecl_big_add_ui(num, num, d); - some_digit = 1; - } else if (exponent_charp(c)) { - cl_object exp, decimals; - if (!some_digit) - goto NOT_A_NUMBER; - if (radix != 10) { - radix = 10; - goto AGAIN; - } - num = _ecl_big_register_normalize(num); - decimals = (decimal < i) ? - ecl_make_fixnum(decimal - i): - ecl_make_fixnum(0); - exp = ecl_parse_integer(str, ++i, end, ep, 10); - if (exp == OBJNULL || (*ep < end)) - return OBJNULL; - return make_float(num, ecl_plus(decimals, exp), - c, sign); - } else if (radix != 10) { - _ecl_big_register_free(num); - num = ecl_parse_number(str, start, end, ep, 10); - if (num != OBJNULL) { - if (floatp(num)) - return num; - if (ECL_FIXNUMP(num) || ECL_BIGNUMP(num)) { - i = *ep; - if (i > start && ecl_char(str, i-1) == '.') - return num; - } - } - return OBJNULL; - } else { - NOT_A_NUMBER: - *ep = i; - _ecl_big_register_free(num); - return OBJNULL; - } - } - /* If we have reached the end without decimals (for instance - * 1., 2, 13., etc) we return an integer */ - *ep = i; - if (decimal < i) { - if (!some_digit) goto NOT_A_NUMBER; - return make_float(_ecl_big_register_normalize(num), - ecl_make_fixnum(decimal - i), 'e', sign); - } else { - if (sign < 0) _ecl_big_complement(num, num); - return _ecl_big_register_normalize(num); - } + _ecl_big_set_ui(num, 0); + c = ecl_char(str, i = start); + sign = 1; + if (c == '+') { + if (++i == end) goto NOT_A_NUMBER; + c = ecl_char(str, i); + } else if (c == '-') { + sign = -1; + if (++i == end) goto NOT_A_NUMBER; + c = ecl_char(str, i); + } + if (c == '/') { + goto NOT_A_NUMBER; + } + for (; i < end; i++) { + c = ecl_char(str, i); + if (c == '/') { + cl_object den; + if (sign < 0) _ecl_big_complement(num, num); + num = _ecl_big_register_normalize(num); + c = ecl_char(str, ++i); + if (ecl_digitp(c, radix) < 0) + goto NOT_A_NUMBER; + den = ecl_parse_integer(str, i, end, ep, radix); + if (den == OBJNULL || (*ep < end)) { + return OBJNULL; + } else if (den == ecl_make_fixnum(0)) { + return ECL_NIL; + } else { + return ecl_make_ratio(num, den); + } + } else if (c == '.') { + if (decimal <= i) { + goto NOT_A_NUMBER; + } + if (radix != 10) { + radix = 10; + goto AGAIN; + } + /* For a number xxxx.1234...nEyyy + * we have stored in num the number xxxx1234...n and + * will get in the exponent yyy. What we do is to simply + * shift the exponent by -n. */ + decimal = i+1; + } else if ((d = ecl_digitp(c, radix)) >= 0) { + _ecl_big_mul_ui(num, num, radix); + _ecl_big_add_ui(num, num, d); + some_digit = 1; + } else if (exponent_charp(c)) { + cl_object exp, decimals; + if (!some_digit) + goto NOT_A_NUMBER; + if (radix != 10) { + radix = 10; + goto AGAIN; + } + num = _ecl_big_register_normalize(num); + decimals = (decimal < i) ? + ecl_make_fixnum(decimal - i): + ecl_make_fixnum(0); + exp = ecl_parse_integer(str, ++i, end, ep, 10); + if (exp == OBJNULL || (*ep < end)) + return OBJNULL; + return make_float(num, ecl_plus(decimals, exp), + c, sign); + } else if (radix != 10) { + _ecl_big_register_free(num); + num = ecl_parse_number(str, start, end, ep, 10); + if (num != OBJNULL) { + if (floatp(num)) + return num; + if (ECL_FIXNUMP(num) || ECL_BIGNUMP(num)) { + i = *ep; + if (i > start && ecl_char(str, i-1) == '.') + return num; + } + } + return OBJNULL; + } else { + NOT_A_NUMBER: + *ep = i; + _ecl_big_register_free(num); + return OBJNULL; + } + } + /* If we have reached the end without decimals (for instance + * 1., 2, 13., etc) we return an integer */ + *ep = i; + if (decimal < i) { + if (!some_digit) goto NOT_A_NUMBER; + return make_float(_ecl_big_register_normalize(num), + ecl_make_fixnum(decimal - i), 'e', sign); + } else { + if (sign < 0) _ecl_big_complement(num, num); + return _ecl_big_register_normalize(num); + } } diff -Nru ecl-16.1.2/src/c/reference.d ecl-16.1.3+ds/src/c/reference.d --- ecl-16.1.2/src/c/reference.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/reference.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,174 +1,167 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - reference.c -- Reference in Constants and Variables. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * reference.d - reference in Constants and Variables + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include #include -/* - Symbol-function returns - function-closure for function - (macro . function-closure) for macros - special for special forms. -*/ +/* Symbol-function returns */ +/* function-closure for function */ +/* (macro . function-closure) for macros */ +/* special for special forms. */ cl_object cl_symbol_function(cl_object sym) { - cl_object output; - int type = ecl_symbol_type(sym); - if (type & ecl_stp_special_form) { - output = @'special'; - } else if (Null(sym) || (ECL_SYM_FUN(sym) == ECL_NIL)) { - FEundefined_function(sym); - } else if (type & ecl_stp_macro) { - output = CONS(@'si::macro', ECL_SYM_FUN(sym)); - } else { - output = ECL_SYM_FUN(sym); - } - @(return output) + cl_object output; + int type = ecl_symbol_type(sym); + if (type & ecl_stp_special_form) { + output = @'special'; + } else if (Null(sym) || (ECL_SYM_FUN(sym) == ECL_NIL)) { + FEundefined_function(sym); + } else if (type & ecl_stp_macro) { + output = CONS(@'si::macro', ECL_SYM_FUN(sym)); + } else { + output = ECL_SYM_FUN(sym); + } + @(return output); } cl_object cl_fdefinition(cl_object fname) { - @(return ((ECL_SYMBOLP(fname))? cl_symbol_function(fname) : ecl_fdefinition(fname))) + @(return ((ECL_SYMBOLP(fname))? cl_symbol_function(fname) : ecl_fdefinition(fname))); } cl_object cl_fboundp(cl_object fname) { - if (Null(fname)) { - @(return ECL_NIL); - } else if (ECL_SYMBOLP(fname)) { - @(return (((fname->symbol.stype & ecl_stp_special_form) - || ECL_SYM_FUN(fname) != ECL_NIL)? ECL_T : ECL_NIL)) - } else if (LISTP(fname)) { - if (CAR(fname) == @'setf') { - cl_object sym = CDR(fname); - if (CONSP(sym) && CDR(sym) == ECL_NIL) { - cl_object pair; - sym = CAR(sym); - if (ECL_SYMBOLP(sym)) { - pair = ecl_setf_definition(sym, ECL_NIL); - @(return ecl_cdr(pair)); - } - } - } - } - FEinvalid_function_name(fname); + if (Null(fname)) { + @(return ECL_NIL); + } else if (ECL_SYMBOLP(fname)) { + @(return (((fname->symbol.stype & ecl_stp_special_form) + || ECL_SYM_FUN(fname) != ECL_NIL)? ECL_T : ECL_NIL)); + } else if (LISTP(fname)) { + if (CAR(fname) == @'setf') { + cl_object sym = CDR(fname); + if (CONSP(sym) && CDR(sym) == ECL_NIL) { + cl_object pair; + sym = CAR(sym); + if (ECL_SYMBOLP(sym)) { + pair = ecl_setf_definition(sym, ECL_NIL); + @(return ecl_cdr(pair)); + } + } + } + } + FEinvalid_function_name(fname); } cl_object ecl_fdefinition(cl_object fun) { - cl_type t = ecl_t_of(fun); - cl_object output; + cl_type t = ecl_t_of(fun); + cl_object output; - if (t == t_symbol) { - output = ECL_SYM_FUN(fun); - unlikely_if (output == ECL_NIL) - FEundefined_function(fun); - unlikely_if (fun->symbol.stype & (ecl_stp_macro | ecl_stp_special_form)) - FEundefined_function(fun); - } else unlikely_if (Null(fun)) { - FEundefined_function(fun); - } else if (t == t_list) { - cl_object sym = CDR(fun); - unlikely_if (!CONSP(sym)) - FEinvalid_function_name(fun); - if (CAR(fun) == @'setf') { - unlikely_if (CDR(sym) != ECL_NIL) - FEinvalid_function_name(fun); - sym = CAR(sym); - unlikely_if (ecl_t_of(sym) != t_symbol) - FEinvalid_function_name(fun); - output = ecl_setf_definition(sym, ECL_NIL); - unlikely_if (Null(ecl_cdr(output))) - FEundefined_function(fun); - output = ECL_CONS_CAR(output); - } else if (CAR(fun) == @'lambda') { - return si_make_lambda(ECL_NIL, sym); - } else if (CAR(fun) == @'ext::lambda-block') { - return si_make_lambda(CAR(sym), CDR(sym)); - } else { - FEinvalid_function_name(fun); - } - } else { - FEinvalid_function_name(fun); - } - return output; + if (t == t_symbol) { + output = ECL_SYM_FUN(fun); + unlikely_if (output == ECL_NIL) + FEundefined_function(fun); + unlikely_if (fun->symbol.stype & (ecl_stp_macro | ecl_stp_special_form)) + FEundefined_function(fun); + } else unlikely_if (Null(fun)) { + FEundefined_function(fun); + } else if (t == t_list) { + cl_object sym = CDR(fun); + unlikely_if (!CONSP(sym)) + FEinvalid_function_name(fun); + if (CAR(fun) == @'setf') { + unlikely_if (CDR(sym) != ECL_NIL) + FEinvalid_function_name(fun); + sym = CAR(sym); + unlikely_if (ecl_t_of(sym) != t_symbol) + FEinvalid_function_name(fun); + output = ecl_setf_definition(sym, ECL_NIL); + unlikely_if (Null(ecl_cdr(output))) + FEundefined_function(fun); + output = ECL_CONS_CAR(output); + } else if (CAR(fun) == @'lambda') { + return si_make_lambda(ECL_NIL, sym); + } else if (CAR(fun) == @'ext::lambda-block') { + return si_make_lambda(CAR(sym), CDR(sym)); + } else { + FEinvalid_function_name(fun); + } + } else { + FEinvalid_function_name(fun); + } + return output; } cl_object si_coerce_to_function(cl_object fun) { - cl_type t = ecl_t_of(fun); - if (!(t == t_cfun || t == t_cfunfixed || t == t_cclosure - || t == t_bytecodes || t == t_bclosure - || (t == t_instance && fun->instance.isgf))) { - fun = ecl_fdefinition(fun); - } - @(return fun) + cl_type t = ecl_t_of(fun); + if (!(t == t_cfun || t == t_cfunfixed || t == t_cclosure + || t == t_bytecodes || t == t_bclosure + || (t == t_instance && fun->instance.isgf))) { + fun = ecl_fdefinition(fun); + } + @(return fun); } cl_object cl_symbol_value(cl_object sym) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object value; - if (Null(sym)) { - value = sym; - } else { - if (ecl_unlikely(!ECL_SYMBOLP(sym))) { - FEwrong_type_only_arg(@[symbol-value], sym, @[symbol]); - } - value = ECL_SYM_VAL(the_env, sym); - if (ecl_unlikely(value == OBJNULL)) { - FEunbound_variable(sym); - } - } - @(return value) + const cl_env_ptr the_env = ecl_process_env(); + cl_object value; + if (Null(sym)) { + value = sym; + } else { + if (ecl_unlikely(!ECL_SYMBOLP(sym))) { + FEwrong_type_only_arg(@[symbol-value], sym, @[symbol]); + } + value = ECL_SYM_VAL(the_env, sym); + if (ecl_unlikely(value == OBJNULL)) { + FEunbound_variable(sym); + } + } + @(return value); } bool ecl_boundp(cl_env_ptr env, cl_object sym) { - if (Null(sym)) { - return 1; - } else { - if (ecl_unlikely(!ECL_SYMBOLP(sym))) - FEwrong_type_only_arg(@[boundp], sym, @[symbol]); - return ECL_SYM_VAL(env, sym) != OBJNULL; - } + if (Null(sym)) { + return 1; + } else { + if (ecl_unlikely(!ECL_SYMBOLP(sym))) + FEwrong_type_only_arg(@[boundp], sym, @[symbol]); + return ECL_SYM_VAL(env, sym) != OBJNULL; + } } cl_object cl_boundp(cl_object sym) { - const cl_env_ptr the_env = ecl_process_env(); - ecl_return1(the_env, ecl_boundp(the_env,sym)? ECL_T : ECL_NIL); + const cl_env_ptr the_env = ecl_process_env(); + ecl_return1(the_env, ecl_boundp(the_env,sym)? ECL_T : ECL_NIL); } cl_object cl_special_operator_p(cl_object form) { - const cl_env_ptr the_env = ecl_process_env(); - int special = ecl_symbol_type(form) & ecl_stp_special_form; - ecl_return1(the_env, special? ECL_T : ECL_NIL); + const cl_env_ptr the_env = ecl_process_env(); + int special = ecl_symbol_type(form) & ecl_stp_special_form; + ecl_return1(the_env, special? ECL_T : ECL_NIL); } diff -Nru ecl-16.1.2/src/c/sequence.d ecl-16.1.3+ds/src/c/sequence.d --- ecl-16.1.2/src/c/sequence.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/sequence.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - sequence.d -- Sequence routines. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * sequence.d - sequence routines + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -26,278 +21,278 @@ ecl_sequence_start_end(cl_object fun, cl_object sequence, cl_object start, cl_object end) { - cl_index_pair p; - cl_index l; - p.length = l = ecl_length(sequence); - unlikely_if (!ECL_FIXNUMP(start) || ecl_fixnum_minusp(start)) { - FEwrong_type_key_arg(fun, @[:start], start, @[unsigned-byte]); - } - p.start = ecl_fixnum(start); - if (Null(end)) { - p.end = l; - } else { - unlikely_if (!ECL_FIXNUMP(end) || ecl_fixnum_minusp(end)) { - FEwrong_type_key_arg(fun, @[:end], end, - ecl_read_from_cstring("(OR NULL UNSIGNED-BYTE)")); - } - p.end = ecl_fixnum(end); - unlikely_if (p.end > l) { - cl_object fillp = ecl_make_fixnum(l); - FEwrong_type_key_arg(fun, @[:end], end, - ecl_make_integer_type(start, fillp)); - } - } - unlikely_if (p.end < p.start) { - FEwrong_type_key_arg(fun, @[:start], start, - ecl_make_integer_type(ecl_make_fixnum(0), - ecl_make_fixnum(p.end))); - } - return p; + cl_index_pair p; + cl_index l; + p.length = l = ecl_length(sequence); + unlikely_if (!ECL_FIXNUMP(start) || ecl_fixnum_minusp(start)) { + FEwrong_type_key_arg(fun, @[:start], start, @[unsigned-byte]); + } + p.start = ecl_fixnum(start); + if (Null(end)) { + p.end = l; + } else { + unlikely_if (!ECL_FIXNUMP(end) || ecl_fixnum_minusp(end)) { + FEwrong_type_key_arg(fun, @[:end], end, + ecl_read_from_cstring("(OR NULL UNSIGNED-BYTE)")); + } + p.end = ecl_fixnum(end); + unlikely_if (p.end > l) { + cl_object fillp = ecl_make_fixnum(l); + FEwrong_type_key_arg(fun, @[:end], end, + ecl_make_integer_type(start, fillp)); + } + } + unlikely_if (p.end < p.start) { + FEwrong_type_key_arg(fun, @[:start], start, + ecl_make_integer_type(ecl_make_fixnum(0), + ecl_make_fixnum(p.end))); + } + return p; } cl_object si_sequence_start_end(cl_object fun, cl_object sequence, cl_object start, cl_object end) { - cl_index_pair p = ecl_sequence_start_end(fun, sequence, start, end); - @(return ecl_make_fixnum(p.start) ecl_make_fixnum(p.end) - ecl_make_fixnum(p.length)); + cl_index_pair p = ecl_sequence_start_end(fun, sequence, start, end); + @(return ecl_make_fixnum(p.start) ecl_make_fixnum(p.end) + ecl_make_fixnum(p.length)); } cl_object cl_elt(cl_object x, cl_object i) { - @(return ecl_elt(x, ecl_to_size(i))) + @(return ecl_elt(x, ecl_to_size(i))); } cl_object ecl_elt(cl_object seq, cl_fixnum index) { - cl_fixnum i; - cl_object l; + cl_fixnum i; + cl_object l; - if (index < 0) - goto E; - switch (ecl_t_of(seq)) { - case t_list: - for (i = index, l = seq; i > 0; --i) { - if (!LISTP(l)) goto E0; - if (Null(l)) goto E; - l = ECL_CONS_CDR(l); - } - if (!LISTP(l)) goto E0; - if (Null(l)) goto E; - return ECL_CONS_CAR(l); + if (index < 0) + goto E; + switch (ecl_t_of(seq)) { + case t_list: + for (i = index, l = seq; i > 0; --i) { + if (!LISTP(l)) goto E0; + if (Null(l)) goto E; + l = ECL_CONS_CDR(l); + } + if (!LISTP(l)) goto E0; + if (Null(l)) goto E; + return ECL_CONS_CAR(l); #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_vector: - case t_bitvector: - case t_base_string: - if (index >= seq->vector.fillp) goto E; - return ecl_aref_unsafe(seq, index); - default: - E0: - FEtype_error_sequence(seq); - } -E: - FEtype_error_index(seq, index); + case t_vector: + case t_bitvector: + case t_base_string: + if (index >= seq->vector.fillp) goto E; + return ecl_aref_unsafe(seq, index); + default: + E0: + FEtype_error_sequence(seq); + } + E: + FEtype_error_index(seq, index); } cl_object si_elt_set(cl_object seq, cl_object index, cl_object val) { - @(return ecl_elt_set(seq, ecl_to_size(index), val)) + @(return ecl_elt_set(seq, ecl_to_size(index), val)); } cl_object ecl_elt_set(cl_object seq, cl_fixnum index, cl_object val) { - cl_fixnum i; - cl_object l; + cl_fixnum i; + cl_object l; - if (index < 0) - goto E; - switch (ecl_t_of(seq)) { - case t_list: - for (i = index, l = seq; i > 0; --i) { - if (!LISTP(l)) goto E0; - if (Null(l)) goto E; - l = ECL_CONS_CDR(l); - } - if (!LISTP(l)) goto E0; - if (Null(l)) goto E; - ECL_RPLACA(l, val); - return val; + if (index < 0) + goto E; + switch (ecl_t_of(seq)) { + case t_list: + for (i = index, l = seq; i > 0; --i) { + if (!LISTP(l)) goto E0; + if (Null(l)) goto E; + l = ECL_CONS_CDR(l); + } + if (!LISTP(l)) goto E0; + if (Null(l)) goto E; + ECL_RPLACA(l, val); + return val; #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_vector: - case t_bitvector: - case t_base_string: - if (index >= seq->vector.fillp) goto E; - return ecl_aset_unsafe(seq, index, val); - default: - E0: - FEtype_error_sequence(seq); - } -E: - FEtype_error_index(seq, index); + case t_vector: + case t_bitvector: + case t_base_string: + if (index >= seq->vector.fillp) goto E; + return ecl_aset_unsafe(seq, index, val); + default: + E0: + FEtype_error_sequence(seq); + } + E: + FEtype_error_index(seq, index); } cl_object ecl_subseq(cl_object sequence, cl_index start, cl_index limit) { - switch (ecl_t_of(sequence)) { - case t_list: - if (start) - sequence = ecl_nthcdr(start, sequence); - { - cl_object x = ECL_NIL; - cl_object *z = &x; - while (!Null(sequence) && (limit--)) { - if (ECL_ATOM(sequence)) - FEtype_error_cons(sequence); - z = &ECL_CONS_CDR(*z = ecl_list1(ECL_CONS_CAR(sequence))); - sequence = ECL_CONS_CDR(sequence); - } - return x; - } + switch (ecl_t_of(sequence)) { + case t_list: + if (start) + sequence = ecl_nthcdr(start, sequence); + { + cl_object x = ECL_NIL; + cl_object *z = &x; + while (!Null(sequence) && (limit--)) { + if (ECL_ATOM(sequence)) + FEtype_error_cons(sequence); + z = &ECL_CONS_CDR(*z = ecl_list1(ECL_CONS_CAR(sequence))); + sequence = ECL_CONS_CDR(sequence); + } + return x; + } #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_vector: - case t_bitvector: - case t_base_string: { - cl_index size; - cl_object x; - if (start > sequence->vector.fillp) { - x = ecl_alloc_simple_vector(0, ecl_array_elttype(sequence)); - } else { - size = sequence->vector.fillp - start; - if (size > limit) - size = limit; - x = ecl_alloc_simple_vector(size, ecl_array_elttype(sequence)); - ecl_copy_subarray(x, 0, sequence, start, size); - } - return x; - } - default: - FEtype_error_sequence(sequence); - } + case t_vector: + case t_bitvector: + case t_base_string: { + cl_index size; + cl_object x; + if (start > sequence->vector.fillp) { + x = ecl_alloc_simple_vector(0, ecl_array_elttype(sequence)); + } else { + size = sequence->vector.fillp - start; + if (size > limit) + size = limit; + x = ecl_alloc_simple_vector(size, ecl_array_elttype(sequence)); + ecl_copy_subarray(x, 0, sequence, start, size); + } + return x; + } + default: + FEtype_error_sequence(sequence); + } } cl_object ecl_copy_seq(cl_object sequence) { - return ecl_subseq(sequence, 0, MOST_POSITIVE_FIXNUM); + return ecl_subseq(sequence, 0, MOST_POSITIVE_FIXNUM); } @(defun subseq (sequence start &optional end &aux x) - cl_index_pair p; -@ - p = ecl_sequence_start_end(@[subseq], sequence, start, end); - sequence = ecl_subseq(sequence, p.start, p.end - p.start); - @(return sequence); -@) + cl_index_pair p; + @ + p = ecl_sequence_start_end(@[subseq], sequence, start, end); + sequence = ecl_subseq(sequence, p.start, p.end - p.start); + @(return sequence); + @) cl_object cl_copy_seq(cl_object x) { - @(return ecl_subseq(x, 0, MOST_POSITIVE_FIXNUM)); + @(return ecl_subseq(x, 0, MOST_POSITIVE_FIXNUM)); } cl_object cl_length(cl_object x) { - @(return ecl_make_fixnum(ecl_length(x))) + @(return ecl_make_fixnum(ecl_length(x))); } cl_fixnum ecl_length(cl_object x) { - cl_fixnum i; + cl_fixnum i; - switch (ecl_t_of(x)) { - case t_list: - /* INV: A list's length always fits in a fixnum */ - i = 0; - loop_for_in(x) { - i++; - } end_loop_for_in; - return(i); + switch (ecl_t_of(x)) { + case t_list: + /* INV: A list's length always fits in a fixnum */ + i = 0; + loop_for_in(x) { + i++; + } end_loop_for_in; + return(i); #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_vector: - case t_base_string: - case t_bitvector: - return(x->vector.fillp); - - default: - FEtype_error_sequence(x); - } + case t_vector: + case t_base_string: + case t_bitvector: + return(x->vector.fillp); + + default: + FEtype_error_sequence(x); + } } cl_object cl_reverse(cl_object seq) { - cl_object output, x; + cl_object output, x; - switch (ecl_t_of(seq)) { - case t_list: { - for (x = seq, output = ECL_NIL; !Null(x); x = ECL_CONS_CDR(x)) { - if (!LISTP(x)) goto E; - output = CONS(ECL_CONS_CAR(x), output); - } - break; - } + switch (ecl_t_of(seq)) { + case t_list: { + for (x = seq, output = ECL_NIL; !Null(x); x = ECL_CONS_CDR(x)) { + if (!LISTP(x)) goto E; + output = CONS(ECL_CONS_CAR(x), output); + } + break; + } #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_vector: - case t_bitvector: - case t_base_string: - output = ecl_alloc_simple_vector(seq->vector.fillp, ecl_array_elttype(seq)); - ecl_copy_subarray(output, 0, seq, 0, seq->vector.fillp); - ecl_reverse_subarray(output, 0, seq->vector.fillp); - break; - default: - E: - FEtype_error_sequence(seq); - } - @(return output) + case t_vector: + case t_bitvector: + case t_base_string: + output = ecl_alloc_simple_vector(seq->vector.fillp, ecl_array_elttype(seq)); + ecl_copy_subarray(output, 0, seq, 0, seq->vector.fillp); + ecl_reverse_subarray(output, 0, seq->vector.fillp); + break; + default: + E: + FEtype_error_sequence(seq); + } + @(return output); } cl_object cl_nreverse(cl_object seq) { - switch (ecl_t_of(seq)) { - case t_list: { - cl_object x, y, z; - for (x = seq, y = ECL_NIL; !Null(x); ) { - if (!LISTP(x)) FEtype_error_list(x); - z = x; - x = ECL_CONS_CDR(x); - if (x == seq) FEcircular_list(seq); - ECL_RPLACD(z, y); - y = z; - } - seq = y; - break; - } + switch (ecl_t_of(seq)) { + case t_list: { + cl_object x, y, z; + for (x = seq, y = ECL_NIL; !Null(x); ) { + if (!LISTP(x)) FEtype_error_list(x); + z = x; + x = ECL_CONS_CDR(x); + if (x == seq) FEcircular_list(seq); + ECL_RPLACD(z, y); + y = z; + } + seq = y; + break; + } #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_vector: - case t_base_string: - case t_bitvector: - ecl_reverse_subarray(seq, 0, seq->vector.fillp); - break; - default: - FEtype_error_sequence(seq); - } - @(return seq) + case t_vector: + case t_base_string: + case t_bitvector: + ecl_reverse_subarray(seq, 0, seq->vector.fillp); + break; + default: + FEtype_error_sequence(seq); + } + @(return seq); } diff -Nru ecl-16.1.2/src/c/serialize.d ecl-16.1.3+ds/src/c/serialize.d --- ecl-16.1.2/src/c/serialize.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/serialize.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - serialize.d -- Serialize a bunch of lisp data. -*/ -/* - Copyright (c) 2010, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * serialize.d - serialize a bunch of lisp data + * + * Copyright (c) 2010 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -21,128 +16,128 @@ #include struct fake_package { - _ECL_HDR; - cl_object name; + _ECL_HDR; + cl_object name; }; struct fake_symbol { - _ECL_HDR; - cl_object name; - cl_object pack; + _ECL_HDR; + cl_object name; + cl_object pack; }; -#define ROUND_TO_WORD(int) \ - ((int + sizeof(cl_fixnum) - 1) & ~(sizeof(cl_fixnum) - 1)) -#define ROUNDED_SIZE(name) \ - ROUND_TO_WORD(sizeof(struct name)) +#define ROUND_TO_WORD(int) \ + ((int + sizeof(cl_fixnum) - 1) & ~(sizeof(cl_fixnum) - 1)) +#define ROUNDED_SIZE(name) \ + ROUND_TO_WORD(sizeof(struct name)) static cl_index object_size[] = { - 0, /* t_start */ - ROUNDED_SIZE(ecl_cons), /* t_list */ - 0, /* t_character = 2 */ - 0, /* t_fixnum = 3 */ - ROUNDED_SIZE(ecl_bignum), /* t_bignum = 4 */ - ROUNDED_SIZE(ecl_ratio), /* t_ratio */ - ROUNDED_SIZE(ecl_singlefloat), /* t_singlefloat */ - ROUNDED_SIZE(ecl_doublefloat), /* t_doublefloat */ + 0, /* t_start */ + ROUNDED_SIZE(ecl_cons), /* t_list */ + 0, /* t_character = 2 */ + 0, /* t_fixnum = 3 */ + ROUNDED_SIZE(ecl_bignum), /* t_bignum = 4 */ + ROUNDED_SIZE(ecl_ratio), /* t_ratio */ + ROUNDED_SIZE(ecl_singlefloat), /* t_singlefloat */ + ROUNDED_SIZE(ecl_doublefloat), /* t_doublefloat */ #ifdef ECL_LONG_FLOAT - ROUNDED_SIZE(ecl_long_float), /* t_longfloat */ + ROUNDED_SIZE(ecl_long_float), /* t_longfloat */ #endif - ROUNDED_SIZE(ecl_complex), /* t_complex */ - ROUNDED_SIZE(fake_symbol), /* t_symbol */ - ROUNDED_SIZE(fake_package), /* t_package */ - ROUNDED_SIZE(ecl_hashtable), /* t_hashtable */ - ROUNDED_SIZE(ecl_array), /* t_array */ - ROUNDED_SIZE(ecl_vector), /* t_vector */ + ROUNDED_SIZE(ecl_complex), /* t_complex */ + ROUNDED_SIZE(fake_symbol), /* t_symbol */ + ROUNDED_SIZE(fake_package), /* t_package */ + ROUNDED_SIZE(ecl_hashtable), /* t_hashtable */ + ROUNDED_SIZE(ecl_array), /* t_array */ + ROUNDED_SIZE(ecl_vector), /* t_vector */ #ifdef ECL_UNICODE - ROUNDED_SIZE(ecl_string), /* t_string */ + ROUNDED_SIZE(ecl_string), /* t_string */ #endif - ROUNDED_SIZE(ecl_base_string), /* t_base_string */ - ROUNDED_SIZE(ecl_vector), /* t_bitvector */ - ROUNDED_SIZE(ecl_stream), /* t_stream */ - ROUNDED_SIZE(ecl_random), /* t_random */ - ROUNDED_SIZE(ecl_readtable), /* t_readtable */ - ROUNDED_SIZE(ecl_pathname), /* t_pathname */ - ROUNDED_SIZE(ecl_bytecodes), /* t_bytecodes */ - ROUNDED_SIZE(ecl_bclosure), /* t_bclosure */ - ROUNDED_SIZE(ecl_cfun), /* t_cfun */ - ROUNDED_SIZE(ecl_cfunfixed), /* t_cfunfixed */ - ROUNDED_SIZE(ecl_cclosure), /* t_cclosure */ - ROUNDED_SIZE(ecl_instance), /* t_instance */ + ROUNDED_SIZE(ecl_base_string), /* t_base_string */ + ROUNDED_SIZE(ecl_vector), /* t_bitvector */ + ROUNDED_SIZE(ecl_stream), /* t_stream */ + ROUNDED_SIZE(ecl_random), /* t_random */ + ROUNDED_SIZE(ecl_readtable), /* t_readtable */ + ROUNDED_SIZE(ecl_pathname), /* t_pathname */ + ROUNDED_SIZE(ecl_bytecodes), /* t_bytecodes */ + ROUNDED_SIZE(ecl_bclosure), /* t_bclosure */ + ROUNDED_SIZE(ecl_cfun), /* t_cfun */ + ROUNDED_SIZE(ecl_cfunfixed), /* t_cfunfixed */ + ROUNDED_SIZE(ecl_cclosure), /* t_cclosure */ + ROUNDED_SIZE(ecl_instance), /* t_instance */ #ifdef ECL_THREADS - ROUNDED_SIZE(ecl_process), /* t_process */ - ROUNDED_SIZE(ecl_lock), /* t_lock */ - ROUNDED_SIZE(ecl_rwlock), /* t_rwlock */ - ROUNDED_SIZE(ecl_condition_variable), /* t_condition_variable */ - ROUNDED_SIZE(ecl_semaphore), /* t_semaphore */ - ROUNDED_SIZE(ecl_barrier), /* t_barrier */ - ROUNDED_SIZE(ecl_mailbox), /* t_mailbox */ -#endif - ROUNDED_SIZE(ecl_codeblock), /* t_codeblock */ - ROUNDED_SIZE(ecl_foreign), /* t_foreign */ - ROUNDED_SIZE(ecl_frame), /* t_frame */ - ROUNDED_SIZE(ecl_weak_pointer) /* t_weak_pointer */ + ROUNDED_SIZE(ecl_process), /* t_process */ + ROUNDED_SIZE(ecl_lock), /* t_lock */ + ROUNDED_SIZE(ecl_rwlock), /* t_rwlock */ + ROUNDED_SIZE(ecl_condition_variable), /* t_condition_variable */ + ROUNDED_SIZE(ecl_semaphore), /* t_semaphore */ + ROUNDED_SIZE(ecl_barrier), /* t_barrier */ + ROUNDED_SIZE(ecl_mailbox), /* t_mailbox */ +#endif + ROUNDED_SIZE(ecl_codeblock), /* t_codeblock */ + ROUNDED_SIZE(ecl_foreign), /* t_foreign */ + ROUNDED_SIZE(ecl_frame), /* t_frame */ + ROUNDED_SIZE(ecl_weak_pointer) /* t_weak_pointer */ #ifdef ECL_SSE2 - , ROUNDED_SIZE(ecl_sse_pack) /* t_sse_pack */ + , ROUNDED_SIZE(ecl_sse_pack) /* t_sse_pack */ #endif }; typedef struct pool { - cl_object data; - cl_object hash; - cl_object queue; - cl_object last; + cl_object data; + cl_object hash; + cl_object queue; + cl_object last; } *pool_t; static cl_index alloc(pool_t pool, cl_index size) { - cl_index bytes = ROUND_TO_WORD(size); - cl_index fillp = pool->data->vector.fillp; - cl_index next_fillp = fillp + bytes; - if (next_fillp >= pool->data->vector.dim) { - cl_index new_dim = next_fillp + next_fillp / 2; - pool->data = _ecl_funcall3(@'adjust-array', pool->data, - ecl_make_fixnum(new_dim)); - } - pool->data->vector.fillp = next_fillp; - return fillp; + cl_index bytes = ROUND_TO_WORD(size); + cl_index fillp = pool->data->vector.fillp; + cl_index next_fillp = fillp + bytes; + if (next_fillp >= pool->data->vector.dim) { + cl_index new_dim = next_fillp + next_fillp / 2; + pool->data = _ecl_funcall3(@'adjust-array', pool->data, + ecl_make_fixnum(new_dim)); + } + pool->data->vector.fillp = next_fillp; + return fillp; } static cl_object fix_to_ptr(cl_object ptr) { - cl_fixnum i = (cl_fixnum)ptr; - return (cl_object)(i & ~ECL_IMMEDIATE_TAG); + cl_fixnum i = (cl_fixnum)ptr; + return (cl_object)(i & ~ECL_IMMEDIATE_TAG); } static cl_object enqueue(pool_t pool, cl_object what) { - cl_object record, index; - if (ECL_FIXNUMP(what) || ECL_CHARACTERP(what) || what == OBJNULL) { - return what; - } + cl_object record, index; + if (ECL_FIXNUMP(what) || ECL_CHARACTERP(what) || what == OBJNULL) { + return what; + } #ifdef ECL_SMALL_CONS - if (Null(what)) - return what; + if (Null(what)) + return what; #endif - index = ecl_gethash_safe(what, pool->hash, OBJNULL); - if (index == OBJNULL) { - cl_object cons; - index = ecl_make_fixnum(pool->hash->hash.entries); - ecl_sethash(what, pool->hash, index); - cons = ecl_cons(what, ECL_NIL); - ECL_RPLACD(pool->last, cons); - pool->last = cons; - } - return fix_to_ptr(index); + index = ecl_gethash_safe(what, pool->hash, OBJNULL); + if (index == OBJNULL) { + cl_object cons; + index = ecl_make_fixnum(pool->hash->hash.entries); + ecl_sethash(what, pool->hash, index); + cons = ecl_cons(what, ECL_NIL); + ECL_RPLACD(pool->last, cons); + pool->last = cons; + } + return fix_to_ptr(index); } #ifdef ECL_SMALL_CONS typedef struct { - _ECL_HDR; - cl_object car, cdr; + _ECL_HDR; + cl_object car, cdr; } large_cons; typedef large_cons *large_cons_ptr; #endif @@ -150,20 +145,20 @@ static cl_index serialize_bits(pool_t pool, void *data, cl_index size) { - cl_index index = alloc(pool, size); - memcpy(pool->data->vector.self.b8 + index, data, size); - return index; + cl_index index = alloc(pool, size); + memcpy(pool->data->vector.self.b8 + index, data, size); + return index; } static void serialize_object_ptr(pool_t pool, cl_object *ptr, cl_index dim) { - cl_index index = serialize_bits(pool, ptr, dim*sizeof(cl_object)); - for (; dim; dim--, index += sizeof(cl_object)) { - cl_object *p = (cl_object *)(pool->data->vector.self.b8 + index); - *p = enqueue(pool, *p); - p++; - } + cl_index index = serialize_bits(pool, ptr, dim*sizeof(cl_object)); + for (; dim; dim--, index += sizeof(cl_object)) { + cl_object *p = (cl_object *)(pool->data->vector.self.b8 + index); + *p = enqueue(pool, *p); + p++; + } } static void serialize_vector(pool_t pool, cl_object v); @@ -171,422 +166,422 @@ static void serialize_displaced_vector(pool_t pool, cl_object v) { - cl_object disp = v->vector.displaced; - cl_object to = ECL_CONS_CAR(disp); - if (Null(to)) { - v->vector.displaced = ECL_NIL; - serialize_vector(pool, v); - } else { - cl_index index = v->vector.self.b8 - to->vector.self.b8; - v->vector.displaced = enqueue(pool, to); - v->vector.self.b8 = (uint8_t*)index; - } + cl_object disp = v->vector.displaced; + cl_object to = ECL_CONS_CAR(disp); + if (Null(to)) { + v->vector.displaced = ECL_NIL; + serialize_vector(pool, v); + } else { + cl_index index = v->vector.self.b8 - to->vector.self.b8; + v->vector.displaced = enqueue(pool, to); + v->vector.self.b8 = (uint8_t*)index; + } } static void serialize_vector(pool_t pool, cl_object v) { - if (!Null(v->vector.displaced)) { - serialize_displaced_vector(pool, v); - } else if (v->vector.elttype == ecl_aet_object) { - serialize_object_ptr(pool, v->vector.self.t, v->vector.dim); - } else { - serialize_bits(pool, v->vector.self.b8, - v->vector.dim * ecl_aet_size[v->vector.elttype]); - } + if (!Null(v->vector.displaced)) { + serialize_displaced_vector(pool, v); + } else if (v->vector.elttype == ecl_aet_object) { + serialize_object_ptr(pool, v->vector.self.t, v->vector.dim); + } else { + serialize_bits(pool, v->vector.self.b8, + v->vector.dim * ecl_aet_size[v->vector.elttype]); + } } static void serialize_array(pool_t pool, cl_object a) { - serialize_bits(pool, a->array.dims, sizeof(cl_index) * a->array.rank); - serialize_vector(pool, a); + serialize_bits(pool, a->array.dims, sizeof(cl_index) * a->array.rank); + serialize_vector(pool, a); } static void serialize_one(pool_t pool, cl_object what) { - cl_index bytes, index; - cl_object buffer; + cl_index bytes, index; + cl_object buffer; #ifdef ECL_SMALL_CONS - if (ECL_LISTP(what)) { - cl_index bytes = ROUND_TO_WORD(sizeof(large_cons)); - cl_index index = alloc(pool, bytes); - large_cons_ptr cons = - (large_cons_ptr)(pool->data->vector.self.b8 + index); - memset(cons, 0, bytes); - cons->t = t_list; - cons->car = enqueue(pool, ECL_CONS_CAR(what)); - cons->cdr = enqueue(pool, ECL_CONS_CDR(what)); - return; - } -#endif - bytes = object_size[what->d.t]; - index = alloc(pool, bytes); - buffer = (cl_object)(pool->data->vector.self.b8 + index); - memcpy(buffer, what, bytes); - switch (buffer->d.t) { - case t_singlefloat: - case t_doublefloat: + if (ECL_LISTP(what)) { + cl_index bytes = ROUND_TO_WORD(sizeof(large_cons)); + cl_index index = alloc(pool, bytes); + large_cons_ptr cons = + (large_cons_ptr)(pool->data->vector.self.b8 + index); + memset(cons, 0, bytes); + cons->t = t_list; + cons->car = enqueue(pool, ECL_CONS_CAR(what)); + cons->cdr = enqueue(pool, ECL_CONS_CDR(what)); + return; + } +#endif + bytes = object_size[what->d.t]; + index = alloc(pool, bytes); + buffer = (cl_object)(pool->data->vector.self.b8 + index); + memcpy(buffer, what, bytes); + switch (buffer->d.t) { + case t_singlefloat: + case t_doublefloat: #ifdef ECL_LONG_FLOAT - case t_longfloat: + case t_longfloat: #endif - break; + break; #ifndef ECL_SMALL_CONS - case t_list: - buffer->cons.car = enqueue(pool, buffer->cons.car); - buffer->cons.cdr = enqueue(pool, buffer->cons.car); - break; -#endif - case t_bignum: { - cl_fixnum size = ECL_BIGNUM_SIZE(buffer); - cl_index dim = ((size < 0) ? (-size) : size); - cl_index bytes = dim * sizeof(mp_limb_t); - serialize_bits(pool, ECL_BIGNUM_LIMBS(buffer), bytes); - break; - } - case t_ratio: { - buffer->ratio.den = enqueue(pool, buffer->ratio.den); - buffer->ratio.num = enqueue(pool, buffer->ratio.num); - break; - } - case t_complex: { - buffer->complex.real = enqueue(pool, buffer->complex.real); - buffer->complex.imag = enqueue(pool, buffer->complex.imag); - break; - } + case t_list: + buffer->cons.car = enqueue(pool, buffer->cons.car); + buffer->cons.cdr = enqueue(pool, buffer->cons.car); + break; +#endif + case t_bignum: { + cl_fixnum size = ECL_BIGNUM_SIZE(buffer); + cl_index dim = ((size < 0) ? (-size) : size); + cl_index bytes = dim * sizeof(mp_limb_t); + serialize_bits(pool, ECL_BIGNUM_LIMBS(buffer), bytes); + break; + } + case t_ratio: { + buffer->ratio.den = enqueue(pool, buffer->ratio.den); + buffer->ratio.num = enqueue(pool, buffer->ratio.num); + break; + } + case t_complex: { + buffer->complex.real = enqueue(pool, buffer->complex.real); + buffer->complex.imag = enqueue(pool, buffer->complex.imag); + break; + } #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_vector: - case t_bitvector: - case t_base_string: { - serialize_vector(pool, buffer); - break; - } - case t_array: { - cl_index bytes = ROUND_TO_WORD(buffer->array.rank * - sizeof(cl_index)); - serialize_bits(pool, buffer->array.dims, bytes); - serialize_vector(pool, buffer); - break; - } - case t_package: { - struct fake_package *p = (struct fake_package *)buffer; - p->name = enqueue(pool, what->pack.name); - break; - } - case t_symbol: { - struct fake_symbol *p = (struct fake_symbol *)buffer; - p->name = enqueue(pool, what->symbol.name); - p->pack = enqueue(pool, what->symbol.hpack); - break; - } - case t_pathname: - buffer->pathname.host = - enqueue(pool, buffer->pathname.host); - buffer->pathname.device = - enqueue(pool, buffer->pathname.device); - buffer->pathname.directory = - enqueue(pool, buffer->pathname.directory); - buffer->pathname.name = enqueue(pool, buffer->pathname.name); - buffer->pathname.type = enqueue(pool, buffer->pathname.type); - buffer->pathname.version = - enqueue(pool, buffer->pathname.version); - break; - case t_random: { - buffer->random.value = enqueue(pool, buffer->random.value); - break; - } - case t_bclosure: { - buffer->bclosure.code = enqueue(pool, buffer->bclosure.code); - buffer->bclosure.lex = enqueue(pool, buffer->bclosure.lex); - } - case t_bytecodes: { - buffer->bytecodes.name = enqueue(pool, buffer->bytecodes.name); - buffer->bytecodes.definition = enqueue(pool, buffer->bytecodes.definition); - buffer->bytecodes.data = enqueue(pool, buffer->bytecodes.data); - buffer->bytecodes.file = enqueue(pool, buffer->bytecodes.file); - buffer->bytecodes.file_position = enqueue(pool, buffer->bytecodes.file_position); - buffer->bytecodes.code = serialize_bits(pool, buffer->bytecodes.code, - buffer->bytecodes.code_size); - } - default: - FEerror("Unable to serialize object ~A", 1, what); - } + case t_vector: + case t_bitvector: + case t_base_string: { + serialize_vector(pool, buffer); + break; + } + case t_array: { + cl_index bytes = ROUND_TO_WORD(buffer->array.rank * + sizeof(cl_index)); + serialize_bits(pool, buffer->array.dims, bytes); + serialize_vector(pool, buffer); + break; + } + case t_package: { + struct fake_package *p = (struct fake_package *)buffer; + p->name = enqueue(pool, what->pack.name); + break; + } + case t_symbol: { + struct fake_symbol *p = (struct fake_symbol *)buffer; + p->name = enqueue(pool, what->symbol.name); + p->pack = enqueue(pool, what->symbol.hpack); + break; + } + case t_pathname: + buffer->pathname.host = + enqueue(pool, buffer->pathname.host); + buffer->pathname.device = + enqueue(pool, buffer->pathname.device); + buffer->pathname.directory = + enqueue(pool, buffer->pathname.directory); + buffer->pathname.name = enqueue(pool, buffer->pathname.name); + buffer->pathname.type = enqueue(pool, buffer->pathname.type); + buffer->pathname.version = + enqueue(pool, buffer->pathname.version); + break; + case t_random: { + buffer->random.value = enqueue(pool, buffer->random.value); + break; + } + case t_bclosure: { + buffer->bclosure.code = enqueue(pool, buffer->bclosure.code); + buffer->bclosure.lex = enqueue(pool, buffer->bclosure.lex); + } + case t_bytecodes: { + buffer->bytecodes.name = enqueue(pool, buffer->bytecodes.name); + buffer->bytecodes.definition = enqueue(pool, buffer->bytecodes.definition); + buffer->bytecodes.data = enqueue(pool, buffer->bytecodes.data); + buffer->bytecodes.file = enqueue(pool, buffer->bytecodes.file); + buffer->bytecodes.file_position = enqueue(pool, buffer->bytecodes.file_position); + buffer->bytecodes.code_size = serialize_bits(pool, buffer->bytecodes.code, + buffer->bytecodes.code_size); + } + default: + FEerror("Unable to serialize object ~A", 1, what); + } } static void init_pool(pool_t pool, cl_object root) { - pool->data = si_make_vector(@'ext::byte8', - ecl_make_fixnum(1024), - ECL_T, - ecl_make_fixnum(2 * sizeof(cl_index)), - ECL_NIL, - ecl_make_fixnum(0)); - pool->hash = cl__make_hash_table(@'eql', ecl_make_fixnum(256), - cl_core.rehash_size, - cl_core.rehash_threshold); - ecl_sethash(root, pool->hash, ecl_make_fixnum(0)); - pool->queue = ecl_list1(root); - pool->last = pool->queue; + pool->data = si_make_vector(@'ext::byte8', + ecl_make_fixnum(1024), + ECL_T, + ecl_make_fixnum(2 * sizeof(cl_index)), + ECL_NIL, + ecl_make_fixnum(0)); + pool->hash = cl__make_hash_table(@'eql', ecl_make_fixnum(256), + cl_core.rehash_size, + cl_core.rehash_threshold); + ecl_sethash(root, pool->hash, ecl_make_fixnum(0)); + pool->queue = ecl_list1(root); + pool->last = pool->queue; } static cl_object close_pool(pool_t pool) { - pool->data->vector.self.index[0] = pool->data->vector.fillp; - pool->data->vector.self.index[1] = pool->hash->hash.entries; - return pool->data; + pool->data->vector.self.index[0] = pool->data->vector.fillp; + pool->data->vector.self.index[1] = pool->hash->hash.entries; + return pool->data; } cl_object si_serialize(cl_object root) { - struct pool pool[1]; - init_pool(pool, root); - while (!Null(pool->queue)) { - cl_object what = ECL_CONS_CAR(pool->queue); - serialize_one(pool, what); - pool->queue = ECL_CONS_CDR(pool->queue); - } - @(return close_pool(pool)); + struct pool pool[1]; + init_pool(pool, root); + while (!Null(pool->queue)) { + cl_object what = ECL_CONS_CAR(pool->queue); + serialize_one(pool, what); + pool->queue = ECL_CONS_CDR(pool->queue); + } + @(return close_pool(pool)); } static void * reconstruct_bits(uint8_t *data, cl_index bytes) { - void *output = ecl_alloc_atomic(bytes); - memcpy(output, data, bytes); - return output; + void *output = ecl_alloc_atomic(bytes); + memcpy(output, data, bytes); + return output; } static void * reconstruct_object_ptr(uint8_t *data, cl_index bytes) { - void *output = ecl_alloc(bytes); - memcpy(output, data, bytes); - return output; + void *output = ecl_alloc(bytes); + memcpy(output, data, bytes); + return output; } static uint8_t * reconstruct_bytecodes(cl_object o, uint8_t *data) { - o->bytecodes.code = reconstruct_bits(data, o->bytecodes.code_size); - data += o->bytecodes.code_size; - return data; + o->bytecodes.code = reconstruct_bits(data, o->bytecodes.code_size); + data += o->bytecodes.code_size; + return data; } static uint8_t * reconstruct_vector(cl_object v, uint8_t *data) { - if (v->vector.displaced == ECL_NIL) { - cl_type t = v->vector.elttype; - cl_index size = v->vector.dim * ecl_aet_size[t]; - cl_index bytes = ROUND_TO_WORD(size); - if (t == ecl_aet_object) { - v->vector.self.t = reconstruct_object_ptr(data, bytes); - } else { - v->vector.self.t = reconstruct_bits(data, size); - } - data += bytes; - } - return data; + if (v->vector.displaced == ECL_NIL) { + cl_type t = v->vector.elttype; + cl_index size = v->vector.dim * ecl_aet_size[t]; + cl_index bytes = ROUND_TO_WORD(size); + if (t == ecl_aet_object) { + v->vector.self.t = reconstruct_object_ptr(data, bytes); + } else { + v->vector.self.t = reconstruct_bits(data, size); + } + data += bytes; + } + return data; } static uint8_t * reconstruct_array(cl_object a, uint8_t *data) { - cl_index bytes = ROUND_TO_WORD(a->array.rank * sizeof(cl_index)); - a->array.dims = reconstruct_bits(data, bytes); - return reconstruct_vector(a, data + bytes); + cl_index bytes = ROUND_TO_WORD(a->array.rank * sizeof(cl_index)); + a->array.dims = reconstruct_bits(data, bytes); + return reconstruct_vector(a, data + bytes); } static uint8_t * duplicate_object(uint8_t *data, cl_object *output) { - cl_type t = ((cl_object)data)->d.t; - cl_object o = ecl_alloc_object(t); - cl_index bytes = object_size[t]; - memcpy(o, data, bytes); - *output = o; - return data + bytes; + cl_type t = ((cl_object)data)->d.t; + cl_object o = ecl_alloc_object(t); + cl_index bytes = object_size[t]; + memcpy(o, data, bytes); + *output = o; + return data + bytes; } static uint8_t * reconstruct_one(uint8_t *data, cl_object *output) { - cl_object o = (cl_object)data; - switch (o->d.t) { + cl_object o = (cl_object)data; + switch (o->d.t) { #ifdef ECL_SMALL_CONS - case t_list: { - large_cons_ptr c = (large_cons_ptr)data; - *output = ecl_cons(c->car, c->cdr); - data += ROUND_TO_WORD(sizeof(large_cons)); - break; - } + case t_list: { + large_cons_ptr c = (large_cons_ptr)data; + *output = ecl_cons(c->car, c->cdr); + data += ROUND_TO_WORD(sizeof(large_cons)); + break; + } #endif #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - case t_vector: - case t_bitvector: - data = duplicate_object(data, output); - data = reconstruct_vector(*output, data); - break; - case t_array: - data = duplicate_object(data, output); - data = reconstruct_array(*output, data); - break; - case t_package: - *output = (cl_object)data; - data += ROUND_TO_WORD(sizeof(struct fake_package)); - break; - case t_symbol: - *output = (cl_object)data; - data += ROUND_TO_WORD(sizeof(struct fake_symbol)); - break; - case t_bytecodes: - data = duplicate_object(data, output); - data = reconstruct_bytecodes(*output, data); - default: - data = duplicate_object(data, output); - } - return data; + case t_base_string: + case t_vector: + case t_bitvector: + data = duplicate_object(data, output); + data = reconstruct_vector(*output, data); + break; + case t_array: + data = duplicate_object(data, output); + data = reconstruct_array(*output, data); + break; + case t_package: + *output = (cl_object)data; + data += ROUND_TO_WORD(sizeof(struct fake_package)); + break; + case t_symbol: + *output = (cl_object)data; + data += ROUND_TO_WORD(sizeof(struct fake_symbol)); + break; + case t_bytecodes: + data = duplicate_object(data, output); + data = reconstruct_bytecodes(*output, data); + default: + data = duplicate_object(data, output); + } + return data; } static cl_object get_object(cl_object o_or_index, cl_object *o_list) { - if (ECL_IMMEDIATE(o_or_index)) { - return o_or_index; - } else { - cl_index i = (cl_index)o_or_index >> 2; - return o_list[i]; - } + if (ECL_IMMEDIATE(o_or_index)) { + return o_or_index; + } else { + cl_index i = (cl_index)o_or_index >> 2; + return o_list[i]; + } } static void fixup_vector(cl_object v, cl_object *o_list) { - if (!ECL_IMMEDIATE(v->vector.displaced)) { - cl_object disp = get_object(v->vector.displaced, o_list); - cl_object to = ECL_CONS_CAR(disp); - if (to != ECL_NIL) { - cl_index offset = (cl_index)v->vector.self.b8; - v->vector.displaced = ECL_NIL; - ecl_displace(v, to, ecl_make_fixnum(offset)); - return; - } - } - if (v->vector.elttype == ecl_aet_object) { - cl_index i; - cl_object *p = v->vector.self.t; - for (i = v->vector.dim; i; i--, p++) { - *p = get_object(*p, o_list); - } - } + if (!ECL_IMMEDIATE(v->vector.displaced)) { + cl_object disp = get_object(v->vector.displaced, o_list); + cl_object to = ECL_CONS_CAR(disp); + if (to != ECL_NIL) { + cl_index offset = (cl_index)v->vector.self.b8; + v->vector.displaced = ECL_NIL; + ecl_displace(v, to, ecl_make_fixnum(offset)); + return; + } + } + if (v->vector.elttype == ecl_aet_object) { + cl_index i; + cl_object *p = v->vector.self.t; + for (i = v->vector.dim; i; i--, p++) { + *p = get_object(*p, o_list); + } + } } static void fixup(cl_object o, cl_object *o_list) { #ifdef ECL_SMALL_CONS - if (ECL_LISTP(o)) { - ECL_RPLACA(o, get_object(ECL_CONS_CAR(o), o_list)); - ECL_RPLACD(o, get_object(ECL_CONS_CDR(o), o_list)); - return; - } -#endif - switch (o->d.t) { - case t_ratio: - o->ratio.den = get_object(o->ratio.den, o_list); - o->ratio.num = get_object(o->ratio.num, o_list); - break; - case t_complex: - o->complex.real = get_object(o->complex.real, o_list); - o->complex.imag = get_object(o->complex.imag, o_list); - break; + if (ECL_LISTP(o)) { + ECL_RPLACA(o, get_object(ECL_CONS_CAR(o), o_list)); + ECL_RPLACD(o, get_object(ECL_CONS_CDR(o), o_list)); + return; + } +#endif + switch (o->d.t) { + case t_ratio: + o->ratio.den = get_object(o->ratio.den, o_list); + o->ratio.num = get_object(o->ratio.num, o_list); + break; + case t_complex: + o->complex.real = get_object(o->complex.real, o_list); + o->complex.imag = get_object(o->complex.imag, o_list); + break; #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - case t_vector: - case t_bitvector: - case t_array: - fixup_vector(o, o_list); - break; - case t_pathname: - o->pathname.host = get_object(o->pathname.host, o_list); - o->pathname.device = - get_object(o->pathname.device, o_list); - o->pathname.directory = - get_object(o->pathname.directory, o_list); - o->pathname.name = get_object(o->pathname.name, o_list); - o->pathname.type = get_object(o->pathname.type, o_list); - o->pathname.version = - get_object(o->pathname.version, o_list); - break; - case t_random: - o->random.value = get_object(o->random.value, o_list); - break; - case t_bclosure: - o->bclosure.code = get_object(o->bclosure.code, o_list); - o->bclosure.lex = get_object(o->bclosure.lex, o_list); - o->bclosure.entry = _ecl_bclosure_dispatch_vararg; - break; - case t_bytecodes: - o->bytecodes.name = get_object(o->bytecodes.name, o_list); - o->bytecodes.definition = get_object(o->bytecodes.definition, o_list); - o->bytecodes.data = get_object(o->bytecodes.data, o_list); - o->bytecodes.file = get_object(o->bytecodes.file, o_list); - o->bytecodes.file_position = get_object(o->bytecodes.file_position, o_list); - o->bytecodes.entry = _ecl_bytecodes_dispatch_vararg; - break; - default: - break; - } + case t_base_string: + case t_vector: + case t_bitvector: + case t_array: + fixup_vector(o, o_list); + break; + case t_pathname: + o->pathname.host = get_object(o->pathname.host, o_list); + o->pathname.device = + get_object(o->pathname.device, o_list); + o->pathname.directory = + get_object(o->pathname.directory, o_list); + o->pathname.name = get_object(o->pathname.name, o_list); + o->pathname.type = get_object(o->pathname.type, o_list); + o->pathname.version = + get_object(o->pathname.version, o_list); + break; + case t_random: + o->random.value = get_object(o->random.value, o_list); + break; + case t_bclosure: + o->bclosure.code = get_object(o->bclosure.code, o_list); + o->bclosure.lex = get_object(o->bclosure.lex, o_list); + o->bclosure.entry = _ecl_bclosure_dispatch_vararg; + break; + case t_bytecodes: + o->bytecodes.name = get_object(o->bytecodes.name, o_list); + o->bytecodes.definition = get_object(o->bytecodes.definition, o_list); + o->bytecodes.data = get_object(o->bytecodes.data, o_list); + o->bytecodes.file = get_object(o->bytecodes.file, o_list); + o->bytecodes.file_position = get_object(o->bytecodes.file_position, o_list); + o->bytecodes.entry = _ecl_bytecodes_dispatch_vararg; + break; + default: + break; + } } cl_object ecl_deserialize(uint8_t *raw) { - cl_index *data = (cl_index*)raw; - cl_index i, num_el = data[1]; - cl_object *output = ecl_alloc(sizeof(cl_object) * num_el); - raw += 2*sizeof(cl_index); - for (i = 0; i < num_el; i++) { - raw = reconstruct_one(raw, output+i); - } - for (i = 0; i < num_el; i++) { - cl_object package = output[i]; - if (!ECL_IMMEDIATE(package) && package->d.t == t_package) { - cl_object name = get_object(package->pack.name, - output); - output[i] = ecl_find_package_nolock(name); - } - } - for (i = 0; i < num_el; i++) { - cl_object symbol = output[i]; - if (!ECL_IMMEDIATE(symbol) && symbol->d.t == t_symbol) { - struct fake_symbol *s = (struct fake_symbol *)symbol; - cl_object name = get_object(s->name, output); - cl_object pack = get_object(s->pack, output); - int flag; - output[i] = ecl_intern(name, pack, &flag); - } - } - for (i = 0; i < num_el; i++) { - fixup(output[i], output); - } - return output[0]; + cl_index *data = (cl_index*)raw; + cl_index i, num_el = data[1]; + cl_object *output = ecl_alloc(sizeof(cl_object) * num_el); + raw += 2*sizeof(cl_index); + for (i = 0; i < num_el; i++) { + raw = reconstruct_one(raw, output+i); + } + for (i = 0; i < num_el; i++) { + cl_object package = output[i]; + if (!ECL_IMMEDIATE(package) && package->d.t == t_package) { + cl_object name = get_object(package->pack.name, + output); + output[i] = ecl_find_package_nolock(name); + } + } + for (i = 0; i < num_el; i++) { + cl_object symbol = output[i]; + if (!ECL_IMMEDIATE(symbol) && symbol->d.t == t_symbol) { + struct fake_symbol *s = (struct fake_symbol *)symbol; + cl_object name = get_object(s->name, output); + cl_object pack = get_object(s->pack, output); + int flag; + output[i] = ecl_intern(name, pack, &flag); + } + } + for (i = 0; i < num_el; i++) { + fixup(output[i], output); + } + return output[0]; } cl_object si_deserialize(cl_object data) { - @(return ecl_deserialize(data->vector.self.b8)) + @(return ecl_deserialize(data->vector.self.b8)); } diff -Nru ecl-16.1.2/src/c/sse2.d ecl-16.1.3+ds/src/c/sse2.d --- ecl-16.1.2/src/c/sse2.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/sse2.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - sse2.c -- SSE2 vector type support -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * sse2.d - SSE2 vector type support + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -30,71 +25,71 @@ cl_object si_sse_pack_p(cl_object x) { - @(return (ECL_SSE_PACK_P(x) ? ECL_T : ECL_NIL)) + @(return (ECL_SSE_PACK_P(x) ? ECL_T : ECL_NIL)); } /* Element type substitution */ static void verify_sse_elttype(cl_elttype eltt) { - switch (eltt) { - case ecl_aet_sf: - case ecl_aet_df: - case ecl_aet_b8: - case ecl_aet_i8: + switch (eltt) { + case ecl_aet_sf: + case ecl_aet_df: + case ecl_aet_b8: + case ecl_aet_i8: #ifdef ecl_uint16_t - case ecl_aet_b16: - case ecl_aet_i16: + case ecl_aet_b16: + case ecl_aet_i16: #endif #ifdef ecl_uint32_t - case ecl_aet_b32: - case ecl_aet_i32: + case ecl_aet_b32: + case ecl_aet_i32: #endif #ifdef ecl_uint64_t - case ecl_aet_b64: - case ecl_aet_i64: + case ecl_aet_b64: + case ecl_aet_i64: #endif - break; /* OK */ - default: - FEerror("Invalid element type for an SSE pack: ~S", 1, ecl_elttype_to_symbol(eltt)); - } + break; /* OK */ + default: + FEerror("Invalid element type for an SSE pack: ~S", 1, ecl_elttype_to_symbol(eltt)); + } } static cl_elttype symbol_to_sse_elttype(cl_object type) { - cl_elttype eltt = ecl_symbol_to_elttype(type); - verify_sse_elttype(eltt); - return eltt; + cl_elttype eltt = ecl_symbol_to_elttype(type); + verify_sse_elttype(eltt); + return eltt; } cl_object si_sse_pack_as_elt_type(cl_object x, cl_object type) { - cl_elttype rtype; + cl_elttype rtype; - if (ecl_unlikely(!ECL_SSE_PACK_P(x))) { - FEwrong_type_nth_arg(@[ext::sse-pack-as-elt-type], 1, x, @[ext::sse-pack]); - } - - rtype = symbol_to_sse_elttype(type); - - if (x->sse.elttype != rtype) { - cl_object new = ecl_alloc_object(t_sse_pack); - new->sse.elttype = rtype; - new->sse.data.vi = x->sse.data.vi; - x = new; - } + if (ecl_unlikely(!ECL_SSE_PACK_P(x))) { + FEwrong_type_nth_arg(@[ext::sse-pack-as-elt-type], 1, x, @[ext::sse-pack]); + } + + rtype = symbol_to_sse_elttype(type); + + if (x->sse.elttype != rtype) { + cl_object new = ecl_alloc_object(t_sse_pack); + new->sse.elttype = rtype; + new->sse.data.vi = x->sse.data.vi; + x = new; + } - @(return x) + @(return x); } cl_object si_sse_pack_element_type(cl_object x) { - if (ecl_unlikely(!ECL_SSE_PACK_P(x))) { - FEwrong_type_nth_arg(@[ext::sse-pack-element-type], 1, x, @[ext::sse-pack]); - } + if (ecl_unlikely(!ECL_SSE_PACK_P(x))) { + FEwrong_type_nth_arg(@[ext::sse-pack-element-type], 1, x, @[ext::sse-pack]); + } - @(return ecl_elttype_to_symbol(x->sse.elttype) ecl_make_fixnum(x->sse.elttype)); + @(return ecl_elttype_to_symbol(x->sse.elttype) ecl_make_fixnum(x->sse.elttype)); } /* Conversion to and from specialized vectors */ @@ -102,42 +97,42 @@ cl_object si_sse_pack_to_vector(cl_object x, cl_object elt_type) { - cl_elttype etype; - cl_object vec; + cl_elttype etype; + cl_object vec; - if (ecl_unlikely(!ECL_SSE_PACK_P(x))) { - FEwrong_type_nth_arg(@[ext::sse-pack-to-vector], 1, x, @[ext::sse-pack]); - } + if (ecl_unlikely(!ECL_SSE_PACK_P(x))) { + FEwrong_type_nth_arg(@[ext::sse-pack-to-vector], 1, x, @[ext::sse-pack]); + } - etype = x->sse.elttype; - if (elt_type != ECL_NIL) - etype = symbol_to_sse_elttype(elt_type); + etype = x->sse.elttype; + if (elt_type != ECL_NIL) + etype = symbol_to_sse_elttype(elt_type); - vec = ecl_alloc_simple_vector(16/ecl_aet_size[etype], etype); - memcpy(vec->vector.self.b8, x->sse.data.b8, 16); + vec = ecl_alloc_simple_vector(16/ecl_aet_size[etype], etype); + memcpy(vec->vector.self.b8, x->sse.data.b8, 16); - @(return vec) + @(return vec); } cl_object si_vector_to_sse_pack(cl_object x) { - cl_object ssev; + cl_object ssev; - if (ecl_unlikely(!ECL_ARRAYP(x))) { - FEwrong_type_nth_arg(@[ext::vector-to-sse-pack], 1, x, @[array]); - } + if (ecl_unlikely(!ECL_ARRAYP(x))) { + FEwrong_type_nth_arg(@[ext::vector-to-sse-pack], 1, x, @[array]); + } - verify_sse_elttype(x->vector.elttype); + verify_sse_elttype(x->vector.elttype); - if (ecl_unlikely(x->vector.dim * ecl_aet_size[x->vector.elttype] != 16)) - FEerror("Wrong vector size in VECTOR-TO-SSE-PACK: ~S",1,ecl_make_fixnum(x->vector.dim)); + if (ecl_unlikely(x->vector.dim * ecl_aet_size[x->vector.elttype] != 16)) + FEerror("Wrong vector size in VECTOR-TO-SSE-PACK: ~S",1,ecl_make_fixnum(x->vector.dim)); - ssev = ecl_alloc_object(t_sse_pack); - ssev->sse.elttype = x->vector.elttype; - memcpy(ssev->sse.data.b8, x->vector.self.b8, 16); + ssev = ecl_alloc_object(t_sse_pack); + ssev->sse.elttype = x->vector.elttype; + memcpy(ssev->sse.data.b8, x->vector.self.b8, 16); - @(return ssev) + @(return ssev); } /* Boxing and unboxing. @@ -147,58 +142,58 @@ cl_object ecl_make_int_sse_pack(__m128i value) { - cl_object obj = ecl_alloc_object(t_sse_pack); - obj->sse.elttype = ecl_aet_b8; - obj->sse.data.vi = value; - @(return obj); + cl_object obj = ecl_alloc_object(t_sse_pack); + obj->sse.elttype = ecl_aet_b8; + obj->sse.data.vi = value; + @(return obj); } __m128i ecl_unbox_int_sse_pack(cl_object x) { - do { - if (ECL_SSE_PACK_P(x)) - return x->sse.data.vi; - x = ecl_type_error(@'coerce', "variable", x, @'ext::sse-pack'); - } while(1); + do { + if (ECL_SSE_PACK_P(x)) + return x->sse.data.vi; + x = ecl_type_error(@'coerce', "variable", x, @'ext::sse-pack'); + } while(1); } cl_object ecl_make_float_sse_pack(__m128 value) { - cl_object obj = ecl_alloc_object(t_sse_pack); - obj->sse.elttype = ecl_aet_sf; - obj->sse.data.vf = value; - @(return obj); + cl_object obj = ecl_alloc_object(t_sse_pack); + obj->sse.elttype = ecl_aet_sf; + obj->sse.data.vf = value; + @(return obj); } __m128 ecl_unbox_float_sse_pack(cl_object x) { - do { - if (ECL_SSE_PACK_P(x)) - return x->sse.data.vf; - x = ecl_type_error(@'coerce', "variable", x, @'ext::sse-pack'); - } while(1); + do { + if (ECL_SSE_PACK_P(x)) + return x->sse.data.vf; + x = ecl_type_error(@'coerce', "variable", x, @'ext::sse-pack'); + } while(1); } cl_object ecl_make_double_sse_pack(__m128d value) { - cl_object obj = ecl_alloc_object(t_sse_pack); - obj->sse.elttype = ecl_aet_df; - obj->sse.data.vd = value; - @(return obj); + cl_object obj = ecl_alloc_object(t_sse_pack); + obj->sse.elttype = ecl_aet_df; + obj->sse.data.vd = value; + @(return obj); } __m128d ecl_unbox_double_sse_pack(cl_object x) { - do { - if (ECL_SSE_PACK_P(x)) - return x->sse.data.vd; - x = ecl_type_error(@'coerce', "variable", x, @'ext::sse-pack'); - } while(1); + do { + if (ECL_SSE_PACK_P(x)) + return x->sse.data.vd; + x = ecl_type_error(@'coerce', "variable", x, @'ext::sse-pack'); + } while(1); } -#endif // ECL_SSE2 +#endif /* ECL_SSE2 */ diff -Nru ecl-16.1.2/src/c/stacks.d ecl-16.1.3+ds/src/c/stacks.d --- ecl-16.1.2/src/c/stacks.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/stacks.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - stacks.c -- Binding/History/Frame stacks. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * stacks.d - binding/history/frame stacks + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -31,91 +26,94 @@ static void cs_set_size(cl_env_ptr env, cl_index new_size) { - volatile char foo = 0; - cl_index margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; - env->cs_limit_size = new_size - 2*margin; + volatile char foo = 0; + cl_index margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; + env->cs_limit_size = new_size - (2*margin); #ifdef ECL_DOWN_STACK - if (&foo > env->cs_org - new_size + 16) { - env->cs_limit = env->cs_org - new_size + 2*margin; - if (env->cs_limit < env->cs_barrier) - env->cs_barrier = env->cs_limit; - } + if (&foo > (env->cs_org - new_size) + 16) { + env->cs_limit = (env->cs_org - new_size) + (2*margin); + if (env->cs_limit < env->cs_barrier) + env->cs_barrier = env->cs_limit; + } #else - if (&foo < env->cs_org + new_size - 16) { - env->cs_limit = env->cs_org + new_size - 2*margin; - if (env->cs_limit > env->cs_barrier) - env->cs_barrier = env->cs_limit; - } -#endif - else - ecl_internal_error("can't reset env->cs_limit."); - env->cs_size = new_size; + if (&foo < (env->cs_org + new_size) - 16) { + env->cs_limit = (env->cs_org + new_size) - (2*margin); + if (env->cs_limit > env->cs_barrier) + env->cs_barrier = env->cs_limit; + } +#endif + else + ecl_internal_error("can't reset env->cs_limit."); + env->cs_size = new_size; } void ecl_cs_overflow(void) { - static const char *stack_overflow_msg = - "\n;;;\n;;; Stack overflow.\n" - ";;; Jumping to the outermost toplevel prompt\n" - ";;;\n\n"; - cl_env_ptr env = ecl_process_env(); - cl_index margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; - cl_index size = env->cs_size; + static const char *stack_overflow_msg = + "\n;;;\n;;; Stack overflow.\n" + ";;; Jumping to the outermost toplevel prompt\n" + ";;;\n\n"; + cl_env_ptr env = ecl_process_env(); + cl_index margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; + cl_index size = env->cs_size; #ifdef ECL_DOWN_STACK - if (env->cs_limit > env->cs_org - size) - env->cs_limit -= margin; + if (env->cs_limit > env->cs_org - size) + env->cs_limit -= margin; #else - if (env->cs_limit < env->cs_org + size) - env->cs_limit += margin; + if (env->cs_limit < env->cs_org + size) + env->cs_limit += margin; #endif - else - ecl_unrecoverable_error(env, stack_overflow_msg); + else + ecl_unrecoverable_error(env, stack_overflow_msg); - if (env->cs_max_size == (cl_index)0 || env->cs_size < env->cs_max_size) - si_serror(6, make_constant_base_string("Extend stack size"), - @'ext::stack-overflow', - @':size', ecl_make_fixnum(size), - @':type', @'ext::c-stack'); - else - si_serror(6, ECL_NIL, - @'ext::stack-overflow', - @':size', ECL_NIL, - @':type', @'ext::c-stack'); - size += size/2; - if (size > env->cs_max_size) - size = env->cs_max_size; - cs_set_size(env, size); + if (env->cs_max_size == (cl_index)0 || env->cs_size < env->cs_max_size) + si_serror(6, make_constant_base_string("Extend stack size"), + @'ext::stack-overflow', + @':size', ecl_make_fixnum(size), + @':type', @'ext::c-stack'); + else + si_serror(6, ECL_NIL, + @'ext::stack-overflow', + @':size', ECL_NIL, + @':type', @'ext::c-stack'); + size += size/2; + if (size > env->cs_max_size) + size = env->cs_max_size; + cs_set_size(env, size); } void ecl_cs_set_org(cl_env_ptr env) { - /* Rough estimate. Not very safe. We assume that cl_boot() - * is invoked from the main() routine of the program. - */ - env->cs_org = (char*)(&env); - env->cs_barrier = env->cs_org; - env->cs_max_size = 0; + /* Rough estimate. Not very safe. We assume that cl_boot() + * is invoked from the main() routine of the program. + */ + env->cs_org = (char*)(&env); + env->cs_barrier = env->cs_org; + env->cs_max_size = 0; #if defined(HAVE_SYS_RESOURCE_H) && defined(RLIMIT_STACK) && !defined(NACL) - { - struct rlimit rl; - cl_index size; - getrlimit(RLIMIT_STACK, &rl); - if (rl.rlim_cur != RLIM_INFINITY) { - env->cs_max_size = rl.rlim_cur; - size = rl.rlim_cur / 2; - if (size > (cl_index)ecl_option_values[ECL_OPT_C_STACK_SIZE]) - ecl_set_option(ECL_OPT_C_STACK_SIZE, size); + { + struct rlimit rl; + cl_index size; + + if (!getrlimit(RLIMIT_STACK, &rl) && + ( rl.rlim_cur != RLIM_INFINITY + || rl.rlim_cur != RLIM_SAVED_MAX + || rl.rlim_cur != RLIM_SAVED_CUR) ) { + env->cs_max_size = rl.rlim_cur; + size = rl.rlim_cur / 2; + if (size < (cl_index)ecl_option_values[ECL_OPT_C_STACK_SIZE]) + ecl_set_option(ECL_OPT_C_STACK_SIZE, size); #ifdef ECL_DOWN_STACK - env->cs_barrier = env->cs_org - rl.rlim_cur - 1024; + env->cs_barrier = (env->cs_org - rl.rlim_cur) - 1024; #else - env->cs_barrier = env->cs_org + rl.rlim_cur + 1024; + env->cs_barrier = (env->cs_org + rl.rlim_cur) + 1024; #endif - } - } + } + } #endif - cs_set_size(env, ecl_option_values[ECL_OPT_C_STACK_SIZE]); + cs_set_size(env, ecl_option_values[ECL_OPT_C_STACK_SIZE]); } @@ -124,125 +122,125 @@ void ecl_bds_unwind_n(cl_env_ptr env, int n) { - while (n--) ecl_bds_unwind1(env); + while (n--) ecl_bds_unwind1(env); } static void ecl_bds_set_size(cl_env_ptr env, cl_index new_size) { - ecl_bds_ptr old_org = env->bds_org; - cl_index limit = env->bds_top - old_org; - if (new_size <= limit) { - FEerror("Cannot shrink the binding stack below ~D.", 1, - ecl_make_unsigned_integer(limit)); - } else { - cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; - ecl_bds_ptr org; - env->bds_limit_size = new_size - 2*margin; - org = ecl_alloc_atomic(new_size * sizeof(*org)); - - ecl_disable_interrupts_env(env); - memcpy(org, old_org, (limit + 1) * sizeof(*org)); - env->bds_top = org + limit; - env->bds_org = org; - env->bds_limit = org + (new_size - 2*margin); - env->bds_size = new_size; - ecl_enable_interrupts_env(env); + ecl_bds_ptr old_org = env->bds_org; + cl_index limit = env->bds_top - old_org; + if (new_size <= limit) { + FEerror("Cannot shrink the binding stack below ~D.", 1, + ecl_make_unsigned_integer(limit)); + } else { + cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; + ecl_bds_ptr org; + env->bds_limit_size = new_size - 2*margin; + org = ecl_alloc_atomic(new_size * sizeof(*org)); + + ecl_disable_interrupts_env(env); + memcpy(org, old_org, (limit + 1) * sizeof(*org)); + env->bds_top = org + limit; + env->bds_org = org; + env->bds_limit = org + (new_size - 2*margin); + env->bds_size = new_size; + ecl_enable_interrupts_env(env); - ecl_dealloc(old_org); - } + ecl_dealloc(old_org); + } } ecl_bds_ptr ecl_bds_overflow(void) { - static const char *stack_overflow_msg = - "\n;;;\n;;; Binding stack overflow.\n" - ";;; Jumping to the outermost toplevel prompt\n" - ";;;\n\n"; - cl_env_ptr env = ecl_process_env(); - cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; - cl_index size = env->bds_size; - ecl_bds_ptr org = env->bds_org; - ecl_bds_ptr last = org + size; - if (env->bds_limit >= last) { - ecl_unrecoverable_error(env, stack_overflow_msg); - } - env->bds_limit += margin; - si_serror(6, make_constant_base_string("Extend stack size"), - @'ext::stack-overflow', @':size', ecl_make_fixnum(size), - @':type', @'ext::binding-stack'); - ecl_bds_set_size(env, size + (size / 2)); - return env->bds_top; + static const char *stack_overflow_msg = + "\n;;;\n;;; Binding stack overflow.\n" + ";;; Jumping to the outermost toplevel prompt\n" + ";;;\n\n"; + cl_env_ptr env = ecl_process_env(); + cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; + cl_index size = env->bds_size; + ecl_bds_ptr org = env->bds_org; + ecl_bds_ptr last = org + size; + if (env->bds_limit >= last) { + ecl_unrecoverable_error(env, stack_overflow_msg); + } + env->bds_limit += margin; + si_serror(6, make_constant_base_string("Extend stack size"), + @'ext::stack-overflow', @':size', ecl_make_fixnum(size), + @':type', @'ext::binding-stack'); + ecl_bds_set_size(env, size + (size / 2)); + return env->bds_top; } void ecl_bds_unwind(cl_env_ptr env, cl_index new_bds_top_index) { - ecl_bds_ptr new_bds_top = new_bds_top_index + env->bds_org; - ecl_bds_ptr bds = env->bds_top; - for (; bds > new_bds_top; bds--) + ecl_bds_ptr new_bds_top = new_bds_top_index + env->bds_org; + ecl_bds_ptr bds = env->bds_top; + for (; bds > new_bds_top; bds--) #ifdef ECL_THREADS - ecl_bds_unwind1(env); + ecl_bds_unwind1(env); #else - bds->symbol->symbol.value = bds->value; + bds->symbol->symbol.value = bds->value; #endif - env->bds_top = new_bds_top; + env->bds_top = new_bds_top; } cl_index ecl_progv(cl_env_ptr env, cl_object vars0, cl_object values0) { - cl_object vars = vars0, values = values0; - cl_index n = env->bds_top - env->bds_org; - for (; LISTP(vars) && LISTP(values); vars = ECL_CONS_CDR(vars)) { - if (Null(vars)) { - return n; - } else { - cl_object var = ECL_CONS_CAR(vars); - if (Null(values)) { - ecl_bds_bind(env, var, OBJNULL); - } else { - ecl_bds_bind(env, var, ECL_CONS_CAR(values)); - values = ECL_CONS_CDR(values); - } - } - } - FEerror("Wrong arguments to special form PROGV. Either~%" - "~A~%or~%~A~%are not proper lists", - 2, vars0, values0); + cl_object vars = vars0, values = values0; + cl_index n = env->bds_top - env->bds_org; + for (; LISTP(vars) && LISTP(values); vars = ECL_CONS_CDR(vars)) { + if (Null(vars)) { + return n; + } else { + cl_object var = ECL_CONS_CAR(vars); + if (Null(values)) { + ecl_bds_bind(env, var, OBJNULL); + } else { + ecl_bds_bind(env, var, ECL_CONS_CAR(values)); + values = ECL_CONS_CDR(values); + } + } + } + FEerror("Wrong arguments to special form PROGV. Either~%" + "~A~%or~%~A~%are not proper lists", + 2, vars0, values0); } static ecl_bds_ptr get_bds_ptr(cl_object x) { - if (ECL_FIXNUMP(x)) { - cl_env_ptr env = ecl_process_env(); - ecl_bds_ptr p = env->bds_org + ecl_fixnum(x); - if (env->bds_org <= p && p <= env->bds_top) - return(p); - } - FEerror("~S is an illegal bds index.", 1, x); + if (ECL_FIXNUMP(x)) { + cl_env_ptr env = ecl_process_env(); + ecl_bds_ptr p = env->bds_org + ecl_fixnum(x); + if (env->bds_org <= p && p <= env->bds_top) + return(p); + } + FEerror("~S is an illegal bds index.", 1, x); } cl_object si_bds_top() { - cl_env_ptr env = ecl_process_env(); - @(return ecl_make_fixnum(env->bds_top - env->bds_org)) + cl_env_ptr env = ecl_process_env(); + @(return ecl_make_fixnum(env->bds_top - env->bds_org)); } cl_object si_bds_var(cl_object arg) { - @(return get_bds_ptr(arg)->symbol) + @(return get_bds_ptr(arg)->symbol); } cl_object si_bds_val(cl_object arg) { - cl_object v = get_bds_ptr(arg)->value; - @(return ((v == OBJNULL)? ECL_UNBOUND : v)) + cl_object v = get_bds_ptr(arg)->value; + @(return ((v == OBJNULL)? ECL_UNBOUND : v)); } #ifdef ecl_bds_bind @@ -260,47 +258,47 @@ static cl_index ecl_new_binding_index(cl_env_ptr env, cl_object symbol) { - cl_object pool; - cl_index new_index = symbol->symbol.binding; - if (new_index == ECL_MISSING_SPECIAL_BINDING) { - pool = ecl_atomic_pop(&cl_core.reused_indices); - if (!Null(pool)) { - new_index = ecl_fixnum(ECL_CONS_CAR(pool)); - } else { - new_index = ecl_atomic_index_incf(&cl_core.last_var_index); - } - symbol->symbol.binding = new_index; - symbol->symbol.dynamic |= 1; - } - si_set_finalizer(symbol, ECL_T); - return new_index; + cl_object pool; + cl_index new_index = symbol->symbol.binding; + if (new_index == ECL_MISSING_SPECIAL_BINDING) { + pool = ecl_atomic_pop(&cl_core.reused_indices); + if (!Null(pool)) { + new_index = ecl_fixnum(ECL_CONS_CAR(pool)); + } else { + new_index = ecl_atomic_index_incf(&cl_core.last_var_index); + } + symbol->symbol.binding = new_index; + symbol->symbol.dynamic |= 1; + } + si_set_finalizer(symbol, ECL_T); + return new_index; } static cl_object ecl_extend_bindings_array(cl_object vector) { - cl_index new_size = cl_core.last_var_index * 1.25; - cl_object new_vector = si_make_vector(ECL_T, ecl_make_fixnum(new_size), ECL_NIL, - ECL_NIL, ECL_NIL, ECL_NIL); - si_fill_array_with_elt(new_vector, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL); - ecl_copy_subarray(new_vector, 0, vector, 0, vector->vector.dim); - return new_vector; + cl_index new_size = cl_core.last_var_index * 1.25; + cl_object new_vector = si_make_vector(ECL_T, ecl_make_fixnum(new_size), ECL_NIL, + ECL_NIL, ECL_NIL, ECL_NIL); + si_fill_array_with_elt(new_vector, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL); + ecl_copy_subarray(new_vector, 0, vector, 0, vector->vector.dim); + return new_vector; } static cl_index invalid_or_too_large_binding_index(cl_env_ptr env, cl_object s) { - cl_index index = s->symbol.binding; - if (index == ECL_MISSING_SPECIAL_BINDING) { - index = ecl_new_binding_index(env, s); - } - if (index >= env->thread_local_bindings_size) { - cl_object vector = env->bindings_array; - env->bindings_array = vector = ecl_extend_bindings_array(vector); - env->thread_local_bindings_size = vector->vector.dim; - env->thread_local_bindings = vector->vector.self.t; - } - return index; + cl_index index = s->symbol.binding; + if (index == ECL_MISSING_SPECIAL_BINDING) { + index = ecl_new_binding_index(env, s); + } + if (index >= env->thread_local_bindings_size) { + cl_object vector = env->bindings_array; + env->bindings_array = vector = ecl_extend_bindings_array(vector); + env->thread_local_bindings_size = vector->vector.dim; + env->thread_local_bindings = vector->vector.self.t; + } + return index; } #endif /* ECL_THREADS */ @@ -311,23 +309,23 @@ ecl_bds_bind(cl_env_ptr env, cl_object s, cl_object v) { #ifdef ECL_THREADS - cl_object *location; - ecl_bds_ptr slot; - cl_index index = s->symbol.binding; - if (index >= env->thread_local_bindings_size) { - index = invalid_or_too_large_binding_index(env,s); - } - location = env->thread_local_bindings + index; - slot = ++env->bds_top; - if (slot >= env->bds_limit) slot = ecl_bds_overflow(); - slot->symbol = s; - slot->value = *location; - *location = v; + cl_object *location; + ecl_bds_ptr slot; + cl_index index = s->symbol.binding; + if (index >= env->thread_local_bindings_size) { + index = invalid_or_too_large_binding_index(env,s); + } + location = env->thread_local_bindings + index; + slot = ++env->bds_top; + if (slot >= env->bds_limit) slot = ecl_bds_overflow(); + slot->symbol = s; + slot->value = *location; + *location = v; #else - ecl_bds_check(env); - (++(env->bds_top))->symbol = s; - env->bds_top->value = s->symbol.value; \ - s->symbol.value = v; + ecl_bds_check(env); + (++(env->bds_top))->symbol = s; + env->bds_top->value = s->symbol.value; \ + s->symbol.value = v; #endif } @@ -335,35 +333,35 @@ ecl_bds_push(cl_env_ptr env, cl_object s) { #ifdef ECL_THREADS - cl_object *location; - ecl_bds_ptr slot; - cl_index index = s->symbol.binding; - if (index >= env->thread_local_bindings_size) { - index = invalid_or_too_large_binding_index(env,s); - } - location = env->thread_local_bindings + index; - slot = ++env->bds_top; - if (slot >= env->bds_limit) slot = ecl_bds_overflow(); - slot->symbol = s; - slot->value = *location; - if (*location == ECL_NO_TL_BINDING) *location = s->symbol.value; + cl_object *location; + ecl_bds_ptr slot; + cl_index index = s->symbol.binding; + if (index >= env->thread_local_bindings_size) { + index = invalid_or_too_large_binding_index(env,s); + } + location = env->thread_local_bindings + index; + slot = ++env->bds_top; + if (slot >= env->bds_limit) slot = ecl_bds_overflow(); + slot->symbol = s; + slot->value = *location; + if (*location == ECL_NO_TL_BINDING) *location = s->symbol.value; #else - ecl_bds_check(env); - (++(env->bds_top))->symbol = s; - env->bds_top->value = s->symbol.value; + ecl_bds_check(env); + (++(env->bds_top))->symbol = s; + env->bds_top->value = s->symbol.value; #endif } void ecl_bds_unwind1(cl_env_ptr env) { - ecl_bds_ptr slot = env->bds_top--; - cl_object s = slot->symbol; + ecl_bds_ptr slot = env->bds_top--; + cl_object s = slot->symbol; #ifdef ECL_THREADS - cl_object *location = env->thread_local_bindings + s->symbol.binding; - *location = slot->value; + cl_object *location = env->thread_local_bindings + s->symbol.binding; + *location = slot->value; #else - s->symbol.value = slot->value; + s->symbol.value = slot->value; #endif } @@ -371,30 +369,30 @@ cl_object ecl_bds_read(cl_env_ptr env, cl_object s) { - cl_index index = s->symbol.binding; - if (index < env->thread_local_bindings_size) { - cl_object x = env->thread_local_bindings[index]; - if (x != ECL_NO_TL_BINDING) return x; - } - return s->symbol.value; + cl_index index = s->symbol.binding; + if (index < env->thread_local_bindings_size) { + cl_object x = env->thread_local_bindings[index]; + if (x != ECL_NO_TL_BINDING) return x; + } + return s->symbol.value; } cl_object * ecl_bds_ref(cl_env_ptr env, cl_object s) { - cl_index index = s->symbol.binding; - if (index < env->thread_local_bindings_size) { - cl_object *location = env->thread_local_bindings + index; - if (*location != ECL_NO_TL_BINDING) - return location; - } - return &(s->symbol.value); + cl_index index = s->symbol.binding; + if (index < env->thread_local_bindings_size) { + cl_object *location = env->thread_local_bindings + index; + if (*location != ECL_NO_TL_BINDING) + return location; + } + return &(s->symbol.value); } cl_object ecl_bds_set(cl_env_ptr env, cl_object s, cl_object value) { - return *ecl_bds_ref(env, s) = value; + return *ecl_bds_ref(env, s) = value; } #endif /* ECL_THREADS */ @@ -403,78 +401,78 @@ static cl_object ihs_function_name(cl_object x) { - cl_object y; + cl_object y; - switch (ecl_t_of(x)) { - case t_symbol: - return(x); - - case t_bclosure: - x = x->bclosure.code; - - case t_bytecodes: - y = x->bytecodes.name; - if (Null(y)) - return(@'lambda'); - else - return y; - - case t_cfun: - case t_cfunfixed: - return(x->cfun.name); - - default: - return(ECL_NIL); - } + switch (ecl_t_of(x)) { + case t_symbol: + return(x); + + case t_bclosure: + x = x->bclosure.code; + + case t_bytecodes: + y = x->bytecodes.name; + if (Null(y)) + return(@'lambda'); + else + return y; + + case t_cfun: + case t_cfunfixed: + return(x->cfun.name); + + default: + return(ECL_NIL); + } } static ecl_ihs_ptr get_ihs_ptr(cl_index n) { - cl_env_ptr env = ecl_process_env(); - ecl_ihs_ptr p = env->ihs_top; - if (n > p->index) - FEerror("~D is an illegal IHS index.", 1, ecl_make_fixnum(n)); - while (n < p->index) - p = p->next; - return p; + cl_env_ptr env = ecl_process_env(); + ecl_ihs_ptr p = env->ihs_top; + if (n > p->index) + FEerror("~D is an illegal IHS index.", 1, ecl_make_fixnum(n)); + while (n < p->index) + p = p->next; + return p; } cl_object si_ihs_top(void) { - cl_env_ptr env = ecl_process_env(); - @(return ecl_make_fixnum(env->ihs_top->index)) + cl_env_ptr env = ecl_process_env(); + @(return ecl_make_fixnum(env->ihs_top->index)); } cl_object si_ihs_prev(cl_object x) { - @(return cl_1M(x)) + @(return cl_1M(x)); } cl_object si_ihs_next(cl_object x) { - @(return cl_1P(x)) + @(return cl_1P(x)); } cl_object si_ihs_bds(cl_object arg) { - @(return ecl_make_fixnum(get_ihs_ptr(ecl_to_size(arg))->bds)) + @(return ecl_make_fixnum(get_ihs_ptr(ecl_to_size(arg))->bds)); } cl_object si_ihs_fun(cl_object arg) { - @(return get_ihs_ptr(ecl_to_size(arg))->function) + @(return get_ihs_ptr(ecl_to_size(arg))->function); } cl_object si_ihs_env(cl_object arg) { - @(return get_ihs_ptr(ecl_to_size(arg))->lex_env) + @(return get_ihs_ptr(ecl_to_size(arg))->lex_env); } /********************** FRAME STACK *************************/ @@ -482,137 +480,137 @@ static void frs_set_size(cl_env_ptr env, cl_index new_size) { - ecl_frame_ptr old_org = env->frs_org; - cl_index limit = env->frs_top - old_org; - if (new_size <= limit) { - FEerror("Cannot shrink frame stack below ~D.", 1, - ecl_make_unsigned_integer(limit)); - } else { - cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; - ecl_frame_ptr org; - env->frs_limit_size = new_size - 2*margin; - org = ecl_alloc_atomic(new_size * sizeof(*org)); - - ecl_disable_interrupts_env(env); - memcpy(org, old_org, (limit + 1) * sizeof(*org)); - env->frs_top = org + limit; - env->frs_org = org; - env->frs_limit = org + (new_size - 2*margin); - env->frs_size = new_size; - ecl_enable_interrupts_env(env); + ecl_frame_ptr old_org = env->frs_org; + cl_index limit = env->frs_top - old_org; + if (new_size <= limit) { + FEerror("Cannot shrink frame stack below ~D.", 1, + ecl_make_unsigned_integer(limit)); + } else { + cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; + ecl_frame_ptr org; + env->frs_limit_size = new_size - 2*margin; + org = ecl_alloc_atomic(new_size * sizeof(*org)); + + ecl_disable_interrupts_env(env); + memcpy(org, old_org, (limit + 1) * sizeof(*org)); + env->frs_top = org + limit; + env->frs_org = org; + env->frs_limit = org + (new_size - 2*margin); + env->frs_size = new_size; + ecl_enable_interrupts_env(env); - ecl_dealloc(old_org); - } + ecl_dealloc(old_org); + } } static void frs_overflow(void) /* used as condition in list.d */ { - static const char *stack_overflow_msg = - "\n;;;\n;;; Frame stack overflow.\n" - ";;; Jumping to the outermost toplevel prompt\n" - ";;;\n\n"; - cl_env_ptr env = ecl_process_env(); - cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; - cl_index size = env->frs_size; - ecl_frame_ptr org = env->frs_org; - ecl_frame_ptr last = org + size; - if (env->frs_limit >= last) { - ecl_unrecoverable_error(env, stack_overflow_msg); - } - env->frs_limit += margin; - si_serror(6, make_constant_base_string("Extend stack size"), - @'ext::stack-overflow', @':size', ecl_make_fixnum(size), - @':type', @'ext::frame-stack'); - frs_set_size(env, size + size / 2); + static const char *stack_overflow_msg = + "\n;;;\n;;; Frame stack overflow.\n" + ";;; Jumping to the outermost toplevel prompt\n" + ";;;\n\n"; + cl_env_ptr env = ecl_process_env(); + cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; + cl_index size = env->frs_size; + ecl_frame_ptr org = env->frs_org; + ecl_frame_ptr last = org + size; + if (env->frs_limit >= last) { + ecl_unrecoverable_error(env, stack_overflow_msg); + } + env->frs_limit += margin; + si_serror(6, make_constant_base_string("Extend stack size"), + @'ext::stack-overflow', @':size', ecl_make_fixnum(size), + @':type', @'ext::frame-stack'); + frs_set_size(env, size + size / 2); } ecl_frame_ptr _ecl_frs_push(register cl_env_ptr env, register cl_object val) { - ecl_frame_ptr output = ++env->frs_top; - if (output >= env->frs_limit) { - frs_overflow(); - output = env->frs_top; - } - output->frs_bds_top_index = env->bds_top - env->bds_org; - output->frs_val = val; - output->frs_ihs = env->ihs_top; - output->frs_sp = ECL_STACK_INDEX(env); - return output; + ecl_frame_ptr output = ++env->frs_top; + if (output >= env->frs_limit) { + frs_overflow(); + output = env->frs_top; + } + output->frs_bds_top_index = env->bds_top - env->bds_org; + output->frs_val = val; + output->frs_ihs = env->ihs_top; + output->frs_sp = ECL_STACK_INDEX(env); + return output; } void ecl_unwind(cl_env_ptr env, ecl_frame_ptr fr) { - env->nlj_fr = fr; - while (env->frs_top != fr && env->frs_top->frs_val != ECL_PROTECT_TAG) - --env->frs_top; - env->ihs_top = env->frs_top->frs_ihs; - ecl_bds_unwind(env, env->frs_top->frs_bds_top_index); - ECL_STACK_SET_INDEX(env, env->frs_top->frs_sp); - ecl_longjmp(env->frs_top->frs_jmpbuf, 1); - /* never reached */ + env->nlj_fr = fr; + while (env->frs_top != fr && env->frs_top->frs_val != ECL_PROTECT_TAG) + --env->frs_top; + env->ihs_top = env->frs_top->frs_ihs; + ecl_bds_unwind(env, env->frs_top->frs_bds_top_index); + ECL_STACK_SET_INDEX(env, env->frs_top->frs_sp); + ecl_longjmp(env->frs_top->frs_jmpbuf, 1); + /* never reached */ } ecl_frame_ptr frs_sch (cl_object frame_id) { - cl_env_ptr env = ecl_process_env(); - ecl_frame_ptr top; - for (top = env->frs_top; top >= env->frs_org; top--) - if (top->frs_val == frame_id) - return(top); - return(NULL); + cl_env_ptr env = ecl_process_env(); + ecl_frame_ptr top; + for (top = env->frs_top; top >= env->frs_org; top--) + if (top->frs_val == frame_id) + return(top); + return(NULL); } static ecl_frame_ptr get_frame_ptr(cl_object x) { - if (ECL_FIXNUMP(x)) { - cl_env_ptr env = ecl_process_env(); - ecl_frame_ptr p = env->frs_org + ecl_fixnum(x); - if (env->frs_org <= p && p <= env->frs_top) - return p; - } - FEerror("~S is an illegal frs index.", 1, x); + if (ECL_FIXNUMP(x)) { + cl_env_ptr env = ecl_process_env(); + ecl_frame_ptr p = env->frs_org + ecl_fixnum(x); + if (env->frs_org <= p && p <= env->frs_top) + return p; + } + FEerror("~S is an illegal frs index.", 1, x); } cl_object si_frs_top() { - cl_env_ptr env = ecl_process_env(); - @(return ecl_make_fixnum(env->frs_top - env->frs_org)) + cl_env_ptr env = ecl_process_env(); + @(return ecl_make_fixnum(env->frs_top - env->frs_org)); } cl_object si_frs_bds(cl_object arg) { - @(return ecl_make_fixnum(get_frame_ptr(arg)->frs_bds_top_index)) + @(return ecl_make_fixnum(get_frame_ptr(arg)->frs_bds_top_index)); } cl_object si_frs_tag(cl_object arg) { - @(return get_frame_ptr(arg)->frs_val) + @(return get_frame_ptr(arg)->frs_val); } cl_object si_frs_ihs(cl_object arg) { - @(return ecl_make_fixnum(get_frame_ptr(arg)->frs_ihs->index)) + @(return ecl_make_fixnum(get_frame_ptr(arg)->frs_ihs->index)); } cl_object si_sch_frs_base(cl_object fr, cl_object ihs) { - cl_env_ptr env = ecl_process_env(); - ecl_frame_ptr x; - cl_index y = ecl_to_size(ihs); - for (x = get_frame_ptr(fr); - x <= env->frs_top && x->frs_ihs->index < y; - x++); - @(return ((x > env->frs_top) ? ECL_NIL : ecl_make_fixnum(x - env->frs_org))) + cl_env_ptr env = ecl_process_env(); + ecl_frame_ptr x; + cl_index y = ecl_to_size(ihs); + for (x = get_frame_ptr(fr); + x <= env->frs_top && x->frs_ihs->index < y; + x++); + @(return ((x > env->frs_top) ? ECL_NIL : ecl_make_fixnum(x - env->frs_org))); } /********************* INITIALIZATION ***********************/ @@ -620,93 +618,94 @@ cl_object si_set_limit(cl_object type, cl_object limit) { - cl_env_ptr env = ecl_process_env(); - cl_index margin; - if (type == @'ext::frame-stack') { - cl_index the_size = ecl_to_size(limit); - margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; - frs_set_size(env, the_size + 2*margin); - } else if (type == @'ext::binding-stack') { - cl_index the_size = ecl_to_size(limit); - margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; - ecl_bds_set_size(env, the_size + 2*margin); - } else if (type == @'ext::c-stack') { - cl_index the_size = ecl_to_size(limit); - margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; - cs_set_size(env, the_size + 2*margin); - } else if (type == @'ext::lisp-stack') { - cl_index the_size = ecl_to_size(limit); - ecl_stack_set_size(env, the_size); - } else { - /* - * size_t can be larger than cl_index, and ecl_to_size() - * creates a fixnum which is too small for size_t on 32-bit. - */ - size_t the_size = (size_t)ecl_to_ulong(limit); - _ecl_set_max_heap_size(the_size); - } + cl_env_ptr env = ecl_process_env(); + cl_index margin; + if (type == @'ext::frame-stack') { + cl_index the_size = ecl_to_size(limit); + margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; + frs_set_size(env, the_size + 2*margin); + } else if (type == @'ext::binding-stack') { + cl_index the_size = ecl_to_size(limit); + margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; + ecl_bds_set_size(env, the_size + 2*margin); + } else if (type == @'ext::c-stack') { + cl_index the_size = ecl_to_size(limit); + margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; + cs_set_size(env, the_size + 2*margin); + } else if (type == @'ext::lisp-stack') { + cl_index the_size = ecl_to_size(limit); + ecl_stack_set_size(env, the_size); + } else { + /* + * size_t can be larger than cl_index, and ecl_to_size() + * creates a fixnum which is too small for size_t on 32-bit. + */ + size_t the_size = (size_t)ecl_to_ulong(limit); + _ecl_set_max_heap_size(the_size); + } - return si_get_limit(type); + return si_get_limit(type); } cl_object si_get_limit(cl_object type) { - cl_env_ptr env = ecl_process_env(); - cl_index output; - if (type == @'ext::frame-stack') - output = env->frs_limit_size; - else if (type == @'ext::binding-stack') - output = env->bds_limit_size; - else if (type == @'ext::c-stack') - output = env->cs_limit_size; - else if (type == @'ext::lisp-stack') - output = env->stack_limit_size; - else - /* size_t can be larger than cl_index */ - @(return ecl_make_unsigned_integer(cl_core.max_heap_size)); + cl_env_ptr env = ecl_process_env(); + cl_index output; + if (type == @'ext::frame-stack') + output = env->frs_limit_size; + else if (type == @'ext::binding-stack') + output = env->bds_limit_size; + else if (type == @'ext::c-stack') + output = env->cs_limit_size; + else if (type == @'ext::lisp-stack') + output = env->stack_limit_size; + else { + /* size_t can be larger than cl_index */ + @(return ecl_make_unsigned_integer(cl_core.max_heap_size)); + } - @(return ecl_make_unsigned_integer(output)) + @(return ecl_make_unsigned_integer(output)); } cl_object si_reset_margin(cl_object type) { - cl_env_ptr env = ecl_process_env(); - if (type == @'ext::frame-stack') - frs_set_size(env, env->frs_size); - else if (type == @'ext::binding-stack') - ecl_bds_set_size(env, env->bds_size); - else if (type == @'ext::c-stack') - cs_set_size(env, env->cs_size); - else - return ECL_NIL; + cl_env_ptr env = ecl_process_env(); + if (type == @'ext::frame-stack') + frs_set_size(env, env->frs_size); + else if (type == @'ext::binding-stack') + ecl_bds_set_size(env, env->bds_size); + else if (type == @'ext::c-stack') + cs_set_size(env, env->cs_size); + else + return ECL_NIL; - return ECL_T; + return ECL_T; } void init_stacks(cl_env_ptr env) { - static struct ecl_ihs_frame ihs_org = { NULL, NULL, NULL, 0}; - cl_index size, margin; + static struct ecl_ihs_frame ihs_org = { NULL, NULL, NULL, 0}; + cl_index size, margin; - margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; - size = ecl_option_values[ECL_OPT_FRAME_STACK_SIZE] + 2 * margin; - env->frs_size = size; - env->frs_org = (ecl_frame_ptr)ecl_alloc_atomic(size * sizeof(*env->frs_org)); - env->frs_top = env->frs_org-1; - env->frs_limit = &env->frs_org[size - 2*margin]; - - margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; - size = ecl_option_values[ECL_OPT_BIND_STACK_SIZE] + 2 * margin; - env->bds_size = size; - env->bds_org = (ecl_bds_ptr)ecl_alloc_atomic(size * sizeof(*env->bds_org)); - env->bds_top = env->bds_org-1; - env->bds_limit = &env->bds_org[size - 2*margin]; - - env->ihs_top = &ihs_org; - ihs_org.function = ECL_NIL; - ihs_org.lex_env = ECL_NIL; - ihs_org.index = 0; + margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; + size = ecl_option_values[ECL_OPT_FRAME_STACK_SIZE] + 2 * margin; + env->frs_size = size; + env->frs_org = (ecl_frame_ptr)ecl_alloc_atomic(size * sizeof(*env->frs_org)); + env->frs_top = env->frs_org-1; + env->frs_limit = &env->frs_org[size - 2*margin]; + + margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; + size = ecl_option_values[ECL_OPT_BIND_STACK_SIZE] + 2 * margin; + env->bds_size = size; + env->bds_org = (ecl_bds_ptr)ecl_alloc_atomic(size * sizeof(*env->bds_org)); + env->bds_top = env->bds_org-1; + env->bds_limit = &env->bds_org[size - 2*margin]; + + env->ihs_top = &ihs_org; + ihs_org.function = ECL_NIL; + ihs_org.lex_env = ECL_NIL; + ihs_org.index = 0; } diff -Nru ecl-16.1.2/src/c/string.d ecl-16.1.3+ds/src/c/string.d --- ecl-16.1.2/src/c/string.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/string.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,22 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - string.d -- String routines. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL is free software; you can redistribute it and/or - modify it under thep 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. - - See file '../Copyright' for full details. -*/ - + * string.d - string routines + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -28,22 +22,22 @@ static cl_object do_make_base_string(cl_index s, ecl_base_char code) { - cl_object x = ecl_alloc_simple_base_string(s); - cl_index i; - for (i = 0; i < s; i++) - x->base_string.self[i] = code; - return x; + cl_object x = ecl_alloc_simple_base_string(s); + cl_index i; + for (i = 0; i < s; i++) + x->base_string.self[i] = code; + return x; } #ifdef ECL_UNICODE static cl_object do_make_string(cl_index s, ecl_character code) { - cl_object x = ecl_alloc_simple_extended_string(s); - cl_index i; - for (i = 0; i < s; i++) - x->string.self[i] = code; - return x; + cl_object x = ecl_alloc_simple_extended_string(s); + cl_index i; + for (i = 0; i < s; i++) + x->string.self[i] = code; + return x; } #else #define do_make_string do_make_base_string @@ -51,307 +45,307 @@ @(defun make_string (size &key (initial_element ECL_CODE_CHAR(' ')) (element_type @'character')) - cl_index s; - cl_object x; -@ - s = ecl_to_index(size); - /* INV: ecl_[base_]char_code() checks the type of initial_element() */ - if (element_type == @'base-char' || element_type == @'standard-char') { - int code = ecl_base_char_code(initial_element); - x = do_make_base_string(s, code); - } else if (element_type == @'character') { - cl_index code = ecl_char_code(initial_element); - x = do_make_string(s, code); - } else if (_ecl_funcall3(@'subtypep', element_type, @'base-char') == ECL_T) { - int code = ecl_base_char_code(initial_element); - x = do_make_base_string(s, code); - } else if (_ecl_funcall3(@'subtypep', element_type, @'character') == ECL_T) { - cl_index code = ecl_char_code(initial_element); - x = do_make_string(s, code); - } else { - FEerror("The type ~S is not a valid string char type.", - 1, element_type); - } - @(return x) -@) + cl_index s; + cl_object x; + @ + s = ecl_to_index(size); + /* INV: ecl_[base_]char_code() checks the type of initial_element() */ + if (element_type == @'base-char' || element_type == @'standard-char') { + int code = ecl_base_char_code(initial_element); + x = do_make_base_string(s, code); + } else if (element_type == @'character') { + cl_index code = ecl_char_code(initial_element); + x = do_make_string(s, code); + } else if (_ecl_funcall3(@'subtypep', element_type, @'base-char') == ECL_T) { + int code = ecl_base_char_code(initial_element); + x = do_make_base_string(s, code); + } else if (_ecl_funcall3(@'subtypep', element_type, @'character') == ECL_T) { + cl_index code = ecl_char_code(initial_element); + x = do_make_string(s, code); + } else { + FEerror("The type ~S is not a valid string char type.", + 1, element_type); + } + @(return x); + @) /* - Make a string of a certain size, with some eading zeros to - keep C happy. The string must be adjustable, to allow further - growth. (See unixfsys.c for its use). + Make a string of a certain size, with some eading zeros to + keep C happy. The string must be adjustable, to allow further + growth. (See unixfsys.c for its use). */ cl_object ecl_alloc_adjustable_base_string(cl_index l) { - cl_object output = ecl_alloc_object(t_base_string); - output->base_string.self = (ecl_base_char *)ecl_alloc_atomic(l+1); - output->base_string.self[l] = 0; - output->base_string.flags = ECL_FLAG_HAS_FILL_POINTER | ECL_FLAG_ADJUSTABLE; - output->base_string.elttype = ecl_aet_bc; - output->base_string.displaced = ECL_NIL; - output->base_string.dim = l; - output->base_string.fillp = 0; - return output; + cl_object output = ecl_alloc_object(t_base_string); + output->base_string.self = (ecl_base_char *)ecl_alloc_atomic(l+1); + output->base_string.self[l] = 0; + output->base_string.flags = ECL_FLAG_HAS_FILL_POINTER | ECL_FLAG_ADJUSTABLE; + output->base_string.elttype = ecl_aet_bc; + output->base_string.displaced = ECL_NIL; + output->base_string.dim = l; + output->base_string.fillp = 0; + return output; } #ifdef ECL_UNICODE cl_object ecl_alloc_adjustable_extended_string(cl_index l) { - cl_index bytes = sizeof(ecl_character) * l; - cl_object output = ecl_alloc_object(t_string); - output->string.self = (ecl_character *)ecl_alloc_atomic(bytes); - output->string.flags = ECL_FLAG_HAS_FILL_POINTER | ECL_FLAG_ADJUSTABLE; - output->string.elttype = ecl_aet_ch; - output->string.displaced = ECL_NIL; - output->string.dim = l; - output->string.fillp = 0; - return output; + cl_index bytes = sizeof(ecl_character) * l; + cl_object output = ecl_alloc_object(t_string); + output->string.self = (ecl_character *)ecl_alloc_atomic(bytes); + output->string.flags = ECL_FLAG_HAS_FILL_POINTER | ECL_FLAG_ADJUSTABLE; + output->string.elttype = ecl_aet_ch; + output->string.displaced = ECL_NIL; + output->string.dim = l; + output->string.fillp = 0; + return output; } #endif /* - Make_simple_base_string(s) makes a simple-base string from C string s. + Make_simple_base_string(s) makes a simple-base string from C string s. */ cl_object ecl_make_simple_base_string(char *s, cl_fixnum l) { - cl_object x = ecl_alloc_object(t_base_string); - x->base_string.elttype = ecl_aet_bc; - x->base_string.flags = 0; /* no fill pointer, no adjustable */ - x->base_string.displaced = ECL_NIL; - if (l < 0) l = strlen(s); - x->base_string.dim = (x->base_string.fillp = l); - x->base_string.self = (ecl_base_char *)s; - return x; + cl_object x = ecl_alloc_object(t_base_string); + x->base_string.elttype = ecl_aet_bc; + x->base_string.flags = 0; /* no fill pointer, no adjustable */ + x->base_string.displaced = ECL_NIL; + if (l < 0) l = strlen(s); + x->base_string.dim = (x->base_string.fillp = l); + x->base_string.self = (ecl_base_char *)s; + return x; } cl_object make_base_string_copy(const char *s) { - cl_object x; - cl_index l = strlen(s); + cl_object x; + cl_index l = strlen(s); - x = ecl_alloc_simple_base_string(l); - memcpy(x->base_string.self, s, l); - return x; + x = ecl_alloc_simple_base_string(l); + memcpy(x->base_string.self, s, l); + return x; } cl_object ecl_cstring_to_base_string_or_nil(const char *s) { - if (s == NULL) - return ECL_NIL; - else - return make_base_string_copy(s); + if (s == NULL) + return ECL_NIL; + else + return make_base_string_copy(s); } bool ecl_fits_in_base_string(cl_object s) { - switch (ecl_t_of(s)) { + switch (ecl_t_of(s)) { #ifdef ECL_UNICODE - case t_string: { - cl_index i; - for (i = 0; i < s->string.fillp; i++) { - if (!ECL_BASE_CHAR_CODE_P(s->string.self[i])) - return 0; - } - return 1; - } -#endif - case t_base_string: - return 1; - default: - FEwrong_type_nth_arg(@[si::copy-to-simple-base-string],1,s,@[string]); - } + case t_string: { + cl_index i; + for (i = 0; i < s->string.fillp; i++) { + if (!ECL_BASE_CHAR_CODE_P(s->string.self[i])) + return 0; + } + return 1; + } +#endif + case t_base_string: + return 1; + default: + FEwrong_type_nth_arg(@[si::copy-to-simple-base-string],1,s,@[string]); + } } cl_object si_copy_to_simple_base_string(cl_object x) { - cl_object y; + cl_object y; AGAIN: - switch(ecl_t_of(x)) { - case t_symbol: - x = x->symbol.name; - goto AGAIN; - case t_character: - x = cl_string(x); - goto AGAIN; -#ifdef ECL_UNICODE - case t_string: { - cl_index index, length = x->string.fillp; - y = ecl_alloc_simple_base_string(length); - for (index=0; index < length; index++) { - ecl_character c = x->string.self[index]; - if (!ECL_BASE_CHAR_CODE_P(c)) - FEerror("Cannot coerce string ~A to a base-string", 1, x); - y->base_string.self[index] = c; - } - break; - } -#endif - case t_base_string: { - cl_index length = x->base_string.fillp; - y = ecl_alloc_simple_base_string(length); - memcpy(y->base_string.self, x->base_string.self, length); - break; - } - case t_list: - if (Null(x)) { - x = ECL_NIL_SYMBOL->symbol.name; - goto AGAIN; - } - default: - FEwrong_type_nth_arg(@[si::copy-to-simple-base-string],1,x,@[string]); - } - @(return y) + switch(ecl_t_of(x)) { + case t_symbol: + x = x->symbol.name; + goto AGAIN; + case t_character: + x = cl_string(x); + goto AGAIN; +#ifdef ECL_UNICODE + case t_string: { + cl_index index, length = x->string.fillp; + y = ecl_alloc_simple_base_string(length); + for (index=0; index < length; index++) { + ecl_character c = x->string.self[index]; + if (!ECL_BASE_CHAR_CODE_P(c)) + FEerror("Cannot coerce string ~A to a base-string", 1, x); + y->base_string.self[index] = c; + } + break; + } +#endif + case t_base_string: { + cl_index length = x->base_string.fillp; + y = ecl_alloc_simple_base_string(length); + memcpy(y->base_string.self, x->base_string.self, length); + break; + } + case t_list: + if (Null(x)) { + x = ECL_NIL_SYMBOL->symbol.name; + goto AGAIN; + } + default: + FEwrong_type_nth_arg(@[si::copy-to-simple-base-string],1,x,@[string]); + } + @(return y); } cl_object cl_string(cl_object x) { - switch (ecl_t_of(x)) { - case t_symbol: - x = x->symbol.name; - break; - case t_character: { - cl_object y; - ecl_character c = ECL_CHAR_CODE(x); -#ifdef ECL_UNICODE - if (ECL_BASE_CHAR_CODE_P(c)) { - y = ecl_alloc_simple_base_string(1); - y->base_string.self[0] = c; - x = y; - } else { - y = ecl_alloc_simple_extended_string(1); - y->string.self[0] = c; - x = y; - } + switch (ecl_t_of(x)) { + case t_symbol: + x = x->symbol.name; + break; + case t_character: { + cl_object y; + ecl_character c = ECL_CHAR_CODE(x); +#ifdef ECL_UNICODE + if (ECL_BASE_CHAR_CODE_P(c)) { + y = ecl_alloc_simple_base_string(1); + y->base_string.self[0] = c; + x = y; + } else { + y = ecl_alloc_simple_extended_string(1); + y->string.self[0] = c; + x = y; + } #else - y = ecl_alloc_simple_base_string(1); - y->base_string.self[0] = c; - x = y; - break; -#endif - } -#ifdef ECL_UNICODE - case t_string: -#endif - case t_base_string: - break; - case t_list: - if (Null(x)) { - x = ECL_NIL_SYMBOL->symbol.name; - break; - } - default: - FEwrong_type_nth_arg(@[string],1,x,@[string]); - } - @(return x) + y = ecl_alloc_simple_base_string(1); + y->base_string.self[0] = c; + x = y; + break; +#endif + } +#ifdef ECL_UNICODE + case t_string: +#endif + case t_base_string: + break; + case t_list: + if (Null(x)) { + x = ECL_NIL_SYMBOL->symbol.name; + break; + } + default: + FEwrong_type_nth_arg(@[string],1,x,@[string]); + } + @(return x); } #ifdef ECL_UNICODE cl_object si_coerce_to_base_string(cl_object x) { - if (!ECL_BASE_STRING_P(x)) { - x = si_copy_to_simple_base_string(x); - } - @(return x) + if (!ECL_BASE_STRING_P(x)) { + x = si_copy_to_simple_base_string(x); + } + @(return x); } cl_object si_coerce_to_extended_string(cl_object x) { - cl_object y; + cl_object y; AGAIN: - switch (ecl_t_of(x)) { - case t_symbol: - x = x->symbol.name; - goto AGAIN; - case t_character: - y = ecl_alloc_simple_extended_string(1); - y->string.self[0] = ECL_CHAR_CODE(x); - break; - case t_base_string: { - cl_index index, len = x->base_string.dim; - y = ecl_alloc_simple_extended_string(x->base_string.fillp); - for(index=0; index < len; index++) { - y->string.self[index] = x->base_string.self[index]; - } - y->string.fillp = x->base_string.fillp; - } - case t_string: - y = x; - break; - case t_list: - if (Null(x)) { - x = ECL_NIL_SYMBOL->symbol.name; - goto AGAIN; - } - default: - FEwrong_type_nth_arg(@[si::coerce-to-extended-string],1,x,@[string]); - } - @(return y) + switch (ecl_t_of(x)) { + case t_symbol: + x = x->symbol.name; + goto AGAIN; + case t_character: + y = ecl_alloc_simple_extended_string(1); + y->string.self[0] = ECL_CHAR_CODE(x); + break; + case t_base_string: { + cl_index index, len = x->base_string.dim; + y = ecl_alloc_simple_extended_string(x->base_string.fillp); + for(index=0; index < len; index++) { + y->string.self[index] = x->base_string.self[index]; + } + y->string.fillp = x->base_string.fillp; + } + case t_string: + y = x; + break; + case t_list: + if (Null(x)) { + x = ECL_NIL_SYMBOL->symbol.name; + goto AGAIN; + } + default: + FEwrong_type_nth_arg(@[si::coerce-to-extended-string],1,x,@[string]); + } + @(return y); } #endif cl_object cl_char(cl_object object, cl_object index) { - cl_index position = ecl_to_index(index); - @(return ECL_CODE_CHAR(ecl_char(object, position))) + cl_index position = ecl_to_index(index); + @(return ECL_CODE_CHAR(ecl_char(object, position))); } ecl_character ecl_char(cl_object object, cl_index index) { - /* CHAR bypasses fill pointers when accessing strings */ - switch(ecl_t_of(object)) { + /* CHAR bypasses fill pointers when accessing strings */ + switch(ecl_t_of(object)) { #ifdef ECL_UNICODE - case t_string: - if (index >= object->string.dim) - FEtype_error_index(object, index); - return object->string.self[index]; -#endif - case t_base_string: - if (index >= object->base_string.dim) - FEtype_error_index(object, index); - return object->base_string.self[index]; - default: - FEwrong_type_nth_arg(@[char],1,object,@[string]); - } + case t_string: + if (index >= object->string.dim) + FEtype_error_index(object, index); + return object->string.self[index]; +#endif + case t_base_string: + if (index >= object->base_string.dim) + FEtype_error_index(object, index); + return object->base_string.self[index]; + default: + FEwrong_type_nth_arg(@[char],1,object,@[string]); + } } cl_object si_char_set(cl_object object, cl_object index, cl_object value) { - cl_index position = ecl_to_index(index); - cl_index c = ecl_char_code(value); - ecl_char_set(object, position, c); - @(return value) + cl_index position = ecl_to_index(index); + cl_index c = ecl_char_code(value); + ecl_char_set(object, position, c); + @(return value); } ecl_character ecl_char_set(cl_object object, cl_index index, ecl_character value) { - /* CHAR bypasses fill pointers when accessing strings */ - switch(ecl_t_of(object)) { + /* CHAR bypasses fill pointers when accessing strings */ + switch(ecl_t_of(object)) { #ifdef ECL_UNICODE - case t_string: - if (index >= object->string.dim) - FEtype_error_index(object, index); - return object->string.self[index] = value; -#endif - case t_base_string: - if (index >= object->base_string.dim) - FEtype_error_index(object, index); - return object->base_string.self[index] = value; - default: - FEwrong_type_nth_arg(@[si::char-set],1,object,@[string]); - } + case t_string: + if (index >= object->string.dim) + FEtype_error_index(object, index); + return object->string.self[index] = value; +#endif + case t_base_string: + if (index >= object->base_string.dim) + FEtype_error_index(object, index); + return object->base_string.self[index] = value; + default: + FEwrong_type_nth_arg(@[si::char-set],1,object,@[string]); + } } #ifdef ECL_UNICODE @@ -360,32 +354,32 @@ cl_object string2, cl_index s2, cl_index e2, int case_sensitive, cl_index *m) { - cl_index c1, c2; - for (; s1 < e1; s1++, s2++) { - if (s2 >= e2) { /* s1 is longer than s2, therefore s2 < s1 */ - *m = s1; - return +1; - } - c1 = ecl_char(string1, s1); - c2 = ecl_char(string2, s2); - if (!case_sensitive) { - c1 = ecl_char_upcase(c1); - c2 = ecl_char_upcase(c2); - } - if (c1 < c2) { - *m = s1; - return -1; - } else if (c1 > c2) { - *m = s1; - return +1; - } - } - *m = s1; - if (s2 >= e2) { - return 0; - } else { /* s1 is shorter than s2, hence s1 < s2 */ - return -1; - } + cl_index c1, c2; + for (; s1 < e1; s1++, s2++) { + if (s2 >= e2) { /* s1 is longer than s2, therefore s2 < s1 */ + *m = s1; + return +1; + } + c1 = ecl_char(string1, s1); + c2 = ecl_char(string2, s2); + if (!case_sensitive) { + c1 = ecl_char_upcase(c1); + c2 = ecl_char_upcase(c2); + } + if (c1 < c2) { + *m = s1; + return -1; + } else if (c1 > c2) { + *m = s1; + return +1; + } + } + *m = s1; + if (s2 >= e2) { + return 0; + } else { /* s1 is shorter than s2, hence s1 < s2 */ + return -1; + } } #endif @@ -393,380 +387,387 @@ compare_base(unsigned char *s1, cl_index l1, unsigned char *s2, cl_index l2, int case_sensitive, cl_index *m) { - cl_index l, c1, c2; - for (l = 0; l < l1; l++, s1++, s2++) { - if (l == l2) { /* s1 is longer than s2, therefore s2 < s1 */ - *m = l; - return +1; - } - c1 = *s1; - c2 = *s2; - if (!case_sensitive) { - c1 = ecl_char_upcase(c1); - c2 = ecl_char_upcase(c2); - } - if (c1 < c2) { - *m = l; - return -1; - } else if (c1 > c2) { - *m = l; - return +1; - } - } - *m = l; - if (l1 == l2) - return 0; - else { /* s1 is shorter than s2, hence s1 < s2 */ - return -1; - } + cl_index l, c1, c2; + for (l = 0; l < l1; l++, s1++, s2++) { + if (l == l2) { /* s1 is longer than s2, therefore s2 < s1 */ + *m = l; + return +1; + } + c1 = *s1; + c2 = *s2; + if (!case_sensitive) { + c1 = ecl_char_upcase(c1); + c2 = ecl_char_upcase(c2); + } + if (c1 < c2) { + *m = l; + return -1; + } else if (c1 > c2) { + *m = l; + return +1; + } + } + *m = l; + if (l1 == l2) + return 0; + else { /* s1 is shorter than s2, hence s1 < s2 */ + return -1; + } } @(defun string= (string1 string2 &key (start1 ecl_make_fixnum(0)) end1 - (start2 ecl_make_fixnum(0)) end2) - cl_index_pair p; - cl_index s1, e1, s2, e2; -@ -{ - string1 = cl_string(string1); - string2 = cl_string(string2); - p = ecl_vector_start_end(@[string=], string1, start1, end1); - s1 = p.start; e1 = p.end; - p = ecl_vector_start_end(@[string=], string2, start2, end2); - s2 = p.start; e2 = p.end; - if (e1 - s1 != e2 - s2) - @(return ECL_NIL); -#ifdef ECL_UNICODE - if (string1->string.t == t_string) { - if (string2->string.t == t_string) { - while (s1 < e1) - if (string1->string.self[s1++] != string2->string.self[s2++]) - @(return ECL_NIL); - @(return ECL_T); - } else { - while (s1 < e1) - if (string1->string.self[s1++] != string2->base_string.self[s2++]) - @(return ECL_NIL); - @(return ECL_T); - } - } else { - if (string2->string.t == t_string) { - while (s1 < e1) - if (string1->base_string.self[s1++] != string2->string.self[s2++]) - @(return ECL_NIL); - @(return ECL_T); - } else { - while (s1 < e1) - if (string1->base_string.self[s1++] != string2->base_string.self[s2++]) - @(return ECL_NIL); - @(return ECL_T); - } - } -#else + (start2 ecl_make_fixnum(0)) end2) + cl_index_pair p; + cl_index s1, e1, s2, e2; + @ + { + string1 = cl_string(string1); + string2 = cl_string(string2); + p = ecl_vector_start_end(@[string=], string1, start1, end1); + s1 = p.start; e1 = p.end; + p = ecl_vector_start_end(@[string=], string2, start2, end2); + s2 = p.start; e2 = p.end; + if (e1 - s1 != e2 - s2) { + @(return ECL_NIL); + } +#ifdef ECL_UNICODE + if (string1->string.t == t_string) { + if (string2->string.t == t_string) { while (s1 < e1) - if (string1->base_string.self[s1++] != string2->base_string.self[s2++]) - @(return ECL_NIL); -#endif + if (string1->string.self[s1++] != string2->string.self[s2++]) { + @(return ECL_NIL); + } @(return ECL_T); -} -@) + } else { + while (s1 < e1) + if (string1->string.self[s1++] != string2->base_string.self[s2++]) { + @(return ECL_NIL); + } + @(return ECL_T); + } + } else { + if (string2->string.t == t_string) { + while (s1 < e1) + if (string1->base_string.self[s1++] != string2->string.self[s2++]) { + @(return ECL_NIL); + } + @(return ECL_T); + } else { + while (s1 < e1) + if (string1->base_string.self[s1++] != string2->base_string.self[s2++]) { + @(return ECL_NIL); + } + @(return ECL_T); + } + } +#else + while (s1 < e1) + if (string1->base_string.self[s1++] != string2->base_string.self[s2++]) { + @(return ECL_NIL); + } +#endif + @(return ECL_T); + } + @) /* - This correponds to string= (just the string equality). + This correponds to string= (just the string equality). */ bool ecl_string_eq(cl_object x, cl_object y) { - cl_index i, j; - i = x->base_string.fillp; - j = y->base_string.fillp; - if (i != j) return 0; -#ifdef ECL_UNICODE - switch(ecl_t_of(x)) { - case t_string: - switch(ecl_t_of(y)) { - case t_string: - return memcmp(x->string.self, y->string.self, i * sizeof *x->string.self) == 0; - case t_base_string: { - cl_index index; - for(index=0; indexstring.self[index] != y->base_string.self[index]) - return 0; - return 1; - } - default: - FEwrong_type_nth_arg(@[string=],2,y,@[string]); - } - break; - case t_base_string: - switch(ecl_t_of(y)) { - case t_string: - return ecl_string_eq(y, x); - case t_base_string: - return memcmp(x->base_string.self, y->base_string.self, i) == 0; - default: - FEwrong_type_nth_arg(@[string=],2,y,@[string]); - } - break; - default: - FEwrong_type_nth_arg(@[string=],2,x,@[string]); - } + cl_index i, j; + i = x->base_string.fillp; + j = y->base_string.fillp; + if (i != j) return 0; +#ifdef ECL_UNICODE + switch(ecl_t_of(x)) { + case t_string: + switch(ecl_t_of(y)) { + case t_string: + return memcmp(x->string.self, y->string.self, i * sizeof *x->string.self) == 0; + case t_base_string: { + cl_index index; + for(index=0; indexstring.self[index] != y->base_string.self[index]) + return 0; + return 1; + } + default: + FEwrong_type_nth_arg(@[string=],2,y,@[string]); + } + break; + case t_base_string: + switch(ecl_t_of(y)) { + case t_string: + return ecl_string_eq(y, x); + case t_base_string: + return memcmp(x->base_string.self, y->base_string.self, i) == 0; + default: + FEwrong_type_nth_arg(@[string=],2,y,@[string]); + } + break; + default: + FEwrong_type_nth_arg(@[string=],2,x,@[string]); + } #else - return memcmp(x->base_string.self, y->base_string.self, i) == 0; + return memcmp(x->base_string.self, y->base_string.self, i) == 0; #endif } @(defun string_equal (string1 string2 &key (start1 ecl_make_fixnum(0)) end1 - (start2 ecl_make_fixnum(0)) end2) - cl_index s1, e1, s2, e2; - cl_index_pair p; - int output; -@ - string1 = cl_string(string1); - string2 = cl_string(string2); - p = ecl_vector_start_end(@[string=], string1, start1, end1); - s1 = p.start; e1 = p.end; - p = ecl_vector_start_end(@[string=], string2, start2, end2); - s2 = p.start; e2 = p.end; - if (e1 - s1 != e2 - s2) - @(return ECL_NIL); -#ifdef ECL_UNICODE - if (ECL_EXTENDED_STRING_P(string1) || ECL_EXTENDED_STRING_P(string2)) { - output = compare_strings(string1, s1, e1, string2, s2, e2, 0, &e1); - } else -#endif - output = compare_base(string1->base_string.self + s1, e1 - s1, - string2->base_string.self + s2, e2 - s2, - 0, &e1); - @(return ((output == 0)? ECL_T : ECL_NIL)) -@) + (start2 ecl_make_fixnum(0)) end2) + cl_index s1, e1, s2, e2; + cl_index_pair p; + int output; + @ + string1 = cl_string(string1); + string2 = cl_string(string2); + p = ecl_vector_start_end(@[string=], string1, start1, end1); + s1 = p.start; e1 = p.end; + p = ecl_vector_start_end(@[string=], string2, start2, end2); + s2 = p.start; e2 = p.end; + if (e1 - s1 != e2 - s2) { + @(return ECL_NIL); + } +#ifdef ECL_UNICODE + if (ECL_EXTENDED_STRING_P(string1) || ECL_EXTENDED_STRING_P(string2)) { + output = compare_strings(string1, s1, e1, string2, s2, e2, 0, &e1); + } else +#endif + output = compare_base(string1->base_string.self + s1, e1 - s1, + string2->base_string.self + s2, e2 - s2, + 0, &e1); + @(return ((output == 0)? ECL_T : ECL_NIL)); + @) static cl_object string_compare(cl_narg narg, int sign1, int sign2, int case_sensitive, ecl_va_list ARGS) { - cl_object string1 = ecl_va_arg(ARGS); - cl_object string2 = ecl_va_arg(ARGS); - cl_index s1, e1, s2, e2; - cl_index_pair p; - int output; - cl_object result; - cl_object KEYS[4]; + cl_object string1 = ecl_va_arg(ARGS); + cl_object string2 = ecl_va_arg(ARGS); + cl_index s1, e1, s2, e2; + cl_index_pair p; + int output; + cl_object result; + cl_object KEYS[4]; #define start1 KEY_VARS[0] #define end1 KEY_VARS[1] #define start2 KEY_VARS[2] #define end2 KEY_VARS[3] #define start1p KEY_VARS[4] #define start2p KEY_VARS[6] - cl_object KEY_VARS[8]; + cl_object KEY_VARS[8]; - if (narg < 2) FEwrong_num_arguments_anonym(); - KEYS[0]=@':start1'; - KEYS[1]=@':end1'; - KEYS[2]=@':start2'; - KEYS[3]=@':end2'; - cl_parse_key(ARGS, 4, KEYS, KEY_VARS, NULL, FALSE); - - string1 = cl_string(string1); - string2 = cl_string(string2); - if (start1p == ECL_NIL) start1 = ecl_make_fixnum(0); - if (start2p == ECL_NIL) start2 = ecl_make_fixnum(0); - p = ecl_vector_start_end(@[string=], string1, start1, end1); - s1 = p.start; e1 = p.end; - p = ecl_vector_start_end(@[string=], string2, start2, end2); - s2 = p.start; e2 = p.end; -#ifdef ECL_UNICODE - if (ECL_EXTENDED_STRING_P(string1) || ECL_EXTENDED_STRING_P(string2)) { - output = compare_strings(string1, s1, e1, string2, s2, e2, - case_sensitive, &e1); - } else -#endif - { - output = compare_base(string1->base_string.self + s1, e1 - s1, - string2->base_string.self + s2, e2 - s2, - case_sensitive, &e1); - e1 += s1; - } - if (output == sign1 || output == sign2) { - result = ecl_make_fixnum(e1); - } else { - result = ECL_NIL; - } - @(return result) + if (narg < 2) FEwrong_num_arguments_anonym(); + KEYS[0]=@':start1'; + KEYS[1]=@':end1'; + KEYS[2]=@':start2'; + KEYS[3]=@':end2'; + cl_parse_key(ARGS, 4, KEYS, KEY_VARS, NULL, FALSE); + + string1 = cl_string(string1); + string2 = cl_string(string2); + if (start1p == ECL_NIL) start1 = ecl_make_fixnum(0); + if (start2p == ECL_NIL) start2 = ecl_make_fixnum(0); + p = ecl_vector_start_end(@[string=], string1, start1, end1); + s1 = p.start; e1 = p.end; + p = ecl_vector_start_end(@[string=], string2, start2, end2); + s2 = p.start; e2 = p.end; +#ifdef ECL_UNICODE + if (ECL_EXTENDED_STRING_P(string1) || ECL_EXTENDED_STRING_P(string2)) { + output = compare_strings(string1, s1, e1, string2, s2, e2, + case_sensitive, &e1); + } else +#endif + { + output = compare_base(string1->base_string.self + s1, e1 - s1, + string2->base_string.self + s2, e2 - s2, + case_sensitive, &e1); + e1 += s1; + } + if (output == sign1 || output == sign2) { + result = ecl_make_fixnum(e1); + } else { + result = ECL_NIL; + } + @(return result); #undef start1p #undef start2p #undef start1 #undef end1 #undef start2 #undef end2 -} + } @(defun string< (&rest args) -@ - return string_compare(narg, -1, -1, 1, args); -@) + @ + return string_compare(narg, -1, -1, 1, args); + @) @(defun string> (&rest args) -@ - return string_compare(narg, +1, +1, 1, args); -@) + @ + return string_compare(narg, +1, +1, 1, args); + @) @(defun string<= (&rest args) -@ - return string_compare(narg, -1, 0, 1, args); -@) + @ + return string_compare(narg, -1, 0, 1, args); + @) @(defun string>= (&rest args) -@ - return string_compare(narg, 0, +1, 1, args); -@) + @ + return string_compare(narg, 0, +1, 1, args); + @) @(defun string/= (&rest args) -@ - return string_compare(narg, -1, +1, 1, args); -@) + @ + return string_compare(narg, -1, +1, 1, args); + @) @(defun string-lessp (&rest args) -@ - return string_compare(narg, -1, -1, 0, args); -@) + @ + return string_compare(narg, -1, -1, 0, args); + @) @(defun string-greaterp (&rest args) -@ - return string_compare(narg, +1, +1, 0, args); -@) + @ + return string_compare(narg, +1, +1, 0, args); + @) @(defun string-not-greaterp (&rest args) -@ - return string_compare(narg, -1, 0, 0, args); -@) + @ + return string_compare(narg, -1, 0, 0, args); + @) @(defun string-not-lessp (&rest args) -@ - return string_compare(narg, 0, +1, 0, args); -@) + @ + return string_compare(narg, 0, +1, 0, args); + @) @(defun string-not-equal (&rest args) -@ - return string_compare(narg, -1, +1, 0, args); -@) + @ + return string_compare(narg, -1, +1, 0, args); + @) bool ecl_member_char(ecl_character c, cl_object char_bag) { - cl_index i, f; - switch (ecl_t_of(char_bag)) { - case t_list: - loop_for_in(char_bag) { - cl_object other = CAR(char_bag); - if (ECL_CHARACTERP(other) && c == ECL_CHAR_CODE(other)) - return(TRUE); - } end_loop_for_in; - return(FALSE); - case t_vector: - for (i = 0, f = char_bag->vector.fillp; i < f; i++) { - cl_object other = char_bag->vector.self.t[i]; - if (ECL_CHARACTERP(other) && c == ECL_CHAR_CODE(other)) - return(TRUE); - } - return(FALSE); -#ifdef ECL_UNICODE - case t_string: - for (i = 0, f = char_bag->string.fillp; i < f; i++) { - if (c == char_bag->string.self[i]) - return(TRUE); - } - return(FALSE); -#endif - case t_base_string: - for (i = 0, f = char_bag->base_string.fillp; i < f; i++) { - if (c == char_bag->base_string.self[i]) - return(TRUE); - } - return(FALSE); - case t_bitvector: - return(FALSE); - default: - FEwrong_type_nth_arg(@[member],2,char_bag,@[sequence]); - } + cl_index i, f; + switch (ecl_t_of(char_bag)) { + case t_list: + loop_for_in(char_bag) { + cl_object other = CAR(char_bag); + if (ECL_CHARACTERP(other) && c == ECL_CHAR_CODE(other)) + return(TRUE); + } end_loop_for_in; + return(FALSE); + case t_vector: + for (i = 0, f = char_bag->vector.fillp; i < f; i++) { + cl_object other = char_bag->vector.self.t[i]; + if (ECL_CHARACTERP(other) && c == ECL_CHAR_CODE(other)) + return(TRUE); + } + return(FALSE); +#ifdef ECL_UNICODE + case t_string: + for (i = 0, f = char_bag->string.fillp; i < f; i++) { + if (c == char_bag->string.self[i]) + return(TRUE); + } + return(FALSE); +#endif + case t_base_string: + for (i = 0, f = char_bag->base_string.fillp; i < f; i++) { + if (c == char_bag->base_string.self[i]) + return(TRUE); + } + return(FALSE); + case t_bitvector: + return(FALSE); + default: + FEwrong_type_nth_arg(@[member],2,char_bag,@[sequence]); + } } static cl_object string_trim0(bool left_trim, bool right_trim, cl_object char_bag, cl_object strng) { - cl_index i, j; + cl_index i, j; - strng = cl_string(strng); - i = 0; - j = ecl_length(strng); - if (left_trim) { - for (; i < j; i++) { - cl_index c = ecl_char(strng, i); - if (!ecl_member_char(c, char_bag)) - break; - } - } - if (right_trim) { - for (; j > i; j--) { - cl_index c = ecl_char(strng, j-1); - if (!ecl_member_char(c, char_bag)) { - break; - } - } - } - return cl_subseq(3, strng, ecl_make_fixnum(i), ecl_make_fixnum(j)); + strng = cl_string(strng); + i = 0; + j = ecl_length(strng); + if (left_trim) { + for (; i < j; i++) { + cl_index c = ecl_char(strng, i); + if (!ecl_member_char(c, char_bag)) + break; + } + } + if (right_trim) { + for (; j > i; j--) { + cl_index c = ecl_char(strng, j-1); + if (!ecl_member_char(c, char_bag)) { + break; + } + } + } + return cl_subseq(3, strng, ecl_make_fixnum(i), ecl_make_fixnum(j)); } cl_object cl_string_trim(cl_object char_bag, cl_object strng) { - return string_trim0(TRUE, TRUE, char_bag, strng); + return string_trim0(TRUE, TRUE, char_bag, strng); } cl_object cl_string_left_trim(cl_object char_bag, cl_object strng) { - return string_trim0(TRUE, FALSE, char_bag, strng); + return string_trim0(TRUE, FALSE, char_bag, strng); } cl_object cl_string_right_trim(cl_object char_bag, cl_object strng) { - return string_trim0(FALSE, TRUE, char_bag, strng); + return string_trim0(FALSE, TRUE, char_bag, strng); } static cl_object string_case(cl_narg narg, cl_object fun, ecl_casefun casefun, ecl_va_list ARGS) { - cl_object strng = ecl_va_arg(ARGS); - cl_index_pair p; - cl_index i; - bool b; - cl_object KEYS[2]; + cl_object strng = ecl_va_arg(ARGS); + cl_index_pair p; + cl_index i; + bool b; + cl_object KEYS[2]; #define kstart KEY_VARS[0] #define kend KEY_VARS[1] #define kstartp KEY_VARS[2] - cl_object KEY_VARS[4]; + cl_object KEY_VARS[4]; - if (narg < 1) FEwrong_num_arguments_anonym(); - KEYS[0]=@':start'; - KEYS[1]=@':end'; - cl_parse_key(ARGS, 2, KEYS, KEY_VARS, NULL, FALSE); - - strng = cl_string(strng); - strng = cl_copy_seq(strng); - if (kstartp == ECL_NIL) - kstart = ecl_make_fixnum(0); - p = ecl_vector_start_end(fun, strng, kstart, kend); - b = TRUE; -#ifdef ECL_UNICODE - if (ECL_EXTENDED_STRING_P(strng)) { - for (i = p.start; i < p.end; i++) - strng->string.self[i] = (*casefun)(strng->string.self[i], &b); - } else -#endif - for (i = p.start; i < p.end; i++) - strng->base_string.self[i] = (*casefun)(strng->base_string.self[i], &b); - @(return strng) + if (narg < 1) FEwrong_num_arguments_anonym(); + KEYS[0]=@':start'; + KEYS[1]=@':end'; + cl_parse_key(ARGS, 2, KEYS, KEY_VARS, NULL, FALSE); + + strng = cl_string(strng); + strng = cl_copy_seq(strng); + if (kstartp == ECL_NIL) + kstart = ecl_make_fixnum(0); + p = ecl_vector_start_end(fun, strng, kstart, kend); + b = TRUE; +#ifdef ECL_UNICODE + if (ECL_EXTENDED_STRING_P(strng)) { + for (i = p.start; i < p.end; i++) + strng->string.self[i] = (*casefun)(strng->string.self[i], &b); + } else +#endif + for (i = p.start; i < p.end; i++) + strng->base_string.self[i] = (*casefun)(strng->base_string.self[i], &b); + @(return strng); #undef kstartp #undef kstart #undef kend @@ -775,121 +776,121 @@ static ecl_character char_upcase(ecl_character c, bool *bp) { - return ecl_char_upcase(c); + return ecl_char_upcase(c); } @(defun string-upcase (&rest args) -@ - return string_case(narg, @[string-upcase], char_upcase, args); -@) + @ + return string_case(narg, @[string-upcase], char_upcase, args); + @) static ecl_character char_downcase(ecl_character c, bool *bp) { - return ecl_char_downcase(c); + return ecl_char_downcase(c); } @(defun string-downcase (&rest args) -@ - return string_case(narg, @[string-downcase], char_downcase, args); -@) + @ + return string_case(narg, @[string-downcase], char_downcase, args); + @) static ecl_character char_capitalize(ecl_character c, bool *bp) { - if (ecl_lower_case_p(c)) { - if (*bp) - c = ecl_char_upcase(c); - *bp = FALSE; - } else if (ecl_upper_case_p(c)) { - if (!*bp) - c = ecl_char_downcase(c); - *bp = FALSE; - } else { - *bp = !ecl_alphanumericp(c); - } - return c; + if (ecl_lower_case_p(c)) { + if (*bp) + c = ecl_char_upcase(c); + *bp = FALSE; + } else if (ecl_upper_case_p(c)) { + if (!*bp) + c = ecl_char_downcase(c); + *bp = FALSE; + } else { + *bp = !ecl_alphanumericp(c); + } + return c; } @(defun string-capitalize (&rest args) -@ - return string_case(narg, @[string-capitalize], char_capitalize, args); -@) + @ + return string_case(narg, @[string-capitalize], char_capitalize, args); + @) static cl_object nstring_case(cl_narg narg, cl_object fun, ecl_casefun casefun, ecl_va_list ARGS) { - cl_object strng = ecl_va_arg(ARGS); - cl_index_pair p; - cl_index i; - bool b; - cl_object KEYS[2]; + cl_object strng = ecl_va_arg(ARGS); + cl_index_pair p; + cl_index i; + bool b; + cl_object KEYS[2]; #define kstart KEY_VARS[0] #define kend KEY_VARS[1] #define kstartp KEY_VARS[2] - cl_object KEY_VARS[4]; + cl_object KEY_VARS[4]; - if (narg < 1) FEwrong_num_arguments_anonym(); - KEYS[0]=@':start'; - KEYS[1]=@':end'; - cl_parse_key(ARGS, 2, KEYS, KEY_VARS, NULL, FALSE); - - if (ecl_unlikely(!ECL_STRINGP(strng))) - FEwrong_type_nth_arg(fun, 1, strng, @[string]); - if (kstartp == ECL_NIL) - kstart = ecl_make_fixnum(0); - p = ecl_vector_start_end(fun, strng, kstart, kend); - b = TRUE; -#ifdef ECL_UNICODE - if (ECL_EXTENDED_STRING_P(strng)) { - for (i = p.start; i < p.end; i++) - strng->string.self[i] = (*casefun)(strng->string.self[i], &b); - } else -#endif - for (i = p.start; i < p.end; i++) - strng->base_string.self[i] = (*casefun)(strng->base_string.self[i], &b); - @(return strng) + if (narg < 1) FEwrong_num_arguments_anonym(); + KEYS[0]=@':start'; + KEYS[1]=@':end'; + cl_parse_key(ARGS, 2, KEYS, KEY_VARS, NULL, FALSE); + + if (ecl_unlikely(!ECL_STRINGP(strng))) + FEwrong_type_nth_arg(fun, 1, strng, @[string]); + if (kstartp == ECL_NIL) + kstart = ecl_make_fixnum(0); + p = ecl_vector_start_end(fun, strng, kstart, kend); + b = TRUE; +#ifdef ECL_UNICODE + if (ECL_EXTENDED_STRING_P(strng)) { + for (i = p.start; i < p.end; i++) + strng->string.self[i] = (*casefun)(strng->string.self[i], &b); + } else +#endif + for (i = p.start; i < p.end; i++) + strng->base_string.self[i] = (*casefun)(strng->base_string.self[i], &b); + @(return strng); #undef kstartp #undef kstart #undef kend } @(defun nstring-upcase (&rest args) -@ - return nstring_case(narg, @'nstring-upcase', char_upcase, args); -@) + @ + return nstring_case(narg, @'nstring-upcase', char_upcase, args); + @) @(defun nstring-downcase (&rest args) -@ - return nstring_case(narg, @'nstring-downcase', char_downcase, args); -@) + @ + return nstring_case(narg, @'nstring-downcase', char_downcase, args); + @) @(defun nstring-capitalize (&rest args) -@ - return nstring_case(narg, @'nstring-capitalize', char_capitalize, args); -@) + @ + return nstring_case(narg, @'nstring-capitalize', char_capitalize, args); + @) @(defun si::base-string-concatenate (&rest args) - cl_index l; - int i; - cl_object output; -@ - /* Compute final size and store NONEMPTY coerced strings. */ - for (i = 0, l = 0; i < narg; i++) { - cl_object s = si_coerce_to_base_string(ecl_va_arg(args)); - if (s->base_string.fillp) { - ECL_STACK_PUSH(the_env, s); - l += s->base_string.fillp; - } - } - /* Do actual copying by recovering those strings */ - output = ecl_alloc_simple_base_string(l); - while (l) { - cl_object s = ECL_STACK_POP_UNSAFE(the_env); - size_t bytes = s->base_string.fillp; - l -= bytes; - memcpy(output->base_string.self + l, s->base_string.self, bytes); - } - @(return output); -@) + cl_index l; + int i; + cl_object output; + @ + /* Compute final size and store NONEMPTY coerced strings. */ + for (i = 0, l = 0; i < narg; i++) { + cl_object s = si_coerce_to_base_string(ecl_va_arg(args)); + if (s->base_string.fillp) { + ECL_STACK_PUSH(the_env, s); + l += s->base_string.fillp; + } + } + /* Do actual copying by recovering those strings */ + output = ecl_alloc_simple_base_string(l); + while (l) { + cl_object s = ECL_STACK_POP_UNSAFE(the_env); + size_t bytes = s->base_string.fillp; + l -= bytes; + memcpy(output->base_string.self + l, s->base_string.self, bytes); + } + @(return output); + @) diff -Nru ecl-16.1.2/src/c/structure.d ecl-16.1.3+ds/src/c/structure.d --- ecl-16.1.2/src/c/structure.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/structure.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - structure.c -- Structure interface. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * structure.d - structure interface + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -26,65 +21,65 @@ static bool structure_subtypep(cl_object x, cl_object y) { - if (ECL_CLASS_NAME(x) == y) { - return TRUE; - } else { - cl_object superiors = ECL_CLASS_SUPERIORS(x); - loop_for_on_unsafe(superiors) { - if (structure_subtypep(ECL_CONS_CAR(superiors), y)) - return TRUE; - } end_loop_for_on_unsafe(superiors); - return FALSE; - } + if (ECL_CLASS_NAME(x) == y) { + return TRUE; + } else { + cl_object superiors = ECL_CLASS_SUPERIORS(x); + loop_for_on_unsafe(superiors) { + if (structure_subtypep(ECL_CONS_CAR(superiors), y)) + return TRUE; + } end_loop_for_on_unsafe(superiors); + return FALSE; + } } cl_object si_structure_subtype_p(cl_object x, cl_object y) { - @(return ((ecl_t_of(x) == T_STRUCTURE - && structure_subtypep(ECL_STRUCT_TYPE(x), y)) ? ECL_T : ECL_NIL)) + @(return ((ecl_t_of(x) == T_STRUCTURE + && structure_subtypep(ECL_STRUCT_TYPE(x), y)) ? ECL_T : ECL_NIL)); } @(defun si::make-structure (type &rest args) - cl_object x; - int i; -@ - x = ecl_alloc_object(T_STRUCTURE); - ECL_STRUCT_TYPE(x) = type; - ECL_STRUCT_SLOTS(x) = NULL; /* for GC sake */ - ECL_STRUCT_LENGTH(x) = --narg; - ECL_STRUCT_SLOTS(x) = (cl_object *)ecl_alloc_align(sizeof(cl_object)*narg, sizeof(cl_object)); - x->instance.sig = ECL_UNBOUND; - if (narg >= ECL_SLOTS_LIMIT) - FEerror("Limit on structure size exceeded: ~S slots requested.", - 1, ecl_make_fixnum(narg)); - for (i = 0; i < narg; i++) - ECL_STRUCT_SLOT(x, i) = ecl_va_arg(args); - @(return x) -@) + cl_object x; + int i; + @ + x = ecl_alloc_object(T_STRUCTURE); + ECL_STRUCT_TYPE(x) = type; + ECL_STRUCT_SLOTS(x) = NULL; /* for GC sake */ + ECL_STRUCT_LENGTH(x) = --narg; + ECL_STRUCT_SLOTS(x) = (cl_object *)ecl_alloc_align(sizeof(cl_object)*narg, sizeof(cl_object)); + x->instance.sig = ECL_UNBOUND; + if (narg >= ECL_SLOTS_LIMIT) + FEerror("Limit on structure size exceeded: ~S slots requested.", + 1, ecl_make_fixnum(narg)); + for (i = 0; i < narg; i++) + ECL_STRUCT_SLOT(x, i) = ecl_va_arg(args); + @(return x); + @) #define ecl_copy_structure si_copy_instance cl_object cl_copy_structure(cl_object s) { - switch (ecl_t_of(s)) { - case t_instance: - s = ecl_copy_structure(s); - break; - case t_list: + switch (ecl_t_of(s)) { + case t_instance: + s = ecl_copy_structure(s); + break; + case t_list: #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - case t_bitvector: - case t_vector: - s = cl_copy_seq(s); - break; - default: - FEwrong_type_only_arg(@[copy-structure], s, @[structure]); - } - @(return s) + case t_base_string: + case t_bitvector: + case t_vector: + s = cl_copy_seq(s); + break; + default: + FEwrong_type_only_arg(@[copy-structure], s, @[structure]); + } + @(return s); } @@ -92,57 +87,57 @@ cl_object si_structure_name(cl_object s) { - if (ecl_unlikely(Null(si_structurep(s)))) - FEwrong_type_only_arg(@[si::structure-name], s, @[structure]); - @(return ECL_STRUCT_NAME(s)) + if (ecl_unlikely(Null(si_structurep(s)))) + FEwrong_type_only_arg(@[si::structure-name], s, @[structure]); + @(return ECL_STRUCT_NAME(s)); } cl_object si_structure_ref(cl_object x, cl_object type, cl_object index) { - if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE || - !structure_subtypep(ECL_STRUCT_TYPE(x), type))) - FEwrong_type_nth_arg(@[si::structure-ref], 1, x, type); - @(return ECL_STRUCT_SLOT(x, ecl_fixnum(index))) + if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE || + !structure_subtypep(ECL_STRUCT_TYPE(x), type))) + FEwrong_type_nth_arg(@[si::structure-ref], 1, x, type); + @(return ECL_STRUCT_SLOT(x, ecl_fixnum(index))); } cl_object ecl_structure_ref(cl_object x, cl_object type, int n) { - if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE || - !structure_subtypep(ECL_STRUCT_TYPE(x), type))) - FEwrong_type_nth_arg(@[si::structure-ref], 1, x, type); - return(ECL_STRUCT_SLOT(x, n)); + if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE || + !structure_subtypep(ECL_STRUCT_TYPE(x), type))) + FEwrong_type_nth_arg(@[si::structure-ref], 1, x, type); + return(ECL_STRUCT_SLOT(x, n)); } cl_object si_structure_set(cl_object x, cl_object type, cl_object index, cl_object val) { - if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE || - !structure_subtypep(ECL_STRUCT_TYPE(x), type))) - FEwrong_type_nth_arg(@[si::structure-set], 1, x, type); - ECL_STRUCT_SLOT(x, ecl_fixnum(index)) = val; - @(return val) + if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE || + !structure_subtypep(ECL_STRUCT_TYPE(x), type))) + FEwrong_type_nth_arg(@[si::structure-set], 1, x, type); + ECL_STRUCT_SLOT(x, ecl_fixnum(index)) = val; + @(return val); } cl_object ecl_structure_set(cl_object x, cl_object type, int n, cl_object v) { - if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE || - !structure_subtypep(ECL_STRUCT_TYPE(x), type))) - FEwrong_type_nth_arg(@[si::structure-set], 1, x, type); - ECL_STRUCT_SLOT(x, n) = v; - return(v); + if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE || + !structure_subtypep(ECL_STRUCT_TYPE(x), type))) + FEwrong_type_nth_arg(@[si::structure-set], 1, x, type); + ECL_STRUCT_SLOT(x, n) = v; + return(v); } cl_object si_structurep(cl_object s) { - if (ECL_INSTANCEP(s) && - structure_subtypep(ECL_CLASS_OF(s), @'structure-object')) - return ECL_T; - else - return ECL_NIL; + if (ECL_INSTANCEP(s) && + structure_subtypep(ECL_CLASS_OF(s), @'structure-object')) + return ECL_T; + else + return ECL_NIL; } diff -Nru ecl-16.1.2/src/c/symbol.d ecl-16.1.3+ds/src/c/symbol.d --- ecl-16.1.2/src/c/symbol.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/symbol.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,85 +1,77 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - symbol.d -- Symbols. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * symbol.d - symbols + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include #include -/******************************* ------- ******************************/ -/* FIXME! CURRENTLY SYMBOLS ARE RESTRICTED TO HAVE NON-UNICODE NAMES */ - cl_object ecl_symbol_package(cl_object s) { - if (Null(s)) - return ECL_NIL_SYMBOL->symbol.hpack; - if (ecl_t_of(s) == t_symbol) - return s->symbol.hpack; - FEwrong_type_nth_arg(@[symbol-package], 1, s, @[symbol]); + if (Null(s)) + return ECL_NIL_SYMBOL->symbol.hpack; + if (ecl_t_of(s) == t_symbol) + return s->symbol.hpack; + FEwrong_type_nth_arg(@[symbol-package], 1, s, @[symbol]); } int ecl_symbol_type(cl_object s) { - if (Null(s)) - return ECL_NIL_SYMBOL->symbol.stype; - if (ecl_t_of(s) == t_symbol) - return s->symbol.stype; - FEwrong_type_nth_arg(@[symbol-name], 1, s, @[symbol]); + if (Null(s)) + return ECL_NIL_SYMBOL->symbol.stype; + if (ecl_t_of(s) == t_symbol) + return s->symbol.stype; + FEwrong_type_nth_arg(@[symbol-name], 1, s, @[symbol]); } void ecl_symbol_type_set(cl_object s, int type) { - if (Null(s)) { - ECL_NIL_SYMBOL->symbol.stype = type; - return; - } - if (ecl_t_of(s) == t_symbol) { - s->symbol.stype = type; - return; - } - FEwrong_type_nth_arg(@[symbol-name], 1, s, @[symbol]); + if (Null(s)) { + ECL_NIL_SYMBOL->symbol.stype = type; + return; + } + if (ecl_t_of(s) == t_symbol) { + s->symbol.stype = type; + return; + } + FEwrong_type_nth_arg(@[symbol-name], 1, s, @[symbol]); } cl_object ecl_symbol_name(cl_object s) { - if (Null(s)) { - return ECL_NIL_SYMBOL->symbol.name; - } - if (ecl_t_of(s) == t_symbol) { - return s->symbol.name; - } - FEwrong_type_nth_arg(@[symbol-name], 1, s, @[symbol]); + if (Null(s)) { + return ECL_NIL_SYMBOL->symbol.name; + } + if (ecl_t_of(s) == t_symbol) { + return s->symbol.name; + } + FEwrong_type_nth_arg(@[symbol-name], 1, s, @[symbol]); } static cl_object * ecl_symbol_plist(cl_object s) { - if (Null(s)) { - return &ECL_NIL_SYMBOL->symbol.plist; - } - if (ecl_t_of(s) == t_symbol) { - return &s->symbol.plist; - } - FEwrong_type_nth_arg(@[symbol-plist], 1, s, @[symbol]); + if (Null(s)) { + return &ECL_NIL_SYMBOL->symbol.plist; + } + if (ecl_t_of(s) == t_symbol) { + return &s->symbol.plist; + } + FEwrong_type_nth_arg(@[symbol-plist], 1, s, @[symbol]); } /**********************************************************************/ @@ -89,394 +81,394 @@ cl_object cl_make_symbol(cl_object str) { - cl_object x; - /* INV: In several places it is assumed that we copy the string! */ - switch (ecl_t_of(str)) { + cl_object x; + /* INV: In several places it is assumed that we copy the string! */ + switch (ecl_t_of(str)) { #ifdef ECL_UNICODE - case t_string: - if (!ecl_fits_in_base_string(str)) { - str = cl_copy_seq(str); - } else { - str = si_copy_to_simple_base_string(str); - } - break; + case t_string: + if (!ecl_fits_in_base_string(str)) { + str = cl_copy_seq(str); + } else { + str = si_copy_to_simple_base_string(str); + } + break; #endif - case t_base_string: - str = si_copy_to_simple_base_string(str); - break; - default: - FEwrong_type_nth_arg(@[make-symbol],1,str,@[string]); - } - x = ecl_alloc_object(t_symbol); - x->symbol.name = str; - x->symbol.dynamic = 0; + case t_base_string: + str = si_copy_to_simple_base_string(str); + break; + default: + FEwrong_type_nth_arg(@[make-symbol],1,str,@[string]); + } + x = ecl_alloc_object(t_symbol); + x->symbol.name = str; + x->symbol.dynamic = 0; #ifdef ECL_THREADS - x->symbol.binding = ECL_MISSING_SPECIAL_BINDING; + x->symbol.binding = ECL_MISSING_SPECIAL_BINDING; #endif /* */ - ECL_SET(x,OBJNULL); - ECL_SYM_FUN(x) = ECL_NIL; - x->symbol.plist = ECL_NIL; - x->symbol.hpack = ECL_NIL; - x->symbol.stype = ecl_stp_ordinary; - @(return x) + ECL_SET(x,OBJNULL); + ECL_SYM_FUN(x) = ECL_NIL; + x->symbol.plist = ECL_NIL; + x->symbol.hpack = ECL_NIL; + x->symbol.stype = ecl_stp_ordinary; + @(return x); } /* - ecl_make_keyword(s) makes a keyword from C string s. + ecl_make_keyword(s) makes a keyword from C string s. */ cl_object ecl_make_keyword(const char *s) { - cl_object x = _ecl_intern(s, cl_core.keyword_package); - /* cl_export(x, keyword_package); this is implicit in ecl_intern() */ - return x; + cl_object x = _ecl_intern(s, cl_core.keyword_package); + /* cl_export(x, keyword_package); this is implicit in ecl_intern() */ + return x; } cl_object ecl_make_symbol(const char *s, const char *p) { - cl_object package = ecl_find_package(p); - cl_object x = _ecl_intern(s, package); - /* cl_export(x, keyword_package); this is implicit in ecl_intern() */ - return x; + cl_object package = ecl_find_package(p); + cl_object x = _ecl_intern(s, package); + /* cl_export(x, keyword_package); this is implicit in ecl_intern() */ + return x; } cl_object ecl_symbol_value(cl_object s) { - if (Null(s)) { - return s; - } else { - /* FIXME: Should we check symbol type? */ - const cl_env_ptr the_env = ecl_process_env(); - cl_object value = ECL_SYM_VAL(the_env, s); - unlikely_if (value == OBJNULL) - FEunbound_variable(s); - return value; - } + if (Null(s)) { + return s; + } else { + /* FIXME: Should we check symbol type? */ + const cl_env_ptr the_env = ecl_process_env(); + cl_object value = ECL_SYM_VAL(the_env, s); + unlikely_if (value == OBJNULL) + FEunbound_variable(s); + return value; + } } static void FEtype_error_plist(cl_object x) { - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("Not a valid property list ~D"), - @':format-arguments', cl_list(1, x), - @':expected-type', @'si::property-list', - @':datum', x); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("Not a valid property list ~D"), + @':format-arguments', cl_list(1, x), + @':expected-type', @'si::property-list', + @':datum', x); } cl_object ecl_getf(cl_object place, cl_object indicator, cl_object deflt) { - cl_object l; + cl_object l; #ifdef ECL_SAFE - assert_type_proper_list(place); + assert_type_proper_list(place); #endif - for (l = place; CONSP(l); ) { - cl_object cdr_l = ECL_CONS_CDR(l); - if (!CONSP(cdr_l)) - break; - if (ECL_CONS_CAR(l) == indicator) - return ECL_CONS_CAR(cdr_l); - l = ECL_CONS_CDR(cdr_l); - } - if (l != ECL_NIL) - FEtype_error_plist(place); - return(deflt); + for (l = place; CONSP(l); ) { + cl_object cdr_l = ECL_CONS_CDR(l); + if (!CONSP(cdr_l)) + break; + if (ECL_CONS_CAR(l) == indicator) + return ECL_CONS_CAR(cdr_l); + l = ECL_CONS_CDR(cdr_l); + } + if (l != ECL_NIL) + FEtype_error_plist(place); + return(deflt); } cl_object ecl_get(cl_object s, cl_object p, cl_object d) { - return ecl_getf(*ecl_symbol_plist(s), p, d); + return ecl_getf(*ecl_symbol_plist(s), p, d); } /* - (SI:PUT-F plist value indicator) - returns the new property list with value for property indicator. - It will be used in SETF for GETF. + (SI:PUT-F plist value indicator) + returns the new property list with value for property indicator. + It will be used in SETF for GETF. */ cl_object si_put_f(cl_object place, cl_object value, cl_object indicator) { - cl_object l; + cl_object l; #ifdef ECL_SAFE - assert_type_proper_list(place); + assert_type_proper_list(place); #endif - /* This loop guarantees finishing for circular lists */ - for (l = place; CONSP(l); ) { - cl_object cdr_l = ECL_CONS_CDR(l); - if (!CONSP(cdr_l)) - break; - if (ECL_CONS_CAR(l) == indicator) { - ECL_RPLACA(cdr_l, value); - @(return place); - } - l = ECL_CONS_CDR(cdr_l); - } - if (l != ECL_NIL) - FEtype_error_plist(place); - place = CONS(value, place); - @(return CONS(indicator, place)); + /* This loop guarantees finishing for circular lists */ + for (l = place; CONSP(l); ) { + cl_object cdr_l = ECL_CONS_CDR(l); + if (!CONSP(cdr_l)) + break; + if (ECL_CONS_CAR(l) == indicator) { + ECL_RPLACA(cdr_l, value); + @(return place); + } + l = ECL_CONS_CDR(cdr_l); + } + if (l != ECL_NIL) + FEtype_error_plist(place); + place = CONS(value, place); + @(return CONS(indicator, place)); } /* - Remf(p, i) removes property i - from the property list pointed by p, - which is a pointer to an cl_object. - The returned value of remf(p, i) is: + Remf(p, i) removes property i + from the property list pointed by p, + which is a pointer to an cl_object. + The returned value of remf(p, i) is: - TRUE if the property existed - FALSE otherwise. + TRUE if the property existed + FALSE otherwise. */ static bool remf(cl_object *place, cl_object indicator) { - cl_object l = *place, tail = ECL_NIL; - while (!Null(l)) { - cl_object ind; - if (!LISTP(l)) - FEtype_error_plist(*place); - ind = ECL_CONS_CAR(l); - l = ECL_CONS_CDR(l); - if (!CONSP(l)) - FEtype_error_plist(*place); - if (ind == indicator) { - l = ECL_CONS_CDR(l); - if (Null(tail)) - *place = l; - else - ECL_RPLACD(tail, l); - return TRUE; - } - tail = l; - l = ECL_CONS_CDR(l); - } - return FALSE; + cl_object l = *place, tail = ECL_NIL; + while (!Null(l)) { + cl_object ind; + if (!LISTP(l)) + FEtype_error_plist(*place); + ind = ECL_CONS_CAR(l); + l = ECL_CONS_CDR(l); + if (!CONSP(l)) + FEtype_error_plist(*place); + if (ind == indicator) { + l = ECL_CONS_CDR(l); + if (Null(tail)) + *place = l; + else + ECL_RPLACD(tail, l); + return TRUE; + } + tail = l; + l = ECL_CONS_CDR(l); + } + return FALSE; } bool ecl_keywordp(cl_object s) { - return (ecl_t_of(s) == t_symbol) && (s->symbol.hpack == cl_core.keyword_package); + return (ecl_t_of(s) == t_symbol) && (s->symbol.hpack == cl_core.keyword_package); } @(defun get (sym indicator &optional deflt) - cl_object *plist; -@ - plist = ecl_symbol_plist(sym); - @(return ecl_getf(*plist, indicator, deflt)) -@) + cl_object *plist; + @ + plist = ecl_symbol_plist(sym); + @(return ecl_getf(*plist, indicator, deflt)); + @) cl_object cl_remprop(cl_object sym, cl_object prop) { - cl_object *plist = ecl_symbol_plist(sym); - @(return (remf(plist, prop)? ECL_T: ECL_NIL)) + cl_object *plist = ecl_symbol_plist(sym); + @(return (remf(plist, prop)? ECL_T: ECL_NIL)); } cl_object cl_symbol_plist(cl_object sym) { - @(return *ecl_symbol_plist(sym)) + @(return *ecl_symbol_plist(sym)); } @(defun getf (place indicator &optional deflt) -@ - @(return ecl_getf(place, indicator, deflt)) -@) + @ + @(return ecl_getf(place, indicator, deflt)); + @) cl_object cl_get_properties(cl_object place, cl_object indicator_list) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object l; + const cl_env_ptr the_env = ecl_process_env(); + cl_object l; #ifdef ECL_SAFE - assert_type_proper_list(place); + assert_type_proper_list(place); #endif - for (l = place; CONSP(l); ) { - cl_object cdr_l = ECL_CONS_CDR(l); - if (!CONSP(cdr_l)) - break; - if (ecl_member_eq(ECL_CONS_CAR(l), indicator_list)) - ecl_return3(the_env,ECL_CONS_CAR(l),ECL_CONS_CAR(cdr_l),l); - l = ECL_CONS_CDR(cdr_l); - } - if (l != ECL_NIL) - FEtype_error_plist(place); - ecl_return3(the_env, ECL_NIL, ECL_NIL, ECL_NIL); + for (l = place; CONSP(l); ) { + cl_object cdr_l = ECL_CONS_CDR(l); + if (!CONSP(cdr_l)) + break; + if (ecl_member_eq(ECL_CONS_CAR(l), indicator_list)) + ecl_return3(the_env,ECL_CONS_CAR(l),ECL_CONS_CAR(cdr_l),l); + l = ECL_CONS_CDR(cdr_l); + } + if (l != ECL_NIL) + FEtype_error_plist(place); + ecl_return3(the_env, ECL_NIL, ECL_NIL, ECL_NIL); } cl_object cl_symbol_name(cl_object x) { - ecl_return1(ecl_process_env(), ecl_symbol_name(x)); + ecl_return1(ecl_process_env(), ecl_symbol_name(x)); } @(defun copy_symbol (sym &optional cp &aux x) -@ - if (Null(sym)) - sym = ECL_NIL_SYMBOL; - x = cl_make_symbol(ecl_symbol_name(sym)); - if (!Null(cp)) { - x->symbol.dynamic = 0; - x->symbol.stype = sym->symbol.stype; - x->symbol.value = sym->symbol.value; - x->symbol.gfdef = sym->symbol.gfdef; - x->symbol.plist = cl_copy_list(sym->symbol.plist); + @ + if (Null(sym)) + sym = ECL_NIL_SYMBOL; + x = cl_make_symbol(ecl_symbol_name(sym)); + if (!Null(cp)) { + x->symbol.dynamic = 0; + x->symbol.stype = sym->symbol.stype; + x->symbol.value = sym->symbol.value; + x->symbol.gfdef = sym->symbol.gfdef; + x->symbol.plist = cl_copy_list(sym->symbol.plist); #ifdef ECL_THREADS - x->symbol.binding = ECL_MISSING_SPECIAL_BINDING; + x->symbol.binding = ECL_MISSING_SPECIAL_BINDING; #endif - /* FIXME!!! We should also copy the system property list */ - } - @(return x) -@) + /* FIXME!!! We should also copy the system property list */ + } + @(return x); + @) @(defun gensym (&optional (prefix cl_core.gensym_prefix)) - cl_type t; - cl_object counter, output; - bool increment; -@ { - if (ecl_stringp(prefix)) { - counter = ECL_SYM_VAL(the_env, @'*gensym-counter*'); - increment = 1; - } else if ((t = ecl_t_of(prefix)) == t_fixnum || t == t_bignum) { - counter = prefix; - prefix = cl_core.gensym_prefix; - increment = 0; - } else { - FEwrong_type_nth_arg(@[gensym],2,prefix, - cl_list(3, @'or', @'string', @'integer')); - } - output = ecl_make_string_output_stream(64, 1); - ecl_bds_bind(the_env, @'*print-escape*', ECL_NIL); - ecl_bds_bind(the_env, @'*print-readably*', ECL_NIL); - ecl_bds_bind(the_env, @'*print-base*', ecl_make_fixnum(10)); - ecl_bds_bind(the_env, @'*print-radix*', ECL_NIL); - si_write_ugly_object(prefix, output); - si_write_ugly_object(counter, output); - ecl_bds_unwind_n(the_env, 4); - output = cl_make_symbol(cl_get_output_stream_string(output)); - if (increment) - ECL_SETQ(the_env, @'*gensym-counter*',ecl_one_plus(counter)); - @(return output); -} @) + cl_type t; + cl_object counter, output; + bool increment; + @ { + if (ecl_stringp(prefix)) { + counter = ECL_SYM_VAL(the_env, @'*gensym-counter*'); + increment = 1; + } else if ((t = ecl_t_of(prefix)) == t_fixnum || t == t_bignum) { + counter = prefix; + prefix = cl_core.gensym_prefix; + increment = 0; + } else { + FEwrong_type_nth_arg(@[gensym],2,prefix, + cl_list(3, @'or', @'string', @'integer')); + } + output = ecl_make_string_output_stream(64, 1); + ecl_bds_bind(the_env, @'*print-escape*', ECL_NIL); + ecl_bds_bind(the_env, @'*print-readably*', ECL_NIL); + ecl_bds_bind(the_env, @'*print-base*', ecl_make_fixnum(10)); + ecl_bds_bind(the_env, @'*print-radix*', ECL_NIL); + si_write_ugly_object(prefix, output); + si_write_ugly_object(counter, output); + ecl_bds_unwind_n(the_env, 4); + output = cl_make_symbol(cl_get_output_stream_string(output)); + if (increment) + ECL_SETQ(the_env, @'*gensym-counter*',ecl_one_plus(counter)); + @(return output); + } @) @(defun gentemp (&optional (prefix cl_core.gentemp_prefix) (pack ecl_current_package())) - cl_object output, s; - int intern_flag; -@ - unlikely_if (!ECL_STRINGP(prefix)) - FEwrong_type_nth_arg(@[gentemp], 1, prefix, @[string]); - pack = si_coerce_to_package(pack); -ONCE_MORE: - output = ecl_make_string_output_stream(64, 1); - ecl_bds_bind(the_env, @'*print-escape*', ECL_NIL); - ecl_bds_bind(the_env, @'*print-readably*', ECL_NIL); - ecl_bds_bind(the_env, @'*print-base*', ecl_make_fixnum(10)); - ecl_bds_bind(the_env, @'*print-radix*', ECL_NIL); - si_write_ugly_object(prefix, output); - si_write_ugly_object(cl_core.gentemp_counter, output); - ecl_bds_unwind_n(the_env, 4); - cl_core.gentemp_counter = ecl_one_plus(cl_core.gentemp_counter); - s = ecl_intern(cl_get_output_stream_string(output), pack, &intern_flag); - if (intern_flag != 0) - goto ONCE_MORE; - @(return s) -@) + cl_object output, s; + int intern_flag; + @ + unlikely_if (!ECL_STRINGP(prefix)) + FEwrong_type_nth_arg(@[gentemp], 1, prefix, @[string]); + pack = si_coerce_to_package(pack); + ONCE_MORE: + output = ecl_make_string_output_stream(64, 1); + ecl_bds_bind(the_env, @'*print-escape*', ECL_NIL); + ecl_bds_bind(the_env, @'*print-readably*', ECL_NIL); + ecl_bds_bind(the_env, @'*print-base*', ecl_make_fixnum(10)); + ecl_bds_bind(the_env, @'*print-radix*', ECL_NIL); + si_write_ugly_object(prefix, output); + si_write_ugly_object(cl_core.gentemp_counter, output); + ecl_bds_unwind_n(the_env, 4); + cl_core.gentemp_counter = ecl_one_plus(cl_core.gentemp_counter); + s = ecl_intern(cl_get_output_stream_string(output), pack, &intern_flag); + if (intern_flag != 0) + goto ONCE_MORE; + @(return s); + @) cl_object cl_symbol_package(cl_object sym) { - @(return ecl_symbol_package(sym)) + @(return ecl_symbol_package(sym)); } cl_object cl_keywordp(cl_object sym) { - @(return (ecl_keywordp(sym)? ECL_T: ECL_NIL)) + @(return (ecl_keywordp(sym)? ECL_T: ECL_NIL)); } /* - (SI:REM-F plist indicator) returns two values: + (SI:REM-F plist indicator) returns two values: - * the new property list - in which property indcator is removed + * the new property list + in which property indcator is removed - * T if really removed - NIL otherwise. + * T if really removed + NIL otherwise. - It will be used for macro REMF. + It will be used for macro REMF. */ cl_object si_rem_f(cl_object plist, cl_object indicator) { - cl_env_ptr the_env = ecl_process_env(); - bool found = remf(&plist, indicator); - ecl_return2(the_env, plist, (found? ECL_T : ECL_NIL)); + cl_env_ptr the_env = ecl_process_env(); + bool found = remf(&plist, indicator); + ecl_return2(the_env, plist, (found? ECL_T : ECL_NIL)); } cl_object si_set_symbol_plist(cl_object sym, cl_object plist) { - *ecl_symbol_plist(sym) = plist; - @(return plist) + *ecl_symbol_plist(sym) = plist; + @(return plist); } cl_object si_putprop(cl_object sym, cl_object value, cl_object indicator) { - cl_object *plist = ecl_symbol_plist(sym); - *plist = si_put_f(*plist, value, indicator); - @(return value) + cl_object *plist = ecl_symbol_plist(sym); + *plist = si_put_f(*plist, value, indicator); + @(return value); } /* Added for defstruct. Beppe */ @(defun si::put-properties (sym &rest ind_values) -@ - while (--narg >= 2) { - cl_object prop = ecl_va_arg(ind_values); - si_putprop(sym, ecl_va_arg(ind_values), prop); - narg--; - } - @(return sym) -@) + @ + while (--narg >= 2) { + cl_object prop = ecl_va_arg(ind_values); + si_putprop(sym, ecl_va_arg(ind_values), prop); + narg--; + } + @(return sym); + @) cl_object @si::*make-special(cl_object sym) { - int type = ecl_symbol_type(sym); - if (type & ecl_stp_constant) - FEerror("~S is a constant.", 1, sym); - ecl_symbol_type_set(sym, type | ecl_stp_special); - cl_remprop(sym, @'si::symbol-macro'); - @(return sym) + int type = ecl_symbol_type(sym); + if (type & ecl_stp_constant) + FEerror("~S is a constant.", 1, sym); + ecl_symbol_type_set(sym, type | ecl_stp_special); + cl_remprop(sym, @'si::symbol-macro'); + @(return sym); } cl_object @si::*make-constant(cl_object sym, cl_object val) { - int type = ecl_symbol_type(sym); - if (type & ecl_stp_special) - FEerror("The argument ~S to DEFCONSTANT is a special variable.", - 1, sym); - ecl_symbol_type_set(sym, type | ecl_stp_constant); - ECL_SET(sym, val); - @(return sym) + int type = ecl_symbol_type(sym); + if (type & ecl_stp_special) + FEerror("The argument ~S to DEFCONSTANT is a special variable.", + 1, sym); + ecl_symbol_type_set(sym, type | ecl_stp_constant); + ECL_SET(sym, val); + @(return sym); } void ecl_defvar(cl_object sym, cl_object val) { - si_safe_eval(3, cl_list(3, @'defvar', sym, cl_list(2, @'quote', val)), ECL_NIL, ECL_NIL); + si_safe_eval(3, cl_list(3, @'defvar', sym, cl_list(2, @'quote', val)), ECL_NIL, ECL_NIL); } void ecl_defparameter(cl_object sym, cl_object val) { - si_safe_eval(3, cl_list(3, @'defparameter', sym, cl_list(2, @'quote', val)), ECL_NIL, ECL_NIL); + si_safe_eval(3, cl_list(3, @'defparameter', sym, cl_list(2, @'quote', val)), ECL_NIL, ECL_NIL); } diff -Nru ecl-16.1.2/src/c/symbols_list2.h ecl-16.1.3+ds/src/c/symbols_list2.h --- ecl-16.1.2/src/c/symbols_list2.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/symbols_list2.h 2016-12-19 10:25:00.000000000 +0000 @@ -71,16 +71,11 @@ #else # define IF_SSE2(x) NULL #endif -#if defined(HAVE_LIBFFI) || defined(ECL_DYNAMIC_FFI) +#if defined(HAVE_LIBFFI) # define IF_DFFI(x) x #else # define IF_DFFI(x) NULL #endif -#if defined(HAVE_LIBFFI) -# define IF_LIBFFI(x) x -#else -# define IF_LIBFFI(x) NULL -#endif cl_symbol_initializer cl_symbols[] = { @@ -1212,7 +1207,15 @@ {EXT_ "MKSTEMP","si_mkstemp"}, {SYS_ "RMDIR","si_rmdir"}, {EXT_ "MAKE-PIPE","si_make_pipe"}, +/* PACKAGE_LOCKS */ +{SYS_ "*IGNORE-PACKAGE-LOCKS*",NULL}, {EXT_ "PACKAGE-LOCK","si_package_lock"}, +{SYS_ "LOCK-PACKAGE",NULL}, +{SYS_ "UNLOCK-PACKAGE",NULL}, +{SYS_ "PACKAGE-LOCKED-P",NULL}, +{SYS_ "WITHOUT-PACKAGE-LOCKS",NULL}, +{SYS_ "WITH-UNLOCKED-PACKAGES",NULL}, +/* ~PACKAGE_LOCKS */ {SYS_ "PACKAGE-HASH-TABLES","si_package_hash_tables"}, {SYS_ "PATHNAME-TRANSLATIONS","si_pathname_translations"}, {SYS_ "POINTER","si_pointer"}, @@ -1230,6 +1233,7 @@ {SYS_ "REPLACE-ARRAY","si_replace_array"}, {SYS_ "ROW-MAJOR-ASET","si_row_major_aset"}, {EXT_ "RUN-PROGRAM","si_run_program"}, +{EXT_ "TERMINATE-PROCESS","si_terminate_process"}, {SYS_ "WAIT-FOR-ALL-PROCESSES","si_wait_for_all_processes"}, {EXT_ "SAFE-EVAL","ECL_NAME(si_safe_eval)"}, {SYS_ "SCH-FRS-BASE","si_sch_frs_base"}, @@ -1554,6 +1558,7 @@ {MP_ "MAKE-LOCK",IF_MP("mp_make_lock")}, {KEY_ "RECURSIVE",NULL}, {MP_ "RECURSIVE-LOCK-P",IF_MP("mp_recursive_lock_p")}, +{MP_ "HOLDING-LOCK-P",IF_MP("mp_holding_lock_p")}, {MP_ "LOCK-NAME",IF_MP("mp_lock_name")}, {MP_ "LOCK-OWNER",IF_MP("mp_lock_owner")}, {MP_ "LOCK-COUNT",IF_MP("mp_lock_count")}, @@ -1749,12 +1754,12 @@ {SYS_ "*CODE-WALKER*",NULL}, -/* #if defined(HAVE_LIBFFI) || defined(ECL_DYNAMIC_FFI) */ +/* #if defined(HAVE_LIBFFI) */ {SYS_ "CALL-CFUN",IF_DFFI("si_call_cfun")}, {KEY_ "CALLBACK",NULL}, {SYS_ "MAKE-DYNAMIC-CALLBACK",IF_DFFI("si_make_dynamic_callback")}, -{SYS_ "FREE-FFI-CLOSURE",IF_LIBFFI("si_free_ffi_closure")}, -/* #endif defined(HAVE_LIBFFI) || defined(ECL_DYNAMIC_FFI) */ +{SYS_ "FREE-FFI-CLOSURE",IF_DFFI("si_free_ffi_closure")}, +/* #endif defined(HAVE_LIBFFI) */ {KEY_ "CDECL",NULL}, {KEY_ "STDCALL",NULL}, @@ -1905,22 +1910,27 @@ {EXT_ "*BYTECODES-COMPILER*",NULL}, +#ifdef ECL_IEEE_FP +{SYS_ "NAN","si_nan"}, + {EXT_ "SHORT-FLOAT-POSITIVE-INFINITY",NULL}, {EXT_ "SINGLE-FLOAT-POSITIVE-INFINITY",NULL}, {EXT_ "DOUBLE-FLOAT-POSITIVE-INFINITY",NULL}, {EXT_ "LONG-FLOAT-POSITIVE-INFINITY",NULL}, + {EXT_ "SHORT-FLOAT-NEGATIVE-INFINITY",NULL}, {EXT_ "SINGLE-FLOAT-NEGATIVE-INFINITY",NULL}, {EXT_ "DOUBLE-FLOAT-NEGATIVE-INFINITY",NULL}, {EXT_ "LONG-FLOAT-NEGATIVE-INFINITY",NULL}, +#endif /* ECL_IEEE_FP */ + {EXT_ "FLOAT-NAN-P","si_float_nan_p"}, {EXT_ "FLOAT-INFINITY-P","si_float_infinity_p"}, - -{SYS_ "READ-OBJECT-OR-IGNORE","si_read_object_or_ignore"}, - {EXT_ "FLOAT-NAN-STRING",NULL}, {EXT_ "FLOAT-INFINITY-STRING",NULL}, +{SYS_ "READ-OBJECT-OR-IGNORE","si_read_object_or_ignore"}, + {EXT_ "READTABLE-LOCK","si_readtable_lock"}, {SYS_ "+IO-SYNTAX-PROGV-LIST+",NULL}, @@ -1939,7 +1949,11 @@ {SYS_ "*ALLOW-WITH-INTERRUPTS*",NULL}, +/* conveniance macros from CMU util */ +{EXT_ "ONCE-ONLY",NULL}, +{EXT_ "COLLECT",NULL}, {EXT_ "WITH-UNIQUE-NAMES",NULL}, +{EXT_ "WITH-GENSYMS",NULL}, {EXT_ "WITH-CLEAN-SYMBOLS",NULL}, {SYS_ "HANDLE-SIGNAL","si_handle_signal"}, @@ -2212,6 +2226,8 @@ {EXT_ "HASH-TABLE-CONTENT","si_hash_table_content"}, {EXT_ "HASH-TABLE-FILL","si_hash_table_fill"}, +{EXT_ "RANDOM-STATE-ARRAY","si_random_state_array"}, + {SYS_ "REPORT-FUNCTION",NULL}, {SYS_ "DO-DEFSETF","ECL_NAME(si_do_defsetf)"}, diff -Nru ecl-16.1.2/src/c/symbols_list.h ecl-16.1.3+ds/src/c/symbols_list.h --- ecl-16.1.2/src/c/symbols_list.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/symbols_list.h 2016-12-19 10:25:00.000000000 +0000 @@ -71,16 +71,11 @@ #else # define IF_SSE2(x) NULL #endif -#if defined(HAVE_LIBFFI) || defined(ECL_DYNAMIC_FFI) +#if defined(HAVE_LIBFFI) # define IF_DFFI(x) x #else # define IF_DFFI(x) NULL #endif -#if defined(HAVE_LIBFFI) -# define IF_LIBFFI(x) x -#else -# define IF_LIBFFI(x) NULL -#endif cl_symbol_initializer cl_symbols[] = { @@ -1212,7 +1207,15 @@ {EXT_ "MKSTEMP", EXT_ORDINARY, si_mkstemp, 1, OBJNULL}, {SYS_ "RMDIR", SI_ORDINARY, si_rmdir, 1, OBJNULL}, {EXT_ "MAKE-PIPE", EXT_ORDINARY, si_make_pipe, 0, OBJNULL}, +/* PACKAGE_LOCKS */ +{SYS_ "*IGNORE-PACKAGE-LOCKS*", SI_SPECIAL, NULL, -1, ECL_NIL}, {EXT_ "PACKAGE-LOCK", EXT_ORDINARY, si_package_lock, 2, OBJNULL}, +{SYS_ "LOCK-PACKAGE", EXT_ORDINARY, NULL, 1, OBJNULL}, +{SYS_ "UNLOCK-PACKAGE", EXT_ORDINARY, NULL, 1, OBJNULL}, +{SYS_ "PACKAGE-LOCKED-P", EXT_ORDINARY, NULL, 1, OBJNULL}, +{SYS_ "WITHOUT-PACKAGE-LOCKS", EXT_ORDINARY, NULL, 1, OBJNULL}, +{SYS_ "WITH-UNLOCKED-PACKAGES", EXT_ORDINARY, NULL, 1, OBJNULL}, +/* ~PACKAGE_LOCKS */ {SYS_ "PACKAGE-HASH-TABLES", SI_ORDINARY, si_package_hash_tables, 1, OBJNULL}, {SYS_ "PATHNAME-TRANSLATIONS", SI_ORDINARY, si_pathname_translations, -1, OBJNULL}, {SYS_ "POINTER", SI_ORDINARY, si_pointer, 1, OBJNULL}, @@ -1230,6 +1233,7 @@ {SYS_ "REPLACE-ARRAY", SI_ORDINARY, si_replace_array, 2, OBJNULL}, {SYS_ "ROW-MAJOR-ASET", SI_ORDINARY, si_row_major_aset, 3, OBJNULL}, {EXT_ "RUN-PROGRAM", EXT_ORDINARY, si_run_program, -1, OBJNULL}, +{EXT_ "TERMINATE-PROCESS", EXT_ORDINARY, si_terminate_process, -1, OBJNULL}, {SYS_ "WAIT-FOR-ALL-PROCESSES", SI_ORDINARY, si_wait_for_all_processes, -1, OBJNULL}, {EXT_ "SAFE-EVAL", EXT_ORDINARY, ECL_NAME(si_safe_eval), -1, OBJNULL}, {SYS_ "SCH-FRS-BASE", SI_ORDINARY, si_sch_frs_base, 2, OBJNULL}, @@ -1554,6 +1558,7 @@ {MP_ "MAKE-LOCK", MP_ORDINARY, IF_MP(mp_make_lock), -1, OBJNULL}, {KEY_ "RECURSIVE", KEYWORD, NULL, -1, OBJNULL}, {MP_ "RECURSIVE-LOCK-P", MP_ORDINARY, IF_MP(mp_recursive_lock_p), 1, OBJNULL}, +{MP_ "HOLDING-LOCK-P", MP_ORDINARY, IF_MP(mp_holding_lock_p), 1, OBJNULL}, {MP_ "LOCK-NAME", MP_ORDINARY, IF_MP(mp_lock_name), 1, OBJNULL}, {MP_ "LOCK-OWNER", MP_ORDINARY, IF_MP(mp_lock_owner), 1, OBJNULL}, {MP_ "LOCK-COUNT", MP_ORDINARY, IF_MP(mp_lock_count), 1, OBJNULL}, @@ -1598,7 +1603,7 @@ {MP_ "BARRIER", MP_ORDINARY, NULL, -1, OBJNULL}, {MP_ "MAKE-BARRIER", MP_ORDINARY, IF_MP(mp_make_barrier), -1, OBJNULL}, {MP_ "BARRIER-UNBLOCK", MP_ORDINARY, IF_MP(mp_barrier_unblock), -1, OBJNULL}, -{MP_ "BARRIER-WAIT", MP_ORDINARY, IF_MP(mp_barrier_wait), -1, OBJNULL}, +{MP_ "BARRIER-WAIT", MP_ORDINARY, IF_MP(mp_barrier_wait), 1, OBJNULL}, {MP_ "BARRIER-COUNT", MP_ORDINARY, IF_MP(mp_barrier_count), 1, OBJNULL}, {MP_ "BARRIER-NAME", MP_ORDINARY, IF_MP(mp_barrier_name), 1, OBJNULL}, {MP_ "BARRIER-ARRIVERS-COUNT", MP_ORDINARY, IF_MP(mp_barrier_arrivers_count), 1, OBJNULL}, @@ -1749,12 +1754,12 @@ {SYS_ "*CODE-WALKER*", SI_SPECIAL, NULL, -1, OBJNULL}, -/* #if defined(HAVE_LIBFFI) || defined(ECL_DYNAMIC_FFI) */ +/* #if defined(HAVE_LIBFFI) */ {SYS_ "CALL-CFUN", SI_ORDINARY, IF_DFFI(si_call_cfun), -1, OBJNULL}, {KEY_ "CALLBACK", KEYWORD, NULL, -1, OBJNULL}, {SYS_ "MAKE-DYNAMIC-CALLBACK", SI_ORDINARY, IF_DFFI(si_make_dynamic_callback), -1, OBJNULL}, -{SYS_ "FREE-FFI-CLOSURE", SI_ORDINARY, IF_LIBFFI(si_free_ffi_closure), 1, OBJNULL}, -/* #endif defined(HAVE_LIBFFI) || defined(ECL_DYNAMIC_FFI) */ +{SYS_ "FREE-FFI-CLOSURE", SI_ORDINARY, IF_DFFI(si_free_ffi_closure), 1, OBJNULL}, +/* #endif defined(HAVE_LIBFFI) */ {KEY_ "CDECL", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "STDCALL", KEYWORD, NULL, -1, OBJNULL}, @@ -1905,22 +1910,27 @@ {EXT_ "*BYTECODES-COMPILER*", EXT_SPECIAL, NULL, -1, ECL_NIL}, +#ifdef ECL_IEEE_FP +{SYS_ "NAN", EXT_ORDINARY, si_nan, 0, OBJNULL}, + {EXT_ "SHORT-FLOAT-POSITIVE-INFINITY", EXT_CONSTANT, NULL, -1, OBJNULL}, {EXT_ "SINGLE-FLOAT-POSITIVE-INFINITY", EXT_CONSTANT, NULL, -1, OBJNULL}, {EXT_ "DOUBLE-FLOAT-POSITIVE-INFINITY", EXT_CONSTANT, NULL, -1, OBJNULL}, {EXT_ "LONG-FLOAT-POSITIVE-INFINITY", EXT_CONSTANT, NULL, -1, OBJNULL}, + {EXT_ "SHORT-FLOAT-NEGATIVE-INFINITY", EXT_CONSTANT, NULL, -1, OBJNULL}, {EXT_ "SINGLE-FLOAT-NEGATIVE-INFINITY", EXT_CONSTANT, NULL, -1, OBJNULL}, {EXT_ "DOUBLE-FLOAT-NEGATIVE-INFINITY", EXT_CONSTANT, NULL, -1, OBJNULL}, {EXT_ "LONG-FLOAT-NEGATIVE-INFINITY", EXT_CONSTANT, NULL, -1, OBJNULL}, +#endif /* ECL_IEEE_FP */ + {EXT_ "FLOAT-NAN-P", EXT_ORDINARY, si_float_nan_p, 1, OBJNULL}, {EXT_ "FLOAT-INFINITY-P", EXT_ORDINARY, si_float_infinity_p, 1, OBJNULL}, - -{SYS_ "READ-OBJECT-OR-IGNORE", EXT_ORDINARY, si_read_object_or_ignore, 2, OBJNULL}, - {EXT_ "FLOAT-NAN-STRING", EXT_ORDINARY, NULL, 1, OBJNULL}, {EXT_ "FLOAT-INFINITY-STRING", EXT_ORDINARY, NULL, 1, OBJNULL}, +{SYS_ "READ-OBJECT-OR-IGNORE", EXT_ORDINARY, si_read_object_or_ignore, 2, OBJNULL}, + {EXT_ "READTABLE-LOCK", EXT_ORDINARY, si_readtable_lock, -1, OBJNULL}, {SYS_ "+IO-SYNTAX-PROGV-LIST+", SI_CONSTANT, NULL, -1, OBJNULL}, @@ -1939,7 +1949,11 @@ {SYS_ "*ALLOW-WITH-INTERRUPTS*", SI_SPECIAL, NULL, -1, ECL_T}, +/* conveniance macros from CMU util */ +{EXT_ "ONCE-ONLY", EXT_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "COLLECT", EXT_ORDINARY, NULL, -1, OBJNULL}, {EXT_ "WITH-UNIQUE-NAMES", EXT_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "WITH-GENSYMS", EXT_ORDINARY, NULL, -1, OBJNULL}, {EXT_ "WITH-CLEAN-SYMBOLS", EXT_ORDINARY, NULL, -1, OBJNULL}, {SYS_ "HANDLE-SIGNAL", SI_ORDINARY, si_handle_signal, 2, OBJNULL}, @@ -2212,6 +2226,8 @@ {EXT_ "HASH-TABLE-CONTENT", EXT_ORDINARY, si_hash_table_content, 1, OBJNULL}, {EXT_ "HASH-TABLE-FILL", EXT_ORDINARY, si_hash_table_fill, 2, OBJNULL}, +{EXT_ "RANDOM-STATE-ARRAY", EXT_ORDINARY, si_random_state_array, 1, OBJNULL}, + {SYS_ "REPORT-FUNCTION", SI_ORDINARY, NULL, -1, OBJNULL}, {SYS_ "DO-DEFSETF", SI_ORDINARY, ECL_NAME(si_do_defsetf), -1, OBJNULL}, diff -Nru ecl-16.1.2/src/c/tcp.d ecl-16.1.3+ds/src/c/tcp.d --- ecl-16.1.2/src/c/tcp.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/tcp.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,15 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ - -/* tcp.c -- stream interface to TCP */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL is free software; you can redistribute it and/or modify it - under the terms of the GNU General Library Public License as published - by the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - See file '../Copyright' for full details. -*/ + * tcp.d - stream interface to TCP + * + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -50,14 +46,14 @@ #if defined(ECL_MS_WINDOWS_HOST) WSADATA wsadata; int wsock_initialized = 0; -#define INIT_TCP \ - if ( !wsock_initialized ) \ - { \ - if ( WSAStartup( MAKEWORD( 2, 2 ), &wsadata ) != NO_ERROR ) \ - FEerror( "Unable to initialize Windows socket library.", 0 ); \ - else \ - wsock_initialized = 1; \ - } +#define INIT_TCP \ + if ( !wsock_initialized ) \ + { \ + if ( WSAStartup( MAKEWORD( 2, 2 ), &wsadata ) != NO_ERROR ) \ + FEerror( "Unable to initialize Windows socket library.", 0 ); \ + else \ + wsock_initialized = 1; \ + } #else #define INIT_TCP #endif @@ -66,11 +62,11 @@ ecl_tcp_close_all(void) { #if defined(ECL_MS_WINDOWS_HOST) - if ( wsock_initialized ) - { - WSACleanup(); - wsock_initialized = 0; - } + if ( wsock_initialized ) + { + WSACleanup(); + wsock_initialized = 0; + } #endif } @@ -97,30 +93,30 @@ INIT_TCP - /* Get the statistics on the specified host. */ - if ((inaddr.sin_addr.s_addr = inet_addr(host)) == -1) { - if ((host_ptr = gethostbyname(host)) == NULL) { - /* No such host! */ - errno = EINVAL; - return(0); - } - /* Check the address type for an internet host. */ - if (host_ptr->h_addrtype != AF_INET) { - /* Not an Internet host! */ -#if defined(ECL_MS_WINDOWS_HOST) - errno = WSAEPROTOTYPE; -#else - errno = EPROTOTYPE; -#endif - return(0); - } - /* Set up the socket data. */ - inaddr.sin_family = host_ptr->h_addrtype; - memcpy((char *)&inaddr.sin_addr, (char *)host_ptr->h_addr, - sizeof(inaddr.sin_addr)); - } - else - inaddr.sin_family = AF_INET; + /* Get the statistics on the specified host. */ + if ((inaddr.sin_addr.s_addr = inet_addr(host)) == -1) { + if ((host_ptr = gethostbyname(host)) == NULL) { + /* No such host! */ + errno = EINVAL; + return(0); + } + /* Check the address type for an internet host. */ + if (host_ptr->h_addrtype != AF_INET) { + /* Not an Internet host! */ +#if defined(ECL_MS_WINDOWS_HOST) + errno = WSAEPROTOTYPE; +#else + errno = EPROTOTYPE; +#endif + return(0); + } + /* Set up the socket data. */ + inaddr.sin_family = host_ptr->h_addrtype; + memcpy((char *)&inaddr.sin_addr, (char *)host_ptr->h_addr, + sizeof(inaddr.sin_addr)); + } + else + inaddr.sin_family = AF_INET; addr = (struct sockaddr *) &inaddr; addrlen = sizeof (struct sockaddr_in); @@ -176,25 +172,25 @@ INIT_TCP - /* - * Open the network connection. - */ - if ((request = socket(AF_INET, SOCK_STREAM, 0)) < 0) { - return(0); /* errno set by system call. */ - } + /* + * Open the network connection. + */ + if ((request = socket(AF_INET, SOCK_STREAM, 0)) < 0) { + return(0); /* errno set by system call. */ + } #ifdef SO_REUSEADDR - /* Necesary to restart the server without a reboot */ + /* Necesary to restart the server without a reboot */ #if defined(ECL_MS_WINDOWS_HOST) - { - char one = 1; - setsockopt(request, SOL_SOCKET, SO_REUSEADDR, &one, sizeof(char)); - } + { + char one = 1; + setsockopt(request, SOL_SOCKET, SO_REUSEADDR, &one, sizeof(char)); + } #else - { - int one = 1; - setsockopt(request, SOL_SOCKET, SO_REUSEADDR, &one, sizeof(int)); - } + { + int one = 1; + setsockopt(request, SOL_SOCKET, SO_REUSEADDR, &one, sizeof(int)); + } #endif #endif /* SO_REUSEADDR */ #ifdef TCP_NODELAY @@ -240,14 +236,14 @@ loop: errno = 0; if ((conn = accept(request, (struct sockaddr *)NULL, (int *)NULL)) < 0) - if (errno) { - lwpblockon(active, fp, PD_INPUT); - clearerr(fp); - goto loop; - } else { - fclose(fp); - FElibc_error("Accepting requests", 0); - } + if (errno) { + lwpblockon(active, fp, PD_INPUT); + clearerr(fp); + goto loop; + } else { + fclose(fp); + FElibc_error("Accepting requests", 0); + } fclose(fp); } #else @@ -273,57 +269,58 @@ cl_object si_open_client_stream(cl_object host, cl_object port) { - int fd, p; /* file descriptor */ - cl_object stream; + int fd, p; /* file descriptor */ + cl_object stream; - /* Ensure "host" is a string that we can pass to a C function */ - host = si_copy_to_simple_base_string(host); + /* Ensure "host" is a string that we can pass to a C function */ + host = si_copy_to_simple_base_string(host); - if (ecl_unlikely(!ECL_FIXNUMP(port) || - ecl_fixnum_minusp(port) || - ecl_fixnum_greater(port,ecl_make_fixnum(65536)))) { - FEwrong_type_nth_arg(@[si::open-client-stream], 2, port, - ecl_read_from_cstring("(INTEGER 0 65535)")); - } - p = ecl_fixnum(port); - - if (host->base_string.fillp > BUFSIZ - 1) - FEerror("~S is a too long file name.", 1, host); + if (ecl_unlikely(!ECL_FIXNUMP(port) || + ecl_fixnum_minusp(port) || + ecl_fixnum_greater(port,ecl_make_fixnum(65536)))) { + FEwrong_type_nth_arg(@[si::open-client-stream], 2, port, + ecl_read_from_cstring("(INTEGER 0 65535)")); + } + p = ecl_fixnum(port); - ecl_disable_interrupts(); - fd = connect_to_server((char*)host->base_string.self, ecl_fixnum(port)); - ecl_enable_interrupts(); + if (host->base_string.fillp > BUFSIZ - 1) + FEerror("~S is a too long file name.", 1, host); - if (fd == 0) - @(return ECL_NIL) + ecl_disable_interrupts(); + fd = connect_to_server((char*)host->base_string.self, ecl_fixnum(port)); + ecl_enable_interrupts(); + if (fd == 0) { + @(return ECL_NIL); + } + #if defined(ECL_MS_WINDOWS_HOST) - stream = ecl_make_stream_from_fd(host, fd, ecl_smm_io_wsock, 8, 0, ECL_NIL); + stream = ecl_make_stream_from_fd(host, fd, ecl_smm_io_wsock, 8, 0, ECL_NIL); #else - stream = ecl_make_stream_from_fd(host, fd, ecl_smm_io, 8, 0, ECL_NIL); + stream = ecl_make_stream_from_fd(host, fd, ecl_smm_io, 8, 0, ECL_NIL); #endif - @(return stream) + @(return stream); } cl_object si_open_server_stream(cl_object port) { - int fd; /* file descriptor */ - cl_index p; + int fd; /* file descriptor */ + cl_index p; - if (ecl_unlikely(!ECL_FIXNUMP(port) || - ecl_fixnum_minusp(port) || - ecl_fixnum_greater(port,ecl_make_fixnum(65536)))) { - FEwrong_type_only_arg(@[si::open-client-stream], port, - ecl_read_from_cstring("(INTEGER 0 65535)")); - } - p = ecl_fixnum(port); - ecl_disable_interrupts(); - fd = create_server_port(p); - ecl_enable_interrupts(); + if (ecl_unlikely(!ECL_FIXNUMP(port) || + ecl_fixnum_minusp(port) || + ecl_fixnum_greater(port,ecl_make_fixnum(65536)))) { + FEwrong_type_only_arg(@[si::open-client-stream], port, + ecl_read_from_cstring("(INTEGER 0 65535)")); + } + p = ecl_fixnum(port); + ecl_disable_interrupts(); + fd = create_server_port(p); + ecl_enable_interrupts(); - @(return ((fd == 0)? ECL_NIL : ecl_make_stream_from_fd(ECL_NIL, fd, ecl_smm_io, 8, 0, ECL_NIL))) + @(return ((fd == 0)? ECL_NIL : ecl_make_stream_from_fd(ECL_NIL, fd, ecl_smm_io, 8, 0, ECL_NIL))); } /************************************************************ @@ -334,36 +331,36 @@ si_open_unix_socket_stream(cl_object path) { #if defined(ECL_MS_WINDOWS_HOST) - FEerror("UNIX socket not supported under Win32 platform", 0); + FEerror("UNIX socket not supported under Win32 platform", 0); #else - int fd; /* file descriptor */ - struct sockaddr_un addr; + int fd; /* file descriptor */ + struct sockaddr_un addr; + + if (ecl_unlikely(!ECL_STRINGP(path))) + FEwrong_type_nth_arg(@[si::open-unix-socket-stream], 1, path, + @[string]); + + path = si_coerce_to_base_string(path); + if (path->base_string.fillp > UNIX_MAX_PATH-1) + FEerror("~S is a too long file name.", 1, path); + + fd = socket(PF_UNIX, SOCK_STREAM, 0); + if (fd < 0) { + FElibc_error("Unable to create unix socket", 0); + @(return ECL_NIL); + } - if (ecl_unlikely(!ECL_STRINGP(path))) - FEwrong_type_nth_arg(@[si::open-unix-socket-stream], 1, path, - @[string]); - - path = si_coerce_to_base_string(path); - if (path->base_string.fillp > UNIX_MAX_PATH-1) - FEerror("~S is a too long file name.", 1, path); - - fd = socket(PF_UNIX, SOCK_STREAM, 0); - if (fd < 0) { - FElibc_error("Unable to create unix socket", 0); - @(return ECL_NIL) - } - - memcpy(addr.sun_path, path->base_string.self, path->base_string.fillp); - addr.sun_path[path->base_string.fillp] = 0; - addr.sun_family = AF_UNIX; - - if (connect(fd, (struct sockaddr *)&addr, sizeof(addr)) < 0) { - close(fd); - FElibc_error("Unable to connect to unix socket ~A", 1, path); - @(return ECL_NIL) - } + memcpy(addr.sun_path, path->base_string.self, path->base_string.fillp); + addr.sun_path[path->base_string.fillp] = 0; + addr.sun_family = AF_UNIX; + + if (connect(fd, (struct sockaddr *)&addr, sizeof(addr)) < 0) { + close(fd); + FElibc_error("Unable to connect to unix socket ~A", 1, path); + @(return ECL_NIL); + } - @(return ecl_make_stream_from_fd(path, fd, ecl_smm_io, 8, 0, ECL_NIL)) + @(return ecl_make_stream_from_fd(path, fd, ecl_smm_io, 8, 0, ECL_NIL)); #endif } @@ -373,48 +370,49 @@ cl_object si_lookup_host_entry(cl_object host_or_address) { - struct hostent *he; - unsigned long l; - char address[4]; - cl_object name, aliases, addresses; - int i; + struct hostent *he; + unsigned long l; + char address[4]; + cl_object name, aliases, addresses; + int i; - INIT_TCP + INIT_TCP - switch (ecl_t_of(host_or_address)) { + switch (ecl_t_of(host_or_address)) { #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - host_or_address = si_copy_to_simple_base_string(host_or_address); - he = gethostbyname((char*)host_or_address->base_string.self); - break; - case t_fixnum: - l = ecl_fixnum(host_or_address); - goto addr; - case t_bignum: - l = _ecl_big_to_ulong(host_or_address); - addr: address[0] = l & 0xFF; - address[1] = (l >> 8) & 0xFF; - address[2] = (l >> 16) & 0xFF; - address[3] = (l >> 24) & 0xFF; - he = gethostbyaddr(&address, 4, AF_INET); - break; - default: - FEerror("LOOKUP-HOST-ENTRY: Number or string expected, got ~S", - 1, host_or_address); - } - if (he == NULL) - @(return ECL_NIL ECL_NIL ECL_NIL) - name = make_base_string_copy(he->h_name); - aliases = ECL_NIL; - for (i = 0; he->h_aliases[i] != 0; i++) - aliases = CONS(make_base_string_copy(he->h_aliases[i]), aliases); - addresses = ECL_NIL; - for (i = 0; he->h_addr_list[i]; i++) { - unsigned long *s = (unsigned long*)(he->h_addr_list[i]); - l = *s; - addresses = CONS(ecl_make_integer(l), addresses); - } - @(return name aliases addresses) + case t_base_string: + host_or_address = si_copy_to_simple_base_string(host_or_address); + he = gethostbyname((char*)host_or_address->base_string.self); + break; + case t_fixnum: + l = ecl_fixnum(host_or_address); + goto addr; + case t_bignum: + l = _ecl_big_to_ulong(host_or_address); + addr: address[0] = l & 0xFF; + address[1] = (l >> 8) & 0xFF; + address[2] = (l >> 16) & 0xFF; + address[3] = (l >> 24) & 0xFF; + he = gethostbyaddr(&address, 4, AF_INET); + break; + default: + FEerror("LOOKUP-HOST-ENTRY: Number or string expected, got ~S", + 1, host_or_address); + } + if (he == NULL) { + @(return ECL_NIL ECL_NIL ECL_NIL); + } + name = make_base_string_copy(he->h_name); + aliases = ECL_NIL; + for (i = 0; he->h_aliases[i] != 0; i++) + aliases = CONS(make_base_string_copy(he->h_aliases[i]), aliases); + addresses = ECL_NIL; + for (i = 0; he->h_addr_list[i]; i++) { + unsigned long *s = (unsigned long*)(he->h_addr_list[i]); + l = *s; + addresses = CONS(ecl_make_integer(l), addresses); + } + @(return name aliases addresses); } diff -Nru ecl-16.1.2/src/c/threads/atomic.d ecl-16.1.3+ds/src/c/threads/atomic.d --- ecl-16.1.2/src/c/threads/atomic.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/threads/atomic.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - atomic.d -- atomic operations. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * atomic.d - atomic operations + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -26,44 +21,44 @@ cl_object ecl_atomic_get(cl_object *slot) { - cl_object old; - do { - old = (cl_object)AO_load((AO_t*)slot); - } while (!AO_compare_and_swap_full((AO_t*)slot, (AO_t)old, (AO_t)ECL_NIL)); - return old; + cl_object old; + do { + old = (cl_object)AO_load((AO_t*)slot); + } while (!AO_compare_and_swap_full((AO_t*)slot, (AO_t)old, (AO_t)ECL_NIL)); + return old; } void ecl_atomic_push(cl_object *slot, cl_object c) { - cl_object cons = ecl_list1(c), car; - do { - car = (cl_object)AO_load((AO_t*)slot); - ECL_RPLACD(cons, car); - } while (!AO_compare_and_swap_full((AO_t*)slot, (AO_t)car, (AO_t)cons)); + cl_object cons = ecl_list1(c), car; + do { + car = (cl_object)AO_load((AO_t*)slot); + ECL_RPLACD(cons, car); + } while (!AO_compare_and_swap_full((AO_t*)slot, (AO_t)car, (AO_t)cons)); } cl_object ecl_atomic_pop(cl_object *slot) { - cl_object cons, rest; - do { - cons = (cl_object)AO_load((AO_t*)slot); - rest = CDR(cons); - } while (!AO_compare_and_swap_full((AO_t*)slot, (AO_t)cons, (AO_t)rest)); - return cons; + cl_object cons, rest; + do { + cons = (cl_object)AO_load((AO_t*)slot); + rest = CDR(cons); + } while (!AO_compare_and_swap_full((AO_t*)slot, (AO_t)cons, (AO_t)rest)); + return cons; } cl_index ecl_atomic_index_incf(cl_index *slot) { - AO_t old; - AO_t next; - do { - old = AO_load((AO_t*)slot); - next = old+1; - } while (!AO_compare_and_swap_full((AO_t*)slot, (AO_t)old, (AO_t)next)); - return (cl_index)next; + AO_t old; + AO_t next; + do { + old = AO_load((AO_t*)slot); + next = old+1; + } while (!AO_compare_and_swap_full((AO_t*)slot, (AO_t)old, (AO_t)next)); + return (cl_index)next; } #endif /* ECL_THREADS */ diff -Nru ecl-16.1.2/src/c/threads/barrier.d ecl-16.1.3+ds/src/c/threads/barrier.d --- ecl-16.1.2/src/c/threads/barrier.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/threads/barrier.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - barrier.d -- wait barriers -*/ -/* - Copyright (c) 2012, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * barrier.d - wait barriers + * + * Copyright (c) 2012 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #define AO_ASSUME_WINDOWS98 /* We need this for CAS */ #include @@ -23,149 +18,149 @@ static ECL_INLINE void FEerror_not_a_barrier(cl_object barrier) { - FEwrong_type_argument(@'mp::barrier', barrier); + FEwrong_type_argument(@'mp::barrier', barrier); } cl_object ecl_make_barrier(cl_object name, cl_index count) { - cl_object output = ecl_alloc_object(t_barrier); - output->barrier.name = name; - output->barrier.arrivers_count = count; - output->barrier.count = count; - output->barrier.queue_list = ECL_NIL; - output->barrier.queue_spinlock = ECL_NIL; - return output; + cl_object output = ecl_alloc_object(t_barrier); + output->barrier.name = name; + output->barrier.arrivers_count = count; + output->barrier.count = count; + output->barrier.queue_list = ECL_NIL; + output->barrier.queue_spinlock = ECL_NIL; + return output; } @(defun mp::make-barrier (count &key name) -@ - if (count == ECL_T) - count = ecl_make_fixnum(MOST_POSITIVE_FIXNUM); - @(return ecl_make_barrier(name, fixnnint(count))) -@) + @ + if (count == ECL_T) + count = ecl_make_fixnum(MOST_POSITIVE_FIXNUM); + @(return ecl_make_barrier(name, fixnnint(count))); + @) cl_object mp_barrier_name(cl_object barrier) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(barrier) != t_barrier) { - FEerror_not_a_barrier(barrier); - } - ecl_return1(env, barrier->barrier.name); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(barrier) != t_barrier) { + FEerror_not_a_barrier(barrier); + } + ecl_return1(env, barrier->barrier.name); } cl_object mp_barrier_count(cl_object barrier) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(barrier) != t_barrier) { - FEerror_not_a_barrier(barrier); - } - ecl_return1(env, ecl_make_fixnum(barrier->barrier.count)); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(barrier) != t_barrier) { + FEerror_not_a_barrier(barrier); + } + ecl_return1(env, ecl_make_fixnum(barrier->barrier.count)); } cl_object mp_barrier_arrivers_count(cl_object barrier) { - cl_fixnum arrivers, count; - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(barrier) != t_barrier) { - FEerror_not_a_barrier(barrier); - } - arrivers = barrier->barrier.arrivers_count; - count = barrier->barrier.count; - if (arrivers < 0) - arrivers = 0; /* Disabled barrier */ - else - arrivers = count - arrivers; - ecl_return1(env, ecl_make_fixnum(arrivers)); + cl_fixnum arrivers, count; + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(barrier) != t_barrier) { + FEerror_not_a_barrier(barrier); + } + arrivers = barrier->barrier.arrivers_count; + count = barrier->barrier.count; + if (arrivers < 0) + arrivers = 0; /* Disabled barrier */ + else + arrivers = count - arrivers; + ecl_return1(env, ecl_make_fixnum(arrivers)); } @(defun mp::barrier-unblock (barrier &key reset_count disable kill_waiting) - int ping_flags = ECL_WAKEUP_RESET_FLAG | ECL_WAKEUP_ALL; - int kill_flags = ECL_WAKEUP_RESET_FLAG | ECL_WAKEUP_KILL | ECL_WAKEUP_ALL; -@ - unlikely_if (ecl_t_of(barrier) != t_barrier) { - FEerror_not_a_barrier(barrier); - } - if (!Null(reset_count)) - barrier->barrier.count = fixnnint(reset_count); - if (!Null(disable)) - barrier->barrier.arrivers_count = -1; - else - barrier->barrier.arrivers_count = barrier->barrier.count; - ecl_wakeup_waiters(the_env, barrier, - Null(kill_waiting)? ping_flags : kill_flags); - @(return) -@) + int ping_flags = ECL_WAKEUP_RESET_FLAG | ECL_WAKEUP_ALL; + int kill_flags = ECL_WAKEUP_RESET_FLAG | ECL_WAKEUP_KILL | ECL_WAKEUP_ALL; + @ + unlikely_if (ecl_t_of(barrier) != t_barrier) { + FEerror_not_a_barrier(barrier); + } + if (!Null(reset_count)) + barrier->barrier.count = fixnnint(reset_count); + if (!Null(disable)) + barrier->barrier.arrivers_count = -1; + else + barrier->barrier.arrivers_count = barrier->barrier.count; + ecl_wakeup_waiters(the_env, barrier, + Null(kill_waiting)? ping_flags : kill_flags); + @(return); + @) static cl_object barrier_wait_condition(cl_env_ptr env, cl_object barrier) { - /* We were signaled */ - if (env->own_process->process.woken_up != ECL_NIL) - return ECL_T; - /* Disabled barrier */ - else if (barrier->barrier.arrivers_count < 0) - return ECL_T; - else - return ECL_NIL; + /* We were signaled */ + if (env->own_process->process.woken_up != ECL_NIL) + return ECL_T; + /* Disabled barrier */ + else if (barrier->barrier.arrivers_count < 0) + return ECL_T; + else + return ECL_NIL; } static cl_fixnum decrement_counter(cl_fixnum *counter) { - /* The logic is as follows: - * - If the counter is negative, we abort. This is a way of - * disabling the counter. - * - Otherwise, we decrease the counter only if it is positive - * - If the counter is currently zero, then we block. This - * situation implies that some other thread is unblocking. - */ - cl_fixnum c; - do { - c = *counter; - if (c < 0) { - return c; - } else if (c > 0) { - if (AO_compare_and_swap_full((AO_t*)counter, - (AO_t)c, (AO_t)(c-1))) - return c; - } - } while (1); -} - -@(defun mp::barrier-wait (barrier &key) - cl_object output; - cl_fixnum counter; -@ -{ - cl_object own_process = the_env->own_process; - - unlikely_if (ecl_t_of(barrier) != t_barrier) { - FEerror_not_a_barrier(barrier); - } - ecl_disable_interrupts_env(the_env); - counter = decrement_counter(&barrier->barrier.arrivers_count); - if (counter == 0) { - print_lock("barrier %p saturated", barrier, barrier); - /* There are (count-1) threads in the queue and we - * are the last one. We thus unblock all threads and - * proceed. */ - mp_barrier_unblock(1, barrier); - ecl_enable_interrupts_env(the_env); - output = @':unblocked'; - } else if (counter > 0) { - print_lock("barrier %p waiting", barrier, barrier); - ecl_enable_interrupts_env(the_env); - ecl_wait_on(the_env, barrier_wait_condition, barrier); - output = ECL_T; - } else { - print_lock("barrier %p pass-through", barrier, barrier); - /* Barrier disabled */ - output = ECL_NIL; - } - @(return output) + /* The logic is as follows: + * - If the counter is negative, we abort. This is a way of + * disabling the counter. + * - Otherwise, we decrease the counter only if it is positive + * - If the counter is currently zero, then we block. This + * situation implies that some other thread is unblocking. + */ + cl_fixnum c; + do { + c = *counter; + if (c < 0) { + return c; + } else if (c > 0) { + if (AO_compare_and_swap_full((AO_t*)counter, + (AO_t)c, (AO_t)(c-1))) + return c; + } + } while (1); +} + +cl_object +mp_barrier_wait(cl_object barrier) +{ + cl_object output; + cl_fixnum counter; + cl_env_ptr the_env = ecl_process_env(); + cl_object own_process = the_env->own_process; + + unlikely_if (ecl_t_of(barrier) != t_barrier) { + FEerror_not_a_barrier(barrier); + } + ecl_disable_interrupts_env(the_env); + counter = decrement_counter(&barrier->barrier.arrivers_count); + if (counter == 0) { + print_lock("barrier %p saturated", barrier, barrier); + /* There are (count-1) threads in the queue and we + * are the last one. We thus unblock all threads and + * proceed. */ + mp_barrier_unblock(1, barrier); + ecl_enable_interrupts_env(the_env); + output = @':unblocked'; + } else if (counter > 0) { + print_lock("barrier %p waiting", barrier, barrier); + ecl_enable_interrupts_env(the_env); + ecl_wait_on(the_env, barrier_wait_condition, barrier); + output = ECL_T; + } else { + print_lock("barrier %p pass-through", barrier, barrier); + /* Barrier disabled */ + output = ECL_NIL; + } + return output; } -@) diff -Nru ecl-16.1.2/src/c/threads/condition_variable.d ecl-16.1.3+ds/src/c/threads/condition_variable.d --- ecl-16.1.2/src/c/threads/condition_variable.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/threads/condition_variable.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - condition_variable.d -- Native threads. -*/ -/* - Copyright (c) 2003, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * condition_variable.d - condition variables for native threads + * + * Copyright (c) 2003 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -25,82 +20,82 @@ cl_object mp_make_condition_variable(void) { - cl_object output = ecl_alloc_object(t_condition_variable); - output->condition_variable.queue_list = ECL_NIL; - output->condition_variable.queue_spinlock = ECL_NIL; - output->condition_variable.lock = ECL_NIL; - @(return output) + cl_object output = ecl_alloc_object(t_condition_variable); + output->condition_variable.queue_list = ECL_NIL; + output->condition_variable.queue_spinlock = ECL_NIL; + output->condition_variable.lock = ECL_NIL; + @(return output); } static cl_object condition_variable_wait(cl_env_ptr env, cl_object cv) { - cl_object lock = cv->condition_variable.lock; - cl_object own_process = env->own_process; - /* We have entered the queue and still own the mutex? */ - print_lock("cv lock %p is %p =? %p", cv, lock, lock->lock.owner, own_process); - if (lock->lock.owner == own_process) { - mp_giveup_lock(lock); - } - /* We always return when we have been explicitly awaken */ - return own_process->process.woken_up; + cl_object lock = cv->condition_variable.lock; + cl_object own_process = env->own_process; + /* We have entered the queue and still own the mutex? */ + print_lock("cv lock %p is %p =? %p", cv, lock, lock->lock.owner, own_process); + if (lock->lock.owner == own_process) { + mp_giveup_lock(lock); + } + /* We always return when we have been explicitly awaken */ + return own_process->process.woken_up; } cl_object mp_condition_variable_wait(cl_object cv, cl_object lock) { - cl_env_ptr env = ecl_process_env(); - cl_object own_process = env->own_process; - unlikely_if (ecl_t_of(cv) != t_condition_variable) { - FEwrong_type_nth_arg(@[mp::condition-variable-wait], 1, cv, - @[mp::condition-variable]); - } - unlikely_if (ecl_t_of(lock) != t_lock) { - FEwrong_type_nth_arg(@[mp::condition-variable-wait], 2, lock, - @[mp::lock]); - } - unlikely_if (cv->condition_variable.lock != ECL_NIL && - cv->condition_variable.lock != lock) - { - FEerror("Attempt to associate lock ~A~%with condition variable ~A," - "~%which is already associated to lock ~A", 2, lock, - cv, cv->condition_variable.lock); - } - unlikely_if (lock->lock.owner != own_process) { - FEerror("Attempt to wait on a condition variable using lock~%~S" - "~%which is not owned by process~%~S", 2, lock, own_process); - } - unlikely_if (lock->lock.counter > 1) { - FEerror("mp:condition-variable-wait can not be used with recursive" - " locks:~%~S", 1, lock); - } - print_lock("waiting cv %p", cv, cv); - cv->condition_variable.lock = lock; - ecl_wait_on(env, condition_variable_wait, cv); - mp_get_lock_wait(lock); - @(return ECL_T) + cl_env_ptr env = ecl_process_env(); + cl_object own_process = env->own_process; + unlikely_if (ecl_t_of(cv) != t_condition_variable) { + FEwrong_type_nth_arg(@[mp::condition-variable-wait], 1, cv, + @[mp::condition-variable]); + } + unlikely_if (ecl_t_of(lock) != t_lock) { + FEwrong_type_nth_arg(@[mp::condition-variable-wait], 2, lock, + @[mp::lock]); + } + unlikely_if (cv->condition_variable.lock != ECL_NIL && + cv->condition_variable.lock != lock) + { + FEerror("Attempt to associate lock ~A~%with condition variable ~A," + "~%which is already associated to lock ~A", 2, lock, + cv, cv->condition_variable.lock); + } + unlikely_if (lock->lock.owner != own_process) { + FEerror("Attempt to wait on a condition variable using lock~%~S" + "~%which is not owned by process~%~S", 2, lock, own_process); + } + unlikely_if (lock->lock.counter > 1) { + FEerror("mp:condition-variable-wait can not be used with recursive" + " locks:~%~S", 1, lock); + } + print_lock("waiting cv %p", cv, cv); + cv->condition_variable.lock = lock; + ecl_wait_on(env, condition_variable_wait, cv); + mp_get_lock_wait(lock); + @(return ECL_T); } cl_object mp_condition_variable_timedwait(cl_object cv, cl_object lock, cl_object seconds) { - FEerror("Timed condition variables are not supported.", 0); + FEerror("Timed condition variables are not supported.", 0); } cl_object mp_condition_variable_signal(cl_object cv) { - print_lock("signal cv %p", cv, cv); - ecl_wakeup_waiters(ecl_process_env(), cv, - ECL_WAKEUP_RESET_FLAG | ECL_WAKEUP_ONE | ECL_WAKEUP_DELETE); - @(return ECL_T) + print_lock("signal cv %p", cv, cv); + ecl_wakeup_waiters(ecl_process_env(), cv, + ECL_WAKEUP_RESET_FLAG | ECL_WAKEUP_ONE | ECL_WAKEUP_DELETE); + @(return ECL_T); } cl_object mp_condition_variable_broadcast(cl_object cv) { - print_lock("broadcast cv %p", cv); - ecl_wakeup_waiters(ecl_process_env(), cv, - ECL_WAKEUP_RESET_FLAG | ECL_WAKEUP_ALL | ECL_WAKEUP_DELETE); - @(return ECL_T) + print_lock("broadcast cv %p", cv); + ecl_wakeup_waiters(ecl_process_env(), cv, + ECL_WAKEUP_RESET_FLAG | ECL_WAKEUP_ALL | ECL_WAKEUP_DELETE); + @(return ECL_T); } diff -Nru ecl-16.1.2/src/c/threads/ecl_atomics.h ecl-16.1.3+ds/src/c/threads/ecl_atomics.h --- ecl-16.1.2/src/c/threads/ecl_atomics.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/threads/ecl_atomics.h 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - ecl_atomics.h -- alternative definitions for atomic operations -*/ -/* - Copyright (c) 2012, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * ecl_atomics.h - alternative definitions for atomic operations + * + * Copyright (c) 2012 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #ifndef ECL_ATOMICS_H #define AO_ASSUME_WINDOWS98 diff -Nru ecl-16.1.2/src/c/threads/mailbox.d ecl-16.1.3+ds/src/c/threads/mailbox.d --- ecl-16.1.2/src/c/threads/mailbox.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/threads/mailbox.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - mailbox.d -- thread communication queue -*/ -/* - Copyright (c) 2012, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * mailbox.d -- thread communication queue + * + * Copyright (c) 2012 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #define AO_ASSUME_WINDOWS98 /* We need this for CAS */ #include @@ -23,146 +18,144 @@ static ECL_INLINE void FEerror_not_a_mailbox(cl_object mailbox) { - FEwrong_type_argument(@'mp::mailbox', mailbox); + FEwrong_type_argument(@'mp::mailbox', mailbox); } cl_object ecl_make_mailbox(cl_object name, cl_fixnum count) { - cl_object output = ecl_alloc_object(t_mailbox); - cl_fixnum mask; - for (mask = 1; mask < count; mask <<= 1) {} - if (mask == 1) - mask = 63; - count = mask; - mask = count - 1; - output->mailbox.name = name; - output->mailbox.data = si_make_vector(ECL_T, /* element type */ - ecl_make_fixnum(count), /* size */ - ECL_NIL, /* adjustable */ - ECL_NIL, /* fill pointer */ - ECL_NIL, /* displaced to */ - ECL_NIL); /* displacement */ - output->mailbox.reader_semaphore = - ecl_make_semaphore(name, 0); - output->mailbox.writer_semaphore = - ecl_make_semaphore(name, count); - output->mailbox.read_pointer = 0; - output->mailbox.write_pointer = 0; - output->mailbox.mask = mask; - return output; + cl_object output = ecl_alloc_object(t_mailbox); + cl_fixnum mask; + for (mask = 1; mask < count; mask <<= 1) {} + if (mask == 1) + mask = 63; + count = mask; + mask = count - 1; + output->mailbox.name = name; + output->mailbox.data = si_make_vector(ECL_T, /* element type */ + ecl_make_fixnum(count), /* size */ + ECL_NIL, /* adjustable */ + ECL_NIL, /* fill pointer */ + ECL_NIL, /* displaced to */ + ECL_NIL); /* displacement */ + output->mailbox.reader_semaphore = + ecl_make_semaphore(name, 0); + output->mailbox.writer_semaphore = + ecl_make_semaphore(name, count); + output->mailbox.read_pointer = 0; + output->mailbox.write_pointer = 0; + output->mailbox.mask = mask; + return output; } @(defun mp::make-mailbox (&key name (count ecl_make_fixnum(128))) -@ -{ - @(return ecl_make_mailbox(name, fixnnint(count))) -} -@) + @ { + @(return ecl_make_mailbox(name, fixnnint(count))); + } @) cl_object mp_mailbox_name(cl_object mailbox) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(mailbox) != t_mailbox) { - FEerror_not_a_mailbox(mailbox); - } - ecl_return1(env, mailbox->mailbox.name); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(mailbox) != t_mailbox) { + FEerror_not_a_mailbox(mailbox); + } + ecl_return1(env, mailbox->mailbox.name); } cl_object mp_mailbox_count(cl_object mailbox) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(mailbox) != t_mailbox) { - FEerror_not_a_mailbox(mailbox); - } - ecl_return1(env, ecl_make_fixnum(mailbox->mailbox.data->vector.dim)); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(mailbox) != t_mailbox) { + FEerror_not_a_mailbox(mailbox); + } + ecl_return1(env, ecl_make_fixnum(mailbox->mailbox.data->vector.dim)); } cl_object mp_mailbox_empty_p(cl_object mailbox) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(mailbox) != t_mailbox) { - FEerror_not_a_mailbox(mailbox); - } - ecl_return1(env, mailbox->mailbox.reader_semaphore->semaphore.counter? ECL_NIL : ECL_T); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(mailbox) != t_mailbox) { + FEerror_not_a_mailbox(mailbox); + } + ecl_return1(env, mailbox->mailbox.reader_semaphore->semaphore.counter? ECL_NIL : ECL_T); } cl_object mp_mailbox_read(cl_object mailbox) { - cl_env_ptr env = ecl_process_env(); - cl_fixnum ndx; - cl_object output; - unlikely_if (ecl_t_of(mailbox) != t_mailbox) { - FEerror_not_a_mailbox(mailbox); - } - mp_wait_on_semaphore(mailbox->mailbox.reader_semaphore); - { - ndx = AO_fetch_and_add1((AO_t*)&mailbox->mailbox.read_pointer) & - mailbox->mailbox.mask; - output = mailbox->mailbox.data->vector.self.t[ndx]; - } - mp_signal_semaphore(1, mailbox->mailbox.writer_semaphore); - ecl_return1(env, output); + cl_env_ptr env = ecl_process_env(); + cl_fixnum ndx; + cl_object output; + unlikely_if (ecl_t_of(mailbox) != t_mailbox) { + FEerror_not_a_mailbox(mailbox); + } + mp_wait_on_semaphore(mailbox->mailbox.reader_semaphore); + { + ndx = AO_fetch_and_add1((AO_t*)&mailbox->mailbox.read_pointer) & + mailbox->mailbox.mask; + output = mailbox->mailbox.data->vector.self.t[ndx]; + } + mp_signal_semaphore(1, mailbox->mailbox.writer_semaphore); + ecl_return1(env, output); } cl_object mp_mailbox_try_read(cl_object mailbox) { - cl_env_ptr env = ecl_process_env(); - cl_fixnum ndx; - cl_object output; - unlikely_if (ecl_t_of(mailbox) != t_mailbox) { - FEerror_not_a_mailbox(mailbox); - } - output = mp_try_get_semaphore(mailbox->mailbox.reader_semaphore); - if (output != ECL_NIL) { - ndx = AO_fetch_and_add1((AO_t*)&mailbox->mailbox.read_pointer) & - mailbox->mailbox.mask; - output = mailbox->mailbox.data->vector.self.t[ndx]; - mp_signal_semaphore(1, mailbox->mailbox.writer_semaphore); - } - ecl_return1(env, output); + cl_env_ptr env = ecl_process_env(); + cl_fixnum ndx; + cl_object output; + unlikely_if (ecl_t_of(mailbox) != t_mailbox) { + FEerror_not_a_mailbox(mailbox); + } + output = mp_try_get_semaphore(mailbox->mailbox.reader_semaphore); + if (output != ECL_NIL) { + ndx = AO_fetch_and_add1((AO_t*)&mailbox->mailbox.read_pointer) & + mailbox->mailbox.mask; + output = mailbox->mailbox.data->vector.self.t[ndx]; + mp_signal_semaphore(1, mailbox->mailbox.writer_semaphore); + } + ecl_return1(env, output); } cl_object mp_mailbox_send(cl_object mailbox, cl_object msg) { - cl_env_ptr env = ecl_process_env(); - cl_fixnum ndx; - unlikely_if (ecl_t_of(mailbox) != t_mailbox) { - FEerror_not_a_mailbox(mailbox); - } - mp_wait_on_semaphore(mailbox->mailbox.writer_semaphore); - { - ndx = AO_fetch_and_add1((AO_t*)&mailbox->mailbox.write_pointer) & - mailbox->mailbox.mask; - mailbox->mailbox.data->vector.self.t[ndx] = msg; - } - mp_signal_semaphore(1, mailbox->mailbox.reader_semaphore); - ecl_return0(env); + cl_env_ptr env = ecl_process_env(); + cl_fixnum ndx; + unlikely_if (ecl_t_of(mailbox) != t_mailbox) { + FEerror_not_a_mailbox(mailbox); + } + mp_wait_on_semaphore(mailbox->mailbox.writer_semaphore); + { + ndx = AO_fetch_and_add1((AO_t*)&mailbox->mailbox.write_pointer) & + mailbox->mailbox.mask; + mailbox->mailbox.data->vector.self.t[ndx] = msg; + } + mp_signal_semaphore(1, mailbox->mailbox.reader_semaphore); + ecl_return0(env); } cl_object mp_mailbox_try_send(cl_object mailbox, cl_object msg) { - cl_env_ptr env = ecl_process_env(); - cl_object output; - cl_fixnum ndx; - unlikely_if (ecl_t_of(mailbox) != t_mailbox) { - FEerror_not_a_mailbox(mailbox); - } - output = mp_try_get_semaphore(mailbox->mailbox.writer_semaphore); - if (output != ECL_NIL) { - output = msg; - ndx = AO_fetch_and_add1((AO_t*)&mailbox->mailbox.write_pointer) & - mailbox->mailbox.mask; - mailbox->mailbox.data->vector.self.t[ndx] = msg; - mp_signal_semaphore(1, mailbox->mailbox.reader_semaphore); - } - ecl_return1(env, output); + cl_env_ptr env = ecl_process_env(); + cl_object output; + cl_fixnum ndx; + unlikely_if (ecl_t_of(mailbox) != t_mailbox) { + FEerror_not_a_mailbox(mailbox); + } + output = mp_try_get_semaphore(mailbox->mailbox.writer_semaphore); + if (output != ECL_NIL) { + output = msg; + ndx = AO_fetch_and_add1((AO_t*)&mailbox->mailbox.write_pointer) & + mailbox->mailbox.mask; + mailbox->mailbox.data->vector.self.t[ndx] = msg; + mp_signal_semaphore(1, mailbox->mailbox.reader_semaphore); + } + ecl_return1(env, output); } diff -Nru ecl-16.1.2/src/c/threads/mutex.d ecl-16.1.3+ds/src/c/threads/mutex.d --- ecl-16.1.2/src/c/threads/mutex.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/threads/mutex.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - mutex.d -- mutually exclusive locks. -*/ -/* - Copyright (c) 2003, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * mutex.d - mutually exclusive locks + * + * Copyright (c) 2003 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #define AO_ASSUME_WINDOWS98 /* We need this for CAS */ #include @@ -28,178 +23,190 @@ static void FEerror_not_a_lock(cl_object lock) { - FEwrong_type_argument(@'mp::lock', lock); + FEwrong_type_argument(@'mp::lock', lock); } static void FEerror_not_a_recursive_lock(cl_object lock) { - FEerror("Attempted to recursively lock ~S which is already owned by ~S", - 2, lock, lock->lock.owner); + FEerror("Attempted to recursively lock ~S which is already owned by ~S", + 2, lock, lock->lock.owner); } static void FEerror_not_owned(cl_object lock) { - FEerror("Attempted to give up lock ~S that is not owned by process ~S", - 2, lock, mp_current_process()); + FEerror("Attempted to give up lock ~S that is not owned by process ~S", + 2, lock, mp_current_process()); } cl_object ecl_make_lock(cl_object name, bool recursive) { - cl_object output = ecl_alloc_object(t_lock); - output->lock.name = name; - output->lock.owner = ECL_NIL; - output->lock.counter = 0; - output->lock.recursive = recursive; - output->lock.queue_list = ECL_NIL; - output->lock.queue_spinlock = ECL_NIL; - return output; + cl_object output = ecl_alloc_object(t_lock); + output->lock.name = name; + output->lock.owner = ECL_NIL; + output->lock.counter = 0; + output->lock.recursive = recursive; + output->lock.queue_list = ECL_NIL; + output->lock.queue_spinlock = ECL_NIL; + return output; } -@(defun mp::make-lock (&key name ((:recursive recursive) ECL_NIL)) -@ - @(return ecl_make_lock(name, !Null(recursive))) -@) +@(defun mp::make-lock (&key name (recursive ECL_NIL)) + @ + @(return ecl_make_lock(name, !Null(recursive))); + @) cl_object mp_recursive_lock_p(cl_object lock) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(lock) != t_lock) - FEerror_not_a_lock(lock); - ecl_return1(env, lock->lock.recursive? ECL_T : ECL_NIL); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(lock) != t_lock) + FEerror_not_a_lock(lock); + ecl_return1(env, lock->lock.recursive? ECL_T : ECL_NIL); +} + +cl_object +mp_holding_lock_p(cl_object lock) +{ + cl_env_ptr env = ecl_process_env(); + cl_object own_process = env->own_process; + unlikely_if (ecl_t_of(lock) != t_lock) + FEerror_not_a_lock(lock); + ecl_return1(env, (lock->lock.owner == own_process) ? ECL_T : ECL_NIL); } cl_object mp_lock_name(cl_object lock) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(lock) != t_lock) { - FEerror_not_a_lock(lock); - } - ecl_return1(env, lock->lock.name); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(lock) != t_lock) { + FEerror_not_a_lock(lock); + } + ecl_return1(env, lock->lock.name); } cl_object mp_lock_owner(cl_object lock) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(lock) != t_lock) { - FEerror_not_a_lock(lock); - } - ecl_return1(env, lock->lock.owner); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(lock) != t_lock) { + FEerror_not_a_lock(lock); + } + ecl_return1(env, lock->lock.owner); } cl_object mp_lock_count(cl_object lock) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(lock) != t_lock) { - FEerror_not_a_lock(lock); - } - ecl_return1(env, ecl_make_fixnum(lock->lock.counter)); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(lock) != t_lock) { + FEerror_not_a_lock(lock); + } + ecl_return1(env, ecl_make_fixnum(lock->lock.counter)); } cl_object mp_giveup_lock(cl_object lock) { - /* Must be called with interrupts disabled. */ - cl_env_ptr env = ecl_process_env(); - cl_object own_process = env->own_process; - unlikely_if (ecl_t_of(lock) != t_lock) { - FEerror_not_a_lock(lock); - } - unlikely_if (lock->lock.owner != own_process) { - FEerror_not_owned(lock); - } - if (--lock->lock.counter == 0) { - cl_object first = ecl_waiter_pop(env, lock);; - if (first == ECL_NIL) { - lock->lock.owner = ECL_NIL; - } else { - lock->lock.counter = 1; - lock->lock.owner = first; - ecl_wakeup_process(first); - } - } - ecl_return1(env, ECL_T); + /* Must be called with interrupts disabled. */ + cl_env_ptr env = ecl_process_env(); + cl_object own_process = env->own_process; + unlikely_if (ecl_t_of(lock) != t_lock) { + FEerror_not_a_lock(lock); + } + unlikely_if (lock->lock.owner != own_process) { + FEerror_not_owned(lock); + } + if (--lock->lock.counter == 0) { + cl_object first = ecl_waiter_pop(env, lock);; + if (first == ECL_NIL) { + lock->lock.owner = ECL_NIL; + } else { + lock->lock.counter = 1; + lock->lock.owner = first; + ecl_wakeup_process(first); + } + } + ecl_return1(env, ECL_T); } static cl_object get_lock_inner(cl_env_ptr env, cl_object lock) { - cl_object output; - cl_object own_process = env->own_process; - ecl_disable_interrupts_env(env); - if (AO_compare_and_swap_full((AO_t*)&(lock->lock.owner), - (AO_t)ECL_NIL, (AO_t)own_process)) { - lock->lock.counter = 1; - output = ECL_T; - print_lock("acquired %p\t", lock, lock); - } else if (lock->lock.owner == own_process) { - unlikely_if (!lock->lock.recursive) { - FEerror_not_a_recursive_lock(lock); - } - ++lock->lock.counter; - output = ECL_T; - } else { - print_lock("failed acquiring %p for %d\t", lock, lock, - lock->lock.owner); - output = ECL_NIL; - } - ecl_enable_interrupts_env(env); - return output; + cl_object output; + cl_object own_process = env->own_process; + ecl_disable_interrupts_env(env); + if (AO_compare_and_swap_full((AO_t*)&(lock->lock.owner), + (AO_t)ECL_NIL, (AO_t)own_process)) { + lock->lock.counter = 1; + output = ECL_T; + print_lock("acquired %p\t", lock, lock); + } else if (lock->lock.owner == own_process) { + unlikely_if (!lock->lock.recursive) { + FEerror_not_a_recursive_lock(lock); + } + ++lock->lock.counter; + output = ECL_T; + } else { + print_lock("failed acquiring %p for %d\t", lock, lock, + lock->lock.owner); + output = ECL_NIL; + } + ecl_enable_interrupts_env(env); + return output; } cl_object mp_get_lock_nowait(cl_object lock) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(lock) != t_lock) { - FEerror_not_a_lock(lock); - } - ecl_return1(env, get_lock_inner(env, lock)); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(lock) != t_lock) { + FEerror_not_a_lock(lock); + } + ecl_return1(env, get_lock_inner(env, lock)); } static cl_object own_or_get_lock(cl_env_ptr env, cl_object lock) { - cl_object output; - cl_object own_process = env->own_process; - ecl_disable_interrupts_env(env); - if (AO_compare_and_swap_full((AO_t*)&(lock->lock.owner), - (AO_t)ECL_NIL, (AO_t)own_process)) { - lock->lock.counter = 1; - output = ECL_T; - print_lock("acquired %p\t", lock, lock); - } else if (lock->lock.owner == own_process) { - output = ECL_T; - } else { - output = ECL_NIL; - } - ecl_enable_interrupts_env(env); - return output; + cl_object output; + cl_object own_process = env->own_process; + ecl_disable_interrupts_env(env); + if (AO_compare_and_swap_full((AO_t*)&(lock->lock.owner), + (AO_t)ECL_NIL, (AO_t)own_process)) { + lock->lock.counter = 1; + output = ECL_T; + print_lock("acquired %p\t", lock, lock); + } else if (lock->lock.owner == own_process) { + output = ECL_T; + } else { + output = ECL_NIL; + } + ecl_enable_interrupts_env(env); + return output; } cl_object mp_get_lock_wait(cl_object lock) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(lock) != t_lock) { - FEerror_not_a_lock(lock); - } - if (get_lock_inner(env, lock) == ECL_NIL) { - ecl_wait_on(env, own_or_get_lock, lock); - } - @(return ECL_T) + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(lock) != t_lock) { + FEerror_not_a_lock(lock); + } + if (get_lock_inner(env, lock) == ECL_NIL) { + ecl_wait_on(env, own_or_get_lock, lock); + } + @(return ECL_T); } @(defun mp::get-lock (lock &optional (wait ECL_T)) -@ - if (Null(wait)) - return mp_get_lock_nowait(lock); - else - return mp_get_lock_wait(lock); -@) + @ + if (Null(wait)) { + return mp_get_lock_nowait(lock); + } + else { + return mp_get_lock_wait(lock); + } + @) diff -Nru ecl-16.1.2/src/c/threads/process.d ecl-16.1.3+ds/src/c/threads/process.d --- ecl-16.1.2/src/c/threads/process.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/threads/process.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - threads.d -- Native threads. -*/ -/* - Copyright (c) 2003, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * process.d - native threads + * + * Copyright (c) 2003 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #ifndef __sun__ /* See unixinit.d for this */ #define _XOPEN_SOURCE 600 /* For pthread mutex attributes */ @@ -36,16 +31,6 @@ #include "threads/ecl_atomics.h" #ifdef ECL_WINDOWS_THREADS -/* - * We have to put this explicit definition here because Boehm GC - * is designed to produce a DLL and we rather want a static - * reference - */ -# include -extern HANDLE WINAPI GC_CreateThread( - LPSECURITY_ATTRIBUTES lpThreadAttributes, - DWORD dwStackSize, LPTHREAD_START_ROUTINE lpStartAddress, - LPVOID lpParameter, DWORD dwCreationFlags, LPDWORD lpThreadId ); # ifndef WITH___THREAD DWORD cl_env_key; # endif @@ -62,13 +47,13 @@ ecl_process_env(void) { #ifdef ECL_WINDOWS_THREADS - return TlsGetValue(cl_env_key); + return TlsGetValue(cl_env_key); #else - struct cl_env_struct *rv = pthread_getspecific(cl_env_key); - if (rv) - return rv; - FElibc_error("pthread_getspecific() failed.", 0); - return NULL; + struct cl_env_struct *rv = pthread_getspecific(cl_env_key); + if (rv) + return rv; + FElibc_error("pthread_getspecific() failed.", 0); + return NULL; #endif } #endif @@ -77,13 +62,13 @@ ecl_set_process_env(cl_env_ptr env) { #ifdef WITH___THREAD - cl_env_p = env; + cl_env_p = env; #else # ifdef ECL_WINDOWS_THREADS - TlsSetValue(cl_env_key, env); + TlsSetValue(cl_env_key, env); # else - if (pthread_setspecific(cl_env_key, env)) - FElibc_error("pthread_setspecific() failed.", 0); + if (pthread_setspecific(cl_env_key, env)) + FElibc_error("pthread_setspecific() failed.", 0); # endif #endif } @@ -91,7 +76,7 @@ cl_object mp_current_process(void) { - return ecl_process_env()->own_process; + return ecl_process_env()->own_process; } /*---------------------------------------------------------------------- @@ -101,79 +86,79 @@ static void extend_process_vector() { - cl_object v = cl_core.processes; - cl_index new_size = v->vector.dim + v->vector.dim/2; - cl_env_ptr the_env = ecl_process_env(); - ECL_WITH_SPINLOCK_BEGIN(the_env, &cl_core.processes_spinlock) { - cl_object other = cl_core.processes; - if (new_size > other->vector.dim) { - cl_object new = si_make_vector(ECL_T, - ecl_make_fixnum(new_size), - ecl_make_fixnum(other->vector.fillp), - ECL_NIL, ECL_NIL, ECL_NIL); - ecl_copy_subarray(new, 0, other, 0, other->vector.dim); - cl_core.processes = new; - } - } ECL_WITH_SPINLOCK_END; + cl_object v = cl_core.processes; + cl_index new_size = v->vector.dim + v->vector.dim/2; + cl_env_ptr the_env = ecl_process_env(); + ECL_WITH_SPINLOCK_BEGIN(the_env, &cl_core.processes_spinlock) { + cl_object other = cl_core.processes; + if (new_size > other->vector.dim) { + cl_object new = si_make_vector(ECL_T, + ecl_make_fixnum(new_size), + ecl_make_fixnum(other->vector.fillp), + ECL_NIL, ECL_NIL, ECL_NIL); + ecl_copy_subarray(new, 0, other, 0, other->vector.dim); + cl_core.processes = new; + } + } ECL_WITH_SPINLOCK_END; } static void ecl_list_process(cl_object process) { - cl_env_ptr the_env = ecl_process_env(); - bool ok = 0; - do { - ECL_WITH_SPINLOCK_BEGIN(the_env, &cl_core.processes_spinlock) { - cl_object vector = cl_core.processes; - cl_index size = vector->vector.dim; - cl_index ndx = vector->vector.fillp; - if (ndx < size) { - vector->vector.self.t[ndx++] = process; - vector->vector.fillp = ndx; - ok = 1; - } - } ECL_WITH_SPINLOCK_END; - if (ok) break; - extend_process_vector(); - } while (1); + cl_env_ptr the_env = ecl_process_env(); + bool ok = 0; + do { + ECL_WITH_SPINLOCK_BEGIN(the_env, &cl_core.processes_spinlock) { + cl_object vector = cl_core.processes; + cl_index size = vector->vector.dim; + cl_index ndx = vector->vector.fillp; + if (ndx < size) { + vector->vector.self.t[ndx++] = process; + vector->vector.fillp = ndx; + ok = 1; + } + } ECL_WITH_SPINLOCK_END; + if (ok) break; + extend_process_vector(); + } while (1); } static void ecl_unlist_process(cl_object process) { - cl_env_ptr the_env = ecl_process_env(); - ECL_WITH_SPINLOCK_BEGIN(the_env, &cl_core.processes_spinlock) { - cl_object vector = cl_core.processes; - cl_index i; - for (i = 0; i < vector->vector.fillp; i++) { - if (vector->vector.self.t[i] == process) { - vector->vector.fillp--; - do { - vector->vector.self.t[i] = - vector->vector.self.t[i+1]; - } while (++i < vector->vector.fillp); - break; - } - } - } ECL_WITH_SPINLOCK_END; + cl_env_ptr the_env = ecl_process_env(); + ECL_WITH_SPINLOCK_BEGIN(the_env, &cl_core.processes_spinlock) { + cl_object vector = cl_core.processes; + cl_index i; + for (i = 0; i < vector->vector.fillp; i++) { + if (vector->vector.self.t[i] == process) { + vector->vector.fillp--; + do { + vector->vector.self.t[i] = + vector->vector.self.t[i+1]; + } while (++i < vector->vector.fillp); + break; + } + } + } ECL_WITH_SPINLOCK_END; } static cl_object ecl_process_list() { - cl_env_ptr the_env = ecl_process_env(); - cl_object output = ECL_NIL; - ECL_WITH_SPINLOCK_BEGIN(the_env, &cl_core.processes_spinlock) { - cl_object vector = cl_core.processes; - cl_object *data = vector->vector.self.t; - cl_index i; - for (i = 0; i < vector->vector.fillp; i++) { - cl_object p = data[i]; - if (p != ECL_NIL) - output = ecl_cons(p, output); - } - } ECL_WITH_SPINLOCK_END; - return output; + cl_env_ptr the_env = ecl_process_env(); + cl_object output = ECL_NIL; + ECL_WITH_SPINLOCK_BEGIN(the_env, &cl_core.processes_spinlock) { + cl_object vector = cl_core.processes; + cl_object *data = vector->vector.self.t; + cl_index i; + for (i = 0; i < vector->vector.fillp; i++) { + cl_object p = data[i]; + if (p != ECL_NIL) + output = ecl_cons(p, output); + } + } ECL_WITH_SPINLOCK_END; + return output; } /*---------------------------------------------------------------------- @@ -183,495 +168,504 @@ static void assert_type_process(cl_object o) { - if (ecl_t_of(o) != t_process) - FEwrong_type_argument(@[mp::process], o); + if (ecl_t_of(o) != t_process) + FEwrong_type_argument(@[mp::process], o); } static void thread_cleanup(void *aux) { - /* This routine performs some cleanup before a thread is completely - * killed. For instance, it has to remove the associated process - * object from the list, an it has to dealloc some memory. - * - * NOTE: thread_cleanup() does not provide enough "protection". In - * order to ensure that all UNWIND-PROTECT forms are properly - * executed, never use pthread_cancel() to kill a process, but - * rather use the lisp functions mp_interrupt_process() and - * mp_process_kill(). - */ - cl_object process = (cl_object)aux; - cl_env_ptr env = process->process.env; - /* The following flags will disable all interrupts. */ - AO_store_full((AO_t*)&process->process.phase, ECL_PROCESS_EXITING); - ecl_disable_interrupts_env(env); + /* This routine performs some cleanup before a thread is completely + * killed. For instance, it has to remove the associated process + * object from the list, an it has to dealloc some memory. + * + * NOTE: thread_cleanup() does not provide enough "protection". In + * order to ensure that all UNWIND-PROTECT forms are properly + * executed, never use pthread_cancel() to kill a process, but + * rather use the lisp functions mp_interrupt_process() and + * mp_process_kill(). + */ + cl_object process = (cl_object)aux; + cl_env_ptr env = process->process.env; + /* The following flags will disable all interrupts. */ + AO_store_full((AO_t*)&process->process.phase, ECL_PROCESS_EXITING); + ecl_disable_interrupts_env(env); #ifdef HAVE_SIGPROCMASK - /* ...but we might get stray signals. */ - { - sigset_t new[1]; - sigemptyset(new); - sigaddset(new, ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]); - pthread_sigmask(SIG_BLOCK, new, NULL); - } -#endif - process->process.env = NULL; - ecl_unlist_process(process); - mp_barrier_unblock(3, process->process.exit_barrier, @':disable', ECL_T); - ecl_set_process_env(NULL); - if (env) _ecl_dealloc_env(env); - AO_store_release((AO_t*)&process->process.phase, ECL_PROCESS_INACTIVE); + /* ...but we might get stray signals. */ + { + sigset_t new[1]; + sigemptyset(new); + sigaddset(new, ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]); + pthread_sigmask(SIG_BLOCK, new, NULL); + } +#endif + process->process.env = NULL; + ecl_unlist_process(process); + mp_barrier_unblock(3, process->process.exit_barrier, @':disable', ECL_T); + ecl_set_process_env(NULL); + if (env) _ecl_dealloc_env(env); + AO_store_release((AO_t*)&process->process.phase, ECL_PROCESS_INACTIVE); } #ifdef ECL_WINDOWS_THREADS static DWORD WINAPI thread_entry_point(void *arg) #else -static void * -thread_entry_point(void *arg) + static void * + thread_entry_point(void *arg) #endif { - cl_object process = (cl_object)arg; - cl_env_ptr env = process->process.env; + cl_object process = (cl_object)arg; + cl_env_ptr env = process->process.env; - /* - * Upon entering this routine - * process.env = our environment for lisp - * process.phase = ECL_PROCESS_BOOTING - * signals are disabled in the environment - * the communication interrupt is disabled (sigmasked) - * - * This process will not receive signals that originate from - * other processes. Furthermore, we expect not to get any - * other interrupts (SIGSEGV, SIGFPE) if we do things right. - */ - /* 1) Setup the environment for the execution of the thread */ - ecl_set_process_env(env = process->process.env); + /* + * Upon entering this routine + * process.env = our environment for lisp + * process.phase = ECL_PROCESS_BOOTING + * signals are disabled in the environment + * the communication interrupt is disabled (sigmasked) + * + * This process will not receive signals that originate from + * other processes. Furthermore, we expect not to get any + * other interrupts (SIGSEGV, SIGFPE) if we do things right. + */ + /* 1) Setup the environment for the execution of the thread */ + ecl_set_process_env(env = process->process.env); #ifndef ECL_WINDOWS_THREADS - pthread_cleanup_push(thread_cleanup, (void *)process); + pthread_cleanup_push(thread_cleanup, (void *)process); #endif - ecl_cs_set_org(env); - ecl_get_spinlock(env, &process->process.start_spinlock); - print_lock("ENVIRON %p %p %p %p", ECL_NIL, process, - env->bds_org, env->bds_top, env->bds_limit); - - /* 2) Execute the code. The CATCH_ALL point is the destination - * provides us with an elegant way to exit the thread: we just - * do an unwind up to frs_top. - */ - ECL_CATCH_ALL_BEGIN(env) { + ecl_cs_set_org(env); + ecl_get_spinlock(env, &process->process.start_spinlock); + print_lock("ENVIRON %p %p %p %p", ECL_NIL, process, + env->bds_org, env->bds_top, env->bds_limit); + + /* 2) Execute the code. The CATCH_ALL point is the destination + * provides us with an elegant way to exit the thread: we just + * do an unwind up to frs_top. + */ + ECL_CATCH_ALL_BEGIN(env) { #ifdef HAVE_SIGPROCMASK - { - sigset_t *new = (sigset_t*)env->default_sigmask; - pthread_sigmask(SIG_SETMASK, new, NULL); - } -#endif - process->process.phase = ECL_PROCESS_ACTIVE; - ecl_enable_interrupts_env(env); - si_trap_fpe(@'last', ECL_T); - ecl_bds_bind(env, @'mp::*current-process*', process); - - ECL_RESTART_CASE_BEGIN(env, @'abort') { - env->values[0] = cl_apply(2, process->process.function, - process->process.args); - { - cl_object output = ECL_NIL; - int i = env->nvalues; - while (i--) { - output = CONS(env->values[i], output); - } - process->process.exit_values = output; - } - } ECL_RESTART_CASE(1,args) { - /* ABORT restart. */ - process->process.exit_values = args; - } ECL_RESTART_CASE_END; - /* This will disable interrupts during the exit - * so that the unwinding is not interrupted. */ - process->process.phase = ECL_PROCESS_EXITING; - ecl_bds_unwind1(env); - } ECL_CATCH_ALL_END; - - /* 4) If everything went right, we should be exiting the thread - * through this point. thread_cleanup is automatically invoked - * marking the process as inactive. - */ + { + sigset_t *new = (sigset_t*)env->default_sigmask; + pthread_sigmask(SIG_SETMASK, new, NULL); + } +#endif + process->process.phase = ECL_PROCESS_ACTIVE; + ecl_enable_interrupts_env(env); + si_trap_fpe(@'last', ECL_T); + ecl_bds_bind(env, @'mp::*current-process*', process); + + ECL_RESTART_CASE_BEGIN(env, @'abort') { + env->values[0] = cl_apply(2, process->process.function, + process->process.args); + { + cl_object output = ECL_NIL; + int i = env->nvalues; + while (i--) { + output = CONS(env->values[i], output); + } + process->process.exit_values = output; + } + } ECL_RESTART_CASE(1,args) { + /* ABORT restart. */ + process->process.exit_values = args; + } ECL_RESTART_CASE_END; + /* This will disable interrupts during the exit + * so that the unwinding is not interrupted. */ + process->process.phase = ECL_PROCESS_EXITING; + ecl_bds_unwind1(env); + } ECL_CATCH_ALL_END; + + /* 4) If everything went right, we should be exiting the thread + * through this point. thread_cleanup is automatically invoked + * marking the process as inactive. + */ #ifdef ECL_WINDOWS_THREADS - thread_cleanup(process); - return 1; + thread_cleanup(process); + return 1; #else - pthread_cleanup_pop(1); - return NULL; + pthread_cleanup_pop(1); + return NULL; #endif } static cl_object alloc_process(cl_object name, cl_object initial_bindings) { - cl_object process = ecl_alloc_object(t_process), array; - process->process.phase = ECL_PROCESS_INACTIVE; - process->process.name = name; - process->process.function = ECL_NIL; - process->process.args = ECL_NIL; - process->process.interrupt = ECL_NIL; - process->process.exit_values = ECL_NIL; - process->process.env = NULL; - if (initial_bindings != OBJNULL) { - array = si_make_vector(ECL_T, ecl_make_fixnum(256), - ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL); - si_fill_array_with_elt(array, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL); - } else { - array = cl_copy_seq(ecl_process_env()->bindings_array); - } - process->process.initial_bindings = array; - process->process.woken_up = ECL_NIL; - process->process.start_spinlock = ECL_NIL; - process->process.queue_record = ecl_list1(process); - /* Creates the exit barrier so that processes can wait for termination, - * but it is created in a disabled state. */ - process->process.exit_barrier = ecl_make_barrier(name, MOST_POSITIVE_FIXNUM); - mp_barrier_unblock(3, process->process.exit_barrier, @':disable', ECL_T); - return process; + cl_object process = ecl_alloc_object(t_process), array; + process->process.phase = ECL_PROCESS_INACTIVE; + process->process.name = name; + process->process.function = ECL_NIL; + process->process.args = ECL_NIL; + process->process.interrupt = ECL_NIL; + process->process.exit_values = ECL_NIL; + process->process.env = NULL; + if (initial_bindings != OBJNULL) { + array = si_make_vector(ECL_T, ecl_make_fixnum(256), + ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL); + si_fill_array_with_elt(array, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL); + } else { + array = cl_copy_seq(ecl_process_env()->bindings_array); + } + process->process.initial_bindings = array; + process->process.woken_up = ECL_NIL; + process->process.start_spinlock = ECL_NIL; + process->process.queue_record = ecl_list1(process); + /* Creates the exit barrier so that processes can wait for termination, + * but it is created in a disabled state. */ + process->process.exit_barrier = ecl_make_barrier(name, MOST_POSITIVE_FIXNUM); + mp_barrier_unblock(3, process->process.exit_barrier, @':disable', ECL_T); + return process; } bool ecl_import_current_thread(cl_object name, cl_object bindings) { - struct cl_env_struct env_aux[1]; - cl_object process; - pthread_t current; - cl_env_ptr env; - int registered; - struct GC_stack_base stack; -#ifdef ECL_WINDOWS_THREADS - { - HANDLE aux = GetCurrentThread(); - DuplicateHandle(GetCurrentProcess(), - aux, - GetCurrentProcess(), - ¤t, - 0, - FALSE, - DUPLICATE_SAME_ACCESS); - CloseHandle(current); - } + struct cl_env_struct env_aux[1]; + cl_object process; + pthread_t current; + cl_env_ptr env; + int registered; + struct GC_stack_base stack; +#ifdef ECL_WINDOWS_THREADS + { + HANDLE aux = GetCurrentThread(); + if ( !DuplicateHandle(GetCurrentProcess(), + aux, + GetCurrentProcess(), + ¤t, + 0, + FALSE, + DUPLICATE_SAME_ACCESS) ) + { + return 0; + } + } #else - current = pthread_self(); + current = pthread_self(); #endif #ifdef GBC_BOEHM - GC_get_stack_base(&stack); - switch (GC_register_my_thread(&stack)) { - case GC_SUCCESS: - registered = 1; - break; - case GC_DUPLICATE: - /* Thread was probably created using the GC hooks - * for thread creation */ - registered = 0; - break; - default: - return 0; - } -#endif - { - cl_object processes = cl_core.processes; - cl_index i, size; - for (i = 0, size = processes->vector.dim; i < size; i++) { - cl_object p = processes->vector.self.t[i]; - if (!Null(p) && p->process.thread == current) - return 0; - } - } - /* We need a fake env to allow for interrupts blocking. */ - env_aux->disable_interrupts = 1; - ecl_set_process_env(env_aux); - env = _ecl_alloc_env(0); - ecl_set_process_env(env); - env->cleanup = registered; - - /* Link environment and process together */ - env->own_process = process = alloc_process(name, bindings); - process->process.env = env; - process->process.phase = ECL_PROCESS_BOOTING; - process->process.thread = current; - ecl_list_process(process); - - ecl_init_env(env); - env->bindings_array = process->process.initial_bindings; - env->thread_local_bindings_size = env->bindings_array->vector.dim; - env->thread_local_bindings = env->bindings_array->vector.self.t; - ecl_enable_interrupts_env(env); - - /* Activate the barrier so that processes can immediately start waiting. */ - mp_barrier_unblock(1, process->process.exit_barrier); - process->process.phase = ECL_PROCESS_ACTIVE; + GC_get_stack_base(&stack); + switch (GC_register_my_thread(&stack)) { + case GC_SUCCESS: + registered = 1; + break; + case GC_DUPLICATE: + /* Thread was probably created using the GC hooks + * for thread creation */ + registered = 0; + break; + default: + return 0; + } +#endif + { + cl_object processes = cl_core.processes; + cl_index i, size; + for (i = 0, size = processes->vector.fillp; i < size; i++) { + cl_object p = processes->vector.self.t[i]; + if (!Null(p) && p->process.thread == current) + return 0; + } + } + /* We need a fake env to allow for interrupts blocking. */ + env_aux->disable_interrupts = 1; + ecl_set_process_env(env_aux); + env = _ecl_alloc_env(0); + ecl_set_process_env(env); + + /* Link environment and process together */ + env->own_process = process = alloc_process(name, bindings); + process->process.env = env; + process->process.phase = ECL_PROCESS_BOOTING; + process->process.thread = current; + ecl_list_process(process); + + ecl_init_env(env); + env->cleanup = registered; + env->bindings_array = process->process.initial_bindings; + env->thread_local_bindings_size = env->bindings_array->vector.dim; + env->thread_local_bindings = env->bindings_array->vector.self.t; + ecl_enable_interrupts_env(env); + + /* Activate the barrier so that processes can immediately start waiting. */ + mp_barrier_unblock(1, process->process.exit_barrier); + process->process.phase = ECL_PROCESS_ACTIVE; - ecl_bds_bind(env, @'mp::*current-process*', process); - return 1; + ecl_bds_bind(env, @'mp::*current-process*', process); + return 1; } void ecl_release_current_thread(void) { - cl_env_ptr env = ecl_process_env(); - int cleanup = env->cleanup; - thread_cleanup(env->own_process); + cl_env_ptr env = ecl_process_env(); +#ifdef ECL_WINDOWS_THREADS + HANDLE to_close = env->own_process->process.thread; +#endif + + int cleanup = env->cleanup; + thread_cleanup(env->own_process); #ifdef GBC_BOEHM - if (cleanup) { - GC_unregister_my_thread(); - } + if (cleanup) { + GC_unregister_my_thread(); + } +#endif +#ifdef ECL_WINDOWS_THREADS + CloseHandle(to_close); #endif } @(defun mp::make-process (&key name ((:initial-bindings initial_bindings) ECL_T)) - cl_object process; -@ - process = alloc_process(name, initial_bindings); - @(return process) -@) + cl_object process; + @ + process = alloc_process(name, initial_bindings); + @(return process); + @) cl_object mp_process_preset(cl_narg narg, cl_object process, cl_object function, ...) { - ecl_va_list args; - ecl_va_start(args, function, narg, 2); - if (narg < 2) - FEwrong_num_arguments(@[mp::process-preset]); - assert_type_process(process); - process->process.function = function; - process->process.args = cl_grab_rest_args(args); - @(return process) + ecl_va_list args; + ecl_va_start(args, function, narg, 2); + if (narg < 2) + FEwrong_num_arguments(@[mp::process-preset]); + assert_type_process(process); + process->process.function = function; + process->process.args = cl_grab_rest_args(args); + @(return process); } cl_object mp_interrupt_process(cl_object process, cl_object function) { - unlikely_if (mp_process_active_p(process) == ECL_NIL) - FEerror("Cannot interrupt the inactive process ~A", 1, process); - ecl_interrupt_process(process, function); - @(return ECL_T) + unlikely_if (mp_process_active_p(process) == ECL_NIL) + FEerror("Cannot interrupt the inactive process ~A", 1, process); + ecl_interrupt_process(process, function); + @(return ECL_T); } cl_object mp_suspend_loop() { - cl_env_ptr env = ecl_process_env(); - ECL_CATCH_BEGIN(env,@'mp::suspend-loop') { - for ( ; ; ) { - cl_sleep(ecl_make_fixnum(100)); - } - } ECL_CATCH_END; - ecl_return0(env); + cl_env_ptr env = ecl_process_env(); + ECL_CATCH_BEGIN(env,@'mp::suspend-loop') { + for ( ; ; ) { + cl_sleep(ecl_make_fixnum(100)); + } + } ECL_CATCH_END; + ecl_return0(env); } cl_object mp_break_suspend_loop() { - cl_env_ptr the_env = ecl_process_env(); - if (frs_sch(@'mp::suspend-loop')) { - cl_throw(@'mp::suspend-loop'); - } - ecl_return0(the_env); + cl_env_ptr the_env = ecl_process_env(); + if (frs_sch(@'mp::suspend-loop')) { + cl_throw(@'mp::suspend-loop'); + } + ecl_return0(the_env); } cl_object mp_process_suspend(cl_object process) { - return mp_interrupt_process(process, @'mp::suspend-loop'); + return mp_interrupt_process(process, @'mp::suspend-loop'); } cl_object mp_process_resume(cl_object process) { - return mp_interrupt_process(process, @'mp::break-suspend-loop'); + return mp_interrupt_process(process, @'mp::break-suspend-loop'); } cl_object mp_process_kill(cl_object process) { - return mp_interrupt_process(process, @'mp::exit-process'); + return mp_interrupt_process(process, @'mp::exit-process'); } cl_object mp_process_yield(void) { - ecl_process_yield(); - @(return) + ecl_process_yield(); + @(return); } cl_object mp_process_enable(cl_object process) { - cl_env_ptr process_env; - int ok; - /* Try to gain exclusive access to the process at the same - * time we ensure that it is inactive. This prevents two - * concurrent calls to process-enable from different threads - * on the same process */ - unlikely_if (!AO_compare_and_swap_full((AO_t*)&process->process.phase, - ECL_PROCESS_INACTIVE, - ECL_PROCESS_BOOTING)) { - FEerror("Cannot enable the running process ~A.", 1, process); - } - process->process.parent = mp_current_process(); - process->process.trap_fpe_bits = - process->process.parent->process.env->trap_fpe_bits; - ecl_list_process(process); - - /* Link environment and process together */ - process_env = _ecl_alloc_env(ecl_process_env()); - process_env->own_process = process; - process->process.env = process_env; - - ecl_init_env(process_env); - process_env->trap_fpe_bits = process->process.trap_fpe_bits; - process_env->bindings_array = process->process.initial_bindings; - process_env->thread_local_bindings_size = - process_env->bindings_array->vector.dim; - process_env->thread_local_bindings = - process_env->bindings_array->vector.self.t; - - /* Activate the barrier so that processes can immediately start waiting. */ - mp_barrier_unblock(1, process->process.exit_barrier); - - /* Block the thread with this spinlock until it is ready */ - process->process.start_spinlock = ECL_T; - -#ifdef ECL_WINDOWS_THREADS - { - HANDLE code; - DWORD threadId; + cl_env_ptr process_env; + int ok; + /* Try to gain exclusive access to the process at the same + * time we ensure that it is inactive. This prevents two + * concurrent calls to process-enable from different threads + * on the same process */ + unlikely_if (!AO_compare_and_swap_full((AO_t*)&process->process.phase, + ECL_PROCESS_INACTIVE, + ECL_PROCESS_BOOTING)) { + FEerror("Cannot enable the running process ~A.", 1, process); + } + process->process.parent = mp_current_process(); + process->process.trap_fpe_bits = + process->process.parent->process.env->trap_fpe_bits; + ecl_list_process(process); + + /* Link environment and process together */ + process_env = _ecl_alloc_env(ecl_process_env()); + process_env->own_process = process; + process->process.env = process_env; + + ecl_init_env(process_env); + process_env->trap_fpe_bits = process->process.trap_fpe_bits; + process_env->bindings_array = process->process.initial_bindings; + process_env->thread_local_bindings_size = + process_env->bindings_array->vector.dim; + process_env->thread_local_bindings = + process_env->bindings_array->vector.self.t; - code = (HANDLE)CreateThread(NULL, 0, thread_entry_point, process, 0, &threadId); - ok = (process->process.thread = code) != NULL; - } -#else - { - int code; - pthread_attr_t pthreadattr; - - pthread_attr_init(&pthreadattr); - pthread_attr_setdetachstate(&pthreadattr, PTHREAD_CREATE_DETACHED); - /* - * We launch the thread with the signal mask specified in cl_core. - * The reason is that we might need to block certain signals - * to be processed by the signal handling thread in unixint.d - */ + /* Activate the barrier so that processes can immediately start waiting. */ + mp_barrier_unblock(1, process->process.exit_barrier); + + /* Block the thread with this spinlock until it is ready */ + process->process.start_spinlock = ECL_T; + +#ifdef ECL_WINDOWS_THREADS + { + HANDLE code; + DWORD threadId; + + code = (HANDLE)CreateThread(NULL, 0, thread_entry_point, process, 0, &threadId); + ok = (process->process.thread = code) != NULL; + } +#else + { + int code; + pthread_attr_t pthreadattr; + + pthread_attr_init(&pthreadattr); + pthread_attr_setdetachstate(&pthreadattr, PTHREAD_CREATE_DETACHED); + /* + * We launch the thread with the signal mask specified in cl_core. + * The reason is that we might need to block certain signals + * to be processed by the signal handling thread in unixint.d + */ #ifdef HAVE_SIGPROCMASK - { - sigset_t new, previous; - sigfillset(&new); - pthread_sigmask(SIG_BLOCK, &new, &previous); - code = pthread_create(&process->process.thread, &pthreadattr, - thread_entry_point, process); - pthread_sigmask(SIG_SETMASK, &previous, NULL); - } -#else - code = pthread_create(&process->process.thread, &pthreadattr, - thread_entry_point, process); -#endif - ok = (code == 0); - } -#endif - if (!ok) { - ecl_unlist_process(process); - /* Disable the barrier and alert possible waiting processes. */ - mp_barrier_unblock(3, process->process.exit_barrier, - @':disable', ECL_T); - process->process.phase = ECL_PROCESS_INACTIVE; - process->process.env = NULL; - _ecl_dealloc_env(process_env); - } - /* Unleash the thread */ - process->process.start_spinlock = ECL_NIL; + { + sigset_t new, previous; + sigfillset(&new); + pthread_sigmask(SIG_BLOCK, &new, &previous); + code = pthread_create(&process->process.thread, &pthreadattr, + thread_entry_point, process); + pthread_sigmask(SIG_SETMASK, &previous, NULL); + } +#else + code = pthread_create(&process->process.thread, &pthreadattr, + thread_entry_point, process); +#endif + ok = (code == 0); + } +#endif + if (!ok) { + ecl_unlist_process(process); + /* Disable the barrier and alert possible waiting processes. */ + mp_barrier_unblock(3, process->process.exit_barrier, + @':disable', ECL_T); + process->process.phase = ECL_PROCESS_INACTIVE; + process->process.env = NULL; + _ecl_dealloc_env(process_env); + } + /* Unleash the thread */ + process->process.start_spinlock = ECL_NIL; - @(return (ok? process : ECL_NIL)) + @(return (ok? process : ECL_NIL)); } cl_object mp_exit_process(void) { - /* We simply undo the whole of the frame stack. This brings up - back to the thread entry point, going through all possible - UNWIND-PROTECT. - */ - const cl_env_ptr the_env = ecl_process_env(); - ecl_unwind(the_env, the_env->frs_org); - /* Never reached */ + /* We simply undo the whole of the frame stack. This brings up + back to the thread entry point, going through all possible + UNWIND-PROTECT. + */ + const cl_env_ptr the_env = ecl_process_env(); + ecl_unwind(the_env, the_env->frs_org); + /* Never reached */ } cl_object mp_all_processes(void) { - /* No race condition here because this list is never destructively - * modified. When we add or remove processes, we create new lists. */ - @(return ecl_process_list()) + /* No race condition here because this list is never destructively + * modified. When we add or remove processes, we create new lists. */ + @(return ecl_process_list()); } cl_object mp_process_name(cl_object process) { - assert_type_process(process); - @(return process->process.name) + assert_type_process(process); + @(return process->process.name); } cl_object mp_process_active_p(cl_object process) { - assert_type_process(process); - @(return (process->process.phase? ECL_T : ECL_NIL)) + assert_type_process(process); + @(return (process->process.phase? ECL_T : ECL_NIL)); } cl_object mp_process_whostate(cl_object process) { - assert_type_process(process); - @(return (cl_core.null_string)) + assert_type_process(process); + @(return (cl_core.null_string)); } cl_object mp_process_join(cl_object process) { - assert_type_process(process); - if (process->process.phase) { - /* We try to acquire a lock that is only owned by the process - * while it is active. */ - mp_barrier_wait(1, process->process.exit_barrier); - } - return cl_values_list(process->process.exit_values); + assert_type_process(process); + if (process->process.phase) { + /* We try to acquire a lock that is only owned by the process + * while it is active. */ + mp_barrier_wait(process->process.exit_barrier); + } + return cl_values_list(process->process.exit_values); } cl_object mp_process_run_function(cl_narg narg, cl_object name, cl_object function, ...) { - cl_object process; - ecl_va_list args; - ecl_va_start(args, function, narg, 2); - if (narg < 2) - FEwrong_num_arguments(@[mp::process-run-function]); - if (CONSP(name)) { - process = cl_apply(2, @'mp::make-process', name); - } else { - process = mp_make_process(2, @':name', name); - } - cl_apply(4, @'mp::process-preset', process, function, - cl_grab_rest_args(args)); - return mp_process_enable(process); + cl_object process; + ecl_va_list args; + ecl_va_start(args, function, narg, 2); + if (narg < 2) + FEwrong_num_arguments(@[mp::process-run-function]); + if (CONSP(name)) { + process = cl_apply(2, @'mp::make-process', name); + } else { + process = mp_make_process(2, @':name', name); + } + cl_apply(4, @'mp::process-preset', process, function, + cl_grab_rest_args(args)); + return mp_process_enable(process); } cl_object mp_process_run_function_wait(cl_narg narg, ...) { - cl_object process; - ecl_va_list args; - ecl_va_start(args, narg, narg, 0); - process = cl_apply(2, @'mp::process-run-function', - cl_grab_rest_args(args)); - if (!Null(process)) { - ecl_def_ct_single_float(wait, 0.001, static, const); - while (process->process.phase < ECL_PROCESS_ACTIVE) { - cl_sleep(wait); - } - } - @(return process) + cl_object process; + ecl_va_list args; + ecl_va_start(args, narg, narg, 0); + process = cl_apply(2, @'mp::process-run-function', + cl_grab_rest_args(args)); + if (!Null(process)) { + ecl_def_ct_single_float(wait, 0.001, static, const); + while (process->process.phase < ECL_PROCESS_ACTIVE) { + cl_sleep(wait); + } + } + @(return process); } /*---------------------------------------------------------------------- @@ -682,22 +676,22 @@ static cl_object mp_get_sigmask(void) { - cl_object data = ecl_alloc_simple_vector(sizeof(sigset_t), ecl_aet_b8); - sigset_t *mask_ptr = (sigset_t*)data->vector.self.b8; - sigset_t no_signals; - sigemptyset(&no_signals); - if (pthread_sigmask(SIG_BLOCK, &no_signals, mask_ptr)) - FElibc_error("MP:GET-SIGMASK failed in a call to pthread_sigmask", 0); - @(return data) + cl_object data = ecl_alloc_simple_vector(sizeof(sigset_t), ecl_aet_b8); + sigset_t *mask_ptr = (sigset_t*)data->vector.self.b8; + sigset_t no_signals; + sigemptyset(&no_signals); + if (pthread_sigmask(SIG_BLOCK, &no_signals, mask_ptr)) + FElibc_error("MP:GET-SIGMASK failed in a call to pthread_sigmask", 0); + @(return data); } static cl_object mp_set_sigmask(cl_object data) { - sigset_t *mask_ptr = (sigset_t*)data->vector.self.b8; - if (pthread_sigmask(SIG_SETMASK, mask_ptr, NULL)) - FElibc_error("MP:SET-SIGMASK failed in a call to pthread_sigmask", 0); - @(return data) + sigset_t *mask_ptr = (sigset_t*)data->vector.self.b8; + if (pthread_sigmask(SIG_SETMASK, mask_ptr, NULL)) + FElibc_error("MP:SET-SIGMASK failed in a call to pthread_sigmask", 0); + @(return data); } #endif @@ -705,17 +699,17 @@ mp_block_signals(void) { #ifdef ECL_WINDOWS_THREADS - cl_env_ptr the_env = ecl_process_env(); - cl_object previous = ecl_symbol_value(@'ext::*interrupts-enabled*'); - ECL_SETQ(the_env, @'ext::*interrupts-enabled*', ECL_NIL); - @(return previous) -#else - cl_object previous = mp_get_sigmask(); - sigset_t all_signals; - sigfillset(&all_signals); - if (pthread_sigmask(SIG_SETMASK, &all_signals, NULL)) - FElibc_error("MP:BLOCK-SIGNALS failed in a call to pthread_sigmask",0); - @(return previous) + cl_env_ptr the_env = ecl_process_env(); + cl_object previous = ecl_symbol_value(@'ext::*interrupts-enabled*'); + ECL_SETQ(the_env, @'ext::*interrupts-enabled*', ECL_NIL); + @(return previous); +#else + cl_object previous = mp_get_sigmask(); + sigset_t all_signals; + sigfillset(&all_signals); + if (pthread_sigmask(SIG_SETMASK, &all_signals, NULL)) + FElibc_error("MP:BLOCK-SIGNALS failed in a call to pthread_sigmask",0); + @(return previous); #endif } @@ -723,12 +717,12 @@ mp_restore_signals(cl_object sigmask) { #ifdef ECL_WINDOWS_THREADS - cl_env_ptr the_env = ecl_process_env(); - ECL_SETQ(the_env, @'ext::*interrupts-enabled*', sigmask); - ecl_check_pending_interrupts(the_env); - @(return sigmask) + cl_env_ptr the_env = ecl_process_env(); + ECL_SETQ(the_env, @'ext::*interrupts-enabled*', sigmask); + ecl_check_pending_interrupts(the_env); + @(return sigmask); #else - return mp_set_sigmask(sigmask); + return mp_set_sigmask(sigmask); #endif } @@ -739,60 +733,60 @@ void init_threads(cl_env_ptr env) { - cl_object process; - pthread_t main_thread; + cl_object process; + pthread_t main_thread; - cl_core.processes = OBJNULL; + cl_core.processes = OBJNULL; - /* We have to set the environment before any allocation takes place, - * so that the interrupt handling code works. */ + /* We have to set the environment before any allocation takes place, + * so that the interrupt handling code works. */ #if !defined(WITH___THREAD) # if defined(ECL_WINDOWS_THREADS) - cl_env_key = TlsAlloc(); + cl_env_key = TlsAlloc(); # else - pthread_key_create(&cl_env_key, NULL); + pthread_key_create(&cl_env_key, NULL); # endif #endif - ecl_set_process_env(env); + ecl_set_process_env(env); #ifdef ECL_WINDOWS_THREADS - { - HANDLE aux = GetCurrentThread(); - DuplicateHandle(GetCurrentProcess(), - aux, - GetCurrentProcess(), - &main_thread, - 0, - FALSE, - DUPLICATE_SAME_ACCESS); - } -#else - main_thread = pthread_self(); -#endif - process = ecl_alloc_object(t_process); - process->process.phase = ECL_PROCESS_ACTIVE; - process->process.name = @'si::top-level'; - process->process.function = ECL_NIL; - process->process.args = ECL_NIL; - process->process.thread = main_thread; - process->process.env = env; - process->process.woken_up = ECL_NIL; - process->process.queue_record = ecl_list1(process); - process->process.start_spinlock = ECL_NIL; - process->process.exit_barrier = ecl_make_barrier(process->process.name, MOST_POSITIVE_FIXNUM); - - env->own_process = process; - - { - cl_object v = si_make_vector(ECL_T, /* Element type */ - ecl_make_fixnum(256), /* Size */ - ecl_make_fixnum(0), /* fill pointer */ - ECL_NIL, ECL_NIL, ECL_NIL); - v->vector.self.t[0] = process; - v->vector.fillp = 1; - cl_core.processes = v; - cl_core.global_lock = ecl_make_lock(@'mp::global-lock', 1); - cl_core.error_lock = ecl_make_lock(@'mp::error-lock', 1); - cl_core.global_env_lock = ecl_make_rwlock(@'ext::package-lock'); - } + { + HANDLE aux = GetCurrentThread(); + DuplicateHandle(GetCurrentProcess(), + aux, + GetCurrentProcess(), + &main_thread, + 0, + FALSE, + DUPLICATE_SAME_ACCESS); + } +#else + main_thread = pthread_self(); +#endif + process = ecl_alloc_object(t_process); + process->process.phase = ECL_PROCESS_ACTIVE; + process->process.name = @'si::top-level'; + process->process.function = ECL_NIL; + process->process.args = ECL_NIL; + process->process.thread = main_thread; + process->process.env = env; + process->process.woken_up = ECL_NIL; + process->process.queue_record = ecl_list1(process); + process->process.start_spinlock = ECL_NIL; + process->process.exit_barrier = ecl_make_barrier(process->process.name, MOST_POSITIVE_FIXNUM); + + env->own_process = process; + + { + cl_object v = si_make_vector(ECL_T, /* Element type */ + ecl_make_fixnum(256), /* Size */ + ecl_make_fixnum(0), /* fill pointer */ + ECL_NIL, ECL_NIL, ECL_NIL); + v->vector.self.t[0] = process; + v->vector.fillp = 1; + cl_core.processes = v; + cl_core.global_lock = ecl_make_lock(@'mp::global-lock', 1); + cl_core.error_lock = ecl_make_lock(@'mp::error-lock', 1); + cl_core.global_env_lock = ecl_make_rwlock(@'ext::package-lock'); + } } diff -Nru ecl-16.1.2/src/c/threads/queue.d ecl-16.1.3+ds/src/c/threads/queue.d --- ecl-16.1.2/src/c/threads/queue.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/threads/queue.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - queue.d -- waiting queue for threads. -*/ -/* - Copyright (c) 2011, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * queue.d - waiting queue for threads + * + * Copyright (c) 2011 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #ifdef HAVE_SCHED_H #include @@ -27,59 +22,59 @@ ecl_process_yield() { #if defined(ECL_WINDOWS_THREADS) - Sleep(0); + Sleep(0); #elif defined(HAVE_SCHED_H) - sched_yield(); + sched_yield(); #else - ecl_musleep(0.0, 1);*/ + ecl_musleep(0.0, 1);*/ #endif -} + } void ECL_INLINE ecl_get_spinlock(cl_env_ptr the_env, cl_object *lock) { - cl_object own_process = the_env->own_process; - while (!AO_compare_and_swap_full((AO_t*)lock, (AO_t)ECL_NIL, - (AO_t)own_process)) { - ecl_process_yield(); - } + cl_object own_process = the_env->own_process; + while (!AO_compare_and_swap_full((AO_t*)lock, (AO_t)ECL_NIL, + (AO_t)own_process)) { + ecl_process_yield(); + } } void ECL_INLINE ecl_giveup_spinlock(cl_object *lock) { - AO_store((AO_t*)lock, (AO_t)ECL_NIL); + AO_store((AO_t*)lock, (AO_t)ECL_NIL); } static ECL_INLINE void wait_queue_nconc(cl_env_ptr the_env, cl_object q, cl_object new_tail) { - ecl_get_spinlock(the_env, &q->queue.spinlock); - q->queue.list = ecl_nconc(q->queue.list, new_tail); - ecl_giveup_spinlock(&q->queue.spinlock); + ecl_get_spinlock(the_env, &q->queue.spinlock); + q->queue.list = ecl_nconc(q->queue.list, new_tail); + ecl_giveup_spinlock(&q->queue.spinlock); } static ECL_INLINE cl_object wait_queue_pop_all(cl_env_ptr the_env, cl_object q) { - cl_object output; - ecl_disable_interrupts_env(the_env); - { - ecl_get_spinlock(the_env, &q->queue.spinlock); - output = q->queue.list; - q->queue.list = ECL_NIL; - ecl_giveup_spinlock(&q->queue.spinlock); - } - ecl_enable_interrupts_env(the_env); - return output; + cl_object output; + ecl_disable_interrupts_env(the_env); + { + ecl_get_spinlock(the_env, &q->queue.spinlock); + output = q->queue.list; + q->queue.list = ECL_NIL; + ecl_giveup_spinlock(&q->queue.spinlock); + } + ecl_enable_interrupts_env(the_env); + return output; } static ECL_INLINE void wait_queue_delete(cl_env_ptr the_env, cl_object q, cl_object item) { - ecl_get_spinlock(the_env, &q->queue.spinlock); - q->queue.list = ecl_delete_eq(item, q->queue.list); - ecl_giveup_spinlock(&q->queue.spinlock); + ecl_get_spinlock(the_env, &q->queue.spinlock); + q->queue.list = ecl_delete_eq(item, q->queue.list); + ecl_giveup_spinlock(&q->queue.spinlock); } /*---------------------------------------------------------------------- @@ -89,112 +84,112 @@ static cl_object bignum_set_time(cl_object bignum, struct ecl_timeval *time) { - _ecl_big_set_index(bignum, time->tv_sec); - _ecl_big_mul_ui(bignum, bignum, 1000); - _ecl_big_add_ui(bignum, bignum, (time->tv_usec + 999) / 1000); - return bignum; + _ecl_big_set_index(bignum, time->tv_sec); + _ecl_big_mul_ui(bignum, bignum, 1000); + _ecl_big_add_ui(bignum, bignum, (time->tv_usec + 999) / 1000); + return bignum; } static cl_object elapsed_time(struct ecl_timeval *start) { - cl_object delta_big = _ecl_big_register0(); - cl_object aux_big = _ecl_big_register1(); - struct ecl_timeval now; - ecl_get_internal_real_time(&now); - bignum_set_time(aux_big, start); - bignum_set_time(delta_big, &now); - _ecl_big_sub(delta_big, delta_big, aux_big); - _ecl_big_register_free(aux_big); - return delta_big; + cl_object delta_big = _ecl_big_register0(); + cl_object aux_big = _ecl_big_register1(); + struct ecl_timeval now; + ecl_get_internal_real_time(&now); + bignum_set_time(aux_big, start); + bignum_set_time(delta_big, &now); + _ecl_big_sub(delta_big, delta_big, aux_big); + _ecl_big_register_free(aux_big); + return delta_big; } static double waiting_time(cl_index iteration, struct ecl_timeval *start) { - /* Waiting time is smaller than 0.10 s */ - double time; - cl_object top = ecl_make_fixnum(10 * 1000); - cl_object delta_big = elapsed_time(start); - _ecl_big_div_ui(delta_big, delta_big, iteration); - if (ecl_number_compare(delta_big, top) < 0) { - time = ecl_to_double(delta_big) * 1.5; - } else { - time = 0.10; - } - _ecl_big_register_free(delta_big); - return time; + /* Waiting time is smaller than 0.10 s */ + double time; + cl_object top = ecl_make_fixnum(10 * 1000); + cl_object delta_big = elapsed_time(start); + _ecl_big_div_ui(delta_big, delta_big, iteration); + if (ecl_number_compare(delta_big, top) < 0) { + time = ecl_to_double(delta_big) * 1.5; + } else { + time = 0.10; + } + _ecl_big_register_free(delta_big); + return time; } static cl_object ecl_wait_on_timed(cl_env_ptr env, cl_object (*condition)(cl_env_ptr, cl_object), cl_object o) { - volatile const cl_env_ptr the_env = env; - volatile cl_object own_process = the_env->own_process; - volatile cl_object record; - volatile cl_object output; - cl_fixnum iteration = 0; - struct ecl_timeval start; - ecl_get_internal_real_time(&start); - - /* This spinlock is here because the default path (fair) is - * too slow */ - for (iteration = 0; iteration < 10; iteration++) { - cl_object output = condition(the_env,o); - if (output != ECL_NIL) - return output; - } - - /* 0) We reserve a record for the queue. In order to avoid - * using the garbage collector, we reuse records */ - record = own_process->process.queue_record; - unlikely_if (record == ECL_NIL) { - record = ecl_list1(own_process); - } else { - own_process->process.queue_record = ECL_NIL; - } - - ecl_bds_bind(the_env, @'ext::*interrupts-enabled*', ECL_NIL); - ECL_UNWIND_PROTECT_BEGIN(the_env) { - /* 2) Now we add ourselves to the queue. In order to - * avoid a call to the GC, we try to reuse records. */ - print_lock("adding to queue", o); - own_process->process.woken_up = ECL_NIL; - wait_queue_nconc(the_env, o, record); - ecl_bds_bind(the_env, @'ext::*interrupts-enabled*', ECL_T); - ecl_check_pending_interrupts(the_env); - - /* 3) Unlike the sigsuspend() implementation, this - * implementation does not block signals and the - * wakeup event might be lost before the sleep - * function is invoked. We must thus spin over short - * intervals of time to ensure that we check the - * condition periodically. */ - while (Null(output = condition(the_env, o))) { - ecl_musleep(waiting_time(iteration++, &start), 1); - } - ecl_bds_unwind1(the_env); - } ECL_UNWIND_PROTECT_EXIT { - /* 4) At this point we wrap up. We remove ourselves - * from the queue and unblock the lisp interrupt - * signal. Note that we recover the cons for later use.*/ - wait_queue_delete(the_env, o, own_process); - own_process->process.queue_record = record; - ECL_RPLACD(record, ECL_NIL); - - /* 5) When this process exits, it may be because it - * aborts (which we know because output == ECL_NIL), or - * because the condition is satisfied. In both cases - * we allow the first in the queue to test again its - * condition. This is needed for objects, such as - * semaphores, where the condition may be satisfied - * more than once. */ - if (Null(output)) { - ecl_wakeup_waiters(the_env, o, ECL_WAKEUP_ONE); - } - } ECL_UNWIND_PROTECT_END; - ecl_bds_unwind1(the_env); - return output; + volatile const cl_env_ptr the_env = env; + volatile cl_object own_process = the_env->own_process; + volatile cl_object record; + volatile cl_object output; + cl_fixnum iteration = 0; + struct ecl_timeval start; + ecl_get_internal_real_time(&start); + + /* This spinlock is here because the default path (fair) is + * too slow */ + for (iteration = 0; iteration < 10; iteration++) { + cl_object output = condition(the_env,o); + if (output != ECL_NIL) + return output; + } + + /* 0) We reserve a record for the queue. In order to avoid + * using the garbage collector, we reuse records */ + record = own_process->process.queue_record; + unlikely_if (record == ECL_NIL) { + record = ecl_list1(own_process); + } else { + own_process->process.queue_record = ECL_NIL; + } + + ecl_bds_bind(the_env, @'ext::*interrupts-enabled*', ECL_NIL); + ECL_UNWIND_PROTECT_BEGIN(the_env) { + /* 2) Now we add ourselves to the queue. In order to + * avoid a call to the GC, we try to reuse records. */ + print_lock("adding to queue", o); + own_process->process.woken_up = ECL_NIL; + wait_queue_nconc(the_env, o, record); + ecl_bds_bind(the_env, @'ext::*interrupts-enabled*', ECL_T); + ecl_check_pending_interrupts(the_env); + + /* 3) Unlike the sigsuspend() implementation, this + * implementation does not block signals and the + * wakeup event might be lost before the sleep + * function is invoked. We must thus spin over short + * intervals of time to ensure that we check the + * condition periodically. */ + while (Null(output = condition(the_env, o))) { + ecl_musleep(waiting_time(iteration++, &start), 1); + } + ecl_bds_unwind1(the_env); + } ECL_UNWIND_PROTECT_EXIT { + /* 4) At this point we wrap up. We remove ourselves + * from the queue and unblock the lisp interrupt + * signal. Note that we recover the cons for later use.*/ + wait_queue_delete(the_env, o, own_process); + own_process->process.queue_record = record; + ECL_RPLACD(record, ECL_NIL); + + /* 5) When this process exits, it may be because it + * aborts (which we know because output == ECL_NIL), or + * because the condition is satisfied. In both cases + * we allow the first in the queue to test again its + * condition. This is needed for objects, such as + * semaphores, where the condition may be satisfied + * more than once. */ + if (Null(output)) { + ecl_wakeup_waiters(the_env, o, ECL_WAKEUP_ONE); + } + } ECL_UNWIND_PROTECT_END; + ecl_bds_unwind1(the_env); + return output; } /********************************************************************** @@ -230,140 +225,140 @@ ecl_wait_on(cl_env_ptr env, cl_object (*condition)(cl_env_ptr, cl_object), cl_object o) { #if defined(HAVE_SIGPROCMASK) - volatile const cl_env_ptr the_env = env; - volatile cl_object own_process = the_env->own_process; - volatile cl_object record; - volatile sigset_t original; - volatile cl_object output; - - /* 0) We reserve a record for the queue. In order to avoid - * using the garbage collector, we reuse records */ - record = own_process->process.queue_record; - unlikely_if (record == ECL_NIL) { - record = ecl_list1(own_process); - } else { - own_process->process.queue_record = ECL_NIL; - } - - /* 1) First we block lisp interrupt signals. This ensures that - * any awake signal that is issued from here is not lost. */ - { - int code = ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]; - sigset_t empty; - sigemptyset(&empty); - sigaddset(&empty, code); - pthread_sigmask(SIG_BLOCK, &empty, &original); - } - - /* 2) Now we add ourselves to the queue. */ - own_process->process.woken_up = ECL_NIL; - wait_queue_nconc(the_env, o, record); - - ECL_UNWIND_PROTECT_BEGIN(the_env) { - /* 3) At this point we may receive signals, but we - * might have missed a wakeup event if that happened - * between 0) and 2), which is why we start with the - * check*/ - while (Null(output = condition(the_env, o))) - { - /* This will wait until we get a signal that - * demands some code being executed. Note that - * this includes our communication signals and - * the signals used by the GC. Note also that - * as a consequence we might throw / return - * which is why need to protect it all with - * UNWIND-PROTECT. */ - sigsuspend(&original); - } - } ECL_UNWIND_PROTECT_EXIT { - /* 4) At this point we wrap up. We remove ourselves - * from the queue and unblock the lisp interrupt - * signal. Note that we recover the cons for later use.*/ - wait_queue_delete(the_env, o, own_process); - own_process->process.queue_record = record; - ECL_RPLACD(record, ECL_NIL); - - /* 5) When this process exits, it may be because it - * aborts (which we know because output == ECL_NIL), or - * because the condition is satisfied. In both cases - * we allow the first in the queue to test again its - * condition. This is needed for objects, such as - * semaphores, where the condition may be satisfied - * more than once. */ - if (Null(output)) { - ecl_wakeup_waiters(the_env, o, ECL_WAKEUP_ONE); - } - - /* 6) Restoring signals is done last, to ensure that - * all cleanup steps are performed. */ - pthread_sigmask(SIG_SETMASK, &original, NULL); - } ECL_UNWIND_PROTECT_END; - return output; + volatile const cl_env_ptr the_env = env; + volatile cl_object own_process = the_env->own_process; + volatile cl_object record; + volatile sigset_t original; + volatile cl_object output; + + /* 0) We reserve a record for the queue. In order to avoid + * using the garbage collector, we reuse records */ + record = own_process->process.queue_record; + unlikely_if (record == ECL_NIL) { + record = ecl_list1(own_process); + } else { + own_process->process.queue_record = ECL_NIL; + } + + /* 1) First we block lisp interrupt signals. This ensures that + * any awake signal that is issued from here is not lost. */ + { + int code = ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]; + sigset_t empty; + sigemptyset(&empty); + sigaddset(&empty, code); + pthread_sigmask(SIG_BLOCK, &empty, (sigset_t *)&original); + } + + /* 2) Now we add ourselves to the queue. */ + own_process->process.woken_up = ECL_NIL; + wait_queue_nconc(the_env, o, record); + + ECL_UNWIND_PROTECT_BEGIN(the_env) { + /* 3) At this point we may receive signals, but we + * might have missed a wakeup event if that happened + * between 0) and 2), which is why we start with the + * check*/ + while (Null(output = condition(the_env, o))) + { + /* This will wait until we get a signal that + * demands some code being executed. Note that + * this includes our communication signals and + * the signals used by the GC. Note also that + * as a consequence we might throw / return + * which is why need to protect it all with + * UNWIND-PROTECT. */ + sigsuspend((sigset_t *)&original); + } + } ECL_UNWIND_PROTECT_EXIT { + /* 4) At this point we wrap up. We remove ourselves + * from the queue and unblock the lisp interrupt + * signal. Note that we recover the cons for later use.*/ + wait_queue_delete(the_env, o, own_process); + own_process->process.queue_record = record; + ECL_RPLACD(record, ECL_NIL); + + /* 5) When this process exits, it may be because it + * aborts (which we know because output == ECL_NIL), or + * because the condition is satisfied. In both cases + * we allow the first in the queue to test again its + * condition. This is needed for objects, such as + * semaphores, where the condition may be satisfied + * more than once. */ + if (Null(output)) { + ecl_wakeup_waiters(the_env, o, ECL_WAKEUP_ONE); + } + + /* 6) Restoring signals is done last, to ensure that + * all cleanup steps are performed. */ + pthread_sigmask(SIG_SETMASK, (sigset_t *)&original, NULL); + } ECL_UNWIND_PROTECT_END; + return output; #else - return ecl_wait_on_timed(env, condition, o); + return ecl_wait_on_timed(env, condition, o); #endif } cl_object ecl_waiter_pop(cl_env_ptr the_env, cl_object q) { - cl_object output; - ecl_disable_interrupts_env(the_env); - ecl_get_spinlock(the_env, &q->queue.spinlock); - { - cl_object l; - output = ECL_NIL; - for (l = q->queue.list; l != ECL_NIL; l = ECL_CONS_CDR(l)) { - cl_object p = ECL_CONS_CAR(l); - if (p->process.phase != ECL_PROCESS_INACTIVE && - p->process.phase != ECL_PROCESS_EXITING) { - output = p; - break; - } - } - } - ecl_giveup_spinlock(&q->queue.spinlock); - ecl_enable_interrupts_env(the_env); - return output; + cl_object output; + ecl_disable_interrupts_env(the_env); + ecl_get_spinlock(the_env, &q->queue.spinlock); + { + cl_object l; + output = ECL_NIL; + for (l = q->queue.list; l != ECL_NIL; l = ECL_CONS_CDR(l)) { + cl_object p = ECL_CONS_CAR(l); + if (p->process.phase != ECL_PROCESS_INACTIVE && + p->process.phase != ECL_PROCESS_EXITING) { + output = p; + break; + } + } + } + ecl_giveup_spinlock(&q->queue.spinlock); + ecl_enable_interrupts_env(the_env); + return output; } void ecl_wakeup_waiters(cl_env_ptr the_env, cl_object q, int flags) { - ecl_disable_interrupts_env(the_env); - ecl_get_spinlock(the_env, &q->queue.spinlock); - if (q->queue.list != ECL_NIL) { - /* We scan the list of waiting processes, awaking one - * or more, depending on flags. In running through the list - * we eliminate zombie processes --- they should not be here - * because of the UNWIND-PROTECT in ecl_wait_on(), but - * sometimes shit happens */ - cl_object *tail, l; - for (tail = &q->queue.list; (l = *tail) != ECL_NIL; ) { - cl_object p = ECL_CONS_CAR(l); - if (p->process.phase == ECL_PROCESS_INACTIVE || - p->process.phase == ECL_PROCESS_EXITING) { - print_lock("removing %p", q, p); - *tail = ECL_CONS_CDR(l); - } else { - print_lock("awaking %p", q, p); - /* If the process is active, we then - * simply awake it with a signal.*/ - p->process.woken_up = ECL_T; - if (flags & ECL_WAKEUP_DELETE) - *tail = ECL_CONS_CDR(l); - tail = &ECL_CONS_CDR(l); - if (flags & ECL_WAKEUP_KILL) - mp_process_kill(p); - else - ecl_wakeup_process(p); - if (!(flags & ECL_WAKEUP_ALL)) - break; - } - } - } - ecl_giveup_spinlock(&q->queue.spinlock); - ecl_process_yield(); + ecl_disable_interrupts_env(the_env); + ecl_get_spinlock(the_env, &q->queue.spinlock); + if (q->queue.list != ECL_NIL) { + /* We scan the list of waiting processes, awaking one + * or more, depending on flags. In running through the list + * we eliminate zombie processes --- they should not be here + * because of the UNWIND-PROTECT in ecl_wait_on(), but + * sometimes shit happens */ + cl_object *tail, l; + for (tail = &q->queue.list; (l = *tail) != ECL_NIL; ) { + cl_object p = ECL_CONS_CAR(l); + if (p->process.phase == ECL_PROCESS_INACTIVE || + p->process.phase == ECL_PROCESS_EXITING) { + print_lock("removing %p", q, p); + *tail = ECL_CONS_CDR(l); + } else { + print_lock("awaking %p", q, p); + /* If the process is active, we then + * simply awake it with a signal.*/ + p->process.woken_up = ECL_T; + if (flags & ECL_WAKEUP_DELETE) + *tail = ECL_CONS_CDR(l); + tail = &ECL_CONS_CDR(l); + if (flags & ECL_WAKEUP_KILL) + mp_process_kill(p); + else + ecl_wakeup_process(p); + if (!(flags & ECL_WAKEUP_ALL)) + break; + } + } + } + ecl_giveup_spinlock(&q->queue.spinlock); + ecl_process_yield(); } #undef print_lock @@ -371,25 +366,25 @@ void print_lock(char *prefix, cl_object l, ...) { - static cl_object lock = ECL_NIL; - va_list args; - va_start(args, l); - if (l == ECL_NIL - || type_of(l) == t_condition_variable - || ECL_FIXNUMP(l->lock.name)) { - cl_env_ptr env = ecl_process_env(); - ecl_get_spinlock(env, &lock); - printf("\n%ld\t", ecl_fixnum(env->own_process->process.name)); - vprintf(prefix, args); - if (l != ECL_NIL) { - cl_object p = l->lock.queue_list; - while (p != ECL_NIL) { - printf(" %lx", ecl_fixnum(ECL_CONS_CAR(p)->process.name)); - p = ECL_CONS_CDR(p); - } - } - fflush(stdout); - ecl_giveup_spinlock(&lock); - } + static cl_object lock = ECL_NIL; + va_list args; + va_start(args, l); + if (l == ECL_NIL + || type_of(l) == t_condition_variable + || ECL_FIXNUMP(l->lock.name)) { + cl_env_ptr env = ecl_process_env(); + ecl_get_spinlock(env, &lock); + printf("\n%ld\t", ecl_fixnum(env->own_process->process.name)); + vprintf(prefix, args); + if (l != ECL_NIL) { + cl_object p = l->lock.queue_list; + while (p != ECL_NIL) { + printf(" %lx", ecl_fixnum(ECL_CONS_CAR(p)->process.name)); + p = ECL_CONS_CDR(p); + } + } + fflush(stdout); + ecl_giveup_spinlock(&lock); + } } /*#define print_lock(a,b,c) (void)0*/ diff -Nru ecl-16.1.2/src/c/threads/rwlock.d ecl-16.1.3+ds/src/c/threads/rwlock.d --- ecl-16.1.2/src/c/threads/rwlock.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/threads/rwlock.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - rwlock.d -- POSIX read-write locks -*/ -/* - Copyright (c) 2003, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * rwlock.d - POSIX read-write locks + * + * Copyright (c) 2003 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #ifndef __sun__ /* See unixinit.d for this */ #define _XOPEN_SOURCE 600 /* For pthread mutex attributes */ @@ -34,195 +29,197 @@ static void FEerror_not_a_rwlock(cl_object lock) { - FEwrong_type_argument(@'mp::rwlock', lock); + FEwrong_type_argument(@'mp::rwlock', lock); } static void FEunknown_rwlock_error(cl_object lock, int rc) { #ifdef ECL_WINDOWS_THREADS - FEwin32_error("When acting on rwlock ~A, got an unexpected error.", 1, lock); + FEwin32_error("When acting on rwlock ~A, got an unexpected error.", 1, lock); #else - const char *msg = NULL; - switch (rc) { - case EINVAL: - msg = "The value specified by rwlock is invalid"; - break; - case EPERM: - msg = "Read/write lock not owned by us"; - break; - case EDEADLK: - msg = "Thread already owns this lock"; - break; - case ENOMEM: - msg = "Out of memory"; - break; - default: - FElibc_error("When acting on rwlock ~A, got an unexpected error.", - 1, lock); - } - FEerror("When acting on rwlock ~A, got the following C library error:~%" - "~A", 2, lock, make_constant_base_string(msg)); + const char *msg = NULL; + switch (rc) { + case EINVAL: + msg = "The value specified by rwlock is invalid"; + break; + case EPERM: + msg = "Read/write lock not owned by us"; + break; + case EDEADLK: + msg = "Thread already owns this lock"; + break; + case ENOMEM: + msg = "Out of memory"; + break; + default: + FElibc_error("When acting on rwlock ~A, got an unexpected error.", + 1, lock); + } + FEerror("When acting on rwlock ~A, got the following C library error:~%" + "~A", 2, lock, make_constant_base_string(msg)); #endif } cl_object ecl_make_rwlock(cl_object name) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object output = ecl_alloc_object(t_rwlock); + const cl_env_ptr the_env = ecl_process_env(); + cl_object output = ecl_alloc_object(t_rwlock); #ifdef ECL_RWLOCK - int rc; - ecl_disable_interrupts_env(the_env); - rc = pthread_rwlock_init(&output->rwlock.mutex, NULL); - ecl_enable_interrupts_env(the_env); - if (rc) { - FEerror("Unable to create read/write lock", 0); - } - ecl_set_finalizer_unprotected(output, ECL_T); + int rc; + ecl_disable_interrupts_env(the_env); + rc = pthread_rwlock_init(&output->rwlock.mutex, NULL); + ecl_enable_interrupts_env(the_env); + if (rc) { + FEerror("Unable to create read/write lock", 0); + } + ecl_set_finalizer_unprotected(output, ECL_T); #else - output->rwlock.mutex = ecl_make_lock(name, 0); + output->rwlock.mutex = ecl_make_lock(name, 0); #endif - output->rwlock.name = name; - return output; + output->rwlock.name = name; + return output; } @(defun mp::make-rwlock (&key name) -@ - @(return ecl_make_rwlock(name)) -@) + @ + @(return ecl_make_rwlock(name)); + @) cl_object mp_rwlock_name(cl_object lock) { - const cl_env_ptr env = ecl_process_env(); - if (ecl_t_of(lock) != t_rwlock) - FEerror_not_a_rwlock(lock); - ecl_return1(env, lock->rwlock.name); + const cl_env_ptr env = ecl_process_env(); + if (ecl_t_of(lock) != t_rwlock) + FEerror_not_a_rwlock(lock); + ecl_return1(env, lock->rwlock.name); } cl_object mp_giveup_rwlock_read(cl_object lock) { - /* Must be called with interrupts disabled. */ - if (ecl_t_of(lock) != t_rwlock) - FEerror_not_a_rwlock(lock); -#ifdef ECL_RWLOCK - { - int rc = pthread_rwlock_unlock(&lock->rwlock.mutex); - if (rc) - FEunknown_rwlock_error(lock, rc); - @(return ECL_T); - } + /* Must be called with interrupts disabled. */ + if (ecl_t_of(lock) != t_rwlock) + FEerror_not_a_rwlock(lock); +#ifdef ECL_RWLOCK + { + int rc = pthread_rwlock_unlock(&lock->rwlock.mutex); + if (rc) + FEunknown_rwlock_error(lock, rc); + @(return ECL_T); + } #else - return mp_giveup_lock(lock->rwlock.mutex); + return mp_giveup_lock(lock->rwlock.mutex); #endif } cl_object mp_giveup_rwlock_write(cl_object lock) { - return mp_giveup_rwlock_read(lock); + return mp_giveup_rwlock_read(lock); } cl_object mp_get_rwlock_read_nowait(cl_object lock) { - if (ecl_t_of(lock) != t_rwlock) - FEerror_not_a_rwlock(lock); + if (ecl_t_of(lock) != t_rwlock) + FEerror_not_a_rwlock(lock); #ifdef ECL_RWLOCK - { - const cl_env_ptr env = ecl_process_env(); - cl_object output = ECL_T; - int rc = pthread_rwlock_tryrdlock(&lock->rwlock.mutex); - if (rc == 0) { - output = ECL_T; - } else if (rc == EBUSY) { - output = ECL_NIL; - } else { - FEunknown_rwlock_error(lock, rc); - } - ecl_return1(env, output); - } + { + const cl_env_ptr env = ecl_process_env(); + cl_object output = ECL_T; + int rc = pthread_rwlock_tryrdlock(&lock->rwlock.mutex); + if (rc == 0) { + output = ECL_T; + } else if (rc == EBUSY) { + output = ECL_NIL; + } else { + FEunknown_rwlock_error(lock, rc); + } + ecl_return1(env, output); + } #else - return mp_get_lock_nowait(lock->rwlock.mutex); + return mp_get_lock_nowait(lock->rwlock.mutex); #endif } cl_object mp_get_rwlock_read_wait(cl_object lock) { - if (ecl_t_of(lock) != t_rwlock) - FEerror_not_a_rwlock(lock); + if (ecl_t_of(lock) != t_rwlock) + FEerror_not_a_rwlock(lock); #ifdef ECL_RWLOCK - { - const cl_env_ptr env = ecl_process_env(); - int rc = pthread_rwlock_rdlock(&lock->rwlock.mutex); - if (rc != 0) { - FEunknown_rwlock_error(lock, rc); - } - ecl_return1(env, ECL_T); - } + { + const cl_env_ptr env = ecl_process_env(); + int rc = pthread_rwlock_rdlock(&lock->rwlock.mutex); + if (rc != 0) { + FEunknown_rwlock_error(lock, rc); + } + ecl_return1(env, ECL_T); + } #else - return mp_get_lock_wait(lock->rwlock.mutex); + return mp_get_lock_wait(lock->rwlock.mutex); #endif } @(defun mp::get-rwlock-read (lock &optional (wait ECL_T)) -@ - if (Null(wait)) - return mp_get_rwlock_read_nowait(lock); - else - return mp_get_rwlock_read_wait(lock); -@) + @ + if (Null(wait)) + return mp_get_rwlock_read_nowait(lock); + else + return mp_get_rwlock_read_wait(lock); + @) cl_object mp_get_rwlock_write_nowait(cl_object lock) { - if (ecl_t_of(lock) != t_rwlock) - FEerror_not_a_rwlock(lock); + if (ecl_t_of(lock) != t_rwlock) + FEerror_not_a_rwlock(lock); #ifdef ECL_RWLOCK - { - const cl_env_ptr env = ecl_process_env(); - cl_object output = ECL_T; - int rc = pthread_rwlock_trywrlock(&lock->rwlock.mutex); - if (rc == 0) { - output = ECL_T; - } else if (rc == EBUSY) { - output = ECL_NIL; - } else { - FEunknown_rwlock_error(lock, rc); - } - ecl_return1(env, output); - } + { + const cl_env_ptr env = ecl_process_env(); + cl_object output = ECL_T; + int rc = pthread_rwlock_trywrlock(&lock->rwlock.mutex); + if (rc == 0) { + output = ECL_T; + } else if (rc == EBUSY) { + output = ECL_NIL; + } else { + FEunknown_rwlock_error(lock, rc); + } + ecl_return1(env, output); + } #else - return mp_get_lock_nowait(lock->rwlock.mutex); + return mp_get_lock_nowait(lock->rwlock.mutex); #endif } cl_object mp_get_rwlock_write_wait(cl_object lock) { - cl_env_ptr env = ecl_process_env(); - if (ecl_t_of(lock) != t_rwlock) - FEerror_not_a_rwlock(lock); -#ifdef ECL_RWLOCK - { - int rc = pthread_rwlock_wrlock(&lock->rwlock.mutex); - if (rc != 0) { - FEunknown_rwlock_error(lock, rc); - } - @(return ECL_T) - } + cl_env_ptr env = ecl_process_env(); + if (ecl_t_of(lock) != t_rwlock) + FEerror_not_a_rwlock(lock); +#ifdef ECL_RWLOCK + { + int rc = pthread_rwlock_wrlock(&lock->rwlock.mutex); + if (rc != 0) { + FEunknown_rwlock_error(lock, rc); + } + @(return ECL_T); + } #else - return mp_get_lock_wait(lock->rwlock.mutex); + return mp_get_lock_wait(lock->rwlock.mutex); #endif } @(defun mp::get-rwlock-write (lock &optional (wait ECL_T)) -@ - if (Null(wait)) - return mp_get_rwlock_write_nowait(lock); - else - return mp_get_rwlock_write_wait(lock); -@) + @ + if (Null(wait)) { + return mp_get_rwlock_write_nowait(lock); + } + else { + return mp_get_rwlock_write_wait(lock); + } + @) diff -Nru ecl-16.1.2/src/c/threads/semaphore.d ecl-16.1.3+ds/src/c/threads/semaphore.d --- ecl-16.1.2/src/c/threads/semaphore.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/threads/semaphore.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - semaphore.d -- POSIX-like semaphores -*/ -/* - Copyright (c) 2011, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * semaphore.d - POSIX-like semaphores + * + * Copyright (c) 2011 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #define AO_ASSUME_WINDOWS98 /* We need this for CAS */ #include @@ -26,118 +21,114 @@ static ECL_INLINE void FEerror_not_a_semaphore(cl_object semaphore) { - FEwrong_type_argument(@'mp::semaphore', semaphore); + FEwrong_type_argument(@'mp::semaphore', semaphore); } cl_object ecl_make_semaphore(cl_object name, cl_fixnum count) { - cl_object output = ecl_alloc_object(t_semaphore); - output->semaphore.name = name; - output->semaphore.counter = count; - output->semaphore.queue_list = ECL_NIL; - output->semaphore.queue_spinlock = ECL_NIL; - return output; + cl_object output = ecl_alloc_object(t_semaphore); + output->semaphore.name = name; + output->semaphore.counter = count; + output->semaphore.queue_list = ECL_NIL; + output->semaphore.queue_spinlock = ECL_NIL; + return output; } @(defun mp::make-semaphore (&key name (count ecl_make_fixnum(0))) -@ -{ - @(return ecl_make_semaphore(name, fixnnint(count))) -} -@) + @ { + @(return ecl_make_semaphore(name, fixnnint(count))); + } @) cl_object mp_semaphore_name(cl_object semaphore) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(semaphore) != t_semaphore) { - FEerror_not_a_semaphore(semaphore); - } - ecl_return1(env, semaphore->semaphore.name); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(semaphore) != t_semaphore) { + FEerror_not_a_semaphore(semaphore); + } + ecl_return1(env, semaphore->semaphore.name); } cl_object mp_semaphore_count(cl_object semaphore) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(semaphore) != t_semaphore) { - FEerror_not_a_semaphore(semaphore); - } - ecl_return1(env, ecl_make_fixnum(semaphore->semaphore.counter)); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(semaphore) != t_semaphore) { + FEerror_not_a_semaphore(semaphore); + } + ecl_return1(env, ecl_make_fixnum(semaphore->semaphore.counter)); } cl_object mp_semaphore_wait_count(cl_object semaphore) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(semaphore) != t_semaphore) { - FEerror_not_a_semaphore(semaphore); - } - ecl_return1(env, cl_length(semaphore->semaphore.queue_list)); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(semaphore) != t_semaphore) { + FEerror_not_a_semaphore(semaphore); + } + ecl_return1(env, cl_length(semaphore->semaphore.queue_list)); } @(defun mp::signal-semaphore (semaphore &optional (count ecl_make_fixnum(1))) -@ -{ - cl_fixnum n = fixnnint(count); - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(semaphore) != t_semaphore) { - FEerror_not_a_semaphore(semaphore); - } - AO_fetch_and_add((AO_t*)&semaphore->semaphore.counter, n); - if (semaphore->semaphore.queue_list != ECL_NIL) { - ecl_wakeup_waiters(env, semaphore, ECL_WAKEUP_ONE); - } - @(return) -} -@) + @ { + cl_fixnum n = fixnnint(count); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(semaphore) != t_semaphore) { + FEerror_not_a_semaphore(semaphore); + } + AO_fetch_and_add((AO_t*)&semaphore->semaphore.counter, n); + if (semaphore->semaphore.queue_list != ECL_NIL) { + ecl_wakeup_waiters(env, semaphore, ECL_WAKEUP_ONE); + } + @(return); + } @) static cl_object get_semaphore_inner(cl_env_ptr env, cl_object semaphore) { - cl_object output; - ecl_disable_interrupts_env(env); - do { - cl_fixnum counter = semaphore->semaphore.counter; - if (!counter) { - output = ECL_NIL; - break; - } - if (AO_compare_and_swap_full((AO_t*)&(semaphore->semaphore.counter), - (AO_t)counter, (AO_t)(counter-1))) { - output = ecl_make_fixnum(counter); - break; - } - ecl_process_yield(); - } while (1); - ecl_enable_interrupts_env(env); - return output; + cl_object output; + ecl_disable_interrupts_env(env); + do { + cl_fixnum counter = semaphore->semaphore.counter; + if (!counter) { + output = ECL_NIL; + break; + } + if (AO_compare_and_swap_full((AO_t*)&(semaphore->semaphore.counter), + (AO_t)counter, (AO_t)(counter-1))) { + output = ecl_make_fixnum(counter); + break; + } + ecl_process_yield(); + } while (1); + ecl_enable_interrupts_env(env); + return output; } cl_object mp_wait_on_semaphore(cl_object semaphore) { - cl_env_ptr env = ecl_process_env(); - cl_object output; - unlikely_if (ecl_t_of(semaphore) != t_semaphore) { - FEerror_not_a_semaphore(semaphore); - } - output = get_semaphore_inner(env, semaphore); - if (Null(output)) { - output = ecl_wait_on(env, get_semaphore_inner, semaphore); - } - ecl_return1(env, output); + cl_env_ptr env = ecl_process_env(); + cl_object output; + unlikely_if (ecl_t_of(semaphore) != t_semaphore) { + FEerror_not_a_semaphore(semaphore); + } + output = get_semaphore_inner(env, semaphore); + if (Null(output)) { + output = ecl_wait_on(env, get_semaphore_inner, semaphore); + } + ecl_return1(env, output); } cl_object mp_try_get_semaphore(cl_object semaphore) { - cl_env_ptr env = ecl_process_env(); - cl_object output; - unlikely_if (ecl_t_of(semaphore) != t_semaphore) { - FEerror_not_a_semaphore(semaphore); - } - ecl_return1(env, get_semaphore_inner(env, semaphore)); + cl_env_ptr env = ecl_process_env(); + cl_object output; + unlikely_if (ecl_t_of(semaphore) != t_semaphore) { + FEerror_not_a_semaphore(semaphore); + } + ecl_return1(env, get_semaphore_inner(env, semaphore)); } diff -Nru ecl-16.1.2/src/c/time.d ecl-16.1.3+ds/src/c/time.d --- ecl-16.1.2/src/c/time.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/time.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - time.c -- Time routines. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * time.d - time routines + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -50,25 +45,25 @@ ecl_get_internal_real_time(struct ecl_timeval *tv) { #if defined(HAVE_GETTIMEOFDAY) && !defined(ECL_MS_WINDOWS_HOST) - struct timezone tz; - struct timeval aux; - gettimeofday(&aux, &tz); - tv->tv_usec = aux.tv_usec; - tv->tv_sec = aux.tv_sec; + struct timezone tz; + struct timeval aux; + gettimeofday(&aux, &tz); + tv->tv_usec = aux.tv_usec; + tv->tv_sec = aux.tv_sec; #else # if defined(ECL_MS_WINDOWS_HOST) - union { - FILETIME filetime; - DWORDLONG hundred_ns; - } system_time; - GetSystemTimeAsFileTime(&system_time.filetime); - system_time.hundred_ns /= 10000; - tv->tv_sec = system_time.hundred_ns / 1000; - tv->tv_usec = (system_time.hundred_ns % 1000) * 1000; + union { + FILETIME filetime; + DWORDLONG hundred_ns; + } system_time; + GetSystemTimeAsFileTime(&system_time.filetime); + system_time.hundred_ns /= 10000; + tv->tv_sec = system_time.hundred_ns / 1000; + tv->tv_usec = (system_time.hundred_ns % 1000) * 1000; # else - time_t = time(0); - tv->tv_sec = time_t; - tv->tv_usec = 0; + time_t = time(0); + tv->tv_sec = time_t; + tv->tv_usec = 0; # endif #endif } @@ -77,34 +72,34 @@ ecl_get_internal_run_time(struct ecl_timeval *tv) { #ifdef HAVE_GETRUSAGE - struct rusage r; - getrusage(RUSAGE_SELF, &r); - tv->tv_usec = r.ru_utime.tv_usec; - tv->tv_sec = r.ru_utime.tv_sec; + struct rusage r; + getrusage(RUSAGE_SELF, &r); + tv->tv_usec = r.ru_utime.tv_usec; + tv->tv_sec = r.ru_utime.tv_sec; #else # ifdef HAVE_TIMES - struct tms buf; - times(&buf); - tv->tv_sec = buf.tms_utime / CLK_TCK; - tv->tv_usec = (buf.tms_utime % CLK_TCK) * 1000000; + struct tms buf; + times(&buf); + tv->tv_sec = buf.tms_utime / CLK_TCK; + tv->tv_usec = (buf.tms_utime % CLK_TCK) * 1000000; # else # if defined(ECL_MS_WINDOWS_HOST) - union { - FILETIME filetime; - DWORDLONG hundred_ns; - } kernel_time, user_time, creation_time, exit_time; - if (!GetProcessTimes(GetCurrentProcess(), - &creation_time.filetime, - &exit_time.filetime, - &kernel_time.filetime, - &user_time.filetime)) - FEwin32_error("GetProcessTimes() failed", 0); - kernel_time.hundred_ns += user_time.hundred_ns; - kernel_time.hundred_ns /= 10000; - tv->tv_sec = kernel_time.hundred_ns / 1000; - tv->tv_usec = (kernel_time.hundred_ns % 1000) * 1000; + union { + FILETIME filetime; + DWORDLONG hundred_ns; + } kernel_time, user_time, creation_time, exit_time; + if (!GetProcessTimes(GetCurrentProcess(), + &creation_time.filetime, + &exit_time.filetime, + &kernel_time.filetime, + &user_time.filetime)) + FEwin32_error("GetProcessTimes() failed", 0); + kernel_time.hundred_ns += user_time.hundred_ns; + kernel_time.hundred_ns /= 10000; + tv->tv_sec = kernel_time.hundred_ns / 1000; + tv->tv_usec = (kernel_time.hundred_ns % 1000) * 1000; # else - ecl_get_internal_real_time(tv); + ecl_get_internal_real_time(tv); # endif # endif #endif @@ -114,59 +109,59 @@ ecl_musleep(double time, bool alertable) { #ifdef HAVE_NANOSLEEP - struct timespec tm; - int code; - tm.tv_sec = (time_t)floor(time); - tm.tv_nsec = (long)((time - floor(time)) * 1e9); + struct timespec tm; + int code; + tm.tv_sec = (time_t)floor(time); + tm.tv_nsec = (long)((time - floor(time)) * 1e9); AGAIN: - code = nanosleep(&tm, &tm); - { - int old_errno = errno; - if (code < 0 && old_errno == EINTR && !alertable) { - goto AGAIN; - } - } + code = nanosleep(&tm, &tm); + { + int old_errno = errno; + if (code < 0 && old_errno == EINTR && !alertable) { + goto AGAIN; + } + } #else #if defined (ECL_MS_WINDOWS_HOST) - /* Maximum waiting time that fits in SleepEx. This is the - * largest integer that fits safely in DWORD in milliseconds - * and has to be converted to 100ns (1e-3 / 100e-9 = 1e4) */ - const DWORDLONG maxtime = (DWORDLONG)0xfffffff * (DWORDLONG)10000; - DWORDLONG wait = time * 1e7; - union { - FILETIME filetime; - DWORDLONG hundred_ns; - } end, now; - if (alertable) { - GetSystemTimeAsFileTime(&end.filetime); - end.hundred_ns += wait; - } - do { - DWORDLONG interval; - if (wait > maxtime) { - interval = maxtime; - wait -= maxtime; - } else { - interval = wait; - wait = 0; - } - if (SleepEx(interval/10000, alertable) != 0) { - if (alertable) { - break; - } else { - GetSystemTimeAsFileTime(&now.filetime); - if (now.hundred_ns >= end.hundred_ns) - break; - else - wait = end.hundred_ns - now.hundred_ns; - } - } - } while (wait); + /* Maximum waiting time that fits in SleepEx. This is the + * largest integer that fits safely in DWORD in milliseconds + * and has to be converted to 100ns (1e-3 / 100e-9 = 1e4) */ + const DWORDLONG maxtime = (DWORDLONG)0xfffffff * (DWORDLONG)10000; + DWORDLONG wait = time * 1e7; + union { + FILETIME filetime; + DWORDLONG hundred_ns; + } end, now; + if (alertable) { + GetSystemTimeAsFileTime(&end.filetime); + end.hundred_ns += wait; + } + do { + DWORDLONG interval; + if (wait > maxtime) { + interval = maxtime; + wait -= maxtime; + } else { + interval = wait; + wait = 0; + } + if (SleepEx(interval/10000, alertable) != 0) { + if (alertable) { + break; + } else { + GetSystemTimeAsFileTime(&now.filetime); + if (now.hundred_ns >= end.hundred_ns) + break; + else + wait = end.hundred_ns - now.hundred_ns; + } + } + } while (wait); #else - int t = (int)time; - for (t = (time + 0.5); t > 1000; t -= 1000) - sleep(1000); - sleep(t); + int t = (int)time; + for (t = (time + 0.5); t > 1000; t -= 1000) + sleep(1000); + sleep(t); #endif #endif } @@ -174,75 +169,75 @@ cl_fixnum ecl_runtime(void) { - struct ecl_timeval tv; - ecl_get_internal_run_time(&tv); - return tv.tv_sec * 1000 + tv.tv_usec / 1000; + struct ecl_timeval tv; + ecl_get_internal_run_time(&tv); + return tv.tv_sec * 1000 + tv.tv_usec / 1000; } cl_object cl_sleep(cl_object z) { - double time; - /* INV: ecl_minusp() makes sure `z' is real */ - if (ecl_minusp(z)) - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("Not a non-negative number ~S"), - @':format-arguments', cl_list(1, z), - @':expected-type', @'real', @':datum', z); - /* Compute time without overflows */ - ECL_WITHOUT_FPE_BEGIN { - time = ecl_to_double(z); - if (isnan(time) || !isfinite(time) || (time > INT_MAX)) { - time = INT_MAX; - } else if (time < 1e-9) { - time = 1e-9; - } - } ECL_WITHOUT_FPE_END; - ecl_musleep(time, 0); - @(return ECL_NIL) + double time; + /* INV: ecl_minusp() makes sure `z' is real */ + if (ecl_minusp(z)) + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("Not a non-negative number ~S"), + @':format-arguments', cl_list(1, z), + @':expected-type', @'real', @':datum', z); + /* Compute time without overflows */ + ECL_WITHOUT_FPE_BEGIN { + time = ecl_to_double(z); + if (isnan(time) || !isfinite(time) || (time > INT_MAX)) { + time = INT_MAX; + } else if (time < 1e-9) { + time = 1e-9; + } + } ECL_WITHOUT_FPE_END; + ecl_musleep(time, 0); + @(return ECL_NIL); } static cl_object timeval_to_time(long sec, long usec) { - cl_object milliseconds = ecl_plus(ecl_times(ecl_make_integer(sec), - ecl_make_fixnum(1000)), - ecl_make_integer(usec / 1000)); - @(return milliseconds); + cl_object milliseconds = ecl_plus(ecl_times(ecl_make_integer(sec), + ecl_make_fixnum(1000)), + ecl_make_integer(usec / 1000)); + @(return milliseconds); } cl_object cl_get_internal_run_time() { - struct ecl_timeval tv; - ecl_get_internal_run_time(&tv); - return timeval_to_time(tv.tv_sec, tv.tv_usec); + struct ecl_timeval tv; + ecl_get_internal_run_time(&tv); + return timeval_to_time(tv.tv_sec, tv.tv_usec); } cl_object cl_get_internal_real_time() { - struct ecl_timeval tv; - ecl_get_internal_real_time(&tv); - return timeval_to_time(tv.tv_sec - beginning.tv_sec, - tv.tv_usec - beginning.tv_usec); + struct ecl_timeval tv; + ecl_get_internal_real_time(&tv); + return timeval_to_time(tv.tv_sec - beginning.tv_sec, + tv.tv_usec - beginning.tv_usec); } cl_object cl_get_universal_time() { - cl_object utc = ecl_make_integer(time(0)); - @(return ecl_plus(utc, cl_core.Jan1st1970UT)) + cl_object utc = ecl_make_integer(time(0)); + @(return ecl_plus(utc, cl_core.Jan1st1970UT)); } void init_unixtime(void) { - ecl_get_internal_real_time(&beginning); + ecl_get_internal_real_time(&beginning); - ECL_SET(@'internal-time-units-per-second', ecl_make_fixnum(1000)); + ECL_SET(@'internal-time-units-per-second', ecl_make_fixnum(1000)); - cl_core.Jan1st1970UT = - ecl_times(ecl_make_fixnum(24 * 60 * 60), - ecl_make_fixnum(17 + 365 * 70)); + cl_core.Jan1st1970UT = + ecl_times(ecl_make_fixnum(24 * 60 * 60), + ecl_make_fixnum(17 + 365 * 70)); } diff -Nru ecl-16.1.2/src/c/typespec.d ecl-16.1.3+ds/src/c/typespec.d --- ecl-16.1.2/src/c/typespec.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/typespec.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,103 +1,98 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - typespec.c -- Type specifier routines. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * typespec.d - type specifier routines + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include void FEtype_error_fixnum(cl_object x) { - FEwrong_type_argument(@[fixnum], x); + FEwrong_type_argument(@[fixnum], x); } void FEtype_error_size(cl_object x) { - FEwrong_type_argument(cl_list(3, @'integer', ecl_make_fixnum(0), - ecl_make_fixnum(MOST_POSITIVE_FIXNUM)), - x); + FEwrong_type_argument(cl_list(3, @'integer', ecl_make_fixnum(0), + ecl_make_fixnum(MOST_POSITIVE_FIXNUM)), + x); } void FEtype_error_cons(cl_object x) { - FEwrong_type_argument(@[cons], x); + FEwrong_type_argument(@[cons], x); } void FEtype_error_list(cl_object x) { - FEwrong_type_argument(@[list], x); + FEwrong_type_argument(@[list], x); } void FEtype_error_proper_list(cl_object x) { - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("Not a proper list ~D"), - @':format-arguments', cl_list(1, x), - @':expected-type', ecl_read_from_cstring("si::proper-list"), - @':datum', x); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("Not a proper list ~D"), + @':format-arguments', cl_list(1, x), + @':expected-type', ecl_read_from_cstring("si::proper-list"), + @':datum', x); } void FEcircular_list(cl_object x) { - /* FIXME: Is this the right way to rebind it? */ - ecl_bds_bind(ecl_process_env(), @'*print-circle*', ECL_T); - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("Circular list ~D"), - @':format-arguments', cl_list(1, x), - @':expected-type', @'list', - @':datum', x); + /* FIXME: Is this the right way to rebind it? */ + ecl_bds_bind(ecl_process_env(), @'*print-circle*', ECL_T); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("Circular list ~D"), + @':format-arguments', cl_list(1, x), + @':expected-type', @'list', + @':datum', x); } void FEtype_error_index(cl_object seq, cl_fixnum ndx) { - cl_object n = ecl_make_fixnum(ndx); - cl_index l = ECL_INSTANCEP(seq)? seq->instance.length : ecl_length(seq); - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("~S is not a valid index into the object ~S"), - @':format-arguments', cl_list(2, n, seq), - @':expected-type', cl_list(3, @'integer', ecl_make_fixnum(0), ecl_make_fixnum(l-1)), - @':datum', n); + cl_object n = ecl_make_fixnum(ndx); + cl_index l = ECL_INSTANCEP(seq)? seq->instance.length : ecl_length(seq); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("~S is not a valid index into the object ~S"), + @':format-arguments', cl_list(2, n, seq), + @':expected-type', cl_list(3, @'integer', ecl_make_fixnum(0), ecl_make_fixnum(l-1)), + @':datum', n); } void FEtype_error_array(cl_object v) { - FEwrong_type_argument(@[array], v); + FEwrong_type_argument(@[array], v); } void FEtype_error_vector(cl_object v) { - FEwrong_type_argument(@[vector], v); + FEwrong_type_argument(@[vector], v); } void FEtype_error_sequence(cl_object x) { - FEwrong_type_argument(@[sequence], x); + FEwrong_type_argument(@[sequence], x); } cl_object ecl_type_error(cl_object function, const char *place, cl_object o, cl_object type) { - si_wrong_type_argument(4, o, type, - (*place? make_constant_base_string(place) : ECL_NIL), - function); + si_wrong_type_argument(4, o, type, + (*place? make_constant_base_string(place) : ECL_NIL), + function); } /**********************************************************************/ @@ -105,253 +100,255 @@ static cl_object ecl_type_to_symbol(cl_type t) { - switch(t) { - case t_character: - return @'character'; - case t_fixnum: - return @'fixnum'; - case t_bignum: - return @'bignum'; - case t_ratio: - return @'ratio'; - case t_singlefloat: - return @'single-float'; - case t_doublefloat: - return @'double-float'; + switch(t) { + case t_character: + return @'character'; + case t_fixnum: + return @'fixnum'; + case t_bignum: + return @'bignum'; + case t_ratio: + return @'ratio'; + case t_singlefloat: + return @'single-float'; + case t_doublefloat: + return @'double-float'; #ifdef ECL_LONG_FLOAT - case t_longfloat: - return @'long-float'; + case t_longfloat: + return @'long-float'; #endif - case t_complex: - return @'complex'; - case t_symbol: - return @'symbol'; - case t_package: - return @'package'; - case t_list: - return @'list'; - case t_hashtable: - return @'hash-table'; - case t_array: - return @'array'; - case t_vector: - return @'vector'; - case t_bitvector: - return @'bit-vector'; + case t_complex: + return @'complex'; + case t_symbol: + return @'symbol'; + case t_package: + return @'package'; + case t_list: + return @'list'; + case t_hashtable: + return @'hash-table'; + case t_array: + return @'array'; + case t_vector: + return @'vector'; + case t_bitvector: + return @'bit-vector'; #ifdef ECL_UNICODE - case t_string: - return @'string'; + case t_string: + return @'string'; #endif - case t_base_string: - return @'base-string'; - case t_stream: - return @'stream'; - case t_readtable: - return @'readtable'; - case t_pathname: - return @'pathname'; - case t_random: - return @'random-state'; - case t_bytecodes: - case t_bclosure: - case t_cfun: - case t_cfunfixed: - case t_cclosure: - return @'compiled-function'; + case t_base_string: + return @'base-string'; + case t_stream: + return @'stream'; + case t_readtable: + return @'readtable'; + case t_pathname: + return @'pathname'; + case t_random: + return @'random-state'; + case t_bytecodes: + case t_bclosure: + case t_cfun: + case t_cfunfixed: + case t_cclosure: + return @'compiled-function'; #ifdef ECL_THREADS - case t_process: - return @'mp::process'; - case t_lock: - return @'mp::lock'; - case t_condition_variable: - return @'mp::condition-variable'; - case t_semaphore: - return @'mp::semaphore'; - case t_barrier: - return @'mp::barrier'; - case t_mailbox: - return @'mp::mailbox'; + case t_process: + return @'mp::process'; + case t_lock: + return @'mp::lock'; + case t_rwlock: + return @'mp::rwlock'; + case t_condition_variable: + return @'mp::condition-variable'; + case t_semaphore: + return @'mp::semaphore'; + case t_barrier: + return @'mp::barrier'; + case t_mailbox: + return @'mp::mailbox'; #endif - case t_codeblock: - return @'si::code-block'; - case t_foreign: - return @'si::foreign-data'; - case t_frame: - return @'si::frame'; - case t_weak_pointer: - return @'ext::weak-pointer'; + case t_codeblock: + return @'si::code-block'; + case t_foreign: + return @'si::foreign-data'; + case t_frame: + return @'si::frame'; + case t_weak_pointer: + return @'ext::weak-pointer'; #ifdef ECL_SSE2 - case t_sse_pack: - return @'ext::sse-pack'; + case t_sse_pack: + return @'ext::sse-pack'; #endif - default: - ecl_internal_error("not a lisp data object"); - } + default: + ecl_internal_error("not a lisp data object"); + } } cl_object ecl_check_cl_type(cl_object fun, cl_object p, cl_type t) { - while (ecl_t_of(p) != t) { - p = ecl_type_error(fun, "argument", p, ecl_type_to_symbol(t)); - } - return p; + while (ecl_t_of(p) != t) { + p = ecl_type_error(fun, "argument", p, ecl_type_to_symbol(t)); + } + return p; } void assert_type_integer(cl_object p) { - cl_type t = ecl_t_of(p); - if (t != t_fixnum && t != t_bignum) - FEwrong_type_nth_arg(@[coerce], 1, p, @[integer]); + cl_type t = ecl_t_of(p); + if (t != t_fixnum && t != t_bignum) + FEwrong_type_nth_arg(@[coerce], 1, p, @[integer]); } void assert_type_non_negative_integer(cl_object p) { - cl_type t = ecl_t_of(p); + cl_type t = ecl_t_of(p); - if (t == t_fixnum) { - if (ecl_fixnum_plusp(p)) - return; - } else if (t == t_bignum) { - if (_ecl_big_sign(p) >= 0) - return; - } - FEwrong_type_argument(cl_list(3,@'integer',ecl_make_fixnum(0),@'*'), p); + if (t == t_fixnum) { + if (ecl_fixnum_plusp(p)) + return; + } else if (t == t_bignum) { + if (_ecl_big_sign(p) >= 0) + return; + } + FEwrong_type_argument(cl_list(3,@'integer',ecl_make_fixnum(0),@'*'), p); } void assert_type_proper_list(cl_object p) { - if (ECL_ATOM(p) && p != ECL_NIL) - FEtype_error_list(p); - if (cl_list_length(p) == ECL_NIL) - FEcircular_list(p); + if (ECL_ATOM(p) && p != ECL_NIL) + FEtype_error_list(p); + if (cl_list_length(p) == ECL_NIL) + FEcircular_list(p); } cl_object cl_type_of(cl_object x) { - cl_object t; - cl_type tx = ecl_t_of(x); - switch (tx) { - case t_instance: { - cl_object cl = ECL_CLASS_OF(x); - t = ECL_CLASS_NAME(cl); - if (t == ECL_NIL || cl != cl_find_class(2, t, ECL_NIL)) - t = cl; - break; - } - case t_fixnum: - case t_bignum: - t = cl_list(3, @'integer', x, x); - break; - case t_character: { - int i = ECL_CHAR_CODE(x); - if (ecl_standard_char_p(i)) { - t = @'standard-char'; - } else if (ecl_base_char_p(i)) { - t = @'base-char'; - } else { - t = @'character'; - } - break; - } - - case t_symbol: - if (x == ECL_T) - t = @'boolean'; - else if (x->symbol.hpack == cl_core.keyword_package) - t = @'keyword'; - else - t = @'symbol'; - break; - case t_array: - if (ECL_ADJUSTABLE_ARRAY_P(x) || - !Null(CAR(x->array.displaced))) - t = @'array'; - else - t = @'simple-array'; - t = cl_list(3, t, ecl_elttype_to_symbol(ecl_array_elttype(x)), - cl_array_dimensions(x)); - break; - case t_vector: - if (ECL_ADJUSTABLE_ARRAY_P(x) || - !Null(CAR(x->vector.displaced))) { - t = cl_list(3, @'vector', ecl_elttype_to_symbol(ecl_array_elttype(x)), - ecl_make_fixnum(x->vector.dim)); - } else if (ECL_ARRAY_HAS_FILL_POINTER_P(x) || - (cl_elttype)x->vector.elttype != ecl_aet_object) { - t = cl_list(3, @'simple-array', - ecl_elttype_to_symbol(ecl_array_elttype(x)), - cl_array_dimensions(x)); - } else { - t = cl_list(2, @'simple-vector', ecl_make_fixnum(x->vector.dim)); - } - break; + cl_object t; + cl_type tx = ecl_t_of(x); + switch (tx) { + case t_instance: { + cl_object cl = ECL_CLASS_OF(x); + t = ECL_CLASS_NAME(cl); + if (t == ECL_NIL || cl != cl_find_class(2, t, ECL_NIL)) + t = cl; + break; + } + case t_fixnum: + case t_bignum: + t = cl_list(3, @'integer', x, x); + break; + case t_character: { + int i = ECL_CHAR_CODE(x); + if (ecl_standard_char_p(i)) { + t = @'standard-char'; + } else if (ecl_base_char_p(i)) { + t = @'base-char'; + } else { + t = @'character'; + } + break; + } + + case t_symbol: + if (x == ECL_T) + t = @'boolean'; + else if (x->symbol.hpack == cl_core.keyword_package) + t = @'keyword'; + else + t = @'symbol'; + break; + case t_array: + if (ECL_ADJUSTABLE_ARRAY_P(x) || + !Null(CAR(x->array.displaced))) + t = @'array'; + else + t = @'simple-array'; + t = cl_list(3, t, ecl_elttype_to_symbol(ecl_array_elttype(x)), + cl_array_dimensions(x)); + break; + case t_vector: + if (ECL_ADJUSTABLE_ARRAY_P(x) || + !Null(CAR(x->vector.displaced))) { + t = cl_list(3, @'vector', ecl_elttype_to_symbol(ecl_array_elttype(x)), + ecl_make_fixnum(x->vector.dim)); + } else if (ECL_ARRAY_HAS_FILL_POINTER_P(x) || + (cl_elttype)x->vector.elttype != ecl_aet_object) { + t = cl_list(3, @'simple-array', + ecl_elttype_to_symbol(ecl_array_elttype(x)), + cl_array_dimensions(x)); + } else { + t = cl_list(2, @'simple-vector', ecl_make_fixnum(x->vector.dim)); + } + break; #ifdef ECL_UNICODE - case t_string: - if (ECL_ADJUSTABLE_ARRAY_P(x) || - ECL_ARRAY_HAS_FILL_POINTER_P(x) || - !Null(CAR(x->string.displaced))) - t = @'array'; - else - t = @'simple-array'; - t = cl_list(3, t, @'character', cl_list(1, ecl_make_fixnum(x->string.dim))); - break; + case t_string: + if (ECL_ADJUSTABLE_ARRAY_P(x) || + ECL_ARRAY_HAS_FILL_POINTER_P(x) || + !Null(CAR(x->string.displaced))) + t = @'array'; + else + t = @'simple-array'; + t = cl_list(3, t, @'character', cl_list(1, ecl_make_fixnum(x->string.dim))); + break; #endif - case t_base_string: - if (ECL_ADJUSTABLE_ARRAY_P(x) || - ECL_ARRAY_HAS_FILL_POINTER_P(x) || - !Null(CAR(x->base_string.displaced))) - t = @'array'; - else - t = @'simple-array'; - t = cl_list(3, t, @'base-char', cl_list(1, ecl_make_fixnum(x->base_string.dim))); - break; - case t_bitvector: - if (ECL_ADJUSTABLE_ARRAY_P(x) || - ECL_ARRAY_HAS_FILL_POINTER_P(x) || - !Null(CAR(x->vector.displaced))) - t = @'array'; - else - t = @'simple-array'; - t = cl_list(3, t, @'bit', cl_list(1, ecl_make_fixnum(x->vector.dim))); - break; - case t_stream: - switch (x->stream.mode) { - case ecl_smm_synonym: t = @'synonym-stream'; break; - case ecl_smm_broadcast: t = @'broadcast-stream'; break; - case ecl_smm_concatenated: t = @'concatenated-stream'; break; - case ecl_smm_two_way: t = @'two-way-stream'; break; - case ecl_smm_string_input: - case ecl_smm_string_output: t = @'string-stream'; break; - case ecl_smm_echo: t = @'echo-stream'; break; - case ecl_smm_sequence_input: - case ecl_smm_sequence_output: t = @'ext::sequence-stream'; break; - default: t = @'file-stream'; break; - } - break; - case t_pathname: - t = x->pathname.logical? @'logical-pathname' : @'pathname'; - break; - case t_list: - t = Null(x) ? @'null' : @'cons'; - break; + case t_base_string: + if (ECL_ADJUSTABLE_ARRAY_P(x) || + ECL_ARRAY_HAS_FILL_POINTER_P(x) || + !Null(CAR(x->base_string.displaced))) + t = @'array'; + else + t = @'simple-array'; + t = cl_list(3, t, @'base-char', cl_list(1, ecl_make_fixnum(x->base_string.dim))); + break; + case t_bitvector: + if (ECL_ADJUSTABLE_ARRAY_P(x) || + ECL_ARRAY_HAS_FILL_POINTER_P(x) || + !Null(CAR(x->vector.displaced))) + t = @'array'; + else + t = @'simple-array'; + t = cl_list(3, t, @'bit', cl_list(1, ecl_make_fixnum(x->vector.dim))); + break; + case t_stream: + switch (x->stream.mode) { + case ecl_smm_synonym: t = @'synonym-stream'; break; + case ecl_smm_broadcast: t = @'broadcast-stream'; break; + case ecl_smm_concatenated: t = @'concatenated-stream'; break; + case ecl_smm_two_way: t = @'two-way-stream'; break; + case ecl_smm_string_input: + case ecl_smm_string_output: t = @'string-stream'; break; + case ecl_smm_echo: t = @'echo-stream'; break; + case ecl_smm_sequence_input: + case ecl_smm_sequence_output: t = @'ext::sequence-stream'; break; + default: t = @'file-stream'; break; + } + break; + case t_pathname: + t = x->pathname.logical? @'logical-pathname' : @'pathname'; + break; + case t_list: + t = Null(x) ? @'null' : @'cons'; + break; #ifdef ECL_SSE2 - case t_sse_pack: - t = @'ext::sse-pack'; - break; + case t_sse_pack: + t = @'ext::sse-pack'; + break; #endif - default: - t = ecl_type_to_symbol(tx); - } - @(return t) + default: + t = ecl_type_to_symbol(tx); + } + @(return t); } cl_object ecl_make_integer_type(cl_object min, cl_object max) { - return cl_list(3, @'integer', min, max); + return cl_list(3, @'integer', min, max); } diff -Nru ecl-16.1.2/src/c/unify.d ecl-16.1.3+ds/src/c/unify.d --- ecl-16.1.2/src/c/unify.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/unify.d 1970-01-01 00:00:00.000000000 +0000 @@ -1,301 +0,0 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ - -/* - unify.d -- Support for unification. -*/ -/* - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ - - -#include "ecl.h" -#include "unify.h" - -object *slot; /* scanning pointer within object */ -int (*slotf)(); /* read/write mode accessor */ - -/* -------------------- Trail Instructions -------------------- */ - -object *trail[VSSIZE]; -object **trail_top = trail; - -#define BIND(loc, val) {loc = val; trail_push(&loc);} - -@(defun trail_mark () -@ - trail_mark; -@) - -@(defun trail_restore () -@ - trail_restore; - @(return ECL_NIL) -@) - -@(defun trail_unmark () -@ - trail_unmark; - @(return ECL_NIL) -@) - -/* -------------------- Mode Operators -------------------- */ - -bool get_slot(object x) /* read mode */ -{ - if (x == *slot || unify(x, *slot)) - if (*slot == OBJNULL) - return((bool)MAKE_LOCATIVE(slot++)); - else - return((bool)*slot++); /* dereference */ - else - return(FALSE); -} - -bool set_slot(object x) /* write mode */ -{ - /* NOTE: slot contains OBJNULL */ - *slot = x; - return((bool)MAKE_LOCATIVE(slot++)); -} - - -/* -------------------- Get Instructions -------------------- */ - -/* get_variable is just setq */ - -@(defun get_value (v x) -@ - @(return (get_value(v, x)?ECL_T:ECL_NIL)) -@) - -@(defun get_constant (c x) -@ - @(return (get_constant(c, x)?ECL_T:ECL_NIL)) -@) - -@(defun get_nil (arg) -@ - @(return (get_nil(arg)?ECL_T:ECL_NIL)) -@) - -bool -get_cons(object x) -{ - -RETRY: switch (ecl_t_of(x)) { - case t_cons: - slot = &CDR(x); /* cdr slot is first in struct cons */ - slotf = get_slot; - return(TRUE); - - case t_locative: - if (UNBOUNDP(x)) { - object new = CONS(OBJNULL, OBJNULL); - BIND(DEREF(x), new); - slot = &CDR(new); - slotf = set_slot; - return(TRUE); - } - else { - x = DEREF(x); - goto RETRY; - } - - default: return(FALSE); - } - -} - -@(defun get_cons (arg) -@ - @(return (get_cons(arg)?ECL_T:ECL_NIL)) -@) - -bool -get_instance(object x, object class, int arity) -{ -RETRY: switch (ecl_t_of(x)) { - case t_instance: - if (ECL_CLASS_OF(x) == class) { - slot = x->instance.slots; - slotf = get_slot; - return(TRUE); - } else - return(FALSE); - - case t_locative: - if (UNBOUNDP(x)) { - object new = allocate_instance(class, arity); - BIND(DEREF(x), new); - slot = new->instance.slots; - slotf = set_slot; - return(TRUE); - } - else { - x = DEREF(x); - goto RETRY; - } - default: return(FALSE); - } -} - -@(defun get_instance (x class arity) -@ - @(return (get_instance(x, class, ecl_fixnum(arity))?ECL_T:ECL_NIL)) -@) - - -/* -------------------- Unify Instructions -------------------- */ - -#define UNIFY_LOCATIVE(x, y, L) {object *p = &DEREF(x); \ - if (*p == OBJNULL) { \ - BIND(*p, y); return(TRUE); } \ - else { x = *p; goto L;}} -/* -#define UNIFY_LOCATIVE(x, y, L) {if (UNBOUNDP(x)) { \ - BIND(DEREF(x), y); return(TRUE); } \ - else { x = DEREF(x); goto L;}} -*/ - -bool -unify(object x, object y) -{ - /* NOTE: x <- y */ - - L: switch (ecl_t_of(x)) { - - case t_locative: UNIFY_LOCATIVE(x, y, L); - - case t_cons: - L1: switch (ecl_t_of(y)) { - - case t_cons: return(unify(CAR(x), CAR(y)) && - unify(CDR(x), CDR(y))); - - case t_locative: UNIFY_LOCATIVE(y, x, L1); - - default: return(FALSE); - } - - case t_instance: - L2: switch (ecl_t_of(y)) { - - case t_instance: - if (ECL_CLASS_OF(x) == ECL_CLASS_OF(y)) { - int l = x->instance.length; int i; - object *slotx = x->instance.slots; - object *sloty = y->instance.slots; - for (i = 0; i < l; i++) { - if (!unify(*slotx++, *sloty++)) - return(FALSE); - } - return(TRUE); - } else - return(FALSE); - - case t_locative: UNIFY_LOCATIVE(y, x, L2); - - default: return(FALSE); - } - - default: - L3: if (LOCATIVEP(y)) - UNIFY_LOCATIVE(y, x, L3) - else if (equal(x,y)) - return(TRUE); - else - return(FALSE); - } -} - -/* Internal function. One should use unify_variable, which always returns T */ - -@(defun unify_slot () -@ - @(return ((object)unify_slot)) -@) - - -@(defun unify_value (loc) - object x; -@ - x = (object)unify_value(loc); - @(return ((x == ECL_NIL || x)?ECL_T:ECL_NIL)) -@) - -@(defun unify_constant (c) - object x; -@ - x = (object)unify_constant(c); - @(return ((x == ECL_NIL || x)?ECL_T:ECL_NIL)) -@) - -@(defun unify_nil () - object x; -@ - x = (object)unify_nil; - @(return ((x == ECL_NIL || x)?ECL_T:ECL_NIL)) -@) - -/* -------------------- Test Functions -------------------- */ - -@(defun make_locative (&optional (n 0)) -@ - @(return (MAKE_LOCATIVE(ecl_fixnum(n)))) -@) - -@(defun locativep (obje) -@ - @(return (LOCATIVEP(obje)?ECL_T:ECL_NIL)) -@) - -@(defun unboundp (loc) -@ - @(return (UNBOUNDP(loc)?ECL_T:ECL_NIL)) -@) - -@(defun dereference (x) - extern object Slocative; -@ - while (ecl_t_of(x) != t_locative) - x = wrong_type_argument(Slocative, x); - @(return (DEREF(x))) -@) - -@(defun make_variable (name) -@ - @(return (CONS(name, OBJNULL))) -@) - -/* (defmacro unify-variable (v) `(progn (setq ,v (si:unify-slot)) t) */ - -object Ssetq, Sunify_slot; - -@(defun unify_variable (object var) -@ - @(return list(3, Sprogn, - list(3, Ssetq, CADR(var), - CONS(Sunify_slot, ECL_NIL)), - ECL_T)) -@) - -#define make_si_macro(name, cfun) \ - {object x = make_si_ordinary(name); \ - ECL_SYM_FUN(x) = make_cfun(cfun, ECL_NIL, NULL); \ - x->symbol.mflag = TRUE; \ - } - -void -init_unify(void) -{ - make_si_macro("UNIFY-VARIABLE", Lunify_variable); -} diff -Nru ecl-16.1.2/src/c/unixfsys.d ecl-16.1.3+ds/src/c/unixfsys.d --- ecl-16.1.2/src/c/unixfsys.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/unixfsys.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - unixfsys.c -- Unix file system interface. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * unixfsys.d - Unix file system interface + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -59,49 +54,49 @@ static cl_object coerce_to_posix_filename(cl_object filename) { - /* This converts a pathname designator into a namestring, with the - * particularity that directories do not end with a slash '/', because - * this is not supported on all POSIX platforms (most notably Windows) - */ - filename = si_coerce_to_filename(filename); - return cl_string_right_trim(str_slash, filename); + /* This converts a pathname designator into a namestring, with the + * particularity that directories do not end with a slash '/', because + * this is not supported on all POSIX platforms (most notably Windows) + */ + filename = si_coerce_to_filename(filename); + return cl_string_right_trim(str_slash, filename); } static int safe_chdir(const char *path, cl_object prefix) { - if (prefix != ECL_NIL) { - cl_object aux = make_constant_base_string(path); - aux = si_base_string_concatenate(2, prefix, aux); - return safe_chdir((char *)aux->base_string.self, ECL_NIL); - } else { - int output; - ecl_disable_interrupts(); - output = chdir((char *)path); - ecl_enable_interrupts(); - return output; - } + if (prefix != ECL_NIL) { + cl_object aux = make_constant_base_string(path); + aux = si_base_string_concatenate(2, prefix, aux); + return safe_chdir((char *)aux->base_string.self, ECL_NIL); + } else { + int output; + ecl_disable_interrupts(); + output = chdir((char *)path); + ecl_enable_interrupts(); + return output; + } } static int safe_stat(const char *path, struct stat *sb) { - int output; - ecl_disable_interrupts(); - output = stat(path, sb); - ecl_enable_interrupts(); - return output; + int output; + ecl_disable_interrupts(); + output = stat(path, sb); + ecl_enable_interrupts(); + return output; } #ifdef HAVE_LSTAT static int safe_lstat(const char *path, struct stat *sb) { - int output; - ecl_disable_interrupts(); - output = lstat(path, sb); - ecl_enable_interrupts(); - return output; + int output; + ecl_disable_interrupts(); + output = lstat(path, sb); + ecl_enable_interrupts(); + return output; } #endif @@ -109,23 +104,23 @@ static cl_object drive_host_prefix(cl_object pathname) { - cl_object device = pathname->pathname.device; - cl_object host = pathname->pathname.host; - cl_object output = ECL_NIL; - if (device != ECL_NIL) { - output = make_base_string_copy("X:"); - output->base_string.self[0] = device->base_string.self[0]; - } - if (host != ECL_NIL) { - cl_object slash = cl_core.slash; - if (output != ECL_NIL) - output = si_base_string_concatenate(5, output, slash, slash, - host, slash); - else - output = si_base_string_concatenate(4, slash, slash, host, - slash); - } - return output; + cl_object device = pathname->pathname.device; + cl_object host = pathname->pathname.host; + cl_object output = ECL_NIL; + if (device != ECL_NIL) { + output = make_base_string_copy("X:"); + output->base_string.self[0] = device->base_string.self[0]; + } + if (host != ECL_NIL) { + cl_object slash = cl_core.slash; + if (output != ECL_NIL) + output = si_base_string_concatenate(5, output, slash, slash, + host, slash); + else + output = si_base_string_concatenate(4, slash, slash, host, + slash); + } + return output; } #else #define drive_host_prefix(x) ECL_NIL @@ -137,8 +132,8 @@ cl_object ecl_cstring_to_pathname(char *s) { - cl_object string = ecl_make_simple_base_string(s, -1); - return cl_parse_namestring(1, string); + cl_object string = ecl_make_simple_base_string(s, -1); + return cl_parse_namestring(1, string); } /* @@ -147,42 +142,42 @@ */ static cl_object current_dir(void) { - cl_object output; - const char *ok; + cl_object output; + const char *ok; #ifdef _MSC_VER - unsigned char *c; + unsigned char *c; #endif - cl_index size = 128; + cl_index size = 128; - do { - output = ecl_alloc_adjustable_base_string(size); - ecl_disable_interrupts(); - ok = getcwd((char*)output->base_string.self, size); - if (ok == NULL && errno != ENAMETOOLONG) { - perror("ext::getcwd error"); - ecl_internal_error("Can't work without CWD"); - } - ecl_enable_interrupts(); - size += 256; - } while (ok == NULL); - size = strlen((char*)output->base_string.self); - if ((size + 1 /* / */ + 1 /* 0 */) >= output->base_string.dim) { - /* Too large to host the trailing '/' */ - cl_object other = ecl_alloc_adjustable_base_string(size+2); - strcpy((char*)other->base_string.self, (char*)output->base_string.self); - output = other; - } + do { + output = ecl_alloc_adjustable_base_string(size); + ecl_disable_interrupts(); + ok = getcwd((char*)output->base_string.self, size); + if (ok == NULL && errno != ERANGE) { + perror("ext::getcwd error"); + ecl_internal_error("Can't work without CWD"); + } + ecl_enable_interrupts(); + size += 256; + } while (ok == NULL); + size = strlen((char*)output->base_string.self); + if ((size + 2) >= output->base_string.dim) { + /* Too small to host the trailing '/' and '\0' */ + cl_object other = ecl_alloc_adjustable_base_string(size+2); + strcpy((char*)other->base_string.self, (char*)output->base_string.self); + output = other; + } #ifdef _MSC_VER - for (c = output->base_string.self; *c; c++) - if (*c == '\\') - *c = '/'; + for (c = output->base_string.self; *c; c++) + if (*c == '\\') + *c = '/'; #endif - if (output->base_string.self[size-1] != '/') { - output->base_string.self[size++] = '/'; - output->base_string.self[size] = 0; - } - output->base_string.fillp = size; - return output; + if (output->base_string.self[size-1] != '/') { + output->base_string.self[size++] = '/'; + output->base_string.self[size] = 0; + } + output->base_string.fillp = size; + return output; } /* @@ -191,155 +186,161 @@ static cl_object file_kind(char *filename, bool follow_links) { - cl_object output; + cl_object output; #if defined(ECL_MS_WINDOWS_HOST) - DWORD dw; - ecl_disable_interrupts(); - dw = GetFileAttributes( filename ); - if (dw == -1) - output = ECL_NIL; - else if ( dw & FILE_ATTRIBUTE_DIRECTORY ) - output = @':directory'; - else - output = @':file'; - ecl_enable_interrupts(); + DWORD dw; + ecl_disable_interrupts(); + dw = GetFileAttributes( filename ); + if (dw == -1) + output = ECL_NIL; + else if ( dw & FILE_ATTRIBUTE_DIRECTORY ) + output = @':directory'; + else + output = @':file'; + ecl_enable_interrupts(); #else - struct stat buf; + struct stat buf; # ifdef HAVE_LSTAT - if ((follow_links? safe_stat : safe_lstat)(filename, &buf) < 0) + if ((follow_links? safe_stat : safe_lstat)(filename, &buf) < 0) # else - if (safe_stat(filename, &buf) < 0) + if (safe_stat(filename, &buf) < 0) # endif - output = ECL_NIL; + output = ECL_NIL; # ifdef HAVE_LSTAT - else if (S_ISLNK(buf.st_mode)) - output = @':link'; + else if (S_ISLNK(buf.st_mode)) + output = @':link'; # endif - else if (S_ISDIR(buf.st_mode)) - output = @':directory'; - else if (S_ISREG(buf.st_mode)) - output = @':file'; - else - output = @':special'; + else if (S_ISDIR(buf.st_mode)) + output = @':directory'; + else if (S_ISREG(buf.st_mode)) + output = @':file'; + else + output = @':special'; #endif - return output; + return output; } cl_object si_file_kind(cl_object filename, cl_object follow_links) { - filename = coerce_to_posix_filename(filename); - @(return file_kind((char*)filename->base_string.self, !Null(follow_links))) + filename = coerce_to_posix_filename(filename); + @(return file_kind((char*)filename->base_string.self, !Null(follow_links))); } #if defined(HAVE_LSTAT) && !defined(ECL_MS_WINDOWS_HOST) static cl_object si_readlink(cl_object filename) { - /* Given a filename which is a symlink, this routine returns - * the value of this link in the form of a pathname. */ - cl_index size = 128, written; - cl_object output, kind; - do { - output = ecl_alloc_adjustable_base_string(size); - ecl_disable_interrupts(); - written = readlink((char*)filename->base_string.self, - (char*)output->base_string.self, size); - ecl_enable_interrupts(); - size += 256; - } while (written == size); - output->base_string.self[written] = '\0'; - kind = file_kind((char*)output->base_string.self, FALSE); - if (kind == @':directory') { - output->base_string.self[written++] = '/'; - output->base_string.self[written] = '\0'; - } - output->base_string.fillp = written; - return output; + /* Given a filename which is a symlink, this routine returns + * the value of this link in the form of a pathname. */ + cl_index size = 128, written; + cl_object output, kind; + do { + output = ecl_alloc_adjustable_base_string(size); + ecl_disable_interrupts(); + written = readlink((char*)filename->base_string.self, + (char*)output->base_string.self, size); + ecl_enable_interrupts(); + size += 256; + } while (written == size-256); + if ((written + 2) > (cl_index)(output->base_string.self)) { + /* Too small to host the trailing '/' and '\0' */ + cl_object other = ecl_alloc_adjustable_base_string(written+2); + strcpy((char*)other->base_string.self, (char*)output->base_string.self); + output = other; + } + output->base_string.self[written] = '\0'; + kind = file_kind((char*)output->base_string.self, FALSE); + if (kind == @':directory') { + output->base_string.self[written++] = '/'; + output->base_string.self[written] = '\0'; + } + output->base_string.fillp = written; + return output; } #endif /* HAVE_LSTAT */ static cl_object enter_directory(cl_object base_dir, cl_object subdir, bool ignore_if_failure) { - /* Assuming we start in "base_dir", enter a subdirectory named by - * "subdir", which may be a string, :UP, :ABSOLUTE or :RELATIVE. - * If the operation succeeds, return the truename of the resulting - * path -- resolving any links in the process. */ - cl_object aux, output, kind; - if (subdir == @':absolute') { - return cl_make_pathname(4, @':directory', ecl_list1(subdir), - @':defaults', base_dir); - } else if (subdir == @':relative') { - /* Nothing to do */ - return base_dir; - } else if (subdir == @':up') { - aux = make_constant_base_string(".."); - } else if (!ECL_BASE_STRING_P(subdir)) { - unlikely_if (!ecl_fits_in_base_string(subdir)) - FEerror("Directory component ~S found in pathname~& ~S" - "~&is not allowed in TRUENAME or DIRECTORY", - 1, subdir); - aux = si_coerce_to_base_string(subdir); - } else { - aux = subdir; - } - /* We now compose a new path based on the base directory and - * the new component. We have to verify that the new pathname is - * a directory and if it is a link recover the true name. */ - aux = ecl_append(base_dir->pathname.directory, ecl_list1(aux)); - output = cl_make_pathname(4, @':directory', aux, @':defaults', base_dir); - aux = ecl_namestring(output, ECL_NAMESTRING_FORCE_BASE_STRING); - /* We remove the trailing '/' from the namestring because the - * POSIX library does not like it. */ - aux->base_string.self[--aux->base_string.fillp] = 0; - kind = file_kind((char*)aux->base_string.self, FALSE); - if (kind == ECL_NIL) { - if (ignore_if_failure) return ECL_NIL; - FEcannot_open(output); + /* Assuming we start in "base_dir", enter a subdirectory named by + * "subdir", which may be a string, :UP, :ABSOLUTE or :RELATIVE. + * If the operation succeeds, return the truename of the resulting + * path -- resolving any links in the process. */ + cl_object aux, output, kind; + if (subdir == @':absolute') { + return cl_make_pathname(4, @':directory', ecl_list1(subdir), + @':defaults', base_dir); + } else if (subdir == @':relative') { + /* Nothing to do */ + return base_dir; + } else if (subdir == @':up') { + aux = make_constant_base_string(".."); + } else if (!ECL_BASE_STRING_P(subdir)) { + unlikely_if (!ecl_fits_in_base_string(subdir)) + FEerror("Directory component ~S found in pathname~& ~S" + "~&is not allowed in TRUENAME or DIRECTORY", + 1, subdir); + aux = si_coerce_to_base_string(subdir); + } else { + aux = subdir; + } + /* We now compose a new path based on the base directory and + * the new component. We have to verify that the new pathname is + * a directory and if it is a link recover the true name. */ + aux = ecl_append(base_dir->pathname.directory, ecl_list1(aux)); + output = cl_make_pathname(4, @':directory', aux, @':defaults', base_dir); + aux = ecl_namestring(output, ECL_NAMESTRING_FORCE_BASE_STRING); + /* We remove the trailing '/' from the namestring because the + * POSIX library does not like it. */ + aux->base_string.self[--aux->base_string.fillp] = 0; + kind = file_kind((char*)aux->base_string.self, FALSE); + if (kind == ECL_NIL) { + if (ignore_if_failure) return ECL_NIL; + FEcannot_open(output); #ifdef HAVE_LSTAT - } else if (kind == @':link') { - output = cl_truename(ecl_merge_pathnames(si_readlink(aux), - base_dir, @':default')); - if (output->pathname.name != ECL_NIL || - output->pathname.type != ECL_NIL) - goto WRONG_DIR; - return output; + } else if (kind == @':link') { + output = cl_truename(ecl_merge_pathnames(si_readlink(aux), + base_dir, @':default')); + if (output->pathname.name != ECL_NIL || + output->pathname.type != ECL_NIL) + goto WRONG_DIR; + return output; #endif - } else if (kind != @':directory') { - WRONG_DIR: - if (ignore_if_failure) return ECL_NIL; - FEerror("The directory~& ~S~&in pathname~& ~S~&" - "actually points to a file or special device.", - 2, subdir, base_dir); - } - if (subdir == @':up') { - cl_object newdir= output->pathname.directory; - newdir = ecl_nbutlast(newdir, 2); - if (Null(newdir)) { - if (ignore_if_failure) return ECL_NIL; - FEerror("Pathname contained an :UP component " - "that goes above the base directory:" - "~& ~S", 1, output); - } - output->pathname.directory = newdir; - } - return output; + } else if (kind != @':directory') { + WRONG_DIR: + if (ignore_if_failure) return ECL_NIL; + FEerror("The directory~& ~S~&in pathname~& ~S~&" + "actually points to a file or special device.", + 2, subdir, base_dir); + } + if (subdir == @':up') { + cl_object newdir= output->pathname.directory; + newdir = ecl_nbutlast(newdir, 2); + if (Null(newdir)) { + if (ignore_if_failure) return ECL_NIL; + FEerror("Pathname contained an :UP component " + "that goes above the base directory:" + "~& ~S", 1, output); + } + output->pathname.directory = newdir; + } + return output; } static cl_object make_absolute_pathname(cl_object orig_pathname) { - cl_object base_dir = si_getcwd(0); - cl_object pathname = coerce_to_file_pathname(orig_pathname); - return ecl_merge_pathnames(pathname, base_dir, @':default'); + cl_object base_dir = si_getcwd(0); + cl_object pathname = coerce_to_file_pathname(orig_pathname); + return ecl_merge_pathnames(pathname, base_dir, @':default'); } static cl_object make_base_pathname(cl_object pathname) { - return ecl_make_pathname(pathname->pathname.host, - pathname->pathname.device, - ecl_list1(@':absolute'), - ECL_NIL, ECL_NIL, ECL_NIL, @':local'); + return ecl_make_pathname(pathname->pathname.host, + pathname->pathname.device, + ecl_list1(@':absolute'), + ECL_NIL, ECL_NIL, ECL_NIL, @':local'); } #define FOLLOW_SYMLINKS 1 @@ -347,65 +348,66 @@ static cl_object file_truename(cl_object pathname, cl_object filename, int flags) { - cl_object kind; - if (Null(pathname)) { - if (Null(filename)) { - ecl_internal_error("file_truename:" - " both FILENAME and PATHNAME are null!"); - } - pathname = cl_pathname(filename); - } else if (Null(filename)) { - filename = ecl_namestring(pathname, ECL_NAMESTRING_FORCE_BASE_STRING); - if (Null(filename)) { - FEerror("Unprintable pathname ~S found in TRUENAME", 1, pathname); - } - } - kind = file_kind((char*)filename->base_string.self, FALSE); - if (kind == ECL_NIL) { - FEcannot_open(filename); + cl_object kind; + if (Null(pathname)) { + if (Null(filename)) { + ecl_internal_error("file_truename:" + " both FILENAME and PATHNAME are null!"); + } + pathname = cl_pathname(filename); + } else if (Null(filename)) { + filename = ecl_namestring(pathname, ECL_NAMESTRING_FORCE_BASE_STRING); + if (Null(filename)) { + FEerror("Unprintable pathname ~S found in TRUENAME", 1, pathname); + } + } + kind = file_kind((char*)filename->base_string.self, FALSE); + if (kind == ECL_NIL) { + FEcannot_open(filename); #ifdef HAVE_LSTAT - } else if (kind == @':link' && (flags & FOLLOW_SYMLINKS)) { - /* The link might be a relative pathname. In that case - * we have to merge with the original pathname. On - * the other hand, if the link is broken – return file - * truename "as is". */ - struct stat filestatus; - if (safe_stat(filename->base_string.self, &filestatus) < 0) - @(return pathname kind); - filename = si_readlink(filename); - pathname = ecl_make_pathname(pathname->pathname.host, - pathname->pathname.device, - pathname->pathname.directory, - ECL_NIL, ECL_NIL, ECL_NIL, @':local'); - pathname = ecl_merge_pathnames(filename, pathname, @':default'); - return cl_truename(pathname); + } else if (kind == @':link' && (flags & FOLLOW_SYMLINKS)) { + /* The link might be a relative pathname. In that case + * we have to merge with the original pathname. On + * the other hand, if the link is broken – return file + * truename "as is". */ + struct stat filestatus; + if (safe_stat(filename->base_string.self, &filestatus) < 0) { + @(return pathname kind); + } + filename = si_readlink(filename); + pathname = ecl_make_pathname(pathname->pathname.host, + pathname->pathname.device, + pathname->pathname.directory, + ECL_NIL, ECL_NIL, ECL_NIL, @':local'); + pathname = ecl_merge_pathnames(filename, pathname, @':default'); + return cl_truename(pathname); #endif - } else if (kind == @':directory'){ - /* If the pathname is a directory but we have supplied - a file name, correct the type by appending a directory - separator and re-parsing again the namestring */ - if (pathname->pathname.name != ECL_NIL || - pathname->pathname.type != ECL_NIL) { - pathname = si_base_string_concatenate - (2, filename, - make_constant_base_string("/")); - pathname = cl_truename(pathname); - } - } - /* ECL does not contemplate version numbers - in directory pathnames */ - if (pathname->pathname.name == ECL_NIL && - pathname->pathname.type == ECL_NIL) { - /* We have to destructively change the - * pathname version here. Otherwise - * merge_pathnames will not do it. It is - * safe because coerce_to_file_pathname - * created a copy. */ - pathname->pathname.version = ECL_NIL; - } else { - pathname->pathname.version = @':newest'; - } - @(return pathname kind) + } else if (kind == @':directory'){ + /* If the pathname is a directory but we have supplied + a file name, correct the type by appending a directory + separator and re-parsing again the namestring */ + if (pathname->pathname.name != ECL_NIL || + pathname->pathname.type != ECL_NIL) { + pathname = si_base_string_concatenate + (2, filename, + make_constant_base_string("/")); + pathname = cl_truename(pathname); + } + } + /* ECL does not contemplate version numbers + in directory pathnames */ + if (pathname->pathname.name == ECL_NIL && + pathname->pathname.type == ECL_NIL) { + /* We have to destructively change the + * pathname version here. Otherwise + * merge_pathnames will not do it. It is + * safe because coerce_to_file_pathname + * created a copy. */ + pathname->pathname.version = ECL_NIL; + } else { + pathname->pathname.version = @':newest'; + } + @(return pathname kind); } /* @@ -416,334 +418,356 @@ cl_object cl_truename(cl_object orig_pathname) { - cl_object pathname = make_absolute_pathname(orig_pathname); - cl_object base_dir = make_base_pathname(pathname); - cl_object dir; - /* We process the directory part of the filename, removing all - * possible symlinks. To do so, we inspect recursively the - * directory which contains our file, and come back. We also have to - * ensure that the filename itself does not point to a symlink: if so, - * then we resolve the value of the symlink and continue traversing - * the filesystem. - */ - for (dir = pathname->pathname.directory; !Null(dir); dir = ECL_CONS_CDR(dir)) - { - base_dir = enter_directory(base_dir, ECL_CONS_CAR(dir), 0); - } - pathname = ecl_merge_pathnames(base_dir, pathname, @':default'); - @(return file_truename(pathname, ECL_NIL, FOLLOW_SYMLINKS)) + cl_object pathname = make_absolute_pathname(orig_pathname); + cl_object base_dir = make_base_pathname(pathname); + cl_object dir; + /* We process the directory part of the filename, removing all + * possible symlinks. To do so, we inspect recursively the + * directory which contains our file, and come back. We also have to + * ensure that the filename itself does not point to a symlink: if so, + * then we resolve the value of the symlink and continue traversing + * the filesystem. + */ + for (dir = pathname->pathname.directory; !Null(dir); dir = ECL_CONS_CDR(dir)) + { + base_dir = enter_directory(base_dir, ECL_CONS_CAR(dir), 0); + } + pathname = ecl_merge_pathnames(base_dir, pathname, @':default'); + @(return file_truename(pathname, ECL_NIL, FOLLOW_SYMLINKS)); } int ecl_backup_open(const char *filename, int option, int mode) { - char *backupfilename = ecl_alloc(strlen(filename) + 5); - if (backupfilename == NULL) { - FElibc_error("Cannot allocate memory for backup filename", 0); - } + char *backupfilename = ecl_alloc(strlen(filename) + 5); + if (backupfilename == NULL) { + FElibc_error("Cannot allocate memory for backup filename", 0); + } - strcat(strcpy(backupfilename, filename), ".BAK"); - ecl_disable_interrupts(); + strcat(strcpy(backupfilename, filename), ".BAK"); + ecl_disable_interrupts(); #if defined(ECL_MS_WINDOWS_HOST) - /* Windows' rename doesn't replace an existing file */ - if (access(backupfilename, F_OK) == 0 && unlink(backupfilename)) { - ecl_enable_interrupts(); - FElibc_error("Cannot remove the file ~S", 1, - ecl_make_constant_base_string(backupfilename,-1)); - } + /* Windows' rename doesn't replace an existing file */ + if (access(backupfilename, F_OK) == 0 && unlink(backupfilename)) { + ecl_enable_interrupts(); + FElibc_error("Cannot remove the file ~S", 1, + ecl_make_constant_base_string(backupfilename,-1)); + } #endif - if (rename(filename, backupfilename)) { - ecl_enable_interrupts(); - FElibc_error("Cannot rename the file ~S to ~S.", 2, - ecl_make_constant_base_string(filename,-1), - ecl_make_constant_base_string(backupfilename,-1)); - } - ecl_enable_interrupts(); - ecl_dealloc(backupfilename); - return open(filename, option, mode); + if (rename(filename, backupfilename)) { + ecl_enable_interrupts(); + FElibc_error("Cannot rename the file ~S to ~S.", 2, + ecl_make_constant_base_string(filename,-1), + ecl_make_constant_base_string(backupfilename,-1)); + } + ecl_enable_interrupts(); + ecl_dealloc(backupfilename); + return open(filename, option, mode); } cl_object ecl_file_len(int f) { - struct stat filestatus; - memset(&filestatus, 0, sizeof(filestatus)); - ecl_disable_interrupts(); - fstat(f, &filestatus); - ecl_enable_interrupts(); - return ecl_make_integer(filestatus.st_size); + struct stat filestatus; + memset(&filestatus, 0, sizeof(filestatus)); + ecl_disable_interrupts(); + fstat(f, &filestatus); + ecl_enable_interrupts(); + return ecl_make_integer(filestatus.st_size); } @(defun rename-file (oldn newn &key (if_exists @':error')) - cl_object old_filename, new_filename, old_truename, new_truename; - int error; -@ - - /* 1) Get the old filename, and complain if it has wild components, - * or if it does not exist. Notice that the filename to be renamed - * is not the truename, because we might be renaming a symbolic link. - */ - old_truename = cl_truename(oldn); - old_filename = coerce_to_posix_filename(old_truename); - - /* 2) Create the new file name. */ - newn = ecl_merge_pathnames(newn, oldn, @':newest'); - new_filename = si_coerce_to_filename(newn); - - while (if_exists == @':error' || if_exists == ECL_NIL) - { - if (cl_probe_file(new_filename) == ECL_NIL) { - if_exists = ECL_T; - break; - } - /* if the file already exists */ - if (if_exists == @':error') { - const char *msg = "When trying to rename ~S, ~S already exists"; - if_exists = - si_signal_simple_error - (6, @'file-error', /* condition */ - @':supersede', /* continuable */ - /* format */ - ecl_make_constant_base_string(msg,strlen(msg)), - cl_list(2, oldn, new_filename), /* format args */ - @':pathname', /* file-error options */ - new_filename); - if (if_exists == ECL_T) if_exists= @':error'; - } - if (if_exists == ECL_NIL) { - @(return ECL_NIL ECL_NIL ECL_NIL) - } - } - if (ecl_unlikely(if_exists != @':supersede' && if_exists != ECL_T)) { - /* invalid key */ - FEerror("~S is an illegal IF-EXISTS option for RENAME-FILE.", - 1, if_exists); - } - { - ecl_disable_interrupts(); + cl_object old_filename, new_filename, old_truename, new_truename; + int error; + @ + + /* 1) Get the old filename, and complain if it has wild components, + * or if it does not exist. Notice that the filename to be renamed + * is not the truename, because we might be renaming a symbolic link. + */ + old_truename = cl_truename(oldn); + old_filename = coerce_to_posix_filename(old_truename); + + /* 2) Create the new file name. */ + newn = ecl_merge_pathnames(newn, oldn, @':newest'); + new_filename = si_coerce_to_filename(newn); + + while (if_exists == @':error' || if_exists == ECL_NIL) + { + if (cl_probe_file(new_filename) == ECL_NIL) { + if_exists = ECL_T; + break; + } + /* if the file already exists */ + if (if_exists == @':error') { + const char *msg = "When trying to rename ~S, ~S already exists"; + if_exists = + si_signal_simple_error + (6, @'file-error', /* condition */ + @':supersede', /* continuable */ + /* format */ + ecl_make_constant_base_string(msg,strlen(msg)), + cl_list(2, oldn, new_filename), /* format args */ + @':pathname', /* file-error options */ + new_filename); + if (if_exists == ECL_T) if_exists= @':error'; + } + if (if_exists == ECL_NIL) { + @(return ECL_NIL ECL_NIL ECL_NIL); + } + } + if (ecl_unlikely(if_exists != @':supersede' && if_exists != ECL_T)) { + /* invalid key */ + FEerror("~S is an illegal IF-EXISTS option for RENAME-FILE.", + 1, if_exists); + } + { + ecl_disable_interrupts(); #if defined(ECL_MS_WINDOWS_HOST) - error = SetErrorMode(0); - if (MoveFile((char*)old_filename->base_string.self, - (char*)new_filename->base_string.self)) { - SetErrorMode(error); - goto SUCCESS; - } - switch (GetLastError()) { - case ERROR_ALREADY_EXISTS: - case ERROR_FILE_EXISTS: - break; - default: - goto FAILURE_CLOBBER; - }; - if (MoveFileEx((char*)old_filename->base_string.self, - (char*)new_filename->base_string.self, - MOVEFILE_REPLACE_EXISTING)) { - SetErrorMode(error); - goto SUCCESS; - } - /* hack for win95/novell */ - chmod((char*)old_filename->base_string.self, 0777); - chmod((char*)new_filename->base_string.self, 0777); - SetFileAttributesA((char*)new_filename->base_string.self, - FILE_ATTRIBUTE_NORMAL); - SetFileAttributesA((char*)new_filename->base_string.self, - FILE_ATTRIBUTE_TEMPORARY); - if (MoveFile((char*)old_filename->base_string.self, - (char*)new_filename->base_string.self)) { - SetErrorMode(error); - goto SUCCESS; - } - /* fallback on old behavior */ - (void)DeleteFileA((char*)new_filename->base_string.self); - if (MoveFile((char*)old_filename->base_string.self, - (char*)new_filename->base_string.self)) { - SetErrorMode(error); - goto SUCCESS; - } - /* fall through */ + error = SetErrorMode(0); + if (MoveFile((char*)old_filename->base_string.self, + (char*)new_filename->base_string.self)) { + SetErrorMode(error); + goto SUCCESS; + } + switch (GetLastError()) { + case ERROR_ALREADY_EXISTS: + case ERROR_FILE_EXISTS: + break; + default: + goto FAILURE_CLOBBER; + }; + if (MoveFileEx((char*)old_filename->base_string.self, + (char*)new_filename->base_string.self, + MOVEFILE_REPLACE_EXISTING)) { + SetErrorMode(error); + goto SUCCESS; + } + /* hack for win95/novell */ + chmod((char*)old_filename->base_string.self, 0777); + chmod((char*)new_filename->base_string.self, 0777); + SetFileAttributesA((char*)new_filename->base_string.self, + FILE_ATTRIBUTE_NORMAL); + SetFileAttributesA((char*)new_filename->base_string.self, + FILE_ATTRIBUTE_TEMPORARY); + if (MoveFile((char*)old_filename->base_string.self, + (char*)new_filename->base_string.self)) { + SetErrorMode(error); + goto SUCCESS; + } + /* fallback on old behavior */ + (void)DeleteFileA((char*)new_filename->base_string.self); + if (MoveFile((char*)old_filename->base_string.self, + (char*)new_filename->base_string.self)) { + SetErrorMode(error); + goto SUCCESS; + } + /* fall through */ #else - if (rename((char*)old_filename->base_string.self, - (char*)new_filename->base_string.self) == 0) { - goto SUCCESS; - } + if (rename((char*)old_filename->base_string.self, + (char*)new_filename->base_string.self) == 0) { + goto SUCCESS; + } #endif - } -FAILURE_CLOBBER: - ecl_enable_interrupts(); - { - cl_object c_error = _ecl_strerror(errno); - const char *msg = "Unable to rename file ~S to ~S.~%C library error: ~S"; - si_signal_simple_error - (6, @'file-error', /* condition */ - ECL_NIL, /* continuable */ - ecl_make_constant_base_string(msg,strlen(msg)), /* format */ - cl_list(3, oldn, newn, c_error), /* format args */ - @':pathname', /* file-error options */ - oldn); - } - -SUCCESS: - ecl_enable_interrupts(); - new_truename = cl_truename(newn); - @(return newn old_truename new_truename) -@) + } + FAILURE_CLOBBER: + ecl_enable_interrupts(); + { + cl_object c_error = _ecl_strerror(errno); + const char *msg = "Unable to rename file ~S to ~S.~%C library error: ~S"; + si_signal_simple_error + (6, @'file-error', /* condition */ + ECL_NIL, /* continuable */ + ecl_make_constant_base_string(msg,strlen(msg)), /* format */ + cl_list(3, oldn, newn, c_error), /* format args */ + @':pathname', /* file-error options */ + oldn); + } + + SUCCESS: + ecl_enable_interrupts(); + new_truename = cl_truename(newn); + @(return newn old_truename new_truename); + @) static int directory_pathname_p(cl_object path) { - return (path->pathname.name == ECL_NIL) && - (path->pathname.type == ECL_NIL); + return (path->pathname.name == ECL_NIL) && + (path->pathname.type == ECL_NIL); } cl_object cl_delete_file(cl_object file) { - cl_object path = cl_pathname(file); - int isdir = directory_pathname_p(path); - cl_object filename = coerce_to_posix_filename(path); - int ok, code; - - ecl_disable_interrupts(); - ok = (isdir? rmdir : unlink)((char*)filename->base_string.self); - ecl_enable_interrupts(); - - if (ok < 0) { - const char *msg = - isdir? - "Cannot delete the directory ~S.~%C library error: ~S" : - "Cannot delete the file ~S.~%C library error: ~S"; - cl_object c_error = _ecl_strerror(errno); - si_signal_simple_error - (6, @'file-error', /* condition */ - ECL_T, /* continuable */ - ecl_make_constant_base_string(msg,strlen(msg)), /* format */ - cl_list(2, file, c_error), /* format args */ - @':pathname', /* file-error options */ - file); - } - @(return ECL_T) + cl_object path = cl_pathname(file); + int isdir = directory_pathname_p(path); + cl_object filename = coerce_to_posix_filename(path); + int ok, code; + + ecl_disable_interrupts(); + ok = (isdir? rmdir : unlink)((char*)filename->base_string.self); + ecl_enable_interrupts(); + + if (ok < 0) { + const char *msg = + isdir? + "Cannot delete the directory ~S.~%C library error: ~S" : + "Cannot delete the file ~S.~%C library error: ~S"; + cl_object c_error = _ecl_strerror(errno); + si_signal_simple_error + (6, @'file-error', /* condition */ + ECL_T, /* continuable */ + ecl_make_constant_base_string(msg,strlen(msg)), /* format */ + cl_list(2, file, c_error), /* format args */ + @':pathname', /* file-error options */ + file); + } + @(return ECL_T); } cl_object cl_probe_file(cl_object file) { - /* INV: Both SI:FILE-KIND and TRUENAME complain if "file" has wildcards */ - @(return (si_file_kind(file, ECL_T) != ECL_NIL? cl_truename(file) : ECL_NIL)) + /* INV: Both SI:FILE-KIND and TRUENAME complain if "file" has wildcards */ + @(return (si_file_kind(file, ECL_T) != ECL_NIL? cl_truename(file) : ECL_NIL)); } cl_object cl_file_write_date(cl_object file) { - cl_object time, filename = coerce_to_posix_filename(file); - struct stat filestatus; - if (safe_stat((char*)filename->base_string.self, &filestatus) < 0) { - time = ECL_NIL; - } else { - time = UTC_time_to_universal_time(filestatus.st_mtime); - } - @(return time) + cl_object time, filename = coerce_to_posix_filename(file); + struct stat filestatus; + if (safe_stat((char*)filename->base_string.self, &filestatus) < 0) { + time = ECL_NIL; + } else { + time = UTC_time_to_universal_time(filestatus.st_mtime); + } + @(return time); } cl_object cl_file_author(cl_object file) { - cl_object output, filename = coerce_to_posix_filename(file); - struct stat filestatus; - if (safe_stat((char*)filename->base_string.self, &filestatus) < 0) { - const char *msg = "Unable to read file author for ~S." - "~%C library error: ~S"; - cl_object c_error = _ecl_strerror(errno); - si_signal_simple_error - (6, @'file-error', /* condition */ - ECL_T, /* continuable */ - ecl_make_constant_base_string(msg,strlen(msg)), /* format */ - cl_list(2, file, c_error), /* format args */ - @':pathname', /* file-error options */ - file); - } + cl_object output, filename = coerce_to_posix_filename(file); + struct stat filestatus; + if (safe_stat((char*)filename->base_string.self, &filestatus) < 0) { + const char *msg = "Unable to read file author for ~S." + "~%C library error: ~S"; + cl_object c_error = _ecl_strerror(errno); + si_signal_simple_error + (6, @'file-error', /* condition */ + ECL_T, /* continuable */ + ecl_make_constant_base_string(msg,strlen(msg)), /* format */ + cl_list(2, file, c_error), /* format args */ + @':pathname', /* file-error options */ + file); + } #ifdef HAVE_PWD_H - { - struct passwd *pwent; - ecl_disable_interrupts(); - pwent = getpwuid(filestatus.st_uid); - ecl_enable_interrupts(); - output = make_base_string_copy(pwent->pw_name); - } + { + struct passwd *pwent; + ecl_disable_interrupts(); + pwent = getpwuid(filestatus.st_uid); + ecl_enable_interrupts(); + output = make_base_string_copy(pwent->pw_name); + } #else - output = make_constant_base_string("UNKNOWN"); + output = make_constant_base_string("UNKNOWN"); #endif - @(return output) + @(return output); } cl_object ecl_homedir_pathname(cl_object user) { - cl_index i; - cl_object namestring; - const char *h, *d; - if (!Null(user)) { + cl_index i; + cl_object namestring; + const char *h, *d; + if (!Null(user)) { #ifdef HAVE_PWD_H - struct passwd *pwent = NULL; + struct passwd *pwent = NULL; #endif - char *p; - /* This ensures that our string has the right length - and it is terminated with a '\0' */ - user = si_copy_to_simple_base_string(user); - p = (char*)user->base_string.self; - i = user->base_string.fillp; - if (i > 0 && *p == '~') { - p++; - i--; - } - if (i == 0) - return ecl_homedir_pathname(ECL_NIL); + char *p; + /* This ensures that our string has the right length + and it is terminated with a '\0' */ + user = si_copy_to_simple_base_string(user); + p = (char*)user->base_string.self; + i = user->base_string.fillp; + if (i > 0 && *p == '~') { + p++; + i--; + } + if (i == 0) + return ecl_homedir_pathname(ECL_NIL); #ifdef HAVE_PWD_H - pwent = getpwnam(p); - if (pwent == NULL) - FEerror("Unknown user ~S.", 1, p); - namestring = make_base_string_copy(pwent->pw_dir); + pwent = getpwnam(p); + if (pwent == NULL) + FEerror("Unknown user ~S.", 1, p); + namestring = make_base_string_copy(pwent->pw_dir); #endif - FEerror("Unknown user ~S.", 1, p); - } else if ((h = getenv("HOME"))) { - namestring = make_base_string_copy(h); + FEerror("Unknown user ~S.", 1, p); + } else if ((h = getenv("HOME"))) { + namestring = make_base_string_copy(h); #if defined(ECL_MS_WINDOWS_HOST) - } else if ((h = getenv("HOMEPATH")) && (d = getenv("HOMEDRIVE"))) { - namestring = - si_base_string_concatenate(2, - make_constant_base_string(d), - make_constant_base_string(h)); + } else if ((h = getenv("HOMEPATH")) && (d = getenv("HOMEDRIVE"))) { + namestring = + si_base_string_concatenate(2, + make_constant_base_string(d), + make_constant_base_string(h)); #endif - } else { - namestring = make_constant_base_string("/"); - } - if (namestring->base_string.self[0] == '~') { - FEerror("Not a valid home pathname ~S", 1, namestring); - } - i = namestring->base_string.fillp; - if (!IS_DIR_SEPARATOR(namestring->base_string.self[i-1])) - namestring = si_base_string_concatenate(2, namestring, - ECL_CODE_CHAR(DIR_SEPARATOR)); - return cl_parse_namestring(3, namestring, ECL_NIL, ECL_NIL); + } else { + namestring = make_constant_base_string("/"); + } + if (namestring->base_string.self[0] == '~') { + FEerror("Not a valid home pathname ~S", 1, namestring); + } + i = namestring->base_string.fillp; + if (!IS_DIR_SEPARATOR(namestring->base_string.self[i-1])) + namestring = si_base_string_concatenate(2, namestring, + ECL_CODE_CHAR(DIR_SEPARATOR)); + return cl_parse_namestring(3, namestring, ECL_NIL, ECL_NIL); } @(defun user_homedir_pathname (&optional host) -@ - /* Ignore optional host argument. */ - @(return ecl_homedir_pathname(ECL_NIL)); -@) + @ + /* Ignore optional host argument. */ + @(return ecl_homedir_pathname(ECL_NIL)); + @) static bool string_match(const char *s, cl_object pattern) { - if (pattern == ECL_NIL || pattern == @':wild') { - return 1; - } else { - cl_index ls = strlen(s); - ecl_def_ct_base_string(strng, s, ls, /*auto*/, const); - return ecl_string_match(strng, 0, ls, - pattern, 0, ecl_length(pattern)); - } -} + if (pattern == ECL_NIL || pattern == @':wild') { + return 1; + } else { + cl_index ls = strlen(s); + ecl_def_ct_base_string(strng, s, ls, /*auto*/, const); + return ecl_string_match(strng, 0, ls, + pattern, 0, ecl_length(pattern)); + } +} + +/*XXX:*/ +#define PARSE_DIRECTORY_ENTRY \ + { \ + cl_object component, component_path, kind; \ + if (text[0] == '.' && \ + (text[1] == '\0' || \ + (text[1] == '.' && text[2] == '\0'))) \ + continue; \ + if (!string_match(text, text_mask)) \ + continue; \ + component = make_constant_base_string(text); \ + component = si_base_string_concatenate(2, prefix, component); \ + component_path = cl_pathname(component); \ + if (!Null(pathname_mask)) { \ + if (Null(cl_pathname_match_p(component, pathname_mask))) \ + continue; \ + } \ + component_path = file_truename(component_path, component, flags); \ + kind = ecl_nth_value(the_env, 1); \ + out = CONS(CONS(component_path, kind), out); \ + } /* * list_current_directory() lists the files and directories which are contained @@ -755,98 +779,87 @@ list_directory(cl_object base_dir, cl_object text_mask, cl_object pathname_mask, int flags) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object out = ECL_NIL; - cl_object prefix = ecl_namestring(base_dir, ECL_NAMESTRING_FORCE_BASE_STRING); - cl_object component, component_path, kind; - char *text; -#if defined(HAVE_DIRENT_H) - DIR *dir; - struct dirent *entry; + const cl_env_ptr the_env = ecl_process_env(); + cl_object out = ECL_NIL; + cl_object prefix = ecl_namestring(base_dir, ECL_NAMESTRING_FORCE_BASE_STRING); - ecl_disable_interrupts(); - dir = opendir((char*)prefix->base_string.self); - if (dir == NULL) { - out = ECL_NIL; - goto OUTPUT; - } + char *text; +#if defined(HAVE_DIRENT_H) + DIR *dir; + struct dirent *entry; - while ((entry = readdir(dir))) { - text = entry->d_name; + ecl_disable_interrupts(); + dir = opendir((char*)prefix->base_string.self); + if (dir == NULL) { + out = ECL_NIL; + goto OUTPUT; + } + + while ((entry = readdir(dir))) { + text = entry->d_name; + PARSE_DIRECTORY_ENTRY; + } + closedir(dir); #else # ifdef ECL_MS_WINDOWS_HOST - WIN32_FIND_DATA fd; - HANDLE hFind = NULL; - BOOL found = FALSE; - - ecl_disable_interrupts(); - for (;;) { - if (hFind == NULL) { - cl_object aux = make_constant_base_string(".\\*"); - cl_object mask = si_base_string_concatenate(2, prefix, aux); - hFind = FindFirstFile((char*)mask->base_string.self, &fd); - if (hFind == INVALID_HANDLE_VALUE) { - out = ECL_NIL; - goto OUTPUT; - } - found = TRUE; - } else { - found = FindNextFile(hFind, &fd); - } - if (!found) - break; - text = fd.cFileName; + WIN32_FIND_DATA fd; + HANDLE hFind = NULL; + BOOL found = FALSE; + + ecl_disable_interrupts(); + for (;;) { + if (hFind == NULL) { + cl_object aux = make_constant_base_string(".\\*"); + cl_object mask = si_base_string_concatenate(2, prefix, aux); + hFind = FindFirstFile((char*)mask->base_string.self, &fd); + if (hFind == INVALID_HANDLE_VALUE) { + out = ECL_NIL; + goto OUTPUT; + } + found = TRUE; + } else { + found = FindNextFile(hFind, &fd); + } + + if (!found) + break; + + text = fd.cFileName; + PARSE_DIRECTORY_ENTRY; + } + FindClose(hFind); # else /* sys/dir.h as in SYSV */ - FILE *fp; - char iobuffer[BUFSIZ]; - DIRECTORY dir; - - ecl_disable_interrupts(); - fp = fopen((char*)prefix->base_string.self, OPEN_R); - if (fp == NULL) { - out = ECL_NIL; - goto OUTPUT; - } - setbuf(fp, iobuffer); - for (;;) { - if (fread(&dir, sizeof(DIRECTORY), 1, fp) <= 0) - break; - if (dir.d_ino == 0) - continue; - text = dir.d_name; + FILE *fp; + char iobuffer[BUFSIZ]; + DIRECTORY dir; + + ecl_disable_interrupts(); + fp = fopen((char*)prefix->base_string.self, OPEN_R); + if (fp == NULL) { + out = ECL_NIL; + goto OUTPUT; + } + setbuf(fp, iobuffer); + for (;;) { + if (fread(&dir, sizeof(DIRECTORY), 1, fp) <= 0) + break; + if (dir.d_ino == 0) + continue; + + text=dir.d_name; + PARSE_DIRECTORY_ENTRY; + } + fclose(fp); # endif /* !ECL_MS_WINDOWS_HOST */ #endif /* !HAVE_DIRENT_H */ - if (text[0] == '.' && - (text[1] == '\0' || - (text[1] == '.' && text[2] == '\0'))) - continue; - if (!string_match(text, text_mask)) - continue; - component = make_constant_base_string(text); - component = si_base_string_concatenate(2, prefix, component); - component_path = cl_pathname(component); - if (!Null(pathname_mask)) { - if (Null(cl_pathname_match_p(component, pathname_mask))) - continue; - } - component_path = file_truename(component_path, component, flags); - kind = ecl_nth_value(the_env, 1); - out = CONS(CONS(component_path, kind), out); - } -#ifdef HAVE_DIRENT_H - closedir(dir); -#else -# ifdef ECL_MS_WINDOWS_HOST - FindClose(hFind); -# else - fclose(fp); -# endif /* !ECL_MS_WINDOWS_HOST */ -#endif /* !HAVE_DIRENT_H */ - ecl_enable_interrupts(); -OUTPUT: - return cl_nreverse(out); + + ecl_enable_interrupts(); + OUTPUT: + return cl_nreverse(out); } +#undef PARSE_DIRECTORY_ENTRY + /* * dir_files() lists all files which are contained in the current directory and * which match the masks in PATHNAME. This routine is essentially a wrapper for @@ -857,28 +870,28 @@ static cl_object dir_files(cl_object base_dir, cl_object pathname, int flags) { - cl_object all_files, output = ECL_NIL; - cl_object mask; - cl_object name = pathname->pathname.name; - cl_object type = pathname->pathname.type; - if (name == ECL_NIL && type == ECL_NIL) { - return cl_list(1, base_dir); - } - mask = ecl_make_pathname(ECL_NIL, ECL_NIL, ECL_NIL, - name, type, pathname->pathname.version, - @':local'); - for (all_files = list_directory(base_dir, ECL_NIL, mask, flags); - !Null(all_files); - all_files = ECL_CONS_CDR(all_files)) - { - cl_object record = ECL_CONS_CAR(all_files); - cl_object new = ECL_CONS_CAR(record); - cl_object kind = ECL_CONS_CDR(record); - if (kind != @':directory') { - output = CONS(new, output); - } - } - return output; + cl_object all_files, output = ECL_NIL; + cl_object mask; + cl_object name = pathname->pathname.name; + cl_object type = pathname->pathname.type; + if (name == ECL_NIL && type == ECL_NIL) { + return cl_list(1, base_dir); + } + mask = ecl_make_pathname(ECL_NIL, ECL_NIL, ECL_NIL, + name, type, pathname->pathname.version, + @':local'); + for (all_files = list_directory(base_dir, ECL_NIL, mask, flags); + !Null(all_files); + all_files = ECL_CONS_CDR(all_files)) + { + cl_object record = ECL_CONS_CAR(all_files); + cl_object new = ECL_CONS_CAR(record); + cl_object kind = ECL_CONS_CDR(record); + if (kind != @':directory') { + output = CONS(new, output); + } + } + return output; } /* @@ -890,356 +903,356 @@ static cl_object dir_recursive(cl_object base_dir, cl_object directory, cl_object filemask, int flags) { - cl_object item, output = ECL_NIL; + cl_object item, output = ECL_NIL; AGAIN: - /* There are several possibilities here: - * - * 1) The list of subdirectories DIRECTORY is empty, and only PATHNAME - * remains to be inspected. If there is no file name or type, then - * we simply output the truename of the current directory. Otherwise - * we have to find a file which corresponds to the description. - */ - if (directory == ECL_NIL) { - return ecl_nconc(dir_files(base_dir, filemask, flags), output); - } - /* - * 2) We have not yet exhausted the DIRECTORY component of the - * pathname. We have to enter some subdirectory, determined by - * CAR(DIRECTORY) and scan it. - */ - item = ECL_CONS_CAR(directory); - - if (item == @':wild' || ecl_wild_string_p(item)) { - /* - * 2.1) If CAR(DIRECTORY) is a string or :WILD, we have to - * enter & scan all subdirectories in our curent directory. - */ - cl_object next_dir = list_directory(base_dir, item, ECL_NIL, flags); - for (; !Null(next_dir); next_dir = ECL_CONS_CDR(next_dir)) { - cl_object record = ECL_CONS_CAR(next_dir); - cl_object component = ECL_CONS_CAR(record); - cl_object kind = ECL_CONS_CDR(record); - if (kind != @':directory') - continue; - item = dir_recursive(cl_pathname(component), - ECL_CONS_CDR(directory), - filemask, flags); - output = ecl_nconc(item, output); - } - } else if (item == @':wild-inferiors') { - /* - * 2.2) If CAR(DIRECTORY) is :WILD-INFERIORS, we have to do - * scan all subdirectories from _all_ levels, looking for a - * tree that matches the remaining part of DIRECTORY. - */ - cl_object next_dir = list_directory(base_dir, ECL_NIL, ECL_NIL, flags); - for (; !Null(next_dir); next_dir = ECL_CONS_CDR(next_dir)) { - cl_object record = ECL_CONS_CAR(next_dir); - cl_object component = ECL_CONS_CAR(record); - cl_object kind = ECL_CONS_CDR(record); - if (kind != @':directory') - continue; - item = dir_recursive(cl_pathname(component), - directory, filemask, flags); - output = ecl_nconc(item, output); - } - directory = ECL_CONS_CDR(directory); - goto AGAIN; - } else { /* :ABSOLUTE, :RELATIVE, :UP, component without wildcards */ - /* - * 2.2) If CAR(DIRECTORY) is :ABSOLUTE, :RELATIVE or :UP we update - * the directory to reflect the root, the current or the parent one. - */ - base_dir = enter_directory(base_dir, item, 1); - /* - * If enter_directory() fails, we simply ignore this path. This is - * what other implementations do and is consistent with the behavior - * for the file part. - */ - if (Null(base_dir)) - return ECL_NIL; - directory = ECL_CONS_CDR(directory); - goto AGAIN; - } - return output; + /* There are several possibilities here: + * + * 1) The list of subdirectories DIRECTORY is empty, and only PATHNAME + * remains to be inspected. If there is no file name or type, then + * we simply output the truename of the current directory. Otherwise + * we have to find a file which corresponds to the description. + */ + if (directory == ECL_NIL) { + return ecl_nconc(dir_files(base_dir, filemask, flags), output); + } + /* + * 2) We have not yet exhausted the DIRECTORY component of the + * pathname. We have to enter some subdirectory, determined by + * CAR(DIRECTORY) and scan it. + */ + item = ECL_CONS_CAR(directory); + + if (item == @':wild' || ecl_wild_string_p(item)) { + /* + * 2.1) If CAR(DIRECTORY) is a string or :WILD, we have to + * enter & scan all subdirectories in our curent directory. + */ + cl_object next_dir = list_directory(base_dir, item, ECL_NIL, flags); + for (; !Null(next_dir); next_dir = ECL_CONS_CDR(next_dir)) { + cl_object record = ECL_CONS_CAR(next_dir); + cl_object component = ECL_CONS_CAR(record); + cl_object kind = ECL_CONS_CDR(record); + if (kind != @':directory') + continue; + item = dir_recursive(cl_pathname(component), + ECL_CONS_CDR(directory), + filemask, flags); + output = ecl_nconc(item, output); + } + } else if (item == @':wild-inferiors') { + /* + * 2.2) If CAR(DIRECTORY) is :WILD-INFERIORS, we have to do + * scan all subdirectories from _all_ levels, looking for a + * tree that matches the remaining part of DIRECTORY. + */ + cl_object next_dir = list_directory(base_dir, ECL_NIL, ECL_NIL, flags); + for (; !Null(next_dir); next_dir = ECL_CONS_CDR(next_dir)) { + cl_object record = ECL_CONS_CAR(next_dir); + cl_object component = ECL_CONS_CAR(record); + cl_object kind = ECL_CONS_CDR(record); + if (kind != @':directory') + continue; + item = dir_recursive(cl_pathname(component), + directory, filemask, flags); + output = ecl_nconc(item, output); + } + directory = ECL_CONS_CDR(directory); + goto AGAIN; + } else { /* :ABSOLUTE, :RELATIVE, :UP, component without wildcards */ + /* + * 2.2) If CAR(DIRECTORY) is :ABSOLUTE, :RELATIVE or :UP we update + * the directory to reflect the root, the current or the parent one. + */ + base_dir = enter_directory(base_dir, item, 1); + /* + * If enter_directory() fails, we simply ignore this path. This is + * what other implementations do and is consistent with the behavior + * for the file part. + */ + if (Null(base_dir)) + return ECL_NIL; + directory = ECL_CONS_CDR(directory); + goto AGAIN; + } + return output; } @(defun directory (mask &key (resolve_symlinks ECL_T) &allow_other_keys) - cl_object base_dir; - cl_object output; -@ - mask = coerce_to_file_pathname(mask); - mask = make_absolute_pathname(mask); - base_dir = make_base_pathname(mask); - output = dir_recursive(base_dir, mask->pathname.directory, mask, - Null(resolve_symlinks)? 0 : FOLLOW_SYMLINKS); - @(return output) -@) + cl_object base_dir; + cl_object output; + @ + mask = coerce_to_file_pathname(mask); + mask = make_absolute_pathname(mask); + base_dir = make_base_pathname(mask); + output = dir_recursive(base_dir, mask->pathname.directory, mask, + Null(resolve_symlinks)? 0 : FOLLOW_SYMLINKS); + @(return output); + @) @(defun ext::getcwd (&optional (change_d_p_d ECL_NIL)) - cl_object output; -@ - output = cl_parse_namestring(3, current_dir(), ECL_NIL, ECL_NIL); - if (!Null(change_d_p_d)) { - ECL_SETQ(the_env, @'*default-pathname-defaults*', output); - } - @(return output) -@) + cl_object output; + @ + output = cl_parse_namestring(3, current_dir(), ECL_NIL, ECL_NIL); + if (!Null(change_d_p_d)) { + ECL_SETQ(the_env, @'*default-pathname-defaults*', output); + } + @(return output); + @) cl_object si_get_library_pathname(void) { - cl_object s = cl_core.library_pathname; - if (!Null(s)) { - goto OUTPUT_UNCHANGED; - } else { - const char *v = getenv("ECLDIR"); - if (v) { - s = make_constant_base_string(v); - goto OUTPUT; - } - } + cl_object s = cl_core.library_pathname; + if (!Null(s)) { + goto OUTPUT_UNCHANGED; + } else { + const char *v = getenv("ECLDIR"); + if (v) { + s = make_constant_base_string(v); + goto OUTPUT; + } + } #if defined(ECL_MS_WINDOWS_HOST) - { - char *buffer; - HMODULE hnd; - cl_index len, ep; - s = ecl_alloc_adjustable_base_string(cl_core.path_max); - buffer = (char*)s->base_string.self; - ecl_disable_interrupts(); - hnd = GetModuleHandle("ecl.dll"); - len = GetModuleFileName(hnd, buffer, cl_core.path_max-1); - ecl_enable_interrupts(); - if (len == 0) { - FEerror("GetModuleFileName failed (last error = ~S)", - 1, ecl_make_fixnum(GetLastError())); - } - s->base_string.fillp = len; - /* GetModuleFileName returns a file name. We have to strip - * the directory component. */ - s = cl_make_pathname(8, @':name', ECL_NIL, @':type', ECL_NIL, - @':version', ECL_NIL, - @':defaults', s); - s = ecl_namestring(s, ECL_NAMESTRING_FORCE_BASE_STRING); - } + { + char *buffer; + HMODULE hnd; + cl_index len, ep; + s = ecl_alloc_adjustable_base_string(cl_core.path_max); + buffer = (char*)s->base_string.self; + ecl_disable_interrupts(); + hnd = GetModuleHandle("ecl.dll"); + len = GetModuleFileName(hnd, buffer, cl_core.path_max-1); + ecl_enable_interrupts(); + if (len == 0) { + FEerror("GetModuleFileName failed (last error = ~S)", + 1, ecl_make_fixnum(GetLastError())); + } + s->base_string.fillp = len; + /* GetModuleFileName returns a file name. We have to strip + * the directory component. */ + s = cl_make_pathname(8, @':name', ECL_NIL, @':type', ECL_NIL, + @':version', ECL_NIL, + @':defaults', s); + s = ecl_namestring(s, ECL_NAMESTRING_FORCE_BASE_STRING); + } #else - s = make_constant_base_string(ECLDIR "/"); + s = make_constant_base_string(ECLDIR "/"); #endif OUTPUT: - { - cl_object true_pathname = cl_probe_file(s); - if (Null(true_pathname)) { - s = current_dir(); - } else { - /* Produce a string */ - s = ecl_namestring(s, ECL_NAMESTRING_FORCE_BASE_STRING); - } - } - cl_core.library_pathname = s; + { + cl_object true_pathname = cl_probe_file(s); + if (Null(true_pathname)) { + s = current_dir(); + } else { + /* Produce a string */ + s = ecl_namestring(s, ECL_NAMESTRING_FORCE_BASE_STRING); + } + } + cl_core.library_pathname = s; OUTPUT_UNCHANGED: - @(return s); + @(return s); } @(defun ext::chdir (directory &optional (change_d_p_d ECL_T)) - cl_object previous = si_getcwd(0); - cl_object namestring; -@ - /* This will fail if the new directory does not exist */ - directory = cl_truename(directory); - if (directory->pathname.name != ECL_NIL || - directory->pathname.type != ECL_NIL) - FEerror("~A is not a directory pathname.", 1, directory); - namestring = ecl_namestring(directory, - ECL_NAMESTRING_TRUNCATE_IF_ERROR | - ECL_NAMESTRING_FORCE_BASE_STRING); - if (safe_chdir((char*)namestring->base_string.self, ECL_NIL) < 0) { - cl_object c_error = _ecl_strerror(errno); - const char *msg = "Can't change the current directory to ~A." - "~%C library error: ~S"; - si_signal_simple_error - (6, @'file-error', /* condition */ - ECL_T, /* continuable */ - /* format */ - ecl_make_constant_base_string(msg,strlen(msg)), - cl_list(2, directory, c_error), /* format args */ - @':pathname', /* file-error options */ - directory); - } else if (change_d_p_d != ECL_NIL) { - ECL_SETQ(the_env, @'*default-pathname-defaults*', directory); - } - @(return previous) -@) + cl_object previous = si_getcwd(0); + cl_object namestring; + @ + /* This will fail if the new directory does not exist */ + directory = cl_truename(directory); + if (directory->pathname.name != ECL_NIL || + directory->pathname.type != ECL_NIL) + FEerror("~A is not a directory pathname.", 1, directory); + namestring = ecl_namestring(directory, + ECL_NAMESTRING_TRUNCATE_IF_ERROR | + ECL_NAMESTRING_FORCE_BASE_STRING); + if (safe_chdir((char*)namestring->base_string.self, ECL_NIL) < 0) { + cl_object c_error = _ecl_strerror(errno); + const char *msg = "Can't change the current directory to ~A." + "~%C library error: ~S"; + si_signal_simple_error + (6, @'file-error', /* condition */ + ECL_T, /* continuable */ + /* format */ + ecl_make_constant_base_string(msg,strlen(msg)), + cl_list(2, directory, c_error), /* format args */ + @':pathname', /* file-error options */ + directory); + } else if (change_d_p_d != ECL_NIL) { + ECL_SETQ(the_env, @'*default-pathname-defaults*', directory); + } + @(return previous); + @) cl_object si_mkdir(cl_object directory, cl_object mode) { - int modeint, ok; - cl_object filename = si_coerce_to_base_string(directory); + int modeint, ok; + cl_object filename = si_coerce_to_base_string(directory); - if (ecl_unlikely(!ECL_FIXNUMP(mode) || - ecl_fixnum_minusp(mode) || - ecl_fixnum_greater(mode, ecl_make_fixnum(0777)))) { - FEwrong_type_nth_arg(@[si::mkdir], 2, mode, - ecl_make_integer_type(ecl_make_fixnum(0), - ecl_make_fixnum(0777))); - } - modeint = ecl_fixnum(mode); - { - /* Ensure a clean string, without trailing slashes, - * and null terminated. */ - cl_index last = filename->base_string.fillp; - if (last > 1) { - ecl_character c = filename->base_string.self[last-1]; - if (IS_DIR_SEPARATOR(c)) - last--; - } - filename = ecl_subseq(filename, 0, last); - } - ecl_disable_interrupts(); + if (ecl_unlikely(!ECL_FIXNUMP(mode) || + ecl_fixnum_minusp(mode) || + ecl_fixnum_greater(mode, ecl_make_fixnum(0777)))) { + FEwrong_type_nth_arg(@[si::mkdir], 2, mode, + ecl_make_integer_type(ecl_make_fixnum(0), + ecl_make_fixnum(0777))); + } + modeint = ecl_fixnum(mode); + { + /* Ensure a clean string, without trailing slashes, + * and null terminated. */ + cl_index last = filename->base_string.fillp; + if (last > 1) { + ecl_character c = filename->base_string.self[last-1]; + if (IS_DIR_SEPARATOR(c)) + last--; + } + filename = ecl_subseq(filename, 0, last); + } + ecl_disable_interrupts(); #if defined(ECL_MS_WINDOWS_HOST) - ok = mkdir((char*)filename->base_string.self); + ok = mkdir((char*)filename->base_string.self); #else - ok = mkdir((char*)filename->base_string.self, modeint); + ok = mkdir((char*)filename->base_string.self, modeint); #endif - ecl_enable_interrupts(); + ecl_enable_interrupts(); - if (ecl_unlikely(ok < 0)) { - cl_object c_error = _ecl_strerror(errno); - const char *msg = "Could not create directory ~S" - "~%C library error: ~S"; - si_signal_simple_error - (6, @'file-error', /* condition */ - ECL_T, /* continuable */ - /* format */ - ecl_make_constant_base_string(msg,strlen(msg)), - cl_list(2, filename, c_error), /* format args */ - @':pathname', /* file-error options */ - filename); - } - @(return filename) + if (ecl_unlikely(ok < 0)) { + cl_object c_error = _ecl_strerror(errno); + const char *msg = "Could not create directory ~S" + "~%C library error: ~S"; + si_signal_simple_error + (6, @'file-error', /* condition */ + ECL_T, /* continuable */ + /* format */ + ecl_make_constant_base_string(msg,strlen(msg)), + cl_list(2, filename, c_error), /* format args */ + @':pathname', /* file-error options */ + filename); + } + @(return filename); } cl_object si_mkstemp(cl_object template) { - cl_object output; - cl_index l; - int fd; + cl_object output; + cl_index l; + int fd; #if defined(ECL_MS_WINDOWS_HOST) - cl_object phys, dir, file; - char strTempDir[MAX_PATH]; - char strTempFileName[MAX_PATH]; - char *s; - int ok; - - phys = cl_translate_logical_pathname(1, template); - dir = cl_make_pathname(8, - @':type', ECL_NIL, - @':name', ECL_NIL, - @':version', ECL_NIL, - @':defaults', phys); - dir = si_coerce_to_filename(dir); - file = cl_file_namestring(phys); + cl_object phys, dir, file; + char strTempDir[MAX_PATH]; + char strTempFileName[MAX_PATH]; + char *s; + int ok; + + phys = cl_translate_logical_pathname(1, template); + dir = cl_make_pathname(8, + @':type', ECL_NIL, + @':name', ECL_NIL, + @':version', ECL_NIL, + @':defaults', phys); + dir = si_coerce_to_filename(dir); + file = cl_file_namestring(phys); - l = dir->base_string.fillp; - memcpy(strTempDir, dir->base_string.self, l); - strTempDir[l] = 0; - for (s = strTempDir; *s; s++) - if (*s == '/') - *s = '\\'; - - ecl_disable_interrupts(); - ok = GetTempFileName(strTempDir, (char*)file->base_string.self, 0, - strTempFileName); - ecl_enable_interrupts(); - if (!ok) { - output = ECL_NIL; - } else { - l = strlen(strTempFileName); - output = ecl_alloc_simple_base_string(l); - memcpy(output->base_string.self, strTempFileName, l); - } + l = dir->base_string.fillp; + memcpy(strTempDir, dir->base_string.self, l); + strTempDir[l] = 0; + for (s = strTempDir; *s; s++) + if (*s == '/') + *s = '\\'; + + ecl_disable_interrupts(); + ok = GetTempFileName(strTempDir, (char*)file->base_string.self, 0, + strTempFileName); + ecl_enable_interrupts(); + if (!ok) { + output = ECL_NIL; + } else { + l = strlen(strTempFileName); + output = ecl_alloc_simple_base_string(l); + memcpy(output->base_string.self, strTempFileName, l); + } #else - template = si_coerce_to_filename(template); - l = template->base_string.fillp; - output = ecl_alloc_simple_base_string(l + 6); - memcpy(output->base_string.self, template->base_string.self, l); - memcpy(output->base_string.self + l, "XXXXXX", 6); + template = si_coerce_to_filename(template); + l = template->base_string.fillp; + output = ecl_alloc_simple_base_string(l + 6); + memcpy(output->base_string.self, template->base_string.self, l); + memcpy(output->base_string.self + l, "XXXXXX", 6); - ecl_disable_interrupts(); + ecl_disable_interrupts(); # ifdef HAVE_MKSTEMP - fd = mkstemp((char*)output->base_string.self); + fd = mkstemp((char*)output->base_string.self); # else - if (mktemp((char*)output->base_string.self)) { - fd = open((char*)output->base_string.self, O_CREAT|O_TRUNC, 0666); - } else { - fd = -1; - } + if (mktemp((char*)output->base_string.self)) { + fd = open((char*)output->base_string.self, O_CREAT|O_TRUNC, 0666); + } else { + fd = -1; + } # endif - ecl_enable_interrupts(); + ecl_enable_interrupts(); - if (fd < 0) { - output = ECL_NIL; - } else { - close(fd); - } + if (fd < 0) { + output = ECL_NIL; + } else { + close(fd); + } #endif - @(return (Null(output)? output : cl_truename(output))) + @(return (Null(output)? output : cl_truename(output))); } cl_object si_rmdir(cl_object directory) { - return cl_delete_file(cl_make_pathname(6, @':name', ECL_NIL, - @':type', ECL_NIL, - @':defaults', directory)); + return cl_delete_file(cl_make_pathname(6, @':name', ECL_NIL, + @':type', ECL_NIL, + @':defaults', directory)); } cl_object si_copy_file(cl_object orig, cl_object dest) { - FILE *in, *out; - int ok = 0; - orig = si_coerce_to_filename(orig); - dest = si_coerce_to_filename(dest); - ecl_disable_interrupts(); - in = fopen((char*)orig->base_string.self, OPEN_R); - if (in) { - out = fopen((char*)dest->base_string.self, OPEN_W); - if (out) { - unsigned char *buffer = ecl_alloc_atomic(1024); - cl_index size; - do { - size = fread(buffer, 1, 1024, in); - fwrite(buffer, 1, size, out); - } while (size == 1024); - ok = 1; - fclose(out); - } - fclose(in); - } - ecl_enable_interrupts(); - @(return (ok? ECL_T : ECL_NIL)) + FILE *in, *out; + int ok = 0; + orig = si_coerce_to_filename(orig); + dest = si_coerce_to_filename(dest); + ecl_disable_interrupts(); + in = fopen((char*)orig->base_string.self, OPEN_R); + if (in) { + out = fopen((char*)dest->base_string.self, OPEN_W); + if (out) { + unsigned char *buffer = ecl_alloc_atomic(1024); + cl_index size; + do { + size = fread(buffer, 1, 1024, in); + fwrite(buffer, 1, size, out); + } while (size == 1024); + ok = 1; + fclose(out); + } + fclose(in); + } + ecl_enable_interrupts(); + @(return (ok? ECL_T : ECL_NIL)); } cl_object si_chmod(cl_object file, cl_object mode) { - mode_t code = ecl_to_uint32_t(mode); - cl_object filename = coerce_to_posix_filename(file); - unlikely_if (chmod((char*)filename->base_string.self, code)) { - cl_object c_error = _ecl_strerror(errno); - const char *msg = "Unable to change mode of file ~S to value ~O" - "~%C library error: ~S"; - si_signal_simple_error - (6, @'file-error', /* condition */ - ECL_T, /* continuable */ - /* format */ - ecl_make_constant_base_string(msg,strlen(msg)), - cl_list(3, file, mode, c_error), /* format args */ - @':pathname', /* file-error options */ - file); - } - @(return) + mode_t code = ecl_to_uint32_t(mode); + cl_object filename = coerce_to_posix_filename(file); + unlikely_if (chmod((char*)filename->base_string.self, code)) { + cl_object c_error = _ecl_strerror(errno); + const char *msg = "Unable to change mode of file ~S to value ~O" + "~%C library error: ~S"; + si_signal_simple_error + (6, @'file-error', /* condition */ + ECL_T, /* continuable */ + /* format */ + ecl_make_constant_base_string(msg,strlen(msg)), + cl_list(3, file, mode, c_error), /* format args */ + @':pathname', /* file-error options */ + file); + } + @(return); } diff -Nru ecl-16.1.2/src/c/unixint.d ecl-16.1.3+ds/src/c/unixint.d --- ecl-16.1.2/src/c/unixint.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/unixint.d 2016-12-19 10:25:00.000000000 +0000 @@ -1122,16 +1122,11 @@ static cl_object W32_handle_in_new_thread(cl_object signal_code) { - /* XXX: there is some bug present only on windows platform - with importing the current thread. Don't know how to track - it though. */ -#if 0 int outside_ecl = ecl_import_current_thread(@'si::handle-signal', ECL_NIL); mp_process_run_function(4, @'si::handle-signal', @'si::handle-signal', signal_code, ECL_NIL); if (outside_ecl) ecl_release_current_thread(); -#endif /* 0 */ } BOOL WINAPI W32_console_ctrl_handler(DWORD type) @@ -1139,20 +1134,21 @@ switch (type) { case CTRL_C_EVENT: case CTRL_BREAK_EVENT: { - /* cl_object function = */ - /* ECL_SYM_FUN(@'si::terminal-interrupt'); */ - /* if (function) */ - /* W32_handle_in_new_thread(function); */ + cl_object function = + ECL_SYM_FUN(@'si::terminal-interrupt'); + if (function) + W32_handle_in_new_thread(function); return TRUE; } case CTRL_CLOSE_EVENT: case CTRL_LOGOFF_EVENT: - case CTRL_SHUTDOWN_EVENT: - /* Doing nothing is arguably the most - reasonable. Calling (quit) causes process to exit - and Windows has problems, because "process has - unexpectably died.*/ + case CTRL_SHUTDOWN_EVENT: { + cl_object function = + ECL_SYM_FUN(@'ext::quit'); + if (function) + W32_handle_in_new_thread(function); return TRUE; + } default: return FALSE; } @@ -1365,13 +1361,17 @@ if (ecl_option_values[ECL_OPT_TRAP_SIGFPE]) { mysignal(SIGFPE, fpe_signal_handler); si_trap_fpe(ECL_T, ECL_T); -# ifdef ECL_IEEE_FP - /* By default deactivate errors and accept - * denormals in floating point computations */ - si_trap_fpe(@'floating-point-invalid-operation', ECL_NIL); - si_trap_fpe(@'division-by-zero', ECL_NIL); - si_trap_fpe(@'floating-point-overflow', ECL_NIL); -# endif + + /* Don't trap underflows */ + si_trap_fpe(@'floating-point-underflow', ECL_NIL); + +/* # if defined(ECL_IEEE_FP) */ +/* /\* By default deactivate errors and accept denormals */ +/* * in floating point computations. *\/ */ +/* si_trap_fpe(@'floating-point-invalid-operation', ECL_NIL); */ +/* si_trap_fpe(@'division-by-zero', ECL_NIL); */ +/* si_trap_fpe(@'floating-point-overflow', ECL_NIL); */ +/* # endif */ } #endif } diff -Nru ecl-16.1.2/src/c/unixsys.d ecl-16.1.3+ds/src/c/unixsys.d --- ecl-16.1.2/src/c/unixsys.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/unixsys.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - unixsys.s -- Unix shell interface. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. - - See file '../Copyright' for full details. -*/ + * unixsys.s - Unix shell interface + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -48,10 +43,10 @@ si_getpid(void) { #if defined(NACL) - FElibc_error("si_getpid not implemented",1); - @(return Cnil) + FElibc_error("si_getpid not implemented",1); + @(return ECL_NIL); #else - @(return ecl_make_fixnum(getpid())) + @(return ecl_make_fixnum(getpid())); #endif } @@ -59,9 +54,9 @@ si_getuid(void) { #if defined(ECL_MS_WINDOWS_HOST) - @(return ecl_make_fixnum(0)); + @(return ecl_make_fixnum(0)); #else - @(return ecl_make_integer(getuid())); + @(return ecl_make_integer(getuid())); #endif } @@ -72,171 +67,171 @@ si_make_pipe() { #if defined(NACL) - FElibc_error("si_make_pipe not implemented",1); - @(return Cnil) + FElibc_error("si_make_pipe not implemented",1); + @(return ECL_NIL); #else - cl_object output; - int fds[2], ret; + cl_object output; + int fds[2], ret; #if defined(ECL_MS_WINDOWS_HOST) - ret = _pipe(fds, 4096, _O_BINARY); + ret = _pipe(fds, 4096, _O_BINARY); #else - ret = pipe(fds); + ret = pipe(fds); #endif - if (ret < 0) { - FElibc_error("Unable to create pipe", 0); - output = ECL_NIL; - } else { - cl_object in = ecl_make_stream_from_fd(fake_in_name, fds[0], ecl_smm_input, 8, - ECL_STREAM_DEFAULT_FORMAT, ECL_NIL); - cl_object out = ecl_make_stream_from_fd(fake_out_name, fds[1], ecl_smm_output, 8, - ECL_STREAM_DEFAULT_FORMAT, ECL_NIL); - output = cl_make_two_way_stream(in, out); - } - @(return output) + if (ret < 0) { + FElibc_error("Unable to create pipe", 0); + output = ECL_NIL; + } else { + cl_object in = ecl_make_stream_from_fd(fake_in_name, fds[0], ecl_smm_input, 8, + ECL_STREAM_DEFAULT_FORMAT, ECL_NIL); + cl_object out = ecl_make_stream_from_fd(fake_out_name, fds[1], ecl_smm_output, 8, + ECL_STREAM_DEFAULT_FORMAT, ECL_NIL); + output = cl_make_two_way_stream(in, out); + } + @(return output); #endif } static cl_object from_list_to_execve_argument(cl_object l, char ***environp) { - cl_object p; - cl_index i, j, total_size = 0, nstrings = 0; - cl_object buffer; - char **environ; - for (p = l; !Null(p); p = ECL_CONS_CDR(p)) { - cl_object s; - if (!CONSP(p)) { - FEerror("In EXT:RUN-PROGRAM, environment " - "is not a list of strings", 0); - } - s = ECL_CONS_CAR(p); - if (!ECL_BASE_STRING_P(s)) { - FEerror("In EXT:RUN-PROGRAM, environment " - "is not a list of base strings", 0); - } - total_size += s->base_string.fillp + 1; - nstrings++; - } - /* Extra place for ending null */ - total_size++; - buffer = ecl_alloc_simple_base_string(++total_size); - environ = ecl_alloc_atomic((nstrings + 1) * sizeof(char*)); - for (j = i = 0, p = l; !Null(p); p = ECL_CONS_CDR(p)) { - cl_object s = ECL_CONS_CAR(p); - cl_index l = s->base_string.fillp; - if (i + l + 1 >= total_size) { - FEerror("In EXT:RUN-PROGRAM, environment list" - " changed during execution.", 0); - break; - } - environ[j++] = (char*)(buffer->base_string.self + i); - memcpy(buffer->base_string.self + i, - s->base_string.self, - l); - i += l; - buffer->base_string.self[i++] = 0; - } - buffer->base_string.self[i++] = 0; - environ[j] = 0; - if (environp) *environp = environ; - return buffer; + cl_object p; + cl_index i, j, total_size = 0, nstrings = 0; + cl_object buffer; + char **environ; + for (p = l; !Null(p); p = ECL_CONS_CDR(p)) { + cl_object s; + if (!CONSP(p)) { + FEerror("In EXT:RUN-PROGRAM, environment " + "is not a list of strings", 0); + } + s = ECL_CONS_CAR(p); + if (!ECL_BASE_STRING_P(s)) { + FEerror("In EXT:RUN-PROGRAM, environment " + "is not a list of base strings", 0); + } + total_size += s->base_string.fillp + 1; + nstrings++; + } + /* Extra place for ending null */ + total_size++; + buffer = ecl_alloc_simple_base_string(++total_size); + environ = ecl_alloc_atomic((nstrings + 1) * sizeof(char*)); + for (j = i = 0, p = l; !Null(p); p = ECL_CONS_CDR(p)) { + cl_object s = ECL_CONS_CAR(p); + cl_index l = s->base_string.fillp; + if (i + l + 1 >= total_size) { + FEerror("In EXT:RUN-PROGRAM, environment list" + " changed during execution.", 0); + break; + } + environ[j++] = (char*)(buffer->base_string.self + i); + memcpy(buffer->base_string.self + i, + s->base_string.self, + l); + i += l; + buffer->base_string.self[i++] = 0; + } + buffer->base_string.self[i++] = 0; + environ[j] = 0; + if (environp) *environp = environ; + return buffer; } static cl_object make_external_process() { - return _ecl_funcall1(@'ext::make-external-process'); + return _ecl_funcall1(@'ext::make-external-process'); } static cl_object external_process_pid(cl_object p) { - return ecl_structure_ref(p, @'ext::external-process', 0); + return ecl_structure_ref(p, @'ext::external-process', 0); } static cl_object external_process_status(cl_object p) { - return ecl_structure_ref(p, @'ext::external-process', 4); + return ecl_structure_ref(p, @'ext::external-process', 4); } static cl_object external_process_code(cl_object p) { - return ecl_structure_ref(p, @'ext::external-process', 5); + return ecl_structure_ref(p, @'ext::external-process', 5); } static void set_external_process_pid(cl_object process, cl_object pid) { - ecl_structure_set(process, @'ext::external-process', 0, pid); + ecl_structure_set(process, @'ext::external-process', 0, pid); } static void set_external_process_streams(cl_object process, cl_object input, cl_object output, cl_object error) { - ecl_structure_set(process, @'ext::external-process', 1, input); - ecl_structure_set(process, @'ext::external-process', 2, output); - ecl_structure_set(process, @'ext::external-process', 3, error); + ecl_structure_set(process, @'ext::external-process', 1, input); + ecl_structure_set(process, @'ext::external-process', 2, output); + ecl_structure_set(process, @'ext::external-process', 3, error); } static void update_process_status(cl_object process, cl_object status, cl_object code) { - ecl_structure_set(process, @'ext::external-process', 0, ECL_NIL); - ecl_structure_set(process, @'ext::external-process', 4, status); - ecl_structure_set(process, @'ext::external-process', 5, code); + ecl_structure_set(process, @'ext::external-process', 0, ECL_NIL); + ecl_structure_set(process, @'ext::external-process', 4, status); + ecl_structure_set(process, @'ext::external-process', 5, code); } #if defined(SIGCHLD) && !defined(ECL_MS_WINDOWS_HOST) static void add_external_process(cl_env_ptr env, cl_object process) { - cl_object l = ecl_list1(process); - ecl_disable_interrupts_env(env); - ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock); - { - ECL_RPLACD(l, cl_core.external_processes); - cl_core.external_processes = l; - } - ECL_WITH_SPINLOCK_END; - ecl_enable_interrupts_env(env); + cl_object l = ecl_list1(process); + ecl_disable_interrupts_env(env); + ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock); + { + ECL_RPLACD(l, cl_core.external_processes); + cl_core.external_processes = l; + } + ECL_WITH_SPINLOCK_END; + ecl_enable_interrupts_env(env); } static void remove_external_process(cl_env_ptr env, cl_object process) { - ecl_disable_interrupts_env(env); - ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock); - { - cl_core.external_processes = - ecl_delete_eq(process, cl_core.external_processes); - } - ECL_WITH_SPINLOCK_END; - ecl_enable_interrupts_env(env); + ecl_disable_interrupts_env(env); + ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock); + { + cl_core.external_processes = + ecl_delete_eq(process, cl_core.external_processes); + } + ECL_WITH_SPINLOCK_END; + ecl_enable_interrupts_env(env); } static cl_object find_external_process(cl_env_ptr env, cl_object pid) { - cl_object output = ECL_NIL; - ecl_disable_interrupts_env(env); - ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock); - { - cl_object p; - for (p = cl_core.external_processes; p != ECL_NIL; p = ECL_CONS_CDR(p)) { - cl_object process = ECL_CONS_CAR(p); - if (external_process_pid(process) == pid) { - output = process; - break; - } - } - } - ECL_WITH_SPINLOCK_END(&cl_core.external_processes_lock); - ecl_enable_interrupts_env(env); - return output; + cl_object output = ECL_NIL; + ecl_disable_interrupts_env(env); + ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock); + { + cl_object p; + for (p = cl_core.external_processes; p != ECL_NIL; p = ECL_CONS_CDR(p)) { + cl_object process = ECL_CONS_CAR(p); + if (external_process_pid(process) == pid) { + output = process; + break; + } + } + } + ECL_WITH_SPINLOCK_END(&cl_core.external_processes_lock); + ecl_enable_interrupts_env(env); + return output; } #else #define add_external_process(env,p) @@ -246,176 +241,203 @@ static cl_object ecl_waitpid(cl_object pid, cl_object wait) { - cl_object status, code; + cl_object status, code; #if defined(NACL) - FElibc_error("ecl_waitpid not implemented",1); - @(return Cnil) + FElibc_error("ecl_waitpid not implemented",1); + @(return ECL_NIL); #elif defined(ECL_MS_WINDOWS_HOST) - cl_env_ptr the_env = ecl_process_env(); - HANDLE *hProcess = ecl_foreign_data_pointer_safe(pid); - DWORD exitcode; - int ok; - WaitForSingleObject(*hProcess, Null(wait)? 0 : INFINITE); - ecl_disable_interrupts_env(the_env); - ok = GetExitCodeProcess(*hProcess, &exitcode); - if (!ok) { - status = @':error'; - code = ECL_NIL; - } else if (exitcode == STILL_ACTIVE) { - status = @':running'; - code = ECL_NIL; - } else { - status = @':exited'; - code = ecl_make_fixnum(exitcode); - pid->foreign.data = NULL; - CloseHandle(*hProcess); - } - ecl_enable_interrupts_env(the_env); + cl_env_ptr the_env = ecl_process_env(); + HANDLE *hProcess = ecl_foreign_data_pointer_safe(pid); + DWORD exitcode; + int ok; + WaitForSingleObject(*hProcess, Null(wait)? 0 : INFINITE); + ecl_disable_interrupts_env(the_env); + ok = GetExitCodeProcess(*hProcess, &exitcode); + if (!ok) { + status = @':error'; + code = ECL_NIL; + } else if (exitcode == STILL_ACTIVE) { + status = @':running'; + code = ECL_NIL; + } else { + status = @':exited'; + code = ecl_make_fixnum(exitcode); + pid->foreign.data = NULL; + CloseHandle(*hProcess); + } + ecl_enable_interrupts_env(the_env); #else - int code_int, error; - error = waitpid(ecl_to_fix(pid), &code_int, Null(wait)? WNOHANG : 0); - if (error < 0) { - if (errno == EINTR) { - status = @':abort'; - } else { - status = @':error'; - } - code = ECL_NIL; - pid = ECL_NIL; - } else if (error == 0) { - status = ECL_NIL; - code = ECL_NIL; - pid = ECL_NIL; - } else { - pid = ecl_make_fixnum(error); - if (WIFEXITED(code_int)) { - status = @':exited'; - code = ecl_make_fixnum(WEXITSTATUS(code_int)); - } else if (WIFSIGNALED(code_int)) { - status = @':signaled'; - code = ecl_make_fixnum(WTERMSIG(code_int)); - } else if (WIFSTOPPED(code_int)) { - status = @':stopped'; - code = ecl_make_fixnum(WSTOPSIG(code_int)); - } else { - status = @':running'; - code = ECL_NIL; - } - } + int code_int, error; + error = waitpid(ecl_to_fix(pid), &code_int, Null(wait)? WNOHANG : 0); + if (error < 0) { + if (errno == EINTR) { + status = @':abort'; + } else { + status = @':error'; + } + code = ECL_NIL; + pid = ECL_NIL; + } else if (error == 0) { + status = ECL_NIL; + code = ECL_NIL; + pid = ECL_NIL; + } else { + pid = ecl_make_fixnum(error); + if (WIFEXITED(code_int)) { + status = @':exited'; + code = ecl_make_fixnum(WEXITSTATUS(code_int)); + } else if (WIFSIGNALED(code_int)) { + status = @':signaled'; + code = ecl_make_fixnum(WTERMSIG(code_int)); + } else if (WIFSTOPPED(code_int)) { + status = @':stopped'; + code = ecl_make_fixnum(WSTOPSIG(code_int)); + } else { + status = @':running'; + code = ECL_NIL; + } + } +#endif + @(return status code pid); +} + +@(defun ext::terminate-process (process &optional (force ECL_NIL)) + @ + { + cl_env_ptr env = ecl_process_env(); + bool error_encountered = FALSE; + ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock); + { + cl_object pid = external_process_pid(process); + if (!Null(pid)) { + int ret; +#if defined(ECL_MS_WINDOWS_HOST) + HANDLE *ph = (HANDLE*)ecl_foreign_data_pointer_safe(pid); + ret = TerminateProcess(*ph, -1); + error_encountered = (ret == 0); +#else + ret = kill(ecl_fixnum(pid), Null(force) ? SIGTERM : SIGKILL); + error_encountered = (ret != 0); #endif - @(return status code pid) -} + } + } + ECL_WITH_SPINLOCK_END; + if (error_encountered) + FEerror("Cannot terminate the process ~A", 1, process); + return ECL_NIL; + } + @) + @(defun si::wait-for-all-processes (&key (process ECL_NIL)) -@ -{ - const cl_env_ptr env = ecl_process_env(); + @ + { + const cl_env_ptr env = ecl_process_env(); #if defined(SIGCHLD) && !defined(ECL_WINDOWS_HOST) - do { - cl_object status = ecl_waitpid(ecl_make_fixnum(-1), ECL_NIL); - cl_object code = env->values[1]; - cl_object pid = env->values[2]; - if (Null(pid)) { - if (status != @':abort') - break; - } else { - cl_object p = find_external_process(env, pid); - if (!Null(p)) { - set_external_process_pid(p, ECL_NIL); - update_process_status(p, status, code); - } - if (status != @':running') { - remove_external_process(env, p); ecl_delete_eq(p, cl_core.external_processes); - } - } - } while (1); -#endif - ecl_return0(env); -} -@) + do { + cl_object status = ecl_waitpid(ecl_make_fixnum(-1), ECL_NIL); + cl_object code = env->values[1]; + cl_object pid = env->values[2]; + if (Null(pid)) { + if (status != @':abort') + break; + } else { + cl_object p = find_external_process(env, pid); + if (!Null(p)) { + set_external_process_pid(p, ECL_NIL); + update_process_status(p, status, code); + } + if (status != @':running') { + remove_external_process(env, p); + ecl_delete_eq(p, cl_core.external_processes); + } + } + } while (1); +#endif + ecl_return0(env); + } + @) #if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin) cl_object si_close_windows_handle(cl_object h) { - if (ecl_t_of(h) == t_foreign) { - HANDLE *ph = (HANDLE*)h->foreign.data; - if (ph) CloseHandle(*ph); - } + if (ecl_t_of(h) == t_foreign) { + HANDLE *ph = (HANDLE*)h->foreign.data; + if (ph) CloseHandle(*ph); + } } static cl_object make_windows_handle(HANDLE h) { - cl_object foreign = ecl_allocate_foreign_data(@':pointer-void', - sizeof(HANDLE*)); - HANDLE *ph = (HANDLE*)foreign->foreign.data; - *ph = h; - si_set_finalizer(foreign, @'si::close-windows-handle'); - return foreign; + cl_object foreign = ecl_allocate_foreign_data(@':pointer-void', + sizeof(HANDLE*)); + HANDLE *ph = (HANDLE*)foreign->foreign.data; + *ph = h; + si_set_finalizer(foreign, @'si::close-windows-handle'); + return foreign; } #endif @(defun ext::external-process-wait (process &optional (wait ECL_NIL)) -@ -{ - cl_object status, code, pid; - AGAIN: - pid = external_process_pid(process); - if (Null(pid)) { - /* If PID is NIL, it may be because the process failed, - * or because it is being updated by a separate thread, - * which is why we have to spin here. Note also the order - * here: status is updated _after_ code, and hence we - * check it _before_ code. */ - do { - ecl_musleep(0.0, 1); - status = external_process_status(process); - } while (status == @':running'); - code = external_process_code(process); - } else { - status = ecl_waitpid(pid, wait); - code = ecl_nth_value(the_env, 1); - pid = ecl_nth_value(the_env, 2); - /* A SIGCHLD interrupt may abort waitpid. If this - * is the case, the signal handler may have consumed - * the process status and we have to start over again */ - if (Null(pid)) { - if (!Null(wait)) goto AGAIN; - status = external_process_status(process); - code = external_process_code(process); - } else { - update_process_status(process, status, code); - remove_external_process(the_env, process); - } - } - @(return status code) -} -@) + @ { + cl_object status, code, pid; + AGAIN: + pid = external_process_pid(process); + if (Null(pid)) { + /* If PID is NIL, it may be because the process failed, + * or because it is being updated by a separate thread, + * which is why we have to spin here. Note also the order + * here: status is updated _after_ code, and hence we + * check it _before_ code. */ + do { + ecl_musleep(0.0, 1); + status = external_process_status(process); + } while (status == @':running'); + code = external_process_code(process); + } else { + status = ecl_waitpid(pid, wait); + code = ecl_nth_value(the_env, 1); + pid = ecl_nth_value(the_env, 2); + /* A SIGCHLD interrupt may abort waitpid. If this + * is the case, the signal handler may have consumed + * the process status and we have to start over again */ + if (Null(pid)) { + if (!Null(wait)) goto AGAIN; + status = external_process_status(process); + code = external_process_code(process); + } else { + update_process_status(process, status, code); + remove_external_process(the_env, process); + } + } + @(return status code); + } @) #if defined(ECL_MS_WINDOWS_HOST) HANDLE ecl_stream_to_HANDLE(cl_object s, bool output) { - if (ecl_unlikely(!ECL_ANSI_STREAM_P(s))) - return INVALID_HANDLE_VALUE; - switch ((enum ecl_smmode)s->stream.mode) { + if (ecl_unlikely(!ECL_ANSI_STREAM_P(s))) + return INVALID_HANDLE_VALUE; + switch ((enum ecl_smmode)s->stream.mode) { #if defined(ECL_WSOCK) - case ecl_smm_input_wsock: - case ecl_smm_output_wsock: - case ecl_smm_io_wsock: + case ecl_smm_input_wsock: + case ecl_smm_output_wsock: + case ecl_smm_io_wsock: #endif #if defined(ECL_MS_WINDOWS_HOST) - case ecl_smm_io_wcon: + case ecl_smm_io_wcon: #endif - return (HANDLE)IO_FILE_DESCRIPTOR(s); - default: { - int stream_descriptor = ecl_stream_to_handle(s, output); - return (stream_descriptor < 0)? - INVALID_HANDLE_VALUE: - (HANDLE)_get_osfhandle(stream_descriptor); - } - } + return (HANDLE)IO_FILE_DESCRIPTOR(s); + default: { + int stream_descriptor = ecl_stream_to_handle(s, output); + return (stream_descriptor < 0)? + INVALID_HANDLE_VALUE: + (HANDLE)_get_osfhandle(stream_descriptor); + } + } } #endif @@ -423,100 +445,100 @@ static void create_descriptor(cl_object stream, cl_object direction, HANDLE *child, int *parent) { - SECURITY_ATTRIBUTES attr; - HANDLE current = GetCurrentProcess(); - attr.nLength = sizeof(SECURITY_ATTRIBUTES); - attr.lpSecurityDescriptor = NULL; - attr.bInheritHandle = TRUE; - - if (stream == @':stream') { - /* Creates a pipe that we can write to and the - child reads from. We duplicate one extreme of the - pipe so that the child does not inherit it. */ - HANDLE tmp; - if (CreatePipe(&tmp, child, &attr, 0) == 0) - return; - - if (DuplicateHandle(current, tmp, current, - &tmp, 0, FALSE, - DUPLICATE_CLOSE_SOURCE | - DUPLICATE_SAME_ACCESS) == 0) - return; + SECURITY_ATTRIBUTES attr; + HANDLE current = GetCurrentProcess(); + attr.nLength = sizeof(SECURITY_ATTRIBUTES); + attr.lpSecurityDescriptor = NULL; + attr.bInheritHandle = TRUE; + + if (stream == @':stream') { + /* Creates a pipe that we can write to and the + child reads from. We duplicate one extreme of the + pipe so that the child does not inherit it. */ + HANDLE tmp; + if (CreatePipe(&tmp, child, &attr, 0) == 0) + return; + + if (DuplicateHandle(current, tmp, current, + &tmp, 0, FALSE, + DUPLICATE_CLOSE_SOURCE | + DUPLICATE_SAME_ACCESS) == 0) + return; - if (direction == @':input') { + if (direction == @':input') { #ifdef cygwin - *parent = cygwin_attach_handle_to_fd - (0, -1, tmp, S_IRWXU, GENERIC_WRITE); + *parent = cygwin_attach_handle_to_fd + (0, -1, tmp, S_IRWXU, GENERIC_WRITE); #else - *parent = _open_osfhandle - ((intptr_t)tmp, _O_WRONLY); + *parent = _open_osfhandle + ((intptr_t)tmp, _O_WRONLY); #endif - } - else { + } + else { #ifdef cygwin - *parent = cygwin_attach_handle_to_fd - (0, -1, tmp, S_IRWXU, GENERIC_READ); + *parent = cygwin_attach_handle_to_fd + (0, -1, tmp, S_IRWXU, GENERIC_READ); #else - *parent = _open_osfhandle - ((intptr_t)tmp, _O_RDONLY); + *parent = _open_osfhandle + ((intptr_t)tmp, _O_RDONLY); #endif - } + } - if (*parent < 0) - printf("open_osfhandle failed\n"); - } - else if (Null(stream)) { - *child = NULL; - } - else if (!Null(cl_streamp(stream))) { - HANDLE stream_handle = ecl_stream_to_HANDLE - (stream, direction != @':input'); - if (stream_handle == INVALID_HANDLE_VALUE) { - FEerror("~S argument to RUN-PROGRAM does not " - "have a file handle:~%~S", 2, direction, stream); - } - DuplicateHandle(current, stream_handle, - current, child, 0, TRUE, - DUPLICATE_SAME_ACCESS); - } - else { - FEerror("Invalid ~S argument to EXT:RUN-PROGRAM", 1, stream); - } + if (*parent < 0) + printf("open_osfhandle failed\n"); + } + else if (Null(stream)) { + *child = NULL; + } + else if (!Null(cl_streamp(stream))) { + HANDLE stream_handle = ecl_stream_to_HANDLE + (stream, direction != @':input'); + if (stream_handle == INVALID_HANDLE_VALUE) { + FEerror("~S argument to RUN-PROGRAM does not " + "have a file handle:~%~S", 2, direction, stream); + } + DuplicateHandle(current, stream_handle, + current, child, 0, TRUE, + DUPLICATE_SAME_ACCESS); + } + else { + FEerror("Invalid ~S argument to EXT:RUN-PROGRAM", 1, stream); + } } #else static void create_descriptor(cl_object stream, cl_object direction, int *child, int *parent) { - if (stream == @':stream') { - int fd[2]; - pipe(fd); - if (direction == @':input') { - *parent = fd[1]; - *child = fd[0]; - } else { - *parent = fd[0]; - *child = fd[1]; - } - } - else if (Null(stream)) { - if (direction == @':input') - *child = open("/dev/null", O_RDONLY); - else - *child = open("/dev/null", O_WRONLY); - } - else if (!Null(cl_streamp(stream))) { - *child = ecl_stream_to_handle - (stream, direction != @':input'); - if (*child >= 0) { - *child = dup(*child); - } else { - FEerror("~S argument to RUN-PROGRAM does not " - "have a file handle:~%~S", 2, direction, stream); - } - } - else { - FEerror("Invalid ~S argument to EXT:RUN-PROGRAM", 1, stream); - } + if (stream == @':stream') { + int fd[2]; + pipe(fd); + if (direction == @':input') { + *parent = fd[1]; + *child = fd[0]; + } else { + *parent = fd[0]; + *child = fd[1]; + } + } + else if (Null(stream)) { + if (direction == @':input') + *child = open("/dev/null", O_RDONLY); + else + *child = open("/dev/null", O_WRONLY); + } + else if (!Null(cl_streamp(stream))) { + *child = ecl_stream_to_handle + (stream, direction != @':input'); + if (*child >= 0) { + *child = dup(*child); + } else { + FEerror("~S argument to RUN-PROGRAM does not " + "have a file handle:~%~S", 2, direction, stream); + } + } + else { + FEerror("Invalid ~S argument to EXT:RUN-PROGRAM", 1, stream); + } } #endif @(defun ext::run-program (command argv &key (input @':stream') (output @':stream') @@ -525,273 +547,275 @@ (if_output_exists @':error') (if_error_exists @':error') (external_format @':default')) - int parent_write = 0, parent_read = 0, parent_error = 0; - int child_pid; - cl_object pid, process; - cl_object stream_write; - cl_object stream_read; - cl_object stream_error; - cl_object exit_status = ECL_NIL; -@ - command = si_copy_to_simple_base_string(command); - argv = cl_mapcar(2, @'si::copy-to-simple-base-string', argv); - process = make_external_process(); - -{ - if (input == @'t') - input = ecl_symbol_value(@'*standard-input*'); - if (ECL_STRINGP(input) || ECL_PATHNAMEP(input)) - input = cl_open(5, input, - @':direction', @':input', - @':if-does-not-exist', if_input_does_not_exist, - @':external-format', external_format); - - if (output == @'t') - output = ecl_symbol_value(@'*standard-output*'); - if (ECL_STRINGP(output) || ECL_PATHNAMEP(output)) - output = cl_open(7, output, - @':direction', @':output', - @':if-exists', if_output_exists, - @':if-does-not-exist', @':create', - @':external-format', external_format); - - if (error == @'t') - error = ecl_symbol_value(@'*error-output*'); - if (ECL_STRINGP(error) || ECL_PATHNAMEP(error)) - error = cl_open(7, error, - @':direction', @':output', - @':if-exists', if_error_exists, - @':if-does-not-exist', @':create', - @':external-format', external_format); -} + int parent_write = 0, parent_read = 0, parent_error = 0; + int child_pid; + cl_object pid, process; + cl_object stream_write; + cl_object stream_read; + cl_object stream_error; + cl_object exit_status = ECL_NIL; + @ + command = si_copy_to_simple_base_string(command); + argv = cl_mapcar(2, @'si::copy-to-simple-base-string', argv); + process = make_external_process(); + + { + if (input == @'t') + input = ecl_symbol_value(@'*standard-input*'); + if (ECL_STRINGP(input) || ECL_PATHNAMEP(input)) + input = cl_open(5, input, + @':direction', @':input', + @':if-does-not-exist', if_input_does_not_exist, + @':external-format', external_format); + + if (output == @'t') + output = ecl_symbol_value(@'*standard-output*'); + if (ECL_STRINGP(output) || ECL_PATHNAMEP(output)) + output = cl_open(7, output, + @':direction', @':output', + @':if-exists', if_output_exists, + @':if-does-not-exist', @':create', + @':external-format', external_format); + + if (error == @'t') + error = ecl_symbol_value(@'*error-output*'); + if (ECL_STRINGP(error) || ECL_PATHNAMEP(error)) + error = cl_open(7, error, + @':direction', @':output', + @':if-exists', if_error_exists, + @':if-does-not-exist', @':create', + @':external-format', external_format); + } #if defined(ECL_MS_WINDOWS_HOST) -{ - BOOL ok; - STARTUPINFO st_info; - PROCESS_INFORMATION pr_info; - HANDLE child_stdout, child_stdin, child_stderr; - HANDLE current = GetCurrentProcess(); - HANDLE saved_stdout, saved_stdin, saved_stderr; - cl_object env_buffer; - char *env = NULL; - - /* Enclose each argument, as well as the file name - in double quotes, to avoid problems when these - arguments or file names have spaces */ - command = - cl_format(4, ECL_NIL, - ecl_make_simple_base_string("~S~{ ~S~}", -1), - command, argv); - command = si_copy_to_simple_base_string(command); - command = ecl_null_terminated_base_string(command); - - if (!Null(environ)) { - env_buffer = from_list_to_execve_argument(environ, NULL); - env = env_buffer->base_string.self; - } - create_descriptor(input, @':input', &child_stdin, &parent_write); - create_descriptor(output, @':output', &child_stdout, &parent_read); - if (error == @':output') - /* The child inherits a duplicate of its own output - handle.*/ - DuplicateHandle(current, child_stdout, current, - &child_stderr, 0, TRUE, - DUPLICATE_SAME_ACCESS); - else - create_descriptor(error, @':error', &child_stderr, &parent_error); + { + BOOL ok; + STARTUPINFO st_info; + PROCESS_INFORMATION pr_info; + HANDLE child_stdout, child_stdin, child_stderr; + HANDLE current = GetCurrentProcess(); + HANDLE saved_stdout, saved_stdin, saved_stderr; + cl_object env_buffer; + char *env = NULL; + + /* Enclose each argument, as well as the file name + in double quotes, to avoid problems when these + arguments or file names have spaces */ + command = + cl_format(4, ECL_NIL, + ecl_make_simple_base_string("~S~{ ~S~}", -1), + command, argv); + command = si_copy_to_simple_base_string(command); + command = ecl_null_terminated_base_string(command); + + if (!Null(environ)) { + env_buffer = from_list_to_execve_argument(environ, NULL); + env = env_buffer->base_string.self; + } + create_descriptor(input, @':input', &child_stdin, &parent_write); + create_descriptor(output, @':output', &child_stdout, &parent_read); + if (error == @':output') + /* The child inherits a duplicate of its own output + handle.*/ + DuplicateHandle(current, child_stdout, current, + &child_stderr, 0, TRUE, + DUPLICATE_SAME_ACCESS); + else + create_descriptor(error, @':error', &child_stderr, &parent_error); - add_external_process(the_env, process); + add_external_process(the_env, process); #if 1 - ZeroMemory(&st_info, sizeof(STARTUPINFO)); - st_info.cb = sizeof(STARTUPINFO); - st_info.lpTitle = NULL; /* No window title, just exec name */ - st_info.dwFlags = STARTF_USESTDHANDLES | STARTF_USESHOWWINDOW; /* Specify std{in,out,err} */ - st_info.wShowWindow = SW_HIDE; - st_info.hStdInput = child_stdin; - st_info.hStdOutput = child_stdout; - st_info.hStdError = child_stderr; - ZeroMemory(&pr_info, sizeof(PROCESS_INFORMATION)); - ok = CreateProcess(NULL, command->base_string.self, - NULL, NULL, /* lpProcess/ThreadAttributes */ - TRUE, /* Inherit handles (for files) */ - /*CREATE_NEW_CONSOLE |*/ - 0 /*(input == ECL_T || output == ECL_T || error == ECL_T ? 0 : CREATE_NO_WINDOW)*/, - env, /* Inherit environment */ - NULL, /* Current directory */ - &st_info, /* Startup info */ - &pr_info); /* Process info */ + ZeroMemory(&st_info, sizeof(STARTUPINFO)); + st_info.cb = sizeof(STARTUPINFO); + st_info.lpTitle = NULL; /* No window title, just exec name */ + st_info.dwFlags = STARTF_USESTDHANDLES | STARTF_USESHOWWINDOW; /* Specify std{in,out,err} */ + st_info.wShowWindow = SW_HIDE; + st_info.hStdInput = child_stdin; + st_info.hStdOutput = child_stdout; + st_info.hStdError = child_stderr; + ZeroMemory(&pr_info, sizeof(PROCESS_INFORMATION)); + ok = CreateProcess(NULL, command->base_string.self, + NULL, NULL, /* lpProcess/ThreadAttributes */ + TRUE, /* Inherit handles (for files) */ + /*CREATE_NEW_CONSOLE |*/ + 0 /*(input == ECL_T || output == ECL_T || error == ECL_T ? 0 : CREATE_NO_WINDOW)*/, + env, /* Inherit environment */ + NULL, /* Current directory */ + &st_info, /* Startup info */ + &pr_info); /* Process info */ #else /* 1 */ - saved_stdin = GetStdHandle(STD_INPUT_HANDLE); - saved_stdout = GetStdHandle(STD_OUTPUT_HANDLE); - saved_stderr = GetStdHandle(STD_ERROR_HANDLE); - SetStdHandle(STD_INPUT_HANDLE, child_stdin); - SetStdHandle(STD_OUTPUT_HANDLE, child_stdout); - SetStdHandle(STD_ERROR_HANDLE, child_stderr); - ZeroMemory(&st_info, sizeof(STARTUPINFO)); - st_info.cb = sizeof(STARTUPINFO); - ZeroMemory(&pr_info, sizeof(PROCESS_INFORMATION)); - ok = CreateProcess(NULL, command->base_string.self, - NULL, NULL, /* lpProcess/ThreadAttributes */ - TRUE, /* Inherit handles (for files) */ - /*CREATE_NEW_CONSOLE |*/ - 0, - NULL, /* Inherit environment */ - NULL, /* Current directory */ - &st_info, /* Startup info */ - &pr_info); /* Process info */ - SetStdHandle(STD_INPUT_HANDLE, saved_stdin); - SetStdHandle(STD_OUTPUT_HANDLE, saved_stdout); - SetStdHandle(STD_ERROR_HANDLE, saved_stderr); + saved_stdin = GetStdHandle(STD_INPUT_HANDLE); + saved_stdout = GetStdHandle(STD_OUTPUT_HANDLE); + saved_stderr = GetStdHandle(STD_ERROR_HANDLE); + SetStdHandle(STD_INPUT_HANDLE, child_stdin); + SetStdHandle(STD_OUTPUT_HANDLE, child_stdout); + SetStdHandle(STD_ERROR_HANDLE, child_stderr); + ZeroMemory(&st_info, sizeof(STARTUPINFO)); + st_info.cb = sizeof(STARTUPINFO); + ZeroMemory(&pr_info, sizeof(PROCESS_INFORMATION)); + ok = CreateProcess(NULL, command->base_string.self, + NULL, NULL, /* lpProcess/ThreadAttributes */ + TRUE, /* Inherit handles (for files) */ + /*CREATE_NEW_CONSOLE |*/ + 0, + NULL, /* Inherit environment */ + NULL, /* Current directory */ + &st_info, /* Startup info */ + &pr_info); /* Process info */ + SetStdHandle(STD_INPUT_HANDLE, saved_stdin); + SetStdHandle(STD_OUTPUT_HANDLE, saved_stdout); + SetStdHandle(STD_ERROR_HANDLE, saved_stderr); #endif /* 1 */ - /* Child handles must be closed in the parent process */ - /* otherwise the created pipes are never closed */ - if (ok) { - CloseHandle(pr_info.hThread); - pid = make_windows_handle(pr_info.hProcess); - } else { - char *message; - FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | - FORMAT_MESSAGE_ALLOCATE_BUFFER, - 0, GetLastError(), 0, (void*)&message, 0, NULL); - printf("%s\n", message); - LocalFree(message); - pid = ECL_NIL; - } - set_external_process_pid(process, pid); - if (child_stdin) CloseHandle(child_stdin); - if (child_stdout) CloseHandle(child_stdout); - if (child_stderr) CloseHandle(child_stderr); -} + /* Child handles must be closed in the parent process */ + /* otherwise the created pipes are never closed */ + if (ok) { + CloseHandle(pr_info.hThread); + pid = make_windows_handle(pr_info.hProcess); + } else { + char *message; + FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | + FORMAT_MESSAGE_ALLOCATE_BUFFER, + 0, GetLastError(), 0, (void*)&message, 0, NULL); + printf("%s\n", message); + LocalFree(message); + pid = ECL_NIL; + } + set_external_process_pid(process, pid); + if (child_stdin) CloseHandle(child_stdin); + if (child_stdout) CloseHandle(child_stdout); + if (child_stderr) CloseHandle(child_stderr); + } #elif !defined(NACL) /* mingw */ -{ - int child_stdin, child_stdout, child_stderr; - int pipe_fd[2]; - argv = CONS(command, ecl_nconc(argv, ecl_list1(ECL_NIL))); - argv = _ecl_funcall3(@'coerce', argv, @'vector'); - - create_descriptor(input, @':input', &child_stdin, &parent_write); - create_descriptor(output, @':output', &child_stdout, &parent_read); - if (error == @':output') - child_stderr = child_stdout; - else - create_descriptor(error, @':error', &child_stderr, &parent_error); - - add_external_process(the_env, process); - pipe(pipe_fd); - child_pid = fork(); - if (child_pid == 0) { - /* Child */ - int j; - void **argv_ptr = (void **)argv->vector.self.t; - { - /* Wait for the parent to set up its process structure */ - char sync[1]; - close(pipe_fd[1]); - while (read(pipe_fd[0], sync, 1) < 1) { - printf("\nError reading child pipe %d", errno); - fflush(stdout); - } - close(pipe_fd[0]); - } - dup2(child_stdin, STDIN_FILENO); - if (parent_write) close(parent_write); - dup2(child_stdout, STDOUT_FILENO); - if (parent_read) close(parent_read); - dup2(child_stderr, STDERR_FILENO); - if (parent_error) close(parent_error); - for (j = 0; j < argv->vector.fillp; j++) { - cl_object arg = argv->vector.self.t[j]; - if (arg == ECL_NIL) { - argv_ptr[j] = NULL; - } else { - argv_ptr[j] = arg->base_string.self; - } - } - if (!Null(environ)) { - char **pstrings; - cl_object buffer = from_list_to_execve_argument(environ, - &pstrings); - execve((char*)command->base_string.self, argv_ptr, pstrings); - } else { - execvp((char*)command->base_string.self, argv_ptr); - } - /* at this point exec has failed */ - perror("exec"); - abort(); - } - if (child_pid < 0) { - pid = ECL_NIL; + { + int child_stdin, child_stdout, child_stderr; + int pipe_fd[2]; + argv = CONS(command, ecl_nconc(argv, ecl_list1(ECL_NIL))); + argv = _ecl_funcall3(@'coerce', argv, @'vector'); + + create_descriptor(input, @':input', &child_stdin, &parent_write); + create_descriptor(output, @':output', &child_stdout, &parent_read); + if (error == @':output') + child_stderr = child_stdout; + else + create_descriptor(error, @':error', &child_stderr, &parent_error); + + add_external_process(the_env, process); + pipe(pipe_fd); + child_pid = fork(); + if (child_pid == 0) { + /* Child */ + int j; + void **argv_ptr = (void **)argv->vector.self.t; + { + /* Wait for the parent to set up its process structure */ + char sync[1]; + close(pipe_fd[1]); + while (read(pipe_fd[0], sync, 1) < 1) { + printf("\nError reading child pipe %d", errno); + fflush(stdout); + } + close(pipe_fd[0]); + } + dup2(child_stdin, STDIN_FILENO); + if (parent_write) close(parent_write); + dup2(child_stdout, STDOUT_FILENO); + if (parent_read) close(parent_read); + dup2(child_stderr, STDERR_FILENO); + if (parent_error) close(parent_error); + for (j = 0; j < argv->vector.fillp; j++) { + cl_object arg = argv->vector.self.t[j]; + if (arg == ECL_NIL) { + argv_ptr[j] = NULL; } else { - pid = ecl_make_fixnum(child_pid); - } - set_external_process_pid(process, pid); - { - /* This guarantees that the child process does not exit - * before we have created the process structure. If we do not - * do this, the SIGPIPE signal may arrive before - * set_external_process_pid() and our call to external-process-wait - * down there may block indefinitely. */ - char sync[1]; - close(pipe_fd[0]); - while (write(pipe_fd[1], sync, 1) < 1) { - printf("\nError writing child pipe %d", errno); - fflush(stdout); - } - close(pipe_fd[1]); + argv_ptr[j] = arg->base_string.self; } - close(child_stdin); - close(child_stdout); - close(child_stderr); -} + } + if (!Null(environ)) { + char **pstrings; + cl_object buffer = from_list_to_execve_argument(environ, &pstrings); + execve((char*)command->base_string.self, (char **)argv_ptr, pstrings); + } else { + execvp((char*)command->base_string.self, (char **)argv_ptr); + } + /* at this point exec has failed */ + perror("exec"); + abort(); + } + if (child_pid < 0) { + pid = ECL_NIL; + } else { + pid = ecl_make_fixnum(child_pid); + } + set_external_process_pid(process, pid); + { + /* This guarantees that the child process does not exit + * before we have created the process structure. If we do not + * do this, the SIGPIPE signal may arrive before + * set_external_process_pid() and our call to external-process-wait + * down there may block indefinitely. */ + char sync[1]; + close(pipe_fd[0]); + while (write(pipe_fd[1], sync, 1) < 1) { + printf("\nError writing child pipe %d", errno); + fflush(stdout); + } + close(pipe_fd[1]); + } + close(child_stdin); + close(child_stdout); + close(child_stderr); + } #else -{ - FElibc_error("ext::run-program not implemented",1); - @(return Cnil) -} + { + FElibc_error("ext::run-program not implemented",1); + @(return ECL_NIL); + } #endif /* mingw */ - if (Null(pid)) { - if (parent_write) close(parent_write); - if (parent_read) close(parent_read); - if (parent_error) close(parent_error); - parent_write = 0; - parent_read = 0; - parent_error = 0; - remove_external_process(the_env, process); - FEerror("Could not spawn subprocess to run ~S.", 1, command); - } - if (parent_write > 0) { - stream_write = ecl_make_stream_from_fd(command, parent_write, - ecl_smm_output, 8, - external_format, ECL_T); - } else { - parent_write = 0; - stream_write = cl_core.null_stream; - } - if (parent_read > 0) { - stream_read = ecl_make_stream_from_fd(command, parent_read, - ecl_smm_input, 8, - external_format, ECL_T); - } else { - parent_read = 0; - stream_read = cl_core.null_stream; - } - if (parent_error > 0) { - stream_error = ecl_make_stream_from_fd(command, parent_error, - ecl_smm_input, 8, - external_format, ECL_T); - } else { - parent_error = 0; - stream_error = cl_core.null_stream; - } - set_external_process_streams(process, stream_write, stream_read, - stream_error); - if (!Null(wait)) { - exit_status = si_external_process_wait(2, process, ECL_T); - exit_status = ecl_nth_value(the_env, 1); - } - @(return ((parent_read || parent_write)? - cl_make_two_way_stream(stream_read, stream_write) : - ECL_NIL) - exit_status - process) -@) + if (Null(pid)) { + if (parent_write) close(parent_write); + if (parent_read) close(parent_read); + if (parent_error) close(parent_error); + parent_write = 0; + parent_read = 0; + parent_error = 0; + remove_external_process(the_env, process); + FEerror("Could not spawn subprocess to run ~S.", 1, command); + } + if (parent_write > 0) { + stream_write = ecl_make_stream_from_fd(command, parent_write, + ecl_smm_output, 8, + ECL_STREAM_DEFAULT_FORMAT, + external_format); + } else { + parent_write = 0; + stream_write = cl_core.null_stream; + } + if (parent_read > 0) { + stream_read = ecl_make_stream_from_fd(command, parent_read, + ecl_smm_input, 8, + ECL_STREAM_DEFAULT_FORMAT, + external_format); + } else { + parent_read = 0; + stream_read = cl_core.null_stream; + } + if (parent_error > 0) { + stream_error = ecl_make_stream_from_fd(command, parent_error, + ecl_smm_input, 8, + ECL_STREAM_DEFAULT_FORMAT, + external_format); + } else { + parent_error = 0; + stream_error = cl_core.null_stream; + } + set_external_process_streams(process, stream_write, stream_read, + stream_error); + if (!Null(wait)) { + exit_status = si_external_process_wait(2, process, ECL_T); + exit_status = ecl_nth_value(the_env, 1); + } + @(return ((parent_read || parent_write)? + cl_make_two_way_stream(stream_read, stream_write) : + ECL_NIL) + exit_status + process); + @) diff -Nru ecl-16.1.2/src/c/vector_push.d ecl-16.1.3+ds/src/c/vector_push.d --- ecl-16.1.2/src/c/vector_push.d 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/c/vector_push.d 2016-12-19 10:25:00.000000000 +0000 @@ -1,22 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - string.d -- String routines. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL is free software; you can redistribute it and/or - modify it under thep 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. - - See file '../Copyright' for full details. -*/ - + * vector_push.d - vector optimizations + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include diff -Nru ecl-16.1.2/src/clos/change.lsp ecl-16.1.3+ds/src/clos/change.lsp --- ecl-16.1.2/src/clos/change.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clos/change.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -223,42 +223,41 @@ (declare (class class) (optimize (safety 0)) (si::c-local)) - (let ((class-name (class-name class))) - (dolist (slotd (class-slots class)) - ;; remove previous defined reader methods - (dolist (reader (slot-definition-readers slotd)) - (let* ((gf-object (fdefinition reader)) - found) - ;; primary method - (when (setq found - (find-method gf-object nil (list class-name) nil)) - (remove-method gf-object found)) - ;; before method - (when (setq found - (find-method gf-object ':before (list class-name) nil)) - (remove-method gf-object found)) - ;; after method - (when (setq found - (find-method gf-object ':after (list class-name) nil)) - (remove-method gf-object found)) + (dolist (slotd (class-slots class)) + ;; remove previous defined reader methods + (dolist (reader (slot-definition-readers slotd)) + (let* ((gf-object (fdefinition reader)) + found) + ;; primary method + (when (setq found + (find-method gf-object nil (list class) nil)) + (remove-method gf-object found)) + ;; before method + (when (setq found + (find-method gf-object ':before (list class) nil)) + (remove-method gf-object found)) + ;; after method + (when (setq found + (find-method gf-object ':after (list class) nil)) + (remove-method gf-object found)) (when (null (generic-function-methods gf-object)) (fmakunbound reader)))) - ;; remove previous defined writer methods - (dolist (writer (slot-definition-writers slotd)) - (let* ((gf-object (fdefinition writer)) - found) - ;; primary method - (when (setq found - (find-method gf-object nil (list 'T class-name) nil)) - (remove-method gf-object found)) - ;; before method - (when (setq found - (find-method gf-object ':before (list 'T class-name) nil)) - (remove-method gf-object found)) - ;; after method - (when (setq found - (find-method gf-object ':after (list 'T class-name) nil)) - (remove-method gf-object found)) + ;; remove previous defined writer methods + (dolist (writer (slot-definition-writers slotd)) + (let* ((gf-object (fdefinition writer)) + found) + ;; primary method + (when (setq found + (find-method gf-object nil (list 'T class) nil)) + (remove-method gf-object found)) + ;; before method + (when (setq found + (find-method gf-object ':before (list 'T class) nil)) + (remove-method gf-object found)) + ;; after method + (when (setq found + (find-method gf-object ':after (list 'T class) nil)) + (remove-method gf-object found)) (when (null (generic-function-methods gf-object)) - (fmakunbound writer))))))) + (fmakunbound writer)))))) diff -Nru ecl-16.1.2/src/clos/conditions.lsp ecl-16.1.3+ds/src/clos/conditions.lsp --- ecl-16.1.2/src/clos/conditions.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clos/conditions.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -180,7 +180,9 @@ (name (first expression2))) (case name (SIGNAL - (setq condition-form (second expression2))) + (setq condition-form `(coerce-to-condition ,(second expression2) + (list ,@ (cddr expression2)) + 'simple-condition 'signal))) (ERROR (setq condition-form `(coerce-to-condition ,(second expression2) (list ,@(cddr expression2)) @@ -403,7 +405,7 @@ (defun signal (datum &rest arguments) (let* ((condition - (coerce-to-condition datum arguments 'SIMPLE-CONDITION 'SIGNAL)) + (coerce-to-condition datum arguments 'SIMPLE-CONDITION 'SIGNAL)) (*handler-clusters* *handler-clusters*)) (if (typep condition *break-on-signals*) (break "~A~%Break entered because of *BREAK-ON-SIGNALS*." @@ -411,9 +413,8 @@ (loop (unless *handler-clusters* (return)) (let ((cluster (pop *handler-clusters*))) (dolist (handler cluster) -< (when (typep condition (car handler)) - (funcall (cdr handler) condition) - )))) + (when (typep condition (car handler)) + (funcall (cdr handler) condition))))) nil)) diff -Nru ecl-16.1.2/src/clos/kernel.lsp ecl-16.1.3+ds/src/clos/kernel.lsp --- ecl-16.1.2/src/clos/kernel.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clos/kernel.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -63,11 +63,11 @@ ;;; ---------------------------------------------------------------------- ;;; Methods -(defun install-method (name qualifiers specializers lambda-list fun wrap &rest options) +(defun install-method (name qualifiers specializers lambda-list fun &rest options) (declare (notinline ensure-generic-function)) ; (record-definition 'method `(method ,name ,@qualifiers ,specializers)) (let* ((gf (ensure-generic-function name)) - (fun (if wrap (wrapped-method-function fun) fun)) + (fun (wrapped-method-function fun)) (specializers (mapcar #'(lambda (x) (cond ((consp x) (intern-eql-specializer (second x))) ((typep x 'specializer) x) diff -Nru ecl-16.1.2/src/clos/method.lsp ecl-16.1.3+ds/src/clos/method.lsp --- ecl-16.1.2/src/clos/method.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clos/method.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -43,47 +43,31 @@ (slot-value generic-function 'method-class) (find-class 'standard-method))) +(defun method-prototype-for-gf (generic-function) + (when *clos-booted* + (class-prototype (generic-function-method-class generic-function)))) + (defmacro defmethod (&whole whole name &rest args &environment env) (declare (notinline make-method-lambda)) - (let* ((*print-length* 3) - (*print-depth* 2) - (qualifiers (loop while (and args (not (listp (first args)))) - collect (pop args))) - (specialized-lambda-list - (if args - (pop args) - (error "Illegal defmethod form: missing lambda list"))) - (body args)) + (multiple-value-bind (qualifiers specialized-lambda-list body) + (parse-defmethod args) (multiple-value-bind (lambda-list required-parameters specializers) (parse-specialized-lambda-list specialized-lambda-list) (multiple-value-bind (lambda-form declarations documentation) (make-raw-lambda name lambda-list required-parameters specializers body env) (let* ((generic-function (ensure-generic-function name)) - (method-class (generic-function-method-class generic-function)) - method) - (when *clos-booted* - (when (symbolp method-class) - (setf method-class (find-class method-class nil))) - (if method-class - (setf method (class-prototype method-class)) - (error "Cannot determine the method class for generic functions of type ~A" - (type-of generic-function)))) + (method (method-prototype-for-gf generic-function))) (multiple-value-bind (fn-form options) (make-method-lambda generic-function method lambda-form env) (when documentation (setf options (list* :documentation documentation options))) - (multiple-value-bind (wrapped-lambda wrapped-p) - (simplify-lambda name fn-form) - (unless wrapped-p - (error "Unable to unwrap function")) - (ext:register-with-pde - whole - `(install-method ',name ',qualifiers - ,(specializers-expression specializers) - ',lambda-list - ,(maybe-remove-block wrapped-lambda) - ,wrapped-p - ,@(mapcar #'si::maybe-quote options)))))))))) + (ext:register-with-pde + whole + `(install-method ',name ',qualifiers + ,(specializers-expression specializers) + ',lambda-list + ,(maybe-remove-block (simplify-lambda fn-form)) + ,@(mapcar #'si::maybe-quote options))))))))) (defun specializers-expression (specializers) (declare (si::c-local)) @@ -119,7 +103,7 @@ )))) method-lambda) -(defun simplify-lambda (method-name fn-form) +(defun simplify-lambda (fn-form) (let ((aux fn-form)) (if (and (eq (pop aux) 'lambda) (equalp (pop aux) '(.combined-method-args. *next-methods*)) @@ -130,8 +114,8 @@ (eq (third aux) '.combined-method-args.) (listp (setf aux (second aux))) (eq (first aux) 'lambda)) - (values aux t) - (values fn-form nil)))) + aux + (error "Unable to unwrap function")))) (defun make-raw-lambda (name lambda-list required-parameters specializers body env) (declare (si::c-local) @@ -198,6 +182,7 @@ (multiple-value-bind (declarations real-body documentation) (si::find-declarations (cddr method-lambda)) `(lambda ,(second method-lambda) + ,@declarations (let* ((.closed-combined-method-args. (if (listp .combined-method-args.) .combined-method-args. @@ -269,28 +254,19 @@ (defun legal-generic-function-name-p (name) (si::valid-function-name-p name)) -(defun parse-defmethod (args) - (declare (si::c-local)) - ;; This function has to extract the name of the method, a list of - ;; possible qualifiers (identified by not being lists), the lambda - ;; list of the method (which might be empty!) and the body of the - ;; function. - (let* (name) - (unless args - (error "Illegal defmethod form: missing method name")) - (setq name (pop args)) - (unless (legal-generic-function-name-p name) - (error "~A cannot be a generic function specifier.~%~ - It must be either a non-nil symbol or ~%~ - a list whose car is setf and whose second is a non-nil symbol." - name)) - (do ((qualifiers '())) - ((progn - (when (endp args) - (error "Illegal defmethod form: missing lambda-list")) - (listp (first args))) - (values name (nreverse qualifiers) (first args) (rest args))) - (push (pop args) qualifiers)))) +;;; PARSE-DEFMETHOD is used by DEFMETHOD to parse the &REST argument +;;; into the 'real' arguments. This is where the syntax of DEFMETHOD +;;; is really implemented. +(defun parse-defmethod (cdr-of-form) + (declare (si::c-local) + (list cdr-of-form)) + (let ((qualifiers ()) + (spec-ll ())) + (loop (if (and (car cdr-of-form) (atom (car cdr-of-form))) + (push (pop cdr-of-form) qualifiers) + (return (setq qualifiers (nreverse qualifiers))))) + (setq spec-ll (pop cdr-of-form)) + (values qualifiers spec-ll cdr-of-form))) (defun implicit-generic-lambda (lambda-list) "Implicit defgeneric declaration removes all &key arguments (preserving &key)" diff -Nru ecl-16.1.2/src/clos/package.lsp ecl-16.1.3+ds/src/clos/package.lsp --- ecl-16.1.2/src/clos/package.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clos/package.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -12,6 +12,8 @@ ;;;; ;;;; See file '../Copyright' for full details. +(pushnew :cdr-1 *features*) + (defpackage "CLOS" (:use "CL" "EXT") (:import-from "SI" "UNBOUND" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP" diff -Nru ecl-16.1.2/src/clos/print.lsp ecl-16.1.3+ds/src/clos/print.lsp --- ecl-16.1.2/src/clos/print.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clos/print.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -136,6 +136,9 @@ (values `(ext:hash-table-fill ,make-form ',content) nil)))) + (random-state + (let ((state (ext:random-state-array object))) + (values `(make-random-state ,state) nil))) (t (no-make-load-form object))))) @@ -150,7 +153,7 @@ (defun no-make-load-form (object) (declare (si::c-local)) - (error "No adequate specialization of MAKE-LOAD-FORM for an object of type" + (error "No adequate specialization of MAKE-LOAD-FORM for an object type ~A" (type-of object))) (defmethod make-load-form ((class class) &optional environment) @@ -169,12 +172,10 @@ ;;; ---------------------------------------------------------------------- (defmethod print-object ((instance t) stream) - (if (typep instance 'standard-object) - (let ((*package* (find-package "CL"))) - (print-unreadable-object (instance stream) - (format stream "~S" - (class-name (si:instance-class instance))))) - (write instance :stream stream)) + (let ((*package* (find-package "CL"))) + (print-unreadable-object (instance stream) + (format stream "~S" + (class-name (si:instance-class instance))))) instance) (defmethod print-object ((instance standard-object) stream) @@ -198,47 +199,67 @@ (defmethod print-object ((m standard-method) stream) (print-unreadable-object (m stream :type t) - (format stream "~A ~A" - (let ((gf (method-generic-function m))) - (if gf - (generic-function-name gf) - 'UNNAMED)) - (method-specializers m))) + (format stream "~A ~{~S ~}~S" + (let ((gf (method-generic-function m))) + (if gf + (generic-function-name gf) + 'UNNAMED)) + (method-qualifiers m) + (loop for spec in (method-specializers m) + collect (cond ((and (classp spec) + (class-name spec))) + ((typep spec 'eql-specializer) + `(eql ,(eql-specializer-object spec))) + (t spec))))) m) (defun ext::float-nan-string (x) - (when *print-readably* - (error 'print-not-readable :object x)) - (cdr (assoc (type-of x) - '((single-float . "#") - (double-float . "#") - (long-float . "#") - (short-float . "#"))))) + (unless (ext:float-nan-p x) + (signal 'type-error :datum x :expected-type 'float-nan)) + + (cond + ((null *print-readably*) + (etypecase x + (single-float "#") + (double-float "#") + (long-float "#") + (short-float "#"))) + #+ieee-floating-point + (*read-eval* + (etypecase x + (single-float "#.(coerce (si:nan) 'single-float)") + (double-float "#.(coerce (si:nan) 'double-float)") + (long-float "#.(coerce (si:nan) 'long-float)") + (short-float "#.(coerce (si:nan) 'short-float)"))) + (t (error 'print-not-readable :object x)))) (defun ext::float-infinity-string (x) - (when (and *print-readably* (null *read-eval*)) - (error 'print-not-readable :object x)) - (let* ((negative-infinities '((single-float . - "#.ext::single-float-negative-infinity") - (double-float . - "#.ext::double-float-negative-infinity") - (long-float . - "#.ext::long-float-negative-infinity") - (short-float . - "#.ext::short-float-negative-infinity"))) - (positive-infinities '((single-float . - "#.ext::single-float-positive-infinity") - (double-float . - "#.ext::double-float-positive-infinity") - (long-float . - "#.ext::long-float-positive-infinity") - (short-float . - "#.ext::short-float-positive-infinity"))) - (record (assoc (type-of x) - (if (plusp x) positive-infinities negative-infinities)))) - (unless record - (error "Not an infinity")) - (cdr record))) + (unless (ext:float-infinity-p x) + (signal 'type-error :datum x :expected-type 'float-infinity)) + + (cond + ((null *print-readably*) + (etypecase x + (ext:negative-single-float "#") + (ext:positive-single-float "#") + (ext:negative-double-float "#") + (ext:positive-double-float "#") + (ext:negative-long-float "#") + (ext:positive-long-float "#") + (ext:negative-short-float "#") + (ext:positive-short-float "#"))) + #+ieee-floating-point + (*read-eval* + (etypecase x + (ext:negative-single-float "#.ext::single-float-negative-infinity") + (ext:positive-single-float "#.ext::single-float-positive-infinity") + (ext:negative-double-float "#.ext::double-float-negative-infinity") + (ext:positive-double-float "#.ext::double-float-positive-infinity") + (ext:negative-long-float "#.ext::long-float-negative-infinity") + (ext:positive-long-float "#.ext::long-float-positive-infinity") + (ext:negative-short-float "#.ext::short-float-negative-infinity") + (ext:positive-short-float "#.ext::short-float-positive-infinity"))) + (t (error 'print-not-readable :object x)))) ;;; ---------------------------------------------------------------------- ;;; Describe diff -Nru ecl-16.1.2/src/clos/standard.lsp ecl-16.1.3+ds/src/clos/standard.lsp --- ecl-16.1.2/src/clos/standard.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clos/standard.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -163,33 +163,38 @@ (unless (find-if #'has-forward-referenced-parents (class-direct-superclasses class)) (finalize-inheritance class))) -(defmethod initialize-instance ((class class) &rest initargs &key direct-slots) +(defmethod initialize-instance ((class class) &rest initargs &key direct-slots direct-superclasses) (declare (ignore sealedp)) ;; convert the slots from lists to direct slots (apply #'call-next-method class :direct-slots (loop for s in direct-slots collect (canonical-slot-to-direct-slot class s)) + :direct-superclasses + direct-superclasses initargs) (finalize-unless-forward class) class) -(defmethod shared-initialize ((class class) slot-names &rest initargs &key direct-superclasses) - ;; verify that the inheritance list makes sense - (let* ((class (apply #'call-next-method class slot-names - :direct-superclasses - (if (slot-boundp class 'direct-superclasses) - (slot-value class 'direct-superclasses) - nil) - initargs)) - (direct-superclasses (check-direct-superclasses class direct-superclasses))) - (loop for c in (class-direct-superclasses class) - unless (member c direct-superclasses :test #'eq) - do (remove-direct-subclass c class)) - (setf (class-direct-superclasses class) direct-superclasses) - (loop for c in direct-superclasses - do (add-direct-subclass c class)) - class)) +(defmethod shared-initialize ((class class) slot-names &rest initargs + &key (direct-superclasses nil direct-superclasses-p)) + (if direct-superclasses-p + ;; verify that the inheritance list makes sense + (let* ((class (apply #'call-next-method class slot-names + :direct-superclasses + (if (slot-boundp class 'direct-superclasses) + (slot-value class 'direct-superclasses) + nil) + initargs)) + (direct-superclasses (check-direct-superclasses class direct-superclasses))) + (loop for c in (class-direct-superclasses class) + unless (member c direct-superclasses :test #'eq) + do (remove-direct-subclass c class)) + (setf (class-direct-superclasses class) direct-superclasses) + (loop for c in direct-superclasses + do (add-direct-subclass c class)) + class) + (apply #'call-next-method class slot-names initargs))) (defun precompute-valid-initarg-keywords (class) (setf (class-valid-initargs class) diff -Nru ecl-16.1.2/src/clos/walk.lsp ecl-16.1.3+ds/src/clos/walk.lsp --- ecl-16.1.2/src/clos/walk.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clos/walk.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -61,6 +61,9 @@ ;;; will need to call define-walker-template, they will have to figure that ;;; out for themselves. ;;; + +(pushnew :walker *features*) + (defpackage "WALKER" (:export define-walker-template walk-form @@ -77,7 +80,6 @@ (in-package "WALKER") (declaim (notinline note-lexical-binding walk-bindings-1 walk-let/let* walk-form-internal)) -(push :walker *features*) ;;; diff -Nru ecl-16.1.2/src/clx/attributes.lisp ecl-16.1.3+ds/src/clx/attributes.lisp --- ecl-16.1.2/src/clx/attributes.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/attributes.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,643 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; Window Attributes - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -;;; The special variable *window-attributes* is an alist containg: -;;; (drawable attributes attribute-changes geometry geometry-changes) -;;; Where DRAWABLE is the associated window or pixmap -;;; ATTRIBUTES is NIL or a reply-buffer containing the drawable's -;;; attributes for use by the accessors. -;;; ATTRIBUTE-CHANGES is NIL or an array. The first element -;;; of the array is a "value-mask", indicating which -;;; attributes have changed. The other elements are -;;; integers associated with the changed values, ready -;;; for insertion into a server request. -;;; GEOMETRY is like ATTRIBUTES, but for window geometry -;;; GEOMETRY-CHANGES is like ATTRIBUTE-CHANGES, but for window geometry -;;; -;;; Attribute and Geometry accessors and SETF's look on the special variable -;;; *window-attributes* for the drawable. If its not there, the accessor is -;;; NOT within a WITH-STATE, and a server request is made to get or put a value. -;;; If an entry is found in *window-attributes*, the cache buffers are used -;;; for the access. -;;; -;;; All WITH-STATE has to do (re)bind *Window-attributes* to a list including -;;; the new drawable. The caches are initialized to NIL and allocated as needed. - -(in-package :xlib) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +attribute-size+ 44) - (defconstant +geometry-size+ 24) - (defconstant +context-size+ (max +attribute-size+ +geometry-size+ (* 16 4)))) - -(defvar *window-attributes* nil) ;; Bound to an alist of (drawable . state) within WITH-STATE - -;; Window Attribute reply buffer resource -(defvar *context-free-list* nil) ;; resource of free reply buffers - -(defun allocate-context () - (or (threaded-atomic-pop *context-free-list* reply-next reply-buffer) - (make-reply-buffer +context-size+))) - -(defun deallocate-context (context) - (declare (type reply-buffer context)) - (threaded-atomic-push context *context-free-list* reply-next reply-buffer)) - -(defmacro state-attributes (state) `(second ,state)) -(defmacro state-attribute-changes (state) `(third ,state)) -(defmacro state-geometry (state) `(fourth ,state)) -(defmacro state-geometry-changes (state) `(fifth ,state)) - -(defmacro drawable-equal-function () - ;; Since drawables are not always cached, we must use drawable-equal - ;; to determine equality. - ''drawable-equal) - -(defmacro window-equal-function () - ;; Since windows are not always cached, we must use window-equal - ;; to determine equality. - ''window-equal) - -(defmacro with-state ((drawable) &body body) - ;; Allows a consistent view to be obtained of data returned by GetWindowAttributes - ;; and GetGeometry, and allows a coherent update using ChangeWindowAttributes and - ;; ConfigureWindow. The body is not surrounded by a with-display. Within the - ;; indefinite scope of the body, on a per-process basis in a multi-process - ;; environment, the first call within an Accessor Group on the specified drawable - ;; (the object, not just the variable) causes the complete results of the protocol - ;; request to be retained, and returned in any subsequent accessor calls. Calls - ;; within a Setf Group are delayed, and executed in a single request on exit from - ;; the body. In addition, if a call on a function within an Accessor Group follows - ;; a call on a function in the corresponding Setf Group, then all delayed setfs for - ;; that group are executed, any retained accessor information for that group is - ;; discarded, the corresponding protocol request is (re)issued, and the results are - ;; (again) retained, and returned in any subsequent accessor calls. - - ;; Accessor Group A (for GetWindowAttributes): - ;; window-visual, window-visual-info, window-class, window-gravity, window-bit-gravity, - ;; window-backing-store, window-backing-planes, window-backing-pixel, - ;; window-save-under, window-colormap, window-colormap-installed-p, - ;; window-map-state, window-all-event-masks, window-event-mask, - ;; window-do-not-propagate-mask, window-override-redirect - - ;; Setf Group A (for ChangeWindowAttributes): - ;; window-gravity, window-bit-gravity, window-backing-store, window-backing-planes, - ;; window-backing-pixel, window-save-under, window-event-mask, - ;; window-do-not-propagate-mask, window-override-redirect, window-colormap, - ;; window-cursor - - ;; Accessor Group G (for GetGeometry): - ;; drawable-root, drawable-depth, drawable-x, drawable-y, drawable-width, - ;; drawable-height, drawable-border-width - - ;; Setf Group G (for ConfigureWindow): - ;; drawable-x, drawable-y, drawable-width, drawable-height, drawable-border-width, - ;; window-priority - (let ((state-entry (gensym))) - ;; alist of (drawable attributes attribute-changes geometry geometry-changes) - `(with-stack-list (,state-entry ,drawable nil nil nil nil) - (with-stack-list* (*window-attributes* ,state-entry *window-attributes*) - (multiple-value-prog1 - (progn ,@body) - (cleanup-state-entry ,state-entry)))))) - -(defun cleanup-state-entry (state) - ;; Return buffers to the free-list - (let ((entry (state-attributes state))) - (when entry (deallocate-context entry))) - (let ((entry (state-attribute-changes state))) - (when entry - (put-window-attribute-changes (car state) entry) - (deallocate-gcontext-state entry))) - (let ((entry (state-geometry state))) - (when entry (deallocate-context entry))) - (let ((entry (state-geometry-changes state))) - (when entry - (put-drawable-geometry-changes (car state) entry) - (deallocate-gcontext-state entry)))) - - - -(defun change-window-attribute (window number value) - ;; Called from window attribute SETF's to alter an attribute value - ;; number is the change-attributes request mask bit number - (declare (type window window) - (type card8 number) - (type card32 value)) - (let ((state-entry nil) - (changes nil)) - (if (and *window-attributes* - (setq state-entry (assoc window (the list *window-attributes*) - :test (window-equal-function)))) - (progn ; Within a WITH-STATE - cache changes - (setq changes (state-attribute-changes state-entry)) - (unless changes - (setq changes (allocate-gcontext-state)) - (setf (state-attribute-changes state-entry) changes) - (setf (aref changes 0) 0)) ;; Initialize mask to zero - (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit - (setf (aref changes (1+ number)) value)) ;; save value - ; Send change to the server - (with-buffer-request ((window-display window) +x-changewindowattributes+) - (window window) - (card32 (ash 1 number) value))))) -;; -;; These two are twins (change-window-attribute change-drawable-geometry) -;; If you change one, you probably need to change the other... -;; -(defun change-drawable-geometry (drawable number value) - ;; Called from drawable geometry SETF's to alter an attribute value - ;; number is the change-attributes request mask bit number - (declare (type drawable drawable) - (type card8 number) - (type card29 value)) - (let ((state-entry nil) - (changes nil)) - (if (and *window-attributes* - (setq state-entry (assoc drawable (the list *window-attributes*) - :test (drawable-equal-function)))) - (progn ; Within a WITH-STATE - cache changes - (setq changes (state-geometry-changes state-entry)) - (unless changes - (setq changes (allocate-gcontext-state)) - (setf (state-geometry-changes state-entry) changes) - (setf (aref changes 0) 0)) ;; Initialize mask to zero - (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit - (setf (aref changes (1+ number)) value)) ;; save value - ; Send change to the server - (with-buffer-request ((drawable-display drawable) +x-configurewindow+) - (drawable drawable) - (card16 (ash 1 number)) - (card29 value))))) - -(defun get-window-attributes-buffer (window) - (declare (type window window)) - (let ((state-entry nil) - (changes nil)) - (or (and *window-attributes* - (setq state-entry (assoc window (the list *window-attributes*) - :test (window-equal-function))) - (null (setq changes (state-attribute-changes state-entry))) - (state-attributes state-entry)) - (let ((display (window-display window))) - (with-display (display) - ;; When SETF's have been done, flush changes to the server - (when changes - (put-window-attribute-changes window changes) - (deallocate-gcontext-state (state-attribute-changes state-entry)) - (setf (state-attribute-changes state-entry) nil)) - ;; Get window attributes - (with-buffer-request-and-reply (display +x-getwindowattributes+ size :sizes (8)) - ((window window)) - (let ((repbuf (or (state-attributes state-entry) (allocate-context)))) - (declare (type reply-buffer repbuf)) - ;; Copy into repbuf from reply buffer - (buffer-replace (reply-ibuf8 repbuf) buffer-bbuf 0 size) - (when state-entry (setf (state-attributes state-entry) repbuf)) - repbuf))))))) - -;; -;; These two are twins (get-window-attributes-buffer get-drawable-geometry-buffer) -;; If you change one, you probably need to change the other... -;; -(defun get-drawable-geometry-buffer (drawable) - (declare (type drawable drawable)) - (let ((state-entry nil) - (changes nil)) - (or (and *window-attributes* - (setq state-entry (assoc drawable (the list *window-attributes*) - :test (drawable-equal-function))) - (null (setq changes (state-geometry-changes state-entry))) - (state-geometry state-entry)) - (let ((display (drawable-display drawable))) - (with-display (display) - ;; When SETF's have been done, flush changes to the server - (when changes - (put-drawable-geometry-changes drawable changes) - (deallocate-gcontext-state (state-geometry-changes state-entry)) - (setf (state-geometry-changes state-entry) nil)) - ;; Get drawable attributes - (with-buffer-request-and-reply (display +x-getgeometry+ size :sizes (8)) - ((drawable drawable)) - (let ((repbuf (or (state-geometry state-entry) (allocate-context)))) - (declare (type reply-buffer repbuf)) - ;; Copy into repbuf from reply buffer - (buffer-replace (reply-ibuf8 repbuf) buffer-bbuf 0 size) - (when state-entry (setf (state-geometry state-entry) repbuf)) - repbuf))))))) - -(defun put-window-attribute-changes (window changes) - ;; change window attributes - ;; Always from Called within a WITH-DISPLAY - (declare (type window window) - (type gcontext-state changes)) - (let* ((display (window-display window)) - (mask (aref changes 0))) - (declare (type display display) - (type mask32 mask)) - (with-buffer-request (display +x-changewindowattributes+) - (window window) - (card32 mask) - (progn ;; Insert a word in the request for each one bit in the mask - (do ((bits mask (ash bits -1)) - (request-size 2) ;Word count - (i 1 (index+ i 1))) ;Entry count - ((zerop bits) - (card16-put 2 (index-incf request-size)) - (index-incf (buffer-boffset display) (index* request-size 4))) - (declare (type mask32 bits) - (type array-index i request-size)) - (when (oddp bits) - (card32-put (index* (index-incf request-size) 4) (aref changes i)))))))) -;; -;; These two are twins (put-window-attribute-changes put-drawable-geometry-changes) -;; If you change one, you probably need to change the other... -;; -(defun put-drawable-geometry-changes (window changes) - ;; change window attributes or geometry (depending on request-number...) - ;; Always from Called within a WITH-DISPLAY - (declare (type window window) - (type gcontext-state changes)) - (let* ((display (window-display window)) - (mask (aref changes 0))) - (declare (type display display) - (type mask16 mask)) - (with-buffer-request (display +x-configurewindow+) - (window window) - (card16 mask) - (progn ;; Insert a word in the request for each one bit in the mask - (do ((bits mask (ash bits -1)) - (request-size 2) ;Word count - (i 1 (index+ i 1))) ;Entry count - ((zerop bits) - (card16-put 2 (incf request-size)) - (index-incf (buffer-boffset display) (* request-size 4))) - (declare (type mask16 bits) - (type fixnum request-size) - (type array-index i)) - (when (oddp bits) - (card29-put (* (incf request-size) 4) (aref changes i)))))))) - -(defmacro with-attributes ((window &rest options) &body body) - `(let ((.with-attributes-reply-buffer. (get-window-attributes-buffer ,window))) - (declare (type reply-buffer .with-attributes-reply-buffer.)) - (prog1 - (with-buffer-input (.with-attributes-reply-buffer. ,@options) ,@body) - (unless *window-attributes* - (deallocate-context .with-attributes-reply-buffer.))))) -;; -;; These two are twins (with-attributes with-geometry) -;; If you change one, you probably need to change the other... -;; -(defmacro with-geometry ((window &rest options) &body body) - `(let ((.with-geometry-reply-buffer. (get-drawable-geometry-buffer ,window))) - (declare (type reply-buffer .with-geometry-reply-buffer.)) - (prog1 - (with-buffer-input (.with-geometry-reply-buffer. ,@options) ,@body) - (unless *window-attributes* - (deallocate-context .with-geometry-reply-buffer.))))) - -;;;----------------------------------------------------------------------------- -;;; Group A: (for GetWindowAttributes) -;;;----------------------------------------------------------------------------- - -(defun window-visual (window) - (declare (type window window)) - (declare (clx-values resource-id)) - (with-attributes (window :sizes 32) - (resource-id-get 8))) - -(defun window-visual-info (window) - (declare (type window window)) - (declare (clx-values visual-info)) - (with-attributes (window :sizes 32) - (visual-info (window-display window) (resource-id-get 8)))) - -(defun window-class (window) - (declare (type window window)) - (declare (clx-values (member :input-output :input-only))) - (with-attributes (window :sizes 16) - (member16-get 12 :copy :input-output :input-only))) - -(defun set-window-background (window background) - (declare (type window window) - (type (or (member :none :parent-relative) pixel pixmap) background)) - (cond ((eq background :none) (change-window-attribute window 0 0)) - ((eq background :parent-relative) (change-window-attribute window 0 1)) - ((integerp background) ;; Background pixel - (change-window-attribute window 0 0) ;; pixmap :NONE - (change-window-attribute window 1 background)) - ((type? background 'pixmap) ;; Background pixmap - (change-window-attribute window 0 (pixmap-id background))) - (t (x-type-error background '(or (member :none :parent-relative) integer pixmap)))) - background) - -#+Genera (eval-when (compile) (compiler:function-defined 'window-background)) - -(defsetf window-background set-window-background) - -(defun set-window-border (window border) - (declare (type window window) - (type (or (member :copy) pixel pixmap) border)) - (cond ((eq border :copy) (change-window-attribute window 2 0)) - ((type? border 'pixmap) ;; Border pixmap - (change-window-attribute window 2 (pixmap-id border))) - ((integerp border) ;; Border pixel - (change-window-attribute window 3 border)) - (t (x-type-error border '(or (member :copy) integer pixmap)))) - border) - -#+Genera (eval-when (compile) (compiler:function-defined 'window-border)) - -(defsetf window-border set-window-border) - -(defun window-bit-gravity (window) - ;; setf'able - (declare (type window window)) - (declare (clx-values bit-gravity)) - (with-attributes (window :sizes 8) - (member8-vector-get 14 +bit-gravity-vector+))) - -(defun set-window-bit-gravity (window gravity) - (change-window-attribute - window 4 (encode-type (member-vector +bit-gravity-vector+) gravity)) - gravity) - -(defsetf window-bit-gravity set-window-bit-gravity) - -(defun window-gravity (window) - ;; setf'able - (declare (type window window)) - (declare (clx-values win-gravity)) - (with-attributes (window :sizes 8) - (member8-vector-get 15 +win-gravity-vector+))) - -(defun set-window-gravity (window gravity) - (change-window-attribute - window 5 (encode-type (member-vector +win-gravity-vector+) gravity)) - gravity) - -(defsetf window-gravity set-window-gravity) - -(defun window-backing-store (window) - ;; setf'able - (declare (type window window)) - (declare (clx-values (member :not-useful :when-mapped :always))) - (with-attributes (window :sizes 8) - (member8-get 1 :not-useful :when-mapped :always))) - -(defun set-window-backing-store (window when) - (change-window-attribute - window 6 (encode-type (member :not-useful :when-mapped :always) when)) - when) - -(defsetf window-backing-store set-window-backing-store) - -(defun window-backing-planes (window) - ;; setf'able - (declare (type window window)) - (declare (clx-values pixel)) - (with-attributes (window :sizes 32) - (card32-get 16))) - -(defun set-window-backing-planes (window planes) - (change-window-attribute window 7 (encode-type card32 planes)) - planes) - -(defsetf window-backing-planes set-window-backing-planes) - -(defun window-backing-pixel (window) - ;; setf'able - (declare (type window window)) - (declare (clx-values pixel)) - (with-attributes (window :sizes 32) - (card32-get 20))) - -(defun set-window-backing-pixel (window pixel) - (change-window-attribute window 8 (encode-type card32 pixel)) - pixel) - -(defsetf window-backing-pixel set-window-backing-pixel) - -(defun window-save-under (window) - ;; setf'able - (declare (type window window)) - (declare (clx-values (member :off :on))) - (with-attributes (window :sizes 8) - (member8-get 24 :off :on))) - -(defun set-window-save-under (window when) - (change-window-attribute window 10 (encode-type (member :off :on) when)) - when) - -(defsetf window-save-under set-window-save-under) - -(defun window-override-redirect (window) - ;; setf'able - (declare (type window window)) - (declare (clx-values (member :off :on))) - (with-attributes (window :sizes 8) - (member8-get 27 :off :on))) - -(defun set-window-override-redirect (window when) - (change-window-attribute window 9 (encode-type (member :off :on) when)) - when) - -(defsetf window-override-redirect set-window-override-redirect) - -(defun window-event-mask (window) - ;; setf'able - (declare (type window window)) - (declare (clx-values mask32)) - (with-attributes (window :sizes 32) - (card32-get 36))) - -(defsetf window-event-mask (window) (event-mask) - (let ((em (gensym))) - `(let ((,em ,event-mask)) - (declare (type event-mask ,em)) - (change-window-attribute ,window 11 (encode-event-mask ,em)) - ,em))) - -(defun window-do-not-propagate-mask (window) - ;; setf'able - (declare (type window window)) - (declare (clx-values mask32)) - (with-attributes (window :sizes 32) - (card32-get 40))) - -(defsetf window-do-not-propagate-mask (window) (device-event-mask) - (let ((em (gensym))) - `(let ((,em ,device-event-mask)) - (declare (type device-event-mask ,em)) - (change-window-attribute ,window 12 (encode-device-event-mask ,em)) - ,em))) - -(defun window-colormap (window) - (declare (type window window)) - (declare (clx-values (or null colormap))) - (with-attributes (window :sizes 32) - (let ((id (resource-id-get 28))) - (if (zerop id) - nil - (let ((colormap (lookup-colormap (window-display window) id))) - (unless (colormap-visual-info colormap) - (setf (colormap-visual-info colormap) - (visual-info (window-display window) (resource-id-get 8)))) - colormap))))) - -(defun set-window-colormap (window colormap) - (change-window-attribute - window 13 (encode-type (or (member :copy) colormap) colormap)) - colormap) - -(defsetf window-colormap set-window-colormap) - -(defun window-cursor (window) - (declare (type window window)) - (declare (clx-values cursor)) - window - (error "~S can only be set" 'window-cursor)) - -(defun set-window-cursor (window cursor) - (change-window-attribute - window 14 (encode-type (or (member :none) cursor) cursor)) - cursor) - -(defsetf window-cursor set-window-cursor) - -(defun window-colormap-installed-p (window) - (declare (type window window)) - (declare (clx-values generalized-boolean)) - (with-attributes (window :sizes 8) - (boolean-get 25))) - -(defun window-all-event-masks (window) - (declare (type window window)) - (declare (clx-values mask32)) - (with-attributes (window :sizes 32) - (card32-get 32))) - -(defun window-map-state (window) - (declare (type window window)) - (declare (clx-values (member :unmapped :unviewable :viewable))) - (with-attributes (window :sizes 8) - (member8-get 26 :unmapped :unviewable :viewable))) - - -;;;----------------------------------------------------------------------------- -;;; Group G: (for GetGeometry) -;;;----------------------------------------------------------------------------- - -(defun drawable-root (drawable) - (declare (type drawable drawable)) - (declare (clx-values window)) - (with-geometry (drawable :sizes 32) - (window-get 8 (drawable-display drawable)))) - -(defun drawable-x (drawable) - ;; setf'able - (declare (type drawable drawable)) - (declare (clx-values int16)) - (with-geometry (drawable :sizes 16) - (int16-get 12))) - -(defun set-drawable-x (drawable x) - (change-drawable-geometry drawable 0 (encode-type int16 x)) - x) - -(defsetf drawable-x set-drawable-x) - -(defun drawable-y (drawable) - ;; setf'able - (declare (type drawable drawable)) - (declare (clx-values int16)) - (with-geometry (drawable :sizes 16) - (int16-get 14))) - -(defun set-drawable-y (drawable y) - (change-drawable-geometry drawable 1 (encode-type int16 y)) - y) - -(defsetf drawable-y set-drawable-y) - -(defun drawable-width (drawable) - ;; setf'able - ;; Inside width, excluding border. - (declare (type drawable drawable)) - (declare (clx-values card16)) - (with-geometry (drawable :sizes 16) - (card16-get 16))) - -(defun set-drawable-width (drawable width) - (change-drawable-geometry drawable 2 (encode-type card16 width)) - width) - -(defsetf drawable-width set-drawable-width) - -(defun drawable-height (drawable) - ;; setf'able - ;; Inside height, excluding border. - (declare (type drawable drawable)) - (declare (clx-values card16)) - (with-geometry (drawable :sizes 16) - (card16-get 18))) - -(defun set-drawable-height (drawable height) - (change-drawable-geometry drawable 3 (encode-type card16 height)) - height) - -(defsetf drawable-height set-drawable-height) - -(defun drawable-depth (drawable) - (declare (type drawable drawable)) - (declare (clx-values card8)) - (with-geometry (drawable :sizes 8) - (card8-get 1))) - -(defun drawable-border-width (drawable) - ;; setf'able - (declare (type drawable drawable)) - (declare (clx-values integer)) - (with-geometry (drawable :sizes 16) - (card16-get 20))) - -(defun set-drawable-border-width (drawable width) - (change-drawable-geometry drawable 4 (encode-type card16 width)) - width) - -(defsetf drawable-border-width set-drawable-border-width) - -(defun set-window-priority (mode window sibling) - (declare (type (member :above :below :top-if :bottom-if :opposite) mode) - (type window window) - (type (or null window) sibling)) - (with-state (window) - (change-drawable-geometry - window 6 (encode-type (member :above :below :top-if :bottom-if :opposite) mode)) - (when sibling - (change-drawable-geometry window 5 (encode-type window sibling)))) - mode) - -#+Genera (eval-when (compile) (compiler:function-defined 'window-priority)) - -(defsetf window-priority (window &optional sibling) (mode) - ;; A bit strange, but retains setf form. - `(set-window-priority ,mode ,window ,sibling)) diff -Nru ecl-16.1.2/src/clx/big-requests.lisp ecl-16.1.3+ds/src/clx/big-requests.lisp --- ecl-16.1.2/src/clx/big-requests.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/big-requests.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,31 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- -;;; -;;; (c) copyright 2006 Richard Kreuter -;;; (c) copyright 2007 by Christophe Rhodes -;;; -;;; Permission is granted to any individual or institution to use, -;;; copy, modify, and distribute this software, provided that this -;;; complete copyright and permission notice is maintained, intact, in -;;; all copies and supporting documentation. -;;; -;;; 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. - -(in-package "XLIB") - -;;; No new events or errors are defined by this extension. (Big -;;; Requests Extension, section 3) -;;; -;;; The name of this extension is "BIG-REQUESTS" (Big Requests -;;; Extension, section 4) -(define-extension "BIG-REQUESTS") - -(defun enable-big-requests (display) - (declare (type display display)) - (let ((opcode (extension-opcode display "BIG-REQUESTS"))) - (with-buffer-request-and-reply (display opcode nil) - ((data 0)) - (let ((maximum-request-length (card32-get 8))) - (setf (display-extended-max-request-length display) - maximum-request-length))))) diff -Nru ecl-16.1.2/src/clx/buffer.lisp ecl-16.1.3+ds/src/clx/buffer.lisp --- ecl-16.1.2/src/clx/buffer.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/buffer.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,1417 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; This file contains definitions for the BUFFER object for Common-Lisp X -;;; windows version 11 - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -;; A few notes: -;; -;; 1. The BUFFER implements a two-way buffered byte / half-word -;; / word stream. Hooks are left for implementing this with a -;; shared memory buffer, or with effenciency hooks to the network -;; code. -;; -;; 2. The BUFFER object uses overlapping displaced arrays for -;; inserting and removing bytes half-words and words. -;; -;; 3. The BYTE component of these arrays is written to a STREAM -;; associated with the BUFFER. The stream has its own buffer. -;; This may be made more efficient by using the Zetalisp -;; :Send-Output-Buffer operation. -;; -;; 4. The BUFFER object is INCLUDED in the DISPLAY object. -;; This was done to reduce access time when sending requests, -;; while maintaing some code modularity. -;; Several buffer functions are duplicated (with-buffer, -;; buffer-force-output, close-buffer) to keep the naming -;; conventions consistent. -;; -;; 5. A nother layer of software is built on top of this for generating -;; both client and server interface routines, given a specification -;; of the protocol. (see the INTERFACE file) -;; -;; 6. Care is taken to leave the buffer pointer (buffer-bbuf) set to -;; a point after a complete request. This is to ensure that a partial -;; request won't be left after aborts (e.g. control-abort on a lispm). - -(in-package :xlib) - -(defconstant +requestsize+ 160) ;; Max request size (excluding variable length requests) - -;;; This is here instead of in bufmac so that with-display can be -;;; compiled without macros and bufmac being loaded. - -(defmacro with-buffer ((buffer &key timeout inline) - &body body &environment env) - ;; This macro is for use in a multi-process environment. It provides - ;; exclusive access to the local buffer object for request generation and - ;; reply processing. - `(macrolet ((with-buffer ((buffer &key timeout) &body body) - ;; Speedup hack for lexically nested with-buffers - `(progn - (progn ,buffer ,@(and timeout `(,timeout)) nil) - ,@body))) - ,(if (and (null inline) (macroexpand '(use-closures) env)) - `(flet ((.with-buffer-body. () ,@body)) - #+clx-ansi-common-lisp - (declare (dynamic-extent #'.with-buffer-body.)) - (with-buffer-function ,buffer ,timeout #'.with-buffer-body.)) - (let ((buf (if (or (symbolp buffer) (constantp buffer)) - buffer - '.buffer.))) - `(let (,@(unless (eq buf buffer) `((,buf ,buffer)))) - ,@(unless (eq buf buffer) `((declare (type buffer ,buf)))) - ,(declare-bufmac) - (when (buffer-dead ,buf) - (x-error 'closed-display :display ,buf)) - (holding-lock ((buffer-lock ,buf) ,buf "CLX Display Lock" - ,@(and timeout `(:timeout ,timeout))) - ,@body)))))) - -(defun with-buffer-function (buffer timeout function) - (declare (type display buffer) - (type (or null number) timeout) - (type function function) - #+clx-ansi-common-lisp - (dynamic-extent function) - ;; FIXME: This is probably more a bug in SBCL (logged as - ;; bug #243) - (ignorable timeout) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg function)) - (with-buffer (buffer :timeout timeout :inline t) - (funcall function))) - -;;; The following are here instead of in bufmac so that event-case can -;;; be compiled without macros and bufmac being loaded. - -(defmacro read-card8 (byte-index) - `(aref-card8 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro read-int8 (byte-index) - `(aref-int8 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro read-card16 (byte-index) - #+clx-overlapping-arrays - `(aref-card16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1))) - #-clx-overlapping-arrays - `(aref-card16 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro read-int16 (byte-index) - #+clx-overlapping-arrays - `(aref-int16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1))) - #-clx-overlapping-arrays - `(aref-int16 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro read-card32 (byte-index) - #+clx-overlapping-arrays - `(aref-card32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2))) - #-clx-overlapping-arrays - `(aref-card32 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro read-int32 (byte-index) - #+clx-overlapping-arrays - `(aref-int32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2))) - #-clx-overlapping-arrays - `(aref-int32 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro read-card29 (byte-index) - #+clx-overlapping-arrays - `(aref-card29 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2))) - #-clx-overlapping-arrays - `(aref-card29 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro event-code (reply-buffer) - ;; The reply-buffer structure is used for events. - ;; The size slot is used for the event code. - `(reply-size ,reply-buffer)) - -(defmacro reading-event ((event &rest options) &body body) - (declare (arglist (buffer &key sizes) &body body)) - ;; BODY may contain calls to (READ32 &optional index) etc. - ;; These calls will read from the input buffer at byte - ;; offset INDEX. If INDEX is not supplied, then the next - ;; word, half-word or byte is returned. - `(with-buffer-input (,event ,@options) ,@body)) - -(defmacro with-buffer-input ((reply-buffer &key display (sizes '(8 16 32)) index) - &body body) - (unless (listp sizes) (setq sizes (list sizes))) - ;; 160 is a special hack for client-message-events - (when (set-difference sizes '(0 8 16 32 160 256)) - (error "Illegal sizes in ~a" sizes)) - `(let ((%reply-buffer ,reply-buffer) - ,@(and display `((%buffer ,display)))) - (declare (type reply-buffer %reply-buffer) - ,@(and display '((type display %buffer)))) - ,(declare-bufmac) - ,@(and display '(%buffer)) - (let* ((buffer-boffset (the array-index ,(or index 0))) - #-clx-overlapping-arrays - (buffer-bbuf (reply-ibuf8 %reply-buffer)) - #+clx-overlapping-arrays - ,@(append - (when (member 8 sizes) - `((buffer-bbuf (reply-ibuf8 %reply-buffer)))) - (when (or (member 16 sizes) (member 160 sizes)) - `((buffer-woffset (index-ash buffer-boffset -1)) - (buffer-wbuf (reply-ibuf16 %reply-buffer)))) - (when (member 32 sizes) - `((buffer-loffset (index-ash buffer-boffset -2)) - (buffer-lbuf (reply-ibuf32 %reply-buffer)))))) - (declare (type array-index buffer-boffset)) - #-clx-overlapping-arrays - (declare (type buffer-bytes buffer-bbuf)) - #+clx-overlapping-arrays - ,@(append - (when (member 8 sizes) - '((declare (type buffer-bytes buffer-bbuf)))) - (when (member 16 sizes) - '((declare (type array-index buffer-woffset)) - (declare (type buffer-words buffer-wbuf)))) - (when (member 32 sizes) - '((declare (type array-index buffer-loffset)) - (declare (type buffer-longs buffer-lbuf))))) - buffer-boffset - #-clx-overlapping-arrays - buffer-bbuf - #+clx-overlapping-arrays - ,@(append - (when (member 8 sizes) '(buffer-bbuf)) - (when (member 16 sizes) '(buffer-woffset buffer-wbuf)) - (when (member 32 sizes) '(buffer-loffset buffer-lbuf))) - #+clx-overlapping-arrays - (macrolet ((%buffer-sizes () ',sizes)) - ,@body) - #-clx-overlapping-arrays - ,@body))) - -(defun make-buffer (output-size constructor &rest options) - (declare (dynamic-extent options)) - ;; Output-Size is the output-buffer size in bytes. - (let ((byte-output (make-array output-size :element-type 'card8 - :initial-element 0))) - (apply constructor - :size output-size - :obuf8 byte-output - #+clx-overlapping-arrays - :obuf16 - #+clx-overlapping-arrays - (make-array (index-ash output-size -1) - :element-type 'overlap16 - :displaced-to byte-output) - #+clx-overlapping-arrays - :obuf32 - #+clx-overlapping-arrays - (make-array (index-ash output-size -2) - :element-type 'overlap32 - :displaced-to byte-output) - options))) - -(defun make-reply-buffer (size) - ;; Size is the buffer size in bytes - (let ((byte-input (make-array size :element-type 'card8 - :initial-element 0))) - (make-reply-buffer-internal - :size size - :ibuf8 byte-input - #+clx-overlapping-arrays - :ibuf16 - #+clx-overlapping-arrays - (make-array (index-ash size -1) - :element-type 'overlap16 - :displaced-to byte-input) - #+clx-overlapping-arrays - :ibuf32 - #+clx-overlapping-arrays - (make-array (index-ash size -2) - :element-type 'overlap32 - :displaced-to byte-input)))) - -(defun buffer-ensure-size (buffer size) - (declare (type buffer buffer) - (type array-index size)) - (when (index> size (buffer-size buffer)) - (with-buffer (buffer) - (buffer-flush buffer) - (let* ((new-buffer-size (index-ash 1 (integer-length (index1- size)))) - (new-buffer (make-array new-buffer-size :element-type 'card8 - :initial-element 0))) - (setf (buffer-obuf8 buffer) new-buffer) - #+clx-overlapping-arrays - (setf (buffer-obuf16 buffer) - (make-array (index-ash new-buffer-size -1) - :element-type 'overlap16 - :displaced-to new-buffer) - (buffer-obuf32 buffer) - (make-array (index-ash new-buffer-size -2) - :element-type 'overlap32 - :displaced-to new-buffer)))))) - -(defun buffer-pad-request (buffer pad) - (declare (type buffer buffer) - (type array-index pad)) - (unless (index-zerop pad) - (when (index> (index+ (buffer-boffset buffer) pad) - (buffer-size buffer)) - (buffer-flush buffer)) - (incf (buffer-boffset buffer) pad) - (unless (index-zerop (index-mod (buffer-boffset buffer) 4)) - (buffer-flush buffer)))) - -(declaim (inline buffer-new-request-number)) - -(defun buffer-new-request-number (buffer) - (declare (type buffer buffer)) - (setf (buffer-request-number buffer) - (ldb (byte 16 0) (1+ (buffer-request-number buffer))))) - -(defun with-buffer-request-function (display gc-force request-function) - (declare (type display display) - (type (or null gcontext) gc-force)) - (declare (type function request-function) - #+clx-ansi-common-lisp - (dynamic-extent request-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg request-function)) - (with-buffer (display :inline t) - (multiple-value-prog1 - (progn - (when gc-force (force-gcontext-changes-internal gc-force)) - (without-aborts (funcall request-function display))) - (display-invoke-after-function display)))) - -(defun with-buffer-request-function-nolock (display gc-force request-function) - (declare (type display display) - (type (or null gcontext) gc-force)) - (declare (type function request-function) - #+clx-ansi-common-lisp - (dynamic-extent request-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg request-function)) - (multiple-value-prog1 - (progn - (when gc-force (force-gcontext-changes-internal gc-force)) - (without-aborts (funcall request-function display))) - (display-invoke-after-function display))) - -(defstruct (pending-command (:copier nil) (:predicate nil)) - (sequence 0 :type card16) - (reply-buffer nil :type (or null reply-buffer)) - (process nil) - (next nil #-explorer :type #-explorer (or null pending-command))) - -(defun with-buffer-request-and-reply-function - (display multiple-reply request-function reply-function) - (declare (type display display) - (type generalized-boolean multiple-reply)) - (declare (type function request-function reply-function) - #+clx-ansi-common-lisp - (dynamic-extent request-function reply-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg request-function reply-function)) - (let ((pending-command nil) - (reply-buffer nil)) - (declare (type (or null pending-command) pending-command) - (type (or null reply-buffer) reply-buffer)) - (unwind-protect - (progn - (with-buffer (display :inline t) - (setq pending-command (start-pending-command display)) - (without-aborts (funcall request-function display)) - (buffer-force-output display) - (display-invoke-after-function display)) - (cond (multiple-reply - (loop - (setq reply-buffer (read-reply display pending-command)) - (when (funcall reply-function display reply-buffer) (return nil)) - (deallocate-reply-buffer (shiftf reply-buffer nil)))) - (t - (setq reply-buffer (read-reply display pending-command)) - (funcall reply-function display reply-buffer)))) - (when reply-buffer (deallocate-reply-buffer reply-buffer)) - (when pending-command (stop-pending-command display pending-command))))) - -;; -;; Buffer stream operations -;; - -(defun buffer-write (vector buffer start end) - ;; Write out VECTOR from START to END into BUFFER - ;; Internal function, MUST BE CALLED FROM WITHIN WITH-BUFFER - (declare (type buffer buffer) - (type array-index start end)) - (when (buffer-dead buffer) - (x-error 'closed-display :display buffer)) - (wrap-buf-output (buffer) - (funcall (buffer-write-function buffer) vector buffer start end)) - nil) - -(defun buffer-flush (buffer) - ;; Write the buffer contents to the server stream - doesn't force-output the stream - ;; Internal function, MUST BE CALLED FROM WITHIN WITH-BUFFER - (declare (type buffer buffer)) - (unless (buffer-flush-inhibit buffer) - (let ((boffset (buffer-boffset buffer))) - (declare (type array-index boffset)) - (when (index-plusp boffset) - (buffer-write (buffer-obuf8 buffer) buffer 0 boffset) - (setf (buffer-boffset buffer) 0) - (setf (buffer-last-request buffer) nil)))) - nil) - -(defmacro with-buffer-flush-inhibited ((buffer) &body body) - (let ((buf (if (or (symbolp buffer) (constantp buffer)) buffer '.buffer.))) - `(let* (,@(and (not (eq buf buffer)) `((,buf ,buffer))) - (.saved-buffer-flush-inhibit. (buffer-flush-inhibit ,buf))) - (unwind-protect - (progn - (setf (buffer-flush-inhibit ,buf) t) - ,@body) - (setf (buffer-flush-inhibit ,buf) .saved-buffer-flush-inhibit.))))) - -(defun buffer-force-output (buffer) - ;; Output is normally buffered, this forces any buffered output to the server. - (declare (type buffer buffer)) - (when (buffer-dead buffer) - (x-error 'closed-display :display buffer)) - (buffer-flush buffer) - (wrap-buf-output (buffer) - (without-aborts - (funcall (buffer-force-output-function buffer) buffer))) - nil) - -(defun close-buffer (buffer &key abort) - ;; Close the host connection in BUFFER - (declare (type buffer buffer)) - (unless (null (buffer-output-stream buffer)) - (wrap-buf-output (buffer) - (funcall (buffer-close-function buffer) buffer :abort abort)) - (setf (buffer-dead buffer) t) - ;; Zap pointers to the streams, to ensure they're GC'd - (setf (buffer-output-stream buffer) nil) - (setf (buffer-input-stream buffer) nil) - ) - nil) - -(defun buffer-input (buffer vector start end &optional timeout) - ;; Read into VECTOR from the buffer stream - ;; Timeout, when non-nil, is in seconds - ;; Returns non-nil if EOF encountered - ;; Returns :TIMEOUT when timeout exceeded - (declare (type buffer buffer) - (type vector vector) - (type array-index start end) - (type (or null number) timeout)) - (declare (clx-values eof-p)) - (when (buffer-dead buffer) - (x-error 'closed-display :display buffer)) - (unless (= start end) - (let ((result - (wrap-buf-input (buffer) - (funcall (buffer-input-function buffer) - buffer vector start end timeout)))) - (unless (or (null result) (eq result :timeout)) - (close-buffer buffer)) - result))) - -(defun buffer-input-wait (buffer timeout) - ;; Timeout, when non-nil, is in seconds - ;; Returns non-nil if EOF encountered - ;; Returns :TIMEOUT when timeout exceeded - (declare (type buffer buffer) - (type (or null number) timeout)) - (declare (clx-values timeout)) - (when (buffer-dead buffer) - (x-error 'closed-display :display buffer)) - (let ((result - (wrap-buf-input (buffer) - (funcall (buffer-input-wait-function buffer) - buffer timeout)))) - (unless (or (null result) (eq result :timeout)) - (close-buffer buffer)) - result)) - -(defun buffer-listen (buffer) - ;; Returns T if there is input available for the buffer. This should never - ;; block, so it can be called from the scheduler. - (declare (type buffer buffer)) - (declare (clx-values input-available)) - (or (not (null (buffer-dead buffer))) - (wrap-buf-input (buffer) - (funcall (buffer-listen-function buffer) buffer)))) - -;;; Reading sequences of strings - -;;; a list of pascal-strings with card8 lengths, no padding in between -;;; can't use read-sequence-char -(defun read-sequence-string (buffer-bbuf length nitems result-type - &optional (buffer-boffset 0)) - (declare (type buffer-bytes buffer-bbuf) - (type array-index length nitems buffer-boffset)) - length - (with-vector (buffer-bbuf buffer-bytes) - (let ((result (make-sequence result-type nitems))) - (do* ((index 0 (index+ index 1 string-length)) - (count 0 (index1+ count)) - (string-length 0) - (string "")) - ((index>= count nitems) - result) - (declare (type array-index index count string-length) - (type string string)) - (setq string-length (read-card8 index) - string (make-sequence 'string string-length)) - (do ((i (index1+ index) (index1+ i)) - (j 0 (index1+ j))) - ((index>= j string-length) - (setf (elt result count) string)) - (declare (type array-index i j)) - (setf (aref string j) (card8->char (read-card8 i)))))))) - -;;; Reading sequences of chars - -(defmacro define-transformed-sequence-reader (name totype transformer reader) - (let ((ntrans (gensym))) - `(defun ,name (reply-buffer result-type nitems &optional transform data (start 0) (index 0)) - (declare - (type reply-buffer reply-buffer) - (type t result-type) - (type array-index nitems start index) - (type (or null sequence) data) - (type (or null (function (,totype) t)) transform) - #+clx-ansi-common-lisp (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) - (if transform - (flet ((,ntrans (v) (funcall transform (,transformer v)))) - #+clx-ansi-common-lisp (declare (dynamic-extent #',ntrans)) - (,reader reply-buffer result-type nitems #',ntrans data start index)) - (,reader reply-buffer result-type nitems #',transformer data start index))))) - -(define-transformed-sequence-reader read-sequence-char character - card8->char read-sequence-card8) - -;;; Reading sequences of card8's - -(defmacro define-list-readers ((name tname) type size step reader) - `(progn - (defun ,name (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type list data)) - (with-buffer-input (reply-buffer :sizes (,size) :index index) - (do* ((j nitems (index- j 1)) - (list (nthcdr start data) (cdr list)) - (index 0 (index+ index ,step))) - ((index-zerop j)) - (declare (type array-index index j) (type list list)) - (setf (car list) (,reader index))))) - (defun ,tname (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type list data) - (type (function (,type) t) transform) - #+clx-ansi-common-lisp (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) - (with-buffer-input (reply-buffer :sizes (,size) :index index) - (do* ((j nitems (index- j 1)) - (list (nthcdr start data) (cdr list)) - (index 0 (index+ index ,step))) - ((index-zerop j)) - (declare (type array-index index j) (type list list)) - (setf (car list) (funcall transform (,reader index)))))))) - -(define-list-readers (read-list-card8 read-list-card8-with-transform) card8 - 8 1 read-card8) - -#-lispm -(defun read-simple-array-card8 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card8 (*)) data)) - (with-vector (data (simple-array card8 (*))) - (with-buffer-input (reply-buffer :sizes (8)) - (buffer-replace data buffer-bbuf start (index+ start nitems) index)))) - -#-lispm -(defun read-simple-array-card8-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card8 (*)) data)) - (declare (type (function (card8) card8) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data (simple-array card8 (*))) - (with-buffer-input (reply-buffer :sizes (8) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 1))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (the card8 (funcall transform (read-card8 index)))))))) - -(defun read-vector-card8 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data) - (optimize #+cmu(ext:inhibit-warnings 3))) - (with-vector (data vector) - (with-buffer-input (reply-buffer :sizes (8) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 1))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (read-card8 index)))))) - -(defun read-vector-card8-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data) - (optimize #+cmu(ext:inhibit-warnings 3))) - (declare (type (function (card8) t) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data vector) - (with-buffer-input (reply-buffer :sizes (8) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 1))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (funcall transform (read-card8 index))))))) - -(defmacro define-sequence-reader (name type (list tlist) (sa tsa) (vec tvec)) - `(defun ,name (reply-buffer result-type nitems &optional transform data (start 0) (index 0)) - (declare - (type reply-buffer reply-buffer) - (type t result-type) - (type array-index nitems start index) - (type (or null sequence) data) - (type (or null (function (,type) t)) transform) - #+clx-ansi-common-lisp (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) - (let ((result (or data (make-sequence result-type nitems)))) - (typecase result - (list - (if transform - (,tlist reply-buffer nitems result transform start index) - (,list reply-buffer nitems result start index))) - #-lispm - ((simple-array ,type (*)) - (if transform - (,tsa reply-buffer nitems result transform start index) - (,sa reply-buffer nitems result start index))) - ;; FIXME: general sequences - (t - (if transform - (,tvec reply-buffer nitems result transform start index) - (,vec reply-buffer nitems result start index)))) - result))) - -(define-sequence-reader read-sequence-card8 card8 - (read-list-card8 read-list-card8-with-transform) - (read-simple-array-card8 read-simple-array-card8-with-transform) - (read-vector-card8 read-vector-card8-with-transform)) - -(define-transformed-sequence-reader read-sequence-int8 int8 - card8->int8 read-sequence-card8) - -;;; Reading sequences of card16's - -(define-list-readers (read-list-card16 read-list-card16-with-transform) card16 - 16 2 read-card16) - -#-lispm -(defun read-simple-array-card16 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card16 (*)) data)) - (with-vector (data (simple-array card16 (*))) - (with-buffer-input (reply-buffer :sizes (16) :index index) - #-clx-overlapping-arrays - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 2))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (the card16 (read-card16 index)))) - #+clx-overlapping-arrays - (buffer-replace data buffer-wbuf start (index+ start nitems) (index-floor index 2))))) - -#-lispm -(defun read-simple-array-card16-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card16 (*)) data)) - (declare (type (function (card16) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data (simple-array card16 (*))) - (with-buffer-input (reply-buffer :sizes (16) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 2))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (the card16 (funcall transform (read-card16 index)))))))) - -(defun read-vector-card16 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data) - (optimize #+cmu(ext:inhibit-warnings 3))) - (with-vector (data vector) - (with-buffer-input (reply-buffer :sizes (16) :index index) - #-clx-overlapping-arrays - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 2))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (read-card16 index))) - #+clx-overlapping-arrays - (buffer-replace data buffer-wbuf start (index+ start nitems) (index-floor index 2))))) - -(defun read-vector-card16-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data) - (optimize #+cmu(ext:inhibit-warnings 3))) - (declare (type (function (card16) t) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data vector) - (with-buffer-input (reply-buffer :sizes (16) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 2))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (funcall transform (read-card16 index))))))) - -(define-sequence-reader read-sequence-card16 card16 - (read-list-card16 read-list-card16-with-transform) - (read-simple-array-card16 read-simple-array-card16-with-transform) - (read-vector-card16 read-vector-card16-with-transform)) - -(define-transformed-sequence-reader read-sequence-int16 int16 - card16->int16 read-sequence-card16) - -;;; Reading sequences of card32's - -(define-list-readers (read-list-card32 read-list-card32-with-transform) card32 - 32 4 read-card32) - -#-lispm -(defun read-simple-array-card32 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card32 (*)) data)) - (with-vector (data (simple-array card32 (*))) - (with-buffer-input (reply-buffer :sizes (32) :index index) - #-clx-overlapping-arrays - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 4))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (the card32 (read-card32 index)))) - #+clx-overlapping-arrays - (buffer-replace data buffer-lbuf start (index+ start nitems) (index-floor index 4))))) - -#-lispm -(defun read-simple-array-card32-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card32 (*)) data)) - (declare (type (function (card32) card32) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data (simple-array card32 (*))) - (with-buffer-input (reply-buffer :sizes (32) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 4))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (the card32 (funcall transform (read-card32 index)))))))) - -(defun read-vector-card32 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data) - (optimize #+cmu(ext:inhibit-warnings 3))) - (with-vector (data vector) - (with-buffer-input (reply-buffer :sizes (32) :index index) - #-clx-overlapping-arrays - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 4))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (read-card32 index))) - #+clx-overlapping-arrays - (buffer-replace data buffer-lbuf start (index+ start nitems) (index-floor index 4))))) - -(defun read-vector-card32-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data) - (optimize #+cmu(ext:inhibit-warnings 3))) - (declare (type (function (card32) t) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data vector) - (with-buffer-input (reply-buffer :sizes (32) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 4))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (funcall transform (read-card32 index))))))) - -(define-sequence-reader read-sequence-card32 card32 - (read-list-card32 read-list-card32-with-transform) - (read-simple-array-card32 read-simple-array-card32-with-transform) - (read-vector-card32 read-vector-card32-with-transform)) - -(define-transformed-sequence-reader read-sequence-int32 int32 - card32->int32 read-sequence-card32) - -;;; Writing sequences of chars - -(defmacro define-transformed-sequence-writer (name fromtype transformer writer) - (let ((ntrans (gensym))) - `(defun ,name (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare - (type buffer buffer) - (type sequence data) - (type array-index boffset start end) - (type (or null (function (t) ,fromtype)) transform) - #+clx-ansi-common-lisp (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) - (if transform - (flet ((,ntrans (x) (,transformer (the ,fromtype (funcall transform x))))) - #+clx-ansi-common-lisp (declare (dynamic-extent #',ntrans)) - (,writer buffer boffset data start end #',ntrans)) - (,writer buffer boffset data start end #',transformer))))) - -(define-transformed-sequence-writer write-sequence-char character - char->card8 write-sequence-card8) - -;;; Writing sequences of card8's - -(defmacro define-list-writers ((name tname) type step writer) - `(progn - (defun ,name (buffer boffset data start end) - (declare - (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (writing-buffer-chunks ,type - ((list (nthcdr start data))) - ((type list list)) - (do ((j 0 (index+ j ,step))) - ((index>= j chunk)) - (declare (type array-index j)) - (,writer j (pop list))))) - (defun ,tname (buffer boffset data start end transform) - (declare - (type buffer buffer) - (type list data) - (type array-index boffset start end) - (type (function (t) ,type) transform) - #+clx-ansi-common-lisp (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) - (writing-buffer-chunks ,type - ((list (nthcdr start data))) - ((type list list)) - (do ((j 0 (index+ j ,step))) - ((index>= j chunk)) - (declare (type array-index j)) - (,writer j (funcall transform (pop list)))))))) - -;;; original CLX comment: "TI Compiler bug", in WRITE-LIST-CARD8 -#+ti -(progn - (defun write-list-card8 (buffer boffset data start end) - (writing-buffer-chunks card8 - ((list (nthcdr start data))) - ((type list list)) - (dotimes (j chunk) - (setf (aref buffer-bbuf (index+ buffer-boffset j)) (pop list))))) - (defun write-list-card8-with-transform (buffer boffset data start end transform) - (writing-buffer-chunks card8 - ((list (nthcdr start data))) - ((type list lst)) - (dotimes (j chunk) - (declare (type array-index j)) - (write-card8 j (funcall transform (pop lst))))))) - -#-ti -(define-list-writers (write-list-card8 write-list-card8-with-transform) card8 - 1 write-card8) - -;;; Should really write directly from data, instead of into the buffer first -#-lispm -(defun write-simple-array-card8 (buffer boffset data start end) - (declare (type buffer buffer) - (type (simple-array card8 (*)) data) - (type array-index boffset start end)) - (with-vector (data (simple-array card8 (*))) - (writing-buffer-chunks card8 - ((index start (index+ index chunk))) - ((type array-index index)) - (buffer-replace buffer-bbuf data - buffer-boffset - (index+ buffer-boffset chunk) - index))) - nil) - -#-lispm -(defun write-simple-array-card8-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type (simple-array card8 (*)) data) - (type array-index boffset start end)) - (declare (type (function (card8) card8) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data (simple-array card8 (*))) - (writing-buffer-chunks card8 - ((index start)) - ((type array-index index)) - (dotimes (j chunk) - (declare (type array-index j)) - (write-card8 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-card8 (buffer boffset data start end) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) - (with-vector (data vector) - (writing-buffer-chunks card8 - ((index start)) - ((type array-index index)) - (dotimes (j chunk) - (declare (type array-index j)) - (write-card8 j (aref data index)) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-card8-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end)) - (declare (type (function (t) card8) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data vector) - (writing-buffer-chunks card8 - ((index start)) - ((type array-index index)) - (dotimes (j chunk) - (declare (type array-index j)) - (write-card8 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defmacro define-sequence-writer (name type (list tlist) (sa tsa) (vec tvec)) - `(defun ,name (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare - (type buffer buffer) - (type sequence data) - (type array-index boffset start end) - (type (or null (function (t) ,type)) transform) - #+clx-ansi-common-lisp (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) - (typecase data - (list - (if transform - (,tlist buffer boffset data start end transform) - (,list buffer boffset data start end))) - #-lispm - ((simple-array ,type (*)) - (if transform - (,tsa buffer boffset data start end transform) - (,sa buffer boffset data start end))) - (t ; FIXME: general sequences - (if transform - (,tvec buffer boffset data start end transform) - (,vec buffer boffset data start end)))))) - -(define-sequence-writer write-sequence-card8 card8 - (write-list-card8 write-list-card8-with-transform) - (write-simple-array-card8 write-simple-array-card8-with-transform) - (write-vector-card8 write-vector-card8-with-transform)) - -(define-transformed-sequence-writer write-sequence-int8 int8 - int8->card8 write-sequence-card8) - -;;; Writing sequences of card16's - -(define-list-writers (write-list-card16 write-list-card16-with-transform) card16 - 2 write-card16) - -#-lispm -(defun write-simple-array-card16 (buffer boffset data start end) - (declare (type buffer buffer) - (type (simple-array card16 (*)) data) - (type array-index boffset start end)) - (with-vector (data (simple-array card16 (*))) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card16 j (aref data index)) - (setq index (index+ index 1))) - ;; overlapping case - (let ((length (floor chunk 2))) - (buffer-replace buffer-wbuf data - buffer-woffset - (index+ buffer-woffset length) - index) - (setq index (index+ index length))))) - nil) - -#-lispm -(defun write-simple-array-card16-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type (simple-array card16 (*)) data) - (type array-index boffset start end)) - (declare (type (function (card16) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data (simple-array card16 (*))) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card16 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-card16 (buffer boffset data start end) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) - (with-vector (data vector) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card16 j (aref data index)) - (setq index (index+ index 1))) - ;; overlapping case - (let ((length (floor chunk 2))) - (buffer-replace buffer-wbuf data - buffer-woffset - (index+ buffer-woffset length) - index) - (setq index (index+ index length))))) - nil) - -(defun write-vector-card16-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) - (declare (type (function (t) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data vector) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card16 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(define-sequence-writer write-sequence-card16 card16 - (write-list-card16 write-list-card16-with-transform) - (write-simple-array-card16 write-simple-array-card16-with-transform) - (write-vector-card16 write-vector-card16-with-transform)) - -;;; Writing sequences of int16's - -(define-list-writers (write-list-int16 write-list-int16-with-transform) int16 - 2 write-int16) - -#-lispm -(defun write-simple-array-int16 (buffer boffset data start end) - (declare (type buffer buffer) - (type (simple-array int16 (*)) data) - (type array-index boffset start end)) - (with-vector (data (simple-array int16 (*))) - (writing-buffer-chunks int16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of int16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-int16 j (aref data index)) - (setq index (index+ index 1))) - ;; overlapping case - (let ((length (floor chunk 2))) - (buffer-replace buffer-wbuf data - buffer-woffset - (index+ buffer-woffset length) - index) - (setq index (index+ index length))))) - nil) - -#-lispm -(defun write-simple-array-int16-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type (simple-array int16 (*)) data) - (type array-index boffset start end)) - (declare (type (function (int16) int16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data (simple-array int16 (*))) - (writing-buffer-chunks int16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of int16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-int16 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-int16 (buffer boffset data start end) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) - (with-vector (data vector) - (writing-buffer-chunks int16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of int16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-int16 j (aref data index)) - (setq index (index+ index 1))) - ;; overlapping case - (let ((length (floor chunk 2))) - (buffer-replace buffer-wbuf data - buffer-woffset - (index+ buffer-woffset length) - index) - (setq index (index+ index length))))) - nil) - -(defun write-vector-int16-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) - (declare (type (function (t) int16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data vector) - (writing-buffer-chunks int16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of int16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-int16 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(define-sequence-writer write-sequence-int16 int16 - (write-list-int16 write-list-int16-with-transform) - (write-simple-array-int16 write-simple-array-int16-with-transform) - (write-vector-int16 write-vector-int16-with-transform)) - -;;; Writing sequences of card32's - -(define-list-writers (write-list-card32 write-list-card32-with-transform) card32 - 4 write-card32) - -#-lispm -(defun write-simple-array-card32 (buffer boffset data start end) - (declare (type buffer buffer) - (type (simple-array card32 (*)) data) - (type array-index boffset start end)) - (with-vector (data (simple-array card32 (*))) - (writing-buffer-chunks card32 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card32's big - (do ((j 0 (index+ j 4))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card32 j (aref data index)) - (setq index (index+ index 1))) - ;; overlapping case - (let ((length (floor chunk 4))) - (buffer-replace buffer-lbuf data - buffer-loffset - (index+ buffer-loffset length) - index) - (setq index (index+ index length))))) - nil) - -#-lispm -(defun write-simple-array-card32-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type (simple-array card32 (*)) data) - (type array-index boffset start end)) - (declare (type (function (card32) card32) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data (simple-array card32 (*))) - (writing-buffer-chunks card32 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card32's big - (do ((j 0 (index+ j 4))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card32 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-card32 (buffer boffset data start end) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) - (with-vector (data vector) - (writing-buffer-chunks card32 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card32's big - (do ((j 0 (index+ j 4))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card32 j (aref data index)) - (setq index (index+ index 1))) - ;; overlapping case - (let ((length (floor chunk 4))) - (buffer-replace buffer-lbuf data - buffer-loffset - (index+ buffer-loffset length) - index) - (setq index (index+ index length))))) - nil) - -(defun write-vector-card32-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) - (declare (type (function (t) card32) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data vector) - (writing-buffer-chunks card32 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card32's big - (do ((j 0 (index+ j 4))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card32 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(define-sequence-writer write-sequence-card32 card32 - (write-list-card32 write-list-card32-with-transform) - (write-simple-array-card32 write-simple-array-card32-with-transform) - (write-vector-card32 write-vector-card32-with-transform)) - -(define-transformed-sequence-writer write-sequence-int32 int32 - int32->card32 write-sequence-card32) - -(defun read-bitvector256 (buffer-bbuf boffset data) - (declare (type buffer-bytes buffer-bbuf) - (type array-index boffset) - (type (or null (simple-bit-vector 256)) data)) - (let ((result (or data (make-array 256 :element-type 'bit :initial-element 0)))) - (declare (type (simple-bit-vector 256) result)) - (do ((i (index+ boffset 1) (index+ i 1)) ;; Skip first byte - (j 8 (index+ j 8))) - ((index>= j 256)) - (declare (type array-index i j)) - (do ((byte (aref-card8 buffer-bbuf i) (index-ash byte -1)) - (k j (index+ k 1))) - ((zerop byte) - (when data ;; Clear uninitialized bits in data - (do ((end (index+ j 8))) - ((index= k end)) - (declare (type array-index end)) - (setf (aref result k) 0) - (index-incf k)))) - (declare (type array-index k) - (type card8 byte)) - (setf (aref result k) (the bit (logand byte 1))))) - result)) - -(defun write-bitvector256 (buffer boffset map) - (declare (type buffer buffer) - (type array-index boffset) - (type (simple-array bit (*)) map)) - (with-buffer-output (buffer :index boffset :sizes 8) - (do* ((i (index+ buffer-boffset 1) (index+ i 1)) ; Skip first byte - (j 8 (index+ j 8))) - ((index>= j 256)) - (declare (type array-index i j)) - (do ((byte 0) - (bit (index+ j 7) (index- bit 1))) - ((index< bit j) - (aset-card8 byte buffer-bbuf i)) - (declare (type array-index bit) - (type card8 byte)) - (setq byte (the card8 (logior (the card8 (ash byte 1)) (aref map bit)))))))) - -;;; Writing sequences of char2b's - -(define-list-writers (write-list-char2b write-list-char2b-with-transform) card16 - 2 write-char2b) - -#-lispm -(defun write-simple-array-char2b (buffer boffset data start end) - (declare (type buffer buffer) - (type (simple-array card16 (*)) data) - (type array-index boffset start end)) - (with-vector (data (simple-array card16 (*))) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - (do ((j 0 (index+ j 2))) - ((index>= j (1- chunk)) (setf chunk j)) - (declare (type array-index j)) - (write-char2b j (aref data index)) - (setq index (index+ index 1))))) - nil) - -#-lispm -(defun write-simple-array-char2b-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type (simple-array card16 (*)) data) - (type array-index boffset start end)) - (declare (type (function (card16) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data (simple-array card16 (*))) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - (do ((j 0 (index+ j 2))) - ((index>= j (1- chunk)) (setf chunk j)) - (declare (type array-index j)) - (write-char2b j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-char2b (buffer boffset data start end) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) - (with-vector (data vector) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - (do ((j 0 (index+ j 2))) - ((index>= j (1- chunk)) (setf chunk j)) - (declare (type array-index j)) - (write-char2b j (aref data index)) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-char2b-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) - (declare (type (function (t) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data vector) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - (do ((j 0 (index+ j 2))) - ((index>= j (1- chunk)) (setf chunk j)) - (declare (type array-index j)) - (write-char2b j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(define-sequence-writer write-sequence-char2b card16 - (write-list-char2b write-list-char2b-with-transform) - (write-simple-array-char2b write-simple-array-char2b-with-transform) - (write-vector-char2b write-vector-char2b-with-transform)) diff -Nru ecl-16.1.2/src/clx/bufmac.lisp ecl-16.1.3+ds/src/clx/bufmac.lisp --- ecl-16.1.2/src/clx/bufmac.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/bufmac.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,184 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; This file contains macro definitions for the BUFFER object for Common-Lisp -;;; X windows version 11 - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -;;; The read- macros are in buffer.lisp, because event-case depends on (most of) them. - -(defmacro write-card8 (byte-index item) - `(aset-card8 (the card8 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro write-int8 (byte-index item) - `(aset-int8 (the int8 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro write-card16 (byte-index item) - #+clx-overlapping-arrays - `(aset-card16 (the card16 ,item) buffer-wbuf - (index+ buffer-woffset (index-ash ,byte-index -1))) - #-clx-overlapping-arrays - `(aset-card16 (the card16 ,item) buffer-bbuf - (index+ buffer-boffset ,byte-index))) - -(defmacro write-int16 (byte-index item) - #+clx-overlapping-arrays - `(aset-int16 (the int16 ,item) buffer-wbuf - (index+ buffer-woffset (index-ash ,byte-index -1))) - #-clx-overlapping-arrays - `(aset-int16 (the int16 ,item) buffer-bbuf - (index+ buffer-boffset ,byte-index))) - -(defmacro write-card32 (byte-index item) - #+clx-overlapping-arrays - `(aset-card32 (the card32 ,item) buffer-lbuf - (index+ buffer-loffset (index-ash ,byte-index -2))) - #-clx-overlapping-arrays - `(aset-card32 (the card32 ,item) buffer-bbuf - (index+ buffer-boffset ,byte-index))) - -(defmacro write-int32 (byte-index item) - #+clx-overlapping-arrays - `(aset-int32 (the int32 ,item) buffer-lbuf - (index+ buffer-loffset (index-ash ,byte-index -2))) - #-clx-overlapping-arrays - `(aset-int32 (the int32 ,item) buffer-bbuf - (index+ buffer-boffset ,byte-index))) - -(defmacro write-card29 (byte-index item) - #+clx-overlapping-arrays - `(aset-card29 (the card29 ,item) buffer-lbuf - (index+ buffer-loffset (index-ash ,byte-index -2))) - #-clx-overlapping-arrays - `(aset-card29 (the card29 ,item) buffer-bbuf - (index+ buffer-boffset ,byte-index))) - -;; This is used for 2-byte characters, which may not be aligned on 2-byte boundaries -;; and always are written high-order byte first. -(defmacro write-char2b (byte-index item) - ;; It is impossible to do an overlapping write, so only nonoverlapping here. - `(let ((%item ,item) - (%byte-index (index+ buffer-boffset ,byte-index))) - (declare (type card16 %item) - (type array-index %byte-index)) - (aset-card8 (the card8 (ldb (byte 8 8) %item)) buffer-bbuf %byte-index) - (aset-card8 (the card8 (ldb (byte 8 0) %item)) buffer-bbuf (index+ %byte-index 1)))) - -(defmacro set-buffer-offset (value &environment env) - env - `(let ((.boffset. ,value)) - (declare (type array-index .boffset.)) - (setq buffer-boffset .boffset.) - #+clx-overlapping-arrays - ,@(when (member 16 (macroexpand '(%buffer-sizes) env)) - `((setq buffer-woffset (index-ash .boffset. -1)))) - #+clx-overlapping-arrays - ,@(when (member 32 (macroexpand '(%buffer-sizes) env)) - `((setq buffer-loffset (index-ash .boffset. -2)))) - #+clx-overlapping-arrays - .boffset.)) - -(defmacro advance-buffer-offset (value) - `(set-buffer-offset (index+ buffer-boffset ,value))) - -(defmacro with-buffer-output ((buffer &key (sizes '(8 16 32)) length index) &body body) - (unless (listp sizes) (setq sizes (list sizes))) - `(let ((%buffer ,buffer)) - (declare (type display %buffer)) - ,(declare-bufmac) - ,(when length - `(when (index>= (index+ (buffer-boffset %buffer) ,length) (buffer-size %buffer)) - (buffer-flush %buffer))) - (let* ((buffer-boffset (the array-index ,(or index `(buffer-boffset %buffer)))) - #-clx-overlapping-arrays - (buffer-bbuf (buffer-obuf8 %buffer)) - #+clx-overlapping-arrays - ,@(append - (when (member 8 sizes) - `((buffer-bbuf (buffer-obuf8 %buffer)))) - (when (or (member 16 sizes) (member 160 sizes)) - `((buffer-woffset (index-ash buffer-boffset -1)) - (buffer-wbuf (buffer-obuf16 %buffer)))) - (when (member 32 sizes) - `((buffer-loffset (index-ash buffer-boffset -2)) - (buffer-lbuf (buffer-obuf32 %buffer)))))) - (declare (type array-index buffer-boffset)) - #-clx-overlapping-arrays - (declare (type buffer-bytes buffer-bbuf)) - #+clx-overlapping-arrays - ,@(append - (when (member 8 sizes) - '((declare (type buffer-bytes buffer-bbuf)))) - (when (member 16 sizes) - '((declare (type array-index buffer-woffset)) - (declare (type buffer-words buffer-wbuf)))) - (when (member 32 sizes) - '((declare (type array-index buffer-loffset)) - (declare (type buffer-longs buffer-lbuf))))) - buffer-boffset - #-clx-overlapping-arrays - buffer-bbuf - #+clx-overlapping-arrays - ,@(append - (when (member 8 sizes) '(buffer-bbuf)) - (when (member 16 sizes) '(buffer-woffset buffer-wbuf)) - (when (member 32 sizes) '(buffer-loffset buffer-lbuf))) - #+clx-overlapping-arrays - (macrolet ((%buffer-sizes () ',sizes)) - ,@body) - #-clx-overlapping-arrays - ,@body))) - -;;; This macro is just used internally in buffer - -(defmacro writing-buffer-chunks (type args decls &body body) - (when (> (length body) 2) - (error "writing-buffer-chunks called with too many forms")) - (let* ((size (* 8 (index-increment type))) - (form #-clx-overlapping-arrays - (first body) - #+clx-overlapping-arrays ; XXX type dependencies - (or (second body) - (first body)))) - `(with-buffer-output (buffer :index boffset :sizes ,(reverse (adjoin size '(8)))) - ;; Loop filling the buffer - (do* (,@args - ;; Number of bytes needed to output - (len ,(if (= size 8) - `(index- end start) - `(index-ash (index- end start) ,(truncate size 16))) - (index- len chunk)) - ;; Number of bytes available in buffer - (chunk (index-min len (index- (buffer-size buffer) buffer-boffset)) - (index-min len (index- (buffer-size buffer) buffer-boffset)))) - ((not (index-plusp len))) - (declare ,@decls - (type array-index len chunk)) - ,form - (index-incf buffer-boffset chunk) - ;; Flush the buffer - (when (and (index-plusp len) (index>= buffer-boffset (buffer-size buffer))) - (setf (buffer-boffset buffer) buffer-boffset) - (buffer-flush buffer) - (setq buffer-boffset (buffer-boffset buffer)) - #+clx-overlapping-arrays - ,(case size - (16 '(setq buffer-woffset (index-ash buffer-boffset -1))) - (32 '(setq buffer-loffset (index-ash buffer-boffset -2)))))) - (setf (buffer-boffset buffer) (lround buffer-boffset))))) diff -Nru ecl-16.1.2/src/clx/build-clx.lisp ecl-16.1.3+ds/src/clx/build-clx.lisp --- ecl-16.1.2/src/clx/build-clx.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/build-clx.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- - -;;; Load this file if you want to compile CLX in its entirety. -(proclaim '(optimize (speed 3) (safety 1) (space 1) - (compilation-speed 0))) - - -;;; Hide CLOS from CLX, so objects stay implemented as structures. -;;; -#|| -(when (find-package "CLOS") - (rename-package (find-package "CLOS") "NO-CLOS-HERE")) -(when (find-package "PCL") - (rename-package (find-package "PCL") "NO-PCL-HERE")) -(when (find-package "SB-PCL") - (rename-package (find-package "SB-PCL") "NO-SB-PCL-HERE")) -||# - -(when (find-package "XLIB") - (delete-package "XLIB")) - -(unless (find-package "XLIB") - (make-package "XLIB" :use '("COMMON-LISP"))) - -#-sbcl -(compile-file "clx:defsystem.lisp" :error-file nil :load t) - -#+sbcl -(progn (compile-file "clx:defsystem.lisp") - (load "clx:defsystem")) - -(with-compilation-unit () - (#+cmu xlib:compile-clx #-cmu compile-clx (pathname "CLX:"))) diff -Nru ecl-16.1.2/src/clx/CHANGES ecl-16.1.3+ds/src/clx/CHANGES --- ecl-16.1.2/src/clx/CHANGES 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/CHANGES 1970-01-01 00:00:00.000000000 +0000 @@ -1,55 +0,0 @@ -Details of changes since R5: - -NOTE: this file is not updated any more. Changes since checking into -version control can be found from darcs in some way shape or form. -There may however be some Dark Ages between when this file was last -updated and the version that was the initial version control checkin. - - -Changes in CLX 5.02: - -Replace LCL:ENVIRONMENT-VALUE with LCL:ENVIRONMENT-VARIABLE. - -Fix a declaration in the DEFINE-ERROR macro. - -Quote type argument to TYPE-CHECK consistently. - - -Changes in CLX 5.01: - -Support for MIT-MAGIC-COOKIE-1 authorization has been added. - -All VALUES declarations have been changed to CLX-VALUES declarations. -VALUES is a CL type name and cannot be used as a declaration name. - -All ARRAY-REGISTER declarations have been removed as Genera no longer -needs them. - -Many type declarations have been corrected or tightened up now that some -Lisps look at them. - -Print functions have been defined for bitmap and pixmap formats. - -The DISPLAY-PLIST slot will be initialized to NIL. - -When debugging, don't optimize SPEED in the buffer macros. - -Make the CARD8<->CHAR and the window manager code work for sparse -character sets (where some codes do not have corresponding characters). - -The default gcontext extension set and copy functions will take the -correct number of arguments. - -PUT-IMAGE will now work for 24-bit images. - -The buffer accessors for MEMBER8, etc., will use the standard mechanisms -for reporting type errors. - -Typographical errors in SET-WM-PROPERTIES, SET-STANDARD-COLORMAP, and -POINTER-CONTROL have been fixed. - -Symbolics systems will do lazy macroexpansion in the buffer macros. - -A variety of changes for Symbolics Minima systems have been made. - -Some system-dependent code has been added for CMU Common Lisp. diff -Nru ecl-16.1.2/src/clx/clx.asd ecl-16.1.3+ds/src/clx/clx.asd --- ecl-16.1.2/src/clx/clx.asd 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/clx.asd 1970-01-01 00:00:00.000000000 +0000 @@ -1,216 +0,0 @@ -;;; -*- Lisp -*- mode - -;;; Original copyright message from defsystem.lisp: - -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Portions Copyright (C) 1987 Texas Instruments Incorporated. -;;; Portions Copyright (C) 1988, 1989 Franz Inc, Berkeley, Ca. -;;; -;;; Permission is granted to any individual or institution to use, -;;; copy, modify, and distribute this software, provided that this -;;; complete copyright and permission notice is maintained, intact, in -;;; all copies and supporting documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" -;;; without express or implied warranty. -;;; -;;; Franz Incorporated provides this software "as is" without express -;;; or implied warranty. - -(defpackage :clx-system (:use :cl :asdf)) -(in-package :clx-system) - -(pushnew :clx-ansi-common-lisp *features*) - -(defclass clx-source-file (cl-source-file) ()) -(defclass xrender-source-file (clx-source-file) ()) - -;;; CL-SOURCE-FILE, not CLX-SOURCE-FILE, so that we're not accused of -;;; cheating by rebinding *DERIVE-FUNCTION-TYPES* :-) -(defclass example-source-file (cl-source-file) ()) - -(defclass legacy-file (static-file) ()) - -(defsystem CLX - :depends-on (#+sbcl sb-bsd-sockets) - :version "0.7.2" - :serial t - :default-component-class clx-source-file - :components - ((:file "package") - (:file "depdefs") - (:file "clx") - #-(or openmcl allegro) (:file "dependent") - #+openmcl (:file "dep-openmcl") - #+allegro (:file "dep-allegro") - (:file "macros") - (:file "bufmac") - (:file "buffer") - (:file "display") - (:file "gcontext") - (:file "input") - (:file "requests") - (:file "fonts") - (:file "graphics") - (:file "text") - (:file "attributes") - (:file "translate") - (:file "keysyms") - (:file "manager") - (:file "image") - (:file "resource") - #+allegro - (:file "excldep" :pathname "excldep.lisp") - (:module extensions - :pathname #.(make-pathname :directory '(:relative)) - :components - ((:file "shape") - (:file "big-requests") - (:file "xvidmode") - (:xrender-source-file "xrender") - (:file "glx") - (:file "gl" :depends-on ("glx")) - (:file "dpms") - (:file "xtest") - (:file "screensaver") - (:file "xinerama"))) - (:module demo - :default-component-class example-source-file - :components - ((:file "bezier") - ;; KLUDGE: this requires "bezier" for proper operation, - ;; but we don't declare that dependency here, because - ;; asdf doesn't load example files anyway. - (:file "beziertest") - (:file "clclock") - (:file "clipboard") - (:file "clx-demos") - (:file "gl-test") - ;; FIXME: compiling this generates 30-odd spurious code - ;; deletion notes. Find out why, and either fix or - ;; workaround the problem. - (:file "mandel") - (:file "menu") - (:file "zoid"))) - (:module test - :default-component-class example-source-file - :components - ((:file "image") - ;; KLUDGE: again, this depends on "zoid" - (:file "trapezoid"))) - (:static-file "NEWS") - (:static-file "CHANGES") - (:static-file "README") - (:static-file "README-R5") - (:legacy-file "exclMakefile") - (:legacy-file "exclREADME") - (:legacy-file "exclcmac" :pathname "exclcmac.lisp") - (:legacy-file "excldepc" :pathname "excldep.c") - (:legacy-file "sockcl" :pathname "sockcl.lisp") - (:legacy-file "socket" :pathname "socket.c") - (:legacy-file "defsystem" :pathname "defsystem.lisp") - (:legacy-file "provide" :pathname "provide.lisp") - (:legacy-file "cmudep" :pathname "cmudep.lisp") - (:module manual - ;; TODO: teach asdf how to process texinfo files - :components ((:static-file "clx.texinfo"))) - (:module debug - :default-component-class legacy-file - :components - ((:file "debug" :pathname "debug.lisp") - (:file "describe" :pathname "describe.lisp") - (:file "event-test" :pathname "event-test.lisp") - (:file "keytrans" :pathname "keytrans.lisp") - (:file "trace" :pathname "trace.lisp") - (:file "util" :pathname "util.lisp"))))) - -(defmethod perform ((o load-op) (f example-source-file)) - ;; do nothing. We want to compile them when CLX is compiled, but - ;; not load them when CLX is loaded. - t) - -#+sbcl -(defmethod perform :around ((o compile-op) (f xrender-source-file)) - ;; RENDER would appear to be an inherently slow protocol; further, - ;; it's not set in stone, and consequently we care less about speed - ;; than we do about correctness. - (handler-bind ((sb-ext:compiler-note #'muffle-warning)) - (call-next-method))) - -#+sbcl -(defmethod perform :around ((o compile-op) (f clx-source-file)) - ;; our CLX library should compile without WARNINGs, and ideally - ;; without STYLE-WARNINGs. Since it currently does, let's enforce - ;; it here so that we can catch regressions easily. - (let ((on-warnings (operation-on-warnings o)) - (on-failure (operation-on-failure o))) - (unwind-protect - (progn - (setf (operation-on-warnings o) :error - (operation-on-failure o) :error) - ;; a variety of accessors, such as AREF-CARD32, are not - ;; declared INLINE. Without this (non-ANSI) - ;; static-type-inference behaviour, SBCL emits an extra 100 - ;; optimization notes (roughly one fifth of all of the - ;; notes emitted). Since the internals are unlikely to - ;; change much, and certainly the internals should stay in - ;; sync, enabling this extension is a win. (Note that the - ;; use of this does not imply that applications using CLX - ;; calls that expand into calls to these accessors will be - ;; optimized in the same way). - (let ((sb-ext:*derive-function-types* t) - (sadx (find-symbol "STACK-ALLOCATE-DYNAMIC-EXTENT" :sb-c)) - (sadx-var (find-symbol "*STACK-ALLOCATE-DYNAMIC-EXTENT*" :sb-ext))) - ;; deeply unportable stuff, this. I will be shot. We - ;; want to enable the dynamic-extent declarations in CLX. - (when (and sadx (sb-c::policy-quality-name-p sadx)) - ;; no way of setting it back short of yet more yukky stuff - (proclaim `(optimize (,sadx 3)))) - (if sadx-var - (progv (list sadx-var) (list t) - (call-next-method)) - (call-next-method)))) - (setf (operation-on-warnings o) on-warnings - (operation-on-failure o) on-failure)))) - -#+sbcl -(defmethod perform :around (o (f clx-source-file)) - ;; SBCL signals an error if DEFCONSTANT is asked to redefine a - ;; constant unEQLly. For CLX's purposes, however, we are defining - ;; structured constants (lists and arrays) not for EQLity, but for - ;; the purposes of constant-folding operations such as (MEMBER FOO - ;; +BAR+), so it is safe to abort the redefinition provided the - ;; structured data is sufficiently equal. - (handler-bind - ((sb-ext:defconstant-uneql - (lambda (c) - ;; KLUDGE: this really means "don't warn me about - ;; efficiency of generic array access, please" - (declare (optimize (sb-ext:inhibit-warnings 3))) - (let ((old (sb-ext:defconstant-uneql-old-value c)) - (new (sb-ext:defconstant-uneql-new-value c))) - (typecase old - (list (when (equal old new) (abort c))) - (string (when (and (typep new 'string) - (string= old new)) - (abort c))) - (simple-vector - (when (and (typep new 'simple-vector) - (= (length old) (length new)) - (every #'eql old new)) - (abort c))) - (array - (when (and (typep new 'array) - (equal (array-dimensions old) - (array-dimensions new)) - (equal (array-element-type old) - (array-element-type new)) - (dotimes (i (array-total-size old) t) - (unless (eql (row-major-aref old i) - (row-major-aref new i)) - (return nil)))) - (abort c)))))))) - (call-next-method))) diff -Nru ecl-16.1.2/src/clx/clx.lisp ecl-16.1.3+ds/src/clx/clx.lisp --- ecl-16.1.2/src/clx/clx.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/clx.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,940 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -;; Primary Interface Author: -;; Robert W. Scheifler -;; MIT Laboratory for Computer Science -;; 545 Technology Square, Room 418 -;; Cambridge, MA 02139 -;; rws@zermatt.lcs.mit.edu - -;; Design Contributors: -;; Dan Cerys, Texas Instruments -;; Scott Fahlman, CMU -;; Charles Hornig, Symbolics -;; John Irwin, Franz -;; Kerry Kimbrough, Texas Instruments -;; Chris Lindblad, MIT -;; Rob MacLachlan, CMU -;; Mike McMahon, Symbolics -;; David Moon, Symbolics -;; LaMott Oren, Texas Instruments -;; Daniel Weinreb, Symbolics -;; John Wroclawski, MIT -;; Richard Zippel, Symbolics - -;; Primary Implementation Author: -;; LaMott Oren, Texas Instruments - -;; Implementation Contributors: -;; Charles Hornig, Symbolics -;; John Irwin, Franz -;; Chris Lindblad, MIT -;; Robert Scheifler, MIT - -;;; -;;; Change history: -;;; -;;; Date Author Description -;;; ------------------------------------------------------------------------------------- -;;; 04/07/87 R.Scheifler Created code stubs -;;; 04/08/87 L.Oren Started Implementation -;;; 05/11/87 L.Oren Included draft 3 revisions -;;; 07/07/87 L.Oren Untested alpha release to MIT -;;; 07/17/87 L.Oren Alpha release -;;; 08/**/87 C.Lindblad Rewrite of buffer code -;;; 08/**/87 et al Various random bug fixes -;;; 08/**/87 R.Scheifler General syntactic and portability cleanups -;;; 08/**/87 R.Scheifler Rewrite of gcontext caching and shadowing -;;; 09/02/87 L.Oren Change events from resource-ids to objects -;;; 12/24/87 R.Budzianowski KCL support -;;; 12/**/87 J.Irwin ExCL 2.0 support -;;; 01/20/88 L.Oren Add server extension mechanisms -;;; 01/20/88 L.Oren Only force output when blocking on input -;;; 01/20/88 L.Oren Uniform support for :event-window on events -;;; 01/28/88 L.Oren Add window manager property functions -;;; 01/28/88 L.Oren Add character translation facility -;;; 02/**/87 J.Irwin Allegro 2.2 support - -;;; This is considered a somewhat changeable interface. Discussion of better -;;; integration with CLOS, support for user-specified subclassess of basic -;;; objects, and the additional functionality to match the C Xlib is still in -;;; progress. Bug reports should be addressed to bug-clx@expo.lcs.mit.edu. - -;; Note: all of the following is in the package XLIB. - -(in-package :xlib) - -(pushnew :clx *features*) -(pushnew :xlib *features*) - -(defparameter *version* "MIT R5.02") -(pushnew :clx-mit-r4 *features*) -(pushnew :clx-mit-r5 *features*) - -(defparameter *protocol-major-version* 11.) -(defparameter *protocol-minor-version* 0) - -(defparameter *x-tcp-port* 6000) ;; add display number - -;; Note: if you have read the Version 11 protocol document or C Xlib manual, most of -;; the relationships should be fairly obvious. We have no intention of writing yet -;; another moby document for this interface. - -;; Types employed: display, window, pixmap, cursor, font, gcontext, colormap, color. -;; These types are defined solely by a functional interface; we do not specify -;; whether they are implemented as structures or flavors or ... Although functions -;; below are written using DEFUN, this is not an implementation requirement (although -;; it is a requirement that they be functions as opposed to macros or special forms). -;; It is unclear whether with-slots in the Common Lisp Object System must work on -;; them. - -;; Windows, pixmaps, cursors, fonts, gcontexts, and colormaps are all represented as -;; compound objects, rather than as integer resource-ids. This allows applications -;; to deal with multiple displays without having an explicit display argument in the -;; most common functions. Every function uses the display object indicated by the -;; first argument that is or contains a display; it is an error if arguments contain -;; different displays, and predictable results are not guaranteed. - -;; Each of window, pixmap, cursor, font, gcontext, and colormap have the following -;; five functions: - -;(defun make- (display resource-id) -; ;; This function should almost never be called by applications, except in handling -; ;; events. To minimize consing in some implementations, this may use a cache in -; ;; the display. Make-gcontext creates with :cache-p nil. Make-font creates with -; ;; cache-p true. -; (declare (type display display) -; (type integer resource-id) -; (clx-values ))) - -;(defun -display () -; (declare (type ) -; (clx-values display))) - -;(defun -id () -; (declare (type ) -; (clx-values integer))) - -;(defun -equal (-1 -2) -; (declare (type -1 -2))) - -;(defun -p (-1 -2) -; (declare (type -1 -2) -; (clx-values boolean))) - - -(deftype generalized-boolean () 't) ; (or null (not null)) - -(deftype card32 () '(unsigned-byte 32)) - -(deftype card29 () '(unsigned-byte 29)) - -(deftype card24 () '(unsigned-byte 24)) - -(deftype int32 () '(signed-byte 32)) - -(deftype card16 () '(unsigned-byte 16)) - -(deftype int16 () '(signed-byte 16)) - -(deftype card8 () '(unsigned-byte 8)) - -(deftype int8 () '(signed-byte 8)) - -(deftype card4 () '(unsigned-byte 4)) - -#-clx-ansi-common-lisp -(deftype real (&optional (min '*) (max '*)) - (labels ((convert (limit floatp) - (typecase limit - (number (if floatp (float limit 0s0) (rational limit))) - (list (map 'list #'convert limit)) - (otherwise limit)))) - `(or (float ,(convert min t) ,(convert max t)) - (rational ,(convert min nil) ,(convert max nil))))) - -#-clx-ansi-common-lisp -(deftype base-char () - 'string-char) - -; Note that we are explicitly using a different rgb representation than what -; is actually transmitted in the protocol. - -(deftype rgb-val () '(real 0 1)) - -; Note that we are explicitly using a different angle representation than what -; is actually transmitted in the protocol. - -(deftype angle () '(real #.(* -2 pi) #.(* 2 pi))) - -(deftype mask32 () 'card32) - -(deftype mask16 () 'card16) - -(deftype pixel () '(unsigned-byte 32)) -(deftype image-depth () '(integer 0 32)) - -(deftype resource-id () 'card29) - -(deftype keysym () 'card32) - -; The following functions are provided by color objects: - -; The intention is that IHS and YIQ and CYM interfaces will also exist. -; Note that we are explicitly using a different spectrum representation -; than what is actually transmitted in the protocol. - -(def-clx-class (color (:constructor make-color-internal (red green blue)) - (:copier nil) (:print-function print-color)) - (red 0.0 :type rgb-val) - (green 0.0 :type rgb-val) - (blue 0.0 :type rgb-val)) - -(defun print-color (color stream depth) - (declare (type color color) - (ignore depth)) - (print-unreadable-object (color stream :type t) - (prin1 (color-red color) stream) - (write-string " " stream) - (prin1 (color-green color) stream) - (write-string " " stream) - (prin1 (color-blue color) stream))) - -(defun make-color (&key (red 1.0) (green 1.0) (blue 1.0) &allow-other-keys) - (declare (type rgb-val red green blue)) - (declare (clx-values color)) - (make-color-internal red green blue)) - -(defun color-rgb (color) - (declare (type color color)) - (declare (clx-values red green blue)) - (values (color-red color) (color-green color) (color-blue color))) - -(def-clx-class (bitmap-format (:copier nil) (:print-function print-bitmap-format)) - (unit 8 :type (member 8 16 32)) - (pad 8 :type (member 8 16 32)) - (lsb-first-p nil :type generalized-boolean)) - -(defun print-bitmap-format (bitmap-format stream depth) - (declare (type bitmap-format bitmap-format) - (ignore depth)) - (print-unreadable-object (bitmap-format stream :type t) - (format stream "unit ~D pad ~D ~:[M~;L~]SB first" - (bitmap-format-unit bitmap-format) - (bitmap-format-pad bitmap-format) - (bitmap-format-lsb-first-p bitmap-format)))) - -(def-clx-class (pixmap-format (:copier nil) (:print-function print-pixmap-format)) - (depth 0 :type image-depth) - (bits-per-pixel 8 :type (member 1 4 8 12 16 24 32)) - (scanline-pad 8 :type (member 8 16 32))) - -(defun print-pixmap-format (pixmap-format stream depth) - (declare (type pixmap-format pixmap-format) - (ignore depth)) - (print-unreadable-object (pixmap-format stream :type t) - (format stream "depth ~D bits-per-pixel ~D scanline-pad ~D" - (pixmap-format-depth pixmap-format) - (pixmap-format-bits-per-pixel pixmap-format) - (pixmap-format-scanline-pad pixmap-format)))) - -(defparameter *atom-cache-size* 200) -(defparameter *resource-id-map-size* 500) - -(def-clx-class (display (:include buffer) - (:constructor make-display-internal) - (:print-function print-display) - (:copier nil)) - (host) ; Server Host - (display 0 :type integer) ; Display number on host - (after-function nil) ; Function to call after every request - (event-lock - (make-process-lock "CLX Event Lock")) ; with-event-queue lock - (event-queue-lock - (make-process-lock "CLX Event Queue Lock")) ; new-events/event-queue lock - (event-queue-tail ; last event in the event queue - nil :type (or null reply-buffer)) - (event-queue-head ; Threaded queue of events - nil :type (or null reply-buffer)) - (atom-cache (make-hash-table :test (atom-cache-map-test) :size *atom-cache-size*) - :type hash-table) ; Hash table relating atoms keywords - ; to atom id's - (font-cache nil) ; list of font - (protocol-major-version 0 :type card16) ; Major version of server's X protocol - (protocol-minor-version 0 :type card16) ; minor version of servers X protocol - (vendor-name "" :type string) ; vendor of the server hardware - (resource-id-base 0 :type resource-id) ; resouce ID base - (resource-id-mask 0 :type resource-id) ; resource ID mask bits - (resource-id-byte nil) ; resource ID mask field (used with DPB & LDB) - (resource-id-count 0 :type resource-id) ; resource ID mask count - ; (used for allocating ID's) - (resource-id-map (make-hash-table :test (resource-id-map-test) - :size *resource-id-map-size*) - :type hash-table) ; hash table maps resource-id's to - ; objects (used in lookup functions) - (xid 'resourcealloc) ; allocator function - (byte-order #+clx-little-endian :lsbfirst ; connection byte order - #-clx-little-endian :msbfirst) - (release-number 0 :type card32) ; release of the server - (max-request-length 0 :type card16) ; maximum number 32 bit words in request - (default-screen) ; default screen for operations - (roots nil :type list) ; List of screens - (motion-buffer-size 0 :type card32) ; size of motion buffer - (xdefaults) ; contents of defaults from server - (image-lsb-first-p nil :type generalized-boolean) - (bitmap-format (make-bitmap-format) ; Screen image info - :type bitmap-format) - (pixmap-formats nil :type sequence) ; list of pixmap formats - (min-keycode 0 :type card8) ; minimum key-code - (max-keycode 0 :type card8) ; maximum key-code - (error-handler 'default-error-handler) ; Error handler function - (close-down-mode :destroy) ; Close down mode saved by Set-Close-Down-Mode - (authorization-name "" :type string) - (authorization-data "" :type (or (array (unsigned-byte 8)) string)) - (last-width nil :type (or null card29)) ; Accumulated width of last string - (keysym-mapping nil ; Keysym mapping cached from server - :type (or null (array * (* *)))) - (modifier-mapping nil :type list) ; ALIST of (keysym . state-mask) for all modifier keysyms - (keysym-translation nil :type list) ; An alist of (keysym object function) - ; for display-local keysyms - (extension-alist nil :type list) ; extension alist, which has elements: - ; (name major-opcode first-event first-error) - (event-extensions '#() :type vector) ; Vector mapping X event-codes to event keys - (performance-info) ; Hook for gathering performance info - (trace-history) ; Hook for debug trace - (plist nil :type list) ; hook for extension to hang data - ;; These slots are used to manage multi-process input. - (input-in-progress nil) ; Some process reading from the stream. - ; Updated with CONDITIONAL-STORE. - (pending-commands nil) ; Threaded list of PENDING-COMMAND objects - ; for all commands awaiting replies. - ; Protected by WITH-EVENT-QUEUE-INTERNAL. - (asynchronous-errors nil) ; Threaded list of REPLY-BUFFER objects - ; containing error messages for commands - ; which did not expect replies. - ; Protected by WITH-EVENT-QUEUE-INTERNAL. - (report-asynchronous-errors ; When to report asynchronous errors - '(:immediately) :type list) ; The keywords that can be on this list - ; are :IMMEDIATELY, :BEFORE-EVENT-HANDLING, - ; and :AFTER-FINISH-OUTPUT - (event-process nil) ; Process ID of process awaiting events. - ; Protected by WITH-EVENT-QUEUE. - (new-events nil :type (or null reply-buffer)) ; Pointer to the first new event in the - ; event queue. - ; Protected by WITH-EVENT-QUEUE. - (current-event-symbol ; Bound with PROGV by event handling macros - (list (gensym) (gensym)) :type cons) - (atom-id-map (make-hash-table :test (resource-id-map-test) - :size *atom-cache-size*) - :type hash-table) - (extended-max-request-length 0 :type card32) - ) - -(defun print-display-name (display stream) - (declare (type (or null display) display)) - (cond (display - #-allegro (princ (display-host display) stream) - #+allegro (write-string (string (display-host display)) stream) - (write-string ":" stream) - (princ (display-display display) stream)) - (t - (write-string "(no display)" stream))) - display) - -(defun print-display (display stream depth) - (declare (type display display) - (ignore depth)) - (print-unreadable-object (display stream :type t) - (print-display-name display stream) - (write-string " (" stream) - (write-string (display-vendor-name display) stream) - (write-string " R" stream) - (prin1 (display-release-number display) stream) - (write-string ")" stream))) - -;;(deftype drawable () '(or window pixmap)) - -(def-clx-class (drawable (:copier nil) (:print-function print-drawable)) - (id 0 :type resource-id) - (display nil :type (or null display)) - (plist nil :type list) ; Extension hook - ) - -(defun print-drawable (drawable stream depth) - (declare (type drawable drawable) - (ignore depth)) - (print-unreadable-object (drawable stream :type t) - (print-display-name (drawable-display drawable) stream) - (write-string " " stream) - (let ((*print-base* 16)) (prin1 (drawable-id drawable) stream)))) - -(def-clx-class (window (:include drawable) (:copier nil) - (:print-function print-drawable)) - ) - -(def-clx-class (pixmap (:include drawable) (:copier nil) - (:print-function print-drawable)) - ) - -(def-clx-class (visual-info (:copier nil) (:print-function print-visual-info)) - (id 0 :type resource-id) - (display nil :type (or null display)) - (class :static-gray :type (member :static-gray :static-color :true-color - :gray-scale :pseudo-color :direct-color)) - (red-mask 0 :type pixel) - (green-mask 0 :type pixel) - (blue-mask 0 :type pixel) - (bits-per-rgb 1 :type card8) - (colormap-entries 0 :type card16) - (plist nil :type list) ; Extension hook - ) - -(defun print-visual-info (visual-info stream depth) - (declare (type visual-info visual-info) - (ignore depth)) - (print-unreadable-object (visual-info stream :type t) - (prin1 (visual-info-bits-per-rgb visual-info) stream) - (write-string "-bit " stream) - (princ (visual-info-class visual-info) stream) - (write-string " " stream) - (print-display-name (visual-info-display visual-info) stream) - (write-string " " stream) - (prin1 (visual-info-id visual-info) stream))) - -(def-clx-class (colormap (:copier nil) (:print-function print-colormap)) - (id 0 :type resource-id) - (display nil :type (or null display)) - (visual-info nil :type (or null visual-info)) - ) - -(defun print-colormap (colormap stream depth) - (declare (type colormap colormap) - (ignore depth)) - (print-unreadable-object (colormap stream :type t) - (when (colormap-visual-info colormap) - (princ (visual-info-class (colormap-visual-info colormap)) stream) - (write-string " " stream)) - (print-display-name (colormap-display colormap) stream) - (write-string " " stream) - (prin1 (colormap-id colormap) stream))) - -(def-clx-class (cursor (:copier nil) (:print-function print-cursor)) - (id 0 :type resource-id) - (display nil :type (or null display)) - ) - -(defun print-cursor (cursor stream depth) - (declare (type cursor cursor) - (ignore depth)) - (print-unreadable-object (cursor stream :type t) - (print-display-name (cursor-display cursor) stream) - (write-string " " stream) - (prin1 (cursor-id cursor) stream))) - -; Atoms are accepted as strings or symbols, and are always returned as keywords. -; Protocol-level integer atom ids are hidden, using a cache in the display object. - -(deftype xatom () '(or string symbol)) - -(defconstant +predefined-atoms+ - '#(nil :PRIMARY :SECONDARY :ARC :ATOM :BITMAP - :CARDINAL :COLORMAP :CURSOR - :CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 - :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7 - :DRAWABLE :FONT :INTEGER :PIXMAP :POINT :RECTANGLE - :RESOURCE_MANAGER :RGB_COLOR_MAP :RGB_BEST_MAP - :RGB_BLUE_MAP :RGB_DEFAULT_MAP - :RGB_GRAY_MAP :RGB_GREEN_MAP :RGB_RED_MAP :STRING - :VISUALID :WINDOW :WM_COMMAND :WM_HINTS - :WM_CLIENT_MACHINE :WM_ICON_NAME :WM_ICON_SIZE - :WM_NAME :WM_NORMAL_HINTS :WM_SIZE_HINTS - :WM_ZOOM_HINTS :MIN_SPACE :NORM_SPACE :MAX_SPACE - :END_SPACE :SUPERSCRIPT_X :SUPERSCRIPT_Y - :SUBSCRIPT_X :SUBSCRIPT_Y - :UNDERLINE_POSITION :UNDERLINE_THICKNESS - :STRIKEOUT_ASCENT :STRIKEOUT_DESCENT - :ITALIC_ANGLE :X_HEIGHT :QUAD_WIDTH :WEIGHT - :POINT_SIZE :RESOLUTION :COPYRIGHT :NOTICE - :FONT_NAME :FAMILY_NAME :FULL_NAME :CAP_HEIGHT - :WM_CLASS :WM_TRANSIENT_FOR)) - -(deftype stringable () '(or string symbol)) - -(deftype fontable () '(or stringable font)) - -; Nil stands for CurrentTime. - -(deftype timestamp () '(or null card32)) - -(defconstant +bit-gravity-vector+ - '#(:forget :north-west :north :north-east :west - :center :east :south-west :south - :south-east :static)) - -(deftype bit-gravity () - '(member :forget :north-west :north :north-east :west - :center :east :south-west :south :south-east :static)) - -(defconstant +win-gravity-vector+ - '#(:unmap :north-west :north :north-east :west - :center :east :south-west :south :south-east - :static)) - -(defparameter *protocol-families* - '(;; X11/X.h, Family* - (:internet . 0) - (:decnet . 1) - (:chaos . 2) - ;; X11/Xauth.h "not part of X standard" - (:Local . 256) - (:Wild . 65535) - (:Netname . 254) - (:Krb5Principal . 253) - (:LocalHost . 252))) - -(deftype win-gravity () - '(member :unmap :north-west :north :north-east :west - :center :east :south-west :south :south-east :static)) - -(deftype grab-status () - '(member :success :already-grabbed :invalid-time :not-viewable)) - -; An association list. - -(deftype alist (key-type-and-name datum-type-and-name) - (declare (ignore key-type-and-name datum-type-and-name)) - 'list) - -(deftype clx-list (&optional element-type) (declare (ignore element-type)) 'list) -(deftype clx-sequence (&optional element-type) (declare (ignore element-type)) 'sequence) - -; A sequence, containing zero or more repetitions of the given elements, -; with the elements expressed as (type name). - -(deftype repeat-seq (&rest elts) elts 'sequence) - -(deftype point-seq () '(repeat-seq (int16 x) (int16 y))) - -(deftype seg-seq () '(repeat-seq (int16 x1) (int16 y1) (int16 x2) (int16 y2))) - -(deftype rect-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height))) - -(deftype arc-seq () - '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height) - (angle angle1) (angle angle2))) - -(deftype gcontext-state () 'simple-vector) - -(def-clx-class (gcontext (:copier nil) (:print-function print-gcontext)) - ;; The accessors convert to CLX data types. - (id 0 :type resource-id) - (display nil :type (or null display)) - (drawable nil :type (or null drawable)) - (cache-p t :type generalized-boolean) - (server-state (allocate-gcontext-state) :type gcontext-state) - (local-state (allocate-gcontext-state) :type gcontext-state) - (plist nil :type list) ; Extension hook - (next nil #-explorer :type #-explorer (or null gcontext)) - ) - -(defun print-gcontext (gcontext stream depth) - (declare (type gcontext gcontext) - (ignore depth)) - (print-unreadable-object (gcontext stream :type t) - (print-display-name (gcontext-display gcontext) stream) - (write-string " " stream) - (prin1 (gcontext-id gcontext) stream))) - -(defconstant +event-mask-vector+ - '#(:key-press :key-release :button-press :button-release - :enter-window :leave-window :pointer-motion :pointer-motion-hint - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion :keymap-state :exposure :visibility-change - :structure-notify :resize-redirect :substructure-notify :substructure-redirect - :focus-change :property-change :colormap-change :owner-grab-button)) - -(deftype event-mask-class () - '(member :key-press :key-release :owner-grab-button :button-press :button-release - :enter-window :leave-window :pointer-motion :pointer-motion-hint - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion :exposure :visibility-change - :structure-notify :resize-redirect :substructure-notify :substructure-redirect - :focus-change :property-change :colormap-change :keymap-state)) - -(deftype event-mask () - '(or mask32 (clx-list event-mask-class))) - -(defconstant +pointer-event-mask-vector+ - ;; the first two elements used to be '%error '%error (i.e. symbols, - ;; and not keywords) but the vector is supposed to contain - ;; keywords, so I renamed them -dan 2004.11.13 - '#(:%error :%error :button-press :button-release - :enter-window :leave-window :pointer-motion :pointer-motion-hint - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion :keymap-state)) - -(deftype pointer-event-mask-class () - '(member :button-press :button-release - :enter-window :leave-window :pointer-motion :pointer-motion-hint - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion :keymap-state)) - -(deftype pointer-event-mask () - '(or mask32 (clx-list pointer-event-mask-class))) - -(defconstant +device-event-mask-vector+ - '#(:key-press :key-release :button-press :button-release :pointer-motion - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion)) - -(deftype device-event-mask-class () - '(member :key-press :key-release :button-press :button-release :pointer-motion - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion)) - -(deftype device-event-mask () - '(or mask32 (clx-list device-event-mask-class))) - -(defconstant +state-mask-vector+ - '#(:shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5 - :button-1 :button-2 :button-3 :button-4 :button-5)) - -(deftype modifier-key () - '(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5)) - -(deftype modifier-mask () - '(or (member :any) mask16 (clx-list modifier-key))) - -(deftype state-mask-key () - '(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5))) - -(defconstant +gcontext-components+ - '(:function :plane-mask :foreground :background - :line-width :line-style :cap-style :join-style :fill-style - :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode - :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes - :arc-mode)) - -(deftype gcontext-key () - '(member :function :plane-mask :foreground :background - :line-width :line-style :cap-style :join-style :fill-style - :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode - :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes - :arc-mode)) - -(deftype event-key () - '(or (member :key-press :key-release :button-press :button-release - :motion-notify :enter-notify :leave-notify :focus-in :focus-out - :keymap-notify :exposure :graphics-exposure :no-exposure - :visibility-notify :create-notify :destroy-notify :unmap-notify - :map-notify :map-request :reparent-notify :configure-notify - :gravity-notify :resize-request :configure-request :circulate-notify - :circulate-request :property-notify :selection-clear - :selection-request :selection-notify :colormap-notify :client-message - :mapping-notify) - (satisfies extension-event-key-p))) - -(deftype error-key () - '(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice - :illegal-request :implementation :length :match :name :pixmap :value :window)) - -(deftype draw-direction () - '(member :left-to-right :right-to-left)) - -(defconstant +boole-vector+ - '#(#.boole-clr #.boole-and #.boole-andc2 #.boole-1 - #.boole-andc1 #.boole-2 #.boole-xor #.boole-ior - #.boole-nor #.boole-eqv #.boole-c2 #.boole-orc2 - #.boole-c1 #.boole-orc1 #.boole-nand #.boole-set)) - -(deftype boole-constant () - `(member ,boole-clr ,boole-and ,boole-andc2 ,boole-1 - ,boole-andc1 ,boole-2 ,boole-xor ,boole-ior - ,boole-nor ,boole-eqv ,boole-c2 ,boole-orc2 - ,boole-c1 ,boole-orc1 ,boole-nand ,boole-set)) - -(def-clx-class (screen (:copier nil) (:print-function print-screen)) - (root nil :type (or null window)) - (width 0 :type card16) - (height 0 :type card16) - (width-in-millimeters 0 :type card16) - (height-in-millimeters 0 :type card16) - (depths nil :type (alist (image-depth depth) ((clx-list visual-info) visuals))) - (root-depth 1 :type image-depth) - (root-visual-info nil :type (or null visual-info)) - (default-colormap nil :type (or null colormap)) - (white-pixel 0 :type pixel) - (black-pixel 1 :type pixel) - (min-installed-maps 1 :type card16) - (max-installed-maps 1 :type card16) - (backing-stores :never :type (member :never :when-mapped :always)) - (save-unders-p nil :type generalized-boolean) - (event-mask-at-open 0 :type mask32) - (plist nil :type list) ; Extension hook - ) - -(defun print-screen (screen stream depth) - (declare (type screen screen) - (ignore depth)) - (print-unreadable-object (screen stream :type t) - (let ((display (drawable-display (screen-root screen)))) - (print-display-name display stream) - (write-string "." stream) - (princ (position screen (display-roots display)) stream)) - (write-string " " stream) - (prin1 (screen-width screen) stream) - (write-string "x" stream) - (prin1 (screen-height screen) stream) - (write-string "x" stream) - (prin1 (screen-root-depth screen) stream) - (when (screen-root-visual-info screen) - (write-string " " stream) - (princ (visual-info-class (screen-root-visual-info screen)) stream)))) - -(defun screen-root-visual (screen) - (declare (type screen screen) - (clx-values resource-id)) - (visual-info-id (screen-root-visual-info screen))) - -;; The list contains alternating keywords and integers. -(deftype font-props () 'list) - -(def-clx-class (font-info (:copier nil) (:predicate nil)) - (direction :left-to-right :type draw-direction) - (min-char 0 :type card16) ;; First character in font - (max-char 0 :type card16) ;; Last character in font - (min-byte1 0 :type card8) ;; The following are for 16 bit fonts - (max-byte1 0 :type card8) ;; and specify min&max values for - (min-byte2 0 :type card8) ;; the two character bytes - (max-byte2 0 :type card8) - (all-chars-exist-p nil :type generalized-boolean) - (default-char 0 :type card16) - (min-bounds nil :type (or null vector)) - (max-bounds nil :type (or null vector)) - (ascent 0 :type int16) - (descent 0 :type int16) - (properties nil :type font-props)) - -(def-clx-class (font (:constructor make-font-internal) (:copier nil) - (:print-function print-font)) - (id-internal nil :type (or null resource-id)) ;; NIL when not opened - (display nil :type (or null display)) - (reference-count 0 :type fixnum) - (name "" :type (or null string)) ;; NIL when ID is for a GContext - (font-info-internal nil :type (or null font-info)) - (char-infos-internal nil :type (or null (simple-array int16 (*)))) - (local-only-p t :type generalized-boolean) ;; When T, always calculate text extents locally - (plist nil :type list) ; Extension hook - ) - -(defun print-font (font stream depth) - (declare (type font font) - (ignore depth)) - (print-unreadable-object (font stream :type t) - (if (font-name font) - (princ (font-name font) stream) - (write-string "(gcontext)" stream)) - (write-string " " stream) - (print-display-name (font-display font) stream) - (when (font-id-internal font) - (write-string " " stream) - (prin1 (font-id font) stream)))) - -(defun font-id (font) - ;; Get font-id, opening font if needed - (or (font-id-internal font) - (open-font-internal font))) - -(defun font-font-info (font) - (or (font-font-info-internal font) - (query-font font))) - -(defun font-char-infos (font) - (or (font-char-infos-internal font) - (progn (query-font font) - (font-char-infos-internal font)))) - -(defun make-font (&key id - display - (reference-count 0) - (name "") - (local-only-p t) - font-info-internal) - (make-font-internal :id-internal id - :display display - :reference-count reference-count - :name name - :local-only-p local-only-p - :font-info-internal font-info-internal)) - -; For each component ( :type ) of font-info, -; there is a corresponding function: - -;(defun font- (font) -; (declare (type font font) -; (clx-values ))) - -(macrolet ((make-font-info-accessors (useless-name &body fields) - `(within-definition (,useless-name make-font-info-accessors) - ,@(mapcar - #'(lambda (field) - (let* ((type (second field)) - (n (string (first field))) - (name (xintern 'font- n)) - (accessor (xintern 'font-info- n))) - `(defun ,name (font) - (declare (type font font)) - (declare (clx-values ,type)) - (,accessor (font-font-info font))))) - fields)))) - (make-font-info-accessors ignore - (direction draw-direction) - (min-char card16) - (max-char card16) - (min-byte1 card8) - (max-byte1 card8) - (min-byte2 card8) - (max-byte2 card8) - (all-chars-exist-p generalized-boolean) - (default-char card16) - (min-bounds vector) - (max-bounds vector) - (ascent int16) - (descent int16) - (properties font-props))) - -(defun font-property (font name) - (declare (type font font) - (type keyword name)) - (declare (clx-values (or null int32))) - (getf (font-properties font) name)) - -(macrolet ((make-mumble-equal (type) - ;; Since caching is only done for objects created by the - ;; client, we must always compare ID and display for - ;; non-identical mumbles. - (let ((predicate (xintern type '-equal)) - (id (xintern type '-id)) - (dpy (xintern type '-display))) - `(within-definition (,type make-mumble-equal) - (defun ,predicate (a b) - (declare (type ,type a b)) - (or (eql a b) - (and (= (,id a) (,id b)) - (eq (,dpy a) (,dpy b))))))))) - (make-mumble-equal window) - (make-mumble-equal pixmap) - (make-mumble-equal cursor) - (make-mumble-equal font) - (make-mumble-equal gcontext) - (make-mumble-equal colormap) - (make-mumble-equal drawable)) - -;;; -;;; Event-mask encode/decode functions -;;; Converts from keyword-lists to integer and back -;;; -(defun encode-mask (key-vector key-list key-type) - ;; KEY-VECTOR is a vector containg bit-position keywords. The - ;; position of the keyword in the vector indicates its bit position - ;; in the resulting mask. KEY-LIST is either a mask or a list of - ;; KEY-TYPE Returns NIL when KEY-LIST is not a list or mask. - (declare (type (simple-array keyword (*)) key-vector) - (type (or mask32 list) key-list)) - (declare (clx-values (or mask32 null))) - (typecase key-list - (mask32 key-list) - (list (let ((mask 0)) - (dolist (key key-list mask) - (let ((bit (position key (the vector key-vector) :test #'eq))) - (unless bit - (x-type-error key key-type)) - (setq mask (logior mask (ash 1 bit))))))))) - -(defun decode-mask (key-vector mask) - (declare (type (simple-array keyword (*)) key-vector) - (type mask32 mask)) - (declare (clx-values list)) - (do ((m mask (ash m -1)) - (bit 0 (1+ bit)) - (len (length key-vector)) - (result nil)) - ((or (zerop m) (>= bit len)) result) - (declare (type mask32 m) - (fixnum bit len) - (list result)) - (when (oddp m) - (push (aref key-vector bit) result)))) - -(defun encode-event-mask (event-mask) - (declare (type event-mask event-mask)) - (declare (clx-values mask32)) - (or (encode-mask +event-mask-vector+ event-mask 'event-mask-class) - (x-type-error event-mask 'event-mask))) - -(defun make-event-mask (&rest keys) - ;; This is only defined for core events. - ;; Useful for constructing event-mask, pointer-event-mask, device-event-mask. - (declare (type (clx-list event-mask-class) keys)) - (declare (clx-values mask32)) - (encode-mask +event-mask-vector+ keys 'event-mask-class)) - -(defun make-event-keys (event-mask) - ;; This is only defined for core events. - (declare (type mask32 event-mask)) - (declare (clx-values (clx-list event-mask-class))) - (decode-mask +event-mask-vector+ event-mask)) - -(defun encode-device-event-mask (device-event-mask) - (declare (type device-event-mask device-event-mask)) - (declare (clx-values mask32)) - (or (encode-mask +device-event-mask-vector+ device-event-mask - 'device-event-mask-class) - (x-type-error device-event-mask 'device-event-mask))) - -(defun encode-modifier-mask (modifier-mask) - (declare (type modifier-mask modifier-mask)) - (declare (clx-values mask16)) - (or (and (eq modifier-mask :any) #x8000) - (encode-mask +state-mask-vector+ modifier-mask 'modifier-key) - (x-type-error modifier-mask 'modifier-mask))) - -(defun encode-state-mask (state-mask) - (declare (type (or mask16 (clx-list state-mask-key)) state-mask)) - (declare (clx-values mask16)) - (or (encode-mask +state-mask-vector+ state-mask 'state-mask-key) - (x-type-error state-mask '(or mask16 (clx-list state-mask-key))))) - -(defun make-state-mask (&rest keys) - ;; Useful for constructing modifier-mask, state-mask. - (declare (type (clx-list state-mask-key) keys)) - (declare (clx-values mask16)) - (encode-mask +state-mask-vector+ keys 'state-mask-key)) - -(defun make-state-keys (state-mask) - (declare (type mask16 state-mask)) - (declare (clx-values (clx-list state-mask-key))) - (decode-mask +state-mask-vector+ state-mask)) - -(defun encode-pointer-event-mask (pointer-event-mask) - (declare (type pointer-event-mask pointer-event-mask)) - (declare (clx-values mask32)) - (or (encode-mask +pointer-event-mask-vector+ pointer-event-mask - 'pointer-event-mask-class) - (x-type-error pointer-event-mask 'pointer-event-mask))) diff -Nru ecl-16.1.2/src/clx/clx-module.lisp ecl-16.1.3+ds/src/clx/clx-module.lisp --- ecl-16.1.2/src/clx/clx-module.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/clx-module.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,5 +0,0 @@ -;;;(in-package :xlib) -;;;(common-lisp:use-package (list :common-lisp)) -(provide :clx) -(load "clx:defsystem.lisp") -(load-clx (translate-logical-pathname "CLX:")) \ No newline at end of file diff -Nru ecl-16.1.2/src/clx/cmudep.lisp ecl-16.1.3+ds/src/clx/cmudep.lisp --- ecl-16.1.2/src/clx/cmudep.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/cmudep.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ -;;; -*- Package: XLIB -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; If you want to use this code or any part of CMU Common Lisp, please contact -;;; Scott Fahlman or slisp-group@cs.cmu.edu. -;;; -(ext:file-comment - "$Header: /loaclhost/usr/local/src/cvs/clx/cmudep.lisp,v 1.1 2000/07/02 19:19:46 dan Exp $") -;;; -;;; ********************************************************************** -;;; -(in-package "XLIB") - -(alien:def-alien-routine ("connect_to_server" xlib::connect-to-server) - c-call:int - (host c-call:c-string) - (port c-call:int)) diff -Nru ecl-16.1.2/src/clx/.cvsignore ecl-16.1.3+ds/src/clx/.cvsignore --- ecl-16.1.2/src/clx/.cvsignore 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/.cvsignore 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -*.fasl diff -Nru ecl-16.1.2/src/clx/debug/debug.lisp ecl-16.1.3+ds/src/clx/debug/debug.lisp --- ecl-16.1.2/src/clx/debug/debug.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/debug/debug.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,77 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES; Patch-file:T -*- - -;;; CLX debugging code - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -;;; Created 04/09/87 14:30:41 by LaMott G. OREN - -(in-package :xlib) - -(export '(display-listen - readflush - check-buffer - check-finish - check-force - clear-next)) - -(defun display-listen (display) - (listen (display-input-stream display))) - -(defun readflush (display) - ;; Flushes Display's input stream, returning what was there - (let ((stream (display-input-stream display))) - (loop while (listen stream) collect (read-byte stream)))) - -;;----------------------------------------------------------------------------- -;; The following are useful display-after functions - -(defun check-buffer (display) - ;; Ensure the output buffer in display is correct - (with-buffer-output (display :length :none :sizes (8 16)) - (do* ((i 0 (+ i length)) - request - length) - ((>= i buffer-boffset) - (unless (= i buffer-boffset) - (warn "Buffer size ~d Requests end at ~d" buffer-boffset i))) - - (let ((buffer-boffset 0) - #+clx-overlapping-arrays - (buffer-woffset 0)) - (setq request (card8-get i)) - (setq length (* 4 (card16-get (+ i 2))))) - (when (zerop request) - (warn "Zero request in buffer") - (return nil)) - (when (zerop length) - (warn "Zero length in buffer") - (return nil))))) - -(defun check-finish (display) - (check-buffer display) - (display-finish-output display)) - -(defun check-force (display) - (check-buffer display) - (display-force-output display)) - -(defun clear-next (display) - ;; Never append requests - (setf (display-last-request display) nil)) - -;; End of file diff -Nru ecl-16.1.2/src/clx/debug/describe.lisp ecl-16.1.3+ds/src/clx/debug/describe.lisp --- ecl-16.1.2/src/clx/debug/describe.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/debug/describe.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,1243 +0,0 @@ -;;; -*- Mode: Lisp; Package: XLIB; Syntax: COMMON-LISP; Base: 10; Lowercase: Yes; -*- - -;;; Describe X11 protocol requests - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -;;; Created 07/15/87 by LaMott G. OREN - -(in-package :xlib) - -(defparameter *request-parameters* (make-array (length *request-names*))) - -(defmacro x-request (name &rest fields) - (unless (zerop (mod (length fields) 3)) - (format t "~%Field length not a multiple of 3 for ~a" name)) - (let ((request (position name *request-names* :test #'string-equal))) - (if request - `(setf (aref *request-parameters* ,request) ',fields) - `(format t "~%~s isn't an X11 request name" ',name)))) - -(defun print-history-description (buffer &optional (start 0)) - ;; Display an output history - (reading-event (buffer) - (let ((request (card8-get start)) - (length (* 4 (card16-get (+ start 2)))) - (margin 5)) - (format t "~a (~d) length ~d" - (request-name request) request length) - (when (>= request (length *request-parameters*)) - (setq request 0)) - (do ((parms (aref *request-parameters* request) (cdddr parms)) - (j start)) - ((or (endp parms) (>= j length))) - (let ((len (first parms)) - (type (second parms)) - (doc (third parms)) - value) - (setq value (case len - (1 (card8-get j)) - (2 (card16-get j)) - (4 (card32-get j)))) - (format t "~%~v@t" margin) - (if value - (progn - (print-value j value type doc) - (incf j len)) - (progn - (format t "~2d ~10a ~a" - j type doc) - (case type - ((listofvalue listofcard32 listofatom) - (format t " Words:~%~v@t" margin) - (dotimes (k (floor (- length (- j start)) 4)) - (format t " ~d" (card32-get j)) - (incf j 4))) - (listofrectangle - (format t " Half-Words:~%~v@t" margin) - (dotimes (k (floor (- length (- j start)) 2)) - (format t " ~d" (card16-get j)) - (incf j 2))) - (x (when (integerp len) (incf j len))) ; Unused - (string8 - (format t " Bytes:~%~v@t" margin) - (dotimes (k (- length (- j start))) - (format t "~a" (int-char (card8-get j))) - (incf j))) - (otherwise - (format t " Bytes:~%~v@t" margin) - (dotimes (k (- length (- j start))) - (format t " ~d" (card8-get j)) - (incf j))))))))))) - -(defun print-value (i value type doc &aux temp) - (format t "~2d ~3d " i value) - (if (consp type) - (case (first type) - (bitmask (format t "~a" (nreverse (decode-mask (symbol-value (second type)) value))) - (setq type (car type))) - (member (if (null (setq temp (nth value (cdr type)))) - (format t "*****ERROR*****") - (format t "~a" temp)) - (setq type (car type)))) - (case type - ((window pixmap drawable cursor font gcontext colormap atom) - (format t "[#x~x]" value) - #+comment - (let ((temp (lookup-resource-id display value))) - (when (eq (first type) 'atom) - (setq temp (lookup-xatom display value))) - (when temp (format t " (~s)" (type-of temp))))) - (int16 (setq temp (card16->int16 value)) - (when (minusp temp) (format t "~d" temp))) - (otherwise - (when (and (numberp type) (not (= type value))) - (format t "*****ERROR*****"))))) - (format t "~30,10t ~10a ~a" type doc)) - -(x-request Error - 1 1 opcode - 1 CARD8 data - 2 8+n request-length - n LISTofBYTE data - ) - -(x-request CreateWindow - 1 1 opcode - 1 CARD8 depth - 2 8+n request-length - 4 WINDOW wid - 4 WINDOW parent - 2 INT16 x - 2 INT16 y - 2 CARD16 width - 2 CARD16 height - 2 CARD16 border-width - 2 (MEMBER CopyFromParent InputOutput InputOnly) class - 4 (OR (MEMBER CopyFromParent) VISUALID) visual - 4 (BITMASK *create-bitmask*) value-mask - 4n LISTofVALUE value-list - ) - -(defparameter *create-bitmask* - #(background-pixmap background-pixel border-pixmap border-pixel bit-gravity - win-gravity backing-store backing-planes backing-pixel override-redirect - save-under event-mask do-not-propagate-mask colormap cursor)) - -(x-request ChangeWindowAttributes - 1 2 opcode - 1 x unused - 2 3+n request-length - 4 WINDOW window - 4 (BITMASK *create-bitmask*) value-mask - 4n LISTofVALUE value-list - ) - -(x-request GetWindowAttributes - 1 3 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request DestroyWindow - 1 4 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request DestroySubwindows - 1 5 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request ChangeSaveSet - 1 6 opcode - 1 (MEMBER insert delete) mode - 2 2 request-length - 4 WINDOW window -) - -(x-request ReparentWindow - 1 7 opcode - 1 x unused - 2 4 request-length - 4 WINDOW window - 4 WINDOW parent - 2 INT16 x - 2 INT16 y -) - -(x-request MapWindow - 1 8 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request MapSubwindows - 1 9 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request UnmapWindow - 1 10 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request UnmapSubwindows - 1 11 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request ConfigureWindow - 1 12 opcode - 1 x unused - 2 3+n request-length - 4 WINDOW window - 2 BITMASK value-mask - 2 x unused - 4n LISTofVALUE value-list -) - -(x-request CirculateWindow - 1 13 opcode - 1 (MEMBER RaiseLowest LowerHighest) direction - 2 2 request-length - 4 WINDOW window -) - -(x-request GetGeometry - 1 14 opcode - 1 x unused - 2 2 request-length - 4 DRAWABLE drawable -) - -(x-request QueryTree - 1 15 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request InternAtom - 1 16 opcode - 1 BOOL only-if-exists - 2 |2+(n+p)/4| request-length - 2 n length-of-name - 2 x unused - n STRING8 name - p x unused -) - -(x-request GetAtomName - 1 17 opcode - 1 x unused - 2 2 request-length - 4 ATOM atom -) - -(x-request ChangeProperty - 1 18 opcode - 1 (MEMBER replace prepend append) mode - 2 |6+(n+p)/4| request-length - 4 WINDOW window - 4 ATOM property - 4 ATOM type - 1 CARD8 format - 3 x unused - 4 CARD32 length-of-data-in-format-units - n LISTofBYTE data - p x unused -) - -(x-request DeleteProperty - 1 19 opcode - 1 x unused - 2 3 request-length - 4 WINDOW window - 4 ATOM property -) - -(x-request GetProperty - 1 20 opcode - 1 BOOL delete - 2 6 request-length - 4 WINDOW window - 4 ATOM property - 4 (OR (MEMBER anypropertytype) ATOM) type - 4 CARD32 long-offset - 4 CARD32 long-length -) - -(x-request ListProperties - 1 21 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request SetSelectionOwner - 1 22 opcode - 1 x unused - 2 4 request-length - 4 (OR (MEMBER none) WINDOW) owner - 4 ATOM selection - 4 (OR (MEMBER currenttime) TIMESTAMP) time -) - -(x-request GetSelectionOwner - 1 23 opcode - 1 x unused - 2 2 request-length - 4 ATOM selection -) - -(x-request ConvertSelection - 1 24 opcode - 1 x unused - 2 6 request-length - 4 WINDOW requestor - 4 ATOM selection - 4 ATOM target - 4 (OR (MEMBER none) ATOM) property - 4 (OR (MEMBER currenttime) TIMESTAMP) time -) - -(x-request SendEvent - 1 25 opcode - 1 BOOL propagate - 2 11 request-length - 4 (OR (MEMBER pointerwindow inputfocus) WINDOW) destination - 4 SETofEVENT event-mask - 32 n event -) - -(x-request GrabPointer - 1 26 opcode - 1 BOOL owner-events - 2 6 request-length - 4 WINDOW grab-window - 2 SETofPOINTEREVENT event-mask - 1 (MEMBER Synchronous Asynchronous) pointer-mode - 1 (MEMBER Synchronous Asynchronous) keyboard-mode - 4 (OR (MEMBER none) WINDOW) confine-to - 4 (OR (MEMBER none) CURSOR) cursor - 4 (OR (MEMBER currenttime) TIMESTAMP) timestamp -) - -(x-request UngrabPointer - 1 27 opcode - 1 x unused - 2 2 request-length - 4 (OR (MEMBER currenttime) TIMESTAMP) time -) - -(x-request GrabButton - 1 28 opcode - 1 BOOL owner-events - 2 6 request-length - 4 WINDOW grab-window - 2 SETofPOINTEREVENT event-mask - 1 (MEMBER Synchronous Asynchronous) pointer-mode - 1 (MEMBER Synchronous Asynchronous) keyboard-mode - 4 (OR (MEMBER none) WINDOW) confine-to - 4 (OR (MEMBER none) CURSOR) cursor - 1 (OR (MEMBER anybutton) BUTTON)button - 1 x unused - 2 SETofKEYMASK modifiers -) - -(x-request UngrabButton - 1 29 opcode - 1 (OR (MEMBER anybutton) BUTTON) button - 2 3 request-length - 4 WINDOW grab-window - 2 SETofKEYMASK modifiers - 2 x unused -) - -(x-request ChangeActivePointerGrab - 1 30 opcode - 1 x unused - 2 4 request-length - 4 (OR (MEMBER none) CURSOR) cursor - 4 (OR (MEMBER currenttime) TIMESTAMP) time - 2 SETofPOINTEREVENT event-mask - 2 x unused -) - -(x-request GrabKeyboard - 1 31 opcode - 1 BOOL owner-events - 2 4 request-length - 4 WINDOW grab-window - 4 (OR (MEMBER currenttime) TIMESTAMP) time - 1 (MEMBER Synchronous Asynchronous) pointer-mode - 1 (MEMBER Synchronous Asynchronous) keyboard-mode - 2 x unused -) - -(x-request UngrabKeyboard - 1 32 opcode - 1 x unused - 2 2 request-length - 4 (OR (MEMBER currenttime) TIMESTAMP) time -) - -(x-request GrabKey - 1 33 opcode - 1 BOOL owner-events - 2 4 request-length - 4 WINDOW grab-window - 2 SETofKEYMASK modifiers - 1 (OR (MEMBER anykey) KEYCODE) key - 1 (MEMBER Synchronous Asynchronous) pointer-mode - 1 (MEMBER Synchronous Asynchronous) keyboard-mode - 3 x unused -) - -(x-request UngrabKey - 1 34 opcode - 1 (OR (MEMBER anykey) KEYCODE) key - 2 3 request-length - 4 WINDOW grab-window - 2 SETofKEYMASK modifiers - 2 x unused -) - -(x-request AllowEvents - 1 35 opcode - 1 (MEMBER AsyncPointer SyncPointer ReplayPointer AsyncKeyboard SyncKeyboard ReplayKeyboard) mode - 2 2 request-length - 4 (OR (MEMBER currenttime) TIMESTAMP) time -) - -(x-request GrabServer - 1 36 opcode - 1 x unused - 2 1 request-length -) - -(x-request UngrabServer - 1 37 opcode - 1 x unused - 2 1 request-length -) - -(x-request QueryPointer - 1 38 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request GetMotionEvents - 1 39 opcode - 1 x unused - 2 4 request-length - 4 WINDOW window - 4 (OR (MEMBER CURRENTTIME) TIMESTAMP) start - 4 (OR (MEMBER CURRENTTIME) TIMESTAMP) stop -) - -(x-request TranslateCoords - 1 40 opcode - 1 x unused - 2 4 request-length - 4 WINDOW src-window - 4 WINDOW dst-window - 2 INT16 src-x - 2 INT16 src-y -) - -(x-request WarpPointer - 1 41 opcode - 1 x unused - 2 6 request-length - 4 (OR (MEMBER none) WINDOW) src-window - 4 WINDOW dst-window - 2 INT16 src-x - 2 INT16 src-y - 2 CARD16 src-width - 2 CARD16 src-height - 2 INT16 dst-x - 2 INT16 dst-y -) - -(x-request SetInputFocus - 1 42 opcode - 1 (MEMBER none pointerroot parent) revert-to - 2 3 request-length - 4 (OR (MEMBER none pointerroot) WINDOW) focus - 4 (OR (MEMBER CURRENTTIME) TIMESTAMP) time -) - -(x-request GetInputFocus - 1 43 opcode - 1 x unused - 2 1 request-length -) - -(x-request QueryKeymap - 1 44 opcode - 1 x unused - 2 1 request-length -) - -(x-request OpenFont - 1 45 opcode - 1 x unused - 2 |3+(n+p)/4| request-length - 4 FONT fid - 2 n length-of-name - 2 x unused - n STRING8 name - p x unused -) - -(x-request CloseFont - 1 46 opcode - 1 x unused - 2 2 request-length - 4 FONT font -) - -(x-request QueryFont - 1 47 opcode - 1 x unused - 2 2 request-length - 4 FONTABLE font -) - -(x-request QueryTextExtents - 1 48 opcode - 1 BOOL odd-length-p - 2 |2+(2n+p)/4| request-length - 4 FONTABLE font - 2n STRING16 string - p x unused -) - -(x-request ListFonts - 1 49 opcode - 1 x unused - 2 |2+(n+p)/4| request-length - 2 CARD16 max-names - 2 n length-of-pattern - n STRING8 pattern - p x unused -) - -(x-request ListFontsWithInfo - 1 50 opcode - 1 x unused - 2 |2+(n+p)/4| request-length - 2 CARD16 max-names - 2 n length-of-pattern - n STRING8 pattern - p x unused -) - -(x-request SetFontPath - 1 51 opcode - 1 x unused - 2 |2+(n+p)/4| request-length - 2 CARD16 number-of-STRs-in-path - 2 x unused - n LISTofSTR path - p x unused -) - -(x-request GetFontPath - 1 52 opcode - 1 x unused - 2 1 request-list -) - -(x-request CreatePixmap - 1 53 opcode - 1 CARD8 depth - 2 4 request-length - 4 PIXMAP pid - 4 DRAWABLE drawable - 2 CARD16 width - 2 CARD16 height -) - -(x-request FreePixmap - 1 54 opcode - 1 x unused - 2 2 request-length - 4 PIXMAP pixmap -) - -(x-request CreateGC - 1 55 opcode - 1 x unused - 2 4+n request-length - 4 GCONTEXT cid - 4 DRAWABLE drawable - 4 (BITMASK *gc-bitmask*) value-mask - 4n LISTofVALUE value-list -) - -(defconstant *gc-bitmask* - #(function plane-mask foreground - background line-width line-style cap-style join-style - fill-style fill-rule tile stipple tile-stipple-x-origin - tile-stipple-y-origin font subwindow-mode graphics-exposures clip-x-origin - clip-y-origin clip-mask dash-offset dashes arc-mode)) - - -(x-request ChangeGC - 1 56 opcode - 1 x unused - 2 3+n request-length - 4 GCONTEXT gc - 4 (BITMASK *gc-bitmask*) value-mask - 4n LISTofVALUE value-list -) - -(x-request CopyGC - 1 57 opcode - 1 x unused - 2 4 request-length - 4 GCONTEXT src-gc - 4 GCONTEXT dst-gc - 4 (BITMASK *gc-bitmask*) value-mask -) - -(x-request SetDashes - 1 58 opcode - 1 x unused - 2 |3+(n+p)/4| request-length - 4 GCONTEXT gc - 2 CARD16 dash-offset - 2 n length-of-dashes - n LISTofCARD8 dashes - p x unused -) - -(x-request SetClipRectangles - 1 59 opcode - 1 (MEMBER UnSorted YSorted YXSorted YXBanded) ordering - 2 3+2n request-length - 4 GCONTEXT gc - 2 INT16 clip-x-origin - 2 INT16 clip-y-origin - 8n LISTofRECTANGLE rectangles -) - -(x-request FreeGC - 1 60 opcode - 1 x unused - 2 2 request-length - 4 GCONTEXT gc -) - -(x-request ClearToBackground - 1 61 opcode - 1 BOOL exposures - 2 4 request-length - 4 WINDOW window - 2 INT16 x - 2 INT16 y - 2 CARD16 width - 2 CARD16 height -) - -(x-request CopyArea - 1 62 opcode - 1 x unused - 2 7 request-length - 4 DRAWABLE src-drawable - 4 DRAWABLE dst-drawable - 4 GCONTEXT gc - 2 INT16 src-x - 2 INT16 src-y - 2 INT16 dst-x - 2 INT16 dst-y - 2 CARD16 width - 2 CARD16 height -) - -(x-request CopyPlane - 1 63 opcode - 1 x unused - 2 8 request-length - 4 DRAWABLE src-drawable - 4 DRAWABLE dst-drawable - 4 GCONTEXT gc - 2 INT16 src-x - 2 INT16 src-y - 2 INT16 dst-x - 2 INT16 dst-y - 2 CARD16 width - 2 CARD16 height - 4 CARD32 bit-plane -) - -(x-request PolyPoint - 1 64 opcode - 1 (MEMBER origin previous) coordinate-mode - 2 3+n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 4n LISTofPOINT points -) - -(x-request PolyLine - 1 65 opcode - 1 (MEMBER origin previous) coordinate-mode - 2 3+n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 4n LISTofPOINT points -) - -(x-request PolySegment - 1 66 opcode - 1 x unused - 2 3+2n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 8n LISTofSEGMENT segments -) - -(x-request PolyRectangle - 1 67 opcode - 1 x unused - 2 3+2n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 8n LISTofRECTANGLE rectangles -) - -(x-request PolyArc - 1 68 opcode - 1 x unused - 2 3+3n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 12n LISTofARC arcs -) - -(x-request FillPoly - 1 69 opcode - 1 x unused - 2 4+n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 1 (MEMBER complex nonconvex convex) shape - 1 (MEMBER origin previous) coordinate-mode - 2 x unused - 4n LISTofPOINT points -) - -(x-request PolyFillRectangle - 1 70 opcode - 1 x unused - 2 3+2n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 8n LISTofRECTANGLE rectangles -) - -(x-request PolyFillArc - 1 71 opcode - 1 x unused - 2 3+3n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 12n LISTofARC arcs -) - -(x-request PutImage - 1 72 opcode - 1 (bitmap xypixmap zpixmap) format - 2 |6+(n+p)/4| request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 2 CARD16 width - 2 CARD16 height - 2 INT16 dst-x - 2 INT16 dst-y - 1 CARD8 left-pad - 1 CARD8 depth - 2 x unused - n LISTofBYTE data - p x unused -) - -(x-request GetImage - 1 73 opcode - 1 (MEMBER error xypixmap zpixmap) format - 2 5 request-length - 4 DRAWABLE drawable - 2 INT16 x - 2 INT16 y - 2 CARD16 width - 2 CARD16 height - 4 CARD32 plane-mask -) - -(x-request PolyText8 - 1 74 opcode - 1 x unused - 2 |4+(n+p)/4| request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 2 INT16 x - 2 INT16 y - n LISTofTEXTITEM8 items - p x unused -) - -(x-request PolyText16 - 1 75 opcode - 1 x unused - 2 |4+(n+p)/4| request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 2 INT16 x - 2 INT16 y - n LISTofTEXTITEM16 items - p x unused -) - -(x-request ImageText8 - 1 76 opcode - 1 n length-of-string - 2 |4+(n+p)/4| request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 2 INT16 x - 2 INT16 y - n STRING8 string - p x unused -) - -(x-request ImageText16 - 1 77 opcode - 1 n number-of-CHAR2Bs-in-string - 2 |4+(2n+p)/4| request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 2 INT16 x - 2 INT16 y - 2n STRING16 string - p x unused -) - -(x-request CreateColormap - 1 78 opcode - 1 (MEMBER none all) alloc - 2 4 request-length - 4 COLORMAP mid - 4 WINDOW window - 4 VISUALID visual -) - -(x-request FreeColormap - 1 79 opcode - 1 x unused - 2 2 request-length - 4 COLORMAP cmap -) - -(x-request CopyColormapAndFree - 1 80 opcode - 1 x unused - 2 3 request-length - 4 COLORMAP mid - 4 COLORMAP src-cmap -) - -(x-request InstallColormap - 1 81 opcode - 1 x unused - 2 2 request-length - 4 COLORMAP cmap -) - -(x-request UninstallColormap - 1 82 opcode - 1 x unused - 2 2 request-length - 4 COLORMAP cmap -) - -(x-request ListInstalledColormaps - 1 83 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window -) - -(x-request AllocColor - 1 84 opcode - 1 x unused - 2 4 request-length - 4 COLORMAP cmap - 2 CARD16 red - 2 CARD16 green - 2 CARD16 blue - 2 x unused -) - -(x-request AllocNamedColor - 1 85 opcode - 1 x unused - 2 |3+(n+p)/4| request-length - 4 COLORMAP cmap - 2 n length-of-name - 2 x unused - n STRING8 name - p x unused -) - -(x-request AllocColorCells - 1 86 opcode - 1 BOOL contiguous - 2 3 request-length - 4 COLORMAP cmap - 2 CARD16 colors - 2 CARD16 planes -) - -(x-request AllocColorPlanes - 1 87 opcode - 1 BOOL contiguous - 2 4 request-length - 4 COLORMAP cmap - 2 CARD16 colors - 2 CARD16 reds - 2 CARD16 greens - 2 CARD16 blues -) - -(x-request FreeColors - 1 88 opcode - 1 x unused - 2 3+n request-length - 4 COLORMAP cmap - 4 CARD32 plane-mask - 4n LISTofCARD32 pixels -) - -(x-request StoreColors - 1 89 opcode - 1 x unused - 2 2+3n request-length - 4 COLORMAP cmap - 12n LISTofCOLORITEM items -) - -(x-request StoreNamedColor - 1 90 opcode - 1 color-mask do-red_do-green_do-blue - 2 |4+(n+p)/4| request-length - 4 COLORMAP cmap - 4 CARD32 pixel - 2 n length-of-name - 2 x unused - n STRING8 name - p x unused -) - -(x-request QueryColors - 1 91 opcode - 1 x unused - 2 2+n request-length - 4 COLORMAP cmap - 4n LISTofCARD32 pixels -) - -(x-request LookupColor - 1 92 opcode - 1 x unused - 2 |3+(n+p)/4| request-length - 4 COLORMAP cmap - 2 n length-of-name - 2 x unused - n STRING8 name - p x unused -) - -(x-request CreateCursor - 1 93 opcode - 1 x unused - 2 8 request-length - 4 CURSOR cid - 4 PIXMAP source - 4 (OR (MEMBER none) PIXMAP) mask - 2 CARD16 fore-red - 2 CARD16 fore-green - 2 CARD16 fore-blue - 2 CARD16 back-red - 2 CARD16 back-green - 2 CARD16 back-blue - 2 CARD16 x - 2 CARD16 y -) - -(x-request CreateGlyphCursor - 1 94 CreateGlyphCursor - 1 x unused - 2 8 request-length - 4 CURSOR cid - 4 FONT source-font - 4 (OR (MEMBER none) FONT) mask-font - 2 CARD16 source-char - 2 CARD16 mask-char - 2 CARD16 fore-red - 2 CARD16 fore-green - 2 CARD16 fore-blue - 2 CARD16 back-red - 2 CARD16 back-green - 2 CARD16 back-blue -) - -(x-request FreeCursor - 1 95 opcode - 1 x unused - 2 2 request-length - 4 CURSOR cursor -) - -(x-request RecolorCursor - 1 96 opcode - 1 x unused - 2 5 request-length - 4 CURSOR cursor - 2 CARD16 fore-red - 2 CARD16 fore-green - 2 CARD16 fore-blue - 2 CARD16 back-red - 2 CARD16 back-green - 2 CARD16 back-blue -) - -(x-request QueryBestSize - 1 97 opcode - 1 (MEMBER cursor tile stipple) class - 2 3 request-length - 4 DRAWABLE drawable - 2 CARD16 width - 2 CARD16 height -) - -(x-request QueryExtension - 1 98 opcode - 1 x unused - 2 |2+(n+p)/4| request-length - 2 n length-of-name - 2 x unused - n STRING8 name - p x unused -) - -(x-request ListExtensions - 1 99 opcode - 1 x unused - 2 1 request-length -) - -(x-request SetKeyboardMapping - 1 100 opcode - 1 n keycode-count - 2 2+nm request-length - 1 KEYCODE first-keycode - 1 m keysyms-per-keycode - 2 x unused - 4nm LISTofKEYSYM keysyms -) - -(x-request GetKeyboardMapping - 1 101 opcode - 1 x unused - 2 2 request-length - 1 KEYCODE first-keycode - 1 CARD8 count - 2 x unused -) - -(x-request ChangeKeyboardControl - 1 102 opcode - 1 x unused - 2 2+n request-length - 4 BITMASK value-mask - 4n LISTofVALUE value-list -) - -(x-request GetKeyboardControl - 1 103 opcode - 1 x unused - 2 1 request-length -) - -(x-request Bell - 1 104 opcode - 1 INT8 percent - 2 1 request-length -) - -(x-request ChangePointerControl - 1 105 opcode - 1 x unused - 2 3 request-length - 2 INT16 acceleration-numerator - 2 INT16 acceleration-denominator - 2 INT16 threshold - 1 BOOL do-acceleration - 1 BOOL do-threshold -) - -(x-request GetPointerControl - 1 106 GetPointerControl - 1 x unused - 2 1 request-length -) - -(x-request SetScreenSaver - 1 107 opcode - 1 x unused - 2 3 request-length - 2 INT16 timeout - 2 INT16 interval - 1 (MEMBER no yes default) prefer-blanking - 1 (MEMBER no yes default) allow-exposures - 2 x unused -) - -(x-request GetScreenSaver - 1 108 opcode - 1 x unused - 2 1 request-length -) - -(x-request ChangeHosts - 1 109 opcode - 1 (MEMBER insert delete) mode - 2 |2+(n+p)/4| request-length - 1 (MEMBER internet decnet chaos) family - 1 x unused - 2 CARD16 length-of-address - n LISTofCARD8 address - p x unused -) - -(x-request ListHosts - 1 110 opcode - 1 x unused - 2 1 request-length -) - -(x-request ChangeAccessControl - 1 111 opcode - 1 (MEMBER disable enable) mode - 2 1 request-length -) - -(x-request ChangeCloseDownMode - 1 112 opcode - 1 (MEMBER destroy retainpermanent retaintemporary) mode - 2 1 request-length -) - -(x-request KillClient - 1 113 opcode - 1 x unused - 2 2 request-length - 4 (MEMBER alltemporary CARD32) resource -) - -(x-request RotateProperties - 1 114 opcode - 1 x unused - 2 3+n request-length - 4 WINDOW window - 2 n number-of-properties - 2 INT16 delta - 4n LISTofATOM properties -) - -(x-request ForceScreenSaver - 1 115 ForceScreenSaver - 1 (MEMBER reset activate) mode - 2 1 request-length -) - -(x-request SetPointerMapping - 1 116 opcode - 1 n length-of-map - 2 |1+(n+p)/4| request-length - n LISTofCARD8 map - p x unused -) - -(x-request GetPointerMapping - 1 117 opcode - 1 x unused - 2 1 request-length -) - -(x-request SetModifierMapping - 1 118 opcode - 1 KEYCODE Lock - 2 5 request-length - 1 KEYCODE Shift_A - 1 KEYCODE Shift_B - 1 KEYCODE Control_A - 1 KEYCODE Control_B - 1 KEYCODE Mod1_A - 1 KEYCODE Mod1_B - 1 KEYCODE Mod2_A - 1 KEYCODE Mod2_B - 1 KEYCODE Mod3_A - 1 KEYCODE Mod3_B - 1 KEYCODE Mod4_A - 1 KEYCODE Mod4_B - 1 KEYCODE Mod5_A - 1 KEYCODE Mod5_B - 2 x unused -) - -(x-request GetModifierMapping - 1 119 opcode - 1 x unused - 2 1 request-length -) - -#+comment -(x-request NoOperation - 1 127 opcode - 1 x unused - 2 1 request-length -) -;; End of file diff -Nru ecl-16.1.2/src/clx/debug/event-test.lisp ecl-16.1.3+ds/src/clx/debug/event-test.lisp --- ecl-16.1.2/src/clx/debug/event-test.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/debug/event-test.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,237 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: (XTEST (XLIB LISP)); Base: 10; Lowercase: Yes -*- - -(in-package :xtest :use '(:xlib :lisp)) - -(defstruct event - key ; Event key - display ; Display event was reported to - ;; The following are from the CLX event - code - state - time - event-window - root - drawable - window - child - parent - root-x - root-y - x - y - width - height - border-width - override-redirect-p - same-screen-p - configure-p - hint-p - kind - mode - keymap - focus-p - count - major - minor - above-sibling - place - atom - selection - requestor - target - property - colormap - new-p - installed-p - format - type - data - send-event-p - ) - -(defun process-input (display &optional timeout) - "Process one event" - (declare (type display display) ; The display (from initialize-clue) - (type (or null number) timeout) ; optional timeout in seconds - (values (or null character))) ; Returns NIL only if timeout exceeded - (let ((event (make-event))) - (setf (event-display event) display) - (macrolet ((set-event (&rest parameters) - `(progn ,@(mapcar #'(lambda (parm) - `(setf (,(intern (concatenate 'string - (string 'event-) - (string parm))) - event) ,parm)) - parameters))) - (dispatch (contact) - `(dispatch-event event event-key send-event-p ,contact))) - - (let ((result - (xlib:event-case (display :timeout timeout :force-output-p t) - ((:key-press :key-release :button-press :button-release) - (code time root window child root-x root-y x y - state same-screen-p event-key send-event-p) - (set-event code time root window child root-x root-y x y - state same-screen-p) - (dispatch window)) - - (:motion-notify - (hint-p time root window child root-x root-y x y - state same-screen-p event-key send-event-p) - (set-event hint-p time root window child root-x root-y x y - state same-screen-p) - (dispatch window)) - - ((:enter-notify :leave-notify) - (kind time root window child root-x root-y x y - state mode focus-p same-screen-p event-key send-event-p) - (set-event kind time root window child root-x root-y x y - state mode focus-p same-screen-p) - (dispatch window)) - - ((:focus-in :focus-out) - (kind window mode event-key send-event-p) - (set-event kind window mode) - (dispatch window)) - - (:keymap-notify - (window keymap event-key send-event-p) - (set-event window keymap) - (dispatch window)) - - (:exposure - (window x y width height count event-key send-event-p) - (set-event window x y width height count) - (dispatch window)) - - (:graphics-exposure - (drawable x y width height count major minor event-key send-event-p) - (set-event drawable x y width height count major minor) - (dispatch drawable)) - - (:no-exposure - (drawable major minor event-key send-event-p) - (set-event drawable major minor) - (dispatch drawable)) - - (:visibility-notify - (window state event-key send-event-p) - (set-event window state) - (dispatch window)) - - (:create-notify - (parent window x y width height border-width - override-redirect-p event-key send-event-p) - (set-event parent window x y width height border-width - override-redirect-p) - (dispatch parent)) - - (:destroy-notify - (event-window window event-key send-event-p) - (set-event event-window window) - (dispatch event-window)) - - (:unmap-notify - (event-window window configure-p event-key send-event-p) - (set-event event-window window configure-p) - (dispatch event-window)) - - (:map-notify - (event-window window override-redirect-p event-key send-event-p) - (set-event event-window window override-redirect-p) - (dispatch event-window)) - - (:map-request - (parent window event-key send-event-p) - (set-event parent window) - (dispatch parent)) - - (:reparent-notify - (event-window window parent x y override-redirect-p event-key send-event-p) - (set-event event-window window parent x y override-redirect-p) - (dispatch event-window)) - - (:configure-notify - (event-window window above-sibling x y width height border-width - override-redirect-p event-key send-event-p) - (set-event event-window window above-sibling x y width height - border-width override-redirect-p) - (dispatch event-window)) - - (:configure-request - (parent window above-sibling x y width height border-width event-key send-event-p) - (set-event parent window above-sibling x y width height border-width) - (dispatch parent)) - - (:gravity-notify - (event-window window x y event-key send-event-p) - (set-event event-window window x y) - (dispatch event-window)) - - (:resize-request - (window width height event-key send-event-p) - (set-event window width height) - (dispatch window)) - - (:circulate-notify - (event-window window parent place event-key send-event-p) - (set-event event-window window parent place) - (dispatch event-window)) - - (:circulate-request - (parent window place event-key send-event-p) - (set-event parent window place) - (dispatch parent)) - - (:property-notify - (window atom time state event-key send-event-p) - (set-event window atom time state) - (dispatch window)) - - (:selection-clear - (time window selection event-key send-event-p) - (set-event time window selection) - (dispatch window)) - - (:selection-request - (time window requestor selection target property event-key send-event-p) - (set-event time window requestor selection target property) - (dispatch window)) - - (:selection-notify - (time window selection target property event-key send-event-p) - (set-event time window selection target property) - (dispatch window)) - - (:colormap-notify - (window colormap new-p installed-p event-key send-event-p) - (set-event window colormap new-p installed-p) - (dispatch window)) - - (:client-message - (format window type data event-key send-event-p) - (set-event format window type data) - (dispatch window)) - - (:mapping-notify - (request start count) - (mapping-notify display request start count)) ;; Special case - ))) - (and result t))))) - -(defun event-case-test (display) - ;; Tests universality of display, event-key, event-code, send-event-p and event-window - (event-case (display) - ((key-press key-release button-press button-release motion-notify - enter-notify leave-notify focus-in focus-out keymap-notify - exposure graphics-exposure no-exposure visibility-notify - create-notify destroy-notify unmap-notify map-notify map-request - reparent-notify configure-notify gravity-notify resize-request - configure-request circulate-notify circulate-request property-notify - selection-clear selection-request selection-notify colormap-notify client-message) - (display event-key event-code send-event-p event-window) - (print (list display event-key event-code send-event-p event-window))) - (mapping-notify ;; mapping-notify doesn't have event-window - (display event-key event-code send-event-p) - (print (list display event-key event-code send-event-p))) - )) diff -Nru ecl-16.1.2/src/clx/debug/keytrans.lisp ecl-16.1.3+ds/src/clx/debug/keytrans.lisp --- ecl-16.1.2/src/clx/debug/keytrans.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/debug/keytrans.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,266 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- - -;;; CLX keysym-translation test programs - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(defun list-missing-keysyms () - ;; Lists explorer characters which have no keysyms - (dotimes (i 256) - (unless (character->keysyms (int-char i)) - (format t "~%(define-keysym ~@c ~d)" (int-char i) i)))) - -(defun list-multiple-keysyms () - ;; Lists characters with more than one keysym - (dotimes (i 256) - (when (cdr (character->keysyms (int-char i))) - (format t "~%Character ~@c [~d] has keysyms" (int-char i) i) - (dolist (keysym (character->keysyms (int-char i))) - (format t " ~d ~d" (ldb (byte 8 8) keysym) (ldb (byte 8 0) keysym)))))) - -(defun check-lowercase-keysyms () - ;; Checks for keysyms with incorrect :lowercase parameters - (maphash #'(lambda (key mapping) - (let* ((value (car mapping)) - (char (keysym-mapping-object value))) - (if (and (characterp char) (both-case-p char) - (= (char-int char) (char-int (char-upcase char)))) - ;; uppercase alphabetic character - (unless (eq (keysym-mapping-lowercase value) - (char-int (char-downcase char))) - (let ((lowercase (keysym-mapping-lowercase value)) - (should-be (char-downcase char))) - (format t "~%Error keysym ~3d ~3d (~@c) has :Lowercase ~3d ~3d (~s) Should be ~3d ~3d (~@c)" - (ldb (byte 8 8) key) - (ldb (byte 8 0) key) - char - (and lowercase (ldb (byte 8 8) lowercase)) - (and lowercase (ldb (byte 8 0) lowercase)) - (int-char lowercase) - (ldb (byte 8 8) (char-int should-be)) - (ldb (byte 8 0) (char-int should-be)) - should-be))) - (when (keysym-mapping-lowercase value) - (let ((lowercase (keysym-mapping-lowercase value))) - (format t "~%Error keysym ~3d ~3d (~@c) has :lowercase ~3d ~3d (~@c) and shouldn't" - (ldb (byte 8 8) key) - (ldb (byte 8 0) key) - char - (and lowercase (ldb (byte 8 8) (char-int lowercase))) - (and lowercase (ldb (byte 8 0) (char-int lowercase))) - lowercase - )))))) - *keysym->character-map*)) - -(defun print-all-keysyms () - (let ((all nil)) - (maphash #'(lambda (key value) (push (cons key value) all)) *keysym->character-map*) - (setq all (sort all #'< :key #'car)) - (format t "~%~d keysyms:" (length all)) - - (dolist (keysym all) - (format t "~%~3d ~3d~{ ~s~}" - (ldb (byte 8 8) (car keysym)) - (ldb (byte 8 0) (car keysym)) - (cadr keysym)) - (dolist (mapping (cddr keysym)) - (format t "~%~7@t~{ ~s~}" mapping))))) - -(defun keysym-mappings (keysym &key display (mask-format #'identity)) - ;; Return all the keysym mappings for keysym. - ;; Returns a list of argument lists that are argument-lists to define-keysym. - ;; The following will re-create the mappings for KEYSYM: - ;; (dolist (mapping (keysym-mappings) keysym) - ;; (apply #'define-keysym mapping)) - (let ((mappings (append (and display (cdr (assoc keysym (display-keysym-translation display)))) - (gethash keysym *keysym->character-map*))) - (result nil)) - (dolist (mapping mappings) - (let ((object (keysym-mapping-object mapping)) - (translate (keysym-mapping-translate mapping)) - (lowercase (keysym-mapping-lowercase mapping)) - (modifiers (keysym-mapping-modifiers mapping)) - (mask (keysym-mapping-mask mapping))) - (push (append (list object keysym) - (when translate (list :translate translate)) - (when lowercase (list :lowercase lowercase)) - (when modifiers (list :modifiers (funcall mask-format modifiers))) - (when mask (list :mask (funcall mask-format mask)))) - result))) - (nreverse result))) - -#+comment -(defun print-keysym-mappings (keysym &optional display) - (format t "~%(keysym ~d ~3d) " - (ldb (byte 8 8) keysym) - (ldb (byte 8 0) keysym)) - (dolist (mapping (keysym-mappings keysym :display display)) - (format t "~16t~{ ~s~}~%" mapping))) - -(defun print-keysym-mappings (keysym &optional display) - (flet ((format-mask (mask) - (cond ((numberp mask) - `(make-state-mask ,@(make-state-keys mask))) - ((atom mask) mask) - (t `(list ,@(mapcar - #'(lambda (item) - (if (numberp item) - `(keysym ,(keysym-mapping-object - (car (gethash item *keysym->character-map*)))) - item)) - mask)))))) - (dolist (mapping (keysym-mappings keysym :display display :mask-format #'format-mask)) - (format t "~%(define-keysym ~s (keysym ~d ~3d)~{ ~s~})" - (car mapping) - (ldb (byte 8 8) keysym) - (ldb (byte 8 0) keysym) - (cdr mapping))))) - -(defun keysym-test (host) - ;; Server key-press Loop-back test - (let* ((display (open-display host)) - (width 400) - (height 400) - (screen (display-default-screen display)) - (black (screen-black-pixel screen)) - (white (screen-white-pixel screen)) - (win (create-window - :parent (screen-root screen) - :background black - :border white - :border-width 1 - :colormap (screen-default-colormap screen) - :bit-gravity :center - :event-mask '(:exposure :key-press) - :x 20 :y 20 - :width width :height height)) - #+comment - (gc (create-gcontext - :drawable win - :background black - :foreground white))) - (initialize-extensions display) - - (map-window win) ; Map the window - ;; Handle events - (unwind-protect - (dotimes (state 64) - (do ((code (display-min-keycode display) (1+ code))) - ((> code (display-max-keycode display))) - (send-event win :key-press '(:key-press) :code code :state state - :window win :root (screen-root screen) :time 0 - :x 1 :y 2 :root-x 10 :root-y 20 :same-screen-p t) - (event-case (display :force-output-p t :discard-p t) - (exposure ;; Come here on exposure events - (window count) - (when (zerop count) ;; Ignore all but the last exposure event - (clear-area window)) - nil) - (key-press (display code state) - (princ (keycode->character display code state)) - t)))) - (close-display display)))) - -(defun keysym-echo (host &optional keymap-p) - ;; Echo characters typed to a window - (let* ((display (open-display host)) - (width 400) - (height 400) - (screen (display-default-screen display)) - (black (screen-black-pixel screen)) - (white (screen-white-pixel screen)) - (win (create-window - :parent (screen-root screen) - :background black - :border white - :border-width 1 - :colormap (screen-default-colormap screen) - :bit-gravity :center - :event-mask '(:exposure :key-press :keymap-state :enter-window) - :x 20 :y 20 - :width width :height height)) - (gc (create-gcontext - :drawable win - :background black - :foreground white))) - (initialize-extensions display) - - (map-window win) ; Map the window - ;; Handle events - (unwind-protect - (event-case (display :force-output-p t :discard-p t) - (exposure ;; Come here on exposure events - (window count) - (when (zerop count) ;; Ignore all but the last exposure event - (clear-area window) - (draw-glyphs window gc 10 10 "Press to exit")) - nil) - (key-press (display code state) - (let ((char (keycode->character display code state))) - (format t "~%Code: ~s State: ~s Char: ~s" code state char) - ;; (PRINC char) (PRINC " ") - (when keymap-p - (let ((keymap (query-keymap display))) - (unless (character-in-map-p display char keymap) - (print "character-in-map-p failed") - (print-keymap keymap)))) - ;; (when (eql char #\0) (setq disp display) (break)) - (eql char #\escape))) - (keymap-notify (keymap) - (print "Keymap-notify") ;; we never get here. Server bug? - (when (keysym-in-map-p display 65 keymap) - (print "Found A")) - (when (character-in-map-p display #\b keymap) - (print "Found B"))) - (enter-notify (event-window) (format t "~%Enter ~s" event-window))) - (close-display display)))) - -(defun print-keymap (keymap) - (do ((j 32 (+ j 32))) ;; first 32 bits is for window - ((>= j 256)) - (format t "~% ~3d: " j) - (do ((i j (1+ i))) - ((>= i (+ j 32))) - (when (zerop (logand i 7)) - (princ " ")) - (princ (aref keymap i))))) - -(defun define-keysym-test (&key display printp - (modifiers (list (keysym :left-meta))) (mask :modifiers)) - (let* ((keysym 067) - (args `(baz ,keysym :modifiers ,modifiers ,@(and mask `(:mask ,mask)))) - (original (copy-tree (keysym-mappings keysym :display display)))) - (when printp (print-keysym-mappings 67) (terpri)) - (apply #'define-keysym args) - (when printp (print-keysym-mappings 67) (terpri)) - (let ((is (keysym-mappings keysym :display display)) - (should-be (append original (list args)))) - (unless (equal is should-be) - (cerror "Ignore" "define-keysym error. ~%is: ~s ~%Should be: ~s" is should-be))) - (apply #'undefine-keysym args) - (when printp (print-keysym-mappings 67) (terpri)) - (let ((is (keysym-mappings keysym :display display))) - (unless (equal is original) - (cerror "Ignore" "undefine-keysym error. ~%is: ~s ~%Should be: ~s" is original))))) - -(define-keysym-test) -(define-keysym-test :modifiers (make-state-mask :shift :lock)) -(define-keysym-test :modifiers (list :shift (keysym :left-meta) :control)) -(define-keysym-test :modifiers (make-state-mask :shift :lock) :mask nil) - diff -Nru ecl-16.1.2/src/clx/debug/trace.lisp ecl-16.1.3+ds/src/clx/debug/trace.lisp --- ecl-16.1.2/src/clx/debug/trace.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/debug/trace.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,456 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -;; Trace works by substituting trace functions for the display-write/input functions. -;; The trace functions maintain a database of requests sent to the server in the -;; trace-history display property. This is an alist of (id . byte-vector) where -;; id is the request number for writes, :reply for replies, :event for events and -;; :error for errors. The alist is kept in reverse order (most recent first) - -;; In a multiprocessing system is it very helpful to know what process wrote or -;; read certain requests. Thus I have modified the format of the trace-history -;; list. It is now an alist of: ((id . more-info) . byte-vector). -;; (more-info is a list returned by the trace-more-info function). -;; Also added the ability to suspend and resume tracing without destroying the -;; trace history. Renamed 'display-trace' to 'show-trace' to avoid confusion. -;; 7feb91 -- jdi - -;;; Created 09/14/87 by LaMott G. OREN - -(in-package :xlib) - -(eval-when (load eval) - (export '(trace-display - suspend-display-tracing - resume-display-tracing - untrace-display - show-trace - display-trace ; for backwards compatibility - describe-request - describe-event - describe-reply - describe-error - describe-trace))) - -(defun trace-display (display) - "Start a trace on DISPLAY. - If display is already being traced, this discards previous history. - See show-trace and describe-trace." - (declare (type display display)) - (unless (getf (display-plist display) 'write-function) - (bind-io-hooks display)) - (setf (display-trace-history display) nil) - t) - -(defun suspend-display-tracing (display) - "Tracing is suspended, but history is not cleared." - (if (getf (display-plist display) 'suspend-display-tracing) - (warn "Tracing is already suspend for ~s" display) - (progn - (unbind-io-hooks display) - (setf (getf (display-plist display) 'suspend-display-tracing) t)))) - -(defun resume-display-tracing (display) - "Used to resume tracing after suspending" - (if (getf (display-plist display) 'suspend-display-tracing) - (progn - (bind-io-hooks display) - (remf (display-plist display) 'suspend-display-tracing)) - (warn "Tracing was not suspended for ~s" display))) - -(defun untrace-display (display) - "Stop tracing DISPLAY." - (declare (type display display)) - (if (not (getf (display-plist display) 'suspend-display-tracing)) - (unbind-io-hooks display) - (remf (display-plist display) 'suspend-display-tracing)) - (setf (display-trace-history display) nil)) - -;; Assumes tracing is not already on. -(defun bind-io-hooks (display) - (let ((write-function (display-write-function display)) - (input-function (display-input-function display))) - ;; Save origional write/input functions so we can untrace - (setf (getf (display-plist display) 'write-function) write-function) - (setf (getf (display-plist display) 'input-function) input-function) - ;; Set new write/input functions that will record what's sent to the server - (setf (display-write-function display) - #'(lambda (vector display start end) - (trace-write-hook vector display start end) - (funcall write-function vector display start end))) - (setf (display-input-function display) - #'(lambda (display vector start end timeout) - (let ((result (funcall input-function - display vector start end timeout))) - (unless result - (trace-read-hook display vector start end)) - result))))) - -(defun unbind-io-hooks (display) - (let ((write-function (getf (display-plist display) 'write-function)) - (input-function (getf (display-plist display) 'input-function))) - (when write-function - (setf (display-write-function display) write-function)) - (when input-function - (setf (display-input-function display) input-function)) - (remf (display-plist display) 'write-function) - (remf (display-plist display) 'input-function))) - - -(defun byte-ref16 (vector index) - #+clx-little-endian - (logior (the card16 - (ash (the card8 (aref vector (index+ index 1))) 8)) - (the card8 - (aref vector index))) - #-clx-little-endian - (logior (the card16 - (ash (the card8 (aref vector index)) 8)) - (the card8 - (aref vector (index+ index 1))))) - -(defun byte-ref32 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (values card32)) - (declare-buffun) - #+clx-little-endian - (the card32 - (logior (the card32 - (ash (the card8 (aref a (index+ i 3))) 24)) - (the card29 - (ash (the card8 (aref a (index+ i 2))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i 1))) 8)) - (the card8 - (aref a i)))) - #-clx-little-endian - (the card32 - (logior (the card32 - (ash (the card8 (aref a i)) 24)) - (the card29 - (ash (the card8 (aref a (index+ i 1))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i 2))) 8)) - (the card8 - (aref a (index+ i 3)))))) - -(defun trace-write-hook (vector display start end) - ;; Called only by buffer-flush. Start should always be 0 - (unless (zerop start) - (format *debug-io* "write-called with non-zero start: ~d" start)) - (let* ((history (display-trace-history display)) - (request-number (display-request-number display)) - (last-history (car history))) - ;; There may be several requests in the buffer, and the last one may be - ;; incomplete. The first one may be the completion of a previous request. - ;; We can detect incomplete requests by comparing the expected length of - ;; the last request with the actual length. - (when (and last-history (numberp (caar last-history))) - (let* ((last-length (index* 4 (byte-ref16 (cdr last-history) 2))) - (append-length (min (- last-length (length (cdr last-history))) - (- end start)))) - (when (plusp append-length) - ;; Last history incomplete - append to last - (setf (cdr last-history) - (concatenate '(vector card8) (cdr last-history) - (subseq vector start (+ start append-length)))) - (index-incf start append-length)))) - ;; Copy new requests into the history - (do* ((new-history nil) - (i start (+ i length)) - request - length) - ((>= i end) - ;; add in sequence numbers - (dolist (entry new-history) - (setf (caar entry) request-number) - (decf request-number)) - (setf (display-trace-history display) - (nconc new-history history))) - (setq request (aref vector i)) - (setq length (index* 4 (byte-ref16 vector (+ i 2)))) - (when (zerop length) - (warn "Zero length in buffer") - (return nil)) - (push (cons (cons 0 (trace-more-info display request vector - i (min (+ i length) end))) - (subseq vector i (min (+ i length) end))) new-history) - (when (zerop request) - (warn "Zero length in buffer") - (return nil))))) - -(defun trace-read-hook (display vector start end) - ;; Reading is done with an initial length of 32 (with start = 0) - ;; This may be followed by several other reads for long replies. - (let* ((history (display-trace-history display)) - (last-history (car history)) - (length (- end start))) - (when (and history (eq (caar last-history) :reply)) - (let* ((last-length (index+ 32 (index* 4 (byte-ref32 (cdr last-history) 4)))) - (append-length (min (- last-length (length (cdr last-history))) - (- end start)))) - (when (plusp append-length) - (setf (cdr last-history) - (concatenate '(vector card8) (cdr last-history) - (subseq vector start (+ start append-length)))) - (index-incf start append-length) - (index-decf length append-length)))) - - ;; Copy new requests into the history - (when (plusp length) - (let ((reply-type (case (aref vector start) (0 :error) (1 :reply) - (otherwise :event)))) - (push (cons (cons reply-type - (trace-more-info display reply-type vector start - (+ start length))) - (subseq vector start (+ start length))) - (display-trace-history display)))))) - -(defun trace-more-info (display request-id vector start end) - ;; Currently only returns current process. - #+allegro - (list mp::*current-process*)) - - -(defun show-trace (display &key length show-process) - "Display the trace history for DISPLAY. - The default is to show ALL history entries. - When the LENGTH parameter is used, only the last LENGTH entries are - displayed." - (declare (type display display)) - (dolist (hist (reverse (subseq (display-trace-history display) - 0 length))) - (let* ((id (caar hist)) - (more-info (cdar hist)) - (vector (cdr hist)) - (length (length vector)) - (request (aref vector 0))) - (format t "~%~5d " id) - (case id - (:error - (trace-error-print display more-info vector)) - (:event - (format t "~a (~d) Sequence ~d" - (if (< request (length *event-key-vector*)) - (aref *event-key-vector* request) - "Unknown") - request - (byte-ref16 vector 2)) - (when show-process - #+allegro - (format t ", Proc ~a" (mp::process-name (car more-info))))) - (:reply - (format t "To ~d length ~d" - (byte-ref16 vector 2) length) - (let ((actual-length (index+ 32 (index* 4 (byte-ref32 vector 4))))) - (unless (= length actual-length) - (format t " Should be ~d **************" actual-length))) - (when show-process - #+allegro - (format t ", Proc ~a" (mp::process-name (car more-info))))) - (otherwise - (format t "~a (~d) length ~d" - (request-name request) request length) - (when show-process - #+allegro - (format t ", Proc ~a" (mp::process-name (car more-info))))))))) - -;; For backwards compatibility -(defun display-trace (&rest args) - (apply 'show-trace args)) - -(defun find-trace (display type sequence &optional (number 0)) - (dolist (history (display-trace-history display)) - (when (and (symbolp (caar history)) - (= (logandc2 (aref (cdr history) 0) 128) type) - (= (byte-ref16 (cdr history) 2) sequence) - (minusp (decf number))) - (return (cdr history))))) - -(defun describe-error (display sequence) - "Describe the error associated with request SEQUENCE." - (let ((vector (find-trace display 0 sequence))) - (if vector - (progn - (terpri) - (trace-error-print display nil vector)) - (format t "Error with sequence ~d not found." sequence)))) - -(defun trace-error-print (display more-info vector - &optional (stream *standard-output*)) - (let ((event (allocate-event))) - ;; Copy into event from reply buffer - (buffer-replace (reply-ibuf8 event) - vector - 0 - *replysize*) - (reading-event (event) - (let* ((type (read-card8 0)) - (error-code (read-card8 1)) - (sequence (read-card16 2)) - (resource-id (read-card32 4)) - (minor-code (read-card16 8)) - (major-code (read-card8 10)) - (current-sequence (ldb (byte 16 0) (buffer-request-number display))) - (error-key - (if (< error-code (length *xerror-vector*)) - (aref *xerror-vector* error-code) - 'unknown-error)) - (params - (case error-key - ((colormap-error cursor-error drawable-error font-error gcontext-error - id-choice-error pixmap-error window-error) - (list :resource-id resource-id)) - (atom-error - (list :atom-id resource-id)) - (value-error - (list :value resource-id)) - (unknown-error - ;; Prevent errors when handler is a sequence - (setq error-code 0) - (list :error-code error-code))))) - type - (let ((condition - (apply #+lispm #'si:make-condition - #+allegro #'make-condition - #-(or lispm allegro) #'make-condition - error-key - :error-key error-key - :display display - :major major-code - :minor minor-code - :sequence sequence - :current-sequence current-sequence - params))) - (princ condition stream) - (deallocate-event event) - condition))))) - -(defun describe-request (display sequence) - "Describe the request with sequence number SEQUENCE" - #+ti (si:load-if "clx:debug;describe") - (let ((request (assoc sequence (display-trace-history display) - :test #'(lambda (item key) - (eql item (car key)))))) - (if (null request) - (format t "~%Request number ~d not found in trace history" sequence) - (let* ((vector (cdr request)) - (len (length vector)) - (hist (make-reply-buffer len))) - (buffer-replace (reply-ibuf8 hist) vector 0 len) - (print-history-description hist))))) - -(defun describe-reply (display sequence) - "Print the reply to request SEQUENCE. - (The current implementation doesn't print very pretty)" - (let ((vector (find-trace display 1 sequence)) - (*print-array* t)) - (if vector - (print vector) - (format t "~%Reply not found")))) - -(defun event-number (name) - (if (integerp name) - (let ((name (logandc2 name 128))) - (if (typep name '(integer 0 63)) - (aref *event-key-vector* name)) - name) - (position (string name) *event-key-vector* :test #'equalp :key #'string))) - -(defun describe-event (display name sequence &optional (number 0)) - "Describe the event with event-name NAME and sequence number SEQUENCE. -If there is more than one event, return NUMBER in the sequence." - (declare (type display display) - (type (or stringable (integer 0 63)) name) - (integer sequence)) - (let* ((event (event-number name)) - (vector (and event (find-trace display event sequence number)))) - (if (not event) - (format t "~%~s isn't an event name" name) - (if (not vector) - (if (and (plusp number) (setq vector (find-trace display event sequence 0))) - (do ((i 1 (1+ i)) - (last-vector)) - (nil) - (if (setq vector (find-trace display event sequence i)) - (setq last-vector vector) - (progn - (format t "~%Event number ~d not found, last event was ~d" - number (1- i)) - (return (trace-event-print display last-vector))))) - (format t "~%Event ~s not found" - (aref *event-key-vector* event))) - (trace-event-print display vector))))) - -(defun trace-event-print (display vector) - (let* ((event (allocate-event)) - (event-code (ldb (byte 7 0) (aref vector 0))) - (event-decoder (aref *event-handler-vector* event-code))) - ;; Copy into event from reply buffer - (setf (event-code event) event-code) - (buffer-replace (reply-ibuf8 event) - vector - 0 - *replysize*) - (prog1 (funcall event-decoder display event - #'(lambda (&rest args &key send-event-p &allow-other-keys) - (setq args (copy-list args)) - (remf args :display) - (remf args :event-code) - (unless send-event-p (remf args :send-event-p)) - args)) - (deallocate-event event)))) - -(defun describe-trace (display &optional length) - "Display the trace history for DISPLAY. - The default is to show ALL history entries. - When the LENGTH parameter is used, only the last LENGTH entries are - displayed." - (declare (type display display)) - #+ti (si:load-if "clx:debug;describe") - (dolist (hist (reverse (subseq (display-trace-history display) - 0 length))) - (let* ((id (car hist)) - (vector (cdr hist)) - (length (length vector))) - (format t "~%~5d " id) - (case id - (:error - (trace-error-print display nil vector)) - (:event - (let ((event (trace-event-print display vector))) - (when event (format t "from ~d ~{ ~s~}" - (byte-ref16 vector 2) event)))) - (:reply - (format t "To ~d length ~d" - (byte-ref16 vector 2) length) - (let ((actual-length (index+ 32 (index* 4 (byte-ref32 vector 4))))) - (unless (= length actual-length) - (format t " Should be ~d **************" actual-length))) - (let ((*print-array* t) - (*print-base* 16.)) - (princ " ") - (princ vector))) - (otherwise - (let* ((len (length vector)) - (hist (make-reply-buffer len))) - (buffer-replace (reply-ibuf8 hist) vector 0 len) - (print-history-description hist))))))) - -;; End of file diff -Nru ecl-16.1.2/src/clx/debug/util.lisp ecl-16.1.3+ds/src/clx/debug/util.lisp --- ecl-16.1.2/src/clx/debug/util.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/debug/util.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,167 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES; -*- - -;; CLX utilities - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -;;; Created 04/09/87 14:30:41 by LaMott G. OREN - -(in-package :xlib) - -(export '(display-root - display-black - display-white - report-events - describe-window - describe-gc - degree - radian - display-refresh - root-tree - window-tree)) - -(defun display-root (display) (screen-root (display-default-screen display))) -(defun display-black (display) (screen-black-pixel (display-default-screen display))) -(defun display-white (display) (screen-white-pixel (display-default-screen display))) - -(defun report-events (display) - (loop - (unless - (process-event display :handler #'(lambda (&rest args) (print args)) :discard-p t :timeout 0.001) - (return nil)))) - -(defun describe-window (window) - (macrolet ((da (attribute &key (transform 'progn) (format "~s")) - (let ((func (intern (concatenate 'string (string 'window-) - (string attribute)) 'xlib))) - `(format t "~%~22a ~?" ',attribute ,format (list (,transform (,func window)))))) - (dg (attribute &key (transform 'progn) (format "~s")) - (let ((func (intern (concatenate 'string (string 'drawable-) - (string attribute)) 'xlib))) - `(format t "~%~22a ~?" ',attribute ,format (list (,transform (,func window))))))) - (with-state (window) - (when (window-p window) - (da visual :format "#x~x") - (da class) - (da gravity) - (da bit-gravity) - (da backing-store) - (da backing-planes :format "#x~x") - (da backing-pixel) - (da save-under) - (da colormap) - (da colormap-installed-p) - (da map-state) - (da all-event-masks :transform make-event-keys :format "~{~<~%~1:;~s ~>~}") - (da event-mask :transform make-event-keys :format "~{~<~%~1:;~s ~>~}") - (da do-not-propagate-mask :transform make-event-keys :format "~{~<~%~1:;~s ~>~}") - (da override-redirect) - ) - (dg root) - (dg depth) - (dg x) - (dg y) - (dg width) - (dg height) - (dg border-width) - - ))) - -(defun describe-gc (gc) - (macrolet ((dgc (name &key (transform 'progn) (format "~s")) - (let ((func (intern (concatenate 'string (string 'gcontext-) - (string name)) 'xlib))) - `(format t "~%~22a ~?" ',name ,format (list (,transform (,func gc))))))) - (dgc function) - (dgc plane-mask) - (dgc foreground) - (dgc background) - (dgc line-width) - (dgc line-style) - (dgc cap-style) - (dgc join-style) - (dgc fill-style) - (dgc fill-rule) - (dgc tile) - (dgc stipple) - (dgc ts-x) - (dgc ts-y) - (dgc font) ;; See below - (dgc subwindow-mode) - (dgc exposures) - (dgc clip-x) - (dgc clip-y) -;; (dgc clip-ordering) - (dgc clip-mask) - (dgc dash-offset) - (dgc dashes) - (dgc arc-mode) - )) - -(defun degree (degrees) - (* degrees (/ pi 180))) - -(defun radian (radians) - (round (* radians (/ 180 pi)))) - -(defun display-refresh (host) - ;; Useful for when the system writes to the screen (sometimes scrolling!) - (let ((display (open-display host))) - (unwind-protect - (let ((screen (display-default-screen display))) - (let ((win (create-window :parent (screen-root screen) :x 0 :y 0 :override-redirect :on - :width (screen-width screen) :height (screen-height screen) - :background (screen-black-pixel screen)))) - (map-window win) - (display-finish-output display) - (unmap-window win) - (destroy-window win) - (display-finish-output display))) - (close-display display)))) - -(defun root-tree (host) - (let ((display (open-display host))) - (unwind-protect - (window-tree (screen-root (display-default-screen display))) - (close-display display))) - (values)) - -(defun window-tree (window &optional (depth 0)) - ;; Print the window tree and properties starting from WINDOW - ;; Returns a list of windows in the order that they are printed. - (declare (arglist window) - (type window window) - (values (list window))) - (let ((props (mapcar #'(lambda (prop) - (multiple-value-bind (data type format) - (get-property window prop) - (case type - (:string (setq data (coerce data 'string)))) - (list prop format type data))) - (list-properties window))) - (result (list window))) - (with-state (window) - (format t "~%~v@t#x~x~20,20t X~3d Y~3d W~4d H~3d ~s" depth (window-id window) - (drawable-x window) (drawable-y window) - (drawable-width window) (drawable-height window) - (window-map-state window))) - (dolist (prop props) - (format t "~%~v@t~{~s ~}" (+ depth 2) prop)) - (dolist (w (query-tree window)) - (setq result (nconc result (window-tree w (+ depth 2))))) - result)) - diff -Nru ecl-16.1.2/src/clx/defsystem.lisp ecl-16.1.3+ds/src/clx/defsystem.lisp --- ecl-16.1.2/src/clx/defsystem.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/defsystem.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,568 +0,0 @@ -;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Portions Copyright (C) 1987 Texas Instruments Incorporated. -;;; Portions Copyright (C) 1988, 1989 Franz Inc, Berkeley, Ca. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; -;;; Franz Incorporated provides this software "as is" without express or -;;; implied warranty. - -;;; #+ features used in this file -;;; clx-ansi-common-lisp -;;; lispm -;;; genera -;;; minima -;;; lucid -;;; lcl3.0 -;;; apollo -;;; kcl -;;; ibcl -;;; excl -;;; CMU -;;; sbcl - -#+(or Genera Minima sbcl ecl) -(eval-when (:compile-toplevel :load-toplevel :execute) - (common-lisp:pushnew :clx-ansi-common-lisp common-lisp:*features*)) - -#+(and Genera clx-ansi-common-lisp) -(eval-when (:compile-toplevel :load-toplevel :execute) - (setf *readtable* si:*ansi-common-lisp-readtable*)) - -#-(or clx-ansi-common-lisp cmu) -(lisp:in-package :user) - -#+cmu -(lisp:in-package "XLIB") -#+cmu -(export 'load-clx) - -#+clx-ansi-common-lisp -(common-lisp:in-package :common-lisp-user) - - -;;;; Lisp Machines - -#+(and lispm (not genera)) -(global:defsystem CLX - (:pathname-default "clx:clx;") - (:patchable "clx:patch;" clx-ti) - (:initial-status :experimental) - - (:module package "package") - (:module depdefs "depdefs") - (:module clx "clx") - (:module dependent "dependent") - (:module macros "macros") - (:module bufmac "bufmac") - (:module buffer "buffer") - (:module display "display") - (:module gcontext "gcontext") - (:module requests "requests") - (:module input "input") - (:module fonts "fonts") - (:module graphics "graphics") - (:module text "text") - (:module attributes "attributes") - (:module translate "translate") - (:module keysyms "keysyms") - (:module manager "manager") - (:module image "image") - (:module resource "resource") - (:module doc "doc") - - (:compile-load package) - (:compile-load depdefs - (:fasload package)) - (:compile-load clx - (:fasload package depdefs)) - (:compile-load dependent - (:fasload package depdefs clx)) - ;; Macros only needed for compilation - (:skip :compile-load macros - (:fasload package depdefs clx dependent)) - ;; Bufmac only needed for compilation - (:skip :compile-load bufmac - (:fasload package depdefs clx dependent macros)) - (:compile-load buffer - (:fasload package depdefs clx dependent macros bufmac)) - (:compile-load display - (:fasload package depdefs clx dependent macros bufmac buffer)) - (:compile-load gcontext - (:fasload package depdefs clx dependent macros bufmac buffer display)) - (:compile-load input - (:fasload package depdefs clx dependent macros bufmac buffer display)) - (:compile-load requests - (:fasload package depdefs clx dependent macros bufmac buffer display input)) - (:compile-load fonts - (:fasload package depdefs clx dependent macros bufmac buffer display)) - (:compile-load graphics - (:fasload package depdefs clx dependent macros fonts bufmac buffer display - fonts)) - (:compile-load text - (:fasload package depdefs clx dependent macros fonts bufmac buffer display - gcontext fonts)) - (:compile-load-init attributes - (dependent) - (:fasload package depdefs clx dependent macros bufmac buffer display)) - (:compile-load translate - (:fasload package depdefs clx dependent macros bufmac buffer display)) - (:compile-load keysyms - (:fasload package depdefs clx dependent macros bufmac buffer display - translate)) - (:compile-load manager - (:fasload package depdefs clx dependent macros bufmac buffer display)) - (:compile-load image - (:fasload package depdefs clx dependent macros bufmac buffer display)) - (:compile-load resource - (:fasload package depdefs clx dependent macros bufmac buffer display)) - (:auxiliary doc) - ) - - -;;; Symbolics Lisp Machines -#+Genera -(scl:defsystem CLX - (:default-pathname "SYS:X11;CLX;" - :pretty-name "CLX" - :maintaining-sites (:scrc) - :distribute-sources t - :distribute-binaries t - :source-category :basic) - (:module doc ("doc") - (:type :lisp-example)) - (:serial - "package" "depdefs" "generalock" "clx" "dependent" "macros" "bufmac" - "buffer" "display" "gcontext" "input" "requests" "fonts" "graphics" - "text" "attributes" "translate" "keysyms" "manager" "image" "resource")) - -#+Minima -(zl:::scl:defsystem Minima-CLX - (:default-pathname "SYS:X11;CLX;" - :pretty-name "Minima CLX" - :maintain-journals nil - :maintaining-sites (:scrc) - :distribute-sources t - :distribute-binaries t - :source-category :basic - :default-module-type :minima-lisp) - (:module doc ("doc") - (:type :lisp-example)) - (:serial - "package" "depdefs" "clx" "dependent" "macros" "bufmac" - "buffer" "display" "gcontext" "input" "requests" "fonts" "graphics" - "text" "attributes" "translate" "keysyms" "manager" "image" "resource")) - - -;;; Franz - -;; -;; The following is a suggestion. If you comment out this form be -;; prepared for possible deadlock, since no interrupts will be recognized -;; while reading from the X socket if the scheduler is not running. -;; -#+excl -(setq compiler::generate-interrupt-checks-switch - (compile nil - '(lambda (safety size speed &optional debug) - (declare (ignore size debug)) - (or (< speed 3) (> safety 0))))) - - -;;; Allegro - -#+allegro -(excl:defsystem :clx - () - |package| - (|excldep| - :load-before-compile (|package|) - :recompile-on (|package|)) - (|depdefs| - :load-before-compile (|package| |excldep|) - :recompile-on (|excldep|)) - (|clx| - :load-before-compile (|package| |excldep| |depdefs|) - :recompile-on (|package| |excldep| |depdefs|)) - (|dependent| - :load-before-compile (|package| |excldep| |depdefs| |clx|) - :recompile-on (|clx|)) - (|exclcmac| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|) - :recompile-on (|dependent|)) - (|macros| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac|) - :recompile-on (|exclcmac|)) - (|bufmac| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros|) - :recompile-on (|macros|)) - (|buffer| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac|) - :recompile-on (|bufmac|)) - (|display| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer|) - :recompile-on (|buffer|)) - (|gcontext| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display|) - :recompile-on (|display|)) - (|input| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display|) - :recompile-on (|display|)) - (|requests| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display| - |input|) - :recompile-on (|display|)) - (|fonts| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display|) - :recompile-on (|display|)) - (|graphics| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display| - |fonts|) - :recompile-on (|fonts|)) - (|text| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display| - |gcontext| |fonts|) - :recompile-on (|gcontext| |fonts|) - :load-after (|translate|)) - ;; The above line gets around a compiler macro expansion bug. - - (|attributes| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display|) - :recompile-on (|display|)) - (|translate| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display| - |text|) - :recompile-on (|display|)) - (|keysyms| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display| - |translate|) - :recompile-on (|translate|)) - (|manager| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display|) - :recompile-on (|display|)) - (|image| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display|) - :recompile-on (|display|)) - - ;; Don't know if l-b-c list is correct. XX - (|resource| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display|) - :recompile-on (|display|)) - ) - -#+allegro -(excl:defsystem :clx-debug - (:default-pathname "debug/" - :needed-systems (:clx) - :load-before-compile (:clx)) - |describe| |keytrans| |trace| |util|) - - -;;;; Compile CLX - -;;; COMPILE-CLX compiles the lisp source files and loads the binaries. -;;; It goes to some trouble to let the source files be in one directory -;;; and the binary files in another. Thus the same set of sources can -;;; be used for different machines and/or lisp systems. It also allows -;;; you to supply explicit extensions, so source files do not have to -;;; be renamed to fit into the naming conventions of an implementation. - -;;; For example, -;;; (compile-clx "*.lisp" "machine/") -;;; compiles source files from the connected directory and puts them -;;; into the "machine" subdirectory. You can then load CLX out of the -;;; machine directory. - -;;; The code has no knowledge of the source file types (eg, ".l" or -;;; ".lisp") or of the binary file types (eg, ".b" or ".sbin"). Calling -;;; compile-file and load with a file type of NIL usually sorts things -;;; out correctly, but you may have to explicitly give the source and -;;; binary file types. - -;;; An attempt at compiling the C language sources is also made, -;;; but you may have to set different compiler switches -;;; should be. If it doesn't do the right thing, then do -;;; (compile-clx "" "" :compile-c NIL) -;;; to prevent the compilation. - -;;; compilation notes -;;; lucid2.0/hp9000s300 -;;; must uudecode the file make-sequence-patch.uu - -#+(or lucid kcl ibcl cmu) -(defun clx-foreign-files (binary-path) - - #+(and lucid (not lcl3.0) (or mc68000 mc68020)) - (load (merge-pathnames "make-sequence-patch" binary-path)) - - #+(and lucid apollo) - (lucid::load-foreign-file - (namestring (merge-pathnames "socket" binary-path)) - :preserve-pathname t) - - #+(and lucid (not apollo)) - (lucid::load-foreign-files - (list (namestring (merge-pathnames "socket.o" binary-path))) - '("-lc")) - - #+cmu - (declare (ignore binary-path)) - #+(or cmu sbcl) - (alien:def-alien-routine ("connect_to_server" xlib::connect-to-server) - c-call:int - (host c-call:c-string) - (port c-call:int)) - - #+(or kcl ibcl) - (progn - (let ((pathname (merge-pathnames "sockcl.o" binary-path)) - (options - (concatenate - 'string - (namestring (merge-pathnames "socket.o" binary-path)) - " -lc"))) - (format t "~&Faslinking ~A with ~A.~%" pathname options) - (si:faslink (namestring pathname) options) - (format t "~&Finished faslinking ~A.~%" pathname))) - ) - -#-(or lispm allegro Minima) -(defun compile-clx (&optional - (source-pathname-defaults "") - (binary-pathname-defaults "") - &key - (compile-c t)) - - ;; The pathname-defaults above might only be strings, so coerce them - ;; to pathnames. Build a default binary path with every component - ;; of the source except the file type. This should prevent - ;; (compile-clx "*.lisp") from destroying source files. - (let* ((source-path (pathname source-pathname-defaults)) - (path (make-pathname - :host (pathname-host source-path) - :device (pathname-device source-path) - :directory (pathname-directory source-path) - :name (pathname-name source-path) - :type nil - :version (pathname-version source-path))) - (binary-path (merge-pathnames binary-pathname-defaults - path)) - #+clx-ansi-common-lisp (*compile-verbose* t) - (*load-verbose* t)) - - ;; Make sure source-path and binary-path file types are distinct so - ;; we don't accidently overwrite the source files. NIL should be an - ;; ok type, but anything else spells trouble. - (if (and (equal (pathname-type source-path) - (pathname-type binary-path)) - (not (null (pathname-type binary-path)))) - (error "Source and binary pathname defaults have same type ~s ~s" - source-path binary-path)) - - (format t "~&;;; Default paths: ~s ~s~%" source-path binary-path) - - ;; In lucid make sure we're using the compiler in production mode. - #+lcl3.0 - (progn - (unless (member :pqc *features*) - (cerror - "Go ahead anyway." - "Lucid's production mode compiler must be loaded to compile CLX.")) - (proclaim '(optimize (speed 3) - (safety 1) - (space 0) - (compilation-speed 0)))) - - (labels ((compile-lisp (filename) - (let ((source (merge-pathnames filename source-path)) - (binary (merge-pathnames filename binary-path))) - ;; If the source and binary pathnames are the same, - ;; then don't supply an output file just to be sure - ;; compile-file defaults correctly. - #+(or kcl ibcl) (load source) - (if (equal source binary) - (compile-file source) - (compile-file source :output-file binary)) - binary)) - (compile-and-load (filename) - (load (compile-lisp filename))) - #+(or lucid kcl ibcl) - (compile-c (filename) - (let* ((c-filename (concatenate 'string filename ".c")) - (o-filename (concatenate 'string filename ".o")) - (src (merge-pathnames c-filename source-path)) - (obj (merge-pathnames o-filename binary-path)) - (args (list "-c" (namestring src) - "-o" (namestring obj) - #+mips "-G 0" - #+(or hp sysv) "-DSYSV" - #+(and mips (not dec)) "-I/usr/include/bsd" - #-(and mips (not dec)) "-DUNIXCONN" - #+(and lucid pa) "-DHPUX -DHPUX7.0" - ))) - (format t ";;; cc~{ ~A~}~%" args) - (unless - (zerop - #+lucid - (multiple-value-bind (iostream estream exitstatus pid) - ;; in 2.0, run-program is exported from system: - ;; in 3.0, run-program is exported from lcl: - ;; system inheirits lcl - (system::run-program "cc" :arguments args) - (declare (ignore iostream estream pid)) - exitstatus) - #+(or kcl ibcl) - (system (format nil "cc~{ ~A~}" args))) - (error "Compile of ~A failed." src))))) - - ;; Now compile and load all the files. - ;; Defer compiler warnings until everything's compiled, if possible. - (#+(or clx-ansi-common-lisp CMU) with-compilation-unit - #+lcl3.0 lucid::with-deferred-warnings - #-(or lcl3.0 clx-ansi-common-lisp CMU) progn - () - - (compile-and-load "package") - #+(or lucid kcl ibcl) (when compile-c (compile-c "socket")) - #+(or kcl ibcl) (compile-lisp "sockcl") - #+(or lucid kcl ibcl) (clx-foreign-files binary-path) - #+excl (compile-and-load "excldep") - (compile-and-load "depdefs") - (compile-and-load "clx") - (compile-and-load "dependent") - #+excl (compile-and-load "exclcmac") ; these are just macros - (compile-and-load "macros") ; these are just macros - (compile-and-load "bufmac") ; these are just macros - (compile-and-load "buffer") - (compile-and-load "display") - (compile-and-load "gcontext") - (compile-and-load "input") - (compile-and-load "requests") - (compile-and-load "fonts") - (compile-and-load "graphics") - (compile-and-load "text") - (compile-and-load "attributes") - (compile-and-load "translate") - (compile-and-load "keysyms") - (compile-and-load "manager") - (compile-and-load "image") - (compile-and-load "resource") - )))) - - -;;;; Load CLX - -;;; This procedure loads the binaries for CLX. All of the binaries -;;; should be in the same directory, so setting the default pathname -;;; should point load to the right place. - -;;; You should have a module definition somewhere so the require/provide -;;; mechanism can avoid reloading CLX. In an ideal world, somebody would -;;; just put -;;; (REQUIRE 'CLX) -;;; in their file (some implementations don't have a central registry for -;;; modules, so a pathname needs to be supplied). - -;;; The REQUIRE should find a file that does -;;; (IN-PACKAGE 'XLIB :USE '(LISP)) -;;; (PROVIDE 'CLX) -;;; (LOAD ) -;;; (LOAD-CLX ) - -#-(or lispm allegro Minima) -(defun load-clx (&optional (binary-pathname-defaults "") - &key (macrosp nil)) - - (let* ((source-path (pathname "")) - (path (make-pathname - :host (pathname-host source-path) - :device (pathname-device source-path) - :directory (pathname-directory source-path) - :name (pathname-name source-path) - :type nil - :version (pathname-version source-path))) - (binary-path (merge-pathnames binary-pathname-defaults - path)) - (*load-verbose* t)) - - (flet ((load-binary (filename) - (let ((binary (merge-pathnames filename binary-path))) - (load binary)))) - - (load-binary "package") - #+(or lucid kcl ibcl cmu) (clx-foreign-files binary-path) - #+excl (load-binary "excldep") - (load-binary "depdefs") - (load-binary "clx") - (load-binary "dependent") - (when macrosp - #+excl (load-binary "exclcmac") - (load-binary "macros") - (load-binary "bufmac")) - (load-binary "buffer") - (load-binary "display") - (load-binary "gcontext") - (load-binary "input") - (load-binary "requests") - (load-binary "fonts") - (load-binary "graphics") - (load-binary "text") - (load-binary "attributes") - (load-binary "translate") - (load-binary "keysyms") - (load-binary "manager") - (load-binary "image") - (load-binary "resource") - ))) - -;;; -;;; ECL likes to combine several files into a single dynamically loadable -;;; library. -;;; -#+ecl -(defconstant +clx-modules+ - '("package" "depdefs" "clx" "dependent" "macros" "bufmac" "buffer" - "display" "gcontext" "input" "requests" "fonts" "graphics" "text" - "attributes" "translate" "keysyms" "manager" "image" "resource")) - -#+(or) ;ecl -(flet ((compile-if-old (destdir sources &rest options) - (mapcar #'(lambda (source) - (let ((object (merge-pathnames destdir (compile-file-pathname source :type :object)))) - (unless (and (probe-file object) - (>= (file-write-date object) (file-write-date source))) - (apply #'compile-file source :output-file object options)) - object)) - sources))) - (let ((clx-objects (compile-if-old "./" +clx-modules+ :system-p t))) - (c::build-fasl "clx" :lisp-files clx-objects))) - -(mapcar #'load +clx-modules+) diff -Nru ecl-16.1.2/src/clx/demo/bezier.lisp ecl-16.1.3+ds/src/clx/demo/bezier.lisp --- ecl-16.1.2/src/clx/demo/bezier.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/demo/bezier.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,39 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- - -;;; CLX interface for Bezier Spline Extension. - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(export 'draw-curves) - -(define-extension "bezier") - -(defun draw-curves (drawable gcontext points) - ;; Draw Bezier splines on drawable using gcontext. - ;; Points are a list of (x0 y0 x1 y1 x2 y2 x3 y3) - (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence points)) - (let* ((display (drawable-display drawable)) - (opcode (extension-opcode display "bezier"))) - (with-buffer-request (display opcode :gc-force gcontext) - ((data card8) 1) ;; X_PolyBezier - The minor_opcode for PolyBezier - (drawable drawable) - (gcontext gcontext) - ((sequence :format int16) points)))) diff -Nru ecl-16.1.2/src/clx/demo/beziertest.lisp ecl-16.1.3+ds/src/clx/demo/beziertest.lisp --- ecl-16.1.2/src/clx/demo/beziertest.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/demo/beziertest.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,81 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- - -;;; CLX Bezier Spline Extension demo program - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(defun bezier-test (host &optional (pathname "/usr/X.V11R1/extensions/test/datafile")) - ;; Display the part picture in /extensions/test/datafile - (let* ((display (open-display host)) - (width 800) - (height 800) - (screen (display-default-screen display)) - (black (screen-black-pixel screen)) - (white (screen-white-pixel screen)) - (win (create-window - :parent (screen-root screen) - :background black - :border white - :border-width 1 - :colormap (screen-default-colormap screen) - :bit-gravity :center - :event-mask '(:exposure :key-press) - :x 20 :y 20 - :width width :height height)) - (gc (create-gcontext - :drawable win - :background black - :foreground white)) - (lines (make-array (* 500 4) :fill-pointer 0 :element-type 'card16)) - (curves (make-array (* 500 8) :fill-pointer 0 :element-type 'card16))) - ;; Read the data - (with-open-file (stream pathname) - (loop - (case (read-char stream nil :eof) - (#\l (dotimes (i 4) (vector-push-extend (read stream) lines))) - (#\b (dotimes (i 8) (vector-push-extend (read stream) curves))) - ((#\space #\newline #\tab)) - (otherwise (return))))) - ;; The data points were created to fit in a 2048x2048 square, - ;; this means scale_factor will always be small enough so that - ;; we don't need to worry about overflows. - (let ((factor (ash (min width height) 5))) - (dotimes (i (length lines)) - (setf (aref lines i) - (ash (* (aref lines i) factor) -16))) - (dotimes (i (length curves)) - (setf (aref curves i) - (ash (* (aref curves i) factor) -16)))) - - (map-window win) ; Map the window - ;; Handle events - (unwind-protect - (loop - (event-case (display :force-output-p t) - (exposure ;; Come here on exposure events - (window count) - (when (zerop count) ;; Ignore all but the last exposure event - (clear-area window) - (draw-segments win gc lines) - (draw-curves win gc curves) - (draw-glyphs win gc 10 10 "Press any key to exit") - ;; Returning non-nil causes event-case to exit - t)) - (key-press () (return-from bezier-test t)))) - (close-display display)))) diff -Nru ecl-16.1.2/src/clx/demo/clclock.lisp ecl-16.1.3+ds/src/clx/demo/clclock.lisp --- ecl-16.1.2/src/clx/demo/clclock.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/demo/clclock.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,78 +0,0 @@ -(defpackage "XCLCLOCK" - (:use "CL") - (:export "CLOCK")) - -(in-package "XCLCLOCK") - -(defvar *display* (xlib:open-default-display)) -(defvar *screen* (xlib:display-default-screen *display*)) -(defvar *colormap* (xlib:screen-default-colormap *screen*)) - -(defvar *font* (xlib:open-font *display* "fixed")) -(defvar *win*) - -(multiple-value-bind (width ascent) - (xlib:text-extents *font* "XVIIII XXXVIIII XXXVIIII") - (setq *win* - (xlib:create-window - :parent (xlib:screen-root *screen*) - :x 512 - :y 512 - :width (+ 20 width) - :height (+ 20 ascent) - :background (xlib:alloc-color *colormap* - (xlib:lookup-color *colormap* - "midnightblue"))))) - -(defvar *gcontext* (xlib:create-gcontext - :drawable *win* - :fill-style :solid - :background (xlib:screen-white-pixel *screen*) - :foreground (xlib:alloc-color *colormap* - (xlib:lookup-color - *colormap* - "yellow")) - :font *font*)) - -(defvar *background* (xlib:create-gcontext - :drawable *win* - :fill-style :solid - :background (xlib:screen-white-pixel *screen*) - :foreground (xlib:alloc-color *colormap* - (xlib:lookup-color *colormap* - "midnightblue")) - :font *font*)) -(defvar *palette* nil) -(defvar *black* (xlib:screen-black-pixel *screen*)) - -(defun romanize (arg) - (if (zerop arg) - "O" - (format nil "~@R" arg))) - -(defun clock-string () - (multiple-value-bind (s m h) (decode-universal-time (get-universal-time)) - (format nil "~a ~a ~a" (romanize h) (romanize m) (romanize s)))) - -(defun update-clockface () - (let ((string (clock-string))) - (let ((string-width (xlib:text-width *gcontext* string))) - (xlib:draw-rectangle *win* *background* - 0 0 - (xlib:drawable-width *win*) - (xlib:drawable-height *win*) - :fill-p) - (xlib:draw-glyphs *win* *gcontext* - (- (truncate - (- (xlib:drawable-width *win*) string-width) - 2) - 10) - (- (xlib:drawable-height *win*) 10) - string))) - (xlib:display-force-output *display*)) - -(defun clock () - (xlib:map-window *win*) - (loop - (update-clockface) - (sleep 1))) diff -Nru ecl-16.1.2/src/clx/demo/clipboard.lisp ecl-16.1.3+ds/src/clx/demo/clipboard.lisp --- ecl-16.1.2/src/clx/demo/clipboard.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/demo/clipboard.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,200 +0,0 @@ -;;; This is a pretty direct translation of the Xlib selection test -;;; program by Tor Andersson found at -;;; , with -;;; minor enhancements: -;;; -;;; * gdk requestors apparently unconditionally request UTF8_STRING -;;; selections without checking the TARGETS list of the selection -;;; owner -- and apparently even never request anything else. This -;;; seems to be in contradiction with the freedesktop.org draft -;;; specification at -;;; -;;; (linked from ), but this is -;;; the real world and we have to live in it. It would be nice if -;;; someone in the freedesktop community could resolve this. -;;; -;;; * the original C code, in the XSendEvent call, has an event mask -;;; of SelectionNotify. SelectionNotify is not an event mask at -;;; all, however: but the code works "by accident" because -;;; SelectionNotify happens to have value 31, which has enough bits -;;; flipped on that most clients select on at least one of those -;;; events. This bug is fixed below. -;;; -;;; * [ Update 2004-11-29, superseding to some extent the above ] in -;;; fact, these two things are related. ICCCM says that the event -;;; disclaiming the ability to send in a given format should be sent -;;; with an empty event mask ("2.2 Responsibilities of the Selection -;;; Owner"). -;;; -;;; * implemented the ICCCM-required TIMESTAMP and MULTIPLE targets -;;; -;;; As ever with these things, the divisions in intellectual property -;;; between the writer of the original C program, Tor Andersson -;;; (contactable at tor [dot] andersson [at] gmail [dot] com) and the -;;; translator (Christophe Rhodes, csr21 [at] cam [dot] ac [dot] uk) -;;; are murky, probably depend on jurisdiction, and in addition for -;;; such a small work are essentially trivial. To set peoples' minds -;;; at ease, Tor wishes this information to be disseminated as widely -;;; as possible. - -;;; Copyright (c) 2004, Christophe Rhodes -;;; -;;; 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 AUTHORS OR COPYRIGHT -;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, -;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER -;;; DEALINGS IN THE SOFTWARE. - -(defpackage "CLIPBOARD" - (:use "CL" "XLIB") - (:export "MAIN")) - -(in-package "CLIPBOARD") - -;;; This is "traditional" XLIB style; I don't really know if it's the -;;; best way -- in developing this program, style of XLIB programming -;;; was secondary to achieving First Paste. -(defvar *window*) -(defvar *time*) -(defvar *display*) - -(defun ownselect () - (format t "~&> set-selection-owner~%") (finish-output) - (set-selection-owner *display* :primary *window* *time*) - (unless (eq *window* (selection-owner *display* :primary)) - (write-string "failed to own primary"))) - -(defun deselect () - (format t "~&> unset-selection-owner~%") (finish-output) - (set-selection-owner *display* :primary nil *time*) - (unless (eq nil (selection-owner *display* :primary)) - (write-string "failed to disown primary"))) - -(defun ask-paste () - (format t "~&! deleting properties on window~%") (finish-output) - (delete-property *window* :aeclip-target) - (delete-property *window* :aeclip-string) - (delete-property *window* :aeclip-utf8_string) - (delete-property *window* :aeclip-text) - (format t "~&> convert-selection TARGETS~%") (finish-output) - (convert-selection :primary :targets *window* :aeclip-target) - (format t "~&> convert-selection STRING~%") (finish-output) - (convert-selection :primary :string *window* :aeclip-string) - (format t "~&> convert-selection UTF8_STRING~%") (finish-output) - (convert-selection :primary :utf8_string *window* :aeclip-utf8_string) - (format t "~&> convert-selection TEXT~%") (finish-output) - (convert-selection :primary :text *window* :aeclip-text) - nil) - -(defun recv-paste (property) - (multiple-value-bind (data name format) - (get-property *window* property) - (format t "~&< get-prop ~S " name) - (case format - (32 (format t "[~{~S~^,~}]" - (mapcar (lambda (x) (atom-name *display* x)) data))) - (8 (format t "~S" (map 'string 'code-char data))) - (t (format t "format=~S data=~S" format data))) - (format t "~%") (finish-output) - (delete-property *window* property))) - -(defun send-copy (selection target property requestor time) - (flet ((send (target property) - (case target - ((:string) - (format t "~&> sending text data~%") (finish-output) - (change-property requestor property - "Hello, World (from the CLX clipboard)!" - target 8 - :transform #'char-code) - property) - (:targets - (format t "~&> sending targets list~%") (finish-output) - ;; ARGH. Can't use :TRANSFORM as we scribble over CLX's buffer. - (let ((targets - (mapcar (lambda (x) (intern-atom *display* x)) - '(:targets :timestamp :multiple :string)))) - (change-property requestor property targets target 32)) - property) - (:timestamp - (format t "~&> sending timestamp~%") (finish-output) - (change-property requestor property (list *time*) target 32) - property) - (t - (format t "~&> sending none~%") (finish-output) - nil)))) - (case target - ;; WARNING: this is untested. I don't know of any clients which - ;; use the :MULTIPLE target. - (:multiple - (let* ((list (get-property requestor property)) - (plist (mapcar (lambda (x) (atom-name *display* x)) list))) - (loop for (ptarget pproperty) on plist by #'cddr - with all-succeeded = t - if (send ptarget pproperty) - collect ptarget into result - and collect pproperty into result - else - collect nil into result - and collect pproperty into result - and do (setf all-succeeded nil) - finally (unless all-succeeded - (let ((new-list - (mapcar (lambda (x) (intern-atom *display* x)) - result))) - (change-property requestor property new-list - target 32)))))) - (t (setf property (send target property)))) - (send-event requestor :selection-notify (make-event-mask) - :selection selection :target target - :property property :time time - :event-window requestor :window requestor))) - -(defun main () - (let* ((*display* (open-default-display)) - (screen (display-default-screen *display*)) - (*window* - (create-window - :parent (screen-root screen) - :x 10 :y 10 :width 200 :height 200 - :event-mask (make-event-mask :button-press :property-change)))) - (map-window *window*) - (display-finish-output *display*) - (event-case (*display*) - (:button-press (code time) - (format t "~&ButtonPress~%") (finish-output) - (case code - (1 (setf *time* time) (ownselect)) - (2 (ask-paste)) - (3 (deselect)))) - (:client-message () - (format t "~&ClientMessage~%") (finish-output)) - (:selection-clear (selection) - (format t "~&SelectionClear ~S~%" selection) (finish-output)) - (:selection-notify (selection target property) - (format t "~&SelectionNotify ~S ~S ~S~%" selection target property) - (finish-output) - (unless (eq property nil) - (recv-paste property)) - (display-finish-output *display*)) - (:selection-request (selection target property requestor time) - (format t "~&SelectionRequest ~S ~S ~S~%" selection target property) - (finish-output) - (send-copy selection target property requestor time) - (display-finish-output *display*)) - (:property-notify (atom state) - (format t "~&PropertyNotify ~S ~S~%" atom state) (finish-output))))) diff -Nru ecl-16.1.2/src/clx/demo/clx-demos.lisp ecl-16.1.3+ds/src/clx/demo/clx-demos.lisp --- ecl-16.1.2/src/clx/demo/clx-demos.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/demo/clx-demos.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,1051 +0,0 @@ -;;; -*- Mode: Lisp; Package: Demos -*- -;;; -;;; This file contains various graphics hacks written and ported over the -;;; years by various and numerous persons. -;;; -;;; This file should be portable to any valid Common Lisp with CLX -- DEC 88. -;;; - -(defpackage :demos (:use :common-lisp) - (:export do-all-demos demo)) - -(in-package :demos) - - -;;;; Graphic demos wrapper macro. - -;;; This wrapper macro should be reconsidered with respect to its property -;;; list usage. Possibly a demo structure should be used with *demos* -;;; pointing to these instead of function names. Also, something should -;;; be done about a title window that displays the name of the demo while -;;; it is running. - -(defparameter *demos* nil) - -(defvar *display* nil) -(defvar *screen* nil) -(defvar *root* nil) -(defvar *black-pixel* nil) -(defvar *white-pixel* nil) -(defvar *window* nil) - -(defmacro defdemo (fun-name demo-name args x y width height doc &rest forms) - `(progn - (defun ,fun-name ,args - ,doc - (unless *display* - #+:cmu - (multiple-value-setq (*display* *screen*) (ext:open-clx-display)) - #+(or sbcl allegro clisp) - (progn - (setf *display* (xlib::open-default-display)) - (setf *screen* (xlib:display-default-screen *display*))) - #-(or cmu sbcl allegro clisp) - (progn - ;; Portable method - (setf *display* (xlib:open-display (machine-instance))) - (setf *screen* (xlib:display-default-screen *display*))) - (setf *root* (xlib:screen-root *screen*)) - (setf *black-pixel* (xlib:screen-black-pixel *screen*)) - (setf *white-pixel* (xlib:screen-white-pixel *screen*))) - (let ((*window* (xlib:create-window :parent *root* - :x ,x :y ,y - :event-mask nil - :width ,width :height ,height - :background *white-pixel* - :border *black-pixel* - :border-width 2 - :override-redirect :on))) - (xlib:map-window *window*) - ;; - ;; I hate to do this since this is not something any normal - ;; program should do ... - (setf (xlib:window-priority *window*) :above) - (xlib:display-finish-output *display*) - (unwind-protect - (progn ,@forms) - (xlib:unmap-window *window*) - (xlib:display-finish-output *display*)))) - (setf (get ',fun-name 'demo-name) ',demo-name) - (setf (get ',fun-name 'demo-doc) ',doc) - (export ',fun-name) - (pushnew ',fun-name *demos*) - ',fun-name)) - - -;;;; Main entry points. - -(defun do-all-demos () - (loop - (dolist (demo *demos*) - (funcall demo) - (sleep 3)))) - -;;; DEMO is a hack to get by. It should be based on creating a menu. At -;;; that time, *name-to-function* should be deleted, since this mapping will -;;; be manifested in the menu slot name cross its action. Also the -;;; "Shove-bounce" demo should be renamed to "Shove bounce"; likewise for -;;; "Fast-towers-of-Hanoi" and "Slow-towers-of-hanoi". -;;; - -(defvar *name-to-function* (make-hash-table :test #'eq)) -(defvar *keyword-package* (find-package "KEYWORD")) - -(defun demo () - (macrolet ((read-demo () - `(let ((*package* *keyword-package*)) - (read)))) - (dolist (d *demos*) - (setf (gethash (intern (string-upcase (get d 'demo-name)) - *keyword-package*) - *name-to-function*) - d)) - (loop - (fresh-line) - (dolist (d *demos*) - (write-string " ") - (write-line (get d 'demo-name))) - (write-string " ") - (write-line "Help ") - (write-string " ") - (write-line "Quit") - (write-string "Enter demo name: ") - (let ((demo (read-demo))) - (case demo - (:help - (let* ((demo (read-demo)) - (fun (gethash demo *name-to-function*))) - (fresh-line) - (if fun - (format t "~&~%~A~&~%" (get fun 'demo-doc)) - (format t "Unknown demo name -- ~A." demo)))) - (:quit (return t)) - (t - (let ((fun (gethash demo *name-to-function*))) - (if fun - #+mp - (mp:make-process #'(lambda () - (loop - (funcall fun) - (sleep 2))) - :name (format nil "~S" demo)) - #-mp - (funcall fun) - (format t "~&~%Unknown demo name -- ~A.~&~%" demo))))))))) - - -;;;; Shared demo utilities. - -(defun full-window-state (w) - (xlib:with-state (w) - (values (xlib:drawable-width w) (xlib:drawable-height w) - (xlib:drawable-x w) (xlib:drawable-y w) - (xlib:window-map-state w)))) - - -;;;; Greynetic. - -;;; GREYNETIC displays random sized and shaded boxes in a window. This is -;;; real slow. It needs work. -;;; -(defun greynetic (window duration) - (let* ((pixmap (xlib:create-pixmap :width 32 :height 32 :depth 1 - :drawable window)) - (gcontext (xlib:create-gcontext :drawable window - :background *white-pixel* - :foreground *black-pixel* - :tile pixmap - :fill-style :tiled))) - (multiple-value-bind (width height) (full-window-state window) - (dotimes (i duration) - (let* ((pixmap-data (greynetic-pixmapper)) - (image (xlib:create-image :width 32 :height 32 - :depth 1 :data pixmap-data))) - (xlib:put-image pixmap gcontext image :x 0 :y 0 :width 32 :height 32) - (xlib:draw-rectangle window gcontext - (- (random width) 5) - (- (random height) 5) - (+ 4 (random (truncate width 3))) - (+ 4 (random (truncate height 3))) - t)) - (xlib:display-force-output *display*))) - (xlib:free-gcontext gcontext) - (xlib:free-pixmap pixmap))) - -(defvar *greynetic-pixmap-array* - (make-array '(32 32) :initial-element 0 :element-type 'xlib:pixel)) - -(defun greynetic-pixmapper () - (let ((pixmap-data *greynetic-pixmap-array*)) - (dotimes (i 4) - (declare (fixnum i)) - (let ((nibble (random 16))) - (setf nibble (logior nibble (ash nibble 4)) - nibble (logior nibble (ash nibble 8)) - nibble (logior nibble (ash nibble 12)) - nibble (logior nibble (ash nibble 16))) - (dotimes (j 32) - (let ((bit (if (logbitp j nibble) 1 0))) - (setf (aref pixmap-data i j) bit - (aref pixmap-data (+ 4 i) j) bit - (aref pixmap-data (+ 8 i) j) bit - (aref pixmap-data (+ 12 i) j) bit - (aref pixmap-data (+ 16 i) j) bit - (aref pixmap-data (+ 20 i) j) bit - (aref pixmap-data (+ 24 i) j) bit - (aref pixmap-data (+ 28 i) j) bit))))) - pixmap-data)) - -#+nil -(defdemo greynetic-demo "Greynetic" (&optional (duration 300)) - 100 100 600 600 - "Displays random grey rectangles." - (greynetic *window* duration)) - - -;;;; Qix. - -(defstruct qix - buffer - (dx1 5) - (dy1 10) - (dx2 10) - (dy2 5)) - -(defun construct-qix (length) - (let ((qix (make-qix))) - (setf (qix-buffer qix) (make-circular-list length)) - qix)) - -(defun make-circular-list (length) - (let ((l (make-list length))) - (rplacd (last l) l))) - - -(defun qix (window lengths duration) - "Each length is the number of lines to put in a qix, and that many qix - (of the correct size) are put up on the screen. Lets the qix wander around - the screen for Duration steps." - (let ((histories (mapcar #'construct-qix lengths))) - (multiple-value-bind (width height) (full-window-state window) - (declare (fixnum width height)) - (xlib:clear-area window) - (xlib:display-force-output *display*) - (do ((h histories (cdr h)) - (l lengths (cdr l))) - ((null h)) - (do ((x (qix-buffer (car h)) (cdr x)) - (i 0 (1+ i))) - ((= i (car l))) - (rplaca x (make-array 4)))) - ;; Start each qix at a random spot on the screen. - (dolist (h histories) - (let ((x (random width)) - (y (random height))) - (rplaca (qix-buffer h) - (make-array 4 :initial-contents (list x y x y))))) - (rplacd (last histories) histories) - (let ((x1 0) (y1 0) (x2 0) (y2 0) - (dx1 0) (dy1 0) (dx2 0) (dy2 0) - tem line next-line qix - (gc (xlib:create-gcontext :drawable window - :foreground *white-pixel* - :background *black-pixel* - :line-width 0 :line-style :solid - :function boole-c2))) - (declare (fixnum x1 y1 x2 y2 dx1 dy1 dx2 dy2)) - (dotimes (i duration) - ;; Line is the next line in the next qix. Rotate this qix and - ;; the qix ring. - (setq qix (car histories)) - (setq line (car (qix-buffer qix))) - (setq next-line (cadr (qix-buffer qix))) - (setf (qix-buffer qix) (cdr (qix-buffer qix))) - (setq histories (cdr histories)) - (setf x1 (svref line 0)) - (setf y1 (svref line 1)) - (setf x2 (svref line 2)) - (setf y2 (svref line 3)) - (xlib:draw-line window gc x1 y1 x2 y2) - (setq dx1 (- (+ (qix-dx1 qix) (random 3)) 1)) - (setq dy1 (- (+ (qix-dy1 qix) (random 3)) 1)) - (setq dx2 (- (+ (qix-dx2 qix) (random 3)) 1)) - (setq dy2 (- (+ (qix-dy2 qix) (random 3)) 1)) - (cond ((> dx1 10) (setq dx1 10)) - ((< dx1 -10) (setq dx1 -10))) - (cond ((> dy1 10) (setq dy1 10)) - ((< dy1 -10) (setq dy1 -10))) - (cond ((> dx2 10) (setq dx2 10)) - ((< dx2 -10) (setq dx2 -10))) - (cond ((> dy2 10) (setq dy2 10)) - ((< dy2 -10) (setq dy2 -10))) - (cond ((or (>= (setq tem (+ x1 dx1)) width) (minusp tem)) - (setq dx1 (- dx1)))) - (cond ((or (>= (setq tem (+ x2 dx2)) width) (minusp tem)) - (setq dx2 (- dx2)))) - (cond ((or (>= (setq tem (+ y1 dy1)) height) (minusp tem)) - (setq dy1 (- dy1)))) - (cond ((or (>= (setq tem (+ y2 dy2)) height) (minusp tem)) - (setq dy2 (- dy2)))) - (setf (qix-dy2 qix) dy2) - (setf (qix-dx2 qix) dx2) - (setf (qix-dy1 qix) dy1) - (setf (qix-dx1 qix) dx1) -` (when (svref next-line 0) - (xlib:draw-line window gc - (svref next-line 0) (svref next-line 1) - (svref next-line 2) (svref next-line 3))) - (setf (svref next-line 0) (+ x1 dx1)) - (setf (svref next-line 1) (+ y1 dy1)) - (setf (svref next-line 2) (+ x2 dx2)) - (setf (svref next-line 3) (+ y2 dy2)) - (xlib:display-force-output *display*)))))) - - -(defdemo qix-demo "Qix" (&optional (lengths '(30 30)) (duration 2000)) - 0 0 700 700 - "Hypnotic wandering lines." - (qix *window* lengths duration)) - - - -;;;; Petal. - -;;; Fast sine constants: - -(defconstant d360 #o5500) -(defconstant d270 #o4160) -(defconstant d180 #o2640) -(defconstant d90 #o1320) -(defconstant vecmax 2880) - -(defparameter sin-array - '#(#o0 #o435 #o1073 #o1531 #o2166 #o2623 #o3260 - #o3714 #o4350 #o5003 #o5435 #o6066 #o6516 #o7145 - #o7573 #o10220 #o10644 #o11266 #o11706 #o12326 - #o12743 #o13357 #o13771 #o14401 #o15007 #o15414 - #o16016 #o16416 #o17013 #o17407 #o20000 #o20366 - #o20752 #o21333 #o21711 #o22265 #o22636 #o23204 - #o23546 #o24106 #o24443 #o24774 #o25323 #o25645 - #o26165 #o26501 #o27011 #o27316 #o27617 #o30115 - #o30406 #o30674 #o31156 #o31434 #o31706 #o32154 - #o32416 #o32654 #o33106 #o33333 #o33554 #o33771 - #o34202 #o34406 #o34605 #o35000 #o35167 #o35351 - #o35526 #o35677 #o36043 #o36203 #o36336 #o36464 - #o36605 #o36721 #o37031 #o37134 #o37231 #o37322 - #o37407 #o37466 #o37540 #o37605 #o37646 #o37701 - #o37730 #o37751 #o37766 #o37775 #o40000)) - -(defmacro psin (val) - `(let* ((val ,val) - neg - frac - sinlo) - (if (>= val d180) - (setq neg t - val (- val d180))) - (if (>= val d90) - (setq val (- d180 val))) - (setq frac (logand val 7)) - (setq val (ash val -3)) - ;; - (setq sinlo (if (>= val 90) - (svref sin-array 90) - (svref sin-array val))) - ;; - (if (< val 90) - (setq sinlo - (+ sinlo (ash (* frac (- (svref sin-array (1+ val)) sinlo)) - -3)))) - ;; - (if neg - (- sinlo) - sinlo))) - -(defmacro pcos (x) - `(let ((tmp (- ,x d270))) - (psin (if (minusp tmp) (+ tmp d360) tmp)))) - - -;;;; Miscellaneous petal hackery. - -(defmacro high-16bits-* (a b) - `(let ((a-h (ash ,a -8)) - (b-h (ash ,b -8))) - (+ (* a-h b-h) - (ash (* a-h (logand ,b 255)) -8) - (ash (* b-h (logand ,a 255)) -8)))) - -(defun complete (style petal) - (let ((repnum 1) - factor cntval needed) - (dotimes (i 3) - (case i - (0 (setq factor 2 cntval 6)) - (1 (setq factor 3 cntval 2)) - (2 (setq factor 5 cntval 1))) - (do () - ((or (minusp cntval) (not (zerop (rem style factor))))) - (setq repnum (* repnum factor)) - (setq cntval (1- cntval)) - (setq style (floor style factor)))) - (setq needed (floor vecmax repnum)) - (if (and (not (oddp needed)) (oddp petal)) (floor needed 2) needed))) - - -;;;; Petal Parameters and Petal itself - -(defparameter continuous t) -(defparameter styinc 2) -(defparameter petinc 1) -(defparameter scalfac-fac 8192) - -(defun petal (petal-window &optional (how-many 10) (style 0) (petal 0)) - (let ((width 512) - (height 512)) - (xlib:clear-area petal-window) - (xlib:display-force-output *display*) - (let ((veccnt 0) - (nustyle 722) - (nupetal 3) - (scalfac (1+ (floor scalfac-fac (min width height)))) - (ctrx (floor width 2)) - (ctry (floor height 2)) - (tt 0) - (s 0) - (lststyle 0) - (lstpetal 0) - (petstyle 0) - (vectors 0) - (r 0) - (x1 0) - (y1 0) - (x2 0) - (y2 0) - (i 0) - (gc (xlib:create-gcontext :drawable petal-window - :foreground *black-pixel* - :background *white-pixel* - :line-width 0 :line-style :solid))) - (loop - (when (zerop veccnt) - (setq tt 0 s 0 lststyle style lstpetal petal petal nupetal - style nustyle petstyle (rem (* petal style) d360) - vectors (complete style petal)) - (when continuous - (setq nupetal (+ nupetal petinc) - nustyle (+ nustyle styinc))) - (when (or (/= lststyle style) (/= lstpetal petal)) - (xlib:clear-area petal-window) - (xlib:display-force-output *display*))) - (when (or (/= lststyle style) (/= lstpetal petal)) - (setq veccnt (1+ veccnt) i veccnt x1 x2 y1 y2 - tt (rem (+ tt style) d360) - s (rem (+ s petstyle) d360) - r (pcos s)) - (setq x2 (+ ctrx (floor (high-16bits-* (pcos tt) r) scalfac)) - y2 (+ ctry (floor (high-16bits-* (psin tt) r) scalfac))) - (when (/= i 1) - (xlib:draw-line petal-window gc x1 y1 x2 y2) - (xlib:display-force-output *display*))) - (when (> veccnt vectors) - (setq veccnt 0) - (setq how-many (1- how-many)) - (sleep 2) - (when (zerop how-many) (return))))))) - -(defdemo petal-demo "Petal" (&optional (how-many 10) (style 0) (petal 0)) - 100 100 512 512 - "Flower-like display." - (petal *window* how-many style petal)) - - -;;;; Hanoi. - -;;; Random parameters: - -(defparameter disk-thickness 15 "The thickness of a disk in pixels.") -(defparameter disk-spacing (+ disk-thickness 3) - "The amount of vertical space used by a disk on a needle.") -(defvar *horizontal-velocity* 20 "The speed at which disks slide sideways.") -(defvar *vertical-velocity* 12 "The speed at which disks move up and down.") - -;;; These variables are bound by the main function. - -(defvar *hanoi-window* () "The window that Hanoi is happening on.") -(defvar *hanoi-window-height* () "The height of the viewport Hanoi is happening on.") -(defvar *transfer-height* () "The height at which disks are transferred.") -(defvar *hanoi-gcontext* () "The graphics context for Hanoi under X11.") - -;;; Needle Functions - -(defstruct disk - size) - -(defstruct needle - position - disk-stack) - -;;; Needle-Top-Height returns the height of the top disk on NEEDLE. - -(defun needle-top-height (needle) - (- *hanoi-window-height* - (* disk-spacing (length (the list (needle-disk-stack needle)))))) - -(defvar available-disks - (do ((i 10 (+ i 10)) - (dlist () (cons (make-disk :size i) dlist))) - ((> i 80) dlist))) - -(defvar needle-1 (make-needle :position 184)) -(defvar needle-2 (make-needle :position 382)) -(defvar needle-3 (make-needle :position 584)) - -;;; Graphic interface abstraction: - -;;; Invert-Rectangle calls the CLX function draw-rectangle with "fill-p" -;;; set to T. Update-Screen forces the display output. -;;; -(defmacro invert-rectangle (x y height width) - `(xlib:draw-rectangle *hanoi-window* *hanoi-gcontext* - ,x ,y ,width ,height t)) - -(defmacro update-screen () - `(xlib:display-force-output *display*)) - - -;;;; Moving disks up and down - -;;; Slide-Up slides the image of a disk up from the coordinates X, -;;; START-Y to the point X, END-Y. DISK-SIZE is the size of the disk to -;;; move. START-Y must be greater than END-Y - -(defun slide-up (start-y end-y x disk-size) - (multiple-value-bind (number-moves pixels-left) - (truncate (- start-y end-y) *vertical-velocity*) - (do ((x (- x disk-size)) - (width (* disk-size 2)) - (old-y start-y (- old-y *vertical-velocity*)) - (new-y (- start-y *vertical-velocity*) (- new-y *vertical-velocity*)) - (number-moves number-moves (1- number-moves))) - ((zerop number-moves) - (when (plusp pixels-left) - (invert-rectangle x (- old-y pixels-left) disk-thickness width) - (invert-rectangle x old-y disk-thickness width) - (update-screen))) - ;; Loop body writes disk at new height & erases at old height. - (invert-rectangle x old-y disk-thickness width) - (invert-rectangle x new-y disk-thickness width) - (update-screen)))) - -;;; Slide-Down slides the image of a disk down from the coordinates X, -;;; START-Y to the point X, END-Y. DISK-SIZE is the size of the disk to -;;; move. START-Y must be less than END-Y. - -(defun slide-down (start-y end-y x disk-size) - (multiple-value-bind (number-moves pixels-left) - (truncate (- end-y start-y) *vertical-velocity*) - (do ((x (- x disk-size)) - (width (* disk-size 2)) - (old-y start-y (+ old-y *vertical-velocity*)) - (new-y (+ start-y *vertical-velocity*) (+ new-y *vertical-velocity*)) - (number-moves number-moves (1- number-moves))) - ((zerop number-moves) - (when (plusp pixels-left) - (invert-rectangle x (+ old-y pixels-left) disk-thickness width) - (invert-rectangle x old-y disk-thickness width) - (update-screen))) - ;; Loop body writes disk at new height & erases at old height. - (invert-rectangle X old-y disk-thickness width) - (invert-rectangle X new-y disk-thickness width) - (update-screen)))) - - -;;;; Lifting and Droping Disks - -;;; Lift-disk pops the top disk off of needle and raises it up to the -;;; transfer height. The disk is returned. - -(defun lift-disk (needle) - "Pops the top disk off of NEEDLE, Lifts it above the needle, & returns it." - (let* ((height (needle-top-height needle)) - (disk (pop (needle-disk-stack needle)))) - (slide-up height - *transfer-height* - (needle-position needle) - (disk-size disk)) - disk)) - -;;; Drop-disk drops a disk positioned over needle at the transfer height -;;; onto needle. The disk is pushed onto needle. - -(defun drop-disk (disk needle) - "DISK must be positioned above NEEDLE. It is dropped onto NEEDLE." - (push disk (needle-disk-stack needle)) - (slide-down *transfer-height* - (needle-top-height needle) - (needle-position needle) - (disk-size disk)) - t) - - -;;; Drop-initial-disk is the same as drop-disk except that the disk is -;;; drawn once before dropping. - -(defun drop-initial-disk (disk needle) - "DISK must be positioned above NEEDLE. It is dropped onto NEEDLE." - (let* ((size (disk-size disk)) - (lx (- (needle-position needle) size))) - (invert-rectangle lx *transfer-height* disk-thickness (* size 2)) - (push disk (needle-disk-stack needle)) - (slide-down *transfer-height* - (needle-top-height needle) - (needle-position needle) - (disk-size disk)) - t)) - - -;;;; Sliding Disks Right and Left - -;;; Slide-Right slides the image of a disk located at START-X, Y to the -;;; position END-X, Y. DISK-SIZE is the size of the disk. START-X is -;;; less than END-X. - -(defun slide-right (start-x end-x Y disk-size) - (multiple-value-bind (number-moves pixels-left) - (truncate (- end-x start-x) *horizontal-velocity*) - (do ((right-x (+ start-x disk-size) (+ right-x *horizontal-velocity*)) - (left-x (- start-x disk-size) (+ left-x *horizontal-velocity*)) - (number-moves number-moves (1- number-moves))) - ((zerop number-moves) - (when (plusp pixels-left) - (invert-rectangle right-x Y disk-thickness pixels-left) - (invert-rectangle left-x Y disk-thickness pixels-left) - (update-screen))) - ;; Loop body adds chunk *horizontal-velocity* pixels wide to right - ;; side of disk, then chops off left side. - (invert-rectangle right-x Y disk-thickness *horizontal-velocity*) - (invert-rectangle left-x Y disk-thickness *horizontal-velocity*) - (update-screen)))) - -;;; Slide-Left is the same as Slide-Right except that START-X is greater -;;; than END-X. - -(defun slide-left (start-x end-x Y disk-size) - (multiple-value-bind (number-moves pixels-left) - (truncate (- start-x end-x) *horizontal-velocity*) - (do ((right-x (- (+ start-x disk-size) *horizontal-velocity*) - (- right-x *horizontal-velocity*)) - (left-x (- (- start-x disk-size) *horizontal-velocity*) - (- left-x *horizontal-velocity*)) - (number-moves number-moves (1- number-moves))) - ((zerop number-moves) - (when (plusp pixels-left) - (setq left-x (- (+ left-x *horizontal-velocity*) pixels-left)) - (setq right-x (- (+ right-x *horizontal-velocity*) pixels-left)) - (invert-rectangle left-x Y disk-thickness pixels-left) - (invert-rectangle right-x Y disk-thickness pixels-left) - (update-screen))) - ;; Loop body adds chunk *horizontal-velocity* pixels wide to left - ;; side of disk, then chops off right side. - (invert-rectangle left-x Y disk-thickness *horizontal-velocity*) - (invert-rectangle right-x Y disk-thickness *horizontal-velocity*) - (update-screen)))) - - -;;;; Transferring Disks - -;;; Transfer disk slides a disk at the transfer height from a position -;;; over START-NEEDLE to a position over END-NEEDLE. Modified disk is -;;; returned. - -(defun transfer-disk (disk start-needle end-needle) - "Moves DISK from a position over START-NEEDLE to a position over END-NEEDLE." - (let ((start (needle-position start-needle)) - (end (needle-position end-needle))) - (if (< start end) - (slide-right start end *transfer-height* (disk-size disk)) - (slide-left start end *transfer-height* (disk-size disk))) - disk)) - - -;;; Move-One-Disk moves the top disk from START-NEEDLE to END-NEEDLE. - -(defun move-one-disk (start-needle end-needle) - "Moves the disk on top of START-NEEDLE to the top of END-NEEDLE." - (drop-disk (transfer-disk (lift-disk start-needle) - start-needle - end-needle) - end-needle) - t) - -;;; Move-N-Disks moves the top N disks from START-NEEDLE to END-NEEDLE -;;; obeying the rules of the towers of hannoi problem. To move the -;;; disks, a third needle, TEMP-NEEDLE, is needed for temporary storage. - -(defun move-n-disks (n start-needle end-needle temp-needle) - "Moves the top N disks from START-NEEDLE to END-NEEDLE. - Uses TEMP-NEEDLE for temporary storage." - (cond ((= n 1) - (move-one-disk start-needle end-needle)) - (t - (move-n-disks (1- n) start-needle temp-needle end-needle) - (move-one-disk start-needle end-needle) - (move-n-disks (1- n) temp-needle end-needle start-needle))) - t) - - -;;;; Hanoi itself. - -(defun hanoi (window n) - (multiple-value-bind (width height) (full-window-state window) - (declare (ignore width)) - (let* ((*hanoi-window* window) - (*hanoi-window-height* height) - (*transfer-height* (- height (* disk-spacing n))) - (*hanoi-gcontext* (xlib:create-gcontext :drawable *hanoi-window* - :foreground *white-pixel* - :background *black-pixel* - :fill-style :solid - :function boole-c2))) - (xlib:clear-area *hanoi-window*) - (xlib:display-force-output *display*) - (let ((needle-1 (make-needle :position 184)) - (needle-2 (make-needle :position 382)) - (needle-3 (make-needle :position 584))) - (setf (needle-disk-stack needle-1) ()) - (setf (needle-disk-stack needle-2) ()) - (setf (needle-disk-stack needle-3) ()) - (do ((n n (1- n)) - (available-disks available-disks (cdr available-disks))) - ((zerop n)) - (drop-initial-disk (car available-disks) needle-1)) - (move-n-disks n needle-1 needle-3 needle-2) - t)))) - -;;; Change the names of these when the DEMO loop isn't so stupid. -;;; -(defdemo slow-hanoi-demo "Slow-towers-of-Hanoi" (&optional (how-many 4)) - 0 100 768 300 - "Solves the Towers of Hanoi problem before your very eyes." - (let ((*horizontal-velocity* 3) - (*vertical-velocity* 1)) - (hanoi *window* how-many))) -;;; -(defdemo fast-hanoi-demo "Fast-towers-of-Hanoi" (&optional (how-many 7)) - 0 100 768 300 - "Solves the Towers of Hanoi problem before your very eyes." - (hanoi *window* how-many)) - - - -;;;; Bounce window. - -;;; BOUNCE-WINDOW takes a window and seemingly drops it to the bottom of -;;; the screen. Optionally, the window can have an initial x velocity, -;;; screen border elasticity, and gravity value. The outer loop is -;;; entered the first time with the window at its initial height, but -;;; each iteration after this, the loop starts with the window at the -;;; bottom of the screen heading upward. The inner loop, except for the -;;; first execution, carries the window up until the negative velocity -;;; becomes positive, carrying the window down to bottom when the -;;; velocity is positive. Due to number lossage, ROUND'ing and -;;; TRUNC'ing when the velocity gets so small will cause the window to -;;; head upward with the same velocity over two iterations which will -;;; cause the window to bounce forever, so we have prev-neg-velocity and -;;; number-problems to check for this. This is not crucial with the x -;;; velocity since the loop terminates as a function of the y velocity. -;;; -(defun bounce-window (window &optional - (x-velocity 0) (elasticity 0.85) (gravity 2)) - (unless (< 0 elasticity 1) - (error "Elasticity must be between 0 and 1.")) - (unless (plusp gravity) - (error "Gravity must be positive.")) - (multiple-value-bind (width height x y mapped) (full-window-state window) - (when (eq mapped :viewable) - (let ((top-of-window-at-bottom (- (xlib:drawable-height *root*) height)) - (left-of-window-at-right (- (xlib:drawable-width *root*) width)) - (y-velocity 0) - (prev-neg-velocity most-negative-fixnum) - (number-problems nil)) - (declare (fixnum top-of-window-at-bottom left-of-window-at-right - y-velocity)) - (loop - (when (= prev-neg-velocity 0) (return t)) - (let ((negative-velocity (minusp y-velocity))) - (loop - (let ((next-y (+ y y-velocity)) - (next-y-velocity (+ y-velocity gravity))) - (declare (fixnum next-y next-y-velocity)) - (when (> next-y top-of-window-at-bottom) - (cond - (number-problems - (setf y-velocity (incf prev-neg-velocity))) - (t - (setq y-velocity - (- (truncate (* elasticity y-velocity)))) - (when (= y-velocity prev-neg-velocity) - (incf y-velocity) - (setf number-problems t)) - (setf prev-neg-velocity y-velocity))) - (setf y top-of-window-at-bottom) - (setf (xlib:drawable-x window) x - (xlib:drawable-y window) y) - (xlib:display-force-output *display*) - (return)) - (setq y-velocity next-y-velocity) - (setq y next-y)) - (when (and negative-velocity (>= y-velocity 0)) - (setf negative-velocity nil)) - (let ((next-x (+ x x-velocity))) - (declare (fixnum next-x)) - (when (or (> next-x left-of-window-at-right) - (< next-x 0)) - (setq x-velocity (- (truncate (* elasticity x-velocity))))) - (setq x next-x)) - (setf (xlib:drawable-x window) x - (xlib:drawable-y window) y) - (xlib:display-force-output *display*)))))))) - -;;; Change the name of this when DEMO is not so stupid. -;;; -(defdemo shove-bounce-demo "Shove-bounce" () - 100 100 300 300 - "Drops the demo window with an inital X velocity which bounces off - screen borders." - (bounce-window *window* 30)) - -(defdemo bounce-demo "Bounce" () - 100 100 300 300 - "Drops the demo window which bounces off screen borders." - (bounce-window *window*)) - - -;;;; Recurrence Demo - -;;; Copyright (C) 1988 Michael O. Newton (newton@csvax.caltech.edu) - -;;; Permission is granted to any individual or institution to use, copy, -;;; modify, and distribute this software, provided that this complete -;;; copyright and permission notice is maintained, intact, in all copies and -;;; supporting documentation. - -;;; The author provides this software "as is" without express or -;;; implied warranty. - -;;; This routine plots the recurrence -;;; x <- y(1+sin(0.7x)) - 1.2(|x|)^.5 -;;; y <- .21 - x -;;; As described in a ?? 1983 issue of the Mathematical Intelligencer - -(defun recurrence (display window &optional (point-count 10000)) - (let ((gc (xlib:create-gcontext :drawable window - :background *white-pixel* - :foreground *black-pixel*))) - (multiple-value-bind (width height) (full-window-state window) - (xlib:clear-area window) - (draw-ppict window gc point-count 0.0 0.0 (* width 0.5) (* height 0.5)) - (xlib:display-force-output display) - (sleep 4)) - (xlib:free-gcontext gc))) - -;;; Draw points. X assumes points are in the range of width x height, -;;; with 0,0 being upper left and 0,H being lower left. -;;; hw and hh are half-width and half-height of screen - -(defun draw-ppict (win gc count x y hw hh) - "Recursively draw pretty picture" - (unless (zerop count) - (let ((xf (floor (* (+ 1.0 x) hw ))) ;These lines center the picture - (yf (floor (* (+ 0.7 y) hh )))) - (xlib:draw-point win gc xf yf) - (draw-ppict win gc (1- count) - (- (* y (1+ (sin (* 0.7 x)))) (* 1.2 (sqrt (abs x)))) - (- 0.21 x) - hw - hh)))) - -(defdemo recurrence-demo "Recurrence" () - 10 10 700 700 - "Plots a cool recurrence relation." - (recurrence *display* *window*)) - - -;;;; Plaid - -;;; -;;; Translated from the X11 Plaid Demo written in C by Christopher Hoover. -;;; - -(defmacro rect-x (rects n) - `(svref ,rects (ash ,n 2))) -(defmacro rect-y (rects n) - `(svref ,rects (+ (ash ,n 2) 1))) -(defmacro rect-width (rects n) - `(svref ,rects (+ (ash ,n 2) 2))) -(defmacro rect-height (rects n) - `(svref ,rects (+ (ash ,n 2) 3))) - -(defun plaid (display window &optional (num-iterations 10000) (num-rectangles 10)) - (let ((gcontext (xlib:create-gcontext :drawable window - :function boole-c2 - :plane-mask (logxor *white-pixel* - *black-pixel*) - :background *white-pixel* - :foreground *black-pixel* - :fill-style :solid)) - (rectangles (make-array (* 4 num-rectangles) - :element-type 'number - :initial-element 0))) - (multiple-value-bind (width height) (full-window-state window) - (let ((center-x (ash width -1)) - (center-y (ash height -1)) - (x-dir -2) - (y-dir -2) - (x-off 2) - (y-off 2)) - (dotimes (iter (truncate num-iterations num-rectangles)) - (dotimes (i num-rectangles) - (setf (rect-x rectangles i) (- center-x x-off)) - (setf (rect-y rectangles i) (- center-y y-off)) - (setf (rect-width rectangles i) (ash x-off 1)) - (setf (rect-height rectangles i) (ash y-off 1)) - (incf x-off x-dir) - (incf y-off y-dir) - (when (or (<= x-off 0) (>= x-off center-x)) - (decf x-off (ash x-dir 1)) - (setf x-dir (- x-dir))) - (when (or (<= y-off 0) (>= y-off center-y)) - (decf y-off (ash y-dir 1)) - (setf y-dir (- y-dir)))) - (xlib:draw-rectangles window gcontext rectangles t) - (xlib:display-force-output display)))) - (xlib:free-gcontext gcontext))) - -(defdemo plaid-demo "Plaid" (&optional (iterations 10000) (num-rectangles 10)) - 10 10 101 201 - "Plaid, man." - (plaid *display* *window* iterations num-rectangles)) - - -;;;; Bball demo - -;;; -;;; Ported to CLX by Blaine Burks -;;; - -(defvar *ball-size-x* 38) -(defvar *ball-size-y* 34) - -(defmacro xor-ball (pixmap window gcontext x y) - `(xlib:copy-area ,pixmap ,gcontext 0 0 *ball-size-x* *ball-size-y* - ,window ,x ,y)) - -(defconstant bball-gravity 1) -(defconstant maximum-x-drift 7) - -(defvar *max-bball-x*) -(defvar *max-bball-y*) - -(defstruct ball - (x (random (- *max-bball-x* *ball-size-x*))) - (y (random (- *max-bball-y* *ball-size-y*))) - (dx (if (zerop (random 2)) (random maximum-x-drift) - (- (random maximum-x-drift)))) - (dy 0)) - -(defun get-bounce-image () - "Returns the pixmap to be bounced around the screen." - (xlib::bitmap-image #*000000000000000000000000000000000000 - #*000000000000000000000000000000000000 - #*000000000000000000001000000010000000 - #*000000000000000000000000000100000000 - #*000000000000000000000100001000000000 - #*000000000000000010000000010000000000 - #*000000000000000000100010000000000000 - #*000000000000000000001000000000000000 - #*000000000001111100000000000101010000 - #*000000000010000011000111000000000000 - #*000000000100000000111000000000000000 - #*000000000100000000000000000100000000 - #*000000000100000000001000100010000000 - #*000000111111100000010000000001000000 - #*000000111111100000100000100000100000 - #*000011111111111000000000000000000000 - #*001111111111111110000000100000000000 - #*001111111111111110000000000000000000 - #*011111111111111111000000000000000000 - #*011111111111111111000000000000000000 - #*111111111111110111100000000000000000 - #*111111111111111111100000000000000000 - #*111111111111111101100000000000000000 - #*111111111111111101100000000000000000 - #*111111111111111101100000000000000000 - #*111111111111111111100000000000000000 - #*111111111111110111100000000000000000 - #*011111111111111111000000000000000000 - #*011111111111011111000000000000000000 - #*001111111111111110000000000000000000 - #*001111111111111110000000000000000000 - #*000011111111111000000000000000000000 - #*000000111111100000000000000000000000 - #*000000000000000000000000000000000000)) - - -(defun bounce-1-ball (pixmap window gcontext ball) - (let ((x (ball-x ball)) - (y (ball-y ball)) - (dx (ball-dx ball)) - (dy (ball-dy ball))) - (xor-ball pixmap window gcontext x y) - (setq x (+ x dx)) - (setq y (+ y dy)) - (if (or (< x 0) (> x (- *max-bball-x* *ball-size-x*))) - (setq x (- x dx) - dx (- dx))) - (if (> y (- *max-bball-y* *ball-size-y*)) - (setq y (- y dy) - dy (- dy))) - (setq dy (+ dy bball-gravity)) - (setf (ball-x ball) x) - (setf (ball-y ball) y) - (setf (ball-dx ball) dx) - (setf (ball-dy ball) dy) - (xor-ball pixmap window gcontext x y))) - -(defun bounce-balls (display window how-many duration) - (xlib:clear-area window) - (xlib:display-force-output display) - (multiple-value-bind (*max-bball-x* *max-bball-y*) (full-window-state window) - (let* ((balls (do ((i 0 (1+ i)) - (list () (cons (make-ball) list))) - ((= i how-many) list))) - (gcontext (xlib:create-gcontext :drawable window - :foreground *white-pixel* - :background *black-pixel* - :function boole-xor - :exposures :off)) - (bounce-pixmap (xlib:create-pixmap :width 38 :height 34 :depth 1 - :drawable window)) - (pixmap-gc (xlib:create-gcontext :drawable bounce-pixmap - :foreground *white-pixel* - :background *black-pixel*))) - (xlib:put-image bounce-pixmap pixmap-gc (get-bounce-image) - :x 0 :y 0 :width 38 :height 34) - (xlib:free-gcontext pixmap-gc) - (dolist (ball balls) - (xor-ball bounce-pixmap window gcontext (ball-x ball) (ball-y ball))) - (xlib:display-force-output display) - (dotimes (i duration) - (dolist (ball balls) - (bounce-1-ball bounce-pixmap window gcontext ball)) - (xlib:display-force-output display)) - (xlib:free-pixmap bounce-pixmap) - (xlib:free-gcontext gcontext)))) - -#+nil -(defdemo bouncing-ball-demo "Bouncing-Ball" (&optional (how-many 5) (duration 500)) - 34 34 700 500 - "Bouncing balls in space." - (bounce-balls *display* *window* how-many duration)) diff -Nru ecl-16.1.2/src/clx/demo/.cvsignore ecl-16.1.3+ds/src/clx/demo/.cvsignore --- ecl-16.1.2/src/clx/demo/.cvsignore 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/demo/.cvsignore 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -*.fasl diff -Nru ecl-16.1.2/src/clx/demo/gl-test.lisp ecl-16.1.3+ds/src/clx/demo/gl-test.lisp --- ecl-16.1.2/src/clx/demo/gl-test.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/demo/gl-test.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,477 +0,0 @@ -(defpackage :gl-test - (:use :common-lisp :xlib) - (:export "TEST" "CLX-TEST")) - -(in-package :gl-test) - - -(defun test (function &key (host "localhost") (display 1) (width 200) (height 200)) - (let* ((display (open-display host :display display)) - (screen (display-default-screen display)) - (root (screen-root screen)) - ctx) - (unwind-protect - (progn - ;;; Inform the server about us. - (glx::client-info display) - (let* ((visual (glx:choose-visual screen '(:glx-rgba - (:glx-red-size 1) - (:glx-green-size 1) - (:glx-blue-size 1) - :glx-double-buffer))) - (colormap (create-colormap (glx:visual-id visual) root)) - (window (create-window :parent root - :x 10 :y 10 :width width :height height - :class :input-output - :background (screen-black-pixel screen) - :border (screen-black-pixel screen) - :visual (glx:visual-id visual) - :depth 24 - :colormap colormap - :event-mask '(:structure-notify :exposure))) - (gc (create-gcontext :foreground (screen-white-pixel screen) - :background (screen-black-pixel screen) - :drawable window - :font (open-font display "fixed")))) - (set-wm-properties window - :name "glx-test" - :resource-class "glx-test" - :command (list "glx-test") - :x 10 :y 10 :width width :height height - :min-width width :min-height height - :initial-state :normal) - - (setf ctx (glx:create-context screen (glx:visual-id visual))) - (map-window window) - (glx:make-current window ctx) - - (funcall function display window) - - (unmap-window window) - (free-gcontext gc))) - - (when ctx (glx:destroy-context ctx)) - (close-display display)))) - - -;;; Tests - - -(defun no-floats (display window) - (declare (ignore display window)) - (gl:color-3s #x7fff #x7fff 0) - (gl:begin gl:+polygon+) - (gl:vertex-2s 0 0) - (gl:vertex-2s 1 0) - (gl:vertex-2s 1 1) - (gl:vertex-2s 0 1) - (gl:end) - (glx:swap-buffers) - (sleep 5)) - - -(defun anim (display window) - (declare (ignore display window)) - (gl:ortho 0.0d0 1.0d0 0.0d0 1.0d0 -1.0d0 1.0d0) - (gl:clear-color 0.0s0 0.0s0 0.0s0 0.0s0) - (gl:line-width 2.0s0) - (loop - repeat 361 - for angle upfrom 0.0s0 by 1.0s0 - do (progn - (gl:clear gl:+color-buffer-bit+) - (gl:push-matrix) - (gl:translate-f 0.5s0 0.5s0 0.0s0) - (gl:rotate-f angle 0.0s0 0.0s0 1.0s0) - (gl:translate-f -0.5s0 -0.5s0 0.0s0) - (gl:begin gl:+polygon+ #-(and) gl:+line-loop+) - (gl:color-3ub 255 0 0) - (gl:vertex-2f 0.25s0 0.25s0) - (gl:color-3ub 0 255 0) - (gl:vertex-2f 0.75s0 0.25s0) - (gl:color-3ub 0 0 255) - (gl:vertex-2f 0.75s0 0.75s0) - (gl:color-3ub 255 255 255) - (gl:vertex-2f 0.25s0 0.75s0) - (gl:end) - (gl:pop-matrix) - (glx:swap-buffers) - (sleep 0.02))) - (sleep 3)) - - -(defun anim/list (display window) - (declare (ignore display window)) - (gl:ortho 0.0d0 1.0d0 0.0d0 1.0d0 -1.0d0 1.0d0) - (gl:clear-color 0.0s0 0.0s0 0.0s0 0.0s0) - (let ((list (gl:gen-lists 1))) - (gl:new-list list gl:+compile+) - (gl:begin gl:+polygon+) - (gl:color-3ub 255 0 0) - (gl:vertex-2f 0.25s0 0.25s0) - (gl:color-3ub 0 255 0) - (gl:vertex-2f 0.75s0 0.25s0) - (gl:color-3ub 0 0 255) - (gl:vertex-2f 0.75s0 0.75s0) - (gl:color-3ub 255 255 255) - (gl:vertex-2f 0.25s0 0.75s0) - (gl:end) - (glx:render) - (gl:end-list) - - (loop - repeat 361 - for angle upfrom 0.0s0 by 1.0s0 - do (progn - (gl:clear gl:+color-buffer-bit+) - (gl:push-matrix) - (gl:rotate-f angle 0.0s0 0.0s0 1.0s0) - (gl:call-list list) - (gl:pop-matrix) - (glx:swap-buffers) - (sleep 0.02)))) - - (sleep 3)) - - -;;; glxgears - -(defconstant +pi+ (coerce pi 'single-float)) -(declaim (type single-float +pi+)) - - -(defun gear (inner-radius outer-radius width teeth tooth-depth) - (let ((r0 inner-radius) - (r1 (/ (- outer-radius tooth-depth) 2.0s0)) - (r2 (/ (+ outer-radius tooth-depth) 2.0s0)) - (da (/ (* 2.0s0 +pi+) teeth 4.0s0))) - (gl:shade-model gl:+flat+) - (gl:normal-3f 0.0s0 0.0s0 1.0s0) - - ;; Front face. - (gl:begin gl:+quad-strip+) - (dotimes (i (1+ teeth)) - (let ((angle (/ (* i 2.0 +pi+) teeth))) - (declare (type single-float angle)) - (gl:vertex-3f (* r0 (cos angle)) - (* r0 (sin angle)) - (* width 0.5s0)) - (gl:vertex-3f (* r1 (cos angle)) - (* r1 (sin angle)) - (* width 0.5s0)) - (when (< i teeth) - (gl:vertex-3f (* r0 (cos angle)) - (* r0 (sin angle)) - (* width 0.5s0)) - (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) - (* r1 (sin (+ angle (* 3 da)))) - (* width 0.5s0))))) - (gl:end) - - - ;; Draw front sides of teeth. - (gl:begin gl:+quads+) - (setf da (/ (* 2.0s0 +pi+) teeth 4.0s0)) - (dotimes (i teeth) - (let ((angle (/ (* i 2.0s0 +pi+) teeth))) - (declare (type single-float angle)) - (gl:vertex-3f (* r1 (cos angle)) - (* r1 (sin angle)) - (* width 0.5s0)) - (gl:vertex-3f (* r2 (cos (+ angle da))) - (* r2 (sin (+ angle da))) - (* width 0.5s0)) - (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) - (* r2 (sin (+ angle (* 2 da)))) - (* width 0.5s0)) - (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) - (* r1 (sin (+ angle (* 3 da)))) - (* width 0.5s0)))) - (gl:end) - - (gl:normal-3f 0.0s0 0.0s0 -1.0s0) - - ;; Draw back face. - (gl:begin gl:+quad-strip+) - (dotimes (i (1+ teeth)) - (let ((angle (/ (* i 2.0s0 +pi+) teeth))) - (declare (type single-float angle)) - (gl:vertex-3f (* r1 (cos angle)) - (* r1 (sin angle)) - (* width -0.5s0)) - (gl:vertex-3f (* r0 (cos angle)) - (* r0 (sin angle)) - (* width -0.5s0)) - (when (< i teeth) - (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) - (* r1 (sin (+ angle (* 3 da)))) - (* width -0.5s0)) - (gl:vertex-3f (* r0 (cos angle)) - (* r0 (sin angle)) - (* width 0.5s0))))) - (gl:end) - - ;; Draw back sides of teeth. - (gl:begin gl:+quads+) - (setf da (/ (* 2.0s0 +pi+) teeth 4.0s0)) - (dotimes (i teeth) - (let ((angle (/ (* i 2.0s0 +pi+) teeth))) - (declare (type single-float angle)) - (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) - (* r1 (sin (+ angle (* 3 da)))) - (* width -0.5s0)) - (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) - (* r2 (sin (+ angle (* 2 da)))) - (* width -0.5s0)) - (gl:vertex-3f (* r2 (cos (+ angle da))) - (* r2 (sin (+ angle da))) - (* width -0.5s0)) - (gl:vertex-3f (* r1 (cos angle)) - (* r1 (sin angle)) - (* width -0.5s0)))) - (gl:end) - - ;; Draw outward faces of teeth. - (gl:begin gl:+quad-strip+) - (dotimes (i teeth) - (let ((angle (/ (* i 2.0s0 +pi+) teeth))) - (declare (type single-float angle)) - (gl:vertex-3f (* r1 (cos angle)) - (* r1 (sin angle)) - (* width 0.5s0)) - (gl:vertex-3f (* r1 (cos angle)) - (* r1 (sin angle)) - (* width -0.5s0)) - (let* ((u (- (* r2 (cos (+ angle da))) (* r1 (cos angle)))) - (v (- (* r2 (sin (+ angle da))) (* r1 (sin angle)))) - (len (sqrt (+ (* u u) (* v v))))) - (setf u (/ u len) - v (/ v len)) - (gl:normal-3f v u 0.0s0) - (gl:vertex-3f (* r2 (cos (+ angle da))) - (* r2 (sin (+ angle da))) - (* width 0.5s0)) - (gl:vertex-3f (* r2 (cos (+ angle da))) - (* r2 (sin (+ angle da))) - (* width -0.5s0)) - (gl:normal-3f (cos angle) (sin angle) 0.0s0) - (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) - (* r2 (sin (+ angle (* 2 da)))) - (* width 0.5s0)) - (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) - (* r2 (sin (+ angle (* 2 da)))) - (* width -0.5s0)) - (setf u (- (* r1 (cos (+ angle (* 3 da)))) (* r2 (cos (+ angle (* 2 da))))) - v (- (* r1 (sin (+ angle (* 3 da)))) (* r2 (sin (+ angle (* 2 da)))))) - (gl:normal-3f v (- u) 0.0s0) - (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) - (* r1 (sin (+ angle (* 3 da)))) - (* width 0.5s0)) - (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) - (* r1 (sin (+ angle (* 3 da)))) - (* width -0.5s0)) - (gl:normal-3f (cos angle) (sin angle) 0.0s0)))) - - (gl:vertex-3f (* r1 (cos 0)) (* r1 (sin 0)) (* width 0.5s0)) - (gl:vertex-3f (* r1 (cos 0)) (* r1 (sin 0)) (* width -0.5s0)) - - (gl:end) - - (gl:shade-model gl:+smooth+) - - ;; Draw inside radius cylinder. - (gl:begin gl:+quad-strip+) - (dotimes (i (1+ teeth)) - (let ((angle (/ (* i 2.0s0 +pi+) teeth))) - (declare (type single-float angle)) - (gl:normal-3f (- (cos angle)) (- (sin angle)) 0.0s0) - (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5s0)) - (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5s0)))) - (gl:end))) - - -(defun draw (gear-1 gear-2 gear-3 view-rotx view-roty view-rotz angle) - (gl:clear (logior gl:+color-buffer-bit+ gl:+depth-buffer-bit+)) - - (gl:push-matrix) - (gl:rotate-f view-rotx 1.0s0 0.0s0 0.0s0) - (gl:rotate-f view-roty 0.0s0 1.0s0 0.0s0) - (gl:rotate-f view-rotz 0.0s0 0.0s0 1.0s0) - - (gl:push-matrix) - (gl:translate-f -3.0s0 -2.0s0 0.0s0) - (gl:rotate-f angle 0.0s0 0.0s0 1.0s0) - (gl:call-list gear-1) - (gl:pop-matrix) - - (gl:push-matrix) - (gl:translate-f 3.1s0 -2.0s0 0.0s0) - (gl:rotate-f (- (* angle -2.0s0) 9.0s0) 0.0s0 0.0s0 1.0s0) - (gl:call-list gear-2) - (gl:pop-matrix) - - (gl:push-matrix) - (gl:translate-f -3.1s0 4.2s0 0.0s0) - (gl:rotate-f (- (* angle -2.s0) 25.0s0) 0.0s0 0.0s0 1.0s0) - (gl:call-list gear-3) - (gl:pop-matrix) - - (gl:pop-matrix)) - - -(defun reshape (width height) - (gl:viewport 0 0 width height) - (let ((h (coerce (/ height width) 'double-float))) - (gl:matrix-mode gl:+projection+) - (gl:load-identity) - (gl:frustum -1.0d0 1.0d0 (- h) h 5.0d0 60.0d0)) - - (gl:matrix-mode gl:+modelview+) - (gl:load-identity) - (gl:translate-f 0.0s0 0.0s0 -40.0s0)) - - -(defun init () - (let (gear-1 gear-2 gear-3) - ;;(gl:light-fv gl:+light0+ gl:+position+ '(5.0s0 5.0s0 10.0s0 0.0s0)) - ;;(gl:enable gl:+cull-face+) - ;;(gl:enable gl:+lighting+) - ;;(gl:enable gl:+light0+) - ;;(gl:enable gl:+depth-test+) - - ;; Make the gears. - (setf gear-1 (gl:gen-lists 1)) - (gl:new-list gear-1 gl:+compile+) - (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0)) - (gear 1.0s0 4.0s0 1.0s0 20 0.7s0) - (gl:end-list) - - (setf gear-2 (gl:gen-lists 1)) - (gl:new-list gear-2 gl:+compile+) - (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.0s0 0.8s0 0.2s0 1.0s0)) - (gear 0.5s0 2.0s0 2.0s0 10 0.7s0) - (gl:end-list) - - (setf gear-3 (gl:gen-lists 1)) - (gl:new-list gear-3 gl:+compile+) - (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.2s0 0.2s0 1.0s0 1.0s0)) - (gear 1.3s0 2.0s0 0.5s0 10 0.7s0) - (gl:end-list) - - ;;(gl:enable gl:+normalize+) - - (values gear-1 gear-2 gear-3))) - - -(defun gears* (display window) - (declare (ignore display window)) - - (gl:enable gl:+cull-face+) - (gl:enable gl:+lighting+) - (gl:enable gl:+light0+) - (gl:enable gl:+normalize+) - (gl:enable gl:+depth-test+) - - (reshape 300 300) - - ;;(gl:light-fv gl:+light0+ gl:+position+ #(5.0s0 5.0s0 10.0s0 0.0s0)) - - (let (list) - (declare (ignore list)) - #-(and) - (progn - (setf list (gl:gen-lists 1)) - (gl:new-list list gl:+compile+) - ;;(gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0)) - (gear 1.0s0 4.0s0 1.0s0 20 0.7s0) - (glx:render) - (gl:end-list)) - - - (loop - ;;for angle from 0.0s0 below 361.0s0 by 1.0s0 - with angle single-float = 0.0s0 - with dt = 0.004s0 - repeat 2500 - do (progn - - (incf angle (* 70.0s0 dt)) ; 70 degrees per second - (when (< 3600.0s0 angle) - (decf angle 3600.0s0)) - - (gl:clear (logior gl:+color-buffer-bit+ gl:+depth-buffer-bit+)) - - (gl:push-matrix) - (gl:rotate-f 20.0s0 0.0s0 1.0s0 0.0s0) - - - (gl:push-matrix) - (gl:translate-f -3.0s0 -2.0s0 0.0s0) - (gl:rotate-f angle 0.0s0 0.0s0 1.0s0) - (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0)) - (gear 1.0s0 4.0s0 1.0s0 20 0.7s0) - (gl:pop-matrix) - - - (gl:push-matrix) - (gl:translate-f 3.1s0 -2.0s0 0.0s0) - (gl:rotate-f (- (* angle -2.0s0) 9.0s0) 0.0s0 0.0s0 1.0s0) - (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.0s0 0.8s0 0.2s0 1.0s0)) - (gear 0.5s0 2.0s0 2.0s0 10 0.7s0) - (gl:pop-matrix) - - - (gl:push-matrix) - (gl:translate-f -3.1s0 4.2s0 0.0s0) - (gl:rotate-f (- (* angle -2.s0) 25.0s0) 0.0s0 0.0s0 1.0s0) - (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.2s0 0.2s0 1.0s0 1.0s0)) - (gear 1.3s0 2.0s0 0.5s0 10 0.7s0) - (gl:pop-matrix) - - - (gl:pop-matrix) - - (glx:swap-buffers) - ;;(sleep 0.025) - ))) - - - ;;(sleep 3) - ) - - -(defun gears (display window) - (declare (ignore window)) - (let ((view-rotx 20.0s0) - (view-roty 30.0s0) - (view-rotz 0.0s0) - (angle 0.0s0) - (frames 0) - (dt 0.004s0) ; *** This is dynamically adjusted - ;;(t-rot-0 -1.0d0) - ;;(t-rate-0 -1.d0) - gear-1 gear-2 gear-3) - - (multiple-value-setq (gear-1 gear-2 gear-3) - (init)) - - (loop - (event-case (display :timeout 0.01 :force-output-p t) - (configure-notify (width height) - (reshape width height) - t) - (key-press (code) - (format t "Key pressed: ~S~%" code) - (return-from gears t))) - - (incf angle (* 70.0s0 dt)) ; 70 degrees per second - (when (< 3600.0s0 angle) - (decf angle 3600.0s0)) - - (draw gear-1 gear-2 gear-3 view-rotx view-roty view-rotz angle) - (glx:swap-buffers) - - (incf frames) - - ;; FPS calculation goes here - ))) diff -Nru ecl-16.1.2/src/clx/demo/hello.lisp ecl-16.1.3+ds/src/clx/demo/hello.lisp --- ecl-16.1.2/src/clx/demo/hello.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/demo/hello.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,65 +0,0 @@ -;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10; Lowercase: Yes -*- - -(in-package :xlib) - -(defun hello-world (host &rest args &key (string "Hello World") (font "fixed")) - ;; CLX demo, says STRING using FONT in its own window on HOST - (let ((display nil) - (abort t)) - (unwind-protect - (progn - (setq display (open-display host)) - (multiple-value-prog1 - (let* ((screen (display-default-screen display)) - (black (screen-black-pixel screen)) - (white (screen-white-pixel screen)) - (font (open-font display font)) - (border 1) ; Minimum margin around the text - (width (+ (text-width font string) (* 2 border))) - (height (+ (max-char-ascent font) (max-char-descent font) (* 2 border))) - (x (truncate (- (screen-width screen) width) 2)) - (y (truncate (- (screen-height screen) height) 2)) - (window (create-window :parent (screen-root screen) - :x x :y y :width width :height height - :background black - :border white - :border-width 1 - :colormap (screen-default-colormap screen) - :bit-gravity :center - :event-mask '(:exposure :button-press))) - (gcontext (create-gcontext :drawable window - :background black - :foreground white - :font font))) - ;; Set window manager hints - (set-wm-properties window - :name 'hello-world - :icon-name string - :resource-name string - :resource-class 'hello-world - :command (list* 'hello-world host args) - :x x :y y :width width :height height - :min-width width :min-height height - :input :off :initial-state :normal) - (map-window window) ; Map the window - ;; Handle events - (event-case (display :discard-p t :force-output-p t) - (exposure ;; Come here on exposure events - (window count) - (when (zerop count) ;; Ignore all but the last exposure event - (with-state (window) - (let ((x (truncate (- (drawable-width window) width) 2)) - (y (truncate (- (+ (drawable-height window) - (max-char-ascent font)) - (max-char-descent font)) - 2))) - ;; Draw text centered in widnow - (clear-area window) - (draw-glyphs window gcontext x y string))) - ;; Returning non-nil causes event-case to exit - nil)) - (button-press () t))) ;; Pressing any mouse-button exits - (setq abort nil))) - ;; Ensure display is closed when done - (when display - (close-display display :abort abort))))) diff -Nru ecl-16.1.2/src/clx/demo/mandel.lisp ecl-16.1.3+ds/src/clx/demo/mandel.lisp --- ecl-16.1.2/src/clx/demo/mandel.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/demo/mandel.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,558 +0,0 @@ -(defpackage "XMANDEL" - (:use "CL") - (:export "NEW-WINDOW" "EVENT-LOOP")) - -(in-package "XMANDEL") - -(defvar *display* (xlib:open-default-display)) -(defvar *screen* (xlib:display-default-screen *display*)) - -(defvar *backing-store* (make-hash-table) "Backing store hashtable, keyed off window id") -(defvar *colmap* nil) -(defvar *helpwin* nil) -(defvar *zoom-table* (make-hash-table)) -(defvar *zoomcolmap* (xlib:create-gcontext - :drawable (xlib:screen-root *screen*) - :foreground (xlib:screen-white-pixel *screen*) - :function boole-xor)) -(defvar *white* (xlib:create-gcontext - :drawable (xlib:screen-root *screen*) - :foreground (xlib:screen-white-pixel *screen*) - )) -(defvar *winmap* (make-hash-table)) -(defvar *textmap* (xlib:create-gcontext - :drawable (xlib:screen-root *screen*) - :foreground (xlib:screen-black-pixel *screen*) - :background (xlib:screen-white-pixel *screen*))) - -;;; OK, this is an ugly hack to make sure we can handle -;;; shift and modstate in a sane way, alas we can't 100% rely -;;; on "current state of keyboard", since we only process events -;;; with a noticeable delay, at eth best of times, so a fast keyboarder -;;; can fool us, we are, however, IIRC, guaranteed that all events are -;;; serialised, so... -(defvar *modstate* nil) -(declaim (list *modstate*)) -(defun make-shift-foo () - (let ((rv 0)) - (if (member :shift *modstate*) - (setf rv 1)) - (if (member :character-set-switch *modstate*) - (setf rv (+ rv 2))) - rv)) - -(defstruct (mandel-square (:conc-name ms-)) - (x 0 :type fixnum) - (y 0 :type fixnum) - (s 512 :type fixnum) - (base-r 0.0d0 :type double-float) - (base-i 0.0d0 :type double-float) - (maxiter 1024 :type fixnum) - (dr 0.0d0 :type double-float) - (di 0.0d0 :type double-float) - win - ) - -(defun make-queue (&rest args) - (apply #'make-instance 'queue args)) - -(defclass queue () - ((head :initform nil :accessor q-head) - (tail :initform nil :accessor q-tail))) -(defclass out-queue () - ((win-queues :accessor win-queues :initarg :xyzzy-1) - (seen-windows :accessor windows :initform nil) - (win-list :accessor win-list :initarg :xyzzy-2) - (last-window :accessor last-window :initform nil)) - (:default-initargs :xyzzy-1 (make-hash-table) - :xyzzy-2 (make-instance 'queue))) - -(defvar *sysqueue* (make-instance 'out-queue)) - -(defgeneric empty-p (queue)) -(defgeneric empty (queue)) -(defgeneric empty-win (queue win)) -(defgeneric enqueue (queue item)) -(defgeneric queue-push (queue item)) -(defgeneric dequeue (queue)) - -(defmethod empty-p ((q null)) - t) -(defmethod empty-p ((q queue)) - (null (q-head q))) -(defmethod empty-p ((q out-queue)) - (let ((coll nil)) - (maphash #'(lambda (key val) - (declare (ignore key)) - (push (empty-p val) coll)) - (win-queues q)) - (every #'identity coll))) - -(defmethod empty ((q null)) - nil) -(defmethod empty ((q queue)) - (setf (q-head q) nil) - (setf (q-tail q) nil)) -(defmethod empty ((q out-queue)) - (maphash #'(lambda (key val) (declare (ignore key)) (empty val)) - (win-queues q))) -(defmethod empty-win ((q out-queue) win) - (let ((temp-queue (gethash win (win-queues q)))) - (empty temp-queue))) - -(defmethod enqueue ((q queue) item) - (cond ((empty-p q) - (setf (q-head q) (cons item nil)) - (setf (q-tail q) (q-head q))) - (t (setf (cdr (q-tail q)) (cons item nil)) - (setf (q-tail q) (cdr (q-tail q)))))) -(defmethod enqueue ((q out-queue) item) - (let ((windows (q-head (win-list q))) - (win (ms-win item))) - (declare (type xlib:window win)) - (unless (member win windows) - (enqueue (win-list q) win)) - (unless (member win (windows q)) - (push win (windows q))) - (let ((temp-queue (gethash win (win-queues q)))) - (if (null temp-queue) - (let ((new (make-queue))) - (setf (gethash win (win-queues q)) new) - (enqueue new item)) - (enqueue temp-queue item))))) - -(defmethod queue-push ((q queue) item) - (cond ((empty-p q) - (setf (q-head q) (cons item nil)) - (setf (q-tail q) (q-head q))) - (t (setf (q-head q) (cons item (q-head q)))))) -(defmethod queue-push ((q out-queue) item) - (let ((windows (q-head (win-list q))) - (win (ms-win item))) - (declare (type xlib:window win)) - (unless (member win windows) - (enqueue (win-list q) win)) - (unless (member win (windows q)) - (push win (windows q))) - (let ((temp-queue (gethash win (win-queues q)))) - (if (null temp-queue) - (let ((new (make-queue))) - (setf (gethash win (win-queues q)) new) - (queue-push new item)) - (queue-push temp-queue item))))) - -(defmethod dequeue ((q out-queue)) - (if (empty-p q) - nil - (let ((windows (win-list q))) - (do* ((next (dequeue windows)) - (finished nil) - (val nil) - (temp-queue (gethash next (win-queues q)) - (gethash next (win-queues q)))) - (finished val) - (cond ((empty-p temp-queue) - (setf next (dequeue windows))) - (t (setf val (dequeue temp-queue)) - (unless (empty-p temp-queue) - (enqueue windows next)) - (setf finished t))))))) -(defmethod dequeue ((q queue)) - (prog1 - (car (q-head q)) - (if (not (empty-p q)) - (setf (q-head q) (cdr (q-head q)))) - (if (null (q-head q)) - (progn - (setf (q-head q) nil) - (setf (q-tail q) nil))))) - -(defun iter (rc ic max) - (declare (double-float rc ic) - (fixnum max)) - (do ((x 0.0d0 (the double-float (+ (- (* x x) (* y y)) rc))) - (y 0.0d0 (the double-float (+ (* 2.0d0 x y) ic))) - (n 1 (the fixnum (1+ n)))) - ((or (>= n max) (>= (+ (* x x) (* y y)) 4.0d0)) - n))) -;;; (a+bi)^2 --> -;;; (a+bi)(a+bi) --> -;;; a^2+2abi+(bi)^2 --> -;;; a^2+2abi-b^2 - -(defclass zoomer () - ((zoom-type :initarg :type :reader zoom-type :type fixnum) - (start-x :initarg :x :reader start-x :type fixnum) - (start-y :initarg :y :reader start-y :type fixnum) - (stop-x :accessor stop-x :initform -1 :type fixnum) - (stop-y :accessor stop-y :initform -1 :type fixnum) - (win :reader win :initarg :win))) - -;;;(defmethod print-object ((object zoomer) stream) -;;; (format stream " [~a ~a]>~%" -;;; (zoom-type object) (start-x object) (start-y object) -;;; (stop-x object) (stop-y object))) - -(defun init-colours () - (unless *colmap* - (setf *colmap* (make-array 256 :element-type 'xlib:gcontext :initial-element *zoomcolmap*)) - (setf (aref *colmap* 0) (xlib:create-gcontext - :drawable (xlib:screen-root *screen*) - :foreground (xlib:alloc-color - (xlib:screen-default-colormap *screen*) - (xlib:make-color :red 0 - :green 0 - :blue 0)))) - (loop for index from 1 to 255 - do (setf (aref *colmap* index) - (xlib:create-gcontext - :drawable (xlib:screen-root *screen*) - :foreground (xlib:alloc-color - (xlib:screen-default-colormap *screen*) - (xlib:make-color :red (random 1.0) - :green (random 1.0) - :blue (random 1.0)))))))) -(defmacro modcol (col max) - `(if (= ,col ,max) 0 (1+ (mod ,col 255)))) - -(defun plot (win col x y max) - (declare (fixnum col x y max)) - (let ((col (modcol col max))) - (xlib:draw-point win (aref *colmap* col) x y) - (setf (aref (the (simple-array (integer 0 255) (512 512)) - (gethash win *backing-store*)) x y) col))) - -(defun display-help () - (unless *helpwin* - (setf *helpwin* (xlib:create-window - :parent (xlib:screen-root *screen*) - :x 512 - :y 512 - :width 310 - :height 180 - :event-mask (xlib:make-event-mask :exposure) - :backing-store :always - :background (xlib:screen-white-pixel *screen*))) - (xlib:map-window *helpwin*) - (xlib:display-force-output *display*)) - (unless (xlib:gcontext-font *textmap*) - (let ((fixed (xlib:list-fonts *display* "fixed")) - font) - (if fixed - (setf font (xlib:open-font *display* "fixed")) - (error "Could not open suitable font")) - (setf (xlib:gcontext-font *textmap*) (if (consp fixed) - (car fixed) - fixed)))) - (xlib:draw-rectangle *helpwin* *white* 0 0 (xlib:drawable-width *helpwin*) (xlib:drawable-height *helpwin*) t) - (xlib:draw-glyphs *helpwin* *textmap* 10 13 "Button 1: Zoom same") - (xlib:draw-glyphs *helpwin* *textmap* 10 33 "Button 2: Zoom new") - (xlib:draw-glyphs *helpwin* *textmap* 10 53 "Button 3: Zoom out, same") - (xlib:draw-glyphs *helpwin* *textmap* 10 93 "In general, click to zoom centred on mouse,") - (xlib:draw-glyphs *helpwin* *textmap* 10 113 "drag to zoom a region.") - (xlib:draw-glyphs *helpwin* *textmap* 10 153 "Q: quit") - (xlib:display-force-output *display*)) - -(defun repaint-window (win x-low y-low x-high y-high) - (declare (fixnum x-low y-low x-high y-high)) - (if (eq win *helpwin*) - (display-help) - (let ((bs (the (simple-array (integer 0 255) (512 512)) (gethash win *backing-store*)))) - (loop for y of-type fixnum from y-low to y-high - do - (loop for x of-type fixnum from x-low to x-high - do (xlib:draw-point win (aref *colmap* (aref bs x y)) x y)))))) - -(defun fill-square (win col x y s max) - (declare (fixnum col x y s max)) - (let ((col (modcol col max))) - (xlib:draw-rectangle win (aref *colmap* col) x y s s t) - (let ((bs (the (simple-array (integer 0 255) (512 512)) (gethash win *backing-store*)))) - (loop for px of-type fixnum from x to (1- (+ x s)) - do (loop for py of-type fixnum from y to (1- (+ y s)) - do (setf (aref bs px py) col)))))) - -(defun make-square (win x y side bx by dx dy &optional (maxiter 1024)) - (declare (xlib:window win) - (fixnum x y side maxiter) - (double-float bx by dx dy)) - (let ((sq (make-mandel-square - :x x :y y :s side - :base-r bx :base-i by - :dr dx :di dy - :maxiter maxiter - :win win))) - (queue-push *sysqueue* sq))) - -(defun mandel-win (win lx ly hx hy &optional (maxiter 1024)) - (declare (xlib:window win) - (double-float lx ly hx hy) - (fixnum maxiter)) - (let ((dx (coerce (/ (- hx lx) 512.0d0) 'double-float)) - (dy (coerce (/ (- hy ly) 512.0d0) 'double-float))) - (setf (gethash win *winmap*) - (make-mandel-square :x 0 :y 0 :s 512 - :base-r lx :base-i ly - :dr dx :di dy :maxiter maxiter)) - (make-square win 0 256 256 lx ly dx dy maxiter) - (make-square win 256 256 256 lx ly dx dy maxiter) - (make-square win 256 0 256 lx ly dx dy maxiter) - (make-square win 0 0 256 lx ly dx dy maxiter))) - -(defun new-window (lx ly hx hy &optional (maxiter 1024)) - (let ((win (xlib:create-window - :parent (xlib:screen-root *screen*) - :x (+ 100 (random 50)) :y (+ 100 (random 50)) - :width 512 :height 512 - :bit-gravity :center - :event-mask (xlib:make-event-mask - :button-motion :button-press :button-release - :key-press :exposure))) - (ar (make-array '(512 512) - :element-type '(integer 0 255) :initial-element 0)) - ) - (setf (gethash win *backing-store*) ar) - (xlib:map-window win) - (mandel-win win - (coerce lx 'double-float) (coerce ly 'double-float) - (coerce hx 'double-float) (coerce hy 'double-float) maxiter))) - -(defun fill-square-p (ix iy s bx by dx dy max win) - (declare (fixnum ix iy s max) - (double-float bx by dx dy)) - (let ((norm (iter (+ bx (* ix dx)) (+ by (* iy dy)) max))) - (and - (loop for px from ix below (+ ix s) - for x of-type double-float = (+ bx (* px dx)) - with y = (+ by (* iy dy)) - for i = (iter x y max) - do (plot win i px iy max) - while (= i norm) - finally (return t)) - (loop for py from iy below (+ s iy) - for y of-type double-float = (+ by (* py dy)) - with x = (+ bx (* ix dx)) - for i = (iter x y max) - do (plot win i ix py max) - while (= i norm) - finally (return t)) - (loop for px from (1- (+ s ix)) downto ix - for x of-type double-float = (+ bx (* px dx)) - with y = (+ by (* dy (1- (+ s iy)))) - for i = (iter x y max) - do (plot win i px iy max) - if (/= i norm) return nil - finally (return t)) - (loop for py from (1- (+ s iy)) downto iy - for y of-type double-float = (+ by (* py dy)) - with x = (+ bx (* dx (1- (+ s ix)))) - for i = (iter x y max) - do (plot win i ix py max) - if (/= i norm) return nil - finally (return t))))) - -(defmacro z (base delta int) - `(+ ,base (* ,delta ,int))) -(defun draw-square (square) - (declare (mandel-square square)) - (let ((dx (ms-dr square)) - (dy (ms-di square)) - (base-x (ms-base-r square)) - (base-y (ms-base-i square)) - (maxiter (ms-maxiter square)) - (win (ms-win square)) - (x (ms-x square)) - (y (ms-y square)) - (s (ms-s square)) - ) - (declare (double-float dx dy base-x base-y) - (fixnum x y s maxiter)) - (cond - ((= s 2) - (plot win - (iter (z base-x dx (1+ x)) (z base-y dy (1+ y)) maxiter) - (1+ x) (1+ y) maxiter) - (plot win - (iter (z base-x dx (1+ x)) (z base-y dy y) maxiter) - (1+ x) y maxiter) - (plot win - (iter (z base-x dx x) (z base-y dy (1+ y)) maxiter) - x (1+ y) maxiter) - (plot win - (iter (z base-x dx x) (z base-y dy y) maxiter) - x y maxiter)) - ((fill-square-p x y s base-x base-y dx dy maxiter win) - (fill-square win - (iter (z base-x dx x) (z base-y dy y) maxiter) - x y s maxiter)) - (t (let ((new-s (/ s 2))) - (make-square win - x y new-s - base-x base-y - dx dy - maxiter) - (make-square win - x (+ y new-s) new-s - base-x base-y - dx dy - maxiter) - (make-square win - (+ x new-s) y new-s - base-x base-y - dx dy - maxiter) - (make-square win - (+ x new-s) (+ y new-s) new-s - base-x base-y - dx dy - maxiter)))))) - -(defun create-zoom (win x y button) - (setf (gethash win *zoom-table*) - (make-instance 'zoomer - :x x :y y - :win win - :type (case button - (1 :zoom-same) - (2 :zoom-new) - (3 :zoom-out))))) - -(defun update-zoom (win x y code) - (declare (ignore code) - (fixnum x y)) - (let ((zoomer (gethash win *zoom-table*))) - (when zoomer - (let ((new-side (max 0 - (- (the fixnum x) (the fixnum (start-x zoomer))) - (- (the fixnum y) (the fixnum (start-y zoomer)))))) - (let ((old-side (max 0 - (- (the fixnum (stop-x zoomer)) - (the fixnum (start-x zoomer))) - (- (the fixnum (stop-y zoomer)) - (the fixnum (start-y zoomer)))))) - (xlib:draw-rectangle win *zoomcolmap* - (the fixnum (start-x zoomer)) - (the fixnum (start-y zoomer)) - old-side old-side)) - (setf (stop-x zoomer) (max (the fixnum (start-x zoomer)) - (the fixnum x) - )) - (setf (stop-y zoomer) (max (the fixnum (start-y zoomer)) - (the fixnum y) - )) - (xlib:draw-rectangle win *zoomcolmap* - (the fixnum (start-x zoomer)) - (the fixnum (start-y zoomer)) - new-side new-side) - (xlib:display-force-output *display*))))) - -(defun finish-zoom (win x y code) - (declare (ignore code)) - (let ((zoomer (gethash win *zoom-table*))) - (setf (stop-x zoomer) x) - (setf (stop-y zoomer) y))) - -(defun do-zoom (win) - (let ((zoomer (gethash win *zoom-table*))) - (declare (zoomer zoomer)) - (setf (gethash win *zoom-table*) nil) - (let ((dx (- (the fixnum (stop-x zoomer)) (the fixnum (start-x zoomer)))) - (dy (- (the fixnum (stop-y zoomer)) (the fixnum (start-y zoomer)))) - (sq (gethash win *winmap*))) - (let ((side (max dx dy)) - (x (the fixnum (start-x zoomer))) - (y (the fixnum (start-y zoomer))) - lx hx ly hy - ) - (if (< side 5) - (setf lx (+ (ms-base-r sq) - (* (- x 128) (ms-dr sq))) - ly (+ (ms-base-i sq) - (* (- y 128) (ms-di sq))) - hx (+ (ms-base-r sq) - (* (+ x 128) (ms-dr sq))) - hy (+ (ms-base-i sq) - (* (+ y 128) (ms-di sq)))) - (setf lx (+ (ms-base-r sq) - (* x (ms-dr sq))) - ly (+ (ms-base-i sq) - (* y (ms-dr sq))) - hx (+ (ms-base-r sq) - (* (+ side x) (ms-dr sq))) - hy (+ (ms-base-i sq) - (* (+ side y) (ms-dr sq))))) -;;; (format t "DEBUG: zoomer is ~a~%~%" zoomer) - (case (zoom-type zoomer) - (:zoom-new (new-window lx ly hx hy (ms-maxiter sq))) - (:zoom-same (empty-win *sysqueue* win) - (mandel-win win lx ly hx hy (ms-maxiter sq))) - (:zoom-out (empty-win *sysqueue* win) - (let ((br (ms-base-r sq)) - (bi (ms-base-i sq)) - (dr (ms-dr sq)) - (di (ms-di sq))) - (mandel-win win - (- br (* 512 dr)) (- bi (* 512 di)) - (+ (* 1024 dr) br) (+ (* 1024 di) bi) - (ms-maxiter sq)))) - - (t (format t "Unknown/unimplemented zoom type ~a~%~%" (zoom-type zoomer)))))))) - -(defun quit-window (window) - (let ((temp (gethash window (win-queues *sysqueue*)))) - (when temp - (empty temp)))) - -(defun event-loop () - (init-colours) - (do ((quit nil) - (redisplay nil t)) - ((eq quit 'quit)) - (xlib:event-case (*display* :timeout 0) - (:button-press (window x y code) - (create-zoom window x y code) - t) - (:button-release (window x y code) - (finish-zoom window x y code) - (do-zoom window) - t) - (:motion-notify (window x y code) - (update-zoom window x y code) - t) - (:exposure (window x y width height count) - (let ((count count)) - (declare (ignore count) - (fixnum x y width height)) - (when redisplay - (repaint-window window x y (1- (+ x width)) (1- (+ y height))))) - t) - (:key-press (window code) - (case (xlib:keysym->character - *display* - (xlib:keycode->keysym *display* code (make-shift-foo))) - (#\q (quit-window window)) - (#\? (display-help)) - ((:left-shift :right-shift) - (push :shift *modstate*)) - ((:left-control :right-control) - (push :ctrl *modstate*)) - (:character-set-switch - (push :character-set-switch *modstate*))) - t) - (:key-release (window code) - (let ((window window)) - (declare (ignore window)) - (case (xlib:keysym->character - *display* - (xlib:keycode->keysym *display* code 0)) - (:character-set-switch - (setf *modstate* (delete :character-set-switch *modstate*))) - ((:left-control :right-control) - (setf *modstate* (delete :ctrl *modstate*))) - ((:left-shift :right-shift) - (setf *modstate* (delete :shift *modstate*))))) - t)) - (cond ((empty-p *sysqueue*) - nil) - (t (let ((square (dequeue *sysqueue*))) - (draw-square square)))))) diff -Nru ecl-16.1.2/src/clx/demo/menu.lisp ecl-16.1.3+ds/src/clx/demo/menu.lisp --- ecl-16.1.2/src/clx/demo/menu.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/demo/menu.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,382 +0,0 @@ -;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10; Lowercase: Yes -*- - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1988 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - - -;;;----------------------------------------------------------------------------------+ -;;; | -;;; These functions demonstrate a simple menu implementation described in | -;;; Kimbrough, Kerry, "Windows to the Future", Lisp Pointers, Oct-Nov, 1987. | -;;; See functions JUST-SAY-LISP and POP-UP for demonstrations. | -;;; | -;;;----------------------------------------------------------------------------------+ - - - -(defstruct (menu) - "A simple menu of text strings." - (title "choose an item:") - item-alist ;((item-window item-string)) - window - gcontext - width - title-width - item-width - item-height - (geometry-changed-p t)) ;nil iff unchanged since displayed - - - -(defun create-menu (parent-window text-color background-color text-font) - (make-menu - ;; Create menu graphics context - :gcontext (CREATE-GCONTEXT :drawable parent-window - :foreground text-color - :background background-color - :font text-font) - ;; Create menu window - :window (CREATE-WINDOW - :parent parent-window - :class :input-output - :x 0 ;temporary value - :y 0 ;temporary value - :width 16 ;temporary value - :height 16 ;temporary value - :border-width 2 - :border text-color - :background background-color - :save-under :on - :override-redirect :on ;override window mgr when positioning - :event-mask (MAKE-EVENT-MASK :leave-window - :exposure)))) - - -(defun menu-set-item-list (menu &rest item-strings) - ;; Assume the new items will change the menu's width and height - (setf (menu-geometry-changed-p menu) t) - - ;; Destroy any existing item windows - (dolist (item (menu-item-alist menu)) - (DESTROY-WINDOW (first item))) - - ;; Add (item-window item-string) elements to item-alist - (setf (menu-item-alist menu) - (let (alist) - (dolist (item item-strings (nreverse alist)) - (push (list (CREATE-WINDOW - :parent (menu-window menu) - :x 0 ;temporary value - :y 0 ;temporary value - :width 16 ;temporary value - :height 16 ;temporary value - :background (GCONTEXT-BACKGROUND (menu-gcontext menu)) - :event-mask (MAKE-EVENT-MASK :enter-window - :leave-window - :button-press - :button-release)) - item) - alist))))) - -(defparameter *menu-item-margin* 4 - "Minimum number of pixels surrounding menu items.") - - -(defun menu-recompute-geometry (menu) - (when (menu-geometry-changed-p menu) - (let* ((menu-font (GCONTEXT-FONT (menu-gcontext menu))) - (title-width (TEXT-EXTENTS menu-font (menu-title menu))) - (item-height (+ (FONT-ASCENT menu-font) (FONT-DESCENT menu-font))) - (item-width 0) - (items (menu-item-alist menu)) - menu-width) - - ;; Find max item string width - (dolist (next-item items) - (setf item-width (max item-width - (TEXT-EXTENTS menu-font (second next-item))))) - - ;; Compute final menu width, taking margins into account - (setf menu-width (max title-width - (+ item-width *menu-item-margin* *menu-item-margin*))) - (let ((window (menu-window menu)) - (delta-y (+ item-height *menu-item-margin*))) - - ;; Update width and height of menu window - (WITH-STATE (window) - (setf (DRAWABLE-WIDTH window) menu-width - (DRAWABLE-HEIGHT window) (+ *menu-item-margin* - (* (1+ (length items)) - delta-y)))) - - ;; Update width, height, position of item windows - (let ((item-left (round (- menu-width item-width) 2)) - (next-item-top delta-y)) - (dolist (next-item items) - (let ((window (first next-item))) - (WITH-STATE (window) - (setf (DRAWABLE-HEIGHT window) item-height - (DRAWABLE-WIDTH window) item-width - (DRAWABLE-X window) item-left - (DRAWABLE-Y window) next-item-top))) - (incf next-item-top delta-y)))) - - ;; Map all item windows - (MAP-SUBWINDOWS (menu-window menu)) - - ;; Save item geometry - (setf (menu-item-width menu) item-width - (menu-item-height menu) item-height - (menu-width menu) menu-width - (menu-title-width menu) title-width - (menu-geometry-changed-p menu) nil)))) - - -(defun menu-refresh (menu) - (let* ((gcontext (menu-gcontext menu)) - (baseline-y (FONT-ASCENT (GCONTEXT-FONT gcontext)))) - - ;; Show title centered in "reverse-video" - (let ((fg (GCONTEXT-BACKGROUND gcontext)) - (bg (GCONTEXT-FOREGROUND gcontext))) - (WITH-GCONTEXT (gcontext :foreground fg :background bg) - (DRAW-IMAGE-GLYPHS - (menu-window menu) - gcontext - (round (- (menu-width menu) - (menu-title-width menu)) 2) ;start x - baseline-y ;start y - (menu-title menu)))) - - ;; Show each menu item (position is relative to item window) - (dolist (item (menu-item-alist menu)) - (DRAW-IMAGE-GLYPHS - (first item) gcontext - 0 ;start x - baseline-y ;start y - (second item))))) - - -(defun menu-choose (menu x y) - ;; Display the menu so that first item is at x,y. - (menu-present menu x y) - - (let ((items (menu-item-alist menu)) - (mw (menu-window menu)) - selected-item) - - ;; Event processing loop - (do () (selected-item) - (EVENT-CASE ((DRAWABLE-DISPLAY mw) :force-output-p t) - (:exposure (count) - - ;; Discard all but final :exposure then display the menu - (when (zerop count) (menu-refresh menu)) - t) - - (:button-release (event-window) - ;;Select an item - (setf selected-item (second (assoc event-window items))) - t) - - (:enter-notify (window) - ;;Highlight an item - (let ((position (position window items :key #'first))) - (when position - (menu-highlight-item menu position))) - t) - - (:leave-notify (window kind) - (if (eql mw window) - ;; Quit if pointer moved out of main menu window - (setf selected-item (when (eq kind :ancestor) :none)) - - ;; Otherwise, unhighlight the item window left - (let ((position (position window items :key #'first))) - (when position - (menu-unhighlight-item menu position)))) - t) - - (otherwise () - ;;Ignore and discard any other event - t))) - - ;; Erase the menu - (UNMAP-WINDOW mw) - - ;; Return selected item string, if any - (unless (eq selected-item :none) selected-item))) - - -(defun menu-highlight-item (menu position) - (let* ((box-margin (round *menu-item-margin* 2)) - (left (- (round (- (menu-width menu) (menu-item-width menu)) 2) - box-margin)) - (top (- (* (+ *menu-item-margin* (menu-item-height menu)) - (1+ position)) - box-margin)) - (width (+ (menu-item-width menu) box-margin box-margin)) - (height (+ (menu-item-height menu) box-margin box-margin))) - - ;; Draw a box in menu window around the given item. - (DRAW-RECTANGLE (menu-window menu) - (menu-gcontext menu) - left top - width height))) - -(defun menu-unhighlight-item (menu position) - ;; Draw a box in the menu background color - (let ((gcontext (menu-gcontext menu))) - (WITH-GCONTEXT (gcontext :foreground (gcontext-background gcontext)) - (menu-highlight-item menu position)))) - - -(defun menu-present (menu x y) - ;; Make sure menu geometry is up-to-date - (menu-recompute-geometry menu) - - ;; Try to center first item at the given location, but - ;; make sure menu is completely visible in its parent - (let ((menu-window (menu-window menu))) - (multiple-value-bind (tree parent) (QUERY-TREE menu-window) - (declare (ignore tree)) - (WITH-STATE (parent) - (let* ((parent-width (DRAWABLE-WIDTH parent)) - (parent-height (DRAWABLE-HEIGHT parent)) - (menu-height (+ *menu-item-margin* - (* (1+ (length (menu-item-alist menu))) - (+ (menu-item-height menu) *menu-item-margin*)))) - (menu-x (max 0 (min (- parent-width (menu-width menu)) - (- x (round (menu-width menu) 2))))) - (menu-y (max 0 (min (- parent-height menu-height) - (- y (round (menu-item-height menu) 2/3) - *menu-item-margin*))))) - (WITH-STATE (menu-window) - (setf (DRAWABLE-X menu-window) menu-x - (DRAWABLE-Y menu-window) menu-y))))) - - ;; Make menu visible - (MAP-WINDOW menu-window))) - -(defun just-say-lisp (&optional (font-name "fixed")) - (let* ((display (open-default-display)) - (screen (first (DISPLAY-ROOTS display))) - (fg-color (SCREEN-BLACK-PIXEL screen)) - (bg-color (SCREEN-WHITE-PIXEL screen)) - (nice-font (OPEN-FONT display font-name)) - (a-menu (create-menu (screen-root screen) ;the menu's parent - fg-color bg-color nice-font))) - - (setf (menu-title a-menu) "Please pick your favorite language:") - (menu-set-item-list a-menu "Fortran" "APL" "Forth" "Lisp") - - ;; Bedevil the user until he picks a nice programming language - (unwind-protect - (do (choice) - ((and (setf choice (menu-choose a-menu 100 100)) - (string-equal "Lisp" choice)))) - - (CLOSE-DISPLAY display)))) - - -(defun pop-up (host strings &key (title "Pick one:") (font "fixed")) - (let* ((display (OPEN-DISPLAY host)) - (screen (first (DISPLAY-ROOTS display))) - (fg-color (SCREEN-BLACK-PIXEL screen)) - (bg-color (SCREEN-WHITE-PIXEL screen)) - (font (OPEN-FONT display font)) - (parent-width 400) - (parent-height 400) - (parent (CREATE-WINDOW :parent (SCREEN-ROOT screen) - :override-redirect :on - :x 100 :y 100 - :width parent-width :height parent-height - :background bg-color - :event-mask (MAKE-EVENT-MASK :button-press - :exposure))) - (a-menu (create-menu parent fg-color bg-color font)) - (prompt "Press a button...") - (prompt-gc (CREATE-GCONTEXT :drawable parent - :foreground fg-color - :background bg-color - :font font)) - (prompt-y (FONT-ASCENT font)) - (ack-y (- parent-height (FONT-DESCENT font)))) - - (setf (menu-title a-menu) title) - (apply #'menu-set-item-list a-menu strings) - - ;; Present main window - (MAP-WINDOW parent) - - (flet ((display-centered-text - (window string gcontext height width) - (multiple-value-bind (w a d l r fa fd) (text-extents gcontext string) - (declare (ignore a d l r)) - (let ((box-height (+ fa fd))) - - ;; Clear previous text - (CLEAR-AREA window - :x 0 :y (- height fa) - :width width :height box-height) - - ;; Draw new text - (DRAW-IMAGE-GLYPHS window gcontext (round (- width w) 2) height string))))) - - (unwind-protect - (loop - (EVENT-CASE (display :force-output-p t) - - (:exposure (count) - - ;; Display prompt - (when (zerop count) - (display-centered-text - parent - prompt - prompt-gc - prompt-y - parent-width)) - t) - - (:button-press (x y) - - ;; Pop up the menu - (let ((choice (menu-choose a-menu x y))) - (if choice - (display-centered-text - parent - (format nil "You have selected ~a." choice) - prompt-gc - ack-y - parent-width) - - (display-centered-text - parent - "No selection...try again." - prompt-gc - ack-y - parent-width))) - t) - - (otherwise () - ;;Ignore and discard any other event - t))) - - (CLOSE-DISPLAY display))))) - diff -Nru ecl-16.1.2/src/clx/demo/zoid.lisp ecl-16.1.3+ds/src/clx/demo/zoid.lisp --- ecl-16.1.2/src/clx/demo/zoid.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/demo/zoid.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,58 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- - -;;; CLX interface for Trapezoid Extension. - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(export '(draw-filled-trapezoids - gcontext-trapezoid-alignment ;; Setf'able - )) - -(define-extension "ZoidExtension") - -(defun draw-filled-trapezoids (drawable gcontext points) - ;; Draw trapezoids on drawable using gcontext. - ;; Points are a list of either (y1 y2 y3 y4 x1 x2) ;; x-aligned - ;; or (x1 x2 x3 x4 y1 y2) ;; y-aligned - ;; Alignment is determined by the GCONTEXT [see gcontext-trapezoid-alignment] - ;; Alignment is set with the ALIGNMENT keyword argument, which may be - ;; :X, :Y, or NIL (use previous alignment) - (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence points)) - (let* ((display (drawable-display drawable)) - (opcode (extension-opcode display "ZoidExtension"))) - (with-buffer-request (display opcode :gc-force gcontext) - ((data card8) 1) ;; X_PolyFillZoid - (drawable drawable) - (gcontext gcontext) - ((sequence :format int16) points)))) - -(define-gcontext-accessor trapezoid-alignment :default :x - :set-function set-trapezoid-alignment) - -(defun set-trapezoid-alignment (gcontext alignment) - (declare (type (member :x :y) alignment)) - (let* ((display (gcontext-display gcontext)) - (opcode (extension-opcode display "ZoidExtension"))) - (with-buffer-request (display opcode) - ((data card8) 2) ;; X_SetZoidAlignment - (gcontext gcontext) - ((member8 %error :x :y) alignment)))) - diff -Nru ecl-16.1.2/src/clx/dep-allegro.lisp ecl-16.1.3+ds/src/clx/dep-allegro.lisp --- ecl-16.1.2/src/clx/dep-allegro.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/dep-allegro.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,2210 +0,0 @@ -;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- - -;; This file contains some of the system dependent code for CLX - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(proclaim '(declaration array-register)) - -;;; The size of the output buffer. Must be a multiple of 4. -(defparameter *output-buffer-size* 8192) - -;;; Number of seconds to wait for a reply to a server request -(defparameter *reply-timeout* nil) - -#-(or clx-overlapping-arrays (not clx-little-endian)) -(progn - (defconstant +word-0+ 0) - (defconstant +word-1+ 1) - - (defconstant +long-0+ 0) - (defconstant +long-1+ 1) - (defconstant +long-2+ 2) - (defconstant +long-3+ 3)) - -#-(or clx-overlapping-arrays clx-little-endian) -(progn - (defconstant +word-0+ 1) - (defconstant +word-1+ 0) - - (defconstant +long-0+ 3) - (defconstant +long-1+ 2) - (defconstant +long-2+ 1) - (defconstant +long-3+ 0)) - -;;; Set some compiler-options for often used code - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +buffer-speed+ #+clx-debugging 1 #-clx-debugging 3 - "Speed compiler option for buffer code.") - (defconstant +buffer-safety+ #+clx-debugging 3 #-clx-debugging 0 - "Safety compiler option for buffer code.") - (defconstant +buffer-debug+ #+clx-debugging 2 #-clx-debugging 1 - "Debug compiler option for buffer code>") - (defun declare-bufmac () - `(declare (optimize - (speed ,+buffer-speed+) - (safety ,+buffer-safety+) - (debug ,+buffer-debug+)))) - ;; It's my impression that in lucid there's some way to make a - ;; declaration called fast-entry or something that causes a function - ;; to not do some checking on args. Sadly, we have no lucid manuals - ;; here. If such a declaration is available, it would be a good - ;; idea to make it here when +buffer-speed+ is 3 and +buffer-safety+ - ;; is 0. - (defun declare-buffun () - `(declare (optimize - (speed ,+buffer-speed+) - (safety ,+buffer-safety+) - (debug ,+buffer-debug+))))) - -(declaim (inline card8->int8 int8->card8 - card16->int16 int16->card16 - card32->int32 int32->card32)) - -#-Genera -(progn - -(defun card8->int8 (x) - (declare (type card8 x)) - (declare (clx-values int8)) - #.(declare-buffun) - (the int8 (if (logbitp 7 x) - (the int8 (- x #x100)) - x))) - -(defun int8->card8 (x) - (declare (type int8 x)) - (declare (clx-values card8)) - #.(declare-buffun) - (the card8 (ldb (byte 8 0) x))) - -(defun card16->int16 (x) - (declare (type card16 x)) - (declare (clx-values int16)) - #.(declare-buffun) - (the int16 (if (logbitp 15 x) - (the int16 (- x #x10000)) - x))) - -(defun int16->card16 (x) - (declare (type int16 x)) - (declare (clx-values card16)) - #.(declare-buffun) - (the card16 (ldb (byte 16 0) x))) - -(defun card32->int32 (x) - (declare (type card32 x)) - (declare (clx-values int32)) - #.(declare-buffun) - (the int32 (if (logbitp 31 x) - (the int32 (- x #x100000000)) - x))) - -(defun int32->card32 (x) - (declare (type int32 x)) - (declare (clx-values card32)) - #.(declare-buffun) - (the card32 (ldb (byte 32 0) x))) - -) - -(declaim (inline aref-card8 aset-card8 aref-int8 aset-int8)) - -#+(or excl lcl3.0 clx-overlapping-arrays) -(declaim (inline aref-card16 aref-int16 aref-card32 aref-int32 aref-card29 - aset-card16 aset-int16 aset-card32 aset-int32 aset-card29)) - -#+(and clx-overlapping-arrays (not Genera)) -(progn - -(defun aref-card16 (a i) - (aref a i)) - -(defun aset-card16 (v a i) - (setf (aref a i) v)) - -(defun aref-int16 (a i) - (card16->int16 (aref a i))) - -(defun aset-int16 (v a i) - (setf (aref a i) (int16->card16 v)) - v) - -(defun aref-card32 (a i) - (aref a i)) - -(defun aset-card32 (v a i) - (setf (aref a i) v)) - -(defun aref-int32 (a i) - (card32->int32 (aref a i))) - -(defun aset-int32 (v a i) - (setf (aref a i) (int32->card32 v)) - v) - -(defun aref-card29 (a i) - (aref a i)) - -(defun aset-card29 (v a i) - (setf (aref a i) v)) - -) - -#+excl -(progn - -(defun aref-card8 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card8)) - #.(declare-buffun) - (the card8 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :unsigned-byte))) - -(defun aset-card8 (v a i) - (declare (type card8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :unsigned-byte) v)) - -(defun aref-int8 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int8)) - #.(declare-buffun) - (the int8 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :signed-byte))) - -(defun aset-int8 (v a i) - (declare (type int8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :signed-byte) v)) - -(defun aref-card16 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card16)) - #.(declare-buffun) - (the card16 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :unsigned-word))) - -(defun aset-card16 (v a i) - (declare (type card16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :unsigned-word) v)) - -(defun aref-int16 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int16)) - #.(declare-buffun) - (the int16 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :signed-word))) - -(defun aset-int16 (v a i) - (declare (type int16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :signed-word) v)) - -(defun aref-card32 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card32)) - #.(declare-buffun) - (the card32 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :unsigned-long))) - -(defun aset-card32 (v a i) - (declare (type card32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :unsigned-long) v)) - -(defun aref-int32 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int32)) - #.(declare-buffun) - (the int32 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :signed-long))) - -(defun aset-int32 (v a i) - (declare (type int32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :signed-long) v)) - -(defun aref-card29 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card29)) - #.(declare-buffun) - (the card29 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :unsigned-long))) - -(defun aset-card29 (v a i) - (declare (type card29 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :unsigned-long) v)) - -) - -(defsetf aref-card8 (a i) (v) - `(aset-card8 ,v ,a ,i)) - -(defsetf aref-int8 (a i) (v) - `(aset-int8 ,v ,a ,i)) - -(defsetf aref-card16 (a i) (v) - `(aset-card16 ,v ,a ,i)) - -(defsetf aref-int16 (a i) (v) - `(aset-int16 ,v ,a ,i)) - -(defsetf aref-card32 (a i) (v) - `(aset-card32 ,v ,a ,i)) - -(defsetf aref-int32 (a i) (v) - `(aset-int32 ,v ,a ,i)) - -(defsetf aref-card29 (a i) (v) - `(aset-card29 ,v ,a ,i)) - -;;; Other random conversions - -(defun rgb-val->card16 (value) - ;; Short floats are good enough - (declare (type rgb-val value)) - (declare (clx-values card16)) - #.(declare-buffun) - ;; Convert VALUE from float to card16 - (the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff))))) - -(defun card16->rgb-val (value) - ;; Short floats are good enough - (declare (type card16 value)) - (declare (clx-values short-float)) - #.(declare-buffun) - ;; Convert VALUE from card16 to float - (the short-float (* (the card16 value) #.(/ 1.0s0 #xffff)))) - -(defun radians->int16 (value) - ;; Short floats are good enough - (declare (type angle value)) - (declare (clx-values int16)) - #.(declare-buffun) - (the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0))))) - -(defun int16->radians (value) - ;; Short floats are good enough - (declare (type int16 value)) - (declare (clx-values short-float)) - #.(declare-buffun) - (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float)))) - - -#+(or cmu sbcl) (progn - -;;; This overrides the (probably incorrect) definition in clx.lisp. Since PI -;;; is irrational, there can't be a precise rational representation. In -;;; particular, the different float approximations will always be /=. This -;;; causes problems with type checking, because people might compute an -;;; argument in any precision. What we do is discard all the excess precision -;;; in the value, and see if the protocol encoding falls in the desired range -;;; (64'ths of a degree.) -;;; -(deftype angle () '(satisfies anglep)) - -(defun anglep (x) - (and (typep x 'real) - (<= (* -360 64) (radians->int16 x) (* 360 64)))) - -) - - -;;----------------------------------------------------------------------------- -;; Character transformation -;;----------------------------------------------------------------------------- - - -;;; This stuff transforms chars to ascii codes in card8's and back. -;;; You might have to hack it a little to get it to work for your machine. - -(declaim (inline char->card8 card8->char)) - -(macrolet ((char-translators () - (let ((alist - `(#-lispm - ;; The normal ascii codes for the control characters. - ,@`((#\Return . 13) - (#\Linefeed . 10) - (#\Rubout . 127) - (#\Page . 12) - (#\Tab . 9) - (#\Backspace . 8) - (#\Newline . 10) - (#\Space . 32)) - ;; One the lispm, #\Newline is #\Return, but we'd really like - ;; #\Newline to translate to ascii code 10, so we swap the - ;; Ascii codes for #\Return and #\Linefeed. We also provide - ;; mappings from the counterparts of these control characters - ;; so that the character mapping from the lisp machine - ;; character set to ascii is invertible. - #+lispm - ,@`((#\Return . 10) (,(code-char 10) . ,(char-code #\Return)) - (#\Linefeed . 13) (,(code-char 13) . ,(char-code #\Linefeed)) - (#\Rubout . 127) (,(code-char 127) . ,(char-code #\Rubout)) - (#\Page . 12) (,(code-char 12) . ,(char-code #\Page)) - (#\Tab . 9) (,(code-char 9) . ,(char-code #\Tab)) - (#\Backspace . 8) (,(code-char 8) . ,(char-code #\Backspace)) - (#\Newline . 10) (,(code-char 10) . ,(char-code #\Newline)) - (#\Space . 32) (,(code-char 32) . ,(char-code #\Space))) - ;; The rest of the common lisp charater set with the normal - ;; ascii codes for them. - (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36) - (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40) - (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44) - (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48) - (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52) - (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56) - (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60) - (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64) - (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68) - (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72) - (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76) - (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80) - (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84) - (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88) - (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92) - (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96) - (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100) - (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104) - (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108) - (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112) - (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116) - (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120) - (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124) - (#\} . 125) (#\~ . 126)))) - (cond ((dolist (pair alist nil) - (when (not (= (char-code (car pair)) (cdr pair))) - (return t))) - `(progn - (defconstant *char-to-card8-translation-table* - ',(let ((array (make-array - (let ((max-char-code 255)) - (dolist (pair alist) - (setq max-char-code - (max max-char-code - (char-code (car pair))))) - (1+ max-char-code)) - :element-type 'card8))) - (dotimes (i (length array)) - (setf (aref array i) (mod i 256))) - (dolist (pair alist) - (setf (aref array (char-code (car pair))) - (cdr pair))) - array)) - (defconstant *card8-to-char-translation-table* - ',(let ((array (make-array 256))) - (dotimes (i (length array)) - (setf (aref array i) (code-char i))) - (dolist (pair alist) - (setf (aref array (cdr pair)) (car pair))) - array)) - #-Genera - (progn - (defun char->card8 (char) - (declare (type base-char char)) - #.(declare-buffun) - (the card8 (aref (the (simple-array card8 (*)) - *char-to-card8-translation-table*) - (the array-index (char-code char))))) - (defun card8->char (card8) - (declare (type card8 card8)) - #.(declare-buffun) - (the base-char - (or (aref (the simple-vector *card8-to-char-translation-table*) - card8) - (error "Invalid CHAR code ~D." card8)))) - ) - #+Genera - (progn - (defun char->card8 (char) - (declare lt:(side-effects reader reducible)) - (aref *char-to-card8-translation-table* (char-code char))) - (defun card8->char (card8) - (declare lt:(side-effects reader reducible)) - (aref *card8-to-char-translation-table* card8)) - ) - #-Minima - (dotimes (i 256) - (unless (= i (char->card8 (card8->char i))) - (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S" - (list i - (card8->char i) - (char->card8 (card8->char i)))) - (return nil))) - #-Minima - (dotimes (i (length *char-to-card8-translation-table*)) - (let ((char (code-char i))) - (unless (eql char (card8->char (char->card8 char))) - (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S" - (list char - (char->card8 char) - (card8->char (char->card8 char)))) - (return nil)))))) - (t - `(progn - (defun char->card8 (char) - (declare (type base-char char)) - #.(declare-buffun) - (the card8 (char-code char))) - (defun card8->char (card8) - (declare (type card8 card8)) - #.(declare-buffun) - (the base-char (code-char card8))) - )))))) - (char-translators)) - -;;----------------------------------------------------------------------------- -;; Process Locking -;; -;; Common-Lisp doesn't provide process locking primitives, so we define -;; our own here, based on Zetalisp primitives. Holding-Lock is very -;; similar to with-lock on The TI Explorer, and a little more efficient -;; than with-process-lock on a Symbolics. -;;----------------------------------------------------------------------------- - -;;; MAKE-PROCESS-LOCK: Creating a process lock. - -#+excl -(defun make-process-lock (name) - (mp:make-process-lock :name name)) - -;;; HOLDING-LOCK: Execute a body of code with a lock held. - -;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN -;;; passes its timeout to the holding-lock macro, so any timeout you want to -;;; work for event-listen you should do for holding-lock. - -;; If you're not sharing DISPLAY objects within a multi-processing -;; shared-memory environment, this is sufficient - -;;; HOLDING-LOCK for CMU Common Lisp. -;;; -;;; We are not multi-processing, but we use this macro to try to protect -;;; against re-entering request functions. This can happen if an interrupt -;;; occurs and the handler attempts to use X over the same display connection. -;;; This can happen if the GC hooks are used to notify the user over the same -;;; display connection. We inhibit GC notifications since display of them -;;; could cause recursive entry into CLX. -;;; - -;;; HOLDING-LOCK for CMU Common Lisp with multi-processes. -;;; -#+excl -(defmacro holding-lock ((locator display &optional whostate &key timeout) - &body body) - (declare (ignore display)) - `(let (.hl-lock. .hl-obtained-lock. .hl-curproc.) - (unwind-protect - (block .hl-doit. - (when (sys:scheduler-running-p) ; fast test for scheduler running - (setq .hl-lock. ,locator - .hl-curproc. mp::*current-process*) - (when (and .hl-curproc. ; nil if in process-wait fun - (not (eq (mp::process-lock-locker .hl-lock.) - .hl-curproc.))) - ;; Then we need to grab the lock. - ,(if timeout - `(if (not (mp::process-lock .hl-lock. .hl-curproc. - ,whostate ,timeout)) - (return-from .hl-doit. nil)) - `(mp::process-lock .hl-lock. .hl-curproc. - ,@(when whostate `(,whostate)))) - ;; There is an apparent race condition here. However, there is - ;; no actual race condition -- our implementation of mp:process- - ;; lock guarantees that the lock will still be held when it - ;; returns, and no interrupt can happen between that and the - ;; execution of the next form. -- jdi 2/27/91 - (setq .hl-obtained-lock. t))) - ,@body) - (if (and .hl-obtained-lock. - ;; Note -- next form added to allow error handler inside - ;; body to unlock the lock prematurely if it knows that - ;; the current process cannot possibly continue but will - ;; throw out (or is it throw up?). - (eq (mp::process-lock-locker .hl-lock.) .hl-curproc.)) - (mp::process-unlock .hl-lock. .hl-curproc.))))) - -;;; WITHOUT-ABORTS - -;;; If you can inhibit asynchronous keyboard aborts inside the body of this -;;; macro, then it is a good idea to do this. This macro is wrapped around -;;; request writing and reply reading to ensure that requests are atomically -;;; written and replies are atomically read from the stream. - -#+excl -(defmacro without-aborts (&body body) - `(without-interrupts ,@body)) - -;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value. -;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's -;;; value changes. - -#+excl -(defun process-block (whostate predicate &rest predicate-args) - (if (sys:scheduler-running-p) - (apply #'mp::process-wait whostate predicate predicate-args) - (or (apply predicate predicate-args) - (error "Program tried to wait with no scheduler.")))) - -;;; PROCESS-WAKEUP: Check some other process' wait function. - -(declaim (inline process-wakeup)) - -#+excl -(defun process-wakeup (process) - (let ((curproc mp::*current-process*)) - (when (and curproc process) - (unless (mp::process-p curproc) - (error "~s is not a process" curproc)) - (unless (mp::process-p process) - (error "~s is not a process" process)) - (if (> (mp::process-priority process) (mp::process-priority curproc)) - (mp::process-allow-schedule process))))) - - -;;; CURRENT-PROCESS: Return the current process object for input locking and -;;; for calling PROCESS-WAKEUP. - -(declaim (inline current-process)) - -;;; Default return NIL, which is acceptable even if there is a scheduler. - -#+excl -(defun current-process () - (and (sys:scheduler-running-p) - mp::*current-process*)) - -;;; WITHOUT-INTERRUPTS -- provide for atomic operations. - -;;; CONDITIONAL-STORE: - -;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times. -;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD. -#-sbcl -(defmacro conditional-store (place old-value new-value) - `(without-interrupts - (cond ((eq ,place ,old-value) - (setf ,place ,new-value) - t)))) - -;;;---------------------------------------------------------------------------- -;;; IO Error Recovery -;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro. -;;; It prevents multiple mindless errors when the network craters. -;;; -;;;---------------------------------------------------------------------------- - -#-Genera -(defmacro wrap-buf-output ((buffer) &body body) - ;; Error recovery wrapper - `(unless (buffer-dead ,buffer) - ,@body)) - -#-Genera -(defmacro wrap-buf-input ((buffer) &body body) - (declare (ignore buffer)) - ;; Error recovery wrapper - `(progn ,@body)) - - -;;;---------------------------------------------------------------------------- -;;; System dependent IO primitives -;;; Functions for opening, reading writing forcing-output and closing -;;; the stream to the server. -;;;---------------------------------------------------------------------------- - -;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X -;;; server - - -;; -;; Note that since we don't use the CL i/o facilities to do i/o, the display -;; input and output "stream" is really a file descriptor (fixnum). -;; -#+excl -(defun open-x-stream (host display protocol) - (declare (ignore protocol)) ;; assume TCP - (let ((stream (socket:make-socket :remote-host (string host) - :remote-port (+ *x-tcp-port* display) - :format :binary))) - (if (streamp stream) - stream - (error "Cannot connect to server: ~A:~D" host display)))) - - -;;; BUFFER-READ-DEFAULT - read data from the X stream - - -;; -;; Rewritten 10/89 to not use foreign function interface to do I/O. -;; -#+excl -(defun buffer-read-default (display vector start end timeout) - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null (real 0 *)) timeout)) - #.(declare-buffun) - - (let* ((howmany (- end start)) - (fd (display-input-stream display))) - (declare (type array-index howmany)) - (or (cond ((fd-char-avail-p fd) nil) - ((and timeout (= timeout 0)) :timeout) - ((buffer-input-wait-default display timeout))) - (fd-read-bytes fd vector start howmany)))) - - -;;; WARNING: -;;; CLX performance will suffer if your lisp uses read-byte for -;;; receiving all data from the X Window System server. -;;; You are encouraged to write a specialized version of -;;; buffer-read-default that does block transfers. - - -;;; BUFFER-WRITE-DEFAULT - write data to the X stream - -#+excl -(defun buffer-write-default (vector display start end) - (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) - #.(declare-buffun) - (let ((stream (display-output-stream display))) - (unless (null stream) - (write-sequence vector stream :start start :end end))) - ) - -;;; WARNING: -;;; CLX performance will be severely degraded if your lisp uses -;;; write-byte to send all data to the X Window System server. -;;; You are STRONGLY encouraged to write a specialized version -;;; of buffer-write-default that does block transfers. - -;;; buffer-force-output-default - force output to the X stream - -#+excl -(defun buffer-force-output-default (display) - ;; The default buffer force-output function for use with common-lisp streams - (declare (type display display)) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (force-output stream)))) - - -;;; BUFFER-CLOSE-DEFAULT - close the X stream - -#+excl -(defun buffer-close-default (display &key abort) - ;; The default buffer close function for use with common-lisp streams - (declare (type display display)) - #.(declare-buffun) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (close stream :abort abort)))) - - -;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the -;;; buffer. This is called in read-input between requests, so that a process -;;; waiting for input is abortable when between requests. Should return -;;; :TIMEOUT if it times out, NIL otherwise. - -;;; The default implementation - - -;; -;; This is used so an 'eq' test may be used to find out whether or not we can -;; safely throw this process out of the CLX read loop. -;; -#+excl -(defparameter *read-whostate* "waiting for input from X server") - -;; -;; Note that this function returns nil on error if the scheduler is running, -;; t on error if not. This is ok since buffer-read will detect the error. -;; -#+excl -(defun buffer-input-wait-default (display timeout) - (declare (type display display) - (type (or null (real 0 *)) timeout)) - (declare (clx-values timeout)) - (let ((fd (display-input-stream display))) - (when (streamp fd) - (cond ((fd-char-avail-p fd) - nil) - - ;; Otherwise no bytes were available on the socket - ((and timeout (= timeout 0)) - ;; If there aren't enough and timeout == 0, timeout. - :timeout) - - ;; If the scheduler is running let it do timeouts. - ((sys:scheduler-running-p) - (if (not - (mp:wait-for-input-available fd :whostate *read-whostate* - :wait-function #'fd-char-avail-p - :timeout timeout)) - (return-from buffer-input-wait-default :timeout)) - ) - - ;; Otherwise we have to handle timeouts by hand, and call select() - ;; to block until input is available. Note we don't really handle - ;; the interaction of interrupts and (numberp timeout) here. XX - (t - #+mswindows - (error "scheduler must be running to use CLX on MS Windows") - #-mswindows - (let ((res 0)) - (declare (fixnum res)) - (with-interrupt-checking-on - (loop - (setq res (fd-wait-for-input fd (if (null timeout) 0 - (truncate timeout)))) - (cond ((plusp res) ; success - (return nil)) - ((eq res 0) ; timeout - (return :timeout)) - ((eq res -1) ; error - (return t)) - ;; Otherwise we got an interrupt -- go around again. - ))))))))) - - -;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the -;;; buffer. This should never block, so it can be called from the scheduler. - -;;; The default implementation is to just use listen. -#+excl -#+(and excl clx-use-allegro-streams) -(defun buffer-listen-default (display) - (declare (type display display)) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (if (null stream) - t - (listen stream)))) - -#+(and excl (not clx-use-allegro-streams)) -(defun buffer-listen-default (display) - (declare (type display display)) - (let ((fd (display-input-stream display))) - (declare (type fixnum fd)) - (if (= fd -1) - t - (fd-char-avail-p fd)))) - - -;;;---------------------------------------------------------------------------- -;;; System dependent speed hacks -;;;---------------------------------------------------------------------------- - -;; -;; WITH-STACK-LIST is used by WITH-STATE as a memory saving feature. -;; If your lisp doesn't have stack-lists, and you're worried about -;; consing garbage, you may want to re-write this to allocate and -;; initialize lists from a resource. -;; -#-lispm -(defmacro with-stack-list ((var &rest elements) &body body) - ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body) - ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body) - ;; except that the list produced by MAPCAR resides on the stack and - ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. - `(let ((,var (list ,@elements))) - (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) - ,@body)) - -#-lispm -(defmacro with-stack-list* ((var &rest elements) &body body) - ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body) - ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body) - ;; except that the list produced by MAPCAR resides on the stack and - ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. - `(let ((,var (list* ,@elements))) - (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) - ,@body)) - -(declaim (inline buffer-replace)) - -#+excl -(defun buffer-replace (target-sequence source-sequence target-start - target-end &optional (source-start 0)) - (declare (type buffer-bytes target-sequence source-sequence) - (type array-index target-start target-end source-start) - (optimize (speed 3) (safety 0))) - - (let ((source-end (length source-sequence))) - (declare (type array-index source-end)) - - (excl:if* (and (eq target-sequence source-sequence) - (> target-start source-start)) - then (let ((nelts (min (- target-end target-start) - (- source-end source-start)))) - (do ((target-index (+ target-start nelts -1) (1- target-index)) - (source-index (+ source-start nelts -1) (1- source-index))) - ((= target-index (1- target-start)) target-sequence) - (declare (type array-index target-index source-index)) - - (setf (aref target-sequence target-index) - (aref source-sequence source-index)))) - else (do ((target-index target-start (1+ target-index)) - (source-index source-start (1+ source-index))) - ((or (= target-index target-end) (= source-index source-end)) - target-sequence) - (declare (type array-index target-index source-index)) - - (setf (aref target-sequence target-index) - (aref source-sequence source-index)))))) - -#-lispm -(defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) - &body body) - (let ((local-state (gensym)) - (resets nil)) - (dolist (index indexes) - (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index)) - resets)) - `(unwind-protect - (progn - ,@body) - (let ((,local-state (gcontext-local-state ,gc))) - (declare (type gcontext-state ,local-state)) - ,@resets - (setf (svref ,local-state ,ts-index) 0)) - (when ,temp-gc - (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) - (deallocate-gcontext-state ,saved-state)))) - -;;;---------------------------------------------------------------------------- -;;; How much error detection should CLX do? -;;; Several levels are possible: -;;; -;;; 1. Do the equivalent of check-type on every argument. -;;; -;;; 2. Simply report TYPE-ERROR. This eliminates overhead of all the format -;;; strings generated by check-type. -;;; -;;; 3. Do error checking only on arguments that are likely to have errors -;;; (like keyword names) -;;; -;;; 4. Do error checking only where not doing so may dammage the envirnment -;;; on a non-tagged machine (i.e. when storing into a structure that has -;;; been passed in) -;;; -;;; 5. No extra error detection code. On lispm's, ASET may barf trying to -;;; store a non-integer into a number array. -;;; -;;; How extensive should the error checking be? For example, if the server -;;; expects a CARD16, is is sufficient for CLX to check for integer, or -;;; should it also check for non-negative and less than 65536? -;;;---------------------------------------------------------------------------- - -;; The +TYPE-CHECK?+ constant controls how much error checking is done. -;; Possible values are: -;; NIL - Don't do any error checking -;; t - Do the equivalent of checktype on every argument -;; :minimal - Do error checking only where errors are likely - -;;; This controls macro expansion, and isn't changable at run-time You will -;;; probably want to set this to nil if you want good performance at -;;; production time. -(defconstant +type-check?+ - #+(or Genera Minima CMU sbcl) nil - #-(or Genera Minima CMU sbcl) t) - -;; TYPE? is used to allow the code to do error checking at a different level from -;; the declarations. It also does some optimizations for systems that don't have -;; good compiler support for TYPEP. The definitions for CARD32, CARD16, INT16, etc. -;; include range checks. You can modify TYPE? to do less extensive checking -;; for these types if you desire. - -;; -;; ### This comment is a lie! TYPE? is really also used for run-time type -;; dispatching, not just type checking. -- Ram. - -(defmacro type? (object type) - #+(or cmu sbcl) - `(typep ,object ,type) - #-(or cmu sbcl) - (if (not (constantp type)) - `(typep ,object ,type) - (progn - (setq type (eval type)) - #+(or Genera explorer Minima) - (if +type-check?+ - `(locally (declare (optimize safety)) (typep ,object ',type)) - `(typep ,object ',type)) - #-(or Genera explorer Minima) - (let ((predicate (assoc type - '((drawable drawable-p) (window window-p) - (pixmap pixmap-p) (cursor cursor-p) - (font font-p) (gcontext gcontext-p) - (colormap colormap-p) (null null) - (integer integerp))))) - (cond (predicate - `(,(second predicate) ,object)) - ((eq type 'generalized-boolean) - 't) ; Everything is a generalized-boolean. - (+type-check?+ - `(locally (declare (optimize safety)) (typep ,object ',type))) - (t - `(typep ,object ',type))))))) - -;; X-TYPE-ERROR is the function called for type errors. -;; If you want lots of checking, but are concerned about code size, -;; this can be made into a macro that ignores some parameters. - -(defun x-type-error (object type &optional error-string) - (x-error 'x-type-error - :datum object - :expected-type type - :type-string error-string)) - - -;;----------------------------------------------------------------------------- -;; Error handlers -;; Hack up KMP error signaling using zetalisp until the real thing comes -;; along -;;----------------------------------------------------------------------------- - -(defun default-error-handler (display error-key &rest key-vals - &key asynchronous &allow-other-keys) - (declare (type generalized-boolean asynchronous) - (dynamic-extent key-vals)) - ;; The default display-error-handler. - ;; It signals the conditions listed in the DISPLAY file. - (if asynchronous - (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals) - (apply #'x-error error-key :display display :error-key error-key key-vals))) - -#+(or clx-ansi-common-lisp excl lcl3.0 (and CMU mp)) -(defun x-error (condition &rest keyargs) - (declare (dynamic-extent keyargs)) - (apply #'error condition keyargs)) - -#+(or clx-ansi-common-lisp excl lcl3.0 CMU) -(defun x-cerror (proceed-format-string condition &rest keyargs) - (declare (dynamic-extent keyargs)) - (apply #'cerror proceed-format-string condition keyargs)) - -;;; X-ERROR for CMU Common Lisp -;;; -;;; We detect a couple condition types for which we disable event handling in -;;; our system. This prevents going into the debugger or returning to a -;;; command prompt with CLX repeatedly seeing the same condition. This occurs -;;; because CMU Common Lisp provides for all events (that is, X, input on file -;;; descriptors, Mach messages, etc.) to come through one routine anyone can -;;; use to wait for input. -;;; -#+(and CMU (not mp)) -(defun x-error (condition &rest keyargs) - (let ((condx (apply #'make-condition condition keyargs))) - (when (eq condition 'closed-display) - (let ((disp (closed-display-display condx))) - (warn "Disabled event handling on ~S." disp) - (ext::disable-clx-event-handling disp))) - (error condx))) - -#-(or lispm ansi-common-lisp excl lcl3.0 CMU sbcl) -(defun x-error (condition &rest keyargs) - (error "X-Error: ~a" - (princ-to-string (apply #'make-condition condition keyargs)))) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl) -(defun x-cerror (proceed-format-string condition &rest keyargs) - (cerror proceed-format-string "X-Error: ~a" - (princ-to-string (apply #'make-condition condition keyargs)))) - -;; version 15 of Pitman error handling defines the syntax for define-condition to be: -;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*] -;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string) -;; or (:report exp) - -#+(and excl (not clx-ansi-common-lisp)) -(defmacro define-condition (name parent-types &optional slots &rest args) - `(excl::define-condition - ,name (,(first parent-types)) - ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - slots) - ,@args)) - -#+(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl) -(define-condition x-error (error) ()) - - - -;;----------------------------------------------------------------------------- -;; HOST hacking -;;----------------------------------------------------------------------------- - -#+(and allegro-version>= (version>= 5 0)) -(eval-when (compile eval load) - #+(version>= 6 0) - (progn - (require :sock) - #-(version>= 7 0) - (require :gray-compat)) - #-(version>= 6 0) - (require :sock)) - -#+(and allegro-version>= (version>= 5 0)) -(defun host-address (host &optional (family :internet)) - (ecase family - (:internet - (cons :internet - (multiple-value-list - (socket::ipaddr-to-dotted (socket::lookup-hostname host) - :values t)))))) - -#+(and allegro-version>= (not (version>= 5 0))) -(defun host-address (host &optional (family :internet)) - ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - (labels ((no-host-error () - (error "Unknown host ~S" host)) - (no-address-error () - (error "Host ~S has no ~S address" host family))) - (let ((hostent 0)) - (unwind-protect - (progn - (setf hostent (ipc::gethostbyname (string host))) - (when (zerop hostent) - (no-host-error)) - (ecase family - ((:internet nil 0) - (unless (= (ipc::hostent-addrtype hostent) 2) - (no-address-error)) - (assert (= (ipc::hostent-length hostent) 4)) - (let ((addr (ipc::hostent-addr hostent))) - (when (or (member comp::.target. - '(:hp :sgi4d :sony :dec3100) - :test #'eq) - (probe-file "/lib/ld.so")) - ;; BSD 4.3 based systems require an extra indirection - (setq addr (si:memref-int addr 0 0 :unsigned-long))) - (list :internet - (si:memref-int addr 0 0 :unsigned-byte) - (si:memref-int addr 1 0 :unsigned-byte) - (si:memref-int addr 2 0 :unsigned-byte) - (si:memref-int addr 3 0 :unsigned-byte)))))) - (ff:free-cstruct hostent))))) - - -;;----------------------------------------------------------------------------- -;; Whether to use closures for requests or not. -;;----------------------------------------------------------------------------- - -;;; If this macro expands to non-NIL, then request and locking code is -;;; compiled in a much more compact format, as the common code is shared, and -;;; the specific code is built into a closure that is funcalled by the shared -;;; code. If your compiler makes efficient use of closures then you probably -;;; want to make this expand to T, as it makes the code more compact. - -(defmacro use-closures () - #+(or lispm Minima) t - #-(or lispm Minima) nil) - -#-(or Genera Minima) -(defun clx-macroexpand (form env) - (macroexpand form env)) - - -;;----------------------------------------------------------------------------- -;; Resource stuff -;;----------------------------------------------------------------------------- - - -;;; Utilities - -(defun getenv (name) - #+excl (sys:getenv name) - ) - -(defun get-host-name () - "Return the same hostname as gethostname(3) would" - ;; resources-pathname was using short-site-name for this purpose - #+excl (short-site-name) - ) - -(defun homedir-file-pathname (name) - (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal) - (merge-pathnames (user-homedir-pathname) (pathname name)))) - -;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if -;;; a resource manager isn't running. - -(defun default-resources-pathname () - (homedir-file-pathname ".Xdefaults")) - -;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the -;;; defaults have been loaded. - -(defun resources-pathname () - (or (let ((string (getenv "XENVIRONMENT"))) - (and string - (pathname string))) - (homedir-file-pathname - (concatenate 'string ".Xdefaults-" (get-host-name))))) - -;;; AUTHORITY-PATHNAME - The pathname of the authority file. - -(defun authority-pathname () - (or (let ((xauthority (getenv "XAUTHORITY"))) - (and xauthority - (pathname xauthority))) - (homedir-file-pathname ".Xauthority"))) - -;;; this particular defaulting behaviour is typical to most Unices, I think -#+unix -(defun get-default-display (&optional display-name) - "Parse the argument DISPLAY-NAME, or the environment variable $DISPLAY -if it is NIL. Display names have the format - - [protocol/] [hostname] : [:] displaynumber [.screennumber] - -There are two special cases in parsing, to match that done in the Xlib -C language bindings - - - If the hostname is ``unix'' or the empty string, any supplied - protocol is ignored and a connection is made using the :local - transport. - - - If a double colon separates hostname from displaynumber, the - protocol is assumed to be decnet. - -Returns a list of (host display-number screen protocol)." - (let* ((name (or display-name - (getenv "DISPLAY") - (error "DISPLAY environment variable is not set"))) - (slash-i (or (position #\/ name) -1)) - (colon-i (position #\: name :start (1+ slash-i))) - (decnet-colon-p (eql (elt name (1+ colon-i)) #\:)) - (host (subseq name (1+ slash-i) colon-i)) - (dot-i (and colon-i (position #\. name :start colon-i))) - (display (when colon-i - (parse-integer name - :start (if decnet-colon-p - (+ colon-i 2) - (1+ colon-i)) - :end dot-i))) - (screen (when dot-i - (parse-integer name :start (1+ dot-i)))) - (protocol - (cond ((or (string= host "") (string-equal host "unix")) :local) - (decnet-colon-p :decnet) - ((> slash-i -1) (intern - (string-upcase (subseq name 0 slash-i)) - :keyword)) - (t :internet)))) - (list host (or display 0) (or screen 0) protocol))) - - -;;----------------------------------------------------------------------------- -;; GC stuff -;;----------------------------------------------------------------------------- - -(defun gc-cleanup () - (declare (special *event-free-list* - *pending-command-free-list* - *reply-buffer-free-lists* - *gcontext-local-state-cache* - *temp-gcontext-cache*)) - (setq *event-free-list* nil) - (setq *pending-command-free-list* nil) - (when (boundp '*reply-buffer-free-lists*) - (fill *reply-buffer-free-lists* nil)) - (setq *gcontext-local-state-cache* nil) - (setq *temp-gcontext-cache* nil) - nil) - - - -;;----------------------------------------------------------------------------- -;; WITH-STANDARD-IO-SYNTAX equivalent, used in (SETF WM-COMMAND) -;;----------------------------------------------------------------------------- - -#-(or clx-ansi-common-lisp Genera CMU sbcl) -(defun with-standard-io-syntax-function (function) - (declare #+lispm - (sys:downward-funarg function)) - (let ((*package* (find-package :user)) - (*print-array* t) - (*print-base* 10) - (*print-case* :upcase) - (*print-circle* nil) - (*print-escape* t) - (*print-gensym* t) - (*print-length* nil) - (*print-level* nil) - (*print-pretty* nil) - (*print-radix* nil) - (*read-base* 10) - (*read-default-float-format* 'single-float) - (*read-suppress* nil) - ) - (funcall function))) - -#-(or clx-ansi-common-lisp Genera CMU sbcl) -(defmacro with-standard-io-syntax (&body body) - `(flet ((.with-standard-io-syntax-body. () ,@body)) - (with-standard-io-syntax-function #'.with-standard-io-syntax-body.))) - - -;;----------------------------------------------------------------------------- -;; DEFAULT-KEYSYM-TRANSLATE -;;----------------------------------------------------------------------------- - -;;; If object is a character, char-bits are set from state. -;;; -;;; [the following isn't implemented (should it be?)] -;;; If object is a list, it is an alist with entries: -;;; (base-char [modifiers] [mask-modifiers]) -;;; When MODIFIERS are specified, this character translation -;;; will only take effect when the specified modifiers are pressed. -;;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore. -;;; When MASK-MODIFIERS is missing, all other modifiers are ignored. -;;; In ambiguous cases, the most specific translation is used. - -#-(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl) -(defun default-keysym-translate (display state object) - (declare (type display display) - (type card16 state) - (type t object) - (clx-values t) - (special left-meta-keysym right-meta-keysym - left-super-keysym right-super-keysym - left-hyper-keysym right-hyper-keysym)) - (when (characterp object) - (when (logbitp (position :control +state-mask-vector+) state) - (setf (char-bit object :control) 1)) - (when (or (state-keysymp display state left-meta-keysym) - (state-keysymp display state right-meta-keysym)) - (setf (char-bit object :meta) 1)) - (when (or (state-keysymp display state left-super-keysym) - (state-keysymp display state right-super-keysym)) - (setf (char-bit object :super) 1)) - (when (or (state-keysymp display state left-hyper-keysym) - (state-keysymp display state right-hyper-keysym)) - (setf (char-bit object :hyper) 1))) - object) - - -;;----------------------------------------------------------------------------- -;; Image stuff -;;----------------------------------------------------------------------------- - -;;; Types - -(deftype pixarray-1-element-type () - 'bit) - -(deftype pixarray-4-element-type () - '(unsigned-byte 4)) - -(deftype pixarray-8-element-type () - '(unsigned-byte 8)) - -(deftype pixarray-16-element-type () - '(unsigned-byte 16)) - -(deftype pixarray-24-element-type () - '(unsigned-byte 24)) - -(deftype pixarray-32-element-type () - #-(or Genera Minima) '(unsigned-byte 32) - #+(or Genera Minima) 'fixnum) - -(deftype pixarray-1 () - '(#+(or cmu sbcl) simple-array - #-(or cmu sbcl) array pixarray-1-element-type (* *))) - -(deftype pixarray-4 () - '(#+(or cmu sbcl) simple-array - #-(or cmu sbcl) array pixarray-4-element-type (* *))) - -(deftype pixarray-8 () - '(#+(or cmu sbcl) simple-array - #-(or cmu sbcl) array pixarray-8-element-type (* *))) - -(deftype pixarray-16 () - '(#+(or cmu sbcl) simple-array - #-(or cmu sbcl) array pixarray-16-element-type (* *))) - -(deftype pixarray-24 () - '(#+(or cmu sbcl) simple-array - #-(or cmu sbcl) array pixarray-24-element-type (* *))) - -(deftype pixarray-32 () - '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-32-element-type (* *))) - -(deftype pixarray () - '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32)) - -(deftype bitmap () - 'pixarray-1) - -;;; WITH-UNDERLYING-SIMPLE-VECTOR - -#+excl -(defmacro with-underlying-simple-vector - ((variable element-type pixarray) &body body) - `(let ((,variable (cdr (excl::ah_data ,pixarray)))) - (declare (type (simple-array ,element-type (*)) ,variable)) - ,@body)) - -;;; These are used to read and write pixels from and to CARD8s. - -;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s. - -(defmacro read-image-load-byte (size position integer) - (unless +image-bit-lsb-first-p+ (setq position (- 7 position))) - `(the (unsigned-byte ,size) - (#-Genera ldb #+Genera sys:%logldb - (byte ,size ,position) - (the card8 ,integer)))) - -;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from -;;; the appropriate number of CARD8s. - -(defmacro read-image-assemble-bytes (&rest bytes) - (unless +image-byte-lsb-first-p+ (setq bytes (reverse bytes))) - (let ((it (first bytes)) - (count 0)) - (dolist (byte (rest bytes)) - (setq it - `(#-Genera dpb #+Genera sys:%logdpb - (the card8 ,byte) - (byte 8 ,(incf count 8)) - (the (unsigned-byte ,count) ,it)))) - #-Genera `(the (unsigned-byte ,(* (length bytes) 8)) ,it) - #+Genera it)) - -;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit -;;; pixel. - -(defmacro write-image-load-byte (position integer integer-size) - integer-size - (unless +image-byte-lsb-first-p+ (setq position (- integer-size 8 position))) - `(the card8 - (#-Genera ldb #+Genera sys:%logldb - (byte 8 ,position) - #-Genera (the (unsigned-byte ,integer-size) ,integer) - #+Genera ,integer - ))) - -;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit -;;; pixels. - -(defmacro write-image-assemble-bytes (&rest bytes) - (unless +image-bit-lsb-first-p+ (setq bytes (reverse bytes))) - (let ((size (floor 8 (length bytes))) - (it (first bytes)) - (count 0)) - (dolist (byte (rest bytes)) - (setq it `(#-Genera dpb #+Genera sys:%logdpb - (the (unsigned-byte ,size) ,byte) - (byte ,size ,(incf count size)) - (the (unsigned-byte ,count) ,it)))) - `(the card8 ,it))) - -#+(or Genera lcl3.0 excl) -(defvar *computed-image-byte-lsb-first-p* +image-byte-lsb-first-p+) - -#+(or Genera lcl3.0 excl) -(defvar *computed-image-bit-lsb-first-p* +image-bit-lsb-first-p+) - -;;; The following table gives the bit ordering within bytes (when accessed -;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to -;;; 31, where bit 0 should be leftmost on the display. For a given byte -;;; labelled A-B, A is for the most significant bit of the byte, and B is -;;; for the least significant bit. -;;; -;;; legend: -;;; 1 scanline-unit = 8 -;;; 2 scanline-unit = 16 -;;; 4 scanline-unit = 32 -;;; M byte-order = MostSignificant -;;; L byte-order = LeastSignificant -;;; m bit-order = MostSignificant -;;; l bit-order = LeastSignificant -;;; -;;; -;;; format ordering -;;; -;;; 1Mm 00-07 08-15 16-23 24-31 -;;; 2Mm 00-07 08-15 16-23 24-31 -;;; 4Mm 00-07 08-15 16-23 24-31 -;;; 1Ml 07-00 15-08 23-16 31-24 -;;; 2Ml 15-08 07-00 31-24 23-16 -;;; 4Ml 31-24 23-16 15-08 07-00 -;;; 1Lm 00-07 08-15 16-23 24-31 -;;; 2Lm 08-15 00-07 24-31 16-23 -;;; 4Lm 24-31 16-23 08-15 00-07 -;;; 1Ll 07-00 15-08 23-16 31-24 -;;; 2Ll 07-00 15-08 23-16 31-24 -;;; 4Ll 07-00 15-08 23-16 31-24 - -#+(or Genera lcl3.0 excl) -(defconstant - *image-bit-ordering-table* - '(((1 (00 07) (08 15) (16 23) (24 31)) (nil nil)) - ((2 (00 07) (08 15) (16 23) (24 31)) (nil nil)) - ((4 (00 07) (08 15) (16 23) (24 31)) (nil nil)) - ((1 (07 00) (15 08) (23 16) (31 24)) (nil t)) - ((2 (15 08) (07 00) (31 24) (23 16)) (nil t)) - ((4 (31 24) (23 16) (15 08) (07 00)) (nil t)) - ((1 (00 07) (08 15) (16 23) (24 31)) (t nil)) - ((2 (08 15) (00 07) (24 31) (16 23)) (t nil)) - ((4 (24 31) (16 23) (08 15) (00 07)) (t nil)) - ((1 (07 00) (15 08) (23 16) (31 24)) (t t)) - ((2 (07 00) (15 08) (23 16) (31 24)) (t t)) - ((4 (07 00) (15 08) (23 16) (31 24)) (t t)))) - -#+(or Genera lcl3.0 excl) -(defun compute-image-byte-and-bit-ordering () - (declare (clx-values image-byte-lsb-first-p image-bit-lsb-first-p)) - ;; First compute the ordering - (let ((ordering nil) - (a (make-array '(1 32) :element-type 'bit :initial-element 0))) - (dotimes (i 4) - (push (flet ((bitpos (a i n) - (declare (optimize (speed 3) (safety 0) (space 0))) - (declare (type (simple-array bit (* *)) a) - (type fixnum i n)) - (with-underlying-simple-vector (v (unsigned-byte 8) a) - (prog2 - (setf (aref v i) n) - (dotimes (i 32) - (unless (zerop (aref a 0 i)) - (return i))) - (setf (aref v i) 0))))) - (list (bitpos a i #b10000000) - (bitpos a i #b00000001))) - ordering)) - (setq ordering (cons (floor +image-unit+ 8) (nreverse ordering))) - ;; Now from the ordering, compute byte-lsb-first-p and bit-lsb-first-p - (let ((byte-and-bit-ordering - (second (assoc ordering *image-bit-ordering-table* - :test #'equal)))) - (unless byte-and-bit-ordering - (error "Couldn't determine image byte and bit ordering~@ - measured image ordering = ~A" - ordering)) - (values-list byte-and-bit-ordering)))) - -#+(or Genera lcl3.0 excl) -(multiple-value-setq - (*computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) - (compute-image-byte-and-bit-ordering)) - -;;; If you can write fast routines that can read and write pixarrays out of a -;;; buffer-bytes, do it! It makes the image code a lot faster. The -;;; FAST-READ-PIXARRAY, FAST-WRITE-PIXARRAY and FAST-COPY-PIXARRAY routines -;;; return T if they can do it, NIL if they can't. - -;;; FIXME: though we have some #+sbcl -conditionalized routines in -;;; here, they would appear not to work, and so are commented out in -;;; the the FAST-xxx-PIXARRAY routines themseleves. Investigate -;;; whether the unoptimized routines are often used, and also whether -;;; speeding them up while maintaining correctness is possible. - -;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s - -#+(or lcl3.0 excl) -(defun fast-read-pixarray-1 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-1-element-type array) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index-ceiling x 8)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y)) - (left-bits (the array-index (mod (the fixnum (- x)) 8))) - (right-bits (index-mod (index- width left-bits) 8)) - (middle-bits (the fixnum (- (the fixnum (- width left-bits)) - right-bits))) - (middle-bytes (index-floor middle-bits 8))) - ((index>= y height)) - (declare (type array-index start y - left-bits right-bits middle-bytes) - (fixnum middle-bits)) - (cond ((< middle-bits 0) - (let ((byte (aref buffer-bbuf (index1- start))) - (x (array-row-major-index array y left-bits))) - (declare (type card8 byte) - (type array-index x)) - (when (index> right-bits 6) - (setf (aref vector (index- x 1)) - (read-image-load-byte 1 7 byte))) - (when (and (index> left-bits 1) - (index> right-bits 5)) - (setf (aref vector (index- x 2)) - (read-image-load-byte 1 6 byte))) - (when (and (index> left-bits 2) - (index> right-bits 4)) - (setf (aref vector (index- x 3)) - (read-image-load-byte 1 5 byte))) - (when (and (index> left-bits 3) - (index> right-bits 3)) - (setf (aref vector (index- x 4)) - (read-image-load-byte 1 4 byte))) - (when (and (index> left-bits 4) - (index> right-bits 2)) - (setf (aref vector (index- x 5)) - (read-image-load-byte 1 3 byte))) - (when (and (index> left-bits 5) - (index> right-bits 1)) - (setf (aref vector (index- x 6)) - (read-image-load-byte 1 2 byte))) - (when (index> left-bits 6) - (setf (aref vector (index- x 7)) - (read-image-load-byte 1 1 byte))))) - (t - (unless (index-zerop left-bits) - (let ((byte (aref buffer-bbuf (index1- start))) - (x (array-row-major-index array y left-bits))) - (declare (type card8 byte) - (type array-index x)) - (setf (aref vector (index- x 1)) - (read-image-load-byte 1 7 byte)) - (when (index> left-bits 1) - (setf (aref vector (index- x 2)) - (read-image-load-byte 1 6 byte)) - (when (index> left-bits 2) - (setf (aref vector (index- x 3)) - (read-image-load-byte 1 5 byte)) - (when (index> left-bits 3) - (setf (aref vector (index- x 4)) - (read-image-load-byte 1 4 byte)) - (when (index> left-bits 4) - (setf (aref vector (index- x 5)) - (read-image-load-byte 1 3 byte)) - (when (index> left-bits 5) - (setf (aref vector (index- x 6)) - (read-image-load-byte 1 2 byte)) - (when (index> left-bits 6) - (setf (aref vector (index- x 7)) - (read-image-load-byte 1 1 byte)) - )))))))) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (x (array-row-major-index array y left-bits) (index+ x 8))) - ((index>= i end) - (unless (index-zerop right-bits) - (let ((byte (aref buffer-bbuf end)) - (x (array-row-major-index - array y (index+ left-bits middle-bits)))) - (declare (type card8 byte) - (type array-index x)) - (setf (aref vector (index+ x 0)) - (read-image-load-byte 1 0 byte)) - (when (index> right-bits 1) - (setf (aref vector (index+ x 1)) - (read-image-load-byte 1 1 byte)) - (when (index> right-bits 2) - (setf (aref vector (index+ x 2)) - (read-image-load-byte 1 2 byte)) - (when (index> right-bits 3) - (setf (aref vector (index+ x 3)) - (read-image-load-byte 1 3 byte)) - (when (index> right-bits 4) - (setf (aref vector (index+ x 4)) - (read-image-load-byte 1 4 byte)) - (when (index> right-bits 5) - (setf (aref vector (index+ x 5)) - (read-image-load-byte 1 5 byte)) - (when (index> right-bits 6) - (setf (aref vector (index+ x 6)) - (read-image-load-byte 1 6 byte)) - ))))))))) - (declare (type array-index end i x)) - (let ((byte (aref buffer-bbuf i))) - (declare (type card8 byte)) - (setf (aref vector (index+ x 0)) - (read-image-load-byte 1 0 byte)) - (setf (aref vector (index+ x 1)) - (read-image-load-byte 1 1 byte)) - (setf (aref vector (index+ x 2)) - (read-image-load-byte 1 2 byte)) - (setf (aref vector (index+ x 3)) - (read-image-load-byte 1 3 byte)) - (setf (aref vector (index+ x 4)) - (read-image-load-byte 1 4 byte)) - (setf (aref vector (index+ x 5)) - (read-image-load-byte 1 5 byte)) - (setf (aref vector (index+ x 6)) - (read-image-load-byte 1 6 byte)) - (setf (aref vector (index+ x 7)) - (read-image-load-byte 1 7 byte)))) - ))))) - t) - -#+(or lcl3.0 excl) -(defun fast-read-pixarray-4 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-4 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-4-element-type array) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index-ceiling x 2)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y)) - (left-nibbles (the array-index (mod (the fixnum (- (the fixnum x))) - 2))) - (right-nibbles (index-mod (index- width left-nibbles) 2)) - (middle-nibbles (index- width left-nibbles right-nibbles)) - (middle-bytes (index-floor middle-nibbles 2))) - ((index>= y height)) - (declare (type array-index start y - left-nibbles right-nibbles middle-nibbles middle-bytes)) - (unless (index-zerop left-nibbles) - (setf (aref array y 0) - (read-image-load-byte - 4 4 (aref buffer-bbuf (index1- start))))) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (x (array-row-major-index array y left-nibbles) (index+ x 2))) - ((index>= i end) - (unless (index-zerop right-nibbles) - (setf (aref array y (index+ left-nibbles middle-nibbles)) - (read-image-load-byte 4 0 (aref buffer-bbuf end))))) - (declare (type array-index end i x)) - (let ((byte (aref buffer-bbuf i))) - (declare (type card8 byte)) - (setf (aref vector (index+ x 0)) - (read-image-load-byte 4 0 byte)) - (setf (aref vector (index+ x 1)) - (read-image-load-byte 4 4 byte)))) - ))) - t) - -#+(or Genera lcl3.0 excl CMU sbcl) -(defun fast-read-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-24-element-type array) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index* x 3)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) - (declare (type array-index start y)) - (do* ((end (index+ start (index* width 3))) - (i start (index+ i 3)) - (x (array-row-major-index array y 0) (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref vector x) - (read-image-assemble-bytes - (aref buffer-bbuf (index+ i 0)) - (aref buffer-bbuf (index+ i 1)) - (aref buffer-bbuf (index+ i 2)))))))) - t) - -;;; COPY-BIT-RECT -- Internal -;;; -;;; This is the classic BITBLT operation, copying a rectangular subarray -;;; from one array to another (but source and destination must not overlap.) -;;; Widths are specified in bits. Neither array can have a non-zero -;;; displacement. We allow extra random bit-offset to be thrown into the X. -;;; -#+(or Genera lcl3.0 excl) -(defun fast-read-pixarray-with-swap - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type array-index boffset - padded-bytes-per-line) - (type pixarray pixarray) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (unless (index= bits-per-pixel 24) - (let ((pixarray-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index pixarray 1 0) - (array-row-major-index pixarray 0 0)) - bits-per-pixel))) - (x-bits (index* x bits-per-pixel))) - (declare (type array-index pixarray-padded-bits-per-line x-bits)) - (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) - (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) - (index-zerop (index-mod x-bits 8))) - (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) - (index-zerop (index-mod x-bits +image-unit+)))) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p - +image-unit+ *computed-image-byte-lsb-first-p* - *computed-image-bit-lsb-first-p*) - (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) - (with-underlying-simple-vector (dst card8 pixarray) - (funcall - (symbol-function image-swap-function) bbuf dst - (index+ boffset - (index* y padded-bytes-per-line) - (index-floor x-bits 8)) - 0 (index-ceiling (index* width bits-per-pixel) 8) - padded-bytes-per-line - (index-floor pixarray-padded-bits-per-line 8) - height image-swap-lsb-first-p))) - t)))) - -(defun fast-read-pixarray (bbuf boffset pixarray - x y width height padded-bytes-per-line - bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type array-index boffset - padded-bytes-per-line) - (type pixarray pixarray) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (progn bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (or - #+(or Genera lcl3.0 excl) - (fast-read-pixarray-with-swap - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (let ((function - (or #+lispm - (and (= (sys:array-element-size pixarray) bits-per-pixel) - (zerop (index-mod padded-bytes-per-line 4)) - (zerop (index-mod - (* #+Genera (sys:array-row-span pixarray) - #-Genera (array-dimension pixarray 1) - bits-per-pixel) - 32)) - #'fast-read-pixarray-using-bitblt) - #+(or CMU) - (and (index= (pixarray-element-size pixarray) bits-per-pixel) - #'fast-read-pixarray-using-bitblt) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 1) - #'fast-read-pixarray-1) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 4) - #'fast-read-pixarray-4) - #+(or Genera lcl3.0 excl CMU) - (and (index= bits-per-pixel 24) - #'fast-read-pixarray-24)))) - (when function - (read-pixarray-internal - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel function - unit byte-lsb-first-p bit-lsb-first-p - +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+))))) - -;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s - -#+(or lcl3.0 excl) -(defun fast-write-pixarray-1 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-1-element-type array) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (right-bits (index-mod width 8)) - (middle-bits (index- width right-bits)) - (middle-bytes (index-ceiling middle-bits 8)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y right-bits middle-bits - middle-bytes start)) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (start-x x) - (x (array-row-major-index array y start-x) (index+ x 8))) - ((index>= i end) - (unless (index-zerop right-bits) - (let ((x (array-row-major-index - array y (index+ start-x middle-bits)))) - (declare (type array-index x)) - (setf (aref buffer-bbuf end) - (write-image-assemble-bytes - (aref vector (index+ x 0)) - (if (index> right-bits 1) - (aref vector (index+ x 1)) - 0) - (if (index> right-bits 2) - (aref vector (index+ x 2)) - 0) - (if (index> right-bits 3) - (aref vector (index+ x 3)) - 0) - (if (index> right-bits 4) - (aref vector (index+ x 4)) - 0) - (if (index> right-bits 5) - (aref vector (index+ x 5)) - 0) - (if (index> right-bits 6) - (aref vector (index+ x 6)) - 0) - 0))))) - (declare (type array-index end i start-x x)) - (setf (aref buffer-bbuf i) - (write-image-assemble-bytes - (aref vector (index+ x 0)) - (aref vector (index+ x 1)) - (aref vector (index+ x 2)) - (aref vector (index+ x 3)) - (aref vector (index+ x 4)) - (aref vector (index+ x 5)) - (aref vector (index+ x 6)) - (aref vector (index+ x 7)))))))) - t) - -#+(or lcl3.0 excl) -(defun fast-write-pixarray-4 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-4 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-4-element-type array) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (right-nibbles (index-mod width 2)) - (middle-nibbles (index- width right-nibbles)) - (middle-bytes (index-ceiling middle-nibbles 2)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y right-nibbles middle-nibbles - middle-bytes start)) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (start-x x) - (x (array-row-major-index array y start-x) (index+ x 2))) - ((index>= i end) - (unless (index-zerop right-nibbles) - (setf (aref buffer-bbuf end) - (write-image-assemble-bytes - (aref array y (index+ start-x middle-nibbles)) - 0)))) - (declare (type array-index end i start-x x)) - (setf (aref buffer-bbuf i) - (write-image-assemble-bytes - (aref vector (index+ x 0)) - (aref vector (index+ x 1)))))))) - t) - -#+(or Genera lcl3.0 excl CMU sbcl) -(defun fast-write-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-24-element-type array) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index y start)) - (do* ((end (index+ start (index* width 3))) - (i start (index+ i 3)) - (x (array-row-major-index array y x) (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (let ((pixel (aref vector x))) - (declare (type pixarray-24-element-type pixel)) - (setf (aref buffer-bbuf (index+ i 0)) - (write-image-load-byte 0 pixel 24)) - (setf (aref buffer-bbuf (index+ i 1)) - (write-image-load-byte 8 pixel 24)) - (setf (aref buffer-bbuf (index+ i 2)) - (write-image-load-byte 16 pixel 24))))))) - t) - -#+(or Genera lcl3.0 excl) -(defun fast-write-pixarray-with-swap - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type pixarray pixarray) - (type card16 x y width height) - (type array-index boffset padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (unless (index= bits-per-pixel 24) - (let ((pixarray-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index pixarray 1 0) - (array-row-major-index pixarray 0 0)) - bits-per-pixel))) - (pixarray-start-bit-offset - (index* (array-row-major-index pixarray y x) - bits-per-pixel))) - (declare (type array-index pixarray-padded-bits-per-line - pixarray-start-bit-offset)) - (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) - (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) - (index-zerop (index-mod pixarray-start-bit-offset 8))) - (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) - (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - +image-unit+ *computed-image-byte-lsb-first-p* - *computed-image-bit-lsb-first-p* - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) - (with-underlying-simple-vector (src card8 pixarray) - (funcall - (symbol-function image-swap-function) - src bbuf (index-floor pixarray-start-bit-offset 8) boffset - (index-ceiling (index* width bits-per-pixel) 8) - (index-floor pixarray-padded-bits-per-line 8) - padded-bytes-per-line height image-swap-lsb-first-p)) - t))))) - -(defun fast-write-pixarray (bbuf boffset pixarray x y width height - padded-bytes-per-line bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type pixarray pixarray) - (type card16 x y width height) - (type array-index boffset padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (progn bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (or - #+(or Genera lcl3.0 excl) - (fast-write-pixarray-with-swap - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (let ((function - (or #+lispm - (and (= (sys:array-element-size pixarray) bits-per-pixel) - (zerop (index-mod padded-bytes-per-line 4)) - (zerop (index-mod - (* #+Genera (sys:array-row-span pixarray) - #-Genera (array-dimension pixarray 1) - bits-per-pixel) - 32)) - #'fast-write-pixarray-using-bitblt) - #+(or CMU) - (and (index= (pixarray-element-size pixarray) bits-per-pixel) - #'fast-write-pixarray-using-bitblt) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 1) - #'fast-write-pixarray-1) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 4) - #'fast-write-pixarray-4) - #+(or Genera lcl3.0 excl CMU) - (and (index= bits-per-pixel 24) - #'fast-write-pixarray-24)))) - (when function - (write-pixarray-internal - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel function - +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+ - unit byte-lsb-first-p bit-lsb-first-p))))) - -;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another - -(defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel) - (declare (type pixarray pixarray copy) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel)) - (progn pixarray copy x y width height bits-per-pixel nil) - (or - #+(or lispm CMU) - (let* ((pixarray-padded-pixels-per-line - #+Genera (sys:array-row-span pixarray) - #-Genera (array-dimension pixarray 1)) - (pixarray-padded-bits-per-line - (* pixarray-padded-pixels-per-line bits-per-pixel)) - (copy-padded-pixels-per-line - #+Genera (sys:array-row-span copy) - #-Genera (array-dimension copy 1)) - (copy-padded-bits-per-line - (* copy-padded-pixels-per-line bits-per-pixel))) - #-(or CMU) - (when (and (= (sys:array-element-size pixarray) bits-per-pixel) - (zerop (index-mod pixarray-padded-bits-per-line 32)) - (zerop (index-mod copy-padded-bits-per-line 32))) - (sys:bitblt boole-1 width height pixarray x y copy 0 0) - t) - #+(or CMU) - (when (index= (pixarray-element-size pixarray) - (pixarray-element-size copy) - bits-per-pixel) - (copy-bit-rect pixarray pixarray-padded-bits-per-line x y - copy copy-padded-bits-per-line 0 0 - height - (index* width bits-per-pixel)) - t)) - - #+(or lcl3.0 excl) - (unless (index= bits-per-pixel 24) - (let ((pixarray-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index pixarray 1 0) - (array-row-major-index pixarray 0 0)) - bits-per-pixel))) - (copy-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index copy 1 0) - (array-row-major-index copy 0 0)) - bits-per-pixel))) - (pixarray-start-bit-offset - (index* (array-row-major-index pixarray y x) - bits-per-pixel))) - (declare (type array-index pixarray-padded-bits-per-line - copy-padded-bits-per-line pixarray-start-bit-offset)) - (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) - (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) - (index-zerop (index-mod copy-padded-bits-per-line 8)) - (index-zerop (index-mod pixarray-start-bit-offset 8))) - (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) - (index-zerop (index-mod copy-padded-bits-per-line +image-unit+)) - (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) - (with-underlying-simple-vector (src card8 pixarray) - (with-underlying-simple-vector (dst card8 copy) - (image-noswap - src dst - (index-floor pixarray-start-bit-offset 8) 0 - (index-ceiling (index* width bits-per-pixel) 8) - (index-floor pixarray-padded-bits-per-line 8) - (index-floor copy-padded-bits-per-line 8) - height nil))) - t))) - #+(or lcl3.0 excl) - (macrolet - ((copy (type element-type) - `(let ((pixarray pixarray) - (copy copy)) - (declare (type ,type pixarray copy)) - #.(declare-buffun) - (with-underlying-simple-vector (src ,element-type pixarray) - (with-underlying-simple-vector (dst ,element-type copy) - (do* ((dst-y 0 (index1+ dst-y)) - (src-y y (index1+ src-y))) - ((index>= dst-y height)) - (declare (type card16 dst-y src-y)) - (do* ((dst-idx (array-row-major-index copy dst-y 0) - (index1+ dst-idx)) - (dst-end (index+ dst-idx width)) - (src-idx (array-row-major-index pixarray src-y x) - (index1+ src-idx))) - ((index>= dst-idx dst-end)) - (declare (type array-index dst-idx src-idx dst-end)) - (setf (aref dst dst-idx) - (the ,element-type (aref src src-idx)))))))))) - (ecase bits-per-pixel - (1 (copy pixarray-1 pixarray-1-element-type)) - (4 (copy pixarray-4 pixarray-4-element-type)) - (8 (copy pixarray-8 pixarray-8-element-type)) - (16 (copy pixarray-16 pixarray-16-element-type)) - (24 (copy pixarray-24 pixarray-24-element-type)) - (32 (copy pixarray-32 pixarray-32-element-type))) - t))) diff -Nru ecl-16.1.2/src/clx/depdefs.lisp ecl-16.1.3+ds/src/clx/depdefs.lisp --- ecl-16.1.2/src/clx/depdefs.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/depdefs.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,693 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;; This file contains some of the system dependent code for CLX - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -;;;------------------------------------------------------------------------- -;;; Declarations -;;;------------------------------------------------------------------------- - -;;; fix a bug in kcl's RATIONAL... -;;; redefine both the function and the type. - -#+(or kcl ibcl) -(progn - (defun rational (x) - (if (rationalp x) - x - (lisp:rational x))) - (deftype rational (&optional l u) `(lisp:rational ,l ,u))) - -;;; DECLAIM - -#-clx-ansi-common-lisp -(defmacro declaim (&rest decl-specs) - (if (cdr decl-specs) - `(progn - ,@(mapcar #'(lambda (decl-spec) `(proclaim ',decl-spec)) - decl-specs)) - `(proclaim ',(car decl-specs)))) - -;;; CLX-VALUES value1 value2 ... -- Documents the values returned by the function. - -#-Genera -(declaim (declaration clx-values)) - -#+Genera -(setf (get 'clx-values 'si:declaration-alias) 'scl:values) - -;;; ARGLIST arg1 arg2 ... -- Documents the arglist of the function. Overrides -;;; the documentation that might get generated by the real arglist of the -;;; function. - -#-(or lispm lcl3.0) -(declaim (declaration arglist)) - -;;; DYNAMIC-EXTENT var -- Tells the compiler that the rest arg var has -;;; dynamic extent and therefore can be kept on the stack and not copied to -;;; the heap, even though the value is passed out of the function. - -#-(or clx-ansi-common-lisp lcl3.0) -(declaim (declaration dynamic-extent)) - -;;; IGNORABLE var -- Tells the compiler that the variable might or might not be used. - -#-clx-ansi-common-lisp -(declaim (declaration ignorable)) - -;;; INDENTATION argpos1 arginden1 argpos2 arginden2 --- Tells the lisp editor how to -;;; indent calls to the function or macro containing the declaration. - -#-genera -(declaim (declaration indentation)) - -;;;------------------------------------------------------------------------- -;;; Declaration macros -;;;------------------------------------------------------------------------- - -;;; WITH-VECTOR (variable type) &body body --- ensures the variable is a local -;;; and then does a type declaration and array register declaration -(defmacro with-vector ((var type) &body body) - `(let ((,var ,var)) - (declare (type ,type ,var)) - ,@body)) - -;;; WITHIN-DEFINITION (name type) &body body --- Includes definitions for -;;; Meta-. - -#+lispm -(defmacro within-definition ((name type) &body body) - `(zl:local-declare - ((sys:function-parent ,name ,type)) - (sys:record-source-file-name ',name ',type) - ,@body)) - -#-lispm -(defmacro within-definition ((name type) &body body) - (declare (ignore name type)) - `(progn ,@body)) - - -;;;------------------------------------------------------------------------- -;;; CLX can maintain a mapping from X server ID's to local data types. If -;;; one takes the view that CLX objects will be instance variables of -;;; objects at the next higher level, then PROCESS-EVENT will typically map -;;; from resource-id to higher-level object. In that case, the lower-level -;;; CLX mapping will almost never be used (except in rare cases like -;;; query-tree), and only serve to consume space (which is difficult to -;;; GC), in which case always-consing versions of the make-s will -;;; be better. Even when maps are maintained, it isn't clear they are -;;; useful for much beyond xatoms and windows (since almost nothing else -;;; ever comes back in events). -;;;-------------------------------------------------------------------------- -(defconstant +clx-cached-types+ - '(drawable - window - pixmap - ;; gcontext - cursor - colormap - font)) - -(defmacro resource-id-map-test () - #+excl '#'equal - #-excl '#'eql) - ; (eq fixnum fixnum) is not guaranteed. -(defmacro atom-cache-map-test () - #+excl '#'equal - #-excl '#'eq) - -(defmacro keysym->character-map-test () - #+excl '#'equal - #-excl '#'eql) - -;;; You must define this to match the real byte order. It is used by -;;; overlapping array and image code. - -#+(or lispm vax little-endian Minima) -(eval-when (eval compile load) - (pushnew :clx-little-endian *features*)) - -#+lcl3.0 -(eval-when (compile eval load) - (ecase lucid::machine-endian - (:big nil) - (:little (pushnew :clx-little-endian *features*)))) - -#+cmu -(eval-when (compile eval load) - (ecase #.(c:backend-byte-order c:*backend*) - (:big-endian) - (:little-endian (pushnew :clx-little-endian *features*)))) - -#+sbcl -(eval-when (:compile-toplevel :load-toplevel :execute) - ;; FIXME: Ideally, we shouldn't end up with the internal - ;; :CLX-LITTLE-ENDIAN decorating user-visible *FEATURES* lists. - ;; This probably wants to be split up into :compile-toplevel - ;; :execute and :load-toplevel clauses, so that loading the compiled - ;; code doesn't push the feature. - (ecase sb-c:*backend-byte-order* - (:big-endian) - (:little-endian (pushnew :clx-little-endian *features*)))) - -;;; Steele's Common-Lisp states: "It is an error if the array specified -;;; as the :displaced-to argument does not have the same :element-type -;;; as the array being created" If this is the case on your lisp, then -;;; leave the overlapping-arrays feature turned off. Lisp machines -;;; (Symbolics TI and LMI) don't have this restriction, and allow arrays -;;; with different element types to overlap. CLX will take advantage of -;;; this to do fast array packing/unpacking when the overlapping-arrays -;;; feature is enabled. - -#+clisp -(eval-when (:compile-toplevel :load-toplevel :execute) - (unless system::*big-endian* (pushnew :clx-little-endian *features*))) - -#+(and clx-little-endian lispm) -(eval-when (eval compile load) - (pushnew :clx-overlapping-arrays *features*)) - -#+(and clx-overlapping-arrays genera) -(progn -(deftype overlap16 () '(unsigned-byte 16)) -(deftype overlap32 () '(signed-byte 32)) -) - -#+(and clx-overlapping-arrays (or explorer lambda cadr)) -(progn -(deftype overlap16 () '(unsigned-byte 16)) -(deftype overlap32 () '(unsigned-byte 32)) -) - -(deftype buffer-bytes () `(simple-array (unsigned-byte 8) (*))) - -#+clx-overlapping-arrays -(progn -(deftype buffer-words () `(vector overlap16)) -(deftype buffer-longs () `(vector overlap32)) -) - -;;; This defines a type which is a subtype of the integers. -;;; This type is used to describe all variables that can be array indices. -;;; It is here because it is used below. -;;; This is inclusive because start/end can be 1 past the end. -(deftype array-index () `(integer 0 ,array-dimension-limit)) - - -;; this is the best place to define these? - -#-Genera -(progn - -(defun make-index-typed (form) - (if (constantp form) form `(the array-index ,form))) - -(defun make-index-op (operator args) - `(the array-index - (values - ,(case (length args) - (0 `(,operator)) - (1 `(,operator - ,(make-index-typed (first args)))) - (2 `(,operator - ,(make-index-typed (first args)) - ,(make-index-typed (second args)))) - (otherwise - `(,operator - ,(make-index-op operator (subseq args 0 (1- (length args)))) - ,(make-index-typed (first (last args))))))))) - -(defmacro index+ (&rest numbers) (make-index-op '+ numbers)) -(defmacro index-logand (&rest numbers) (make-index-op 'logand numbers)) -(defmacro index-logior (&rest numbers) (make-index-op 'logior numbers)) -(defmacro index- (&rest numbers) (make-index-op '- numbers)) -(defmacro index* (&rest numbers) (make-index-op '* numbers)) - -(defmacro index1+ (number) (make-index-op '1+ (list number))) -(defmacro index1- (number) (make-index-op '1- (list number))) - -(defmacro index-incf (place &optional (delta 1)) - (make-index-op 'incf (list place delta))) -(defmacro index-decf (place &optional (delta 1)) - (make-index-op 'decf (list place delta))) - -(defmacro index-min (&rest numbers) (make-index-op 'min numbers)) -(defmacro index-max (&rest numbers) (make-index-op 'max numbers)) - -(defmacro index-floor (number divisor) - (make-index-op 'floor (list number divisor))) -(defmacro index-ceiling (number divisor) - (make-index-op 'ceiling (list number divisor))) -(defmacro index-truncate (number divisor) - (make-index-op 'truncate (list number divisor))) - -(defmacro index-mod (number divisor) - (make-index-op 'mod (list number divisor))) - -(defmacro index-ash (number count) - (make-index-op 'ash (list number count))) - -(defmacro index-plusp (number) `(plusp (the array-index ,number))) -(defmacro index-zerop (number) `(zerop (the array-index ,number))) -(defmacro index-evenp (number) `(evenp (the array-index ,number))) -(defmacro index-oddp (number) `(oddp (the array-index ,number))) - -(defmacro index> (&rest numbers) - `(> ,@(mapcar #'make-index-typed numbers))) -(defmacro index= (&rest numbers) - `(= ,@(mapcar #'make-index-typed numbers))) -(defmacro index< (&rest numbers) - `(< ,@(mapcar #'make-index-typed numbers))) -(defmacro index>= (&rest numbers) - `(>= ,@(mapcar #'make-index-typed numbers))) -(defmacro index<= (&rest numbers) - `(<= ,@(mapcar #'make-index-typed numbers))) - -) - -#+Genera -(progn - -(defmacro index+ (&rest numbers) `(+ ,@numbers)) -(defmacro index-logand (&rest numbers) `(logand ,@numbers)) -(defmacro index-logior (&rest numbers) `(logior ,@numbers)) -(defmacro index- (&rest numbers) `(- ,@numbers)) -(defmacro index* (&rest numbers) `(* ,@numbers)) - -(defmacro index1+ (number) `(1+ ,number)) -(defmacro index1- (number) `(1- ,number)) - -(defmacro index-incf (place &optional (delta 1)) `(setf ,place (index+ ,place ,delta))) -(defmacro index-decf (place &optional (delta 1)) `(setf ,place (index- ,place ,delta))) - -(defmacro index-min (&rest numbers) `(min ,@numbers)) -(defmacro index-max (&rest numbers) `(max ,@numbers)) - -(defun positive-power-of-two-p (x) - (when (symbolp x) - (multiple-value-bind (constantp value) (lt:named-constant-p x) - (when constantp (setq x value)))) - (and (typep x 'fixnum) (plusp x) (zerop (logand x (1- x))))) - -(defmacro index-floor (number divisor) - (cond ((eql divisor 1) number) - ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor)) - `(si:%fixnum-floor ,number ,divisor)) - (t `(floor ,number ,divisor)))) - -(defmacro index-ceiling (number divisor) - (cond ((eql divisor 1) number) - ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-ceiling)) - `(si:%fixnum-ceiling ,number ,divisor)) - (t `(ceiling ,number ,divisor)))) - -(defmacro index-truncate (number divisor) - (cond ((eql divisor 1) number) - ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor)) - `(si:%fixnum-floor ,number ,divisor)) - (t `(truncate ,number ,divisor)))) - -(defmacro index-mod (number divisor) - (cond ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-mod)) - `(si:%fixnum-mod ,number ,divisor)) - (t `(mod ,number ,divisor)))) - -(defmacro index-ash (number count) - (cond ((eql count 0) number) - ((and (typep count 'fixnum) (minusp count) (fboundp 'si:%fixnum-floor)) - `(si:%fixnum-floor ,number ,(expt 2 (- count)))) - ((and (typep count 'fixnum) (plusp count) (fboundp 'si:%fixnum-multiply)) - `(si:%fixnum-multiply ,number ,(expt 2 count))) - (t `(ash ,number ,count)))) - -(defmacro index-plusp (number) `(plusp ,number)) -(defmacro index-zerop (number) `(zerop ,number)) -(defmacro index-evenp (number) `(evenp ,number)) -(defmacro index-oddp (number) `(oddp ,number)) - -(defmacro index> (&rest numbers) `(> ,@numbers)) -(defmacro index= (&rest numbers) `(= ,@numbers)) -(defmacro index< (&rest numbers) `(< ,@numbers)) -(defmacro index>= (&rest numbers) `(>= ,@numbers)) -(defmacro index<= (&rest numbers) `(<= ,@numbers)) - -) - -;;;; Stuff for BUFFER definition - -(defconstant +replysize+ 32.) - -;; used in defstruct initializations to avoid compiler warnings -(defvar *empty-bytes* (make-sequence 'buffer-bytes 0)) -(declaim (type buffer-bytes *empty-bytes*)) -#+clx-overlapping-arrays -(progn -(defvar *empty-words* (make-sequence 'buffer-words 0)) -(declaim (type buffer-words *empty-words*)) -) -#+clx-overlapping-arrays -(progn -(defvar *empty-longs* (make-sequence 'buffer-longs 0)) -(declaim (type buffer-longs *empty-longs*)) -) - -(defstruct (reply-buffer (:conc-name reply-) (:constructor make-reply-buffer-internal) - (:copier nil) (:predicate nil)) - (size 0 :type array-index) ;Buffer size - ;; Byte (8 bit) input buffer - (ibuf8 *empty-bytes* :type buffer-bytes) - ;; Word (16bit) input buffer - #+clx-overlapping-arrays - (ibuf16 *empty-words* :type buffer-words) - ;; Long (32bit) input buffer - #+clx-overlapping-arrays - (ibuf32 *empty-longs* :type buffer-longs) - (next nil #-explorer :type #-explorer (or null reply-buffer)) - (data-size 0 :type array-index) - ) - -(defconstant +buffer-text16-size+ 256) -(deftype buffer-text16 () `(simple-array (unsigned-byte 16) (,+buffer-text16-size+))) - -;; These are here because. - -(defparameter *xlib-package* (find-package :xlib)) - -(defun xintern (&rest parts) - (intern (apply #'concatenate 'string (mapcar #'string parts)) *xlib-package*)) - -(defparameter *keyword-package* (find-package :keyword)) - -(defun kintern (name) - (intern (string name) *keyword-package*)) - -;;; Pseudo-class mechanism. - -(eval-when (:compile-toplevel :load-toplevel :execute) - ;; FIXME: maybe we should reevaluate this? - (defvar *def-clx-class-use-defclass* - #+(or Genera allegro) t - #+(and cmu pcl) '(XLIB:DRAWABLE XLIB:WINDOW XLIB:PIXMAP) - #+(and cmu (not pcl)) nil - #-(or Genera cmu allegro) nil - "Controls whether DEF-CLX-CLASS uses DEFCLASS. - -If it is a list, it is interpreted by DEF-CLX-CLASS to be a list of -type names for which DEFCLASS should be used. If it is not a list, -then DEFCLASS is always used. If it is NIL, then DEFCLASS is never -used, since NIL is the empty list.") - ) - -(defmacro def-clx-class ((name &rest options) &body slots) - (if (or (not (listp *def-clx-class-use-defclass*)) - (member name *def-clx-class-use-defclass*)) - (let ((clos-package #+clx-ansi-common-lisp - (find-package :common-lisp) - #-clx-ansi-common-lisp - (or (find-package :clos) - (find-package :pcl) - (let ((lisp-pkg (find-package :lisp))) - (and (find-symbol (string 'defclass) lisp-pkg) - lisp-pkg)))) - (constructor t) - (constructor-args t) - (include nil) - (print-function nil) - (copier t) - (predicate t)) - (dolist (option options) - (ecase (pop option) - (:constructor - (setf constructor (pop option)) - (setf constructor-args (if (null option) t (pop option)))) - (:include - (setf include (pop option))) - (:print-function - (setf print-function (pop option))) - (:copier - (setf copier (pop option))) - (:predicate - (setf predicate (pop option))))) - (flet ((cintern (&rest symbols) - (intern (apply #'concatenate 'simple-string - (mapcar #'symbol-name symbols)) - *package*)) - (kintern (symbol) - (intern (symbol-name symbol) (find-package :keyword))) - (closintern (symbol) - (intern (symbol-name symbol) clos-package))) - (when (eq constructor t) - (setf constructor (cintern 'make- name))) - (when (eq copier t) - (setf copier (cintern 'copy- name))) - (when (eq predicate t) - (setf predicate (cintern name '-p))) - (when include - (setf slots (append (get include 'def-clx-class) slots))) - (let* ((n-slots (length slots)) - (slot-names (make-list n-slots)) - (slot-initforms (make-list n-slots)) - (slot-types (make-list n-slots))) - (dotimes (i n-slots) - (let ((slot (elt slots i))) - (setf (elt slot-names i) (pop slot)) - (setf (elt slot-initforms i) (pop slot)) - (setf (elt slot-types i) (getf slot :type t)))) - `(progn - - (eval-when (:compile-toplevel :load-toplevel :execute) - (setf (get ',name 'def-clx-class) ',slots)) - - ;; From here down are the system-specific expansions: - - (within-definition (,name def-clx-class) - (,(closintern 'defclass) - ,name ,(and include `(,include)) - (,@(map 'list - #'(lambda (slot-name slot-initform slot-type) - `(,slot-name - :initform ,slot-initform :type ,slot-type - :accessor ,(cintern name '- slot-name) - ,@(when (and constructor - (or (eq constructor-args t) - (member slot-name - constructor-args))) - `(:initarg ,(kintern slot-name))) - )) - slot-names slot-initforms slot-types))) - ,(when constructor - (if (eq constructor-args t) - `(defun ,constructor (&rest args) - (apply #',(closintern 'make-instance) - ',name args)) - `(defun ,constructor ,constructor-args - (,(closintern 'make-instance) ',name - ,@(mapcan #'(lambda (slot-name) - (and (member slot-name slot-names) - `(,(kintern slot-name) ,slot-name))) - constructor-args))))) - ,(when predicate - #+allegro - `(progn - (,(closintern 'defmethod) ,predicate (object) - (declare (ignore object)) - nil) - (,(closintern 'defmethod) ,predicate ((object ,name)) - t)) - #-allegro - `(defun ,predicate (object) - (typep object ',name))) - ,(when copier - `(,(closintern 'defmethod) ,copier ((.object. ,name)) - (,(closintern 'with-slots) ,slot-names .object. - (,(closintern 'make-instance) ',name - ,@(mapcan #'(lambda (slot-name) - `(,(kintern slot-name) ,slot-name)) - slot-names))))) - ,(when print-function - `(,(closintern 'defmethod) - ,(closintern 'print-object) - ((object ,name) stream) - (,print-function object stream 0)))))))) - `(within-definition (,name def-clx-class) - (defstruct (,name ,@options) - ,@slots)))) - -#+Genera -(progn - (scl:defprop def-clx-class "CLX Class" si:definition-type-name) - (scl:defprop def-clx-class zwei:defselect-function-spec-finder - zwei:definition-function-spec-finder)) - - -;; We need this here so we can define DISPLAY for CLX. -;; -;; This structure is :INCLUDEd in the DISPLAY structure. -;; Overlapping (displaced) arrays are provided for byte -;; half-word and word access on both input and output. -;; -(def-clx-class (buffer (:constructor nil) (:copier nil) (:predicate nil)) - ;; Lock for multi-processing systems - (lock (make-process-lock "CLX Buffer Lock")) - #-excl (output-stream nil :type (or null stream)) - #+excl (output-stream -1 :type fixnum) - ;; Buffer size - (size 0 :type array-index) - (request-number 0 :type (unsigned-byte 16)) - ;; Byte position of start of last request - ;; used for appending requests and error recovery - (last-request nil :type (or null array-index)) - ;; Byte position of start of last flushed request - (last-flushed-request nil :type (or null array-index)) - ;; Current byte offset - (boffset 0 :type array-index) - ;; Byte (8 bit) output buffer - (obuf8 *empty-bytes* :type buffer-bytes) - ;; Word (16bit) output buffer - #+clx-overlapping-arrays - (obuf16 *empty-words* :type buffer-words) - ;; Long (32bit) output buffer - #+clx-overlapping-arrays - (obuf32 *empty-longs* :type buffer-longs) - ;; Holding buffer for 16-bit text - (tbuf16 (make-sequence 'buffer-text16 +buffer-text16-size+ :initial-element 0)) - ;; Probably EQ to Output-Stream - #-excl (input-stream nil :type (or null stream)) - #+excl (input-stream -1 :type fixnum) - ;; T when the host connection has gotten errors - (dead nil :type (or null (not null))) - ;; T makes buffer-flush a noop. Manipulated with with-buffer-flush-inhibited. - (flush-inhibit nil :type (or null (not null))) - - ;; Change these functions when using shared memory buffers to the server - ;; Function to call when writing the buffer - (write-function 'buffer-write-default) - ;; Function to call when flushing the buffer - (force-output-function 'buffer-force-output-default) - ;; Function to call when closing a connection - (close-function 'buffer-close-default) - ;; Function to call when reading the buffer - (input-function 'buffer-read-default) - ;; Function to call to wait for data to be input - (input-wait-function 'buffer-input-wait-default) - ;; Function to call to listen for input data - (listen-function 'buffer-listen-default) - - #+Genera (debug-io nil :type (or null stream)) - ) - -;;----------------------------------------------------------------------------- -;; Printing routines. -;;----------------------------------------------------------------------------- - -#-(or clx-ansi-common-lisp Genera) -(defun print-unreadable-object-function (object stream type identity function) - (declare #+lispm - (sys:downward-funarg function)) - (princ "#<" stream) - (when type - (let ((type (type-of object)) - (pcl-package (find-package :pcl))) - ;; Handle pcl type-of lossage - (when (and pcl-package - (symbolp type) - (eq (symbol-package type) pcl-package) - (string-equal (symbol-name type) "STD-INSTANCE")) - (setq type - (funcall (intern (symbol-name 'class-name) pcl-package) - (funcall (intern (symbol-name 'class-of) pcl-package) - object)))) - (prin1 type stream))) - (when (and type function) (princ " " stream)) - (when function (funcall function)) - (when (and (or type function) identity) (princ " " stream)) - (when identity (princ "???" stream)) - (princ ">" stream) - nil) - -#-(or clx-ansi-common-lisp Genera) -(defmacro print-unreadable-object - ((object stream &key type identity) &body body) - (if body - `(flet ((.print-unreadable-object-body. () ,@body)) - (print-unreadable-object-function - ,object ,stream ,type ,identity #'.print-unreadable-object-body.)) - `(print-unreadable-object-function ,object ,stream ,type ,identity nil))) - - -;;----------------------------------------------------------------------------- -;; Image stuff -;;----------------------------------------------------------------------------- - -(defconstant +image-bit-lsb-first-p+ - #+clx-little-endian t - #-clx-little-endian nil) - -(defconstant +image-byte-lsb-first-p+ - #+clx-little-endian t - #-clx-little-endian nil) - -(defconstant +image-unit+ 32) - -(defconstant +image-pad+ 32) - - -;;----------------------------------------------------------------------------- -;; Foreign Functions -;;----------------------------------------------------------------------------- - -#+(and lucid apollo (not lcl3.0)) -(lucid::define-foreign-function '(connect-to-server "connect_to_server") - '((:val host :string) - (:val display :integer32)) - :integer32) - -#+(and lucid (not apollo) (not lcl3.0)) -(lucid::define-c-function connect-to-server (host display) - :result-type :integer) - -#+lcl3.0 -(lucid::def-foreign-function - (connect-to-server - (:language :c) - (:return-type :signed-32bit)) - (host :simple-string) - (display :signed-32bit)) - - -;;----------------------------------------------------------------------------- -;; Finding the server socket -;;----------------------------------------------------------------------------- - -;; These are here because dep-openmcl.lisp and dependent.lisp both need them -(defconstant +X-unix-socket-path+ - "/tmp/.X11-unix/X" - "The location of the X socket") - -(defun unix-socket-path-from-host (host display) - "Return the name of the unix domain socket for host and display, or -nil if a network socket should be opened." - (cond ((or (string= host "") (string= host "unix")) - (format nil "~A~D" +X-unix-socket-path+ display)) - #+darwin - ((and (> (length host) 10) (string= host "tmp/launch" :end1 10)) - (format nil "/~A:~D" host display)) - (t nil))) diff -Nru ecl-16.1.2/src/clx/dependent.lisp ecl-16.1.3+ds/src/clx/dependent.lisp --- ecl-16.1.2/src/clx/dependent.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/dependent.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,4097 +0,0 @@ -;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- - -;; This file contains some of the system dependent code for CLX - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(proclaim '(declaration array-register)) - -#+cmu -(setf (getf ext:*herald-items* :xlib) - `(" CLX X Library " ,*version*)) - - -;;; The size of the output buffer. Must be a multiple of 4. -(defparameter *output-buffer-size* 8192) - -#+explorer -(zwei:define-indentation event-case (1 1)) - -;;; Number of seconds to wait for a reply to a server request -(defparameter *reply-timeout* nil) - -#-(or clx-overlapping-arrays (not clx-little-endian)) -(progn - (defconstant +word-0+ 0) - (defconstant +word-1+ 1) - - (defconstant +long-0+ 0) - (defconstant +long-1+ 1) - (defconstant +long-2+ 2) - (defconstant +long-3+ 3)) - -#-(or clx-overlapping-arrays clx-little-endian) -(progn - (defconstant +word-0+ 1) - (defconstant +word-1+ 0) - - (defconstant +long-0+ 3) - (defconstant +long-1+ 2) - (defconstant +long-2+ 1) - (defconstant +long-3+ 0)) - -;;; Set some compiler-options for often used code - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +buffer-speed+ #+clx-debugging 1 #-clx-debugging 3 - "Speed compiler option for buffer code.") - (defconstant +buffer-safety+ #+clx-debugging 3 #-clx-debugging 0 - "Safety compiler option for buffer code.") - (defconstant +buffer-debug+ #+clx-debugging 2 #-clx-debugging 1 - "Debug compiler option for buffer code>") - (defun declare-bufmac () - `(declare (optimize - (speed ,+buffer-speed+) - (safety ,+buffer-safety+) - (debug ,+buffer-debug+)))) - ;; It's my impression that in lucid there's some way to make a - ;; declaration called fast-entry or something that causes a function - ;; to not do some checking on args. Sadly, we have no lucid manuals - ;; here. If such a declaration is available, it would be a good - ;; idea to make it here when +buffer-speed+ is 3 and +buffer-safety+ - ;; is 0. - (defun declare-buffun () - `(declare (optimize - (speed ,+buffer-speed+) - (safety ,+buffer-safety+) - (debug ,+buffer-debug+))))) - -(declaim (inline card8->int8 int8->card8 - card16->int16 int16->card16 - card32->int32 int32->card32)) - -#-Genera -(progn - -(defun card8->int8 (x) - (declare (type card8 x)) - (declare (clx-values int8)) - #.(declare-buffun) - (the int8 (if (logbitp 7 x) - (the int8 (- x #x100)) - x))) - -(defun int8->card8 (x) - (declare (type int8 x)) - (declare (clx-values card8)) - #.(declare-buffun) - (the card8 (ldb (byte 8 0) x))) - -(defun card16->int16 (x) - (declare (type card16 x)) - (declare (clx-values int16)) - #.(declare-buffun) - (the int16 (if (logbitp 15 x) - (the int16 (- x #x10000)) - x))) - -(defun int16->card16 (x) - (declare (type int16 x)) - (declare (clx-values card16)) - #.(declare-buffun) - (the card16 (ldb (byte 16 0) x))) - -(defun card32->int32 (x) - (declare (type card32 x)) - (declare (clx-values int32)) - #.(declare-buffun) - (the int32 (if (logbitp 31 x) - (the int32 (- x #x100000000)) - x))) - -(defun int32->card32 (x) - (declare (type int32 x)) - (declare (clx-values card32)) - #.(declare-buffun) - (the card32 (ldb (byte 32 0) x))) - -) - -#+Genera -(progn - -(defun card8->int8 (x) - (declare lt:(side-effects simple reducible)) - (if (logbitp 7 x) (- x #x100) x)) - -(defun int8->card8 (x) - (declare lt:(side-effects simple reducible)) - (ldb (byte 8 0) x)) - -(defun card16->int16 (x) - (declare lt:(side-effects simple reducible)) - (if (logbitp 15 x) (- x #x10000) x)) - -(defun int16->card16 (x) - (declare lt:(side-effects simple reducible)) - (ldb (byte 16 0) x)) - -(defun card32->int32 (x) - (declare lt:(side-effects simple reducible)) - (sys:%logldb (byte 32 0) x)) - -(defun int32->card32 (x) - (declare lt:(side-effects simple reducible)) - (ldb (byte 32 0) x)) - -) - -(declaim (inline aref-card8 aset-card8 aref-int8 aset-int8)) - -#-(or Genera lcl3.0 excl) -(progn - -(defun aref-card8 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card8)) - #.(declare-buffun) - (the card8 (aref a i))) - -(defun aset-card8 (v a i) - (declare (type card8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a i) v)) - -(defun aref-int8 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int8)) - #.(declare-buffun) - (card8->int8 (aref a i))) - -(defun aset-int8 (v a i) - (declare (type int8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a i) (int8->card8 v))) - -) - -#+Genera -(progn - -(defun aref-card8 (a i) - (aref a i)) - -(defun aset-card8 (v a i) - (zl:aset v a i)) - -(defun aref-int8 (a i) - (card8->int8 (aref a i))) - -(defun aset-int8 (v a i) - (zl:aset (int8->card8 v) a i)) - -) - -#+(or excl lcl3.0 clx-overlapping-arrays) -(declaim (inline aref-card16 aref-int16 aref-card32 aref-int32 aref-card29 - aset-card16 aset-int16 aset-card32 aset-int32 aset-card29)) - -#+(and clx-overlapping-arrays Genera) -(progn - -(defun aref-card16 (a i) - (aref a i)) - -(defun aset-card16 (v a i) - (zl:aset v a i)) - -(defun aref-int16 (a i) - (card16->int16 (aref a i))) - -(defun aset-int16 (v a i) - (zl:aset (int16->card16 v) a i) - v) - -(defun aref-card32 (a i) - (int32->card32 (aref a i))) - -(defun aset-card32 (v a i) - (zl:aset (card32->int32 v) a i)) - -(defun aref-int32 (a i) (aref a i)) - -(defun aset-int32 (v a i) - (zl:aset v a i)) - -(defun aref-card29 (a i) - (aref a i)) - -(defun aset-card29 (v a i) - (zl:aset v a i)) - -) - -#+(and clx-overlapping-arrays (not Genera)) -(progn - -(defun aref-card16 (a i) - (aref a i)) - -(defun aset-card16 (v a i) - (setf (aref a i) v)) - -(defun aref-int16 (a i) - (card16->int16 (aref a i))) - -(defun aset-int16 (v a i) - (setf (aref a i) (int16->card16 v)) - v) - -(defun aref-card32 (a i) - (aref a i)) - -(defun aset-card32 (v a i) - (setf (aref a i) v)) - -(defun aref-int32 (a i) - (card32->int32 (aref a i))) - -(defun aset-int32 (v a i) - (setf (aref a i) (int32->card32 v)) - v) - -(defun aref-card29 (a i) - (aref a i)) - -(defun aset-card29 (v a i) - (setf (aref a i) v)) - -) - -#+excl -(progn - -(defun aref-card8 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card8)) - #.(declare-buffun) - (the card8 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-byte))) - -(defun aset-card8 (v a i) - (declare (type card8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-byte) v)) - -(defun aref-int8 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int8)) - #.(declare-buffun) - (the int8 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :signed-byte))) - -(defun aset-int8 (v a i) - (declare (type int8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :signed-byte) v)) - -(defun aref-card16 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card16)) - #.(declare-buffun) - (the card16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-word))) - -(defun aset-card16 (v a i) - (declare (type card16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-word) v)) - -(defun aref-int16 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int16)) - #.(declare-buffun) - (the int16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :signed-word))) - -(defun aset-int16 (v a i) - (declare (type int16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :signed-word) v)) - -(defun aref-card32 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card32)) - #.(declare-buffun) - (the card32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-long))) - -(defun aset-card32 (v a i) - (declare (type card32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-long) v)) - -(defun aref-int32 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int32)) - #.(declare-buffun) - (the int32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :signed-long))) - -(defun aset-int32 (v a i) - (declare (type int32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :signed-long) v)) - -(defun aref-card29 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card29)) - #.(declare-buffun) - (the card29 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-long))) - -(defun aset-card29 (v a i) - (declare (type card29 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-long) v)) - -) - -#+lcl3.0 -(progn - -(defun aref-card8 (a i) - (declare (type buffer-bytes a) - (type array-index i) - (clx-values card8)) - #.(declare-buffun) - (the card8 (lucid::%svref-8bit a i))) - -(defun aset-card8 (v a i) - (declare (type card8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (lucid::%svref-8bit a i) v)) - -(defun aref-int8 (a i) - (declare (type buffer-bytes a) - (type array-index i) - (clx-values int8)) - #.(declare-buffun) - (the int8 (lucid::%svref-signed-8bit a i))) - -(defun aset-int8 (v a i) - (declare (type int8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (lucid::%svref-signed-8bit a i) v)) - -(defun aref-card16 (a i) - (declare (type buffer-bytes a) - (type array-index i) - (clx-values card16)) - #.(declare-buffun) - (the card16 (lucid::%svref-16bit a (index-ash i -1)))) - -(defun aset-card16 (v a i) - (declare (type card16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (lucid::%svref-16bit a (index-ash i -1)) v)) - -(defun aref-int16 (a i) - (declare (type buffer-bytes a) - (type array-index i) - (clx-values int16)) - #.(declare-buffun) - (the int16 (lucid::%svref-signed-16bit a (index-ash i -1)))) - -(defun aset-int16 (v a i) - (declare (type int16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (lucid::%svref-signed-16bit a (index-ash i -1)) v)) - -(defun aref-card32 (a i) - (declare (type buffer-bytes a) - (type array-index i) - (clx-values card32)) - #.(declare-buffun) - (the card32 (lucid::%svref-32bit a (index-ash i -2)))) - -(defun aset-card32 (v a i) - (declare (type card32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (lucid::%svref-32bit a (index-ash i -2)) v)) - -(defun aref-int32 (a i) - (declare (type buffer-bytes a) - (type array-index i) - (clx-values int32)) - #.(declare-buffun) - (the int32 (lucid::%svref-signed-32bit a (index-ash i -2)))) - -(defun aset-int32 (v a i) - (declare (type int32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (lucid::%svref-signed-32bit a (index-ash i -2)) v)) - -(defun aref-card29 (a i) - (declare (type buffer-bytes a) - (type array-index i) - (clx-values card29)) - #.(declare-buffun) - (the card29 (lucid::%svref-32bit a (index-ash i -2)))) - -(defun aset-card29 (v a i) - (declare (type card29 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (lucid::%svref-32bit a (index-ash i -2)) v)) - -) - - - -#-(or excl lcl3.0 clx-overlapping-arrays) -(progn - -(defun aref-card16 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card16)) - #.(declare-buffun) - (the card16 - (logior (the card16 - (ash (the card8 (aref a (index+ i +word-1+))) 8)) - (the card8 - (aref a (index+ i +word-0+)))))) - -(defun aset-card16 (v a i) - (declare (type card16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) - v) - -(defun aref-int16 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int16)) - #.(declare-buffun) - (the int16 - (logior (the int16 - (ash (the int8 (aref-int8 a (index+ i +word-1+))) 8)) - (the card8 - (aref a (index+ i +word-0+)))))) - -(defun aset-int16 (v a i) - (declare (type int16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) - v) - -(defun aref-card32 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card32)) - #.(declare-buffun) - (the card32 - (logior (the card32 - (ash (the card8 (aref a (index+ i +long-3+))) 24)) - (the card29 - (ash (the card8 (aref a (index+ i +long-2+))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i +long-1+))) 8)) - (the card8 - (aref a (index+ i +long-0+)))))) - -(defun aset-card32 (v a i) - (declare (type card32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) - (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) - (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) - v) - -(defun aref-int32 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int32)) - #.(declare-buffun) - (the int32 - (logior (the int32 - (ash (the int8 (aref-int8 a (index+ i +long-3+))) 24)) - (the card29 - (ash (the card8 (aref a (index+ i +long-2+))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i +long-1+))) 8)) - (the card8 - (aref a (index+ i +long-0+)))))) - -(defun aset-int32 (v a i) - (declare (type int32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) - (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) - (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) - v) - -(defun aref-card29 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card29)) - #.(declare-buffun) - (the card29 - (logior (the card29 - (ash (the card8 (aref a (index+ i +long-3+))) 24)) - (the card29 - (ash (the card8 (aref a (index+ i +long-2+))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i +long-1+))) 8)) - (the card8 - (aref a (index+ i +long-0+)))))) - -(defun aset-card29 (v a i) - (declare (type card29 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) - (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) - (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) - v) - -) - -(defsetf aref-card8 (a i) (v) - `(aset-card8 ,v ,a ,i)) - -(defsetf aref-int8 (a i) (v) - `(aset-int8 ,v ,a ,i)) - -(defsetf aref-card16 (a i) (v) - `(aset-card16 ,v ,a ,i)) - -(defsetf aref-int16 (a i) (v) - `(aset-int16 ,v ,a ,i)) - -(defsetf aref-card32 (a i) (v) - `(aset-card32 ,v ,a ,i)) - -(defsetf aref-int32 (a i) (v) - `(aset-int32 ,v ,a ,i)) - -(defsetf aref-card29 (a i) (v) - `(aset-card29 ,v ,a ,i)) - -;;; Other random conversions - -(defun rgb-val->card16 (value) - ;; Short floats are good enough - (declare (type rgb-val value)) - (declare (clx-values card16)) - #.(declare-buffun) - ;; Convert VALUE from float to card16 - (the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff))))) - -(defun card16->rgb-val (value) - ;; Short floats are good enough - (declare (type card16 value)) - (declare (clx-values short-float)) - #.(declare-buffun) - ;; Convert VALUE from card16 to float - (the short-float (* (the card16 value) #.(/ 1.0s0 #xffff)))) - -(defun radians->int16 (value) - ;; Short floats are good enough - (declare (type angle value)) - (declare (clx-values int16)) - #.(declare-buffun) - (the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0))))) - -(defun int16->radians (value) - ;; Short floats are good enough - (declare (type int16 value)) - (declare (clx-values short-float)) - #.(declare-buffun) - (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float)))) - - -#+(or cmu sbcl clisp ecl) (progn - -;;; This overrides the (probably incorrect) definition in clx.lisp. Since PI -;;; is irrational, there can't be a precise rational representation. In -;;; particular, the different float approximations will always be /=. This -;;; causes problems with type checking, because people might compute an -;;; argument in any precision. What we do is discard all the excess precision -;;; in the value, and see if the protocol encoding falls in the desired range -;;; (64'ths of a degree.) -;;; -(deftype angle () '(satisfies anglep)) - -(defun anglep (x) - (and (typep x 'real) - (<= (* -360 64) (radians->int16 x) (* 360 64)))) - -) - - -;;----------------------------------------------------------------------------- -;; Character transformation -;;----------------------------------------------------------------------------- - - -;;; This stuff transforms chars to ascii codes in card8's and back. -;;; You might have to hack it a little to get it to work for your machine. - -(declaim (inline char->card8 card8->char)) - -(macrolet ((char-translators () - (let ((alist - `(#-lispm - ;; The normal ascii codes for the control characters. - ,@`((#\Return . 13) - (#\Linefeed . 10) - (#\Rubout . 127) - (#\Page . 12) - (#\Tab . 9) - (#\Backspace . 8) - (#\Newline . 10) - (#\Space . 32)) - ;; One the lispm, #\Newline is #\Return, but we'd really like - ;; #\Newline to translate to ascii code 10, so we swap the - ;; Ascii codes for #\Return and #\Linefeed. We also provide - ;; mappings from the counterparts of these control characters - ;; so that the character mapping from the lisp machine - ;; character set to ascii is invertible. - #+lispm - ,@`((#\Return . 10) (,(code-char 10) . ,(char-code #\Return)) - (#\Linefeed . 13) (,(code-char 13) . ,(char-code #\Linefeed)) - (#\Rubout . 127) (,(code-char 127) . ,(char-code #\Rubout)) - (#\Page . 12) (,(code-char 12) . ,(char-code #\Page)) - (#\Tab . 9) (,(code-char 9) . ,(char-code #\Tab)) - (#\Backspace . 8) (,(code-char 8) . ,(char-code #\Backspace)) - (#\Newline . 10) (,(code-char 10) . ,(char-code #\Newline)) - (#\Space . 32) (,(code-char 32) . ,(char-code #\Space))) - ;; The rest of the common lisp charater set with the normal - ;; ascii codes for them. - (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36) - (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40) - (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44) - (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48) - (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52) - (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56) - (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60) - (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64) - (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68) - (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72) - (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76) - (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80) - (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84) - (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88) - (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92) - (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96) - (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100) - (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104) - (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108) - (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112) - (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116) - (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120) - (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124) - (#\} . 125) (#\~ . 126)))) - (cond ((dolist (pair alist nil) - (when (not (= (char-code (car pair)) (cdr pair))) - (return t))) - `(progn - (defconstant *char-to-card8-translation-table* - ',(let ((array (make-array - (let ((max-char-code 255)) - (dolist (pair alist) - (setq max-char-code - (max max-char-code - (char-code (car pair))))) - (1+ max-char-code)) - :element-type 'card8))) - (dotimes (i (length array)) - (setf (aref array i) (mod i 256))) - (dolist (pair alist) - (setf (aref array (char-code (car pair))) - (cdr pair))) - array)) - (defconstant *card8-to-char-translation-table* - ',(let ((array (make-array 256))) - (dotimes (i (length array)) - (setf (aref array i) (code-char i))) - (dolist (pair alist) - (setf (aref array (cdr pair)) (car pair))) - array)) - #-Genera - (progn - (defun char->card8 (char) - (declare (type base-char char)) - #.(declare-buffun) - (the card8 (aref (the (simple-array card8 (*)) - *char-to-card8-translation-table*) - (the array-index (char-code char))))) - (defun card8->char (card8) - (declare (type card8 card8)) - #.(declare-buffun) - (the base-char - (or (aref (the simple-vector *card8-to-char-translation-table*) - card8) - (error "Invalid CHAR code ~D." card8)))) - ) - #+Genera - (progn - (defun char->card8 (char) - (declare lt:(side-effects reader reducible)) - (aref *char-to-card8-translation-table* (char-code char))) - (defun card8->char (card8) - (declare lt:(side-effects reader reducible)) - (aref *card8-to-char-translation-table* card8)) - ) - #-Minima - (dotimes (i 256) - (unless (= i (char->card8 (card8->char i))) - (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S" - (list i - (card8->char i) - (char->card8 (card8->char i)))) - (return nil))) - #-Minima - (dotimes (i (length *char-to-card8-translation-table*)) - (let ((char (code-char i))) - (unless (eql char (card8->char (char->card8 char))) - (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S" - (list char - (char->card8 char) - (card8->char (char->card8 char)))) - (return nil)))))) - (t - `(progn - (defun char->card8 (char) - (declare (type base-char char)) - #.(declare-buffun) - (the card8 (char-code char))) - (defun card8->char (card8) - (declare (type card8 card8)) - #.(declare-buffun) - (the base-char (code-char card8))) - )))))) - (char-translators)) - -;;----------------------------------------------------------------------------- -;; Process Locking -;; -;; Common-Lisp doesn't provide process locking primitives, so we define -;; our own here, based on Zetalisp primitives. Holding-Lock is very -;; similar to with-lock on The TI Explorer, and a little more efficient -;; than with-process-lock on a Symbolics. -;;----------------------------------------------------------------------------- - -;;; MAKE-PROCESS-LOCK: Creating a process lock. - -#-(or LispM excl Minima sbcl (and cmu mp) (and ecl threads)) -(defun make-process-lock (name) - (declare (ignore name)) - nil) - -#+excl -(defun make-process-lock (name) - (mp:make-process-lock :name name)) - -#+(and LispM (not Genera)) -(defun make-process-lock (name) - (vector nil name)) - -#+Genera -(defun make-process-lock (name) - (process:make-lock name :flavor 'clx-lock)) - -#+Minima -(defun make-process-lock (name) - (minima:make-lock name :recursive t)) - -#+(and cmu mp) -(defun make-process-lock (name) - (mp:make-lock name)) - -#+sbcl -(defun make-process-lock (name) - (sb-thread:make-mutex :name name)) - -#+(and ecl threads) -(defun make-process-lock (name) - (mp:make-lock :name name :recursive t)) - -;;; HOLDING-LOCK: Execute a body of code with a lock held. - -;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN -;;; passes its timeout to the holding-lock macro, so any timeout you want to -;;; work for event-listen you should do for holding-lock. - -;; If you're not sharing DISPLAY objects within a multi-processing -;; shared-memory environment, this is sufficient -#-(or lispm excl lcl3.0 Minima sbcl (and CMU mp) (and ecl threads)) -(defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) - (declare (ignore locator display whostate timeout)) - `(progn ,@body)) - -;;; HOLDING-LOCK for CMU Common Lisp. -;;; -;;; We are not multi-processing, but we use this macro to try to protect -;;; against re-entering request functions. This can happen if an interrupt -;;; occurs and the handler attempts to use X over the same display connection. -;;; This can happen if the GC hooks are used to notify the user over the same -;;; display connection. We inhibit GC notifications since display of them -;;; could cause recursive entry into CLX. -;;; -#+(and CMU (not mp)) -(defmacro holding-lock ((locator display &optional whostate &key timeout) - &body body) - `(let #+cmu((ext:*gc-verbose* nil) - (ext:*gc-inhibit-hook* nil) - (ext:*before-gc-hooks* nil) - (ext:*after-gc-hooks* nil)) - #+sbcl() - ,locator ,display ,whostate ,timeout - (system:without-interrupts (progn ,@body)))) - -;;; HOLDING-LOCK for CMU Common Lisp with multi-processes. -;;; -#+(and cmu mp) -(defmacro holding-lock ((lock display &optional (whostate "CLX wait") - &key timeout) - &body body) - (declare (ignore display)) - `(mp:with-lock-held (,lock ,whostate ,@(and timeout `(:timeout ,timeout))) - ,@body)) - -#+clisp -(defmacro holding-lock ((lock display &optional (whostate "CLX wait") - &key timeout) - &body body) - (declare (ignore lock display whostate timeout)) - `(progn - ,@body)) - -#+(and ecl threads) -(defmacro holding-lock ((lock display &optional (whostate "CLX wait") - &key timeout) - &body body) - (declare (ignore display)) - `(mp::with-lock (,lock) - ,@body)) - -#+sbcl -(defmacro holding-lock ((lock display &optional (whostate "CLX wait") - &key timeout) - &body body) - ;; This macro is used by WITH-DISPLAY, which claims to be callable - ;; recursively. So, had better use a recursive lock. - ;; - ;; FIXME: This is hideously ugly. If WITH-TIMEOUT handled NIL - ;; timeouts... - (declare (ignore display whostate)) - (if timeout - `(if ,timeout - (handler-case - (sb-ext:with-timeout ,timeout - (sb-thread:with-recursive-lock (,lock) - ,@body)) - (sb-ext:timeout () nil)) - (sb-thread:with-recursive-lock (,lock) - ,@body)) - `(sb-thread:with-recursive-lock (,lock) - ,@body))) - -#+Genera -(defmacro holding-lock ((locator display &optional whostate &key timeout) - &body body) - (declare (ignore whostate)) - `(process:with-lock (,locator :timeout ,timeout) - (let ((.debug-io. (buffer-debug-io ,display))) - (scl:let-if .debug-io. ((*debug-io* .debug-io.)) - ,@body)))) - -#+(and lispm (not Genera)) -(defmacro holding-lock ((locator display &optional whostate &key timeout) - &body body) - (declare (ignore display)) - ;; This macro is for use in a multi-process environment. - (let ((lock (gensym)) - (have-lock (gensym)) - (timeo (gensym))) - `(let* ((,lock (zl:locf (svref ,locator 0))) - (,have-lock (eq (car ,lock) sys:current-process)) - (,timeo ,timeout)) - (unwind-protect - (when (cond (,have-lock) - ((#+explorer si:%store-conditional - #-explorer sys:store-conditional - ,lock nil sys:current-process)) - ((null ,timeo) - (sys:process-lock ,lock nil ,(or whostate "CLX Lock"))) - ((sys:process-wait-with-timeout - ,(or whostate "CLX Lock") (round (* ,timeo 60.)) - #'(lambda (lock process) - (#+explorer si:%store-conditional - #-explorer sys:store-conditional - lock nil process)) - ,lock sys:current-process))) - ,@body) - (unless ,have-lock - (#+explorer si:%store-conditional - #-explorer sys:store-conditional - ,lock sys:current-process nil)))))) - -;; Lucid has a process locking mechanism as well under release 3.0 -#+lcl3.0 -(defmacro holding-lock ((locator display &optional whostate &key timeout) - &body body) - (declare (ignore display)) - (if timeout - ;; Hair to support timeout. - `(let ((.have-lock. (eq ,locator lcl:*current-process*)) - (.timeout. ,timeout)) - (unwind-protect - (when (cond (.have-lock.) - ((conditional-store ,locator nil lcl:*current-process*)) - ((null .timeout.) - (lcl:process-lock ,locator) - t) - ((lcl:process-wait-with-timeout ,whostate .timeout. - #'(lambda () - (conditional-store ,locator nil lcl:*current-process*)))) - ;; abort the PROCESS-UNLOCK if actually timing out - (t - (setf .have-lock. :abort) - nil)) - ,@body) - (unless .have-lock. - (lcl:process-unlock ,locator)))) - `(lcl:with-process-lock (,locator) - ,@body))) - - -#+excl -(defmacro holding-lock ((locator display &optional whostate &key timeout) - &body body) - (declare (ignore display)) - `(let (.hl-lock. .hl-obtained-lock. .hl-curproc.) - (unwind-protect - (block .hl-doit. - (when mp::*scheduler-stack-group* ; fast test for scheduler running - (setq .hl-lock. ,locator - .hl-curproc. mp::*current-process*) - (when (and .hl-curproc. ; nil if in process-wait fun - (not (eq (mp::process-lock-locker .hl-lock.) - .hl-curproc.))) - ;; Then we need to grab the lock. - ,(if timeout - `(if (not (mp::process-lock .hl-lock. .hl-curproc. - ,whostate ,timeout)) - (return-from .hl-doit. nil)) - `(mp::process-lock .hl-lock. .hl-curproc. - ,@(when whostate `(,whostate)))) - ;; There is an apparent race condition here. However, there is - ;; no actual race condition -- our implementation of mp:process- - ;; lock guarantees that the lock will still be held when it - ;; returns, and no interrupt can happen between that and the - ;; execution of the next form. -- jdi 2/27/91 - (setq .hl-obtained-lock. t))) - ,@body) - (if (and .hl-obtained-lock. - ;; Note -- next form added to allow error handler inside - ;; body to unlock the lock prematurely if it knows that - ;; the current process cannot possibly continue but will - ;; throw out (or is it throw up?). - (eq (mp::process-lock-locker .hl-lock.) .hl-curproc.)) - (mp::process-unlock .hl-lock. .hl-curproc.))))) - -#+Minima -(defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) - `(holding-lock-1 #'(lambda () ,@body) ,locator ,display - ,@(and whostate `(:whostate ,whostate)) - ,@(and timeout `(:timeout ,timeout)))) - -#+Minima -(defun holding-lock-1 (continuation lock display &key (whostate "Lock") timeout) - (declare (dynamic-extent continuation)) - (declare (ignore display whostate timeout)) - (minima:with-lock (lock) - (funcall continuation))) - -;;; WITHOUT-ABORTS - -;;; If you can inhibit asynchronous keyboard aborts inside the body of this -;;; macro, then it is a good idea to do this. This macro is wrapped around -;;; request writing and reply reading to ensure that requests are atomically -;;; written and replies are atomically read from the stream. - -#-(or Genera excl lcl3.0) -(defmacro without-aborts (&body body) - `(progn ,@body)) - -#+Genera -(defmacro without-aborts (&body body) - `(sys:without-aborts (clx "CLX is in the middle of an operation that should be atomic.") - ,@body)) - -#+excl -(defmacro without-aborts (&body body) - `(without-interrupts ,@body)) - -#+lcl3.0 -(defmacro without-aborts (&body body) - `(lcl:with-interruptions-inhibited ,@body)) - -;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value. -;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's -;;; value changes. - -#-(or lispm excl lcl3.0 Minima (and sb-thread sbcl) (and cmu mp) (and ecl threads)) -(defun process-block (whostate predicate &rest predicate-args) - (declare (ignore whostate)) - (or (apply predicate predicate-args) - (error "Program tried to wait with no scheduler."))) - -#+Genera -(defun process-block (whostate predicate &rest predicate-args) - (declare (type function predicate) - #+clx-ansi-common-lisp - (dynamic-extent predicate) - #-clx-ansi-common-lisp - (sys:downward-funarg predicate)) - (apply #'process:block-process whostate predicate predicate-args)) - -#+(and lispm (not Genera)) -(defun process-block (whostate predicate &rest predicate-args) - (declare (type function predicate) - #+clx-ansi-common-lisp - (dynamic-extent predicate) - #-clx-ansi-common-lisp - (sys:downward-funarg predicate)) - (apply #'global:process-wait whostate predicate predicate-args)) - -#+excl -(defun process-block (whostate predicate &rest predicate-args) - (if mp::*scheduler-stack-group* - (apply #'mp::process-wait whostate predicate predicate-args) - (or (apply predicate predicate-args) - (error "Program tried to wait with no scheduler.")))) - -#+lcl3.0 -(defun process-block (whostate predicate &rest predicate-args) - (declare (dynamic-extent predicate-args)) - (apply #'lcl:process-wait whostate predicate predicate-args)) - -#+Minima -(defun process-block (whostate predicate &rest predicate-args) - (declare (type function predicate) - (dynamic-extent predicate)) - (apply #'minima:process-wait whostate predicate predicate-args)) - -#+(and cmu mp) -(defun process-block (whostate predicate &rest predicate-args) - (declare (type function predicate)) - (mp:process-wait whostate #'(lambda () - (apply predicate predicate-args)))) - -#+(and sbcl sb-thread) -(progn - (declaim (inline yield)) - (defun yield () - (declare (optimize speed (safety 0))) - (sb-alien:alien-funcall - (sb-alien:extern-alien "sched_yield" (function sb-alien:int))) - (values))) - -#+(and sbcl sb-thread) -(defun process-block (whostate predicate &rest predicate-args) - (declare (ignore whostate)) - (declare (type function predicate)) - (loop - (when (apply predicate predicate-args) - (return)) - (yield))) - -#+(and ecl threads) -(defun process-block (whostate predicate &rest predicate-args) - (declare (ignore whostate)) - (declare (type function predicate)) - (loop - (when (apply predicate predicate-args) - (return)) - (mp:process-yield))) - -;;; FIXME: the below implementation for threaded PROCESS-BLOCK using -;;; queues and condition variables might seem better, but in fact it -;;; turns out to make performance extremely suboptimal, at least as -;;; measured by McCLIM on linux 2.4 kernels. -- CSR, 2003-11-10 -#+(or) -(defvar *process-conditions* (make-hash-table)) - -#+(or) -(defun process-block (whostate predicate &rest predicate-args) - (declare (ignore whostate)) - (declare (type function predicate)) - (let* ((pid (sb-thread:current-thread-id)) - (last (gethash pid *process-conditions*)) - (lock - (or (car last) - (sb-thread:make-mutex :name (format nil "lock ~A" pid)))) - (queue - (or (cdr last) - (sb-thread:make-waitqueue :name (format nil "queue ~A" pid))))) - (unless last - (setf (gethash pid *process-conditions*) (cons lock queue))) - (sb-thread:with-mutex (lock) - (loop - (when (apply predicate predicate-args) (return)) - (handler-case - (sb-ext:with-timeout .5 - (sb-thread:condition-wait queue lock)) - (sb-ext:timeout () - (format *trace-output* "thread ~A, process-block timed out~%" - (sb-thread:current-thread-id) ))))))) - -;;; PROCESS-WAKEUP: Check some other process' wait function. - -(declaim (inline process-wakeup)) - -#-(or excl Genera Minima (and sbcl sb-thread) (and cmu mp) (and ecl threads)) -(defun process-wakeup (process) - (declare (ignore process)) - nil) - -#+excl -(defun process-wakeup (process) - (let ((curproc mp::*current-process*)) - (when (and curproc process) - (unless (mp::process-p curproc) - (error "~s is not a process" curproc)) - (unless (mp::process-p process) - (error "~s is not a process" process)) - (if (> (mp::process-priority process) (mp::process-priority curproc)) - (mp::process-allow-schedule process))))) - -#+Genera -(defun process-wakeup (process) - (process:wakeup process)) - -#+Minima -(defun process-wakeup (process) - (when process - (minima:process-wakeup process))) - -#+(and cmu mp) -(defun process-wakeup (process) - (declare (ignore process)) - (mp:process-yield)) - -#+(and sb-thread sbcl) -(defun process-wakeup (process) - (declare (ignore process)) - (yield)) - -#+(and ecl threads) -(defun process-wakeup (process) - (declare (ignore process)) - (mp:process-yield)) - -#+(or) -(defun process-wakeup (process) - (declare (ignore process)) - (destructuring-bind (lock . queue) - (gethash (sb-thread:current-thread-id) *process-conditions* - (cons nil nil)) - (declare (ignore lock)) - (when queue - (sb-thread:condition-notify queue)))) - - -;;; CURRENT-PROCESS: Return the current process object for input locking and -;;; for calling PROCESS-WAKEUP. - -(declaim (inline current-process)) - -;;; Default return NIL, which is acceptable even if there is a scheduler. - -#-(or lispm excl lcl3.0 sbcl Minima (and cmu mp) (and ecl threads)) -(defun current-process () - nil) - -#+lispm -(defun current-process () - sys:current-process) - -#+excl -(defun current-process () - (and mp::*scheduler-stack-group* - mp::*current-process*)) - -#+lcl3.0 -(defun current-process () - lcl:*current-process*) - -#+Minima -(defun current-process () - (minima:current-process)) - -#+(or (and cmu mp) (and ecl threads)) -(defun current-process () - mp:*current-process*) - -#+sbcl -(defun current-process () - sb-thread:*current-thread*) - -;;; WITHOUT-INTERRUPTS -- provide for atomic operations. - -#-(or lispm excl lcl3.0 Minima cmu) -(defmacro without-interrupts (&body body) - `(progn ,@body)) - -#+(and lispm (not Genera)) -(defmacro without-interrupts (&body body) - `(sys:without-interrupts ,@body)) - -#+Genera -(defmacro without-interrupts (&body body) - `(process:with-no-other-processes ,@body)) - -#+LCL3.0 -(defmacro without-interrupts (&body body) - `(lcl:with-scheduling-inhibited ,@body)) - -#+Minima -(defmacro without-interrupts (&body body) - `(minima:with-no-other-processes ,@body)) - -#+cmu -(defmacro without-interrupts (&body body) - `(system:without-interrupts ,@body)) - -#+ecl -(defmacro without-interrupts (&body body) - `(mp:without-interrupts ,@body)) - -#+sbcl -(defvar *without-interrupts-sic-lock* - (sb-thread:make-mutex :name "lock simulating *without-interrupts*")) -#+sbcl -(defmacro without-interrupts (&body body) - `(sb-thread:with-recursive-lock (*without-interrupts-sic-lock*) - ,@body)) - -;;; CONDITIONAL-STORE: - -;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times. -;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD. -#-sbcl -(defmacro conditional-store (place old-value new-value) - `(without-interrupts - (cond ((eq ,place ,old-value) - (setf ,place ,new-value) - t)))) - -#+sbcl -(progn - (defvar *conditional-store-lock* - (sb-thread:make-mutex :name "conditional store")) - (defmacro conditional-store (place old-value new-value) - `(sb-thread:with-mutex (*conditional-store-lock*) - (cond ((eq ,place ,old-value) - (setf ,place ,new-value) - t))))) - -;;;---------------------------------------------------------------------------- -;;; IO Error Recovery -;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro. -;;; It prevents multiple mindless errors when the network craters. -;;; -;;;---------------------------------------------------------------------------- - -#-Genera -(defmacro wrap-buf-output ((buffer) &body body) - ;; Error recovery wrapper - `(unless (buffer-dead ,buffer) - ,@body)) - -#+Genera -(defmacro wrap-buf-output ((buffer) &body body) - ;; Error recovery wrapper - `(let ((.buffer. ,buffer)) - (unless (buffer-dead .buffer.) - (scl:condition-bind - (((sys:network-error) - #'(lambda (error) - (scl:condition-case () - (funcall (buffer-close-function .buffer.) .buffer. :abort t) - (sys:network-error)) - (setf (buffer-dead .buffer.) error) - (setf (buffer-output-stream .buffer.) nil) - (setf (buffer-input-stream .buffer.) nil) - nil))) - ,@body)))) - -#-Genera -(defmacro wrap-buf-input ((buffer) &body body) - (declare (ignore buffer)) - ;; Error recovery wrapper - `(progn ,@body)) - -#+Genera -(defmacro wrap-buf-input ((buffer) &body body) - ;; Error recovery wrapper - `(let ((.buffer. ,buffer)) - (scl:condition-bind - (((sys:network-error) - #'(lambda (error) - (scl:condition-case () - (funcall (buffer-close-function .buffer.) .buffer. :abort t) - (sys:network-error)) - (setf (buffer-dead .buffer.) error) - (setf (buffer-output-stream .buffer.) nil) - (setf (buffer-input-stream .buffer.) nil) - nil))) - ,@body))) - - -;;;---------------------------------------------------------------------------- -;;; System dependent IO primitives -;;; Functions for opening, reading writing forcing-output and closing -;;; the stream to the server. -;;;---------------------------------------------------------------------------- - -;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X -;;; server - -#-(or explorer Genera lucid kcl ibcl excl Minima CMU sbcl ecl clisp) -(defun open-x-stream (host display protocol) - host display protocol ;; unused - (error "OPEN-X-STREAM not implemented yet.")) - -#+clisp -(defun open-x-stream (host display protocol) - (declare (ignore protocol) - (type (integer 0) display)) - (let ((socket - ;; are we dealing with a localhost? - (when (or (string= host "") - (string= host "unix")) - ;; ok, try to connect to a AF_UNIX domain socket - (sys::make-socket-stream "" display)))) - (if socket - socket - ;; try to connect by hand - (let ((host (host-address host))) - (when host - ;; Fixme: get a descent ip standard in CLX: a vector! - (let ((ip (format nil - "~{~D~^.~}" - (rest host)))) - (socket:socket-connect (+ 6000 display) ip - :element-type '(unsigned-byte 8)))))))) - - -;;; Genera: - -;;; TCP and DNA are both layered products, so try to work with either one. - -#+Genera -(when (fboundp 'tcp:add-tcp-port-for-protocol) - (tcp:add-tcp-port-for-protocol :x-window-system 6000)) - -#+Genera -(when (fboundp 'dna:add-dna-contact-id-for-protocol) - (dna:add-dna-contact-id-for-protocol :x-window-system "X$X0")) - -#+Genera -(net:define-protocol :x-window-system (:x-window-system :byte-stream) - (:invoke-with-stream ((stream :characters nil :ascii-translation nil)) - stream)) - -#+Genera -(eval-when (compile) - (compiler:function-defined 'tcp:open-tcp-stream) - (compiler:function-defined 'dna:open-dna-bidirectional-stream)) - -#+Genera -(defun open-x-stream (host display protocol) - (let ((host (net:parse-host host))) - (if (or protocol (plusp display)) - ;; The protocol was specified or the display isn't 0, so we - ;; can't use the Generic Network System. If the protocol was - ;; specified, then use that protocol, otherwise, blindly use - ;; TCP. - (ccase protocol - ((:tcp nil) - (tcp:open-tcp-stream - host (+ *x-tcp-port* display) nil - :direction :io - :characters nil - :ascii-translation nil)) - ((:dna) - (dna:open-dna-bidirectional-stream - host (format nil "X$X~D" display) - :characters nil - :ascii-translation nil))) - (let ((neti:*invoke-service-automatic-retry* t)) - (net:invoke-service-on-host :x-window-system host))))) - -#+explorer -(defun open-x-stream (host display protocol) - (declare (ignore protocol)) - (net:open-connection-on-medium - (net:parse-host host) ;Host - :byte-stream ;Medium - "X11" ;Logical contact name - :stream-type :character-stream - :direction :bidirectional - :timeout-after-open nil - :remote-port (+ *x-tcp-port* display))) - -#+explorer -(net:define-logical-contact-name - "X11" - `((:local "X11") - (:chaos "X11") - (:nsp-stream "X11") - (:tcp ,*x-tcp-port*))) - -#+lucid -(defun open-x-stream (host display protocol) - protocol ;; unused - (let ((fd (connect-to-server host display))) - (when (minusp fd) - (error "Failed to connect to server: ~A ~D" host display)) - (user::make-lisp-stream :input-handle fd - :output-handle fd - :element-type 'unsigned-byte - #-lcl3.0 :stream-type #-lcl3.0 :ephemeral))) - -#+(or kcl ibcl) -(defun open-x-stream (host display protocol) - protocol ;; unused - (let ((stream (open-socket-stream host display))) - (if (streamp stream) - stream - (error "Cannot connect to server: ~A:~D" host display)))) - -#+excl -;; -;; Note that since we don't use the CL i/o facilities to do i/o, the display -;; input and output "stream" is really a file descriptor (fixnum). -;; -(defun open-x-stream (host display protocol) - (declare (ignore protocol));; unused - (let ((fd (connect-to-server (string host) display))) - (when (minusp fd) - (error "Failed to connect to server: ~A ~D" host display)) - fd)) - -#+Minima -(defun open-x-stream (host display protocol) - (declare (ignore protocol));; unused - (minima:open-tcp-stream :foreign-address (apply #'minima:make-ip-address - (cdr (host-address host))) - :foreign-port (+ *x-tcp-port* display))) - -#+(or sbcl ecl) -(defun open-x-stream (host display protocol) - (declare (ignore protocol) - (type (integer 0) display)) - (let ((local-socket-path (unix-socket-path-from-host host display))) - (socket-make-stream - (if local-socket-path - (let ((s (make-instance 'local-socket :type :stream))) - (socket-connect s local-socket-path) - s) - (let ((host (car (host-ent-addresses (get-host-by-name host))))) - (when host - (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))) - (socket-connect s host (+ 6000 display)) - s)))) - :element-type '(unsigned-byte 8) - :input t :output t :buffering :none))) - -;;; BUFFER-READ-DEFAULT - read data from the X stream - -#+(or Genera explorer) -(defun buffer-read-default (display vector start end timeout) - ;; returns non-NIL if EOF encountered - ;; Returns :TIMEOUT when timeout exceeded - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null (real 0 *)) timeout)) - #.(declare-buffun) - (let ((stream (display-input-stream display))) - (or (cond ((null stream)) - ((funcall stream :listen) nil) - ((and timeout (= timeout 0)) :timeout) - ((buffer-input-wait-default display timeout))) - (multiple-value-bind (ignore eofp) - (funcall stream :string-in nil vector start end) - eofp)))) - - -#+excl -;; -;; Rewritten 10/89 to not use foreign function interface to do I/O. -;; -(defun buffer-read-default (display vector start end timeout) - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null (real 0 *)) timeout)) - #.(declare-buffun) - - (let* ((howmany (- end start)) - (fd (display-input-stream display))) - (declare (type array-index howmany) - (fixnum fd)) - (or (cond ((fd-char-avail-p fd) nil) - ((and timeout (= timeout 0)) :timeout) - ((buffer-input-wait-default display timeout))) - (fd-read-bytes fd vector start howmany)))) - - -#+lcl3.0 -(defmacro with-underlying-stream ((variable stream display direction) &body body) - `(let ((,variable - (or (getf (display-plist ,display) ',direction) - (setf (getf (display-plist ,display) ',direction) - (lucid::underlying-stream - ,stream ,(if (eq direction 'input) :input :output)))))) - ,@body)) - -#+lcl3.0 -(defun buffer-read-default (display vector start end timeout) - ;;Note that LISTEN must still be done on "slow stream" or the I/O system - ;;gets confused. But reading should be done from "fast stream" for speed. - ;;We used to inhibit scheduling because there were races in Lucid's - ;;multitasking system. Empirical evidence suggests they may be gone now. - ;;Should you decide you need to inhibit scheduling, do it around the - ;;lcl:read-array. - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null (real 0 *)) timeout)) - #.(declare-buffun) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (or (cond ((null stream)) - ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) - ((buffer-input-wait-default display timeout))) - (with-underlying-stream (stream stream display input) - (eq (lcl:read-array stream vector start end nil :eof) :eof))))) - -#+Minima -(defun buffer-read-default (display vector start end timeout) - ;; returns non-NIL if EOF encountered - ;; Returns :TIMEOUT when timeout exceeded - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null (real 0 *)) timeout)) - #.(declare-buffun) - (let ((stream (display-input-stream display))) - (or (cond ((null stream)) - ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) - ((buffer-input-wait-default display timeout))) - (eq :eof (minima:read-vector vector stream nil start end))))) - -;;; BUFFER-READ-DEFAULT for CMU Common Lisp. -;;; -;;; If timeout is 0, then we call LISTEN to see if there is any input. -;;; Timeout 0 is the only case where READ-INPUT dives into BUFFER-READ without -;;; first calling BUFFER-INPUT-WAIT-DEFAULT. -;;; -#+(or CMU sbcl) -(defun buffer-read-default (display vector start end timeout) - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null fixnum) timeout)) - #.(declare-buffun) - (cond ((and (eql timeout 0) - (not (listen (display-input-stream display)))) - :timeout) - (t - (#+cmu system:read-n-bytes - #+sbcl sb-sys:read-n-bytes - (display-input-stream display) - vector start (- end start)) - nil))) - -#+(or ecl clisp) -(defun buffer-read-default (display vector start end timeout) - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null fixnum) timeout)) - #.(declare-buffun) - (cond ((and (eql timeout 0) - (not (listen (display-input-stream display)))) - :timeout) - (t - (read-sequence vector - (display-input-stream display) - :start start - :end end) - nil))) - -;;; WARNING: -;;; CLX performance will suffer if your lisp uses read-byte for -;;; receiving all data from the X Window System server. -;;; You are encouraged to write a specialized version of -;;; buffer-read-default that does block transfers. -#-(or Genera explorer excl lcl3.0 Minima CMU sbcl ecl clisp) -(defun buffer-read-default (display vector start end timeout) - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null (real 0 *)) timeout)) - #.(declare-buffun) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (or (cond ((null stream)) - ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) - ((buffer-input-wait-default display timeout))) - (do* ((index start (index1+ index))) - ((index>= index end) nil) - (declare (type array-index index)) - (let ((c (read-byte stream nil nil))) - (declare (type (or null card8) c)) - (if (null c) - (return t) - (setf (aref vector index) (the card8 c)))))))) - -;;; BUFFER-WRITE-DEFAULT - write data to the X stream - -#+(or Genera explorer) -(defun buffer-write-default (vector display start end) - ;; The default buffer write function for use with common-lisp streams - (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) - #.(declare-buffun) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (write-string vector stream :start start :end end)))) - -#+excl -(defun buffer-write-default (vector display start end) - (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) - #.(declare-buffun) - (excl::filesys-write-bytes (display-output-stream display) vector start - (- end start))) - -#+lcl3.0 -(defun buffer-write-default (vector display start end) - ;;We used to inhibit scheduling because there were races in Lucid's - ;;multitasking system. Empirical evidence suggests they may be gone now. - ;;Should you decide you need to inhibit scheduling, do it around the - ;;lcl:write-array. - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end)) - #.(declare-buffun) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (with-underlying-stream (stream stream display output) - (lcl:write-array stream vector start end))))) - -#+Minima -(defun buffer-write-default (vector display start end) - ;; The default buffer write function for use with common-lisp streams - (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) - #.(declare-buffun) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (minima:write-vector vector stream start end)))) - -#+CMU -(defun buffer-write-default (vector display start end) - (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) - #.(declare-buffun) - (system:output-raw-bytes (display-output-stream display) vector start end) - nil) - -#+(or sbcl ecl clisp) -(defun buffer-write-default (vector display start end) - (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) - #.(declare-buffun) - (write-sequence vector (display-output-stream display) :start start :end end) - nil) - -;;; WARNING: -;;; CLX performance will be severely degraded if your lisp uses -;;; write-byte to send all data to the X Window System server. -;;; You are STRONGLY encouraged to write a specialized version -;;; of buffer-write-default that does block transfers. - -#-(or Genera explorer excl lcl3.0 Minima CMU sbcl clisp ecl) -(defun buffer-write-default (vector display start end) - ;; The default buffer write function for use with common-lisp streams - (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) - #.(declare-buffun) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (with-vector (vector buffer-bytes) - (do ((index start (index1+ index))) - ((index>= index end)) - (declare (type array-index index)) - (write-byte (aref vector index) stream)))))) - -;;; buffer-force-output-default - force output to the X stream - -#+excl -(defun buffer-force-output-default (display) - ;; buffer-write-default does the actual writing. - (declare (ignore display))) - -#-(or excl) -(defun buffer-force-output-default (display) - ;; The default buffer force-output function for use with common-lisp streams - (declare (type display display)) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (force-output stream)))) - -;;; BUFFER-CLOSE-DEFAULT - close the X stream - -#+excl -(defun buffer-close-default (display &key abort) - ;; The default buffer close function for use with common-lisp streams - (declare (type display display) - (ignore abort)) - #.(declare-buffun) - (excl::filesys-checking-close (display-output-stream display))) - -#-(or excl) -(defun buffer-close-default (display &key abort) - ;; The default buffer close function for use with common-lisp streams - (declare (type display display)) - #.(declare-buffun) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (close stream :abort abort)))) - -;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the -;;; buffer. This is called in read-input between requests, so that a process -;;; waiting for input is abortable when between requests. Should return -;;; :TIMEOUT if it times out, NIL otherwise. - -;;; The default implementation - -;; Poll for input every *buffer-read-polling-time* SECONDS. -#-(or Genera explorer excl lcl3.0 CMU sbcl) -(defparameter *buffer-read-polling-time* 0.5) - -#-(or Genera explorer excl lcl3.0 CMU sbcl clisp) -(defun buffer-input-wait-default (display timeout) - (declare (type display display) - (type (or null (real 0 *)) timeout)) - (declare (clx-values timeout)) - - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (cond ((null stream)) - ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) - ((not (null timeout)) - (multiple-value-bind (npoll fraction) - (truncate timeout *buffer-read-polling-time*) - (dotimes (i npoll) ; Sleep for a time, then listen again - (sleep *buffer-read-polling-time*) - (when (listen stream) - (return-from buffer-input-wait-default nil))) - (when (plusp fraction) - (sleep fraction) ; Sleep a fraction of a second - (when (listen stream) ; and listen one last time - (return-from buffer-input-wait-default nil))) - :timeout))))) - -#+(or CMU sbcl clisp) -(defun buffer-input-wait-default (display timeout) - (declare (type display display) - (type (or null number) timeout)) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (cond ((null stream)) - ((listen stream) nil) - ((eql timeout 0) :timeout) - (t - (if #+sbcl (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd stream) - :input timeout) - #+mp (mp:process-wait-until-fd-usable - (system:fd-stream-fd stream) :input timeout) - #+clisp (multiple-value-bind (sec usec) (floor (or timeout 0)) - (ext:socket-status stream (and timeout sec) - (round usec 1d-6))) - #-(or sbcl mp clisp) (system:wait-until-fd-usable - (system:fd-stream-fd stream) :input timeout) - nil - :timeout))))) - -#+Genera -(defun buffer-input-wait-default (display timeout) - (declare (type display display) - (type (or null (real 0 *)) timeout)) - (declare (clx-values timeout)) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (cond ((null stream)) - ((scl:send stream :listen) nil) - ((and timeout (= timeout 0)) :timeout) - ((null timeout) (si:stream-input-block stream "CLX Input")) - (t - (scl:condition-bind ((neti:protocol-timeout - #'(lambda (error) - (when (eq stream (scl:send error :stream)) - (return-from buffer-input-wait-default :timeout))))) - (neti:with-stream-timeout (stream :input timeout) - (si:stream-input-block stream "CLX Input"))))) - nil)) - -#+explorer -(defun buffer-input-wait-default (display timeout) - (declare (type display display) - (type (or null (real 0 *)) timeout)) - (declare (clx-values timeout)) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (cond ((null stream)) - ((zl:send stream :listen) nil) - ((and timeout (= timeout 0)) :timeout) - ((null timeout) - (si:process-wait "CLX Input" stream :listen)) - (t - (unless (si:process-wait-with-timeout - "CLX Input" (round (* timeout 60.)) stream :listen) - (return-from buffer-input-wait-default :timeout)))) - nil)) - -#+excl -;; -;; This is used so an 'eq' test may be used to find out whether or not we can -;; safely throw this process out of the CLX read loop. -;; -(defparameter *read-whostate* "waiting for input from X server") - -;; -;; Note that this function returns nil on error if the scheduler is running, -;; t on error if not. This is ok since buffer-read will detect the error. -;; -#+excl -(defun buffer-input-wait-default (display timeout) - (declare (type display display) - (type (or null (real 0 *)) timeout)) - (declare (clx-values timeout)) - (let ((fd (display-input-stream display))) - (declare (fixnum fd)) - (when (>= fd 0) - (cond ((fd-char-avail-p fd) - nil) - - ;; Otherwise no bytes were available on the socket - ((and timeout (= timeout 0)) - ;; If there aren't enough and timeout == 0, timeout. - :timeout) - - ;; If the scheduler is running let it do timeouts. - (mp::*scheduler-stack-group* - #+allegro - (if (not - (mp:wait-for-input-available fd :whostate *read-whostate* - :wait-function #'fd-char-avail-p - :timeout timeout)) - (return-from buffer-input-wait-default :timeout)) - #-allegro - (mp::wait-for-input-available fd :whostate *read-whostate* - :wait-function #'fd-char-avail-p)) - - ;; Otherwise we have to handle timeouts by hand, and call select() - ;; to block until input is available. Note we don't really handle - ;; the interaction of interrupts and (numberp timeout) here. XX - (t - (let ((res 0)) - (declare (fixnum res)) - (with-interrupt-checking-on - (loop - (setq res (fd-wait-for-input fd (if (null timeout) 0 - (truncate timeout)))) - (cond ((plusp res) ; success - (return nil)) - ((eq res 0) ; timeout - (return :timeout)) - ((eq res -1) ; error - (return t)) - ;; Otherwise we got an interrupt -- go around again. - ))))))))) - - -#+lcl3.0 -(defun buffer-input-wait-default (display timeout) - (declare (type display display) - (type (or null (real 0 *)) timeout) - (clx-values timeout)) - #.(declare-buffun) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (cond ((null stream)) - ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) - ((with-underlying-stream (stream stream display input) - (lucid::waiting-for-input-from-stream stream - (lucid::with-io-unlocked - (if (null timeout) - (lcl:process-wait "CLX Input" #'listen stream) - (lcl:process-wait-with-timeout - "CLX Input" timeout #'listen stream))))) - nil) - (:timeout)))) - - -;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the -;;; buffer. This should never block, so it can be called from the scheduler. - -;;; The default implementation is to just use listen. -#-(or excl) -(defun buffer-listen-default (display) - (declare (type display display)) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (if (null stream) - t - (listen stream)))) - -#+excl -(defun buffer-listen-default (display) - (declare (type display display)) - (let ((fd (display-input-stream display))) - (declare (type fixnum fd)) - (if (= fd -1) - t - (fd-char-avail-p fd)))) - - -;;;---------------------------------------------------------------------------- -;;; System dependent speed hacks -;;;---------------------------------------------------------------------------- - -;; -;; WITH-STACK-LIST is used by WITH-STATE as a memory saving feature. -;; If your lisp doesn't have stack-lists, and you're worried about -;; consing garbage, you may want to re-write this to allocate and -;; initialize lists from a resource. -;; -#-lispm -(defmacro with-stack-list ((var &rest elements) &body body) - ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body) - ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body) - ;; except that the list produced by MAPCAR resides on the stack and - ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. - `(let ((,var (list ,@elements))) - (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) - ,@body)) - -#-lispm -(defmacro with-stack-list* ((var &rest elements) &body body) - ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body) - ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body) - ;; except that the list produced by MAPCAR resides on the stack and - ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. - `(let ((,var (list* ,@elements))) - (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) - ,@body)) - -(declaim (inline buffer-replace)) - -#+lispm -(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) - (declare (type vector buf1 buf2) - (type array-index start1 end1 start2)) - (sys:copy-array-portion buf2 start2 (length buf2) buf1 start1 end1)) - -#+excl -(defun buffer-replace (target-sequence source-sequence target-start - target-end &optional (source-start 0)) - (declare (type buffer-bytes target-sequence source-sequence) - (type array-index target-start target-end source-start) - (optimize (speed 3) (safety 0))) - - (let ((source-end (length source-sequence))) - (declare (type array-index source-end)) - - (excl:if* (and (eq target-sequence source-sequence) - (> target-start source-start)) - then (let ((nelts (min (- target-end target-start) - (- source-end source-start)))) - (do ((target-index (+ target-start nelts -1) (1- target-index)) - (source-index (+ source-start nelts -1) (1- source-index))) - ((= target-index (1- target-start)) target-sequence) - (declare (type array-index target-index source-index)) - - (setf (aref target-sequence target-index) - (aref source-sequence source-index)))) - else (do ((target-index target-start (1+ target-index)) - (source-index source-start (1+ source-index))) - ((or (= target-index target-end) (= source-index source-end)) - target-sequence) - (declare (type array-index target-index source-index)) - - (setf (aref target-sequence target-index) - (aref source-sequence source-index)))))) - -#+cmu -(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) - (declare (type buffer-bytes buf1 buf2) - (type array-index start1 end1 start2)) - #.(declare-buffun) - (kernel:bit-bash-copy - buf2 (+ (* start2 #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) - (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits)) - buf1 (+ (* start1 #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) - (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits)) - (* (- end1 start1) #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits))) - -#+lucid -;;;The compiler is *supposed* to optimize calls to replace, but in actual -;;;fact it does not. -(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) - (declare (type buffer-bytes buf1 buf2) - (type array-index start1 end1 start2)) - #.(declare-buffun) - (let ((end2 (lucid::%simple-8bit-vector-length buf2))) - (declare (type array-index end2)) - (lucid::simple-8bit-vector-replace-internal - buf1 buf2 start1 end1 start2 end2))) - -#+(and clx-overlapping-arrays (not (or lispm excl))) -(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) - (declare (type vector buf1 buf2) - (type array-index start1 end1 start2)) - (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2)) - -#-(or lispm lucid excl CMU clx-overlapping-arrays) -(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) - (declare (type buffer-bytes buf1 buf2) - (type array-index start1 end1 start2)) - (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2)) - -#+ti -(defun with-location-bindings (sys:"e bindings &rest body) - (do ((bindings bindings (cdr bindings))) - ((null bindings) - (sys:eval-body-as-progn body)) - (sys:bind (sys:*eval `(sys:locf ,(caar bindings))) - (sys:*eval (cadar bindings))))) - -#+ti -(compiler:defoptimizer with-location-bindings with-l-b-compiler nil (form) - (let ((bindings (cadr form)) - (body (cddr form))) - `(let () - ,@(loop for (accessor value) in bindings - collect `(si:bind (si:locf ,accessor) ,value)) - ,@body))) - -#+ti -(defun (:property with-location-bindings compiler::cw-handler) (exp) - (let* ((bindlist (mapcar #'compiler::cw-clause (second exp))) - (body (compiler::cw-clause (cddr exp)))) - (and compiler::cw-return-expansion-flag - (list* (first exp) bindlist body)))) - -#+(and lispm (not ti)) -(defmacro with-location-bindings (bindings &body body) - `(sys:letf* ,bindings ,@body)) - -#+lispm -(defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) - &body body) - ;; don't use svref on LHS because Symbolics didn't define locf for it - (let* ((local-state (gensym)) - (bindings `(((aref ,local-state ,ts-index) 0)))) ; will become zero anyway - (dolist (index indexes) - (push `((aref ,local-state ,index) (svref ,saved-state ,index)) - bindings)) - `(let ((,local-state (gcontext-local-state ,gc))) - (declare (type gcontext-state ,local-state)) - (unwind-protect - (with-location-bindings ,bindings - ,@body) - (setf (svref ,local-state ,ts-index) 0) - (when ,temp-gc - (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) - (deallocate-gcontext-state ,saved-state))))) - -#-lispm -(defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) - &body body) - (let ((local-state (gensym)) - (resets nil)) - (dolist (index indexes) - (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index)) - resets)) - `(unwind-protect - (progn - ,@body) - (let ((,local-state (gcontext-local-state ,gc))) - (declare (type gcontext-state ,local-state)) - ,@resets - (setf (svref ,local-state ,ts-index) 0)) - (when ,temp-gc - (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) - (deallocate-gcontext-state ,saved-state)))) - -;;;---------------------------------------------------------------------------- -;;; How much error detection should CLX do? -;;; Several levels are possible: -;;; -;;; 1. Do the equivalent of check-type on every argument. -;;; -;;; 2. Simply report TYPE-ERROR. This eliminates overhead of all the format -;;; strings generated by check-type. -;;; -;;; 3. Do error checking only on arguments that are likely to have errors -;;; (like keyword names) -;;; -;;; 4. Do error checking only where not doing so may dammage the envirnment -;;; on a non-tagged machine (i.e. when storing into a structure that has -;;; been passed in) -;;; -;;; 5. No extra error detection code. On lispm's, ASET may barf trying to -;;; store a non-integer into a number array. -;;; -;;; How extensive should the error checking be? For example, if the server -;;; expects a CARD16, is is sufficient for CLX to check for integer, or -;;; should it also check for non-negative and less than 65536? -;;;---------------------------------------------------------------------------- - -;; The +TYPE-CHECK?+ constant controls how much error checking is done. -;; Possible values are: -;; NIL - Don't do any error checking -;; t - Do the equivalent of checktype on every argument -;; :minimal - Do error checking only where errors are likely - -;;; This controls macro expansion, and isn't changable at run-time You will -;;; probably want to set this to nil if you want good performance at -;;; production time. -(defconstant +type-check?+ - #+(or Genera Minima CMU sbcl) nil - #-(or Genera Minima CMU sbcl) t) - -;; TYPE? is used to allow the code to do error checking at a different level from -;; the declarations. It also does some optimizations for systems that don't have -;; good compiler support for TYPEP. The definitions for CARD32, CARD16, INT16, etc. -;; include range checks. You can modify TYPE? to do less extensive checking -;; for these types if you desire. - -;; -;; ### This comment is a lie! TYPE? is really also used for run-time type -;; dispatching, not just type checking. -- Ram. - -(defmacro type? (object type) - #+(or cmu sbcl clisp) - `(typep ,object ,type) - #-(or cmu sbcl clisp) - (if (not (constantp type)) - `(typep ,object ,type) - (progn - (setq type (eval type)) - #+(or Genera explorer Minima) - (if +type-check?+ - `(locally (declare (optimize safety)) (typep ,object ',type)) - `(typep ,object ',type)) - #-(or Genera explorer Minima) - (let ((predicate (assoc type - '((drawable drawable-p) (window window-p) - (pixmap pixmap-p) (cursor cursor-p) - (font font-p) (gcontext gcontext-p) - (colormap colormap-p) (null null) - (integer integerp))))) - (cond (predicate - `(,(second predicate) ,object)) - ((eq type 'generalized-boolean) - 't) ; Everything is a generalized-boolean. - (+type-check?+ - `(locally (declare (optimize safety)) (typep ,object ',type))) - (t - `(typep ,object ',type))))))) - -;; X-TYPE-ERROR is the function called for type errors. -;; If you want lots of checking, but are concerned about code size, -;; this can be made into a macro that ignores some parameters. - -(defun x-type-error (object type &optional error-string) - (x-error 'x-type-error - :datum object - :expected-type type - :type-string error-string)) - - -;;----------------------------------------------------------------------------- -;; Error handlers -;; Hack up KMP error signaling using zetalisp until the real thing comes -;; along -;;----------------------------------------------------------------------------- - -(defun default-error-handler (display error-key &rest key-vals - &key asynchronous &allow-other-keys) - (declare (type generalized-boolean asynchronous) - (dynamic-extent key-vals)) - ;; The default display-error-handler. - ;; It signals the conditions listed in the DISPLAY file. - (if asynchronous - (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals) - (apply #'x-error error-key :display display :error-key error-key key-vals))) - -#+(and lispm (not Genera) (not clx-ansi-common-lisp)) -(defun x-error (condition &rest keyargs) - (apply #'sys:signal condition keyargs)) - -#+(and lispm (not Genera) (not clx-ansi-common-lisp)) -(defun x-cerror (proceed-format-string condition &rest keyargs) - (sys:signal (apply #'zl:make-condition condition keyargs) - :proceed-types proceed-format-string)) - -#+(and Genera (not clx-ansi-common-lisp)) -(defun x-error (condition &rest keyargs) - (declare (dbg:error-reporter)) - (apply #'sys:signal condition keyargs)) - -#+(and Genera (not clx-ansi-common-lisp)) -(defun x-cerror (proceed-format-string condition &rest keyargs) - (declare (dbg:error-reporter)) - (apply #'sys:signal condition :continue-format-string proceed-format-string keyargs)) - -#+(or clx-ansi-common-lisp excl lcl3.0 clisp (and CMU mp)) -(defun x-error (condition &rest keyargs) - (declare (dynamic-extent keyargs)) - (apply #'error condition keyargs)) - -#+(or clx-ansi-common-lisp excl lcl3.0 CMU clisp) -(defun x-cerror (proceed-format-string condition &rest keyargs) - (declare (dynamic-extent keyargs)) - (apply #'cerror proceed-format-string condition keyargs)) - -;;; X-ERROR for CMU Common Lisp -;;; -;;; We detect a couple condition types for which we disable event handling in -;;; our system. This prevents going into the debugger or returning to a -;;; command prompt with CLX repeatedly seeing the same condition. This occurs -;;; because CMU Common Lisp provides for all events (that is, X, input on file -;;; descriptors, Mach messages, etc.) to come through one routine anyone can -;;; use to wait for input. -;;; -#+(and CMU (not mp)) -(defun x-error (condition &rest keyargs) - (let ((condx (apply #'make-condition condition keyargs))) - (when (eq condition 'closed-display) - (let ((disp (closed-display-display condx))) - (warn "Disabled event handling on ~S." disp) - (ext::disable-clx-event-handling disp))) - (error condx))) - -#-(or lispm ansi-common-lisp excl lcl3.0 CMU sbcl clisp) -(defun x-error (condition &rest keyargs) - (error "X-Error: ~a" - (princ-to-string (apply #'make-condition condition keyargs)))) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) -(defun x-cerror (proceed-format-string condition &rest keyargs) - (cerror proceed-format-string "X-Error: ~a" - (princ-to-string (apply #'make-condition condition keyargs)))) - -;; version 15 of Pitman error handling defines the syntax for define-condition to be: -;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*] -;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string) -;; or (:report exp) - -#+lcl3.0 -(defmacro define-condition (name parent-types &optional slots &rest args) - `(lcl:define-condition - ,name (,(first parent-types)) - ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - slots) - ,@args)) - -#+(and excl (not clx-ansi-common-lisp)) -(defmacro define-condition (name parent-types &optional slots &rest args) - `(excl::define-condition - ,name (,(first parent-types)) - ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - slots) - ,@args)) - -#+(and CMU (not clx-ansi-common-lisp)) -(defmacro define-condition (name parent-types &optional slots &rest args) - `(common-lisp:define-condition - ,name (,(first parent-types)) - ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - slots) - ,@args)) - -#+(and lispm (not clx-ansi-common-lisp)) -(defmacro define-condition (name parent-types &body options) - (let ((slot-names - (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - (pop options))) - (documentation nil) - (conc-name (concatenate 'string (string name) "-")) - (reporter nil)) - (dolist (item options) - (ecase (first item) - (:documentation (setq documentation (second item))) - (:conc-name (setq conc-name (string (second item)))) - (:report (setq reporter (second item))))) - `(within-definition (,name define-condition) - (zl:defflavor ,name ,slot-names ,parent-types - :initable-instance-variables - #-Genera - (:accessor-prefix ,conc-name) - #+Genera - (:conc-name ,conc-name) - #-Genera - (:outside-accessible-instance-variables ,@slot-names) - #+Genera - (:readable-instance-variables ,@slot-names)) - ,(when reporter ;; when no reporter, parent's is inherited - `(zl:defmethod #-Genera (,name :report) - #+Genera (dbg:report ,name) (stream) - ,(if (stringp reporter) - `(write-string ,reporter stream) - `(,reporter global:self stream)) - global:self)) - (zl:compile-flavor-methods ,name) - ,(when documentation - `(setf (documentation name 'type) ,documentation)) - ',name))) - -#+(and lispm (not Genera) (not clx-ansi-common-lisp)) -(zl:defflavor x-error () (global:error)) - -#+(and Genera (not clx-ansi-common-lisp)) -(scl:defflavor x-error - ((dbg:proceed-types '(:continue)) ; - continue-format-string) - (sys:error) - (:initable-instance-variables continue-format-string)) - -#+(and Genera (not clx-ansi-common-lisp)) -(scl:defmethod (scl:make-instance x-error) (&rest ignore) - (when (not (sys:variable-boundp continue-format-string)) - (setf dbg:proceed-types (remove :continue dbg:proceed-types)))) - -#+(and Genera (not clx-ansi-common-lisp)) -(scl:defmethod (dbg:proceed x-error :continue) () - :continue) - -#+(and Genera (not clx-ansi-common-lisp)) -(sys:defmethod (dbg:document-proceed-type x-error :continue) (stream) - (format stream continue-format-string)) - -#+(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) -(define-condition x-error (error) ()) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl) -(defstruct x-error - report-function) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl) -(defmacro define-condition (name parent-types &body options) - ;; Define a structure that when printed displays an error message - (flet ((reporter-for-condition (name) - (xintern "." name '-reporter.))) - (let ((slot-names - (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - (pop options))) - (documentation nil) - (conc-name (concatenate 'string (string name) "-")) - (reporter nil) - (condition (gensym)) - (stream (gensym)) - (report-function (reporter-for-condition name))) - (dolist (item options) - (ecase (first item) - (:documentation (setq documentation (second item))) - (:conc-name (setq conc-name (string (second item)))) - (:report (setq reporter (second item))))) - (unless reporter - (setq report-function (reporter-for-condition (first parent-types)))) - `(within-definition (,name define-condition) - (defstruct (,name (:conc-name ,(intern conc-name)) - (:print-function condition-print) - (:include ,(first parent-types) - (report-function ',report-function))) - ,@slot-names) - ,(when documentation - `(setf (documentation name 'type) ,documentation)) - ,(when reporter - `(defun ,report-function (,condition ,stream) - ,(if (stringp reporter) - `(write-string ,reporter ,stream) - `(,reporter ,condition ,stream)) - ,condition)) - ',name)))) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) -(defun condition-print (condition stream depth) - (declare (type x-error condition) - (type stream stream) - (ignore depth)) - (if *print-escape* - (print-unreadable-object (condition stream :type t)) - (funcall (x-error-report-function condition) condition stream)) - condition) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) -(defun make-condition (type &rest slot-initializations) - (declare (dynamic-extent slot-initializations)) - (let ((make-function (intern (concatenate 'string (string 'make-) (string type)) - (symbol-package type)))) - (apply make-function slot-initializations))) - -#-(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) -(define-condition type-error (x-error) - ((datum :reader type-error-datum :initarg :datum) - (expected-type :reader type-error-expected-type :initarg :expected-type)) - (:report - (lambda (condition stream) - (format stream "~s isn't a ~a" - (type-error-datum condition) - (type-error-expected-type condition))))) - - -;;----------------------------------------------------------------------------- -;; HOST hacking -;;----------------------------------------------------------------------------- - -#-(or explorer Genera Minima Allegro CMU sbcl ecl clisp) -(defun host-address (host &optional (family :internet)) - ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - host family - (error "HOST-ADDRESS not implemented yet.")) - -#+clisp -(defun host-address (host &optional (family :internet)) - "Return a list whose car is the family keyword (:internet :DECnet :Chaos) - and cdr is a list of network address bytes." - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - (labels ((no-host-error () - (error "Unknown host ~S" host)) - (no-address-error () - (error "Host ~S has no ~S address" host family))) - - (let ((hostent (posix::resolve-host-ipaddr (string host)))) - (when (not (posix::hostent-addr-list hostent)) - (no-host-error)) - (ecase family - ((:internet nil 0) - (unless (= (posix::hostent-addrtype hostent) 2) - (no-address-error)) - (let ((addr (first (posix::hostent-addr-list hostent)))) - (etypecase addr - (integer - (list :internet - (ldb (byte 8 24) addr) - (ldb (byte 8 16) addr) - (ldb (byte 8 8) addr) - (ldb (byte 8 0) addr))) - (string - (let ((parts (read-from-string - (nsubstitute #\Space #\. (ext:string-concat - "(" addr ")"))))) - (check-type parts (cons (unsigned-byte 8) - (cons (unsigned-byte 8) - (cons (unsigned-byte 8) - (cons (unsigned-byte 8) - NULL))))) - (cons :internet parts)))))))))) - - -#+explorer -(defun host-address (host &optional (family :internet)) - ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - (ecase family - ((:internet nil 0) - (let ((addr (ip:get-ip-address host))) - (unless addr (error "~s isn't an internet host name" host)) - (list :internet - (ldb (byte 8 24) addr) - (ldb (byte 8 16) addr) - (ldb (byte 8 8) addr) - (ldb (byte 8 0) addr)))) - ((:chaos 2) - (let ((addr (first (chaos:chaos-addresses host)))) - (unless addr (error "~s isn't a chaos host name" host)) - (list :chaos - (ldb (byte 8 0) addr) - (ldb (byte 8 8) addr)))))) - -#+Genera -(defun host-address (host &optional (family :internet)) - ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - (setf host (string host)) - (let ((net-type (ecase family - ((:internet nil 0) :internet) - ((:DECnet 1) :dna) - ((:chaos 2) :chaos)))) - (dolist (addr - (sys:send (net:parse-host host) :network-addresses) - (error "~S isn't a valid ~(~A~) host name" host family)) - (let ((network (car addr)) - (address (cadr addr))) - (when (sys:send network :network-typep net-type) - (return (ecase family - ((:internet nil 0) - (multiple-value-bind (a b c d) (tcp:explode-internet-address address) - (list :internet a b c d))) - ((:DECnet 1) - (list :DECnet (ldb (byte 8 0) address) (ldb (byte 8 8) address))) - ((:chaos 2) - (list :chaos (ldb (byte 8 0) address) (ldb (byte 8 8) address)))))))))) - -#+Minima -(defun host-address (host &optional (family :internet)) - ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - (etypecase family - ((:internet nil 0) - (list* :internet - (multiple-value-list - (minima:ip-address-components (minima:parse-ip-address (string host)))))))) - -#+Allegro -(defun host-address (host &optional (family :internet)) - ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - (labels ((no-host-error () - (error "Unknown host ~S" host)) - (no-address-error () - (error "Host ~S has no ~S address" host family))) - (let ((hostent 0)) - (unwind-protect - (progn - (setf hostent (ipc::gethostbyname (string host))) - (when (zerop hostent) - (no-host-error)) - (ecase family - ((:internet nil 0) - (unless (= (ipc::hostent-addrtype hostent) 2) - (no-address-error)) - (assert (= (ipc::hostent-length hostent) 4)) - (let ((addr (ipc::hostent-addr hostent))) - (when (or (member comp::.target. - '(:hp :sgi4d :sony :dec3100) - :test #'eq) - (probe-file "/lib/ld.so")) - ;; BSD 4.3 based systems require an extra indirection - (setq addr (si:memref-int addr 0 0 :unsigned-long))) - (list :internet - (si:memref-int addr 0 0 :unsigned-byte) - (si:memref-int addr 1 0 :unsigned-byte) - (si:memref-int addr 2 0 :unsigned-byte) - (si:memref-int addr 3 0 :unsigned-byte)))))) - (ff:free-cstruct hostent))))) - -;#+sbcl -;(require :sockets) - -#+CMU -(defun host-address (host &optional (family :internet)) - ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - (labels ((no-host-error () - (error "Unknown host ~S" host)) - (no-address-error () - (error "Host ~S has no ~S address" host family))) - (let ((hostent #+rwi-sockets(ext:lookup-host-entry (string host)) - #+mna-sockets(net.sbcl.sockets:look-up-host-entry - (string host)) - #+db-sockets(sockets:get-host-by-name (string host)))) - (when (not hostent) - (no-host-error)) - (ecase family - ((:internet nil 0) - #+rwi-sockets(unless (= (ext::host-entry-addr-type hostent) 2) - (no-address-error)) - #+mna-sockets(unless (= (net.sbcl.sockets::host-entry-addr-type hostent) 2) - (no-address-error)) - ;; the following form is for use with SBCL and Daniel - ;; Barlow's socket package - #+db-sockets(unless (sockets:host-ent-address hostent) - (no-address-error)) - (append (list :internet) - #+rwi-sockets - (let ((addr (first (ext::host-entry-addr-list hostent)))) - (list (ldb (byte 8 24) addr) - (ldb (byte 8 16) addr) - (ldb (byte 8 8) addr) - (ldb (byte 8 0) addr))) - #+mna-sockets - (let ((addr (first (net.sbcl.sockets::host-entry-addr-list hostent)))) - (list (ldb (byte 8 24) addr) - (ldb (byte 8 16) addr) - (ldb (byte 8 8) addr) - (ldb (byte 8 0) addr))) - ;; the following form is for use with SBCL and Daniel - ;; Barlow's socket package - #+db-sockets(coerce (sockets:host-ent-address hostent) - 'list))))))) - -#+sbcl -(defun host-address (host &optional (family :internet)) - ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - (let ((hostent (get-host-by-name (string host)))) - (ecase family - ((:internet nil 0) - (cons :internet (coerce (host-ent-address hostent) 'list)))))) - -#+ecl -(defun host-address (host &optional (family :internet)) - ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - (labels ((no-host-error () - (error "Unknown host ~S" host))) - (let ((addr (first (nth-value 3 (si::lookup-host-entry (string host)))))) - (unless addr - (no-host-error)) - (list :internet - (ldb (byte 8 24) addr) - (ldb (byte 8 16) addr) - (ldb (byte 8 8) addr) - (ldb (byte 8 0) addr))))) - -#+explorer ;; This isn't required, but it helps make sense of the results from access-hosts -(defun get-host (host-object) - ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type list host-object)) - (declare (clx-values string family)) - (let* ((family (first host-object)) - (address (ecase family - (:internet - (dpb (second host-object) - (byte 8 24) - (dpb (third host-object) - (byte 8 16) - (dpb (fourth host-object) - (byte 8 8) - (fifth host-object))))) - (:chaos - (dpb (third host-object) (byte 8 8) (second host-object)))))) - (when (eq family :internet) (setq family :ip)) - (let ((host (si:get-host-from-address address family))) - (values (and host (funcall host :name)) family)))) - -;;; This isn't required, but it helps make sense of the results from access-hosts -#+Genera -(defun get-host (host-object) - ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type list host-object)) - (declare (clx-values string family)) - (let ((family (first host-object))) - (values (sys:send (net:get-host-from-address - (ecase family - (:internet - (apply #'tcp:build-internet-address (rest host-object))) - ((:chaos :DECnet) - (dpb (third host-object) (byte 8 8) (second host-object)))) - (net:local-network-of-type (if (eq family :DECnet) - :DNA - family))) - :name) - family))) - -;;; This isn't required, but it helps make sense of the results from access-hosts -#+Minima -(defun get-host (host-object) - ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type list host-object)) - (declare (clx-values string family)) - (let ((family (first host-object))) - (values (ecase family - (:internet - (minima:ip-address-string - (apply #'minima:make-ip-address (rest host-object))))) - family))) - - -;;----------------------------------------------------------------------------- -;; Whether to use closures for requests or not. -;;----------------------------------------------------------------------------- - -;;; If this macro expands to non-NIL, then request and locking code is -;;; compiled in a much more compact format, as the common code is shared, and -;;; the specific code is built into a closure that is funcalled by the shared -;;; code. If your compiler makes efficient use of closures then you probably -;;; want to make this expand to T, as it makes the code more compact. - -(defmacro use-closures () - #+(or lispm Minima) t - #-(or lispm Minima) nil) - -#+(or Genera Minima) -(defun clx-macroexpand (form env) - (declare (ignore env)) - form) - -#-(or Genera Minima) -(defun clx-macroexpand (form env) - (macroexpand form env)) - - -;;----------------------------------------------------------------------------- -;; Resource stuff -;;----------------------------------------------------------------------------- - - -;;; Utilities - -(defun getenv (name) - #+excl (sys:getenv name) - #+lcl3.0 (lcl:environment-variable name) - #+CMU (cdr (assoc name ext:*environment-list* :test #'string=)) - #+sbcl (sb-ext:posix-getenv name) - #+ecl (si:getenv name) - #+clisp (ext:getenv name) - #-(or sbcl excl lcl3.0 CMU ecl clisp) (progn name nil)) - -(defun get-host-name () - "Return the same hostname as gethostname(3) would" - ;; machine-instance probably works on a lot of lisps, but clisp is not - ;; one of them - #+(or cmu sbcl ecl) (machine-instance) - ;; resources-pathname was using short-site-name for this purpose - #+excl (short-site-name) - #+clisp (let ((s (machine-instance))) (subseq s 0 (position #\Space s))) - #-(or excl cmu sbcl ecl clisp) (error "get-host-name not implemented")) - -(defun homedir-file-pathname (name) - (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal) - (merge-pathnames (user-homedir-pathname) (pathname name)))) - -;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if -;;; a resource manager isn't running. - -(defun default-resources-pathname () - (homedir-file-pathname ".Xdefaults")) - -;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the -;;; defaults have been loaded. - -(defun resources-pathname () - (or (let ((string (getenv "XENVIRONMENT"))) - (and string - (pathname string))) - (homedir-file-pathname - (concatenate 'string ".Xdefaults-" (get-host-name))))) - -;;; AUTHORITY-PATHNAME - The pathname of the authority file. - -(defun authority-pathname () - (or (let ((xauthority (getenv "XAUTHORITY"))) - (and xauthority - (pathname xauthority))) - (homedir-file-pathname ".Xauthority"))) - -#+ecl -(eval-when (:load-toplevel :execute :compile-toplevel) - (pushnew :unix *features*)) - -;;; this particular defaulting behaviour is typical to most Unices, I think -#+unix -(defun get-default-display (&optional display-name) - "Parse the argument DISPLAY-NAME, or the environment variable $DISPLAY -if it is NIL. Display names have the format - - [protocol/] [hostname] : [:] displaynumber [.screennumber] - -There are two special cases in parsing, to match that done in the Xlib -C language bindings - - - If the hostname is ``unix'' or the empty string, any supplied - protocol is ignored and a connection is made using the :local - transport. - - - If a double colon separates hostname from displaynumber, the - protocol is assumed to be decnet. - -Returns a list of (host display-number screen protocol)." - (let* ((name (or display-name - (getenv "DISPLAY") - (error "DISPLAY environment variable is not set"))) - (slash-i (or (position #\/ name) -1)) - (colon-i (position #\: name :start (1+ slash-i))) - (decnet-colon-p (eql (elt name (1+ colon-i)) #\:)) - (host (subseq name (1+ slash-i) colon-i)) - (dot-i (and colon-i (position #\. name :start colon-i))) - (display (when colon-i - (parse-integer name - :start (if decnet-colon-p - (+ colon-i 2) - (1+ colon-i)) - :end dot-i))) - (screen (when dot-i - (parse-integer name :start (1+ dot-i)))) - (protocol - (cond ((or (string= host "") (string-equal host "unix")) :local) - (decnet-colon-p :decnet) - ((> slash-i -1) (intern - (string-upcase (subseq name 0 slash-i)) - :keyword)) - (t :internet)))) - (list host (or display 0) (or screen 0) protocol))) - - -;;----------------------------------------------------------------------------- -;; GC stuff -;;----------------------------------------------------------------------------- - -(defun gc-cleanup () - (declare (special *event-free-list* - *pending-command-free-list* - *reply-buffer-free-lists* - *gcontext-local-state-cache* - *temp-gcontext-cache*)) - (setq *event-free-list* nil) - (setq *pending-command-free-list* nil) - (when (boundp '*reply-buffer-free-lists*) - (fill *reply-buffer-free-lists* nil)) - (setq *gcontext-local-state-cache* nil) - (setq *temp-gcontext-cache* nil) - nil) - -#+Genera -(si:define-gc-cleanup clx-cleanup ("CLX Cleanup") - (gc-cleanup)) - - -;;----------------------------------------------------------------------------- -;; WITH-STANDARD-IO-SYNTAX equivalent, used in (SETF WM-COMMAND) -;;----------------------------------------------------------------------------- - -#-(or clx-ansi-common-lisp Genera CMU sbcl ecl) -(defun with-standard-io-syntax-function (function) - (declare #+lispm - (sys:downward-funarg function)) - (let ((*package* (find-package :user)) - (*print-array* t) - (*print-base* 10) - (*print-case* :upcase) - (*print-circle* nil) - (*print-escape* t) - (*print-gensym* t) - (*print-length* nil) - (*print-level* nil) - (*print-pretty* nil) - (*print-radix* nil) - (*read-base* 10) - (*read-default-float-format* 'single-float) - (*read-suppress* nil) - #+ticl (ticl:*print-structure* t) - #+lucid (lucid::*print-structure* t)) - (funcall function))) - -#-(or clx-ansi-common-lisp Genera CMU sbcl ecl) -(defmacro with-standard-io-syntax (&body body) - `(flet ((.with-standard-io-syntax-body. () ,@body)) - (with-standard-io-syntax-function #'.with-standard-io-syntax-body.))) - - -;;----------------------------------------------------------------------------- -;; DEFAULT-KEYSYM-TRANSLATE -;;----------------------------------------------------------------------------- - -;;; If object is a character, char-bits are set from state. -;;; -;;; [the following isn't implemented (should it be?)] -;;; If object is a list, it is an alist with entries: -;;; (base-char [modifiers] [mask-modifiers]) -;;; When MODIFIERS are specified, this character translation -;;; will only take effect when the specified modifiers are pressed. -;;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore. -;;; When MASK-MODIFIERS is missing, all other modifiers are ignored. -;;; In ambiguous cases, the most specific translation is used. - -#-(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl) -(defun default-keysym-translate (display state object) - (declare (type display display) - (type card16 state) - (type t object) - (clx-values t) - (special left-meta-keysym right-meta-keysym - left-super-keysym right-super-keysym - left-hyper-keysym right-hyper-keysym)) - (when (characterp object) - (when (logbitp (position :control +state-mask-vector+) state) - (setf (char-bit object :control) 1)) - (when (or (state-keysymp display state left-meta-keysym) - (state-keysymp display state right-meta-keysym)) - (setf (char-bit object :meta) 1)) - (when (or (state-keysymp display state left-super-keysym) - (state-keysymp display state right-super-keysym)) - (setf (char-bit object :super) 1)) - (when (or (state-keysymp display state left-hyper-keysym) - (state-keysymp display state right-hyper-keysym)) - (setf (char-bit object :hyper) 1))) - object) - -#+(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl clisp) -(defun default-keysym-translate (display state object) - (declare (type display display) - (type card16 state) - (type t object) - (ignore display state) - (clx-values t)) - object) - - -;;----------------------------------------------------------------------------- -;; Image stuff -;;----------------------------------------------------------------------------- - -;;; Types - -(deftype pixarray-1-element-type () - 'bit) - -(deftype pixarray-4-element-type () - '(unsigned-byte 4)) - -(deftype pixarray-8-element-type () - '(unsigned-byte 8)) - -(deftype pixarray-16-element-type () - '(unsigned-byte 16)) - -(deftype pixarray-24-element-type () - '(unsigned-byte 24)) - -(deftype pixarray-32-element-type () - #-(or Genera Minima) '(unsigned-byte 32) - #+(or Genera Minima) 'fixnum) - -(deftype pixarray-1 () - '(#+(or cmu sbcl) simple-array - #-(or cmu sbcl) array pixarray-1-element-type (* *))) - -(deftype pixarray-4 () - '(#+(or cmu sbcl) simple-array - #-(or cmu sbcl) array pixarray-4-element-type (* *))) - -(deftype pixarray-8 () - '(#+(or cmu sbcl) simple-array - #-(or cmu sbcl) array pixarray-8-element-type (* *))) - -(deftype pixarray-16 () - '(#+(or cmu sbcl) simple-array - #-(or cmu sbcl) array pixarray-16-element-type (* *))) - -(deftype pixarray-24 () - '(#+(or cmu sbcl) simple-array - #-(or cmu sbcl) array pixarray-24-element-type (* *))) - -(deftype pixarray-32 () - '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-32-element-type (* *))) - -(deftype pixarray () - '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32)) - -(deftype bitmap () - 'pixarray-1) - -;;; WITH-UNDERLYING-SIMPLE-VECTOR - -#+Genera -(defmacro with-underlying-simple-vector - ((variable element-type pixarray) &body body) - (let ((bits-per-element - (sys:array-bits-per-element - (symbol-value (sys:type-array-element-type element-type))))) - `(scl:stack-let ((,variable - (make-array - (index-ceiling - (index* (array-total-size ,pixarray) - (sys:array-element-size ,pixarray)) - ,bits-per-element) - :element-type ',element-type - :displaced-to ,pixarray))) - (declare (type (vector ,element-type) ,variable)) - ,@body))) - -#+lcl3.0 -(defmacro with-underlying-simple-vector - ((variable element-type pixarray) &body body) - `(let ((,variable (sys:underlying-simple-vector ,pixarray))) - (declare (type (simple-array ,element-type (*)) ,variable)) - ,@body)) - -#+excl -(defmacro with-underlying-simple-vector - ((variable element-type pixarray) &body body) - `(let ((,variable (cdr (excl::ah_data ,pixarray)))) - (declare (type (simple-array ,element-type (*)) ,variable)) - ,@body)) - -#+(or CMU sbcl) -;;; We do *NOT* support viewing an array as having a different element type. -;;; Element-type is ignored. -;;; -(defmacro with-underlying-simple-vector - ((variable element-type pixarray) &body body) - (declare (ignore element-type)) - `(#+cmu kernel::with-array-data #+sbcl sb-kernel:with-array-data - ((,variable ,pixarray) (start) (end)) - (declare (ignore start end)) - ,@body)) - -;;; These are used to read and write pixels from and to CARD8s. - -;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s. - -(defmacro read-image-load-byte (size position integer) - (unless +image-bit-lsb-first-p+ (setq position (- 7 position))) - `(the (unsigned-byte ,size) - (#-Genera ldb #+Genera sys:%logldb - (byte ,size ,position) - (the card8 ,integer)))) - -;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from -;;; the appropriate number of CARD8s. - -(defmacro read-image-assemble-bytes (&rest bytes) - (unless +image-byte-lsb-first-p+ (setq bytes (reverse bytes))) - (let ((it (first bytes)) - (count 0)) - (dolist (byte (rest bytes)) - (setq it - `(#-Genera dpb #+Genera sys:%logdpb - (the card8 ,byte) - (byte 8 ,(incf count 8)) - (the (unsigned-byte ,count) ,it)))) - #-Genera `(the (unsigned-byte ,(* (length bytes) 8)) ,it) - #+Genera it)) - -;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit -;;; pixel. - -(defmacro write-image-load-byte (position integer integer-size) - integer-size - (unless +image-byte-lsb-first-p+ (setq position (- integer-size 8 position))) - `(the card8 - (#-Genera ldb #+Genera sys:%logldb - (byte 8 ,position) - #-Genera (the (unsigned-byte ,integer-size) ,integer) - #+Genera ,integer - ))) - -;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit -;;; pixels. - -(defmacro write-image-assemble-bytes (&rest bytes) - (unless +image-bit-lsb-first-p+ (setq bytes (reverse bytes))) - (let ((size (floor 8 (length bytes))) - (it (first bytes)) - (count 0)) - (dolist (byte (rest bytes)) - (setq it `(#-Genera dpb #+Genera sys:%logdpb - (the (unsigned-byte ,size) ,byte) - (byte ,size ,(incf count size)) - (the (unsigned-byte ,count) ,it)))) - `(the card8 ,it))) - -#+(or Genera lcl3.0 excl) -(defvar *computed-image-byte-lsb-first-p* +image-byte-lsb-first-p+) - -#+(or Genera lcl3.0 excl) -(defvar *computed-image-bit-lsb-first-p* +image-bit-lsb-first-p+) - -;;; The following table gives the bit ordering within bytes (when accessed -;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to -;;; 31, where bit 0 should be leftmost on the display. For a given byte -;;; labelled A-B, A is for the most significant bit of the byte, and B is -;;; for the least significant bit. -;;; -;;; legend: -;;; 1 scanline-unit = 8 -;;; 2 scanline-unit = 16 -;;; 4 scanline-unit = 32 -;;; M byte-order = MostSignificant -;;; L byte-order = LeastSignificant -;;; m bit-order = MostSignificant -;;; l bit-order = LeastSignificant -;;; -;;; -;;; format ordering -;;; -;;; 1Mm 00-07 08-15 16-23 24-31 -;;; 2Mm 00-07 08-15 16-23 24-31 -;;; 4Mm 00-07 08-15 16-23 24-31 -;;; 1Ml 07-00 15-08 23-16 31-24 -;;; 2Ml 15-08 07-00 31-24 23-16 -;;; 4Ml 31-24 23-16 15-08 07-00 -;;; 1Lm 00-07 08-15 16-23 24-31 -;;; 2Lm 08-15 00-07 24-31 16-23 -;;; 4Lm 24-31 16-23 08-15 00-07 -;;; 1Ll 07-00 15-08 23-16 31-24 -;;; 2Ll 07-00 15-08 23-16 31-24 -;;; 4Ll 07-00 15-08 23-16 31-24 - -#+(or Genera lcl3.0 excl) -(defconstant - *image-bit-ordering-table* - '(((1 (00 07) (08 15) (16 23) (24 31)) (nil nil)) - ((2 (00 07) (08 15) (16 23) (24 31)) (nil nil)) - ((4 (00 07) (08 15) (16 23) (24 31)) (nil nil)) - ((1 (07 00) (15 08) (23 16) (31 24)) (nil t)) - ((2 (15 08) (07 00) (31 24) (23 16)) (nil t)) - ((4 (31 24) (23 16) (15 08) (07 00)) (nil t)) - ((1 (00 07) (08 15) (16 23) (24 31)) (t nil)) - ((2 (08 15) (00 07) (24 31) (16 23)) (t nil)) - ((4 (24 31) (16 23) (08 15) (00 07)) (t nil)) - ((1 (07 00) (15 08) (23 16) (31 24)) (t t)) - ((2 (07 00) (15 08) (23 16) (31 24)) (t t)) - ((4 (07 00) (15 08) (23 16) (31 24)) (t t)))) - -#+(or Genera lcl3.0 excl) -(defun compute-image-byte-and-bit-ordering () - (declare (clx-values image-byte-lsb-first-p image-bit-lsb-first-p)) - ;; First compute the ordering - (let ((ordering nil) - (a (make-array '(1 32) :element-type 'bit :initial-element 0))) - (dotimes (i 4) - (push (flet ((bitpos (a i n) - (declare (optimize (speed 3) (safety 0) (space 0))) - (declare (type (simple-array bit (* *)) a) - (type fixnum i n)) - (with-underlying-simple-vector (v (unsigned-byte 8) a) - (prog2 - (setf (aref v i) n) - (dotimes (i 32) - (unless (zerop (aref a 0 i)) - (return i))) - (setf (aref v i) 0))))) - (list (bitpos a i #b10000000) - (bitpos a i #b00000001))) - ordering)) - (setq ordering (cons (floor +image-unit+ 8) (nreverse ordering))) - ;; Now from the ordering, compute byte-lsb-first-p and bit-lsb-first-p - (let ((byte-and-bit-ordering - (second (assoc ordering *image-bit-ordering-table* - :test #'equal)))) - (unless byte-and-bit-ordering - (error "Couldn't determine image byte and bit ordering~@ - measured image ordering = ~A" - ordering)) - (values-list byte-and-bit-ordering)))) - -#+(or Genera lcl3.0 excl) -(multiple-value-setq - (*computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) - (compute-image-byte-and-bit-ordering)) - -;;; If you can write fast routines that can read and write pixarrays out of a -;;; buffer-bytes, do it! It makes the image code a lot faster. The -;;; FAST-READ-PIXARRAY, FAST-WRITE-PIXARRAY and FAST-COPY-PIXARRAY routines -;;; return T if they can do it, NIL if they can't. - -;;; FIXME: though we have some #+sbcl -conditionalized routines in -;;; here, they would appear not to work, and so are commented out in -;;; the the FAST-xxx-PIXARRAY routines themseleves. Investigate -;;; whether the unoptimized routines are often used, and also whether -;;; speeding them up while maintaining correctness is possible. - -;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s - -#+(or lcl3.0 excl) -(defun fast-read-pixarray-1 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-1-element-type array) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index-ceiling x 8)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y)) - (left-bits (the array-index (mod (the fixnum (- x)) 8))) - (right-bits (index-mod (index- width left-bits) 8)) - (middle-bits (the fixnum (- (the fixnum (- width left-bits)) - right-bits))) - (middle-bytes (index-floor middle-bits 8))) - ((index>= y height)) - (declare (type array-index start y - left-bits right-bits middle-bytes) - (fixnum middle-bits)) - (cond ((< middle-bits 0) - (let ((byte (aref buffer-bbuf (index1- start))) - (x (array-row-major-index array y left-bits))) - (declare (type card8 byte) - (type array-index x)) - (when (index> right-bits 6) - (setf (aref vector (index- x 1)) - (read-image-load-byte 1 7 byte))) - (when (and (index> left-bits 1) - (index> right-bits 5)) - (setf (aref vector (index- x 2)) - (read-image-load-byte 1 6 byte))) - (when (and (index> left-bits 2) - (index> right-bits 4)) - (setf (aref vector (index- x 3)) - (read-image-load-byte 1 5 byte))) - (when (and (index> left-bits 3) - (index> right-bits 3)) - (setf (aref vector (index- x 4)) - (read-image-load-byte 1 4 byte))) - (when (and (index> left-bits 4) - (index> right-bits 2)) - (setf (aref vector (index- x 5)) - (read-image-load-byte 1 3 byte))) - (when (and (index> left-bits 5) - (index> right-bits 1)) - (setf (aref vector (index- x 6)) - (read-image-load-byte 1 2 byte))) - (when (index> left-bits 6) - (setf (aref vector (index- x 7)) - (read-image-load-byte 1 1 byte))))) - (t - (unless (index-zerop left-bits) - (let ((byte (aref buffer-bbuf (index1- start))) - (x (array-row-major-index array y left-bits))) - (declare (type card8 byte) - (type array-index x)) - (setf (aref vector (index- x 1)) - (read-image-load-byte 1 7 byte)) - (when (index> left-bits 1) - (setf (aref vector (index- x 2)) - (read-image-load-byte 1 6 byte)) - (when (index> left-bits 2) - (setf (aref vector (index- x 3)) - (read-image-load-byte 1 5 byte)) - (when (index> left-bits 3) - (setf (aref vector (index- x 4)) - (read-image-load-byte 1 4 byte)) - (when (index> left-bits 4) - (setf (aref vector (index- x 5)) - (read-image-load-byte 1 3 byte)) - (when (index> left-bits 5) - (setf (aref vector (index- x 6)) - (read-image-load-byte 1 2 byte)) - (when (index> left-bits 6) - (setf (aref vector (index- x 7)) - (read-image-load-byte 1 1 byte)) - )))))))) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (x (array-row-major-index array y left-bits) (index+ x 8))) - ((index>= i end) - (unless (index-zerop right-bits) - (let ((byte (aref buffer-bbuf end)) - (x (array-row-major-index - array y (index+ left-bits middle-bits)))) - (declare (type card8 byte) - (type array-index x)) - (setf (aref vector (index+ x 0)) - (read-image-load-byte 1 0 byte)) - (when (index> right-bits 1) - (setf (aref vector (index+ x 1)) - (read-image-load-byte 1 1 byte)) - (when (index> right-bits 2) - (setf (aref vector (index+ x 2)) - (read-image-load-byte 1 2 byte)) - (when (index> right-bits 3) - (setf (aref vector (index+ x 3)) - (read-image-load-byte 1 3 byte)) - (when (index> right-bits 4) - (setf (aref vector (index+ x 4)) - (read-image-load-byte 1 4 byte)) - (when (index> right-bits 5) - (setf (aref vector (index+ x 5)) - (read-image-load-byte 1 5 byte)) - (when (index> right-bits 6) - (setf (aref vector (index+ x 6)) - (read-image-load-byte 1 6 byte)) - ))))))))) - (declare (type array-index end i x)) - (let ((byte (aref buffer-bbuf i))) - (declare (type card8 byte)) - (setf (aref vector (index+ x 0)) - (read-image-load-byte 1 0 byte)) - (setf (aref vector (index+ x 1)) - (read-image-load-byte 1 1 byte)) - (setf (aref vector (index+ x 2)) - (read-image-load-byte 1 2 byte)) - (setf (aref vector (index+ x 3)) - (read-image-load-byte 1 3 byte)) - (setf (aref vector (index+ x 4)) - (read-image-load-byte 1 4 byte)) - (setf (aref vector (index+ x 5)) - (read-image-load-byte 1 5 byte)) - (setf (aref vector (index+ x 6)) - (read-image-load-byte 1 6 byte)) - (setf (aref vector (index+ x 7)) - (read-image-load-byte 1 7 byte)))) - ))))) - t) - -#+(or lcl3.0 excl) -(defun fast-read-pixarray-4 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-4 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-4-element-type array) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index-ceiling x 2)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y)) - (left-nibbles (the array-index (mod (the fixnum (- (the fixnum x))) - 2))) - (right-nibbles (index-mod (index- width left-nibbles) 2)) - (middle-nibbles (index- width left-nibbles right-nibbles)) - (middle-bytes (index-floor middle-nibbles 2))) - ((index>= y height)) - (declare (type array-index start y - left-nibbles right-nibbles middle-nibbles middle-bytes)) - (unless (index-zerop left-nibbles) - (setf (aref array y 0) - (read-image-load-byte - 4 4 (aref buffer-bbuf (index1- start))))) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (x (array-row-major-index array y left-nibbles) (index+ x 2))) - ((index>= i end) - (unless (index-zerop right-nibbles) - (setf (aref array y (index+ left-nibbles middle-nibbles)) - (read-image-load-byte 4 0 (aref buffer-bbuf end))))) - (declare (type array-index end i x)) - (let ((byte (aref buffer-bbuf i))) - (declare (type card8 byte)) - (setf (aref vector (index+ x 0)) - (read-image-load-byte 4 0 byte)) - (setf (aref vector (index+ x 1)) - (read-image-load-byte 4 4 byte)))) - ))) - t) - -#+(or Genera lcl3.0 excl CMU sbcl) -(defun fast-read-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-24-element-type array) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index* x 3)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) - (declare (type array-index start y)) - (do* ((end (index+ start (index* width 3))) - (i start (index+ i 3)) - (x (array-row-major-index array y 0) (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref vector x) - (read-image-assemble-bytes - (aref buffer-bbuf (index+ i 0)) - (aref buffer-bbuf (index+ i 1)) - (aref buffer-bbuf (index+ i 2)))))))) - t) - -#+lispm -(defun fast-read-pixarray-using-bitblt - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) - (#+Genera sys:stack-let* #-Genera let* - ((dimensions (list (+ y height) - (floor (* padded-bytes-per-line 8) bits-per-pixel))) - (a (make-array - dimensions - :element-type (array-element-type pixarray) - :displaced-to bbuf - :displaced-index-offset (floor (* boffset 8) bits-per-pixel)))) - (sys:bitblt boole-1 width height a x y pixarray 0 0)) - t) - -#+(or CMU sbcl) -(defun pixarray-element-size (pixarray) - (let ((eltype (array-element-type pixarray))) - (cond ((eq eltype 'bit) 1) - ((and (consp eltype) (eq (first eltype) 'unsigned-byte)) - (second eltype)) - (t - (error "Invalid pixarray: ~S." pixarray))))) - -#+CMU -;;; COPY-BIT-RECT -- Internal -;;; -;;; This is the classic BITBLT operation, copying a rectangular subarray -;;; from one array to another (but source and destination must not overlap.) -;;; Widths are specified in bits. Neither array can have a non-zero -;;; displacement. We allow extra random bit-offset to be thrown into the X. -;;; -(defun copy-bit-rect (source source-width sx sy dest dest-width dx dy - height width) - (declare (type array-index source-width sx sy dest-width dx dy height width)) - #.(declare-buffun) - (kernel::with-array-data ((sdata source) - (sstart) - (send)) - (declare (ignore send)) - (kernel::with-array-data ((ddata dest) - (dstart) - (dend)) - (declare (ignore dend)) - (assert (and (zerop sstart) (zerop dstart))) - (do ((src-idx (index+ (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits) - sx (index* sy source-width)) - (index+ src-idx source-width)) - (dest-idx (index+ (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits) - dx (index* dy dest-width)) - (index+ dest-idx dest-width)) - (count height (1- count))) - ((zerop count)) - (declare (type array-index src-idx dest-idx count)) - (kernel:bit-bash-copy sdata src-idx ddata dest-idx width))))) - - -#+sbcl -(defun copy-bit-rect (source source-width sx sy dest dest-width dx dy - height width) - (declare (type array-index source-width sx sy dest-width dx dy height width)) - #.(declare-buffun) - (sb-kernel:with-array-data ((sdata source) (sstart) (send)) - (declare (ignore send)) - (sb-kernel:with-array-data ((ddata dest) (dstart) (dend)) - (declare (ignore dend)) - (assert (and (zerop sstart) (zerop dstart))) - (do ((src-idx (index+ (* sb-vm:vector-data-offset sb-vm:n-word-bits) - sx (index* sy source-width)) - (index+ src-idx source-width)) - (dest-idx (index+ (* sb-vm:vector-data-offset sb-vm:n-word-bits) - dx (index* dy dest-width)) - (index+ dest-idx dest-width)) - (count height (1- count))) - ((zerop count)) - (declare (type array-index src-idx dest-idx count)) - (sb-kernel:ub1-bash-copy sdata src-idx ddata dest-idx width))))) - -#+(or CMU sbcl) -(defun fast-read-pixarray-using-bitblt - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) - (declare (type (array * 2) pixarray)) - #.(declare-buffun) - (copy-bit-rect bbuf - (index* padded-bytes-per-line #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) - (index* boffset #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) 0 - pixarray - (index* (array-dimension pixarray 1) bits-per-pixel) - x y - height - (index* width bits-per-pixel)) - t) - -#+(or Genera lcl3.0 excl) -(defun fast-read-pixarray-with-swap - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type array-index boffset - padded-bytes-per-line) - (type pixarray pixarray) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (unless (index= bits-per-pixel 24) - (let ((pixarray-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index pixarray 1 0) - (array-row-major-index pixarray 0 0)) - bits-per-pixel))) - (x-bits (index* x bits-per-pixel))) - (declare (type array-index pixarray-padded-bits-per-line x-bits)) - (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) - (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) - (index-zerop (index-mod x-bits 8))) - (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) - (index-zerop (index-mod x-bits +image-unit+)))) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p - +image-unit+ *computed-image-byte-lsb-first-p* - *computed-image-bit-lsb-first-p*) - (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) - (with-underlying-simple-vector (dst card8 pixarray) - (funcall - (symbol-function image-swap-function) bbuf dst - (index+ boffset - (index* y padded-bytes-per-line) - (index-floor x-bits 8)) - 0 (index-ceiling (index* width bits-per-pixel) 8) - padded-bytes-per-line - (index-floor pixarray-padded-bits-per-line 8) - height image-swap-lsb-first-p))) - t)))) - -(defun fast-read-pixarray (bbuf boffset pixarray - x y width height padded-bytes-per-line - bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type array-index boffset - padded-bytes-per-line) - (type pixarray pixarray) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (progn bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (or - #+(or Genera lcl3.0 excl) - (fast-read-pixarray-with-swap - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (let ((function - (or #+lispm - (and (= (sys:array-element-size pixarray) bits-per-pixel) - (zerop (index-mod padded-bytes-per-line 4)) - (zerop (index-mod - (* #+Genera (sys:array-row-span pixarray) - #-Genera (array-dimension pixarray 1) - bits-per-pixel) - 32)) - #'fast-read-pixarray-using-bitblt) - #+(or CMU) - (and (index= (pixarray-element-size pixarray) bits-per-pixel) - #'fast-read-pixarray-using-bitblt) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 1) - #'fast-read-pixarray-1) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 4) - #'fast-read-pixarray-4) - #+(or Genera lcl3.0 excl CMU) - (and (index= bits-per-pixel 24) - #'fast-read-pixarray-24)))) - (when function - (read-pixarray-internal - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel function - unit byte-lsb-first-p bit-lsb-first-p - +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+))))) - -;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s - -#+(or lcl3.0 excl) -(defun fast-write-pixarray-1 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-1-element-type array) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (right-bits (index-mod width 8)) - (middle-bits (index- width right-bits)) - (middle-bytes (index-ceiling middle-bits 8)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y right-bits middle-bits - middle-bytes start)) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (start-x x) - (x (array-row-major-index array y start-x) (index+ x 8))) - ((index>= i end) - (unless (index-zerop right-bits) - (let ((x (array-row-major-index - array y (index+ start-x middle-bits)))) - (declare (type array-index x)) - (setf (aref buffer-bbuf end) - (write-image-assemble-bytes - (aref vector (index+ x 0)) - (if (index> right-bits 1) - (aref vector (index+ x 1)) - 0) - (if (index> right-bits 2) - (aref vector (index+ x 2)) - 0) - (if (index> right-bits 3) - (aref vector (index+ x 3)) - 0) - (if (index> right-bits 4) - (aref vector (index+ x 4)) - 0) - (if (index> right-bits 5) - (aref vector (index+ x 5)) - 0) - (if (index> right-bits 6) - (aref vector (index+ x 6)) - 0) - 0))))) - (declare (type array-index end i start-x x)) - (setf (aref buffer-bbuf i) - (write-image-assemble-bytes - (aref vector (index+ x 0)) - (aref vector (index+ x 1)) - (aref vector (index+ x 2)) - (aref vector (index+ x 3)) - (aref vector (index+ x 4)) - (aref vector (index+ x 5)) - (aref vector (index+ x 6)) - (aref vector (index+ x 7)))))))) - t) - -#+(or lcl3.0 excl) -(defun fast-write-pixarray-4 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-4 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-4-element-type array) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (right-nibbles (index-mod width 2)) - (middle-nibbles (index- width right-nibbles)) - (middle-bytes (index-ceiling middle-nibbles 2)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y right-nibbles middle-nibbles - middle-bytes start)) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (start-x x) - (x (array-row-major-index array y start-x) (index+ x 2))) - ((index>= i end) - (unless (index-zerop right-nibbles) - (setf (aref buffer-bbuf end) - (write-image-assemble-bytes - (aref array y (index+ start-x middle-nibbles)) - 0)))) - (declare (type array-index end i start-x x)) - (setf (aref buffer-bbuf i) - (write-image-assemble-bytes - (aref vector (index+ x 0)) - (aref vector (index+ x 1)))))))) - t) - -#+(or Genera lcl3.0 excl CMU sbcl) -(defun fast-write-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-24-element-type array) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index y start)) - (do* ((end (index+ start (index* width 3))) - (i start (index+ i 3)) - (x (array-row-major-index array y x) (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (let ((pixel (aref vector x))) - (declare (type pixarray-24-element-type pixel)) - (setf (aref buffer-bbuf (index+ i 0)) - (write-image-load-byte 0 pixel 24)) - (setf (aref buffer-bbuf (index+ i 1)) - (write-image-load-byte 8 pixel 24)) - (setf (aref buffer-bbuf (index+ i 2)) - (write-image-load-byte 16 pixel 24))))))) - t) - -#+lispm -(defun fast-write-pixarray-using-bitblt - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) - (#+Genera sys:stack-let* #-Genera let* - ((dimensions (list (+ y height) - (floor (* padded-bytes-per-line 8) bits-per-pixel))) - (a (make-array - dimensions - :element-type (array-element-type pixarray) - :displaced-to bbuf - :displaced-index-offset (floor (* boffset 8) bits-per-pixel)))) - (sys:bitblt boole-1 width height pixarray x y a 0 0)) - t) - -#+(or CMU sbcl) -(defun fast-write-pixarray-using-bitblt - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) - #.(declare-buffun) - (copy-bit-rect pixarray - (index* (array-dimension pixarray 1) bits-per-pixel) - x y - bbuf - (index* padded-bytes-per-line #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) - (index* boffset #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) 0 - height - (index* width bits-per-pixel)) - t) - -#+(or Genera lcl3.0 excl) -(defun fast-write-pixarray-with-swap - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type pixarray pixarray) - (type card16 x y width height) - (type array-index boffset padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (unless (index= bits-per-pixel 24) - (let ((pixarray-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index pixarray 1 0) - (array-row-major-index pixarray 0 0)) - bits-per-pixel))) - (pixarray-start-bit-offset - (index* (array-row-major-index pixarray y x) - bits-per-pixel))) - (declare (type array-index pixarray-padded-bits-per-line - pixarray-start-bit-offset)) - (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) - (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) - (index-zerop (index-mod pixarray-start-bit-offset 8))) - (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) - (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - +image-unit+ *computed-image-byte-lsb-first-p* - *computed-image-bit-lsb-first-p* - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) - (with-underlying-simple-vector (src card8 pixarray) - (funcall - (symbol-function image-swap-function) - src bbuf (index-floor pixarray-start-bit-offset 8) boffset - (index-ceiling (index* width bits-per-pixel) 8) - (index-floor pixarray-padded-bits-per-line 8) - padded-bytes-per-line height image-swap-lsb-first-p)) - t))))) - -(defun fast-write-pixarray (bbuf boffset pixarray x y width height - padded-bytes-per-line bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type pixarray pixarray) - (type card16 x y width height) - (type array-index boffset padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (progn bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (or - #+(or Genera lcl3.0 excl) - (fast-write-pixarray-with-swap - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (let ((function - (or #+lispm - (and (= (sys:array-element-size pixarray) bits-per-pixel) - (zerop (index-mod padded-bytes-per-line 4)) - (zerop (index-mod - (* #+Genera (sys:array-row-span pixarray) - #-Genera (array-dimension pixarray 1) - bits-per-pixel) - 32)) - #'fast-write-pixarray-using-bitblt) - #+(or CMU) - (and (index= (pixarray-element-size pixarray) bits-per-pixel) - #'fast-write-pixarray-using-bitblt) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 1) - #'fast-write-pixarray-1) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 4) - #'fast-write-pixarray-4) - #+(or Genera lcl3.0 excl CMU) - (and (index= bits-per-pixel 24) - #'fast-write-pixarray-24)))) - (when function - (write-pixarray-internal - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel function - +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+ - unit byte-lsb-first-p bit-lsb-first-p))))) - -;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another - -(defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel) - (declare (type pixarray pixarray copy) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel)) - (progn pixarray copy x y width height bits-per-pixel nil) - (or - #+(or lispm CMU) - (let* ((pixarray-padded-pixels-per-line - #+Genera (sys:array-row-span pixarray) - #-Genera (array-dimension pixarray 1)) - (pixarray-padded-bits-per-line - (* pixarray-padded-pixels-per-line bits-per-pixel)) - (copy-padded-pixels-per-line - #+Genera (sys:array-row-span copy) - #-Genera (array-dimension copy 1)) - (copy-padded-bits-per-line - (* copy-padded-pixels-per-line bits-per-pixel))) - #-(or CMU) - (when (and (= (sys:array-element-size pixarray) bits-per-pixel) - (zerop (index-mod pixarray-padded-bits-per-line 32)) - (zerop (index-mod copy-padded-bits-per-line 32))) - (sys:bitblt boole-1 width height pixarray x y copy 0 0) - t) - #+(or CMU) - (when (index= (pixarray-element-size pixarray) - (pixarray-element-size copy) - bits-per-pixel) - (copy-bit-rect pixarray pixarray-padded-bits-per-line x y - copy copy-padded-bits-per-line 0 0 - height - (index* width bits-per-pixel)) - t)) - - #+(or lcl3.0 excl) - (unless (index= bits-per-pixel 24) - (let ((pixarray-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index pixarray 1 0) - (array-row-major-index pixarray 0 0)) - bits-per-pixel))) - (copy-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index copy 1 0) - (array-row-major-index copy 0 0)) - bits-per-pixel))) - (pixarray-start-bit-offset - (index* (array-row-major-index pixarray y x) - bits-per-pixel))) - (declare (type array-index pixarray-padded-bits-per-line - copy-padded-bits-per-line pixarray-start-bit-offset)) - (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) - (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) - (index-zerop (index-mod copy-padded-bits-per-line 8)) - (index-zerop (index-mod pixarray-start-bit-offset 8))) - (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) - (index-zerop (index-mod copy-padded-bits-per-line +image-unit+)) - (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) - (with-underlying-simple-vector (src card8 pixarray) - (with-underlying-simple-vector (dst card8 copy) - (image-noswap - src dst - (index-floor pixarray-start-bit-offset 8) 0 - (index-ceiling (index* width bits-per-pixel) 8) - (index-floor pixarray-padded-bits-per-line 8) - (index-floor copy-padded-bits-per-line 8) - height nil))) - t))) - #+(or lcl3.0 excl) - (macrolet - ((copy (type element-type) - `(let ((pixarray pixarray) - (copy copy)) - (declare (type ,type pixarray copy)) - #.(declare-buffun) - (with-underlying-simple-vector (src ,element-type pixarray) - (with-underlying-simple-vector (dst ,element-type copy) - (do* ((dst-y 0 (index1+ dst-y)) - (src-y y (index1+ src-y))) - ((index>= dst-y height)) - (declare (type card16 dst-y src-y)) - (do* ((dst-idx (array-row-major-index copy dst-y 0) - (index1+ dst-idx)) - (dst-end (index+ dst-idx width)) - (src-idx (array-row-major-index pixarray src-y x) - (index1+ src-idx))) - ((index>= dst-idx dst-end)) - (declare (type array-index dst-idx src-idx dst-end)) - (setf (aref dst dst-idx) - (the ,element-type (aref src src-idx)))))))))) - (ecase bits-per-pixel - (1 (copy pixarray-1 pixarray-1-element-type)) - (4 (copy pixarray-4 pixarray-4-element-type)) - (8 (copy pixarray-8 pixarray-8-element-type)) - (16 (copy pixarray-16 pixarray-16-element-type)) - (24 (copy pixarray-24 pixarray-24-element-type)) - (32 (copy pixarray-32 pixarray-32-element-type))) - t))) diff -Nru ecl-16.1.2/src/clx/dep-openmcl.lisp ecl-16.1.3+ds/src/clx/dep-openmcl.lisp --- ecl-16.1.2/src/clx/dep-openmcl.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/dep-openmcl.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,1123 +0,0 @@ -;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- - -;; This file contains some of the system dependent code for CLX - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(proclaim '(declaration array-register)) - - -;;; The size of the output buffer. Must be a multiple of 4. -(defparameter *output-buffer-size* 8192) - -;;; Number of seconds to wait for a reply to a server request -(defparameter *reply-timeout* nil) - -(progn - (defconstant +word-0+ 1) - (defconstant +word-1+ 0) - - (defconstant +long-0+ 3) - (defconstant +long-1+ 2) - (defconstant +long-2+ 1) - (defconstant +long-3+ 0)) - -;;; Set some compiler-options for often used code - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +buffer-speed+ #+clx-debugging 1 #-clx-debugging 3 - "Speed compiler option for buffer code.") - (defconstant +buffer-safety+ #+clx-debugging 3 #-clx-debugging 0 - "Safety compiler option for buffer code.") - (defconstant +buffer-debug+ #+clx-debugging 2 #-clx-debugging 1 - "Debug compiler option for buffer code>") - (defun declare-bufmac () - `(declare (optimize - (speed ,+buffer-speed+) - (safety ,+buffer-safety+) - (debug ,+buffer-debug+)))) - ;; It's my impression that in lucid there's some way to make a - ;; declaration called fast-entry or something that causes a function - ;; to not do some checking on args. Sadly, we have no lucid manuals - ;; here. If such a declaration is available, it would be a good - ;; idea to make it here when +buffer-speed+ is 3 and +buffer-safety+ - ;; is 0. - (defun declare-buffun () - `(declare (optimize - (speed ,+buffer-speed+) - (safety ,+buffer-safety+) - (debug ,+buffer-debug+))))) - -(declaim (inline card8->int8 int8->card8 - card16->int16 int16->card16 - card32->int32 int32->card32)) - -(progn - -(defun card8->int8 (x) - (declare (type card8 x)) - (declare (clx-values int8)) - #.(declare-buffun) - (the int8 (if (logbitp 7 x) - (the int8 (- x #x100)) - x))) - -(defun int8->card8 (x) - (declare (type int8 x)) - (declare (clx-values card8)) - #.(declare-buffun) - (the card8 (ldb (byte 8 0) x))) - -(defun card16->int16 (x) - (declare (type card16 x)) - (declare (clx-values int16)) - #.(declare-buffun) - (the int16 (if (logbitp 15 x) - (the int16 (- x #x10000)) - x))) - -(defun int16->card16 (x) - (declare (type int16 x)) - (declare (clx-values card16)) - #.(declare-buffun) - (the card16 (ldb (byte 16 0) x))) - -(defun card32->int32 (x) - (declare (type card32 x)) - (declare (clx-values int32)) - #.(declare-buffun) - (the int32 (if (logbitp 31 x) - (the int32 (- x #x100000000)) - x))) - -(defun int32->card32 (x) - (declare (type int32 x)) - (declare (clx-values card32)) - #.(declare-buffun) - (the card32 (ldb (byte 32 0) x))) - -) - -(declaim (inline aref-card8 aset-card8 aref-int8 aset-int8)) - -(progn - -(defun aref-card8 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card8)) - #.(declare-buffun) - (the card8 (aref a i))) - -(defun aset-card8 (v a i) - (declare (type card8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a i) v)) - -(defun aref-int8 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int8)) - #.(declare-buffun) - (card8->int8 (aref a i))) - -(defun aset-int8 (v a i) - (declare (type int8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a i) (int8->card8 v))) - -) - -(progn - -(defun aref-card16 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card16)) - #.(declare-buffun) - (the card16 - (logior (the card16 - (ash (the card8 (aref a (index+ i +word-1+))) 8)) - (the card8 - (aref a (index+ i +word-0+)))))) - -(defun aset-card16 (v a i) - (declare (type card16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) - v) - -(defun aref-int16 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int16)) - #.(declare-buffun) - (the int16 - (logior (the int16 - (ash (the int8 (aref-int8 a (index+ i +word-1+))) 8)) - (the card8 - (aref a (index+ i +word-0+)))))) - -(defun aset-int16 (v a i) - (declare (type int16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) - v) - -(defun aref-card32 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card32)) - #.(declare-buffun) - (the card32 - (logior (the card32 - (ash (the card8 (aref a (index+ i +long-3+))) 24)) - (the card29 - (ash (the card8 (aref a (index+ i +long-2+))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i +long-1+))) 8)) - (the card8 - (aref a (index+ i +long-0+)))))) - -(defun aset-card32 (v a i) - (declare (type card32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) - (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) - (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) - v) - -(defun aref-int32 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int32)) - #.(declare-buffun) - (the int32 - (logior (the int32 - (ash (the int8 (aref-int8 a (index+ i +long-3+))) 24)) - (the card29 - (ash (the card8 (aref a (index+ i +long-2+))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i +long-1+))) 8)) - (the card8 - (aref a (index+ i +long-0+)))))) - -(defun aset-int32 (v a i) - (declare (type int32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) - (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) - (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) - v) - -(defun aref-card29 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card29)) - #.(declare-buffun) - (the card29 - (logior (the card29 - (ash (the card8 (aref a (index+ i +long-3+))) 24)) - (the card29 - (ash (the card8 (aref a (index+ i +long-2+))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i +long-1+))) 8)) - (the card8 - (aref a (index+ i +long-0+)))))) - -(defun aset-card29 (v a i) - (declare (type card29 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) - (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) - (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) - v) - -) - -(defsetf aref-card8 (a i) (v) - `(aset-card8 ,v ,a ,i)) - -(defsetf aref-int8 (a i) (v) - `(aset-int8 ,v ,a ,i)) - -(defsetf aref-card16 (a i) (v) - `(aset-card16 ,v ,a ,i)) - -(defsetf aref-int16 (a i) (v) - `(aset-int16 ,v ,a ,i)) - -(defsetf aref-card32 (a i) (v) - `(aset-card32 ,v ,a ,i)) - -(defsetf aref-int32 (a i) (v) - `(aset-int32 ,v ,a ,i)) - -(defsetf aref-card29 (a i) (v) - `(aset-card29 ,v ,a ,i)) - -;;; Other random conversions - -(defun rgb-val->card16 (value) - ;; Short floats are good enough - (declare (type rgb-val value)) - (declare (clx-values card16)) - #.(declare-buffun) - ;; Convert VALUE from float to card16 - (the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff))))) - -(defun card16->rgb-val (value) - ;; Short floats are good enough - (declare (type card16 value)) - (declare (clx-values short-float)) - #.(declare-buffun) - ;; Convert VALUE from card16 to float - (the short-float (* (the card16 value) #.(/ 1.0s0 #xffff)))) - -(defun radians->int16 (value) - ;; Short floats are good enough - (declare (type angle value)) - (declare (clx-values int16)) - #.(declare-buffun) - (the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0))))) - -(defun int16->radians (value) - ;; Short floats are good enough - (declare (type int16 value)) - (declare (clx-values short-float)) - #.(declare-buffun) - (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float)))) - - -;;----------------------------------------------------------------------------- -;; Character transformation -;;----------------------------------------------------------------------------- - - -;;; This stuff transforms chars to ascii codes in card8's and back. -;;; You might have to hack it a little to get it to work for your machine. - -(declaim (inline char->card8 card8->char)) - -(macrolet ((char-translators () - (let ((alist - `( - ;; The normal ascii codes for the control characters. - ,@`((#\Return . 13) - (#\Linefeed . 10) - (#\Rubout . 127) - (#\Page . 12) - (#\Tab . 9) - (#\Backspace . 8) - (#\Newline . 10) - (#\Space . 32)) - - ;; The rest of the common lisp charater set with - ;; the normal ascii codes for them. - (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36) - (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40) - (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44) - (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48) - (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52) - (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56) - (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60) - (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64) - (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68) - (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72) - (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76) - (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80) - (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84) - (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88) - (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92) - (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96) - (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100) - (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104) - (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108) - (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112) - (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116) - (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120) - (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124) - (#\} . 125) (#\~ . 126)))) - (cond ((dolist (pair alist nil) - (when (not (= (char-code (car pair)) (cdr pair))) - (return t))) - `(progn - (defconstant *char-to-card8-translation-table* - ',(let ((array (make-array - (let ((max-char-code 255)) - (dolist (pair alist) - (setq max-char-code - (max max-char-code - (char-code (car pair))))) - (1+ max-char-code)) - :element-type 'card8))) - (dotimes (i (length array)) - (setf (aref array i) (mod i 256))) - (dolist (pair alist) - (setf (aref array (char-code (car pair))) - (cdr pair))) - array)) - (defconstant *card8-to-char-translation-table* - ',(let ((array (make-array 256))) - (dotimes (i (length array)) - (setf (aref array i) (code-char i))) - (dolist (pair alist) - (setf (aref array (cdr pair)) (car pair))) - array)) - (progn - (defun char->card8 (char) - (declare (type base-char char)) - #.(declare-buffun) - (the card8 (aref (the (simple-array card8 (*)) - *char-to-card8-translation-table*) - (the array-index (char-code char))))) - (defun card8->char (card8) - (declare (type card8 card8)) - #.(declare-buffun) - (the base-char - (or (aref (the simple-vector *card8-to-char-translation-table*) - card8) - (error "Invalid CHAR code ~D." card8)))) - ) - #+Genera - (progn - (defun char->card8 (char) - (declare lt:(side-effects reader reducible)) - (aref *char-to-card8-translation-table* (char-code char))) - (defun card8->char (card8) - (declare lt:(side-effects reader reducible)) - (aref *card8-to-char-translation-table* card8)) - ) - (dotimes (i 256) - (unless (= i (char->card8 (card8->char i))) - (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S" - (list i - (card8->char i) - (char->card8 (card8->char i)))) - (return nil))) - (dotimes (i (length *char-to-card8-translation-table*)) - (let ((char (code-char i))) - (unless (eql char (card8->char (char->card8 char))) - (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S" - (list char - (char->card8 char) - (card8->char (char->card8 char)))) - (return nil)))))) - (t - `(progn - (defun char->card8 (char) - (declare (type base-char char)) - #.(declare-buffun) - (the card8 (char-code char))) - (defun card8->char (card8) - (declare (type card8 card8)) - #.(declare-buffun) - (the base-char (code-char card8))) - )))))) - (char-translators)) - -;;----------------------------------------------------------------------------- -;; Process Locking -;; -;; Common-Lisp doesn't provide process locking primitives, so we define -;; our own here, based on Zetalisp primitives. Holding-Lock is very -;; similar to with-lock on The TI Explorer, and a little more efficient -;; than with-process-lock on a Symbolics. -;;----------------------------------------------------------------------------- - -;;; MAKE-PROCESS-LOCK: Creating a process lock. - -(defun make-process-lock (name) - (ccl:make-lock name)) - -;;; HOLDING-LOCK: Execute a body of code with a lock held. - -;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN -;;; passes its timeout to the holding-lock macro, so any timeout you want to -;;; work for event-listen you should do for holding-lock. - -(defmacro holding-lock ((locator display &optional whostate &key timeout) - &body body) - (declare (ignore timeout display)) - `(ccl:with-lock-grabbed (,locator ,whostate) - ,@body)) - -;;; WITHOUT-ABORTS - -;;; If you can inhibit asynchronous keyboard aborts inside the body of this -;;; macro, then it is a good idea to do this. This macro is wrapped around -;;; request writing and reply reading to ensure that requests are atomically -;;; written and replies are atomically read from the stream. - -(defmacro without-aborts (&body body) - `(ccl:without-interrupts ,@body)) - -;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value. -;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's -;;; value changes. - -(defun process-block (whostate predicate &rest predicate-args) - (declare (dynamic-extern predicate-args)) - (apply #'ccl:process-wait whostate predicate predicate-args)) - -;;; PROCESS-WAKEUP: Check some other process' wait function. - -(declaim (inline process-wakeup)) - -(defun process-wakeup (process) - (declare (ignore process)) - nil) - -;;; CURRENT-PROCESS: Return the current process object for input locking and -;;; for calling PROCESS-WAKEUP. - -(declaim (inline current-process)) - -;;; Default return NIL, which is acceptable even if there is a scheduler. - -(defun current-process () - ccl::*current-process*) - -;;; WITHOUT-INTERRUPTS -- provide for atomic operations. - -(defmacro without-interrupts (&body body) - `(ccl:without-interrupts ,@body)) - -;;; CONDITIONAL-STORE: - -;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times. -;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD. - -(defmacro conditional-store (place old-value new-value) - `(ccl::conditional-store ,place ,old-value ,new-value)) - -;;;---------------------------------------------------------------------------- -;;; IO Error Recovery -;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro. -;;; It prevents multiple mindless errors when the network craters. -;;; -;;;---------------------------------------------------------------------------- - -(defmacro wrap-buf-output ((buffer) &body body) - ;; Error recovery wrapper - `(unless (buffer-dead ,buffer) - ,@body)) - -(defmacro wrap-buf-input ((buffer) &body body) - (declare (ignore buffer)) - ;; Error recovery wrapper - `(progn ,@body)) - - -;;;---------------------------------------------------------------------------- -;;; System dependent IO primitives -;;; Functions for opening, reading writing forcing-output and closing -;;; the stream to the server. -;;;---------------------------------------------------------------------------- - -;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X -;;; server - -(defun open-x-stream (host display protocol) - (declare (ignore protocol)) - (let ((local-socket-path (unix-socket-path-from-host host display))) - (if local-socket-path - (ccl::make-socket :connect :active - :address-family :file - :remote-filename local-socket-path) - (ccl::make-socket :connect :active - :remote-host host - :remote-port (+ 6000 display))))) - -;;; BUFFER-READ-DEFAULT - read data from the X stream - -(defun buffer-read-default (display vector start end timeout) - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null (real 0 *)) timeout)) - #.(declare-buffun) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (or (cond ((null stream)) - ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) - ((buffer-input-wait-default display timeout))) - (progn - (ccl:stream-read-ivector stream vector start (- end start)) - nil)))) - -;;; BUFFER-WRITE-DEFAULT - write data to the X stream - -(defun buffer-write-default (vector display start end) - (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) - #.(declare-buffun) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (ccl:stream-write-ivector stream vector start (- end start))) - nil)) - -;;; buffer-force-output-default - force output to the X stream - -(defun buffer-force-output-default (display) - ;; The default buffer force-output function for use with common-lisp streams - (declare (type display display)) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (force-output stream)))) - -;;; BUFFER-CLOSE-DEFAULT - close the X stream - -(defun buffer-close-default (display &key abort) - ;; The default buffer close function for use with common-lisp streams - (declare (type display display)) - #.(declare-buffun) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (close stream :abort abort)))) - -;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the -;;; buffer. This is called in read-input between requests, so that a process -;;; waiting for input is abortable when between requests. Should return -;;; :TIMEOUT if it times out, NIL otherwise. - -(defun buffer-input-wait-default (display timeout) - (declare (type display display) - (type (or null number) timeout)) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (cond ((null stream)) - ((listen stream) nil) - ((eql timeout 0) :timeout) - (t - (let* ((fd (ccl::stream-device stream :input)) - (ticks (and timeout (floor (* timeout ccl::*ticks-per-second*))))) - (if (ccl::process-input-wait fd ticks) - nil - :timeout)))))) - - -;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the -;;; buffer. This should never block, so it can be called from the scheduler. - -;;; The default implementation is to just use listen. - -(defun buffer-listen-default (display) - (declare (type display display)) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (if (null stream) - t - (listen stream)))) - - -;;;---------------------------------------------------------------------------- -;;; System dependent speed hacks -;;;---------------------------------------------------------------------------- - -;; -;; WITH-STACK-LIST is used by WITH-STATE as a memory saving feature. -;; If your lisp doesn't have stack-lists, and you're worried about -;; consing garbage, you may want to re-write this to allocate and -;; initialize lists from a resource. -;; - -(defmacro with-stack-list ((var &rest elements) &body body) - ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body) - ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body) - ;; except that the list produced by MAPCAR resides on the stack and - ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. - `(let ((,var (list ,@elements))) - (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) - ,@body)) - -(defmacro with-stack-list* ((var &rest elements) &body body) - ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body) - ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body) - ;; except that the list produced by MAPCAR resides on the stack and - ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. - `(let ((,var (list* ,@elements))) - (declare (type cons ,var) - (dynamic-extent ,var)) - ,@body)) - -(declaim (inline buffer-replace)) - -(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) - (declare (type buffer-bytes buf1 buf2) - (type array-index start1 end1 start2)) - (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2)) - -(defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) - &body body) - (let ((local-state (gensym)) - (resets nil)) - (dolist (index indexes) - (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index)) - resets)) - `(unwind-protect - (progn - ,@body) - (let ((,local-state (gcontext-local-state ,gc))) - (declare (type gcontext-state ,local-state)) - ,@resets - (setf (svref ,local-state ,ts-index) 0)) - (when ,temp-gc - (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) - (deallocate-gcontext-state ,saved-state)))) - -;;;---------------------------------------------------------------------------- -;;; How much error detection should CLX do? -;;; Several levels are possible: -;;; -;;; 1. Do the equivalent of check-type on every argument. -;;; -;;; 2. Simply report TYPE-ERROR. This eliminates overhead of all the format -;;; strings generated by check-type. -;;; -;;; 3. Do error checking only on arguments that are likely to have errors -;;; (like keyword names) -;;; -;;; 4. Do error checking only where not doing so may dammage the envirnment -;;; on a non-tagged machine (i.e. when storing into a structure that has -;;; been passed in) -;;; -;;; 5. No extra error detection code. On lispm's, ASET may barf trying to -;;; store a non-integer into a number array. -;;; -;;; How extensive should the error checking be? For example, if the server -;;; expects a CARD16, is is sufficient for CLX to check for integer, or -;;; should it also check for non-negative and less than 65536? -;;;---------------------------------------------------------------------------- - -;; The +TYPE-CHECK?+ constant controls how much error checking is done. -;; Possible values are: -;; NIL - Don't do any error checking -;; t - Do the equivalent of checktype on every argument -;; :minimal - Do error checking only where errors are likely - -;;; This controls macro expansion, and isn't changable at run-time You will -;;; probably want to set this to nil if you want good performance at -;;; production time. -(defconstant +type-check?+ nil) - -;; TYPE? is used to allow the code to do error checking at a different level from -;; the declarations. It also does some optimizations for systems that don't have -;; good compiler support for TYPEP. The definitions for CARD32, CARD16, INT16, etc. -;; include range checks. You can modify TYPE? to do less extensive checking -;; for these types if you desire. - -;; -;; ### This comment is a lie! TYPE? is really also used for run-time type -;; dispatching, not just type checking. -- Ram. - -(defmacro type? (object type) - (if (not (constantp type)) - `(typep ,object ,type) - (progn - (setq type (eval type)) - (let ((predicate (assoc type - '((drawable drawable-p) (window window-p) - (pixmap pixmap-p) (cursor cursor-p) - (font font-p) (gcontext gcontext-p) - (colormap colormap-p) (null null) - (integer integerp))))) - (cond (predicate - `(,(second predicate) ,object)) - ((eq type 'generalized-boolean) - 't) ; Everything is a generalized-boolean. - (+type-check?+ - `(locally (declare (optimize safety)) (typep ,object ',type))) - (t - `(typep ,object ',type))))))) - -;; X-TYPE-ERROR is the function called for type errors. -;; If you want lots of checking, but are concerned about code size, -;; this can be made into a macro that ignores some parameters. - -(defun x-type-error (object type &optional error-string) - (x-error 'x-type-error - :datum object - :expected-type type - :type-string error-string)) - - -;;----------------------------------------------------------------------------- -;; Error handlers -;; Hack up KMP error signaling using zetalisp until the real thing comes -;; along -;;----------------------------------------------------------------------------- - -(defun default-error-handler (display error-key &rest key-vals - &key asynchronous &allow-other-keys) - (declare (type generalized-boolean asynchronous) - (dynamic-extent key-vals)) - ;; The default display-error-handler. - ;; It signals the conditions listed in the DISPLAY file. - (if asynchronous - (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals) - (apply #'x-error error-key :display display :error-key error-key key-vals))) - -(defun x-error (condition &rest keyargs) - (declare (dynamic-extent keyargs)) - (apply #'error condition keyargs)) - -(defun x-cerror (proceed-format-string condition &rest keyargs) - (declare (dynamic-extent keyargs)) - (apply #'cerror proceed-format-string condition keyargs)) - - -;; version 15 of Pitman error handling defines the syntax for define-condition to be: -;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*] -;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string) -;; or (:report exp) - -(define-condition x-error (error) ()) - - -;;----------------------------------------------------------------------------- -;; HOST hacking -;;----------------------------------------------------------------------------- - -(defun host-address (host &optional (family :internet)) - ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - (ecase family - ((:internet nil 0) - (let* ((addr (ccl::host-as-inet-host host))) - (cons :internet (list - (ldb (byte 8 24) addr) - (ldb (byte 8 16) addr) - (ldb (byte 8 8) addr) - (ldb (byte 8 0) addr))))))) - - -;;----------------------------------------------------------------------------- -;; Whether to use closures for requests or not. -;;----------------------------------------------------------------------------- - -;;; If this macro expands to non-NIL, then request and locking code is -;;; compiled in a much more compact format, as the common code is shared, and -;;; the specific code is built into a closure that is funcalled by the shared -;;; code. If your compiler makes efficient use of closures then you probably -;;; want to make this expand to T, as it makes the code more compact. - -(defmacro use-closures () nil) - -(defun clx-macroexpand (form env) - (macroexpand form env)) - - -;;----------------------------------------------------------------------------- -;; Resource stuff -;;----------------------------------------------------------------------------- - - -;;; Utilities - -(defun getenv (name) - (ccl::getenv name)) - -(defun get-host-name () - "Return the same hostname as gethostname(3) would" - (machine-instance)) - -(defun homedir-file-pathname (name) - (merge-pathnames (user-homedir-pathname) (pathname name))) - -;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if -;;; a resource manager isn't running. - -(defun default-resources-pathname () - (homedir-file-pathname ".Xdefaults")) - -;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the -;;; defaults have been loaded. - -(defun resources-pathname () - (or (let ((string (getenv "XENVIRONMENT"))) - (and string - (pathname string))) - (homedir-file-pathname - (concatenate 'string ".Xdefaults-" (get-host-name))))) - -;;; AUTHORITY-PATHNAME - The pathname of the authority file. - -(defun authority-pathname () - (or (let ((xauthority (getenv "XAUTHORITY"))) - (and xauthority - (pathname xauthority))) - (homedir-file-pathname ".Xauthority"))) - -;;; this particular defaulting behaviour is typical to most Unices, I think - -(defun get-default-display (&optional display-name) - "Parse the argument DISPLAY-NAME, or the environment variable $DISPLAY -if it is NIL. Display names have the format - - [protocol/] [hostname] : [:] displaynumber [.screennumber] - -There are two special cases in parsing, to match that done in the Xlib -C language bindings - - - If the hostname is ``unix'' or the empty string, any supplied - protocol is ignored and a connection is made using the :local - transport. - - - If a double colon separates hostname from displaynumber, the - protocol is assumed to be decnet. - -Returns a list of (host display-number screen protocol)." - (let* ((name (or display-name - (getenv "DISPLAY") - (error "DISPLAY environment variable is not set"))) - (slash-i (or (position #\/ name) -1)) - (colon-i (position #\: name :start (1+ slash-i))) - (decnet-colon-p (eql (elt name (1+ colon-i)) #\:)) - (host (subseq name (1+ slash-i) colon-i)) - (dot-i (and colon-i (position #\. name :start colon-i))) - (display (when colon-i - (parse-integer name - :start (if decnet-colon-p - (+ colon-i 2) - (1+ colon-i)) - :end dot-i))) - (screen (when dot-i - (parse-integer name :start (1+ dot-i)))) - (protocol - (cond ((or (string= host "") (string-equal host "unix")) :local) - (decnet-colon-p :decnet) - ((> slash-i -1) (intern - (string-upcase (subseq name 0 slash-i)) - :keyword)) - (t :internet)))) - (list host (or display 0) (or screen 0) protocol))) - - -;;----------------------------------------------------------------------------- -;; GC stuff -;;----------------------------------------------------------------------------- - -(defun gc-cleanup () - (declare (special *event-free-list* - *pending-command-free-list* - *reply-buffer-free-lists* - *gcontext-local-state-cache* - *temp-gcontext-cache*)) - (setq *event-free-list* nil) - (setq *pending-command-free-list* nil) - (when (boundp '*reply-buffer-free-lists*) - (fill *reply-buffer-free-lists* nil)) - (setq *gcontext-local-state-cache* nil) - (setq *temp-gcontext-cache* nil) - nil) - - -;;----------------------------------------------------------------------------- -;; DEFAULT-KEYSYM-TRANSLATE -;;----------------------------------------------------------------------------- - -;;; If object is a character, char-bits are set from state. -;;; -;;; [the following isn't implemented (should it be?)] -;;; If object is a list, it is an alist with entries: -;;; (base-char [modifiers] [mask-modifiers]) -;;; When MODIFIERS are specified, this character translation -;;; will only take effect when the specified modifiers are pressed. -;;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore. -;;; When MASK-MODIFIERS is missing, all other modifiers are ignored. -;;; In ambiguous cases, the most specific translation is used. - -(defun default-keysym-translate (display state object) - (declare (type display display) - (type card16 state) - (type t object) - (ignore display state) - (clx-values t)) - object) - - -;;----------------------------------------------------------------------------- -;; Image stuff -;;----------------------------------------------------------------------------- - -;;; Types - -(deftype pixarray-1-element-type () - 'bit) - -(deftype pixarray-4-element-type () - '(unsigned-byte 4)) - -(deftype pixarray-8-element-type () - '(unsigned-byte 8)) - -(deftype pixarray-16-element-type () - '(unsigned-byte 16)) - -(deftype pixarray-24-element-type () - '(unsigned-byte 24)) - -(deftype pixarray-32-element-type () - '(unsigned-byte 32)) - -(deftype pixarray-1 () - '(array pixarray-1-element-type (* *))) - -(deftype pixarray-4 () - '(array pixarray-4-element-type (* *))) - -(deftype pixarray-8 () - '(array pixarray-8-element-type (* *))) - -(deftype pixarray-16 () - '(array pixarray-16-element-type (* *))) - -(deftype pixarray-24 () - '(array pixarray-24-element-type (* *))) - -(deftype pixarray-32 () - '(array pixarray-32-element-type (* *))) - -(deftype pixarray () - '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32)) - -(deftype bitmap () - 'pixarray-1) - -;;; WITH-UNDERLYING-SIMPLE-VECTOR - -(defmacro with-underlying-simple-vector ((variable element-type pixarray) - &body body) - (declare (ignore element-type)) - `(let* ((,variable (ccl::array-data-and-offset ,pixarray))) - ,@body)) - -;;; These are used to read and write pixels from and to CARD8s. - -;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s. - -(defmacro read-image-load-byte (size position integer) - (unless +image-bit-lsb-first-p+ (setq position (- 7 position))) - `(the (unsigned-byte ,size) - (ldb - (byte ,size ,position) - (the card8 ,integer)))) - -;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from -;;; the appropriate number of CARD8s. - -(defmacro read-image-assemble-bytes (&rest bytes) - (unless +image-byte-lsb-first-p+ (setq bytes (reverse bytes))) - (let ((it (first bytes)) - (count 0)) - (dolist (byte (rest bytes)) - (setq it - `(dpb - (the card8 ,byte) - (byte 8 ,(incf count 8)) - (the (unsigned-byte ,count) ,it)))) - `(the (unsigned-byte ,(* (length bytes) 8)) ,it))) - -;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit -;;; pixel. - -(defmacro write-image-load-byte (position integer integer-size) - integer-size - (unless +image-byte-lsb-first-p+ (setq position (- integer-size 8 position))) - `(the card8 - (ldb - (byte 8 ,position) - (the (unsigned-byte ,integer-size) ,integer)))) - -;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit -;;; pixels. - -(defmacro write-image-assemble-bytes (&rest bytes) - (unless +image-bit-lsb-first-p+ (setq bytes (reverse bytes))) - (let ((size (floor 8 (length bytes))) - (it (first bytes)) - (count 0)) - (dolist (byte (rest bytes)) - (setq it `(dpb - (the (unsigned-byte ,size) ,byte) - (byte ,size ,(incf count size)) - (the (unsigned-byte ,count) ,it)))) - `(the card8 ,it))) - - -;;; If you can write fast routines that can read and write pixarrays out of a -;;; buffer-bytes, do it! It makes the image code a lot faster. The -;;; FAST-READ-PIXARRAY, FAST-WRITE-PIXARRAY and FAST-COPY-PIXARRAY routines -;;; return T if they can do it, NIL if they can't. - -;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s - -(defun fast-read-pixarray (bbuf boffset pixarray - x y width height padded-bytes-per-line - bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (declare (ignore bbuf boffset pixarray x y width height - padded-bytes-per-line bits-per-pixel unit - byte-lsb-first-p bit-lsb-first-p)) - nil) - -;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s - -(defun fast-write-pixarray (bbuf boffset pixarray x y width height - padded-bytes-per-line bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (declare (ignore bbuf boffset pixarray x y width height - padded-bytes-per-line bits-per-pixel unit - byte-lsb-first-p bit-lsp-first-p)) - nil) - -;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another - -(defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel) - (declare (ignore pixarray copy x y width height bits-per-pixel)) - nil) diff -Nru ecl-16.1.2/src/clx/display.lisp ecl-16.1.3+ds/src/clx/display.lisp --- ecl-16.1.2/src/clx/display.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/display.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,680 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11 - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -;;; Authorizaton - -(defparameter *known-authorizations* '("MIT-MAGIC-COOKIE-1")) - -;;; X11 Authorization: to prevent malicious users from snooping on a -;;; display, X servers may require connection requests to be -;;; authorized. The X server (or display manager) will create a random -;;; key on startup, and store it as an entry in a file generally named -;;; $HOME/.Xauthority (see xauth(1) and the AUTHORITY-PATHNAME -;;; function). Clients must extract from this file the "magic cookie" -;;; that corresponds to the server they wish to connect to, and send -;;; it as authorization data when opening the display. - -;;; The format of the .Xauthority file is documented in the XFree -;;; sources, in the file xc/lib/Xau/README. - -;;; Stolen from the cmucl sources, with patches by Hannu Rummukainen and -;;; Scott Fahlman. - -(defun read-xauth-entry (stream) - (labels ((read-short (stream &optional (eof-errorp t)) - (let ((high-byte (read-byte stream eof-errorp))) - (and high-byte - (dpb high-byte (byte 8 8) (read-byte stream))))) - (read-short-length-string (stream) - (let ((length (read-short stream))) - (let ((string (make-string length))) - (dotimes (k length) - (setf (schar string k) (card8->char (read-byte stream)))) - string))) - (read-short-length-vector (stream) - (let ((length (read-short stream))) - (let ((vector (make-array length - :element-type '(unsigned-byte 8)))) - (dotimes (k length) - (setf (aref vector k) (read-byte stream))) - vector)))) - (let ((family-id (read-short stream nil))) - (if (null family-id) - (list nil nil nil nil nil) - (let* ((address-data (read-short-length-vector stream)) - (number (parse-integer (read-short-length-string stream))) - (name (read-short-length-string stream)) - (data (read-short-length-vector stream)) - (family (car (rassoc family-id *protocol-families*)))) - (unless family - (return-from read-xauth-entry - ;; we return FAMILY-ID to signal to - ;; GET-BEST-AUTHORIZATION that we haven't finished - ;; with the stream. - (list family-id nil nil nil nil))) - (let ((address - (case family - (:local (map 'string #'code-char address-data)) - (:internet (coerce address-data 'list)) - ;; FIXME: we can probably afford not to support - ;; :DECNET or :CHAOSNET in this modern age, but - ;; :INTERNET6 probably deserve support. -- CSR, - ;; 2005-08-07 - (t nil)))) - ;; if ADDRESS is NIL by this time, we will never match - ;; the address of DISPLAY. - (list family address number name data))))))) - -(defun get-best-authorization (host display protocol) - ;; parse .Xauthority, extract the cookie for DISPLAY on HOST. - ;; PROTOCOL determines whether the server connection is using an - ;; Internet protocol (value of :internet) or a non-network - ;; protocol such as Unix domain sockets (value of :local). Returns - ;; two strings: an authorization name (very likely the string - ;; "MIT-MAGIC-COOKIE-1") and an authorization key, represented as - ;; fixnums in a vector. If we fail to find an appropriate cookie, - ;; return two empty strings. - (let ((pathname (authority-pathname))) - (when pathname - (with-open-file (stream pathname :element-type '(unsigned-byte 8) - :if-does-not-exist nil) - (when stream - (let* ((host-address (and (eql protocol :internet) - (rest (host-address host protocol)))) - (best-name nil) (best-pos nil) - (best-data nil)) - ;; Check for the localhost address, in which case we're - ;; really FamilyLocal. - (when (or (eql protocol :local) - (and (eql protocol :internet) - (equal host-address '(127 0 0 1)))) - (setq host-address (get-host-name)) - (setq protocol :local)) - (loop - (destructuring-bind (family address number name data) - (read-xauth-entry stream) - (unless family (return)) - (when (and (eql family protocol) - (equal host-address address) - (= number display) - (let ((pos1 (position name *known-authorizations* - :test #'string=))) - (and pos1 - (or (null best-pos) - (< pos1 best-pos))))) - (setf best-name name - best-pos (position name *known-authorizations* - :test #'string=) - best-data data)))) - (when best-name - (return-from get-best-authorization - (values best-name best-data))))))) - (values "" ""))) - -(defmacro with-display ((display &key timeout inline) - &body body) - ;; This macro is for use in a multi-process environment. It - ;; provides exclusive access to the local display object for - ;; multiple request generation. It need not provide immediate - ;; exclusive access for replies; that is, if another process is - ;; waiting for a reply (while not in a with-display), then - ;; synchronization need not (but can) occur immediately. Except - ;; where noted, all routines effectively contain an implicit - ;; with-display where needed, so that correct synchronization is - ;; always provided at the interface level on a per-call basis. - ;; Nested uses of this macro will work correctly. This macro does - ;; not prevent concurrent event processing; see with-event-queue. - `(with-buffer (,display - ,@(and timeout `(:timeout ,timeout)) - ,@(and inline `(:inline ,inline))) - ,@body)) - -;; -;; Resource id management -;; -(defun initialize-resource-allocator (display) - ;; Find the resource-id-byte (appropriate for LDB & DPB) from the resource-id-mask - (let ((id-mask (display-resource-id-mask display))) - (unless (zerop id-mask) ;; zero mask is an error - (do ((first 0 (index1+ first)) - (mask id-mask (the mask32 (ash mask -1)))) - ((oddp mask) - (setf (display-resource-id-byte display) - (byte (integer-length mask) first))) - (declare (type array-index first) - (type mask32 mask)))))) - -(defun resourcealloc (display) - ;; Allocate a resource-id for use in DISPLAY - (declare (type display display)) - (declare (clx-values resource-id)) - (loop for next-count upfrom (1+ (display-resource-id-count display)) - repeat (1+ (display-resource-id-mask display)) - as id = (dpb next-count - (display-resource-id-byte display) - (display-resource-id-base display)) - unless (nth-value 1 (gethash id (display-resource-id-map display))) - do (setf (display-resource-id-count display) next-count) - (setf (gethash id (display-resource-id-map display)) t) - (return-from resourcealloc id)) - ;; internal consistency check - (assert (= (hash-table-count (display-resource-id-map display)) - (1+ (display-resource-id-mask display)))) - ;; tell the user what's gone wrong - (error 'resource-ids-exhausted)) - -(defmacro allocate-resource-id (display object type) - ;; Allocate a resource-id for OBJECT in DISPLAY - `(with-display (,display) - ,(if (member (eval type) +clx-cached-types+) - `(let ((id (funcall (display-xid ,display) ,display))) - (save-id ,display id ,object) - id) - `(funcall (display-xid ,display) ,display)))) - -(defmacro deallocate-resource-id (display id type) - (declare (ignore type)) - ;; Deallocate a resource-id for OBJECT in DISPLAY - `(deallocate-resource-id-internal ,display ,id)) - -(defun deallocate-resource-id-internal (display id) - (with-display (display) - (remhash id (display-resource-id-map display)))) - -(defun lookup-resource-id (display id) - ;; Find the object associated with resource ID - (gethash id (display-resource-id-map display))) - -(defun save-id (display id object) - ;; cache the object associated with ID for this display. - (declare (type display display) - (type integer id) - (type t object)) - (declare (clx-values object)) - ;; we can't cache objects from other clients, because they may - ;; become invalid without us being told about that. - (let ((base (display-resource-id-base display)) - (mask (display-resource-id-mask display))) - (when (= (logandc2 id mask) base) - (setf (gethash id (display-resource-id-map display)) object)) - object)) - -;; Define functions to find the CLX data types given a display and resource-id -;; If the data type is being cached, look there first. -(macrolet ((generate-lookup-functions (useless-name &body types) - `(within-definition (,useless-name generate-lookup-functions) - ,@(mapcar - #'(lambda (type) - `(defun ,(xintern 'lookup- type) - (display id) - (declare (type display display) - (type resource-id id)) - (declare (clx-values ,type)) - ,(if (member type +clx-cached-types+) - `(let ((,type (lookup-resource-id display id))) - (cond ((null ,type) ;; Not found, create and save it. - (setq ,type (,(xintern 'make- type) - :display display :id id)) - (save-id display id ,type)) - ;; Found. Check the type - ,(cond ((null +type-check?+) - `(t ,type)) - ((member type '(window pixmap)) - `((type? ,type 'drawable) ,type)) - (t `((type? ,type ',type) ,type))) - ,@(when +type-check?+ - `((t (x-error 'lookup-error - :id id - :display display - :type ',type - :object ,type)))))) - ;; Not being cached. Create a new one each time. - `(,(xintern 'make- type) - :display display :id id)))) - types)))) - (generate-lookup-functions ignore - drawable - window - pixmap - gcontext - cursor - colormap - font)) - -(defun id-atom (id display) - ;; Return the cached atom for an atom ID - (declare (type resource-id id) - (type display display)) - (declare (clx-values (or null keyword))) - (gethash id (display-atom-id-map display))) - -(defun atom-id (atom display) - ;; Return the ID for an atom in DISPLAY - (declare (type xatom atom) - (type display display)) - (declare (clx-values (or null resource-id))) - (gethash (if (or (null atom) (keywordp atom)) atom (kintern atom)) - (display-atom-cache display))) - -(defun set-atom-id (atom display id) - ;; Set the ID for an atom in DISPLAY - (declare (type xatom atom) - (type display display) - (type resource-id id)) - (declare (clx-values resource-id)) - (let ((atom (if (or (null atom) (keywordp atom)) atom (kintern atom)))) - (setf (gethash id (display-atom-id-map display)) atom) - (setf (gethash atom (display-atom-cache display)) id) - id)) - -(defsetf atom-id set-atom-id) - -(defun initialize-predefined-atoms (display) - (dotimes (i (length +predefined-atoms+)) - (declare (type resource-id i)) - (setf (atom-id (svref +predefined-atoms+ i) display) i))) - -(defun visual-info (display visual-id) - (declare (type display display) - (type resource-id visual-id) - (clx-values visual-info)) - (when (zerop visual-id) - (return-from visual-info nil)) - (dolist (screen (display-roots display)) - (declare (type screen screen)) - (dolist (depth (screen-depths screen)) - (declare (type cons depth)) - (dolist (visual-info (rest depth)) - (declare (type visual-info visual-info)) - (when (funcall (resource-id-map-test) visual-id (visual-info-id visual-info)) - (return-from visual-info visual-info))))) - (error "Visual info not found for id #x~x in display ~s." visual-id display)) - - -;; -;; Display functions -;; -(defmacro with-event-queue ((display &key timeout inline) - &body body &environment env) - ;; exclusive access to event queue - `(macrolet ((with-event-queue ((display &key timeout) &body body) - ;; Speedup hack for lexically nested with-event-queues - `(progn - (progn ,display ,@(and timeout `(,timeout)) nil) - ,@body))) - ,(if (and (null inline) (macroexpand '(use-closures) env)) - `(flet ((.with-event-queue-body. () ,@body)) - #+clx-ansi-common-lisp - (declare (dynamic-extent #'.with-event-queue-body.)) - (with-event-queue-function - ,display ,timeout #'.with-event-queue-body.)) - (let ((disp (if (or (symbolp display) (constantp display)) - display - '.display.))) - `(let (,@(unless (eq disp display) `((,disp ,display)))) - (holding-lock ((display-event-lock ,disp) ,disp "CLX Event Lock" - ,@(and timeout `(:timeout ,timeout))) - ,@body)))))) - -(defun with-event-queue-function (display timeout function) - (declare (type display display) - (type (or null number) timeout) - (type function function) - #+clx-ansi-common-lisp - (dynamic-extent function) - ;; FIXME: see SBCL bug #243 - (ignorable display timeout) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg function)) - (with-event-queue (display :timeout timeout :inline t) - (funcall function))) - -(defmacro with-event-queue-internal ((display &key timeout) &body body) - ;; exclusive access to the internal event queues - (let ((disp (if (or (symbolp display) (constantp display)) display '.display.))) - `(let (,@(unless (eq disp display) `((,disp ,display)))) - (holding-lock ((display-event-queue-lock ,disp) ,disp "CLX Event Queue Lock" - ,@(and timeout `(:timeout ,timeout))) - ,@body)))) - -(defun open-default-display (&optional display-name) - "Open a connection to DISPLAY-NAME if supplied, or to the appropriate -default display as given by GET-DEFAULT-DISPLAY otherwise. - -OPEN-DISPLAY-NAME always attempts to do display authorization. The -hostname is resolved to an address, then authorization data for the -(protocol, host-address, displaynumber) triple is looked up in the -file given by AUTHORITY_PATHNAME (typically $HOME/.Xauthority). If -the protocol is :local, or if the hostname resolves to the local host, -authority data for the local machine's actual hostname - as returned by -gethostname(3) - is used instead." - (destructuring-bind (host display screen protocol) - (get-default-display display-name) - (let ((display (open-display host :display display :protocol protocol))) - (setf (display-default-screen display) (nth screen (display-roots display))) - display))) - -(defun open-display (host &key (display 0) protocol authorization-name authorization-data) - ;; Implementation specific routine to setup the buffer for a - ;; specific host and display. This must interface with the local - ;; network facilities, and will probably do special things to - ;; circumvent the nework when displaying on the local host. - ;; - ;; A string must be acceptable as a host, but otherwise the possible types - ;; for host and protocol are not constrained, and will likely be very - ;; system dependent. The default protocol is system specific. Authorization, - ;; if any, is assumed to come from the environment somehow. - (declare (type integer display)) - (declare (clx-values display)) - ;; Get the authorization mechanism from the environment. Handle the - ;; special case of a host name of "" and "unix" which means the - ;; protocol is :local - (when (null authorization-name) - (multiple-value-setq (authorization-name authorization-data) - (get-best-authorization host - display - (if (member host '("" "unix") :test #'equal) - :local - protocol)))) - ;; PROTOCOL is the network protocol (something like :TCP :DNA or :CHAOS). See OPEN-X-STREAM. - (let* ((stream (open-x-stream host display protocol)) - (disp (make-buffer *output-buffer-size* #'make-display-internal - :host host :display display - :output-stream stream :input-stream stream)) - (ok-p nil)) - (unwind-protect - (progn - (display-connect disp - :authorization-name authorization-name - :authorization-data authorization-data) - (setf (display-authorization-name disp) authorization-name) - (setf (display-authorization-data disp) authorization-data) - (initialize-resource-allocator disp) - (initialize-predefined-atoms disp) - (initialize-extensions disp) - (when (assoc "BIG-REQUESTS" (display-extension-alist disp) - :test #'string=) - (enable-big-requests disp)) - (setq ok-p t)) - (unless ok-p (close-display disp :abort t))) - disp)) - -(defun display-force-output (display) - ; Output is normally buffered, this forces any buffered output to the server. - (declare (type display display)) - (with-display (display) - (buffer-force-output display))) - -(defun close-display (display &key abort) - ;; Close the host connection in DISPLAY - (declare (type display display)) - (close-buffer display :abort abort)) - -(defun display-connect (display &key authorization-name authorization-data) - (with-buffer-output (display :sizes (8 16)) - (card8-put - 0 - (ecase (display-byte-order display) - (:lsbfirst #x6c) ;; Ascii lowercase l - Least Significant Byte First - (:msbfirst #x42))) ;; Ascii uppercase B - Most Significant Byte First - (card16-put 2 *protocol-major-version*) - (card16-put 4 *protocol-minor-version*) - (card16-put 6 (length authorization-name)) - (card16-put 8 (length authorization-data)) - (write-sequence-char display 12 authorization-name) - (if (stringp authorization-data) - (write-sequence-char display (lround (+ 12 (length authorization-name))) - authorization-data) - (write-sequence-card8 display (lround (+ 12 (length authorization-name))) - authorization-data))) - (buffer-force-output display) - (let ((reply-buffer nil)) - (declare (type (or null reply-buffer) reply-buffer)) - (unwind-protect - (progn - (setq reply-buffer (allocate-reply-buffer #x1000)) - (with-buffer-input (reply-buffer :sizes (8 16 32)) - (buffer-input display buffer-bbuf 0 8) - (let ((success (boolean-get 0)) - (reason-length (card8-get 1)) - (major-version (card16-get 2)) - (minor-version (card16-get 4)) - (total-length (card16-get 6)) - vendor-length - num-roots - num-formats) - (declare (ignore total-length)) - (unless success - (x-error 'connection-failure - :major-version major-version - :minor-version minor-version - :host (display-host display) - :display (display-display display) - :reason - (progn (buffer-input display buffer-bbuf 0 reason-length) - (string-get reason-length 0 :reply-buffer reply-buffer)))) - (buffer-input display buffer-bbuf 0 32) - (setf (display-protocol-major-version display) major-version) - (setf (display-protocol-minor-version display) minor-version) - (setf (display-release-number display) (card32-get 0)) - (setf (display-resource-id-base display) (card32-get 4)) - (setf (display-resource-id-mask display) (card32-get 8)) - (setf (display-motion-buffer-size display) (card32-get 12)) - (setq vendor-length (card16-get 16)) - (setf (display-max-request-length display) (card16-get 18)) - (setq num-roots (card8-get 20)) - (setq num-formats (card8-get 21)) - ;; Get the image-info - (setf (display-image-lsb-first-p display) (zerop (card8-get 22))) - (let ((format (display-bitmap-format display))) - (declare (type bitmap-format format)) - (setf (bitmap-format-lsb-first-p format) (zerop (card8-get 23))) - (setf (bitmap-format-unit format) (card8-get 24)) - (setf (bitmap-format-pad format) (card8-get 25))) - (setf (display-min-keycode display) (card8-get 26)) - (setf (display-max-keycode display) (card8-get 27)) - ;; 4 bytes unused - ;; Get the vendor string - (buffer-input display buffer-bbuf 0 (lround vendor-length)) - (setf (display-vendor-name display) - (string-get vendor-length 0 :reply-buffer reply-buffer)) - ;; Initialize the pixmap formats - (dotimes (i num-formats) ;; loop gathering pixmap formats - (declare (ignorable i)) - (buffer-input display buffer-bbuf 0 8) - (push (make-pixmap-format :depth (card8-get 0) - :bits-per-pixel (card8-get 1) - :scanline-pad (card8-get 2)) - ; 5 unused bytes - (display-pixmap-formats display))) - (setf (display-pixmap-formats display) - (nreverse (display-pixmap-formats display))) - ;; Initialize the screens - (dotimes (i num-roots) - (declare (ignorable i)) - (buffer-input display buffer-bbuf 0 40) - (let* ((root-id (card32-get 0)) - (root (make-window :id root-id :display display)) - (root-visual (card32-get 32)) - (default-colormap-id (card32-get 4)) - (default-colormap - (make-colormap :id default-colormap-id :display display)) - (screen - (make-screen - :root root - :default-colormap default-colormap - :white-pixel (card32-get 8) - :black-pixel (card32-get 12) - :event-mask-at-open (card32-get 16) - :width (card16-get 20) - :height (card16-get 22) - :width-in-millimeters (card16-get 24) - :height-in-millimeters (card16-get 26) - :min-installed-maps (card16-get 28) - :max-installed-maps (card16-get 30) - :backing-stores (member8-get 36 :never :when-mapped :always) - :save-unders-p (boolean-get 37) - :root-depth (card8-get 38))) - (num-depths (card8-get 39)) - (depths nil)) - ;; Save root window for event reporting - (save-id display root-id root) - (save-id display default-colormap-id default-colormap) - ;; Create the depth AList for a screen, (depth . visual-infos) - (dotimes (j num-depths) - (declare (ignorable j)) - (buffer-input display buffer-bbuf 0 8) - (let ((depth (card8-get 0)) - (num-visuals (card16-get 2)) - (visuals nil)) ;; 4 bytes unused - (dotimes (k num-visuals) - (declare (ignorable k)) - (buffer-input display buffer-bbuf 0 24) - (let* ((visual (card32-get 0)) - (visual-info (make-visual-info - :id visual - :display display - :class (member8-get 4 :static-gray :gray-scale - :static-color :pseudo-color - :true-color :direct-color) - :bits-per-rgb (card8-get 5) - :colormap-entries (card16-get 6) - :red-mask (card32-get 8) - :green-mask (card32-get 12) - :blue-mask (card32-get 16) - ;; 4 bytes unused - ))) - (push visual-info visuals) - (when (funcall (resource-id-map-test) root-visual visual) - (setf (screen-root-visual-info screen) - (setf (colormap-visual-info default-colormap) - visual-info))))) - (push (cons depth (nreverse visuals)) depths))) - (setf (screen-depths screen) (nreverse depths)) - (push screen (display-roots display)))) - (setf (display-roots display) (nreverse (display-roots display))) - (setf (display-default-screen display) (first (display-roots display)))))) - (when reply-buffer - (deallocate-reply-buffer reply-buffer)))) - display) - -(defun display-protocol-version (display) - (declare (type display display)) - (declare (clx-values major minor)) - (values (display-protocol-major-version display) - (display-protocol-minor-version display))) - -(defun display-vendor (display) - (declare (type display display)) - (declare (clx-values name release)) - (values (display-vendor-name display) - (display-release-number display))) - -(defun display-nscreens (display) - (declare (type display display)) - (length (display-roots display))) - -#+comment ;; defined by the DISPLAY defstruct -(defsetf display-error-handler (display) (handler) - ;; All errors (synchronous and asynchronous) are processed by - ;; calling an error handler in the display. If handler is a - ;; sequence it is expected to contain handler functions specific to - ;; each error; the error code is used to index the sequence, - ;; fetching the appropriate handler. Any results returned by the - ;; handler are ignored; it is assumed the handler either takes care - ;; of the error completely, or else signals. For all core errors, - ;; the keyword/value argument pairs are: - ;; :display display - ;; :error-key error-key - ;; :major integer - ;; :minor integer - ;; :sequence integer - ;; :current-sequence integer - ;; For :colormap, :cursor, :drawable, :font, :gcontext, :id-choice, :pixmap, and - ;; :window errors another pair is: - ;; :resource-id integer - ;; For :atom errors, another pair is: - ;; :atom-id integer - ;; For :value errors, another pair is: - ;; :value integer - ) - - ;; setf'able - ;; If defined, called after every protocol request is generated, - ;; even those inside explicit with-display's, but never called from - ;; inside the after-function itself. The function is called inside - ;; the effective with-display for the associated request. Default - ;; value is nil. Can be set, for example, to #'display-force-output - ;; or #'display-finish-output. - -(defvar *inside-display-after-function* nil) - -(defun display-invoke-after-function (display) - ; Called after every protocal request is generated - (declare (type display display)) - (when (and (display-after-function display) - (not *inside-display-after-function*)) - (let ((*inside-display-after-function* t)) ;; Ensure no recursive calls - (funcall (display-after-function display) display)))) - -(defun display-finish-output (display) - ;; Forces output, then causes a round-trip to ensure that all possible - ;; errors and events have been received. - (declare (type display display)) - (with-buffer-request-and-reply (display +x-getinputfocus+ 16 :sizes (8 32)) - () - ) - ;; Report asynchronous errors here if the user wants us to. - (report-asynchronous-errors display :after-finish-output)) - -(defparameter - *request-names* - '#("error" "CreateWindow" "ChangeWindowAttributes" "GetWindowAttributes" - "DestroyWindow" "DestroySubwindows" "ChangeSaveSet" "ReparentWindow" - "MapWindow" "MapSubwindows" "UnmapWindow" "UnmapSubwindows" - "ConfigureWindow" "CirculateWindow" "GetGeometry" "QueryTree" - "InternAtom" "GetAtomName" "ChangeProperty" "DeleteProperty" - "GetProperty" "ListProperties" "SetSelectionOwner" "GetSelectionOwner" - "ConvertSelection" "SendEvent" "GrabPointer" "UngrabPointer" - "GrabButton" "UngrabButton" "ChangeActivePointerGrab" "GrabKeyboard" - "UngrabKeyboard" "GrabKey" "UngrabKey" "AllowEvents" - "GrabServer" "UngrabServer" "QueryPointer" "GetMotionEvents" - "TranslateCoords" "WarpPointer" "SetInputFocus" "GetInputFocus" - "QueryKeymap" "OpenFont" "CloseFont" "QueryFont" - "QueryTextExtents" "ListFonts" "ListFontsWithInfo" "SetFontPath" - "GetFontPath" "CreatePixmap" "FreePixmap" "CreateGC" - "ChangeGC" "CopyGC" "SetDashes" "SetClipRectangles" - "FreeGC" "ClearToBackground" "CopyArea" "CopyPlane" - "PolyPoint" "PolyLine" "PolySegment" "PolyRectangle" - "PolyArc" "FillPoly" "PolyFillRectangle" "PolyFillArc" - "PutImage" "GetImage" "PolyText8" "PolyText16" - "ImageText8" "ImageText16" "CreateColormap" "FreeColormap" - "CopyColormapAndFree" "InstallColormap" "UninstallColormap" "ListInstalledColormaps" - "AllocColor" "AllocNamedColor" "AllocColorCells" "AllocColorPlanes" - "FreeColors" "StoreColors" "StoreNamedColor" "QueryColors" - "LookupColor" "CreateCursor" "CreateGlyphCursor" "FreeCursor" - "RecolorCursor" "QueryBestSize" "QueryExtension" "ListExtensions" - "SetKeyboardMapping" "GetKeyboardMapping" "ChangeKeyboardControl" "GetKeyboardControl" - "Bell" "ChangePointerControl" "GetPointerControl" "SetScreenSaver" - "GetScreenSaver" "ChangeHosts" "ListHosts" "ChangeAccessControl" - "ChangeCloseDownMode" "KillClient" "RotateProperties" "ForceScreenSaver" - "SetPointerMapping" "GetPointerMapping" "SetModifierMapping" "GetModifierMapping")) diff -Nru ecl-16.1.2/src/clx/dpms.lisp ecl-16.1.3+ds/src/clx/dpms.lisp --- ecl-16.1.2/src/clx/dpms.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/dpms.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,168 +0,0 @@ - -;;;; Original Author: Matthew Kennedy -;;;; -;;;; Documentation strings derived from DPMS.txt distributed with the Xorg X11 -;;;; server implementation. DPMS.txt contains the following copyright: -;;;; -;;;; Copyright (C) Digital Equipment Corporation, 1996 -;;;; -;;;; Permission to use, copy, modify, distribute, and sell this documentation -;;;; for any purpose is hereby granted without fee, provided that the above -;;;; copyright notice and this permission notice appear in all copies. Digital -;;;; Equipment Corporation makes no representations about the suitability for -;;;; any purpose of the information in this document. This documentation is -;;;; provided ``as is'' without express or implied warranty. - -(defpackage :dpms - (:use :common-lisp) - (:import-from :xlib - "DEFINE-EXTENSION" - "DISPLAY" - "WITH-BUFFER-REQUEST-AND-REPLY" - "WITH-BUFFER-REQUEST" - "EXTENSION-OPCODE" - "CARD8-GET" - "CARD16-GET" - "BOOLEAN-GET" - "CARD8" - "CARD16" - "DATA") - (:export "DPMS-GET-VERSION" - "DPMS-CAPABLE" - "DPMS-GET-TIMEOUTS" - "DPMS-SET-TIMEOUTS" - "DPMS-ENABLE" - "DPMS-DISABLE" - "DPMS-FORCE-LEVEL" - "DPMS-INFO")) - -(in-package :dpms) - -(define-extension "DPMS") - -(defmacro dpms-opcode (display) - `(extension-opcode ,display "DPMS")) - -(defconstant +get-version+ 0) -(defconstant +capable+ 1) -(defconstant +get-timeouts+ 2) -(defconstant +set-timeouts+ 3) -(defconstant +enable+ 4) -(defconstant +disable+ 5) -(defconstant +force-level+ 6) -(defconstant +info+ 7) - -(defun dpms-get-version (display &optional (major-version 1) (minor-version 1)) - "Return two values: the major and minor version of the DPMS -implementation the server supports. - -If supplied, the MAJOR-VERSION and MINOR-VERSION indicate what -version of the protocol the client wants the server to implement." - (declare (type display display)) - (with-buffer-request-and-reply (display (dpms-opcode display) nil) - ((data +get-version+) - (card16 major-version) - (card16 minor-version)) - (values (card16-get 8) - (card16-get 10)))) - -(defun dpms-capable (display) - "True if the currently running server's devices are capable of -DPMS operations. - -The truth value of this request is implementation defined, but is -generally based on the capabilities of the graphic card and -monitor combination. Also, the return value in the case of -heterogeneous multi-head servers is implementation defined." - (declare (type display display)) - (with-buffer-request-and-reply (display (dpms-opcode display) nil) - ((data +capable+)) - (boolean-get 8))) - -(defun dpms-get-timeouts (display) - "Return three values: the current values of the DPMS timeout -values. The timeout values are (in order returned): standby, -suspend and off. All values are in units of seconds. A value of -zero for any timeout value indicates that the mode is disabled." - (declare (type display display)) - (with-buffer-request-and-reply (display (dpms-opcode display) nil) - ((data +get-timeouts+)) - (values (card16-get 8) - (card16-get 10) - (card16-get 12)))) - -(defun dpms-set-timeouts (display standby suspend off) - "Set the values of the DPMS timeouts. All values are in units -of seconds. A value of zero for any timeout value disables that -mode." - (declare (type display display)) - (with-buffer-request (display (dpms-opcode display)) - (data +set-timeouts+) - (card16 standby) - (card16 suspend) - (card16 off) - (card16 0)) ;unused - (values)) - -(defun dpms-enable (display) - "Enable the DPMS characteristics of the server using the -server's currently stored timeouts. If DPMS is already enabled, -no change is affected." - (declare (type display display)) - (with-buffer-request (display (dpms-opcode display)) - (data +enable+)) - (values)) - -(defun dpms-disable (display) - "Disable the DPMS characteristics of the server. It does not -affect the core or extension screen savers. If DPMS is already -disabled, no change is effected. - -This request is provided so that DPMS may be disabled without -damaging the server's stored timeout values." - (declare (type display display)) - (with-buffer-request (display (dpms-opcode display)) - ((data +disable+))) - (values)) - -(defun dpms-force-level (display power-level) - "Forces a specific DPMS level on the server. Valid keyword -values for POWER-LEVEL are: DPMS-MODE-ON, DPMS-MODE-STANDBY, -DPMS-MODE-SUSPEND and DPMS-MODE-OFF." - (declare (type display display)) - (with-buffer-request (display (dpms-opcode display)) - (data +force-level+) - (card16 (ecase power-level - (:dpms-mode-on 0) - (:dpms-mode-standby 1) - (:dpms-mode-suspend 2) - (:dpms-mode-off 3))) - (card16 0)) ;unused - (values)) - -(defun dpms-info (display) - "Returns two valus: the DPMS power-level and state value for the display. - -State is one of the keywords DPMS-ENABLED or DPMS-DISABLED. - -If state is DPMS-ENABLED, then power level is returned as one of -the keywords DPMS-MODE-ON, DPMS-MODE-STANDBY, DPMS-MODE-SUSPEND -or DPMS-MODE-OFF. If state is DPMS-DISABLED, then power-level is -undefined and returned as NIL." - (declare (type display display)) - (with-buffer-request-and-reply (display (dpms-opcode display) nil) - ((data +info+)) - (let ((state (if (boolean-get 10) - :dpms-enabled - :dpms-disabled))) - (values (unless (eq state :dpms-disabled) - (ecase (card16-get 8) - (0 :dpms-mode-on) - (1 :dpms-mode-standby) - (2 :dpms-mode-suspend) - (3 :dpms-mode-off))) - state)))) - -;;; Local Variables: -;;; indent-tabs-mode: nil -;;; End: diff -Nru ecl-16.1.2/src/clx/exclcmac.lisp ecl-16.1.3+ds/src/clx/exclcmac.lisp --- ecl-16.1.2/src/clx/exclcmac.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/exclcmac.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,260 +0,0 @@ -;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*- -;;; -;;; CLX -- exclcmac.cl -;;; This file provides for inline expansion of some functions. -;;; -;;; Copyright (c) 1989 Franz Inc, Berkeley, Ca. -;;; -;;; Permission is granted to any individual or institution to use, copy, -;;; modify, and distribute this software, provided that this complete -;;; copyright and permission notice is maintained, intact, in all copies and -;;; supporting documentation. -;;; -;;; Franz Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -;; -;; Type predicates -;; -(excl:defcmacro card8p (x) - (let ((xx (gensym))) - `(let ((,xx ,x)) - (declare (optimize (speed 3) (safety 0)) - (fixnum ,xx)) - (and (excl:fixnump ,xx) (> #.(expt 2 8) ,xx) (>= ,xx 0))))) - -(excl:defcmacro card16p (x) - (let ((xx (gensym))) - `(let ((,xx ,x)) - (declare (optimize (speed 3) (safety 0)) - (fixnum ,xx)) - (and (excl:fixnump ,xx) (> #.(expt 2 16) ,xx) (>= ,xx 0))))) - -(excl:defcmacro int8p (x) - (let ((xx (gensym))) - `(let ((,xx ,x)) - (declare (optimize (speed 3) (safety 0)) - (fixnum ,xx)) - (and (excl:fixnump ,xx) (> #.(expt 2 7) ,xx) (>= ,xx #.(expt -2 7)))))) - -(excl:defcmacro int16p (x) - (let ((xx (gensym))) - `(let ((,xx ,x)) - (declare (optimize (speed 3) (safety 0)) - (fixnum ,xx)) - (and (excl:fixnump ,xx) (> #.(expt 2 15) ,xx) (>= ,xx #.(expt -2 15)))))) - -;; Card29p, card32p, int32p are too large to expand inline - - -;; -;; Type transformers -;; -(excl:defcmacro card8->int8 (x) - (let ((xx (gensym))) - `(let ((,xx ,x)) - ,(declare-bufmac) - (declare (type card8 ,xx)) - (the int8 (if (logbitp 7 ,xx) - (the int8 (- ,xx #x100)) - ,xx))))) -(excl:defcmacro int8->card8 (x) - `(locally ,(declare-bufmac) - (the card8 (ldb (byte 8 0) (the int8 ,x))))) - -(excl:defcmacro card16->int16 (x) - (let ((xx (gensym))) - `(let ((,xx ,x)) - ,(declare-bufmac) - (declare (type card16 ,xx)) - (the int16 (if (logbitp 15 ,xx) - (the int16 (- ,xx #x10000)) - ,xx))))) - -(excl:defcmacro int16->card16 (x) - `(locally ,(declare-bufmac) - (the card16 (ldb (byte 16 0) (the int16 ,x))))) - -(excl:defcmacro card32->int32 (x) - (let ((xx (gensym))) - `(let ((,xx ,x)) - ,(declare-bufmac) - (declare (type card32 ,xx)) - (the int32 (if (logbitp 31 ,xx) - (the int32 (- ,xx #x100000000)) - ,xx))))) - -(excl:defcmacro int32->card32 (x) - `(locally ,(declare-bufmac) - (the card32 (ldb (byte 32 0) (the int32 ,x))))) - -(excl:defcmacro char->card8 (char) - `(locally ,(declare-bufmac) - (the card8 (char-code (the string-char ,char))))) - -(excl:defcmacro card8->char (card8) - `(locally ,(declare-bufmac) - (the string-char (code-char (the card8 ,card8))))) - - -;; -;; Array accessors and setters -;; -(excl:defcmacro aref-card8 (a i) - `(locally ,(declare-bufmac) - (the card8 (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :unsigned-byte)))) - -(excl:defcmacro aset-card8 (v a i) - `(locally ,(declare-bufmac) - (setf (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :unsigned-byte) - (the card8 ,v)))) - -(excl:defcmacro aref-int8 (a i) - `(locally ,(declare-bufmac) - (the int8 (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :signed-byte)))) - -(excl:defcmacro aset-int8 (v a i) - `(locally ,(declare-bufmac) - (setf (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :signed-byte) - (the int8 ,v)))) - -(excl:defcmacro aref-card16 (a i) - `(locally ,(declare-bufmac) - (the card16 (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :unsigned-word)))) - -(excl:defcmacro aset-card16 (v a i) - `(locally ,(declare-bufmac) - (setf (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :unsigned-word) - (the card16 ,v)))) - -(excl:defcmacro aref-int16 (a i) - `(locally ,(declare-bufmac) - (the int16 (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :signed-word)))) - -(excl:defcmacro aset-int16 (v a i) - `(locally ,(declare-bufmac) - (setf (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :signed-word) - (the int16 ,v)))) - -(excl:defcmacro aref-card32 (a i) - `(locally ,(declare-bufmac) - (the card32 (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :unsigned-long)))) - -(excl:defcmacro aset-card32 (v a i) - `(locally ,(declare-bufmac) - (setf (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :unsigned-long) - (the card32 ,v)))) - -(excl:defcmacro aref-int32 (a i) - `(locally ,(declare-bufmac) - (the int32 (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :signed-long)))) - -(excl:defcmacro aset-int32 (v a i) - `(locally ,(declare-bufmac) - (setf (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :signed-long) - (the int32 ,v)))) - -(excl:defcmacro aref-card29 (a i) - ;; Don't need to mask bits here since X protocol guarantees top bits zero - `(locally ,(declare-bufmac) - (the card29 (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :unsigned-long)))) - -(excl:defcmacro aset-card29 (v a i) - ;; I also assume here Lisp is passing a number that fits in 29 bits. - `(locally ,(declare-bufmac) - (setf (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :unsigned-long) - (the card29 ,v)))) - -;; -;; Font accessors -;; -(excl:defcmacro font-id (font) - ;; Get font-id, opening font if needed - (let ((f (gensym))) - `(let ((,f ,font)) - (or (font-id-internal ,f) - (open-font-internal ,f))))) - -(excl:defcmacro font-font-info (font) - (let ((f (gensym))) - `(let ((,f ,font)) - (or (font-font-info-internal ,f) - (query-font ,f))))) - -(excl:defcmacro font-char-infos (font) - (let ((f (gensym))) - `(let ((,f ,font)) - (or (font-char-infos-internal ,f) - (progn (query-font ,f) - (font-char-infos-internal ,f)))))) - - -;; -;; Miscellaneous -;; -(excl:defcmacro current-process () - `(the (or mp::process null) (and mp::*scheduler-stack-group* - mp::*current-process*))) - -(excl:defcmacro process-wakeup (process) - (let ((proc (gensym))) - `(let ((.pw-curproc. mp::*current-process*) - (,proc ,process)) - (when (and .pw-curproc. ,proc) - (if (> (mp::process-priority ,proc) - (mp::process-priority .pw-curproc.)) - (mp::process-allow-schedule ,proc)))))) - -(excl:defcmacro buffer-new-request-number (buffer) - (let ((buf (gensym))) - `(let ((,buf ,buffer)) - (declare (type buffer ,buf)) - (setf (buffer-request-number ,buf) - (ldb (byte 16 0) (1+ (buffer-request-number ,buf))))))) - - diff -Nru ecl-16.1.2/src/clx/excldefsys.lisp ecl-16.1.3+ds/src/clx/excldefsys.lisp --- ecl-16.1.2/src/clx/excldefsys.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/excldefsys.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,186 +0,0 @@ -;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*- -;;; -;;; Copyright (c) 1988, 1989 Franz Inc, Berkeley, Ca. -;;; -;;; Permission is granted to any individual or institution to use, copy, -;;; modify, and distribute this software, provided that this complete -;;; copyright and permission notice is maintained, intact, in all copies and -;;; supporting documentation. -;;; -;;; Franz Incorporated provides this software "as is" without express or -;;; implied warranty. -;;; - -(in-package :xlib :use '(:foreign-functions :lisp :excl)) - -#+allegro -(require :defsystem "defsys") - -(eval-when (load) - (require :clxexcldep "excldep")) - -;; -;; The following is a suggestion. If you comment out this form be -;; prepared for possible deadlock, since no interrupts will be recognized -;; while reading from the X socket if the scheduler is not running. -;; -(setq compiler::generate-interrupt-checks-switch - (compile nil '(lambda (safety size speed) - (declare (ignore size)) - (or (< speed 3) (> safety 0))))) - - -#+allegro -(excl:defsystem :clx - () - |depdefs| - (|clx| :load-before-compile (|depdefs|) - :recompile-on (|depdefs|)) - (|dependent| :load-before-compile (|depdefs| |clx|) - :recompile-on (|clx|)) - (|exclcmac| :load-before-compile (|depdefs| |clx| |dependent|) - :recompile-on (|dependent|)) - (|macros| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|) - :recompile-on (|exclcmac|)) - (|bufmac| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros|) - :recompile-on (|macros|)) - (|buffer| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac|) - :recompile-on (|bufmac|)) - (|display| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer|) - :recompile-on (|buffer|)) - (|gcontext| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| - |display|) - :recompile-on (|display|)) - (|input| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| |display| - ) - :recompile-on (|display|)) - (|requests| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| - |display| |input|) - :recompile-on (|display|)) - (|fonts| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| |display| - ) - :recompile-on (|display|)) - (|graphics| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| - |display| |fonts|) - :recompile-on (|fonts|)) - (|text| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| - |bufmac| |buffer| |display| - |gcontext| |fonts|) - :recompile-on (|gcontext| |fonts|) - :load-after (|translate|)) - ;; The above line gets around a compiler macro expansion bug. - - (|attributes| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| - |display|) - :recompile-on (|display|)) - (|translate| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| - |display| |text|) - :recompile-on (|display|)) - (|keysyms| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| - |display| |translate|) - :recompile-on (|translate|)) - (|manager| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| - |display|) - :recompile-on (|display|)) - (|image| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| |display| - ) - :recompile-on (|display|)) - - ;; Don't know if l-b-c list is correct. XX - (|resource| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| - |display|) - :recompile-on (|display|)) - ) - -#+allegro -(excl:defsystem :clx-debug - (:default-pathname "debug/" - :needed-systems (:clx) - :load-before-compile (:clx)) - |describe| |keytrans| |trace| |util|) - - -(defun compile-clx (&optional pathname-defaults) - (let ((*default-pathname-defaults* - (or pathname-defaults *default-pathname-defaults*))) - (declare (special *default-pathname-defaults*)) - (compile-file "depdefs") - (load "depdefs") - (compile-file "clx") - (load "clx") - (compile-file "dependent") - (load "dependent") - (compile-file "macros") - (load "macros") - (compile-file "bufmac") - (load "bufmac") - (compile-file "buffer") - (load "buffer") - (compile-file "display") - (load "display") - (compile-file "gcontext") - (load "gcontext") - (compile-file "input") - (load "input") - (compile-file "requests") - (load "requests") - (compile-file "fonts") - (load "fonts") - (compile-file "graphics") - (load "graphics") - (compile-file "text") - (load "text") - (compile-file "attributes") - (load "attributes") - (load "translate") - (compile-file "translate") ; work-around bug in 2.0 and 2.2 - (load "translate") - (compile-file "keysyms") - (load "keysyms") - (compile-file "manager") - (load "manager") - (compile-file "image") - (load "image") - (compile-file "resource") - (load "resource") - )) - - -(defun load-clx (&optional pathname-defaults) - (let ((*default-pathname-defaults* - (or pathname-defaults *default-pathname-defaults*))) - (declare (special *default-pathname-defaults*)) - (load "depdefs") - (load "clx") - (load "dependent") - (load "macros") - (load "bufmac") - (load "buffer") - (load "display") - (load "gcontext") - (load "input") - (load "requests") - (load "fonts") - (load "graphics") - (load "text") - (load "attributes") - (load "translate") - (load "keysyms") - (load "manager") - (load "image") - (load "resource") - )) diff -Nru ecl-16.1.2/src/clx/excldep.c ecl-16.1.3+ds/src/clx/excldep.c --- ecl-16.1.2/src/clx/excldep.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/excldep.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,76 +0,0 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ - -/* - * Allegro CL dependent C helper routines for CLX - */ - -/* - * This code requires select and interval timers. - * This means you probably need BSD, or a version - * of Unix with select and interval timers added. - */ - -#include -#include -#include -#include - -#define ERROR -1 -#define INTERRUPT -2 -#define TIMEOUT 0 -#define SUCCESS 1 - -#ifdef FD_SETSIZE -#define NUMBER_OF_FDS FD_SETSIZE /* Highest possible file descriptor */ -#else -#define NUMBER_OF_FDS 32 -#endif - -/* Length of array needed to hold all file descriptor bits */ -#define CHECKLEN ((NUMBER_OF_FDS+8*sizeof(int)-1) / (8 * sizeof(int))) - -extern int errno; - -/* - * This function waits for input to become available on 'fd'. If timeout is - * 0, wait forever. Otherwise wait 'timeout' seconds. If input becomes - * available before the timer expires, return SUCCESS. If the timer expires - * return TIMEOUT. If an error occurs, return ERROR. If an interrupt occurs - * while waiting, return INTERRUPT. - */ -int fd_wait_for_input(fd, timeout) - register int fd; - register int timeout; -{ - struct timeval timer; - register int i; - int checkfds[CHECKLEN]; - - if (fd < 0 || fd >= NUMBER_OF_FDS) { - fprintf(stderr, "Bad file descriptor argument: %d to fd_wait_for_input\n", fd); - fflush(stderr); - } - - for (i = 0; i < CHECKLEN; i++) - checkfds[i] = 0; - checkfds[fd / (8 * sizeof(int))] |= 1 << (fd % (8 * sizeof(int))); - - if (timeout) { - timer.tv_sec = timeout; - timer.tv_usec = 0; - i = select(32, checkfds, (int *)0, (int *)0, &timer); - } else - i = select(32, checkfds, (int *)0, (int *)0, (struct timeval *)0); - - if (i < 0) - /* error condition */ - if (errno == EINTR) - return (INTERRUPT); - else - return (ERROR); - else if (i == 0) - return (TIMEOUT); - else - return (SUCCESS); -} diff -Nru ecl-16.1.2/src/clx/excldep.lisp ecl-16.1.3+ds/src/clx/excldep.lisp --- ecl-16.1.2/src/clx/excldep.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/excldep.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,435 +0,0 @@ -;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*- -;;; -;;; CLX -- excldep.cl -;;; -;;; Copyright (c) 1987, 1988, 1989 Franz Inc, Berkeley, Ca. -;;; -;;; Permission is granted to any individual or institution to use, copy, -;;; modify, and distribute this software, provided that this complete -;;; copyright and permission notice is maintained, intact, in all copies and -;;; supporting documentation. -;;; -;;; Franz Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(eval-when (compile load eval) - (require :foreign) - (require :process) ; Needed even if scheduler is not - ; running. (Must be able to make - ; a process-lock.) - ) - -(eval-when (load) - (provide :clx)) - - -#-(or little-endian big-endian) -(eval-when (eval compile load) - (let ((x '#(1))) - (if (not (eq 0 (sys::memref x - #.(sys::mdparam 'comp::md-lvector-data0-norm) - 0 :unsigned-byte))) - (pushnew :little-endian *features*) - (pushnew :big-endian *features*)))) - - -(defmacro correct-case (string) - ;; This macro converts the given string to the - ;; current preferred case, or leaves it alone in a case-sensitive mode. - (let ((str (gensym))) - `(let ((,str ,string)) - (case excl::*current-case-mode* - (:case-insensitive-lower - (string-downcase ,str)) - (:case-insensitive-upper - (string-upcase ,str)) - ((:case-sensitive-lower :case-sensitive-upper) - ,str))))) - - -(defconstant type-pred-alist - '(#-(version>= 4 1 devel 16) - (card8 . card8p) - #-(version>= 4 1 devel 16) - (card16 . card16p) - #-(version>= 4 1 devel 16) - (card29 . card29p) - #-(version>= 4 1 devel 16) - (card32 . card32p) - #-(version>= 4 1 devel 16) - (int8 . int8p) - #-(version>= 4 1 devel 16) - (int16 . int16p) - #-(version>= 4 1 devel 16) - (int32 . int32p) - #-(version>= 4 1 devel 16) - (mask16 . card16p) - #-(version>= 4 1 devel 16) - (mask32 . card32p) - #-(version>= 4 1 devel 16) - (pixel . card32p) - #-(version>= 4 1 devel 16) - (resource-id . card29p) - #-(version>= 4 1 devel 16) - (keysym . card32p) - (angle . anglep) - (color . color-p) - (bitmap-format . bitmap-format-p) - (pixmap-format . pixmap-format-p) - (display . display-p) - (drawable . drawable-p) - (window . window-p) - (pixmap . pixmap-p) - (visual-info . visual-info-p) - (colormap . colormap-p) - (cursor . cursor-p) - (gcontext . gcontext-p) - (screen . screen-p) - (font . font-p) - (image-x . image-x-p) - (image-xy . image-xy-p) - (image-z . image-z-p) - (wm-hints . wm-hints-p) - (wm-size-hints . wm-size-hints-p) - )) - -;; This (if (and ...) t nil) stuff has a purpose -- it lets the old -;; sun4 compiler opencode the `and'. - -#-(version>= 4 1 devel 16) -(defun card8p (x) - (declare (optimize (speed 3) (safety 0)) - (fixnum x)) - (if (and (excl:fixnump x) (> #.(expt 2 8) x) (>= x 0)) - t - nil)) - -#-(version>= 4 1 devel 16) -(defun card16p (x) - (declare (optimize (speed 3) (safety 0)) - (fixnum x)) - (if (and (excl:fixnump x) (> #.(expt 2 16) x) (>= x 0)) - t - nil)) - -#-(version>= 4 1 devel 16) -(defun card29p (x) - (declare (optimize (speed 3) (safety 0))) - (if (or (and (excl:fixnump x) (>= (the fixnum x) 0)) - (and (excl:bignump x) (> #.(expt 2 29) (the bignum x)) - (>= (the bignum x) 0))) - t - nil)) - -#-(version>= 4 1 devel 16) -(defun card32p (x) - (declare (optimize (speed 3) (safety 0))) - (if (or (and (excl:fixnump x) (>= (the fixnum x) 0)) - (and (excl:bignump x) (> #.(expt 2 32) (the bignum x)) - (>= (the bignum x) 0))) - t - nil)) - -#-(version>= 4 1 devel 16) -(defun int8p (x) - (declare (optimize (speed 3) (safety 0)) - (fixnum x)) - (if (and (excl:fixnump x) (> #.(expt 2 7) x) (>= x #.(expt -2 7))) - t - nil)) - -#-(version>= 4 1 devel 16) -(defun int16p (x) - (declare (optimize (speed 3) (safety 0)) - (fixnum x)) - (if (and (excl:fixnump x) (> #.(expt 2 15) x) (>= x #.(expt -2 15))) - t - nil)) - -#-(version>= 4 1 devel 16) -(defun int32p (x) - (declare (optimize (speed 3) (safety 0))) - (if (or (excl:fixnump x) - (and (excl:bignump x) (> #.(expt 2 31) (the bignum x)) - (>= (the bignum x) #.(expt -2 31)))) - t - nil)) - -;; This one can be handled better by knowing a little about what we're -;; testing for. Plus this version can handle (single-float pi), which -;; is otherwise larger than pi! -(defun anglep (x) - (declare (optimize (speed 3) (safety 0))) - (if (or (and (excl::fixnump x) (>= (the fixnum x) #.(truncate (* -2 pi))) - (<= (the fixnum x) #.(truncate (* 2 pi)))) - (and (excl::single-float-p x) - (>= (the single-float x) #.(float (* -2 pi) 0.0s0)) - (<= (the single-float x) #.(float (* 2 pi) 0.0s0))) - (and (excl::double-float-p x) - (>= (the double-float x) #.(float (* -2 pi) 0.0d0)) - (<= (the double-float x) #.(float (* 2 pi) 0.0d0)))) - t - nil)) - -(eval-when (load eval) - #+(version>= 4 1 devel 16) - (mapcar #'(lambda (elt) (excl:add-typep-transformer (car elt) (cdr elt))) - type-pred-alist) - #-(version>= 4 1 devel 16) - (nconc excl::type-pred-alist type-pred-alist)) - - -;; Return t if there is a character available for reading or on error, -;; otherwise return nil. -#-(version>= 6 0) -(progn - -#-(or (version>= 4 2) mswindows) -(defun fd-char-avail-p (fd) - (multiple-value-bind (available-p errcode) - (comp::.primcall-sargs 'sys::filesys excl::fs-char-avail fd) - (excl:if* errcode - then t - else available-p))) - -#+(and (version>= 4 2) (not mswindows)) -(defun fd-char-avail-p (fd) - (excl::filesys-character-available-p fd)) - -#+mswindows -(defun fd-char-avail-p (socket-stream) - (listen socket-stream)) -) - -#+(version>= 6 0) -(defun fd-char-avail-p (socket-stream) - (excl::read-no-hang-p socket-stream)) - -(defmacro with-interrupt-checking-on (&body body) - `(locally (declare (optimize (safety 1))) - ,@body)) - -;; Read from the given fd into 'vector', which has element type card8. -;; Start storing at index 'start-index' and read exactly 'length' bytes. -;; Return t if an error or eof occurred, nil otherwise. -(defun fd-read-bytes (fd vector start-index length) - ;; Read from the given stream fd into 'vector', which has element type card8. - ;; Start storing at index 'start-index' and read exactly 'length' bytes. - ;; Return t if an error or eof occurred, nil otherwise. - (declare (fixnum next-index start-index length)) - (with-interrupt-checking-on - (let ((end-index (+ start-index length))) - (loop - (let ((next-index (excl:read-vector vector fd - :start start-index - :end end-index))) - (excl:if* (eq next-index start-index) - then ; end of file before was all filled up - (return t) - elseif (eq next-index end-index) - then ; we're all done - (return nil) - else (setq start-index next-index))))))) - - -;; special patch for CLX (various process fixes) -;; patch1000.2 - -(eval-when (compile load eval) - (unless (find-package :patch) - (make-package :patch :use '(:lisp :excl)))) - -(in-package :patch) - -(defvar *patches* nil) - -#+allegro -(eval-when (compile eval load) - (when (and (= excl::cl-major-version-number 3) - (or (= excl::cl-minor-version-number 0) - (and (= excl::cl-minor-version-number 1) - excl::cl-generation-number - (< excl::cl-generation-number 9)))) - (push :clx-r4-process-patches *features*))) - -#+clx-r4-process-patches -(push (cons 1000.2 "special patch for CLX (various process fixes)") - *patches*) - - -(in-package :mp) - -#+clx-r4-process-patches -(export 'wait-for-input-available) - - -#+clx-r4-process-patches -(defun with-timeout-event (seconds fnc args) - (unless *scheduler-stack-group* (start-scheduler)) ;[spr670] - (let ((clock-event (make-clock-event))) - (when (<= seconds 0) (setq seconds 0)) - (multiple-value-bind (secs msecs) (truncate seconds) - ;; secs is now a nonegative integer, and msecs is either fixnum zero - ;; or else something interesting. - (unless (eq 0 msecs) - (setq msecs (truncate (* 1000.0 msecs)))) - ;; Now msecs is also a nonnegative fixnum. - (multiple-value-bind (now mnow) (excl::cl-internal-real-time) - (incf secs now) - (incf msecs mnow) - (when (>= msecs 1000) - (decf msecs 1000) - (incf secs)) - (unless (excl:fixnump secs) (setq secs most-positive-fixnum)) - (setf (clock-event-secs clock-event) secs - (clock-event-msecs clock-event) msecs - (clock-event-function clock-event) fnc - (clock-event-args clock-event) args))) - clock-event)) - - -#+clx-r4-process-patches -(defmacro with-timeout ((seconds &body timeout-body) &body body) - `(let* ((clock-event (with-timeout-event ,seconds - #'process-interrupt - (cons *current-process* - '(with-timeout-internal)))) - (excl::*without-interrupts* t) - ret) - (unwind-protect - ;; Warning: Branch tensioner better not reorder this code! - (setq ret (catch 'with-timeout-internal - (add-to-clock-queue clock-event) - (let ((excl::*without-interrupts* nil)) - (multiple-value-list (progn ,@body))))) - (excl:if* (eq ret 'with-timeout-internal) - then (let ((excl::*without-interrupts* nil)) - (setq ret (multiple-value-list (progn ,@timeout-body)))) - else (remove-from-clock-queue clock-event))) - (values-list ret))) - - -#+clx-r4-process-patches -(defun process-lock (lock &optional (lock-value *current-process*) - (whostate "Lock") timeout) - (declare (optimize (speed 3))) - (unless (process-lock-p lock) - (error "First argument to PROCESS-LOCK must be a process-lock: ~s" lock)) - (without-interrupts - (excl:if* (null (process-lock-locker lock)) - then (setf (process-lock-locker lock) lock-value) - else (excl:if* timeout - then (excl:if* (or (eq 0 timeout) ;for speed - (zerop timeout)) - then nil - else (with-timeout (timeout) - (process-lock-1 lock lock-value whostate))) - else (process-lock-1 lock lock-value whostate))))) - - -#+clx-r4-process-patches -(defun process-lock-1 (lock lock-value whostate) - (declare (type process-lock lock) - (optimize (speed 3))) - (let ((process *current-process*)) - (declare (type process process)) - (unless process - (error - "PROCESS-LOCK may not be called on the scheduler's stack group.")) - (loop (unless (process-lock-locker lock) - (return (setf (process-lock-locker lock) lock-value))) - (push process (process-lock-waiting lock)) - (let ((saved-whostate (process-whostate process))) - (unwind-protect - (progn (setf (process-whostate process) whostate) - (process-add-arrest-reason process lock)) - (setf (process-whostate process) saved-whostate)))))) - - -#+clx-r4-process-patches -(defun process-wait (whostate function &rest args) - (declare (optimize (speed 3))) - ;; Run the wait function once here both for efficiency and as a - ;; first line check for errors in the function. - (unless (apply function args) - (process-wait-1 whostate function args))) - - -#+clx-r4-process-patches -(defun process-wait-1 (whostate function args) - (declare (optimize (speed 3))) - (let ((process *current-process*)) - (declare (type process process)) - (unless process - (error - "Process-wait may not be called within the scheduler's stack group.")) - (let ((saved-whostate (process-whostate process))) - (unwind-protect - (without-scheduling-internal - (without-interrupts - (setf (process-whostate process) whostate - (process-wait-function process) function - (process-wait-args process) args) - (chain-rem-q process) - (chain-ins-q process *waiting-processes*)) - (process-resume-scheduler nil)) - (setf (process-whostate process) saved-whostate - (process-wait-function process) nil - (process-wait-args process) nil))))) - - -#+clx-r4-process-patches -(defun process-wait-with-timeout (whostate seconds function &rest args) - ;; Now returns T upon completion, NIL upon timeout. -- 6Jun89 smh - ;; [spr1135] [rfe939] Timeout won't throw out of interrupt level code. - ;; -- 28Feb90 smh - ;; Run the wait function once here both for efficiency and as a - ;; first line check for errors in the function. - (excl:if* (apply function args) - then t - else (let ((ret (list nil))) - (without-interrupts - (let ((clock-event - (with-timeout-event seconds #'identity '(nil)))) - (add-to-clock-queue clock-event) - (process-wait-1 whostate - #'(lambda (clock-event function args ret) - (or (null (chain-next clock-event)) - (and (apply function args) - (setf (car ret) 't)))) - (list clock-event function args ret)))) - (car ret)))) - - -;; -;; Returns nil on timeout, otherwise t. -;; -#+clx-r4-process-patches -(defun wait-for-input-available - (stream-or-fd &key (wait-function #'listen) - (whostate "waiting for input") - timeout) - (let ((fd (excl:if* (excl:fixnump stream-or-fd) then stream-or-fd - elseif (streamp stream-or-fd) - then (excl::stream-input-fn stream-or-fd) - else (error "wait-for-input-available expects a stream or file descriptor: ~s" stream-or-fd)))) - ;; At this point fd could be nil, since stream-input-fn returns nil for - ;; streams that are output only, or for certain special purpose streams. - (if fd - (unwind-protect - (progn - (mp::mpwatchfor fd) - (excl:if* timeout - then (mp::process-wait-with-timeout - whostate timeout wait-function stream-or-fd) - else (mp::process-wait whostate wait-function stream-or-fd) - t)) - (mp::mpunwatchfor fd)) - (excl:if* timeout - then (mp::process-wait-with-timeout - whostate timeout wait-function stream-or-fd) - else (mp::process-wait whostate wait-function stream-or-fd) - t)))) diff -Nru ecl-16.1.2/src/clx/exclMakefile ecl-16.1.3+ds/src/clx/exclMakefile --- ecl-16.1.2/src/clx/exclMakefile 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/exclMakefile 1970-01-01 00:00:00.000000000 +0000 @@ -1,168 +0,0 @@ -# -# Makefile for CLX -# (X11 R4.4 release, Franz Allegro Common Lisp version) -# - -# ************************************************************************* -# * Change the next line to point to where you have Common Lisp installed * -# * (make sure the Lisp doesn't already have CLX loaded in) * -# ************************************************************************* -CL = /usr/local/bin/cl - -RM = /bin/rm -SHELL = /bin/sh -ECHO = /bin/echo -TAGS = /usr/local/lib/emacs/etc/etags - -# Name of dumped lisp -CLX = CLX - -CLOPTS = -qq - -# Use this one for Suns -CFLAGS = -O -DUNIXCONN -# Use this one for Silicon Graphics & Mips Inc MIPS based machines -# CFLAGS = -O -G 0 -I/usr/include/bsd -# Use this one for DEC MIPS based machines -# CFLAGS = -O -G 0 -DUNIXCONN -# Use this one for HP machines -# CFLAGS = -O -DSYSV -DUNIXCONN - - -# Lisp optimization for compiling -SPEED = 3 -SAFETY = 0 - - -C_SRC = excldep.c socket.c -C_OBJS = excldep.o socket.o - -L_OBJS = defsystem.fasl package.fasl excldep.fasl depdefs.fasl clx.fasl \ - dependent.fasl exclcmac.fasl macros.fasl bufmac.fasl buffer.fasl \ - display.fasl gcontext.fasl requests.fasl input.fasl fonts.fasl \ - graphics.fasl text.fasl attributes.fasl translate.fasl keysyms.fasl \ - manager.fasl image.fasl resource.fasl - -L_NOMACROS_OBJS = package.fasl excldep.fasl depdefs.fasl clx.fasl \ - dependent.fasl buffer.fasl display.fasl gcontext.fasl \ - requests.fasl input.fasl fonts.fasl graphics.fasl text.fasl \ - attributes.fasl translate.fasl keysyms.fasl manager.fasl image.fasl \ - resource.fasl - -L_SRC = defsystem.cl package.cl excldep.cl depdefs.cl clx.cl \ - dependent.cl exclcmac.cl macros.cl bufmac.cl buffer.cl \ - display.cl gcontext.cl requests.cl input.cl fonts.cl \ - graphics.cl text.cl attributes.cl translate.cl keysyms.cl \ - manager.cl image.cl resource.cl - -# default and aliases -all: no-clos -# all: partial-clos -compile-CLX-for-CLUE: compile-partial-clos-CLX -clue: partial-clos - -# -# Three build rules are provided: no-clos, partial-clos, and full-clos. -# The first is no-clos, which results in a CLX whose datastructures are -# all defstructs. partial-clos results in xlib:window, xlib:pixmap, and -# xlib:drawable being CLOS instances, all others defstructs. full-clos -# makes all CLX complex datatypes into CLOS instances. -# -# (note that the :clos feature implies native CLOS *not* PCL). -# - -no-clos: $(C_OBJS) compile-no-clos-CLX cat - -# -# This rule is used to compile CLX to be used with XCW version 2, or CLUE. -# -partial-clos: $(C_OBJS) compile-partial-clos-CLX cat - -full-clos: $(C_OBJS) compile-full-clos-CLX cat - - -c: $(C_OBJS) - - -compile-no-clos-CLX: $(C_OBJS) - $(ECHO) " \ - (set-case-mode :case-sensitive-lower) \ - (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ - #+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \ - (load \"defsystem\") \ - #+allegro (compile-system :clx) \ - #-allegro (compile-clx) \ - #+allegro (compile-system :clx-debug)" \ - | $(CL) $(CLOPTS) -batch - -compile-partial-clos-CLX: $(C_OBJS) - $(ECHO) " \ - #+clos (set-case-mode :case-sensitive-lower) \ - #-clos (setq excl::*print-nickname* t) \ - (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ - (unless (or (find-package 'clos) (find-package 'pcl)) \ - (let ((spread (sys:gsgc-parameter :generation-spread))) \ - (setf (sys:gsgc-parameter :generation-spread) 1) \ - (require :pcl) \ - (provide :pcl) \ - (gc) (gc) \ - (setf (sys:gsgc-parameter :generation-spread) spread))) \ - #+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \ - (load \"defsystem\") \ - (load \"package\") \ - (setq xlib::*def-clx-class-use-defclass* '(xlib:window xlib:pixmap xlib:drawable)) \ - #+allegro (compile-system :clx) \ - #-allegro (compile-clx \"\" \"\" :for-clue t) \ - #+allegro (compile-system :clx-debug)" \ - | $(CL) $(CLOPTS) -batch - -compile-full-clos-CLX: $(C_OBJS) - $(ECHO) " \ - #+clos (set-case-mode :case-sensitive-lower) \ - #-clos (setq excl::*print-nickname* t) \ - (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ - (unless (or (find-package 'clos) (find-package 'pcl)) \ - (let ((spread (sys:gsgc-parameter :generation-spread))) \ - (setf (sys:gsgc-parameter :generation-spread) 1) \ - (require :pcl) \ - (provide :pcl) \ - (gc) (gc) \ - (setf (sys:gsgc-parameter :generation-spread) spread))) \ - #+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \ - (load \"defsystem\") \ - (load \"package\") \ - (setq xlib::*def-clx-class-use-defclass* t) \ - #+allegro (compile-system :clx) \ - #-allegro (compile-clx \"\" \"\" :for-clue t) \ - #+allegro (compile-system :clx-debug)" \ - | $(CL) $(CLOPTS) -batch - - -cat: - -cat $(L_NOMACROS_OBJS) > CLX.fasl - - -load-CLX: - $(ECHO) " \ - (let ((spread (sys:gsgc-parameter :generation-spread))) \ - (setf (sys:gsgc-parameter :generation-spread) 1) \ - (load \"defsystem\") \ - #+allegro (load-system :clx) \ - #-allegro (load-clx) \ - (gc :tenure) \ - (setf (sys:gsgc-parameter :generation-spread) spread)) \ - (gc t)" \ - '(dumplisp :name "$(CLX)" #+allegro :checkpoint #+allegro nil)' \ - "(exit)" | $(CL) $(CLOPTS) - -clean: - $(RM) -f *.fasl debug/*.fasl $(CLX) core $(C_OBJS) make.out - - -install: - mv CLX.fasl $(DEST)/clx.fasl - mv *.o $(DEST) - - -tags: - $(TAGS) $(L_SRC) $(C_SRC) diff -Nru ecl-16.1.2/src/clx/exclREADME ecl-16.1.3+ds/src/clx/exclREADME --- ecl-16.1.2/src/clx/exclREADME 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/exclREADME 1970-01-01 00:00:00.000000000 +0000 @@ -1,56 +0,0 @@ - This file contains instructions on how to make CLX work with Franz -Common Lisp. CLX should work on any machine that supports Allegro Common -Lisp version 3.0.1 or greater. It also works under ExCL version 2.0.10. -However it has been tested extensively with only Allegro CL versions 3.0, -3.1, and 4.0. - - There are three steps to compile and install CLX. The first is simply -moving files around. In this directory, execute (assuming you using csh): - -% foreach i (*.l */*.l) -? mv $i $i:r.cl -? end -% mv exclMakefile Makefile - - The second is compiling the source files into fasl files. The fasl files -will be combined into one big fasl file, CLX.fasl. This file is then installed -in your Common Lisp library directory in the next step. You may need to edit -the Makefile to select the proper CFLAGS for your machine -- look in Makefile -for examples. Then just: - -% make - - Now you must move the CLX.fasl file into the standard CL library. -This is normally "/usr/local/lib/cl/code", but you can find out for sure -by typing: - - (directory-namestring excl::*library-code-pathname*) - -to a running Lisp. If it prints something other than "/usr/local/lib/cl/code" -substitute what it prints in the below instructions. - -% mv CLX.fasl /usr/local/lib/cl/code/clx.fasl -% mv *.o /usr/local/lib/cl/code - -Now you can just start up Lisp and type: - - (load "clx") - -to load in CLX. You may want to dump a lisp at this point since CLX is a large -package and can take some time to load into Lisp. You probably also want to -set the :generation-spread to 1 while loading CLX. Please see your Allegro CL -User Guide for more information on :generation-spread. - - - Sophisticated users may wish to peruse the Makefile and defsystem.cl -and note how things are set up. For example we hardwire the compiler -interrupt check switch on, so that CL can still be interrupted while it -is reading from the X11 socket. Please see chapter 7 of the CL User's -guide for more information on compiler switches and their effects. - - -Please report Franz specific CLX bugs to: - - ucbvax!franz!bugs - or - bugs@Franz.COM diff -Nru ecl-16.1.2/src/clx/fonts.lisp ecl-16.1.3+ds/src/clx/fonts.lisp --- ecl-16.1.2/src/clx/fonts.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/fonts.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,367 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -;; The char-info stuff is here instead of CLX because of uses of int16->card16. - -; To allow efficient storage representations, the type char-info is not -; required to be a structure. - -;; For each of left-bearing, right-bearing, width, ascent, descent, attributes: - -;(defun char- (font index) -; ;; Note: I have tentatively chosen to return nil for an out-of-bounds index -; ;; (or an in-bounds index on a pseudo font), although returning zero or -; ;; signalling might be better. -; (declare (type font font) -; (type integer index) -; (clx-values (or null integer)))) - -;(defun max-char- (font) -; ;; Note: I have tentatively chosen separate accessors over allowing :min and -; ;; :max as an index above. -; (declare (type font font) -; (clx-values integer))) - -;(defun min-char- (font) -; (declare (type font font) -; (clx-values integer))) - -;; Note: char16- accessors could be defined to accept two-byte indexes. - -(deftype char-info-vec () '(simple-array int16 (*))) - -(macrolet ((def-char-info-accessors (useless-name &body fields) - `(within-definition (,useless-name def-char-info-accessors) - ,@(do ((field fields (cdr field)) - (n 0 (1+ n)) - (name) (type) - (result nil)) - ((endp field) result) - (setq name (xintern 'char- (caar field))) - (setq type (cadar field)) - (flet ((from (form) - (if (eq type 'int16) - form - `(,(xintern 'int16-> type) ,form)))) - (push - `(defun ,name (font index) - (declare (type font font) - (type array-index index)) - (declare (clx-values (or null ,type))) - (when (and (font-name font) - (index>= (font-max-char font) index (font-min-char font))) - (the ,type - ,(from - `(the int16 - (let ((char-info-vector (font-char-infos font))) - (declare (type char-info-vec char-info-vector)) - (if (index-zerop (length char-info-vector)) - ;; Fixed width font - (aref (the char-info-vec - (font-max-bounds font)) - ,n) - ;; Variable width font - (aref char-info-vector - (index+ - (index* - 6 - (index- - index - (font-min-char font))) - ,n))))))))) - result) - (setq name (xintern 'min-char- (caar field))) - (push - `(defun ,name (font) - (declare (type font font)) - (declare (clx-values (or null ,type))) - (when (font-name font) - (the ,type - ,(from - `(the int16 - (aref (the char-info-vec (font-min-bounds font)) - ,n)))))) - result) - (setq name (xintern 'max-char- (caar field))) - (push - `(defun ,name (font) - (declare (type font font)) - (declare (clx-values (or null ,type))) - (when (font-name font) - (the ,type - ,(from - `(the int16 - (aref (the char-info-vec (font-max-bounds font)) - ,n)))))) - result))) - - (defun make-char-info - (&key ,@(mapcar - #'(lambda (field) - `(,(car field) (required-arg ,(car field)))) - fields)) - (declare ,@(mapcar #'(lambda (field) `(type ,@(reverse field))) fields)) - (let ((result (make-array ,(length fields) :element-type 'int16))) - (declare (type char-info-vec result)) - ,@(do* ((field fields (cdr field)) - (var (caar field) (caar field)) - (type (cadar field) (cadar field)) - (n 0 (1+ n)) - (result nil)) - ((endp field) (nreverse result)) - (push `(setf (aref result ,n) - ,(if (eq type 'int16) - var - `(,(xintern type '->int16) ,var))) - result)) - result))))) - (def-char-info-accessors ignore - (left-bearing int16) - (right-bearing int16) - (width int16) - (ascent int16) - (descent int16) - (attributes card16))) - -(defun open-font (display name) - ;; Font objects may be cached and reference counted locally within the display - ;; object. This function might not execute a with-display if the font is cached. - ;; The protocol QueryFont request happens on-demand under the covers. - (declare (type display display) - (type stringable name)) - (declare (clx-values font)) - (let* ((name-string (string-downcase (string name))) - (font (car (member name-string (display-font-cache display) - :key 'font-name - :test 'equal))) - font-id) - (unless font - (setq font (make-font :display display :name name-string)) - (setq font-id (allocate-resource-id display font 'font)) - (setf (font-id-internal font) font-id) - (with-buffer-request (display +x-openfont+) - (resource-id font-id) - (card16 (length name-string)) - (pad16 nil) - (string name-string)) - (push font (display-font-cache display))) - (incf (font-reference-count font)) - (unless (font-font-info-internal font) - (query-font font)) - font)) - -(defun open-font-internal (font) - ;; Called "under the covers" to open a font object - (declare (type font font)) - (declare (clx-values resource-id)) - (let* ((name-string (font-name font)) - (display (font-display font)) - (id (allocate-resource-id display font 'font))) - (setf (font-id-internal font) id) - (with-buffer-request (display +x-openfont+) - (resource-id id) - (card16 (length name-string)) - (pad16 nil) - (string name-string)) - (push font (display-font-cache display)) - (incf (font-reference-count font)) - id)) - -(defun discard-font-info (font) - ;; Discards any state that can be re-obtained with QueryFont. This is - ;; simply a performance hint for memory-limited systems. - (declare (type font font)) - (setf (font-font-info-internal font) nil - (font-char-infos-internal font) nil)) - -(defun query-font (font) - ;; Internal function called by font and char info accessors - (declare (type font font)) - (declare (clx-values font-info)) - (let ((display (font-display font)) - font-id - font-info - props) - (setq font-id (font-id font)) ;; May issue an open-font request - (with-buffer-request-and-reply (display +x-queryfont+ 60) - ((resource-id font-id)) - (let* ((min-byte2 (card16-get 40)) - (max-byte2 (card16-get 42)) - (min-byte1 (card8-get 49)) - (max-byte1 (card8-get 50)) - (min-char min-byte2) - (max-char (index+ (index-ash max-byte1 8) max-byte2)) - (nfont-props (card16-get 46)) - (nchar-infos (index* (card32-get 56) 6)) - (char-info (make-array nchar-infos :element-type 'int16))) - (setq font-info - (make-font-info - :direction (member8-get 48 :left-to-right :right-to-left) - :min-char min-char - :max-char max-char - :min-byte1 min-byte1 - :max-byte1 max-byte1 - :min-byte2 min-byte2 - :max-byte2 max-byte2 - :all-chars-exist-p (boolean-get 51) - :default-char (card16-get 44) - :ascent (int16-get 52) - :descent (int16-get 54) - :min-bounds (char-info-get 8) - :max-bounds (char-info-get 24))) - (setq props (sequence-get :length (index* 2 nfont-props) :format int32 - :result-type 'list :index 60)) - (sequence-get :length nchar-infos :format int16 :data char-info - :index (index+ 60 (index* 2 nfont-props 4))) - (setf (font-char-infos-internal font) char-info) - (setf (font-font-info-internal font) font-info))) - ;; Replace atom id's with keywords in the plist - (do ((p props (cddr p))) - ((endp p)) - (setf (car p) (atom-name display (car p)))) - (setf (font-info-properties font-info) props) - font-info)) - -(defun close-font (font) - ;; This might not generate a protocol request if the font is reference - ;; counted locally. - (declare (type font font)) - (when (and (not (plusp (decf (font-reference-count font)))) - (font-id-internal font)) - (let ((display (font-display font)) - (id (font-id-internal font))) - (declare (type display display)) - ;; Remove font from cache - (setf (display-font-cache display) (delete font (display-font-cache display))) - ;; Close the font - (with-buffer-request (display +x-closefont+) - (resource-id id))))) - -(defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list)) - (declare (type display display) - (type string pattern) - (type card16 max-fonts) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence string))) - (let ((string (string pattern))) - (with-buffer-request-and-reply (display +x-listfonts+ size :sizes (8 16)) - ((card16 max-fonts (length string)) - (string string)) - (values - (read-sequence-string - buffer-bbuf (index- size +replysize+) (card16-get 8) result-type +replysize+))))) - -(defun list-fonts (display pattern &key (max-fonts 65535) (result-type 'list)) - ;; Note: Was called list-fonts-with-info. - ;; Returns "pseudo" fonts that contain basic font metrics and properties, but - ;; no per-character metrics and no resource-ids. These pseudo fonts will be - ;; converted (internally) to real fonts dynamically as needed, by issuing an - ;; OpenFont request. However, the OpenFont might fail, in which case the - ;; invalid-font error can arise. - (declare (type display display) - (type string pattern) - (type card16 max-fonts) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence font))) - (let ((string (string pattern)) - (result nil)) - (with-buffer-request-and-reply (display +x-listfontswithinfo+ 60 - :sizes (8 16) :multiple-reply t) - ((card16 max-fonts (length string)) - (string string)) - (cond ((zerop (card8-get 1)) t) - (t - (let* ((name-len (card8-get 1)) - (min-byte2 (card16-get 40)) - (max-byte2 (card16-get 42)) - (min-byte1 (card8-get 49)) - (max-byte1 (card8-get 50)) - (min-char min-byte2) - (max-char (index+ (index-ash max-byte1 8) max-byte2)) - (nfont-props (card16-get 46)) - (font - (make-font - :display display - :name nil - :font-info-internal - (make-font-info - :direction (member8-get 48 :left-to-right :right-to-left) - :min-char min-char - :max-char max-char - :min-byte1 min-byte1 - :max-byte1 max-byte1 - :min-byte2 min-byte2 - :max-byte2 max-byte2 - :all-chars-exist-p (boolean-get 51) - :default-char (card16-get 44) - :ascent (int16-get 52) - :descent (int16-get 54) - :min-bounds (char-info-get 8) - :max-bounds (char-info-get 24) - :properties (sequence-get :length (index* 2 nfont-props) - :format int32 - :result-type 'list - :index 60))))) - (setf (font-name font) (string-get name-len (index+ 60 (index* 2 nfont-props 4)))) - (push font result)) - nil))) - ;; Replace atom id's with keywords in the plist - (dolist (font result) - (do ((p (font-properties font) (cddr p))) - ((endp p)) - (setf (car p) (atom-name display (car p))))) - (coerce (nreverse result) result-type))) - -(defun font-path (display &key (result-type 'list)) - (declare (type display display) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence (or string pathname)))) - (with-buffer-request-and-reply (display +x-getfontpath+ size :sizes (8 16)) - () - (values - (read-sequence-string - buffer-bbuf (index- size +replysize+) (card16-get 8) result-type +replysize+)))) - -(defun set-font-path (display paths) - (declare (type display display) - (type (clx-sequence (or string pathname)) paths)) - (let ((path-length (length paths)) - (request-length 8)) - ;; Find the request length - (dotimes (i path-length) - (let* ((string (string (elt paths i))) - (len (length string))) - (incf request-length (1+ len)))) - (with-buffer-request (display +x-setfontpath+ :length request-length) - (length (ceiling request-length 4)) - (card16 path-length) - (pad16 nil) - (progn - (incf buffer-boffset 8) - (dotimes (i path-length) - (let* ((string (string (elt paths i))) - (len (length string))) - (card8-put 0 len) - (string-put 1 string :appending t :header-length 1) - (incf buffer-boffset (1+ len)))) - (setf (buffer-boffset display) (lround buffer-boffset))))) - paths) - -(defsetf font-path set-font-path) diff -Nru ecl-16.1.2/src/clx/gcontext.lisp ecl-16.1.3+ds/src/clx/gcontext.lisp --- ecl-16.1.2/src/clx/gcontext.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/gcontext.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,972 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; GContext - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -;;; GContext values are usually cached locally in the GContext object. -;;; This is required because the X.11 server doesn't have any requests -;;; for getting GContext values back. -;;; -;;; GContext changes are cached until force-GContext-changes is called. -;;; All the requests that use GContext (including the GContext accessors, -;;; but not the SETF's) call force-GContext-changes. -;;; In addition, the macro WITH-GCONTEXT may be used to provide a -;;; local view if a GContext. -;;; -;;; Each GContext keeps a copy of the values the server has seen, and -;;; a copy altered by SETF, called the LOCAL-STATE (bad name...). -;;; The SETF accessors increment a timestamp in the GContext. -;;; When the timestamp in a GContext isn't equal to the timestamp in -;;; the local-state, changes have been made, and force-GContext-changes -;;; loops through the GContext and local-state, sending differences to -;;; the server, and updating GContext. -;;; -;;; WITH-GCONTEXT works by BINDING the local-state slot in a GContext to -;;; a private copy. This is easy (and fast) for lisp machines, but other -;;; lisps will have problems. Fortunately, most other lisps don't care, -;;; because they don't run in a multi-processing shared-address space -;;; environment. - -(in-package :xlib) - -;; GContext state accessors -;; The state vector contains all card32s to speed server updating - -(eval-when (:compile-toplevel :load-toplevel :execute) -(defconstant +gcontext-fast-change-length+ #.(length +gcontext-components+)) - -(macrolet ((def-gc-internals (name &rest extras) - (let ((macros nil) - (indexes nil) - (masks nil) - (index 0)) - (dolist (name +gcontext-components+) - (push `(defmacro ,(xintern 'gcontext-internal- name) (state) - `(svref ,state ,,index)) - macros) - (setf (getf indexes name) index) - (push (ash 1 index) masks) - (incf index)) - (dolist (extra extras) - (push `(defmacro ,(xintern 'gcontext-internal- (first extra)) (state) - `(svref ,state ,,index)) - macros) - ;; don't override already correct index entries - (unless (or (getf indexes (second extra)) (getf indexes (first extra))) - (setf (getf indexes (or (second extra) (first extra))) index)) - (push (logior (ash 1 index) - (if (second extra) - (ash 1 (position (second extra) +gcontext-components+)) - 0)) - masks) - (incf index)) - `(within-definition (def-gc-internals ,name) - ,@(nreverse macros) - (eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *gcontext-data-length* ,index) - (defvar *gcontext-indexes* ',indexes) - (defvar *gcontext-masks* - ',(coerce (nreverse masks) 'simple-vector) - )))))) - (def-gc-internals ignore - (:clip :clip-mask) (:dash :dashes) (:font-obj :font) (:timestamp))) - -) ;; end EVAL-WHEN - -(deftype gcmask () '(unsigned-byte #.+gcontext-fast-change-length+)) - -(deftype xgcmask () '(unsigned-byte #.*gcontext-data-length*)) - -(defstruct (gcontext-extension (:type vector) (:copier nil)) ;; un-named - (name nil :type symbol :read-only t) - (default nil :type t :read-only t) - ;; FIXME: these used to have glorious, but wrong, type declarations. - ;; See if we can't return them to their former glory. - (set-function #'(lambda (gcontext value) - (declare (ignore gcontext)) - value) - :type (or function symbol) :read-only t) - (copy-function #'(lambda (from-gc to-gc value) - (declare (ignore from-gc to-gc)) - value) - :type (or function symbol) :read-only t)) - -(defvar *gcontext-extensions* nil) ;; list of gcontext-extension - -;; Gcontext state Resource -(defvar *gcontext-local-state-cache* nil) ;; List of unused gcontext local states - -(defmacro gcontext-state-next (state) - `(svref ,state 0)) - -(defun allocate-gcontext-state () - ;; Allocate a gcontext-state - ;; Loop until a local state is found that's large enough to hold - ;; any extensions that may exist. - (let ((length (index+ *gcontext-data-length* (length *gcontext-extensions*)))) - (declare (type array-index length)) - (loop - (let ((state (or (threaded-atomic-pop *gcontext-local-state-cache* - gcontext-state-next gcontext-state) - (make-array length :initial-element nil)))) - (declare (type gcontext-state state)) - (when (index>= (length state) length) - (return state)))))) - -(defun deallocate-gcontext-state (state) - (declare (type gcontext-state state)) - (fill state nil) - (threaded-atomic-push state *gcontext-local-state-cache* - gcontext-state-next gcontext-state)) - -;; Temp-Gcontext Resource -(defvar *temp-gcontext-cache* nil) ;; List of unused gcontexts - -(defun allocate-temp-gcontext () - (or (threaded-atomic-pop *temp-gcontext-cache* gcontext-next gcontext) - (make-gcontext :local-state '#() :server-state '#()))) - -(defun deallocate-temp-gcontext (gc) - (declare (type gcontext gc)) - (threaded-atomic-push gc *temp-gcontext-cache* gcontext-next gcontext)) - -;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared -;; as (type ), there is an accessor: - -;(defun gcontext- (gcontext) -; ;; The value will be nil if the last value stored is unknown (e.g., the cache was -; ;; off, or the component was copied from a gcontext with unknown state). -; (declare (type gcontext gcontext) -; (clx-values ))) - -;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared -;; as (type (or null ) ), there is a setf for the corresponding accessor: - -;(defsetf gcontext- (gcontext) (value) -; ) - -;; Generate all the accessors and defsetf's for GContext - -(defmacro xgcmask->gcmask (mask) - `(the gcmask (logand ,mask #.(1- (ash 1 +gcontext-fast-change-length+))))) - -(defmacro access-gcontext ((gcontext local-state) &body body) - `(let ((,local-state (gcontext-local-state ,gcontext))) - (declare (type gcontext-state ,local-state)) - ,@body)) - -(defmacro modify-gcontext ((gcontext local-state) &body body) - ;; The timestamp must be altered after the modification - `(let ((,local-state (gcontext-local-state ,gcontext))) - (declare (type gcontext-state ,local-state)) - (prog1 - (progn ,@body) - (setf (gcontext-internal-timestamp ,local-state) 0)))) - -(defmacro def-gc-accessor (name type) - (let* ((gcontext-name (xintern 'gcontext- name)) - (internal-accessor (xintern 'gcontext-internal- name)) - (internal-setfer (xintern 'set- gcontext-name))) - `(within-definition (,name def-gc-accessor) - - (defun ,gcontext-name (gcontext) - (declare (type gcontext gcontext)) - (declare (clx-values (or null ,type))) - (let ((value (,internal-accessor (gcontext-local-state gcontext)))) - (declare (type (or null card32) value)) - (when value ;; Don't do anything when value isn't known - (let ((%buffer (gcontext-display gcontext))) - (declare (type display %buffer)) - %buffer - (decode-type ,type value))))) - - (defun ,internal-setfer (gcontext value) - (declare (type gcontext gcontext) - (type ,type value)) - (modify-gcontext (gcontext local-state) - (setf (,internal-accessor local-state) (encode-type ,type value)) - ,@(when (eq type 'pixmap) - ;; write-through pixmaps, because the protocol allows - ;; the server to copy the pixmap contents at the time - ;; of the store, rather than continuing to share with - ;; the pixmap. - `((let ((server-state (gcontext-server-state gcontext))) - (setf (,internal-accessor server-state) nil)))) - value)) - - (defsetf ,gcontext-name ,internal-setfer)))) - -(defmacro incf-internal-timestamp (state) - (let ((ts (gensym))) - `(let ((,ts (the fixnum (gcontext-internal-timestamp ,state)))) - (declare (type fixnum ,ts)) - ;; the probability seems low enough - (setq ,ts (if (= ,ts most-positive-fixnum) - 1 - (the fixnum (1+ ,ts)))) - (setf (gcontext-internal-timestamp ,state) ,ts)))) - -(def-gc-accessor function boole-constant) -(def-gc-accessor plane-mask card32) -(def-gc-accessor foreground card32) -(def-gc-accessor background card32) -(def-gc-accessor line-width card16) -(def-gc-accessor line-style (member :solid :dash :double-dash)) -(def-gc-accessor cap-style (member :not-last :butt :round :projecting)) -(def-gc-accessor join-style (member :miter :round :bevel)) -(def-gc-accessor fill-style (member :solid :tiled :stippled :opaque-stippled)) -(def-gc-accessor fill-rule (member :even-odd :winding)) -(def-gc-accessor tile pixmap) -(def-gc-accessor stipple pixmap) -(def-gc-accessor ts-x int16) ;; Tile-Stipple-X-origin -(def-gc-accessor ts-y int16) ;; Tile-Stipple-Y-origin -;; (def-GC-accessor font font) ;; See below -(def-gc-accessor subwindow-mode (member :clip-by-children :include-inferiors)) -(def-gc-accessor exposures (member :off :on)) -(def-gc-accessor clip-x int16) -(def-gc-accessor clip-y int16) -;; (def-GC-accessor clip-mask) ;; see below -(def-gc-accessor dash-offset card16) -;; (def-GC-accessor dashes) ;; see below -(def-gc-accessor arc-mode (member :chord :pie-slice)) - - -(defun gcontext-clip-mask (gcontext) - (declare (type gcontext gcontext)) - (declare (clx-values (or null (member :none) pixmap rect-seq) - (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)))) - (access-gcontext (gcontext local-state) - (multiple-value-bind (clip clip-mask) - (without-interrupts - (values (gcontext-internal-clip local-state) - (gcontext-internal-clip-mask local-state))) - (if (null clip) - (values (let ((%buffer (gcontext-display gcontext))) - (declare (type display %buffer)) - (decode-type (or (member :none) pixmap) clip-mask)) - nil) - (values (second clip) - (decode-type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) - (first clip))))))) - -(defsetf gcontext-clip-mask (gcontext &optional ordering) (clip-mask) - ;; A bit strange, but retains setf form. - ;; a nil clip-mask is transformed to an empty vector - `(set-gcontext-clip-mask ,gcontext ,ordering ,clip-mask)) - -(defun set-gcontext-clip-mask (gcontext ordering clip-mask) - ;; a nil clip-mask is transformed to an empty vector - (declare (type gcontext gcontext) - (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) ordering) - (type (or (member :none) pixmap rect-seq) clip-mask)) - (unless clip-mask (x-type-error clip-mask '(or (member :none) pixmap rect-seq))) - (multiple-value-bind (clip-mask clip) - (typecase clip-mask - (pixmap (values (pixmap-id clip-mask) nil)) - ((member :none) (values 0 nil)) - (sequence - (values nil - (list (encode-type - (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) - ordering) - (copy-seq clip-mask)))) - (otherwise (x-type-error clip-mask '(or (member :none) pixmap rect-seq)))) - (modify-gcontext (gcontext local-state) - (let ((server-state (gcontext-server-state gcontext))) - (declare (type gcontext-state server-state)) - (without-interrupts - (setf (gcontext-internal-clip local-state) clip - (gcontext-internal-clip-mask local-state) clip-mask) - (if (null clip) - (setf (gcontext-internal-clip server-state) nil) - (setf (gcontext-internal-clip-mask server-state) nil)) - (when (and clip-mask (not (zerop clip-mask))) - ;; write-through clip-mask pixmap, because the protocol allows the - ;; server to copy the pixmap contents at the time of the store, - ;; rather than continuing to share with the pixmap. - (setf (gcontext-internal-clip-mask server-state) nil)))))) - clip-mask) - -(defun gcontext-dashes (gcontext) - (declare (type gcontext gcontext)) - (declare (clx-values (or null card8 sequence))) - (access-gcontext (gcontext local-state) - (multiple-value-bind (dash dashes) - (without-interrupts - (values (gcontext-internal-dash local-state) - (gcontext-internal-dashes local-state))) - (if (null dash) - dashes - dash)))) - -(defsetf gcontext-dashes set-gcontext-dashes) - -(defun set-gcontext-dashes (gcontext dashes) - (declare (type gcontext gcontext) - (type (or card8 sequence) dashes)) - (multiple-value-bind (dashes dash) - (if (type? dashes 'sequence) - (if (zerop (length dashes)) - (x-type-error dashes '(or card8 sequence) "non-empty sequence") - (values nil (or (copy-seq dashes) (vector)))) - (values (encode-type card8 dashes) nil)) - (modify-gcontext (gcontext local-state) - (let ((server-state (gcontext-server-state gcontext))) - (declare (type gcontext-state server-state)) - (without-interrupts - (setf (gcontext-internal-dash local-state) dash - (gcontext-internal-dashes local-state) dashes) - (if (null dash) - (setf (gcontext-internal-dash server-state) nil) - (setf (gcontext-internal-dashes server-state) nil)))))) - dashes) - -(defun gcontext-font (gcontext &optional metrics-p) - ;; If the stored font is known, it is returned. If it is not known and - ;; metrics-p is false, then nil is returned. If it is not known and - ;; metrics-p is true, then a pseudo font is returned. Full metric and - ;; property information can be obtained, but the font does not have a name or - ;; a resource-id, and attempts to use it where a resource-id is required will - ;; result in an invalid-font error. - (declare (type gcontext gcontext) - (type generalized-boolean metrics-p)) - (declare (clx-values (or null font))) - (access-gcontext (gcontext local-state) - (let ((font (gcontext-internal-font-obj local-state))) - (or font - (when metrics-p - ;; XXX this isn't correct - (make-font :display (gcontext-display gcontext) - :id (gcontext-id gcontext) - :name nil)))))) - -(defsetf gcontext-font set-gcontext-font) - -(defun set-gcontext-font (gcontext font) - (declare (type gcontext gcontext) - (type fontable font)) - (let* ((font-object (if (font-p font) font (open-font (gcontext-display gcontext) font))) - (font (and font-object (font-id font-object)))) - ;; XXX need to check font has id (and name?) - (modify-gcontext (gcontext local-state) - (let ((server-state (gcontext-server-state gcontext))) - (declare (type gcontext-state server-state)) - (without-interrupts - (setf (gcontext-internal-font-obj local-state) font-object - (gcontext-internal-font local-state) font) - ;; check against font, not against font-obj - (if (null font) - (setf (gcontext-internal-font server-state) nil) - (setf (gcontext-internal-font-obj server-state) font-object)))))) - font) - -(defun force-gcontext-changes-internal (gcontext) - ;; Force any delayed changes. - (declare (type gcontext gcontext)) - #.(declare-buffun) - - (let ((display (gcontext-display gcontext)) - (server-state (gcontext-server-state gcontext)) - (local-state (gcontext-local-state gcontext))) - (declare (type display display) - (type gcontext-state server-state local-state)) - - ;; Update server when timestamps don't match - (unless (= (the fixnum (gcontext-internal-timestamp local-state)) - (the fixnum (gcontext-internal-timestamp server-state))) - - ;; The display is already locked. - (macrolet ((with-buffer ((buffer &key timeout) &body body) - `(progn (progn ,buffer ,@(and timeout `(,timeout)) nil) - ,@body))) - - ;; Because there is no locking on the local state we have to - ;; assume that state will change and set timestamps up front, - ;; otherwise by the time we figured out there were no changes - ;; and tried to store the server stamp as the local stamp, the - ;; local stamp might have since been modified. - (setf (gcontext-internal-timestamp local-state) - (incf-internal-timestamp server-state)) - - (block no-changes - (let ((last-request (buffer-last-request display))) - (with-buffer-request (display +x-changegc+) - (gcontext gcontext) - (progn - (do ((i 0 (index+ i 1)) - (bit 1 (the xgcmask (ash bit 1))) - (nbyte 12) - (mask 0) - (local 0)) - ((index>= i +gcontext-fast-change-length+) - (when (zerop mask) - ;; If nothing changed, restore last-request and quit - (setf (buffer-last-request display) - (if (zerop (buffer-last-request display)) - nil - last-request)) - (return-from no-changes nil)) - (card29-put 8 mask) - (card16-put 2 (index-ash nbyte -2)) - (index-incf (buffer-boffset display) nbyte)) - (declare (type array-index i nbyte) - (type xgcmask bit) - (type gcmask mask) - (type (or null card32) local)) - (unless (eql (the (or null card32) (svref server-state i)) - (setq local (the (or null card32) (svref local-state i)))) - (setf (svref server-state i) local) - (card32-put nbyte local) - (setq mask (the gcmask (logior mask bit))) - (index-incf nbyte 4))))))) - - ;; Update GContext extensions - (do ((extension *gcontext-extensions* (cdr extension)) - (i *gcontext-data-length* (index+ i 1)) - (local)) - ((endp extension)) - (unless (eql (svref server-state i) - (setq local (svref local-state i))) - (setf (svref server-state i) local) - (funcall (gcontext-extension-set-function (car extension)) gcontext local))) - - ;; Update clipping rectangles - (multiple-value-bind (local-clip server-clip) - (without-interrupts - (values (gcontext-internal-clip local-state) - (gcontext-internal-clip server-state))) - (unless (equalp local-clip server-clip) - (setf (gcontext-internal-clip server-state) nil) - (unless (null local-clip) - (with-buffer-request (display +x-setcliprectangles+) - (data (first local-clip)) - (gcontext gcontext) - ;; XXX treat nil correctly - (card16 (or (gcontext-internal-clip-x local-state) 0) - (or (gcontext-internal-clip-y local-state) 0)) - ;; XXX this has both int16 and card16 values - ((sequence :format int16) (second local-clip))) - (setf (gcontext-internal-clip server-state) local-clip)))) - - ;; Update dashes - (multiple-value-bind (local-dash server-dash) - (without-interrupts - (values (gcontext-internal-dash local-state) - (gcontext-internal-dash server-state))) - (unless (equalp local-dash server-dash) - (setf (gcontext-internal-dash server-state) nil) - (unless (null local-dash) - (with-buffer-request (display +x-setdashes+) - (gcontext gcontext) - ;; XXX treat nil correctly - (card16 (or (gcontext-internal-dash-offset local-state) 0) - (length local-dash)) - ((sequence :format card8) local-dash)) - (setf (gcontext-internal-dash server-state) local-dash)))))))) - -(defun force-gcontext-changes (gcontext) - ;; Force any delayed changes. - (declare (type gcontext gcontext)) - (let ((display (gcontext-display gcontext)) - (server-state (gcontext-server-state gcontext)) - (local-state (gcontext-local-state gcontext))) - (declare (type gcontext-state server-state local-state)) - ;; Update server when timestamps don't match - (unless (= (the fixnum (gcontext-internal-timestamp local-state)) - (the fixnum (gcontext-internal-timestamp server-state))) - (with-display (display) - (force-gcontext-changes-internal gcontext))))) - -;;; WARNING: WITH-GCONTEXT WORKS MUCH MORE EFFICIENTLY WHEN THE OPTIONS BEING "BOUND" ARE -;;; SET IN THE GCONTEXT ON ENTRY. BECAUSE THERE'S NO WAY TO GET THE VALUE OF AN -;;; UNKNOWN GC COMPONENT, WITH-GCONTEXT MUST CREATE A TEMPORARY GC, COPY THE UNKNOWN -;;; COMPONENTS TO THE TEMPORARY GC, ALTER THE GC BEING USED, THEN COPY COMPOMENTS -;;; BACK. - -(defmacro with-gcontext ((gcontext &rest options &key clip-ordering - &allow-other-keys) - &body body) - ;; "Binds" the gcontext components specified by options within the - ;; dynamic scope of the body (i.e., indefinite scope and dynamic - ;; extent), on a per-process basis in a multi-process environment. - ;; The body is not surrounded by a with-display. If cache-p is nil or - ;; the some component states are unknown, this will implement - ;; save/restore by creating a temporary gcontext and doing - ;; copy-gcontext-components to and from it. - - (declare (arglist (gcontext &rest options &key - function plane-mask foreground background - line-width line-style cap-style join-style - fill-style fill-rule arc-mode tile stipple ts-x - ts-y font subwindow-mode exposures clip-x clip-y - clip-mask clip-ordering dash-offset dashes - &allow-other-keys) - &body body)) - (remf options :clip-ordering) - - (let ((gc (gensym)) - (saved-state (gensym)) - (temp-gc (gensym)) - (temp-mask (gensym)) - (temp-vars nil) - (setfs nil) - (indexes nil) ; List of gcontext field indices - (extension-indexes nil) ; List of gcontext extension field indices - (ts-index (getf *gcontext-indexes* :timestamp))) - - (do* ((option options (cddr option)) - (name (car option) (car option)) - (value (cadr option) (cadr option))) - ((endp option) (setq setfs (nreverse setfs))) - (let ((index (getf *gcontext-indexes* name))) - (if index - (push index indexes) - (let ((extension (find name *gcontext-extensions* - :key #'gcontext-extension-name))) - (if extension - (progn - (push (xintern "Internal-" 'gcontext- name "-State-Index") - extension-indexes)) - (x-type-error name 'gcontext-key))))) - (let ((accessor `(,(xintern 'gcontext- name) ,gc - ,@(when (eq name :clip-mask) `(,clip-ordering)))) - (temp-var (gensym))) - (when value - (push `(,temp-var ,value) temp-vars) - (push `(when ,temp-var (setf ,accessor ,temp-var)) setfs)))) - (if setfs - `(multiple-value-bind (,gc ,saved-state ,temp-mask ,temp-gc) - (copy-gcontext-local-state ,gcontext ',indexes ,@extension-indexes) - (declare (type gcontext ,gc) - (type gcontext-state ,saved-state) - (type xgcmask ,temp-mask) - (type (or null gcontext) ,temp-gc)) - (with-gcontext-bindings (,gc ,saved-state - ,(append indexes extension-indexes) - ,ts-index ,temp-mask ,temp-gc) - (let ,temp-vars - ,@setfs) - ,@body)) - `(progn ,@body)))) - -(defun copy-gcontext-local-state (gcontext indexes &rest extension-indices) - ;; Called from WITH-GCONTEXT to save the fields in GCONTEXT indicated by MASK - (declare (type gcontext gcontext) - (type list indexes) - (dynamic-extent extension-indices)) - (let ((local-state (gcontext-local-state gcontext)) - (saved-state (allocate-gcontext-state)) - (cache-p (gcontext-cache-p gcontext))) - (declare (type gcontext-state local-state saved-state)) - (setf (gcontext-internal-timestamp saved-state) 1) - (let ((temp-gc nil) - (temp-mask 0) - (extension-mask 0)) - (declare (type xgcmask temp-mask) - (type integer extension-mask)) - (dolist (i indexes) - (when (or (not (setf (svref saved-state i) (svref local-state i))) - (not cache-p)) - (setq temp-mask - (the xgcmask (logior temp-mask - (the xgcmask (svref *gcontext-masks* i))))))) - (dolist (i extension-indices) - (when (or (not (setf (svref saved-state i) (svref local-state i))) - (not cache-p)) - (setq extension-mask - (the xgcmask (logior extension-mask (ash 1 i)))))) - (when (or (plusp temp-mask) - (plusp extension-mask)) - ;; Copy to temporary GC when field unknown or cache-p false - (let ((display (gcontext-display gcontext))) - (declare (type display display)) - (with-display (display) - (setq temp-gc (allocate-temp-gcontext)) - (setf (gcontext-id temp-gc) (allocate-resource-id display gcontext 'gcontext) - (gcontext-display temp-gc) display - (gcontext-drawable temp-gc) (gcontext-drawable gcontext) - (gcontext-server-state temp-gc) saved-state - (gcontext-local-state temp-gc) saved-state) - ;; Create a new (temporary) gcontext - (with-buffer-request (display +x-creategc+) - (gcontext temp-gc) - (drawable (gcontext-drawable gcontext)) - (card29 0)) - ;; Copy changed components to the temporary gcontext - (when (plusp temp-mask) - (with-buffer-request (display +x-copygc+) - (gcontext gcontext) - (gcontext temp-gc) - (card29 (xgcmask->gcmask temp-mask)))) - ;; Copy extension fields to the new gcontext - (when (plusp extension-mask) - ;; Copy extension fields from temp back to gcontext - (do ((bit (ash extension-mask (- *gcontext-data-length*)) (ash bit -1)) - (i 0 (index+ i 1))) - ((zerop bit)) - (let ((copy-function (gcontext-extension-copy-function - (elt *gcontext-extensions* i)))) - (funcall copy-function gcontext temp-gc - (svref local-state (index+ i *gcontext-data-length*)))))) - ))) - (values gcontext saved-state (logior temp-mask extension-mask) temp-gc)))) - -(defun restore-gcontext-temp-state (gcontext temp-mask temp-gc) - (declare (type gcontext gcontext temp-gc) - (type xgcmask temp-mask)) - (let ((display (gcontext-display gcontext))) - (declare (type display display)) - (with-display (display) - (with-buffer-request (display +x-copygc+) - (gcontext temp-gc) - (gcontext gcontext) - (card29 (xgcmask->gcmask temp-mask))) - ;; Copy extension fields from temp back to gcontext - (do ((bit (ash temp-mask (- *gcontext-data-length*)) (ash bit -1)) - (extensions *gcontext-extensions* (cdr extensions)) - (i *gcontext-data-length* (index+ i 1)) - (local-state (gcontext-local-state temp-gc))) - ((zerop bit)) - (let ((copy-function (gcontext-extension-copy-function (car extensions)))) - (funcall copy-function temp-gc gcontext (svref local-state i)))) - ;; free gcontext - (with-buffer-request (display +x-freegc+) - (gcontext temp-gc)) - (deallocate-resource-id display (gcontext-id temp-gc) 'gcontext) - (deallocate-temp-gcontext temp-gc) - ;; Copy saved state back to server state - (do ((server-state (gcontext-server-state gcontext)) - (bit (xgcmask->gcmask temp-mask) (the gcmask (ash bit -1))) - (i 0 (index+ i 1))) - ((zerop bit) - (incf-internal-timestamp server-state)) - (declare (type gcontext-state server-state) - (type gcmask bit) - (type array-index i)) - (when (oddp bit) - (setf (svref server-state i) nil)))))) - -(defun create-gcontext (&rest options &key (drawable (required-arg drawable)) - function plane-mask foreground background - line-width line-style cap-style join-style fill-style fill-rule - arc-mode tile stipple ts-x ts-y font subwindow-mode - exposures clip-x clip-y clip-mask clip-ordering - dash-offset dashes - (cache-p t) - &allow-other-keys) - ;; Only non-nil components are passed on in the request, but for effective caching - ;; assumptions have to be made about what the actual protocol defaults are. For - ;; all gcontext components, a value of nil causes the default gcontext value to be - ;; used. For clip-mask, this implies that an empty rect-seq cannot be represented - ;; as a list. Note: use of stringable as font will cause an implicit open-font. - ;; Note: papers over protocol SetClipRectangles and SetDashes special cases. If - ;; cache-p is true, then gcontext state is cached locally, and changing a gcontext - ;; component will have no effect unless the new value differs from the cached - ;; value. Component changes (setfs and with-gcontext) are always deferred - ;; regardless of the cache mode, and sent over the protocol only when required by a - ;; local operation or by an explicit call to force-gcontext-changes. - (declare (type drawable drawable) ; Required to be non-null - (type (or null boole-constant) function) - (type (or null pixel) plane-mask foreground background) - (type (or null card16) line-width dash-offset) - (type (or null int16) ts-x ts-y clip-x clip-y) - (type (or null (member :solid :dash :double-dash)) line-style) - (type (or null (member :not-last :butt :round :projecting)) cap-style) - (type (or null (member :miter :round :bevel)) join-style) - (type (or null (member :solid :tiled :opaque-stippled :stippled)) fill-style) - (type (or null (member :even-odd :winding)) fill-rule) - (type (or null (member :chord :pie-slice)) arc-mode) - (type (or null pixmap) tile stipple) - (type (or null fontable) font) - (type (or null (member :clip-by-children :include-inferiors)) subwindow-mode) - (type (or null (member :on :off)) exposures) - (type (or null (member :none) pixmap rect-seq) clip-mask) - (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering) - (type (or null card8 sequence) dashes) - (dynamic-extent options) - (type generalized-boolean cache-p)) - (declare (clx-values gcontext)) - (let* ((display (drawable-display drawable)) - (gcontext (make-gcontext :display display :drawable drawable :cache-p cache-p)) - (local-state (gcontext-local-state gcontext)) - (server-state (gcontext-server-state gcontext)) - (gcontextid (allocate-resource-id display gcontext 'gcontext))) - (declare (type display display) - (type gcontext gcontext) - (type resource-id gcontextid) - (type gcontext-state local-state server-state)) - (setf (gcontext-id gcontext) gcontextid) - - (unless function (setf (gcontext-function gcontext) boole-1)) - ;; using the depth of the drawable would be better, but ... - (unless plane-mask (setf (gcontext-plane-mask gcontext) #xffffffff)) - (unless foreground (setf (gcontext-foreground gcontext) 0)) - (unless background (setf (gcontext-background gcontext) 1)) - (unless line-width (setf (gcontext-line-width gcontext) 0)) - (unless line-style (setf (gcontext-line-style gcontext) :solid)) - (unless cap-style (setf (gcontext-cap-style gcontext) :butt)) - (unless join-style (setf (gcontext-join-style gcontext) :miter)) - (unless fill-style (setf (gcontext-fill-style gcontext) :solid)) - (unless fill-rule (setf (gcontext-fill-rule gcontext) :even-odd)) - (unless arc-mode (setf (gcontext-arc-mode gcontext) :pie-slice)) - (unless ts-x (setf (gcontext-ts-x gcontext) 0)) - (unless ts-y (setf (gcontext-ts-y gcontext) 0)) - (unless subwindow-mode (setf (gcontext-subwindow-mode gcontext) - :clip-by-children)) - (unless exposures (setf (gcontext-exposures gcontext) :on)) - (unless clip-mask (setf (gcontext-clip-mask gcontext) :none)) - (unless clip-x (setf (gcontext-clip-x gcontext) 0)) - (unless clip-y (setf (gcontext-clip-y gcontext) 0)) - (unless dashes (setf (gcontext-dashes gcontext) 4)) - (unless dash-offset (setf (gcontext-dash-offset gcontext) 0)) - ;; a bit kludgy, but ... - (replace server-state local-state) - - (when function (setf (gcontext-function gcontext) function)) - (when plane-mask (setf (gcontext-plane-mask gcontext) plane-mask)) - (when foreground (setf (gcontext-foreground gcontext) foreground)) - (when background (setf (gcontext-background gcontext) background)) - (when line-width (setf (gcontext-line-width gcontext) line-width)) - (when line-style (setf (gcontext-line-style gcontext) line-style)) - (when cap-style (setf (gcontext-cap-style gcontext) cap-style)) - (when join-style (setf (gcontext-join-style gcontext) join-style)) - (when fill-style (setf (gcontext-fill-style gcontext) fill-style)) - (when fill-rule (setf (gcontext-fill-rule gcontext) fill-rule)) - (when arc-mode (setf (gcontext-arc-mode gcontext) arc-mode)) - (when tile (setf (gcontext-tile gcontext) tile)) - (when stipple (setf (gcontext-stipple gcontext) stipple)) - (when ts-x (setf (gcontext-ts-x gcontext) ts-x)) - (when ts-y (setf (gcontext-ts-y gcontext) ts-y)) - (when font (setf (gcontext-font gcontext) font)) - (when subwindow-mode (setf (gcontext-subwindow-mode gcontext) subwindow-mode)) - (when exposures (setf (gcontext-exposures gcontext) exposures)) - (when clip-x (setf (gcontext-clip-x gcontext) clip-x)) - (when clip-y (setf (gcontext-clip-y gcontext) clip-y)) - (when clip-mask (setf (gcontext-clip-mask gcontext clip-ordering) clip-mask)) - (when dash-offset (setf (gcontext-dash-offset gcontext) dash-offset)) - (when dashes (setf (gcontext-dashes gcontext) dashes)) - - (setf (gcontext-internal-timestamp server-state) 1) - (setf (gcontext-internal-timestamp local-state) - ;; SetClipRectangles or SetDashes request need to be sent? - (if (or (gcontext-internal-clip local-state) - (gcontext-internal-dash local-state)) - ;; Yes, mark local state "modified" to ensure - ;; force-gcontext-changes will occur. - 0 - ;; No, mark local state "unmodified" - 1)) - - (with-buffer-request (display +x-creategc+) - (resource-id gcontextid) - (drawable drawable) - (progn (do* ((i 0 (index+ i 1)) - (bit 1 (the xgcmask (ash bit 1))) - (nbyte 16) - (mask 0) - (local (svref local-state i) (svref local-state i))) - ((index>= i +gcontext-fast-change-length+) - (card29-put 12 mask) - (card16-put 2 (index-ash nbyte -2)) - (index-incf (buffer-boffset display) nbyte)) - (declare (type array-index i nbyte) - (type xgcmask bit) - (type gcmask mask) - (type (or null card32) local)) - (unless (eql local (the (or null card32) (svref server-state i))) - (setf (svref server-state i) local) - (card32-put nbyte local) - (setq mask (the gcmask (logior mask bit))) - (index-incf nbyte 4))))) - - ;; Initialize extensions - (do ((extensions *gcontext-extensions* (cdr extensions)) - (i *gcontext-data-length* (index+ i 1))) - ((endp extensions)) - (declare (type list extensions) - (type array-index i)) - (setf (svref server-state i) - (setf (svref local-state i) - (gcontext-extension-default (car extensions))))) - - ;; Set extension values - (do* ((option-list options (cddr option-list)) - (option (car option-list) (car option-list)) - (extension)) - ((endp option-list)) - (declare (type list option-list)) - (cond ((getf *gcontext-indexes* option)) ; Gcontext field - ((member option '(:drawable :clip-ordering :cache-p))) ; Optional parameter - ((setq extension (find option *gcontext-extensions* - :key #'gcontext-extension-name)) - (funcall (gcontext-extension-set-function extension) - gcontext (second option-list))) - (t (x-type-error option 'gcontext-key)))) - gcontext)) - -(defun copy-gcontext-components (src dst &rest keys) - (declare (type gcontext src dst) - (dynamic-extent keys)) - ;; you might ask why this isn't just a bunch of - ;; (setf (gcontext- dst) (gcontext- src)) - ;; the answer is that you can do that yourself if you want, what we are - ;; providing here is access to the protocol request, which will generally - ;; be more efficient (particularly for things like clip and dash lists). - (when keys - (let ((display (gcontext-display src)) - (mask 0)) - (declare (type xgcmask mask)) - (with-display (display) - (force-gcontext-changes-internal src) - (force-gcontext-changes-internal dst) - - ;; collect entire mask and handle extensions - (dolist (key keys) - (let ((i (getf *gcontext-indexes* key))) - (declare (type (or null array-index) i)) - (if i - (setq mask (the xgcmask (logior mask - (the xgcmask (svref *gcontext-masks* i))))) - (let ((extension (find key *gcontext-extensions* :key #'gcontext-extension-name))) - (if extension - (funcall (gcontext-extension-copy-function extension) - src dst (svref (gcontext-local-state src) - (index+ (position extension *gcontext-extensions*) *gcontext-data-length*))) - (x-type-error key 'gcontext-key)))))) - - (when (plusp mask) - (do ((src-server-state (gcontext-server-state src)) - (dst-server-state (gcontext-server-state dst)) - (dst-local-state (gcontext-local-state dst)) - (bit mask (the xgcmask (ash bit -1))) - (i 0 (index+ i 1))) - ((zerop bit) - (incf-internal-timestamp dst-server-state) - (setf (gcontext-internal-timestamp dst-local-state) 0)) - (declare (type gcontext-state src-server-state dst-server-state dst-local-state) - (type xgcmask bit) - (type array-index i)) - (when (oddp bit) - (setf (svref dst-local-state i) - (setf (svref dst-server-state i) (svref src-server-state i))))) - (with-buffer-request (display +x-copygc+) - (gcontext src dst) - (card29 (xgcmask->gcmask mask)))))))) - -(defun copy-gcontext (src dst) - (declare (type gcontext src dst)) - ;; Copies all components. - (apply #'copy-gcontext-components src dst +gcontext-components+) - (do ((extensions *gcontext-extensions* (cdr extensions)) - (i *gcontext-data-length* (index+ i 1))) - ((endp extensions)) - (funcall (gcontext-extension-copy-function (car extensions)) - src dst (svref (gcontext-local-state src) i)))) - -(defun free-gcontext (gcontext) - (declare (type gcontext gcontext)) - (let ((display (gcontext-display gcontext))) - (with-buffer-request (display +x-freegc+) - (gcontext gcontext)) - (deallocate-resource-id display (gcontext-id gcontext) 'gcontext) - (deallocate-gcontext-state (gcontext-server-state gcontext)) - (deallocate-gcontext-state (gcontext-local-state gcontext)) - nil)) - -(defmacro define-gcontext-accessor (name &key default set-function copy-function) - ;; This will define a new gcontext accessor called NAME. - ;; Defines the gcontext-NAME accessor function and its defsetf. - ;; Gcontext's will cache DEFAULT-VALUE and the last value SETF'ed when - ;; gcontext-cache-p is true. The NAME keyword will be allowed in - ;; CREATE-GCONTEXT, WITH-GCONTEXT, and COPY-GCONTEXT-COMPONENTS. - ;; SET-FUNCTION will be called with parameters (GCONTEXT NEW-VALUE) - ;; from create-gcontext, and force-gcontext-changes. - ;; COPY-FUNCTION will be called with parameters (src-gc dst-gc src-value) - ;; from copy-gcontext and copy-gcontext-components. - ;; The copy-function defaults to: - ;; (lambda (ignore dst-gc value) - ;; (if value - ;; (,set-function dst-gc value) - ;; (error "Can't copy unknown GContext component ~a" ',name))) - (declare (type symbol name) - (type t default) - (type symbol set-function) ;; required - (type (or symbol list) copy-function)) - (let* ((gc-name (intern (concatenate 'string - (string 'gcontext-) - (string name)))) ;; in current package - (key-name (kintern name)) - (setfer (xintern "Set-" gc-name)) - (internal-set-function (xintern "Internal-Set-" gc-name)) - (internal-copy-function (xintern "Internal-Copy-" gc-name)) - (internal-state-index (xintern "Internal-" gc-name "-State-Index"))) - (unless copy-function - (setq copy-function - `(lambda (src-gc dst-gc value) - (declare (ignore src-gc)) - (if value - (,set-function dst-gc value) - (error "Can't copy unknown GContext component ~a" ',name))))) - `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter ,internal-state-index - (add-gcontext-extension ',key-name ,default ',internal-set-function - ',internal-copy-function)) - ) ;; end eval-when - (defun ,gc-name (gcontext) - (svref (gcontext-local-state gcontext) ,internal-state-index)) - (defun ,setfer (gcontext new-value) - (let ((local-state (gcontext-local-state gcontext))) - (setf (gcontext-internal-timestamp local-state) 0) - (setf (svref local-state ,internal-state-index) new-value))) - (defsetf ,gc-name ,setfer) - (defun ,internal-set-function (gcontext new-value) - (,set-function gcontext new-value) - (setf (svref (gcontext-server-state gcontext) ,internal-state-index) - (setf (svref (gcontext-local-state gcontext) ,internal-state-index) - new-value))) - (defun ,internal-copy-function (src-gc dst-gc new-value) - (,copy-function src-gc dst-gc new-value) - (setf (svref (gcontext-local-state dst-gc) ,internal-state-index) - (setf (svref (gcontext-server-state dst-gc) ,internal-state-index) - new-value))) - ',name))) - -;; GContext extension fields are treated in much the same way as normal GContext -;; components. The current value is stored in a slot of the gcontext-local-state, -;; and the value known to the server is in a slot of the gcontext-server-state. -;; The slot-number is defined by its position in the *gcontext-extensions* list. -;; The value of the special variable |Internal-GCONTEXT-name| (where "name" is -;; the extension component name) reflects this position. The position within -;; *gcontext-extensions* and the value of the special value are determined at -;; LOAD time to facilitate merging of seperately compiled extension files. - -(defun add-gcontext-extension (name default-value set-function copy-function) - (declare (type symbol name) - (type t default-value) - (type (or function symbol) set-function) - (type (or function symbol) copy-function)) - (let ((number (or (position name *gcontext-extensions* :key #'gcontext-extension-name) - (prog1 (length *gcontext-extensions*) - (push nil *gcontext-extensions*))))) - (setf (nth number *gcontext-extensions*) - (make-gcontext-extension :name name - :default default-value - :set-function set-function - :copy-function copy-function)) - (+ number *gcontext-data-length*))) diff -Nru ecl-16.1.2/src/clx/generalock.lisp ecl-16.1.3+ds/src/clx/generalock.lisp --- ecl-16.1.2/src/clx/generalock.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/generalock.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,72 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: PROCESS; Base: 10; Lowercase: Yes -*- - -;;; Copyright (C) 1990 Symbolics, Inc. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Symbolics, Inc. provides this software "as is" without -;;; express or implied warranty. - -(defflavor xlib::clx-lock () (simple-recursive-normal-lock) - (:init-keywords :flavor)) - -(defwhopper (lock-internal xlib::clx-lock) (lock-argument) - (catch 'timeout - (continue-whopper lock-argument))) - -(defmethod (lock-block-internal xlib::clx-lock) (lock-argument) - (declare (dbg:locking-function describe-process-lock-for-debugger self)) - (when (null waiter-queue) - (setf waiter-queue (make-scheduler-queue :name name)) - (setf timer (create-timer-call #'lock-timer-expired `(,self) :name name))) - (let ((process (lock-argument-process lock-argument))) - (unwind-protect - (progn - (lock-map-over-conflicting-owners - self lock-argument - #'(lambda (other-lock-arg) - (add-promotion process lock-argument - (lock-argument-process other-lock-arg) other-lock-arg))) - (unless (timer-pending-p timer) - (when (and (safe-to-use-timers %real-current-process) - (not dbg:*debugger-might-have-system-problems*)) - (reset-timer-relative-timer-units timer *lock-timer-interval*))) - (assert (store-conditional (locf latch) process nil)) - (sys:with-aborts-enabled (lock-latch) - (let ((timeout (lock-argument-getf lock-argument :timeout nil))) - (cond ((null timeout) - (promotion-block waiter-queue name #'lock-lockable self lock-argument)) - ((and (plusp timeout) - (using-resource (timer process-block-timers) - ;; Yeah, we know about the internal representation - ;; of timers here. - (setf (car (timer-args timer)) %real-current-process) - (with-scheduler-locked - (reset-timer-relative timer timeout) - (flet ((lock-lockable-or-timeout (timer lock lock-argument) - (or (not (timer-pending-p timer)) - (lock-lockable lock lock-argument)))) - (let ((priority (process-process-priority *current-process*))) - (if (ldb-test %%scheduler-priority-preemption-field priority) - (promotion-block waiter-queue name - #'lock-lockable-or-timeout - timer self lock-argument) - ;; Change to preemptive priority so that when - ;; unlock-internal wakes us up so we can have the lock, - ;; we will really wake up right away - (with-process-priority - (dpb 1 %%scheduler-priority-preemption-field - priority) - (promotion-block waiter-queue name - #'lock-lockable-or-timeout - timer self lock-argument))))) - (lock-lockable self lock-argument))))) - (t (throw 'timeout nil)))))) - (unless (store-conditional (locf latch) nil process) - (lock-latch-wait-internal self)) - (remove-promotions process lock-argument)))) - -(compile-flavor-methods xlib::clx-lock) diff -Nru ecl-16.1.2/src/clx/gl.lisp ecl-16.1.3+ds/src/clx/gl.lisp --- ecl-16.1.2/src/clx/gl.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/gl.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,3692 +0,0 @@ -(defpackage :gl - (:use :common-lisp :xlib) - (:import-from :glx - "*CURRENT-CONTEXT*" - "CONTEXT" - "CONTEXT-P" - "CONTEXT-DISPLAY" - "CONTEXT-TAG" - "CONTEXT-RBUF" - "CONTEXT-INDEX" - ) - (:import-from :xlib - "DATA" - "WITH-BUFFER-REQUEST" - "WITH-BUFFER-REQUEST-AND-REPLY" - "CARD32-GET" - "SEQUENCE-GET" - - "WITH-DISPLAY" - "DISPLAY-FORCE-OUTPUT" - - "INT8" "INT16" "INT32" "INTEGER" - "CARD8" "CARD16" "CARD32" - - "ASET-CARD8" - "ASET-CARD16" - "ASET-CARD32" - "ASET-INT8" - "ASET-INT16" - "ASET-INT32" - - "DECLARE-BUFFUN" - - ;; Types - "ARRAY-INDEX" - "BUFFER-BYTES" - ) - - (:export "GET-STRING" - - ;; Rendering commands (alphabetical order) - - "ACCUM" - "ACTIVE-TEXTURE-ARB" - "ALPHA-FUNC" - "BEGIN" - "BIND-TEXTURE" - "BLEND-COLOR" - "BLEND-EQUOTION" - "BLEND-FUNC" - "CALL-LIST" - "CLEAR" - "CLEAR-ACCUM" - "CLEAR-COLOR" - "CLEAR-DEPTH" - "CLEAR-INDEX" - "CLEAR-STENCIL" - "CLIP-PLANE" - "COLOR-3B" - "COLOR-3D" - "COLOR-3F" - "COLOR-3I" - "COLOR-3S" - "COLOR-3UB" - "COLOR-3UI" - "COLOR-3US" - "COLOR-4B" - "COLOR-4D" - "COLOR-4F" - "COLOR-4I" - "COLOR-4S" - "COLOR-4UB" - "COLOR-4UI" - "COLOR-4US" - "COLOR-MASK" - "COLOR-MATERIAL" - "CONVOLUTION-PARAMETER-F" - "CONVOLUTION-PARAMETER-I" - "COPY-COLOR-SUB-TABLE" - "COPY-COLOR-TABLE" - "COPY-CONVOLUTION-FILTER-ID" - "COPY-CONVOLUTION-FILTER-2D" - "COPY-PIXELS" - "COPY-TEX-IMAGE-1D" - "COPY-TEX-IMAGE-2D" - "COPY-TEX-SUB-IMAGE-1D" - "COPY-TEX-SUB-IMAGE-2D" - "COPY-TEX-SUB-IMAGE-3D" - "CULL-FACE" - "DEPTH-FUNC" - "DEPTH-MASK" - "DEPTH-RANGE" - "DRAW-BUFFER" - "EDGE-FLAG-V" - "END" - "EVAL-COORD-1D" - "EVAL-COORD-1F" - "EVAL-COORD-2D" - "EVAL-COORD-2F" - "EVAL-MESH-1" - "EVAL-MESH-2" - "EVAL-POINT-1" - "EVAL-POINT-2" - "FOG-F" - "FOG-I" - "FRONT-FACE" - "FRUSTUM" - "HINT" - "HISTOGRAM" - "INDEX-MASK" - "INDEX-D" - "INDEX-F" - "INDEX-I" - "INDEX-S" - "INDEX-UB" - "INIT-NAMES" - "LIGHT-MODEL-F" - "LIGHT-MODEL-I" - "LIGHT-F" - "LIGHT-FV" - "LIGHT-I" - "LIGHT-IV" - "LINE-STIPPLE" - "LINE-WIDTH" - "LIST-BASE" - "LOAD-IDENTITY" - "LOAD-NAME" - "LOGIC-OP" - "MAP-GRID-1D" - "MAP-GRID-1F" - "MAP-GRID-2D" - "MAP-GRID-2F" - "MATERIAL-F" - "MATERIAL-FV" - "MATERIAL-I" - "MATERIAL-IV" - "MATRIX-MODE" - "MINMAX" - "MULTI-TEX-COORD-1D-ARB" - "MULTI-TEX-COORD-1F-ARB" - "MULTI-TEX-COORD-1I-ARB" - "MULTI-TEX-COORD-1S-ARB" - "MULTI-TEX-COORD-2D-ARB" - "MULTI-TEX-COORD-2F-ARB" - "MULTI-TEX-COORD-2I-ARB" - "MULTI-TEX-COORD-2S-ARB" - "MULTI-TEX-COORD-3D-ARB" - "MULTI-TEX-COORD-3F-ARB" - "MULTI-TEX-COORD-3I-ARB" - "MULTI-TEX-COORD-3S-ARB" - "MULTI-TEX-COORD-4D-ARB" - "MULTI-TEX-COORD-4F-ARB" - "MULTI-TEX-COORD-4I-ARB" - "MULTI-TEX-COORD-4S-ARB" - "NORMAL-3B" - "NORMAL-3D" - "NORMAL-3F" - "NORMAL-3I" - "NORMAL-3S" - "ORTHO" - "PASS-THROUGH" - "PIXEL-TRANSFER-F" - "PIXEL-TRANSFER-I" - "PIXEL-ZOOM" - "POINT-SIZE" - "POLYGON-MODE" - "POLYGON-OFFSET" - "POP-ATTRIB" - "POP-MATRIX" - "POP-NAME" - "PUSH-ATTRIB" - "PUSH-MATRIX" - "PUSH-NAME" - "RASTER-POS-2D" - "RASTER-POS-2F" - "RASTER-POS-2I" - "RASTER-POS-2S" - "RASTER-POS-3D" - "RASTER-POS-3F" - "RASTER-POS-3I" - "RASTER-POS-3S" - "RASTER-POS-4D" - "RASTER-POS-4F" - "RASTER-POS-4I" - "RASTER-POS-4S" - "READ-BUFFER" - "RECT-D" - "RECT-F" - "RECT-I" - "RECT-S" - "RESET-HISTOGRAM" - "RESET-MINMAX" - "ROTATE-D" - "ROTATE-F" - "SCALE-D" - "SCALE-F" - "SCISSOR" - "SHADE-MODEL" - "STENCIL-FUNC" - "STENCIL-MASK" - "STENCIL-OP" - "TEX-ENV-F" - "TEX-ENV-I" - "TEX-GEN-D" - "TEX-GEN-F" - "TEX-GEN-I" - "TEX-PARAMETER-F" - "TEX-PARAMETER-I" - "TRANSLATE-D" - "TRANSLATE-F" - "VERTEX-2D" - "VERTEX-2F" - "VERTEX-2I" - "VERTEX-2S" - "VERTEX-3D" - "VERTEX-3F" - "VERTEX-3I" - "VERTEX-3S" - "VERTEX-4D" - "VERTEX-4F" - "VERTEX-4I" - "VERTEX-4S" - "VIEWPORT" - - ;; * Where did this come from? - ;;"NO-FLOATS" - - ;; Non-rendering commands - "NEW-LIST" - "END-LIST" - "GEN-LISTS" - "ENABLE" - "DISABLE" - "FLUSH" - "FINISH" - - ;; Constants - - ;; Boolean - - "+FALSE+" - "+TRUE+" - - ;; Types - - "+BYTE+" - "+UNSIGNED-BYTE+" - "+SHORT+" - "+UNSIGNED-SHORT+" - "+INT+" - "+UNSIGNED-INT+" - "+FLOAT+" - "+DOUBLE+" - "+2-BYTES+" - "+3-BYTES+" - "+4-BYTES+" - - ;; Primitives - - "+POINTS+" - "+LINES+" - "+LINE-LOOP+" - "+LINE-STRIP+" - "+TRIANGLES+" - "+TRIANGLE-STRIP+" - "+triangle-fan+" - "+QUADS+" - "+QUAD-STRIP+" - "+POLYGON+" - - ;; Arrays - - "+VERTEX-ARRAY+" - "+NORMAL-ARRAY+" - "+COLOR-ARRAY+" - "+INDEX-ARRAY+" - "+TEXTURE-COORD-ARRAY+" - "+EDGE-FLAG-ARRAY+" - "+VERTEX-ARRAY-SIZE+" - "+VERTEX-ARRAY-TYPE+" - "+VERTEX-ARRAY-STRIDE+" - "+NORMAL-ARRAY-TYPE+" - "+NORMAL-ARRAY-STRIDE+" - "+COLOR-ARRAY-SIZE+" - "+COLOR-ARRAY-TYPE+" - "+COLOR-ARRAY-STRIDE+" - "+INDEX-ARRAY-TYPE+" - "+INDEX-ARRAY-STRIDE+" - "+TEXTURE-COORD-ARRAY-SIZE+" - "+TEXTURE-COORD-ARRAY-TYPE+" - "+TEXTURE-COORD-ARRAY-STRIDE+" - "+EDGE-FLAG-ARRAY-STRIDE+" - "+VERTEX-ARRAY-POINTER+" - "+NORMAL-ARRAY-POINTER+" - "+COLOR-ARRAY-POINTER+" - "+INDEX-ARRAY-POINTER+" - "+TEXTURE-COORD-ARRAY-POINTER+" - "+EDGE-FLAG-ARRAY-POINTER+" - - ;; Array formats - - "+V2F+" - "+V3F+" - "+C4UB-V2F+" - "+C4UB-V3F+" - "+C3F-V3F+" - "+N3F-V3F+" - "+C4F-N3F-V3F+" - "+T2F-V3F+" - "+T4F-V4F+" - "+T2F-C4UB-V3F+" - "+T2F-C3F-V3F+" - "+T2F-N3F-V3F+" - "+T2F-C4F-N3F-V3F+" - "+T4F-C4F-N3F-V4F+" - - ;; Matrices - - "+MATRIX-MODE+" - "+MODELVIEW+" - "+PROJECTION+" - "+TEXTURE+" - - ;; Points - - "+POINT-SMOOTH+" - "+POINT-SIZE+" - "+POINT-SIZE-GRANULARITY+" - "+POINT-SIZE-RANGE+" - - ;; Lines - - "+LINE-SMOOTH+" - "+LINE-STIPPLE+" - "+LINE-STIPPLE-PATTERN+" - "+LINE-STIPPLE-REPEAT+" - "+LINE-WIDTH+" - "+LINE-WIDTH-GRANULARITY+" - "+LINE-WIDTH-RANGE+" - - ;; Polygons - - "+POINT+" - "+LINE+" - "+FILL+" - "+CW+" - "+CCW+" - "+FRONT+" - "+BACK+" - "+POLYGON-MODE+" - "+POLYGON-SMOOTH+" - "+POLYGON-STIPPLE+" - "+EDGE-FLAG+" - "+CULL-FACE+" - "+CULL-FACE-MODE+" - "+FRONT-FACE+" - "+POLYGON-OFFSET-FACTOR+" - "+POLYGON-OFFSET-UNITS+" - "+POLYGON-OFFSET-POINT+" - "+POLYGON-OFFSET-LINE+" - "+POLYGON-OFFSET-FILL+" - - ;; Display Lists - - "+COMPILE+" - "+COMPILE-AND-EXECUTE+" - "+LIST-BASE+" - "+LIST-INDEX+" - "+LIST-MODE+" - - ;; Depth Buffer - - "+NEVER+" - "+LESS+" - "+EQUAL+" - "+LEQUAL+" - "+GREATER+" - "+NOTEQUAL+" - "+GEQUAL+" - "+ALWAYS+" - "+DEPTH-TEST+" - "+DEPTH-BITS+" - "+DEPTH-CLEAR-VALUE+" - "+DEPTH-FUNC+" - "+DEPTH-RANGE+" - "+DEPTH-WRITEMASK+" - "+DEPTH-COMPONENT+" - - ;; Lighting - - "+LIGHTING+" - "+LIGHT0+" - "+LIGHT1+" - "+LIGHT2+" - "+LIGHT3+" - "+LIGHT4+" - "+LIGHT5+" - "+LIGHT6+" - "+LIGHT7+" - "+SPOT-EXPONENT+" - "+SPOT-CUTOFF+" - "+CONSTANT-ATTENUATION+" - "+LINEAR-ATTENUATION+" - "+QUADRATIC-ATTENUATION+" - "+AMBIENT+" - "+DIFFUSE+" - "+SPECULAR+" - "+SHININESS+" - "+EMISSION+" - "+POSITION+" - "+SPOT-DIRECTION+" - "+AMBIENT-AND-DIFFUSE+" - "+COLOR-INDEXES+" - "+LIGHT-MODEL-TWO-SIDE+" - "+LIGHT-MODEL-LOCAL-VIEWER+" - "+LIGHT-MODEL-AMBIENT+" - "+FRONT-AND-BACK+" - "+SHADE-MODEL+" - "+FLAT+" - "+SMOOTH+" - "+COLOR-MATERIAL+" - "+COLOR-MATERIAL-FACE+" - "+COLOR-MATERIAL-PARAMETER+" - "+NORMALIZE+" - - ;; Clipping planes - - "+CLIP-PLANE0+" - "+CLIP-PLANE1+" - "+CLIP-PLANE2+" - "+CLIP-PLANE3+" - "+CLIP-PLANE4+" - "+CLIP-PLANE5+" - - ;; Accumulation buffer - - "+ACCUM-RED-BITS+" - "+ACCUM-GREEN-BITS+" - "+ACCUM-BLUE-BITS+" - "+ACCUM-ALPHA-BITS+" - "+ACCUM-CLEAR-VALUE+" - "+ACCUM+" - "+ADD+" - "+LOAD+" - "+MULT+" - "+RETURN+" - - ;; Alpha Testing - - "+ALPHA-TEST+" - "+ALPHA-TEST-REF+" - "+ALPHA-TEST-FUNC+" - - ;; Blending - - "+BLEND+" - "+BLEND-SRC+" - "+BLEND-DST+" - "+ZERO+" - "+ONE+" - "+SRC-COLOR+" - "+ONE-MINUS-SRC-COLOR+" - "+DST-COLOR+" - "+ONE-MINUS-DST-COLOR+" - "+SRC-ALPHA+" - "+ONE-MINUS-SRC-ALPHA+" - "+DST-ALPHA+" - "+ONE-MINUS-DST-ALPHA+" - "+SRC-ALPHA-SATURATE+" - "+CONSTANT-COLOR+" - "+ONE-MINUS-CONSTANT-COLOR+" - "+CONSTANT-ALPHA+" - "+ONE-MINUS-CONSTANT-ALPHA+" - - ;; Render mode - - "+FEEDBACK+" - "+RENDER+" - "+SELECT+" - - ;; Feedback - - "+2D+" - "+3D+" - "+3D-COLOR+" - "+3D-COLOR-TEXTURE+" - "+4D-COLOR-TEXTURE+" - "+POINT-TOKEN+" - "+LINE-TOKEN+" - "+LINE-RESET-TOKEN+" - "+POLYGON-TOKEN+" - "+BITMAP-TOKEN+" - "+DRAW-PIXEL-TOKEN+" - "+COPY-PIXEL-TOKEN+" - "+PASS-THROUGH-TOKEN+" - "+FEEDBACK-BUFFER-POINTER+" - "+FEEDBACK-BUFFER-SIZE+" - "+FEEDBACK-BUFFER-TYPE+" - - ;; Selection - - "+SELECTION-BUFFER-POINTER+" - "+SELECTION-BUFFER-SIZE+" - - ;; Fog - - "+FOG+" - "+FOG-MODE+" - "+FOG-DENSITY+" - "+FOG-COLOR+" - "+FOG-INDEX+" - "+FOG-START+" - "+FOG-END+" - "+LINEAR+" - "+EXP+" - "+EXP2+" - - ;; Logic operations - - "+LOGIC-OP+" - "+INDEX-LOGIC-OP+" - "+COLOR-LOGIC-OP+" - "+LOGIC-OP-MODE+" - "+CLEAR+" - "+SET+" - "+COPY+" - "+COPY-INVERTED+" - "+NOOP+" - "+INVERT+" - "+AND+" - "+NAND+" - "+OR+" - "+NOR+" - "+XOR+" - "+EQUIV+" - "+AND-REVERSE+" - "+AND-INVERTED+" - "+OR-REVERSE+" - "+OR-INVERTED+" - - ;; Stencil - - "+STENCIL-TEST+" - "+STENCIL-WRITEMASK+" - "+STENCIL-BITS+" - "+STENCIL-FUNC+" - "+STENCIL-VALUE-MASK+" - "+STENCIL-REF+" - "+STENCIL-FAIL+" - "+STENCIL-PASS-DEPTH-PASS+" - "+STENCIL-PASS-DEPTH-FAIL+" - "+STENCIL-CLEAR-VALUE+" - "+STENCIL-INDEX+" - "+KEEP+" - "+REPLACE+" - "+INCR+" - "+DECR+" - - ;; Buffers, Pixel Drawing/Reading - - "+NONE+" - "+LEFT+" - "+RIGHT+" - "+FRONT-LEFT+" - "+FRONT-RIGHT+" - "+BACK-LEFT+" - "+BACK-RIGHT+" - "+AUX0+" - "+AUX1+" - "+AUX2+" - "+AUX3+" - "+COLOR-INDEX+" - "+RED+" - "+GREEN+" - "+BLUE+" - "+ALPHA+" - "+LUMINANCE+" - "+LUMINANCE-ALPHA+" - "+ALPHA-BITS+" - "+RED-BITS+" - "+GREEN-BITS+" - "+BLUE-BITS+" - "+INDEX-BITS+" - "+SUBPIXEL-BITS+" - "+AUX-BUFFERS+" - "+READ-BUFFER+" - "+DRAW-BUFFER+" - "+DOUBLEBUFFER+" - "+STEREO+" - "+BITMAP+" - "+COLOR+" - "+DEPTH+" - "+STENCIL+" - "+DITHER+" - "+RGB+" - "+RGBA+" - - ;; Implementation Limits - - "+MAX-LIST-NESTING+" - "+MAX-ATTRIB-STACK-DEPTH+" - "+MAX-MODELVIEW-STACK-DEPTH+" - "+MAX-NAME-STACK-DEPTH+" - "+MAX-PROJECTION-STACK-DEPTH+" - "+MAX-TEXTURE-STACK-DEPTH+" - "+MAX-EVAL-ORDER+" - "+MAX-LIGHTS+" - "+MAX-CLIP-PLANES+" - "+MAX-TEXTURE-SIZE+" - "+MAX-PIXEL-MAP-TABLE+" - "+MAX-VIEWPORT-DIMS+" - "+MAX-CLIENT-ATTRIB-STACK-DEPTH+" - - ;; Gets - - "+ATTRIB-STACK-DEPTH+" - "+CLIENT-ATTRIB-STACK-DEPTH+" - "+COLOR-CLEAR-VALUE+" - "+COLOR-WRITEMASK+" - "+CURRENT-INDEX+" - "+CURRENT-COLOR+" - "+CURRENT-NORMAL+" - "+CURRENT-RASTER-COLOR+" - "+CURRENT-RASTER-DISTANCE+" - "+current-raster-index+" - "+CURRENT-RASTER-POSITION+" - "+CURRENT-RASTER-TEXTURE-COORDS+" - "+CURRENT-RASTER-POSITION-VALID+" - "+CURRENT-TEXTURE-COORDS+" - "+INDEX-CLEAR-VALUE+" - "+INDEX-MODE+" - "+INDEX-WRITEMASK+" - "+MODELVIEW-MATRIX+" - "+MODELVIEW-STACK-DEPTH+" - "+NAME-STACK-DEPTH+" - "+PROJECTION-MATRIX+" - "+PROJECTION-STACK-DEPTH+" - "+RENDER-MODE+" - "+RGBA-MODE+" - "+TEXTURE-MATRIX+" - "+TEXTURE-STACK-DEPTH+" - "+VIEWPORT+" - - ;; GL Evaluators - - "+AUTO-NORMAL+" - "+MAP1-COLOR-4+" - "+MAP1-GRID-DOMAIN+" - "+MAP1-GRID-SEGMENTS+" - "+MAP1-INDEX+" - "+MAP1-NORMAL+" - "+MAP1-TEXTURE-COORD-1+" - "+MAP1-TEXTURE-COORD-2+" - "+MAP1-TEXTURE-COORD-3+" - "+MAP1-TEXTURE-COORD-4+" - "+MAP1-VERTEX-3+" - "+MAP1-VERTEX-4+" - "+MAP2-COLOR-4+" - "+MAP2-GRID-DOMAIN+" - "+MAP2-GRID-SEGMENTS+" - "+MAP2-INDEX+" - "+MAP2-NORMAL+" - "+MAP2-TEXTURE-COORD-1+" - "+MAP2-TEXTURE-COORD-2+" - "+MAP2-TEXTURE-COORD-3+" - "+MAP2-TEXTURE-COORD-4+" - "+MAP2-VERTEX-3+" - "+MAP2-VERTEX-4+" - "+COEFF+" - "+DOMAIN+" - "+ORDER+" - - ;; Hints - - "+FOG-HINT+" - "+LINE-SMOOTH-HINT+" - "+PERSPECTIVE-CORRECTION-HINT+" - "+POINT-SMOOTH-HINT+" - "+POLYGON-SMOOTH-HINT+" - "+DONT-CARE+" - "+FASTEST+" - "+NICEST+" - - ;; Scissor box - - "+SCISSOR-TEST+" - "+SCISSOR-BOX+" - - ;; Pixel Mode / Transfer - - "+MAP-COLOR+" - "+MAP-STENCIL+" - "+INDEX-SHIFT+" - "+INDEX-OFFSET+" - "+RED-SCALE+" - "+RED-BIAS+" - "+GREEN-SCALE+" - "+GREEN-BIAS+" - "+BLUE-SCALE+" - "+BLUE-BIAS+" - "+ALPHA-SCALE+" - "+ALPHA-BIAS+" - "+DEPTH-SCALE+" - "+DEPTH-BIAS+" - "+PIXEL-MAP-S-TO-S-SIZE+" - "+PIXEL-MAP-I-TO-I-SIZE+" - "+PIXEL-MAP-I-TO-R-SIZE+" - "+PIXEL-MAP-I-TO-G-SIZE+" - "+PIXEL-MAP-I-TO-B-SIZE+" - "+PIXEL-MAP-I-TO-A-SIZE+" - "+PIXEL-MAP-R-TO-R-SIZE+" - "+PIXEL-MAP-G-TO-G-SIZE+" - "+PIXEL-MAP-B-TO-B-SIZE+" - "+PIXEL-MAP-A-TO-A-SIZE+" - "+PIXEL-MAP-S-TO-S+" - "+PIXEL-MAP-I-TO-I+" - "+PIXEL-MAP-I-TO-R+" - "+PIXEL-MAP-I-TO-G+" - "+PIXEL-MAP-I-TO-B+" - "+PIXEL-MAP-I-TO-A+" - "+PIXEL-MAP-R-TO-R+" - "+PIXEL-MAP-G-TO-G+" - "+PIXEL-MAP-B-TO-B+" - "+PIXEL-MAP-A-TO-A+" - "+PACK-ALIGNMENT+" - "+PACK-LSB-FIRST+" - "+PACK-ROW-LENGTH+" - "+PACK-SKIP-PIXELS+" - "+PACK-SKIP-ROWS+" - "+PACK-SWAP-BYTES+" - "+UNPACK-ALIGNMENT+" - "+UNPACK-LSB-FIRST+" - "+UNPACK-ROW-LENGTH+" - "+UNPACK-SKIP-PIXELS+" - "+UNPACK-SKIP-ROWS+" - "+UNPACK-SWAP-BYTES+" - "+ZOOM-X+" - "+ZOOM-Y+" - - ;; Texture Mapping - - "+TEXTURE-ENV+" - "+TEXTURE-ENV-MODE+" - "+TEXTURE-1D+" - "+TEXTURE-2D+" - "+TEXTURE-WRAP-S+" - "+TEXTURE-WRAP-T+" - "+TEXTURE-MAG-FILTER+" - "+TEXTURE-MIN-FILTER+" - "+TEXTURE-ENV-COLOR+" - "+TEXTURE-GEN-S+" - "+TEXTURE-GEN-T+" - "+TEXTURE-GEN-MODE+" - "+TEXTURE-BORDER-COLOR+" - "+TEXTURE-WIDTH+" - "+TEXTURE-HEIGHT+" - "+TEXTURE-BORDER+" - "+TEXTURE-COMPONENTS+" - "+TEXTURE-RED-SIZE+" - "+TEXTURE-GREEN-SIZE+" - "+TEXTURE-BLUE-SIZE+" - "+TEXTURE-ALPHA-SIZE+" - "+TEXTURE-LUMINANCE-SIZE+" - "+TEXTURE-INTENSITY-SIZE+" - "+NEAREST-MIPMAP-NEAREST+" - "+NEAREST-MIPMAP-LINEAR+" - "+LINEAR-MIPMAP-NEAREST+" - "+LINEAR-MIPMAP-LINEAR+" - "+OBJECT-LINEAR+" - "+OBJECT-PLANE+" - "+EYE-LINEAR+" - "+EYE-PLANE+" - "+SPHERE-MAP+" - "+DECAL+" - "+MODULATE+" - "+NEAREST+" - "+REPEAT+" - "+CLAMP+" - "+S+" - "+T+" - "+R+" - "+Q+" - "+TEXTURE-GEN-R+" - "+TEXTURE-GEN-Q+" - - ;; GL 1.1 Texturing - - "+PROXY-TEXTURE-1D+" - "+PROXY-TEXTURE-2D+" - "+TEXTURE-PRIORITY+" - "+TEXTURE-RESIDENT+" - "+TEXTURE-BINDING-1D+" - "+TEXTURE-BINDING-2D+" - "+TEXTURE-INTERNAL-FORMAT+" - "+PACK-SKIP-IMAGES+" - "+PACK-IMAGE-HEIGHT+" - "+UNPACK-SKIP-IMAGES+" - "+UNPACK-IMAGE-HEIGHT+" - "+TEXTURE-3D+" - "+PROXY-TEXTURE-3D+" - "+TEXTURE-DEPTH+" - "+TEXTURE-WRAP-R+" - "+MAX-3D-TEXTURE-SIZE+" - "+TEXTURE-BINDING-3D+" - - ;; Internal texture formats (GL 1.1) - "+ALPHA4+" - "+ALPHA8+" - "+ALPHA12+" - "+ALPHA16+" - "+LUMINANCE4+" - "+LUMINANCE8+" - "+LUMINANCE12+" - "+LUMINANCE16+" - "+LUMINANCE4-ALPHA4+" - "+LUMINANCE6-ALPHA2+" - "+LUMINANCE8-ALPHA8+" - "+LUMINANCE12-ALPHA4+" - "+LUMINANCE12-ALPHA12+" - "+LUMINANCE16-ALPHA16+" - "+INTENSITY+" - "+INTENSITY4+" - "+INTENSITY8+" - "+INTENSITY12+" - "+INTENSITY16+" - "+R3-G3-B2+" - "+RGB4+" - "+RGB5+" - "+RGB8+" - "+RGB10+" - "+RGB12+" - "+RGB16+" - "+RGBA2+" - "+RGBA4+" - "+RGB5-A1+" - "+RGBA8+" - "+rgb10-a2+" - "+RGBA12+" - "+RGBA16+" - - ;; Utility - - "+VENDOR+" - "+RENDERER+" - "+VERSION+" - "+EXTENSIONS+" - - ;; Errors - - "+NO-ERROR+" - "+INVALID-VALUE+" - "+INVALID-ENUM+" - "+INVALID-OPERATION+" - "+STACK-OVERFLOW+" - "+STACK-UNDERFLOW+" - "+OUT-OF-MEMORY+" - - ;; OpenGL 1.2 - - "+RESCALE-NORMAL+" - "+CLAMP-TO-EDGE+" - "+MAX-ELEMENTS-VERTICES+" - "+MAX-ELEMENTS-INDICES+" - "+BGR+" - "+BGRA+" - "+UNSIGNED-BYTE-3-3-2+" - "+UNSIGNED-BYTE-2-3-3-REV+" - "+UNSIGNED-SHORT-5-6-5+" - "+UNSIGNED-SHORT-5-6-5-REV+" - "+UNSIGNED-SHORT-4-4-4-4+" - "+UNSIGNED-SHORT-4-4-4-4-REV+" - "+UNSIGNED-SHORT-5-5-5-1+" - "+UNSIGNED-SHORT-1-5-5-5-REV+" - "+UNSIGNED-INT-8-8-8-8+" - "+UNSIGNED-INT-8-8-8-8-REV+" - "+UNSIGNED-INT-10-10-10-2+" - "+UNSIGNED-INT-2-10-10-10-REV+" - "+LIGHT-MODEL-COLOR-CONTROL+" - "+SINGLE-COLOR+" - "+SEPARATE-SPECULAR-COLOR+" - "+TEXTURE-MIN-LOD+" - "+TEXTURE-MAX-LOD+" - "+TEXTURE-BASE-LEVEL+" - "+TEXTURE-MAX-LEVEL+" - "+SMOOTH-POINT-SIZE-RANGE+" - "+SMOOTH-POINT-SIZE-GRANULARITY+" - "+SMOOTH-LINE-WIDTH-RANGE+" - "+SMOOTH-LINE-WIDTH-GRANULARITY+" - "+ALIASED-POINT-SIZE-RANGE+" - "+ALIASED-LINE-WIDTH-RANGE+" - - ;; OpenGL 1.2 Imaging subset - ;; GL_EXT_color_table - "+COLOR-TABLE+" - "+POST-CONVOLUTION-COLOR-TABLE+" - "+POST-COLOR-MATRIX-COLOR-TABLE+" - "+PROXY-COLOR-TABLE+" - "+PROXY-POST-CONVOLUTION-COLOR-TABLE+" - "+PROXY-POST-COLOR-MATRIX-COLOR-TABLE+" - "+COLOR-TABLE-SCALE+" - "+COLOR-TABLE-BIAS+" - "+COLOR-TABLE-FORMAT+" - "+COLOR-TABLE-WIDTH+" - "+COLOR-TABLE-RED-SIZE+" - "+COLOR-TABLE-GREEN-SIZE+" - "+COLOR-TABLE-BLUE-SIZE+" - "+COLOR-TABLE-ALPHA-SIZE+" - "+COLOR-TABLE-LUMINANCE-SIZE+" - "+COLOR-TABLE-INTENSITY-SIZE+" - ;; GL_EXT_convolution and GL_HP_convolution - "+CONVOLUTION-1D+" - "+CONVOLUTION-2D+" - "+SEPARABLE-2D+" - "+CONVOLUTION-BORDER-MODE+" - "+CONVOLUTION-FILTER-SCALE+" - "+CONVOLUTION-FILTER-BIAS+" - "+REDUCE+" - "+CONVOLUTION-FORMAT+" - "+CONVOLUTION-WIDTH+" - "+CONVOLUTION-HEIGHT+" - "+MAX-CONVOLUTION-WIDTH+" - "+MAX-CONVOLUTION-HEIGHT+" - "+POST-CONVOLUTION-RED-SCALE+" - "+POST-CONVOLUTION-GREEN-SCALE+" - "+POST-CONVOLUTION-BLUE-SCALE+" - "+POST-CONVOLUTION-ALPHA-SCALE+" - "+POST-CONVOLUTION-RED-BIAS+" - "+POST-CONVOLUTION-GREEN-BIAS+" - "+POST-CONVOLUTION-BLUE-BIAS+" - "+POST-CONVOLUTION-ALPHA-BIAS+" - "+CONSTANT-BORDER+" - "+REPLICATE-BORDER+" - "+CONVOLUTION-BORDER-COLOR+" - ;; GL_SGI_color_matrix - "+COLOR-MATRIX+" - "+COLOR-MATRIX-STACK-DEPTH+" - "+MAX-COLOR-MATRIX-STACK-DEPTH+" - "+POST-COLOR-MATRIX-RED-SCALE+" - "+POST-COLOR-MATRIX-GREEN-SCALE+" - "+POST-COLOR-MATRIX-BLUE-SCALE+" - "+POST-COLOR-MATRIX-ALPHA-SCALE+" - "+POST-COLOR-MATRIX-RED-BIAS+" - "+POST-COLOR-MATRIX-GREEN-BIAS+" - "+POST-COLOR-MATRIX-BLUE-BIAS+" - "+POST-COLOR-MATRIX-ALPHA-BIAS+" - ;; GL_EXT_histogram - "+HISTOGRAM+" - "+PROXY-HISTOGRAM+" - "+HISTOGRAM-WIDTH+" - "+HISTOGRAM-FORMAT+" - "+HISTOGRAM-RED-SIZE+" - "+HISTOGRAM-GREEN-SIZE+" - "+HISTOGRAM-BLUE-SIZE+" - "+HISTOGRAM-ALPHA-SIZE+" - "+HISTOGRAM-LUMINANCE-SIZE+" - "+HISTOGRAM-SINK+" - "+MINMAX+" - "+MINMAX-FORMAT+" - "+MINMAX-SINK+" - "+TABLE-TOO-LARGE+" - ;; GL_EXT_blend_color, GL_EXT_blend_minmax - "+BLEND-EQUATION+" - "+MIN+" - "+MAX+" - "+FUNC-ADD+" - "+FUNC-SUBTRACT+" - "+FUNC-REVERSE-SUBTRACT+" - - ;; glPush/PopAttrib bits - - "+CURRENT-BIT+" - "+POINT-BIT+" - "+LINE-BIT+" - "+POLYGON-BIT+" - "+POLYGON-STIPPLE-BIT+" - "+PIXEL-MODE-BIT+" - "+LIGHTING-BIT+" - "+FOG-BIT+" - "+DEPTH-BUFFER-BIT+" - "+ACCUM-BUFFER-BIT+" - "+STENCIL-BUFFER-BIT+" - "+VIEWPORT-BIT+" - "+TRANSFORM-BIT+" - "+ENABLE-BIT+" - "+COLOR-BUFFER-BIT+" - "+HINT-BIT+" - "+EVAL-BIT+" - "+LIST-BIT+" - "+TEXTURE-BIT+" - "+SCISSOR-BIT+" - "+ALL-ATTRIB-BITS+" - "+CLIENT-PIXEL-STORE-BIT+" - "+CLIENT-VERTEX-ARRAY-BIT+" - "+CLIENT-ALL-ATTRIB-BITS+" - - ;; ARB Multitexturing extension - - "+ARB-MULTITEXTURE+" - "+TEXTURE0-ARB+" - "+TEXTURE1-ARB+" - "+TEXTURE2-ARB+" - "+TEXTURE3-ARB+" - "+TEXTURE4-ARB+" - "+TEXTURE5-ARB+" - "+TEXTURE6-ARB+" - "+TEXTURE7-ARB+" - "+TEXTURE8-ARB+" - "+TEXTURE9-ARB+" - "+TEXTURE10-ARB+" - "+TEXTURE11-ARB+" - "+TEXTURE12-ARB+" - "+TEXTURE13-ARB+" - "+TEXTURE14-ARB+" - "+TEXTURE15-ARB+" - "+TEXTURE16-ARB+" - "+TEXTURE17-ARB+" - "+TEXTURE18-ARB+" - "+TEXTURE19-ARB+" - "+TEXTURE20-ARB+" - "+TEXTURE21-ARB+" - "+TEXTURE22-ARB+" - "+TEXTURE23-ARB+" - "+TEXTURE24-ARB+" - "+TEXTURE25-ARB+" - "+TEXTURE26-ARB+" - "+TEXTURE27-ARB+" - "+TEXTURE28-ARB+" - "+TEXTURE29-ARB+" - "+TEXTURE30-ARB+" - "+TEXTURE31-ARB+" - "+ACTIVE-TEXTURE-ARB+" - "+CLIENT-ACTIVE-TEXTURE-ARB+" - "+MAX-TEXTURE-UNITS-ARB+" - -;;; Misc extensions - - "+EXT-ABGR+" - "+ABGR-EXT+" - "+EXT-BLEND-COLOR+" - "+CONSTANT-COLOR-EXT+" - "+ONE-MINUS-CONSTANT-COLOR-EXT+" - "+CONSTANT-ALPHA-EXT+" - "+ONE-MINUS-CONSTANT-ALPHA-EXT+" - "+blend-color-ext+" - "+EXT-POLYGON-OFFSET+" - "+POLYGON-OFFSET-EXT+" - "+POLYGON-OFFSET-FACTOR-EXT+" - "+POLYGON-OFFSET-BIAS-EXT+" - "+EXT-TEXTURE3D+" - "+PACK-SKIP-IMAGES-EXT+" - "+PACK-IMAGE-HEIGHT-EXT+" - "+UNPACK-SKIP-IMAGES-EXT+" - "+UNPACK-IMAGE-HEIGHT-EXT+" - "+TEXTURE-3D-EXT+" - "+PROXY-TEXTURE-3D-EXT+" - "+TEXTURE-DEPTH-EXT+" - "+TEXTURE-WRAP-R-EXT+" - "+MAX-3D-TEXTURE-SIZE-EXT+" - "+TEXTURE-3D-BINDING-EXT+" - "+EXT-TEXTURE-OBJECT+" - "+TEXTURE-PRIORITY-EXT+" - "+TEXTURE-RESIDENT-EXT+" - "+TEXTURE-1D-BINDING-EXT+" - "+TEXTURE-2D-BINDING-EXT+" - "+EXT-RESCALE-NORMAL+" - "+RESCALE-NORMAL-EXT+" - "+EXT-VERTEX-ARRAY+" - "+VERTEX-ARRAY-EXT+" - "+NORMAL-ARRAY-EXT+" - "+COLOR-ARRAY-EXT+" - "+INDEX-ARRAY-EXT+" - "+TEXTURE-COORD-ARRAY-EXT+" - "+EDGE-FLAG-ARRAY-EXT+" - "+VERTEX-ARRAY-SIZE-EXT+" - "+VERTEX-ARRAY-TYPE-EXT+" - "+VERTEX-ARRAY-STRIDE-EXT+" - "+VERTEX-ARRAY-COUNT-EXT+" - "+NORMAL-ARRAY-TYPE-EXT+" - "+NORMAL-ARRAY-STRIDE-EXT+" - "+NORMAL-ARRAY-COUNT-EXT+" - "+COLOR-ARRAY-SIZE-EXT+" - "+COLOR-ARRAY-TYPE-EXT+" - "+COLOR-ARRAY-STRIDE-EXT+" - "+COLOR-ARRAY-COUNT-EXT+" - "+INDEX-ARRAY-TYPE-EXT+" - "+INDEX-ARRAY-STRIDE-EXT+" - "+INDEX-ARRAY-COUNT-EXT+" - "+TEXTURE-COORD-ARRAY-SIZE-EXT+" - "+TEXTURE-COORD-ARRAY-TYPE-EXT+" - "+TEXTURE-COORD-ARRAY-STRIDE-EXT+" - "+TEXTURE-COORD-ARRAY-COUNT-EXT+" - "+EDGE-FLAG-ARRAY-STRIDE-EXT+" - "+EDGE-FLAG-ARRAY-COUNT-EXT+" - "+VERTEX-ARRAY-POINTER-EXT+" - "+NORMAL-ARRAY-POINTER-EXT+" - "+COLOR-ARRAY-POINTER-EXT+" - "+INDEX-ARRAY-POINTER-EXT+" - "+TEXTURE-COORD-ARRAY-POINTER-EXT+" - "+EDGE-FLAG-ARRAY-POINTER-EXT+" - "+SGIS-TEXTURE-EDGE-CLAMP+" - "+CLAMP-TO-EDGE-SGIS+" - "+EXT-BLEND-MINMAX+" - "+FUNC-ADD-EXT+" - "+MIN-EXT+" - "+MAX-EXT+" - "+BLEND-EQUATION-EXT+" - "+EXT-BLEND-SUBTRACT+" - "+FUNC-SUBTRACT-EXT+" - "+FUNC-REVERSE-SUBTRACT-EXT+" - "+EXT-BLEND-LOGIC-OP+" - "+EXT-POINT-PARAMETERS+" - "+POINT-SIZE-MIN-EXT+" - "+POINT-SIZE-MAX-EXT+" - "+POINT-FADE-THRESHOLD-SIZE-EXT+" - "+DISTANCE-ATTENUATION-EXT+" - "+EXT-PALETTED-TEXTURE+" - "+TABLE-TOO-LARGE-EXT+" - "+COLOR-TABLE-FORMAT-EXT+" - "+COLOR-TABLE-WIDTH-EXT+" - "+COLOR-TABLE-RED-SIZE-EXT+" - "+COLOR-TABLE-GREEN-SIZE-EXT+" - "+COLOR-TABLE-BLUE-SIZE-EXT+" - "+COLOR-TABLE-ALPHA-SIZE-EXT+" - "+COLOR-TABLE-LUMINANCE-SIZE-EXT+" - "+COLOR-TABLE-INTENSITY-SIZE-EXT+" - "+TEXTURE-INDEX-SIZE-EXT+" - "+COLOR-INDEX1-EXT+" - "+COLOR-INDEX2-EXT+" - "+COLOR-INDEX4-EXT+" - "+COLOR-INDEX8-EXT+" - "+COLOR-INDEX12-EXT+" - "+COLOR-INDEX16-EXT+" - "+EXT-CLIP-VOLUME-HINT+" - "+CLIP-VOLUME-CLIPPING-HINT-EXT+" - "+EXT-COMPILED-VERTEX-ARRAY+" - "+ARRAY-ELEMENT-LOCK-FIRST-EXT+" - "+ARRAY-ELEMENT-LOCK-COUNT-EXT+" - "+HP-OCCLUSION-TEST+" - "+OCCLUSION-TEST-HP+" - "+OCCLUSION-TEST-RESULT-HP+" - "+EXT-SHARED-TEXTURE-PALETTE+" - "+SHARED-TEXTURE-PALETTE-EXT+" - "+EXT-STENCIL-WRAP+" - "+INCR-WRAP-EXT+" - "+DECR-WRAP-EXT+" - "+NV-TEXGEN-REFLECTION+" - "+NORMAL-MAP-NV+" - "+REFLECTION-MAP-NV+" - "+EXT-TEXTURE-ENV-ADD+" - "+MESA-WINDOW-POS+" - "+MESA-RESIZE-BUFFERS+" - - )) - - -(in-package :gl) - - - -;;; Opcodes. - -(eval-when (:compile-toplevel :load-toplevel :execute) -(defconstant +get-string+ 129) -(defconstant +new-list+ 101) -(defconstant +end-list+ 102) -(defconstant +gen-lists+ 104) -(defconstant +finish+ 108) -(defconstant +disable+ 138) -(defconstant +enable+ 139) -(defconstant +flush+ 142) - - - -;;; Constants. -;;; Shamelessly taken from CL-SDL. - -;; Boolean - -(defconstant +false+ #x0) -(defconstant +true+ #x1) - -;; Types - -(defconstant +byte+ #x1400) -(defconstant +unsigned-byte+ #x1401) -(defconstant +short+ #x1402) -(defconstant +unsigned-short+ #x1403) -(defconstant +int+ #x1404) -(defconstant +unsigned-int+ #x1405) -(defconstant +float+ #x1406) -(defconstant +double+ #x140a) -(defconstant +2-bytes+ #x1407) -(defconstant +3-bytes+ #x1408) -(defconstant +4-bytes+ #x1409) - -;; Primitives - -(defconstant +points+ #x0000) -(defconstant +lines+ #x0001) -(defconstant +line-loop+ #x0002) -(defconstant +line-strip+ #x0003) -(defconstant +triangles+ #x0004) -(defconstant +triangle-strip+ #x0005) -(defconstant +triangle-fan+ #x0006) -(defconstant +quads+ #x0007) -(defconstant +quad-strip+ #x0008) -(defconstant +polygon+ #x0009) - -;; Arrays - -(defconstant +vertex-array+ #x8074) -(defconstant +normal-array+ #x8075) -(defconstant +color-array+ #x8076) -(defconstant +index-array+ #x8077) -(defconstant +texture-coord-array+ #x8078) -(defconstant +edge-flag-array+ #x8079) -(defconstant +vertex-array-size+ #x807a) -(defconstant +vertex-array-type+ #x807b) -(defconstant +vertex-array-stride+ #x807c) -(defconstant +normal-array-type+ #x807e) -(defconstant +normal-array-stride+ #x807f) -(defconstant +color-array-size+ #x8081) -(defconstant +color-array-type+ #x8082) -(defconstant +color-array-stride+ #x8083) -(defconstant +index-array-type+ #x8085) -(defconstant +index-array-stride+ #x8086) -(defconstant +texture-coord-array-size+ #x8088) -(defconstant +texture-coord-array-type+ #x8089) -(defconstant +texture-coord-array-stride+ #x808a) -(defconstant +edge-flag-array-stride+ #x808c) -(defconstant +vertex-array-pointer+ #x808e) -(defconstant +normal-array-pointer+ #x808f) -(defconstant +color-array-pointer+ #x8090) -(defconstant +index-array-pointer+ #x8091) -(defconstant +texture-coord-array-pointer+ #x8092) -(defconstant +edge-flag-array-pointer+ #x8093) - -;; Array formats - -(defconstant +v2f+ #x2a20) -(defconstant +v3f+ #x2a21) -(defconstant +c4ub-v2f+ #x2a22) -(defconstant +c4ub-v3f+ #x2a23) -(defconstant +c3f-v3f+ #x2a24) -(defconstant +n3f-v3f+ #x2a25) -(defconstant +c4f-n3f-v3f+ #x2a26) -(defconstant +t2f-v3f+ #x2a27) -(defconstant +t4f-v4f+ #x2a28) -(defconstant +t2f-c4ub-v3f+ #x2a29) -(defconstant +t2f-c3f-v3f+ #x2a2a) -(defconstant +t2f-n3f-v3f+ #x2a2b) -(defconstant +t2f-c4f-n3f-v3f+ #x2a2c) -(defconstant +t4f-c4f-n3f-v4f+ #x2a2d) - -;; Matrices - -(defconstant +matrix-mode+ #x0ba0) -(defconstant +modelview+ #x1700) -(defconstant +projection+ #x1701) -(defconstant +texture+ #x1702) - -;; Points - -(defconstant +point-smooth+ #x0b10) -(defconstant +point-size+ #x0b11) -(defconstant +point-size-granularity+ #x0b13) -(defconstant +point-size-range+ #x0b12) - -;; Lines - -(defconstant +line-smooth+ #x0b20) -(defconstant +line-stipple+ #x0b24) -(defconstant +line-stipple-pattern+ #x0b25) -(defconstant +line-stipple-repeat+ #x0b26) -(defconstant +line-width+ #x0b21) -(defconstant +line-width-granularity+ #x0b23) -(defconstant +line-width-range+ #x0b22) - -;; Polygons - -(defconstant +point+ #x1b00) -(defconstant +line+ #x1b01) -(defconstant +fill+ #x1b02) -(defconstant +cw+ #x0900) -(defconstant +ccw+ #x0901) -(defconstant +front+ #x0404) -(defconstant +back+ #x0405) -(defconstant +polygon-mode+ #x0b40) -(defconstant +polygon-smooth+ #x0b41) -(defconstant +polygon-stipple+ #x0b42) -(defconstant +edge-flag+ #x0b43) -(defconstant +cull-face+ #x0b44) -(defconstant +cull-face-mode+ #x0b45) -(defconstant +front-face+ #x0b46) -(defconstant +polygon-offset-factor+ #x8038) -(defconstant +polygon-offset-units+ #x2a00) -(defconstant +polygon-offset-point+ #x2a01) -(defconstant +polygon-offset-line+ #x2a02) -(defconstant +polygon-offset-fill+ #x8037) - -;; Display Lists - -(defconstant +compile+ #x1300) -(defconstant +compile-and-execute+ #x1301) -(defconstant +list-base+ #x0b32) -(defconstant +list-index+ #x0b33) -(defconstant +list-mode+ #x0b30) - -;; Depth Buffer - -(defconstant +never+ #x0200) -(defconstant +less+ #x0201) -(defconstant +equal+ #x0202) -(defconstant +lequal+ #x0203) -(defconstant +greater+ #x0204) -(defconstant +notequal+ #x0205) -(defconstant +gequal+ #x0206) -(defconstant +always+ #x0207) -(defconstant +depth-test+ #x0b71) -(defconstant +depth-bits+ #x0d56) -(defconstant +depth-clear-value+ #x0b73) -(defconstant +depth-func+ #x0b74) -(defconstant +depth-range+ #x0b70) -(defconstant +depth-writemask+ #x0b72) -(defconstant +depth-component+ #x1902) - -;; Lighting - -(defconstant +lighting+ #x0b50) -(defconstant +light0+ #x4000) -(defconstant +light1+ #x4001) -(defconstant +light2+ #x4002) -(defconstant +light3+ #x4003) -(defconstant +light4+ #x4004) -(defconstant +light5+ #x4005) -(defconstant +light6+ #x4006) -(defconstant +light7+ #x4007) -(defconstant +spot-exponent+ #x1205) -(defconstant +spot-cutoff+ #x1206) -(defconstant +constant-attenuation+ #x1207) -(defconstant +linear-attenuation+ #x1208) -(defconstant +quadratic-attenuation+ #x1209) -(defconstant +ambient+ #x1200) -(defconstant +diffuse+ #x1201) -(defconstant +specular+ #x1202) -(defconstant +shininess+ #x1601) -(defconstant +emission+ #x1600) -(defconstant +position+ #x1203) -(defconstant +spot-direction+ #x1204) -(defconstant +ambient-and-diffuse+ #x1602) -(defconstant +color-indexes+ #x1603) -(defconstant +light-model-two-side+ #x0b52) -(defconstant +light-model-local-viewer+ #x0b51) -(defconstant +light-model-ambient+ #x0b53) -(defconstant +front-and-back+ #x0408) -(defconstant +shade-model+ #x0b54) -(defconstant +flat+ #x1d00) -(defconstant +smooth+ #x1d01) -(defconstant +color-material+ #x0b57) -(defconstant +color-material-face+ #x0b55) -(defconstant +color-material-parameter+ #x0b56) -(defconstant +normalize+ #x0ba1) - -;; Clipping planes - -(defconstant +clip-plane0+ #x3000) -(defconstant +clip-plane1+ #x3001) -(defconstant +clip-plane2+ #x3002) -(defconstant +clip-plane3+ #x3003) -(defconstant +clip-plane4+ #x3004) -(defconstant +clip-plane5+ #x3005) - -;; Accumulation buffer - -(defconstant +accum-red-bits+ #x0d58) -(defconstant +accum-green-bits+ #x0d59) -(defconstant +accum-blue-bits+ #x0d5a) -(defconstant +accum-alpha-bits+ #x0d5b) -(defconstant +accum-clear-value+ #x0b80) -(defconstant +accum+ #x0100) -(defconstant +add+ #x0104) -(defconstant +load+ #x0101) -(defconstant +mult+ #x0103) -(defconstant +return+ #x0102) - -;; Alpha Testing - -(defconstant +alpha-test+ #x0bc0) -(defconstant +alpha-test-ref+ #x0bc2) -(defconstant +alpha-test-func+ #x0bc1) - -;; Blending - -(defconstant +blend+ #x0be2) -(defconstant +blend-src+ #x0be1) -(defconstant +blend-dst+ #x0be0) -(defconstant +zero+ #x0) -(defconstant +one+ #x1) -(defconstant +src-color+ #x0300) -(defconstant +one-minus-src-color+ #x0301) -(defconstant +dst-color+ #x0306) -(defconstant +one-minus-dst-color+ #x0307) -(defconstant +src-alpha+ #x0302) -(defconstant +one-minus-src-alpha+ #x0303) -(defconstant +dst-alpha+ #x0304) -(defconstant +one-minus-dst-alpha+ #x0305) -(defconstant +src-alpha-saturate+ #x0308) -(defconstant +constant-color+ #x8001) -(defconstant +one-minus-constant-color+ #x8002) -(defconstant +constant-alpha+ #x8003) -(defconstant +one-minus-constant-alpha+ #x8004) - -;; Render mode - -(defconstant +feedback+ #x1c01) -(defconstant +render+ #x1c00) -(defconstant +select+ #x1c02) - -;; Feedback - -(defconstant +2d+ #x0600) -(defconstant +3d+ #x0601) -(defconstant +3d-color+ #x0602) -(defconstant +3d-color-texture+ #x0603) -(defconstant +4d-color-texture+ #x0604) -(defconstant +point-token+ #x0701) -(defconstant +line-token+ #x0702) -(defconstant +line-reset-token+ #x0707) -(defconstant +polygon-token+ #x0703) -(defconstant +bitmap-token+ #x0704) -(defconstant +draw-pixel-token+ #x0705) -(defconstant +copy-pixel-token+ #x0706) -(defconstant +pass-through-token+ #x0700) -(defconstant +feedback-buffer-pointer+ #x0df0) -(defconstant +feedback-buffer-size+ #x0df1) -(defconstant +feedback-buffer-type+ #x0df2) - -;; Selection - -(defconstant +selection-buffer-pointer+ #x0df3) -(defconstant +selection-buffer-size+ #x0df4) - -;; Fog - -(defconstant +fog+ #x0b60) -(defconstant +fog-mode+ #x0b65) -(defconstant +fog-density+ #x0b62) -(defconstant +fog-color+ #x0b66) -(defconstant +fog-index+ #x0b61) -(defconstant +fog-start+ #x0b63) -(defconstant +fog-end+ #x0b64) -(defconstant +linear+ #x2601) -(defconstant +exp+ #x0800) -(defconstant +exp2+ #x0801) - -;; Logic operations - -(defconstant +logic-op+ #x0bf1) -(defconstant +index-logic-op+ #x0bf1) -(defconstant +color-logic-op+ #x0bf2) -(defconstant +logic-op-mode+ #x0bf0) -(defconstant +clear+ #x1500) -(defconstant +set+ #x150f) -(defconstant +copy+ #x1503) -(defconstant +copy-inverted+ #x150c) -(defconstant +noop+ #x1505) -(defconstant +invert+ #x150a) -(defconstant +and+ #x1501) -(defconstant +nand+ #x150e) -(defconstant +or+ #x1507) -(defconstant +nor+ #x1508) -(defconstant +xor+ #x1506) -(defconstant +equiv+ #x1509) -(defconstant +and-reverse+ #x1502) -(defconstant +and-inverted+ #x1504) -(defconstant +or-reverse+ #x150b) -(defconstant +or-inverted+ #x150d) - -;; Stencil - -(defconstant +stencil-test+ #x0b90) -(defconstant +stencil-writemask+ #x0b98) -(defconstant +stencil-bits+ #x0d57) -(defconstant +stencil-func+ #x0b92) -(defconstant +stencil-value-mask+ #x0b93) -(defconstant +stencil-ref+ #x0b97) -(defconstant +stencil-fail+ #x0b94) -(defconstant +stencil-pass-depth-pass+ #x0b96) -(defconstant +stencil-pass-depth-fail+ #x0b95) -(defconstant +stencil-clear-value+ #x0b91) -(defconstant +stencil-index+ #x1901) -(defconstant +keep+ #x1e00) -(defconstant +replace+ #x1e01) -(defconstant +incr+ #x1e02) -(defconstant +decr+ #x1e03) - -;; Buffers, Pixel Drawing/Reading - -(defconstant +none+ #x0) -(defconstant +left+ #x0406) -(defconstant +right+ #x0407) -(defconstant +front-left+ #x0400) -(defconstant +front-right+ #x0401) -(defconstant +back-left+ #x0402) -(defconstant +back-right+ #x0403) -(defconstant +aux0+ #x0409) -(defconstant +aux1+ #x040a) -(defconstant +aux2+ #x040b) -(defconstant +aux3+ #x040c) -(defconstant +color-index+ #x1900) -(defconstant +red+ #x1903) -(defconstant +green+ #x1904) -(defconstant +blue+ #x1905) -(defconstant +alpha+ #x1906) -(defconstant +luminance+ #x1909) -(defconstant +luminance-alpha+ #x190a) -(defconstant +alpha-bits+ #x0d55) -(defconstant +red-bits+ #x0d52) -(defconstant +green-bits+ #x0d53) -(defconstant +blue-bits+ #x0d54) -(defconstant +index-bits+ #x0d51) -(defconstant +subpixel-bits+ #x0d50) -(defconstant +aux-buffers+ #x0c00) -(defconstant +read-buffer+ #x0c02) -(defconstant +draw-buffer+ #x0c01) -(defconstant +doublebuffer+ #x0c32) -(defconstant +stereo+ #x0c33) -(defconstant +bitmap+ #x1a00) -(defconstant +color+ #x1800) -(defconstant +depth+ #x1801) -(defconstant +stencil+ #x1802) -(defconstant +dither+ #x0bd0) -(defconstant +rgb+ #x1907) -(defconstant +rgba+ #x1908) - -;; Implementation Limits - -(defconstant +max-list-nesting+ #x0b31) -(defconstant +max-attrib-stack-depth+ #x0d35) -(defconstant +max-modelview-stack-depth+ #x0d36) -(defconstant +max-name-stack-depth+ #x0d37) -(defconstant +max-projection-stack-depth+ #x0d38) -(defconstant +max-texture-stack-depth+ #x0d39) -(defconstant +max-eval-order+ #x0d30) -(defconstant +max-lights+ #x0d31) -(defconstant +max-clip-planes+ #x0d32) -(defconstant +max-texture-size+ #x0d33) -(defconstant +max-pixel-map-table+ #x0d34) -(defconstant +max-viewport-dims+ #x0d3a) -(defconstant +max-client-attrib-stack-depth+ #x0d3b) - -;; Gets - -(defconstant +attrib-stack-depth+ #x0bb0) -(defconstant +client-attrib-stack-depth+ #x0bb1) -(defconstant +color-clear-value+ #x0c22) -(defconstant +color-writemask+ #x0c23) -(defconstant +current-index+ #x0b01) -(defconstant +current-color+ #x0b00) -(defconstant +current-normal+ #x0b02) -(defconstant +current-raster-color+ #x0b04) -(defconstant +current-raster-distance+ #x0b09) -(defconstant +current-raster-index+ #x0b05) -(defconstant +current-raster-position+ #x0b07) -(defconstant +current-raster-texture-coords+ #x0b06) -(defconstant +current-raster-position-valid+ #x0b08) -(defconstant +current-texture-coords+ #x0b03) -(defconstant +index-clear-value+ #x0c20) -(defconstant +index-mode+ #x0c30) -(defconstant +index-writemask+ #x0c21) -(defconstant +modelview-matrix+ #x0ba6) -(defconstant +modelview-stack-depth+ #x0ba3) -(defconstant +name-stack-depth+ #x0d70) -(defconstant +projection-matrix+ #x0ba7) -(defconstant +projection-stack-depth+ #x0ba4) -(defconstant +render-mode+ #x0c40) -(defconstant +rgba-mode+ #x0c31) -(defconstant +texture-matrix+ #x0ba8) -(defconstant +texture-stack-depth+ #x0ba5) -(defconstant +viewport+ #x0ba2) - -;; GL Evaluators - -(defconstant +auto-normal+ #x0d80) -(defconstant +map1-color-4+ #x0d90) -(defconstant +map1-grid-domain+ #x0dd0) -(defconstant +map1-grid-segments+ #x0dd1) -(defconstant +map1-index+ #x0d91) -(defconstant +map1-normal+ #x0d92) -(defconstant +map1-texture-coord-1+ #x0d93) -(defconstant +map1-texture-coord-2+ #x0d94) -(defconstant +map1-texture-coord-3+ #x0d95) -(defconstant +map1-texture-coord-4+ #x0d96) -(defconstant +map1-vertex-3+ #x0d97) -(defconstant +map1-vertex-4+ #x0d98) -(defconstant +map2-color-4+ #x0db0) -(defconstant +map2-grid-domain+ #x0dd2) -(defconstant +map2-grid-segments+ #x0dd3) -(defconstant +map2-index+ #x0db1) -(defconstant +map2-normal+ #x0db2) -(defconstant +map2-texture-coord-1+ #x0db3) -(defconstant +map2-texture-coord-2+ #x0db4) -(defconstant +map2-texture-coord-3+ #x0db5) -(defconstant +map2-texture-coord-4+ #x0db6) -(defconstant +map2-vertex-3+ #x0db7) -(defconstant +map2-vertex-4+ #x0db8) -(defconstant +coeff+ #x0a00) -(defconstant +domain+ #x0a02) -(defconstant +order+ #x0a01) - -;; Hints - -(defconstant +fog-hint+ #x0c54) -(defconstant +line-smooth-hint+ #x0c52) -(defconstant +perspective-correction-hint+ #x0c50) -(defconstant +point-smooth-hint+ #x0c51) -(defconstant +polygon-smooth-hint+ #x0c53) -(defconstant +dont-care+ #x1100) -(defconstant +fastest+ #x1101) -(defconstant +nicest+ #x1102) - -;; Scissor box - -(defconstant +scissor-test+ #x0c11) -(defconstant +scissor-box+ #x0c10) - -;; Pixel Mode / Transfer - -(defconstant +map-color+ #x0d10) -(defconstant +map-stencil+ #x0d11) -(defconstant +index-shift+ #x0d12) -(defconstant +index-offset+ #x0d13) -(defconstant +red-scale+ #x0d14) -(defconstant +red-bias+ #x0d15) -(defconstant +green-scale+ #x0d18) -(defconstant +green-bias+ #x0d19) -(defconstant +blue-scale+ #x0d1a) -(defconstant +blue-bias+ #x0d1b) -(defconstant +alpha-scale+ #x0d1c) -(defconstant +alpha-bias+ #x0d1d) -(defconstant +depth-scale+ #x0d1e) -(defconstant +depth-bias+ #x0d1f) -(defconstant +pixel-map-s-to-s-size+ #x0cb1) -(defconstant +pixel-map-i-to-i-size+ #x0cb0) -(defconstant +pixel-map-i-to-r-size+ #x0cb2) -(defconstant +pixel-map-i-to-g-size+ #x0cb3) -(defconstant +pixel-map-i-to-b-size+ #x0cb4) -(defconstant +pixel-map-i-to-a-size+ #x0cb5) -(defconstant +pixel-map-r-to-r-size+ #x0cb6) -(defconstant +pixel-map-g-to-g-size+ #x0cb7) -(defconstant +pixel-map-b-to-b-size+ #x0cb8) -(defconstant +pixel-map-a-to-a-size+ #x0cb9) -(defconstant +pixel-map-s-to-s+ #x0c71) -(defconstant +pixel-map-i-to-i+ #x0c70) -(defconstant +pixel-map-i-to-r+ #x0c72) -(defconstant +pixel-map-i-to-g+ #x0c73) -(defconstant +pixel-map-i-to-b+ #x0c74) -(defconstant +pixel-map-i-to-a+ #x0c75) -(defconstant +pixel-map-r-to-r+ #x0c76) -(defconstant +pixel-map-g-to-g+ #x0c77) -(defconstant +pixel-map-b-to-b+ #x0c78) -(defconstant +pixel-map-a-to-a+ #x0c79) -(defconstant +pack-alignment+ #x0d05) -(defconstant +pack-lsb-first+ #x0d01) -(defconstant +pack-row-length+ #x0d02) -(defconstant +pack-skip-pixels+ #x0d04) -(defconstant +pack-skip-rows+ #x0d03) -(defconstant +pack-swap-bytes+ #x0d00) -(defconstant +unpack-alignment+ #x0cf5) -(defconstant +unpack-lsb-first+ #x0cf1) -(defconstant +unpack-row-length+ #x0cf2) -(defconstant +unpack-skip-pixels+ #x0cf4) -(defconstant +unpack-skip-rows+ #x0cf3) -(defconstant +unpack-swap-bytes+ #x0cf0) -(defconstant +zoom-x+ #x0d16) -(defconstant +zoom-y+ #x0d17) - -;; Texture Mapping - -(defconstant +texture-env+ #x2300) -(defconstant +texture-env-mode+ #x2200) -(defconstant +texture-1d+ #x0de0) -(defconstant +texture-2d+ #x0de1) -(defconstant +texture-wrap-s+ #x2802) -(defconstant +texture-wrap-t+ #x2803) -(defconstant +texture-mag-filter+ #x2800) -(defconstant +texture-min-filter+ #x2801) -(defconstant +texture-env-color+ #x2201) -(defconstant +texture-gen-s+ #x0c60) -(defconstant +texture-gen-t+ #x0c61) -(defconstant +texture-gen-mode+ #x2500) -(defconstant +texture-border-color+ #x1004) -(defconstant +texture-width+ #x1000) -(defconstant +texture-height+ #x1001) -(defconstant +texture-border+ #x1005) -(defconstant +texture-components+ #x1003) -(defconstant +texture-red-size+ #x805c) -(defconstant +texture-green-size+ #x805d) -(defconstant +texture-blue-size+ #x805e) -(defconstant +texture-alpha-size+ #x805f) -(defconstant +texture-luminance-size+ #x8060) -(defconstant +texture-intensity-size+ #x8061) -(defconstant +nearest-mipmap-nearest+ #x2700) -(defconstant +nearest-mipmap-linear+ #x2702) -(defconstant +linear-mipmap-nearest+ #x2701) -(defconstant +linear-mipmap-linear+ #x2703) -(defconstant +object-linear+ #x2401) -(defconstant +object-plane+ #x2501) -(defconstant +eye-linear+ #x2400) -(defconstant +eye-plane+ #x2502) -(defconstant +sphere-map+ #x2402) -(defconstant +decal+ #x2101) -(defconstant +modulate+ #x2100) -(defconstant +nearest+ #x2600) -(defconstant +repeat+ #x2901) -(defconstant +clamp+ #x2900) -(defconstant +s+ #x2000) -(defconstant +t+ #x2001) -(defconstant +r+ #x2002) -(defconstant +q+ #x2003) -(defconstant +texture-gen-r+ #x0c62) -(defconstant +texture-gen-q+ #x0c63) - -;; GL 1.1 Texturing - -(defconstant +proxy-texture-1d+ #x8063) -(defconstant +proxy-texture-2d+ #x8064) -(defconstant +texture-priority+ #x8066) -(defconstant +texture-resident+ #x8067) -(defconstant +texture-binding-1d+ #x8068) -(defconstant +texture-binding-2d+ #x8069) -(defconstant +texture-internal-format+ #x1003) -(defconstant +pack-skip-images+ #x806b) -(defconstant +pack-image-height+ #x806c) -(defconstant +unpack-skip-images+ #x806d) -(defconstant +unpack-image-height+ #x806e) -(defconstant +texture-3d+ #x806f) -(defconstant +proxy-texture-3d+ #x8070) -(defconstant +texture-depth+ #x8071) -(defconstant +texture-wrap-r+ #x8072) -(defconstant +max-3d-texture-size+ #x8073) -(defconstant +texture-binding-3d+ #x806a) - -;; Internal texture formats (GL 1.1) -(defconstant +alpha4+ #x803b) -(defconstant +alpha8+ #x803c) -(defconstant +alpha12+ #x803d) -(defconstant +alpha16+ #x803e) -(defconstant +luminance4+ #x803f) -(defconstant +luminance8+ #x8040) -(defconstant +luminance12+ #x8041) -(defconstant +luminance16+ #x8042) -(defconstant +luminance4-alpha4+ #x8043) -(defconstant +luminance6-alpha2+ #x8044) -(defconstant +luminance8-alpha8+ #x8045) -(defconstant +luminance12-alpha4+ #x8046) -(defconstant +luminance12-alpha12+ #x8047) -(defconstant +luminance16-alpha16+ #x8048) -(defconstant +intensity+ #x8049) -(defconstant +intensity4+ #x804a) -(defconstant +intensity8+ #x804b) -(defconstant +intensity12+ #x804c) -(defconstant +intensity16+ #x804d) -(defconstant +r3-g3-b2+ #x2a10) -(defconstant +rgb4+ #x804f) -(defconstant +rgb5+ #x8050) -(defconstant +rgb8+ #x8051) -(defconstant +rgb10+ #x8052) -(defconstant +rgb12+ #x8053) -(defconstant +rgb16+ #x8054) -(defconstant +rgba2+ #x8055) -(defconstant +rgba4+ #x8056) -(defconstant +rgb5-a1+ #x8057) -(defconstant +rgba8+ #x8058) -(defconstant +rgb10-a2+ #x8059) -(defconstant +rgba12+ #x805a) -(defconstant +rgba16+ #x805b) - -;; Utility - -(defconstant +vendor+ #x1f00) -(defconstant +renderer+ #x1f01) -(defconstant +version+ #x1f02) -(defconstant +extensions+ #x1f03) - -;; Errors - -(defconstant +no-error+ #x0) -(defconstant +invalid-value+ #x0501) -(defconstant +invalid-enum+ #x0500) -(defconstant +invalid-operation+ #x0502) -(defconstant +stack-overflow+ #x0503) -(defconstant +stack-underflow+ #x0504) -(defconstant +out-of-memory+ #x0505) - -;; OpenGL 1.2 - -(defconstant +rescale-normal+ #x803a) -(defconstant +clamp-to-edge+ #x812f) -(defconstant +max-elements-vertices+ #x80e8) -(defconstant +max-elements-indices+ #x80e9) -(defconstant +bgr+ #x80e0) -(defconstant +bgra+ #x80e1) -(defconstant +unsigned-byte-3-3-2+ #x8032) -(defconstant +unsigned-byte-2-3-3-rev+ #x8362) -(defconstant +unsigned-short-5-6-5+ #x8363) -(defconstant +unsigned-short-5-6-5-rev+ #x8364) -(defconstant +unsigned-short-4-4-4-4+ #x8033) -(defconstant +unsigned-short-4-4-4-4-rev+ #x8365) -(defconstant +unsigned-short-5-5-5-1+ #x8034) -(defconstant +unsigned-short-1-5-5-5-rev+ #x8366) -(defconstant +unsigned-int-8-8-8-8+ #x8035) -(defconstant +unsigned-int-8-8-8-8-rev+ #x8367) -(defconstant +unsigned-int-10-10-10-2+ #x8036) -(defconstant +unsigned-int-2-10-10-10-rev+ #x8368) -(defconstant +light-model-color-control+ #x81f8) -(defconstant +single-color+ #x81f9) -(defconstant +separate-specular-color+ #x81fa) -(defconstant +texture-min-lod+ #x813a) -(defconstant +texture-max-lod+ #x813b) -(defconstant +texture-base-level+ #x813c) -(defconstant +texture-max-level+ #x813d) -(defconstant +smooth-point-size-range+ #x0b12) -(defconstant +smooth-point-size-granularity+ #x0b13) -(defconstant +smooth-line-width-range+ #x0b22) -(defconstant +smooth-line-width-granularity+ #x0b23) -(defconstant +aliased-point-size-range+ #x846d) -(defconstant +aliased-line-width-range+ #x846e) - -;; OpenGL 1.2 Imaging subset -;; GL_EXT_color_table -(defconstant +color-table+ #x80d0) -(defconstant +post-convolution-color-table+ #x80d1) -(defconstant +post-color-matrix-color-table+ #x80d2) -(defconstant +proxy-color-table+ #x80d3) -(defconstant +proxy-post-convolution-color-table+ #x80d4) -(defconstant +proxy-post-color-matrix-color-table+ #x80d5) -(defconstant +color-table-scale+ #x80d6) -(defconstant +color-table-bias+ #x80d7) -(defconstant +color-table-format+ #x80d8) -(defconstant +color-table-width+ #x80d9) -(defconstant +color-table-red-size+ #x80da) -(defconstant +color-table-green-size+ #x80db) -(defconstant +color-table-blue-size+ #x80dc) -(defconstant +color-table-alpha-size+ #x80dd) -(defconstant +color-table-luminance-size+ #x80de) -(defconstant +color-table-intensity-size+ #x80df) -;; GL_EXT_convolution and GL_HP_convolution -(defconstant +convolution-1d+ #x8010) -(defconstant +convolution-2d+ #x8011) -(defconstant +separable-2d+ #x8012) -(defconstant +convolution-border-mode+ #x8013) -(defconstant +convolution-filter-scale+ #x8014) -(defconstant +convolution-filter-bias+ #x8015) -(defconstant +reduce+ #x8016) -(defconstant +convolution-format+ #x8017) -(defconstant +convolution-width+ #x8018) -(defconstant +convolution-height+ #x8019) -(defconstant +max-convolution-width+ #x801a) -(defconstant +max-convolution-height+ #x801b) -(defconstant +post-convolution-red-scale+ #x801c) -(defconstant +post-convolution-green-scale+ #x801d) -(defconstant +post-convolution-blue-scale+ #x801e) -(defconstant +post-convolution-alpha-scale+ #x801f) -(defconstant +post-convolution-red-bias+ #x8020) -(defconstant +post-convolution-green-bias+ #x8021) -(defconstant +post-convolution-blue-bias+ #x8022) -(defconstant +post-convolution-alpha-bias+ #x8023) -(defconstant +constant-border+ #x8151) -(defconstant +replicate-border+ #x8153) -(defconstant +convolution-border-color+ #x8154) -;; GL_SGI_color_matrix -(defconstant +color-matrix+ #x80b1) -(defconstant +color-matrix-stack-depth+ #x80b2) -(defconstant +max-color-matrix-stack-depth+ #x80b3) -(defconstant +post-color-matrix-red-scale+ #x80b4) -(defconstant +post-color-matrix-green-scale+ #x80b5) -(defconstant +post-color-matrix-blue-scale+ #x80b6) -(defconstant +post-color-matrix-alpha-scale+ #x80b7) -(defconstant +post-color-matrix-red-bias+ #x80b8) -(defconstant +post-color-matrix-green-bias+ #x80b9) -(defconstant +post-color-matrix-blue-bias+ #x80ba) -(defconstant +post-color-matrix-alpha-bias+ #x80bb) -;; GL_EXT_histogram -(defconstant +histogram+ #x8024) -(defconstant +proxy-histogram+ #x8025) -(defconstant +histogram-width+ #x8026) -(defconstant +histogram-format+ #x8027) -(defconstant +histogram-red-size+ #x8028) -(defconstant +histogram-green-size+ #x8029) -(defconstant +histogram-blue-size+ #x802a) -(defconstant +histogram-alpha-size+ #x802b) -(defconstant +histogram-luminance-size+ #x802c) -(defconstant +histogram-sink+ #x802d) -(defconstant +minmax+ #x802e) -(defconstant +minmax-format+ #x802f) -(defconstant +minmax-sink+ #x8030) -(defconstant +table-too-large+ #x8031) -;; GL_EXT_blend_color, GL_EXT_blend_minmax -(defconstant +blend-equation+ #x8009) -(defconstant +min+ #x8007) -(defconstant +max+ #x8008) -(defconstant +func-add+ #x8006) -(defconstant +func-subtract+ #x800a) -(defconstant +func-reverse-subtract+ #x800b) - -;; glPush/PopAttrib bits - -(defconstant +current-bit+ #x00000001) -(defconstant +point-bit+ #x00000002) -(defconstant +line-bit+ #x00000004) -(defconstant +polygon-bit+ #x00000008) -(defconstant +polygon-stipple-bit+ #x00000010) -(defconstant +pixel-mode-bit+ #x00000020) -(defconstant +lighting-bit+ #x00000040) -(defconstant +fog-bit+ #x00000080) -(defconstant +depth-buffer-bit+ #x00000100) -(defconstant +accum-buffer-bit+ #x00000200) -(defconstant +stencil-buffer-bit+ #x00000400) -(defconstant +viewport-bit+ #x00000800) -(defconstant +transform-bit+ #x00001000) -(defconstant +enable-bit+ #x00002000) -(defconstant +color-buffer-bit+ #x00004000) -(defconstant +hint-bit+ #x00008000) -(defconstant +eval-bit+ #x00010000) -(defconstant +list-bit+ #x00020000) -(defconstant +texture-bit+ #x00040000) -(defconstant +scissor-bit+ #x00080000) -(defconstant +all-attrib-bits+ #x000fffff) -(defconstant +client-pixel-store-bit+ #x00000001) -(defconstant +client-vertex-array-bit+ #x00000002) -(defconstant +client-all-attrib-bits+ #xffffffff) - -;; ARB Multitexturing extension - -(defconstant +arb-multitexture+ 1) -(defconstant +texture0-arb+ #x84c0) -(defconstant +texture1-arb+ #x84c1) -(defconstant +texture2-arb+ #x84c2) -(defconstant +texture3-arb+ #x84c3) -(defconstant +texture4-arb+ #x84c4) -(defconstant +texture5-arb+ #x84c5) -(defconstant +texture6-arb+ #x84c6) -(defconstant +texture7-arb+ #x84c7) -(defconstant +texture8-arb+ #x84c8) -(defconstant +texture9-arb+ #x84c9) -(defconstant +texture10-arb+ #x84ca) -(defconstant +texture11-arb+ #x84cb) -(defconstant +texture12-arb+ #x84cc) -(defconstant +texture13-arb+ #x84cd) -(defconstant +texture14-arb+ #x84ce) -(defconstant +texture15-arb+ #x84cf) -(defconstant +texture16-arb+ #x84d0) -(defconstant +texture17-arb+ #x84d1) -(defconstant +texture18-arb+ #x84d2) -(defconstant +texture19-arb+ #x84d3) -(defconstant +texture20-arb+ #x84d4) -(defconstant +texture21-arb+ #x84d5) -(defconstant +texture22-arb+ #x84d6) -(defconstant +texture23-arb+ #x84d7) -(defconstant +texture24-arb+ #x84d8) -(defconstant +texture25-arb+ #x84d9) -(defconstant +texture26-arb+ #x84da) -(defconstant +texture27-arb+ #x84db) -(defconstant +texture28-arb+ #x84dc) -(defconstant +texture29-arb+ #x84dd) -(defconstant +texture30-arb+ #x84de) -(defconstant +texture31-arb+ #x84df) -(defconstant +active-texture-arb+ #x84e0) -(defconstant +client-active-texture-arb+ #x84e1) -(defconstant +max-texture-units-arb+ #x84e2) - -;;; Misc extensions - -(defconstant +ext-abgr+ 1) -(defconstant +abgr-ext+ #x8000) -(defconstant +ext-blend-color+ 1) -(defconstant +constant-color-ext+ #x8001) -(defconstant +one-minus-constant-color-ext+ #x8002) -(defconstant +constant-alpha-ext+ #x8003) -(defconstant +one-minus-constant-alpha-ext+ #x8004) -(defconstant +blend-color-ext+ #x8005) -(defconstant +ext-polygon-offset+ 1) -(defconstant +polygon-offset-ext+ #x8037) -(defconstant +polygon-offset-factor-ext+ #x8038) -(defconstant +polygon-offset-bias-ext+ #x8039) -(defconstant +ext-texture3d+ 1) -(defconstant +pack-skip-images-ext+ #x806b) -(defconstant +pack-image-height-ext+ #x806c) -(defconstant +unpack-skip-images-ext+ #x806d) -(defconstant +unpack-image-height-ext+ #x806e) -(defconstant +texture-3d-ext+ #x806f) -(defconstant +proxy-texture-3d-ext+ #x8070) -(defconstant +texture-depth-ext+ #x8071) -(defconstant +texture-wrap-r-ext+ #x8072) -(defconstant +max-3d-texture-size-ext+ #x8073) -(defconstant +texture-3d-binding-ext+ #x806a) -(defconstant +ext-texture-object+ 1) -(defconstant +texture-priority-ext+ #x8066) -(defconstant +texture-resident-ext+ #x8067) -(defconstant +texture-1d-binding-ext+ #x8068) -(defconstant +texture-2d-binding-ext+ #x8069) -(defconstant +ext-rescale-normal+ 1) -(defconstant +rescale-normal-ext+ #x803a) -(defconstant +ext-vertex-array+ 1) -(defconstant +vertex-array-ext+ #x8074) -(defconstant +normal-array-ext+ #x8075) -(defconstant +color-array-ext+ #x8076) -(defconstant +index-array-ext+ #x8077) -(defconstant +texture-coord-array-ext+ #x8078) -(defconstant +edge-flag-array-ext+ #x8079) -(defconstant +vertex-array-size-ext+ #x807a) -(defconstant +vertex-array-type-ext+ #x807b) -(defconstant +vertex-array-stride-ext+ #x807c) -(defconstant +vertex-array-count-ext+ #x807d) -(defconstant +normal-array-type-ext+ #x807e) -(defconstant +normal-array-stride-ext+ #x807f) -(defconstant +normal-array-count-ext+ #x8080) -(defconstant +color-array-size-ext+ #x8081) -(defconstant +color-array-type-ext+ #x8082) -(defconstant +color-array-stride-ext+ #x8083) -(defconstant +color-array-count-ext+ #x8084) -(defconstant +index-array-type-ext+ #x8085) -(defconstant +index-array-stride-ext+ #x8086) -(defconstant +index-array-count-ext+ #x8087) -(defconstant +texture-coord-array-size-ext+ #x8088) -(defconstant +texture-coord-array-type-ext+ #x8089) -(defconstant +texture-coord-array-stride-ext+ #x808a) -(defconstant +texture-coord-array-count-ext+ #x808b) -(defconstant +edge-flag-array-stride-ext+ #x808c) -(defconstant +edge-flag-array-count-ext+ #x808d) -(defconstant +vertex-array-pointer-ext+ #x808e) -(defconstant +normal-array-pointer-ext+ #x808f) -(defconstant +color-array-pointer-ext+ #x8090) -(defconstant +index-array-pointer-ext+ #x8091) -(defconstant +texture-coord-array-pointer-ext+ #x8092) -(defconstant +edge-flag-array-pointer-ext+ #x8093) -(defconstant +sgis-texture-edge-clamp+ 1) -(defconstant +clamp-to-edge-sgis+ #x812f) -(defconstant +ext-blend-minmax+ 1) -(defconstant +func-add-ext+ #x8006) -(defconstant +min-ext+ #x8007) -(defconstant +max-ext+ #x8008) -(defconstant +blend-equation-ext+ #x8009) -(defconstant +ext-blend-subtract+ 1) -(defconstant +func-subtract-ext+ #x800a) -(defconstant +func-reverse-subtract-ext+ #x800b) -(defconstant +ext-blend-logic-op+ 1) -(defconstant +ext-point-parameters+ 1) -(defconstant +point-size-min-ext+ #x8126) -(defconstant +point-size-max-ext+ #x8127) -(defconstant +point-fade-threshold-size-ext+ #x8128) -(defconstant +distance-attenuation-ext+ #x8129) -(defconstant +ext-paletted-texture+ 1) -(defconstant +table-too-large-ext+ #x8031) -(defconstant +color-table-format-ext+ #x80d8) -(defconstant +color-table-width-ext+ #x80d9) -(defconstant +color-table-red-size-ext+ #x80da) -(defconstant +color-table-green-size-ext+ #x80db) -(defconstant +color-table-blue-size-ext+ #x80dc) -(defconstant +color-table-alpha-size-ext+ #x80dd) -(defconstant +color-table-luminance-size-ext+ #x80de) -(defconstant +color-table-intensity-size-ext+ #x80df) -(defconstant +texture-index-size-ext+ #x80ed) -(defconstant +color-index1-ext+ #x80e2) -(defconstant +color-index2-ext+ #x80e3) -(defconstant +color-index4-ext+ #x80e4) -(defconstant +color-index8-ext+ #x80e5) -(defconstant +color-index12-ext+ #x80e6) -(defconstant +color-index16-ext+ #x80e7) -(defconstant +ext-clip-volume-hint+ 1) -(defconstant +clip-volume-clipping-hint-ext+ #x80f0) -(defconstant +ext-compiled-vertex-array+ 1) -(defconstant +array-element-lock-first-ext+ #x81a8) -(defconstant +array-element-lock-count-ext+ #x81a9) -(defconstant +hp-occlusion-test+ 1) -(defconstant +occlusion-test-hp+ #x8165) -(defconstant +occlusion-test-result-hp+ #x8166) -(defconstant +ext-shared-texture-palette+ 1) -(defconstant +shared-texture-palette-ext+ #x81fb) -(defconstant +ext-stencil-wrap+ 1) -(defconstant +incr-wrap-ext+ #x8507) -(defconstant +decr-wrap-ext+ #x8508) -(defconstant +nv-texgen-reflection+ 1) -(defconstant +normal-map-nv+ #x8511) -(defconstant +reflection-map-nv+ #x8512) -(defconstant +ext-texture-env-add+ 1) -(defconstant +mesa-window-pos+ 1) -(defconstant +mesa-resize-buffers+ 1) -) - - - -;;; Utility stuff - -(deftype bool () 'card8) -(deftype float32 () 'single-float) -(deftype float64 () 'double-float) - -(declaim (inline aset-float32 aset-float64)) - -#+sbcl -(defun aset-float32 (value array index) - (declare (type single-float value) - (type buffer-bytes array) - (type array-index index)) - #.(declare-buffun) - (let ((bits (sb-kernel:single-float-bits value))) - (declare (type (unsigned-byte 32) bits)) - (aset-card32 bits array index)) - value) - - -#+cmu -(defun aset-float32 (value array index) - (declare (type single-float value) - (type buffer-bytes array) - (type array-index index)) - #.(declare-buffun) - (let ((bits (kernel:single-float-bits value))) - (declare (type (unsigned-byte 32) bits)) - (aset-card32 bits array index)) - value) - - -#+openmcl -(defun aset-float32 (value array index) - (declare (type single-float value) - (type buffer-bytes array) - (type array-index index)) - #.(declare-buffun) - (let ((bits (ccl::single-float-bits value))) - (declare (type (unsigned-byte 32) bits)) - (aset-card32 bits array index)) - value) - - -#+sbcl -(defun aset-float64 (value array index) - (declare (type double-float value) - (type buffer-bytes array) - (type array-index index)) - #.(declare-buffun) - (let ((low (sb-kernel:double-float-low-bits value)) - (high (sb-kernel:double-float-high-bits value))) - (declare (type (unsigned-byte 32) low high)) - (aset-card32 low array index) - (aset-card32 high array (the array-index (+ index 4)))) - value) - - -#+cmu -(defun aset-float64 (value array index) - (declare (type double-float value) - (type buffer-bytes array) - (type array-index index)) - #.(declare-buffun) - (let ((low (kernel:double-float-low-bits value)) - (high (kernel:double-float-high-bits value))) - (declare (type (unsigned-byte 32) low high)) - (aset-card32 low array index) - (aset-card32 high array (+ index 4))) - value) - - -#+openmcl -(defun aset-float64 (value array index) - (declare (type double-float value) - (type buffer-bytes array) - (type array-index index)) - #.(declare-buffun) - (multiple-value-bind (low high) - (ccl::double-float-bits value) - (declare (type (unsigned-byte 32) low high)) - (aset-card32 low array index) - (aset-card32 high array (the array-index (+ index 4)))) - value) - - -(eval-when (:compile-toplevel :load-toplevel :execute) -(defun byte-width (type) - (ecase type - ((int8 card8 bool) 1) - ((int16 card16) 2) - ((int32 card32 float32) 4) - ((float64) 8))) - - -(defun setter (type) - (ecase type - (int8 'aset-int8) - (int16 'aset-int16) - (int32 'aset-int32) - (bool 'aset-card8) - (card8 'aset-card8) - (card16 'aset-card16) - (card32 'aset-card32) - (float32 'aset-float32) - (float64 'aset-float64))) - - -(defun sequence-setter (type) - (ecase type - (int8 'sset-int8) - (int16 'sset-int16) - (int32 'sset-int32) - (bool 'sset-card8) - (card8 'sset-card8) - (card16 'sset-card16) - (card32 'sset-card32) - (float32 'sset-float32) - (float64 'sset-float64))) - - -(defmacro define-sequence-setter (type) - `(defun ,(intern (format nil "~A-~A" 'sset type)) (seq buffer start length) - (declare (type sequence seq) - (type buffer-bytes buffer) - (type array-index start) - (type fixnum length)) - #.(declare-buffun) - (assert (= length (length seq)) - (length seq) - "SEQUENCE length should be ~D, not ~D." length (length seq)) - (typecase seq - (list - (let ((offset 0)) - (declare (type fixnum offset)) - (dolist (n seq) - (declare (type ,type n)) - (,(setter type) n buffer (the array-index (+ start offset))) - (incf offset ,(byte-width type))))) - ((simple-array ,type) - (dotimes (i ,(byte-width type)) - (,(setter type) - (aref seq i) - buffer - (the array-index (+ start (* i ,(byte-width type))))))) - (vector - (dotimes (i ,(byte-width type)) - (,(setter type) - (svref seq i) - buffer - (the array-index (+ start (* i ,(byte-width type)))))))))) - - -(define-sequence-setter int8) -(define-sequence-setter int16) -(define-sequence-setter int32) -(define-sequence-setter bool) -(define-sequence-setter card8) -(define-sequence-setter card16) -(define-sequence-setter card32) -(define-sequence-setter float32) -(define-sequence-setter float64) - - - -(defun make-argspecs (list) - (destructuring-bind (name type) - list - (etypecase type - (symbol `(,name ,type 1 nil)) - (list - `(,name - ,(second type) - ,(third type) - ,(if (consp (third type)) - (make-symbol (format nil "~A-~A" name 'length)) - nil)))))) - - -(defun byte-width-calculation (argspecs) - (let ((constant 0) - (calculated ())) - (loop - for (name type length length-var) in argspecs - do (let ((byte-width (byte-width type))) - (typecase length - (number (incf constant (* byte-width length))) - (symbol (push `(* ,byte-width ,length) calculated)) - (cons (push `(* ,byte-width ,length-var) calculated))))) - (if (null calculated) - constant - (list* '+ constant calculated)))) - - -(defun composite-args (argspecs) - (loop - for (name type length length-var) in argspecs - when (consp length) - collect (list length-var length))) - - -(defun make-setter-forms (argspecs) - (loop - for (name type length length-var) in argspecs - collecting `(progn - ,(if (and (numberp length) - (= 1 length)) - `(,(setter type) ,name .rbuf. .index.) - `(,(sequence-setter type) ,name .rbuf. .index. - ,(if length-var length-var length))) - (setf .index. (the array-index - (+ .index. - (the fixnum (* ,(byte-width type) - ,(if length-var length-var length))))))))) - - -(defmacro define-rendering-command (name opcode &rest args) - ;; FIXME: Must heavily type-annotate. - (labels ((expand-args (list) - (loop - for (arg type) in list - if (consp arg) - append (loop - for name in arg - collecting (list name type)) - else - collect (list arg type)))) - - (let* ((args (expand-args args)) - (argspecs (mapcar 'make-argspecs args)) - (total-byte-width (byte-width-calculation argspecs)) - (composite-args (composite-args argspecs))) - - `(defun ,name ,(mapcar #'first argspecs) - (declare ,@(mapcar #'(lambda (list) - (if (symbolp (second list)) - (list* 'type (reverse list)) - `(type sequence ,(first list)))) - args)) - #.(declare-buffun) - (assert (context-p *current-context*) - (*current-context*) - "*CURRENT-CONTEXT* is not set (~S)." *current-context*) - (let* ((.ctx. *current-context*) - (.index0. (context-index .ctx.)) - (.index. (+ .index0. 4)) - (.rbuf. (context-rbuf .ctx.)) - ,@composite-args - (.length. (+ 4 (* 4 (ceiling ,total-byte-width 4))))) - - (declare (type context .ctx.) - (type array-index .index. .index0.) - (type buffer-bytes .rbuf.) - ,@(mapcar #'(lambda (list) - `(type fixnum ,(first list))) - composite-args) - (type fixnum .length.)) - - (when (< (- (length .rbuf.) 8) - (+ .index. .length.)) - (error "Rendering command sequence too long. Implement automatic buffer flushing.")) - - (aset-card16 .length. .rbuf. (the array-index .index0.)) - (aset-card16 ,opcode .rbuf. (the array-index (+ .index0. 2))) - ,@(make-setter-forms argspecs) - (setf (context-index .ctx.) (the array-index (+ .index0. .length.)))))))) - -) ;; eval-when - - -;;; Command implementation. - - -(defun get-string (name) - (assert (context-p *current-context*) - (*current-context*) - "*CURRENT-CONTEXT* is not set (~S)." *current-context*) - (let* ((ctx *current-context*) - (display (context-display ctx))) - (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) - ((data +get-string+) - ;; *** This is CONTEXT-TAG - (card32 (context-tag ctx)) - ;; *** This is ENUM. - (card32 name)) - (let* ((length (card32-get 12)) - (bytes (sequence-get :format card8 - :result-type '(simple-array card8 (*)) - :index 32 - :length length))) - (declare (type (simple-array card8 (*)) bytes) - (type fixnum length)) - ;; FIXME: How does this interact with unicode? - (map-into (make-string (1- length)) #'code-char bytes))))) - - - - -;;; Rendering commands (in alphabetical order). - - -(define-rendering-command accum 137 - ;; *** ENUM - (op card32) - (value float32)) - - -(define-rendering-command active-texture-arb 197 - ;; *** ENUM - (texture card32)) - - -(define-rendering-command alpha-func 159 - ;; *** ENUM - (func card32) - (ref float32)) - - -(define-rendering-command begin 4 - ;; *** ENUM - (mode card32)) - - -(define-rendering-command bind-texture 4117 - ;; *** ENUM - (target card32) - (texture card32)) - - -(define-rendering-command blend-color 4096 - (red float32) - (green float32) - (blue float32) - (alpha float32)) - - -(define-rendering-command blend-equotion 4097 - ;; *** ENUM - (mode card32)) - - -(define-rendering-command blend-func 160 - ;; *** ENUM - (sfactor card32) - ;; *** ENUM - (dfactor card32)) - - -(define-rendering-command call-list 1 - (list card32)) - - -(define-rendering-command clear 127 - ;; *** BITFIELD - (mask card32)) - - -(define-rendering-command clear-accum 128 - (red float32) - (green float32) - (blue float32) - (alpha float32)) - - -(define-rendering-command clear-color 130 - (red float32) - (green float32) - (blue float32) - (alpha float32)) - - -(define-rendering-command clear-depth 132 - (depth float64)) - - -(define-rendering-command clear-index 129 - (c float32)) - - -(define-rendering-command clear-stencil 131 - (s int32)) - - -(define-rendering-command clip-plane 77 - (equotion-0 float64) - (equotion-1 float64) - (equotion-2 float64) - (equotion-3 float64) - ;; *** ENUM - (plane card32)) - - -(define-rendering-command color-3b 6 - ((r g b) int8)) - -(define-rendering-command color-3d 7 - ((r g b) float64)) - -(define-rendering-command color-3f 8 - ((r g b) float32)) - -(define-rendering-command color-3i 9 - ((r g b) int32)) - -(define-rendering-command color-3s 10 - ((r g b) int16)) - -(define-rendering-command color-3ub 11 - ((r g b) card8)) - -(define-rendering-command color-3ui 12 - ((r g b) card32)) - -(define-rendering-command color-3us 13 - ((r g b) card16)) - - -(define-rendering-command color-4b 14 - ((r g b a) int8)) - -(define-rendering-command color-4d 15 - ((r g b a) float64)) - -(define-rendering-command color-4f 16 - ((r g b a) float32)) - -(define-rendering-command color-4i 17 - ((r g b a) int32)) - -(define-rendering-command color-4s 18 - ((r g b a) int16)) - -(define-rendering-command color-4ub 19 - ((r g b a) card8)) - -(define-rendering-command color-4ui 20 - ((r g b a) card32)) - -(define-rendering-command color-4us 21 - ((r g b a) card16)) - - -(define-rendering-command color-mask 134 - (red bool) - (green bool) - (blue bool) - (alpha bool)) - - -(define-rendering-command color-material 78 - ;; *** ENUM - (face card32) - ;; *** ENUM - (mode card32)) - - -(define-rendering-command color-table-parameter-fv 2054 - ;; *** ENUM - (target card32) - ;; TODO: - ;; +GL-COLOR-TABLE-SCALE+ (#x80D6) => (length params) = 4 - ;; +GL-COLOR-TABLE-BIAS+ (#x80d7) => (length params) = 4 - ;; else (length params) = 0 (command is erronous) - ;; *** ENUM - (pname card32) - (params (list float32 4))) - - -(define-rendering-command color-table-parameter-iv 2055 - ;; *** ENUM - (target card32) - ;; TODO: - ;; +GL-COLOR-TABLE-SCALE+ (#x80D6) => (length params) = 4 - ;; +GL-COLOR-TABLE-BIAS+ (#x80d7) => (length params) = 4 - ;; else (length params) = 0 (command is erronous) - ;; *** ENUM - (pname card32) - (params (list int32 4))) - - -(define-rendering-command convolution-parameter-f 4103 - ;; *** ENUM - (target card32) - ;; *** ENUM - (pname card32) - (params float32)) - - -(define-rendering-command convolution-parameter-fv 4104 - ;; *** ENUM - (target card32) - ;; *** ENUM - (pname card32) - (params (list float32 (ecase pname - ((#.+convolution-border-mode+ - #.+convolution-format+ - #.+convolution-width+ - #.+convolution-height+ - #.+max-convolution-width+ - #.+max-convolution-width+) - 1) - ((#.+convolution-filter-scale+ - #.+convolution-filter-bias+) - 4))))) - - -(define-rendering-command convolution-parameter-i 4105 - ;; *** ENUM - (target card32) - ;; *** ENUM - (pname card32) - (params int32)) - - -(define-rendering-command convolution-parameter-iv 4106 - ;; *** ENUM - (target card32) - ;; *** ENUM - (pname card32) - (params (list int32 (ecase pname - ((#.+convolution-border-mode+ - #.+convolution-format+ - #.+convolution-width+ - #.+convolution-height+ - #.+max-convolution-width+ - #.+max-convolution-width+) - 1) - ((#.+convolution-filter-scale+ - #.+convolution-filter-bias+) - 4))))) - - -(define-rendering-command copy-color-sub-table 196 - ;; *** ENUM - (target card32) - (start int32) - (x int32) - (y int32) - (width int32)) - - -(define-rendering-command copy-color-table 2056 - ;; *** ENUM - (target card32) - ;; *** ENUM - (internalformat card32) - (x int32) - (y int32) - (width int32)) - - -(define-rendering-command copy-convolution-filter-id 4107 - ;; *** ENUM - (target card32) - ;; *** ENUM - (internalformat card32) - (x int32) - (y int32) - (width int32)) - - -(define-rendering-command copy-convolution-filter-2d 4108 - ;; *** ENUM - (target card32) - ;; *** ENUM - (internalformat card32) - (x int32) - (y int32) - (width int32) - (height int32)) - - -(define-rendering-command copy-pixels 172 - (x int32) - (y int32) - (width int32) - (height int32) - ;; *** ENUM - (type card32)) - - -(define-rendering-command copy-tex-image-1d 4119 - ;; *** ENUM - (target card32) - (level int32) - ;; *** ENUM - (internalformat card32) - (x int32) - (y int32) - (width int32) - (border int32)) - - -(define-rendering-command copy-tex-image-2d 4120 - ;; *** ENUM - (target card32) - (level int32) - ;; *** ENUM - (internalformat card32) - (x int32) - (y int32) - (width int32) - (height int32) - (border int32)) - - -(define-rendering-command copy-tex-sub-image-1d 4121 - ;; *** ENUM - (target card32) - (level int32) - (xoffset int32) - (x int32) - (y int32) - (width int32)) - - -(define-rendering-command copy-tex-sub-image-2d 4122 - ;; *** ENUM - (target card32) - (level int32) - (xoffset int32) - (yoffset int32) - (x int32) - (y int32) - (width int32) - (height int32)) - - -(define-rendering-command copy-tex-sub-image-3d 4123 - ;; *** ENUM - (target card32) - (level int32) - (xoffset int32) - (yoffset int32) - (zoffset int32) - (x int32) - (y int32) - (width int32) - (height int32)) - - -(define-rendering-command cull-face 79 - ;; *** ENUM - (mode card32)) - - -(define-rendering-command depth-func 164 - ;; *** ENUM - (func card32)) - - -(define-rendering-command depth-mask 135 - (mask bool)) - - -(define-rendering-command depth-range 174 - (z-near float64) - (z-far float64)) - - -(define-rendering-command draw-buffer 126 - ;; *** ENUM - (mode card32)) - - -(define-rendering-command edge-flag-v 22 - (flag-0 bool)) - - -(define-rendering-command end 23) - - -(define-rendering-command eval-coord-1d 151 - (u-0 float64)) - -(define-rendering-command eval-coord-1f 152 - (u-0 float32)) - - -(define-rendering-command eval-coord-2d 153 - ((u-0 u-1) float64)) - -(define-rendering-command eval-coord-2f 154 - ((u-0 u-1) float32)) - - -(define-rendering-command eval-mesh-1 155 - ;; *** ENUM - (mode card32) - ((i1 i2) int32)) - - -(define-rendering-command eval-mesh-2 157 - ;; *** ENUM - (mode card32) - ((i1 i2 j1 j2) int32)) - - -(define-rendering-command eval-point-1 156 - (i int32)) - - -(define-rendering-command eval-point-2 158 - (i int32) - (j int32)) - - -(define-rendering-command fog-f 80 - ;; *** ENUM - (pname card32) - (param float32)) - - -(define-rendering-command fog-fv 81 - ;; *** ENUM - (pname card32) - (params (list float32 (ecase pname - ((#.+fog-index+ - #.+fog-density+ - #.+fog-start+ - #.+fog-end+ - #.+fog-mode+) - 1) - ((#.+fog-color+) - 4))))) - - - -(define-rendering-command fog-i 82 - ;; *** ENUM - (pname card32) - (param int32)) - - -(define-rendering-command fog-iv 83 - ;; *** ENUM - (pname card32) - (params (list int32 (ecase pname - ((#.+fog-index+ - #.+fog-density+ - #.+fog-start+ - #.+fog-end+ - #.+fog-mode+) - 1) - ((#.+fog-color+) - 4))))) - - -(define-rendering-command front-face 84 - ;; *** ENUM - (mode card32)) - - -(define-rendering-command frustum 175 - (left float64) - (right float64) - (bottom float64) - (top float64) - (z-near float64) - (z-far float64)) - - -(define-rendering-command hint 85 - ;; *** ENUM - (target card32) - ;; *** ENUM - (mode card32)) - - -(define-rendering-command histogram 4110 - ;; *** ENUM - (target card32) - (width int32) - ;; *** ENUM - (internalformat card32) - (sink bool)) - - -(define-rendering-command index-mask 136 - (mask card32)) - - -(define-rendering-command index-d 24 - (c-0 float64)) - -(define-rendering-command index-f 25 - (c-0 float32)) - -(define-rendering-command index-i 26 - (c-0 int32)) - -(define-rendering-command index-s 27 - (c-0 int16)) - -(define-rendering-command index-ub 194 - (c-0 card8)) - - -(define-rendering-command init-names 121) - - -(define-rendering-command light-model-f 90 - ;; *** ENUM - (pname card32) - (param float32)) - - -(define-rendering-command light-model-fv 91 - ;; *** ENUM - (pname card32) - (params (list float32 (ecase pname - ((#.+light-model-color-control+ - #.+light-model-local-viewer+ - #.+light-model-two-side+) - 1) - ((#.+light-model-ambient+) - 4))))) - -(define-rendering-command light-model-i 92 - ;; *** ENUM - (pname card32) - (param int32)) - - -(define-rendering-command light-model-iv 93 - ;; *** ENUM - (pname card32) - (params (list int32 (ecase pname - ((#.+light-model-color-control+ - #.+light-model-local-viewer+ - #.+light-model-two-side+) - 1) - ((#.+light-model-ambient+) - 4))))) - - -(define-rendering-command light-f 86 - ;; *** ENUM - (light card32) - ;; *** ENUM - (pname card32) - (param float32)) - - -(define-rendering-command light-fv 87 - ;; *** ENUM - (light card32) - ;; *** ENUM - (pname card32) - (params (list float32 (ecase pname - ((#.+ambient+ - #.+diffuse+ - #.+specular+ - #.+position+) - 4) - ((#.+spot-direction+) - 3) - ((#.+spot-exponent+ - #.+spot-cutoff+ - #.+constant-attenuation+ - #.+linear-attenuation+ - #.+quadratic-attenuation+) - 1))))) - - -(define-rendering-command light-i 88 - ;; *** ENUM - (light card32) - ;; *** ENUM - (pname card32) - (param int32)) - - -(define-rendering-command light-iv 89 - ;; *** ENUM - (light card32) - ;; *** ENUM - (pname card32) - (params (list int32 (ecase pname - ((#.+ambient+ - #.+diffuse+ - #.+specular+ - #.+position+) - 4) - ((#.+spot-direction+) - 3) - ((#.+spot-exponent+ - #.+spot-cutoff+ - #.+constant-attenuation+ - #.+linear-attenuation+ - #.+quadratic-attenuation+) - 1))))) - - -(define-rendering-command line-stipple 94 - (factor int32) - (pattern card16)) - - -(define-rendering-command line-width 95 - (width float32)) - - -(define-rendering-command list-base 3 - (base card32)) - - -(define-rendering-command load-identity 176) - - -(define-rendering-command load-matrix-d 178 - (m (list float64 16))) - - -(define-rendering-command load-matrix-f 177 - (m (list float32 16))) - - -(define-rendering-command load-name 122 - (name card32)) - - -(define-rendering-command logic-op 161 - ;; *** ENUM - (name card32)) - - -(define-rendering-command map-grid-1d 147 - (u1 float64) - (u2 float64) - (un int32)) - -(define-rendering-command map-grid-1f 148 - (un int32) - (u1 float32) - (u2 float32)) - - -(define-rendering-command map-grid-2d 149 - (u1 float64) - (u2 float64) - (v1 float64) - (v2 float64) - (un int32) - (vn int32)) - - -(define-rendering-command map-grid-2f 150 - (un int32) - (u1 float32) - (u2 float32) - (vn int32) - (v1 float32) - (v2 float32)) - - -(define-rendering-command material-f 96 - ;; *** ENUM - (face card32) - ;; *** ENUM - (pname card32) - (param float32)) - - -(define-rendering-command material-fv 97 - ;; *** ENUM - (face card32) - ;; *** ENUM - (pname card32) - (params (list float32 (ecase pname - ((#.+ambient+ - #.+diffuse+ - #.+specular+ - #.+emission+ - #.+ambient-and-diffuse+) - 4) - ((#.+shininess+) - 1) - ((#.+color-index+) - 3))))) - - -(define-rendering-command material-i 98 - ;; *** ENUM - (face card32) - ;; *** ENUM - (pname card32) - (param int32)) - - -(define-rendering-command material-iv 99 - ;; *** ENUM - (face card32) - ;; *** ENUM - (pname card32) - (params (list int32 (ecase pname - ((#.+ambient+ - #.+diffuse+ - #.+specular+ - #.+emission+ - #.+ambient-and-diffuse+) - 4) - ((#.+shininess+) - 1) - ((#.+color-index+) - 3))))) - - -(define-rendering-command matrix-mode 179 - ;; *** ENUM - (mode card32)) - - -(define-rendering-command minmax 4111 - ;; *** ENUM - (target card32) - ;; *** ENUM - (internalformat card32) - (sink bool)) - - -(define-rendering-command mult-matrix-d 181 - (m (list float64 16))) - - -(define-rendering-command mult-matrix-f 180 - (m (list float32 16))) - - -;;; *** Note that TARGET is placed last for FLOAT64 versions. -(define-rendering-command multi-tex-coord-1d-arb 198 - (v-0 float64) - ;; *** ENUM - (target card32)) - -(define-rendering-command multi-tex-coord-1f-arb 199 - ;; *** ENUM - (target card32) - (v-0 float32)) - -(define-rendering-command multi-tex-coord-1i-arb 200 - ;; *** ENUM - (target card32) - (v-0 int32)) - -(define-rendering-command multi-tex-coord-1s-arb 201 - ;; *** ENUM - (target card32) - (v-0 int16)) - - -(define-rendering-command multi-tex-coord-2d-arb 202 - ((v-0 v-1) float64) - ;; *** ENUM - (target card32)) - -(define-rendering-command multi-tex-coord-2f-arb 203 - ;; *** ENUM - (target card32) - ((v-0 v-1) float32)) - -(define-rendering-command multi-tex-coord-2i-arb 204 - ;; *** ENUM - (target card32) - ((v-0 v-1) int32)) - -(define-rendering-command multi-tex-coord-2s-arb 205 - ;; *** ENUM - (target card32) - ((v-0 v-1) int16)) - - -(define-rendering-command multi-tex-coord-3d-arb 206 - ((v-0 v-1 v-2) float64) - ;; *** ENUM - (target card32)) - -(define-rendering-command multi-tex-coord-3f-arb 207 - ;; *** ENUM - (target card32) - ((v-0 v-1 v-2) float32)) - -(define-rendering-command multi-tex-coord-3i-arb 208 - ;; *** ENUM - (target card32) - ((v-0 v-1 v-2) int32)) - -(define-rendering-command multi-tex-coord-3s-arb 209 - ;; *** ENUM - (target card32) - ((v-0 v-1 v-2) int16)) - - -(define-rendering-command multi-tex-coord-4d-arb 210 - ((v-0 v-1 v-2 v-3) float64) - ;; *** ENUM - (target card32)) - -(define-rendering-command multi-tex-coord-4f-arb 211 - ;; *** ENUM - (target card32) - ((v-0 v-1 v-2 v-3) float32)) - -(define-rendering-command multi-tex-coord-4i-arb 212 - ;; *** ENUM - (target card32) - ((v-0 v-1 v-2 v-3) int32)) - -(define-rendering-command multi-tex-coord-4s-arb 213 - ;; *** ENUM - (target card32) - ((v-0 v-1 v-2 v-3) int16)) - - -(define-rendering-command normal-3b 28 - ((v-0 v-1 v-2) int8)) - -(define-rendering-command normal-3d 29 - ((v-0 v-1 v-2) float64)) - -(define-rendering-command normal-3f 30 - ((v-0 v-1 v-2) float32)) - -(define-rendering-command normal-3i 31 - ((v-0 v-1 v-2) int32)) - -(define-rendering-command normal-3s 32 - ((v-0 v-1 v-2) int16)) - - -(define-rendering-command ortho 182 - (left float64) - (right float64) - (bottom float64) - (top float64) - (z-near float64) - (z-far float64)) - - -(define-rendering-command pass-through 123 - (token float32)) - - -(define-rendering-command pixel-transfer-f 166 - ;; *** ENUM - (pname card32) - (param float32)) - - -(define-rendering-command pixel-transfer-i 167 - ;; *** ENUM - (pname card32) - (param int32)) - - -(define-rendering-command pixel-zoom 165 - (xfactor float32) - (yfactor float32)) - - -(define-rendering-command point-size 100 - (size float32)) - - -(define-rendering-command polygon-mode 101 - ;; *** ENUM - (face card32) - ;; *** ENUM - (mode card32)) - - -(define-rendering-command polygon-offset 192 - (factor float32) - (units float32)) - - -(define-rendering-command pop-attrib 141) - - -(define-rendering-command pop-matrix 183) - - -(define-rendering-command pop-name 124) - - -(define-rendering-command prioritize-textures 4118 - (n int32) - (textures (list card32 n)) - (priorities (list float32 n))) - - -(define-rendering-command push-attrib 142 - ;; *** BITFIELD - (mask card32)) - - -(define-rendering-command push-matrix 184) - - -(define-rendering-command push-name 125 - (name card32)) - - -(define-rendering-command raster-pos-2d 33 - ((v-0 v-1) float64)) - -(define-rendering-command raster-pos-2f 34 - ((v-0 v-1) float32)) - -(define-rendering-command raster-pos-2i 35 - ((v-0 v-1) int32)) - -(define-rendering-command raster-pos-2s 36 - ((v-0 v-1) int16)) - - -(define-rendering-command raster-pos-3d 37 - ((v-0 v-1 v-2) float64)) - -(define-rendering-command raster-pos-3f 38 - ((v-0 v-1 v-2) float32)) - -(define-rendering-command raster-pos-3i 39 - ((v-0 v-1 v-2) int32)) - -(define-rendering-command raster-pos-3s 40 - ((v-0 v-1 v-2) int16)) - - -(define-rendering-command raster-pos-4d 41 - ((v-0 v-1 v-2 v-3) float64)) - -(define-rendering-command raster-pos-4f 42 - ((v-0 v-1 v-2 v-3) float32)) - -(define-rendering-command raster-pos-4i 43 - ((v-0 v-1 v-2 v-3) int32)) - -(define-rendering-command raster-pos-4s 44 - ((v-0 v-1 v-2 v-3) int16)) - - -(define-rendering-command read-buffer 171 - ;; *** ENUM - (mode card32)) - - -(define-rendering-command rect-d 45 - ((v1-0 v1-1 v2-0 v2-1) float64)) - -(define-rendering-command rect-f 46 - ((v1-0 v1-1 v2-0 v2-1) float32)) - -(define-rendering-command rect-i 47 - ((v1-0 v1-1 v2-0 v2-1) int32)) - -(define-rendering-command rect-s 48 - ((v1-0 v1-1 v2-0 v2-1) int16)) - - -(define-rendering-command reset-histogram 4112 - ;; *** ENUM - (target card32)) - - -(define-rendering-command reset-minmax 4113 - ;; *** ENUM - (target card32)) - - -(define-rendering-command rotate-d 185 - ((angle x y z) float64)) - - -(define-rendering-command rotate-f 186 - ((angle x y z) float32)) - - -(define-rendering-command scale-d 187 - ((x y z) float64)) - - -(define-rendering-command scale-f 188 - ((x y z) float32)) - - -(define-rendering-command scissor 103 - ((x y width height) int32)) - - -(define-rendering-command shade-model 104 - ;; *** ENUM - (mode card32)) - - -(define-rendering-command stencil-func 162 - ;; *** ENUM - (func card32) - (ref int32) - (mask card32)) - - -(define-rendering-command stencil-mask 133 - (mask card32)) - - -(define-rendering-command stencil-op 163 - ;; *** ENUM - (fail card32) - ;; *** ENUM - (zfail card32) - ;; *** ENUM - (zpass card32)) - - -(define-rendering-command tex-env-f 111 - ;; *** ENUM - (target card32) - ;; *** ENUM - (pname card32) - (param float32)) - - -(define-rendering-command tex-env-fv 112 - ;; *** ENUM - (target card32) - ;; *** ENUM - (pname card32) - (param (list float32 (ecase pname - (#.+texture-env-mode+ 1) - (#.+texture-env-color+ 4))))) - - -(define-rendering-command tex-env-i 113 - ;; *** ENUM - (target card32) - ;; *** ENUM - (pname card32) - (param int32)) - - -(define-rendering-command tex-env-iv 114 - ;; *** ENUM - (target card32) - ;; *** ENUM - (pname card32) - (param (list int32 (ecase pname - (#.+texture-env-mode+ 1) - (#.+texture-env-color+ 4))))) - - -;;; *** -;;; last there. -(define-rendering-command tex-gen-d 115 - (param float64) - ;; *** ENUM - (coord card32) - ;; *** ENUM - (pname card32)) - - -(define-rendering-command tex-gen-dv 116 - ;; *** ENUM - (coord card32) - ;; *** ENUM - (pname card32) - ;; +texture-gen-mode+ n=1 - ;; +object-plane+ n=4 - ;; +eye-plane+ n=1 - (params (list float64 (ecase pname - ((#.+texture-gen-mode+ #.+eye-plane+) 1) - (#.+object-plane+ 4))))) - - -(define-rendering-command tex-gen-f 117 - ;; *** ENUM - (coord card32) - ;; *** ENUM - (pname card32) - (param float32)) - - -(define-rendering-command tex-gen-fv 118 - ;; *** ENUM - (coord card32) - ;; *** ENUM - (pname card32) - (params (list float32 (ecase pname - ((#.+texture-gen-mode+ #.+eye-plane+) 1) - (#.+object-plane+ 4))))) - - -(define-rendering-command tex-gen-i 119 - ;; *** ENUM - (coord card32) - ;; *** ENUM - (pname card32) - (param int32)) - - -(define-rendering-command tex-gen-iv 120 - ;; *** ENUM - (coord card32) - ;; *** ENUM - (pname card32) - (params (list int32 (ecase pname - ((#.+texture-gen-mode+ #.+eye-plane+) 1) - (#.+object-plane+ 4))))) - - -(define-rendering-command tex-parameter-f 105 - ;; *** ENUM - (target card32) - ;; *** ENUM - (pname card32) - (param float32)) - - -(define-rendering-command tex-parameter-fv 106 - ;; *** ENUM - (target card32) - ;; *** ENUM - (pname card32) - (params (list float32 (ecase pname - ((#.+texture-border-color+) - 4) - ((#.+texture-mag-filter+ - #.+texture-min-filter+ - #.+texture-wrap-s+ - #.+texture-wrap-t+) - 1))))) - - -(define-rendering-command tex-parameter-i 107 - ;; *** ENUM - (target card32) - ;; *** ENUM - (pname card32) - (param int32)) - - -(define-rendering-command tex-parameter-iv 108 - ;; *** ENUM - (target card32) - ;; *** ENUM - (pname card32) - (params (list int32 (ecase pname - ((#.+texture-border-color+) - 4) - ((#.+texture-mag-filter+ - #.+texture-min-filter+ - #.+texture-wrap-s+ - #.+texture-wrap-t+) - 1))))) - - -(define-rendering-command translate-d 189 - ((x y z) float64)) - -(define-rendering-command translate-f 190 - ((x y z) float32)) - - -(define-rendering-command vertex-2d 65 - ((x y) float64)) - -(define-rendering-command vertex-2f 66 - ((x y) float32)) - -(define-rendering-command vertex-2i 67 - ((x y) int32)) - -(define-rendering-command vertex-2s 68 - ((x y) int16)) - - -(define-rendering-command vertex-3d 69 - ((x y z) float64)) - -(define-rendering-command vertex-3f 70 - ((x y z) float32)) - -(define-rendering-command vertex-3i 71 - ((x y z) int32)) - -(define-rendering-command vertex-3s 72 - ((x y z) int16)) - - -(define-rendering-command vertex-4d 73 - ((x y z w) float64)) - -(define-rendering-command vertex-4f 74 - ((x y z w) float32)) - -(define-rendering-command vertex-4i 75 - ((x y z w) int32)) - -(define-rendering-command vertex-4s 76 - ((x y z w) int16)) - - -(define-rendering-command viewport 191 - ((x y width height) int32)) - - -;;; Potentially lerge rendering commands. - - -#-(and) -(define-large-rendering-command call-lists 2 - (n int32) - ;; *** ENUM - (type card32) - (lists (list type n))) - - - -;;; Requests for GL non-rendering commands. - -(defun new-list (list mode) - (assert (context-p *current-context*) - (*current-context*) - "~S is not a context." *current-context*) - (let* ((ctx *current-context*) - (display (context-display ctx))) - (with-buffer-request (display (extension-opcode display "GLX")) - (data +new-list+) - ;; *** GLX_CONTEXT_TAG - (card32 (context-tag ctx)) - (card32 list) - ;; *** ENUM - (card32 mode)))) - - -(defun gen-lists (range) - (assert (context-p *current-context*) - (*current-context*) - "~S is not a context." *current-context*) - (let* ((ctx *current-context*) - (display (context-display ctx))) - (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) - ((data +gen-lists+) - ;; *** GLX_CONTEXT_TAG - (card32 (context-tag ctx)) - (integer range)) - (card32-get 8)))) - - -(defun end-list () - (assert (context-p *current-context*) - (*current-context*) - "~S is not a context." *current-context*) - (let* ((ctx *current-context*) - (display (context-display ctx))) - (with-buffer-request (display (extension-opcode display "GLX")) - (data +end-list+) - ;; *** GLX_CONTEXT_TAG - (card32 (context-tag ctx))))) - - -(defun enable (cap) - (assert (context-p *current-context*) - (*current-context*) - "~S is not a context." *current-context*) - (let* ((ctx *current-context*) - (display (context-display ctx))) - (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) - ((data +enable+) - ;; *** GLX_CONTEXT_TAG - (card32 (context-tag ctx)) - ;; *** ENUM? - (card32 cap))))) - - -;;; FIXME: FLUSH and FINISH should send *all* buffered data, including -;;; buffered rendering commands. -(defun flush () - (assert (context-p *current-context*) - (*current-context*) - "~S is not a context." *current-context*) - (let* ((ctx *current-context*) - (display (context-display ctx))) - (with-buffer-request (display (extension-opcode display "GLX")) - (data +flush+) - ;; *** GLX_CONTEXT_TAG - (card32 (context-tag ctx))))) - - -(defun finish () - (assert (context-p *current-context*) - (*current-context*) - "~S is not a context." *current-context*) - (let* ((ctx *current-context*) - (display (context-display ctx))) - (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) - ((data +finish+) - ;; *** GLX_CONTEXT_TAG - (card32 (context-tag ctx)))))) diff -Nru ecl-16.1.2/src/clx/glx.lisp ecl-16.1.3+ds/src/clx/glx.lisp --- ecl-16.1.2/src/clx/glx.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/glx.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,632 +0,0 @@ -(defpackage :glx - (:use :common-lisp :xlib) - (:import-from :xlib - "DEFINE-ACCESSOR" - "DEF-CLX-CLASS" - "DECLARE-EVENT" - "ALLOCATE-RESOURCE-ID" - "DEALLOCATE-RESOURCE-ID" - "PRINT-DISPLAY-NAME" - "WITH-BUFFER-REQUEST" - "WITH-BUFFER-REQUEST-AND-REPLY" - "READ-CARD32" - "WRITE-CARD32" - "CARD32-GET" - "CARD8-GET" - "SEQUENCE-GET" - "SEQUENCE-PUT" - "DATA" - - ;; Types - "ARRAY-INDEX" - "BUFFER-BYTES" - - "WITH-DISPLAY" - "BUFFER-FLUSH" - "BUFFER-WRITE" - "BUFFER-FORCE-OUTPUT" - "ASET-CARD8" - "ASET-CARD16" - "ASET-CARD32" - ) - (:export ;; Constants - "+VENDOR+" - "+VERSION+" - "+EXTENSIONS+" - - ;; Conditions - "BAD-CONTEXT" - "BAD-CONTEXT-STATE" - "BAD-DRAWABLE" - "BAD-PIXMAP" - "BAD-CONTEXT-TAG" - "BAD-CURRENT-WINDOW" - "BAD-RENDER-REQUEST" - "BAD-LARGE-REQUEST" - "UNSUPPORTED-PRIVATE-REQUEST" - "BAD-FB-CONFIG" - "BAD-PBUFFER" - "BAD-CURRENT-DRAWABLE" - "BAD-WINDOW" - - ;; Requests - "QUERY-VERSION" - "QUERY-SERVER-STRING" - "CREATE-CONTEXT" - "DESTROY-CONTEXT" - "IS-DIRECT" - "QUERY-CONTEXT" - "GET-DRAWABLE-ATTRIBUTES" - "MAKE-CURRENT" - ;;"GET-VISUAL-CONFIGS" - "CHOOSE-VISUAL" - "VISUAL-ATTRIBUTE" - "VISUAL-ID" - "RENDER" - "SWAP-BUFFERS" - "WAIT-GL" - "WAIT-X" - )) - - -(in-package :glx) - - -(declaim (optimize (debug 3) (safety 3))) - - -(define-extension "GLX" - :events (:glx-pbuffer-clobber) - :errors (bad-context - bad-context-state - bad-drawable - bad-pixmap - bad-context-tag - bad-current-window - bad-render-request - bad-large-request - unsupported-private-request - bad-fb-config - bad-pbuffer - bad-current-drawable - bad-window)) - - -;;; Opcodes. - -(eval-when (:compile-toplevel :load-toplevel :execute) -(defconstant +render+ 1) -(defconstant +create-context+ 3) -(defconstant +destroy-context+ 4) -(defconstant +make-current+ 5) -(defconstant +is-direct+ 6) -(defconstant +query-version+ 7) -(defconstant +wait-gl+ 8) -(defconstant +wait-x+ 9) -(defconstant +copy-context+ 10) -(defconstant +swap-buffers+ 11) -(defconstant +get-visual-configs+ 14) -(defconstant +destroy-glx-pixmap+ 15) -(defconstant +query-server-string+ 19) -(defconstant +client-info+ 20) -(defconstant +get-fb-configs+ 21) -(defconstant +query-context+ 25) -(defconstant +get-drawable-attributes+ 29) -) - - -;;; Constants - -(eval-when (:compile-toplevel :load-toplevel :execute) -(defconstant +vendor+ 1) -(defconstant +version+ 2) -(defconstant +extensions+ 3) -) - - -;;; Types - -;;; FIXME: -;;; - Are all the 32-bit values unsigned? Do we care? -;;; - These are not used much, yet. -(progn - (deftype attribute-pair ()) - (deftype bitfield () 'mask32) - (deftype bool32 () 'card32) ; 1 for true and 0 for false - (deftype enum () 'card32) - (deftype fbconfigid () 'card32) - ;; FIXME: How to define these two? - (deftype float32 () 'single-float) - (deftype float64 () 'double-float) - ;;(deftype glx-context () 'card32) - (deftype context-tag () 'card32) - ;;(deftype glx-drawable () 'card32) - (deftype glx-pixmap () 'card32) - (deftype glx-pbuffer () 'card32) - (deftype glx-render-command () #|TODO|#) - (deftype glx-window () 'card32) - #-(and) - (deftype visual-property () - "An ordered list of 32-bit property values followed by unordered pairs of -property types and property values." - ;; FIXME: maybe CLX-LIST or even just LIST? - 'clx-sequence)) - - -;;; FIXME: DEFINE-ACCESSOR interns getter and setter in XLIB package -;;; (using XINTERN). Therefore the accessors defined below can only -;;; be accessed using double-colon, which is a bad style. Or these -;;; forms must be taken to another file so the accessors exist before -;;; we get to this file. - -#-(and) -(define-accessor glx-context-tag (32) - ((index) `(read-card32 ,index)) - ((index thing) `(write-card32 ,index ,thing))) - -#-(and) -(define-accessor glx-enum (32) - ((index) `(read-card32 ,index)) - ((index thing) `(write-card32 ,index ,thing))) - - -;;; FIXME: I'm just not sure we need a seperate accessors for what -;;; essentially are aliases for other types. Maybe use compiler -;;; macros? -;;; -;;; This trick won't do because CLX wants e.g. CONTEXT-TAG to be a -;;; known accessor. The only trick left I think is to change the -;;; XINTERN function to intern the new symbols in the same package as -;;; he symbol part of it comes from. Don't know if it would break -;;; anything, thought. (I would be quite surprised if it did -- there -;;; is only one package in CLX after all: XLIB.) -;;; -;;; I also found the origin of the error (about symbol not being a -;;; known accessor): INDEX-INCREMENT function. Looks like all we have -;;; to do is to add an XLIB::BYTE-WIDTH property to the type symbol -;;; plist. But accessors are macros, not functions, anyway. - -#-(and) -(progn - (declaim (inline context-tag-get context-tag-put enum-get enum-put)) - (defun context-tag-get (index) (card32-get index)) - (defun context-tag-put (index thing) (card32-put index thing)) - (defun enum-get (index) (card32-get index)) - (defun enum-put (index thing) (card32-put index thing)) -) - - -;;; Structures - - -(def-clx-class (context (:constructor %make-context) - (:print-function print-context) - (:copier nil)) - (id 0 :type resource-id) - (display nil :type (or null display)) - (tag 0 :type card32) - (drawable nil :type (or null drawable)) - ;; TODO: There can only be one current context (as far as I - ;; understand). If so, we'd need only one buffer (otherwise it's a - ;; big waste to have a quarter megabyte buffer for each context; or - ;; we could allocate/grow the buffer on demand). - ;; - ;; 256k buffer for Render command. Big requests are served with - ;; RenderLarge command. First 8 octets are Render request fields. - ;; - (rbuf (make-array (+ 8 (* 256 1024)) :element-type '(unsigned-byte 8)) :type buffer-bytes) - ;; Index into RBUF where the next rendering command should be inserted. - (index 8 :type array-index)) - - -(defun print-context (ctx stream depth) - (declare (type context ctx) - (ignore depth)) - (print-unreadable-object (ctx stream :type t) - (print-display-name (context-display ctx) stream) - (write-string " " stream) - (princ (context-id ctx) stream))) - - -(def-clx-class (visual (:constructor %make-visual) - (:print-function print-visual) - (:copier nil)) - (id 0 :type resource-id) - (attributes nil :type list)) - - -(defun print-visual (visual stream depth) - (declare (type visual visual) - (ignore depth)) - (print-unreadable-object (visual stream :type t) - (write-string "ID: " stream) - (princ (visual-id visual) stream) - (write-string " " stream) - (princ (visual-attributes visual) stream))) - - - -;;; Events. - -(defconstant +damaged+ #x8017) -(defconstant +saved+ #x8018) -(defconstant +window+ #x8019) -(defconstant +pbuffer+ #x801a) - - -(declare-event :glx-pbuffer-clobber - (card16 sequence) - (card16 event-type) ;; +DAMAGED+ or +SAVED+ - (card16 draw-type) ;; +WINDOW+ or +PBUFFER+ - (resource-id drawable) - ;; FIXME: (bitfield buffer-mask) - (card32 buffer-mask) - (card16 aux-buffer) - (card16 x y width height count)) - - - -;;; Errors. - -(define-condition bad-context (request-error) ()) -(define-condition bad-context-state (request-error) ()) -(define-condition bad-drawable (request-error) ()) -(define-condition bad-pixmap (request-error) ()) -(define-condition bad-context-tag (request-error) ()) -(define-condition bad-current-window (request-error) ()) -(define-condition bad-render-request (request-error) ()) -(define-condition bad-large-request (request-error) ()) -(define-condition unsupported-private-request (request-error) ()) -(define-condition bad-fb-config (request-error) ()) -(define-condition bad-pbuffer (request-error) ()) -(define-condition bad-current-drawable (request-error) ()) -(define-condition bad-window (request-error) ()) - -(define-error bad-context decode-core-error) -(define-error bad-context-state decode-core-error) -(define-error bad-drawable decode-core-error) -(define-error bad-pixmap decode-core-error) -(define-error bad-context-tag decode-core-error) -(define-error bad-current-window decode-core-error) -(define-error bad-render-request decode-core-error) -(define-error bad-large-request decode-core-error) -(define-error unsupported-private-request decode-core-error) -(define-error bad-fb-config decode-core-error) -(define-error bad-pbuffer decode-core-error) -(define-error bad-current-drawable decode-core-error) -(define-error bad-window decode-core-error) - - - -;;; Requests. - - -(defun query-version (display) - (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) - ((data +query-version+) - (card32 1) - (card32 3)) - (values - (card32-get 8) - (card32-get 12)))) - - -(defun query-server-string (display screen name) - "NAME is one of +VENDOR+, +VERSION+ or +EXTENSIONS+" - (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) - ((data +query-server-string+) - (card32 (or (position screen (display-roots display) :test #'eq) 0)) - (card32 name)) - (let* ((length (card32-get 12)) - (bytes (sequence-get :format card8 - :result-type '(simple-array card8 (*)) - :index 32 - :length length))) - (declare (type (simple-array card8 (*)) bytes) - (type fixnum length)) - (map-into (make-string (1- length)) #'code-char bytes)))) - - -(defun client-info (display) - ;; TODO: This should be invoked automatically when using this - ;; library in initialization stage. - ;; - ;; TODO: No extensions supported yet. - ;; - ;; *** Maybe the LENGTH field must be filled in some special way - ;; (similar to data)? - (with-buffer-request (display (extension-opcode display "GLX")) - (data +client-info+) - (card32 4) ; length of the request - (card32 1) ; major - (card32 3) ; minor - (card32 0) ; n - )) - - -;;; XXX: This looks like an internal thing. Should name appropriately. -(defun make-context (display) - (let ((ctx (%make-context :display display))) - (setf (context-id ctx) - (allocate-resource-id display ctx 'context)) - ;; Prepare render request buffer. - ctx)) - - -(defun create-context (screen visual - &optional - (share-list 0) - (is-direct nil)) - "Do NOT use the direct mode, yet!" - (let* ((root (screen-root screen)) - (display (drawable-display root)) - (ctx (make-context display))) - (with-buffer-request (display (extension-opcode display "GLX")) - (data +create-context+) - (resource-id (context-id ctx)) - (resource-id visual) - (card32 (or (position screen (display-roots display) :test #'eq) 0)) - (resource-id share-list) - (boolean is-direct)) - ctx)) - - -;;; TODO: Maybe make this var private to GLX-MAKE-CURRENT and GLX-GET-CURRENT-CONTEXT only? -;;; -(defvar *current-context* nil) - - -(defun destroy-context (ctx) - (let ((id (context-id ctx)) - (display (context-display ctx))) - (with-buffer-request (display (extension-opcode display "GLX")) - (data +destroy-context+) - (resource-id id)) - (deallocate-resource-id display id 'context) - (setf (context-id ctx) 0) - (when (eq ctx *current-context*) - (setf *current-context* nil)))) - - -(defun is-direct (ctx) - (let ((display (context-display ctx))) - (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) - ((data +is-direct+) - (resource-id (context-id ctx))) - (card8-get 8)))) - - -(defun query-context (ctx) - ;; TODO: What are the attribute types? - (let ((display (context-display ctx))) - (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) - ((data +query-context+) - (resource-id (context-id ctx))) - (let ((num-attributes (card32-get 8))) - ;; FIXME: Is this really so? - (declare (type fixnum num-attributes)) - (loop - repeat num-attributes - for i fixnum upfrom 32 by 8 - collecting (cons (card32-get i) - (card32-get (+ i 4)))))))) - - -(defun get-drawable-attributes (drawable) - (let ((display (drawable-display drawable))) - (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) - ((data +get-drawable-attributes+) - (drawable drawable)) - (let ((num-attributes (card32-get 8))) - ;; FIXME: Is this really so? - (declare (type fixnum num-attributes)) - (loop - repeat num-attributes - for i fixnum upfrom 32 by 8 - collecting (cons (card32-get i) - (card32-get (+ i 4)))))))) - - -;;; TODO: What is the idea behind passing drawable to this function? -;;; Can a context be made current for different drawables at different -;;; times? (Man page on glXMakeCurrent says that context's viewport -;;; is set to the size of drawable when creating; it does not change -;;; afterwards.) -;;; -(defun make-current (drawable ctx) - (let ((display (drawable-display drawable)) - (old-tag (if *current-context* (context-tag *current-context*) 0))) - (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) - ((data +make-current+) - (resource-id (drawable-id drawable)) - (resource-id (context-id ctx)) - ;; *** CARD32 is really a CONTEXT-TAG - (card32 old-tag)) - (let ((new-tag (card32-get 8))) - (setf (context-tag ctx) new-tag - (context-drawable ctx) drawable - (context-display ctx) display - *current-context* ctx))))) - - -;;; FIXME: Decide how to represent and use these. -(eval-when (:load-toplevel :compile-toplevel :execute) - (macrolet ((generate-config-properties () - (let ((list '((:glx-visual visual-id) - (:glx-class card32) - (:glx-rgba bool32) - (:glx-red-size card32) - (:glx-green-size card32) - (:glx-blue-size card32) - (:glx-alpha-size card32) - (:glx-accum-red-size card32) - (:glx-accum-green-size card32) - (:glx-accum-blue-size card32) - (:glx-accum-alpha-size card32) - (:glx-double-buffer bool32) - (:glx-stereo bool32) - (:glx-buffer-size card32) - (:glx-depth-size card32) - (:glx-stencil-size card32) - (:glx-aux-buffers card32) - (:glx-level int32)))) - `(progn - ,@(loop for (symbol type) in list - collect `(setf (get ',symbol 'visual-config-property-type) ',type)) - (defparameter *visual-config-properties* - (map 'vector #'car ',list)) - (declaim (type simple-vector *visual-config-properties*)) - (deftype visual-config-property () - '(member ,@(mapcar #'car list))))))) - (generate-config-properties))) - - -(defun make-visual (attributes) - (let ((id-cons (first attributes))) - (assert (eq :glx-visual (car id-cons)) - (id-cons) - "GLX visual id must be first in attributes list!") - (%make-visual :id (cdr id-cons) - :attributes (rest attributes)))) - - -(defun visual-attribute (visual attribute) - (assert (or (numberp attribute) - (find attribute *visual-config-properties*)) - (attribute) - "~S is not a known GLX visual attribute." attribute) - (cdr (assoc attribute (visual-attributes visual)))) - - -;;; TODO: Make this return nice structured objects with field values of correct type. -;;; FIXME: Looks like every other result is corrupted. -(defun get-visual-configs (screen) - (let ((display (drawable-display (screen-root screen)))) - (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) - ((data +get-visual-configs+) - (card32 (or (position screen (display-roots display) :test #'eq) 0))) - (let* ((num-visuals (card32-get 8)) - (num-properties (card32-get 12)) - (num-ordered (length *visual-config-properties*))) - ;; FIXME: Is this really so? - (declare (type fixnum num-ordered num-visuals num-properties)) - (loop - with index fixnum = 28 - repeat num-visuals - collecting (make-visual - (nconc (when (<= num-ordered num-properties) - (map 'list #'(lambda (property) - (cons property (card32-get (incf index 4)))) - *visual-config-properties*)) - (when (< num-ordered num-properties) - (loop repeat (/ (- num-properties num-ordered) 2) - collecting (cons (card32-get (incf index 4)) - (card32-get (incf index 4)))))))))))) - - -(defun choose-visual (screen attributes) - "ATTRIBUTES is a list of desired attributes for a visual. The elements may be -either a symbol, which means that the boolean attribute with that name must be true; or -it can be a list of the form: (attribute-name value &optional (test '<=)) which means that -the attribute named attribute-name must satisfy the test when applied to the given value and -attribute's value in visual. -Example: '(:glx-rgba (:glx-alpha-size 4) :glx-double-buffer (:glx-class 4 =)." - ;; TODO: Add type checks - ;; - ;; TODO: This function checks only supplied attributes; should check - ;; all attributes, with default for boolean type being false, and - ;; for number types zero. - ;; - ;; TODO: Make this smarter, like the docstring says, instead of - ;; parrotting the inflexible C API. - ;; - (flet ((visual-matches-p (visual attributes) - (dolist (attribute attributes t) - (etypecase attribute - (symbol (not (null (visual-attribute visual attribute)))) - (cons (<= (second attribute) (visual-attribute visual (car attribute)))))))) - (let* ((visuals (get-visual-configs screen)) - (candidates (loop - for visual in visuals - when (visual-matches-p visual attributes) - collect visual)) - (result (first candidates))) - - (dolist (candidate (rest candidates)) - ;; Visuals with glx-class 3 (pseudo-color) and 4 (true-color) - ;; are preferred over glx-class 2 (static-color) and 5 (direct-color). - (let ((class (visual-attribute candidate :glx-class))) - (when (or (= class 3) - (= class 4)) - (setf result candidate)))) - result))) - - -(defun render () - (declare (optimize (debug 3))) - (assert (context-p *current-context*) - (*current-context*) - "~S is not a context." *current-context*) - (let* ((ctx *current-context*) - (display (context-display ctx)) - (rbuf (context-rbuf ctx)) - (index (context-index ctx))) - (declare (type buffer-bytes rbuf) - (type array-index index)) - (when (< 8 index) - (with-display (display) - ;; Flush display's buffer first so we don't get messed up with X requests. - (buffer-flush display) - ;; First, update the Render request fields. - (aset-card8 (extension-opcode display "GLX") rbuf 0) - (aset-card8 1 rbuf 1) - (aset-card16 (ceiling index 4) rbuf 2) - (aset-card32 (context-tag ctx) rbuf 4) - ;; Then send the request. - (buffer-write rbuf display 0 (context-index ctx)) - ;; Start filling from the beginning - (setf (context-index ctx) 8))) - (values))) - - -(defun swap-buffers () - (assert (context-p *current-context*) - (*current-context*) - "~S is not a context." *current-context*) - (let* ((ctx *current-context*) - (display (context-display ctx))) - ;; Make sure all rendering commands are sent away. - (glx:render) - (with-buffer-request (display (extension-opcode display "GLX")) - (data +swap-buffers+) - ;; *** GLX_CONTEXT_TAG - (card32 (context-tag ctx)) - (resource-id (drawable-id (context-drawable ctx)))) - (display-force-output display))) - - -;;; FIXME: These two are more complicated than sending messages. As I -;;; understand it, wait-gl should inhibit any X requests until all GL -;;; requests are sent... -(defun wait-gl () - (assert (context-p *current-context*) - (*current-context*) - "~S is not a context." *current-context*) - (let* ((ctx *current-context*) - (display (context-display ctx))) - (with-buffer-request (display (extension-opcode display "GLX")) - (data +wait-gl+) - ;; *** GLX_CONTEXT_TAG - (card32 (context-tag ctx))))) - - -(defun wait-x () - (assert (context-p *current-context*) - (*current-context*) - "~S is not a context." *current-context*) - (let* ((ctx *current-context*) - (display (context-display ctx))) - (with-buffer-request (display (extension-opcode display "GLX")) - (data +wait-x+) - ;; *** GLX_CONTEXT_TAG - (card32 (context-tag ctx))))) diff -Nru ecl-16.1.2/src/clx/graphics.lisp ecl-16.1.3+ds/src/clx/graphics.lisp --- ecl-16.1.2/src/clx/graphics.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/graphics.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,447 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; CLX drawing requests - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(defvar *inhibit-appending* nil) - -(defun draw-point (drawable gcontext x y) - ;; Should be clever about appending to existing buffered protocol request. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y)) - (let ((display (drawable-display drawable))) - (declare (type display display)) - (with-display (display) - (force-gcontext-changes-internal gcontext) - (with-buffer-output (display :length +requestsize+) - (let* ((last-request-byte (display-last-request display)) - (current-boffset buffer-boffset)) - ;; To append or not append, that is the question - (if (and (not *inhibit-appending*) - last-request-byte - ;; Same request? - (= (aref-card8 buffer-bbuf last-request-byte) +x-polypoint+) - (progn ;; Set buffer pointers to last request - (set-buffer-offset last-request-byte) - ;; same drawable and gcontext? - (or (compare-request (4) - (data 0) - (drawable drawable) - (gcontext gcontext)) - (progn ;; If failed, reset buffer pointers - (set-buffer-offset current-boffset) - nil)))) - ;; Append request - (progn - ;; Set new request length - (card16-put 2 (index+ 1 (index-ash (index- current-boffset last-request-byte) - -2))) - (set-buffer-offset current-boffset) - (put-items (0) ; Insert new point - (int16 x y)) - (setf (display-boffset display) (index+ buffer-boffset 4))) - ;; New Request - (progn - (put-items (4) - (code +x-polypoint+) - (data 0) ;; Relative-p false - (length 4) - (drawable drawable) - (gcontext gcontext) - (int16 x y)) - (buffer-new-request-number display) - (setf (buffer-last-request display) buffer-boffset) - (setf (display-boffset display) (index+ buffer-boffset 16))))))) - (display-invoke-after-function display))) - - -(defun draw-points (drawable gcontext points &optional relative-p) - (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence points) ;(repeat-seq (integer x) (integer y)) - (type generalized-boolean relative-p)) - (with-buffer-request ((drawable-display drawable) +x-polypoint+ :gc-force gcontext) - ((data boolean) relative-p) - (drawable drawable) - (gcontext gcontext) - ((sequence :format int16) points))) - -(defun draw-line (drawable gcontext x1 y1 x2 y2 &optional relative-p) - ;; Should be clever about appending to existing buffered protocol request. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x1 y1 x2 y2) - (type generalized-boolean relative-p)) - (let ((display (drawable-display drawable))) - (declare (type display display)) - (when relative-p - (incf x2 x1) - (incf y2 y1)) - (with-display (display) - (force-gcontext-changes-internal gcontext) - (with-buffer-output (display :length +requestsize+) - (let* ((last-request-byte (display-last-request display)) - (current-boffset buffer-boffset)) - ;; To append or not append, that is the question - (if (and (not *inhibit-appending*) - last-request-byte - ;; Same request? - (= (aref-card8 buffer-bbuf last-request-byte) +x-polysegment+) - (progn ;; Set buffer pointers to last request - (set-buffer-offset last-request-byte) - ;; same drawable and gcontext? - (or (compare-request (4) - (drawable drawable) - (gcontext gcontext)) - (progn ;; If failed, reset buffer pointers - (set-buffer-offset current-boffset) - nil)))) - ;; Append request - (progn - ;; Set new request length - (card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte) - -2))) - (set-buffer-offset current-boffset) - (put-items (0) ; Insert new point - (int16 x1 y1 x2 y2)) - (setf (display-boffset display) (index+ buffer-boffset 8))) - ;; New Request - (progn - (put-items (4) - (code +x-polysegment+) - (length 5) - (drawable drawable) - (gcontext gcontext) - (int16 x1 y1 x2 y2)) - (buffer-new-request-number display) - (setf (buffer-last-request display) buffer-boffset) - (setf (display-boffset display) (index+ buffer-boffset 20))))))) - (display-invoke-after-function display))) - -(defun draw-lines (drawable gcontext points &key relative-p fill-p (shape :complex)) - (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence points) ;(repeat-seq (integer x) (integer y)) - (type generalized-boolean relative-p fill-p) - (type (member :complex :non-convex :convex) shape)) - (if fill-p - (fill-polygon drawable gcontext points relative-p shape) - (with-buffer-request ((drawable-display drawable) +x-polyline+ :gc-force gcontext) - ((data boolean) relative-p) - (drawable drawable) - (gcontext gcontext) - ((sequence :format int16) points)))) - -;; Internal function called from DRAW-LINES -(defun fill-polygon (drawable gcontext points relative-p shape) - ;; This is clever about appending to previous requests. Should it be? - (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence points) ;(repeat-seq (integer x) (integer y)) - (type generalized-boolean relative-p) - (type (member :complex :non-convex :convex) shape)) - (with-buffer-request ((drawable-display drawable) +x-fillpoly+ :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - ((member8 :complex :non-convex :convex) shape) - (boolean relative-p) - ((sequence :format int16) points))) - -(defun draw-segments (drawable gcontext segments) - (declare (type drawable drawable) - (type gcontext gcontext) - ;; (repeat-seq (integer x1) (integer y1) (integer x2) (integer y2))) - (type sequence segments)) - (with-buffer-request ((drawable-display drawable) +x-polysegment+ :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - ((sequence :format int16) segments))) - -(defun draw-rectangle (drawable gcontext x y width height &optional fill-p) - ;; Should be clever about appending to existing buffered protocol request. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type card16 width height) - (type generalized-boolean fill-p)) - (let ((display (drawable-display drawable)) - (request (if fill-p +x-polyfillrectangle+ +x-polyrectangle+))) - (declare (type display display) - (type card16 request)) - (with-display (display) - (force-gcontext-changes-internal gcontext) - (with-buffer-output (display :length +requestsize+) - (let* ((last-request-byte (display-last-request display)) - (current-boffset buffer-boffset)) - ;; To append or not append, that is the question - (if (and (not *inhibit-appending*) - last-request-byte - ;; Same request? - (= (aref-card8 buffer-bbuf last-request-byte) request) - (progn ;; Set buffer pointers to last request - (set-buffer-offset last-request-byte) - ;; same drawable and gcontext? - (or (compare-request (4) - (drawable drawable) - (gcontext gcontext)) - (progn ;; If failed, reset buffer pointers - (set-buffer-offset current-boffset) - nil)))) - ;; Append request - (progn - ;; Set new request length - (card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte) - -2))) - (set-buffer-offset current-boffset) - (put-items (0) ; Insert new point - (int16 x y) - (card16 width height)) - (setf (display-boffset display) (index+ buffer-boffset 8))) - ;; New Request - (progn - (put-items (4) - (code request) - (length 5) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (card16 width height)) - (buffer-new-request-number display) - (setf (buffer-last-request display) buffer-boffset) - (setf (display-boffset display) (index+ buffer-boffset 20))))))) - (display-invoke-after-function display))) - -(defun draw-rectangles (drawable gcontext rectangles &optional fill-p) - (declare (type drawable drawable) - (type gcontext gcontext) - ;; (repeat-seq (integer x) (integer y) (integer width) (integer height))) - (type sequence rectangles) - (type generalized-boolean fill-p)) - (with-buffer-request ((drawable-display drawable) - (if fill-p +x-polyfillrectangle+ +x-polyrectangle+) - :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - ((sequence :format int16) rectangles))) - -(defun draw-arc (drawable gcontext x y width height angle1 angle2 &optional fill-p) - ;; Should be clever about appending to existing buffered protocol request. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type card16 width height) - (type angle angle1 angle2) - (type generalized-boolean fill-p)) - (let ((display (drawable-display drawable)) - (request (if fill-p +x-polyfillarc+ +x-polyarc+))) - (declare (type display display) - (type card16 request)) - (with-display (display) - (force-gcontext-changes-internal gcontext) - (with-buffer-output (display :length +requestsize+) - (let* ((last-request-byte (display-last-request display)) - (current-boffset buffer-boffset)) - ;; To append or not append, that is the question - (if (and (not *inhibit-appending*) - last-request-byte - ;; Same request? - (= (aref-card8 buffer-bbuf last-request-byte) request) - (progn ;; Set buffer pointers to last request - (set-buffer-offset last-request-byte) - ;; same drawable and gcontext? - (or (compare-request (4) - (drawable drawable) - (gcontext gcontext)) - (progn ;; If failed, reset buffer pointers - (set-buffer-offset current-boffset) - nil)))) - ;; Append request - (progn - ;; Set new request length - (card16-put 2 (index+ 3 (index-ash (index- current-boffset last-request-byte) - -2))) - (set-buffer-offset current-boffset) - (put-items (0) ; Insert new point - (int16 x y) - (card16 width height) - (angle angle1 angle2)) - (setf (display-boffset display) (index+ buffer-boffset 12))) - ;; New Request - (progn - (put-items (4) - (code request) - (length 6) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (card16 width height) - (angle angle1 angle2)) - (buffer-new-request-number display) - (setf (buffer-last-request display) buffer-boffset) - (setf (display-boffset display) (index+ buffer-boffset 24))))))) - (display-invoke-after-function display))) - -(defun draw-arcs-list (drawable gcontext arcs &optional fill-p) - (declare (type drawable drawable) - (type gcontext gcontext) - (type list arcs) - (type generalized-boolean fill-p)) - (let* ((display (drawable-display drawable)) - (limit (index- (buffer-size display) 12)) - (length (length arcs)) - (request (if fill-p +x-polyfillarc+ +x-polyarc+))) - (with-buffer-request ((drawable-display drawable) request :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - (progn - (card16-put 2 (index+ (index-ash length -1) 3)) ; Set request length (in words) - (set-buffer-offset (index+ buffer-boffset 12)) ; Position to start of data - (do ((arc arcs)) - ((endp arc) - (setf (buffer-boffset display) buffer-boffset)) - ;; Make sure there's room - (when (index>= buffer-boffset limit) - (setf (buffer-boffset display) buffer-boffset) - (buffer-flush display) - (set-buffer-offset (buffer-boffset display))) - (int16-put 0 (pop arc)) - (int16-put 2 (pop arc)) - (card16-put 4 (pop arc)) - (card16-put 6 (pop arc)) - (angle-put 8 (pop arc)) - (angle-put 10 (pop arc)) - (set-buffer-offset (index+ buffer-boffset 12))))))) - -(defun draw-arcs-vector (drawable gcontext arcs &optional fill-p) - (declare (type drawable drawable) - (type gcontext gcontext) - (type vector arcs) - (type generalized-boolean fill-p)) - (let* ((display (drawable-display drawable)) - (limit (index- (buffer-size display) 12)) - (length (length arcs)) - (request (if fill-p +x-polyfillarc+ +x-polyarc+))) - (with-buffer-request ((drawable-display drawable) request :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - (progn - (card16-put 2 (index+ (index-ash length -1) 3)) ; Set request length (in words) - (set-buffer-offset (index+ buffer-boffset 12)) ; Position to start of data - (do ((n 0 (index+ n 6)) - (length (length arcs))) - ((index>= n length) - (setf (buffer-boffset display) buffer-boffset)) - ;; Make sure there's room - (when (index>= buffer-boffset limit) - (setf (buffer-boffset display) buffer-boffset) - (buffer-flush display) - (set-buffer-offset (buffer-boffset display))) - (int16-put 0 (aref arcs (index+ n 0))) - (int16-put 2 (aref arcs (index+ n 1))) - (card16-put 4 (aref arcs (index+ n 2))) - (card16-put 6 (aref arcs (index+ n 3))) - (angle-put 8 (aref arcs (index+ n 4))) - (angle-put 10 (aref arcs (index+ n 5))) - (set-buffer-offset (index+ buffer-boffset 12))))))) - -(defun draw-arcs (drawable gcontext arcs &optional fill-p) - (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence arcs) - (type generalized-boolean fill-p)) - (etypecase arcs - (list (draw-arcs-list drawable gcontext arcs fill-p)) - (vector (draw-arcs-vector drawable gcontext arcs fill-p)))) - -;; The following image routines are bare minimum. It may be useful to define -;; some form of "image" object to hide representation details and format -;; conversions. It also may be useful to provide stream-oriented interfaces -;; for reading and writing the data. - -(defun put-raw-image (drawable gcontext data &key - (start 0) - (depth (required-arg depth)) - (x (required-arg x)) - (y (required-arg y)) - (width (required-arg width)) - (height (required-arg height)) - (left-pad 0) - (format (required-arg format))) - ;; Data must be a sequence of 8-bit quantities, already in the appropriate format - ;; for transmission; the caller is responsible for all byte and bit swapping and - ;; compaction. Start is the starting index in data; the end is computed from the - ;; other arguments. - (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence data) ; Sequence of integers - (type array-index start) - (type card8 depth left-pad) ;; required - (type int16 x y) ;; required - (type card16 width height) ;; required - (type (member :bitmap :xy-pixmap :z-pixmap) format)) - (with-buffer-request ((drawable-display drawable) +x-putimage+ :gc-force gcontext) - ((data (member :bitmap :xy-pixmap :z-pixmap)) format) - (drawable drawable) - (gcontext gcontext) - (card16 width height) - (int16 x y) - (card8 left-pad depth) - (pad16 nil) - ((sequence :format card8 :start start) data))) - -(defun get-raw-image (drawable &key - data - (start 0) - (x (required-arg x)) - (y (required-arg y)) - (width (required-arg width)) - (height (required-arg height)) - (plane-mask #xffffffff) - (format (required-arg format)) - (result-type '(vector card8))) - ;; If data is given, it is modified in place (and returned), otherwise a new sequence - ;; is created and returned, with a size computed from the other arguments and the - ;; returned depth. The sequence is filled with 8-bit quantities, in transmission - ;; format; the caller is responsible for any byte and bit swapping and compaction - ;; required for further local use. - (declare (type drawable drawable) - (type (or null sequence) data) ;; sequence of integers - (type int16 x y) ;; required - (type card16 width height) ;; required - (type array-index start) - (type pixel plane-mask) - (type (member :xy-pixmap :z-pixmap) format)) - (declare (clx-values (clx-sequence integer) depth visual-info)) - (let ((display (drawable-display drawable))) - (with-buffer-request-and-reply (display +x-getimage+ nil :sizes (8 32)) - (((data (member error :xy-pixmap :z-pixmap)) format) - (drawable drawable) - (int16 x y) - (card16 width height) - (card32 plane-mask)) - (let ((depth (card8-get 1)) - (length (* 4 (card32-get 4))) - (visual (resource-id-get 8))) - (values (sequence-get :result-type result-type :format card8 - :length length :start start :data data - :index +replysize+) - depth - (visual-info display visual)))))) diff -Nru ecl-16.1.2/src/clx/image.lisp ecl-16.1.3+ds/src/clx/image.lisp --- ecl-16.1.2/src/clx/image.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/image.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,2668 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- - -;;; CLX Image functions - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(defmacro with-image-data-buffer ((buffer size) &body body) - (declare (indentation 0 4 1 1)) - `(let ((.reply-buffer. (allocate-reply-buffer ,size))) - (declare (type reply-buffer .reply-buffer.)) - (unwind-protect - (let ((,buffer (reply-ibuf8 .reply-buffer.))) - (declare (type buffer-bytes ,buffer)) - (with-vector (,buffer buffer-bytes) - ,@body)) - (deallocate-reply-buffer .reply-buffer.)))) - -(def-clx-class (image (:constructor nil) (:copier nil) (:predicate nil)) - ;; Public structure - (width 0 :type card16 :read-only t) - (height 0 :type card16 :read-only t) - (depth 1 :type card8 :read-only t) - (plist nil :type list)) - -;; Image-Plist accessors: -(defmacro image-name (image) `(getf (image-plist ,image) :name)) -(defmacro image-x-hot (image) `(getf (image-plist ,image) :x-hot)) -(defmacro image-y-hot (image) `(getf (image-plist ,image) :y-hot)) -(defmacro image-red-mask (image) `(getf (image-plist ,image) :red-mask)) -(defmacro image-blue-mask (image) `(getf (image-plist ,image) :blue-mask)) -(defmacro image-green-mask (image) `(getf (image-plist ,image) :green-mask)) - -(defun print-image (image stream depth) - (declare (type image image) - (ignore depth)) - (print-unreadable-object (image stream :type t) - (when (image-name image) - (write-string (string (image-name image)) stream) - (write-string " " stream)) - (prin1 (image-width image) stream) - (write-string "x" stream) - (prin1 (image-height image) stream) - (write-string "x" stream) - (prin1 (image-depth image) stream))) - -(defconstant +empty-data-x+ '#.(make-sequence '(array card8 (*)) 0)) - -(defconstant +empty-data-z+ - '#.(make-array '(0 0) :element-type 'pixarray-1-element-type)) - -(def-clx-class (image-x (:include image) (:copier nil) - (:print-function print-image)) - ;; Use this format for shoveling image data - ;; Private structure. Accessors for these NOT exported. - (format :z-pixmap :type (member :bitmap :xy-pixmap :z-pixmap)) - (bytes-per-line 0 :type card16) - (bits-per-pixel 1 :type (member 1 4 8 16 24 32)) - (bit-lsb-first-p +image-bit-lsb-first-p+ :type generalized-boolean) ; Bit order - (byte-lsb-first-p +image-byte-lsb-first-p+ :type generalized-boolean) ; Byte order - (data +empty-data-x+ :type (array card8 (*))) ; row-major - (unit +image-unit+ :type (member 8 16 32)) ; Bitmap unit - (pad +image-pad+ :type (member 8 16 32)) ; Scanline pad - (left-pad 0 :type card8)) ; Left pad - -(def-clx-class (image-xy (:include image) (:copier nil) - (:print-function print-image)) - ;; Public structure - ;; Use this format for image processing - (bitmap-list nil :type list)) ;; list of bitmaps - -(def-clx-class (image-z (:include image) (:copier nil) - (:print-function print-image)) - ;; Public structure - ;; Use this format for image processing - (bits-per-pixel 1 :type (member 1 4 8 16 24 32)) - (pixarray +empty-data-z+ :type pixarray)) - -(defun create-image (&key width height depth - (data (required-arg data)) - plist name x-hot y-hot - red-mask blue-mask green-mask - bits-per-pixel format bytes-per-line - (byte-lsb-first-p - #+clx-little-endian t - #-clx-little-endian nil) - (bit-lsb-first-p - #+clx-little-endian t - #-clx-little-endian nil) - unit pad left-pad) - ;; Returns an image-x image-xy or image-z structure, depending on the - ;; type of the :DATA parameter. - (declare - (type (or null card16) width height) ; Required - (type (or null card8) depth) ; Defualts to 1 - (type (or buffer-bytes ; Returns image-x - list ; Returns image-xy - pixarray) data) ; Returns image-z - (type list plist) - (type (or null stringable) name) - (type (or null card16) x-hot y-hot) - (type (or null pixel) red-mask blue-mask green-mask) - (type (or null (member 1 4 8 16 24 32)) bits-per-pixel) - - ;; The following parameters are ignored for image-xy and image-z: - (type (or null (member :bitmap :xy-pixmap :z-pixmap)) - format) ; defaults to :z-pixmap - (type (or null card16) bytes-per-line) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) - (type (or null (member 8 16 32)) unit pad) - (type (or null card8) left-pad)) - (declare (clx-values image)) - (let ((image - (etypecase data - (buffer-bytes ; image-x - (let ((data data)) - (declare (type buffer-bytes data)) - (unless depth (setq depth (or bits-per-pixel 1))) - (unless format - (setq format (if (= depth 1) :xy-pixmap :z-pixmap))) - (unless bits-per-pixel - (setq bits-per-pixel - (cond ((eq format :xy-pixmap) 1) - ((index> depth 24) 32) - ((index> depth 16) 24) - ((index> depth 8) 16) - ((index> depth 4) 8) - ((index> depth 1) 4) - (t 1)))) - (unless width (required-arg width)) - (unless height (required-arg height)) - (unless bytes-per-line - (let* ((pad (or pad 8)) - (bits-per-line (index* width bits-per-pixel)) - (padded-bits-per-line - (index* (index-ceiling bits-per-line pad) pad))) - (declare (type array-index pad bits-per-line - padded-bits-per-line)) - (setq bytes-per-line (index-ceiling padded-bits-per-line 8)))) - (unless unit (setq unit +image-unit+)) - (unless pad - (setq pad - (dolist (pad '(32 16 8)) - (when (and (index<= pad +image-pad+) - (zerop - (index-mod - (index* bytes-per-line 8) pad))) - (return pad))))) - (unless left-pad (setq left-pad 0)) - (make-image-x - :width width :height height :depth depth :plist plist - :format format :data data - :bits-per-pixel bits-per-pixel - :bytes-per-line bytes-per-line - :byte-lsb-first-p byte-lsb-first-p - :bit-lsb-first-p bit-lsb-first-p - :unit unit :pad pad :left-pad left-pad))) - (list ; image-xy - (let ((data data)) - (declare (type list data)) - (unless depth (setq depth (length data))) - (when data - (unless width (setq width (array-dimension (car data) 1))) - (unless height (setq height (array-dimension (car data) 0)))) - (make-image-xy - :width width :height height :plist plist :depth depth - :bitmap-list data))) - (pixarray ; image-z - (let ((data data)) - (declare (type pixarray data)) - (unless width (setq width (array-dimension data 1))) - (unless height (setq height (array-dimension data 0))) - (unless bits-per-pixel - (setq bits-per-pixel - (etypecase data - (pixarray-32 32) - (pixarray-24 24) - (pixarray-16 16) - (pixarray-8 8) - (pixarray-4 4) - (pixarray-1 1))))) - (unless depth (setq depth bits-per-pixel)) - (make-image-z - :width width :height height :depth depth :plist plist - :bits-per-pixel bits-per-pixel :pixarray data))))) - (declare (type image image)) - (when name (setf (image-name image) name)) - (when x-hot (setf (image-x-hot image) x-hot)) - (when y-hot (setf (image-y-hot image) y-hot)) - (when red-mask (setf (image-red-mask image) red-mask)) - (when blue-mask (setf (image-blue-mask image) blue-mask)) - (when green-mask (setf (image-green-mask image) green-mask)) - image)) - -;;;----------------------------------------------------------------------------- -;;; Swapping stuff - -(defun image-noswap - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p) - (ignore lsb-first-p)) - #.(declare-buffun) - (if (index= srcinc destinc) - (buffer-replace - dest src destoff - (index+ destoff (index* srcinc (index1- height)) srclen) - srcoff) - (do* ((h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc)) - (destend (index+ deststart srclen) (index+ deststart srclen))) - ((index-zerop h)) - (declare (type array-index srcstart deststart destend) - (type card16 h)) - (buffer-replace dest src deststart destend srcstart)))) - -(defun image-swap-two-bytes - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (do ((length (index* (index-ceiling srclen 2) 2)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 2) - (if lsb-first-p - (setf (aref dest (index1+ (index+ deststart length))) - (the card8 (aref src (index+ srcstart length)))) - (setf (aref dest (index+ deststart length)) - (the card8 (aref src (index1+ (index+ srcstart length))))))) - (do ((i length (index- i 2)) - (srcidx srcstart (index+ srcidx 2)) - (destidx deststart (index+ destidx 2))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 (aref src (index1+ srcidx)))) - (setf (aref dest (index1+ destidx)) - (the card8 (aref src srcidx)))))))) - -(defun image-swap-three-bytes - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (do ((length (index* (index-ceiling srclen 3) 3)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 3) - (when (index= (index- srclen length) 2) - (setf (aref dest (index+ deststart length 1)) - (the card8 (aref src (index+ srcstart length 1))))) - (if lsb-first-p - (setf (aref dest (index+ deststart length 2)) - (the card8 (aref src (index+ srcstart length)))) - (setf (aref dest (index+ deststart length)) - (the card8 (aref src (index+ srcstart length 2)))))) - (do ((i length (index- i 3)) - (srcidx srcstart (index+ srcidx 3)) - (destidx deststart (index+ destidx 3))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 (aref src (index+ srcidx 2)))) - (setf (aref dest (index1+ destidx)) - (the card8 (aref src (index1+ srcidx)))) - (setf (aref dest (index+ destidx 2)) - (the card8 (aref src srcidx)))))))) - -(defun image-swap-four-bytes - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (do ((length (index* (index-ceiling srclen 4) 4)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 4) - (unless lsb-first-p - (setf (aref dest (index+ deststart length)) - (the card8 (aref src (index+ srcstart length 3))))) - (when (if lsb-first-p - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 1)) - (the card8 (aref src (index+ srcstart length 2))))) - (when (if (null lsb-first-p) - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 2)) - (the card8 (aref src (index+ srcstart length 1))))) - (when lsb-first-p - (setf (aref dest (index+ deststart length 3)) - (the card8 (aref src (index+ srcstart length)))))) - (do ((i length (index- i 4)) - (srcidx srcstart (index+ srcidx 4)) - (destidx deststart (index+ destidx 4))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 (aref src (index+ srcidx 3)))) - (setf (aref dest (index1+ destidx)) - (the card8 (aref src (index+ srcidx 2)))) - (setf (aref dest (index+ destidx 2)) - (the card8 (aref src (index1+ srcidx)))) - (setf (aref dest (index+ destidx 3)) - (the card8 (aref src srcidx)))))))) - -(defun image-swap-words - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (do ((length (index* (index-ceiling srclen 4) 4)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 4) - (unless lsb-first-p - (setf (aref dest (index+ deststart length 1)) - (the card8 (aref src (index+ srcstart length 3))))) - (when (if lsb-first-p - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length)) - (the card8 (aref src (index+ srcstart length 2))))) - (when (if (null lsb-first-p) - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 3)) - (the card8 (aref src (index+ srcstart length 1))))) - (when lsb-first-p - (setf (aref dest (index+ deststart length 2)) - (the card8 (aref src (index+ srcstart length)))))) - (do ((i length (index- i 4)) - (srcidx srcstart (index+ srcidx 4)) - (destidx deststart (index+ destidx 4))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 (aref src (index+ srcidx 2)))) - (setf (aref dest (index1+ destidx)) - (the card8 (aref src (index+ srcidx 3)))) - (setf (aref dest (index+ destidx 2)) - (the card8 (aref src srcidx))) - (setf (aref dest (index+ destidx 3)) - (the card8 (aref src (index1+ srcidx))))))))) - -(defun image-swap-nibbles - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p) - (ignore lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (do ((h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index srcstart deststart) - (type card16 h)) - (do ((i srclen (index1- i)) - (srcidx srcstart (index1+ srcidx)) - (destidx deststart (index1+ destidx))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 - (let ((byte (aref src srcidx))) - (declare (type card8 byte)) - (dpb (the card4 (ldb (byte 4 0) byte)) - (byte 4 4) - (the card4 (ldb (byte 4 4) byte))))))))))) - -(defun image-swap-nibbles-left - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p) - (ignore lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (do ((h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index srcstart deststart) - (type card16 h)) - (do ((i srclen (index1- i)) - (srcidx srcstart (index1+ srcidx)) - (destidx deststart (index1+ destidx))) - ((index= i 1) - (setf (aref dest destidx) - (the card8 - (let ((byte1 (aref src srcidx))) - (declare (type card8 byte1)) - (dpb (the card4 (ldb (byte 4 0) byte1)) - (byte 4 4) - 0))))) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 - (let ((byte1 (aref src srcidx)) - (byte2 (aref src (index1+ srcidx)))) - (declare (type card8 byte1 byte2)) - (dpb (the card4 (ldb (byte 4 0) byte1)) - (byte 4 4) - (the card4 (ldb (byte 4 4) byte2))))))))))) - -(defconstant +image-byte-reverse+ - '#.(coerce - '#( - 0 128 64 192 32 160 96 224 16 144 80 208 48 176 112 240 - 8 136 72 200 40 168 104 232 24 152 88 216 56 184 120 248 - 4 132 68 196 36 164 100 228 20 148 84 212 52 180 116 244 - 12 140 76 204 44 172 108 236 28 156 92 220 60 188 124 252 - 2 130 66 194 34 162 98 226 18 146 82 210 50 178 114 242 - 10 138 74 202 42 170 106 234 26 154 90 218 58 186 122 250 - 6 134 70 198 38 166 102 230 22 150 86 214 54 182 118 246 - 14 142 78 206 46 174 110 238 30 158 94 222 62 190 126 254 - 1 129 65 193 33 161 97 225 17 145 81 209 49 177 113 241 - 9 137 73 201 41 169 105 233 25 153 89 217 57 185 121 249 - 5 133 69 197 37 165 101 229 21 149 85 213 53 181 117 245 - 13 141 77 205 45 173 109 237 29 157 93 221 61 189 125 253 - 3 131 67 195 35 163 99 227 19 147 83 211 51 179 115 243 - 11 139 75 203 43 171 107 235 27 155 91 219 59 187 123 251 - 7 135 71 199 39 167 103 231 23 151 87 215 55 183 119 247 - 15 143 79 207 47 175 111 239 31 159 95 223 63 191 127 255) - '(vector card8))) - -(defun image-swap-bits - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p) - (ignore lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (let ((byte-reverse +image-byte-reverse+)) - (with-vector (byte-reverse (simple-array card8 (256))) - (macrolet ((br (byte) - `(the card8 (aref byte-reverse (the card8 ,byte))))) - (do ((h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index srcstart deststart) - (type card16 h)) - (do ((i srclen (index1- i)) - (srcidx srcstart (index1+ srcidx)) - (destidx deststart (index1+ destidx))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) (br (aref src srcidx))))))))))) - -(defun image-swap-bits-and-two-bytes - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (let ((byte-reverse +image-byte-reverse+)) - (with-vector (byte-reverse (simple-array card8 (256))) - (macrolet ((br (byte) - `(the card8 (aref byte-reverse (the card8 ,byte))))) - (do ((length (index* (index-ceiling srclen 2) 2)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 2) - (if lsb-first-p - (setf (aref dest (index1+ (index+ deststart length))) - (br (aref src (index+ srcstart length)))) - (setf (aref dest (index+ deststart length)) - (br (aref src (index1+ (index+ srcstart length))))))) - (do ((i length (index- i 2)) - (srcidx srcstart (index+ srcidx 2)) - (destidx deststart (index+ destidx 2))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (br (aref src (index1+ srcidx)))) - (setf (aref dest (index1+ destidx)) - (br (aref src srcidx))))))))))) - -(defun image-swap-bits-and-four-bytes - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (let ((byte-reverse +image-byte-reverse+)) - (with-vector (byte-reverse (simple-array card8 (256))) - (macrolet ((br (byte) - `(the card8 (aref byte-reverse (the card8 ,byte))))) - (do ((length (index* (index-ceiling srclen 4) 4)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 4) - (unless lsb-first-p - (setf (aref dest (index+ deststart length)) - (br (aref src (index+ srcstart length 3))))) - (when (if lsb-first-p - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 1)) - (br (aref src (index+ srcstart length 2))))) - (when (if (null lsb-first-p) - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 2)) - (br (aref src (index+ srcstart length 1))))) - (when lsb-first-p - (setf (aref dest (index+ deststart length 3)) - (br (aref src (index+ srcstart length)))))) - (do ((i length (index- i 4)) - (srcidx srcstart (index+ srcidx 4)) - (destidx deststart (index+ destidx 4))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (br (aref src (index+ srcidx 3)))) - (setf (aref dest (index1+ destidx)) - (br (aref src (index+ srcidx 2)))) - (setf (aref dest (index+ destidx 2)) - (br (aref src (index1+ srcidx)))) - (setf (aref dest (index+ destidx 3)) - (br (aref src srcidx))))))))))) - -(defun image-swap-bits-and-words - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (let ((byte-reverse +image-byte-reverse+)) - (with-vector (byte-reverse (simple-array card8 (256))) - (macrolet ((br (byte) - `(the card8 (aref byte-reverse (the card8 ,byte))))) - (do ((length (index* (index-ceiling srclen 4) 4)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 4) - (unless lsb-first-p - (setf (aref dest (index+ deststart length 1)) - (br (aref src (index+ srcstart length 3))))) - (when (if lsb-first-p - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length)) - (br (aref src (index+ srcstart length 2))))) - (when (if (null lsb-first-p) - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 3)) - (br (aref src (index+ srcstart length 1))))) - (when lsb-first-p - (setf (aref dest (index+ deststart length 2)) - (br (aref src (index+ srcstart length)))))) - (do ((i length (index- i 4)) - (srcidx srcstart (index+ srcidx 4)) - (destidx deststart (index+ destidx 4))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (br (aref src (index+ srcidx 2)))) - (setf (aref dest (index1+ destidx)) - (br (aref src (index+ srcidx 3)))) - (setf (aref dest (index+ destidx 2)) - (br (aref src srcidx))) - (setf (aref dest (index+ destidx 3)) - (br (aref src (index1+ srcidx)))))))))))) - -;;; The following table gives the bit ordering within bytes (when accessed -;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to -;;; 31, where bit 0 should be leftmost on the display. For a given byte -;;; labelled A-B, A is for the most significant bit of the byte, and B is -;;; for the least significant bit. -;;; -;;; legend: -;;; 1 scanline-unit = 8 -;;; 2 scanline-unit = 16 -;;; 4 scanline-unit = 32 -;;; M byte-order = MostSignificant -;;; L byte-order = LeastSignificant -;;; m bit-order = MostSignificant -;;; l bit-order = LeastSignificant -;;; -;;; -;;; format ordering -;;; -;;; 1Mm 00-07 08-15 16-23 24-31 -;;; 2Mm 00-07 08-15 16-23 24-31 -;;; 4Mm 00-07 08-15 16-23 24-31 -;;; 1Ml 07-00 15-08 23-16 31-24 -;;; 2Ml 15-08 07-00 31-24 23-16 -;;; 4Ml 31-24 23-16 15-08 07-00 -;;; 1Lm 00-07 08-15 16-23 24-31 -;;; 2Lm 08-15 00-07 24-31 16-23 -;;; 4Lm 24-31 16-23 08-15 00-07 -;;; 1Ll 07-00 15-08 23-16 31-24 -;;; 2Ll 07-00 15-08 23-16 31-24 -;;; 4Ll 07-00 15-08 23-16 31-24 -;;; -;;; -;;; The following table gives the required conversion between any two -;;; formats. It is based strictly on the table above. If you believe one, -;;; you should believe the other. -;;; -;;; legend: -;;; n no changes -;;; s reverse 8-bit units within 16-bit units -;;; l reverse 8-bit units within 32-bit units -;;; w reverse 16-bit units within 32-bit units -;;; r reverse bits within 8-bit units -;;; sr s+R -;;; lr l+R -;;; wr w+R - -(defconstant +image-swap-function+ - '#.(make-array - '(12 12) :initial-contents - (let ((n 'image-noswap) - (s 'image-swap-two-bytes) - (l 'image-swap-four-bytes) - (w 'image-swap-words) - (r 'image-swap-bits) - (sr 'image-swap-bits-and-two-bytes) - (lr 'image-swap-bits-and-four-bytes) - (wr 'image-swap-bits-and-words)) - (list #| 1Mm 2Mm 4Mm 1Ml 2Ml 4Ml 1Lm 2Lm 4Lm 1Ll 2Ll 4Ll |# - (list #| 1Mm |# n n n r sr lr n s l r r r ) - (list #| 2Mm |# n n n r sr lr n s l r r r ) - (list #| 4Mm |# n n n r sr lr n s l r r r ) - (list #| 1Ml |# r r r n s l r sr lr n n n ) - (list #| 2Ml |# sr sr sr s n w sr r wr s s s ) - (list #| 4Ml |# lr lr lr l w n lr wr r l l l ) - (list #| 1Lm |# n n n r sr lr n s l r r r ) - (list #| 2Lm |# s s s sr r wr s n w sr sr sr) - (list #| 4Lm |# l l l lr wr r l w n lr lr lr) - (list #| 1Ll |# r r r n s l r sr lr n n n ) - (list #| 2Ll |# r r r n s l r sr lr n n n ) - (list #| 4Ll |# r r r n s l r sr lr n n n ))))) - -;;; Of course, the table above is a lie. We also need to factor in the -;;; order of the source data to cope with swapping half of a unit at the -;;; end of a scanline, since we are trying to avoid de-ref'ing off the -;;; end of the source. -;;; -;;; Defines whether the first half of a unit has the first half of the data - -(defconstant +image-swap-lsb-first-p+ - '#.(make-array - 12 :initial-contents - (list t #| 1mm |# - t #| 2mm |# - t #| 4mm |# - t #| 1ml |# - nil #| 2ml |# - nil #| 4ml |# - t #| 1lm |# - nil #| 2lm |# - nil #| 4lm |# - t #| 1ll |# - t #| 2ll |# - t #| 4ll |# - ))) - -(defun image-swap-function - (bits-per-pixel - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) - (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p - to-byte-lsb-first-p to-bit-lsb-first-p) - (clx-values function lsb-first-p)) - (cond ((index= bits-per-pixel 1) - (let ((from-index - (index+ - (ecase from-bitmap-unit (32 2) (16 1) (8 0)) - (if from-bit-lsb-first-p 3 0) - (if from-byte-lsb-first-p 6 0)))) - (values - (aref +image-swap-function+ from-index - (index+ - (ecase to-bitmap-unit (32 2) (16 1) (8 0)) - (if to-bit-lsb-first-p 3 0) - (if to-byte-lsb-first-p 6 0))) - (aref +image-swap-lsb-first-p+ from-index)))) - (t - (values - (if (if (index= bits-per-pixel 4) - (eq from-bit-lsb-first-p to-bit-lsb-first-p) - (eq from-byte-lsb-first-p to-byte-lsb-first-p)) - 'image-noswap - (ecase bits-per-pixel - (4 'image-swap-nibbles) - (8 'image-noswap) - (16 'image-swap-two-bytes) - (24 'image-swap-three-bytes) - (32 'image-swap-four-bytes))) - from-byte-lsb-first-p)))) - - -;;;----------------------------------------------------------------------------- -;;; GET-IMAGE - -(defun read-pixarray-1 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index-ceiling x 8)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y)) - (left-bits (the array-index - (mod (the (integer #x-FFFF 0) (- x)) - 8))) - (right-bits (index-mod (index- width left-bits) 8)) - (middle-bits (- width left-bits right-bits)) - (middle-bytes (floor middle-bits 8))) - ((index>= y height)) - (declare (type array-index start y left-bits right-bits)) - (declare (fixnum middle-bits middle-bytes)) - (cond ((< middle-bits 0) - (let ((byte (aref buffer-bbuf (index1- start))) - (x left-bits)) - (declare (type card8 byte) - (type array-index x)) - (when (index> right-bits 6) - (setf (aref array y (index- x 1)) - (read-image-load-byte 1 7 byte))) - (when (and (index> left-bits 1) - (index> right-bits 5)) - (setf (aref array y (index- x 2)) - (read-image-load-byte 1 6 byte))) - (when (and (index> left-bits 2) - (index> right-bits 4)) - (setf (aref array y (index- x 3)) - (read-image-load-byte 1 5 byte))) - (when (and (index> left-bits 3) - (index> right-bits 3)) - (setf (aref array y (index- x 4)) - (read-image-load-byte 1 4 byte))) - (when (and (index> left-bits 4) - (index> right-bits 2)) - (setf (aref array y (index- x 5)) - (read-image-load-byte 1 3 byte))) - (when (and (index> left-bits 5) - (index> right-bits 1)) - (setf (aref array y (index- x 6)) - (read-image-load-byte 1 2 byte))) - (when (index> left-bits 6) - (setf (aref array y (index- x 7)) - (read-image-load-byte 1 1 byte))))) - (t - (unless (index-zerop left-bits) - (let ((byte (aref buffer-bbuf (index1- start))) - (x left-bits)) - (declare (type card8 byte) - (type array-index x)) - (setf (aref array y (index- x 1)) - (read-image-load-byte 1 7 byte)) - (when (index> left-bits 1) - (setf (aref array y (index- x 2)) - (read-image-load-byte 1 6 byte)) - (when (index> left-bits 2) - (setf (aref array y (index- x 3)) - (read-image-load-byte 1 5 byte)) - (when (index> left-bits 3) - (setf (aref array y (index- x 4)) - (read-image-load-byte 1 4 byte)) - (when (index> left-bits 4) - (setf (aref array y (index- x 5)) - (read-image-load-byte 1 3 byte)) - (when (index> left-bits 5) - (setf (aref array y (index- x 6)) - (read-image-load-byte 1 2 byte)) - (when (index> left-bits 6) - (setf (aref array y (index- x 7)) - (read-image-load-byte 1 1 byte)) - )))))))) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (x left-bits (index+ x 8))) - ((index>= i end) - (unless (index-zerop right-bits) - (let ((byte (aref buffer-bbuf end)) - (x (index+ left-bits middle-bits))) - (declare (type card8 byte) - (type array-index x)) - (setf (aref array y (index+ x 0)) - (read-image-load-byte 1 0 byte)) - (when (index> right-bits 1) - (setf (aref array y (index+ x 1)) - (read-image-load-byte 1 1 byte)) - (when (index> right-bits 2) - (setf (aref array y (index+ x 2)) - (read-image-load-byte 1 2 byte)) - (when (index> right-bits 3) - (setf (aref array y (index+ x 3)) - (read-image-load-byte 1 3 byte)) - (when (index> right-bits 4) - (setf (aref array y (index+ x 4)) - (read-image-load-byte 1 4 byte)) - (when (index> right-bits 5) - (setf (aref array y (index+ x 5)) - (read-image-load-byte 1 5 byte)) - (when (index> right-bits 6) - (setf (aref array y (index+ x 6)) - (read-image-load-byte 1 6 byte)) - ))))))))) - (declare (type array-index end i x)) - (let ((byte (aref buffer-bbuf i))) - (declare (type card8 byte)) - (setf (aref array y (index+ x 0)) - (read-image-load-byte 1 0 byte)) - (setf (aref array y (index+ x 1)) - (read-image-load-byte 1 1 byte)) - (setf (aref array y (index+ x 2)) - (read-image-load-byte 1 2 byte)) - (setf (aref array y (index+ x 3)) - (read-image-load-byte 1 3 byte)) - (setf (aref array y (index+ x 4)) - (read-image-load-byte 1 4 byte)) - (setf (aref array y (index+ x 5)) - (read-image-load-byte 1 5 byte)) - (setf (aref array y (index+ x 6)) - (read-image-load-byte 1 6 byte)) - (setf (aref array y (index+ x 7)) - (read-image-load-byte 1 7 byte)))) - ))))) - -(defun read-pixarray-4 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-4 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index-ceiling x 2)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y)) - (left-nibbles (mod (the fixnum (- x)) 2)) - (right-nibbles (index-mod (index- width left-nibbles) 2)) - (middle-nibbles (index- width left-nibbles right-nibbles)) - (middle-bytes (index-floor middle-nibbles 2))) - ((index>= y height)) - (declare (type array-index start y - left-nibbles right-nibbles middle-nibbles middle-bytes)) - (unless (index-zerop left-nibbles) - (setf (aref array y 0) - (read-image-load-byte - 4 4 (aref buffer-bbuf (index1- start))))) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (x left-nibbles (index+ x 2))) - ((index>= i end) - (unless (index-zerop right-nibbles) - (setf (aref array y (index+ left-nibbles middle-nibbles)) - (read-image-load-byte 4 0 (aref buffer-bbuf end))))) - (declare (type array-index end i x)) - (let ((byte (aref buffer-bbuf i))) - (declare (type card8 byte)) - (setf (aref array y (index+ x 0)) - (read-image-load-byte 4 0 byte)) - (setf (aref array y (index+ x 1)) - (read-image-load-byte 4 4 byte)))) - ))) - -(defun read-pixarray-8 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-8 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - x) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) - (declare (type array-index start y)) - (do* ((end (index+ start width)) - (i start (index1+ i)) - (x 0 (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref array y x) - (the card8 (aref buffer-bbuf i))))))) - -(defun read-pixarray-16 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-16 array) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index* x 2)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) - (declare (type array-index start y)) - (do* ((end (index+ start (index* width 2))) - (i start (index+ i 2)) - (x 0 (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref array y x) - (read-image-assemble-bytes - (aref buffer-bbuf (index+ i 0)) - (aref buffer-bbuf (index+ i 1)))))))) - -(defun read-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index* x 3)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) - (declare (type array-index start y)) - (do* ((end (index+ start (index* width 3))) - (i start (index+ i 3)) - (x 0 (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref array y x) - (read-image-assemble-bytes - (aref buffer-bbuf (index+ i 0)) - (aref buffer-bbuf (index+ i 1)) - (aref buffer-bbuf (index+ i 2)))))))) - -(defun read-pixarray-32 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-32 array) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index* x 4)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) - (declare (type array-index start y)) - (do* ((end (index+ start (index* width 4))) - (i start (index+ i 4)) - (x 0 (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref array y x) - (read-image-assemble-bytes - (aref buffer-bbuf (index+ i 0)) - (aref buffer-bbuf (index+ i 1)) - (aref buffer-bbuf (index+ i 2)) - (aref buffer-bbuf (index+ i 3)))))))) - -(defun read-pixarray-internal - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel read-pixarray-function - from-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type array-index boffset padded-bytes-per-line) - (type pixarray pixarray) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type function read-pixarray-function) - (type (member 8 16 32) from-unit to-unit) - (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p - to-byte-lsb-first-p to-bit-lsb-first-p)) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - from-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (if (eq image-swap-function 'image-noswap) - (funcall - read-pixarray-function - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) - (with-image-data-buffer (buf (index* height padded-bytes-per-line)) - (funcall - (symbol-function image-swap-function) bbuf buf - (index+ boffset (index* y padded-bytes-per-line)) 0 - (index-ceiling (index* (index+ x width) bits-per-pixel) 8) - padded-bytes-per-line padded-bytes-per-line height - image-swap-lsb-first-p) - (funcall - read-pixarray-function - buf 0 pixarray x 0 width height padded-bytes-per-line - bits-per-pixel))))) - -(defun read-pixarray - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type array-index boffset padded-bytes-per-line) - (type pixarray pixarray) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (unless (fast-read-pixarray - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (read-pixarray-internal - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel - (ecase bits-per-pixel - ( 1 #'read-pixarray-1 ) - ( 4 #'read-pixarray-4 ) - ( 8 #'read-pixarray-8 ) - (16 #'read-pixarray-16) - (24 #'read-pixarray-24) - (32 #'read-pixarray-32)) - unit byte-lsb-first-p bit-lsb-first-p - +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+))) - -(defun read-xy-format-image-x - (buffer-bbuf index length data width height depth - padded-bytes-per-line padded-bytes-per-plane - unit byte-lsb-first-p bit-lsb-first-p pad) - (declare (type buffer-bytes buffer-bbuf) - (type card16 width height) - (type array-index index length padded-bytes-per-line - padded-bytes-per-plane) - (type image-depth depth) - (type (member 8 16 32) unit pad) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) - (clx-values image-x)) - (assert (index<= (index* depth padded-bytes-per-plane) length)) - (let* ((bytes-per-line (index-ceiling width 8)) - (data-length (index* padded-bytes-per-plane depth))) - (declare (type array-index bytes-per-line data-length)) - (cond (data - (check-type data buffer-bytes) - (assert (index>= (length data) data-length))) - (t - (setq data (make-array data-length :element-type 'card8)))) - (do ((plane 0 (index1+ plane))) - ((index>= plane depth)) - (declare (type image-depth plane)) - (image-noswap - buffer-bbuf data - (index+ index (index* plane padded-bytes-per-plane)) - (index* plane padded-bytes-per-plane) - bytes-per-line padded-bytes-per-line padded-bytes-per-line - height byte-lsb-first-p)) - (create-image - :width width :height height :depth depth :data data - :bits-per-pixel 1 :format :xy-pixmap - :bytes-per-line padded-bytes-per-line - :unit unit :pad pad - :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p))) - -(defun read-z-format-image-x - (buffer-bbuf index length data width height depth - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p pad bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type card16 width height) - (type array-index index length padded-bytes-per-line) - (type image-depth depth) - (type (member 8 16 32) unit pad) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (clx-values image-x)) - (assert (index<= (index* height padded-bytes-per-line) length)) - (let ((bytes-per-line (index-ceiling (index* width bits-per-pixel) 8)) - (data-length (index* padded-bytes-per-line height))) - (declare (type array-index bytes-per-line data-length)) - (cond (data - (check-type data buffer-bytes) - (assert (index>= (length data) data-length))) - (t - (setq data (make-array data-length :element-type 'card8)))) - (image-noswap - buffer-bbuf data index 0 bytes-per-line padded-bytes-per-line - padded-bytes-per-line height byte-lsb-first-p) - (create-image - :width width :height height :depth depth :data data - :bits-per-pixel bits-per-pixel :format :z-pixmap - :bytes-per-line padded-bytes-per-line - :unit unit :pad pad - :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p))) - -(defun read-image-xy (bbuf index length data x y width height depth - padded-bytes-per-line padded-bytes-per-plane - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type card16 x y width height) - (type array-index index length padded-bytes-per-line - padded-bytes-per-plane) - (type image-depth depth) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) - (clx-values image-xy)) - (check-type data list) - (multiple-value-bind (dimensions element-type) - (if data - (values (array-dimensions (first data)) - (array-element-type (first data))) - (values (list height - (index* (index-ceiling width +image-pad+) +image-pad+)) - 'pixarray-1-element-type)) - (do* ((arrays data) - (result nil) - (limit (index+ length index)) - (plane 0 (1+ plane)) - (index index (index+ index padded-bytes-per-plane))) - ((or (>= plane depth) - (index> (index+ index padded-bytes-per-plane) limit)) - (setq data (nreverse result) depth (length data))) - (declare (type array-index limit index) - (type image-depth plane) - (type list arrays result)) - (let ((array (or (pop arrays) - (make-array dimensions :element-type element-type)))) - (declare (type pixarray-1 array)) - (push array result) - (read-pixarray - bbuf index array x y width height padded-bytes-per-line 1 - unit byte-lsb-first-p bit-lsb-first-p))) - (create-image - :width width :height height :depth depth :data data))) - -(defun read-image-z (bbuf index length data x y width height depth - padded-bytes-per-line bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type card16 x y width height) - (type array-index index length padded-bytes-per-line) - (type image-depth depth) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) - (clx-values image-z)) - (assert (index<= (index* (index+ y height) padded-bytes-per-line) length)) - (let* ((image-bits-per-line (index* width bits-per-pixel)) - (image-pixels-per-line - (index-ceiling - (index* (index-ceiling image-bits-per-line +image-pad+) - +image-pad+) - bits-per-pixel))) - (declare (type array-index image-bits-per-line image-pixels-per-line)) - (unless data - (setq data - (make-array - (list height image-pixels-per-line) - :element-type (ecase bits-per-pixel - (1 'pixarray-1-element-type) - (4 'pixarray-4-element-type) - (8 'pixarray-8-element-type) - (16 'pixarray-16-element-type) - (24 'pixarray-24-element-type) - (32 'pixarray-32-element-type))))) - (read-pixarray - bbuf index data x y width height padded-bytes-per-line bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (create-image - :width width :height height :depth depth :data data - :bits-per-pixel bits-per-pixel))) - -(defun get-image (drawable &key - data - (x (required-arg x)) - (y (required-arg y)) - (width (required-arg width)) - (height (required-arg height)) - plane-mask format result-type) - (declare (type drawable drawable) - (type (or buffer-bytes list pixarray) data) - (type int16 x y) ;; required - (type card16 width height) ;; required - (type (or null pixel) plane-mask) - (type (or null (member :xy-pixmap :z-pixmap)) format) - (type (or null (member image-xy image-x image-z)) result-type) - (clx-values image visual-info)) - (unless result-type - (setq result-type (ecase format - (:xy-pixmap 'image-xy) - (:z-pixmap 'image-z) - ((nil) 'image-x)))) - (unless format - (setq format (case result-type - (image-xy :xy-pixmap) - ((image-z image-x) :z-pixmap)))) - (unless (ecase result-type - (image-xy (eq format :xy-pixmap)) - (image-z (eq format :z-pixmap)) - (image-x t)) - (error "Result-type ~s is incompatible with format ~s" - result-type format)) - (unless plane-mask (setq plane-mask #xffffffff)) - (let ((display (drawable-display drawable))) - (with-buffer-request-and-reply (display +x-getimage+ nil :sizes (8 32)) - (((data (member error :xy-pixmap :z-pixmap)) format) - (drawable drawable) - (int16 x y) - (card16 width height) - (card32 plane-mask)) - (let* ((depth (card8-get 1)) - (length (index* 4 (card32-get 4))) - (visual-info (visual-info display (resource-id-get 8))) - (bitmap-format (display-bitmap-format display)) - (unit (bitmap-format-unit bitmap-format)) - (byte-lsb-first-p (display-image-lsb-first-p display)) - (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) - (declare (type image-depth depth) - (type array-index length) - (type (or null visual-info) visual-info) - (type bitmap-format bitmap-format) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (multiple-value-bind (pad bits-per-pixel) - (ecase format - (:xy-pixmap - (values (bitmap-format-pad bitmap-format) 1)) - (:z-pixmap - (if (= depth 1) - (values (bitmap-format-pad bitmap-format) 1) - (let ((pixmap-format - (find depth (display-pixmap-formats display) - :key #'pixmap-format-depth))) - (declare (type pixmap-format pixmap-format)) - (values (pixmap-format-scanline-pad pixmap-format) - (pixmap-format-bits-per-pixel pixmap-format)))))) - (declare (type (member 8 16 32) pad) - (type (member 1 4 8 16 24 32) bits-per-pixel)) - (let* ((bits-per-line (index* bits-per-pixel width)) - (padded-bits-per-line - (index* (index-ceiling bits-per-line pad) pad)) - (padded-bytes-per-line - (index-ceiling padded-bits-per-line 8)) - (padded-bytes-per-plane - (index* padded-bytes-per-line height)) - (image - (ecase result-type - (image-x - (ecase format - (:xy-pixmap - (read-xy-format-image-x - buffer-bbuf +replysize+ length data - width height depth - padded-bytes-per-line padded-bytes-per-plane - unit byte-lsb-first-p bit-lsb-first-p - pad)) - (:z-pixmap - (read-z-format-image-x - buffer-bbuf +replysize+ length data - width height depth - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p - pad bits-per-pixel)))) - (image-xy - (read-image-xy - buffer-bbuf +replysize+ length data - 0 0 width height depth - padded-bytes-per-line padded-bytes-per-plane - unit byte-lsb-first-p bit-lsb-first-p)) - (image-z - (read-image-z - buffer-bbuf +replysize+ length data - 0 0 width height depth padded-bytes-per-line - bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p))))) - (declare (type image image) - (type array-index bits-per-line - padded-bits-per-line padded-bytes-per-line)) - (when visual-info - (unless (zerop (visual-info-red-mask visual-info)) - (setf (image-red-mask image) - (visual-info-red-mask visual-info))) - (unless (zerop (visual-info-green-mask visual-info)) - (setf (image-green-mask image) - (visual-info-green-mask visual-info))) - (unless (zerop (visual-info-blue-mask visual-info)) - (setf (image-blue-mask image) - (visual-info-blue-mask visual-info)))) - (values image visual-info))))))) - - -;;;----------------------------------------------------------------------------- -;;; PUT-IMAGE - -(defun write-pixarray-1 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (right-bits (index-mod width 8)) - (middle-bits (index- width right-bits)) - (middle-bytes (index-ceiling middle-bits 8)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y right-bits middle-bits - middle-bytes start)) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (start-x x) - (x start-x (index+ x 8))) - ((index>= i end) - (unless (index-zerop right-bits) - (let ((x (index+ start-x middle-bits))) - (declare (type array-index x)) - (setf (aref buffer-bbuf end) - (write-image-assemble-bytes - (aref array y (index+ x 0)) - (if (index> right-bits 1) - (aref array y (index+ x 1)) - 0) - (if (index> right-bits 2) - (aref array y (index+ x 2)) - 0) - (if (index> right-bits 3) - (aref array y (index+ x 3)) - 0) - (if (index> right-bits 4) - (aref array y (index+ x 4)) - 0) - (if (index> right-bits 5) - (aref array y (index+ x 5)) - 0) - (if (index> right-bits 6) - (aref array y (index+ x 6)) - 0) - 0))))) - (declare (type array-index end i start-x x)) - (setf (aref buffer-bbuf i) - (write-image-assemble-bytes - (aref array y (index+ x 0)) - (aref array y (index+ x 1)) - (aref array y (index+ x 2)) - (aref array y (index+ x 3)) - (aref array y (index+ x 4)) - (aref array y (index+ x 5)) - (aref array y (index+ x 6)) - (aref array y (index+ x 7)))))))) - -(defun write-pixarray-4 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-4 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (right-nibbles (index-mod width 2)) - (middle-nibbles (index- width right-nibbles)) - (middle-bytes (index-ceiling middle-nibbles 2)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y right-nibbles middle-nibbles - middle-bytes start)) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (start-x x) - (x start-x (index+ x 2))) - ((index>= i end) - (unless (index-zerop right-nibbles) - (setf (aref buffer-bbuf end) - (write-image-assemble-bytes - (aref array y (index+ start-x middle-nibbles)) - 0)))) - (declare (type array-index end i start-x x)) - (setf (aref buffer-bbuf i) - (write-image-assemble-bytes - (aref array y (index+ x 0)) - (aref array y (index+ x 1)))))))) - -(defun write-pixarray-8 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-8 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y start)) - (do* ((end (index+ start width)) - (i start (index1+ i)) - (x x (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref buffer-bbuf i) (the card8 (aref array y x))))))) - -(defun write-pixarray-16 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-16 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y start)) - (do* ((end (index+ start (index* width 2))) - (i start (index+ i 2)) - (x x (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (let ((pixel (aref array y x))) - (declare (type pixarray-16-element-type pixel)) - (setf (aref buffer-bbuf (index+ i 0)) - (write-image-load-byte 0 pixel 16)) - (setf (aref buffer-bbuf (index+ i 1)) - (write-image-load-byte 8 pixel 16))))))) - -(defun write-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index y start)) - (do* ((end (index+ start (index* width 3))) - (i start (index+ i 3)) - (x x (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (let ((pixel (aref array y x))) - (declare (type pixarray-24-element-type pixel)) - (setf (aref buffer-bbuf (index+ i 0)) - (write-image-load-byte 0 pixel 24)) - (setf (aref buffer-bbuf (index+ i 1)) - (write-image-load-byte 8 pixel 24)) - (setf (aref buffer-bbuf (index+ i 2)) - (write-image-load-byte 16 pixel 24))))))) - -(defun write-pixarray-32 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-32 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y start)) - (do* ((end (index+ start (index* width 4))) - (i start (index+ i 4)) - (x x (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (let ((pixel (aref array y x))) - (declare (type pixarray-32-element-type pixel)) - (setf (aref buffer-bbuf (index+ i 0)) - (write-image-load-byte 0 pixel 32)) - (setf (aref buffer-bbuf (index+ i 1)) - (write-image-load-byte 8 pixel 32)) - (setf (aref buffer-bbuf (index+ i 2)) - (write-image-load-byte 16 pixel 32)) - (setf (aref buffer-bbuf (index+ i 3)) - (write-image-load-byte 24 pixel 32))))))) - -(defun write-pixarray-internal - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel write-pixarray-function - from-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type pixarray pixarray) - (type card16 x y width height) - (type array-index boffset padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type function write-pixarray-function) - (type (member 8 16 32) from-unit to-unit) - (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p - to-byte-lsb-first-p to-bit-lsb-first-p)) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - from-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) - (if (eq image-swap-function 'image-noswap) - (funcall - write-pixarray-function - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) - (with-image-data-buffer (buf (index* height padded-bytes-per-line)) - (funcall - write-pixarray-function - buf 0 pixarray x y width height padded-bytes-per-line - bits-per-pixel) - (funcall - (symbol-function image-swap-function) buf bbuf 0 boffset - (index-ceiling (index* width bits-per-pixel) 8) - padded-bytes-per-line padded-bytes-per-line height - image-swap-lsb-first-p))))) - -(defun write-pixarray - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type pixarray pixarray) - (type card16 x y width height) - (type array-index boffset padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (unless (fast-write-pixarray - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (write-pixarray-internal - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel - (ecase bits-per-pixel - ( 1 #'write-pixarray-1 ) - ( 4 #'write-pixarray-4 ) - ( 8 #'write-pixarray-8 ) - (16 #'write-pixarray-16) - (24 #'write-pixarray-24) - (32 #'write-pixarray-32)) - +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+ - unit byte-lsb-first-p bit-lsb-first-p))) - -(defun write-xy-format-image-x-data - (data obuf data-start obuf-start x y width height - from-padded-bytes-per-line to-padded-bytes-per-line - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type buffer-bytes data obuf) - (type array-index data-start obuf-start - from-padded-bytes-per-line to-padded-bytes-per-line) - (type card16 x y width height) - (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) - (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p - to-byte-lsb-first-p to-bit-lsb-first-p)) - (assert (index-zerop (index-mod x 8))) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - 1 - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) - (let ((x-mod-unit (index-mod x from-bitmap-unit))) - (declare (type card16 x-mod-unit)) - (if (and (index-plusp x-mod-unit) - (not (eq from-byte-lsb-first-p from-bit-lsb-first-p))) - (let* ((temp-width (index+ width x-mod-unit)) - (temp-bytes-per-line (index-ceiling temp-width 8)) - (temp-padded-bits-per-line - (index* (index-ceiling temp-width from-bitmap-unit) - from-bitmap-unit)) - (temp-padded-bytes-per-line - (index-ceiling temp-padded-bits-per-line 8))) - (declare (type card16 temp-width temp-bytes-per-line - temp-padded-bits-per-line temp-padded-bytes-per-line)) - (with-image-data-buffer - (buf (index* height temp-padded-bytes-per-line)) - (funcall - (symbol-function image-swap-function) data buf - (index+ data-start - (index* y from-padded-bytes-per-line) - (index-floor (index- x x-mod-unit) 8)) - 0 temp-bytes-per-line from-padded-bytes-per-line - temp-padded-bytes-per-line height image-swap-lsb-first-p) - (write-xy-format-image-x-data - buf obuf 0 obuf-start x-mod-unit 0 width height - temp-padded-bytes-per-line to-padded-bytes-per-line - from-bitmap-unit to-byte-lsb-first-p to-byte-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p))) - (funcall - (symbol-function image-swap-function) data obuf - (index+ data-start - (index* y from-padded-bytes-per-line) - (index-floor x 8)) - obuf-start (index-ceiling width 8) from-padded-bytes-per-line - to-padded-bytes-per-line height image-swap-lsb-first-p))))) - -(defun write-xy-format-image-x - (display image src-x src-y width height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type display display) - (type image-x image) - (type int16 src-x src-y) - (type card16 width height) - (type array-index padded-bytes-per-line) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (dotimes (plane (image-depth image)) - (let ((data-start - (index* (index* plane (image-height image)) - (image-x-bytes-per-line image))) - (src-y src-y) - (height height)) - (declare (type int16 src-y) - (type card16 height)) - (loop - (when (index-zerop height) (return)) - (let ((nlines - (index-min (index-floor (index- (buffer-size display) - (buffer-boffset display)) - padded-bytes-per-line) - height))) - (declare (type array-index nlines)) - (when (index-plusp nlines) - (write-xy-format-image-x-data - (image-x-data image) (buffer-obuf8 display) - data-start (buffer-boffset display) - src-x src-y width nlines - (image-x-bytes-per-line image) padded-bytes-per-line - (image-x-unit image) (image-x-byte-lsb-first-p image) - (image-x-bit-lsb-first-p image) - unit byte-lsb-first-p bit-lsb-first-p) - (index-incf (buffer-boffset display) - (index* nlines padded-bytes-per-line)) - (index-incf src-y nlines) - (when (index-zerop (index-decf height nlines)) (return)))) - (buffer-flush display))))) - -(defun write-z-format-image-x-data - (data obuf data-start obuf-start x y width height - from-padded-bytes-per-line to-padded-bytes-per-line - bits-per-pixel - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type buffer-bytes data obuf) - (type array-index data-start obuf-start - from-padded-bytes-per-line to-padded-bytes-per-line) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) - (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p - to-byte-lsb-first-p to-bit-lsb-first-p)) - (if (index= bits-per-pixel 1) - (write-xy-format-image-x-data - data obuf data-start obuf-start x y width height - from-padded-bytes-per-line to-padded-bytes-per-line - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (let ((srcoff - (index+ data-start - (index* y from-padded-bytes-per-line) - (index-floor (index* x bits-per-pixel) 8))) - (srclen (index-ceiling (index* width bits-per-pixel) 8))) - (declare (type array-index srcoff srclen)) - (if (and (index= bits-per-pixel 4) (index-oddp x)) - (with-image-data-buffer (buf (index* height to-padded-bytes-per-line)) - (image-swap-nibbles-left - data buf srcoff 0 srclen - from-padded-bytes-per-line to-padded-bytes-per-line height nil) - (write-z-format-image-x-data - buf obuf 0 obuf-start 0 0 width height - to-padded-bytes-per-line to-padded-bytes-per-line - bits-per-pixel - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) - (funcall - (symbol-function image-swap-function) data obuf srcoff obuf-start - srclen from-padded-bytes-per-line to-padded-bytes-per-line height - image-swap-lsb-first-p)))))) - -(defun write-z-format-image-x (display image src-x src-y width height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type display display) - (type image-x image) - (type int16 src-x src-y) - (type card16 width height) - (type array-index padded-bytes-per-line) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (loop - (when (index-zerop height) (return)) - (let ((nlines - (index-min (index-floor (index- (buffer-size display) - (buffer-boffset display)) - padded-bytes-per-line) - height))) - (declare (type array-index nlines)) - (when (index-plusp nlines) - (write-z-format-image-x-data - (image-x-data image) (buffer-obuf8 display) 0 (buffer-boffset display) - src-x src-y width nlines - (image-x-bytes-per-line image) padded-bytes-per-line - (image-x-bits-per-pixel image) - (image-x-unit image) (image-x-byte-lsb-first-p image) - (image-x-bit-lsb-first-p image) - unit byte-lsb-first-p bit-lsb-first-p) - (index-incf (buffer-boffset display) - (index* nlines padded-bytes-per-line)) - (index-incf src-y nlines) - (when (index-zerop (index-decf height nlines)) (return)))) - (buffer-flush display))) - -(defun write-image-xy (display image src-x src-y width height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type display display) - (type image-xy image) - (type array-index padded-bytes-per-line) - (type int16 src-x src-y) - (type card16 width height) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (dolist (bitmap (image-xy-bitmap-list image)) - (declare (type pixarray-1 bitmap)) - (let ((src-y src-y) - (height height)) - (declare (type int16 src-y) - (type card16 height)) - (loop - (let ((nlines - (index-min (index-floor (index- (buffer-size display) - (buffer-boffset display)) - padded-bytes-per-line) - height))) - (declare (type array-index nlines)) - (when (index-plusp nlines) - (write-pixarray - (buffer-obuf8 display) (buffer-boffset display) - bitmap src-x src-y width nlines - padded-bytes-per-line 1 - unit byte-lsb-first-p bit-lsb-first-p) - (index-incf (buffer-boffset display) - (index* nlines padded-bytes-per-line)) - (index-incf src-y nlines) - (when (index-zerop (index-decf height nlines)) (return)))) - (buffer-flush display))))) - -(defun write-image-z (display image src-x src-y width height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type display display) - (type image-z image) - (type array-index padded-bytes-per-line) - (type int16 src-x src-y) - (type card16 width height) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (loop - (let ((bits-per-pixel (image-z-bits-per-pixel image)) - (nlines - (index-min (index-floor (index- (buffer-size display) - (buffer-boffset display)) - padded-bytes-per-line) - height))) - (declare (type (member 1 4 8 16 24 32) bits-per-pixel) - (type array-index nlines)) - (when (index-plusp nlines) - (write-pixarray - (buffer-obuf8 display) (buffer-boffset display) - (image-z-pixarray image) src-x src-y width nlines - padded-bytes-per-line bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (index-incf (buffer-boffset display) - (index* nlines padded-bytes-per-line)) - (index-incf src-y nlines) - (when (index-zerop (index-decf height nlines)) (return)))) - (buffer-flush display))) - -;;; Note: The only difference between a format of :bitmap and :xy-pixmap -;;; of depth 1 is that when sending a :bitmap format the foreground -;;; and background in the gcontext are used. - -(defun put-image (drawable gcontext image &key - (src-x 0) (src-y 0) ;Position within image - (x (required-arg x)) ;Position within drawable - (y (required-arg y)) - width height - bitmap-p) - ;; Copy an image into a drawable. - ;; WIDTH and HEIGHT default from IMAGE. - ;; When BITMAP-P, force format to be :bitmap when depth=1. - ;; This causes gcontext to supply foreground & background pixels. - (declare (type drawable drawable) - (type gcontext gcontext) - (type image image) - (type int16 x y) ;; required - (type int16 src-x src-y) - (type (or null card16) width height) - (type generalized-boolean bitmap-p)) - (let* ((format - (etypecase image - (image-x (image-x-format (the image-x image))) - (image-xy :xy-pixmap) - (image-z :z-pixmap))) - (src-x - (if (image-x-p image) - (index+ src-x (image-x-left-pad (the image-x image))) - src-x)) - (image-width (image-width image)) - (image-height (image-height image)) - (width (min (or width image-width) (index- image-width src-x))) - (height (min (or height image-height) (index- image-height src-y))) - (depth (image-depth image)) - (display (drawable-display drawable)) - (bitmap-format (display-bitmap-format display)) - (unit (bitmap-format-unit bitmap-format)) - (byte-lsb-first-p (display-image-lsb-first-p display)) - (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) - (declare (type (member :bitmap :xy-pixmap :z-pixmap) format) - (type fixnum src-x image-width image-height width height) - (type image-depth depth) - (type display display) - (type bitmap-format bitmap-format) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (when (and bitmap-p (not (index= depth 1))) - (error "Bitmaps must have depth 1")) - (unless (<= 0 src-x (index1- (image-width image))) - (error "src-x not inside image")) - (unless (<= 0 src-y (index1- (image-height image))) - (error "src-y not inside image")) - (when (and (index> width 0) (index> height 0)) - (multiple-value-bind (pad bits-per-pixel) - (ecase format - ((:bitmap :xy-pixmap) - (values (bitmap-format-pad bitmap-format) 1)) - (:z-pixmap - (if (= depth 1) - (values (bitmap-format-pad bitmap-format) 1) - (let ((pixmap-format - (find depth (display-pixmap-formats display) - :key #'pixmap-format-depth))) - (declare (type (or null pixmap-format) pixmap-format)) - (if (null pixmap-format) - (error "The depth of the image ~s does not match any server pixmap format." image)) - (if (not (= (etypecase image - (image-z (image-z-bits-per-pixel image)) - (image-x (image-x-bits-per-pixel image))) - (pixmap-format-bits-per-pixel pixmap-format))) - ;; We could try to use the "/* XXX slow, but works */" - ;; code in XPutImage from X11R4 here. However, that - ;; would require considerable support code - ;; (see XImUtil.c, etc). - (error "The bits-per-pixel of the image ~s does not match any server pixmap format." image)) - (values (pixmap-format-scanline-pad pixmap-format) - (pixmap-format-bits-per-pixel pixmap-format)))))) - (declare (type (member 8 16 32) pad) - (type (member 1 4 8 16 24 32) bits-per-pixel)) - (let* ((left-pad - (if (or (eq format :xy-pixmap) (= depth 1)) - (index-mod src-x (index-min pad +image-pad+)) - 0)) - (left-padded-src-x (index- src-x left-pad)) - (left-padded-width (index+ width left-pad)) - (bits-per-line (index* left-padded-width bits-per-pixel)) - (padded-bits-per-line - (index* (index-ceiling bits-per-line pad) pad)) - (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) - (request-bytes-per-line - (ecase format - ((:bitmap :xy-pixmap) (index* padded-bytes-per-line depth)) - (:z-pixmap padded-bytes-per-line))) - (max-bytes-per-request - (index* (index- (display-max-request-length display) 6) 4)) - (max-request-height - (floor max-bytes-per-request request-bytes-per-line))) - (declare (type card8 left-pad) - (type int16 left-padded-src-x) - (type card16 left-padded-width) - (type array-index bits-per-line padded-bits-per-line - padded-bytes-per-line request-bytes-per-line - max-bytes-per-request max-request-height)) - ;; Be sure that a scanline can fit in a request - (when (index-zerop max-request-height) - (error "Can't even fit one image scanline in a request")) - ;; Be sure a scanline can fit in a buffer - (buffer-ensure-size display padded-bytes-per-line) - ;; Send the image in multiple requests to avoid exceeding the - ;; request limit - (do* ((request-src-y src-y (index+ request-src-y request-height)) - (request-y y (index+ request-y request-height)) - (height-remaining - height (the fixnum (- height-remaining request-height))) - (request-height - (index-min height-remaining max-request-height) - (index-min height-remaining max-request-height))) - ((<= height-remaining 0)) - (declare (type array-index request-src-y request-height) - (fixnum height-remaining)) - (let* ((request-bytes (index* request-bytes-per-line request-height)) - (request-words (index-ceiling request-bytes 4)) - (request-length (index+ request-words 6))) - (declare (type array-index request-bytes) - (type card16 request-words request-length)) - (with-buffer-request (display +x-putimage+ :gc-force gcontext) - ((data (member :bitmap :xy-pixmap :z-pixmap)) - (cond ((or (eq format :bitmap) bitmap-p) :bitmap) - ((plusp left-pad) :xy-pixmap) - (t format))) - (drawable drawable) - (gcontext gcontext) - (card16 width request-height) - (int16 x request-y) - (card8 left-pad depth) - (pad16 nil) - (progn - (length-put 2 request-length) - (setf (buffer-boffset display) (advance-buffer-offset 24)) - (etypecase image - (image-x - (ecase (image-x-format (the image-x image)) - ((:bitmap :xy-pixmap) - (write-xy-format-image-x - display image left-padded-src-x request-src-y - left-padded-width request-height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p)) - (:z-pixmap - (write-z-format-image-x - display image left-padded-src-x request-src-y - left-padded-width request-height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p)))) - (image-xy - (write-image-xy - display image left-padded-src-x request-src-y - left-padded-width request-height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p)) - (image-z - (write-image-z - display image left-padded-src-x request-src-y - left-padded-width request-height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p))) - ;; Be sure the request is padded to a multiple of 4 bytes - (buffer-pad-request display (index- (index* request-words 4) request-bytes)) - ))))))))) - -;;;----------------------------------------------------------------------------- -;;; COPY-IMAGE - -(defun xy-format-image-x->image-x (image x y width height) - (declare (type image-x image) - (type card16 x y width height) - (clx-values image-x)) - (let* ((padded-x (index+ x (image-x-left-pad image))) - (left-pad (index-mod padded-x 8)) - (x (index- padded-x left-pad)) - (unit (image-x-unit image)) - (byte-lsb-first-p (image-x-byte-lsb-first-p image)) - (bit-lsb-first-p (image-x-bit-lsb-first-p image)) - (pad (image-x-pad image)) - (padded-width - (index* (index-ceiling (index+ width left-pad) pad) pad)) - (padded-bytes-per-line (index-ceiling padded-width 8)) - (padded-bytes-per-plane (index* padded-bytes-per-line height)) - (length (index* padded-bytes-per-plane (image-depth image))) - (obuf (make-array length :element-type 'card8))) - (declare (type card16 x) - (type card8 left-pad) - (type (member 8 16 32) unit pad) - (type array-index padded-width padded-bytes-per-line - padded-bytes-per-plane length) - (type buffer-bytes obuf)) - (dotimes (plane (image-depth image)) - (let ((data-start - (index* (image-x-bytes-per-line image) - (image-height image) - plane)) - (obuf-start - (index* padded-bytes-per-plane - plane))) - (declare (type array-index data-start obuf-start)) - (write-xy-format-image-x-data - (image-x-data image) obuf data-start obuf-start - x y width height - (image-x-bytes-per-line image) padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p - unit byte-lsb-first-p bit-lsb-first-p))) - (create-image - :width width :height height :depth (image-depth image) - :data obuf :format (image-x-format image) :bits-per-pixel 1 - :bytes-per-line padded-bytes-per-line - :unit unit :pad pad :left-pad left-pad - :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p))) - -(defun z-format-image-x->image-x (image x y width height) - (declare (type image-x image) - (type card16 x y width height) - (clx-values image-x)) - (let* ((padded-x (index+ x (image-x-left-pad image))) - (left-pad - (if (index= (image-depth image) 1) - (index-mod padded-x 8) - 0)) - (x (index- padded-x left-pad)) - (bits-per-pixel (image-x-bits-per-pixel image)) - (unit (image-x-unit image)) - (byte-lsb-first-p (image-x-byte-lsb-first-p image)) - (bit-lsb-first-p (image-x-bit-lsb-first-p image)) - (pad (image-x-pad image)) - (bits-per-line (index* (index+ width left-pad) bits-per-pixel)) - (padded-bits-per-line (index* (index-ceiling bits-per-line pad) pad)) - (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) - (padded-bytes-per-plane (index* padded-bytes-per-line height)) - (length (index* padded-bytes-per-plane (image-depth image))) - (obuf (make-array length :element-type 'card8))) - (declare (type card16 x) - (type card8 left-pad) - (type (member 8 16 32) unit pad) - (type array-index bits-per-pixel padded-bytes-per-line - padded-bytes-per-plane length) - (type buffer-bytes obuf)) - (write-z-format-image-x-data - (image-x-data image) obuf 0 0 - x y width height - (image-x-bytes-per-line image) padded-bytes-per-line - bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p - unit byte-lsb-first-p bit-lsb-first-p) - (create-image - :width width :height height :depth (image-depth image) - :data obuf :format :z-pixmap :bits-per-pixel bits-per-pixel - :bytes-per-line padded-bytes-per-line - :unit unit :pad pad :left-pad left-pad - :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p))) - -(defun image-x->image-x (image x y width height) - (declare (type image-x image) - (type card16 x y width height) - (clx-values image-x)) - (ecase (image-x-format image) - ((:bitmap :xy-pixmap) - (xy-format-image-x->image-x image x y width height)) - (:z-pixmap - (z-format-image-x->image-x image x y width height)))) - -(defun image-x->image-xy (image x y width height) - (declare (type image-x image) - (type card16 x y width height) - (clx-values image-xy)) - (unless (or (eq (image-x-format image) :bitmap) - (eq (image-x-format image) :xy-pixmap) - (and (eq (image-x-format image) :z-pixmap) - (index= (image-depth image) 1))) - (error "Format conversion from ~S to ~S not supported" - (image-x-format image) :xy-pixmap)) - (read-image-xy - (image-x-data image) 0 (length (image-x-data image)) nil - (index+ x (image-x-left-pad image)) y width height - (image-depth image) (image-x-bytes-per-line image) - (index* (image-x-bytes-per-line image) (image-height image)) - (image-x-unit image) (image-x-byte-lsb-first-p image) - (image-x-bit-lsb-first-p image))) - -(defun image-x->image-z (image x y width height) - (declare (type image-x image) - (type card16 x y width height) - (clx-values image-z)) - (unless (or (eq (image-x-format image) :z-pixmap) - (eq (image-x-format image) :bitmap) - (and (eq (image-x-format image) :xy-pixmap) - (index= (image-depth image) 1))) - (error "Format conversion from ~S to ~S not supported" - (image-x-format image) :z-pixmap)) - (read-image-z - (image-x-data image) 0 (length (image-x-data image)) nil - (index+ x (image-x-left-pad image)) y width height - (image-depth image) (image-x-bytes-per-line image) - (image-x-bits-per-pixel image) - (image-x-unit image) (image-x-byte-lsb-first-p image) - (image-x-bit-lsb-first-p image))) - -(defun copy-pixarray (array x y width height bits-per-pixel) - (declare (type pixarray array) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel)) - (let* ((bits-per-line (index* bits-per-pixel width)) - (padded-bits-per-line - (index* (index-ceiling bits-per-line +image-pad+) +image-pad+)) - (padded-width (index-ceiling padded-bits-per-line bits-per-pixel)) - (copy (make-array (list height padded-width) - :element-type (array-element-type array)))) - (declare (type array-index bits-per-line padded-bits-per-line padded-width) - (type pixarray copy)) - #.(declare-buffun) - (unless (fast-copy-pixarray array copy x y width height bits-per-pixel) - (macrolet - ((copy (array-type element-type) - `(let ((array array) - (copy copy)) - (declare (type ,array-type array copy)) - (do* ((dst-y 0 (index1+ dst-y)) - (src-y y (index1+ src-y))) - ((index>= dst-y height)) - (declare (type card16 dst-y src-y)) - (do* ((dst-x 0 (index1+ dst-x)) - (src-x x (index1+ src-x))) - ((index>= dst-x width)) - (declare (type card16 dst-x src-x)) - (setf (aref copy dst-y dst-x) - (the ,element-type - (aref array src-y src-x)))))))) - (ecase bits-per-pixel - (1 (copy pixarray-1 pixarray-1-element-type)) - (4 (copy pixarray-4 pixarray-4-element-type)) - (8 (copy pixarray-8 pixarray-8-element-type)) - (16 (copy pixarray-16 pixarray-16-element-type)) - (24 (copy pixarray-24 pixarray-24-element-type)) - (32 (copy pixarray-32 pixarray-32-element-type))))) - copy)) - -(defun image-xy->image-x (image x y width height) - (declare (type image-xy image) - (type card16 x y width height) - (clx-values image-x)) - (let* ((padded-bits-per-line - (index* (index-ceiling width +image-pad+) +image-pad+)) - (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) - (padded-bytes-per-plane (index* padded-bytes-per-line height)) - (bytes-total (index* padded-bytes-per-plane (image-depth image))) - (data (make-array bytes-total :element-type 'card8))) - (declare (type array-index padded-bits-per-line padded-bytes-per-line - padded-bytes-per-plane bytes-total) - (type buffer-bytes data)) - (let ((index 0)) - (declare (type array-index index)) - (dolist (bitmap (image-xy-bitmap-list image)) - (declare (type pixarray-1 bitmap)) - (write-pixarray - data index bitmap x y width height padded-bytes-per-line 1 - +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+) - (index-incf index padded-bytes-per-plane))) - (create-image - :width width :height height :depth (image-depth image) - :data data :format :xy-pixmap :bits-per-pixel 1 - :bytes-per-line padded-bytes-per-line - :unit +image-unit+ :pad +image-pad+ - :byte-lsb-first-p +image-byte-lsb-first-p+ - :bit-lsb-first-p +image-bit-lsb-first-p+))) - -(defun image-xy->image-xy (image x y width height) - (declare (type image-xy image) - (type card16 x y width height) - (clx-values image-xy)) - (create-image - :width width :height height :depth (image-depth image) - :data (mapcar - #'(lambda (array) - (declare (type pixarray-1 array)) - (copy-pixarray array x y width height 1)) - (image-xy-bitmap-list image)))) - -(defun image-xy->image-z (image x y width height) - (declare (type image-xy image) - (type card16 x y width height) - (ignore image x y width height)) - (error "Format conversion from ~S to ~S not supported" - :xy-pixmap :z-pixmap)) - -(defun image-z->image-x (image x y width height) - (declare (type image-z image) - (type card16 x y width height) - (clx-values image-x)) - (let* ((bits-per-line (index* width (image-z-bits-per-pixel image))) - (padded-bits-per-line - (index* (index-ceiling bits-per-line +image-pad+) +image-pad+)) - (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) - (bytes-total - (index* padded-bytes-per-line height (image-depth image))) - (data (make-array bytes-total :element-type 'card8)) - (bits-per-pixel (image-z-bits-per-pixel image))) - (declare (type array-index bits-per-line padded-bits-per-line - padded-bytes-per-line bytes-total) - (type buffer-bytes data) - (type (member 1 4 8 16 24 32) bits-per-pixel)) - (write-pixarray - data 0 (image-z-pixarray image) x y width height padded-bytes-per-line - (image-z-bits-per-pixel image) - +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+) - (create-image - :width width :height height :depth (image-depth image) - :data data :format :z-pixmap - :bits-per-pixel bits-per-pixel - :bytes-per-line padded-bytes-per-line - :unit +image-unit+ :pad +image-pad+ - :byte-lsb-first-p +image-byte-lsb-first-p+ - :bit-lsb-first-p +image-bit-lsb-first-p+))) - -(defun image-z->image-xy (image x y width height) - (declare (type image-z image) - (type card16 x y width height) - (ignore image x y width height)) - (error "Format conversion from ~S to ~S not supported" - :z-pixmap :xy-pixmap)) - -(defun image-z->image-z (image x y width height) - (declare (type image-z image) - (type card16 x y width height) - (clx-values image-z)) - (create-image - :width width :height height :depth (image-depth image) - :data (copy-pixarray - (image-z-pixarray image) x y width height - (image-z-bits-per-pixel image)))) - -(defun copy-image (image &key (x 0) (y 0) width height result-type) - ;; Copy with optional sub-imaging and format conversion. - ;; result-type defaults to (type-of image) - (declare (type image image) - (type card16 x y) - (type (or null card16) width height) ;; Default from image - (type (or null (member image-x image-xy image-z)) result-type)) - (declare (clx-values image)) - (let* ((image-width (image-width image)) - (image-height (image-height image)) - (width (or width image-width)) - (height (or height image-height))) - (declare (type card16 image-width image-height width height)) - (unless (<= 0 x (the fixnum (1- image-width))) - (error "x not inside image")) - (unless (<= 0 y (the fixnum (1- image-height))) - (error "y not inside image")) - (setq width (index-min width (max (the fixnum (- image-width x)) 0))) - (setq height (index-min height (max (the fixnum (- image-height y)) 0))) - (let ((copy - (etypecase image - (image-x - (ecase result-type - ((nil image-x) (image-x->image-x image x y width height)) - (image-xy (image-x->image-xy image x y width height)) - (image-z (image-x->image-z image x y width height)))) - (image-xy - (ecase result-type - (image-x (image-xy->image-x image x y width height)) - ((nil image-xy) (image-xy->image-xy image x y width height)) - (image-z (image-xy->image-z image x y width height)))) - (image-z - (ecase result-type - (image-x (image-z->image-x image x y width height)) - (image-xy (image-z->image-xy image x y width height)) - ((nil image-z) (image-z->image-z image x y width height))))))) - (declare (type image copy)) - (setf (image-plist copy) (copy-list (image-plist image))) - (when (and (image-x-hot image) (not (index-zerop x))) - (setf (image-x-hot copy) (index- (image-x-hot image) x))) - (when (and (image-y-hot image) (not (index-zerop y))) - (setf (image-y-hot copy) (index- (image-y-hot image) y))) - copy))) - - -;;;----------------------------------------------------------------------------- -;;; Image I/O functions - - -(defun read-bitmap-file (pathname) - ;; Creates an image from a C include file in standard X11 format - (declare (type (or pathname string stream) pathname)) - (declare (clx-values image)) - (with-open-file (fstream pathname :direction :input) - (let ((line "") - (properties nil) - (name nil) - (name-end nil)) - (declare (type string line) - (type stringable name) - (type list properties)) - ;; Get properties - (loop - (setq line (read-line fstream)) - (unless (char= (aref line 0) #\#) (return)) - (flet ((read-keyword (line start end) - (kintern - (substitute - #\- #\_ - (#-excl string-upcase - #+excl correct-case - (subseq line start end)) - :test #'char=)))) - (when (null name) - (setq name-end (position #\_ line :test #'char= :from-end t) - name (read-keyword line 8 name-end)) - (unless (eq name :image) - (setf (getf properties :name) name))) - (let* ((ind-start (index1+ name-end)) - (ind-end (position #\Space line :test #'char= - :start ind-start)) - (ind (read-keyword line ind-start ind-end)) - (val-start (index1+ ind-end)) - (val (parse-integer line :start val-start))) - (setf (getf properties ind) val)))) - ;; Calculate sizes - (multiple-value-bind (width height depth left-pad) - (flet ((extract-property (ind &rest default) - (prog1 (apply #'getf properties ind default) - (remf properties ind)))) - (values (extract-property :width) - (extract-property :height) - (extract-property :depth 1) - (extract-property :left-pad 0))) - (declare (type (or null card16) width height) - (type image-depth depth) - (type card8 left-pad)) - (unless (and width height) (error "Not a BITMAP file")) - (let* ((bits-per-pixel - (cond ((index> depth 24) 32) - ((index> depth 16) 24) - ((index> depth 8) 16) - ((index> depth 4) 8) - ((index> depth 1) 4) - (t 1))) - (bits-per-line (index* width bits-per-pixel)) - (bytes-per-line (index-ceiling bits-per-line 8)) - (padded-bits-per-line - (index* (index-ceiling bits-per-line 32) 32)) - (padded-bytes-per-line - (index-ceiling padded-bits-per-line 8)) - (data (make-array (* padded-bytes-per-line height) - :element-type 'card8)) - (line-base 0) - (byte 0)) - (declare (type array-index bits-per-line bytes-per-line - padded-bits-per-line padded-bytes-per-line - line-base byte) - (type buffer-bytes data)) - (with-vector (data buffer-bytes) - (flet ((parse-hex (char) - (second - (assoc char - '((#\0 0) (#\1 1) (#\2 2) (#\3 3) - (#\4 4) (#\5 5) (#\6 6) (#\7 7) - (#\8 8) (#\9 9) (#\a 10) (#\b 11) - (#\c 12) (#\d 13) (#\e 14) (#\f 15)) - :test #'char-equal)))) - (declare (inline parse-hex)) - ;; Read data - ;; Note: using read-line instead of read-char would be 20% faster, - ;; but would cons a lot of garbage... - (dotimes (i height) - (dotimes (j bytes-per-line) - (loop (when (eql (read-char fstream) #\x) (return))) - (setf (aref data (index+ line-base byte)) - (index+ (index-ash (parse-hex (read-char fstream)) 4) - (parse-hex (read-char fstream)))) - (incf byte)) - (setq byte 0 - line-base (index+ line-base padded-bytes-per-line))))) - ;; Compensate for left-pad in width and x-hot - (index-decf width left-pad) - (when (and (getf properties :x-hot) (plusp (getf properties :x-hot))) - (index-decf (getf properties :x-hot) left-pad)) - (create-image - :width width :height height - :depth depth :bits-per-pixel bits-per-pixel - :data data :plist properties :format :z-pixmap - :bytes-per-line padded-bytes-per-line - :unit 32 :pad 32 :left-pad left-pad - :byte-lsb-first-p t :bit-lsb-first-p t)))))) - -(defun write-bitmap-file (pathname image &optional name) - ;; Writes an image to a C include file in standard X11 format - ;; NAME argument used for variable prefixes. Defaults to "image" - (declare (type (or pathname string stream) pathname) - (type image image) - (type (or null stringable) name)) - (unless (typep image 'image-x) - (setq image (copy-image image :result-type 'image-x))) - (let* ((plist (image-plist image)) - (name (or name (image-name image) 'image)) - (left-pad (image-x-left-pad image)) - (width (index+ (image-width image) left-pad)) - (height (image-height image)) - (depth - (if (eq (image-x-format image) :z-pixmap) - (image-depth image) - 1)) - (bits-per-pixel (image-x-bits-per-pixel image)) - (bits-per-line (index* width bits-per-pixel)) - (bytes-per-line (index-ceiling bits-per-line 8)) - (last (index* bytes-per-line height)) - (count 0)) - (declare (type list plist) - (type stringable name) - (type card8 left-pad) - (type card16 width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type image-depth depth) - (type array-index bits-per-line bytes-per-line count last)) - ;; Move x-hot by left-pad, if there is an x-hot, so image readers that - ;; don't know about left pad get the hot spot in the right place. We have - ;; already increased width by left-pad. - (when (getf plist :x-hot) - (setq plist (copy-list plist)) - (index-incf (getf plist :x-hot) left-pad)) - (with-image-data-buffer (data last) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - (image-x-unit image) (image-x-byte-lsb-first-p image) - (image-x-bit-lsb-first-p image) 32 t t) - (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) - (funcall - (symbol-function image-swap-function) (image-x-data image) - data 0 0 bytes-per-line (image-x-bytes-per-line image) - bytes-per-line height image-swap-lsb-first-p)) - (with-vector (data buffer-bytes) - (setq name (string-downcase (string name))) - (with-open-file (fstream pathname :direction :output) - (format fstream "#define ~a_width ~d~%" name width) - (format fstream "#define ~a_height ~d~%" name height) - (unless (= depth 1) - (format fstream "#define ~a_depth ~d~%" name depth)) - (unless (zerop left-pad) - (format fstream "#define ~a_left_pad ~d~%" name left-pad)) - (do ((prop plist (cddr prop))) - ((endp prop)) - (when (and (not (member (car prop) '(:width :height))) - (numberp (cadr prop))) - (format fstream "#define ~a_~a ~d~%" - name - (substitute - #\_ #\- (string-downcase (string (car prop))) - :test #'char=) - (cadr prop)))) - (format fstream "static char ~a_bits[] = {" name) - (dotimes (i height) - (dotimes (j bytes-per-line) - (when (zerop (index-mod count 15)) - (terpri fstream) - (write-char #\space fstream)) - (write-string "0x" fstream) - ;; Faster than (format fstream "0x~2,'0x," byte) - (let ((byte (aref data count)) - (translate "0123456789abcdef")) - (declare (type card8 byte)) - (write-char (char translate (ldb (byte 4 4) byte)) fstream) - (write-char (char translate (ldb (byte 4 0) byte)) fstream)) - (index-incf count) - (unless (index= count last) - (write-char #\, fstream)))) - (format fstream "};~%")))))) - -(defun bitmap-image (&optional plist &rest patterns) - ;; Create an image containg pattern - ;; PATTERNS are bit-vector constants (e.g. #*10101) - ;; If the first parameter is a list, its used as the image property-list. - (declare (type (or list bit-vector) plist) - (type list patterns)) ;; list of bitvector - (declare (clx-values image)) - (unless (listp plist) - (push plist patterns) - (setq plist nil)) - (let* ((width (length (first patterns))) - (height (length patterns)) - (bitarray (make-array (list height width) :element-type 'bit)) - (row 0)) - (declare (type card16 width height row) - (type pixarray-1 bitarray)) - (dolist (pattern patterns) - (declare (type simple-bit-vector pattern)) - (dotimes (col width) - (declare (type card16 col)) - (setf (aref bitarray row col) (the bit (aref pattern col)))) - (incf row)) - (create-image :width width :height height :plist plist :data bitarray))) - -(defun image-pixmap (drawable image &key gcontext width height depth) - ;; Create a pixmap containing IMAGE. Size defaults from the image. - ;; DEPTH is the pixmap depth. - ;; GCONTEXT is used for putting the image into the pixmap. - ;; If none is supplied, then one is created, used then freed. - (declare (type drawable drawable) - (type image image) - (type (or null gcontext) gcontext) - (type (or null card16) width height) - (type (or null card8) depth)) - (declare (clx-values pixmap)) - (let* ((image-width (image-width image)) - (image-height (image-height image)) - (image-depth (image-depth image)) - (width (or width image-width)) - (height (or height image-height)) - (depth (or depth image-depth)) - (pixmap (create-pixmap :drawable drawable - :width width - :height height - :depth depth)) - (gc (or gcontext (create-gcontext - :drawable pixmap - :foreground 1 - :background 0)))) - (unless (= depth image-depth) - (if (= image-depth 1) - (unless gcontext (xlib::required-arg gcontext)) - (error "Pixmap depth ~d incompatible with image depth ~d" - depth image-depth))) - (put-image pixmap gc image :x 0 :y 0 :bitmap-p (and (= image-depth 1) - gcontext)) - ;; Tile when image-width is less than the pixmap width, or - ;; the image-height is less than the pixmap height. - ;; ??? Would it be better to create a temporary pixmap and - ;; ??? let the server do the tileing? - (do ((x image-width (+ x image-width))) - ((>= x width)) - (copy-area pixmap gc 0 0 image-width image-height pixmap x 0) - (incf image-width image-width)) - (do ((y image-height (+ y image-height))) - ((>= y height)) - (copy-area pixmap gc 0 0 image-width image-height pixmap 0 y) - (incf image-height image-height)) - (unless gcontext (free-gcontext gc)) - pixmap)) - diff -Nru ecl-16.1.2/src/clx/input.lisp ecl-16.1.3+ds/src/clx/input.lisp --- ecl-16.1.2/src/clx/input.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/input.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,1897 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11 - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -;;; -;;; Change history: -;;; -;;; Date Author Description -;;; ------------------------------------------------------------------------------------- -;;; 12/10/87 LGO Created - -(in-package :xlib) - -;; Event Resource -(defvar *event-free-list* nil) ;; List of unused (processed) events - -(eval-when (:compile-toplevel :load-toplevel :execute) - ;; Maximum number of events supported (the X11 alpha release only has 34) - (defconstant +max-events+ 64) - (defvar *event-key-vector* (make-array +max-events+ :initial-element nil) - "Vector of event keys - See define-event")) - -(defvar *event-macro-vector* (make-array +max-events+ :initial-element nil) - "Vector of event handler functions - See declare-event") -(defvar *event-handler-vector* (make-array +max-events+ :initial-element nil) - "Vector of event handler functions - See declare-event") -(defvar *event-send-vector* (make-array +max-events+ :initial-element nil) - "Vector of event sending functions - See declare-event") - -(defun allocate-event () - (or (threaded-atomic-pop *event-free-list* reply-next reply-buffer) - (make-reply-buffer +replysize+))) - -(defun deallocate-event (reply-buffer) - (declare (type reply-buffer reply-buffer)) - (setf (reply-size reply-buffer) +replysize+) - (threaded-atomic-push reply-buffer *event-free-list* reply-next reply-buffer)) - -;; Extensions are handled as follows: -;; DEFINITION: Use DEFINE-EXTENSION -;; -;; CODE: Use EXTENSION-CODE to get the X11 opcode for an extension. -;; This looks up the code on the display-extension-alist. -;; -;; EVENTS: Use DECLARE-EVENT to define events. This calls ALLOCATE-EXTENSION-EVENT-CODE -;; at LOAD time to define an internal event-code number -;; (stored in the 'event-code property of the event-name) -;; used to index the following vectors: -;; *event-key-vector* Used for getting the event-key -;; *event-macro-vector* Used for getting the event-parameter getting macros -;; -;; The GET-INTERNAL-EVENT-CODE function can be called at runtime to convert -;; a server event-code into an internal event-code used to index the following -;; vectors: -;; *event-handler-vector* Used for getting the event-handler function -;; *event-send-vector* Used for getting the event-sending function -;; -;; The GET-EXTERNAL-EVENT-CODE function can be called at runtime to convert -;; internal event-codes to external (server) codes. -;; -;; ERRORS: Use DEFINE-ERROR to define new error decodings. -;; - - -;; Any event-code greater than 34 is for an extension -(defparameter *first-extension-event-code* 35) - -(defvar *extensions* nil) ;; alist of (extension-name-symbol events errors) - -(defmacro define-extension (name &key events errors) - ;; Define extension NAME with EVENTS and ERRORS. - ;; Note: The case of NAME is important. - ;; To define the request, Use: - ;; (with-buffer-request (display (extension-opcode ,name)) ,@body) - ;; See the REQUESTS file for lots of examples. - ;; To define event handlers, use declare-event. - ;; To define error handlers, use declare-error and define-condition. - (declare (type stringable name) - (type list events errors)) - (let ((name-symbol (kintern name)) ;; Intern name in the keyword package - (event-list (mapcar #'canonicalize-event-name events))) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (setq *extensions* (cons (list ',name-symbol ',event-list ',errors) - (delete ',name-symbol *extensions* :key #'car)))))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun canonicalize-event-name (event) - ;; Returns the event name keyword given an event name stringable - (declare (type stringable event)) - (declare (clx-values event-key)) - (kintern event))) - -(defun extension-event-key-p (key) - (dolist (extension *extensions* nil) - (when (member key (second extension)) - (return t)))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun allocate-extension-event-code (name) - ;; Allocate an event-code for an extension. This is executed at - ;; COMPILE and LOAD time from DECLARE-EVENT. The event-code is - ;; used at compile-time by macros to index the following vectors: - ;; *EVENT-KEY-VECTOR* *EVENT-MACRO-VECTOR* *EVENT-HANDLER-VECTOR* - ;; *EVENT-SEND-VECTOR* - (let ((event-code (get name 'event-code))) - (declare (type (or null card8) event-code)) - (unless event-code - ;; First ensure the name is for a declared extension - (unless (extension-event-key-p name) - (x-type-error name 'event-key)) - (setq event-code (position nil *event-key-vector* - :start *first-extension-event-code*)) - (setf (svref *event-key-vector* event-code) name) - (setf (get name 'event-code) event-code)) - event-code))) - -(defun get-internal-event-code (display code) - ;; Given an X11 event-code, return the internal event-code. - ;; The internal event-code is used for indexing into the following vectors: - ;; *event-key-vector* *event-handler-vector* *event-send-vector* - ;; Returns NIL when the event-code is for an extension that isn't handled. - (declare (type display display) - (type card8 code)) - (declare (clx-values (or null card8))) - (setq code (logand #x7f code)) - (if (< code *first-extension-event-code*) - code - (let* ((code-offset (- code *first-extension-event-code*)) - (event-extensions (display-event-extensions display)) - (code (if (< code-offset (length event-extensions)) - (aref event-extensions code-offset) - 0))) - (declare (type card8 code-offset code)) - (when (zerop code) - (x-cerror "Ignore the event" - 'unimplemented-event :event-code code :display display)) - code))) - -(defun get-external-event-code (display event) - ;; Given an X11 event name, return the event-code - (declare (type display display) - (type event-key event)) - (declare (clx-values card8)) - (let ((code (get-event-code event))) - (declare (type (or null card8) code)) - (when (>= code *first-extension-event-code*) - (setq code (+ *first-extension-event-code* - (or (position code (display-event-extensions display)) - (x-error 'undefined-event :display display :event-name event))))) - code)) - -(defmacro extension-opcode (display name) - ;; Returns the major opcode for extension NAME. - ;; This is a macro to enable NAME to be interned for fast run-time - ;; retrieval. - ;; Note: The case of NAME is important. - (let ((name-symbol (kintern name))) ;; Intern name in the keyword package - `(or (second (assoc ',name-symbol (display-extension-alist ,display))) - (x-error 'absent-extension :name ',name-symbol :display ,display)))) - -(defun initialize-extensions (display) - ;; Initialize extensions for DISPLAY - (let ((event-extensions (make-array 16 :element-type 'card8 :initial-element 0)) - (extension-alist nil)) - (declare (type vector event-extensions) - (type list extension-alist)) - (dolist (extension *extensions*) - (let ((name (first extension)) - (events (second extension))) - (declare (type keyword name) - (type list events)) - (multiple-value-bind (major-opcode first-event first-error) - (query-extension display name) - (declare (type (or null card8) major-opcode first-event first-error)) - (when (and major-opcode (plusp major-opcode)) - (push (list name major-opcode first-event first-error) - extension-alist) - (when (plusp first-event) ;; When there are extension events - ;; Grow extension vector when needed - (let ((max-event (- (+ first-event (length events)) - *first-extension-event-code*))) - (declare (type card8 max-event)) - (when (>= max-event (length event-extensions)) - (let ((new-extensions (make-array (+ max-event 16) :element-type 'card8 - :initial-element 0))) - (declare (type vector new-extensions)) - (replace new-extensions event-extensions) - (setq event-extensions new-extensions)))) - (dolist (event events) - (declare (type symbol event)) - (setf (aref event-extensions (- first-event *first-extension-event-code*)) - (get-event-code event)) - (incf first-event))))))) - (setf (display-event-extensions display) event-extensions) - (setf (display-extension-alist display) extension-alist))) - -;; -;; Reply handlers -;; - -(defvar *pending-command-free-list* nil) - -(defun start-pending-command (display) - (declare (type display display)) - (let ((pending-command (or (threaded-atomic-pop *pending-command-free-list* - pending-command-next pending-command) - (make-pending-command)))) - (declare (type pending-command pending-command)) - (setf (pending-command-reply-buffer pending-command) nil) - (setf (pending-command-process pending-command) (current-process)) - (setf (pending-command-sequence pending-command) - (ldb (byte 16 0) (1+ (buffer-request-number display)))) - ;; Add the pending command to the end of the threaded list of pending - ;; commands for the display. - (with-event-queue-internal (display) - (threaded-nconc pending-command (display-pending-commands display) - pending-command-next pending-command)) - pending-command)) - -(defun stop-pending-command (display pending-command) - (declare (type display display) - (type pending-command pending-command)) - (with-event-queue-internal (display) - ;; Remove the pending command from the threaded list of pending commands - ;; for the display. - (threaded-delete pending-command (display-pending-commands display) - pending-command-next pending-command) - ;; Deallocate any reply buffers in this pending command - (loop - (let ((reply-buffer - (threaded-pop (pending-command-reply-buffer pending-command) - reply-next reply-buffer))) - (declare (type (or null reply-buffer) reply-buffer)) - (if reply-buffer - (deallocate-reply-buffer reply-buffer) - (return nil))))) - ;; Clear pointers to help the Garbage Collector - (setf (pending-command-process pending-command) nil) - ;; Deallocate this pending-command - (threaded-atomic-push pending-command *pending-command-free-list* - pending-command-next pending-command) - nil) - -;;; - -(defvar *reply-buffer-free-lists* (make-array 32 :initial-element nil)) - -(defun allocate-reply-buffer (size) - (declare (type array-index size)) - (if (index<= size +replysize+) - (allocate-event) - (let ((index (integer-length (index1- size)))) - (declare (type array-index index)) - (or (threaded-atomic-pop (svref *reply-buffer-free-lists* index) - reply-next reply-buffer) - (make-reply-buffer (index-ash 1 index)))))) - -(defun deallocate-reply-buffer (reply-buffer) - (declare (type reply-buffer reply-buffer)) - (let ((size (reply-size reply-buffer))) - (declare (type array-index size)) - (if (index<= size +replysize+) - (deallocate-event reply-buffer) - (let ((index (integer-length (index1- size)))) - (declare (type array-index index)) - (threaded-atomic-push reply-buffer (svref *reply-buffer-free-lists* index) - reply-next reply-buffer))))) - -;;; - -(defun read-error-input (display sequence reply-buffer token) - (declare (type display display) - (type reply-buffer reply-buffer) - (type card16 sequence)) - (tagbody - start - (with-event-queue-internal (display) - (let ((command - ;; Find any pending command with this sequence number. - (threaded-dolist (pending-command (display-pending-commands display) - pending-command-next pending-command) - (when (= (pending-command-sequence pending-command) sequence) - (return pending-command))))) - (declare (type (or null pending-command) command)) - (cond ((not (null command)) - ;; Give this reply to the pending command - (threaded-nconc reply-buffer (pending-command-reply-buffer command) - reply-next reply-buffer) - (process-wakeup (pending-command-process command))) - ((member :immediately (display-report-asynchronous-errors display)) - ;; No pending command and we should report the error immediately - (go report-error)) - (t - ;; No pending command found, count this as an asynchronous error - (threaded-nconc reply-buffer (display-asynchronous-errors display) - reply-next reply-buffer))))) - (return-from read-error-input nil) - report-error - (note-input-complete display token) - (apply #'report-error display - (prog1 (make-error display reply-buffer t) - (deallocate-event reply-buffer))))) - -(defun read-reply-input (display sequence length reply-buffer) - (declare (type display display) - (type (or null reply-buffer) reply-buffer) - (type card16 sequence) - (type array-index length)) - (unwind-protect - (progn - (when (index< +replysize+ length) - (let ((repbuf nil)) - (declare (type (or null reply-buffer) repbuf)) - (unwind-protect - (progn - (setq repbuf (allocate-reply-buffer length)) - (buffer-replace (reply-ibuf8 repbuf) (reply-ibuf8 reply-buffer) - 0 +replysize+) - (deallocate-event (shiftf reply-buffer repbuf nil))) - (when repbuf - (deallocate-reply-buffer repbuf)))) - (when (buffer-input display (reply-ibuf8 reply-buffer) +replysize+ length) - (return-from read-reply-input t)) - (setf (reply-data-size reply-buffer) length)) - (with-event-queue-internal (display) - ;; Find any pending command with this sequence number. - (let ((command - (threaded-dolist (pending-command (display-pending-commands display) - pending-command-next pending-command) - (when (= (pending-command-sequence pending-command) sequence) - (return pending-command))))) - (declare (type (or null pending-command) command)) - (when command - ;; Give this reply to the pending command - (threaded-nconc (shiftf reply-buffer nil) - (pending-command-reply-buffer command) - reply-next reply-buffer) - (process-wakeup (pending-command-process command))))) - nil) - (when reply-buffer - (deallocate-reply-buffer reply-buffer)))) - -(defun read-event-input (display code reply-buffer) - (declare (type display display) - (type card8 code) - (type reply-buffer reply-buffer)) - ;; Push the event in the input buffer on the display's event queue - (setf (event-code reply-buffer) - (get-internal-event-code display code)) - (enqueue-event reply-buffer display) - nil) - -(defun note-input-complete (display token) - (declare (type display display)) - (when (eq (display-input-in-progress display) token) - ;; Indicate that input is no longer in progress - (setf (display-input-in-progress display) nil) - ;; Let the event process get the first chance to do input - (let ((process (display-event-process display))) - (when (not (null process)) - (process-wakeup process))) - ;; Then give processes waiting for command responses a chance - (unless (display-input-in-progress display) - (with-event-queue-internal (display) - (threaded-dolist (command (display-pending-commands display) - pending-command-next pending-command) - (process-wakeup (pending-command-process command))))))) - -(defun read-input (display timeout force-output-p predicate &rest predicate-args) - (declare (type display display) - (type (or null number) timeout) - (type generalized-boolean force-output-p) - (dynamic-extent predicate-args)) - (declare (type function predicate) - #+clx-ansi-common-lisp - (dynamic-extent predicate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg predicate)) - (let ((reply-buffer nil) - (token (or (current-process) (cons nil nil)))) - (declare (type (or null reply-buffer) reply-buffer)) - (unwind-protect - (tagbody - loop - (when (display-dead display) - (x-error 'closed-display :display display)) - (when (apply predicate predicate-args) - (return-from read-input nil)) - ;; Check and see if we have to force output - (when (and force-output-p - (or (and (not (eq (display-input-in-progress display) token)) - (not (conditional-store - (display-input-in-progress display) nil token))) - (null (buffer-listen display)))) - (go force-output)) - ;; Ensure that only one process is reading input. - (unless (or (eq (display-input-in-progress display) token) - (conditional-store (display-input-in-progress display) nil token)) - (if (eql timeout 0) - (return-from read-input :timeout) - (apply #'process-block "CLX Input Lock" - #'(lambda (display predicate &rest predicate-args) - (declare (type display display) - (dynamic-extent predicate-args) - (type function predicate) - #+clx-ansi-common-lisp - (dynamic-extent predicate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg predicate)) - (or (apply predicate predicate-args) - (null (display-input-in-progress display)) - (not (null (display-dead display))))) - display predicate predicate-args)) - (go loop)) - ;; Now start gobbling. - (setq reply-buffer (allocate-event)) - (with-buffer-input (reply-buffer :sizes (8 16 32)) - (let ((type 0)) - (declare (type card8 type)) - ;; Wait for input before we disallow aborts. - (unless (eql timeout 0) - (let ((eof-p (buffer-input-wait display timeout))) - (when eof-p (return-from read-input eof-p)))) - (without-aborts - (let ((eof-p (buffer-input display buffer-bbuf 0 +replysize+ - (if force-output-p 0 timeout)))) - (when eof-p - (when (eq eof-p :timeout) - (if force-output-p - (go force-output) - (return-from read-input :timeout))) - (setf (display-dead display) t) - (return-from read-input eof-p))) - (setf (reply-data-size reply-buffer) +replysize+) - (when (= (the card8 (setq type (read-card8 0))) 1) - ;; Normal replies can be longer than +replysize+, so we - ;; have to handle them while aborts are still disallowed. - (let ((value - (read-reply-input - display (read-card16 2) - (index+ +replysize+ (index* (read-card32 4) 4)) - (shiftf reply-buffer nil)))) - (when value - (return-from read-input value)) - (go loop)))) - (if (zerop type) - (read-error-input - display (read-card16 2) (shiftf reply-buffer nil) token) - (read-event-input - display (read-card8 0) (shiftf reply-buffer nil))))) - (go loop) - force-output - (note-input-complete display token) - (display-force-output display) - (setq force-output-p nil) - (go loop)) - (when (not (null reply-buffer)) - (deallocate-reply-buffer reply-buffer)) - (note-input-complete display token)))) - -(defun report-asynchronous-errors (display mode) - (when (and (display-asynchronous-errors display) - (member mode (display-report-asynchronous-errors display))) - (let ((aborted t)) - (unwind-protect - (loop - (let ((error - (with-event-queue-internal (display) - (threaded-pop (display-asynchronous-errors display) - reply-next reply-buffer)))) - (declare (type (or null reply-buffer) error)) - (if error - (apply #'report-error display - (prog1 (make-error display error t) - (deallocate-event error))) - (return (setq aborted nil))))) - ;; If we get aborted out of this, deallocate all outstanding asynchronous - ;; errors. - (when aborted - (with-event-queue-internal (display) - (loop - (let ((reply-buffer - (threaded-pop (display-asynchronous-errors display) - reply-next reply-buffer))) - (declare (type (or null reply-buffer) reply-buffer)) - (if reply-buffer - (deallocate-event reply-buffer) - (return nil)))))))))) - -(defun wait-for-event (display timeout force-output-p) - (declare (type display display) - (type (or null number) timeout) - (type generalized-boolean force-output-p)) - (let ((event-process-p (not (eql timeout 0)))) - (declare (type generalized-boolean event-process-p)) - (unwind-protect - (loop - (when event-process-p - (conditional-store (display-event-process display) nil (current-process))) - (let ((eof (read-input - display timeout force-output-p - #'(lambda (display) - (declare (type display display)) - (or (not (null (display-new-events display))) - (and (display-asynchronous-errors display) - (member :before-event-handling - (display-report-asynchronous-errors display)) - t))) - display))) - (when eof (return eof))) - ;; Report asynchronous errors here if the user wants us to. - (when event-process-p - (report-asynchronous-errors display :before-event-handling)) - (when (not (null (display-new-events display))) - (return nil))) - (when (and event-process-p - (eq (display-event-process display) (current-process))) - (setf (display-event-process display) nil))))) - -(defun read-reply (display pending-command) - (declare (type display display) - (type pending-command pending-command)) - (loop - (when (read-input display nil nil - #'(lambda (pending-command) - (declare (type pending-command pending-command)) - (not (null (pending-command-reply-buffer pending-command)))) - pending-command) - (x-error 'closed-display :display display)) - (let ((reply-buffer - (with-event-queue-internal (display) - (threaded-pop (pending-command-reply-buffer pending-command) - reply-next reply-buffer)))) - (declare (type reply-buffer reply-buffer)) - ;; Check for error. - (with-buffer-input (reply-buffer) - (ecase (read-card8 0) - (0 (apply #'report-error display - (prog1 (make-error display reply-buffer nil) - (deallocate-reply-buffer reply-buffer)))) - (1 (return reply-buffer))))))) - -;;; - -(defun event-listen (display &optional (timeout 0)) - (declare (type display display) - (type (or null number) timeout) - (clx-values number-of-events-queued eof-or-timeout)) - ;; Returns the number of events queued locally, if any, else nil. Hangs - ;; waiting for events, forever if timeout is nil, else for the specified - ;; number of seconds. - (let* ((current-event-symbol (car (display-current-event-symbol display))) - (current-event (and (boundp current-event-symbol) - (symbol-value current-event-symbol))) - (queue (if current-event - (reply-next (the reply-buffer current-event)) - (display-event-queue-head display)))) - (declare (type symbol current-event-symbol) - (type (or null reply-buffer) current-event queue)) - (if queue - (values - (with-event-queue-internal (display :timeout timeout) - (threaded-length queue reply-next reply-buffer)) - nil) - (with-event-queue (display :timeout timeout :inline t) - (let ((eof-or-timeout (wait-for-event display timeout nil))) - (if eof-or-timeout - (values nil eof-or-timeout) - (values - (with-event-queue-internal (display :timeout timeout) - (threaded-length (display-new-events display) - reply-next reply-buffer)) - nil))))))) - -(defun queue-event (display event-key &rest args &key append-p send-event-p &allow-other-keys) - ;; The event is put at the head of the queue if append-p is nil, else the tail. - ;; Additional arguments depend on event-key, and are as specified above with - ;; declare-event, except that both resource-ids and resource objects are accepted - ;; in the event components. - (declare (type display display) - (type event-key event-key) - (type generalized-boolean append-p send-event-p) - (dynamic-extent args)) - (unless (get event-key 'event-code) - (x-type-error event-key 'event-key)) - (let* ((event (allocate-event)) - (buffer (reply-ibuf8 event)) - (event-code (get event-key 'event-code))) - (declare (type reply-buffer event) - (type buffer-bytes buffer) - (type (or null card8) event-code)) - (unless event-code (x-type-error event-key 'event-key)) - (setf (event-code event) event-code) - (with-display (display) - (apply (svref *event-send-vector* event-code) display args) - (buffer-replace buffer - (display-obuf8 display) - 0 - +replysize+ - (index+ 12 (buffer-boffset display))) - (setf (aref buffer 0) (if send-event-p (logior event-code #x80) event-code) - (aref buffer 2) 0 - (aref buffer 3) 0)) - (with-event-queue (display) - (if append-p - (enqueue-event event display) - (with-event-queue-internal (display) - (threaded-requeue event - (display-event-queue-head display) - (display-event-queue-tail display) - reply-next reply-buffer)))))) - -(defun enqueue-event (new-event display) - (declare (type reply-buffer new-event) - (type display display)) - ;; Place EVENT at the end of the event queue for DISPLAY - (let* ((event-code (event-code new-event)) - (event-key (and (index< event-code (length *event-key-vector*)) - (svref *event-key-vector* event-code)))) - (declare (type array-index event-code) - (type (or null keyword) event-key)) - (if (null event-key) - (unwind-protect - (cerror "Ignore this event" "No handler for ~s event" event-key) - (deallocate-event new-event)) - (with-event-queue-internal (display) - (threaded-enqueue new-event - (display-event-queue-head display) - (display-event-queue-tail display) - reply-next reply-buffer) - (unless (display-new-events display) - (setf (display-new-events display) new-event)))))) - - -(defmacro define-event (name code) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (setf (svref *event-key-vector* ,code) ',name) - (setf (get ',name 'event-code) ,code))) - -;; Event names. Used in "type" field in XEvent structures. Not to be -;; confused with event masks above. They start from 2 because 0 and 1 -;; are reserved in the protocol for errors and replies. */ - -(define-event :key-press 2) -(define-event :key-release 3) -(define-event :button-press 4) -(define-event :button-release 5) -(define-event :motion-notify 6) -(define-event :enter-notify 7) -(define-event :leave-notify 8) -(define-event :focus-in 9) -(define-event :focus-out 10) -(define-event :keymap-notify 11) -(define-event :exposure 12) -(define-event :graphics-exposure 13) -(define-event :no-exposure 14) -(define-event :visibility-notify 15) -(define-event :create-notify 16) -(define-event :destroy-notify 17) -(define-event :unmap-notify 18) -(define-event :map-notify 19) -(define-event :map-request 20) -(define-event :reparent-notify 21) -(define-event :configure-notify 22) -(define-event :configure-request 23) -(define-event :gravity-notify 24) -(define-event :resize-request 25) -(define-event :circulate-notify 26) -(define-event :circulate-request 27) -(define-event :property-notify 28) -(define-event :selection-clear 29) -(define-event :selection-request 30) -(define-event :selection-notify 31) -(define-event :colormap-notify 32) -(define-event :client-message 33) -(define-event :mapping-notify 34) - - -(defmacro declare-event (event-codes &body declares &environment env) - ;; Used to indicate the keyword arguments for handler functions in - ;; process-event and event-case. - ;; Generates the functions used in SEND-EVENT. - ;; A compiler warning is printed when all of EVENT-CODES are not - ;; defined by a preceding DEFINE-EXTENSION. - ;; The body is a list of declarations, each of which has the form: - ;; (type . items) Where type is a data-type, and items is a list of - ;; symbol names. The item order corresponds to the order of fields - ;; in the event sent by the server. An item may be a list of items. - ;; In this case, each item is aliased to the same event field. - ;; This is used to give all events an EVENT-WINDOW item. - ;; See the INPUT file for lots of examples. - (declare (type (or keyword list) event-codes) - (type (alist (field-type symbol) (field-names list)) - declares)) - (when (atom event-codes) (setq event-codes (list event-codes))) - (setq event-codes (mapcar #'canonicalize-event-name event-codes)) - (let* ((keywords nil) - (name (first event-codes)) - (get-macro (xintern name '-event-get-macro)) - (get-function (xintern name '-event-get)) - (put-function (xintern name '-event-put))) - (multiple-value-bind (get-code get-index get-sizes) - (get-put-items - 2 declares nil - #'(lambda (type index item args) - (flet ((event-get (type index item args) - (unless (member type '(pad8 pad16)) - `(,(kintern item) - (,(getify type) ,index ,@args))))) - (if (atom item) - (event-get type index item args) - (mapcan #'(lambda (item) - (event-get type index item args)) - item))))) - (declare (ignore get-index)) - (multiple-value-bind (put-code put-index put-sizes) - (get-put-items - 2 declares t - #'(lambda (type index item args) - (unless (member type '(pad8 pad16)) - (if (atom item) - (progn - (push item keywords) - `((,(putify type) ,index ,item ,@args))) - (let ((names (mapcar #'(lambda (name) (kintern name)) - item))) - (setq keywords (append item keywords)) - `((,(putify type) ,index - (check-consistency ',names ,@item) ,@args))))))) - (declare (ignore put-index)) - `(within-definition (,name declare-event) - (defun ,get-macro (display event-key variable) - ;; Note: we take pains to macroexpand the get-code here to enable application - ;; code to be compiled without having the CLX macros file loaded. - `(let ((%buffer ,display)) - (declare (ignorable %buffer)) - ,(getf `(:display (the display ,display) - :event-key (the keyword ,event-key) - :event-code (the card8 (logand #x7f (read-card8 0))) - :send-event-p (logbitp 7 (read-card8 0)) - ,@',(mapcar #'(lambda (form) - (clx-macroexpand form env)) - get-code)) - variable))) - - (defun ,get-function (display event handler) - (declare (type display display) - (type reply-buffer event)) - (declare (type function handler) - #+clx-ansi-common-lisp - (dynamic-extent handler) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg handler)) - (reading-event (event :display display :sizes (8 16 ,@get-sizes)) - (funcall handler - :display display - :event-key (svref *event-key-vector* (event-code event)) - :event-code (logand #x7f (card8-get 0)) - :send-event-p (logbitp 7 (card8-get 0)) - ,@get-code))) - - (defun ,put-function (display &key ,@(setq keywords (nreverse keywords)) - &allow-other-keys) - (declare (type display display)) - ,(when (member 'sequence keywords) - `(unless sequence (setq sequence (display-request-number display)))) - (with-buffer-output (display :sizes ,put-sizes - :index (index+ (buffer-boffset display) 12)) - ,@put-code)) - - ,@(mapcar #'(lambda (name) - (allocate-extension-event-code name) - `(let ((event-code (or (get ',name 'event-code) - (allocate-extension-event-code ',name)))) - (setf (svref *event-macro-vector* event-code) - (function ,get-macro)) - (setf (svref *event-handler-vector* event-code) - (function ,get-function)) - (setf (svref *event-send-vector* event-code) - (function ,put-function)))) - event-codes) - ',name))))) - -(defun check-consistency (names &rest args) - ;; Ensure all args are nil or have the same value. - ;; Returns the consistent non-nil value. - (let ((value (car args))) - (dolist (arg (cdr args)) - (if value - (when (and arg (not (eq arg value))) - (x-error 'inconsistent-parameters - :parameters (mapcan #'list names args))) - (setq value arg))) - value)) - -(declare-event (:key-press :key-release :button-press :button-release) - ;; for key-press and key-release, code is the keycode - ;; for button-press and button-release, code is the button number - (data code) - (card16 sequence) - ((or null card32) time) - (window root (window event-window)) - ((or null window) child) - (int16 root-x root-y x y) - (card16 state) - (boolean same-screen-p) - ) - -(declare-event :motion-notify - ((data boolean) hint-p) - (card16 sequence) - ((or null card32) time) - (window root (window event-window)) - ((or null window) child) - (int16 root-x root-y x y) - (card16 state) - (boolean same-screen-p)) - -(declare-event (:enter-notify :leave-notify) - ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual)) kind) - (card16 sequence) - ((or null card32) time) - (window root (window event-window)) - ((or null window) child) - (int16 root-x root-y x y) - (card16 state) - ((member8 :normal :grab :ungrab) mode) - ((bit 0) focus-p) - ((bit 1) same-screen-p)) - -(declare-event (:focus-in :focus-out) - ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual - :pointer :pointer-root :none)) - kind) - (card16 sequence) - (window (window event-window)) - ((member8 :normal :while-grabbed :grab :ungrab) mode)) - -(declare-event :keymap-notify - ((bit-vector256 0) keymap)) - -(declare-event :exposure - (card16 sequence) - (window (window event-window)) - (card16 x y width height count)) - -(declare-event :graphics-exposure - (card16 sequence) - (drawable (drawable event-window)) - (card16 x y width height) - (card16 minor) ;; Minor opcode - (card16 count) - (card8 major)) - -(declare-event :no-exposure - (card16 sequence) - (drawable (drawable event-window)) - (card16 minor) - (card8 major)) - -(declare-event :visibility-notify - (card16 sequence) - (window (window event-window)) - ((member8 :unobscured :partially-obscured :fully-obscured) state)) - -(declare-event :create-notify - (card16 sequence) - (window (parent event-window) window) - (int16 x y) - (card16 width height border-width) - (boolean override-redirect-p)) - -(declare-event :destroy-notify - (card16 sequence) - (window event-window window)) - -(declare-event :unmap-notify - (card16 sequence) - (window event-window window) - (boolean configure-p)) - -(declare-event :map-notify - (card16 sequence) - (window event-window window) - (boolean override-redirect-p)) - -(declare-event :map-request - (card16 sequence) - (window (parent event-window) window)) - -(declare-event :reparent-notify - (card16 sequence) - (window event-window window parent) - (int16 x y) - (boolean override-redirect-p)) - -(declare-event :configure-notify - (card16 sequence) - (window event-window window) - ((or null window) above-sibling) - (int16 x y) - (card16 width height border-width) - (boolean override-redirect-p)) - -(declare-event :configure-request - ((data (member8 :above :below :top-if :bottom-if :opposite)) stack-mode) - (card16 sequence) - (window (parent event-window) window) - ((or null window) above-sibling) - (int16 x y) - (card16 width height border-width value-mask)) - -(declare-event :gravity-notify - (card16 sequence) - (window event-window window) - (int16 x y)) - -(declare-event :resize-request - (card16 sequence) - (window (window event-window)) - (card16 width height)) - -(declare-event :circulate-notify - (card16 sequence) - (window event-window window parent) - ((member8 :top :bottom) place)) - -(declare-event :circulate-request - (card16 sequence) - (window (parent event-window) window) - (pad16 1 2) - ((member8 :top :bottom) place)) - -(declare-event :property-notify - (card16 sequence) - (window (window event-window)) - (keyword atom) ;; keyword - ((or null card32) time) - ((member8 :new-value :deleted) state)) - -(declare-event :selection-clear - (card16 sequence) - ((or null card32) time) - (window (window event-window)) - (keyword selection) ;; keyword - ) - -(declare-event :selection-request - (card16 sequence) - ((or null card32) time) - (window (window event-window) requestor) - (keyword selection target) - ((or null keyword) property) - ) - -(declare-event :selection-notify - (card16 sequence) - ((or null card32) time) - (window (window event-window)) - (keyword selection target) - ((or null keyword) property) - ) - -(declare-event :colormap-notify - (card16 sequence) - (window (window event-window)) - ((or null colormap) colormap) - (boolean new-p installed-p)) - -(declare-event :client-message - (data format) - (card16 sequence) - (window (window event-window)) - (keyword type) - ((client-message-sequence format) data)) - -(declare-event :mapping-notify - (card16 sequence) - ((member8 :modifier :keyboard :pointer) request) - (card8 start) ;; first key-code - (card8 count)) - - -;; -;; EVENT-LOOP -;; - -(defun event-loop-setup (display) - (declare (type display display) - (clx-values progv-vars progv-vals - current-event-symbol current-event-discarded-p-symbol)) - (let* ((progv-vars (display-current-event-symbol display)) - (current-event-symbol (first progv-vars)) - (current-event-discarded-p-symbol (second progv-vars))) - (declare (type list progv-vars) - (type symbol current-event-symbol current-event-discarded-p-symbol)) - (values - progv-vars - (list (if (boundp current-event-symbol) - ;; The current event is already bound, so bind it to the next - ;; event. - (let ((event (symbol-value current-event-symbol))) - (declare (type (or null reply-buffer) event)) - (and event (reply-next (the reply-buffer event)))) - ;; The current event isn't bound, so bind it to the head of the - ;; event queue. - (display-event-queue-head display)) - nil) - current-event-symbol - current-event-discarded-p-symbol))) - -(defun event-loop-step-before (display timeout force-output-p current-event-symbol) - (declare (type display display) - (type (or null number) timeout) - (type generalized-boolean force-output-p) - (type symbol current-event-symbol) - (clx-values event eof-or-timeout)) - (unless (symbol-value current-event-symbol) - (let ((eof-or-timeout (wait-for-event display timeout force-output-p))) - (when eof-or-timeout - (return-from event-loop-step-before (values nil eof-or-timeout)))) - (setf (symbol-value current-event-symbol) (display-new-events display))) - (let ((event (symbol-value current-event-symbol))) - (declare (type reply-buffer event)) - (with-event-queue-internal (display) - (when (eq event (display-new-events display)) - (setf (display-new-events display) (reply-next event)))) - (values event nil))) - -(defun dequeue-event (display event) - (declare (type display display) - (type reply-buffer event) - (clx-values next)) - ;; Remove the current event from the event queue - (with-event-queue-internal (display) - (let ((next (reply-next event)) - (head (display-event-queue-head display))) - (declare (type (or null reply-buffer) next head)) - (when (eq event (display-new-events display)) - (setf (display-new-events display) next)) - (cond ((eq event head) - (threaded-dequeue (display-event-queue-head display) - (display-event-queue-tail display) - reply-next reply-buffer)) - ((null head) - (setq next nil)) - (t - (do* ((previous head current) - (current (reply-next previous) (reply-next previous))) - ((or (null current) (eq event current)) - (when (eq event current) - (when (eq current (display-event-queue-tail display)) - (setf (display-event-queue-tail display) previous)) - (setf (reply-next previous) next))) - (declare (type reply-buffer previous) - (type (or null reply-buffer) current))))) - next))) - -(defun event-loop-step-after - (display event discard-p current-event-symbol current-event-discarded-p-symbol - &optional aborted) - (declare (type display display) - (type reply-buffer event) - (type generalized-boolean discard-p aborted) - (type symbol current-event-symbol current-event-discarded-p-symbol)) - (when (and discard-p - (not aborted) - (not (symbol-value current-event-discarded-p-symbol))) - (discard-current-event display)) - (let ((next (reply-next event))) - (declare (type (or null reply-buffer) next)) - (when (symbol-value current-event-discarded-p-symbol) - (setf (symbol-value current-event-discarded-p-symbol) nil) - (setq next (dequeue-event display event)) - (deallocate-event event)) - (setf (symbol-value current-event-symbol) next))) - -(defmacro event-loop ((display event timeout force-output-p discard-p) &body body) - ;; Bind EVENT to the events for DISPLAY. - ;; This is the "GUTS" of process-event and event-case. - `(let ((.display. ,display) - (.timeout. ,timeout) - (.force-output-p. ,force-output-p) - (.discard-p. ,discard-p)) - (declare (type display .display.) - (type (or null number) .timeout.) - (type generalized-boolean .force-output-p. .discard-p.)) - (with-event-queue (.display. ,@(and timeout `(:timeout .timeout.))) - (multiple-value-bind (.progv-vars. .progv-vals. - .current-event-symbol. .current-event-discarded-p-symbol.) - (event-loop-setup .display.) - (declare (type list .progv-vars. .progv-vals.) - (type symbol .current-event-symbol. .current-event-discarded-p-symbol.)) - (progv .progv-vars. .progv-vals. - (loop - (multiple-value-bind (.event. .eof-or-timeout.) - (event-loop-step-before - .display. .timeout. .force-output-p. - .current-event-symbol.) - (declare (type (or null reply-buffer) .event.)) - (when (null .event.) (return (values nil .eof-or-timeout.))) - (let ((.aborted. t)) - (unwind-protect - (progn - (let ((,event .event.)) - (declare (type reply-buffer ,event)) - ,@body) - (setq .aborted. nil)) - (event-loop-step-after - .display. .event. .discard-p. - .current-event-symbol. .current-event-discarded-p-symbol. - .aborted.)))))))))) - -(defun discard-current-event (display) - ;; Discard the current event for DISPLAY. - ;; Returns NIL when the event queue is empty, else T. - ;; To ensure events aren't ignored, application code should only call - ;; this when throwing out of event-case or process-next-event, or from - ;; inside even-case, event-cond or process-event when :peek-p is T and - ;; :discard-p is NIL. - (declare (type display display) - (clx-values generalized-boolean)) - (let* ((symbols (display-current-event-symbol display)) - (event - (let ((current-event-symbol (first symbols))) - (declare (type symbol current-event-symbol)) - (when (boundp current-event-symbol) - (symbol-value current-event-symbol))))) - (declare (type list symbols) - (type (or null reply-buffer) event)) - (unless (null event) - ;; Set the discarded-p flag - (let ((current-event-discarded-p-symbol (second symbols))) - (declare (type symbol current-event-discarded-p-symbol)) - (when (boundp current-event-discarded-p-symbol) - (setf (symbol-value current-event-discarded-p-symbol) t))) - ;; Return whether the event queue is empty - (not (null (reply-next (the reply-buffer event))))))) - -;; -;; PROCESS-EVENT -;; -(defun process-event (display &key handler timeout peek-p discard-p (force-output-p t)) - ;; If force-output-p is true, first invokes display-force-output. Invokes handler - ;; on each queued event until handler returns non-nil, and that returned object is - ;; then returned by process-event. If peek-p is true, then the event is not - ;; removed from the queue. If discard-p is true, then events for which handler - ;; returns nil are removed from the queue, otherwise they are left in place. Hangs - ;; until non-nil is generated for some event, or for the specified timeout (in - ;; seconds, if given); however, it is acceptable for an implementation to wait only - ;; once on network data, and therefore timeout prematurely. Returns nil on - ;; timeout. If handler is a sequence, it is expected to contain handler functions - ;; specific to each event class; the event code is used to index the sequence, - ;; fetching the appropriate handler. Handler is called with raw resource-ids, not - ;; with resource objects. The arguments to the handler are described using declare-event. - ;; - ;; T for peek-p means the event (for which the handler returns non-nil) is not removed - ;; from the queue (it is left in place), NIL means the event is removed. - - (declare (type display display) - (type (or null number) timeout) - (type generalized-boolean peek-p discard-p force-output-p)) - (declare (type t handler) - #+clx-ansi-common-lisp - (dynamic-extent handler) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera handler)) - (event-loop (display event timeout force-output-p discard-p) - (let* ((event-code (event-code event)) ;; Event decoder defined by DECLARE-EVENT - (event-decoder (and (index< event-code (length *event-handler-vector*)) - (svref *event-handler-vector* event-code)))) - (declare (type array-index event-code) - (type (or null function) event-decoder)) - (if event-decoder - (let ((event-handler (if (functionp handler) - handler - (and (type? handler 'sequence) - (< event-code (length handler)) - (elt handler event-code))))) - (if event-handler - (let ((result (funcall event-decoder display event event-handler))) - (when result - (unless peek-p - (discard-current-event display)) - (return result))) - (cerror "Ignore this event" - "No handler for ~s event" - (svref *event-key-vector* event-code)))) - (cerror "Ignore this event" - "Server Error: event with unknown event code ~d received." - event-code))))) - -(defun make-event-handlers (&key (type 'array) default) - (declare (type t type) ;Sequence type specifier - (type (or null function) default) - (clx-values sequence)) ;Default handler for initial content - ;; Makes a handler sequence suitable for process-event - (make-sequence type +max-events+ :initial-element default)) - -(defun event-handler (handlers event-key) - (declare (type sequence handlers) - (type event-key event-key) - (clx-values function)) - ;; Accessor for a handler sequence - (elt handlers (position event-key *event-key-vector* :test #'eq))) - -(defun set-event-handler (handlers event-key handler) - (declare (type sequence handlers) - (type event-key event-key) - (type function handler) - (clx-values handler)) - (setf (elt handlers (position event-key *event-key-vector* :test #'eq)) handler)) - -(defsetf event-handler set-event-handler) - -;; -;; EVENT-CASE -;; - -(defmacro event-case ((&rest args) &body clauses) - ;; If force-output-p is true, first invokes display-force-output. Executes the - ;; matching clause for each queued event until a clause returns non-nil, and that - ;; returned object is then returned by event-case. If peek-p is true, then the - ;; event is not removed from the queue. If discard-p is true, then events for - ;; which the clause returns nil are removed from the queue, otherwise they are left - ;; in place. Hangs until non-nil is generated for some event, or for the specified - ;; timeout (in seconds, if given); however, it is acceptable for an implementation - ;; to wait only once on network data, and therefore timeout prematurely. Returns - ;; nil on timeout. In each clause, event-or-events is an event-key or a list of - ;; event-keys (but they need not be typed as keywords) or the symbol t or otherwise - ;; (but only in the last clause). The keys are not evaluated, and it is an error - ;; for the same key to appear in more than one clause. Args is the list of event - ;; components of interest; corresponding values (if any) are bound to variables - ;; with these names (i.e., the args are variable names, not keywords, the keywords - ;; are derived from the variable names). An arg can also be a (keyword var) form, - ;; as for keyword args in a lambda lists. If no t/otherwise clause appears, it is - ;; equivalent to having one that returns nil. - (declare (arglist (display &key timeout peek-p discard-p (force-output-p t)) - (event-or-events ((&rest args) |...|) &body body) |...|)) - ;; Event-case is just event-cond with the whole body in the test-form - `(event-cond ,args - ,@(mapcar - #'(lambda (clause) - `(,(car clause) ,(cadr clause) (progn ,@(cddr clause)))) - clauses))) - -;; -;; EVENT-COND -;; - -(defmacro event-cond ((display &key timeout peek-p discard-p (force-output-p t)) - &body clauses) - ;; The clauses of event-cond are of the form: - ;; (event-or-events binding-list test-form . body-forms) - ;; - ;; EVENT-OR-EVENTS event-key or a list of event-keys (but they - ;; need not be typed as keywords) or the symbol t - ;; or otherwise (but only in the last clause). If - ;; no t/otherwise clause appears, it is equivalent - ;; to having one that returns nil. The keys are - ;; not evaluated, and it is an error for the same - ;; key to appear in more than one clause. - ;; - ;; BINDING-LIST The list of event components of interest. - ;; corresponding values (if any) are bound to - ;; variables with these names (i.e., the binding-list - ;; has variable names, not keywords, the keywords are - ;; derived from the variable names). An arg can also - ;; be a (keyword var) form, as for keyword args in a - ;; lambda list. - ;; - ;; The matching TEST-FORM for each queued event is executed until a - ;; clause's test-form returns non-nil. Then the BODY-FORMS are - ;; evaluated, returning the (possibly multiple) values of the last - ;; form from event-cond. If there are no body-forms then, if the - ;; test-form is non-nil, the value of the test-form is returned as a - ;; single value. - ;; - ;; Options: - ;; FORCE-OUTPUT-P When true, first invoke display-force-output if no - ;; input is pending. - ;; - ;; PEEK-P When true, then the event is not removed from the queue. - ;; - ;; DISCARD-P When true, then events for which the clause returns nil - ;; are removed from the queue, otherwise they are left in place. - ;; - ;; TIMEOUT If NIL, hang until non-nil is generated for some event's - ;; test-form. Otherwise return NIL after TIMEOUT seconds have - ;; elapsed. - ;; - (declare (arglist (display &key timeout peek-p discard-p force-output-p) - (event-or-events (&rest args) test-form &body body) |...|)) - (let ((event (gensym)) - (disp (gensym)) - (peek (gensym))) - `(let ((,disp ,display) - (,peek ,peek-p)) - (declare (type display ,disp)) - (event-loop (,disp ,event ,timeout ,force-output-p ,discard-p) - (event-dispatch (,disp ,event ,peek) ,@clauses))))) - -(defun get-event-code (event) - ;; Returns the event code given an event-key - (declare (type event-key event)) - (declare (clx-values card8)) - (or (get event 'event-code) - (x-type-error event 'event-key))) - -(defun universal-event-get-macro (display event-key variable) - (getf - `(:display (the display ,display) :event-key (the keyword ,event-key) :event-code - (the card8 (logand 127 (read-card8 0))) :send-event-p - (logbitp 7 (read-card8 0))) - variable)) - -(defmacro event-dispatch ((display event peek-p) &body clauses) - ;; Helper macro for event-case - ;; CLAUSES are of the form: - ;; (event-or-events binding-list test-form . body-forms) - (let ((event-key (gensym)) - (all-events (make-array +max-events+ :element-type 'bit :initial-element 0))) - `(reading-event (,event) - (let ((,event-key (svref *event-key-vector* (event-code ,event)))) - (case ,event-key - ,@(mapcar - #'(lambda (clause) ; Translate event-cond clause to case clause - (let* ((events (first clause)) - (arglist (second clause)) - (test-form (third clause)) - (body-forms (cdddr clause))) - (flet ((event-clause (display peek-p first-form rest-of-forms) - (if rest-of-forms - `(when ,first-form - (unless ,peek-p (discard-current-event ,display)) - (return (progn ,@rest-of-forms))) - ;; No body forms, return the result of the test form - (let ((result (gensym))) - `(let ((,result ,first-form)) - (when ,result - (unless ,peek-p (discard-current-event ,display)) - (return ,result))))))) - - (if (member events '(otherwise t)) - ;; code for OTHERWISE clause. - ;; Find all events NOT used by other clauses - (let ((keys (do ((i 0 (1+ i)) - (key nil) - (result nil)) - ((>= i +max-events+) result) - (setq key (svref *event-key-vector* i)) - (when (and key (zerop (aref all-events i))) - (push key result))))) - `(otherwise - (binding-event-values - (,display ,event-key ,(or keys :universal) ,@arglist) - ,(event-clause display peek-p test-form body-forms)))) - - ;; Code for normal clauses - (let (true-events) ;; canonicalize event-names - (if (consp events) - (progn - (setq true-events (mapcar #'canonicalize-event-name events)) - (dolist (event true-events) - (setf (aref all-events (get-event-code event)) 1))) - (setf true-events (canonicalize-event-name events) - (aref all-events (get-event-code true-events)) 1)) - `(,true-events - (binding-event-values - (,display ,event-key ,true-events ,@arglist) - ,(event-clause display peek-p test-form body-forms)))))))) - clauses)))))) - -(defmacro binding-event-values ((display event-key event-keys &rest value-list) &body body) - ;; Execute BODY with the variables in VALUE-LIST bound to components of the - ;; EVENT-KEYS events. - (unless (consp event-keys) (setq event-keys (list event-keys))) - (flet ((var-key (var) (kintern (if (consp var) (first var) var))) - (var-symbol (var) (if (consp var) (second var) var))) - ;; VARS is an alist of: - ;; (component-key ((event-key event-key ...) . extraction-code) - ;; ((event-key event-key ...) . extraction-code) ...) - ;; There should probably be accessor macros for this, instead of things like cdadr. - (let ((vars (mapcar #'list value-list)) - (multiple-p nil)) - ;; Fill in the VARS alist with event-keys and extraction-code - (do ((keys event-keys (cdr keys)) - (temp nil)) - ((endp keys)) - (let* ((key (car keys)) - (binder (case key - (:universal #'universal-event-get-macro) - (otherwise (svref *event-macro-vector* (get-event-code key)))))) - (dolist (var vars) - (let ((code (funcall binder display event-key (var-key (car var))))) - (unless code (warn "~a isn't a component of the ~s event" - (var-key (car var)) key)) - (if (setq temp (member code (cdr var) :key #'cdr :test #'equal)) - (push key (caar temp)) - (push `((,key) . ,code) (cdr var))))))) - ;; Bind all the values - `(let ,(mapcar #'(lambda (var) - (if (cddr var) ;; if more than one binding form - (progn (setq multiple-p t) - (var-symbol (car var))) - (list (var-symbol (car var)) (cdadr var)))) - vars) - ;; When some values come from different places, generate code to set them - ,(when multiple-p - `(case ,event-key - ,@(do ((keys event-keys (cdr keys)) - (clauses nil) ;; alist of (event-keys bindings) - (clause nil nil) - (temp)) - ((endp keys) - (dolist (clause clauses) - (unless (cdar clause) ;; Atomize single element lists - (setf (car clause) (caar clause)))) - clauses) - ;; Gather up all the bindings associated with (car keys) - (dolist (var vars) - (when (cddr var) ;; when more than one binding form - (dolist (events (cdr var)) - (when (member (car keys) (car events)) - ;; Optimize for event-window being the same as some other binding - (if (setq temp (member (cdr events) clause - :key #'caddr - :test #'equal)) - (setq clause - (nconc clause `((setq ,(car var) ,(second (car temp)))))) - (push `(setq ,(car var) ,(cdr events)) clause)))))) - ;; Merge bindings for (car keys) with other bindings - (when clause - (if (setq temp (member clause clauses :key #'cdr :test #'equal)) - (push (car keys) (caar temp)) - (push `((,(car keys)) . ,clause) clauses)))))) - ,@body)))) - - -;;;----------------------------------------------------------------------------- -;;; Error Handling -;;;----------------------------------------------------------------------------- - -(eval-when (:compile-toplevel :load-toplevel :execute) -(defparameter - *xerror-vector* - '#(unknown-error - request-error ; 1 bad request code - value-error ; 2 integer parameter out of range - window-error ; 3 parameter not a Window - pixmap-error ; 4 parameter not a Pixmap - atom-error ; 5 parameter not an Atom - cursor-error ; 6 parameter not a Cursor - font-error ; 7 parameter not a Font - match-error ; 8 parameter mismatch - drawable-error ; 9 parameter not a Pixmap or Window - access-error ; 10 attempt to access private resource" - alloc-error ; 11 insufficient resources - colormap-error ; 12 no such colormap - gcontext-error ; 13 parameter not a GContext - id-choice-error ; 14 invalid resource ID for this connection - name-error ; 15 font or color name does not exist - length-error ; 16 request length incorrect; - ; internal Xlib error - implementation-error ; 17 server is defective - )) -) - -(defun make-error (display event asynchronous) - (declare (type display display) - (type reply-buffer event) - (type generalized-boolean asynchronous)) - (reading-event (event) - (let* ((error-code (read-card8 1)) - (error-key (get-error-key display error-code)) - (error-decode-function (get error-key 'error-decode-function)) - (params (funcall error-decode-function display event))) - (list* error-code error-key - :asynchronous asynchronous :current-sequence (display-request-number display) - params)))) - -(defun report-error (display error-code error-key &rest params) - (declare (type display display) - (dynamic-extent params)) - ;; All errors (synchronous and asynchronous) are processed by calling - ;; an error handler in the display. The handler is called with the display - ;; as the first argument and the error-key as its second argument. If handler is - ;; an array it is expected to contain handler functions specific to - ;; each error; the error code is used to index the array, fetching the - ;; appropriate handler. Any results returned by the handler are ignored;; - ;; it is assumed the handler either takes care of the error completely, - ;; or else signals. For all core errors, additional keyword/value argument - ;; pairs are: - ;; :major integer - ;; :minor integer - ;; :sequence integer - ;; :current-sequence integer - ;; :asynchronous (member t nil) - ;; For :colormap, :cursor, :drawable, :font, :GContext, :id-choice, :pixmap, and :window - ;; errors another pair is: - ;; :resource-id integer - ;; For :atom errors, another pair is: - ;; :atom-id integer - ;; For :value errors, another pair is: - ;; :value integer - (let* ((handler (display-error-handler display)) - (handler-function - (if (type? handler 'sequence) - (elt handler error-code) - handler))) - (apply handler-function display error-key params))) - -(defun request-name (code &optional display) - (if (< code (length *request-names*)) - (svref *request-names* code) - (dolist (extension (and display (display-extension-alist display)) "unknown") - (when (= code (second extension)) - (return (first extension)))))) - -#-(or clx-ansi-common-lisp excl lcl3.0 CMU) -(define-condition request-error (x-error) - ((display :reader request-error-display) - (error-key :reader request-error-error-key) - (major :reader request-error-major) - (minor :reader request-error-minor) - (sequence :reader request-error-sequence) - (current-sequence :reader request-error-current-sequence) - (asynchronous :reader request-error-asynchronous)) - (:report report-request-error)) - -(defun report-request-error (condition stream) - (let ((error-key (request-error-error-key condition)) - (asynchronous (request-error-asynchronous condition)) - (major (request-error-major condition)) - (minor (request-error-minor condition)) - (sequence (request-error-sequence condition)) - (current-sequence (request-error-current-sequence condition))) - (format stream "~:[~;Asynchronous ~]~a in ~:[request ~d (last request was ~d) ~;current request~2* ~] Code ~d.~d [~a]" - asynchronous error-key (= sequence current-sequence) - sequence current-sequence major minor - (request-name major (request-error-display condition))))) - -;; Since the :report arg is evaluated as (function report-request-error) the -;; define-condition must come after the function definition. -#+(or clx-ansi-common-lisp excl lcl3.0 CMU) -(define-condition request-error (x-error) - ((display :reader request-error-display :initarg :display) - (error-key :reader request-error-error-key :initarg :error-key) - (major :reader request-error-major :initarg :major) - (minor :reader request-error-minor :initarg :minor) - (sequence :reader request-error-sequence :initarg :sequence) - (current-sequence :reader request-error-current-sequence :initarg :current-sequence) - (asynchronous :reader request-error-asynchronous :initarg :asynchronous)) - (:report report-request-error)) - -(define-condition resource-error (request-error) - ((resource-id :reader resource-error-resource-id :initarg :resource-id)) - (:report - (lambda (condition stream) - (report-request-error condition stream) - (format stream " ID #x~x" (resource-error-resource-id condition))))) - -(define-condition unknown-error (request-error) - ((error-code :reader unknown-error-error-code :initarg :error-code)) - (:report - (lambda (condition stream) - (report-request-error condition stream) - (format stream " Error Code ~d." (unknown-error-error-code condition))))) - -(define-condition access-error (request-error) ()) - -(define-condition alloc-error (request-error) ()) - -(define-condition atom-error (request-error) - ((atom-id :reader atom-error-atom-id :initarg :atom-id)) - (:report - (lambda (condition stream) - (report-request-error condition stream) - (format stream " Atom-ID #x~x" (atom-error-atom-id condition))))) - -(define-condition colormap-error (resource-error) ()) - -(define-condition cursor-error (resource-error) ()) - -(define-condition drawable-error (resource-error) ()) - -(define-condition font-error (resource-error) ()) - -(define-condition gcontext-error (resource-error) ()) - -(define-condition id-choice-error (resource-error) ()) - -(define-condition illegal-request-error (request-error) ()) - -(define-condition length-error (request-error) ()) - -(define-condition match-error (request-error) ()) - -(define-condition name-error (request-error) ()) - -(define-condition pixmap-error (resource-error) ()) - -(define-condition value-error (request-error) - ((value :reader value-error-value :initarg :value)) - (:report - (lambda (condition stream) - (report-request-error condition stream) - (format stream " Value ~d." (value-error-value condition))))) - -(define-condition window-error (resource-error)()) - -(define-condition implementation-error (request-error) ()) - -;;----------------------------------------------------------------------------- -;; Internal error conditions signaled by CLX - -(define-condition x-type-error (type-error x-error) - ((type-string :reader x-type-error-type-string :initarg :type-string)) - (:report - (lambda (condition stream) - (format stream "~s isn't a ~a" - (type-error-datum condition) - (or (x-type-error-type-string condition) - (type-error-expected-type condition)))))) - -(define-condition closed-display (x-error) - ((display :reader closed-display-display :initarg :display)) - (:report - (lambda (condition stream) - (format stream "Attempt to use closed display ~s" - (closed-display-display condition))))) - -(define-condition lookup-error (x-error) - ((id :reader lookup-error-id :initarg :id) - (display :reader lookup-error-display :initarg :display) - (type :reader lookup-error-type :initarg :type) - (object :reader lookup-error-object :initarg :object)) - (:report - (lambda (condition stream) - (format stream "ID ~d from display ~s should have been a ~s, but was ~s" - (lookup-error-id condition) - (lookup-error-display condition) - (lookup-error-type condition) - (lookup-error-object condition))))) - -(define-condition connection-failure (x-error) - ((major-version :reader connection-failure-major-version :initarg :major-version) - (minor-version :reader connection-failure-minor-version :initarg :minor-version) - (host :reader connection-failure-host :initarg :host) - (display :reader connection-failure-display :initarg :display) - (reason :reader connection-failure-reason :initarg :reason)) - (:report - (lambda (condition stream) - (format stream "Connection failure to X~d.~d server ~a display ~d: ~a" - (connection-failure-major-version condition) - (connection-failure-minor-version condition) - (connection-failure-host condition) - (connection-failure-display condition) - (connection-failure-reason condition))))) - -(define-condition reply-length-error (x-error) - ((reply-length :reader reply-length-error-reply-length :initarg :reply-length) - (expected-length :reader reply-length-error-expected-length :initarg :expected-length) - (display :reader reply-length-error-display :initarg :display)) - (:report - (lambda (condition stream) - (format stream "Reply length was ~d when ~d words were expected for display ~s" - (reply-length-error-reply-length condition) - (reply-length-error-expected-length condition) - (reply-length-error-display condition))))) - -(define-condition reply-timeout (x-error) - ((timeout :reader reply-timeout-timeout :initarg :timeout) - (display :reader reply-timeout-display :initarg :display)) - (:report - (lambda (condition stream) - (format stream "Timeout after waiting ~d seconds for a reply for display ~s" - (reply-timeout-timeout condition) - (reply-timeout-display condition))))) - -(define-condition sequence-error (x-error) - ((display :reader sequence-error-display :initarg :display) - (req-sequence :reader sequence-error-req-sequence :initarg :req-sequence) - (msg-sequence :reader sequence-error-msg-sequence :initarg :msg-sequence)) - (:report - (lambda (condition stream) - (format stream "Reply out of sequence for display ~s.~% Expected ~d, Got ~d" - (sequence-error-display condition) - (sequence-error-req-sequence condition) - (sequence-error-msg-sequence condition))))) - -(define-condition unexpected-reply (x-error) - ((display :reader unexpected-reply-display :initarg :display) - (msg-sequence :reader unexpected-reply-msg-sequence :initarg :msg-sequence) - (req-sequence :reader unexpected-reply-req-sequence :initarg :req-sequence) - (length :reader unexpected-reply-length :initarg :length)) - (:report - (lambda (condition stream) - (format stream "Display ~s received a server reply when none was expected.~@ - Last request sequence ~d Reply Sequence ~d Reply Length ~d bytes." - (unexpected-reply-display condition) - (unexpected-reply-req-sequence condition) - (unexpected-reply-msg-sequence condition) - (unexpected-reply-length condition))))) - -(define-condition missing-parameter (x-error) - ((parameter :reader missing-parameter-parameter :initarg :parameter)) - (:report - (lambda (condition stream) - (let ((parm (missing-parameter-parameter condition))) - (if (consp parm) - (format stream "One or more of the required parameters ~a is missing." - parm) - (format stream "Required parameter ~a is missing or null." parm)))))) - -;; This can be signalled anywhere a pseudo font access fails. -(define-condition invalid-font (x-error) - ((font :reader invalid-font-font :initarg :font)) - (:report - (lambda (condition stream) - (format stream "Can't access font ~s" (invalid-font-font condition))))) - -(define-condition device-busy (x-error) - ((display :reader device-busy-display :initarg :display)) - (:report - (lambda (condition stream) - (format stream "Device busy for display ~s" - (device-busy-display condition))))) - -(define-condition unimplemented-event (x-error) - ((display :reader unimplemented-event-display :initarg :display) - (event-code :reader unimplemented-event-event-code :initarg :event-code)) - (:report - (lambda (condition stream) - (format stream "Event code ~d not implemented for display ~s" - (unimplemented-event-event-code condition) - (unimplemented-event-display condition))))) - -(define-condition undefined-event (x-error) - ((display :reader undefined-event-display :initarg :display) - (event-name :reader undefined-event-event-name :initarg :event-name)) - (:report - (lambda (condition stream) - (format stream "Event code ~d undefined for display ~s" - (undefined-event-event-name condition) - (undefined-event-display condition))))) - -(define-condition absent-extension (x-error) - ((name :reader absent-extension-name :initarg :name) - (display :reader absent-extension-display :initarg :display)) - (:report - (lambda (condition stream) - (format stream "Extension ~a isn't defined for display ~s" - (absent-extension-name condition) - (absent-extension-display condition))))) - -(define-condition inconsistent-parameters (x-error) - ((parameters :reader inconsistent-parameters-parameters :initarg :parameters)) - (:report - (lambda (condition stream) - (format stream "inconsistent-parameters:~{ ~s~}" - (inconsistent-parameters-parameters condition))))) - -(define-condition resource-ids-exhausted (x-error) - () - (:report - (lambda (condition stream) - (declare (ignore condition)) - (format stream "All X resource IDs are in use.")))) - -(defun get-error-key (display error-code) - (declare (type display display) - (type array-index error-code)) - ;; Return the error-key associated with error-code - (if (< error-code (length *xerror-vector*)) - (svref *xerror-vector* error-code) - ;; Search the extensions for the error - (dolist (entry (display-extension-alist display) 'unknown-error) - (let* ((event-name (first entry)) - (first-error (fourth entry)) - (errors (third (assoc event-name *extensions*)))) - (declare (type keyword event-name) - (type array-index first-error) - (type list errors)) - (when (and errors - (index<= first-error error-code - (index+ first-error (index- (length errors) 1)))) - (return (nth (index- error-code first-error) errors))))))) - -(defmacro define-error (error-key function) - ;; Associate a function with ERROR-KEY which will be called with - ;; parameters DISPLAY and REPLY-BUFFER and - ;; returns a plist of keyword/value pairs which will be passed on - ;; to the error handler. A compiler warning is printed when - ;; ERROR-KEY is not defined in a preceding DEFINE-EXTENSION. - ;; Note: REPLY-BUFFER may used with the READING-EVENT and READ-type - ;; macros for getting error fields. See DECODE-CORE-ERROR for - ;; an example. - (declare (type symbol error-key) - (type (or symbol list) function)) - ;; First ensure the name is for a declared extension - (unless (or (find error-key *xerror-vector*) - (dolist (extension *extensions*) - (when (member error-key (third extension)) - (return t)))) - (x-type-error error-key 'error-key)) - `(setf (get ',error-key 'error-decode-function) (function ,function))) - -;; All core errors use this, so we make it available to extensions. -(defun decode-core-error (display event &optional arg) - ;; All core errors have the following keyword/argument pairs: - ;; :major integer - ;; :minor integer - ;; :sequence integer - ;; In addition, many have an additional argument that comes from the - ;; same place in the event, but is named differently. When the ARG - ;; argument is specified, the keyword ARG with card32 value starting - ;; at byte 4 of the event is returned with the other keyword/argument - ;; pairs. - (declare (type display display) - (type reply-buffer event) - (type (or null keyword) arg)) - (declare (clx-values keyword/arg-plist)) - display - (reading-event (event) - (let* ((sequence (read-card16 2)) - (minor-code (read-card16 8)) - (major-code (read-card8 10)) - (result (list :major major-code - :minor minor-code - :sequence sequence))) - (when arg - (setq result (list* arg (read-card32 4) result))) - result))) - -(defun decode-resource-error (display event) - (decode-core-error display event :resource-id)) - -(define-error unknown-error - (lambda (display event) - (list* :error-code (aref (reply-ibuf8 event) 1) - (decode-core-error display event)))) - -(define-error request-error decode-core-error) ; 1 bad request code - -(define-error value-error ; 2 integer parameter out of range - (lambda (display event) - (decode-core-error display event :value))) - -(define-error window-error decode-resource-error) ; 3 parameter not a Window - -(define-error pixmap-error decode-resource-error) ; 4 parameter not a Pixmap - -(define-error atom-error ; 5 parameter not an Atom - (lambda (display event) - (decode-core-error display event :atom-id))) - -(define-error cursor-error decode-resource-error) ; 6 parameter not a Cursor - -(define-error font-error decode-resource-error) ; 7 parameter not a Font - -(define-error match-error decode-core-error) ; 8 parameter mismatch - -(define-error drawable-error decode-resource-error) ; 9 parameter not a Pixmap or Window - -(define-error access-error decode-core-error) ; 10 attempt to access private resource" - -(define-error alloc-error decode-core-error) ; 11 insufficient resources - -(define-error colormap-error decode-resource-error) ; 12 no such colormap - -(define-error gcontext-error decode-resource-error) ; 13 parameter not a GContext - -(define-error id-choice-error decode-resource-error) ; 14 invalid resource ID for this connection - -(define-error name-error decode-core-error) ; 15 font or color name does not exist - -(define-error length-error decode-core-error) ; 16 request length incorrect; - ; internal Xlib error - -(define-error implementation-error decode-core-error) ; 17 server is defective diff -Nru ecl-16.1.2/src/clx/keysyms.lisp ecl-16.1.3+ds/src/clx/keysyms.lisp --- ecl-16.1.2/src/clx/keysyms.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/keysyms.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,433 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES -*- - -;;; Define lisp character to keysym mappings - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(define-keysym-set :latin-1 (keysym 0 0) (keysym 0 255)) -(define-keysym-set :latin-2 (keysym 1 0) (keysym 1 255)) -(define-keysym-set :latin-3 (keysym 2 0) (keysym 2 255)) -(define-keysym-set :latin-4 (keysym 3 0) (keysym 3 255)) -(define-keysym-set :kana (keysym 4 0) (keysym 4 255)) -(define-keysym-set :arabic (keysym 5 0) (keysym 5 255)) -(define-keysym-set :cyrillic (keysym 6 0) (keysym 6 255)) -(define-keysym-set :greek (keysym 7 0) (keysym 7 255)) -(define-keysym-set :tech (keysym 8 0) (keysym 8 255)) -(define-keysym-set :special (keysym 9 0) (keysym 9 255)) -(define-keysym-set :publish (keysym 10 0) (keysym 10 255)) -(define-keysym-set :apl (keysym 11 0) (keysym 11 255)) -(define-keysym-set :hebrew (keysym 12 0) (keysym 12 255)) -(define-keysym-set :thai (keysym 13 0) (keysym 13 255)) -(define-keysym-set :korean (keysym 14 0) (keysym 14 255)) -(define-keysym-set :latin-5 (keysym 15 0) (keysym 15 255)) -(define-keysym-set :latin-6 (keysym 16 0) (keysym 16 255)) -(define-keysym-set :latin-7 (keysym 17 0) (keysym 17 255)) -(define-keysym-set :latin-8 (keysym 18 0) (keysym 18 255)) -(define-keysym-set :latin-9 (keysym 19 0) (keysym 19 255)) -(define-keysym-set :currency (keysym 32 0) (keysym 32 255)) -(define-keysym-set :|3270| (keysym 253 0) (keysym 253 255)) -(define-keysym-set :xkb (keysym 254 0) (keysym 254 255)) -(define-keysym-set :keyboard (keysym 255 0) (keysym 255 255)) - -(define-keysym :character-set-switch character-set-switch-keysym) -(define-keysym :left-shift left-shift-keysym) -(define-keysym :right-shift right-shift-keysym) -(define-keysym :left-control left-control-keysym) -(define-keysym :right-control right-control-keysym) -(define-keysym :caps-lock caps-lock-keysym) -(define-keysym :shift-lock shift-lock-keysym) -(define-keysym :left-meta left-meta-keysym) -(define-keysym :right-meta right-meta-keysym) -(define-keysym :left-alt left-alt-keysym) -(define-keysym :right-alt right-alt-keysym) -(define-keysym :left-super left-super-keysym) -(define-keysym :right-super right-super-keysym) -(define-keysym :left-hyper left-hyper-keysym) -(define-keysym :right-hyper right-hyper-keysym) - -(define-keysym #\space 032) -(define-keysym #\! 033) -(define-keysym #\" 034) -(define-keysym #\# 035) -(define-keysym #\$ 036) -(define-keysym #\% 037) -(define-keysym #\& 038) -(define-keysym #\' 039) -(define-keysym #\( 040) -(define-keysym #\) 041) -(define-keysym #\* 042) -(define-keysym #\+ 043) -(define-keysym #\, 044) -(define-keysym #\- 045) -(define-keysym #\. 046) -(define-keysym #\/ 047) -(define-keysym #\0 048) -(define-keysym #\1 049) -(define-keysym #\2 050) -(define-keysym #\3 051) -(define-keysym #\4 052) -(define-keysym #\5 053) -(define-keysym #\6 054) -(define-keysym #\7 055) -(define-keysym #\8 056) -(define-keysym #\9 057) -(define-keysym #\: 058) -(define-keysym #\; 059) -(define-keysym #\< 060) -(define-keysym #\= 061) -(define-keysym #\> 062) -(define-keysym #\? 063) -(define-keysym #\@ 064) -(define-keysym #\A 065 :lowercase 097) -(define-keysym #\B 066 :lowercase 098) -(define-keysym #\C 067 :lowercase 099) -(define-keysym #\D 068 :lowercase 100) -(define-keysym #\E 069 :lowercase 101) -(define-keysym #\F 070 :lowercase 102) -(define-keysym #\G 071 :lowercase 103) -(define-keysym #\H 072 :lowercase 104) -(define-keysym #\I 073 :lowercase 105) -(define-keysym #\J 074 :lowercase 106) -(define-keysym #\K 075 :lowercase 107) -(define-keysym #\L 076 :lowercase 108) -(define-keysym #\M 077 :lowercase 109) -(define-keysym #\N 078 :lowercase 110) -(define-keysym #\O 079 :lowercase 111) -(define-keysym #\P 080 :lowercase 112) -(define-keysym #\Q 081 :lowercase 113) -(define-keysym #\R 082 :lowercase 114) -(define-keysym #\S 083 :lowercase 115) -(define-keysym #\T 084 :lowercase 116) -(define-keysym #\U 085 :lowercase 117) -(define-keysym #\V 086 :lowercase 118) -(define-keysym #\W 087 :lowercase 119) -(define-keysym #\X 088 :lowercase 120) -(define-keysym #\Y 089 :lowercase 121) -(define-keysym #\Z 090 :lowercase 122) -(define-keysym #\[ 091) -(define-keysym #\\ 092) -(define-keysym #\] 093) -(define-keysym #\^ 094) -(define-keysym #\_ 095) -(define-keysym #\` 096) -(define-keysym #\a 097) -(define-keysym #\b 098) -(define-keysym #\c 099) -(define-keysym #\d 100) -(define-keysym #\e 101) -(define-keysym #\f 102) -(define-keysym #\g 103) -(define-keysym #\h 104) -(define-keysym #\i 105) -(define-keysym #\j 106) -(define-keysym #\k 107) -(define-keysym #\l 108) -(define-keysym #\m 109) -(define-keysym #\n 110) -(define-keysym #\o 111) -(define-keysym #\p 112) -(define-keysym #\q 113) -(define-keysym #\r 114) -(define-keysym #\s 115) -(define-keysym #\t 116) -(define-keysym #\u 117) -(define-keysym #\v 118) -(define-keysym #\w 119) -(define-keysym #\x 120) -(define-keysym #\y 121) -(define-keysym #\z 122) -(define-keysym #\{ 123) -(define-keysym #\| 124) -(define-keysym #\} 125) -(define-keysym #\~ 126) - -(progn ;; Semi-standard characters - (define-keysym #\rubout (keysym 255 255)) ; :tty - (define-keysym #\tab (keysym 255 009)) ; :tty - (define-keysym #\linefeed (keysym 255 010)) ; :tty - (define-keysym #\page (keysym 009 227)) ; :special - (define-keysym #\return (keysym 255 013)) ; :tty - (define-keysym #\backspace (keysym 255 008)) ; :tty - ) - -;;; these keysym definitions are only correct if the underlying lisp's -;;; definition of characters between 160 and 255 match latin1 exactly. -;;; If the characters are in some way locale-dependent (as, I believe, -;;; in Allegro8) or are treated as opaque without any notions of -;;; graphicness or case (as in cmucl and openmcl) then defining these -;;; keysyms is either not useful or wrong. -- CSR, 2006-03-14 -#+sbcl -(progn - (do ((i 160 (+ i 1))) - ((>= i 256)) - (if (or (<= #xc0 i #xd6) - (<= #xd8 i #xde)) - (define-keysym (code-char i) i :lowercase (+ i 32)) - (define-keysym (code-char i) i)))) - -#+(or lispm excl) -(progn ;; Nonstandard characters - (define-keysym #\escape (keysym 255 027)) ; :tty - ) - -#+ti -(progn - (define-keysym #\Inverted-exclamation-mark 161) - (define-keysym #\american-cent-sign 162) - (define-keysym #\british-pound-sign 163) - (define-keysym #\Currency-sign 164) - (define-keysym #\Japanese-yen-sign 165) - (define-keysym #\Yen 165) - (define-keysym #\Broken-bar 166) - (define-keysym #\Section-symbol 167) - (define-keysym #\Section 167) - (define-keysym #\Diaresis 168) - (define-keysym #\Umlaut 168) - (define-keysym #\Copyright-sign 169) - (define-keysym #\Copyright 169) - (define-keysym #\Feminine-ordinal-indicator 170) - (define-keysym #\Angle-quotation-left 171) - (define-keysym #\Soft-hyphen 173) - (define-keysym #\Shy 173) - (define-keysym #\Registered-trademark 174) - (define-keysym #\Macron 175) - (define-keysym #\Degree-sign 176) - (define-keysym #\Ring 176) - (define-keysym #\Plus-minus-sign 177) - (define-keysym #\Superscript-2 178) - (define-keysym #\Superscript-3 179) - (define-keysym #\Acute-accent 180) - (define-keysym #\Greek-mu 181) - (define-keysym #\Paragraph-symbol 182) - (define-keysym #\Paragraph 182) - (define-keysym #\Pilcrow-sign 182) - (define-keysym #\Middle-dot 183) - (define-keysym #\Cedilla 184) - (define-keysym #\Superscript-1 185) - (define-keysym #\Masculine-ordinal-indicator 186) - (define-keysym #\Angle-quotation-right 187) - (define-keysym #\Fraction-1/4 188) - (define-keysym #\One-quarter 188) - (define-keysym #\Fraction-1/2 189) - (define-keysym #\One-half 189) - (define-keysym #\Fraction-3/4 190) - (define-keysym #\Three-quarters 190) - (define-keysym #\Inverted-question-mark 191) - (define-keysym #\Multiplication-sign 215) - (define-keysym #\Eszet 223) - (define-keysym #\Division-sign 247) -) - -#+ti -(progn ;; There are no 7-bit ascii representations for the following - ;; European characters, so use int-char to create them to ensure - ;; nothing is lost while sending files through the mail. - (define-keysym (int-char 192) 192 :lowercase 224) - (define-keysym (int-char 193) 193 :lowercase 225) - (define-keysym (int-char 194) 194 :lowercase 226) - (define-keysym (int-char 195) 195 :lowercase 227) - (define-keysym (int-char 196) 196 :lowercase 228) - (define-keysym (int-char 197) 197 :lowercase 229) - (define-keysym (int-char 198) 198 :lowercase 230) - (define-keysym (int-char 199) 199 :lowercase 231) - (define-keysym (int-char 200) 200 :lowercase 232) - (define-keysym (int-char 201) 201 :lowercase 233) - (define-keysym (int-char 202) 202 :lowercase 234) - (define-keysym (int-char 203) 203 :lowercase 235) - (define-keysym (int-char 204) 204 :lowercase 236) - (define-keysym (int-char 205) 205 :lowercase 237) - (define-keysym (int-char 206) 206 :lowercase 238) - (define-keysym (int-char 207) 207 :lowercase 239) - (define-keysym (int-char 208) 208 :lowercase 240) - (define-keysym (int-char 209) 209 :lowercase 241) - (define-keysym (int-char 210) 210 :lowercase 242) - (define-keysym (int-char 211) 211 :lowercase 243) - (define-keysym (int-char 212) 212 :lowercase 244) - (define-keysym (int-char 213) 213 :lowercase 245) - (define-keysym (int-char 214) 214 :lowercase 246) - (define-keysym (int-char 215) 215) - (define-keysym (int-char 216) 216 :lowercase 248) - (define-keysym (int-char 217) 217 :lowercase 249) - (define-keysym (int-char 218) 218 :lowercase 250) - (define-keysym (int-char 219) 219 :lowercase 251) - (define-keysym (int-char 220) 220 :lowercase 252) - (define-keysym (int-char 221) 221 :lowercase 253) - (define-keysym (int-char 222) 222 :lowercase 254) - (define-keysym (int-char 223) 223) - (define-keysym (int-char 224) 224) - (define-keysym (int-char 225) 225) - (define-keysym (int-char 226) 226) - (define-keysym (int-char 227) 227) - (define-keysym (int-char 228) 228) - (define-keysym (int-char 229) 229) - (define-keysym (int-char 230) 230) - (define-keysym (int-char 231) 231) - (define-keysym (int-char 232) 232) - (define-keysym (int-char 233) 233) - (define-keysym (int-char 234) 234) - (define-keysym (int-char 235) 235) - (define-keysym (int-char 236) 236) - (define-keysym (int-char 237) 237) - (define-keysym (int-char 238) 238) - (define-keysym (int-char 239) 239) - (define-keysym (int-char 240) 240) - (define-keysym (int-char 241) 241) - (define-keysym (int-char 242) 242) - (define-keysym (int-char 243) 243) - (define-keysym (int-char 244) 244) - (define-keysym (int-char 245) 245) - (define-keysym (int-char 246) 246) - (define-keysym (int-char 247) 247) - (define-keysym (int-char 248) 248) - (define-keysym (int-char 249) 249) - (define-keysym (int-char 250) 250) - (define-keysym (int-char 251) 251) - (define-keysym (int-char 252) 252) - (define-keysym (int-char 253) 253) - (define-keysym (int-char 254) 254) - (define-keysym (int-char 255) 255) - ) - -#+lispm ;; Nonstandard characters -(progn - (define-keysym #\center-dot (keysym 183)) ; :latin-1 - (define-keysym #\down-arrow (keysym 008 254)) ; :technical - (define-keysym #\alpha (keysym 007 225)) ; :greek - (define-keysym #\beta (keysym 007 226)) ; :greek - (define-keysym #\and-sign (keysym 008 222)) ; :technical - (define-keysym #\not-sign (keysym 172)) ; :latin-1 - (define-keysym #\epsilon (keysym 007 229)) ; :greek - (define-keysym #\pi (keysym 007 240)) ; :greek - (define-keysym #\lambda (keysym 007 235)) ; :greek - (define-keysym #\gamma (keysym 007 227)) ; :greek - (define-keysym #\delta (keysym 007 228)) ; :greek - (define-keysym #\up-arrow (keysym 008 252)) ; :technical - (define-keysym #\plus-minus (keysym 177)) ; :latin-1 - (define-keysym #\infinity (keysym 008 194)) ; :technical - (define-keysym #\partial-delta (keysym 008 239)) ; :technical - (define-keysym #\left-horseshoe (keysym 011 218)) ; :apl - (define-keysym #\right-horseshoe (keysym 011 216)) ; :apl - (define-keysym #\up-horseshoe (keysym 011 195)) ; :apl - (define-keysym #\down-horseshoe (keysym 011 214)) ; :apl - (define-keysym #\double-arrow (keysym 008 205)) ; :technical - (define-keysym #\left-arrow (keysym 008 251)) ; :technical - (define-keysym #\right-arrow (keysym 008 253)) ; :technical - (define-keysym #\not-equals (keysym 008 189)) ; :technical - (define-keysym #\less-or-equal (keysym 008 188)) ; :technical - (define-keysym #\greater-or-equal (keysym 008 190)) ; :technical - (define-keysym #\equivalence (keysym 008 207)) ; :technical - (define-keysym #\or-sign (keysym 008 223)) ; :technical - (define-keysym #\integral (keysym 008 191)) ; :technical -;; break isn't null -;; (define-keysym #\null (keysym 255 107)) ; :function - (define-keysym #\clear-input (keysym 255 011)) ; :tty - (define-keysym #\help (keysym 255 106)) ; :function - (define-keysym #\refresh (keysym 255 097)) ; :function - (define-keysym #\abort (keysym 255 105)) ; :function - (define-keysym #\resume (keysym 255 098)) ; :function - (define-keysym #\end (keysym 255 087)) ; :cursor -;;#\universal-quantifier -;;#\existential-quantifier -;;#\circle-plus -;;#\circle-cross same as #\circle-x - ) - -#+genera -(progn -;;#\network -;;#\symbol-help - (define-keysym #\lozenge (keysym 009 224)) ; :special - (define-keysym #\suspend (keysym 255 019)) ; :tty - (define-keysym #\function (keysym 255 032)) ; :function - (define-keysym #\square (keysym 010 231)) ; :publishing - (define-keysym #\circle (keysym 010 230)) ; :publishing - (define-keysym #\triangle (keysym 010 232)) ; :publishing - (define-keysym #\scroll (keysym 255 086)) ; :cursor - (define-keysym #\select (keysym 255 096)) ; :function - (define-keysym #\complete (keysym 255 104)) ; :function - ) - -#+ti -(progn - (define-keysym #\terminal (keysym 255 032)) ; :function - (define-keysym #\system (keysym 255 096)) ; :function - (define-keysym #\center-arrow (keysym 255 80)) - (define-keysym #\left-arrow (keysym 255 081)) ; :cursor - (define-keysym #\up-arrow (keysym 255 082)) ; :cursor - (define-keysym #\right-arrow (keysym 255 083)) ; :cursor - (define-keysym #\down-arrow (keysym 255 084)) ; :cursor - (define-keysym #\end (keysym 255 087)) ; :cursor - (define-keysym #\undo (keysym 255 101)) ; :function - (define-keysym #\break (keysym 255 107)) - (define-keysym #\keypad-space (keysym 255 128)) ; :keypad - (define-keysym #\keypad-tab (keysym 255 137)) ; :keypad - (define-keysym #\keypad-enter (keysym 255 141)) ; :keypad - (define-keysym #\f1 (keysym 255 145)) ; :keypad - (define-keysym #\f2 (keysym 255 146)) ; :keypad - (define-keysym #\f3 (keysym 255 147)) ; :keypad - (define-keysym #\f4 (keysym 255 148)) ; :keypad - (define-keysym #\f1 (keysym 255 190)) ; :keypad - (define-keysym #\f2 (keysym 255 191)) ; :keypad - (define-keysym #\f3 (keysym 255 192)) ; :keypad - (define-keysym #\f4 (keysym 255 193)) ; :keypad - (define-keysym #\keypad-plus (keysym 255 171)) ; :keypad - (define-keysym #\keypad-comma (keysym 255 172)) ; :keypad - (define-keysym #\keypad-minus (keysym 255 173)) ; :keypad - (define-keysym #\keypad-period (keysym 255 174)) ; :keypad - (define-keysym #\keypad-0 (keysym 255 176)) ; :keypad - (define-keysym #\keypad-1 (keysym 255 177)) ; :keypad - (define-keysym #\keypad-2 (keysym 255 178)) ; :keypad - (define-keysym #\keypad-3 (keysym 255 179)) ; :keypad - (define-keysym #\keypad-4 (keysym 255 180)) ; :keypad - (define-keysym #\keypad-5 (keysym 255 181)) ; :keypad - (define-keysym #\keypad-6 (keysym 255 182)) ; :keypad - (define-keysym #\keypad-7 (keysym 255 183)) ; :keypad - (define-keysym #\keypad-8 (keysym 255 184)) ; :keypad - (define-keysym #\keypad-9 (keysym 255 185)) ; :keypad - (define-keysym #\keypad-equal (keysym 255 189)) ; :keypad - (define-keysym #\f1 (keysym 255 192)) ; :function - (define-keysym #\f2 (keysym 255 193)) ; :function - (define-keysym #\f3 (keysym 255 194)) ; :function - (define-keysym #\f4 (keysym 255 195)) ; :function - (define-keysym #\network (keysym 255 214)) - (define-keysym #\status (keysym 255 215)) - (define-keysym #\clear-screen (keysym 255 217)) - (define-keysym #\left (keysym 255 218)) - (define-keysym #\middle (keysym 255 219)) - (define-keysym #\right (keysym 255 220)) - (define-keysym #\resume (keysym 255 221)) - (define-keysym #\vt (keysym 009 233)) ; :special ;; same as #\delete - ) - -#+ti -(progn ;; Explorer specific characters - (define-keysym #\Call (keysym 131)) ; :latin-1 - (define-keysym #\Macro (keysym 133)) ; :latin-1 - (define-keysym #\Quote (keysym 142)) ; :latin-1 - (define-keysym #\Hold-output (keysym 143)) ; :latin-1 - (define-keysym #\Stop-output (keysym 144)) ; :latin-1 - (define-keysym #\Center (keysym 156)) ; :latin-1 - (define-keysym #\no-break-space (keysym 160)) ; :latin-1 - - (define-keysym #\circle-plus (keysym 13)) ; :latin-1 - (define-keysym #\universal-quantifier (keysym 20)) ; :latin-1 - (define-keysym #\existential-quantifier (keysym 21)) ; :latin-1 - (define-keysym #\circle-cross (keysym 22)) ; :latin-1 - ) - diff -Nru ecl-16.1.2/src/clx/macros.lisp ecl-16.1.3+ds/src/clx/macros.lisp --- ecl-16.1.2/src/clx/macros.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/macros.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,1097 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -;;; CLX basically implements a very low overhead remote procedure call -;;; to the server. This file contains macros which generate the code -;;; for both the client AND the server, given a specification of the -;;; interface. This was done to eliminate errors that may occur because -;;; the client and server code get/put bytes in different places, and -;;; it makes it easier to extend the protocol. - -;;; This is built on top of BUFFER - -(in-package :xlib) - -(defmacro type-check (value type) - value type - (when +type-check?+ - `(unless (type? ,value ,type) - (x-type-error ,value ,type)))) - -;;; This variable is used by the required-arg macro just to satisfy compilers. -(defvar *required-arg-dummy*) - -;;; An error signalling macro use to specify that keyword arguments are required. -(defmacro required-arg (name) - `(progn (x-error 'missing-parameter :parameter ',name) - *required-arg-dummy*)) - -(defmacro lround (index) - ;; Round up to the next 32 bit boundary - `(the array-index (logand (index+ ,index 3) -4))) - -(defmacro wround (index) - ;; Round up to the next 16 bit boundary - `(the array-index (logand (index+ ,index 1) -2))) - -;; -;; Data-type accessor functions -;; -;; These functions translate between lisp data-types and the byte, -;; half-word or word that gets transmitted across the client/server -;; connection - -(defun index-increment (type) - ;; Given a type, return its field width in bytes - (let* ((name (if (consp type) (car type) type)) - (increment (get name 'byte-width :not-found))) - (when (eq increment :not-found) - ;; Check for TYPE in a different package - (when (not (eq (symbol-package name) *xlib-package*)) - (setq name (xintern name)) - (setq increment (get name 'byte-width :not-found))) - (when (eq increment :not-found) - (error "~s isn't a known field accessor" name))) - increment)) - -(eval-when (:compile-toplevel :load-toplevel :execute) -(defun getify (name) - (xintern name '-get)) - -(defun putify (name &optional predicate-p) - (xintern name '-put (if predicate-p '-predicating ""))) - -;;; Use &body so zmacs indents properly -(defmacro define-accessor (name (width) &body get-put-macros) - ;; The first body form defines the get macro - ;; The second body form defines the put macro - ;; The third body form is optional, and defines a put macro that does - ;; type checking and does a put when ok, else NIL when the type is incorrect. - ;; If no third body form is present, then these macros assume that - ;; (AND (TYPEP ,thing 'type) (PUT-type ,thing)) can be generated. - ;; these predicating puts are used by the OR accessor. - (declare (arglist name (width) get-macro put-macro &optional predicating-put-macro)) - (when (cdddr get-put-macros) - (error "Too many parameters to define-accessor: ~s" (cdddr get-put-macros))) - (let ((get-macro (or (first get-put-macros) (error "No GET macro form for ~s" name))) - (put-macro (or (second get-put-macros) (error "No PUT macro form for ~s" name)))) - `(within-definition (,name define-accessor) - (setf (get ',name 'byte-width) ,(and width (floor width 8))) - (defmacro ,(getify name) ,(car get-macro) - ,@(cdr get-macro)) - (defmacro ,(putify name) ,(car put-macro) - ,@(cdr put-macro)) - ,@(when +type-check?+ - (let ((predicating-put (third get-put-macros))) - (when predicating-put - `((setf (get ',name 'predicating-put) t) - (defmacro ,(putify name t) ,(car predicating-put) - ,@(cdr predicating-put))))))))) -) ;; End eval-when - -(define-accessor card32 (32) - ((index) `(read-card32 ,index)) - ((index thing) `(write-card32 ,index ,thing))) - -(define-accessor card29 (32) - ((index) `(read-card29 ,index)) - ((index thing) `(write-card29 ,index ,thing))) - -(define-accessor card16 (16) - ((index) `(read-card16 ,index)) - ((index thing) `(write-card16 ,index ,thing))) - -(define-accessor card8 (8) - ((index) `(read-card8 ,index)) - ((index thing) `(write-card8 ,index ,thing))) - -(define-accessor integer (32) - ((index) `(read-int32 ,index)) - ((index thing) `(write-int32 ,index ,thing))) - -(define-accessor int16 (16) - ((index) `(read-int16 ,index)) - ((index thing) `(write-int16 ,index ,thing))) - -(define-accessor rgb-val (16) - ;; Used for color's - ((index) `(card16->rgb-val (read-card16 ,index))) - ((index thing) `(write-card16 ,index (rgb-val->card16 ,thing)))) - -(define-accessor angle (16) - ;; Used for drawing arcs - ((index) `(int16->radians (read-int16 ,index))) - ((index thing) `(write-int16 ,index (radians->int16 ,thing)))) - -(define-accessor bit (0) - ;; Like BOOLEAN, but tests bits - ;; only used by declare-event (:enter-notify :leave-notify) - ((index bit) - `(logbitp ,bit (read-card8 ,index))) - ((index thing bit) - (if (zerop bit) - `(write-card8 ,index (if ,thing 1 0)) - `(write-card8 ,index (dpb (if ,thing 1 0) (byte 1 ,bit) (read-card8 ,index)))))) - -(define-accessor boolean (8) - ((index) - `(plusp (read-card8 ,index))) - ((index thing) `(write-card8 ,index (if ,thing 1 0)))) - -(define-accessor drawable (32) - ((index &optional (buffer '%buffer)) - `(lookup-drawable ,buffer (read-card29 ,index))) - ((index thing) `(write-card29 ,index (drawable-id ,thing)))) - -(define-accessor window (32) - ((index &optional (buffer '%buffer)) - `(lookup-window ,buffer (read-card29 ,index))) - ((index thing) `(write-card29 ,index (window-id ,thing)))) - -(define-accessor pixmap (32) - ((index &optional (buffer '%buffer)) - `(lookup-pixmap ,buffer (read-card29 ,index))) - ((index thing) `(write-card29 ,index (pixmap-id ,thing)))) - -(define-accessor gcontext (32) - ((index &optional (buffer '%buffer)) - `(lookup-gcontext ,buffer (read-card29 ,index))) - ((index thing) `(write-card29 ,index (gcontext-id ,thing)))) - -(define-accessor cursor (32) - ((index &optional (buffer '%buffer)) - `(lookup-cursor ,buffer (read-card29 ,index))) - ((index thing) `(write-card29 ,index (cursor-id ,thing)))) - -(define-accessor colormap (32) - ((index &optional (buffer '%buffer)) - `(lookup-colormap ,buffer (read-card29 ,index))) - ((index thing) `(write-card29 ,index (colormap-id ,thing)))) - -(define-accessor font (32) - ((index &optional (buffer '%buffer)) - `(lookup-font ,buffer (read-card29 ,index))) - ;; The FONT-ID accessor may make a OpenFont request. Since we don't support recursive - ;; with-buffer-request, issue a compile time error, rather than barf at run-time. - ((index thing) - (declare (ignore index thing)) - (error "FONT-ID must be called OUTSIDE with-buffer-request. Use RESOURCE-ID instead."))) - -;; Needed to get and put xatom's in events -(define-accessor keyword (32) - ((index &optional (buffer '%buffer)) - `(atom-name ,buffer (read-card29 ,index))) - ((index thing &key (buffer '%buffer)) - `(write-card29 ,index (or (atom-id ,thing ,buffer) - (error "CLX implementation error in KEYWORD-PUT"))))) - -(define-accessor resource-id (32) - ((index) `(read-card29 ,index)) - ((index thing) `(write-card29 ,index ,thing))) - -(define-accessor resource-id-or-nil (32) - ((index) (let ((id (gensym))) - `(let ((,id (read-card29 ,index))) - (and (plusp ,id) ,id)))) - ((index thing) `(write-card29 ,index (or ,thing 0)))) - -(defmacro char-info-get (index) - `(make-char-info - :left-bearing (int16-get ,index) - :right-bearing (int16-get ,(+ index 2)) - :width (int16-get ,(+ index 4)) - :ascent (int16-get ,(+ index 6)) - :descent (int16-get ,(+ index 8)) - :attributes (card16-get ,(+ index 10)))) - -(define-accessor member8 (8) - ((index &rest keywords) - (let ((value (gensym))) - `(let ((,value (read-card8 ,index))) - (declare (type (integer 0 (,(length keywords))) ,value)) - (type-check ,value '(integer 0 (,(length keywords)))) - (svref ',(apply #'vector keywords) ,value)))) - ((index thing &rest keywords) - `(write-card8 ,index (position ,thing - #+lispm ',keywords ;; Lispm's prefer lists - #-lispm (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) - ((index thing &rest keywords) - (let ((value (gensym))) - `(let ((,value (position ,thing - #+lispm ',keywords - #-lispm (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) - (and ,value (write-card8 ,index ,value)))))) - -(define-accessor member16 (16) - ((index &rest keywords) - (let ((value (gensym))) - `(let ((,value (read-card16 ,index))) - (declare (type (integer 0 (,(length keywords))) ,value)) - (type-check ,value '(integer 0 (,(length keywords)))) - (svref ',(apply #'vector keywords) ,value)))) - ((index thing &rest keywords) - `(write-card16 ,index (position ,thing - #+lispm ',keywords ;; Lispm's prefer lists - #-lispm (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) - ((index thing &rest keywords) - (let ((value (gensym))) - `(let ((,value (position ,thing - #+lispm ',keywords - #-lispm (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) - (and ,value (write-card16 ,index ,value)))))) - -(define-accessor member (32) - ((index &rest keywords) - (let ((value (gensym))) - `(let ((,value (read-card29 ,index))) - (declare (type (integer 0 (,(length keywords))) ,value)) - (type-check ,value '(integer 0 (,(length keywords)))) - (svref ',(apply #'vector keywords) ,value)))) - ((index thing &rest keywords) - `(write-card29 ,index (position ,thing - #+lispm ',keywords ;; Lispm's prefer lists - #-lispm (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) - ((index thing &rest keywords) - (if (cdr keywords) ;; IF more than one - (let ((value (gensym))) - `(let ((,value (position ,thing - #+lispm ',keywords - #-lispm (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) - (and ,value (write-card29 ,index ,value)))) - `(and (eq ,thing ,(car keywords)) (write-card29 ,index 0))))) - -(deftype member-vector (vector) `(member ,@(coerce (symbol-value vector) 'list))) - -(define-accessor member-vector (32) - ((index membership-vector) - `(member-get ,index ,@(coerce (eval membership-vector) 'list))) - ((index thing membership-vector) - `(member-put ,index ,thing ,@(coerce (eval membership-vector) 'list))) - ((index thing membership-vector) - `(member-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))) - -(define-accessor member16-vector (16) - ((index membership-vector) - `(member16-get ,index ,@(coerce (eval membership-vector) 'list))) - ((index thing membership-vector) - `(member16-put ,index ,thing ,@(coerce (eval membership-vector) 'list))) - ((index thing membership-vector) - `(member16-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))) - -(define-accessor member8-vector (8) - ((index membership-vector) - `(member8-get ,index ,@(coerce (eval membership-vector) 'list))) - ((index thing membership-vector) - `(member8-put ,index ,thing ,@(coerce (eval membership-vector) 'list))) - ((index thing membership-vector) - `(member8-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))) - -(define-accessor boole-constant (32) - ;; this isn't member-vector because we need eql instead of eq - ((index) - (let ((value (gensym))) - `(let ((,value (read-card29 ,index))) - (declare (type (integer 0 (,(length +boole-vector+))) ,value)) - (type-check ,value '(integer 0 (,(length +boole-vector+)))) - (svref +boole-vector+ ,value)))) - ((index thing) - `(write-card29 ,index (position ,thing (the simple-vector +boole-vector+)))) - ((index thing) - (let ((value (gensym))) - `(let ((,value (position ,thing (the simple-vector +boole-vector+)))) - (and ,value (write-card29 ,index ,value)))))) - -(define-accessor null (32) - ((index) `(if (zerop (read-card32 ,index)) nil (read-card32 ,index))) - ((index value) (declare (ignore value)) `(write-card32 ,index 0))) - -(define-accessor pad8 (8) - ((index) (declare (ignore index)) nil) - ((index value) (declare (ignore index value)) nil)) - -(define-accessor pad16 (16) - ((index) (declare (ignore index)) nil) - ((index value) (declare (ignore index value)) nil)) - -(define-accessor pad32 (32) - ((index) (declare (ignore index)) nil) - ((index value) (declare (ignore index value)) nil)) - -(define-accessor bit-vector256 (256) - ;; used for key-maps - ;; REAL-INDEX parameter provided so the default index can be over-ridden. - ;; This is needed for the :keymap-notify event where the keymap overlaps - ;; the window id. - ((index &optional (real-index index) data) - `(read-bitvector256 buffer-bbuf ,real-index ,data)) - ((index map &optional (real-index index) (buffer '%buffer)) - `(write-bitvector256 ,buffer (index+ buffer-boffset ,real-index) ,map))) - -(define-accessor string (nil) - ((length index &key reply-buffer) - `(read-sequence-char - ,(or reply-buffer '%reply-buffer) 'string ,length nil nil 0 ,index)) - ((index string &key buffer (start 0) end header-length appending) - (unless buffer (setq buffer '%buffer)) - (unless header-length (setq header-length (lround index))) - (let* ((real-end (if appending (or end `(length ,string)) (gensym))) - (form `(write-sequence-char ,buffer (index+ buffer-boffset ,header-length) - ,string ,start ,real-end))) - (if appending - form - `(let ((,real-end ,(or end `(length ,string)))) - (write-card16 2 (index-ceiling (index+ (index- ,real-end ,start) ,header-length) 4)) - ,form))))) - -(define-accessor sequence (nil) - ((&key length (format 'card32) result-type transform reply-buffer data index start) - `(,(ecase format - (card8 'read-sequence-card8) - (int8 'read-sequence-int8) - (card16 'read-sequence-card16) - (int16 'read-sequence-int16) - (card32 'read-sequence-card32) - (int32 'read-sequence-int32)) - ,(or reply-buffer '%reply-buffer) - ,result-type ,length ,transform ,data - ,@(when (or start index) `(,(or start 0))) - ,@(when index `(,index)))) - ((index data &key (format 'card32) (start 0) end transform buffer appending) - (unless buffer (setq buffer '%buffer)) - (let* ((real-end (if appending (or end `(length ,data)) (gensym))) - (writer (xintern 'write-sequence- format)) - (form `(,writer ,buffer (index+ buffer-boffset ,(lround index)) - ,data ,start ,real-end ,transform))) - (flet ((maker (size) - (if appending - form - (let ((idx `(index- ,real-end ,start))) - (unless (= size 1) - (setq idx `(index-ceiling ,idx ,size))) - `(let ((,real-end ,(or end `(length ,data)))) - (write-card16 2 (index+ ,idx ,(index-ceiling index 4))) - ,form))))) - (ecase format - ((card8 int8) - (maker 4)) - ((card16 int16 char2b) - (maker 2)) - ((card32 int32) - (maker 1))))))) - -(defmacro client-message-event-get-sequence () - '(let* ((format (read-card8 1)) - (sequence (make-array (ceiling 160 format) - :element-type `(unsigned-byte ,format)))) - (declare (type (member 8 16 32) format)) - (do ((i 12) - (j 0 (index1+ j))) - ((>= i 32)) - (case format - (8 (setf (aref sequence j) (read-card8 i)) - (index-incf i)) - (16 (setf (aref sequence j) (read-card16 i)) - (index-incf i 2)) - (32 (setf (aref sequence j) (read-card32 i)) - (index-incf i 4)))) - sequence)) - -(defmacro client-message-event-put-sequence (format sequence) - `(ecase ,format - (8 (sequence-put 12 ,sequence - :format card8 - :end (min (length ,sequence) 20) - :appending t)) - (16 (sequence-put 12 ,sequence - :format card16 - :end (min (length ,sequence) 10) - :appending t)) - (32 (sequence-put 12 ,sequence - :format card32 - :end (min (length ,sequence) 5) - :appending t)))) - -;; Used only in declare-event -(define-accessor client-message-sequence (160) - ((index format) (declare (ignore index format)) `(client-message-event-get-sequence)) - ((index value format) (declare (ignore index)) - `(client-message-event-put-sequence ,format ,value))) - - -;;; -;;; Compound accessors -;;; Accessors that take other accessors as parameters -;;; -(define-accessor code (0) - ((index) (declare (ignore index)) '(read-card8 0)) - ((index value) (declare (ignore index)) `(write-card8 0 ,value)) - ((index value) (declare (ignore index)) `(write-card8 0 ,value))) - -(define-accessor length (0) - ((index) (declare (ignore index)) '(read-card16 2)) - ((index value) (declare (ignore index)) `(write-card16 2 ,value)) - ((index value) (declare (ignore index)) `(write-card16 2 ,value))) - -(deftype data () 'card8) - -(define-accessor data (0) - ;; Put data in byte 1 of the reqeust - ((index &optional stuff) (declare (ignore index)) - (if stuff - (if (consp stuff) - `(,(getify (car stuff)) 1 ,@(cdr stuff)) - `(,(getify stuff) 1)) - `(read-card8 1))) - ((index thing &optional stuff) - (if stuff - (if (consp stuff) - `(macrolet ((write-card32 (index value) index value)) - (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff)))) - `(,(putify stuff) 1 ,thing)) - `(write-card8 1 ,thing))) - ((index thing &optional stuff) - (if stuff - `(and (type? ,thing ',stuff) - ,(if (consp stuff) - `(macrolet ((write-card32 (index value) index value)) - (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff)))) - `(,(putify stuff) 1 ,thing))) - `(and (type? ,thing 'card8) (write-card8 1 ,thing))))) - -;; Macroexpand the result of OR-GET to allow the macros file to not be loaded -;; when using event-case. This is pretty gross. - -(defmacro or-expand (&rest forms &environment environment) - `(cond ,@(mapcar #'(lambda (forms) - (mapcar #'(lambda (form) - (clx-macroexpand form environment)) - forms)) - forms))) - -;; -;; the OR type -;; -(define-accessor or (32) - ;; Select from among several types (usually NULL and something else) - ((index &rest type-list &environment environment) - (do ((types type-list (cdr types)) - (value (gensym)) - (result)) - ((endp types) - `(let ((,value (read-card32 ,index))) - (macrolet ((read-card32 (index) index ',value) - (read-card29 (index) index ',value)) - ,(clx-macroexpand `(or-expand ,@(nreverse result)) environment)))) - (let ((item (car types)) - (args nil)) - (when (consp item) - (setq args (cdr item) - item (car item))) - (if (eq item 'null) ;; Special case for NULL - (push `((zerop ,value) nil) result) - (push - `((,(getify item) ,index ,@args)) - result))))) - - ((index value &rest type-list) - (do ((types type-list (cdr types)) - (result)) - ((endp types) - `(cond ,@(nreverse result) - ,@(when +type-check?+ - `((t (x-type-error ,value '(or ,@type-list))))))) - (let* ((type (car types)) - (type-name type) - (args nil)) - (when (consp type) - (setq args (cdr type) - type-name (car type))) - (push - `(,@(cond ((get type-name 'predicating-put) nil) - ((or +type-check?+ (cdr types)) `((type? ,value ',type))) - (t '(t))) - (,(putify type-name (get type-name 'predicating-put)) ,index ,value ,@args)) - result))))) - -;; -;; the MASK type... -;; is used to specify a subset of a collection of "optional" arguments. -;; A mask type consists of a 32 bit mask word followed by a word for each one-bit -;; in the mask. The MASK type is ALWAYS the LAST item in a request. -;; -(setf (get 'mask 'byte-width) nil) - -(defun mask-get (index type-values body-function) - (declare (type function body-function) - #+clx-ansi-common-lisp - (dynamic-extent body-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg body-function)) - ;; This is a function, because it must return more than one form (called by get-put-items) - ;; Functions that use this must have a binding for %MASK - (let* ((bit 0) - (result - (mapcar - #'(lambda (form) - (if (atom form) - form ;; Hack to allow BODY-FUNCTION to return keyword/value pairs - (prog1 - `(when (logbitp ,bit %mask) - ;; Execute form when bit is set - ,form) - (incf bit)))) - (get-put-items - (+ index 4) type-values nil - #'(lambda (type index item args) - (declare (ignore index)) - (funcall body-function type '(* (incf %index) 4) item args)))))) - ;; First form must load %MASK - `(,@(when (atom (car result)) - (list (pop result))) - (progn (setq %mask (read-card32 ,index)) - (setq %index ,(ceiling index 4)) - ,(car result)) - ,@(cdr result)))) - -;; MASK-PUT - -(defun mask-put (index type-values body-function) - (declare (type function body-function) - #+clx-ansi-common-lisp - (dynamic-extent body-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg body-function)) - ;; The MASK type writes a 32 bit mask with 1 bits for each non-nil value in TYPE-VALUES - ;; A 32 bit value follows for each non-nil value. - `((let ((%mask 0) - (%index ,index)) - ,@(let ((bit 1)) - (get-put-items - index type-values t - #'(lambda (type index item args) - (declare (ignore index)) - (if (or (symbolp item) (constantp item)) - `((unless (null ,item) - (setq %mask (logior %mask ,(shiftf bit (ash bit 1)))) - ,@(funcall body-function type - `(index-incf %index 4) item args))) - `((let ((.item. ,item)) - (unless (null .item.) - (setq %mask (logior %mask ,(shiftf bit (ash bit 1)))) - ,@(funcall body-function type - `(index-incf %index 4) '.item. args)))))))) - (write-card32 ,index %mask) - (write-card16 2 (index-ceiling (index-incf %index 4) 4)) - (incf (buffer-boffset %buffer) %index)))) - -(define-accessor progn (nil) - ;; Catch-all for inserting random code - ;; Note that code using this is then responsible for setting the request length - ((index statement) (declare (ignore index)) statement) - ((index statement) (declare (ignore index)) statement)) - - -; -; Wrapper macros, for use around the above -; - -;;; type-check was here, and has been moved up - -(defmacro check-put (index value type &rest args &environment env) - (let* ((var (if (or (symbolp value) (constantp value)) value '.value.)) - (body - (if (or (null (macroexpand `(type-check ,var ',type) env)) - (member type '(or progn pad8 pad16)) - (constantp value)) - `(,(putify type) ,index ,var ,@args) - ;; Do type checking - (if (get type 'predicating-put) - `(or (,(putify type t) ,index ,var ,@args) - (x-type-error ,var ',(if args `(,type ,@args) type))) - `(if (type? ,var ',type) - (,(putify type) ,index ,var ,@args) - (x-type-error ,var ',(if args `(,type ,@args) type))))))) - (if (eq var value) - body - `(let ((,var ,value)) - ,body)))) - -(defun get-put-items (index type-args putp &optional body-function) - (declare (type (or null function) body-function) - #+clx-ansi-common-lisp - (dynamic-extent body-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg body-function)) - ;; Given a lists of the form (type item item ... item) - ;; Calls body-function with four arguments, a function name, - ;; index, item name, and optional arguments. - ;; The results are appended together and retured. - (unless body-function - (setq body-function - #'(lambda (type index item args) - `((check-put ,index ,item ,type ,@args))))) - (do* ((items type-args (cdr items)) - (type (caar items) (caar items)) - (args nil nil) - (result nil) - (sizes nil)) - ((endp items) (values result index sizes)) - (when (consp type) - (setq args (cdr type) - type (car type))) - (cond ((member type '(return buffer))) - ((eq type 'mask) ;; Hack to enable mask-get/put to return multiple values - (setq result - (append result (if putp - (mask-put index (cdar items) body-function) - (mask-get index (cdar items) body-function))) - index nil)) - (t (do* ((item (cdar items) (cdr item)) - (increment (index-increment type))) - ((endp item)) - (when (constantp index) - (case increment ;Round up index when needed - (2 (setq index (wround index))) - (4 (setq index (lround index))))) - (setq result - (append result (funcall body-function type index (car item) args))) - (when (constantp index) - ;; Variable length requests have null length increment. - ;; Variable length requests set the request size - ;; & maintain buffer pointers - (if (null increment) - (setq index nil) - (progn - (incf index increment) - (when (and increment (zerop increment)) (setq increment 1)) - (pushnew (* increment 8) sizes))))))))) - -(defmacro with-buffer-request-internal - ((buffer opcode &key length sizes &allow-other-keys) - &body type-args) - (multiple-value-bind (code index item-sizes) - (get-put-items 4 type-args t) - (let ((length (if length `(index+ ,length +requestsize+) '+requestsize+)) - (sizes (remove-duplicates (append '(8 16) item-sizes sizes)))) - `(with-buffer-output (,buffer :length ,length :sizes ,sizes) - (setf (buffer-last-request ,buffer) buffer-boffset) - (write-card8 0 ,opcode) ;; Stick in the opcode - ,@code - ,@(when index - (setq index (lround index)) - `((write-card16 2 ,(ceiling index 4)) - (setf (buffer-boffset ,buffer) (index+ buffer-boffset ,index)))) - (buffer-new-request-number ,buffer))))) - -(defmacro with-buffer-request - ((buffer opcode &rest options &key inline gc-force &allow-other-keys) - &body type-args &environment env) - (if (and (null inline) (macroexpand '(use-closures) env)) - `(flet ((.request-body. (.display.) - (declare (type display .display.)) - (with-buffer-request-internal (.display. ,opcode ,@options) - ,@type-args))) - #+clx-ansi-common-lisp - (declare (dynamic-extent #'.request-body.)) - (,(if (eq (car (macroexpand '(with-buffer (buffer)) env)) 'progn) - 'with-buffer-request-function-nolock - 'with-buffer-request-function) - ,buffer ,gc-force #'.request-body.)) - `(let ((.display. ,buffer)) - (declare (type display .display.)) - (with-buffer (.display.) - ,@(when gc-force `((force-gcontext-changes-internal ,gc-force))) - (multiple-value-prog1 - (without-aborts - (with-buffer-request-internal (.display. ,opcode ,@options) - ,@type-args)) - (display-invoke-after-function .display.)))))) - -(defmacro with-buffer-request-and-reply - ((buffer opcode reply-size &key sizes multiple-reply inline) - type-args &body reply-forms &environment env) - (declare (indentation 0 4 1 4 2 1)) - (let* ((inner-reply-body - `(with-buffer-input (.reply-buffer. :display .display. - ,@(and sizes (list :sizes sizes))) - nil ,@reply-forms)) - (reply-body - (if (or (not (symbolp reply-size)) (constantp reply-size)) - inner-reply-body - `(let ((,reply-size (reply-data-size (the reply-buffer .reply-buffer.)))) - (declare (type array-index ,reply-size)) - ,inner-reply-body)))) - (if (and (null inline) (macroexpand '(use-closures) env)) - `(flet ((.request-body. (.display.) - (declare (type display .display.)) - (with-buffer-request-internal (.display. ,opcode) - ,@type-args)) - (.reply-body. (.display. .reply-buffer.) - (declare (type display .display.) - (type reply-buffer .reply-buffer.)) - (progn .display. .reply-buffer. nil) - ,reply-body)) - #+clx-ansi-common-lisp - (declare (dynamic-extent #'.request-body. #'.reply-body.)) - (with-buffer-request-and-reply-function - ,buffer ,multiple-reply #'.request-body. #'.reply-body.)) - `(let ((.display. ,buffer) - (.pending-command. nil) - (.reply-buffer. nil)) - (declare (type display .display.) - (type (or null pending-command) .pending-command.) - (type (or null reply-buffer) .reply-buffer.)) - (unwind-protect - (progn - (with-buffer (.display.) - (setq .pending-command. (start-pending-command .display.)) - (without-aborts - (with-buffer-request-internal (.display. ,opcode) - ,@type-args)) - (buffer-force-output .display.) - (display-invoke-after-function .display.)) - ,@(if multiple-reply - `((loop - (setq .reply-buffer. (read-reply .display. .pending-command.)) - (when ,reply-body (return nil)) - (deallocate-reply-buffer (shiftf .reply-buffer. nil)))) - `((setq .reply-buffer. (read-reply .display. .pending-command.)) - ,reply-body))) - (when .reply-buffer. - (deallocate-reply-buffer .reply-buffer.)) - (when .pending-command. - (stop-pending-command .display. .pending-command.))))))) - -(defmacro compare-request ((index) &body body) - `(macrolet ((write-card32 (index item) `(= ,item (read-card32 ,index))) - (write-int32 (index item) `(= ,item (read-int32 ,index))) - (write-card29 (index item) `(= ,item (read-card29 ,index))) - (write-int29 (index item) `(= ,item (read-int29 ,index))) - (write-card16 (index item) `(= ,item (read-card16 ,index))) - (write-int16 (index item) `(= ,item (read-int16 ,index))) - (write-card8 (index item) `(= ,item (read-card8 ,index))) - (write-int8 (index item) `(= ,item (read-int8 ,index)))) - (macrolet ((type-check (value type) value type nil)) - (and ,@(get-put-items index body t))))) - -(defmacro put-items ((index) &body body) - `(progn ,@(get-put-items index body t))) - -(defmacro decode-type (type value) - ;; Given an integer and type, return the value - (let ((args nil)) - (when (consp type) - (setq args (cdr type) - type (car type))) - `(macrolet ((read-card29 (value) value) - (read-card32 (value) value) - (read-int32 (value) `(card32->int32 ,value)) - (read-card16 (value) value) - (read-int16 (value) `(card16->int16 ,value)) - (read-card8 (value) value) - (read-int8 (value) `(int8->card8 ,value))) - (,(getify type) ,value ,@args)))) - -(defmacro encode-type (type value) - ;; Given a value and type, return an integer - ;; When check-p, do type checking on value - (let ((args nil)) - (when (consp type) - (setq args (cdr type) - type (car type))) - `(macrolet ((write-card29 (index value) index value) - (write-card32 (index value) index value) - (write-int32 (index value) index `(int32->card32 ,value)) - (write-card16 (index value) index value) - (write-int16 (index value) index `(int16->card16 ,value)) - (write-card8 (index value) index value) - (write-int8 (index value) index `(int8->card8 ,value))) - (check-put 0 ,value ,type ,@args)))) - -(defmacro set-decode-type (type accessor value) - `(setf ,accessor (encode-type ,type ,value))) -(defsetf decode-type set-decode-type) - - -;;; -;;; Request codes -;;; - -(defconstant +x-createwindow+ 1) -(defconstant +x-changewindowattributes+ 2) -(defconstant +x-getwindowattributes+ 3) -(defconstant +x-destroywindow+ 4) -(defconstant +x-destroysubwindows+ 5) -(defconstant +x-changesaveset+ 6) -(defconstant +x-reparentwindow+ 7) -(defconstant +x-mapwindow+ 8) -(defconstant +x-mapsubwindows+ 9) -(defconstant +x-unmapwindow+ 10) -(defconstant +x-unmapsubwindows+ 11) -(defconstant +x-configurewindow+ 12) -(defconstant +x-circulatewindow+ 13) -(defconstant +x-getgeometry+ 14) -(defconstant +x-querytree+ 15) -(defconstant +x-internatom+ 16) -(defconstant +x-getatomname+ 17) -(defconstant +x-changeproperty+ 18) -(defconstant +x-deleteproperty+ 19) -(defconstant +x-getproperty+ 20) -(defconstant +x-listproperties+ 21) -(defconstant +x-setselectionowner+ 22) -(defconstant +x-getselectionowner+ 23) -(defconstant +x-convertselection+ 24) -(defconstant +x-sendevent+ 25) -(defconstant +x-grabpointer+ 26) -(defconstant +x-ungrabpointer+ 27) -(defconstant +x-grabbutton+ 28) -(defconstant +x-ungrabbutton+ 29) -(defconstant +x-changeactivepointergrab+ 30) -(defconstant +x-grabkeyboard+ 31) -(defconstant +x-ungrabkeyboard+ 32) -(defconstant +x-grabkey+ 33) -(defconstant +x-ungrabkey+ 34) -(defconstant +x-allowevents+ 35) -(defconstant +x-grabserver+ 36) -(defconstant +x-ungrabserver+ 37) -(defconstant +x-querypointer+ 38) -(defconstant +x-getmotionevents+ 39) -(defconstant +x-translatecoords+ 40) -(defconstant +x-warppointer+ 41) -(defconstant +x-setinputfocus+ 42) -(defconstant +x-getinputfocus+ 43) -(defconstant +x-querykeymap+ 44) -(defconstant +x-openfont+ 45) -(defconstant +x-closefont+ 46) -(defconstant +x-queryfont+ 47) -(defconstant +x-querytextextents+ 48) -(defconstant +x-listfonts+ 49) -(defconstant +x-listfontswithinfo+ 50) -(defconstant +x-setfontpath+ 51) -(defconstant +x-getfontpath+ 52) -(defconstant +x-createpixmap+ 53) -(defconstant +x-freepixmap+ 54) -(defconstant +x-creategc+ 55) -(defconstant +x-changegc+ 56) -(defconstant +x-copygc+ 57) -(defconstant +x-setdashes+ 58) -(defconstant +x-setcliprectangles+ 59) -(defconstant +x-freegc+ 60) -(defconstant +x-cleartobackground+ 61) -(defconstant +x-copyarea+ 62) -(defconstant +x-copyplane+ 63) -(defconstant +x-polypoint+ 64) -(defconstant +x-polyline+ 65) -(defconstant +x-polysegment+ 66) -(defconstant +x-polyrectangle+ 67) -(defconstant +x-polyarc+ 68) -(defconstant +x-fillpoly+ 69) -(defconstant +x-polyfillrectangle+ 70) -(defconstant +x-polyfillarc+ 71) -(defconstant +x-putimage+ 72) -(defconstant +x-getimage+ 73) -(defconstant +x-polytext8+ 74) -(defconstant +x-polytext16+ 75) -(defconstant +x-imagetext8+ 76) -(defconstant +x-imagetext16+ 77) -(defconstant +x-createcolormap+ 78) -(defconstant +x-freecolormap+ 79) -(defconstant +x-copycolormapandfree+ 80) -(defconstant +x-installcolormap+ 81) -(defconstant +x-uninstallcolormap+ 82) -(defconstant +x-listinstalledcolormaps+ 83) -(defconstant +x-alloccolor+ 84) -(defconstant +x-allocnamedcolor+ 85) -(defconstant +x-alloccolorcells+ 86) -(defconstant +x-alloccolorplanes+ 87) -(defconstant +x-freecolors+ 88) -(defconstant +x-storecolors+ 89) -(defconstant +x-storenamedcolor+ 90) -(defconstant +x-querycolors+ 91) -(defconstant +x-lookupcolor+ 92) -(defconstant +x-createcursor+ 93) -(defconstant +x-createglyphcursor+ 94) -(defconstant +x-freecursor+ 95) -(defconstant +x-recolorcursor+ 96) -(defconstant +x-querybestsize+ 97) -(defconstant +x-queryextension+ 98) -(defconstant +x-listextensions+ 99) -(defconstant +x-setkeyboardmapping+ 100) -(defconstant +x-getkeyboardmapping+ 101) -(defconstant +x-changekeyboardcontrol+ 102) -(defconstant +x-getkeyboardcontrol+ 103) -(defconstant +x-bell+ 104) -(defconstant +x-changepointercontrol+ 105) -(defconstant +x-getpointercontrol+ 106) -(defconstant +x-setscreensaver+ 107) -(defconstant +x-getscreensaver+ 108) -(defconstant +x-changehosts+ 109) -(defconstant +x-listhosts+ 110) -(defconstant +x-changeaccesscontrol+ 111) -(defconstant +x-changeclosedownmode+ 112) -(defconstant +x-killclient+ 113) -(defconstant +x-rotateproperties+ 114) -(defconstant +x-forcescreensaver+ 115) -(defconstant +x-setpointermapping+ 116) -(defconstant +x-getpointermapping+ 117) -(defconstant +x-setmodifiermapping+ 118) -(defconstant +x-getmodifiermapping+ 119) -(defconstant +x-nooperation+ 127) - -;;; Some macros for threaded lists - -(defmacro threaded-atomic-push (item list next type) - (let ((x (gensym)) - (y (gensym))) - `(let ((,x ,item)) - (declare (type ,type ,x)) - (loop - (let ((,y ,list)) - (declare (type (or null ,type) ,y) - (optimize (speed 3) (safety 0))) - (setf (,next ,x) ,y) - (when (conditional-store ,list ,y ,x) - (return ,x))))))) - -(defmacro threaded-atomic-pop (list next type) - (let ((y (gensym))) - `(loop - (let ((,y ,list)) - (declare (type (or null ,type) ,y) - (optimize (speed 3) (safety 0))) - (if (null ,y) - (return nil) - (when (conditional-store ,list ,y (,next (the ,type ,y))) - (setf (,next (the ,type ,y)) nil) - (return ,y))))))) - -(defmacro threaded-nconc (item list next type) - (let ((first (gensym)) - (x (gensym)) - (y (gensym)) - (z (gensym))) - `(let ((,z ,item) - (,first ,list)) - (declare (type ,type ,z) - (type (or null ,type) ,first) - (optimize (speed 3) (safety 0))) - (if (null ,first) - (setf ,list ,z) - (do* ((,x ,first ,y) - (,y (,next ,x) (,next ,x))) - ((null ,y) - (setf (,next ,x) ,z) - ,first) - (declare (type ,type ,x) - (type (or null ,type) ,y))))))) - -(defmacro threaded-push (item list next type) - (let ((x (gensym))) - `(let ((,x ,item)) - (declare (type ,type ,x) - (optimize (speed 3) (safety 0))) - (shiftf (,next ,x) ,list ,x) - ,x))) - -(defmacro threaded-pop (list next type) - (let ((x (gensym))) - `(let ((,x ,list)) - (declare (type (or null ,type) ,x) - (optimize (speed 3) (safety 0))) - (when ,x - (shiftf ,list (,next (the ,type ,x)) nil)) - ,x))) - -(defmacro threaded-enqueue (item head tail next type) - (let ((x (gensym))) - `(let ((,x ,item)) - (declare (type ,type ,x) - (optimize (speed 3) (safety 0))) - (if (null ,tail) - (threaded-nconc ,x ,head ,next ,type) - (threaded-nconc ,x (,next (the ,type ,tail)) ,next ,type)) - (setf ,tail ,x)))) - -(defmacro threaded-dequeue (head tail next type) - (let ((x (gensym))) - `(let ((,x ,head)) - (declare (type (or null ,type) ,x) - (optimize (speed 3) (safety 0))) - (when ,x - (when (eq ,x ,tail) - (setf ,tail (,next (the ,type ,x)))) - (setf ,head (,next (the ,type ,x)))) - ,x))) - -(defmacro threaded-requeue (item head tail next type) - (let ((x (gensym))) - `(let ((,x ,item)) - (declare (type ,type ,x) - (optimize (speed 3) (safety 0))) - (if (null ,tail) - (setf ,tail (setf ,head ,x)) - (shiftf (,next ,x) ,head ,x)) - ,x))) - -(defmacro threaded-dolist ((variable list next type) &body body) - `(block nil - (do* ((,variable ,list (,next (the ,type ,variable)))) - ((null ,variable)) - (declare (type (or null ,type) ,variable)) - ,@body))) - -(defmacro threaded-delete (item list next type) - (let ((x (gensym)) - (y (gensym)) - (z (gensym)) - (first (gensym))) - `(let ((,x ,item) - (,first ,list)) - (declare (type ,type ,x) - (type (or null ,type) ,first) - (optimize (speed 3) (safety 0))) - (when ,first - (if (eq ,first ,x) - (setf ,first (setf ,list (,next ,x))) - (do* ((,y ,first ,z) - (,z (,next ,y) (,next ,y))) - ((or (null ,z) (eq ,z ,x)) - (when (eq ,z ,x) - (setf (,next ,y) (,next ,x)))) - (declare (type ,type ,y)) - (declare (type (or null ,type) ,z))))) - (setf (,next ,x) nil) - ,first))) - -(defmacro threaded-length (list next type) - (let ((x (gensym)) - (count (gensym))) - `(do ((,x ,list (,next (the ,type ,x))) - (,count 0 (index1+ ,count))) - ((null ,x) - ,count) - (declare (type (or null ,type) ,x) - (type array-index ,count) - (optimize (speed 3) (safety 0)))))) - diff -Nru ecl-16.1.2/src/clx/manager.lisp ecl-16.1.3+ds/src/clx/manager.lisp --- ecl-16.1.2/src/clx/manager.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/manager.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,795 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- - -;;; Window Manager Property functions - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(defun wm-name (window) - (declare (type window window)) - (declare (clx-values string)) - (get-property window :WM_NAME :type :STRING :result-type 'string :transform #'card8->char)) - -(defsetf wm-name (window) (name) - `(set-string-property ,window :WM_NAME ,name)) - -(defun set-string-property (window property string) - (declare (type window window) - (type keyword property) - (type stringable string)) - (change-property window property (string string) :STRING 8 :transform #'char->card8) - string) - -(defun wm-icon-name (window) - (declare (type window window)) - (declare (clx-values string)) - (get-property window :WM_ICON_NAME :type :STRING - :result-type 'string :transform #'card8->char)) - -(defsetf wm-icon-name (window) (name) - `(set-string-property ,window :WM_ICON_NAME ,name)) - -(defun wm-client-machine (window) - (declare (type window window)) - (declare (clx-values string)) - (get-property window :WM_CLIENT_MACHINE :type :STRING - :result-type 'string :transform #'card8->char)) - -(defsetf wm-client-machine (window) (name) - `(set-string-property ,window :WM_CLIENT_MACHINE ,name)) - -(defun get-wm-class (window) - (declare (type window window)) - (declare (clx-values (or null name-string) (or null class-string))) - (let ((value (get-property window :WM_CLASS :type :STRING :result-type '(vector card8)))) - (declare (type (or null (vector card8)) value)) - (when value - (let* ((name-len (position 0 (the (vector card8) value))) - (name (subseq (the (vector card8) value) 0 name-len)) - (class - (when name-len - (subseq (the (vector card8) value) (1+ name-len) - (position 0 (the (vector card8) value) :start (1+ name-len)))))) - (values (and (plusp (length name)) (map 'string #'card8->char name)) - (and (plusp (length class)) (map 'string #'card8->char class))))))) - -(defun set-wm-class (window resource-name resource-class) - (declare (type window window) - (type (or null stringable) resource-name resource-class)) - (change-property window :WM_CLASS - (concatenate '(vector card8) - (map '(vector card8) #'char->card8 - (string (or resource-name ""))) - #(0) - (map '(vector card8) #'char->card8 - (string (or resource-class ""))) - #(0)) - :string 8) - (values)) - -(defun wm-command (window) - ;; Returns a list whose car is the command and - ;; whose cdr is the list of arguments - (declare (type window window)) - (declare (clx-values list)) - (do* ((command-string (get-property window :WM_COMMAND :type :STRING - :result-type '(vector card8))) - (command nil) - (start 0 (1+ end)) - (end 0) - (len (length command-string))) - ((>= start len) (nreverse command)) - (setq end (position 0 command-string :start start)) - (push (map 'string #'card8->char (subseq command-string start end)) - command))) - -(defsetf wm-command set-wm-command) -(defun set-wm-command (window command) - ;; Uses PRIN1 inside the ANSI common lisp form WITH-STANDARD-IO-SYNTAX (or - ;; equivalent), with elements of command separated by NULL characters. This - ;; enables - ;; (with-standard-io-syntax (mapcar #'read-from-string (wm-command window))) - ;; to recover a lisp command. - (declare (type window window) - (type list command)) - (change-property window :WM_COMMAND - (apply #'concatenate '(vector card8) - (mapcan #'(lambda (c) - (list (map '(vector card8) #'char->card8 - (with-output-to-string (stream) - (with-standard-io-syntax - (prin1 c stream)))) - #(0))) - command)) - :string 8) - command) - -;;----------------------------------------------------------------------------- -;; WM_HINTS - -(def-clx-class (wm-hints) - (input nil :type (or null (member :off :on))) - (initial-state nil :type (or null (member :dont-care :normal :zoom :iconic :inactive))) - (icon-pixmap nil :type (or null pixmap)) - (icon-window nil :type (or null window)) - (icon-x nil :type (or null card16)) - (icon-y nil :type (or null card16)) - (icon-mask nil :type (or null pixmap)) - (window-group nil :type (or null resource-id)) - (flags 0 :type card32) ;; Extension-hook. Exclusive-Or'ed with the FLAGS field - ;; may be extended in the future - ) - -(defun wm-hints (window) - (declare (type window window)) - (declare (clx-values wm-hints)) - (let ((prop (get-property window :WM_HINTS :type :WM_HINTS :result-type 'vector))) - (when prop - (decode-wm-hints prop (window-display window))))) - -(defsetf wm-hints set-wm-hints) -(defun set-wm-hints (window wm-hints) - (declare (type window window) - (type wm-hints wm-hints)) - (declare (clx-values wm-hints)) - (change-property window :WM_HINTS (encode-wm-hints wm-hints) :WM_HINTS 32) - wm-hints) - -(defun decode-wm-hints (vector display) - (declare (type (simple-vector 9) vector) - (type display display)) - (declare (clx-values wm-hints)) - (let ((input-hint 0) - (state-hint 1) - (icon-pixmap-hint 2) - (icon-window-hint 3) - (icon-position-hint 4) - (icon-mask-hint 5) - (window-group-hint 6)) - (let ((flags (aref vector 0)) - (hints (make-wm-hints)) - (%buffer display)) - (declare (type card32 flags) - (type wm-hints hints) - (type display %buffer)) - (setf (wm-hints-flags hints) flags) - (when (logbitp input-hint flags) - (setf (wm-hints-input hints) (decode-type (member :off :on) (aref vector 1)))) - (when (logbitp state-hint flags) - (setf (wm-hints-initial-state hints) - (decode-type (member :dont-care :normal :zoom :iconic :inactive) - (aref vector 2)))) - (when (logbitp icon-pixmap-hint flags) - (setf (wm-hints-icon-pixmap hints) (decode-type pixmap (aref vector 3)))) - (when (logbitp icon-window-hint flags) - (setf (wm-hints-icon-window hints) (decode-type window (aref vector 4)))) - (when (logbitp icon-position-hint flags) - (setf (wm-hints-icon-x hints) (aref vector 5) - (wm-hints-icon-y hints) (aref vector 6))) - (when (logbitp icon-mask-hint flags) - (setf (wm-hints-icon-mask hints) (decode-type pixmap (aref vector 7)))) - (when (and (logbitp window-group-hint flags) (> (length vector) 7)) - (setf (wm-hints-window-group hints) (aref vector 8))) - hints))) - - -(defun encode-wm-hints (wm-hints) - (declare (type wm-hints wm-hints)) - (declare (clx-values simple-vector)) - (let ((input-hint #b1) - (state-hint #b10) - (icon-pixmap-hint #b100) - (icon-window-hint #b1000) - (icon-position-hint #b10000) - (icon-mask-hint #b100000) - (window-group-hint #b1000000) - (mask #b1111111) - ) - (let ((vector (make-array 9 :initial-element 0)) - (flags 0)) - (declare (type (simple-vector 9) vector) - (type card16 flags)) - (when (wm-hints-input wm-hints) - (setf flags input-hint - (aref vector 1) (encode-type (member :off :on) (wm-hints-input wm-hints)))) - (when (wm-hints-initial-state wm-hints) - (setf flags (logior flags state-hint) - (aref vector 2) (encode-type (member :dont-care :normal :zoom :iconic :inactive) - (wm-hints-initial-state wm-hints)))) - (when (wm-hints-icon-pixmap wm-hints) - (setf flags (logior flags icon-pixmap-hint) - (aref vector 3) (encode-type pixmap (wm-hints-icon-pixmap wm-hints)))) - (when (wm-hints-icon-window wm-hints) - (setf flags (logior flags icon-window-hint) - (aref vector 4) (encode-type window (wm-hints-icon-window wm-hints)))) - (when (and (wm-hints-icon-x wm-hints) (wm-hints-icon-y wm-hints)) - (setf flags (logior flags icon-position-hint) - (aref vector 5) (encode-type card16 (wm-hints-icon-x wm-hints)) - (aref vector 6) (encode-type card16 (wm-hints-icon-y wm-hints)))) - (when (wm-hints-icon-mask wm-hints) - (setf flags (logior flags icon-mask-hint) - (aref vector 7) (encode-type pixmap (wm-hints-icon-mask wm-hints)))) - (when (wm-hints-window-group wm-hints) - (setf flags (logior flags window-group-hint) - (aref vector 8) (wm-hints-window-group wm-hints))) - (setf (aref vector 0) (logior flags (logandc2 (wm-hints-flags wm-hints) mask))) - vector))) - -;;----------------------------------------------------------------------------- -;; WM_SIZE_HINTS - -(def-clx-class (wm-size-hints) - (user-specified-position-p nil :type generalized-boolean) ;; True when user specified x y - (user-specified-size-p nil :type generalized-boolean) ;; True when user specified width height - ;; the next four fields are obsolete when using a modern window manager - ;; (that will use min-width and friends instead), but they should be set by - ;; clients in case an old window manager is used - (x nil :type (or null int32)) - (y nil :type (or null int32)) - (width nil :type (or null card32)) - (height nil :type (or null card32)) - (min-width nil :type (or null card32)) - (min-height nil :type (or null card32)) - (max-width nil :type (or null card32)) - (max-height nil :type (or null card32)) - (width-inc nil :type (or null card32)) - (height-inc nil :type (or null card32)) - (min-aspect nil :type (or null number)) - (max-aspect nil :type (or null number)) - (base-width nil :type (or null card32)) - (base-height nil :type (or null card32)) - (win-gravity nil :type (or null win-gravity)) - (program-specified-position-p nil :type generalized-boolean) ;; True when program specified x y - (program-specified-size-p nil :type generalized-boolean) ;; True when program specified width height - ) - - -(defun wm-normal-hints (window) - (declare (type window window)) - (declare (clx-values wm-size-hints)) - (decode-wm-size-hints (get-property window :WM_NORMAL_HINTS :type :WM_SIZE_HINTS :result-type 'vector))) - -(defsetf wm-normal-hints set-wm-normal-hints) -(defun set-wm-normal-hints (window hints) - (declare (type window window) - (type wm-size-hints hints)) - (declare (clx-values wm-size-hints)) - (change-property window :WM_NORMAL_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32) - hints) - -;;; OBSOLETE -(defun wm-zoom-hints (window) - (declare (type window window)) - (declare (clx-values wm-size-hints)) - (decode-wm-size-hints (get-property window :WM_ZOOM_HINTS :type :WM_SIZE_HINTS :result-type 'vector))) - -;;; OBSOLETE -(defsetf wm-zoom-hints set-wm-zoom-hints) -;;; OBSOLETE -(defun set-wm-zoom-hints (window hints) - (declare (type window window) - (type wm-size-hints hints)) - (declare (clx-values wm-size-hints)) - (change-property window :WM_ZOOM_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32) - hints) - -(defun decode-wm-size-hints (vector) - (declare (type (or null (simple-vector *)) vector)) - (declare (clx-values (or null wm-size-hints))) - (when vector - (let ((flags (aref vector 0)) - (hints (make-wm-size-hints))) - (declare (type card16 flags) - (type wm-size-hints hints)) - (setf (wm-size-hints-user-specified-position-p hints) (logbitp 0 flags)) - (setf (wm-size-hints-user-specified-size-p hints) (logbitp 1 flags)) - (setf (wm-size-hints-program-specified-position-p hints) (logbitp 2 flags)) - (setf (wm-size-hints-program-specified-size-p hints) (logbitp 3 flags)) - (when (logbitp 4 flags) - (setf (wm-size-hints-min-width hints) (aref vector 5) - (wm-size-hints-min-height hints) (aref vector 6))) - (when (logbitp 5 flags) - (setf (wm-size-hints-max-width hints) (aref vector 7) - (wm-size-hints-max-height hints) (aref vector 8))) - (when (logbitp 6 flags) - (setf (wm-size-hints-width-inc hints) (aref vector 9) - (wm-size-hints-height-inc hints) (aref vector 10))) - (when (logbitp 7 flags) - (setf (wm-size-hints-min-aspect hints) (/ (aref vector 11) (aref vector 12)) - (wm-size-hints-max-aspect hints) (/ (aref vector 13) (aref vector 14)))) - (when (> (length vector) 15) - ;; This test is for backwards compatibility since old Xlib programs - ;; can set a size-hints structure that is too small. See ICCCM. - (when (logbitp 8 flags) - (setf (wm-size-hints-base-width hints) (aref vector 15) - (wm-size-hints-base-height hints) (aref vector 16))) - (when (logbitp 9 flags) - (setf (wm-size-hints-win-gravity hints) - (decode-type (member-vector +win-gravity-vector+) (aref vector 17))))) - ;; Obsolete fields - (when (or (logbitp 0 flags) (logbitp 2 flags)) - (setf (wm-size-hints-x hints) (card32->int32 (aref vector 1)) - (wm-size-hints-y hints) (card32->int32 (aref vector 2)))) - (when (or (logbitp 1 flags) (logbitp 3 flags)) - (setf (wm-size-hints-width hints) (aref vector 3) - (wm-size-hints-height hints) (aref vector 4))) - hints))) - -(defun encode-wm-size-hints (hints) - (declare (type wm-size-hints hints)) - (declare (clx-values simple-vector)) - (let ((vector (make-array 18 :initial-element 0)) - (flags 0)) - (declare (type (simple-vector 18) vector) - (type card16 flags)) - (when (wm-size-hints-user-specified-position-p hints) - (setf (ldb (byte 1 0) flags) 1)) - (when (wm-size-hints-user-specified-size-p hints) - (setf (ldb (byte 1 1) flags) 1)) - (when (wm-size-hints-program-specified-position-p hints) - (setf (ldb (byte 1 2) flags) 1)) - (when (wm-size-hints-program-specified-size-p hints) - (setf (ldb (byte 1 3) flags) 1)) - (when (and (wm-size-hints-min-width hints) (wm-size-hints-min-height hints)) - (setf (ldb (byte 1 4) flags) 1 - (aref vector 5) (wm-size-hints-min-width hints) - (aref vector 6) (wm-size-hints-min-height hints))) - (when (and (wm-size-hints-max-width hints) (wm-size-hints-max-height hints)) - (setf (ldb (byte 1 5) flags) 1 - (aref vector 7) (wm-size-hints-max-width hints) - (aref vector 8) (wm-size-hints-max-height hints))) - (when (and (wm-size-hints-width-inc hints) (wm-size-hints-height-inc hints)) - (setf (ldb (byte 1 6) flags) 1 - (aref vector 9) (wm-size-hints-width-inc hints) - (aref vector 10) (wm-size-hints-height-inc hints))) - (let ((min-aspect (wm-size-hints-min-aspect hints)) - (max-aspect (wm-size-hints-max-aspect hints))) - (when (and min-aspect max-aspect) - (setf (ldb (byte 1 7) flags) 1 - min-aspect (rationalize min-aspect) - max-aspect (rationalize max-aspect) - (aref vector 11) (numerator min-aspect) - (aref vector 12) (denominator min-aspect) - (aref vector 13) (numerator max-aspect) - (aref vector 14) (denominator max-aspect)))) - (when (and (wm-size-hints-base-width hints) - (wm-size-hints-base-height hints)) - (setf (ldb (byte 1 8) flags) 1 - (aref vector 15) (wm-size-hints-base-width hints) - (aref vector 16) (wm-size-hints-base-height hints))) - (when (wm-size-hints-win-gravity hints) - (setf (ldb (byte 1 9) flags) 1 - (aref vector 17) (encode-type - (member-vector +win-gravity-vector+) - (wm-size-hints-win-gravity hints)))) - ;; Obsolete fields - (when (and (wm-size-hints-x hints) (wm-size-hints-y hints)) - (unless (wm-size-hints-user-specified-position-p hints) - (setf (ldb (byte 1 2) flags) 1)) - (setf (aref vector 1) (wm-size-hints-x hints) - (aref vector 2) (wm-size-hints-y hints))) - (when (and (wm-size-hints-width hints) (wm-size-hints-height hints)) - (unless (wm-size-hints-user-specified-size-p hints) - (setf (ldb (byte 1 3) flags) 1)) - (setf (aref vector 3) (wm-size-hints-width hints) - (aref vector 4) (wm-size-hints-height hints))) - (setf (aref vector 0) flags) - vector)) - -;;----------------------------------------------------------------------------- -;; Icon_Size - -;; Use the same intermediate structure as WM_SIZE_HINTS - -(defun icon-sizes (window) - (declare (type window window)) - (declare (clx-values wm-size-hints)) - (let ((vector (get-property window :WM_ICON_SIZE :type :WM_ICON_SIZE :result-type 'vector))) - (declare (type (or null (simple-vector 6)) vector)) - (when vector - (make-wm-size-hints - :min-width (aref vector 0) - :min-height (aref vector 1) - :max-width (aref vector 2) - :max-height (aref vector 3) - :width-inc (aref vector 4) - :height-inc (aref vector 5))))) - -(defsetf icon-sizes set-icon-sizes) -(defun set-icon-sizes (window wm-size-hints) - (declare (type window window) - (type wm-size-hints wm-size-hints)) - (let ((vector (vector (wm-size-hints-min-width wm-size-hints) - (wm-size-hints-min-height wm-size-hints) - (wm-size-hints-max-width wm-size-hints) - (wm-size-hints-max-height wm-size-hints) - (wm-size-hints-width-inc wm-size-hints) - (wm-size-hints-height-inc wm-size-hints)))) - (change-property window :WM_ICON_SIZE vector :WM_ICON_SIZE 32) - wm-size-hints)) - -;;----------------------------------------------------------------------------- -;; WM-Protocols - -(defun wm-protocols (window) - (map 'list #'(lambda (id) (atom-name (window-display window) id)) - (get-property window :WM_PROTOCOLS :type :ATOM))) - -(defsetf wm-protocols set-wm-protocols) -(defun set-wm-protocols (window protocols) - (change-property window :WM_PROTOCOLS - (map 'list #'(lambda (atom) (intern-atom (window-display window) atom)) - protocols) - :ATOM 32) - protocols) - -;;----------------------------------------------------------------------------- -;; WM-Colormap-windows - -(defun wm-colormap-windows (window) - (values (get-property window :WM_COLORMAP_WINDOWS :type :WINDOW - :transform #'(lambda (id) - (lookup-window (window-display window) id))))) - -(defsetf wm-colormap-windows set-wm-colormap-windows) -(defun set-wm-colormap-windows (window colormap-windows) - (change-property window :WM_COLORMAP_WINDOWS colormap-windows :WINDOW 32 - :transform #'window-id) - colormap-windows) - -;;----------------------------------------------------------------------------- -;; Transient-For - -(defun transient-for (window) - (let ((prop (get-property window :WM_TRANSIENT_FOR :type :WINDOW :result-type 'list))) - (and prop (lookup-window (window-display window) (car prop))))) - -(defsetf transient-for set-transient-for) -(defun set-transient-for (window transient) - (declare (type window window transient)) - (change-property window :WM_TRANSIENT_FOR (list (window-id transient)) :WINDOW 32) - transient) - -;;----------------------------------------------------------------------------- -;; Set-WM-Properties - -(defun set-wm-properties (window &rest options &key - name icon-name resource-name resource-class command - client-machine hints normal-hints zoom-hints - ;; the following are used for wm-normal-hints - (user-specified-position-p nil usppp) - (user-specified-size-p nil usspp) - (program-specified-position-p nil psppp) - (program-specified-size-p nil psspp) - x y width height min-width min-height max-width max-height - width-inc height-inc min-aspect max-aspect - base-width base-height win-gravity - ;; the following are used for wm-hints - input initial-state icon-pixmap icon-window - icon-x icon-y icon-mask window-group) - ;; Set properties for WINDOW. - (declare (arglist window &rest options &key - name icon-name resource-name resource-class command - client-machine hints normal-hints - ;; the following are used for wm-normal-hints - user-specified-position-p user-specified-size-p - program-specified-position-p program-specified-size-p - min-width min-height max-width max-height - width-inc height-inc min-aspect max-aspect - base-width base-height win-gravity - ;; the following are used for wm-hints - input initial-state icon-pixmap icon-window - icon-x icon-y icon-mask window-group)) - (declare (type window window) - (type (or null stringable) name icon-name resource-name resource-class client-machine) - (type (or null list) command) - (type (or null wm-hints) hints) - (type (or null wm-size-hints) normal-hints zoom-hints) - (type generalized-boolean user-specified-position-p user-specified-size-p) - (type generalized-boolean program-specified-position-p program-specified-size-p) - (type (or null int32) x y) - (type (or null card32) width height min-width min-height max-width max-height width-inc height-inc base-width base-height) - (type (or null win-gravity) win-gravity) - (type (or null number) min-aspect max-aspect) - (type (or null (member :off :on)) input) - (type (or null (member :dont-care :normal :zoom :iconic :inactive)) initial-state) - (type (or null pixmap) icon-pixmap icon-mask) - (type (or null window) icon-window) - (type (or null card32) icon-x icon-y) - (type (or null resource-id) window-group) - (dynamic-extent options)) - (when name (setf (wm-name window) name)) - (when icon-name (setf (wm-icon-name window) icon-name)) - (when client-machine (setf (wm-client-machine window) client-machine)) - (when (or resource-name resource-class) - (set-wm-class window resource-name resource-class)) - (when command (setf (wm-command window) command)) - ;; WM-HINTS - (if (dolist (arg '(:input :initial-state :icon-pixmap :icon-window - :icon-x :icon-y :icon-mask :window-group)) - (when (getf options arg) (return t))) - (let ((wm-hints (if hints (copy-wm-hints hints) (make-wm-hints)))) - (when input (setf (wm-hints-input wm-hints) input)) - (when initial-state (setf (wm-hints-initial-state wm-hints) initial-state)) - (when icon-pixmap (setf (wm-hints-icon-pixmap wm-hints) icon-pixmap)) - (when icon-window (setf (wm-hints-icon-window wm-hints) icon-window)) - (when icon-x (setf (wm-hints-icon-x wm-hints) icon-x)) - (when icon-y (setf (wm-hints-icon-y wm-hints) icon-y)) - (when icon-mask (setf (wm-hints-icon-mask wm-hints) icon-mask)) - (when window-group (setf (wm-hints-window-group wm-hints) window-group)) - (setf (wm-hints window) wm-hints)) - (when hints (setf (wm-hints window) hints))) - ;; WM-NORMAL-HINTS - (if (dolist (arg '(:x :y :width :height :min-width :min-height :max-width :max-height - :width-inc :height-inc :min-aspect :max-aspect - :user-specified-position-p :user-specified-size-p - :program-specified-position-p :program-specified-size-p - :base-width :base-height :win-gravity)) - (when (getf options arg) (return t))) - (let ((size (if normal-hints (copy-wm-size-hints normal-hints) (make-wm-size-hints)))) - (when x (setf (wm-size-hints-x size) x)) - (when y (setf (wm-size-hints-y size) y)) - (when width (setf (wm-size-hints-width size) width)) - (when height (setf (wm-size-hints-height size) height)) - (when min-width (setf (wm-size-hints-min-width size) min-width)) - (when min-height (setf (wm-size-hints-min-height size) min-height)) - (when max-width (setf (wm-size-hints-max-width size) max-width)) - (when max-height (setf (wm-size-hints-max-height size) max-height)) - (when width-inc (setf (wm-size-hints-width-inc size) width-inc)) - (when height-inc (setf (wm-size-hints-height-inc size) height-inc)) - (when min-aspect (setf (wm-size-hints-min-aspect size) min-aspect)) - (when max-aspect (setf (wm-size-hints-max-aspect size) max-aspect)) - (when base-width (setf (wm-size-hints-base-width size) base-width)) - (when base-height (setf (wm-size-hints-base-height size) base-height)) - (when win-gravity (setf (wm-size-hints-win-gravity size) win-gravity)) - (when usppp - (setf (wm-size-hints-user-specified-position-p size) user-specified-position-p)) - (when usspp - (setf (wm-size-hints-user-specified-size-p size) user-specified-size-p)) - (when psppp - (setf (wm-size-hints-program-specified-position-p size) program-specified-position-p)) - (when psspp - (setf (wm-size-hints-program-specified-size-p size) program-specified-size-p)) - (setf (wm-normal-hints window) size)) - (when normal-hints (setf (wm-normal-hints window) normal-hints))) - (when zoom-hints (setf (wm-zoom-hints window) zoom-hints)) - ) - -;;; OBSOLETE -(defun set-standard-properties (window &rest options) - (declare (dynamic-extent options)) - (apply #'set-wm-properties window options)) - -;;----------------------------------------------------------------------------- -;; WM Control - -(defun iconify-window (window screen) - (declare (type window window) - (type screen screen)) - (let ((root (screen-root screen))) - (declare (type window root)) - (send-event root :client-message '(:substructure-redirect :substructure-notify) - :window window :format 32 :type :WM_CHANGE_STATE :data (list 3)))) - -(defun withdraw-window (window screen) - (declare (type window window) - (type screen screen)) - (unmap-window window) - (let ((root (screen-root screen))) - (declare (type window root)) - (send-event root :unmap-notify '(:substructure-redirect :substructure-notify) - :window window :event-window root :configure-p nil))) - - -;;----------------------------------------------------------------------------- -;; Colormaps - -(def-clx-class (standard-colormap (:copier nil) (:predicate nil)) - (colormap nil :type (or null colormap)) - (base-pixel 0 :type pixel) - (max-color nil :type (or null color)) - (mult-color nil :type (or null color)) - (visual nil :type (or null visual-info)) - (kill nil :type (or (member nil :release-by-freeing-colormap) - drawable gcontext cursor colormap font))) - -(defun rgb-colormaps (window property) - (declare (type window window) - (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP - :RGB_GREEN_MAP :RGB_BLUE_MAP) property)) - (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector))) - (declare (type (or null simple-vector) prop)) - (when prop - (list (make-standard-colormap - :colormap (lookup-colormap (window-display window) (aref prop 0)) - :base-pixel (aref prop 7) - :max-color (make-color :red (card16->rgb-val (aref prop 1)) - :green (card16->rgb-val (aref prop 3)) - :blue (card16->rgb-val (aref prop 5))) - :mult-color (make-color :red (card16->rgb-val (aref prop 2)) - :green (card16->rgb-val (aref prop 4)) - :blue (card16->rgb-val (aref prop 6))) - :visual (and (<= 9 (length prop)) - (visual-info (window-display window) (aref prop 8))) - :kill (and (<= 10 (length prop)) - (let ((killid (aref prop 9))) - (if (= killid 1) - :release-by-freeing-colormap - (lookup-resource-id (window-display window) killid))))))))) - -(defsetf rgb-colormaps set-rgb-colormaps) -(defun set-rgb-colormaps (window property maps) - (declare (type window window) - (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP - :RGB_GREEN_MAP :RGB_BLUE_MAP) property) - (type list maps)) - (let ((prop (make-array (* 10 (length maps)) :element-type 'card32)) - (index -1)) - (dolist (map maps) - (setf (aref prop (incf index)) - (encode-type colormap (standard-colormap-colormap map))) - (setf (aref prop (incf index)) - (encode-type rgb-val (color-red (standard-colormap-max-color map)))) - (setf (aref prop (incf index)) - (encode-type rgb-val (color-red (standard-colormap-mult-color map)))) - (setf (aref prop (incf index)) - (encode-type rgb-val (color-green (standard-colormap-max-color map)))) - (setf (aref prop (incf index)) - (encode-type rgb-val (color-green (standard-colormap-mult-color map)))) - (setf (aref prop (incf index)) - (encode-type rgb-val (color-blue (standard-colormap-max-color map)))) - (setf (aref prop (incf index)) - (encode-type rgb-val (color-blue (standard-colormap-mult-color map)))) - (setf (aref prop (incf index)) - (standard-colormap-base-pixel map)) - (setf (aref prop (incf index)) - (visual-info-id (standard-colormap-visual map))) - (setf (aref prop (incf index)) - (let ((kill (standard-colormap-kill map))) - (etypecase kill - (symbol - (ecase kill - ((nil) 0) - ((:release-by-freeing-colormap) 1))) - (drawable (drawable-id kill)) - (gcontext (gcontext-id kill)) - (cursor (cursor-id kill)) - (colormap (colormap-id kill)) - (font (font-id kill)))))) - (change-property window property prop :RGB_COLOR_MAP 32))) - -;;; OBSOLETE -(defun get-standard-colormap (window property) - (declare (type window window) - (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP - :RGB_GREEN_MAP :RGB_BLUE_MAP) property)) - (declare (clx-values colormap base-pixel max-color mult-color)) - (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector))) - (declare (type (or null simple-vector) prop)) - (when prop - (values (lookup-colormap (window-display window) (aref prop 0)) - (aref prop 7) ;Base Pixel - (make-color :red (card16->rgb-val (aref prop 1)) ;Max Color - :green (card16->rgb-val (aref prop 3)) - :blue (card16->rgb-val (aref prop 5))) - (make-color :red (card16->rgb-val (aref prop 2)) ;Mult color - :green (card16->rgb-val (aref prop 4)) - :blue (card16->rgb-val (aref prop 6))))))) - -;;; OBSOLETE -(defun set-standard-colormap (window property colormap base-pixel max-color mult-color) - (declare (type window window) - (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP - :RGB_GREEN_MAP :RGB_BLUE_MAP) property) - (type colormap colormap) - (type pixel base-pixel) - (type color max-color mult-color)) - (let ((prop (vector (encode-type colormap colormap) - (encode-type rgb-val (color-red max-color)) - (encode-type rgb-val (color-red mult-color)) - (encode-type rgb-val (color-green max-color)) - (encode-type rgb-val (color-green mult-color)) - (encode-type rgb-val (color-blue max-color)) - (encode-type rgb-val (color-blue mult-color)) - base-pixel))) - (change-property window property prop :RGB_COLOR_MAP 32))) - -;;----------------------------------------------------------------------------- -;; Cut-Buffers - -(defun cut-buffer (display &key (buffer 0) (type :STRING) (result-type 'string) - (transform #'card8->char) (start 0) end) - ;; Return the contents of cut-buffer BUFFER - (declare (type display display) - (type (integer 0 7) buffer) - (type xatom type) - (type array-index start) - (type (or null array-index) end) - (type t result-type) ;a sequence type - (type (or null (function (integer) t)) transform)) - (declare (clx-values sequence type format bytes-after)) - (let* ((root (screen-root (first (display-roots display)))) - (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 - :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7) - buffer))) - (get-property root property :type type :result-type result-type - :start start :end end :transform transform))) - -;; Implement the following: -;; (defsetf cut-buffer (display &key (buffer 0) (type :string) (format 8) -;; (transform #'char->card8) (start 0) end) (data) -;; In order to avoid having to pass positional parameters to set-cut-buffer, -;; We've got to do the following. WHAT A PAIN... -#-clx-ansi-common-lisp -(define-setf-method cut-buffer (display &rest option-list) - (declare (dynamic-extent option-list)) - (do* ((options (copy-list option-list)) - (option options (cddr option)) - (store (gensym)) - (dtemp (gensym)) - (temps (list dtemp)) - (values (list display))) - ((endp option) - (values (nreverse temps) - (nreverse values) - (list store) - `(set-cut-buffer ,store ,dtemp ,@options) - `(cut-buffer ,@options))) - (unless (member (car option) '(:buffer :type :format :start :end :transform)) - (error "Keyword arg ~s isn't recognized" (car option))) - (let ((x (gensym))) - (push x temps) - (push (cadr option) values) - (setf (cadr option) x)))) - -(defun - #+clx-ansi-common-lisp (setf cut-buffer) - #-clx-ansi-common-lisp set-cut-buffer - (data display &key (buffer 0) (type :STRING) (format 8) - (start 0) end (transform #'char->card8)) - (declare (type sequence data) - (type display display) - (type (integer 0 7) buffer) - (type xatom type) - (type (member 8 16 32) format) - (type array-index start) - (type (or null array-index) end) - (type (or null (function (integer) t)) transform)) - (let* ((root (screen-root (first (display-roots display)))) - (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 - :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7) - buffer))) - (change-property root property data type format :transform transform :start start :end end) - data)) - -(defun rotate-cut-buffers (display &optional (delta 1) (careful-p t)) - ;; Positive rotates left, negative rotates right (opposite of actual protocol request). - ;; When careful-p, ensure all cut-buffer properties are defined, to prevent errors. - (declare (type display display) - (type int16 delta) - (type generalized-boolean careful-p)) - (let* ((root (screen-root (first (display-roots display)))) - (buffers '#(:cut_buffer0 :cut_buffer1 :cut_buffer2 :cut_buffer3 - :cut_buffer4 :cut_buffer5 :cut_buffer6 :cut_buffer7))) - (when careful-p - (let ((props (list-properties root))) - (dotimes (i 8) - (unless (member (aref buffers i) props) - (setf (cut-buffer display :buffer i) ""))))) - (rotate-properties root buffers delta))) - diff -Nru ecl-16.1.2/src/clx/manual/clx.texinfo ecl-16.1.3+ds/src/clx/manual/clx.texinfo --- ecl-16.1.2/src/clx/manual/clx.texinfo 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/manual/clx.texinfo 1970-01-01 00:00:00.000000000 +0000 @@ -1,18312 +0,0 @@ -\input texinfo @c -*-texinfo-*- -@c $Id: clx.texinfo,v 1.3 2004/11/18 12:01:48 dan Exp $ -@c %**start of header -@setfilename clx.info -@settitle Common LISP X Interface -@setchapternewpage odd -@c %**end of header - -@dircategory lisp -@direntry -* CLX: (clx). Common LISP X Interface -@end direntry - -@copying -The Common LISP X Interface (CLX) - -Copyright @copyright{} 1988, 1989 Texas Instruments Incorporated - -@quotation -Permission is granted to any individual or institution to use, copy, -modify and distribute this document, provided that this complete -copyright and permission notice is maintained, intact, in all copies -and supporting documentation. Texas Instruments Incorporated makes no -representations about the suitability of this document or the software -described herein for any purpose. It is provided "as is" without -express or implied warranty. -@end quotation - -@end copying - -@titlepage -@title The Common Lisp X Interface (CLX) - -@page -@vskip 0pt plus 1filll -@insertcopying -@end titlepage - -@contents - -@ifnottex -@node Top, Acknowledgments, (dir), (dir) -@top The Common LISP X Interface (CLX) - -@insertcopying -@end ifnottex - -@menu -* Acknowledgments:: -* Introduction to CLX:: -* Displays:: -* Screens:: -* Windows and Pixmaps:: -* Graphics Contexts:: -* Graphic Operations:: -* Images:: -* Font and Characters:: -* Colors:: -* Cursors:: -* Atoms:: -* Events and Input:: -* Resources:: -* Control Functions:: -* Extensions:: -* Errors:: -* Undocumented:: -* Glossary:: -* Function Index:: -* Type Index:: - -@detailmenu - --- The Detailed Node Listing --- - -Introduction to CLX - -* The X Window System:: -* A Quick Tour of CLX:: -* Naming and Argument Conventions:: -* Programming Considerations:: -* Data Types:: - -The X Window System - -* Windows:: -* Input Events:: - -A Quick Tour of CLX - -* A Simple Menu:: -* Displaying the Menu:: -* Menu Input:: -* The Main Program:: -* Debugging With CLX:: - -Displays - -* Opening the Display:: -* Display Attributes:: -* Managing the Output Buffer:: -* Closing the Display:: - -Screens - -* Screens and Visuals:: -* Screen Attributes:: - -Windows and Pixmaps - -* Drawables:: -* Creating Windows:: -* Window Attributes:: -* Stacking Order:: -* Window Hierarchy:: -* Mapping Windows:: -* Destroying Windows:: -* Pixmaps:: - -Graphics Contexts - -* Creating Graphics Contexts:: -* Graphics Context Attributes:: -* Copying Graphics Contexts:: -* Destroying Graphics Contexts:: -* Graphics Context Cache:: - -Graphic Operations - -* Area and Plane Operations:: -* Drawing Points:: -* Drawing Lines:: -* Drawing Rectangles:: -* Drawing Arcs:: -* Drawing Text:: - -Images - -* Image Types:: -* Image Functions:: -* Image Files:: -* Direct Image Transfer:: - -Image Types - -* Basic Images:: -* XY-Format Images:: -* Z-Format Images:: - -Font and Characters - -* Opening Fonts:: -* Listing Fonts:: -* Font Attributes:: -* Chracter Attributes:: -* Querying Text Size:: - -Colors - -* Colormaps and Colors:: -* Color Functions:: -* Colormap Functions:: - -Colormap Functions - -* Creating Colormaps:: -* Installing Colormaps:: -* Allocating Colors:: -* Finding Colors:: -* Changing Colors:: -* Colormap Attributes:: - -Cursors - -* Creating Cursors:: -* Cursor Functions:: -* Cursor Attributes:: - -Atoms, Properties and Selections - -* Atoms (Atoms):: -* Properties:: -* Selections:: - -Events and Input - -* Selecting Events:: -* Processing Events:: -* Managing the Event Queue:: -* Sending Events:: -* Pointer Position:: -* Managing Input Focus:: -* Grabbing the Pointer:: -* Grabbing a Button:: -* Grabbing the Keyboard:: -* Grabbing a Key:: -* Event Types:: -* Releasing Queued Events:: - -Event Types - -* Keyboard and Pointer Events:: -* Input Focus Events:: -* Keyboard and Pointer State Events:: -* Exposure Events:: -* Window State Events:: -* Structure Control Events:: -* Client Communications Events:: -* Declaring Event Types:: - -Resources - -* Resource Binings:: -* Basic Resource Database Functions:: -* Accessing Resource Values:: -* Resource Database Files:: - -Accessing Resource Values - -* Complete Names and Classes:: -* Matching Resource Names:: -* Resource Access Functions:: - -Control Functions - -* Grabbing the Server:: -* Pointer Control:: -* Keyboard Control:: -* Keyboard Encodings:: -* Client Termination:: -* Managing Host Access:: -* Screen Saver:: - -Keyboard Encodings - -* Keycodes and Keysyms:: -* Keyboard Mapping:: -* Using Keycodes and Keysyms:: - -Extensions - -* Extensions (Extensions):: -* SHAPE - The X11 Nonrectangular Window Shape Extension:: -* RENDER - A new rendering system for X11:: -* DPMS - The X11 Display Power Management Signaling Extension:: -* BIG-REQUESTS - Big Requests Extension:: - -RENDER - A new rendering system for X11 - -* Picture formats:: -* The picture object:: -* Glyphs and Glyphsets:: -* Using glyphs:: -* Errors (Extensions):: - -Errors - -* Introduction (Errors):: - -@end detailmenu -@end menu - -@node Acknowledgments, Introduction to CLX, Top, Top -@chapter Acknowledgments - -Primary Interface Author: - -Robert W. Scheifler - -@display -MIT Laboratory for Computer Science -545 Technology Square, Room 418 -Cambridge, MA 02139 -@email{rws@@zermatt.lcs.mit.edu} -@end display - -Primary Implementation Author: - -LaMott Oren - -@display -Texas Instruments -PO Box 655474, MS 238 -Dallas, TX 75265 -@email{oren@@csc.ti.com} -@end display - - - -Design Contributors: - -@itemize @bullet -@item Dan Cerys, BBN -@item Scott Fahlman, CMU -@item Kerry Kimbrough, Texas Instruments -@item Chris Lindblad, MIT -@item Rob MacLachlan, CMU -@item Mike McMahon, Symbolics -@item David Moon, Symbolics -@item LaMott Oren, Texas Instruments -@item Daniel Weinreb, Symbolics -@item John Wroclawski, MIT -@item Richard Zippel, Symbolics -@end itemize - -Documentation Contributors: - -@itemize @bullet -@item Keith Cessna, Texas Instruments -@item Kerry Kimbrough, Texas Instruments -@item Mike Myjak -@item LaMott Oren, Texas Instruments -@item Dan Stenger, Texas Instruments -@end itemize - -The X Window System is a trademark of MIT. - -UNIX is a trademark of AT&T Bell Laboratories. - -ULTRIX, ULTRIX-32, ULTRIX-32m, ULTRIX-32w, and VAX/VMS are trademarks of Digital Equipment -Corporation. - -@node Introduction to CLX, Displays, Acknowledgments, Top -@chapter Introduction to CLX - -This manual assumes a basic understanding of window systems and the Common Lisp programming -language. To provide an introduction to the Common Lisp X Interface (CLX) programming, this -section discusses the following: - -@itemize @bullet -@item Overview of the X Window System -@item Naming and argument conventions -@item Programming considerations -@end itemize - -@menu -* The X Window System:: -* A Quick Tour of CLX:: -* Naming and Argument Conventions:: -* Programming Considerations:: -* Data Types:: -@end menu - -@node The X Window System, A Quick Tour of CLX, Introduction to CLX, Introduction to CLX -@section The X Window System - -The X Window System was developed at the Massachusetts Institute of -Technology (MIT) and first released in 1985. Since then, the X Window -System has become an industry-standard product available on virtually -every type of bit-mapped workstation. The current version of X, -Version 11, has been implemented for several different computer -architectures, for a wide variety of display hardware, and also for -many different operating systems. X Version 11 represents the -fulfillment of the original design goals proposed by MIT, as follows: - -@table @asis -@item Portable -Support virtually any bitmap display and any interactive input device -(including keyboards, mice, tablets, joysticks, and touch screens). -Make it easy to implement the window system on different operating -systems. - -@item Device-Independent Applications -Avoid rewriting, recompiling, or even relinking in order to use -different display/input hardware. Make it easy for an application to -work on both monochrome and color hardware. - -@item Network Transparent -Let an application run on one computer while using another computer's -display, even if the other computer has a different operating system -or hardware architecture. - -@item Multitasking -Support multiple applications being displayed simultaneously. - -@item No User Interface Policy - -Since no one agrees on what constitutes the best user interface, make -it possible for a broad range of user interface styles (or policies) -to be implemented, external to the window system and to the -application programs. - -@item Cheap Windows -Windows should be abundant, and ubiquitous. Provide overlapping -windows and a simple mechanism for window hierarchy. - -@item High-Performance Graphics -Provide powerful interfaces for synthesizing 2-D images (geometric -primitives, high-quality text with multiple typefaces, and scanned -images). - -@item Extensible -Include a mechanism for adding new capabilities. Allow separate sites -to develop independent extensions without becoming incompatible with -remote applications. -@end table - -Some of these goals lead directly to the basic X architecture -- the -client-server model. The basic window system is implemented by the X -@emph{server} program. An application program (the @emph{client}) -sends window system @emph{requests} to the X server through a reliable -two-way byte-stream. - -In general, the server and the client can be executing on separate -host computers, in which case the byte-stream is implemented via some -network protocol (TCP, DECnet(tm), Chaosnet, and so -forth). The X server, which is connected to several client programs -running concurrently, executes client requests in round-robin -fashion. The server is responsible for drawing client graphics on the -display screen and for making sure that graphics output to a window -stays inside its boundary. - -The other primary job of the X server is to channel input from the -keyboard, pointer, and other input devices back to the appropriate -client programs. Input arrives at the client asynchronously in the -form of input @emph{events} representing up/down transitions of keys -or pointer buttons, changes in the pointer position, and so on. In -some cases, a request generates a return value (or @emph{reply}) from -the server, which is another kind of client input. Replies and input -events are received via the same byte-stream connecting the client -with the server. - -@menu -* Windows:: -* Input Events:: -@end menu - -@node Windows, Input Events, The X Window System, The X Window System -@subsection Windows - -The X Window System supports one or more screens containing -overlapping windows and subwindows. A @emph{screen} is a physical -monitor and hardware, which can be either color or black and -white. There can be multiple screens per display workstation. A single -server can provide display services for any number of screens. A set -of screens for a single user with one keyboard and one mouse is called -a @emph{display}. - -All windows in an X server are arranged in a strict hierarchy. At the -top of the hierarchy are the @emph{root windows}, which cover each of -the display screens. Each root window is either partially or -completely covered by child windows. All windows, except for root -windows, have parents. Any window can in turn have its own -children. In this way, an application program can create a window tree -of arbitrary depth on each screen. - -A child window can be larger than its parent. That is, part or all of -the child window can extend beyond the boundaries of the parent. -However, all output to a window is clipped by the boundaries of its -parent window. If several children of a window have overlapping -locations, one of the children is considered to be on top of/or raised -over the others, @emph{obscuring} them. Window output to areas that -are covered by other windows is suppressed. - -A window has a border that is zero or more pixels in width and can be -any pattern (pixmap) or solid color. A window usually has a background -pattern that is drawn by the X server. Each window has its own -coordinate system. Child windows obscure their parents unless the -child windows have no background. Graphics operations in the parent -window are usually clipped by the children. - -X also provides objects called @emph{pixmaps} for off-screen storage -of graphics. Single-plane pixmaps (that is, of depth 1) are sometimes -referred to as @emph{bitmaps}. Both pixmaps and windows can be used -interchangeably in most graphics functions. Pixmaps are also used in -various graphics operations to define patterns, or -@emph{tiles}. Windows and pixmaps together are referred to as -@emph{drawables}. - -@node Input Events, , Windows, The X Window System -@subsection Input Events - -The X input mechanism is conceptually simple yet quite powerful. Most -events are attached to a particular window (that is, contain an -identifier for the window receiving the event). A client program can -receive multiple window input streams, all multiplexed over the single -byte-stream connection to the server. - -Clients can tailor their input by expressing interest in only certain -event types. The server uses special event types to send important -messages to the client. For example, the client can elect to receive -an @var{:enter-notify} -(@pxref{:enter-notify}) event -when the pointer cursor moves into a certain window. Another vital -message from the server is an @var{:exposure} -(@pxref{:exposure}) event. This is a -signal to the client indicating that at least some portion of the -window has suddenly become visible (perhaps the user moved another -window which had been overlapping it). The client is then responsible -for doing what is necessary to redisplay the window's image. Client -programs must be prepared to regenerate the contents of windows in -this way on demand. - -Input is also subject to policy decisions about which client window -receives keyboard and pointer events. Since the pointer is free to roam -between windows, just clicking on a window is often enough to send a -pointer event to that window. Keyboard events, however, must go to a -keyboard focus window which has to be designated in some other way. -Usually, the arbiter of such input management policy is a program called -the @emph{window manager}. The window manager gives the human -user a way to make a window the keyboard focus, to manage the layout of -windows on the screen, to represent windows with icons, and so forth. In -fact, the window manager client determines most of the so-called look -and feel of the X Window System. - -@node A Quick Tour of CLX, Naming and Argument Conventions, The X Window System, Introduction to CLX -@section A Quick Tour of CLX - -The X Window System is defined by the X Window System Protocol -Specification, a detailed description of the encoding and the meaning of -requests and events sent between a client and a server. This standard -protocol does not depend on any particular programming language. As a -result, each programming language must define its own functional -interface for using the X protocol. The standard X interface used by -Common Lisp programmers is called CLX. CLX is a set of data types, -functions, and macros which allow a Common Lisp client program to -interact with an X server to send requests and to receive input events -and replies. - -For the most part, CLX functions are closely tied to the underlying -requests in the X protocol. Many CLX functions simply add requests to an -output buffer. These requests later execute asynchronously on the X -display server. However, some functions of CLX lie outside the scope of -the protocol--for example, reading events and managing a clientside -event queue. CLX is also responsible for important batching and caching -tasks that minimize network communication. - -The following paragraphs show an example of a CLX client program. All -CLX functions and macros are shown in upper case. Note that some of the -terms used are unique to X, while other terms that are common to other -window systems have different meanings in X. It may be helpful to refer -to the glossary when you are uncertain of a term's meaning in the -context of the X Window System. - -@menu -* A Simple Menu:: -* Displaying the Menu:: -* Menu Input:: -* The Main Program:: -* Debugging With CLX:: -@end menu - -@node A Simple Menu, Displaying the Menu, A Quick Tour of CLX, A Quick Tour of CLX -@subsection A Simple Menu - -The example client program creates and displays a simple pop-up menu -consisting of a column of strings--a title string followed by selectable -menu item strings. The implementation uses one window to represent the -entire menu, plus a set of subwindows, one for each menu item. Here is -the definition of a structure which represents such a menu. - -@lisp -(defstruct (menu) - "A simple menu of text strings." - (title "Choose an item:") - item-alist ;((item-window item-string)) - window - gcontext - width - title-width - item-width - item-height - (geometry-changed-p t)) ;nil if unchanged since displayed -@end lisp - - -The @code{window} slot will contain the -@var{window} (@pxref{window}) -object that represents the menu. The @code{item-} -@code{alist} represents the relationship between the menu items -and their associated subwindows. Each entry in @code{item-alist} -is a list whose first element is a (sub)window object and whose second -element is the corresponding item string. A -@var{window} (@pxref{window}) -object is an instance of a CLX-defined data type which represents X -windows. A -@var{window} (@pxref{window}) -object actually carries two pieces of information: an X window ID -integer and a -@var{display} (@pxref{display}) -object. A -@var{display} (@pxref{display}) -is another CLX-defined data type that represents a connection to a -specific X display server. The @code{gcontext} slot contains an -instance of a CLX data type known as a @emph{graphics context}. A -graphics context is a set of display attribute values, such as -foreground color, fill style, line style, text font, and so forth. Each -X graphics request (and hence each CLX graphics function call) must -supply a graphics context to use in displaying the request. The menu's -@code{gcontext} will thus hold all of the attribute values used -during menu display. - -The first thing to do is make an instance of a @code{menu} object: - -@lisp -(defun create-menu (parent-window text-color background-color text-font) - (make-menu - ;; Create menu graphics context - :gcontext (CREATE-GCONTEXT :drawable parent-window - :foreground text-color - :background background-color - :font text-font) - - ;; Create menu window - :window (CREATE-WINDOW - :parent parent-window - :class :input-output - :x 0 ;temporary value - :y 0 ;temporary value - :width 16 ;temporary value - :height 16 ;temporary value - :border-width 2 - :border text-color - :background background-color - :save-under :on - :override-redirect :on ;override window mgr when positioning - :event-mask (MAKE-EVENT-MASK :leave-window :exposure)))) -@end lisp - -@var{create-window} (@pxref{create-window}) -is one of the most important CLX functions, since it creates and returns -a @var{window} (@pxref{window}) -object. Several of its options are shown here. The default window class -is @var{:input-output}, but X provides for @var{:input-only} windows, -too. Every window must have a parent window, except for a system-defined -@emph{root window}, which represents an entire display screen. The -@var{:event-mask} keyword value, a CLX -@var{event-mask} (@pxref{event-mask}) -data type, says that an input event will be received for the menu window -when the window is exposed and also when the pointer cursor leaves the -window. The window border is a pattern-filled or (as in this case) a -solid-colored boundary which is maintained automatically by the X -server; a client cannot draw in a window's border, since all graphics -requests are relative to the origin (upper-left corner) of the window's -interior and are clipped by the server to this inside region. Turning on -the @var{:save-under} option is a hint to the X server that, when this -window is made visible, it may be more efficient to save the pixels it -obscures, rather than require several client programs to refresh their -windows when the pop-up menu disappears. This is a way to work around -X's client-managed refresh policy when only a small amount of screen -space is needed temporarily. - -Why is @var{:override-redirect} turned on for the menu window? This is -actually a little unusual, because it prevents any window manager client -from @emph{redirecting} the position of the menu when it is popped up. -Remember that the window manager represents the user's policy for -controlling the positions of his windows, so this kind of redirection is -ordinarily correct. However, in this case, as a favor to the user, the -menu avoids redirection in order to pop up the menu at a very specific -location; that is, under the pointer cursor. - -What about the item subwindows? The @code{menu-set-item-list} -function in the following example creates them whenever the menu's item -list is changed. The upper-left x and y coordinates and the width and -height are not important yet, because they are computed just before the -menu is displayed. This function also calls -@var{create-window} (@pxref{create-window}), -demonstrating the equal treatment of parent and children windows in the -X window hierarchy. - -@lisp -(defun menu-set-item-list (menu &rest item-strings) - ;; Assume the new items will change the menu's width and height - (setf (menu-geometry-changed-p menu) t) - - ;; Destroy any existing item windows - (dolist (item (menu-item-alist menu)) - (DESTROY-WINDOW (first item))) - - ;; Add (item-window item-string) elements to item-alist - (setf (menu-item-alist menu) - (let (alist) - (dolist (item item-strings (nreverse alist)) - (push (list (CREATE-WINDOW - :parent (menu-window menu) - :x 0 ;temporary value - :y 0 ;temporary value - :width 16 ;temporary value - :height 16 ;temporary value - :background (GCONTEXT-BACKGROUND (menu-gcontext menu)) - :event-mask (MAKE-EVENT-MASK :enter-window - :leave-window - :button-press - :button-release)) - item) - alist))))) -@end lisp - -@node Displaying the Menu, Menu Input, A Simple Menu, A Quick Tour of CLX -@subsection Displaying the Menu - -The @code{menu-recompute-geometry} function (shown in the -following example) handles the job of calculating the size of the menu, -based on its current item list and its current text font. CLX provides a -way to inquire the geometrical properties of a font object (for example, -its ascent and descent from the baseline) and also a -@var{text-extents} (@pxref{text-extents}) -function. -@var{text-extents} (@pxref{text-extents}) -returns the geometry of a given string as displayed in a given font. -Notice the use of the -@var{with-state} (@pxref{with-state}) -macro when setting a window's geometry attributes. CLX strives to -preserve the familiar @code{setf} style of accessing individual window -attributes, even though an attribute access actually involves sending a -request to a (possibly remote) server and/or waiting for a reply. -@var{with-state} (@pxref{with-state}) -tells CLX to batch together all read and write accesses to a given -window, using a local cache to minimize the number of server requests. -This CLX feature can result in a dramatic improvement in client -performance without burdening the programmer interface. - -@code{menu-recompute-geometry} causes all the item subwindows to -become @emph{mapped}. Mapping a window means attempting to make it -visible on the screen. However, a subwindow will not actually be -@emph{visible} until it and all of its ancestors are mapped. Even then, -another window might be covering up the subwindow. - -@lisp -(defun menu-recompute-geometry (menu) - (when (menu-geometry-changed-p menu) - (let* ((menu-font (GCONTEXT-FONT (menu-gcontext menu))) - (title-width (TEXT-EXTENTS menu-font (menu-title menu))) - (item-height (+ (FONT-ASCENT menu-font) - (FONT-DESCENT menu-font) - *menu-item-margin*)) - (item-width 0) - (items (menu-item-alist menu)) - menu-width) - - ;; Find max item string width - (setf item-width - (+ *menu-item-margin* - (dolist (next-item items item-width) - (setf item-width (max item-width - (TEXT-EXTENTS menu-font (second next-item))))))) - - ;; Compute final menu width, taking margins into account - (setf menu-width (max title-width (+ item-width *menu-item-margin*))) - (let ((window (menu-window menu))) - - ;; Update width and height of menu window - (WITH-STATE (window) - (setf (DRAWABLE-WIDTH window) menu-width - (DRAWABLE-HEIGHT window) (* (1+ (length items)) item-height))) - - ;; Update width, height, position of item windows - (let ((item-left (round (- menu-width item-width) 2)) - (next-item-top (- item-height (round *menu-item-margin* 2)))) - (dolist (next-item items) - (let ((window (first next-item))) - (WITH-STATE (window) - (setf (DRAWABLE-HEIGHT window) item-height - (DRAWABLE-WIDTH window) item-width - (DRAWABLE-X window) item-left - (DRAWABLE-Y window) next-item-top))) - (incf next-item-top item-height)))) - - ;; Map all item windows - (MAP-SUBWINDOWS (menu-window menu)) - - ;; Save item geometry - (setf (menu-item-width menu) item-width - (menu-item-height menu) item-height - (menu-width menu) menu-width - (menu-title-width menu) title-width - (menu-geometry-changed-p menu) nil)))) -@end lisp - -Of course, the sample client must know how to draw/redraw the menu and -its items, so the function @code{menu-refresh} is defined next to -handle that task (shown in the following example). Note that the -location of window output is given relative to the window origin. -Windows and subwindows have different coordinate systems. The location -of the origin (upper-left corner) of a subwindow's coordinate system is -given with respect to its parent window's coordinate system. Negative -coordinates are valid, although only output to the +x/+y quadrant of a -window's coordinate system will ever be visible. - -@lisp -(defun menu-refresh (menu) - (let* ((gcontext (menu-gcontext menu)) - (baseline-y (FONT-ASCENT (GCONTEXT-FONT gcontext)))) - ;; Show title centered in "reverse-video" - (let ((fg (GCONTEXT-BACKGROUND gcontext)) - (bg (GCONTEXT-FOREGROUND gcontext))) - (WITH-GCONTEXT (gcontext :foreground fg :background bg) - (DRAW-IMAGE-GLYPHS - (menu-window menu) - gcontext - (round (- (menu-width menu) - (menu-title-width menu)) 2) ;start x - baseline-y ;start y - (menu-title menu)))) - - ;; Show each menu item (position is relative to item window) - (let ((box-margin (round *menu-item-margin* 2))) - (dolist (item (menu-item-alist menu)) - (DRAW-IMAGE-GLYPHS - (first item) gcontext - box-margin ;start x - (+ baseline-y box-margin) ;start y - (second item)))))) -@end lisp - -@var{with-gcontext} (@pxref{with-gcontext}) -is a CLX macro that allows you temporarily to modify a graphics context -within the dynamic scope of the macro body. -@var{draw-image-glyphs} (@pxref{draw-image-glyphs}) -is a CLX text drawing function which produces a terminal-like rendering: -foreground character on a background block. (More sophisticated text -rendering functions are also available.) The strange use of -@emph{glyphs} instead of @emph{string} here actually highlights an -important fact: X and Common Lisp have totally different concepts of a -character. A Common Lisp character is an object whose implementation can -comprehend a vast universe of text complexities (typefaces, type styles, -international character sets, symbols, and so forth). However, to X, a -string is just a sequence of integer indexes into the array of bitmaps -represented by a CLX font object. In general, -@var{draw-image-glyphs} (@pxref{draw-image-glyphs}), -@var{text-extents} (@pxref{text-extents}), -and other CLX text functions accept a @var{:translate} keyword -argument. Its value is a function which translates the characters of a -string argument into the appropriate font-and-index pairs needed by CLX. -This example relies upon the default translation function, which simply -uses @var{char-code} to compute an index into the current font. - -@node Menu Input, The Main Program, Displaying the Menu, A Quick Tour of CLX -@subsection Menu Input - -Now that a menu can be displayed, the sample client program must define -how the menu will process user input. The @code{menu-choose} -function (shown in the following example) has the classic structure of -an X client program. First, do some initialization (for example, present -the menu at a given location). Then, enter an input event loop. Read an -input event, process it, and repeat the loop until a termination event -is received. The -@var{event-case} (@pxref{event-case}) -macro continues reading an event from the menu window's display object -until one of its clauses returns non-@var{nil}. These clauses specify -the action to be taken for each event type and also bind values from the -event report to local variables, such as the @var{event-window} -receiving the event. Notice that the @var{:force-output-p} option is -enabled, causing -@var{event-case} (@pxref{event-case}) -to begin by sending any client requests which CLX has not yet output to -the server. To improve performance, CLX quietly queues up requests and -periodically sends them off in a batch. However, in an interactive -feedback loop such as this, it is important to keep the display crisply -up-to-date. - -@lisp -(defun menu-choose (menu x y) - ;; Display the menu so that first item is at x,y. - (menu-present menu x y) - - (let ((items (menu-item-alist menu)) - (mw (menu-window menu)) - selected-item) - - ;; Event processing loop - (do () (selected-item) - (EVENT-CASE ((DRAWABLE-DISPLAY mw) :force-output-p t) - (:exposure - (count) - ;; Discard all but final :exposure then display the menu - (when (zerop count) (menu-refresh menu)) - t) - - (:button-release - (event-window) - ;;Select an item - (setf selected-item (second (assoc event-window items))) - t) - - (:enter-notify - (window) - ;;Highlight an item - (menu-highlight-item menu (find window items :key #'first)) - t) - - (:leave-notify - (window kind) - (if (eql mw window) - ;; Quit if pointer moved out of main menu window - (setf selected-item (when (eq kind :ancestor) :none)) - ;; Otherwise, unhighlight the item window left - (menu-unhighlight-item menu (find window items :key #'first))) - t) - - (otherwise - () - ;;Ignore and discard any other event - t))) - - ;; Erase the menu - (UNMAP-WINDOW mw) - - ;; Return selected item string, if any - (unless (eq selected-item :none) selected-item))) -@end lisp - -The event loop in @code{menu-choose} demonstrates an idiom used in -all X programs: the contents of a window are displayed (in this case, by -calling @code{menu-refresh}) only when an -@var{:exposure} (@pxref{:exposure}) -event is received, signaling that the server has actually made the -window @emph{viewable}. The handling of -@var{:exposure} (@pxref{:exposure}) -in @code{menu-choose} also implements a little trick for improving -efficiency. In general, when a window is exposed after being previously -obscured (perhaps only partially), the server is free to send several -@var{:exposure} (@pxref{:exposure}) -events, one for each rectangular tile of the exposed region. For small -windows like this menu, it is not worth the trouble to redraw the image -one tile at a time. So the code above just ignores all but the last tile -exposure and redraws everything in one call to -@code{menu-refresh}. - -@node The Main Program, Debugging With CLX, Menu Input, A Quick Tour of CLX -@subsection The Main Program - -After all the preceding build-up and the other functions referenced -(but not shown here) have been implemented, the code for the main -client program is very small. - -@lisp -(defun just-say-lisp (host &optional (font-name "fg-16")) - (let* ((display (OPEN-DISPLAY host)) - (screen (first (DISPLAY-ROOTS display))) - (fg-color (SCREEN-BLACK-PIXEL screen)) - (bg-color (SCREEN-WHITE-PIXEL screen)) - (nice-font (OPEN-FONT display font-name)) - - ;; Create a menu as a child of the root window. - (a-menu (create-menu (SCREEN-ROOT screen) - fg-color bg-color nice-font))) - - (setf (menu-title a-menu) "Please pick your favorite language:") - (menu-set-item-list a-menu "Fortran" "APL" "Forth" "Lisp") - - ;; Bedevil the user until he picks a nice programming language - (unwind-protect - (loop - ;; Determine the current root window position of the pointer - (multiple-value-bind (x y) (QUERY-POINTER (SCREEN-ROOT screen)) - - (let ((choice (menu-choose a-menu x y))) - (when (string-equal "Lisp" choice) - (return))))) - - (CLOSE-DISPLAY display)))) -@end lisp - -Note that the main program event loop lies in the body of an -@var{unwind-protect} form. This is a good programming technique -because, without this protection, an unexpected error could cause the -program to terminate without freeing the @emph{server resources} it has -created. Server resources are CLX objects which refer to objects -actually stored on the X server. Examples of these are -@var{window} (@pxref{window}), -@var{font} (@pxref{font}), -@var{pixmap} (@pxref{pixmap}), -@var{cursor} (@pxref{cursor}), -@var{colormap} (@pxref{colormap}), -and -@var{gcontext} (@pxref{gcontext}) -objects. These server resources are created and destroyed by user -requests. Server resources created by a client are also destroyed when -its display connection is closed. If client resources are repeatedly -created without being destroyed, then the server will eventually run out -of memory and fail. - -Most server resources are potentially sharable between applications. In -fact, windows are manipulated explicitly by window manager programs. -Fonts and cursors are typically shared automatically since the X server -loads and unloads font storage as needed. -@var{gcontext} (@pxref{gcontext}) -objects are not ordinarily shared between client applications. - -@node Debugging With CLX, , The Main Program, A Quick Tour of CLX -@subsection Debugging With CLX - -Typically, most CLX programs do not need to control the buffering of -output requests directly. However, CLX programmers need to be aware of -the asynchronous nature of client-server communication. It may be -convenient to control the CLX output buffer more directly, especially -during debugging. - -A client that wants a request to execute immediately instead of -asynchronously can follow it with a call to -@var{display-force-output} (@pxref{display-force-output}). -This function @emph{blocks} (does not return) until all previously -buffered output requests have been sent. Otherwise, the output buffer is -always flushed by a call to any function which returns a value from the -server or which waits for input (for example, -@var{get-property} (@pxref{get-property}). -Certain output requests can cause input events to be sent. For example, -@var{map-window} (@pxref{map-window}) -can cause -@var{:exposure} (@pxref{:exposure}) -events to be sent. Synchronizing output with the resulting input can be -done with the -@var{display-finish-output} (@pxref{display-finish-output}) -function. This function blocks until all previously buffered output has -been sent and all resulting input events have been received. - -Functions that return information from the server block until an -explicit reply is received or an error occurs. If a nonblocking call -results in an error, the error is generally not reported until later. -All errors (synchronous and asynchronous) are processed by calling an -error handler defined for the display. If the handler is a sequence it -is expected to contain handler functions specific to each error. The -error code is used to index the sequence, fetching the appropriate -handler. Any results returned by the handler are ignored since it is -assumed that the handler either takes care of the error completely, or -else signals. - -@node Naming and Argument Conventions, Programming Considerations, A Quick Tour of CLX, Introduction to CLX -@section Naming and Argument Conventions - -Throughout CLX, a number of conventions for naming and syntax of the CLX -functions have been followed. These conventions are intended to make the -syntax of the functions more predictable. - -The major naming conventions are as follows: - -@itemize @bullet -@item -To better differentiate the CLX symbols from other symbols, they have -all been placed in the package XLIB. External symbols have been -explicitly exported. - -@item -The @emph{display} argument, where used, is always first in the -argument list. - -@item -All server resource objects, where used, occur at the beginning of the -argument list, immediately after the display variable. - -@item -When a graphics context (@emph{gcontext}) is present together with -another type of server resource (most commonly, a @emph{drawable}), -the graphics context occurs in the argument list after the other -server resource. Drawables out rank all other server resources. - -@item -Source arguments always precede the destination arguments in the -argument list. - -@item -The @emph{x} argument always precedes the @emph{y} argument in the -argument list. - -@item -The @emph{width} argument always precedes the @emph{height} argument -in the argument list. - -@item -Where the @emph{x}, @emph{y}, @emph{width} and @emph{height} arguments -are used together, the @emph{x} and @emph{y} arguments always precede -the @emph{width} and @emph{height} arguments. - -@item -Where a @emph{mask} is accompanied with a @emph{structure}, the mask -always precedes the structure in the argument list. -@end itemize - -@node Programming Considerations, Data Types, Naming and Argument Conventions, Introduction to CLX -@section Programming Considerations - -The major programming considerations are as follows: - -@itemize @bullet -@item -Keyboards are the greatest variable between different manufacturer's -workstations. If you want your program to be portable, you should be -particularly conservative here. - -@item -Many display systems have limited amounts of off-screen memory. If you -can, you should minimize use of pixmaps and backing store. - -@item -The user should have control of his screen real-estate. Therefore, you -should write your applications to react to window management, rather -than presume control of the entire screen. What you do inside of your -top level window, however, is up to your application. - -@item -Coordinates and sizes in X are actually 16-bit quantities. They -usually are declared as an -@var{int16} (@pxref{int16}) in -the functions. Values larger than 16 bits can be truncated silently. -Sizes (width and height) are unsigned quantities. - -@item -The types -@var{color} (@pxref{color}), -@var{colormap} (@pxref{colormap}), -@var{cursor} (@pxref{cursor}), -@var{display} (@pxref{display}), -@var{font} (@pxref{font}), -@var{gcontext} (@pxref{gcontext}), -@var{pixmap} (@pxref{pixmap}), -@var{screen} (@pxref{screen}), -and -@var{window} (@pxref{window}) -are defined solely by a functional interface. Even though they are -treated like structures in this document, it is not specified whether -they are implemented as structures or classes. Although some -interfaces are described as functions, they are not required to be -defined using @var{defun.} (It is a requirement that they be -functions as opposed to macros or special forms.) -@end itemize - -@node Data Types, , Programming Considerations, Introduction to CLX -@section Data Types - - -The following are some data type definitions that are commonly used in -CLX function definitions. - -@deftp {Type} alist (key-type-and-name datum-type-and-name) 'list -@var{alist} defines an association list. An association list is a -sequence, containing zero or more repetitions of the given elements -with each of the elements expressed as (@emph{type} @emph{name}). -@end deftp - - -@deftp {Type} angle `(number ,(* -2pi) ,(* 2pi)) -@var{angle} defines an angle in units of radians and is bounded by -(-2%pi;) and (2%pi;). Note that we are explicitly using a -different angle representation than what is actually transmitted in -the protocol. -@end deftp - - -@deftp {Type} arc-seq '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height) (angle angle1) (angle angle2)) -@var{arc-seq} defines a six-tuple sequence of the form -(@emph{x}, @emph{y}, @emph{width}, @emph{height}, @emph{angle1}, @emph{angle2}). -The points @emph{x} and @emph{y} are signed, 16-bit quantities with a -range from -32,768 to 32,767. The @emph{width} and @emph{height} -values are unsigned, 16-bit quantities and range from 0 to 65,535. -@emph{angle1} and @emph{angle2} are in units of radians, and bounded -by (-2%pi;) and (2%pi;). -@end deftp - - -@deftp {Type} array-index `(integer 0 ,array-dimension-limit) -@var{array-index} defines a type which is a subtype of the integers -and can be used to describe all variables that can be array -indices. The range is inclusive because start and end array index -specifiers can be one (1) past the end. -@end deftp - - -@deftp {Type} bit-gravity '(member gravity*) -A keyword that specifies which region of a window should be retained -when the window is resized. - -@emph{gravity} -- One of the following: -@itemize @c menu - -@item @var{:center} -@item @var{:north} -@item @var{:south} -@item @var{:static} - -@item @var{:east} -@item @var{:north-east} -@item @var{:south-east :west} - -@item @var{:forget} -@item @var{:north-west} -@item @var{:south-west} -@end itemize - -If a window is reconfigured without changing its inside width or -height, then the contents of the window moves with the window and are -not lost. Otherwise, the contents of a resized window are either moved -or lost, depending on its bit-gravity attribute. See -@var{window-bit-gravity}, in @ref{Window Attributes}, for additional -information. - -@end deftp - - - -@deftp {Type} bitmap '(array bit (* *)) -Specifies a two-dimensional array of bits. -@end deftp - - -@deftp {Structure} bitmap-format - -A structure that describes the storage format of a bitmap. - -The @var{bitmap-format} structure contains slots for @var{unit}, -@var{pad}, and @var{lsb-first-p}. The @var{unit} member indicates -the unit of increments used to maintain the bitmap data. The units -available for use are 8, 16, or 32 bits. The @var{pad} member -indicates how many bits are needed to pad the left edge of the -scan-line. The @var{lsb-first-p} member is a predicate which -indicates the ordering of bits with the bitmap unit. - -@end deftp - - -@deftp {Slot of bitmap-format} unit - -Type: (@var{member} 8 16 32). - -The size of a contiguous grouping of bits, which can be 8, 16, or -32. The default is 8. - -@end deftp - - - -@deftp {Slot of bitmap-format} pad - -Type: (@var{member} 8 16 32). - -The number of bits to left-pad the scan-line, which can be 8, 16, or -32. The default is 8. -@end deftp - - -@deftp {Slot of bitmap-format} lsb-first-p - -Type: @var{boolean}. - -A predicate indicating whether the least significant bit comes first -(@var{true}) or not (@var{nil}). -@end deftp - - -@deftp {Type} boolean '(or nil (not nil)) -@var{boolean} defines a type which is all inclusive. It is used for -variables that can take on a true (non-@var{nil}) or false -(@var{nil}) value. -@end deftp - -@deftp {Type} boole-constant `(member value*) - -@var{boole-constant} defines a type that is a set of the values -associated with the 16 boolean operation-code constants for the Common -Lisp language. It is used for the set of allowed source and -destination combination functions in a graphics context. - -@emph{value} -- One of the following: -@itemize @c menu - -@item @var{boole-1} -@item @var{boole-c1} -@item @var{boole-nand} -@item @var{boole-xor} - -@item @var{boole-2} -@item @var{boole-c2} -@item @var{boole-nor} - -@item @var{boole-and} -@item @var{boole-clr} -@item @var{boole-orc1} - -@item @var{boole-andc1} -@item @var{boole-eqv} -@item @var{boole-orc2} - -@item @var{boole-andc2} -@item @var{boole-ior} -@item @var{boole-set} -@end itemize -@end deftp - - -@deftp {Type} card8 '(unsigned-byte 8) -An unsigned integer value that is a maximum of eight bits long. This -gives a number of this type a range from 0 to 255. -@end deftp - - -@deftp {Type} card16 '(unsigned-byte 16) -An unsigned integer value that is a maximum of 16 bits long. This -gives a number of this type a range from 0 to 65,535. -@end deftp - - -@deftp {Type} card29 '(unsigned-byte 29) -An unsigned integer value that is a maximum of 29 bits long. This -gives a number of this type a range from 0 to 536,870,911. -@end deftp - - -@deftp {Type} card32 '(unsigned-byte 32) -An unsigned integer value that is a maximum of 32 bits long. This -gives a number of this type a range from 0 to 4,294,967,295. -@end deftp - - -@deftp {Type} color '(satisfies color-p) -@anchor{color} -A @var{color}. @xref{Color Functions}, for additional -information. -@end deftp - - -@deftp {Type} colormap '(satisfies colormap-p) -@anchor{colormap} -A @var{colormap}. @xref{Colormap Functions}, for -additional information. -@end deftp - - -@deftp {Type} cursor '(satisfies cursor-p) -@anchor{cursor} -A @var{cursor}. @xref{Cursors}, for additional information. -@end deftp - - -@deftp {Type} device-event-mask '(or mask32 (list device-event-mask-class)) -@anchor{event-mask} - -Provides a way to specify a set of bits for an event bitmask. Two ways -of specifying the bits are allowed: by setting the event bits in a 32 -bit mask, or by listing the keyword names of the device related event -bits in a list. -@end deftp - - -@deftp {Type} device-event-mask-class '(member event*) -A keyword name, for a device related event, that corresponds to a -particular bit in an event bitmask. The set of names is a subset of -the names in the type @var{event-mask-class}. - -@emph{event} -- One of the following: -@itemize @c menu - -@item @var{:button-1-motion} -@item @var{:button-motion} - -@item @var{:button-2-motion} -@item @var{:button-press} - -@item @var{:button-3-motion} -@item @var{:key-press} - -@item @var{:button-4-motion} -@item @var{:key-release} - -@item @var{:button-5-motion} -@item @var{:pointer-motion} -@end itemize -@end deftp - - -@deftp {Type} display '(satisfies display-p) -@anchor{display} -A connection to an X server. @xref{Displays}, for additional -information. -@end deftp - - -@deftp {Type} drawable '(or window pixmap) -Both @var{windows} and @var{pixmaps} can be used as sources and -destinations in graphics operations. @var{windows} and @var{pixmaps} -together are known as @emph{drawables}. However, an @var{:input-only} -window cannot be used as a source or destination in a graphics -operation. -@end deftp - - -@deftp {Type} draw-direction '(member :left-to-right :right-to-left) -Defines a list of rotation directions for drawing arcs and -fonts. @var{draw-direction} can have the values of -@var{:left-to-right} or @var{:right-to-left}. -@end deftp - - -@deftp {Type} error-key '(member error*) -Defines a list of all predefined errors. All errors (synchronous and -asynchronous) are processed by calling an error handler in the -display. The handler is called with the display as the first argument -and the error-key as its second argument. - -@emph{error} -- One of the following: -@itemize @c menu - -@item @var{:access} -@item @var{:drawable} -@item @var{:implementation} -@item @var{:value} - -@item @var{:alloc} -@item @var{:font} -@item @var{:length} -@item @var{:window} - -@item @var{:atom} -@item @var{:gcontext} -@item @var{:match} - -@item @var{:colormap} -@item @var{:id-choice} -@item @var{:name} - -@item @var{:cursor} -@item @var{:illegal-request} -@item @var{:pixmap} -@end itemize -@end deftp - -@deftp {Type} event-key '(member event-type*) -Defines a list that specifies all predefined event-types. Clients are -informed of information asynchronously by means of events. These -events can be either asynchronously generated from devices or -generated as side effects of client requests. - -@emph{event-type} -- One of the following: -@itemize @c menu - -@item @var{:button-press} -@item @var{:exposure} -@item @var{:motion-notify} - -@item @var{:button-release} -@item @var{:focus-in} -@item @var{:no-exposure} - -@item @var{:circulate-notify} -@item @var{:focus-out} -@item @var{:property-notify} - -@item @var{:circulate-request} -@item @var{:graphics-exposure} -@item @var{:reparent-notify} - -@item @var{:client-message} -@item @var{:gravity-notify} -@item @var{:resize-request} - -@item @var{:colormap-notify} -@item @var{:keymap-notify} -@item @var{:selection-clear} - -@item @var{:configure-notify} -@item @var{:key-press} -@item @var{:selection-notify} - -@item @var{:configure-request} -@item @var{:key-release} -@item @var{:selection-request} - -@item @var{:create-notify} -@item @var{:leave-notify} -@item @var{:unmap-notify} - -@item @var{:destroy-notify} -@item @var{:map-notify} -@item @var{:visibility-notify} - -@item @var{:enter-notify} -@item @var{:map-request} -@end itemize -@end deftp - -@deftp {Type} event-mask '(or mask32 (list event-mask-class)) -Provides a way to specify a set of bits for an event bitmask. Two ways -of specifying the bits are allowed: by setting the event bits in a 32 -bit mask, or by listing the keyword names of the event bits in a list. -@end deftp - - -@deftp {Type} event-mask-class '(member event*) -The elements of the type @var{event-mask-class} are keyword names -that correspond to a particular bit in an event bitmask. - -@emph{event} -- One of the following: -@itemize @c menu - -@item @var{:button-1-motion} -@item @var{:enter-window} -@item @var{:pointer-motion-hint} - -@item @var{:button-2-motion} -@item @var{:exposure} -@item @var{:property-change} - -@item @var{:button-3-motion} -@item @var{:focus-change} -@item @var{:resize-redirect} - -@item @var{:button-4-motion} -@item @var{:key-press} -@item @var{:structure-notify} - -@item @var{:button-5-motion} -@item @var{:key-release} -@item @var{:substructure-notify} - -@item @var{:button-motion} -@item @var{:keymap-state} -@item @var{:substructure-redirect} - -@item @var{:button-press} -@item @var{:leave-window} -@item @var{:visibility-change} - -@item @var{:button-release} -@item @var{:owner-grab-button} - -@item @var{:colormap-change} -@item @var{:pointer-motion} -@end itemize -@end deftp - - -@defun make-event-keys event-mask -Returns a list of @var{event-mask-class} keyword names for the event -bits that are set in the specified event mask. - -@table @var -@item event-mask -An event mask (type @var{mask32}). -@end table - -@end defun - - -@defun make-event-mask &rest keys - -@table @var -@item keys -@var{event-mask-class} keywords. -@end table - -Constructs an event mask from a set of @var{event-mask-class} keyword -names. - -@table @var -@item event-mask -Type @var{mask32}. -@end table - -@end defun - - -@deftp {Type} font '(satisfies font-p) -@anchor{font} - -A text font. @xref{Font and Characters}, for additional -information. - -@end deftp - - -@deftp {Type} fontable '(or stringable font) - -A @var{fontable} is either a @var{font} object or the name of one of -the fonts in the font database. - -@end deftp - - -@deftp {Type} font-props 'list - -A @var{list} that contains alternating keywords and integers. - -@end deftp - - -@deftp {Type} gcontext '(satisfies gcontext-p) -@anchor{gcontext} - -A graphics context. @xref{Graphics Contexts}, for additional -information. - -@end deftp - - -@deftp {Type} gcontext-key '(member type*) - -A list of predefined types for use in @var{gcontext} -processing. Various information for graphics output is stored in a -graphics context (GC or GContext), such as foreground pixel, -background pixel, line width, clipping region, and so forth. - -@var{type} -- One of the following: -@itemize @c menu - -@item @var{:arc-mode} -@item @var{:exposures} -@item @var{:line-width} - -@item @var{:background} -@item @var{:fill-rule} -@item @var{:plane-mask} - -@item @var{:cap-style :fill-style} -@item @var{:stipple} - -@item @var{:clip-mask} -@item @var{:font} -@item @var{:subwindow-mode} - -@item @var{:clip-x} -@item @var{:foreground} -@item @var{:tile} - -@item @var{:clip-y} -@item @var{:function} -@item @var{:ts-x} - -@item @var{:dash-offset} -@item @var{:join-style} -@item @var{:ts-y} - -@item @var{:dashes} -@item @var{:line-style} -@end itemize -@end deftp - -@deftp {Type} grab-status '(member grab-type*) - -There are two kinds of grabs: active and passive. An @emph{active -grab} occurs when a single client grabs the keyboard and/or pointer -explicitly. Clients can also grab a particular keyboard key or pointer -button in a window. The grab activates when the key or button is -actually pressed, and is called a @emph{passive grab}. Passive grabs -can be very convenient for implementing reliable pop-up menus. - -@var{grab-type} -- One of the following: - -@itemize @c menu - -@item @var{:already-grabbed} - -@item @var{:frozen} - -@item @var{:invalid-time} - -@item @var{:not-viewable} - -@item @var{:success} -@end itemize -@end deftp - - -@deftp {Type} image-depth '(integer 0 32) -Used in determining the depth of a pixmap, window, or image. The value -specifies the number of bits deep that a given pixel has within a -given pixmap, window, or image. -@end deftp - - -@deftp {Type} index-size '(member :default 8 16) -Used to control the element size of the destination buffer given to -the translate function when drawing glyphs. If @var{:default} is -specified, the size is based on the current font, if known; otherwise, -16 is used. -@end deftp - - -@deftp {Type} int8 '(signed-byte 8) -A signed integer value that is a maximum of eight bits long. A number -of this type can have a range from -128 to 127. -@end deftp - - -@deftp {Type} int16 '(signed-byte 16) -@anchor{int16} -A signed integer value that is a maximum of 16 bits long. A number of -this type can have a range from -32,768 to 32,767. -@end deftp - - -@deftp {Type} int32 '(signed-byte 32) -A signed integer value that is a maximum of 32 bits long. A number of -this type can have a range from -2,147,483,648 to 2,147,483,647. -@end deftp - - -@deftp {Type} keysym 'card32 -Used as an encoding of a symbol on a keycap on a keyboard. It is an -unsigned integer value represented in a maximum of 32 bits long. A -@var{keysym} type can have a range from 0 to 4,294,967,295. -@end deftp - - -@deftp {Type} mask16 ' card16 -A positional bitmask that contains 16 boolean flags. -@end deftp - - -@deftp {Type} mask32 ' card32 -A positional bitmask that contains 32 boolean flags. -@end deftp - - -@deftp {Type} modifier-key '(member modifier*) -A keyword identifying one of the modifier keys on the keyboard device. - -@var{modifier} -- One of the following: -@itemize @c menu - -@item @var{:shift} -@item @var{:mod-2} - -@item @var{:lock} -@item @var{:mod-3} - -@item @var{:control} -@item @var{:mod-4} - -@item @var{:mod-1} -@item @var{:mod-5} -@end itemize -@end deftp - - -@deftp {Type} modifier-mask '(or (member :any) mask16 (list modifier-key)) -A bitmask or list of keywords that specifies a set of modifier -keys. The keyword @var{:any} is equivalent to any subset of modifier -key. -@end deftp - - -@deftp {Type} pixarray '(or (array pixel (* *)) (array card16 (* *)) (array card8 (* *)) (array (unsigned-byte 4) (* *)) (array bit (* *))) - -Specifies a two-dimensional array of pixels. - -@end deftp - - - -@deftp {Type} pixel '(unsigned-byte 32) - -An unsigned integer value that is a maximum of 32 bits long. This -gives a pixel type a value range from 0 to 4,294,967,295. Useful -values are dependent on the class of colormap being used. - -@end deftp - - -@deftp {Type} pixmap '(satisfies pixmap-p) -@anchor{pixmap} - -A @var{pixmap}, @pxref{Pixmaps}), for additional information. - -@end deftp - - -@deftp {Structure} pixmap-format - -A structure that describes the storage format of a pixmap. - -The @var{pixmap-format} structure contains slots for @var{depth}, -@var{bits-per-pixel}, and @var{scanline-pad}. The @var{depth} member -indicates the number of bit planes in the pixmap. The -@var{bits-per-pixel} member indicates the number of bits used to -represent a single pixel. For X, a pixel can be 1, 4, 8, 16, 24, or 32 -bits wide. As for @var{bitmap-format}, the @var{scanline-pad} member -indicates how many pixels are needed to pad the left edge of the -scan-line. -@end deftp - -@deftp {Slot of pixmap-format} depth - -Type: @var{image-depth}. - -The number of bit planes in the pixmap. -@end deftp - - -@deftp {Slot of pixmap-format} bits-per-pixel - - -Type: (@var{member} 1 4 8 16 24 32). - -The number of consecutive bits used to encode a single pixel. The -default is 8. -@end deftp - - -@deftp {Slot of pixmap-format} scanline-pad - -Type: (@var{member} 8 16 32). - -The number of bits to left-pad the scan-line, which can be 8, 16, or -32. The default is 8. -@end deftp - -@deftp {Type} point-seq '(repeat-seq (int16 x) (int16 y)) - -The @var{point-seq} type is used to define sequences of -(@var{x},@var{y}) pairs of points. The paired values are 16-bit, -signed integer quantities. This gives the points in this type a range -from -32,768 to 32,767. -@end deftp - -@deftp {Type} pointer-event-mask '(or mask32 (list pointer-event-mask-class)) - -Provides a way to specify a set of bits for an event bitmask. Two ways -of specifying the bits are allowed: by setting the event bits in a 32 -bit mask, or by listing the keyword names of the pointer related event -bits in a list. - -@end deftp - - -@deftp {Type} pointer-event-mask-class '(member event*) - -A keyword name, for a pointer related event, that corresponds to a -particular bit in an event bitmask. The set of names is a subset of -the names in the type @var{event-mask-class}. - -@var{event} -- One of the following: - -@itemize @c menu - -@item @var{:button-1-motion} -@item @var{:button-motion} -@item @var{:leave-window} - -@item @var{:button-2-motion} -@item @var{:button-press} -@item @var{:pointer-motion} - -@item @var{:button-3-motion} -@item @var{:button-release} -@item @var{:pointer-motion-hint} - -@item @var{:button-4-motion} -@item @var{:enter-window} - -@item @var{:button-5-motion} -@item @var{:keymap-state} -@end itemize -@end deftp - -@deftp {Type} rect-seq '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height)) - -@var{rect-seq} defines a four-tuple sequence of the form (@var{x}, -@var{y}, @var{width}, @var{height}). The points @var{x} and -@var{y} are signed, 16-bit quantities with a range from -32,768 to -32,767. The @var{width} and @var{height} values are unsigned, 16-bit -quantities and range from 0 to 65,535. - -@end deftp - - -@deftp {Type} repeat-seq (&rest elts) 'sequence - -A subtype used to define repeating sequences. - -@end deftp - - -@deftp {Type} resource-id 'card29 - -A numeric identifier that is assigned by the server to a server -resource object. - -@end deftp - - -@deftp {Type} rgb-val '(float 0.0 1.0) - -An @var{rgb-val} is a floating-point value between 0 and 1 that -specifies a saturation for a red, green, or blue additive primary. The -0 value indicates no saturation and 1 indicates full saturation. - -@end deftp - -@deftp {Type} screen '(satisfies screen-p) -@anchor{screen} - -A display screen. @xref{Screens}, for further information. - -@end deftp - - -@deftp {Type} seg-seq '(repeat-seq (int16 x1) (int16 y1) (int16 x2) (int16 y2)) - -Defines sequences of (@var{x1}, @var{y1}, @var{x2}, @var{y2}) sets -of points. The point values are 16-bit, signed integer -quantities. This gives the points in this type a range from -32,768 to -32,767. - -@end deftp - - -@deftp {Type} state-mask-key '(or modifier-key (member button*)) - -A keyword identifying one of the display modifier keys or pointer -buttons whose state is reported in device events. - -@var{button} -- One of the following: - -@itemize @c menu -@item @var{:button-1} -@item @var{:button-4} -@item @var{:button-2} -@item @var{:button-5} -@item @var{:button-3} -@end itemize - -@end deftp - -@defun make-state-keys state-mask - -@table @var -@item state-mask -A 16-bit mask of type @var{mask16}. - -@end table - -Returns a list of @var{state-mask-key} symbols corresponding to the -@var{state-mask}. A symbol belongs to the returned list if, and only -if, the corresponding @var{state-mask} bit is 1. - -@table @var -@item state-keywords -Type @var{list}. -@end table - -@end defun - - -@defun make-state-mask &rest keys - -@table @var -@item keys -A list of @var{state-mask-key} symbols. -@end table - -Returns a 16-bit @var{mask} representing the given -@var{state-mask-key} symbols. The returned @var{mask} contains a 1 -bit for each keyword. - -@table @var -@item mask -Type @var{mask16}. -@end table -@end defun - -@deftp {Type} stringable '(or string symbol) - -Used for naming something. This type can be either a string or a -@var{symbol} whose @var{symbol-name} is used as the string containing -the name. The case of the characters in the string is ignored when -comparing stringables. - -@end deftp - - -@deftp {Type} timestamp '(or null card32) - -An encoding of a time. @var{nil} stands for the current time. - -@end deftp - - -@deftp {Structure} visual-info - -A structure that represents a visual type. The elements of this -structure are @var{id}, @var{class}, @var{red-mask}, @var{green-mask}, -@var{blue-mask}, @var{bits-per-rgb}, and @var{colormap-entries}. - -@end deftp - - -@deftp {Slot of visual-info} id - -Type: @var{card29}. - -A unique identification number. - -@end deftp - - -@deftp {Slot of visual-info} class - -Type: (member :direct-color :gray-scale :pseudo-color :static-color :static-gray :true-color). - -The class of the visual type. - -@end deftp - - -@deftp {Slots of visual-info} red-mask -@deftpx {Slots of visual-info} green-mask -@deftpx {Slots of visual-info} blue-mask - -Type: @var{pixel}. - -The @var{red-mask}, @var{green-mask}, and @var{blue-mask} elements are -only meaningful for the @var{:direct-color} and @var{:true-color} -classes. Each mask has one contiguous set of bits with no -intersections. - -@end deftp - -@deftp {Slot of visual-info} bits-per-rgb - -Type: @var{card8}. - -Specifies the log base 2 of the approximate number of distinct color -values ( individually) of red, green, and blue. Actual RGB values are -unsigned 16-bit numbers. - -@end deftp - - -@deftp {Slot of visual-info} colormap-entries - -Type: @var{card16}. - -Defines the number of available colormap entries in a newly created -colormap. For @var{:direct-color} and @var{:true-color}, this is the -size of an individual pixel subfield. - -@end deftp - - -@deftp {Type} win-gravity '(member gravity*) - -A keyword that specifies how to reposition a window when its parent is -resized. - -@var{gravity} -- One of the following: -@itemize @c menu - -@item @var{:center} -@item @var{:north-west} -@item @var{:static} - -@item @var{:east} -@item @var{:south} -@item @var{:unmap} - -@item @var{:north} -@item @var{:south-east} -@item @var{:west} - -@item @var{:north-east} -@item @var{:south-west} -@end itemize - -If a parent window is reconfigured without changing its inside width -or height, then all child windows move with the parent and are not -changed. Otherwise, each child of the resized parent is moved, -depending on the child's gravity attribute. See @var{window-gravity} -(@pxref{Window Attributes})), for additional information. - -@end deftp - - -@deftp {Type} window '(satisfies window-p) -@anchor{window} - -A window. @xref{Windows and Pixmaps}, for additional -information. - -@end deftp - - -@deftp {Type} xatom '(or string symbol) - -A name that has been assigned a corresponding unique ID by the -server. @var{xatoms} are used to identify properties, selections, and -types defined in the X server. An @var{xatom} can be either a -@var{string} or @var{symbol} whose @var{symbol-name} is used as the -@var{xatom} name. The case of the characters in the string are -significant when comparing @var{xatoms}. - -@end deftp - -@node Displays, Screens, Introduction to CLX, Top -@chapter Displays - -A particular X server, together with its screens and input devices, is -called a @emph{display}. The CLX @var{display} object contains all the -information about the particular display and its screens, as well as the -state that is needed to communicate with the display over a particular -connection. - -Before your program can use a display, you must establish a connection to -the X server driving your display. Once you have established a connection, -you then can use the CLX macros and functions discussed in this section to -return information about the display. This section discusses how to: - -@itemize @bullet -@item Open (connect) a display -@item Obtain information about a display -@item Access and change display attributes -@item Close (disconnect) a display -@end itemize - -@menu -* Opening the Display:: -* Display Attributes:: -* Managing the Output Buffer:: -* Closing the Display:: -@end menu - -@node Opening the Display, Display Attributes, Displays, Displays -@section Opening the Display - - -The @var{open-display} and @var{open-default-display} functions are -used to open a connection to an X server. @var{open-default-display} -is an extension that is not present in the MIT CLX tree, but is -preferred where available as it uses the same rules for display -defaulting as the C Xlib bindings, and tends to get authorization -right more often than @var{open-display} (particularly on -ssh-forwarded connections) - -@defun open-display host &key :display :protocol - -@table @var -@item host -Specifies the name of the @emph{host} machine on which the server -executes. A string must be acceptable as a @emph{host}, but otherwise -the possible types are not constrained and will likely be very system -dependent. - -@item :display -An integer that specifies which display device on the @emph{host} -should be used for this connection. This is needed since multiple -displays can be controlled by a single X server. The default is -display 0 (zero). - -@item :protocol -A keyword argument that specifies which network protocol should be -used for connecting to the server (for example, @var{:tcp}, -@var{:dna}, or @var{:chaos}). The set of possible values and the -default value are implementation specific. - -@end table - -Returns a @var{display} that serves as the connection to the X -server and contains all the information about that X server. - -Authorization, if any, is assumed to come from the -environment. After a successful call to @var{open-display}, all -screens on the display can be used by the client application. - -@table @var -@item display -Type @var{display}. -@end table - -@end defun - -@defun open-default-display &optional display-name - -@table @var -@item display-name -The display to connect to. Display names have the format - -@verbatim - [protocol/] [hostname] : [:] displaynumber [.screennumber] -@end verbatim - -There are two special cases in parsing, to match that done in the Xlib -C language bindings - -@itemize @bullet -@item If the hostname is @code{unix} or the empty string, any supplied -protocol is ignored and a connection is made using the @code{local} transport. -@item If a double colon separates @var{hostname} from @var{displaynumber}, the -protocol is assumed to be @code{decnet}. -@end itemize - -If @var{display-name} is not supplied, a default will be provided -appropriate for the local environment: on a POSIX system - the only -kind this CLX port runs on - the default display is taken from the -environment variable @env{DISPLAY}. See also the section ``DISPLAY -NAMES'' in X(7) - -@end table - -Open a connection to @var{display-name} or to the appropriate -default display. - -@code{open-display-name} always attempts to do display authorization, -following complicated rules that closely match the ones that the C -Xlib bindings use. Briefly: the hostname is resolved to an address, -then authorization data for the (protocol, host-address, -displaynumber) triple is looked up in the file given by the -environment variable @env{AUTHORITY_PATHNAME} (typically -@file{$HOME/.Xauthority}). If the protocol is @code{:local}, or if -the hostname resolves to the local host, authority data for the local -machine's actual hostname - as returned by gethostname(3) - is used -instead. - -@end defun - -@node Display Attributes, Managing the Output Buffer, Opening the Display, Displays -@section Display Attributes - -The complete set of display attributes is discussed in the following -paragraphs. - -@defun display-authorization-data display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the authorization data string for @var{display} that was -transmitted to the server by @var{open-display} during connection -setup. The data is specific to the particular authorization protocol -that was used. The @var{display-authorization-name} function returns -the protocol used. - -@table @var -@item authorization-data -Type @var{string}. -@end table - -@end defun - -@defun display-authorization-name display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the authorization protocol namestring for @var{display} that -was transmitted by @var{open-display} to the server during connection -setup. The @var{authorization-name} indicates what authorization -protocol the client expects the server to use. Specification of valid -authorization mechanisms is not part of the X protocol. A server that -implements a different protocol than the client expects, or a server -that only implements the host-based mechanism, can simply ignore this -information. If both name and data strings are empty, this is to be -interpreted as "no explicit authorization." - -@table @var -@item authorization-name -Type @var{string}. -@end table - -@end defun - -@defun display-bitmap-format display -@anchor{display-bitmap-format} - -@table @var -@item display -A @var{display} object. -@end table - -Returns the @emph{bitmap-format} information for the specified @emph{display}. - -@table @var -@item bitmap-format -Type @var{bitmap-format}. -@end table - -@end defun - -@defun display-byte-order display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the @var{byte-order} to be employed in communication with the -server for the given @var{display}. The possible values are as -follows: - -@table @var -@item :lsbfirst -Values are transmitted least significant byte first. -@item :msbfirst -Values are transmitted most significant byte first. -@end table - -Except where explicitly noted in the protocol, all 16-bit and 32-bit -quantities sent by the client must be transmitted with this -@var{byte-order}, and all 16-bit and 32-bit quantities returned by the -server are transmitted with this @var{byte-order}. - -@table @var -@item byte-order -Either @var{:lsbfirst} or @var{:msbfirst}. -@end table - -@end defun - -@defun display-display display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the @var{display-number} for the host associated with -@var{display}. - -@table @var -@item display-number -Type @var{integer}. -@end table - -@end defun - -@defun display-error-handler display - -@table @var -@item display -A @var{display} object. -@end table - -Returns and (with @code{setf}) sets the @var{error-handler} function -for the given @var{display}. CLX calls (one of) the display error -handler functions to handle server errors returned to the -connection. The default error handler, @var{default-error-handler}, -signals conditions as they occur. @xref{Errors}, for a list of -the conditions that CLX can signal. For more information about errors -and error handling, refer to the section entitled Common Lisp -Condition System in the @emph{Lisp Reference} manual. - -If the value of @var{error-handler} is a sequence, it is expected to -contain a handler function for each specific error. The error code is -used as an index into the sequence to fetch the appropriate handler -function. If this element is a function, it is called for all -errors. Any results returned by the handler are ignored since it is -assumed the handler either takes care of the error completely or else -signals. The arguments passed to the handler function are the -@var{display} object, a symbol naming the type of error, and a set of -keyword-value argument pairs that vary depending on the type of -error. For all core errors, the keyword-value argument pairs are: - -@multitable @columnfractions 0.5 0.5 -@item @var{:current-sequence} @tab @var{card16} -@item @var{:major} @tab @var{card8} -@item @var{:minor} @tab @var{card16} -@item @var{:sequence} @tab @var{card16} -@end multitable - -For @var{colormap}, @var{cursor}, @var{drawable}, @var{font}, -@var{gcontext}, @var{id-choice}, @var{pixmap}, and @var{window} -errors, the keyword-value pairs are the core error pairs plus: - -@multitable @columnfractions 0.5 0.5 -@item @var{:resource-id} @tab @var{card32} -@end multitable - -For @var{:atom} errors, the keyword-value pairs are the core error -pairs plus: - -@multitable @columnfractions 0.5 0.5 -@item @var{:atom-id} @tab @var{card32} -@end multitable - -For @var{:value} errors, the keyword-value pairs are the core error -pairs plus: - -@multitable @columnfractions 0.5 0.5 -@item @var{:value} @tab @var{card32} -@end multitable - -@table @var -@item error-handler -Type @var{function} or @var{sequence}. -@end table - -@end defun - -@defun display-image-lsb-first-p display - -@table @var -@item display -A @var{display} object. -@end table - -Although the server is generally responsible for byte swapping -communication data to match the client, images (pixmaps/bitmaps) are -always transmitted and received in formats (including byte order) -specified by the server. Within images for each scan-line unit in -bitmaps or for each pixel value in pixmaps, the leftmost bit in the -image as displayed on the screen is either the least or most -significant bit in the unit. For the given @var{display}, -@var{display-image-lsb-first-p} returns non-@var{nil} if the leftmost -bit is the least significant bit; otherwise, it returns @var{nil}. - -@table @var -@item image-lsb-first-p -Type @var{boolean}. -@end table - -@end defun - - -@defun display-keycode-range display - -@table @var -@item display -A @var{display} object. -@end table - -Returns @var{min-keycode} and @var{max-keycode} as multiple -values. See the @var{display-max-keycode} and -@var{display-min-keycode} functions for additional information. - -@table @var -@item min-keycode -@itemx max-keycode -Type @var{card8}. -@end table - -@end defun - - -@defun display-max-keycode display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the maximum keycode value for the specified -@emph{display}. This value is never greater than 255. Not all keycodes -in the allowed range are required to have corresponding keys. - -@table @var -@item max-keycode -Type @var{card8}. -@end table - -@end defun - - -@defun display-max-request-length display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the maximum length of a request, in four-byte units, that is -accepted by the specified @emph{display}. Requests larger than this -generate a length error, and the server will read and simply discard -the entire request. This length is always at least 4096 (that is, -requests of length up to and including 16384 bytes are accepted by all -servers). - -@table @var -@item max-request-length -Type @var{card16}. -@end table - -@end defun - - -@defun display-min-keycode display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the minimum keycode value for the specified -@var{display}. This value is never less than eight. Not all keycodes -in the allowed range are required to have corresponding keys. - -@table @var -@item min-keycode -Type @var{card8}. -@end table - -@end defun - - -@defun display-motion-buffer-size display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the approximate size of the motion buffer for the specified -@var{display}. The server can retain the recent history of pointer -motion at a finer granularity than is reported by @var{:motion-notify} -events. Such history is available through the @var{motion-events} -function. - -@table @var -@item motion-buffer-size -Type @var{card32}. -@end table - -@end defun - - -@defun display-p display - -@table @var -@item display-p -Type @var{boolean}. -@end table - -Returns non-@var{nil} if @emph{display} is a @var{display} object; -@end defun - -@defun display-pixmap-formats display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the list of @var{pixmap-format} values for the given -@emph{display}. This list contains one entry for each depth value. The -entry describes the format used to represent images of that depth. An -entry for a depth is included if any screen supports that depth, and -all screens supporting that depth must support (only) the format for -that depth. - -@table @var -@item pixmap-formats -Type @var{list}. -@end table - -@end defun - - -@defun display-plist display - -@table @var -@item display -A @var{display} object. -@end table - -Returns and (with @code{setf}) sets the property list for the specified -@emph{display}. This function provides a hook where extensions can add -data. -@table @var -@item plist -Type @var{list}. -@end table - -@end defun - - -@defun display-protocol-major-version display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the major version number of the X protocol associated with the -specified @emph{display}. In general, the major version would -increment for incompatible changes. The returned protocol version -number indicates the protocol the server actually supports. This might -not equal the version supported by the client. The server can (but -need not) refuse connections from clients that offer a different -version than the server supports. A server can (but need not) support -more than one version simultaneously. -@table @var -@item protocol-major-version -Type @var{card16}. -@end table - -@end defun - - -@defun display-protocol-minor-version display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the minor protocol revision number associated with the -specified @emph{display}. In general, the minor version would -increment for small upward compatible changes in the X protocol. -@table @var -@item protocol-minor-version -Type @var{card16}. -@end table - -@end defun - - -@defun display-protocol-version display - -@table @var -@item display -A @var{display} object. -@end table - -Returns @emph{protocol-major-version} and -@emph{protocol-minor-version} as multiple values. See the -@var{display-protocol-major-version} and -@var{display-protocol-minor-version} functions for additional -information. - -@table @var -@item protocol-major-version -@itemx protocol-minor-version -@end table - -@end defun - - -@defun display-resource-id-base display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the @emph{resource-id-base} value that was returned from the -server during connection setup for the specified @emph{display}. This -is used in combination with the @emph{resource-id-mask} to construct -valid IDs for this connection. -@table @var -@item resource-id-base -Type @var{resource-id}. -@end table - -@end defun - - -@defun display-resource-id-mask display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the @emph{resource-id-mask} that was returned from the server -during connection setup for the specified @emph{display}. The -@emph{resource-id-mask} contains a single contiguous set of bits (at -least 18) which the client uses to allocate resource IDs for types -@var{window}, @var{pixmap}, @var{cursor}, @var{font}, @var{gcontext}, -and @var{colormap} by choosing a value with (only) some subset of -these bits set, and @var{or}ing it with the -@emph{resource-id-base}. Only values constructed in this way can be -used to name newly created server resources over this -connection. Server resource IDs never have the top three bits set. The -client is not restricted to linear or contiguous allocation of server -resource IDs. Once an ID has been freed, it can be reused, but this -should not be necessary. - - -An ID must be unique with respect to the IDs of all other server -resources, not just other server resources of the same type. However, -note that the value spaces of server resource identifiers, atoms, -visualids, and keysyms are distinguished by context, and as such are -not required to be disjoint (for example, a given numeric value might -be both a valid window ID, a valid atom, and a valid keysym.) -@table @var -@item resource-id-mask -Type @var{resource-id}. -@end table - -@end defun - - -@defun display-roots display - -@table @var -@item display -A @var{display} object. -@end table - -Returns a list of all the @var{screen} structures available for the -given @emph{display}. -@table @var -@item roots -A list of screens. -@end table - -@end defun - - -@defun display-vendor display - -@table @var -@item display -A @var{display} object. -@end table -Returns @emph{vendor-name} and @emph{release-number} as -multiple values. See the @var{display-vendor-name} and -@var{display-release-number} functions for additional information. -@table @var -@item vendor-name -@itemx release-number -@end table - -@end defun - - -@defun display-vendor-name display - -@table @var -@item display -A @var{display} object. -@end table - -Returns a string that provides some vendor identification of the X -server implementation associated with the specified @emph{display}. -@table @var -@item vendor-name -Type @var{string}. -@end table - -@end defun - - -@defun display-version-number display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the X protocol version number for this implementation of CLX. -@table @var -@item version-number -Type @var{card16}. -@end table - -@end defun - -@defun display-xid display - -@table @var -@item display -A @var{display} object. -@end table - -Returns the function that is used to allocate server resource IDs for -this @emph{display}. -@table @var -@item resource-allocator -Type @var{function}. -@end table - -@end defun - - -@defmac with-display display &body body - -This macro is for use in a multi-process -environment. @var{with-display} provides exclusive access to the local -@var{display} object for multiple request generation. It need not -provide immediate exclusive access for replies. That is, if another -process is waiting for a reply (while not in a @var{with-display}), -then synchronization need not (but can) occur immediately. Except -where noted, all routines effectively contain an implicit -@var{with-display} where needed, so that correct synchronization is -always provided at the interface level on a per-call basis. Nested -uses of this macro work correctly. This macro does not prevent -concurrent event processing (@pxref{with-event-queue}). - -@table @var -@item display -A @var{display}. -@end table - -@end defmac - -@node Managing the Output Buffer, Closing the Display, Display Attributes, Displays -@section Managing the Output Buffer - - -Most CLX functions cause output requests to be generated to an X -server. Output requests are not transmitted immediately but instead -are stored in an @emph{output buffer} for the appropriate -display. Requests in the output buffer are typically sent only when -the buffer is filled. Alternatively, buffered requests can be sent -prior to processing an event in the input event queue -(@pxref{Processing Events}). In either case, CLX sends the output -buffer automatically without explicit instructions from the client -application. - -However, in some cases, explicit control over the output buffer is -needed, typically to ensure that the X server is in a consistent state -before proceeding further. The @var{display-force-output} and -@var{display-finish-output} functions allow a client program to -synchronize with buffered output requests. - -@defun display-after-function display - -@table @var -@item display -A @var{display} object. -@end table - -Returns and (with @code{setf}) sets the @emph{after-function} for the -given @emph{display}. If @emph{after-function} is non-@var{nil}, it is -a function that is called after every protocol request is generated, -even those inside an explicit @var{with-display}, but never called -from inside the @emph{after-function}. The function is called inside -the effective @var{with-display} for the associated request. The -default value is @var{nil}. This can be set, for example, to -#'@var{display-force-output} or #' @var{display-finish-outpu}t. -@table @var -@item after-function -Type @var{function} or @var{null}. -@end table - -@end defun - - -@defun display-force-output display -@anchor{display-force-output} - -@table @var -@item display -A @var{display} object. -@end table - -Forces any buffered output to be sent to the X server. - -@end defun - - -@defun display-finish-output display -@anchor{display-finish-output} - -@table @var -@item display -A @var{display} object. -@end table - -Forces any buffered output to be sent to the X server and then waits -until all requests display error handler. Any events generated by -output requests are read and stored in the event queue. - -@end defun - -@node Closing the Display, , Managing the Output Buffer, Displays -@section Closing the Display - -To close or disconnect a display from the X server, use @var{close-display}. - -@defun close-display display - -@table @var -@item display -A @var{display} object. -@end table - -Closes the connection to the X server for the specified -@var{display}. It destroys all server resources (@var{window}, -@var{font}, @var{pixmap}, @var{colormap}, @var{cursor}, and -@var{gcontext}), that the client application has created on this -display, unless the close down mode of the server resource has been -changed (@pxref{set-close-down-mode}). Therefore, these server -resources should never be referenced again. In addition, this function -discards any output requests that have been buffered but have not yet -been sent. - -@end defun - -@node Screens, Windows and Pixmaps, Displays, Top -@chapter Screens - -@menu -* Screens and Visuals:: -* Screen Attributes:: -@end menu - -@node Screens and Visuals, Screen Attributes, Screens, Screens -@section Screens and Visuals - - -An X display supports graphical output to one or more -@emph{screens}. Each screen has its own root window and window -hierarchy. Each window belongs to exactly one screen and cannot -simultaneously appear on another screen. - - -The kinds of graphics hardware used by X screens can vary greatly in -their support for color and in their methods for accessing raster -memory. X uses the concept of a @emph{visual type} (usually -referred to simply as a @emph{visual}) which uniquely identifies the -hardware capabilities of a display screen. Fundamentally, a visual is -represented by a @var{card29} integer ID, which uniquely identifies -the visual type relative to a single display. CLX also represents a -visual with a @var{visual-info} structure that contains other -attributes associated with a visual (@pxref{Data Types}). A -screen can support more than one depth (that is, pixel size), and for -each supported depth, a screen may support more than one visual. -However, it is more typical for a screen to have only a single depth -and a single visual type. - - -A visual represents various aspects of the screen hardware, as -follows: - -@itemize @bullet - -@item -A screen can be color or gray-scale. - -@item -A screen can have a colormap that is either writable or read-only. - -@item -A screen can have a single colormap or separate colormaps for each of -the red, green, and blue components. With separate colormaps, a pixel -value is decomposed into three parts to determine indexes into each of -the red, green, and blue colormaps. - -@end itemize - -CLX supports the following classes of visual types: -@var{:direct-color}, @var{:gray-scale}, @var{:pseudo-color}, -@var{:static-color}, @var{:static-gray}, and @var{:true-color}. The -following tables show how the characteristics of a screen determine -the class of its visual type. - -For screens with a single colormap: - -@multitable {} {Color} {Gray-Scale} -@item Read-only @tab @var{:static-color} @tab @var{:static-gray} -@item Writable @tab @var{:pseudo-color} @tab @var{:gray-scale} -@end multitable - -For screens with red, green, and blue colormaps: - -@multitable @columnfractions 0.3 0.3 0.3 -@item Read-only @tab @var{:true-color} @tab -@item Writable @tab @var{:direct-color} @tab @var{:gray-scale} -@end multitable - -The visual class also indicates how screen colormaps are -handled. @pxref{Colormaps and Colors}). - -@node Screen Attributes, , Screens and Visuals, Screens -@section Screen Attributes - -In CLX, each display screen is represented by a @var{screen} -structure. The @var{display-roots} function returns the list of -@var{screen} structures for the display. The following paragraphs -discuss the attributes of CLX @var{screen} structures. - -@defun screen-backing-stores screen - -@table @var -@item screen -A @var{screen}. -@end table - -Returns a value indicating when the @emph{screen} supports backing -stores, although it may be storage limited in the number of windows it -can support at once. The value returned can be one of @var{:always}, -@var{:never}, or @var{:when-mapped}. - -@table @var -@item backing-stores-type -One of @var{:always}, @var{:never}, or @var{:when-mapped}. -@end table - -@end defun - - -@defun screen-black-pixel screen - -@table @var -@item screen -A @var{screen}. -@end table - -Returns the black pixel value for the specified @emph{screen}. - -@table @var -@item black-pixel -Type @var{pixel}. -@end table - -@end defun - - -@defun screen-default-colormap screen - -@table @var -@item screen -A @var{screen}. -@end table - -Returns the @emph{default-colormap} for the specified -@emph{screen}. The @emph{default-colormap} is initially associated -with the root window. Clients with minimal color requirements creating -windows of the same depth as the root may want to allocate from this -map by default. Most routine allocations of color should be made out -of this colormap. - -@table @var -@item default-colormap -Type @var{colormap}. -@end table - -@end defun - - -@defun screen-depths screen - -@table @var -@item screen -A @var{screen}. -@end table - - -Returns an association list that specifies what drawable -depths are supported on the specified @emph{screen}. Elements of the -returned association list have the form (depth @emph{visual}*), where -each @emph{visual} is a @var{visual-info} structure. Pixmaps are -supported for each depth listed, and windows of that depth are -supported if at least one visual type is listed for the depth. A -pixmap depth of one is always supported and listed, but windows of -depth one might not be supported. A depth of zero is never listed, but -zero-depth @var{:input-only} windows are always supported. - -@table @var -@item depths -Type @var{alist}. -@end table - -@end defun - - -@defun screen-event-mask-at-open screen - -@table @var -@item screen -A @var{screen}. -@end table - - -Returns the initial root event mask for the specified -@emph{screen}. - -@table @var -@item event-mask-at-open -Type @var{mask32}. -@end table - -@end defun - - -@defun screen-height screen - -@table @var -@item screen -A @var{screen}. -@end table - - -Returns the @emph{height} of the specified @emph{screen} in -pixel units. - -@table @var -@item height -Type @var{card16}. -@end table - -@end defun - - -@defun screen-height-in-millimeters screen - -@table @var -@item screen -A @var{screen}. -@end table - - -Returns the height of the specified @emph{screen} in -millimeters. The returned height can be used with the width in -millimeters to determine the physical size and the aspect ratio of the -screen. - -@table @var -@item height-in-millimeters -Type @var{card16}. -@end table - -@end defun - - -@defun screen-max-installed-maps screen - -@table @var -@item screen -A @var{screen}. -@end table - - -Returns the maximum number of colormaps that can be -installed simultaneously with @var{install-colormap}. - -@table @var -@item max-installed-colormaps -Type @var{card16}. -@end table - -@end defun - - -@defun screen-min-installed-maps screen - -@table @var -@item screen -A @var{screen}. -@end table - -Returns the minimum number of colormaps that can be guaranteed to be -installed simultaneously. - -@table @var -@item min-installed-colormaps -Type @var{card16}. -@end table - -@end defun - - -@defun screen-p screen - -@table @var -@item screen-p -Type @var{boolean}. -@end table - - -Returns non-@code{nil} if the @emph{screen} argument is a -@end defun - - - -@defun screen-plist screen - -@table @var -@item screen -A @var{screen}. -@end table - - -Returns and (with @code{setf}) sets the property list for the -specified @emph{screen}. This function provides a hook where -extensions can add data. - -@table @var -@item plist -Type @var{list}. -@end table - -@end defun - -@defun screen-root screen - -@table @var -@item screen -A @var{screen}. -@end table - - -Returns the @emph{root-window} for the specified -@emph{screen}. This function is useful with functions that take a -parent window as an argument. The class of the root window is always -@var{:input-output}. - -@table @var -@item root-window -Type @var{window} or @var{null}. -@end table - -@end defun - - -@defun screen-root-depth screen - -@table @var -@item screen -A @var{screen}. -@end table - -Returns the depth of the root window for the specified -@emph{screen}. Other depths can also be supported on this -@emph{screen}. - -@table @var -@item root-window-depth -Type @var{image-depth}. -@end table - -@end defun - - -@defun screen-root-visual screen - -@table @var -@item screen -A @var{screen}. -@end table - - -Returns the default visual type for the root window for the -specified @emph{screen}. - -@table @var -@item root-window-visual -Type @var{card29}. -@end table - -@end defun - - -@defun screen-save-unders-p screen - -@table @var -@item screen -A screen. -@end table - - -If true, the server can support the save-under mode in -@var{create-window} and in changing window attributes. - -@table @var -@item save-unders-p -Type @var{boolean}. -@end table - -@end defun - - -@defun screen-white-pixel screen - -@table @var -@item screen -A screen. -@end table - - -Returns the white pixel value for the specified -@emph{screen}. - -@table @var -@item white-pixel -Type @var{pixel}. -@end table - -@end defun - - -@defun screen-width screen - -@table @var -@item screen -A screen. -@end table - - -Returns the width of the specified @emph{screen} in pixel -units. - -@table @var -@item width -Type @var{card16}. -@end table - -@end defun - - -@defun screen-width-in-millimeters screen - -@table @var -@item screen -A screen. -@end table - - -Returns the width of the specified @emph{screen} in millimeters. The -returned width can be used with the height in millimeters to determine -the physical size and the aspect ratio of the screen. - -@table @var -@item width-in-millimeters -Type @var{card16}. -@end table - -@end defun - - -@node Windows and Pixmaps, Graphics Contexts, Screens, Top -@chapter Windows and Pixmaps - -@menu -* Drawables:: -* Creating Windows:: -* Window Attributes:: -* Stacking Order:: -* Window Hierarchy:: -* Mapping Windows:: -* Destroying Windows:: -* Pixmaps:: -@end menu - -@node Drawables, Creating Windows, Windows and Pixmaps, Windows and Pixmaps -@section Drawables - -Both windows and pixmaps can be used as sources and destinations in -graphics operations. These are collectively known as -@emph{drawables}. The following functions apply to both windows and -pixmaps. - -@defun drawable-display drawable - -@table @var -@item drawable -A @var{drawable} object. -@end table - -Returns the display for the specified @emph{drawable}. - -@end defun - -@defun drawable-equal drawable-1 drawable-2 - -@table @var -@item drawable-1 -@itemx drawable-2 -@var{drawable} objects. -@end table - -Returns true if the two arguments refer to the same server resource, -and @var{nil} if they do not. - -@end defun - - -@defun drawable-id drawable - -@table @var -@item drawable -A @var{drawable} object. -@end table - -Returns the unique resource ID assigned to the specified -@var{drawable}. - -@table @var -@item id -Type @var{resource-id}. -@end table - -@end defun - -@defun drawable-p drawable - -@table @var -@item boole -Type @var{boolean}. -@end table - -Returns true if the argument is a @var{drawable} and @var{nil} -otherwise. - -@end defun - -@defun drawable-plist drawable - -@table @var -@item plist -A property list. -@end table - -Returns and (with @code{setf}) sets the property list for the specified -@emph{drawable}. This function provides a hook where extensions can -add data. - -@end defun - -@node Creating Windows, Window Attributes, Drawables, Windows and Pixmaps -@section Creating Windows - - -A window is a @var{drawable} that can also receive input events. CLX -represents a window with a @var{window} object. The -@var{create-window} function creates a new @var{window} object. - -@defun create-window &key :parent :x :y :width :height (:depth 0) (:border-width 0) (:class :copy) (:visual :copy) :background :border :gravity :bit-gravity :backing-store :backing-planes :backing-pixel :save-under :event-mask :do-not-propagate-mask :override-redirect :colormap :cursor -@anchor{create-window} - -@table @var -@item :parent -The parent window. This argument is required. - -@item :x -@itemx :y -@var{int16} coordinates for the outside upper-left corner of the new -window with respect to the origin (inside upper-left corner) of the -@var{:parent}. These arguments are required. - -@item :width -@itemx :height - -@var{card16} values for the size of the new window. These arguments -are required. - -@item :depth - -A @var{card16} specifying the depth of the new window. - -@item :class - -One of @var{:input-outpu}t, @var{:input-only}, or @var{:copy}. - -@item :visual - -A @var{card29} ID specifying the visual type of the new window. - -@item :background -@itemx :backing-pixel -@itemx :backing-planes -@itemx :backing-store -@itemx :bit-gravity -@itemx :border -@itemx :border-width -@itemx :colormap -@itemx :cursor -@itemx :do-not-propagate-mask -@itemx :event -@itemx :gravity -@itemx :override-redirect -@itemx :save-under - -Initial attribute values for the new window. If @var{nil}, the default -value is defined by the X protocol.See paragraph -@end table - -Creates and returns a window. A @var{:parent} window must be -specified; the first window created by a client will have a root -window as its @var{:parent}. The new window is initially unmapped and -is placed on top of its siblings in the stacking order. A -@var{:create-notify} event is generated by the server. - -The @var{:class} of a window can be @var{:input-output} or -@var{:input-only}. Windows of class @var{:input-only} cannot be used -as the destination drawable for graphics output and can never receive -@var{:exposure} events, but otherwise operate the same as -@var{:input-output} windows. The @var{:class} can also be @var{:copy}, -in which case the new window has the same class as its @var{:parent}. - -For an @var{:input-output} window, the @var{:visual} and @var{:depth} -must be a combination supported by the @var{:parent}'s screen, but the -@var{:depth} need not be the same as the @var{:parent}'s. The -@var{:parent} of an @var{:input-output} window must also be -@var{:input-output}. A @var{:depth} of 0 means that the depth of the -@var{:parent} is used. - -For an @var{:input-only} window, the @var{:depth} must be zero, and -the @var{:visual} must be supported by the @var{:parent}'s screen. The -@var{:parent} of an @var{:input-only} window can be of any class. The -only attributes that can be given for an @var{:input-only} window are -@var{:cursor}, @var{:do-not-propagate-mask}, @var{:event-mask}, -@var{:gravity}, and @var{:override-redirect}. - -@table @var -@item window -Type @var{window}. -@end table - -@end defun - -@node Window Attributes, Stacking Order, Creating Windows, Windows and Pixmaps -@section Window Attributes - - -The following paragraphs describe the CLX functions used to return or -change window attributes. Using the @var{with-state} macro improves -the performance of attribute access by batching related accesses in -the minimum number of server requests. - -@defun drawable-border-width drawable - -@table @var -@item drawable -A @var{drawable} object. -@end table - -Returns the @emph{border-width} of the @emph{drawable} in pixels. It -always returns zero if the @emph{drawable} is a pixmap or an -@var{:input-only} window. Used with @code{setf}, this function also -changes the border width of the @var{:input-only} window. The default -border width of a new window is zero. - -Changing just the border width leaves the outer left corner of a -window in a fixed position but moves the absolute position of the -window's origin. It is an error to make the border width of an -@var{:input-only} window nonzero. - -When changing the border-width of a window, if the override-redirect -attribute of the window is @var{:off} and some other client has -selected @var{:substructure-redirect} on the parent, a -@var{:configure-request} event is generated, and no further processing -is performed. Otherwise, the border-width is changed. - -@table @var -@item border-width -Type @var{card16}. -@end table - -@end defun - - -@defun drawable-depth drawable - -@table @var -@item drawable -A @var{drawable} object. -@end table - -Returns the depth of the specified @emph{drawable} (bits per pixel). - -@table @var -@item depth -Type @var{card8}. -@end table - -@end defun - - -@defun drawable-height drawable - -@table @var -@item inside-height -Type @var{card16}. -@end table - -@end defun - - -@defun drawable-width drawable - -@table @var -@item drawable -A @var{drawable} object. -@end table - -These functions return the height or width of the -@emph{drawable}. These coordinates define the inside size of the -@emph{drawable}, in pixels. Used with @code{setf}, these functions also -change the inside height or width of a window. However, the height or -width of a pixmap cannot be changed. - -Changing the width and height resizes a window without changing its -position or stacking priority. - -Changing the size of a mapped window may cause the window to lose its -contents and generate an @var{:exposure} event. If a mapped window is -made smaller, @var{:exposure} events are generated on windows that it -formerly obscured. - -When changing the size of a window, if the override-redirect attribute -of the window is @var{:off} and some other client has selected -@var{:substructure-redirect} on the parent, a @var{:configure-request} -event is generated, and no further processing is performed. Otherwise, -if another client has selected @var{:resize-redirect} on the window, a -@var{:resize-request} event is generated, and the current inside width -and height are maintained. Note that the override-redirect attribute -of the window has no effect on @var{:resize-redirect} and that -@var{:substructure-redirect} on the parent has precedence over -@var{:resize-redirect} on the window. - -When the inside size of the window is changed, the children of the -window can move according to their window gravity. Depending on the -window's bit gravity, the contents of the window can also be moved. - -@table @var -@item inside-width -Type @var{card16}. -@end table - -@end defun - - -@defun drawable-x drawable - -@table @var -@item outside-left -Type @var{int16}. -@end table - -@end defun - - -@defun drawable-y drawable - -@table @var -@item drawable -A @var{drawable} object. -@end table - -These functions return the x or y coordinate of the specified -@emph{drawable}. They always return zero if the @emph{drawable} is a -pixmap. These coordinates define the location of the top left pixel of -the window's border or of the window, if it has no border. Used with -@code{setf}, these functions also change the x or y coordinate of a -window. However, the x or y coordinate of a pixmap cannot be changed. - -Changing the x and y coordinates moves a window without changing its -size or stacking priority. Moving a mapped window generates -@var{:exposure} events on any formerly obscured windows. - -When changing the position of a window, if the override-redirect -attribute of the window is @var{:off} and some other client has -selected @var{:substructure-redirect} on the parent, a -@var{:configure-request} event is generated, and no further processing -is performed. Otherwise, the window is moved. - -@table @var -@item outside-top -Type @var{int16}. -@end table - -@end defun - - -@defun window-all-event-masks window - -@table @var -@item window -A @var{window}. -@end table - -Returns the inclusive-or of the event masks selected on the -specified @emph{window} by all clients. -@table @var -@item all-event-masks -Type @var{mask32}. -@end table - -@end defun - - -@defun setf (window-background) window background - -@table @var -@item window -A @var{window}. -@item background -Either a @var{pixel}, a @var{pixmap}, @var{:none}, or @var{:parent-relative}. -@end table - -Changes the @emph{background} attribute of the @emph{window} to the -specified value. This operation is not allowed on an @var{:input-only} -window. Changing the background does not cause the window contents to -be changed. Note that the background of a window cannot be returned -from the X server. The default background of a new window is -@var{:none}. - -In general, the server automatically fills in exposed areas of the -window when they are first made visible. A background pixmap is tiled -to fill each area. However, if the background is @var{:none}, the -server will not modify exposed areas. If the background is -@var{:parent-relative}, the window and its parent must have the same -depth. In this case, the window shares the same background as its -parent. The parent's background is not copied and is reexamined -whenever the window's background is required. If the background is -@var{:parent-relative}, the background pixmap tile origin is the same -as the parent's; otherwise, the tile origin is the window origin. - -@table @var -@item background -Either a @var{pixel}, a @var{pixmap}, @var{:none}, or @var{:parent-relative}. -@end table - -@end defun - - -@defun window-backing-pixel window - -@table @var -@item window -A @var{window}. -@end table - -Returns and (with @code{setf}) changes the value of the backing-pixel -attribute for the specified @emph{window}. Changing the backing-pixel -attribute of a mapped window may have no immediate effect. The default -backing-pixel of a new window is zero. - -@table @var -@item backing-pixel -Type @var{pixel}. -@end table - -@end defun - - -@defun window-backing-planes window - -@table @var -@item window -A @var{window}. -@end table - -Returns and (with @code{setf}) changes the value of the backing-planes -attribute for the specified @emph{window}. Changing the backing-planes -attribute of a mapped window may have no immediate effect. The default -backing-planes of a new window is all one's. - -@table @var -@item backing-planes -Type @var{pixel}. -@end table - -@end defun - - -@defun window-backing-store window - -@table @var -@item window -A @var{window}. -@end table - -Returns and (with @code{setf}) changes the value of the backing-store -attribute for the specified @emph{window}. Changing the backing-store -attribute of an obscured window to @var{:when-mapped} or @var{:always} -may have no immediate effect. The default backing-store of a new -window is @var{:not-useful}. - -@table @var -@item backing-store-type -One of @var{:always}, @var{:not-useful}, or @var{:when-mapped}. -@end table - -@end defun - - -@defun window-bit-gravity window - -@table @var -@item window -A @var{window}. -@end table - -Returns and (with @code{setf}) changes the bit-gravity attribute of the -@emph{window}. If a window is reconfigured without changing its inside -width or height, the contents of the window move with the window and -are not lost. Otherwise, the contents of the resized window are either -moved or lost, depending on its bit-gravity attribute. The default -bit-gravity of a new window is @var{:forget}. - -For example, suppose a window's size is changed by @emph{W} pixels -in width and @emph{H} pixels in height. The following table shows, -for each bit-gravity value, the change in position (relative to the -window origin) that results for each pixel of the window contents. - -@multitable {Bit-Gravity} {X Change} {Y Change} -@item @var{:center} @tab @emph{W/}2 @tab @emph{H/}2 -@item @var{:east} @tab @emph{W} @tab @emph{H/}2 -@item @var{:north} @tab @emph{W/}2 @tab 0 -@item @var{:north-east} @tab @emph{W} @tab 0 -@item @var{:north-west} @tab 0 @tab 0 -@item @var{:south} @tab @emph{W/}2 @tab @emph{H} -@item @var{:south-east} @tab W @tab H -@item @var{:south-west} @tab 0 @tab H -@item @var{:west} @tab 0 @tab H/2 -@end multitable - - -A @var{:static} bit-gravity indicates the contents or window should -not move relative to the origin of the root window. - -A server can choose to ignore the specified bit-gravity attribute -and use @var{:forget} instead. A @var{:forget} bit-gravity -attribute indicates that the window contents are always discarded -after a size change, even if backing-store or save-under attributes -are @var{:on}. The window's background is displayed (unless it is -@var{:none}), and zero or more @var{:exposure} events are -generated. -@table @var -@item bit-gravity -Type @var{bit-gravity}. -@end table - -@end defun - - -@defun setf (window-border) window border - -@table @var -@item window -A @var{window}. -@item border -Either a @var{pixel}, a @var{pixmap}, or @var{:copy}. -@end table - -Changes the @emph{border} attribute of the @emph{window} to the -specified value. This operation is not allowed on an -@var{:input-only} window. Changing the border attribute also causes -the window border to be repainted. Note that the border of a window -cannot be returned from the X server. The default border of a new -window is @var{:copy}. - -A border pixmap is tiled to fill the border. The border pixmap tile -origin is the same as the background tile origin. A border pixmap -and the window must have the same root and depth. If the border is -@var{:copy}, the parent's border is copied and used; subsequent -changes to the parent's border do not affect the window border. -@table @var -@item border -Either a @var{pixel}, a @var{pixmap}, or @var{:copy}. -@end table - -@end defun - - -@defun window-class window - -@table @var -@item window -A @var{window}. -@end table - -Returns the @emph{class} of the specified @emph{window}. -@table @var -@item class -Either @var{:input-output} or @var{:input-only}. -@end table - -@end defun - - -@defun window-colormap window - -@table @var -@item window -A @var{window}. -@end table - -Returns and (with @code{setf}) changes the value of the colormap -attribute for the specified @emph{window}. A value of @var{:copy} is -never returned, since the parent's colormap attribute is actually -copied, but the attribute can be set to @var{:copy} in a @code{setf} -form. Changing the colormap of a window (defining a new map, not -changing the contents of the existing map) generates a -@var{:colormap-notify} event. Changing the colormap of a visible -window may have no immediate effect on the screen -(@pxref{install-colormap}). The default colormap of a new window is -@var{:copy}. -@table @var -@item colormap -Type @var{colormap} or @var{null}. -@end table - -@end defun - - -@defun window-colormap-installed-p window - -@table @var -@item window -A @var{window}. -@end table - -Returns non-@var{nil} if the colormap associated with this -@emph{window} is installed. Otherwise, this function returns -@var{nil}. -@table @var -@item colormap-installed-p -Type @var{boolean}. -@end table - -@end defun - - -@defun setf (window-cursor) window cursor - -@table @var -@item window -A @var{window}. -@item cursor -Either @var{cursor} or @var{:none}. -@end table - -Changes the @emph{cursor} attribute of the @emph{window} to the -specified value. Changing the cursor of a root window to @var{:none} -restores the default cursor. Note that the cursor of window cannot be -returned from the X server. The default cursor of a new window is -@var{:none}. - -@table @var -@item cursor -Type @var{cursor} or @var{:none}. -@end table - -@end defun - - -@defun window-display window - -@table @var -@item window -A @var{window}. -@end table - -Returns the @var{display} object associated with the specified -@emph{window}. -@table @var -@item display -Type @var{display}. -@end table - -@end defun - - -@defun window-do-not-propagate-mask window - -@table @var -@item window -A @var{window}. -@end table - -Returns and (with @code{setf}) changes the do-not-propagate-mask -attribute for the window. The default do-not-propagate-mask of a new -window is zero. - -If a window receives an event from one of the user input devices, and -if no client has selected to receive the event, the event can instead -be propagated up the window hierarchy to the first ancestor for which -some client has selected it. However, any event type selected by the -do-not-propagate-mask is not be propagated. The types of events that -can be selected by the do-not-propagate-mask are those of type -@var{device-event-mask-class}. @xref{Selecting Events}. -@table @var -@item do-not-propagate-mask -Type @var{mask32}. -@end table - -@end defun - - -@defun window-equal window-1 window-2 - -@table @var -@item window-1 -@itemx window-2 -The windows to compare for equality. -@end table - -Returns non-@var{nil} if the two arguments are the same window, and -@var{nil} if they are not. -@table @var -@item equal-p -Type @var{boolean}. -@end table - -@end defun - - -@defun window-event-mask window - -@table @var -@item window -A @var{window}. -@end table - -Returns and (with @code{setf}) changes the value of the event-mask -attribute for the @emph{window}. The default event-mask of a new -window is zero. -@table @var -@item event-mask -Type @var{mask32}. -@end table - -@end defun - - -@defun window-gravity window - -@table @var -@item window -A @var{window}. -@end table - -Returns and (with @code{setf}) changes the gravity attribute of the -@emph{window}. If a parent window is reconfigured without changing its -inside width or height, then all child windows move with the parent -and are not changed. Otherwise, each child of the resized parent is -moved, depending on the child's gravity attribute. The default gravity -of a new window is @var{:north-west}. - -For example, suppose the size of the window's parent is changed by -@emph{W} pixels in width and @emph{H} pixels in height. The following -table shows, for each possible gravity value, the resulting change in -the window's position relative to its parent's origin. When the window -is moved, two events are generated--a @var{:configure-notify} event -followed by a @var{:gravity-notify} event. - -@multitable {Gravity} {X Change} {Y Change} -@item @var{:center} @tab @emph{W/}2 @tab @emph{H/}2 -@item @var{:east} @tab @emph{W} @tab @emph{H/}2 -@item @var{:north} @tab @emph{W/}2 @tab 0 -@item @var{:north-east} @tab @emph{W} @tab 0 -@item @var{:north-west} @tab 0 @tab 0 -@item @var{:south} @tab @emph{W/}2 @tab @emph{H} -@item @var{:south-east} @tab W @tab H -@item @var{:south-west} @tab 0 @tab H -@item @var{:west} @tab 0 @tab H/2 -@end multitable - - -A @var{:static} gravity indicates that the position of the window -should not move relative to the origin of the root window. - -An @var{:unmap} gravity is like @var{:north-west}, except the window -is also unmapped and an @var{:unmap-notify} event is generated. This -@var{:unmap-notify} event is generated after the -@var{:configure-notify} event is generated for the parent. -@table @var -@item gravity -Type @var{win-gravity}. -@end table - -@end defun - - -@defun window-id window - -@table @var -@item window -A @var{window}. -@end table - -Returns the unique ID assigned to @emph{window}. -@table @var -@item id -Type @var{resource-id}. -@end table - -@end defun - - -@defun window-map-state window - -@table @var -@item window -A @var{window}. -@end table - -Returns the map state of @emph{window}. A window is @var{:unviewable} -if it is mapped but some ancestor is unmapped. -@table @var -@item map-state -One of @var{:unmapped}, @var{:unviewable}, or @var{:viewable}. -@end table - -@end defun - - -@defun window-override-redirect window - -@table @var -@item window -A @var{window}. -@end table - -Returns and (with @code{setf}) changes the value of the -override-redirect attribute for @emph{window}. The default -override-redirect of a new window is @var{:off}. - -The override-redirect attribute determines whether or not attempts to -change window geometry or parent hierarchy can be @emph{redirected} by -a window manager or some other client. The functions that might be -affected by the override-redirect attribute are -@var{circulate-window-down}, @var{circulate-window-up}, -@var{drawable-border-width}, @var{drawable-height}, -@var{drawable-width}, @var{drawable-x}, @var{drawable-y}, -@var{map-window}, and @var{window-priority}. -@table @var -@item override-redirect -Either @var{:on} or @var{:off}. -@end table - -@end defun - - -@defun window-p object - -@table @var -@item window-p -Type @var{boolean}. -@end table - -Returns non-@var{nil} if the @emph{object} argument is a window; otherwise, it returns @var{nil}. -@end defun - -@defun window-plist window - -@table @var -@item window -A @var{window}. -@end table - -Returns and (with @code{setf}) sets the property list for the specified -@emph{window}. This function provides a hook where extensions can hang -data. -@table @var -@item plist -A property list. -@end table - -@end defun - - - -@defun setf (window-priority window) (&optional sibling) mode - -@table @var -@item window -A @var{window}. - -@item sibling -An optional argument specifying that @emph{window} is to be restacked -relative to this sibling @var{window}. - -@item mode -One of @var{:above}, @var{:below}, @var{:bottom-if}, @var{:opposite}, or @var{:top-if}. -@end table - -Changes the stacking priority element of the @emph{window} to the -specified value. It is an error if the @emph{sibling} argument is -specified and is not actually a sibling of the window. Note that the -priority of an existing window cannot be returned from the X server. - -When changing the priority of a window, if the override-redirect -attribute of the window is @var{:off} and some other client has -selected :substructure-redirect on the parent, a :configure-request -event is generated, and no further processing is -performed. Otherwise, the priority is changed. -@table @var -@item mode -One of @var{:above}, @var{:below}, @var{:bottom-if}, @var{:opposite}, or @var{:top-if}. -@end table - -@end defun - - -@defun window-save-under window - -@table @var -@item window -A @var{window}. -@end table - -Returns and (with @code{setf}) changes the value of the save-under -attribute for the specified @emph{window}. Changing the save-under -attribute of a mapped window may have no immediate effect. -@table @var -@item save-under -Either @var{:on} or @var{:off}. -@end table - -@end defun - -@defun window-visual window - -@table @var -@item window -A @var{window}. -@end table - -Returns the @emph{visual-type} associated with the specified @emph{window}. -@table @var -@item visual-type -Type @var{card29}. -@end table - -@end defun - - - -@defmac with-state drawable &body body -@anchor{with-state} - -Batches successive read and write accesses to window attributes and -drawable geometry, in order to minimize the number of requests sent to -the server. Batching occurs automatically within the dynamic extent of -the @emph{body}. The @emph{body} is not executed within a -@var{with-display} form. - -All window attributes can be returned or changed in a single -request. Similarly, all drawable geometry values can be returned or -changed in a single request. @var{with-state} combines accesses to -these values into the minimum number of server requests necessary to -guarantee that each read access returns the current server state of -the @emph{drawable}. The number of server requests sent depends on -the sequence of calls to reader and @code{setf} functions within the -dynamic extent of the @emph{body}. There are two groups of reader and -@code{setf} functions--the Window Attributes group and the Drawable -Geometry group--as shown in Table 4-1. - -@multitable {Group} {Reader Functions} {Setf Functions} - -@item Window Attributes @tab @var{window-all-event-masks} @tab @var{window-background} - -@item @tab @var{window-backing-pixel} @tab @var{window-backing-pixel} -@item @tab @var{window-backing-planes} @tab @var{window-backing-planes} -@item @tab @var{window-backing-store} @tab @var{window-backing-store} -@item @tab @var{window-bit-gravity} @tab @var{window-bit-gravity} -@item @tab @var{window-class} @tab @var{window-border} -@item @tab @var{window-colormap} @tab @var{window-colormap} -@item @tab @var{window-colormap-installed-p} @tab @var{window-cursor} -@item @tab @var{window-do-not-propagate-mask} @tab @var{window-do-not-propagate-mask} -@item @tab @var{window-event-mask} @tab @var{window-event-mask} -@item @tab @var{window-gravity} @tab @var{window-gravity} -@item @tab @var{window-map-state} @tab -@item @tab @var{window-override-redirect} @tab @var{window-override-redirect} -@item @tab @var{window-save-under} @tab @var{window-save-under} -@item @tab @var{window-visual} @tab - -@item Drawable Geometry @tab @var{drawable-border-width} @tab @var{drawable-border-width} - -@item @tab @var{drawable-depth} @tab @var{drawable-height} -@item @tab @var{drawable-height} @tab @var{drawable-width} -@item @tab @var{drawable-root} @tab @var{drawable-x} -@item @tab @var{drawable-width} @tab @var{drawable-y} -@item @tab @var{drawable-x} @tab @var{window-priority} -@item @tab @var{drawable-y} @tab - -@end multitable - - -The results from a sequence of calls to @code{setf} functions in a -given group are cached and sent in a single server request, either -upon exit from the @emph{body} or when a reader function from the -corresponding group is called. - -@var{with-state} sends a single request to update all its cached -values for the @emph{drawable} before the first call to a reader -function within the @emph{body} and also before the first call to a -reader function following a sequence of calls to @code{setf} functions -from the corresponding group. - -@table @var -@item drawable -A @var{display}. -@item body -The forms in which attributes accesses are batched. -@end table - -@end defmac - - -@node Stacking Order, Window Hierarchy, Window Attributes, Windows and Pixmaps -@section Stacking Order - - -Sibling windows can @emph{stack} on top of each other. Windows above -can @emph{obscure} or @emph{occlude} lower windows. This relationship -between sibling windows is known as the stacking order. The -@var{window-priority} function can be used to change the stacking -order of a single window. CLX also provides functions to raise or -lower children of a window. Raising a mapped window can generate -@var{:exposure} events for the window and any mapped subwindows that -were formerly obscured. Lowering a mapped window can generate -@var{:exposure} events on any windows it formerly obscured. - -@defun circulate-window-down window - -@table @var -@item window -A @var{window}. -@end table - -Lowers the highest mapped child of the specified @emph{window} that -partially or completely occludes another child to the bottom of the -stack. Completely unobscured children are unaffected. Exposure -processing is performed on formerly obscured windows. - -If some other client has selected @var{:substructure-redirect} on the -@emph{window}, a @var{:circulate-request} event is generated, and no -further processing is performed. Otherwise, the child window is -lowered and a @var{:circulate-notify} event is generated if the -@emph{window} is actually restacked. - -@end defun - - -@defun circulate-window-up window - -@table @var -@item window -A @var{window}. -@end table - -Raises the lowest mapped child of the specified @emph{window} that is -partially or completely occluded by another child to the top of the -stack. Completely unobscured children are unaffected. Exposure -processing is performed on formerly obscured windows. - -If another client has selected @var{:substructure-redirect} on the -@emph{window}, a @var{:circulate-request} event is generated, and no -further processing is performed. Otherwise, the child window is raised -and a @var{:circulate-notify} event is generated if the @emph{window} -is actually restacked. - -@end defun - -@node Window Hierarchy, Mapping Windows, Stacking Order, Windows and Pixmaps -@section Window Hierarchy - - -All the windows in X are arranged in a strict hierarchy. At the top of -the hierarchy are the root windows, which cover the display -screens. Each root window is partially or completely covered by its -child windows. All windows, except for root windows, have -parents. Child windows can have their own children. In this way, a -tree of arbitrary depth on each screen can be created. CLX provides -several functions for examining and modifying the window hierarchy. - -@defun drawable-root drawable - -@table @var -@item drawable -A @var{drawable}. -@end table - -Returns the root window of the specified @emph{drawable}. - -@table @var -@item root-window -Type @var{window}. -@end table - -@end defun - -@defun query-tree window &key (:result-type `list) - -@table @var -@item window -A @var{window}. -@item :result-type -A valid type specifier for a sub-type of @var{sequence}. The default is a @var{list}. -@end table - -Returns the @emph{children} windows, the @emph{parent} window, and the -@emph{root} window for the specified @emph{window}. The children are -returned as a sequence of windows in current stacking order, from -bottom-most (first) to top-most (last). The @var{:result-type} -specifies the type of children sequence returned. - -@table @var -@item children -Type @var{sequence} of @var{window}. -@item parent -Type @var{window} or @var{null}. -@item root -Type @var{window}. -@end table - -@end defun - - -@defun reparent-window window parent x y - -@table @var -@item window -A @var{window}. -@item parent -The new parent @var{window}. -@item x -@itemx y -The position (type @var{int16}) of the @emph{window} in its new -@emph{parent}. These coordinates are relative to the @emph{parent}'s -origin, and specify the new position of the upper, left, outer corner -of the @emph{window}. -@end table - -Changes a @emph{window}'s @emph{parent} within a single -screen. There is no way to move a window between screens. - -The specified @emph{window} is reparented by inserting it as a child -of the specified @emph{parent}. If the @emph{window} is mapped, an -@var{unmap-window} operation is automatically performed on the -specified @emph{window}. The @emph{window} is then removed from its -current position in the hierarchy and inserted as the child of the -specified @emph{parent}. The @emph{window} is placed on top in the -stacking order with respect to sibling windows. - -After reparenting the specified @emph{window,} a -@var{:reparent-notify} event is generated. The override-redirect -attribute of the @emph{window} is passed on in this event. Window -manager clients normally should ignore this event if this attribute is -@var{:on}. @xref{Events and Input}, for more information on -@var{:reparent-notify} event processing. Finally, if the specified -@emph{window} was originally mapped, a @var{map-window} operation is -automatically performed on it. - -The X server performs normal exposure processing on formerly obscured -windows. It might not generate @var{:exposure} events for regions from -the initial @var{unmap-window} operation if they are immediately -obscured by the final @var{map-window} operation. - -It is an error if any of the following are true: - -@itemize @bullet - -@item -The new @emph{parent} window is not on the same screen as the old parent window. - -@item -The new @emph{parent} window is the specified @emph{window} or an -inferior of the specified @emph{window}. - -@item -The specified @emph{window} has a @var{:parent-relative} background -attribute and the new @emph{parent} window is not the same depth as -the specified @emph{window}. -@end itemize - - - -@end defun - -@defun translate-coordinates source source-x source-y destination - -@table @var -@item source -A @var{window} defining the source coordinate system. - -@item source-x -@itemx source-y -Coordinates (@var{int16}) relative to the origin of the @emph{source} -@var{window}. - -@item destination -A @var{window} defining the destination coordinate system. - -@end table - -Returns the position defined by @emph{source-x} and @emph{source-y} -(relative to the origin of the @emph{source} window), expressed as -coordinates relative to the origin of the @emph{destination} window. - -@table @var -@item destination-x -Type @var{int16} or @var{null}. -@item destination-y -Type @var{int16} or @var{null}. -@item destination-child -Type @var{window} or @var{null}. -@end table - -@end defun - - -@node Mapping Windows, Destroying Windows, Window Hierarchy, Windows and Pixmaps -@section Mapping Windows - -A window is considered mapped if a @var{map-window} call has been made -on it. When windows are first created, they are not mapped because an -application may wish to create a window long before it is mapped to -the screen. A mapped window may not be visible on the screen for one -of the following reasons: - -@itemize @bullet - -@item It is obscured by another opaque sibling window. -@item One of its ancestors is not mapped. -@item It is entirely clipped by an ancestor. - -@end itemize - - -A subwindow will appear on the screen as long as all of its ancestors -are mapped and not obscured by a sibling or clipped by an -ancestor. Mapping a window that has an unmapped ancestor does not -display the window, but marks it as eligible for display when the -ancestor becomes mapped. Such a window is called unviewable. When all -its ancestors are mapped, the window becomes viewable and remains -visible on the screen if not obscured by any sibling or ancestor. - -Any output to a window not visible on the screen is -discarded. @var{:exposure} events are generated for the window when -part or all of it becomes visible on the screen. A client only -receives the @var{:exposure} events if it has selected them. Mapping -or unmapping a window does not change its stacking order priority. - -@defun map-window window - -@table @var -@item window -A @var{window}. -@end table -@anchor{map-window} - -Maps the @emph{window}. This function has no effect when the -@emph{window} is already mapped. - -If the override-redirect attribute of the @emph{window} is @var{:off} -and another client has selected @var{:substructure-redirect} on the -parent window, the X server generates a @var{:map-request} event and -the @var{map-window} function does not map the -@emph{window}. Otherwise, the @emph{window} is mapped, and the X -server generates a @var{:map-notify} event. - -If the @emph{window} becomes visible and no earlier contents for it -are remembered, @var{map-window} tiles the window with its -background. If no background was defined for the window, the existing -screen contents are not altered, and the X server generates one or -more @var{:exposure} events. If a backing-store was maintained while -the window was unmapped, no @var{:exposure} events are generated. If a -backing-store will now be maintained, a full window exposure is always -generated. Otherwise, only visible regions may be reported. Similar -tiling and exposure take place for any newly viewable inferiors. - -@var{map-window} generates @var{:exposure} events on each -@var{:input-output} window that it causes to become visible. - - - -@end defun - -@defun map-subwindows window - -@table @var -@item window -A @var{window}. -@end table - -Maps all child windows for a specified @emph{window} in top-to-bottom -stacking order. The X server generates an @var{:exposure} event on -each newly visible window. This function is much more efficient than -mapping each child individually. - - - -@end defun - - -@defun unmap-window window - -@table @var -@item window -A @var{window}. -@end table - -Unmaps the specified @emph{window} and causes the X server to generate -an @var{:unmap-notify} event. If the specified @emph{window} is -already unmapped, @var{unmap-window} has no effect. Normal exposure -processing on formerly obscured windows is performed. Any child window -is no longer viewable. Unmapping the @emph{window} generates -@var{:exposure} events on windows that were formerly obscured by -@emph{window} and its children. - - - -@end defun - - -@defun unmap-subwindows window - -@table @var -@item window -A @var{window}. -@end table - -Unmaps all child windows for the specified @emph{window} in bottom to -top stacking order. The X server generates an @var{:unmap-notify} -event on each child and @var{:exposure} events on formerly obscured -windows. Using this function is much more efficient than unmapping -child windows individually. - - - -@end defun - - -@node Destroying Windows, Pixmaps, Mapping Windows, Windows and Pixmaps -@section Destroying Windows - - -CLX provides functions to destroy a window or destroy all children of -a window. Note that by default, windows are destroyed when a -connection is closed. For further information, -@xref{Closing the Display}, and @xref{Client Termination}. - -@defun destroy-window window - -@table @var -@item window -A @var{window}. -@end table - -Destroys the specified @emph{window} as well as all of its -inferiors. The windows should never again be referenced. If the -specified @emph{window} is mapped, it is automatically unmapped. The -window and all of its inferiors are then destroyed, and a -@var{:destroy-notify} event is generated for each window. The ordering -of the @var{:destroy-notify} events is such that for any given window -being destroyed, @var{:destroy-notify} is generated on the window's -inferiors before being generated on the window. The ordering among -siblings and across sub-hierarchies is not otherwise constrained. If -the @emph{window} is a root window, no windows are -destroyed. Destroying a mapped window generates @var{:exposure} events -on other windows that the mapped window obscured. - - - -@end defun - -@defun destroy-subwindows window - -@table @var -@item window -A @var{window}. -@end table - -Destroys all inferiors of the specified @emph{window}, in bottom to -top stacking order. The X server generates a @var{:destroy-notify} -event for each window. This is much more efficient than deleting many -windows individually. The inferiors should never be referenced again. - - -@end defun - - -@node Pixmaps, , Destroying Windows, Windows and Pixmaps -@section Pixmaps - - -A @emph{pixmap} is a three-dimensional array of bits. A pixmap is -normally thought of as a two-dimensional array of pixels, where each -pixel can be a value from 0 to 2@emph{n}-1, where @emph{n} -is the depth of the pixmap. A pixmap can also be thought of as a stack -of @emph{n} bitmaps. A @emph{bitmap} is a single bit pixmap of depth -1. CLX provides functions to: - -@itemize @bullet - -@item Create or free a pixmap - -@item Test if an object is a pixmap - -@item Test if two pixmap objects are equal - -@item Return the pixmap resource ID from a @var{pixmap} object -@end itemize - - - -Note that pixmaps can only be used on the screen where they were -created. Pixmaps are off-screen server resources that are used for a -number of operations. These include defining patterns for cursors or -as the source for certain raster operations. - -@defun create-pixmap &key :width :height :depth :drawable - -@table @var -@item :width -@itemx :height -The nonzero width and height (type @var{card16}). - -@item :depth -The depth (type @var{card8}) of the pixmap. - -@item :drawable -A @var{drawable} which determines the screen where the pixmap will be used. -@end table - -Creates a pixmap of the specified @var{:width}, @var{:height}, and -@var{:depth}. It is valid to pass a window whose class is -@var{:input-only} as the @var{:drawable} argument. The @var{:width} -and @var{:height} arguments must be nonzero. The @var{:depth} must be -supported by the screen of the specified @var{:drawable}. - -@table @var -@item pixmap -Type @var{pixmap}. -@end table - -@end defun - - -@defun free-pixmap pixmap - -@table @var -@item pixmap -A @var{pixmap}. -@end table - -Allows the X server to free the pixmap storage when no other server -resources reference it. The pixmap should never be referenced again. - - - -@end defun - - -@defun pixmap-display pixmap - -@table @var -@item pixmap -A @var{pixmap}. -@end table - -Returns the @var{display} object associated with the specified @emph{pixmap}. - -@table @var -@item display -Type @var{display}. -@end table - -@end defun - - -@defun pixmap-equal pixmap-1 pixmap-2 - -@table @var -@item pixmap-1 -@itemx pixmap-2 -A three-dimensional array of bits to be tested. -@end table - -Returns true if the two arguments refer to the same server resource, -and @var{nil} if they do not. - - - -@end defun - - -@defun pixmap-id pixmap - -@table @var -@item pixmap -A @var{pixmap}. -@end table - -Returns the unique resource ID that has been assigned to the specified -@emph{pixmap}. - -@table @var -@item id -Type @var{resource-id}. -@end table - -@end defun - - -@defun pixmap-p object - -@table @var -@item pixmap -Type @var{boolean}. -@end table - -Returns true if the argument is a @var{pixmap} object and @var{nil} -otherwise. - -@end defun - -@defun pixmap-plist pixmap - -@table @var -@item pixmap -A @var{pixmap}. -@end table - -Returns and (with @code{setf}) sets the property list for the specified -@emph{pixmap}. This function provides a hook where extensions can add -data. - -@table @var -@item plist -A property list. -@end table - -@end defun - - -@node Graphics Contexts, Graphic Operations, Windows and Pixmaps, Top -@chapter Graphics Contexts - -Clients of the X Window System specify the visual attributes of -graphical output primitives by using @emph{graphics contexts}. A -graphics context is a set of graphical attribute values such as -foreground color, font, line style, and so forth. Like a window, a -graphics context is another kind of X server resource which is created -and maintained at the request of a client program. The client program, -which may use several different graphics contexts at different times, -is responsible for specifying a graphics context to use with each -graphical output function. - -CLX represents a graphics context by an object of type @var{gcontext} -and defines functions to create, modify, and manipulate @var{gcontext} -objects. By default, CLX also records the contents of graphics -contexts in a cache associated with each display. This local caching -of graphics contexts has two important advantages: - -@enumerate - -@item -Communication efficiency -- Changes to attribute values in a -@var{gcontext} are first made only in the local cache. Just before a -@var{gcontext} is actually used, CLX automatically sends any changes -to the X server, batching all changes into a single request. - -@item -Inquiring @var{gcontext} contents -- Accessor functions can be used -to return the value of any individual @var{gcontext} component by -reading the copy of the @var{gcontext} from the cache. This kind of -inquiry is not supported by the basic X protocol. There is no way for -a client program to request an X server to return the contents of a -@var{gcontext}. -@end enumerate - - -Caching graphics contexts can result in a synchronization problem if -more than one client program modifies a graphics context. However, -this problem is unusual. Sharing a graphics context among several -clients, while possible, is not expected to be useful and is not very -easy to do. At any rate, a client program can choose to not cache a -@var{gcontext} when it is created. - -Each client program must determine its own policy for creating and -using graphics contexts. Depending on the display hardware and the -server implementation, creating a new graphics context can be more or -less expensive than modifying an existing one. In general, some amount -of graphics context information can be cached in the display hardware, -in which case modifying the hardware cache is faster than replacing -it. Typical display hardware can cache only a small number of graphics -contexts. Graphics output is fastest when only a few graphics contexts -are used without heavy modifications. - -This section explains the CLX functions used to: - -@itemize @bullet - -@item Create a graphics context - -@item Return the contents of a graphics context - -@item Change the contents of a graphics context - -@item Copy a graphics context - -@item Free a graphics context -@end itemize - - -@menu -* Creating Graphics Contexts:: -* Graphics Context Attributes:: -* Copying Graphics Contexts:: -* Destroying Graphics Contexts:: -* Graphics Context Cache:: -@end menu - -@node Creating Graphics Contexts, Graphics Context Attributes, Graphics Contexts, Graphics Contexts -@section Creating Graphics Contexts - -To create a graphics context, use @var{create-gcontext}. - -@defun create-gcontext &key :arc-mode :background (:cache-p t) :cap-style :clip-mask :clip-ordering :clip-x :clip-y :dash-offset :dashes :drawable :exposures :fill-rule :fill-style :font :foreground :function :join-style :line-style :line-width :plane-mask :stipple :subwindow-mode :tile :ts-x :ts-y - -@table @var -@item :cache-p -Specifies if this graphics context should be cached locally by CLX. If -@var{nil} then the state is not cached, otherwise a local cache is -kept. -@item :drawable -The @var{drawable} whose root and depth are to be associated with -this graphics context. This is a required keyword argument. -@item :arc-mode -@itemx :background -@itemx :cap-style -@itemx :clip-mask -@itemx :clip-ordering -@itemx :clip-x -@itemx :clip-y -@itemx :dash-offset -@itemx :dashes -@itemx :exposures -@itemx :fill-rule -@itemx :fill-style -@itemx :font -@itemx :foreground -@itemx :function -@itemx :join-style -@itemx :line-style -@itemx :line-width -@itemx :plane-mask -@itemx :stipple -@itemx :subwindow-mode -@itemx :tile -@itemx :ts-x -@itemx :ts-y -Initial attribute values for the graphics context. -@end table - -Creates, initializes, and returns a graphics context -(@var{gcontext}). The graphics context can only be used with -destination drawables having the same root and depth as the specified -@var{:drawable}. If @var{:cache-p} is non-@var{nil}, the graphics -context state is cached locally, and changing a component has no -effect unless the new value differs from the cached value. Changes to -a graphics context (@code{setf} and @var{with-gcontext}) are always -deferred regardless of the cache mode and sent to the server only when -required by a local operation or by an explicit call to -@var{force-gcontext-changes}. - -All of the graphics context components are set to the values that are -specified by the keyword arguments, except that a value of @var{nil} -causes the default value to be used. These default values are as -follows: - -@multitable {Component} {Default Value} -@item @var{arc-mode} @tab @var{:pie-slice} -@item @var{background} @tab 1 -@item @var{cap-style} @tab @var{:butt} -@item @var{clip-mask} @tab @var{:none} -@item @var{clip-ordering} @tab @var{:unsorted} -@item @var{clip-x} @tab 0 -@item @var{clip-y} @tab 0 -@item @var{dash-offset} @tab 0 -@item @var{dashes} @tab 4 (that is, the list '(4, 4)) -@item @var{exposures} @tab @var{:on} -@item @var{fill-rule} @tab @var{:even-odd} -@item @var{fill-style} @tab @var{:solid} -@item @var{font} @tab server dependent -@item @var{foreground} @tab 0 -@item @var{function} @tab @var{boole-1} -@item @var{join-style} @tab @var{:miter} -@item @var{line-style} @tab @var{:solid} -@item @var{line-width} @tab 0 -@item @var{plane-mask} @tab A bit mask of all ones -@item @var{stipple} @tab Pixmap of unspecified size filled with ones -@item @var{subwindow-mode} @tab @var{:clip-by-children} -@item @var{tile} @tab Pixmap of an unspecified size filled with the foreground pixel (that is, the client-specified pixel if any, or else 0) -@item @var{ts-x} @tab 0 -@item @var{ts-y} @tab 0 -@end multitable - - -Note that foreground and background do not default to any values that -are likely to be useful on a color display. Since specifying a -@var{nil} value means use the default, this implies for clip-mask that -an empty rectangle sequence cannot be specified as an empty list; -@var{:none} must be used instead. Specifying a @var{stringable} for -font causes an implicit @var{open-font} call to occur. - -@table @var -@item gcontext -Type @var{gcontext}. -@end table - -@end defun - - -@node Graphics Context Attributes, Copying Graphics Contexts, Creating Graphics Contexts, Graphics Contexts -@section Graphics Context Attributes - -The following paragraphs describe the CLX functions used to return or -change the attributes of a @var{gcontext}. Functions that return the -contents of a @var{gcontext} return @var{nil} if the last value stored -is unknown (for example, if the @var{gcontext} was not cached or if -the @var{gcontext} was not created by the inquiring client). - -@defun gcontext-arc-mode gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the arc-mode attribute of the -specified graphics context. - -The arc-mode attribute of a graphics context controls the kind of -filling, if any, to be done by the @var{draw-arcs} function. A value -of @var{:chord} specifies that arcs are filled inward to the chord -between the end points of the arc. @var{:pie-slice} specifies that -arcs are filled inward to the center point of the arc, creating a pie -slice effect. - -@table @var -@item arc-mode -Either @var{:chord} or @var{:pie-slice}. -@end table - -@end defun - - -@defun gcontext-background gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the background attribute of the -specified graphics context. - -The background attribute specifies the pixel value drawn for pixels -that are not set in a bitmap and for pixels that are cleared by a -graphics operation, such as the gaps in dashed lines. - -@table @var -@item background -Type @var{card32}. -@end table - -@end defun - - -@defun gcontext-cache-p gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the local cache mode for the -@emph{gcontext}. If true, the state of the @emph{gcontext} is cached -by CLX and changes to its attributes have no effect unless the new -value differs from its cached value. - -@table @var -@item cache-p -Type @var{boolean}. -@end table - -@defun gcontext-cap-style gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the cap-style attribute of the -specified graphics context. - -The cap-style attribute of a graphics context defines how the end -points of a path are drawn. The possible values and their -interpretations are as follows: -@multitable {Cap-Style} {Interpretations} -@item @var{:butt} -@tab Square at the end point (perpendicular to the slope of the line) with no projection beyond. - -@item @var{:not-last} -@tab -Equivalent to @var{:butt}, except that for a line-width of zero or one -the final end point is not drawn. - -@item @var{:projecting} -@tab -Square at the end, but the path continues beyond the end point for a -distance equal to half the line-width. This is equivalent to -@var{:butt} for line-width zero or one. - -@item @var{:round} -@tab -A circular arc with the radius equal to 1/2 of the line-width, -centered on the end point. This is equivalent to @var{:butt} for -line-width zero or one. -@end multitable - -The following table describes what happens when the end points of a -line are identical. The effect depends on both the cap style and line -width. - -@multitable {Cap-Style} {Line-Width} {Effect} -@item @var{:butt} @tab thin -@tab -Device dependent, but the desired effect is that a single pixel is -drawn. - -@item @var{:butt} @tab wide -@tab -Nothing is drawn. - -@item @var{:not-last} @tab thin -@tab -Device dependent, but the desired effect is that nothing is drawn. - -@item @var{:projecting} @tab thin -@tab -Same as @var{:butt} with thin line-width. - -@item @var{:projecting} @tab wide -@tab -The closed path is a square, aligned with the coordinate axes, -centered at the end point, with sides equal to the line-width. - -@item @var{:round} @tab wide -@tab -The closed path is a circle, centered at the end point, with diameter equal to the line-width. - -@item @var{:round} @tab thin -@tab -Same as @var{:butt} with thin line-width. - -@end multitable - -@table @var -@item cap-style -One of @var{:butt}, @var{:not-last}, @var{:projecting}, or @var{:round}. -@end table - -@end defun - - -@defun gcontext-clip-mask gcontext &optional ordering - -@table @var -@item gcontext -A @var{gcontext}. -@item ordering -One of @var{:unsorted}, @var{:y-sorted}, @var{:yx-banded}, @var{:yx-sorted}, or @var{nil}. -@end table - -Returns and (with @code{setf}) changes the clip-mask attribute of the -graphics context. - -When changing the clip-mask attribute, the new clip-mask can be -specified as a pixmap or a @var{rect-seq} or as the values @var{:none} -or @var{nil}. The ordering argument can be specified only with -@code{setf} when the new clip-mask is a @var{rect-seq}. - -The clip-mask attribute of a graphics context affects all graphics -operations and is used to restrict output to the destination -drawable. The clip-mask does not clip the source of a graphics -operation. A value of @var{:none} for clip-mask indicates that no -clipping is to be done. - -If a pixmap is specified as the clip-mask, it must have depth one and -the same root as the specified graphics context. Pixels where the -clip-mask has a one bit are drawn. Pixels outside the area covered by -the clip-mask or where the clip-mask has a zero bit are not drawn. - -If a sequence of rectangles is specified as the clip-mask, the output -is clipped to remain contained within the rectangles. The rectangles -should be non-intersecting, or the results of graphics operations will -be undefined. The rectangle coordinates are interpreted relative to -the clip origin. Note that the sequence of rectangles can be empty, -which effectively disables output. This is the opposite of setting the -clip-mask to @var{:none}. - -If known by the client, the ordering of clip-mask rectangles can be -specified to provide faster operation by the server. A value of -@var{:unsorted} means the rectangles are in arbitrary order. A value -of @var{:y-sorted} means that the rectangles are non-decreasing in -their Y origin. A @var{:yx-sorted} value is like @var{:y-sorted} with -the additional constraint that all rectangles with an equal Y origin -are non-decreasing in their X origin. A @var{:yx-banded} value -additionally constrains @var{:yx-sorted} by requiring that, for every -possible Y scan line, all rectangles that include that scan line have -an identical Y origins and Y extents. If incorrect ordering is -specified, the X server may generate an error, but it is not required -to do so. If no error is generated, the results of the graphics -operations are undefined. - - - -@end defun - - -@defun gcontext-clip-x gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the clip-x attribute of the -specified graphics context. - -The clip-x and clip-y attributes specify the origin for the clip-mask, -whether it is a pixmap or a sequence of rectangles. These coordinates -are interpreted relative to the origin of whatever destination -drawable is specified in a graphics operation. - -@table @var -@item clip-x -Type @var{int16}. -@end table - -@end defun - -@defun gcontext-clip-y gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the clip-y attribute of the -specified graphics context. - -The clip-x and clip-y attributes specify the origin for the clip-mask, -whether it is a pixmap or a sequence of rectangles. These coordinates -are interpreted relative to the origin of whatever destination -drawable is specified in a graphics operation. -@table @var -@item clip-y -Type @var{int16}. -@end table - -@end defun - - -@defun gcontext-dash-offset gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the dash-offset attribute of the -specified graphics context. - -The dash-offset attribute of a graphics context defines the phase of -the pattern contained in the dashes attribute. This phase specifies -how many elements (pixels) into the path the pattern should actually -begin in any single graphics operation. Dashing is continuous through -path elements combined with a join-style, but is reset to the -dash-offset each time a cap-style is applied at a line end point. -@table @var -@item dash-offset -Type @var{card16}. -@end table - -@end defun - - -@defun gcontext-dashes gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the dashes attribute of the -specified graphics context. The sequence must be non-empty and the -elements must be non-zero @var{card8} values. - -The dashes attribute in a graphics context specifies the pattern that -is used for graphics operations which use the dashed line styles. It -is a non-@var{nil} sequence with each element representing the length -of a single dash or space. The initial and alternating elements of the -dashes are the even dashes, while the others are the odd dashes. An -odd length sequence is equivalent to the same sequence concatenated -with itself to produce an even length sequence. All of the elements of -a dashes sequence must be non-zero. - -Specifying a single integer value, @emph{N}, for the dashes attribute -is an abbreviated way of specifying a two element sequence with both -elements equal to the specified value [@emph{N}, @emph{N}]. - -The unit of measure for dashes is the same as in the ordinary -coordinate system. Ideally, a dash length is measured along the slope -of the line, but server implementations are only required to match -this ideal for horizontal and vertical lines. -@table @var -@item dashes -Type @var{sequence} or @var{card8}. -@end table - -@end defun - - -@defun gcontext-display gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns the @var{display} object associated with the specified -@emph{gcontext}. -@table @var -@item display -Type @var{display}. -@end table - -@end defun - - -@defun gcontext-equal gcontext-1 gcontext-2 - -@table @var -@item gcontext-1 -@itemx gcontext-2 -A @var{gcontext}. -@end table - -Returns true if the two arguments refer to the same server resource, -and @var{nil} if they do not. -@table @var -@item equal-p -Type @var{boolean}. -@end table - -@end defun - - -@defun gcontext-exposures gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the exposures attribute of the -specified graphics context. - -The exposures attribute in a graphics context controls the generation -of @var{:graphics-exposure} events for calls to the @var{copy-area} -and @var{copy-plane} functions. If @var{:on}, -@var{:graphics-exposure} events will be reported when calling the -@var{copy-area} and @var{copy-plane} functions with this graphics -context. Otherwise, if @var{:off}, the events will not be reported. -@table @var -@item exposures -Either @var{:off} or @var{:on}. -@end table - -@end defun - - -@defun gcontext-fill-rule gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the fill-rule attribute of the -specified graphics context. - -The fill-rule attribute in a graphics context specifies the rule used -to determine the interior of a filled area. It can be specified as -either @var{:even-odd} or @var{:winding}. - -The @var{:even-odd} rule defines a point to be inside if any infinite -ray starting at the point crosses the border an odd number of -times. Tangencies do not count as a crossing. - -The @var{:winding} rule defines a point to be inside if any infinite -ray starting at the point crosses an unequal number of clockwise and -counterclockwise directed border segments. A clockwise directed border -segment crosses the ray from left to right as observed from the -point. A counterclockwise segment crosses the ray from right to left -as observed from the point. The case where a directed line segment is -coincident with the ray is uninteresting because you can simply choose -a different ray that is not coincident with a segment. - -For both @var{:even-odd} and @var{:winding}, a point is infinitely small, and the border is an -infinitely thin line. A pixel is inside if the center point of the pixel is inside, and the center -point is not on the border. If the center point is on the border, the pixel is inside if, and -only if, the polygon interior is immediately to its right (x increasing direction). Pixels -with centers along a horizontal edge are a special case and are inside if, and only if, the -polygon interior is immediately below (y increasing direction). -@table @var -@item fill-rule -Either @var{:even-odd} or @var{:winding}. -@end table - -@end defun - -@defun gcontext-fill-style gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the fill-style attribute of the -specified graphics context. - -The fill-style attribute of a graphics context defines the contents of -the source for line, text, and fill graphics operations. It determines -whether the source image is drawn with a solid color, a tile, or a -stippled tile. The possible values and their meanings are as follows: - -@table @var -@item :opaque-stippled -Filled with a tile with the same width and height as stipple, but with -the background value used everywhere stipple has a zero and the -foreground pixel value used everywhere stipple has a one. - -@item :solid -Filled with the foreground pixel value. - -@item :stippled -Filled with the foreground pixel value masked by stipple. - -@item :tiled -Filled with tile. -@end table - - -When drawing lines with line-style @var{:double-dash}, the filling of -the odd dashes are controlled by the fill-style in the following -manner: - -@table @var -@item :opaque-stippled -Same as for even dashes. - -@item :solid -Filled with the background pixel value. - -@item :stippled -Filled with the background pixel value masked by stipple. - -@item :tiled -Filled the same as the even dashes. -@end table - -@table @var -@item fill-style -One of @var{:opaque-stippled}, @var{:solid}, @var{:stippled}, or @var{:tiled}. -@end table - -@end defun - - -@defun gcontext-font gcontext &optional metrics-p - -@table @var -@item gcontext -A @var{gcontext}. - -@item metrics-p -Specifies whether a pseudo-font is returned when the real font stored -in the graphics context is not known. The default is @var{nil}, which -means do not return a pseudo-font. -@end table - -Returns and (with @code{setf}) changes the @emph{font} attribute of the -specified graphics context. If the stored font is known, it is -returned. If it is not known and the @emph{metrics-p} argument is -@var{nil}, then @var{nil} is returned. If the font is not known and -@emph{metrics-p} is true, then a pseudo-font is constructed and -returned. For a constructed pseudo-font, full metric and property -information can be obtained, but it does not have a name or a resource -ID, and attempts to use it where a resource ID is required results in -an invalid-font error. - -The font attribute in a graphics context defines the default text font -used in text drawing operations. When setting the value of the font -attribute, either a @var{font} object or a font name can be used. If a -font name is passed, @var{open-font} is call automatically to get the -@var{font} object. - -@table @var -@item font -Type @var{font} or @var{null}. -@end table -@end defun - -@end defun - - - -@defun gcontext-foreground gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the foreground attribute of the -specified graphics context. - -The foreground attribute of a graphics context specifies the pixel -value drawn for set bits in a bitmap and for bits set by a graphics -operation. -@table @var -@item foreground -Type @var{card32}. -@end table - -@end defun - - -@defun gcontext-function gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns the @emph{function} of the specified graphics context. - -In all graphic operations, given a source pixel and a corresponding -destination pixel, the resulting pixel drawn is computed bitwise on -the bits of the source and destination pixels. That is, a logical -operation is used to combine each bit plane of corresponding source -and destination pixels. The graphics context function attribute -specifies the logical operation used via one of the 16 operation codes -defined by Common Lisp for the @var{boole} function. - -The following table shows each of the logical operation codes that can -be given by the function attribute. For each operation code, its -result is shown as a logical function of a source pixel @emph{S} and a -destination pixel @emph{D}. - -@multitable {Symbol} {Result} -@item @var{boole-1} -@tab @emph{S} -@item @var{boole-2} -@tab @emph{D} -@item @var{boole-andc1} -@tab (logandc1 @emph{S D}) -@item @var{boole-andc2} -@tab (logandc2 @emph{S D}) -@item @var{boole-and} -@tab (logand @emph{S D}) -@item @var{boole-c1} -@tab (lognot @emph{S}) -@item @var{boole-c2} -@tab (lognot @emph{D}) -@item @var{boole-clr} -@tab 0 -@item @var{boole-eqv} -@tab (logeqv @emph{S D}) -@item @var{boole-ior} -@tab (logior @emph{S D}) -@item @var{boole-nand} -@tab (lognand @emph{S D}) -@item @var{boole-nor} -@tab (lognor @emph{S D}) -@item @var{boole-orc1} -@tab (logorc1 @emph{S D}) -@item @var{boole-orc2} -@tab (logorc2 @emph{S D}) -@item @var{boole-set} -@tab 1 -@item @var{boole-xor} -@tab (logxor @emph{S D}) -@end multitable - -@table @var -@item function -Type @var{boole-constant}. -@end table - -@end defun - - -@defun gcontext-id gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns the unique ID that has been assigned to the specified graphics -context. -@table @var -@item id -Type @var{resource-id}. -@end table - -@end defun - - -@defun gcontext-join-style gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the join-style attribute of the -specified graphics context. - -The join-style attribute of a graphics context defines how the segment -intersections are drawn for wide polylines. The possible values and -their interpretations are as follows: - -@table @var -@item :bevel -Uses @var{:butt} end point styles with the triangular notch filled. -@item :miter -The outer edges of two lines extend to meet at an angle. -@item :round -A circular arc with diameter equal to the line-width, centered on the join point. -@end table - -When the end points of a polyline segment are identical, the effect is -as if the segment was removed from the polyline. When a polyline is a -single point, the effect is the same as when the cap-style is applied -at both end points. - -@table @var -@item join-style -One of @var{:bevel}, @var{:miter}, or @var{:round}. -@end table - -@end defun - - -@defun gcontext-line-style gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the line-style attribute of the -specified graphics context. - -The line-style attribute of a graphics context specifies how (which -sections of) lines are drawn for a path in graphics operations. The -possible values and their meanings are as follows: - -@table @var -@item :solid -The full path is drawn. - -@item :double-dash -The full path is drawn, but the even dashes are filled differently -than the odd dashes. The @var{:butt} style is used where even and odd -dashes meet (see paragraph 5.4.7, Fill-Rule and -Fill-Style). - -@item :on-off-dash -Only the even dashes are drawn, with cap-style applied to all internal -ends of the individual dashes, except @var{:not-last} is treated as -@var{:butt}. -@end table - -@table @var -@item line-style -One of @var{:dash}, @var{:double-dash}, or @var{:solid}. -@end table - -@end defun - - -@defun gcontext-line-width gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns the @emph{line-width} of the specified graphics context. - -The line-width is measured in pixels and can be greater than or equal -to one (wide line) or can be the special value zero (thin line). - -Wide lines are drawn centered on the path described by the graphics -operation. Unless otherwise specified by the join-style or cap-style, -the bounding box of a wide line with end points [x1, y1], [x2, y2], -and width w is a rectangle with vertices at the following real -coordinates: - -[x1 - (w*@emph{sin}/2), y1 + (w*@emph{cos}/2)], [x1+ (w*@emph{sin}/2), y1 - (w*@emph{cos}/2)],@* -[x2 - (w*@emph{sin}/2), y2 + (w*@emph{cos}/2)], [x2 + (w*@emph{sin}/2), y2 - (w*@emph{cos}/2)] - -where @emph{sin} is the sine of the angle of the line and @emph{cos} -is the cosine of the angle of the line. A pixel is part of the line -and, hence, is drawn if the center of the pixel is fully inside the -bounding box (which is viewed as having infinitely thin edges). If the -center of the pixel is exactly on the bounding box, it is part of the -line if, and only if, the interior is immediately to its right (x -increasing direction). Pixels with centers on a horizontal edge are a -special case and are part of the line if, and only if, the interior is -immediately below (y increasing direction). - -Thin lines (zero line-width) are always one pixel wide lines drawn -using an unspecified, device dependent algorithm. There are only two -constraints on this algorithm. - -@enumerate -@item -If a line is drawn unclipped from [x1,y1] to [x2,y2] and if another -line is drawn unclipped from [x1+dx,y1+dy] to [x2+dx,y2+dy], a point -[x,y] is touched by drawing the first line if, and only if, the -point [x+dx,y+dy] is touched by drawing the second line. - -@item -The effective set of points comprising a line cannot be affected by -clipping. That is, a point is touched in a clipped line if, and only -if, the point lies inside the clipping region and the point would be -touched by the line when drawn unclipped. -@end enumerate - - -A wide line drawn from [x1,y1] to [x2,y2] always draws the same pixels -as a wide line drawn from [x2,y2] to [x1,y1], not counting cap-style -and join-style. Implementors are encouraged to make this property true -for thin lines, but it is not required. A line-width of zero may -differ from a line-width of one in which pixels are drawn. This -permits the use of many manufacturer's line drawing hardware, which -may run much faster than the more precisely specified wide lines. - -In general, drawing a thin line is faster than drawing a wide line of -width one. However, because of their different drawing algorithms, -thin lines may not mix well, aesthetically speaking, with wide -lines. If it is desirable to obtain precise and uniform results across -all displays, a client should always use a line-width of one, rather -than a line-width of zero. -@table @var -@item line-width -Type @var{card16}. -@end table - -@end defun - - -@defun gcontext-p gcontext - -@table @var -@item gcontext -Type @var{boolean}. -@end table - - - -Returns non-@var{nil} if the argument is a graphics context and - -@end defun - - - - -@defun gcontext-plane-mask gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns the @emph{plane-mask} of the specified graphics context. - -The plane-mask attribute of a graphics context specifies which bit -planes of the destination drawable are modified during a graphic -operation. The plane-mask is a pixel value in which a 1 bit means that -the corresponding bit plane will be modified and a 0 bit means that -the corresponding bit plane will not be affected during a graphic -operations. Thus, the actual result of a graphic operation depends on -both the function and plane-mask attributes of the graphics context -and is given by the following expression: - -@lisp -(logior (logand - (boole function source destination) - plane-mask) - - (logandc2 - destination - plane-mask)) -@end lisp - -@table @var -@item plane-mask -Type @var{card32}. -@end table - -@end defun - - -@defun gcontext-plist gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - - - -Returns and (with @code{setf}) sets the property list for the specified -@emph{gcontext}. This function provides a hook where extensions can -add data. - -@table @var -@item gcontext-p -Type @var{list}. -@end table - -@end defun - - -@defun gcontext-stipple gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns the @emph{stipple} of the specified graphics context. - -The stipple attribute of a graphics context is a bitmap used to -prevent certain pixels in the destination of graphics operations from -being affected by tiling. - -The stipple and tile have the same origin. This origin point is -interpreted relative to the origin of whatever destination drawable is -specified in a graphics request. The stipple pixmap must have depth -one and must have the same root as the graphics context. The tile -pixmap must have the same root and depth as the graphics context. For -stipple operations where the fill-style is @var{:stippled} (but not -@var{:opaque-stippled}), the stipple pattern is tiled in a single -plane and acts as an additional clip mask to be @var{and}ed with the -clip-mask. Any size pixmap can be used for stipple or tile, although -some sizes may be faster to use than others. - -Specifying a pixmap for stipple or tile in a graphics context might or -might not result in a copy being made. If the pixmap is later used as -the destination for a graphics operation, the change might or might -not be reflected in the graphics context. If the pixmap is used both -as the destination for a graphics operation and as a stipple or tile, -the results are not defined. - -Some displays have hardware support for tiling or stippling with -patterns of specific sizes. Tiling and stippling operations that -restrict themselves to those sizes may run much faster than such -operations with arbitrary size patterns. CLX provides functions to -determine the best size for stipple or tile (see -@var{query-best-stipple} and @var{query-best-tile}). - -@table @var -@item stipple -Type @var{pixmap}. -@end table - -@end defun - - -@defun gcontext-subwindow-mode gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns and (with @code{setf}) changes the subwindow-mode attribute of -the specified graphics context. - -The subwindow-mode attribute of a graphics context specifies whether -subwindows obscure the contents of their parent window during a -graphics operation. For a value of @var{:clip-by-children}, both -source and destination windows are clipped by all viewable -@var{:input-output} class children. This clipping is in addition to -the clipping provided by the clip-mode attribute. For a value of -@var{:include-inferiors}, neither the source nor destination window -is clipped by its inferiors. This results in the inclusion of -subwindow contents in the source and the drawing through of subwindow -boundaries of the destination. The use of @var{:include-inferiors} on -a window of one depth with mapped inferiors of differing depth is not -illegal, but the semantics are not defined by the core protocol. -@table @var -@item subwindow-mode -One of @var{:clip-by-children} or @var{:include-inferiors}. -@end table - -@end defun - - -@defun gcontext-tile gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns the @emph{tile} of the specified graphics context. - -The tile attribute is a pixmap used to fill in areas for graphics -operations. It is so named because copies of it are laid out side by -side to fill the area. - -The stipple and tile have the same origin. This origin point is -interpreted relative to the origin of whatever destination drawable is -specified in a graphics request. The stipple pixmap must have depth -one and must have the same root as the graphics context. The tile -pixmap must have the same root and depth as the graphics context. For -stipple operations where the fill-style is @var{:stippled} (but not -@var{:opaque-stippled}), the stipple pattern is tiled in a single -plane and acts as an additional clip mask to be @var{and}ed with the -clip-mask. Any size pixmap can be used for stipple or tile, although -some sizes may be faster to use than others. - -Specifying a pixmap for stipple or tile in a graphics context might or -might not result in a copy being made. If the pixmap is later used as -the destination for a graphics operation, the change might or might -not be reflected in the graphics context. If the pixmap is used both -as the destination for a graphics operation and as a stipple or tile, -the results are not defined. - -Some displays have hardware support for tiling or stippling with -patterns of specific sizes. Tiling and stippling operations that -restrict themselves to those sizes may run much faster than such -operations with arbitrary size patterns. CLX provides functions to -determine the best size for stipple or tile (see -@var{query-best-stipple} and @var{query-best-tile}). -@table @var -@item tile -Type @var{pixmap}. -@end table - -@end defun - - -@defun gcontext-ts-x gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns the @emph{ts-x} attribute of the specified graphics context. - -The ts-x and ts-y attributes of a graphics context are the coordinates -of the origin for tile pixmaps and the stipple. -@table @var -@item ts-x -Type @var{int16}. -@end table - -@end defun - - -@defun gcontext-ts-y gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Returns the @emph{ts-y} attribute of the specified graphics context. - -The ts-x and ts-y attributes of a graphics context are the coordinates -of the origin for tile pixmaps and the stipple. -@table @var -@item ts-y -Type @var{int16}. -@end table - -@end defun - - -@defun query-best-stipple width height drawable - -@table @var -@item width -@itemx height -Specifies the width and height of the desired stipple pattern. -@item drawable -A @var{drawable}. -@end table - -Returns the @emph{best-width} and @emph{best-height} for stipple -pixmaps on the @emph{drawable}. - -The @emph{drawable} indicates the screen and possibly the window class -and depth. An @var{:input-only} window cannot be specified as the -@emph{drawable}. The size is returned as width and height values. - -@table @var -@item best-width -@itemx best-height -Type @var{card16}. -@end table - -@end defun - - -@defun query-best-tile width height drawable - -@table @var -@item width -@itemx height -Specifies the width and height of the desired tile pattern. -@item drawable -A @var{drawable}. -@end table - -Returns the @emph{best-width} and @emph{best-height} for tile pixmaps -on the @emph{drawable}. - -The @emph{drawable} indicates the screen and possibly the window class -and depth. An @var{:input-only} window cannot be specified as the -@emph{drawable}. The size is returned as width and height values. - -@table @var -@item best-width -@itemx best-height -Type @var{card16}. -@end table - -@end defun - - -@node Copying Graphics Contexts, Destroying Graphics Contexts, Graphics Context Attributes, Graphics Contexts -@section Copying Graphics Contexts - -CLX provides functions to copy some or all attribute values from one -graphics context to another. These functions are generally more -efficient than using @code{setf} to copy @var{gcontext} attributes -individually. - -@defun copy-gcontext source destination - -@table @var -@item source -The source @var{gcontext}. -@item destination -The destination @var{gcontext}. -@end table - -Copies all the values of the attributes of the source graphics context -into the destination graphics context. The source and destination -graphics contexts must have the same root and depth. - - - -@end defun - - -@defun copy-gcontext-components source destination &rest keys - -@table @var -@item source -The source @var{gcontext}. -@item destination -The destination @var{gcontext}. - -@item keys -The remaining arguments are keywords, of type @var{gcontext-key}, -which specify which attributes of the graphics context are to be -copied. -@end table - -Copies the values of the specified attributes of the source graphics -context to the destination graphics context. The source and -destination graphics contexts must have the same root and depth. - - -@end defun - - -@node Destroying Graphics Contexts, Graphics Context Cache, Copying Graphics Contexts, Graphics Contexts -@section Destroying Graphics Contexts - -To destroy a graphics context, use @var{free-gcontext.} - -@defun free-gcontext gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Deletes the association between the assigned resource ID and the -specified graphics context, and then destroys the graphics context. - - -@end defun - - -@node Graphics Context Cache, , Destroying Graphics Contexts, Graphics Contexts -@section Graphics Context Cache - -CLX provides a set of functions to control the automatic graphics context -caching mechanism. - - -@defun force-gcontext-changes gcontext - -@table @var -@item gcontext -A @var{gcontext}. -@end table - -Forces any delayed changes to the specified graphics context to be -sent out to the server. Note that @var{force-gcontext-changes} is -called by all of the graphics functions. - - - -@end defun - -@defmac with-gcontext gcontext &key :arc-mode :background :cap-style :clip-mask :clip-ordering :clip-x :clip-y :dashes :dash-offset :exposures :fill-rule :fill-style :font :foreground :function :join-style :line-style :line-width :plane-mask :stipple :subwindow-mode :tile :ts-x :ts-y &allow-other-keys &body body -@anchor{with-gcontext} - -Changes the indicated graphics context components to the specified -values only within the dynamic extent of the body. @var{with-gcontext} -works on a per-process basis in a multiprocessing environment. The -@emph{body} is not surrounded by a @var{with-display} form. If there -is no local cache for the specified graphics context, or if some of -the component states are unknown, @var{with-gcontext} does the save -and restore by creating a temporary graphics context and copying -components to and from it using @var{copy-gcontext-components}. - -@table @var -@item gcontext -A @var{gcontext}. -@item :arc-mode -@itemx :background -@itemx :cap-style -@itemx :clip-mask -@itemx :clip-ordering -@itemx :clip-x -@itemx :clip-y -@itemx :dashes -@itemx :dash-offset -@itemx :exposures -@itemx :fill-rule -@itemx :fill-style -@itemx :font -@itemx :foreground -@itemx :function -@itemx :join-style -@itemx :line-style -@itemx :line-width -@itemx :plane-mask -@itemx :stipple -@itemx :subwindow-mode -@itemx :tile -@itemx :ts-x -@itemx :ts-y -These keyword arguments and associated values specify which graphics -context components are to be changed. Any components not specified are -left unmodified. @xref{Creating Graphics Contexts}, for more information. -@item body -The body of code which will have access to the altered graphics context. -@end table - -@end defmac - -@node Graphic Operations, Images, Graphics Contexts, Top -@chapter Graphic Operations - -Once connected to an X server, a client can use CLX functions to -perform graphic operations on drawables. - -This section describes CLX functions to: - -@itemize @bullet - -@item Operate on areas and planes - -@item Draw points - -@item Draw lines - -@item Draw rectangles - -@item Draw arcs - -@item Draw text - -@end itemize - - -@menu -* Area and Plane Operations:: -* Drawing Points:: -* Drawing Lines:: -* Drawing Rectangles:: -* Drawing Arcs:: -* Drawing Text:: -@end menu - -@node Area and Plane Operations, Drawing Points, Graphic Operations, Graphic Operations -@section Area and Plane Operations - - -@var{clear-area} clears an area or an entire window to the background. -Since pixmaps do not have backgrounds, they cannot be filled by using -the functions described in the following paragraphs. Instead, you -should use @var{draw-rectangle}, which sets the pixmap to a known -value. @xref{Drawing Rectangles}, for information on -@var{draw-rectangle}. - -@defun clear-area window &key (:x 0) (:y 0) :width :height :exposures-p - -@table @var -@item window -A @var{window}. - -@item :x -@itemx :y -Upper-left corner of the area to be cleared. These coordinates are -relative to the @emph{window} origin. Type is @var{int16}. - -@item :width -The width of the area to clear or @var{nil} to clear to the remaining -width of the window. Type is @var{card16} or @var{null}. - -@item :height -The height of the area to clear or @var{nil} to clear to the remaining -height of the window. Type is @var{card16} or @var{null}. - -@item :exposures-p -Specifies if @var{:exposure} events should be generated for the -affected areas. Type @var{boolean}. -@end table - -Draws a rectangular area in the specified @emph{window} with the -background pixel or pixmap of the @emph{window}. The @var{:x} and -@var{:y} coordinates are relative to the @emph{window} origin, and -specify the upper-left corner of the rectangular area that is to be -cleared. A @var{nil} or zero value for @var{:height} or @var{:width} -clears the remaining area (height - y or width - x). If the -@emph{window} has a defined background tile, the rectangle is tiled by -using a plane-mask of all ones and a function of @var{:copy}. If the -@emph{window} has background @var{:none}, the contents of the -@emph{window} are not changed. In either case, if @var{:exposures-p} -is non-@var{nil}, then one or more @var{:exposure} events are -generated for regions of the rectangle that are either visible or are -being retained in a backing store. - -To clear the entire area in a specified @emph{window}, use -(@var{clear-area} @emph{window}). - - -@end defun - -@defun copy-area source gcontext source-x source-y width height destination destination-x destination-y - -@table @var -@item source -Source @var{drawable}. - -@item gcontext -The graphics context to use during the copy operation. - -@item source-x -@itemx source-y -The x and y coordinates of the upper-left corner of the area in the -@emph{source} @var{drawable}. These coordinates are relative to the -@emph{source} @var{drawable} origin. Type is @var{int16}. - -@item width -@itemx height -The width and height of the area being copied. These apply to both the -@emph{source} and @emph{destination} areas. Type is @var{card16}. - -@item destination -The destination @var{drawable}. - -@item destination-x -@itemx destination-y -The x and y coordinates of the upper left corner of the area in the -@emph{destination} @var{drawable}. These coordinates are relative to -the @emph{destination} @var{drawable} origin. Type is @var{int16}. -@end table - -Copies the specified rectangular area from the @emph{source} -@var{drawable} to the specified rectangular area of the -@emph{destination} @var{drawable}, combining them as specified in the -supplied graphics context (@emph{gcontext}). The @emph{x} and @emph{y} -coordinates are relative to their respective drawable origin, with -each pair specifying the upper left corner of the area. - -If either regions of the @emph{source} area are obscured and have not -been retained in backing store, or regions outside the boundaries of -the @emph{source} @var{drawable} are specified, those regions are not -copied. Instead, the following occurs on all corresponding -@emph{destination} regions that are either visible or are retained in -backing store: - -@itemize @bullet - -@item -If the @emph{destination} rectangle is a window with a background -other than @var{:none}, these corresponding regions of the -@emph{destination} are tiled, using plane-mask of all ones and -function of @var{boole-1} (copy source), with that background. - -@item -If the exposures attribute of the graphics context is @var{:on}, -then @var{:graphics-exposure} events for all corresponding -@emph{destination} regions are generated (regardless of tiling or -whether the @emph{destination} is a window or a pixmap). - -@item -If exposures is @var{:on} but no regions are exposed, a -@var{:no-exposure} event is generated. Note that by default, -exposures is @var{:on} for new graphics contexts. @xref{Graphics Contexts}, for further information. - -@end itemize - - -@end defun - -@defun copy-plane source gcontext plane source-x source-y width height destination destination-x destination-y - -@table @var -@item source -The source @var{drawable}. -@item gcontext -The graphics context to use during the copy operation. -@item plane -Specifies the bit-plane of the @emph{source} @var{drawable}. Exactly one bit must be set. -Type is @var{pixel}. -@item source-x -@itemx source-y -The @emph{x} and @emph{y} coordinates of the upper-left corner of the -area in the @emph{source} @var{drawable}. These coordinates are -relative to the @emph{source} @var{drawable} origin. Type is -@var{int16}. - -@item width -@itemx height -The width and height of the area being copied. These apply to both the -@emph{source} and @emph{destination} areas. Type is @var{card16}. - -@item destination -The destination @var{drawable}. - -@item destination-x -@itemx destination-y - -The x and y coordinates of the upper-left corner of the destination -area in the @emph{destination} @var{drawable}. These coordinates are -relative to the @emph{destination} @var{drawable} origin. Type is -@var{int16}. -@end table - -Uses a single bit plane of the specified rectangular area of the -@emph{source} @var{drawable} along with the specified graphics context -(@emph{gcontext}) to modify the specified rectangle area of the -@emph{destination} @var{drawabl}e. The drawables specified by the -@emph{source} and @emph{destination} arguments must have the same root -but need not have the same depth. - -Effectively, this operation forms a pixmap of the same depth as -@emph{destination} and with a size specified by the @emph{source} -area. It then uses the foreground and background from the graphics -context (foreground where the bit-plane in @emph{source} contains a -one bit, background where the bit-plane in @emph{source} contains a -zero bit), and the equivalent of a @var{copy-area} operation is -performed with all the same exposure semantics. This can also be -thought of as using the specified region of the @emph{source} -bit-plane as a stipple with a fillstyle of @var{:opaque-stippled} for -filling a rectangular area of the @emph{destination}. - - - -@end defun - -@node Drawing Points, Drawing Lines, Area and Plane Operations, Graphic Operations -@section Drawing Points - -The @var{draw-point} and @var{draw-points} functions make use of the following graphics -context components: function, plane-mask, foreground, subwindow-mode, clip-x, -clip-y, clip-ordering, clip-region and clip-mask. - -The @var{draw-point} function uses the foreground pixel and function components of the -graphics context to draw a single point into the specified drawable, while @var{draw-points} -draws multiple points into the specified drawable. These functions are not affected by -the tile or stipple in the graphics context. - - -@defun draw-point drawable gcontext x y - -@table @var -@item drawable -The destination @var{drawable}. -@item gcontext -The graphics context for drawing the point. -@item x -@itemx y -The @emph{x} and @emph{y} coordinates of the point drawn. Type is @var{int16}. -@end table -Combines the foreground pixel in the @emph{gcontext} with the pixel in -the @emph{drawable} specified by the @emph{x} and @emph{y} -coordinates. - - -@end defun - -@defun draw-points drawable gcontext points &optional relative-p - -@table @var -@item drawable -The destination @var{drawable}. -@item gcontext -The graphics context for drawing the points. -@item points -A list of points to be drawn in the order listed. The first point is always relative -to the @emph{drawable}'s origin; if @emph{relative-p}, the rest of the points are drawn relative to the -previous point, else they are drawn relative to the @emph{drawable}'s origin. Type is -@var{point-seq}. -@item relative-p -Specifies the coordinate mode used for drawing the pixels either relative to -the origin or to the previous point. Type @var{boolean}. -@end table - -Combines the foreground pixels in the graphics context with the pixels -at each point in the @emph{drawable}. The points are drawn in the -order listed. - -@var{draw-points} requires a mode argument, @emph{relative-p} that -indicates whether the points are relative to the destination origin or -to the previous point. In either case, the first point is always -relative to the destination origin. The rest of the points are -relative either to the @emph{drawable}'s origin or to the previous -point, depending on the value of @emph{relative-p}. - - -@end defun - - -@node Drawing Lines, Drawing Rectangles, Drawing Points, Graphic Operations -@section Drawing Lines - - -The @var{draw-line}, @var{draw-lines}, and @var{draw-segments} functions use the following -graphics context components: background, cap-style, clip-x-origin, clip-y-origin, -clip-mask, dash-list, dash-offset, fill-style, foreground, function, plane-mask, line-width, -line-style, stipple, subwindow-mode, tile, ts-x-origin, and ts-y-origin. - -The @var{draw-lines} function also uses the join-style graphics context component. - -@defun draw-line drawable gcontext x1 y1 x2 y2 &optional relative-p - -@table @var -@item drawable -The destination @var{drawable}. -@item gcontext -The graphics context for drawing the line. -@item x1 -@itemx y1 -@itemx x2 -@itemx y2 -The end points of the line. -@item relative-p -Specifies the coordinate mode used for drawing the line either relative to -the origin or the previous point. In either case, the first point is always drawn -relative to the @emph{drawable}'s origin. -@end table - -Draws a line from the point @emph{x1},@emph{y1} to the point -@emph{x2},@emph{y2}. When @emph{relative-p} is true, the first point -is relative to the destination origin but the second point is relative -to the first point. When @emph{relative-p} is @var{nil}, both points -are relative to the destination origin. - - -@end defun - - -@defun draw-lines drawable gcontext points &key :relative-p :fill-p (:shape :complex) - -@table @var -@item drawable -The destination @var{drawable}. -@item gcontext -The graphics context for drawing the lines. -@item points -A list of points that define the lines. Type is @var{point-seq}. -@item :relative-p -The coordinate mode of the points. -@item :fill-p -When true, a filled polygon is drawn instead of a polyline. -@item :shape -A hint that allows the server to use the most efficient area fill algorithm. -Either @var{:convex}, @var{:non-convex}, or @var{:complex}. -@end table - -Draws a line between each pair of @emph{points} in the points -list. The lines are drawn in the order listed and join correctly at -all intermediate points. The join-style graphics context component -defines the type of joint to use. When the first and last points -coincide, the first and last lines also join correctly to produce a -hollow polygon. - -When @var{:relative-p} is true, the first point is always relative to -the destination origin, but the rest are relative to the previous -point. When @var{:relative-p} is @var{nil}, the rest of the points -are drawn relative to the destination origin. - -When @var{:fill-p} is true, the polygon defined by the @emph{points} -list is filled. The @var{:shape} keyword provides the server with a -hint about how to fill the polygon. @var{:shape} can be either -@var{:complex} (by default), @var{:convex}, or @var{:non-convex}. - -The @var{:convex} operand is the simplest type of area and the -fastest to fill. A fill area is convex if every straight line -connecting any two interior points is entirely inside the area. For -example, triangles and rectangles are convex polygons. - -The @var{:non-convex} operand is for filling an area that is not -convex and is also not self-intersecting. Filling this type of area is -harder than filling a convex area, but easier than filling one that is -self-intersecting. For example, the shape of the letter "T" is -non-convex and non-self-intersecting. - -The @var{:complex} operand is the most general (and therefore the -hardest) type of fill area. A complex fill area can be non-convex and -self-intersecting. For example, draw the outline of a bow tie, without -lifting your pencil or tracing over an edge twice. This shape is -non-convex and intersects itself at the knot in the middle. - -@var{NOTE:} Unless you are sure that a shape is @var{:convex} or -@var{:non-convex}, it should always be drawn as a @var{:complex} -shape. If @var{:convex} or @var{:non-convex} is specified -incorrectly, the graphics result is undefined. - - -@end defun - - -@defun draw-segments drawable gcontext segments - -@table @var -@item drawable -The destination @var{drawable} to receive the line segments. -@item gcontext -Specifies the graphics context for drawing the lines. -@item segments -The points list for the segments to draw. Type is @var{seq}. -@end table - -Draws multiple lines, not necessarily connected. @emph{segments} is a -sequence of the form @{x1 y1 x2 y2@}*, in which each subsequence -specifies the end points of a line segment. Line segments are drawn in -the order given by @emph{segments}. Unlike @var{draw-lines}, no -joining is performed at coincident end points. - - -@end defun - - -@node Drawing Rectangles, Drawing Arcs, Drawing Lines, Graphic Operations -@section Drawing Rectangles - - -The @var{draw-rectangle} and @var{draw-rectangles} functions draw -hollow or filled outlines of the specified rectangle or rectangles as -if a five-point polyline were specified for each rectangle, as -follows: - -@display -[x,y,] [x+width,y] [x+width,y+height] [x,y+height] [x,y] -@end display - -@var{draw-rectangle} and @var{draw-rectangles} use the following -graphics context components: background, function, plane-mask, -foreground, subwindow-mode, cap-style, clip-x, clip-y, clip-ordering, -clip-region and clip-mask, dash-list, dash-offset, fill-style, -join-style, line-width, line-style, stipple, tile, ts-x-origin, and -ts-y-origin. - -@defun draw-rectangle drawable gcontext x y width height &optional fill-p - -@table @var -@item drawable -The destination @var{drawable}. - -@item gcontext -The graphics context for drawing the rectangle. - -@item x -@itemx y -The x and y coordinates that define the upper left corner of the rectangle. The -coordinates are relative to the destination origin. Type is @var{int16}. - -@item width -@itemx height -Specifies the width and height that define the outline of the rectangle. -Type is @var{card16}. - -@item fill-p -Specifies whether the rectangle is filled or not. Type @var{boolean}. -@end table - -Draws a rectangle defined by the @emph{x}, @emph{y}, @emph{width}, and - -@emph{height} arguments. - - - -@end defun - - -@defun draw-rectangles drawable gcontext rectangles &optional fill-p - -@table @var -@item drawable -The destination @var{drawable}. - -@item gcontext -The graphics context. - -@item rectangles -A list specifying the upper left corner x and y, width and height of the -rectangles. Type is @var{rect-seq}. - -@item fill-p -Specified if the rectangles are filled or not. Type is @var{boolean}. -@end table - -Draws the rectangles in the order listed in @emph{rectangles}. For the -specified @emph{rectangle} or @emph{rectangles}, no pixel is drawn -more than once. The x and y coordinates of each rectangle are relative -to the destination origin and define the upper left corner of the -rectangle. If rectangles intersect, the intersecting pixels are drawn -multiple times. - - - -@end defun - -@node Drawing Arcs, Drawing Text, Drawing Rectangles, Graphic Operations -@section Drawing Arcs - -@var{draw-arc} draws a single circular or an elliptical arc, while -@var{draw-arcs} draws multiple circular or elliptical -arcs. @var{draw-arc} and @var{draw-arcs} use the following graphics -context components: arc-mode, background, cap-style, clip-x, clip-y, -clip-mask, dash-list, dash-offset, fill-style, foreground, join-style, -function, plane-mask, line-width, line-style, stipple, subwindow-mode, -tile, ts-x-origin, and ts-y-origin. - -@defun draw-arc drawable gcontext x y width height angle1 angle2 &optional fill-p - -@table @var -@item drawable -The destination @var{drawable}. - -@item gcontext -The graphics context for drawing the arc. - -@item x -@itemx y -The x and y coordinates of the arc rectangle relative to the origin of the @emph{drawable}. -Type is @var{int16}. - -@item width -@itemx height -Specifies the width and height of the rectangle. These are the major and -minor axes of the arc. Type is @var{card16}. - -@item angle1 -Specifies the start of the arc in radians. Type is @var{angle}. - -@item angle2 -Specifies the direction and end point of the arc. Type is @var{angle}. - -@item fill-p -Specifies whether the arc is filled or not. Type @var{boolean}. -@end table - -Draws either a circular or an elliptical arc. Also, outlined or filled -arcs can be drawn. Each arc is specified by a rectangle (@emph{x}, -@emph{y}, @emph{width}, and @emph{height}) and two angles -(@emph{angle1} and @emph{angle2}). The angles are signed integers in -radians, with positive indicating counterclockwise motion and negative -indicating clockwise motion. The start of the arc is specified by -@emph{angle1}, and the path and extent of the arc is specified by -@emph{angle2} relative to the start of the arc. If the magnitude of -@emph{angle2} is greater than 360 degrees, it is truncated to 360 -degrees. The @emph{x} and @emph{y} coordinates of the rectangle are -relative to the @emph{drawable}'s origin. - -For example, an arc specified as -[@emph{x},@emph{y},@emph{width},@emph{height},@emph{angle1},@emph{angle2}] -has the origin of the major and minor axes at: - -@display -[@emph{x}+(@emph{width}/2),@emph{y}+(@emph{height}/2)] -@end display - -The infinitely thin path describing the entire circle/ellipse -intersects the horizontal axis at: - -@display -[@emph{x},@emph{y}+(@emph{height}/2)] and [@emph{x}+@emph{width},@emph{y}+(@emph{height}/2)] -@end display - -The intersection of the vertical axis is at: - -@display -[@emph{x}+(@emph{width}/2),@emph{y}] and [@emph{x}+(@emph{width}/2),@emph{y}+@emph{height}] -@end display - -These coordinates can be fractional; that is, they are not truncated -to discrete coordinates. Note that the angle values are slightly -different in CLX than in the X protocol specification. - -If @emph{fill-p} is @var{nil}, then only the outline of the arc is -drawn. Otherwise, if @emph{fill-p} is true, @var{draw-arc} fills the -area bounded by the arc outline and one or two line segments, -depending on the arc-mode. If the arc-mode is @var{:chord}, the -filled area is bounded by the arc outline and the line segment joining -the arc end points. If the arc-mode is @var{:pie-slice}, the filled -area is bounded by the arc outline and the two line segments joining -each arc end point with the center point. - - - -@end defun - - -@defun draw-arcs drawable gcontext arcs &optional fill-p - -@table @var -@item drawable -Specifies the @var{drawable} where you want the arcs drawn. -@item gcontext -Specifies the graphics context for drawing the arc. -@item arcs -A sequence containing the width, height, angle1, and angle2 arguments defining -the arcs. See @var{draw-arc} for more detail. Type is @var{arc-seq}. -@item fill-p -Specifies whether the arcs are filled or not. Type is @var{boolean}. -@end table - -Draws circular or elliptical, outlined or filled arcs. Each arc is -specified by a rectangle and two angles. For a more detailed -description, see @var{draw-arc}. - -The arcs are filled in the order listed. For any given arc, no pixel is drawn more than -once. If regions intersect, the intersecting pixels are drawn multiple times. - - -@end defun - - -@node Drawing Text, , Drawing Arcs, Graphic Operations -@section Drawing Text - -CLX provides functions for drawing text using text fonts provided by -the X server. An X font is array of character bit maps indexed by -integer codes. @xref{Font and Characters}, for a complete discussion -of the CLX functions used to manage fonts and characters. - -Since Common Lisp programs typically represent text as sequences of -characters (that is, strings), CLX text functions must be prepared to -convert a Common Lisp character into the integer code used to index the -appropriate character bitmap in a given font. The @var{:translate} -argument to a text function is a function which performs this -conversion. The default @var{:translate} function handles all -characters that satisfy @var{graphic-char-p} by converting each -character into its ASCII code. Note that the assumption made by the -default @var{:translate} function--that is, that an X font indexes -bitmaps by ASCII codes--is often valid, but other encodings are -possible. In general, a @var{:translate} function can perform complex -transformations. It can be used to convert non-character input, to -handle non-ASCII character encodings, and to change the fonts used to -access character bitmaps. The complete behavior of a @var{:translate} -function is given below by describing a prototypical -@var{translate-function}. - -CLX offers two different ways to draw text--filled text and block -text. The @var{draw-glyph} and @var{draw-glyphs} functions create -filled text, in which each character image is treated as an area to be -filled according to the fill-style of the given graphics context, -without otherwise disturbing the surrounding background. In addition, -filled text sends a complex type of server request which allows a series -of font indices, font changes, and horizontal position changes to be -compiled into a single request. Filled text functions use the following -graphics context attributes: background, clip-mask, clip-x-origin, -clip-y-origin, fill-style, font, foreground, function, plane-mask, -stipple, subwindow-mode, tile, ts-x-origin, ts-y-origin. - -Block text is a rendering style commonly used by display terminals, in -which each character image appears in the foreground pixel inside a -rectangular character cell drawn in the graphics context background -pixel. The @var{draw-image-glyph} and @var{draw-image-glyphs} -functions create block text. Block text functions use the following -graphics context attributes: background, clip-mask, clip-x-origin, -clip-y-origin, font, foreground, plane-mask, stipple, subwindow-mode, -tile, ts-x-origin, ts-y-origin. - - -@defun draw-glyph drawable gcontext x y element &key :translate :width (:size :default) - -@table @var -@item drawable -The destination @var{drawable}. - -@item gcontext -The graphics context for drawing text. - -@item x -@itemx y -The left baseline position for the character drawn. - -@item element -A character or other object to be translated into a font index. - -@item :translate -A function to translate text to font indexes. Default is @var{#'translate-default}. - -@item :width -The total pixel width of the character actually drawn, if known. - -@item :size -Specifies the element size of the destination buffer given to @var{:translate} (8, 16, or -@var{:default}). -@end table - -Draws a single character of filled text represented by the given -@emph{element}. The given @emph{x} and @emph{y} specify the left -baseline position for the character. The first return value is true if -the character is successfully translated and drawn, or @var{nil} if -the @var{:translate} function did not translate it. The second return -value gives the total pixel width of the character actually drawn, if -known. - -Specifying a @var{:width} is a hint to improve performance. The -@var{:width} is assumed to be the total pixel width of the character -actually drawn. Specifying @var{:width} permits appending the output -of subsequent calls to the same protocol request, provided -@emph{gcontext} has not been modified in the interim. If @var{:width} -is not specified, appending of subsequent output might not occur -(unless @var{:translate} returns the character width). - -The @var{:size} specifies the element size of the destination buffer -given to @var{:translate} (either 8, 16, or @var{:default}). If -@var{:default} is specified, the size is based on the current font, -if known; otherwise, 16 is used. - -@table @var -@item output-p -Type @var{boolean}. -@item width -Type @var{int32} or @var{null}. -@end table - -@end defun - -@defun draw-glyphs drawable gcontext x y sequence &key (:start 0) :end :translate :width (:size :default) - -@table @var -@item drawable -The destination @var{drawable}. -@item gcontext -The graphics context for drawing text. -@item x -@itemx y -The left baseline position for the character drawn. -@item sequence -A sequence of characters or other objects to be translated into font indexes. -@item :start -@itemx :end -Start and end indexes defining the elements to draw. -@item :translate -A function to translate text to font indexes. Default is -@var{#'translate-default}. -@item :width -The total total pixel width of the character actually drawn, if known. -@item :size -The element size of the destination buffer given to @var{:translate} (8, 16, or -@var{:default}). -@end table - - -Draws the filled text characters represented by the given -sequence. @var{:start} and @var{:end} define the elements of the -sequence which are drawn. The given @emph{x} and @emph{y} specify the -left baseline position for the first character. The first return value -is @var{nil} if all characters are successfully translated and drawn; -otherwise, the index of the first untranslated sequence element is -returned. The second return value gives the total pixel width of the -characters actually drawn, if known. - -Specifying a @var{:width} is a hint to improve performance. The -@var{:width} is assumed to be the total pixel width of the character -sequence actually drawn. Specifying @var{:width} permits appending -the output of subsequent calls to the same protocol request, provided -@emph{gcontext} has not been modified in the interim. If @var{:width} -is not specified, appending of subsequent output might not occur -(unless @var{:translate} returns the character width). - -The @var{:size} specifies the element size of the destination buffer -given to@var{ :translate} (either 8, 16, or @var{:default}). If -@var{:default} is specified, the size is based on the current font, -if known; otherwise, 16 is used. -@table @var -@item new-start -Type @var{array-index} or @var{null}. -@item width -Type @var{int32} or @var{null}. -@end table - -@end defun - - -@defun draw-image-glyph drawable gcontext x y element &key :translate :width (:size :default) - -@table @var -@item drawable -The destination @var{drawable}. -@item gcontext -The graphics context for drawing text. -@item x -@itemx y -The left baseline position for the character drawn. -@item element -A character or other object to be translated into a font index. -@item :translate -A function to translate text to font indexes. Default is -@var{#'translate-default}. -@item :width -The total pixel width of the character actually drawn, if known. -@item :size -Specifies the element size of the destination buffer given to @var{:translate} (8, 16, or -@var{:default}). -@end table - - -Draws a single character of block text represented by the given -@emph{element}. The given @emph{x} and @emph{y} specify the left -baseline position for the character. The first return value is true if -the character is successfully translated and drawn, or @var{nil} if -the @var{:translate} function did not translate it. The -@var{:translate} function is allowed to return an initial font -change. The second return value gives the total pixel width of the -character actually drawn, if known. - -The @var{:translate} function may not return a horizontal position -change, since @var{draw-image-glyph} does not generate complex output -requests. - -Specifying a @var{:width} is a hint to improve performance. The -@var{:width} is assumed to be the total pixel width of the character -actually drawn. Specifying @var{:width} permits appending the output -of subsequent calls to the same protocol request, provided -@emph{gcontext} has not been modified in the interim. If @var{:width} -is not specified, appending of subsequent output might not occur -(unless @var{:translate} returns the character width). - -The @var{:size} specifies the element size of the destination buffer -given to @var{:translate} (either 8, 16, or @var{:default}). If -@var{:default} is specified, the size is based on the current font, -if known; otherwise, 16 is used. -@table @var -@item output-p -Type @var{boolean}. -@item width -Type @var{int32} or @var{null}. -@end table - -@end defun - - - -@defun draw-image-glyphs drawable gcontext x y sequence &key (:start 0) :end :translate :width (:size :default) -@anchor{draw-image-glyphs} - -@table @var -@item drawable -The destination @var{drawable}. -@item x -@itemx y -The left baseline position for the character drawn. -@item gcontext -The graphics context for drawing text. -@item sequence -A sequence of characters or other objects to be translated into font indexes. -@item :start -@itemx :end -Start and end indexes defining the elements to draw. -@item :translate -A function to translate text to font indexes. Default is -@var{#'translate-default}. -@item :width -The total total pixel width of the character actually drawn, if known. -@item :size -The element size of the destination buffer given to @var{:translate} (8, 16, or -@var{:default}). -@end table - - -Draws the block text characters represented by the given -@var{sequence}. @var{:start} and @var{:end} define the elements of -the @emph{sequence} which are drawn. The given @emph{x} and @emph{y} -specify the left baseline position for the first character. The first -return value is @var{nil} if all characters are successfully -translated and drawn; otherwise, the index of the first untranslated -sequence element is returned. The @var{:translate} function is -allowed to return an initial font change. The second return value -gives the total pixel width of the characters actually drawn, if -known. - -The @var{:translate} function may not return a horizontal position -change, since @var{draw-image-glyphs} does not generate complex -output requests. - -Specifying a @var{:width} is a hint to improve performance. The -@var{:width} is assumed to be the total pixel width of the character -sequence actually drawn. Specifying @var{:width} permits appending -the output of subsequent calls to the same protocol request, provided -@emph{gcontext} has not been modified in the interim. If @var{:width} -is not specified, appending of subsequent output might not occur -(unless @var{:translate} returns the character width). - -The @var{:size} specifies the element size of the destination buffer -given to @var{:translate} (either 8, 16, or @var{:default}). If -@var{:default} is specified, the size will be based on the current -font, if known; otherwise, 16 is used. - -@table @var -@item new-start -Type @var{array-index} or @var{null}. -@item width -Type @var{int32} or @var{null}. -@end table - -@end defun - - -@defun translate-function source source-start source-end font destination destination-start - -@table @var -@item source -A sequence of characters or other objects to be translated. -@item source-start -An array-index specifying the first @emph{source} element to be translated. -@item source-end -An array-index specifying the end of the @emph{source} subsequence to be -translated. -@item font -The font indexed by translated @emph{source} elements. -@item destination -A vector where translated @emph{source} elements are stored. -@item destination-start -An array-index specifying the position to begin storing -translated @emph{source} elements. -@end table - - -A function used as the @var{:translate} argument for text -functions. Converts elements of the @emph{source} (sub)sequence -into font indexes for the given @emph{font} and stores them into -the @emph{destination} vector. - -The @emph{destination} vector is created automatically by -CLX. @emph{destination} is guaranteed to have room for (- -@emph{source-end source-star}t) integer elements, starting at -@emph{destination-start}. Elements of @emph{destination} can be -either @var{card8} or @var{card16} integers, depending on the -context. @emph{font} is the current font, if known, or @var{nil} -otherwise. Starting with the element at @emph{source-start}, -@var{translate-function} should translate as many elements of -@emph{source} as possible (up to the @emph{source-end} element) -into indexes in the current @emph{font}, and store them into -@emph{destination}. The first return value should be the source -index of the first untranslated element. - -The second return value indicates the changes which should be made -to the current text output request before translating the -remaining @emph{source} elements. If no further elements need to -be translated, the second return value should be @var{nil}. If a -horizontal motion is required before further translation, the -second return value should be the change in x position. If a font -change is required for further translation, the second return -value should be the new font. - -If known, the pixel width of the translated text can be returned as the third value; this can -allow for appending of subsequent output to the same protocol request, if no overall -width has been specified at the higher level. -@table @var -@item first-not-done -Type @var{array-index}. -@item to-continue -Type @var{int16}, @var{font}, or @var{null}. -@item current-width -Type @var{int32} or @var{null}. -@end table - -@end defun - - - -@node Images, Font and Characters, Graphic Operations, Top -@chapter Images - -The X protocol provides for the transfer of images (two-dimensional -arrays of pixel data) between a client program and a -@var{drawable}. The format for image data can vary considerably. In -order to present a uniform data representation for the manipulation of a -variety of images, CLX defines a special @var{image} data -type. Additional @var{image} subtypes -- @var{image-xy} and -@var{image-z} -- allow for the representation of an image either as a -sequence of bit planes or as an array of pixels. CLX includes functions -for accessing @var{image} objects; for transferring image data between -@var{image} objects, @var{drawables}, and files; and also for direct -transfer of raw image data. - -@menu -* Image Types:: -* Image Functions:: -* Image Files:: -* Direct Image Transfer:: -@end menu - -@node Image Types, Image Functions, Images, Images -@section Image Types - - -The @var{image} data type is the base type for all @var{image} -objects. @var{image-xy} and @var{image-z} are subtypes of the -@var{image} type which furnish accessors specialized for different -image representations. - -@menu -* Basic Images:: -* XY-Format Images:: -* Z-Format Images:: -@end menu - -@node Basic Images, XY-Format Images, Image Types, Image Types -@subsection Basic Images - -The following paragraphs describe the CLX functions that can be used to -access all types of @var{image} objects. - -@defun image-blue-mask image - -@table @var -@item image -An @var{image} object. -@end table - - -Returns (and with @code{setf}) changes the @emph{mask} that -selects the pixel subfield for blue intensity values. The -@emph{mask} is non-@var{nil} only for images for -@var{:direct-color} or @var{:true-color} visual types. - -@table @var -@item mask -Type @var{pixel} or @var{null}. -@end table - -@end defun - - -@defun image-depth image - -@table @var -@item image -An @var{image} object. -@end table - -Returns the @emph{depth} (that is, the number of bits per pixel) -for the @emph{image}. -@table @var -@item depth -Type @var{card8}. -@end table - -@end defun - - -@defun image-green-mask image - -@table @var -@item image -An @var{image} object. -@end table - -Returns (and with @code{setf}) changes the mask that selects the -pixel subfield for green intensity values. The mask is -non-@var{nil} only for images for @var{:direct-color} or -@var{:true-color} visual types. -@table @var -@item mask -Type @var{pixel} or @var{null}. -@end table - -@end defun - - -@defun image-height image - -@table @var -@item image -An @var{image} object. -@end table - -Returns the @emph{height} of the @emph{image} in pixels. -@table @var -@item height -Type @var{card16}. -@end table - -@end defun - -@defun image-name image - -@table @var -@item image -An @var{image} object. -@end table - -Returns and (with @code{setf}) changes the @emph{name} string -optionally associated with the @emph{image}. -@table @var -@item name -Type @var{stringable} or @var{null}. -@end table - -@end defun - - -@defun image-plist image - -@table @var -@item image -An @var{image} object. -@end table - - -Returns and (with @code{setf}) changes the @emph{image} property -list. The property list is a hook for added application -extensions. -@table @var -@item plist -Type @var{list}. -@end table - -@end defun - - -@defun image-red-mask image - -@table @var -@item image -An @var{image} object. -@end table - - -Returns (and with @code{setf}) changes the @emph{mask} which -selects the pixel subfield for red intensity values. The -@emph{mask} is non-@var{nil} only for images for -@var{:direct-color} or @var{:true-color} visual types. -@table @var -@item mask -Type @var{pixel} or @var{null}. -@end table - -@end defun - - -@defun image-width image - -@table @var -@item image -An @var{image} object. -@end table - - -Returns the @emph{width} of the @emph{image} in pixels. -@table @var -@item width -Type @var{card16}. -@end table - -@end defun - - -@defun image-x-hot image - -@table @var -@item image -An @var{image} object. -@end table - - -Returns and (with @code{setf}) changes the x position of the hot -spot for an image used as a cursor glyph. The hot spot position is -specified relative to the upper-left origin of the @emph{image}. -@table @var -@item x-position -Type @var{card16} or @var{null}. -@end table - -@end defun - - -@defun image-y-hot image - -@table @var -@item image -An @var{image} object. -@end table - - -Returns and (with @code{setf}) changes the y position of the hot -spot for an image used as a cursor glyph. The hot spot position is -specified relative to the upper-left origin of the @emph{image}. -@table @var -@item y-position -Type @var{card16} or @var{null}. -@end table - -@end defun - - -@node XY-Format Images, Z-Format Images, Basic Images, Image Types -@subsection XY-Format Images - - -The @var{image-xy} subtype represents an image as a sequence of -bitmaps, one for each plane of the image, in most-significant to -least-significant bit order. The following paragraphs describe the -additional CLX functions that can be used to access @var{image-xy} -objects. - -@defun image-xy-bitmap-list image - -@table @var -@item image -An @var{image-xy} object. -@end table - - -Returns and (with @code{setf}) changes the list of bitmap planes -for the @emph{image}. -@table @var -@item bitmaps -Type @var{list} of @var{bitmap}. -@end table - -@end defun - - -@node Z-Format Images, , XY-Format Images, Image Types -@subsection Z-Format Images - - -The @var{image-z} subtype represents an image as a two-dimensional -array of pixels, in scanline order. The following paragraphs describe -the additional CLX functions that can be used to access @var{image-z} -objects. - -@defun image-z-bits-per-pixel image - -@table @var -@item image -An @var{image-z} object. -@end table - - -Returns and (with @code{setf}) changes the number of bits per data -unit used to contain a pixel value for the @emph{image}. Depending -on the storage format for image data, this value can be larger -than the actual @emph{image} depth. -@table @var -@item pixel-data-size -One of 1, 4, 8, 16, 24, or 32. -@end table - -@end defun - - -@defun image-z-pixarray image - -@table @var -@item image -An @var{image-z} object. -@end table - -Returns and (with @code{setf}) changes the two-dimensional array -of pixel data for the @emph{image}. -@table @var -@item pixarray -Type @var{pixarray}. -@end table - -@end defun - - - -@node Image Functions, Image Files, Image Types, Images -@section Image Functions - -The following paragraphs describe the CLX functions used to: - -@itemize @bullet -@item Create an @var{image} object. - -@item Copy an image or a subimage. - -@item Read an image from a @var{drawable}. - -@item Display an image to a @var{drawable}. -@end itemize - - -@defun create-image &key :bit-lsb-first-p :bits-per-pixel :blue-mask :byte-lsb-first-p :bytes-per-line :data :depth :format :green-mask :height :name :plist :red-mask :width :x-hot :y-hot Function - -@table @var -@item :bit-lsb-first-p -For a returned image, true if the order of bits in each @var{:data} -byte is least-significant bit first. -@item :bits-per-pixel -One of 1, 4, 8, 16, 24, or 32. -@item :blue-mask -For @var{:true-color} or @var{:direct-color} images, a pixel mask. -@item :byte-lsb-first-p -For a returned @emph{image}, true if the @var{:data} byte order is -least-significant byte first. -@item :bytes-per-line -For a returned @emph{image}, the number of @var{:data} bytes per scanline. -@item :data -Either a @var{list} of @var{bitmaps}, a @var{pixarray}, or an array of @var{card8} bytes. -@item :depth -The number of bits per displayed pixel. -@item :format -One of @var{:bitmap}, @var{:xy-format}, or @var{:z-format}. -@item :green-mask -For @var{:true-color} or @var{:direct-color} images, a pixel mask. -@item :height -A @var{card16} for the image height in pixels. -@item :name -An optional @var{stringable} for the image name. -@item :plist -An optional image property list. -@item :red-mask -For @var{:true-color} or @var{:direct-color} images, a pixel mask. -@item :width -A @var{card16} for the image width in pixels. -@item :x-hot -For a @var{cursor} image, the x position of the hot spot. -@item :y-hot -For a cursor image, the y position of the hot spot. -@end table - -Creates an @var{image} object from the given @var{:data} and -returns either an @var{image}, @var{image-xy}, or an -@var{image-z}, depending on the type of image @var{:data}. If the -@var{:data} is a list, it is assumed to be a @var{list} of -@var{bitmaps} and an @var{image-xy} is created. If the -@var{:data} is a @var{pixarray}, an @var{image-z} is -created. Otherwise, the @var{:data} must be an array of bytes -(@var{card8}), in which case a basic @var{image} object is -created. - -If the @var{:data} is a list, each element must be a bitmap of -equal size. @var{:width} and @var{:height} default to the bitmap -width -- (@var{array-dimension bitmap} 1) -- and the bitmap height --- (@var{array-dimension bitmap} 0) -- respectively. @var{:depth} -defaults to the number of bitmaps. - -If the @var{:data} is a @var{pixarray}, @var{:width} and -@var{:height} default to the @var{pixarray} width -- -(@var{array-dimension pixarray} 1), and the pixarray height -- -(@var{array-dimension pixarray} 0), respectively. @var{:depth} -defaults to (@var{pixarray-depth} @var{:data}). The -@var{:bits-per-pixel} is rounded to a valid size, if necessary. By -default, the @var{:bits-per-pixel} is equal to the @var{:depth}. - -If the @var{:data} is an array of @var{card8}, the @var{:width} -and @var{:height} are required to interpret the image data -correctly. The @var{:bits-per-pixel} defaults to the @var{:depth}, -and the @var{:depth} defaults to 1. @var{:bytes-per-line} defaults -to: - -@lisp -(@var{floor} (@var{length :data}) (* @var{:bits-per-pixel :height})) -@end lisp - -The @var{:format} defines the storage format of image data bytes -and can be one of the following values: - -@table @var -@item :xy-pixmap -The @var{:data} is organized as a set of bitmaps representing image -bit planes, appearing in most-significant to least-significant bit -order. - -@item :z-pixmap -The @var{:data} is organized as a set of pixel values in scanline -order. - -@item :bitmap -Similar to @var{:xy-pixmap}, except that the @var{:depth} must be 1, -and 1 and 0 bits represent the foreground and background pixels, -respectively. -@end table - -By default, the @var{:format} is @var{:bitmap} if @var{:depth} is -1; otherwise, @var{:z-pixmap}. - -@table @var -Type @var{image}. -@end table - -@end defun - - -@defun copy-image image &key (:x 0) (:y 0) :width :height :result-type - -@table @var -@item image -An @var{image} object. -@item :x -@itemx :y -@var{card16} values defining the position of the upper-left corner of the subimage -copied. -@item :width -@itemx :height -@var{card16} values defining the size of subimage copied. -@item :result-type -One of @var{'image-x}, @var{'image-xy}, or @var{'image-z}. -@end table - - -Returns a new image, of the given @var{:result-type}, containing a -copy of the portion of the @emph{image} defined by @var{:x}, -@var{:y}, @var{:width}, and @var{:height}. By default, -@var{:width} is: - -@lisp -(- (@var{image-width} @emph{image}) @var{:x}) -@end lisp - -and @var{:height} is: - -@lisp -(- (@var{image-height} @emph{image}) @var{:y}) -@end lisp - -If necessary, the new image is converted to the @var{:result-type}, -that can be one of the following values: - -@table @code -@item 'image-x -A basic @var{image} object is returned. -@item 'image-xy -An @var{image-xy} is returned. -@item 'image-z -An @var{image-z} is returned. -@end table - -@table @var -@item new-image -Type @var{image}. -@end table - -@end defun - - -@defun get-image drawable &key :x :y :width :height :plane-mask (:format :z-format) :result-type Function - -@table @var -@item drawable -A @var{drawable}. -@item :x -@itemx :y -@var{card16} values defining the upper-left @var{drawable} pixel returned. These -arguments are required. -@item :width -@itemx :height -@var{card16} values defining the size of the @emph{image} returned. These -arguments are required. -@item :plane-mask -A pixel mask. -@item :format -Either @var{:xy-pixmap} or @var{:z-pixmap}. -@item :result-type -One of @var{'image-x}, @var{'image-xy}, or @var{'image-z}. -@end table - - -Returns an @emph{image} containing pixel values from the region of -the @emph{drawable} given by @var{:x}, @var{:y}, @var{:width}, -and @var{:height}. The bits for all planes selected by 1 bits in -the @var{:plane-mask} are returned as zero; the default -@var{:plane-mask} is all 1 bits. The @var{:format} of the returned -pixel values may be either @var{:xy-format} or @var{:z-format}. - -The @var{:result-type} defines the type of image object returned: - -@table @code -@item 'image-x -A basic @var{image} object is returned. -@item 'image-xy -An @var{image-xy} is returned. -@item 'image-z -An @var{image-z} is returned. -@end table - - -By default, @var{:result-type} is @var{'image-z} if @var{:format} -is @var{:z-format} and @var{'image-xy} if @var{:format} is -@var{:xy-format}. -@table @var -Type @var{image}. -@end table - -@end defun - -@defun put-image drawable gcontext image &key (:src-x 0) (:src-y 0) :x :y :width :height :bitmap-p - -@table @var -@item drawable -The destination @var{drawable}. -@item gcontext -The graphics context used to display the @emph{image}. -@item image -An @var{image} object. -@item :src-x -@itemx :src-y -@var{card16} values defining the upper-left position of the @emph{image} region to -display. -@item :x -@itemx :y -The position in the @emph{drawable} where the @emph{image} region is displayed. These -arguments are required. -@item :width :height -@var{card16} values defining the size of the @emph{image} region displayed. -@item :bitmap-p -If @emph{image} is depth 1, then if true, foreground and background pixels are -used to display 1 and 0 bits of the @emph{image}. -@end table - -Displays a region of the @emph{image} defined by @var{:src-x}, -@var{:src-y}, @var{:width}, and @var{:height} on the destination -d@emph{rawable}, with the upper-left pixel of the @emph{image} -region displayed at the @emph{drawable} position given by @var{:x} -and @var{:y}. By default, @var{:width} is: - -@lisp -(- (@var{image-width} @emph{image}) @var{:src-x}) -@end lisp - -and @var{:height} is: - -@lisp -(- (@var{image-height} @emph{image}) @var{:src-y}) -@end lisp - -The following attributes of the @emph{gcontext} are used to display -the @var{image}: clip-mask, clip-x, clip-y, function, plane-mask, -and subwindow-mode. - -The @var{:bitmap-p} argument applies only to images of depth 1. In -this case, if @var{:bitmap-p} is true or if the @emph{image} is a -basic @var{image} object created with @var{:format :bitmap}, the -@emph{image} is combined with the foreground and background pixels -of the @var{gcontext}. 1 bits of the @emph{image} are displayed in -the foreground pixel and 0 bits are displayed in the background -pixel. - - -@end defun - - -@node Image Files, Direct Image Transfer, Image Functions, Images -@section Image Files - - -CLX provides functions that allow images to be written to a file in a standard X -format. The following paragraphs describe the CLX functions used to: - -@itemize @bullet -@item Read an image from a file. - -@item Write an image to a file. -@end itemize - - -@defun read-bitmap-file pathname - -@table @var -@item pathname -An image file pathname. -@end table - - -Reads an image file in standard X format and returns an -@var{image} object. The returned @emph{image} can have -depth greater than one. -@table @var -@item image -Type @var{image}. -@end table - -@end defun - - -@defun write-bitmap-file pathname image &optional name - -@table @var -@item pathname -An image file pathname. -@item image -An @var{image} object. -@item name -A @var{stringable} image name. -@end table - -Writes the @emph{image} to an image file in standard X -format. The @emph{image} can have depth greater than -one. The @emph{name} is an image identifier written to the -file; the default @emph{name} is (@var{or} -(@var{image-name} @emph{image}) @var{'image}). - - -@end defun - - -@node Direct Image Transfer, , Image Files, Images -@section Direct Image Transfer - - -For cases where the @var{image} representation is not needed, -CLX provides functions to read and display image data -directly. -@defun get-raw-image drawable &key :data (:start 0) :x :y :width :height :plane-mask (:format :z-format) (:result-type '(vector card8)) - -@table @var -@item drawable -A @var{drawable}. -@item :data -An optional @var{sequence} of @var{card8}. -@item :start -The index of the first @var{:data} element modified. -@item :x -@itemx :y -@var{card16} values defining the size of the @var{image} returned. These arguments are -required. -@item :width -@itemx :height -@var{card16} values defining the size of the image returned.These -arguments are required. -@item :plane-mask -A pixel mask. -@item :format -Either @var{:xy-pixmap} or @var{:z-pixmap}. This argument is required. -@item :result-type -The type of image data sequence to return. -@end table - - -Returns a sequence of image data from the region of the -@emph{drawable} given by @var{:x}, @var{:y}, -@var{:width}, and @var{:height}. If @var{:data} is -given, it is modified beginning with the element at the -@var{:start} index and returned. The @emph{depth} and -@emph{visua}l type ID of the @emph{drawable} are also -returned. - -The bits for all planes selected by 1 bits in the -@var{:plane-mask} are returned as zero; the default -@var{:plane-mask} is all 1 bits. The @var{:format} of -the returned pixel values may be either -@var{:xy-format} or @var{:z-format}. The -@var{:result-type} defines the type of image data -returned. - -The calling program is responsible for handling the -byte-order and bit-order returned by the server for the -@emph{drawable}'s display (see @var{display-byte-order} -and @var{display-image-lsb-first-p}). -@table @var -@item data -Type @var{sequence} or @var{card8}. -@item depth -Type @var{card8}. -@item visual -Type @var{card29}. -@end table - -@end defun - - -@defun put-raw-image drawable gcontext data &key (:start 0) :depth :x :y :width :height (:left-pad 0) :format - -@table @var -@item drawable -The destination @var{drawable}. -@item gcontext -The graphics context used to display the image. -@item data -A sequence of integers. -@item :start -The index of the first element of @emph{data} displayed. -@item :depth -The number of bits per pixel displayed. This argument is required. -@item :x -@itemx :y -The position in the @emph{drawable} where the image region is displayed. These -arguments are required. -@item :width -@itemx :height -@var{card16} values defining the size of the image region displayed. These -arguments are required. -@item :left-pad -A @var{card8} specifying the number of leading bits to discard for each image -scanline. -@item :format -One of @var{:bitmap}, @var{:xy-pixmap}, or @var{:z-pixmap}. -@end table - -Displays a region of the image data defined by @var{:start}, -@var{:left-pad}, @var{:width}, and @var{:height} on the -destination @emph{drawable}, with the upper-left pixel of the image -region displayed at the @emph{drawable} position given by @var{:x} -and @var{:y}. - -The @var{:format} can be either @var{:xy-pixmap}, -@var{:z-pixmap}, or @var{:bitmap}. If @var{:xy-pixmap} or -@var{:z-pixmap} formats are used, @var{:depth} must match the -depth of the destination @emph{drawable}. For @var{:xy-pixmap}, the -data must be in XY format. For @var{:z-pixmap}, the data must be in -Z format for the given @var{:depth}. - -If the @var{:format} is @var{:bitmap}, the @var{:depth} must be -1. In this case, the image is combined with the foreground and -background pixels of the @emph{gcontext}. 1 bits of the image are -displayed in the foreground pixel and 0 bits are displayed in the -background pixel. - -The @var{:left-pad} must be zero for @var{:z-pixmap} format. For -@var{:bitmap} and @var{:xy-pixmap} formats, the @var{:left-pad} -must be less than the bitmap-scanline-pad for the @emph{drawable}'s -display (@pxref{display-bitmap-format}). The first -@var{:left-pad} bits in every scanline are to be ignored by the -server; the actual image begins that many bits into the data. - -The following attributes of the @emph{gcontext} are used to display -the @var{image}: clip-mask, clip-x, clip-y, function, plane-mask, -and subwindow-mode. - -The calling program is responsible for handling the byte-order and -bit-order required by the server for the @emph{drawable}'s display -(see @var{display-byte-order} and -@var{display-image-lsb-first-p}). - - -@end defun - - -@node Font and Characters, Colors, Images, Top -@chapter Font and Characters - -An X server maintains a set of fonts used in the text operations -requested by client programs. An X font is an array of character bit -maps (or @emph{glyphs}) indexed by integer codes. In fact, font glyphs -can also represent cursor shapes or other images and are not limited to -character images. X supports both linear and matrix encoding of font -indexes. With linear encoding, a font index is interpreted as a single -16-bit integer index into a one-dimensional array of glyphs. With matrix -encoding, a font index is interpreted as a pair of 8-bit integer indexes -into a two-dimensional array of glyphs. The type of index encoding used -is font-dependent. - -In order to access or use a font, a client program must first open it -using the @var{open-font} function, sending a font name string as an -identifier. @var{open-font} creates a CLX @var{font} object used to -refer to the font in subsequent functions. Afterward, calling -@var{open-font} with the same font name returns the same @var{font} -object. When a font is no longer in use, a client program can call -@var{close-font} to destroy the @var{font} object. - -A font has several attributes which describe its geometry and its -glyphs. CLX provides functions to return the attributes of a font, as -well functions for accessing the attributes of individual font -glyphs. Glyph attributes are referred to as @emph{character attributes}, -since characters are the most common type of font glyphs. A font also -has a property list of values recorded by the X server. However, the set -of possible font properties and their values are not standardized and -are implementation-dependent. Typically, CLX maintains a cache of font -and character attributes, in order to minimize server requests. -However, the font cache mechanism is implementation-dependent and cannot -be controlled by the client. In some cases, CLX may create a -@emph{pseudo-font} object solely for the purpose of accessing font -attributes. A pseudo-font is represented by a special type of -@var{font} object that cannot be used in a @var{gcontext}. If -necessary, CLX can automatically convert a pseudo-font into a true font, -if the name of the pseudo-font is known. - -The set of available fonts is server-dependent; that is, font names are -not guaranteed to be portable from one server to the next. However, the -public X implementation from MIT includes a set of fonts that are -typically available with most X servers. - -The following paragraphs describe CLX functions to: - -@itemize @bullet -@item Open and close fonts. -@item List available fonts. -@item Access font attributes. -@item Access character attributes. -@item Return the size of a text string. -@end itemize - -@menu -* Opening Fonts:: -* Listing Fonts:: -* Font Attributes:: -* Chracter Attributes:: -* Querying Text Size:: -@end menu - -@node Opening Fonts, Listing Fonts, Font and Characters, Font and Characters -@section Opening Fonts - - -The following paragraphs discuss the CLX functions for opening and -closing fonts. - -@defun open-font display name - -@table @var -@item display -A @var{display} object. -@item name -A font name string. -@end table - -Opens the font with the given @emph{name} and returns a -@var{font} object. The name string should contain only ISO -Latin-1 characters; case is not significant. - -@table @var -@item font -Type @var{font}. -@end table - -@end defun - - -@defun close-font font - -@table @var -@item font -A @var{font} object. -@end table - -Deletes the association between the resource ID and the -@emph{font}. The @emph{font} is freed when no other server -resource references it. The @emph{font} can be unloaded by the X -server if this is the last reference to the @emph{font} by any -client. In any case, the @emph{font} should never again be -referenced because its resource ID is destroyed. This might not -generate a protocol request if the @emph{font} is -reference-counted locally or if it is a pseudo-font. - -@end defun - - -@defun discard-font-info fonts - -@table @var -@item font -A @var{font} object. -@end table - -Discards any state that can be re-obtained with -@var{open-font}. This is simply a performance hint for -memory-limited systems. - -@end defun - -@node Listing Fonts, Font Attributes, Opening Fonts, Font and Characters -@section Listing Fonts - - -The following paragraphs describe CLX functions that return fonts or -font names that match a given pattern string. Such pattern strings -should contain only ISO Latin-1 characters; case is not significant. The -following pattern characters can be used for @emph{wildcard} matching: - -@table @code -@item #\* -Matches any sequence of zero or more characters. -@item #\? -Matches any single character. -@end table - -For example, the pattern "T?mes Roman" matches the name "Times Roman" -but not the name "Thames Roman". However, the pattern "T*mes Roman" -matches both names. - -@defun font-path display &key (:result-type 'list) - -@table @var -@item display -A @var{display} object. -@item :result-type -Specifies the type of resulting sequence. -@end table - -Returns a @var{list} (by default) of names containing the current -search path for fonts. With @code{setf}, this function sets the -search path for font lookup. There is only one search path per -server, not one per client. The interpretation of the names is -server-dependent, but they are intended to specify directories to be -searched in the order listed. - -Setting the path to the empty list restores the default path -defined for the server. Note that as a side-effect of -executing this request, the server is guaranteed to flush -all cached information about fonts for which there are -currently no explicit resource IDs allocated. -@table @var -@item paths -Type @var{sequence} of either @var{string} or @var{pathname}. -@end table - -@end defun - - -@defun list-font-names display pattern &key (:max-fonts 65535) (:result-type 'list) - -@table @var -@item display -A @var{display} object. -@item pattern -A string used to match font names. Only font names that match the pattern are -returned. -@item :max-fonts -The maximum number of font names returned. Default is 65535. -@item :result-type -The type of sequence to return. Default is '@var{list}. -@end table - -Returns a sequence of strings containing the font names that match -the @emph{pattern}. The fonts available are determined by the font -search path; see @var{font-path}). The maximum number of font names -returned is determined by @var{:max-fonts}. - -@table @var -@item font-name -Type @var{sequence} of @var{string}. -@end table - -@end defun - - -@defun list-fonts display pattern &key (:max-fonts 65535) (:result-type 'list) - -@table @var -@item display -A @var{display} object. -@item pattern -A string used to match font names. Only fonts whose name matches the -pattern are returned. -@item :max-fonts -The maximum number of fonts returned. Default is 65535. -@item :result-type -The type of sequence to return. Default is @var{'list}. -@end table - -Returns a sequence of pseudo-fonts corresponding to the available -fonts whose names match the @emph{pattern}. The fonts available are -determined by the font search path; see @var{font-path}). The -maximum number of @var{font} objects returned is determined by -@var{:max-fonts}. - -@table @var -@item font -Type @var{sequence} of @var{font}. -@end table - -@end defun - - -@node Font Attributes, Chracter Attributes, Listing Fonts, Font and Characters -@section Font Attributes - - -The following paragraphs describe the CLX functions used to access font -attributes. - -@defun font-all-chars-exist-p font - -@table @var -@item exists-p -Type @var{boolean}. -@end table - - -Returns true if glyphs exist for all indexes in the range returned -by @var{font-min-char} and @var{font-max-char}. Returns -@var{nil} if an index in the range corresponds to empty glyph. - -@table @var -@item font -A @var{font} object. -@end table - -@end defun - - -@defun font-ascent font - -@table @var -@item ascent -Type @var{int16}. -@end table - - -Returns the vertical @emph{ascent} of the @emph{font} used for -interline spacing. The @emph{ascent} defines the nominal distance -in pixels from the baseline to the bottom of the previous line of -text. Some font glyphs may actually extend beyond the font -@emph{ascent}. -@table @var -@item font -A @var{font} object. -@end table - -@end defun - - -@defun font-default-char font - -@table @var -@item index -Type @var{card16}. -@end table - - -Returns the @emph{index} of the glyph drawn when an invalid or -empty glyph index is specified. If the default index specifies an -invalid or empty glyph, an invalid or empty index has no effect. -@table @var -@item font -A @var{font} object. -@end table - -@end defun - - -@defun font-descent font - -@table @var -@item descent -Type @var{int16}. -@end table - - -Returns the vertical @emph{descent} of the @emph{font} used for -interline spacing. The @emph{descent} defines the nominal distance -in pixels from the baseline to the top of the next line of -text. Some font glyphs may actually extend beyond the font -@emph{descent}. -@table @var -@item font -A @var{font} object. -@end table - -@end defun - - -@defun font-direction font - -@table @var -@item direction -Type @var{draw-direction}. -@end table - - -Returns the nominal drawing @emph{direction} for the -@emph{font}. The font drawing direction is only a hint that -indicates whether the @emph{char-width} of most font glyphs is -positive (@var{:left-to-right} direction) or negative -(@var{:right-to-left} direction). Note that X does not provide -any direct support for vertical text. -@table @var -@item font -A @var{font} object. -@end table - -@end defun - - -@defun font-display font - -@table @var -@item font -A @var{font} object. -@end table - -Returns the @var{display} object associated with the specified -@emph{font}. - -@table @var -@item display -Type @var{display}. -@end table - -@end defun - - -@defun font-equal font-1 font-2 - -@table @var -@item font-1 -@itemx font-2 -The @var{font} objects. -@end table - -Returns true if the two arguments refer to the same server -resource and @var{nil} if they do not. - - -@end defun - - -@defun font-id font - -@table @var -@item font -A @var{font} object. -@end table - -Returns the unique resource ID assigned to the specified @emph{font}. - -@table @var -@item id -Type @var{resource-id}. -@end table - -@end defun - - -@defun font-max-byte1 font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns zero if the @emph{font} uses linear index -encoding. Otherwise, if the @emph{font} uses matrix index -encoding, a value between 1 and 255 is returned that specifies the -maximum value for the most significant byte of font indexes. -@table @var -@item max-byte1 -Type @var{card8}@emph{.} -@end table - -@end defun - - -@defun font-max-byte2 font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns zero if the @emph{font} uses linear index -encoding. Otherwise, if the @emph{font} uses matrix index -encoding, a value between 1 and 255 is returned that specifies the -maximum value for the least significant byte of font indexes. -@table @var -@item max-byte2 -Type @var{card8}@emph{.} -@end table - -@end defun - - -@defun font-max-char font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the maximum valid value used for linear encoded -indexes. This function is not meaningful for fonts that use matrix -index encoding. -@table @var -@item index -Type @var{card16}. -@end table - -@end defun - - -@defun font-min-byte1 font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns zero if the @emph{font} uses linear index -encoding. Otherwise, if the @emph{font} uses matrix index -encoding, a value between 1 and 255 is returned that specifies the -minimum value for the most significant byte of font indexes. -@table @var -@item min-byte1 -Type @var{card8}. -@end table - -@end defun - - -@defun font-min-byte2 font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns zero if the @emph{font} uses linear index -encoding. Otherwise, if the @emph{font} uses matrix index -encoding, a value between 1 and 255 is returned that specifies the -minimum value for the least significant byte of font indexes. -@table @var -@item min-byte2 -Type @var{card8}. -@end table - -@end defun - - -@defun font-min-char font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the minimum valid value used for linear encoded -indexes. This function is not meaningful for fonts that use matrix -index encoding. -@table @var -@item index -Type @var{card16}. -@end table - -@end defun - - -@defun font-name font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the name of the @emph{font}, or @var{nil} if @emph{font} -is a pseudo-font. -@table @var -@item name -Type @var{string} or @var{null}. -@end table - -@end defun - - -@defun font-p font - -Returns true if the argument is a @var{font} object and -@var{nil} otherwise. - -@table @var -@item font-p -Type @var{boolean}. -@end table - -@end defun - - -@defun font-plist font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns and (with @code{setf}) sets the property list for the -specified @emph{font}. This function provides a hook where -extensions can add data. -@table @var -@item plist -Type @var{list}. -@end table - -@end defun - - -@defun font-properties font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the list of font @emph{properties} recorded by the X -server. The returned list is a property list of keyword/value -pairs. The set of possible font property keywords is -implementation-dependent. -@table @var -@item properties -Type @var{list}. -@end table - -@end defun - - -@defun font-property font name - -@table @var -@item font -A @var{font} object. -@item name -A font property keyword. -@end table - - -Returns the value of the font @emph{property} specified by the -@emph{name} keyword. The property value, if it exists, is returned -as an uninterpreted 32-bit integer. -@table @var -@item property -Type @var{int32} or @var{null}. -@end table - -@end defun - - -@defun max-char-ascent font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the maximum @var{char-ascent} value for all characters in -@emph{font}. -@table @var -@item ascent -Type @var{int16}. -@end table - -@end defun - - -@defun max-char-attributes font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the maximum @var{char-attributes} value for all -characters in @emph{font}. -@table @var -@item attributes -Type @var{int16}. -@end table - -@end defun - - -@defun max-char-descent font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the maximum @var{char-descent} value for all characters -in @emph{font}. -@table @var -@item descent -Type @var{int16}. -@end table - -@end defun - - -@defun max-char-left-bearing font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the maximum @var{char-left-bearing} value for all characters in @emph{font}. -@table @var -@item left-bearing -Type @var{int16}. -@end table - -@end defun - - -@defun max-char-right-bearing font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the maximum @var{char-right-bearing} value for all -characters in @emph{font}. -@table @var -@item right-bearing -Type @var{int16}. -@end table - -@end defun - - -@defun max-char-width font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the maximum @var{char-width} value for all characters in -@emph{font}. -@table @var -@item width -Type @var{int16}. -@end table - -@end defun - - -@defun min-char-ascent font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the minimum @var{char-ascent} for all characters in -@emph{font}. -@table @var -@item ascent -Type @var{int16}. -@end table - -@end defun - - -@defun min-char-attributes font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the minimum @var{char-attributes} for all characters in @emph{font}. -@table @var -@item attributes -Type @var{int16}. -@end table - -@end defun - - -@defun min-char-descent font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the minimum @var{char-descent} for all characters in @emph{font}. -@table @var -@item descent -Type @var{int16}. -@end table - -@end defun - - -@defun min-char-left-bearing font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the minimum @var{char-left-bearing} for all characters in -@emph{font}. -@table @var -@item left-bearing -Type @var{int16}. -@end table - -@end defun - - -@defun min-char-right-bearing font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the minimum @var{char-right-bearing} for all characters -in @emph{font}. -@table @var -@item right-bearing -Type @var{int16}. -@end table - -@end defun - - -@defun min-char-width font - -@table @var -@item font -A @var{font} object. -@end table - - -Returns the minimum @var{char-width} for all characters in -@emph{font}. -@table @var -@item width -Type @var{int16}. -@end table - -@end defun - - -@node Chracter Attributes, Querying Text Size, Font Attributes, Font and Characters -@section Chracter Attributes - - -The following paragraphs describe the CLX functions used to access the -attributes of individual font glyphs. - -@defun char-ascent font index - -@table @var -@item font -A @var{font} object. -@item index -An @var{int16} font index. -@end table - - -Returns the vertical distance in pixels from the baseline to the top -of the given font glyph. Returns @var{nil} if the index is invalid -or specifies an empty glyph, or if the @emph{font} is a pseudo-font. -@table @var -@item ascent -Type @var{int16} or @var{null}. -@end table - -@end defun - - -@defun char-attributes font index - -@table @var -@item font -A @var{font} object. -@item index -An @var{int16} font index. -@end table - - -Returns font-specific @emph{attributes} of the given glyph. The -interpretation of such attributes is server-dependent. Returns -@var{nil} if the @emph{index} is invalid or specifies an empty -glyph, or if the @emph{font} is a pseudo-font. -@table @var -@item attributes -Type @var{int16} or @var{null}. -@end table - -@end defun - - -@defun char-descent font index - -@table @var -@item font -A @var{font} object. -@item index -An @var{int16} font index. -@end table - - -Returns the vertical distance in pixels from the baseline to the -bottom of the given font glyph. Returns @var{nil} if the -@emph{index} is invalid or specifies an empty glyph, or if the -@emph{font} is a pseudo-font. -@table @var -@item descent -Type @var{int16} or @var{null}. -@end table - -@end defun - - -@defun char-left-bearing font index - -@table @var -@item font -A @var{font} object. -@item index -An @var{int16} font index. -@end table - - -Returns the left side bearing of the given font glyph. If -@var{draw-glyph} is called with horizontal position @emph{x}, -the leftmost pixel of the glyph is drawn at the position -(+ @emph{x left-bearing}). Returns @var{nil} if the -@emph{index} is invalid or specifies an empty glyph, or if the -@emph{font} is a pseudo-font. -@table @var -@item left-bearing -Type @var{int16} or @var{null}. -@end table - -@end defun - - -@defun char-right-bearing font index - -@table @var -@item font -A @emph{font} object. -@item index -An @var{int16} font index. -@end table - - -Returns the right side bearing of the given font glyph. If -n@var{draw-glyph} is called with horizontal position @emph{x}, -the rightmost pixel of the glyph is drawn at the position (+ -@emph{x rightbearing}). Returns @var{nil} if the -@emph{index} is invalid or specifies an empty glyph, or if the -@emph{font} is a pseudo-font. - -@table @var -@item right-bearing -Type @var{int16} or @var{null}. -@end table - -@end defun - - -@defun char-width font index - -@table @var -@item font -A @var{font} object. -@item index -An @var{int16} font index. -@end table - -Returns the @emph{width} of the given font glyph. The @emph{width} -is defined to be equal to (- @emph{rightbearing -left-bearing}). Returns @var{nil} if the @emph{index} is invalid -or specifies an empty glyph, or if the @emph{font} is a pseudo-font. - -@table @var -@item width -Type @var{int16} or @var{null}. -@end table - -@end defun - - -@node Querying Text Size, , Chracter Attributes, Font and Characters -@section Querying Text Size - - -CLX defines functions to return the size of text drawn in a specified -font. @xref{Drawing Text}, for a description of the -@var{:translate} function used by the functions in the following -paragraphs. - -@defun text-extents font sequence &key (:start 0) :end :translate -@anchor{text-extents} - -@table @var -@item font -The font (or @var{gcontext}) used for measuring characters. -@item sequence -A sequence of characters or other objects to be translated into font indexes. -@item :start -@itemx :end -Start and end indexes defining the elements to draw. -@item :translate -A function to translate text to font indexes. Default is -@var{#'translate-default}. -@end table - -Returns the complete geometry of the given @emph{sequence} when -drawn in the given @emph{fon}t. The @emph{font} can be a -@var{gcontext}, in which case the font attribute of the given -graphics context is used. @var{:start} and @var{:end} define the -elements of the @emph{sequence} which are used. - -The returned @emph{width} is the total pixel width of the -translated character sequence. The returned @emph{ascent} and -@emph{descent} give the vertical ascent and descent for characters -in the translated @emph{sequence}. The returned @emph{left} gives -the left bearing of the leftmost character. The returned -@emph{right} gives the right bearing of the rightmost -character. The returned @emph{font-ascent} and @emph{font-descent} -give the maximum vertical ascent and descent for all characters in -the @emph{fon}t. If @var{:translate} causes font changes, then -@emph{font-ascent} and @emph{font-descent} will be the maximums -over all fonts used. The @emph{direction} returns the preferred -draw direction for the font. If @var{:translate} causes font -changes, then the @emph{direction} will be @var{nil}. The -@emph{first-not-done} value returned is @var{nil} if all elements -of the @emph{sequence} were successfully translated; otherwise the -index of the first untranslated element is returned. - -@table @var -@item width -Type @var{int32}. -@item ascent -Type @var{int16}. -@item descent -Type @var{int16}. -@item left -Type @var{int32}. -@item right -Type @var{int32}. -@item font-ascent -Type @var{int16}. -@item direction -Type @var{draw-direction}. -@item first-not-done -Type @var{array-index} or @var{null}. -@end table - -@end defun - - -@defun text-width font sequence &key (:start 0) :end :translate - -@table @var -@item font -The font (or @var{gcontext}) used for measuring characters. -@item sequence -A sequence of characters or other objects to be translated into font indexes. -@item :start -@item :end -Start and end indexes defining the elements to draw. -@item :translate -A function to translate text to font indexes. Default is -@var{#'translate-default}. -@end table - - -Returns the total pixel width of the given @emph{sequence} when -drawn in the given @emph{font}. The @emph{font} can be a -@var{gcontext}, in which case the font attribute of the given -graphics context is used. @var{:start} and @var{:end} define the -elements of the @emph{sequence} which are used. The second value -returned is @var{nil} if all elements of the @emph{sequence} were -successfully translated; otherwise the index of the first -untranslated element is returned. -@table @var -@item width -Type @var{int32}. -@item first-not-done -Type @var{array-index} or @var{null}. -@end table - -@end defun - - -@node Colors, Cursors, Font and Characters, Top -@chapter Colors - -@menu -* Colormaps and Colors:: -* Color Functions:: -* Colormap Functions:: -@end menu - -@node Colormaps and Colors, Color Functions, Colors, Colors -@section Colormaps and Colors - - -In X, a @emph{color} is defined by a set of three numeric values, -representing intensities of red, green, and blue. Red, green, and blue -are referred to as the @emph{primary} hues. A @emph{colormap} is a list -of colors, each indexed by an integer @emph{pixel} value. Each entry in -a colormap is called a color @emph{cell}. Raster graphics displays store -pixel values in a special screen hardware memory. As the screen hardware -scans this memory, it reads each pixel value, looks up the color in the -corresponding cell of a colormap, and displays the color on its screen. - -The colormap abstraction applies to all classes of visual types -supported by X, including those for screens which are actually -monochrome. For example, @var{:gray-scale} screens use colormaps in -which colors actually specify the monochrome intensity. A typical -black-and-white monochrome display has a @var{:static-gray} screen with -a two-cell colormap. - -The following list describes how pixel values and colormaps are handled -for each visual class. - -@table @var -@item :direct-color -A pixel value is decomposed into separate red, green, and blue -subfields. Each subfield indexes a separate colormap. Entries in all colormaps can -be changed. -@item :gray-scale -A pixel value indexes a single colormap that contains monochrome -intensities. Colormap entries can be changed. -@item :pseudo-color -A pixel value indexes a single colormap that contains color -intensities. Colormap entries can be changed. -@item :static-color -Same as @var{:pseudo-color}, except that the colormap entries are -predefined by the hardware and cannot be changed. -@item :static-gray -Same as @var{:gray-scale}, except that the colormap entries are -predefined by the hardware and cannot be changed. -@item :true-color -Same as @var{:direct-color}, except that the colormap entries are -predefined by the hardware and cannot be changed. Typically, each of -the red, green, and blue colormaps provides a (near) linear ramp of -intensity. -@end table - -CLX provides functions to create colormaps, access and modify colors and -color cells, and install colormaps in screen hardware. - -@node Color Functions, Colormap Functions, Colormaps and Colors, Colors -@section Color Functions - - -A color is represented by a CLX color object, in which each of the red, -green, and blue values is specified by an @var{rgb-val} -- a floating -point number between 0.0 and 1.0. (@pxref{Data Types}). The -value 0.0 represents the minimum intensity, while 1.0 represents the -maximum intensity. CLX automatically converts @var{rgb-val} values into -16-bit integers when sending colors to an X server. The X server, in -turn, scales 16-bit color values to match the actual intensity range -supported by the screen. - -Colors used on @var{:gray-scale} screens must have the same value for -each of red, green, and blue. Only one of these values is used by screen -hardware to determine intensity; however, CLX does not define which of -red, green, or blue is actually used. - -The following paragraphs describe the CLX functions used to create, -access, and modify colors. - -@defun make-color &key (:blue 1.0) (:green 1.0) (:red 1.0) &allow-other-keys - -@table @var -@item :blue -@itemx :green -@itemx :red -@var{rgb-val} values that specify the saturation for each primary. -@end table - - -Creates, initializes, and returns a new @var{color} object with the -specified values for red, green, and blue. -@table @var -@item color -Type @var{color}. -@end table - -@end defun - - -@defun color-blue color - -@table @var -@item color -A @var{color} object. -@end table - - -Returns and (with @code{setf}) sets the value for blue in the -@emph{color}. -@table @var -@item blue-intensity -Type @var{rgb-val}. -@end table - -@end defun - - -@defun color-green color - -@table @var -@item color -A @var{color} object. -@end table - - -Returns and (with @code{setf}) sets the value for green in the -@emph{color}. -@table @var -@item green-intensity -Type @var{rgb-val}. -@end table - -@end defun - - -@defun color-p color - -Returns non-@var{nil} if the argument is a @var{color} object and -@var{nil} otherwise. - -@table @var -@item color-p -Type @var{boolean}. -@end table - -@end defun - -@defun color-red color - -@table @var -@item color -A @var{color} object. -@end table - - -Returns and (with @code{setf}) sets the value for red in the -@emph{color}. -@table @var -@item red-intensity -Type @var{rgb-val}. -@end table - -@end defun - - -@defun color-rgb color - -@table @var -@item color -A @var{color} object. -@end table - - -Returns the values for red, green, and blue in the @emph{color}. -@table @var -@item red -@itemx green -@itemx blue -Type @var{rgb-val}. -@end table - -@end defun - - -@node Colormap Functions, , Color Functions, Colors -@section Colormap Functions - - -A colormap is represented in CLX by a @var{colormap} object. A CLX -program can create and manipulate several @var{colormap} -objects. However, the colors contained in a @var{colormap} are made -visible only when the @var{colormap} is @emph{installed}. Each window -is associated with a @var{colormap} that is used to translate window -pixels into colors (see @var{window-colormap}). However, a window will -appear in its true colors only if its associated @var{colormap} is -installed. - -The total number of colormaps that can be installed depends on the -screen hardware. Most hardware devices allow exactly one -@var{colormap} to be installed at any time. That is, -@var{screen-min-installed-maps} and @var{screen-max-installed-maps} -are both equal to 1. Installing a new @var{colormap} can cause a -previously installed @var{colormap} to be uninstalled. It is important -to remember that the set of installed @var{colormaps} is a hardware -resource shared cooperatively among all client programs connected to an -X server. - -A CLX program can control the contents of @var{colormaps} by allocating -color cells in one of two ways: read-only or read-write. Allocating a -read-only color cell establishes a color value for a specified pixel -value that cannot be changed. However, read-only color cells can be -shared among all client programs. Read-only allocation is the best -strategy for making use of limited @var{colormap} hardware in a -multi-client environment. - -Alternatively, allocating a read-write color cell allows a client the -exclusive right to set the color value stored in the cell. A cell -allocated read-write by one client cannot be allocated by another -client, not even as a read-only cell. Note that read-write allocation is -not allowed for screens whose visual type belongs to one of the -@var{:static-gray}, @var{:static-color}, or @var{:true-color} -classes. For screens of these classes, @var{colormap} cells cannot be -modified. - -Two entries of the default colormap, typically containing the colors -black and white, are automatically allocated read-only. The pixel values -for these entries can be returned by the functions -@var{screen-black-pixel} and @var{screen-white-pixel}. Applications -that need only two colors and also need to operate on both monochrome -and color screens should always use these pixel values. The names -@emph{black} and @emph{white} are intended to reflect relative intensity -levels and need not reflect the actual colors displayed for these pixel -values. - -Each screen has a default @var{colormap}, which is initially -installed. By conventions, clients should allocate only read-only cells -from the default @var{colormap}. - -@menu -* Creating Colormaps:: -* Installing Colormaps:: -* Allocating Colors:: -* Finding Colors:: -* Changing Colors:: -* Colormap Attributes:: -@end menu - -@node Creating Colormaps, Installing Colormaps, Colormap Functions, Colormap Functions -@subsection Creating Colormaps - - -CLX provides functions for creating and freeing new @var{colormap} -objects. - -@defun create-colormap visual window &optional alloc-p - -@table @var -@item visual -A @var{visual} type ID. -@item window -A @var{window}. -@item alloc-p -Specifies whether @var{colormap} cells are permanently allocated read-write. -@end table - - -Creates and returns a @emph{colormap} of the specified -@emph{visual} type for the screen containing the -@emph{window}. The @emph{visual} type must be one of those -supported by the screen. - -Initial color cell values are undefined for visual types belonging -to the @var{:gray-scale}, @var{:pseudo-color}, and -@var{:direct-color} classes. Color cell values for visual types -belonging to the @var{:static-gray}, @var{:static-color}, and -@var{:true-color} classes have initial values defined by the -visual type. However, X does not define the set of possible visual -types or their initial color cell values. - -If @emph{alloc-p} is true, all colormap cells are permanently -allocated read-write and cannot be freed by @var{free-colors}. It -is an error for @emph{alloc-p} to be true when the visual type -belongs to the @var{:static-gray}, @var{:static-color}, or -@var{:true-color} classes. - -@table @var -@item colormap -Type @var{colormap}. -@end table - -@end defun - - -@defun copy-colormap-and-free colormap - -@table @var -@item colormap -A @var{colormap}. -@end table - -Creates and returns a new @var{colormap} by copying, then -freeing, allocated cells from the specified @emph{colormap}. - -All color cells allocated read-only or read-write in the original -@var{colormap} have the same color values and the same allocation -status in the @emph{new-colormap}. The values of unallocated color -cells in the @emph{new-colormap} are undefined. After copying, all -allocated color cells in the original @var{colormap} are freed, -as if @var{free-colors} was called. The unallocated cells of the -original @var{colormap} are not affected. - -If @emph{alloc-p} was true when the original @var{colormap} was -created, then all color cells of the @emph{new-colormap} are -permanently allocated read-write, and all the color cells of the -original @var{colormap} are freed. - -@table @var -@item new-colormap -Type @var{colormap}. -@end table - -@end defun - - -@defun free-colormap colormap - -@table @var -@item colormap -A @var{colormap}. -@end table - -Destroys the @emph{colormap} and frees its server resource. If the -@emph{colormap} is installed, it is uninstalled. For any window -associated with the @emph{colormap}, the window is assigned a -@var{nil} @var{colormap}, and a @var{:colormap-notify} event is -generated. The colors displayed for a window with a @var{nil -colormap} are undefined. - -However, this function has no effect if the @emph{colormap} is a -screen default @var{colormap}. - -@end defun - - -@node Installing Colormaps, Allocating Colors, Creating Colormaps, Colormap Functions -@subsection Installing Colormaps - - -The following paragraphs describe the CLX functions to install and -uninstall colormaps and to return the set of installed colormaps. - -Initially, the default @var{colormap} for a screen is installed (but is -not in the required list). - -@defun install-colormap colormap -@anchor{install-colormap} - -@table @var -@item colormap -A @var{colormap}. -@end table - -Installs the @emph{colormap.} All windows associated with this -@emph{colormap} immediately display with true colors. As a -side-effect, additional colormaps might be implicitly uninstalled by -the server. - -If the specified @emph{colormap} is not already installed, a -@var{:colormap-notify} event is generated on every window -associated with this @emph{colormap}. In addition, for every other -colormap that is implicitly uninstalled, a @var{:colormap-notify} -event is generated on every associated window. - - -@end defun - - -@defun installed-colormaps window &key (:result-type 'list) - -@table @var -@item window -A @var{window}. -@item :result-type -A sub-type of @var{sequence} that indicates the type of sequence to return. -@end table - - -Returns a sequence containing the installed @var{colormaps} for the -screen of the specified @emph{window}. The order of the colormaps is -not significant. -@table @var -@item colormap -Type @var{sequence} of @var{colormap}. -@end table - -@end defun - - -@defun uninstall-colormap colormap - -@table @var -@item colormap -A @var{colormap}. -@end table - -Uninstalls the @emph{colormap}. However, the @emph{colormap} is not -actually uninstalled if this would reduce the set of installed -colormaps below the value of @var{screen-min-installed-maps}. If -the @emph{colormap} is actually uninstalled, a -@var{:colormap-notify} event is generated on every associated -window. - - -@end defun - - -@node Allocating Colors, Finding Colors, Installing Colormaps, Colormap Functions -@subsection Allocating Colors - - -The following paragraphs describe the functions for allocating read-only -and read-write color cells, allocating color planes, and freeing color -cells. - -@defun alloc-color colormap color - -@table @var -@item colormap -A @var{colormap}. -@item color -A @var{color} object or a @var{stringable} containing a color name. -@end table - - -Returns a @emph{pixel} for a read-only color cell in the -@emph{colormap}. The color in the allocated cell is the closest -approximation to the requested @emph{color} possible for the screen -hardware. The other values returned give both the approximate color -stored in the cell and the exact color requested. - -The requested @emph{color} can be either a @var{color} object or a -@var{stringable} containing a color name. If a color name is -given, a corresponding color value is looked up (see -@var{lookup-color}) and used. Color name strings must contain only -ISO Latin-1 characters; case is not significant. - -@table @var -@item pixel -Type @var{pixel}. -@item screen-color -@itemx exact-color -Type @var{color}. -@end table - -@end defun - - -@defun alloc-color-cells colormap colors &key (:planes 0) :contiguous-p (:result-type 'list) - -@table @var -@item colormap -A @var{colormap}. -@item colors -A positive number defining the length of the pixels sequence returned. -@item :planes -A non-negative number defining the length of the masks sequence returned. -@item :contiguous-p -If true, the masks form contiguous sets of bits. -@item :result-type -A subtype of @var{sequence} that indicates the type of sequences returned. -@end table - - -Returns a @var{sequence} of @emph{pixels} for read-write color -cells in the @emph{colormap}. The allocated cells contain undefined -color values. The visual type class of the @var{colormap} must be -either @var{:gray-scale}, @var{:pseudo-color}, or -@var{:direct-color}. - -The @emph{colors} argument and the @var{:planes} argument define -the number of pixels and the number of masks returned, -respectively. The number of colors must be positive, and the number -of planes must be non-negative. A total of (* @emph{colors} -(@var{expt} 2 @emph{planes})) color cells are allocated. The pixel -values for the allocated cells can be computed by combining the -returned pixels and masks. - -The length of the returned masks sequence is equal to -@var{:planes}. Each mask of the returned masks sequence defines a -single bitplane. None of the masks have any 1 bits in common. Thus, -by selectively combining masks with @var{logior}, (@var{expt} 2 -@emph{planes}) distinct combined plane masks can be computed. - -The length of the returned @emph{pixels} sequence is equal to -@emph{colors}. None of the pixels have any 1 bits in common with -each other or with any of the returned masks. By combining pixels -and plane masks with @var{logior}, (* @emph{colors} (@var{expt} 2 -@emph{planes})) distinct pixel values can be produced. - -If the @emph{colormap} class is @var{:gray-scale} or -@var{:pseudo-color}, each @emph{mask} will have exactly one bit -set. If the @var{colormap} class is @var{:direct-color}, each -@emph{mask} will have exactly three bits set. If -@var{:contiguous-p} is true, combining all masks with @var{logior} -produces a plane mask with either one set of contiguous bits (for -@var{:gray-scale} and @var{:pseudo-color}) or three sets of -contiguous bits (for @var{:direct-color}). - -@table @var -@item pixels -@itemx mask -Type @var{sequence} of @var{pixels}. -@end table - -@end defun - - -@defun alloc-color-planes colormap colors &key (:reds 0) (:greens 0) (:blues 0) :contiguous-p (:result-type 'list) - -@table @var -@item colormap -A @var{colormap}. -@item colors -A positive number defining the length of the pixels sequence returned. -@item :planes -A non-negative number defining the length of the masks sequence returned. -@item :contiguous-p -If true, then the masks form contiguous sets of bits. -@item :result-type -A subtype of @var{sequence} that indicates the type of sequences returned. -@end table - - -Returns a @var{sequence} of @emph{pixels} for read-write color -cells in the @emph{colormap}. The allocated cells contain undefined -color values. The visual type class of the @emph{colormap} must be -either @var{:gray-scale}, @var{:pseudo-color}, or -@var{:direct-color}. - -The @emph{colors} argument defines the number of pixels -returned. The @var{:reds}, @var{:greens}, and @var{:blues} -arguments define the number of bits set in the returned red, green, -and blue masks, respectively. The number of colors must be positive, -and the number of bits for each mask must be non-negative. A total -of (* @emph{colors} (@var{expt} 2 (+ @emph{reds greens} -@emph{blues}))) color cells are allocated. The pixel values for the -allocated cells can be computed by combining the returned -@emph{pixels} and masks. - -Each mask of the returned masks defines a pixel subfield for the -corresponding primary. None of the masks have any 1 bits in -common. By selectively combining subsets of the red, green, and blue -masks with @var{logior}, (@var{expt} 2 (+ @emph{reds greens -blues}) distinct combined plane masks can be computed. - -The length of the returned @emph{pixels} @var{sequence} is equal to -@emph{colors}. None of the pixels have any 1 bits in common with -each other or with any of the returned masks. By combining pixels -and plane masks with @var{logior}, (* @emph{colors} (@var{expt} 2 -(+ @emph{reds greens blues})) distinct pixel values can be produced. - -If @var{:contiguous-p} is true, each of returned masks consists of -a set of contiguous bits. If the @var{colormap} class is -@var{:direct-color}, each returned mask lies within the pixel -subfield for its primary. - -@table @var -@item pixels -Type @var{sequence} of @var{pixel}. -@item red-mask -@itemx green-mask -@itemx blue-mask -Type @var{pixel}. -@end table - -@end defun - - -@defun free-colors colormap pixels &optional (plane-mask 0) - -@table @var -@item colormap -A @var{colormap}. -@item pixels -A @var{sequence} of pixel values. -@item plane-mask -A pixel value with no bits in common with any of the @emph{pixels}. -@end table - -Frees a set of allocated color cells from the @emph{colormap}. The -pixel values for the freed cells are computed by combining the given -@emph{pixels} sequence and @var{:plane-mask}. The total number of -cells freed is: - -@lisp -(* (@var{length} @emph{pixels}) (@var{expt} 2 (@var{logcount} @emph{plane-mask}))) -@end lisp - -The @var{:plane-mask} must not have any bits in common with any of -the given @emph{pixels}. The pixel values for the freed cells are -produced by using @var{logior} to combine each of the given pixels -with all subsets of the @var{:plane-mask}. - -Note that freeing an individual pixel allocated by -@var{alloc-color-planes} may not allow it to be reused until all -related pixels computed from the same plane mask are also freed. - -A single error is generated if any computed pixel is invalid or if -its color cell is not allocated by the client. Even if an error is -generated, all valid pixel values are freed. - - -@end defun - - -@node Finding Colors, Changing Colors, Allocating Colors, Colormap Functions -@subsection Finding Colors - - -A CLX program can ask the X server to return the colors stored in -allocated color cells. The server also maintains a dictionary of color -names and their associated color values. CLX provides a function to look -up the values for common colors by names such as "red", "purple", and so -forth. The following paragraphs describe the CLX functions for returning -the color values associated with color cells or with color names. - -@defun lookup-color colormap name - -@table @var -@item colormap -A @var{colormap}. -@item name -A @var{stringable} color name. -@end table - - -Returns the color associated by the X server with the given color -@emph{name}. The @emph{name} must contain only ISO Latin-1 -characters; case is not significant. The first value returned is the -closest approximation to the requested color possible on the screen -hardware. The second value returned is the true color value for the -requested color. - -@table @var -@item screen-color -@itemx exact-color -Type @var{color}. -@end table - -@end defun - - -@defun query-colors colormap pixels &key (:result-type 'list) - -@table @var -@item colormap -A @var{colormap}. -@item pixels -A @var{sequence} of @var{pixel} values. -@item :result-type -A subtype of @var{sequence} that indicates the type of sequences returned. -@end table - - -Returns a @var{sequence} of the colors contained in the allocated -cells of the @emph{colormap} specified by the given -@emph{pixels}. The values returned for unallocated cells are -undefined. -@table @var -@item colors -Type @var{sequence} of @var{color}. -@end table - -@end defun - - -@node Changing Colors, Colormap Attributes, Finding Colors, Colormap Functions -@subsection Changing Colors - - -The following paragraphs describe the CLX functions to change the colors -in colormap cells. - -@defun store-color colormap pixel color &key (:red-p t) (:green-p t) (:blue-p t) - -@table @var -@item colormap -A @var{colormap}. -@item pixel -A @var{pixel}. -@item color -A color @var{object} or a @var{stringable} containing a color name. -@item :red-p -@itemx :green-p -@itemx :blue-p -@var{boolean} values indicating which color components to -store. -@end table - -Changes the contents of the @emph{colormap} cell indexed by the -@emph{pixel}. Components of the given @emph{color} are stored in the -cell. The @var{:red-p}, @var{:green-p}, and @var{:blue-p} -arguments indicate which components of the given @emph{color} are -stored. - -The @emph{color} can be either a @var{color} object or a -@var{stringable} containing a color name. If a color name is given, -a corresponding color value is looked up (see @var{lookup-color}) -and used. Color name strings must contain only ISO Latin-1 -characters; case is not significant. - - -@end defun - - -@defun store-colors colormap pixel-colors &key (:red-p t) (:green-p t) (:blue-p t) - -@table @var -@item colormap -A @var{colormap}. -@item pixel-colors -A list of the form (@{@emph{pixel color}@}*). -@item :red-p -@itemx :green-p -@itemx :blue-p -@var{boolean} values indicating which color components to -store. -@end table - -Changes the contents of multiple @emph{colormap} -cells. @emph{pixel-colors} is a list of the form (@{ @emph{pixel -color}@}*), indicating a set of pixel values and the colors to store -in the corresponding cells. The @var{:red-p}, @var{:green-p}, and -@var{:blue-p} arguments indicate which components of the given colors -are stored. - -Each color can be either a @var{color} object or a -@var{stringable} containing a color name. If a color name is given, -a corresponding color value is looked up (see @var{lookup-color}) -and used. Color name strings must contain only ISO Latin-1 -characters; case is not significant. - - -@end defun - - -@node Colormap Attributes, , Changing Colors, Colormap Functions -@subsection Colormap Attributes - - -The complete set of colormap attributes is discussed in the following -paragraphs. - -@defun colormap-display colormap - -@table @var -@item colormap -A @var{colormap}. -@end table - - -Returns the @var{display} object associated with the specified -@emph{colormap}. -@table @var -@item display -Type @var{display}. -@end table - -@end defun - - -@defun colormap-equal colormap-1 colormap-2 - -@table @var -@item colormap-1 -@itemx colormap-2 -A @var{colormap}. -@end table - -Returns true if the two arguments refer to the same server resource -and @var{nil} if they do not. - - -@end defun - - -@defun colormap-id colormap - -@table @var -@item colormap -A @var{colormap}. -@end table - -Returns the unique ID assigned to the specified @emph{colormap}. - -@table @var -@item id -Type @var{resource-id}. -@end table - -@end defun - - -@defun colormap-p colormap - -Returns non-@var{nil} if the argument is a @var{colormap} and -@var{nil} otherwise. - -@table @var -@item map-p -Type @var{boolean}. -@end table - -@end defun - -@defun colormap-plist colormap - -@table @var -@item colormap -A @var{colormap}. -@end table - - - - -Returns and (with @code{setf}) sets the property list for the -specified @emph{colormap}. This function provides a hook where -extensions can add data. - -@table @var -@item colormap-p -Type @var{boolean}. -@end table - -@end defun - - -@node Cursors, Atoms, Colors, Top -@chapter Cursors - -A @emph{cursor} is a visible shape that appears at the current position -of the pointer device. The cursor shape moves with the pointer to -provide continuous feedback to the user about the current location of -the pointer. Each window can have a cursor attribute that defines the -appearance of the pointer cursor when the pointer position lies within -the window. See @var{window-cursor}. - -A cursor image is composed of a source bitmap, a mask bitmap, a @emph{hot -spot}, a foreground color, and a background color. Either 1-bit -pixmaps or font glyphs can be used to specify source and mask -bitmaps. The source bitmap identifies the foreground and background -pixels of the cursor image; the mask bitmap identifies which source -pixels are actually drawn. The mask bitmap thus allows a cursor to -assume any shape. The hot spot defines the position within the cursor -image that is displayed at the pointer position. - -In CLX, a cursor is represented by a @var{cursor} object. This section -describes the CLX functions to: - -@itemize @bullet -@item Create and free cursor objects - -@item Change cursor colors - -@item Inquire the best cursor size - -@item Access cursor attributes -@end itemize - -@menu -* Creating Cursors:: -* Cursor Functions:: -* Cursor Attributes:: -@end menu - -@node Creating Cursors, Cursor Functions, Cursors, Cursors -@section Creating Cursors - - -The following paragraphs describe the CLX functions used to create and -free @var{cursor} objects. - -@defun create-cursor &key :source :mask :x :y :foreground :background - -@table @var -@item :source -The source pixmap. This argument is required. -@item :mask -The mask pixmap. -@item :x -@itemx :y -The hot spot position in the @var{:source}. This argument is required. -@item :foreground -A @var{color} object specifying the foreground color. This argument is required. -@item :background -A @var{color} object specifying the background color. This argument is required. -@end table - - -Creates and returns a cursor. @var{:x} and @var{:y} define the -position of the hot spot relative to the origin of the -@var{:source. :foreground} and @var{:background} colors must be -specified, even if the server only has a @var{:static-gray} or -@var{:gray-scale} screen. The @var{:source}, @var{:x}, and -@var{:y} arguments must also be specified. - -The cursor image is drawn by drawing a pixel from the @var{:source} -bitmap at every position where the corresponding bit in the -@var{:mask} bitmap is 1. If the corresponding @var{:source} bit is -1, a pixel is drawn in the @var{:foreground} color; otherwise, a -pixel is drawn in the @var{:back-ground} color. If the @var{:mask} -is omitted, all @var{:source} pixels are drawn. If given, the -@var{:mask} must be the same size as the @var{:source}. - -An X server may not be able to support every cursor size. A server -is free to modify any component of the cursor to satisfy hardware or -software limitations. - -The @var{:source} and @var{:mask} can be freed immediately after -the cursor is created. Subsequent drawing in the @var{:source} or -@var{:mask} pixmap has an undefined effect on the cursor. - -@table @var -@item cursor -Type @var{cursor}. -@end table - -@end defun - - -@defun create-glyph-cursor &key :source-font :source-char :mask-font (:mask-char 0) :foreground :background - -@table @var -@item :source-font -The source font. This is a required argument. -@item :source-char -An index specifying a glyph in the source font. This is a required argument. -@item :mask-font -The mask font. -@item :mask-char -An index specifying a glyph in the mask font. -@item :foreground -A @var{color} object specifying the foreground color. This is a required argument. -@item :background -A @var{color} object specifying the background color. This is a required argument. -@end table - - -Creates and returns a cursor defined by font glyphs. The source -bitmap is defined by the @var{:source-font} and -@var{:source-char}. The mask bitmap is defined by the -@var{:mask-font} and @var{:mask-char}. It is an error if the -@var{:source-char} and @var{:mask-char} are not valid indexes for -the @var{:source-font} and @var{:mask-font}, respectively. The hot -spot position is defined by the "character origin" of the source -glyph, that is, the position [- @emph{char-left-bearing}, -@emph{char-ascent}] relative to the upper left corner of the source -glyph bitmap. - -Source and mask bits are compared after aligning the character -origins of the source and mask glyphs. The source and mask glyphs -need not have the same size or character origin position. If the -@var{:mask-font} is omitted, all source pixels are drawn. - -An X server may not be able to support every cursor size. A server -is free to modify any component of the cursor to satisfy hardware or -software limitations. - -Either of the @var{:source-font} or @var{:mask-font} can be closed -after the cursor is created. - -@table @var -@item cursor -Type @var{cursor}. -@end table - -@end defun - - -@defun free-cursor cursor - -@table @var -@item cursor -A @var{cursor} object. -@end table - -Destroys the @var{cursor} object. Cursor server resources are freed -when no other references remain. - - -@end defun - - -@node Cursor Functions, Cursor Attributes, Creating Cursors, Cursors -@section Cursor Functions - - -The following paragraphs describe the CLX functions used to operate on -@var{cursor} objects. - -@defun query-best-cursor width height display - -@table @var -@item display -A @var{display} object. -@item width -@itemx height -The requested cursor size. -@end table - -Returns the cursor size closest to the requested @emph{width} and -@emph{height} that is best suited to the display. The @emph{width} -and @emph{height} returned define the largest cursor size supported -by the X server. Clients should always be prepared to limit cursor -sizes to those supported by the server. - -@table @var -@item width -@itemx height -Type @var{card16}. -@end table - -@end defun - - -@defun recolor-cursor cursor foreground background - -@table @var -@item cursor -A @var{cursor} object. -@item foreground -A @var{color} object specifying the new foreground color. -@item background -A @var{color} object specifying the new background color. -@end table - -Changes the color of the specified @emph{cursor}. If the cursor is -displayed on a screen, the change is visible immediately. - - -@end defun - - -@node Cursor Attributes, , Cursor Functions, Cursors -@section Cursor Attributes - - -The complete set of cursor attributes is discussed in the following -paragraphs. - -@defun cursor-display cursor - -@table @var -@item cursor -A @var{cursor} object. -@end table - - -Returns the @var{display} object associated with the specified -@emph{cursor}. - -@table @var -@item display -Type @var{display}. -@end table - -@end defun - - -@defun cursor-equal cursor-1 cursor-2 - -@table @var -@item cursor-1 -@itemx cursor-2 -@var{cursor} objects. -@end table - -Returns true if the two arguments refer to the same server resource -and @var{nil} if they do not. - - -@end defun - - -@defun cursor-id cursor - -@table @var -@item cursor -A @var{cursor} object. -@end table - - -Returns the unique resource ID that has been assigned to the -specified @emph{cursor}. - -@table @var -@item id -Type @var{resource-id.} -@end table - -@end defun - - -@defun cursor-p cursor - -@table @var -@item cursor-p -Type @var{boolean}. -@end table - -Returns true if the argument is a @var{cursor} object and -@var{nil} otherwise. - -@end defun - -@defun cursor-plist cursor - -@table @var -@item cursor -A @var{cursor} object. -@end table - - -Returns and (with @code{setf}) sets the property list for the -specified @emph{cursor}. This function provides a hook where -extensions can add data. - -@table @var -@item plist -A property list. -@end table - -@end defun - - -@node Atoms, Events and Input, Cursors, Top -@chapter Atoms, Properties and Selections - -@menu -* Atoms (Atoms):: -* Properties:: -* Selections:: -@end menu - -@node Atoms (Atoms), Properties, Atoms, Atoms -@section Atoms - - -In X, an @emph{atom} is a unique ID used as the name for certain server -resources -- properties and selections. - -In CLX, an atom is represented by a keyword symbol. For convenience, CLX -functions also allow atoms to be specified by strings and non-keyword -symbols. @var{xatom} is a CLX data type that permits either string or -symbol values. A string is equivalent to the @var{xatom} given by -(@var{intern} @emph{string} @var{'keyword}). A symbol is equivalent to -the @var{xatom} given by ( @var{intern} (@var{symbol-name} -@emph{symbol}) @var{'keyword}). The symbol name string of an -@var{xatom} must consist only of ISO Latin characters. Note that the -case of @var{xatom} strings is important; the @var{xatom} "Atom" is -not the same as the @var{xatom} "ATOM". - -Certain atoms are already predefined by every X server. Predefined atoms -are designed to represent common names that are likely to be useful for -many client applications. Note that these atoms are predefined only in -the sense of having @var{xatom} and @var{card29} values, not in the -sense of having required semantics. No interpretation is placed on the -meaning or use of an atom by the server. The @var{xatom} objects -predefined by CLX are listed below. - -@multitable @columnfractions 0.3 0.3 0.3 -@item @var{:arc} @tab @var{:italic_angle} @tab @var{:string} -@item @var{:atom} @tab @var{:max_space} @tab @var{:subscript_x} -@item @var{:bitmap} @tab @var{:min_space} @tab @var{:subscript_y} -@item @var{:cap_height} @tab @var{:norm_space} @tab @var{:superscript_x} -@item @var{:cardinal} @tab @var{:notice} @tab @var{:superscript_y} -@item @var{:colormap} @tab @var{:pixmap} @tab @var{:underline_position} -@item @var{:copyright} @tab @var{:point} @tab @var{:underline_thickness} -@item @var{:cursor} @tab @var{:point_size} @tab @var{:visualid} -@item @var{:cut_buffer0} @tab @var{:primary} @tab @var{:weight} -@item @var{:cut_buffer1} @tab @var{:quad_width} @tab @var{:window} -@item @var{:cut_buffer2} @tab @var{:rectangle} @tab @var{:wm_class} -@item @var{:cut_buffer3} @tab @var{:resolution} @tab @var{:wm_client_machine} -@item @var{:cut_buffer4} @tab @var{:resource_manager} @tab @var{:wm_command} -@item @var{:cut_buffer5} @tab @var{:rgb_best_map} @tab @var{:wm_hints} -@item @var{:cut_buffer6} @tab @var{:rgb_blue_map} @tab @var{:wm_icon_name} -@item @var{:cut_buffer7} @tab @var{:rgb_color_map}@tab @var{:wm_icon_size} -@item @var{:drawable} @tab @var{:rgb_default_map} @tab @var{:wm_name} -@item @var{:end_space} @tab @var{:rgb_gray_map} @tab @var{:wm_normal_hints} -@item @var{:family_name} @tab @var{:rgb_green_map}@tab @var{:wm_size_hints} -@item @var{:font} @tab @var{:rgb_red_map} @tab @var{:wm_transient_for} -@item @var{:font_name} @tab @var{:secondary} @tab @var{:wm_zoom_hints} -@item @var{:full_name} @tab @var{:strikeout_ascent} @tab @var{:x_height} -@item @var{:integer} @tab @var{:strikeout_descent} @tab -@end multitable - - -When creating a new atom, the following conventions should be obeyed in -order to minimize the conflict between atom names: - -@itemize @bullet -@item -Symbol names beginning with an underscore should be used for atoms -that are private to a particular vendor or organization. An additional -prefix should identify the organization. - -@item -Symbol names beginning with two underscores should be used for atoms -that are private to a single application or end user. -@end itemize - - -CLX provides functions to convert between an @var{xatom} and its -corresponding ID integer. The data type of an atom ID is -@var{card29}. The @var{xatom} representation is usually sufficient for -most CLX programs. However, it is occasionally useful to be able to -convert an atom ID returned in events or properties into its -corresponding @var{xatom}. - -@defun atom-name display atom-id - -@table @var -@item display -A @var{display} object. -@item atom-id -A @var{card29}. -@end table - -Returns the atom keyword for the @emph{atom-id} on the given -@emph{display} server. - -@table @var -@item atom-name -Type @var{keyword}. -@end table - -@end defun - - -@defun find-atom display atom-name - -@table @var -@item display -A @var{display} object. -@item atom-name -An @var{xatom}. -@end table - -Returns the atom ID for the given @emph{atom-name}, if it exists. If -no atom of that name exists for the display server, @var{nil} is -returned. - -@table @var -@item atom-id -Type @var{card29} or @var{null}. -@end table - -@end defun - - -@defun intern-atom display atom-name - -@table @var -@item display -A @var{display} object. -@item atom-name -An @var{xatom}. -@end table - -Creates an atom with the given name and returns its atom ID. The -atom can survive the interning client; it exists until the last -server connection has been closed and the server resets itself. - -@table @var -@item atom-id -Type @var{card29} or @var{null}. -@end table - -@end defun - - -@node Properties, Selections, Atoms (Atoms), Atoms -@section Properties - - -For each window, an X server can record a set of -@emph{properties}. Properties are a general mechanism for clients to -associate arbitrary data with a window, and for clients to communicate -window data to each other via the server. No interpretation is placed on -property data by the server itself. - -A property consists of a name, a type, a data format, and data. The name -of a property is given by an atom. The property type is another atom -used to denote the intended interpretation of the property data. The -property formats specifies whether the property data should be treated -as a set of 8-, 16-, or 32-bit elements. The property format must be -specified so that the X server can communicate property data with the -correct byte order. - -CLX provides functions to: - -@itemize @bullet -@item Create or change a property - -@item Return property data - -@item List window properties - -@item Delete a property -@end itemize - - -@defun change-property window property data type format &key (:mode :replace) (:start 0) :end :transform - -@table @var -@item window -A @var{window}. -@item property -A property name @var{xatom}. -@item data -A sequence of property data elements. -@item type -The property type @var{xatom}. -@item format -One of 8, 16, or 32. -@item :mode -One of @var{:replace}, @var{:append}, or @var{:prepend}. -@item :start -@itemx :end -Specify the subsequence of previous data replaced when @var{:mode} is @var{:replace}. -@item :transform -A function that transforms each data element into a data value to store. -@end table - -Creates a new window property or changes an existing property. A -@var{:property-notify} event is generated for the @emph{window}. - -If the @var{:mode} is @var{:replace}, the new @emph{data}, -@emph{type}, and @emph{format} replace any previous values. The -subsequence of previous data elements that are replaced is defined -by the @var{:start} and @var{:end} indexes. - -If the @var{:mode} is @var{:prepend} or @var{:append}, no -previous data is changed, but the new @emph{data} is added at the -beginning or the end, respectively. For these modes, if the -@emph{property} already exists, the new @emph{type} and -@emph{format} must match the previous values. - -The @var{:transform}, if given, is a function used to compute the -actual property data stored. The @var{:transform}, which must -accept a single data element and return a single transformed data -element, is called for each data element. If the @emph{data} is a -string, the default @var{:transform} function transforms each -character into its ASCII code; otherwise, the default is to store -the @emph{data} unchanged. - - -@end defun - - -@defun delete-property window property - -@table @var -@item window -A @var{window}. -@item property -A property name @var{xatom}. -@end table - -Deletes the @emph{window property}. If the @emph{property} already -exists, a @var{:property-notify} event is generated for the -@emph{window}. - - -@end defun - - -@defun get-property window property &key :type (:start 0) :end :delete-p (:result-type 'list) :transform -@anchor{get-property} - -@table @var -@item window -A @var{window}. -@item property -A property name @var{xatom}. -@item :type -The requested type @var{xatom} or @var{nil}. -@item :start -@itemx :end -Specify the subsequence of property @emph{data} returned. -@item :transform -A function that transforms each data element into a data value to return. -@item :delete-p -If true, the existing @emph{property} can be deleted. -@item :result-type -The t@emph{ype} of data sequence to return. Default is @var{'list}. -@end table - -Returns a subsequence of the data for the window property. The -@var{:start} and @var{:end} indexes specify the property -@emph{data} elements returned. The @var{:transform} function is -called for elements of the specified subsequence to compute the -@emph{data} sequence returned. The property @emph{type} and -@emph{format} are also returned. The final return value gives the -actual number of data bytes (not elements) following the last data -element returned. - -If the @emph{property} does not exist, the returned @emph{data} and -@emph{type} are @var{nil} and the returned @emph{format} and -@emph{bytes-after} are zero. - -If the given @var{:type} is non-@var{nil} but does not match the -actual property type, then the @emph{data} returned is @var{nil}, -the @emph{type} and @emph{format} returned give the actual property -values, and the @emph{bytes-after} returned gives the total number -of bytes (not elements) in the property data. - -If the given @var{:type} is @var{nil} or if it matches the actual -property type, then: - -@itemize @bullet -@item -The @emph{data} returned is the transformed subsequence of the -property data. - -@item -The @emph{type} and @emph{format} returned give the actual -property values. - -@item -The @emph{bytes-after} returned gives the actual number of data -bytes (not elements) following the last data element returned. -@end itemize - - -In this case, the @var{:delete-p} argument is also examined. If -@var{:delete-p} is true and @emph{bytes-after} is zero, the -property is deleted and a @var{:property-notify} event is generated -for the @emph{window}. - -@table @var -@item data -Type @var{sequence}. -@item type -Type @var{xatom}. -@item format -Type (@var{member 8 16 32}). -@item bytes-after -Type @var{card32}. -@end table - -@end defun - - -@defun list-properties window &key (:result-type 'list) - -@table @var -@item window -A @var{window}. -@item :result-type -The type of sequence to return. Default is @var{'list}. -@end table - - -Returns a sequence containing the names of all @emph{window -properties}. -@table @var -@item properties -Type @var{sequence} of @var{keyword}. -@end table - -@end defun - - -@defun rotate-properties window properties &optional (delta 1) - -@table @var -@item window -A @var{window}. -@item properties -A sequence of @var{xatom} values. -@item delta -The index interval between source and destination elements of @emph{properties}. -@end table - -Rotates the values of the given @emph{window properties}. The value -of property @emph{i} in the given sequence is changed to the value -of the property at index (@var{mod} (+ @emph{i delta}) -(@var{length} @emph{properties})). This function operates much like -the @var{rotatef} macro in Common Lisp. - -If (@var{mod} @emph{delta} (@var{length} @emph{properties})) is -non-zero, a @var{:property-notify} event is generated on the window -for each property, in the same order as they appear in the -@emph{properties} sequence. - - -@end defun - - -@node Selections, , Properties, Atoms -@section Selections - - -A selection is an atom used to identify data that can be shared among -all client programs connected to an X server. Unlike properties, the -data represented by a selection is stored by some client program, not by -the server. - -The data named by a selection is associated with a client window, which -is referred to as the @emph{selection owner}. The server always knows -which window is the owner of a selection. Selections can be created -freely by clients using @var{intern-atom} to create an atom. CLX -provides functions to inquire or change the owner of a selection and to -@emph{convert} a selection. - -Conversion is the key to the use of selections for inter-client -communication. Suppose Client A wants to paste the contents of the data -named by selection @emph{S} into his window @emph{WA}. Client A calls -@var{convert-selection} on selection atom @emph{S}, sending a -conversion request to the server. The server, in turn, sends a -@var{:selection-request} event to the current owner of @emph{S}, which -is window @emph{WB} belonging to Client B. The @var{:selection-request} -event contains the @emph{requestor} window (@emph{WA}), the selection -atom (@emph{S}), an atom identifying a requested data type, and the name -of a property of @emph{WA} into which the value of @emph{S} will be -stored. - -Since @emph{WB} is the owner of @emph{S}, it must be associated with the -data defined by Client B as the value of @emph{S}. When @emph{WB} gets -the @var{:selection-request} event, Client B is expected to convert the -value of @emph{S} to the requested data type (if possible) and store the -converted value in the given requestor property. Client B is then -expected to send a @var{:selection-notify} event to the requestor -window @emph{WA}, informing the requestor that the converted value for -@emph{S} is ready. Upon receiving the @var{:selection-notify} event, -Client A can call @var{get-property} to retrieve the converted value -and to paste it into @emph{WA}. - -@var{NOTE:} Clients using selections must always be prepared to handle -@var{:selection-request} events and/or @var{:selection-notify} -events. There is no way for a client to ask not to receive these types -of events. - -Type atoms used in selection conversion can represent arbitrary -client-defined interpretations of the selection data. For example, if -the value of selection @emph{S} is a text string, Client A might request -its typeface by requesting conversion to the @var{:font} type. A type -@var{atom} can also represent a request to the selection owner to -perform some action as a side-effect of conversion (for example, -@var{:delete}). Some of the predefined atoms of an X server are -intended to be used as selection types (for example, @var{:colormap}, -@var{:bitmap}, @var{:string}, and so forth) However, X does not impose -any requirements on the interpretation of type atoms. - -When multiple clients negotiate for ownership of a selection, certain -race conditions might be possible. For example, two clients might each -receive a user command to assert ownership of the @var{:primary} -selection, but the order in which the server processes these client -requests is unpredictable. As a result, the ownership request initiated -most recently by the user might be incorrectly overridden by the other -earlier ownership request. To prevent such anomalies, the server records -a @emph{last-changed} timestamp for each change of selection ownership. - -Although inter-client communication via selections is rather complex, it -offers important benefits. Since selection communication is mediated by -an X server, clients can share data even though they are running on -different hosts and using different networking protocols. Data storage -and conversion is distributed among clients so that the server is not -required to provide all possible data types or to store multiple forms -of selection data. - -Certain predefined atoms are used as standard selections, as described -in the X11 Inter-client Communications Conventions Manual. Some of the -standard selections covered by these conventions are: - -@table @var -@item :primary -The @emph{primary selection}. The main vehicle for inter-client cut -and paste operations. -@item :secondary -The @emph{secondary selection}. In some environments, clients can use -this as an auxiliary to @var{:primary}. -@item :clipboard -Analogous to akill ring. Represents the most recently deleted data -item. -@end table - - -@defun convert-selection selection type requestor &optional property time - -@table @var -@item selection -The @var{xatom} for the selection name. -@item type -The @var{xatom} for the requested data type. -@item requestor -The @var{window} to receive the converted @emph{selection} value. -@item property -The @var{xatom} for the requestor property to receive the converted value. -@item time -A @var{timestamp}. -@end table - -Requests that the value of the @emph{selection} be converted to the -specified @emph{type} and stored in the given @emph{property} of the -@emph{requestor} window. - -If the @emph{selection} has an owner, the X server sends a -@var{:selection-request} event to the owner window. Otherwise, if -no owner exists, the server generates on the requestor a -@var{:selection-notify} event containing a @var{nil} -@emph{property} atom. - -The given @emph{property} specifies the requestor property that will -receive the converted value. If the @emph{property} is omitted, the -@emph{selection} owner will define a property to use. The -@emph{time} furnishes a timestamp representing the time of the -conversion request; by default, the current server time is used. - -@var{NOTE:} Standard conventions for inter-client communication -require that both the requestor property and the time must be -specified. If possible, the time should be the time of a user event -which initiated the conversion. Alternatively, a timestamp can be -obtained by calling @var{change-property} to append zero-length -data to some property; the timestamp in the resulting -@var{:property-notify} event can then be used. - - -@end defun - - -@defun selection-owner display selection &optional time - -@table @var -@item display -A @var{display}. -@item selection -The @var{xatom} for the selection name. -@item time -A @var{timestamp}. -@end table - - -Returns and (with @code{setf}) changes the owner and the -last-changed @emph{time} for the @emph{selection}. If the owner is -@var{nil}, no owner for the @emph{selection} exists. When the owner -window for a @emph{selection} is destroyed, the @emph{selection} -owner is set to @var{nil} without affecting the last-changed -@emph{time}. - -The @emph{time} argument is used only when changing the -@emph{selection} owner. If the @emph{time} is @var{nil}, the -current server time is used. If the @emph{time} is earlier than the -current last-changed time of the @emph{selection} or if the -@emph{time} is later than the current server time, the owner is not -changed. Therefore, a client should always confirm successful change -of ownership by immediately calling @var{selection-owner}. If the -change in ownership is successful, the last-changed time of the -@emph{selection} is set to the specified @emph{time}. - -If the change in ownership is successful and the new owner is -different from the previous owner, and if the previous owner is not -@var{nil}, a @var{:selection-clear} event is generated for the -previous owner window. - -@var{NOTE:} Standard conventions for inter-client communication -require that a non-nil time must be specified. If possible, the time -should be the time of a user event which initiated the change of -ownership. Alternatively, a timestamp can be obtained by calling -change-property to append zero-length data to some property; the -timestamp in the resulting @var{:property-notify} event can then be -used. -@table @var -@item owner -Type @var{window} or @var{null}. -@end table - -@end defun - - -@node Events and Input, Resources, Atoms, Top -@chapter Events and Input - -A client application uses CLX functions to send @emph{requests} to an X -server over a display connection returned by the @var{open-display} -function. In return, the X server sends back @emph{replies} and -@emph{events}. Replies are synchronized with specific requests and -return requested server information. Events typically occur -asynchronously. Device events are generated by user input from both the -keyboard and pointer devices. Other events are side-effects of the -requests sent by CLX functions. The types of events returned by an X -server are summarized below. - -Device Events - -@table @asis -@item Keyboard -@var{:key-press} @var{:key-release} -@item Pointer -@var{:button-press} -@var{:button-release} -@var{:enter-notify} -@var{:leave-notify} -@var{:motion-notify} -@end table - -Side-Effect Events - -@table @asis -@item Client communication -@var{:client-message} -@var{:property-notify} -@var{:selection-clear} -@var{:selection-notify} -@var{:selection-request} -@item Color map state -@var{:colormap-notify} - -@item Exposure -@var{:exposure} -@var{:graphics-exposure} -@var{:no-exposure} - -@item Input focus -@var{:focus-in} -@var{:focus-out} - -@item Keyboard and pointer state -@var{:keymap-notify} -@var{:mapping-notify} - -@item Structure control -@var{:circulate-request} -@var{:configure-request} -@var{:map-request} - -@item Window state -@var{:resize-request} -@var{:circulate-notify} -@var{:configure-notify} -@var{:create-notify} -@var{:destroy-notify} -@var{:gravity-notify} -@var{:map-notify} -@var{:reparent-notify} -@var{:unmap-notify} -@var{:visibility-notify} -@end table - -Client programs can override the server's normal distribution of events -by@emph{ grabbing} the pointer or the keyboard. Grabbing causes events -from the pointer or keyboard device to be reported to a single specified -window, rather than to their ordinary destinations. It can also cause -the server to @emph{freeze} the grabbed device, sending queued events -only when explicitly requested by the grabbing client. Two kinds of -grabs are possible: -@itemize @bullet - -@item Active -- Events are immediately grabbed. - -@item Passive -- Events are grabbed later, as soon as a specified device event occurs. -@end itemize - -Grabbing an input device is performed rarely and usually only by special -clients, such as window managers. - -This section describes the CLX functions used to: -@itemize @bullet - -@item Select events (@pxref{Selecting Events}) - -@item Process an event on the event queue (@pxref{Processing Events}) - -@item Manage the event queue (@pxref{Managing the Event Queue}) - -@item Send events to other applications (@pxref{Sending Events}) - -@item Read and change the pointer position (@pxref{Pointer Position}) - -@item Manage the keyboard input focus (@pxref{Managing Input Focus}) - -@item Grab pointer and keyboard events (@pxref{Grabbing the Pointer}) - -@item Release queued events (@pxref{Releasing Queued Events}) -@end itemize - -This section also contains a detailed description of the content of each type of event. - -@menu -* Selecting Events:: -* Processing Events:: -* Managing the Event Queue:: -* Sending Events:: -* Pointer Position:: -* Managing Input Focus:: -* Grabbing the Pointer:: -* Grabbing a Button:: -* Grabbing the Keyboard:: -* Grabbing a Key:: -* Event Types:: -* Releasing Queued Events:: -@end menu - -@node Selecting Events, Processing Events, Events and Input, Events and Input -@section Selecting Events - - -A client @emph{selects} which types of events it receives from a -specific window. The window event-mask attribute, set by the client, -determines which event types are selected (see @var{window-event-mask} -in @ref{Window Attributes}). Most types of events are received -by a client only if they are selected for some window. - -In the X protocol, an event-mask is represented as a bit string. CLX -also allows an event mask to be defined by a list of -@var{event-mask-class} keywords. The functions @var{make-event-keys} -and @var{make-event-mask} can be used to convert between these two -forms of an event-mask. In general, including an @var{event-mask-class} -keyword in an event-mask causes one or more related event types to be -selected. The following table describes the event types selected by each -@var{event-mask-class} keyword. - -@multitable @columnfractions 0.5 0.5 -@item Event Mask Keyword @tab Event Types Selected -@item @var{:button-1-motion} -@tab @var{:motion-notify} when @var{:button-1} is down -@item @var{:button-2-motion} -@tab @var{:motion-notify} when @var{:button-2} is down -@item @var{:button-3-motion} -@tab @var{:motion-notify} when @var{:button-3} is down -@item @var{:button-4-motion} -@tab @var{:motion-notify} when @var{:button-4} is down -@item @var{:button-5-motion} -@tab @var{:motion-notify} when @var{:button-5} is down -@item @var{:button-motion} -@tab @var{:motion-notify} when any pointer button is down -@item @var{:button-press} -@tab @var{:button-press} -@item @var{:button-release} -@tab @var{:button-release} -@item @var{:colormap-change} -@tab @var{:colormap-notify} -@item @var{:enter-window} -@tab @var{:enter-notify} -@item @var{:exposure} -@tab @var{:exposure} -@item @var{:focus-change} -@tab @var{:focus-in} @var{:focus-out} -@item @var{:key-press} -@tab @var{:key-press} -@item @var{:key-release} -@tab @var{:key-release} -@item @var{:keymap-state} -@tab @var{:keymap-notify} -@item @var{:leave-window} -@tab @var{:leave-notify} -@item @var{:owner-grab-button} -@tab Pointer events while button is grabbed -@item @var{:pointer-motion} -@tab @var{:motion-notify} -@item @var{:pointer-motion-hint} -@tab Single @var{:motion-notify} only -@item @var{:property-change} -@tab @var{:property-notify} -@item @var{:resize-redirect} -@tab @var{:resize-request} -@item @var{:structure-notify} -@tab @var{:circulate-notify} @var{:configure-notify} @var{:destroy-notify} @var{:gravity-notify} @var{:map-notify} @var{:reparent-notify} @var{:unmap-notify} -@item @var{:substructure-redirect} -@tab @var{:circulate-request} @var{:configure-request} @var{:map-request} -@item @var{:visibility-change} -@tab @var{:visibility-notify} -@end multitable - - -Some types of events do not have to be selected to be received and -therefore are not represented in an event-mask. For example, the -@var{copy-plane} and @var{copy-area} functions cause -@var{:graphics-exposure} and @var{:no-exposure} events to be reported, -unless exposures are turned @var{:off} in the graphics context (see -@var{copy-area} and @var{copy-plane} in @ref{Area and Plane Operations}, -and @var{gcontext-exposures} in paragraph 5.4.6, Exposures). Also, @var{:selection-clear}, @var{:selection-request}, -@var{:selection-notify} and @var{:client-message} events can be -received at any time, but they are generally sent only to clients using -selections (@pxref{Client Communications Events}). @var{:mapping-notify} is always sent to clients when the -keyboard mapping is changed. - -Any client can select events for any window. A window maintains a -separate event-mask for each interested client. In general, multiple -clients can select for the same events on a window. After the X server -generates an event, it sends it to all clients which selected -it. However, the following restrictions apply to sharing window events -among multiple clients. For a given window: -@itemize @bullet - -@item Only one client at a time can include @var{:substructure-redirect} in its event-mask - -@item Only one client at a time can can include @var{:button-press} in its event-mask - -@item Only one client at a time can include @var{:resize-redirect} in its event-mask -@end itemize - -@node Processing Events, Managing the Event Queue, Selecting Events, Events and Input -@section Processing Events - - -Events received by a CLX client are stored in an @emph{event queue} -until they are read and processed. Events are processed by @emph{handler -functions}. - -@defun handler-function &rest event-slots &key :display :event-key :send-event-p &allow-other-keys - -@table @var -@item :display -A @var{display} for the connection that returned the event. -@item :event-key -An @var{event-key} keyword specifying the event type. -@item :send-event-p -If true, the event was sent from another application using the -@var{send-event} function. -@end table - - -The arguments to a handler function are keyword-value pairs that -describe the contents of an event. The actual @emph{event-slots} -passed depend on the event type, except that @var{:display}, -@var{:event-key}, and @var{:send-event-p} are given for all event -types. The keyword symbols used for each event type are event slot -names defined by the @var{declare-event} macro and are described in -@ref{Declaring Event Types}. - -If a handler returns non-@var{nil}, the event is considered -@emph{processed} and can be removed from the event queue. Otherwise, -if a handler function returns @var{nil}, the event can remain in -the event queue for later processing. -@table @var -@item handled-p -Type @var{boolean}. -@end table - -@end defun - - -@defun process-event display &key :handler :timeout :peek-p :discard-p (:force-output-p t) - -@table @var -@item display -A @var{display}. -@item :handler -A handler function or a sequence of handler functions. -@item :timeout -Specifies the timeout delay in seconds. -@item :peek-p -If @var{nil}, events are removed from the event queue after processing. -@item :discard-p -If true, unprocessed events are discarded. -@item :force-output-p -If true, buffered output requests are sent. -@end table - - -Invokes @var{:handler} on each queued event until @var{:handler} -returns non-@var{nil}. Then, the non-@var{nil :handler} value is -returned by @var{process-event}. If @var{:handler} returns -@var{nil} for each event in the event queue, @var{process-event} -waits for another event to arrive. If timeout is non-@var{nil} and -no event arrives within the specified timeout interval (given in -seconds), @var{process-event} returns @var{nil}; if timeout is -@var{nil}, @var{process-event} will not return until -@var{:handler} returns non-@var{nil}. @var{process-event} may -wait only once on network data, and therefore timeout prematurely. - -If @var{:force-output-p} is true, @var{process-event} first -invokes @var{display-force-output} to send any buffered -requests. If @var{:peek-p} is true, a processed event is not -removed from the queue. If @var{:discard-p} is true, unprocessed -events are removed from the queue; otherwise, unprocessed events are -left in place. - -If @var{:handler} is a sequence, it is expected to contain handler -functions for each event type. The sequence index of the handler -function for a particular event type is given by ( @var{position -event-key *event-key-vector*}). -@table @var -@item handled-p -Type @var{boolean}. -@end table - -@end defun - - -@defmac event-case display &key :timeout :peek-p :discard-p (:force-output-p t) &body clauses -@anchor{event-case} - -@table @var -@item display -A @var{display}. -@item :handler -A handler function or a sequence of handler functions. -@item :timeout -Specifies the timeout delay, in seconds. -@item :peek-p -If @var{nil}, events are removed from the event queue after processing. -@item :discard-p -If true, unprocessed events are discarded. -@item :force-output-p -If true, buffered output requests are sent. -@item clauses -Code to process specified event types. -@end table - -Executes the matching clause for each queued event until a clause -returns non-@var{nil}. The non-@var{nil} clause value is then -returned. Each of the clauses is a list of the form -(@emph{event-match} [@emph{event-slots}] &rest @emph{forms}), -where: -@itemize @bullet - -@item -@emph{event-match} -- Either an @var{event-key}, a list of -@var{event-keys}, otherwise, or @var{t}. It is an error for the -same key to appear in more than one clause. - -@item -@emph{event-slots} -- If given, a list of (non-keyword) event slot -symbols defined for the specified event type(s). @xref{Declaring Event Types}. - -@item -@emph{forms} -- A list of forms that process the specified event -type(s). The value of the last form is the value returned by the -clause. -@end itemize - -A clause matches an event if the @var{event-key} is equal to or a -member of the @emph{event-match}, or if the @emph{event-match} is -@var{t} or @var{otherwise}. If no @var{t} or @var{otherwise} -clause appears, it is equivalent to having a final clause that -returns @var{nil}. If @emph{event-slots} is given, these symbols -are bound to the value of the corresponding event slot in the clause -forms. Each element of @emph{event-slots} can also be a list of the -form (@emph{event-slot-keyword variable}), in which case the -@emph{variable} symbol is bound to the value of the event slot -specified by the @emph{event-slot-keyword}. - -If every clause returns @var{nil} for each event in the event -queue, @var{event-case} waits for another event to arrive. If -@var{:timeout} is non-@var{nil} and no event arrives within the -specified timeout interval (given in seconds), @var{event-case} -returns @var{nil}; if @var{:timeout} is @var{nil}, -@var{event-case} will not return until a clause returns -non-@var{nil}. @var{event-case} may wait only once on network data -and therefore timeout prematurely. - -If @var{:force-output-p} is true, @var{event-case} first invokes -@var{display-force-output} to send any buffered requests. If -@var{:peek-p} is true, a processed event is not removed from the -queue. If @var{:discard-p} is true, unprocessed events are removed -from the queue; otherwise, unprocessed events are left in place. - -@table @var -@item handled-p -Type @var{boolean}. -@end table - -@end defmac - - - -@defmac event-cond display &key :timeout :peek-p :discard-p (:force-output-p t) &body clauses - -@table @var -@item handled-p -Type @var{boolean}. -@end table - - -Similar to @var{event-case} except that each of the clauses is a -list of the form (@emph{event-match} [@emph{event-slots}] -@emph{test-form} &rest @emph{forms}). Executes the -@emph{test-form} of the clause that matches each queued event until -a @emph{test-form} returns non-@var{nil}. The body @emph{forms} of -the clause are then executed. The values returned by the last clause -body form are then returned by @var{event-cond}. - -When a @emph{test-form} returns true and @var{:peek-p} is -@var{nil}, or when a @emph{test-form} returns @var{nil} and -@var{:discard-p} is true, the matching event is removed from the -event queue before the body @emph{forms} are executed. -@table @var -@item display -A @var{display}. -@item :handler -A handler function or a sequence of handler functions. -@item :timeout -Specifies the timeout delay in seconds. -@item :peek-p -If @var{nil}, events are removed from the event queue after processing. -@item :discard-p -If true, unprocessed events are discarded. -@item :force-output-p -If true, buffered output requests are sent. -@item clauses -Code to process specified event types. -@end table - -@end defmac - - - -@node Managing the Event Queue, Sending Events, Processing Events, Events and Input -@section Managing the Event Queue - - -The following paragraphs describe CLX functions and macros used to: -@itemize @bullet - -@item Put a new event on the event queue - -@item Discard the current event - -@item Return the current length of the event queue - -@item Gain exclusive access to the event queue for a client process -@end itemize - -@defun queue-event display event-key &rest event-slots &key :append-p &allow-other-keys - -@table @var -@item display -A @var{display}. -@item event-key -Specifies the type of event placed in the queue. -@item event-slots -Keyword-value pairs that describe the contents of an event. -@item :append-p -If true, the event is placed at the tail of the queue; otherwise, the event is -placed at the head of the queue. -@end table - -Places an event of the type given by @emph{event-key} into the event -queue. When @var{:append-p} is true, the event is placed at the -tail of the queue; otherwise, the event is placed at the head of the -queue. The actual @emph{event-slots} passed depend on the event -type. The keyword symbols used for each event type are event slot -names defined by the @var{declare-event} macro and are described in -@ref{Declaring Event Types}. - - - -@end defun - - -@defun discard-current-event display - -@table @var -@item display -A @var{display}. -@end table - - -Discards the current event for the @emph{display}. Returns -@var{nil} when the event queue is empty; otherwise, returns -@var{t}. This function provides extra flexibility for discarding -events, but it should be used carefully; use @var{event-cond} -instead, if possible. Typically, @var{discard-current-event} is -called inside a handler function or a clause of an @var{event-case} -form and is followed by another call to @var{process-event}, -@var{event-case}, or @var{event-cond}. -@table @var -@item discarded-p -Type @var{boolean}. -@end table - -@end defun - - -@defun event-listen display &optional (timeout 0) - -@table @var -@item display -A @var{display}. -@item timeout -The number of seconds to wait for events. -@end table - - -Returns the number of events queued locally. If the event queue is -empty, @var{event-listen} waits for an event to arrive. If timeout -is non-@var{nil} and no event arrives within the specified timeout -interval (given in seconds), @var{event-listen} returns @var{nil}; -if timeout is @var{nil}, @var{event-listen} will not return until -an event arrives. -@table @var -@item event-count -Type @code{(or null integer)}. -@end table - -@end defun - -@defmac with-event-queue display &body body -@anchor{with-event-queue} - -@table @var -@item display -A @var{display}. -@item body -Forms to execute. -@end table - -Executes the @emph{body} in a critical region in which the executing -client process has exclusive access to the event queue. - -@end defmac - - - -@node Sending Events, Pointer Position, Managing the Event Queue, Events and Input -@section Sending Events - - -A client can send an event to a window. Clients selecting this window -event will receive it just like any other event sent by the X server. - -@defun send-event window event-key event-mask &rest event-slots &key :propagate-p :display &allow-other-keys - -@table @var -@item window -The destination @var{window} for the event. -@item event-key -An @var{event-key} defining the type of event to send. -@item event-mask -Specifies the event types that receiving clients must select. -@item event-slots -Keyword-value pairs that describe the contents of an event. -@item :propagate-p -If true, the event can be propagated to ancestors of the destination window. -@item :display -A @var{display}. -@end table - -Sends an event specified by the @emph{event-key} and -@emph{event-slots} to the given destination @emph{window}. Any -active grabs are ignored. The @emph{event-slots} passed depend on -the event type. The keyword symbols used for each event type are -event slot names defined by the @var{declare-event} macro and are -described in @ref{Declaring Event Types}. - -If the @emph{window} is @var{:pointer-window}, the destination -@emph{window} is replaced with the window containing the -pointer. If the @emph{window} is @var{:input-focus}, the -destination @emph{window} is replaced with the descendant of the -focus window that contains the pointer or (if no such descendant -exists) the focus window. The @var{:display} keyword is only -required if the @emph{window} is @var{:pointer-window} or -@var{:input-focus}. - -The @emph{event-key} must be one of the core events, or one of the -events defined by an extension, so the server can send the event -with the correct byte-order. The contents of the event are -otherwise unaltered and unchecked by the server, except that the -@var{send-event-p} event slot is set to true. - -If the @emph{event-mask} is @var{nil}, the event is sent to the -client that created the destination @emph{window} with an -@emph{event-mask} of 0; if that client no longer exists, no event -is sent. Otherwise, the event is sent to every client selecting -any of the event types specified by @emph{event-mask} on the -destination @emph{window}. - -If @var{:propagate-p} is true and no clients have selected any of -the event types in @emph{event-mask} on the destination -@emph{window}, the destination is replaced with the closest -ancestor of @emph{window} for which some client has selected a -type in @emph{event-mask} and no intervening window has that type -in its do-not-propagate mask. If no such window exists, or if the -@emph{window} is an ancestor of the focus window and -@var{:input-focus} was originally specified as the destination, -the event is not sent to any clients. Otherwise, the event is -reported to every client selecting on the final destination any of -the types specified in @emph{event-mask}. - - -@end defun - - -@node Pointer Position, Managing Input Focus, Sending Events, Events and Input -@section Pointer Position - - -The CLX functions affecting pointer position are discussed in the -following paragraphs. - -@defun query-pointer window - -@table @var -@item window -A @var{window} specifying the coordinate system for the returned position. -@end table - - -Returns the current pointer coordinates relative to the given -@emph{window}. If @var{query-pointer} returns @var{nil} for -@emph{same-screen-p}, the pointer is not on the same screen as the -@emph{window}. In this case, @var{query-pointer} returns a value -of @var{nil} for @emph{child} and a value of zero for @emph{x} -and @emph{y}. If @var{query-pointer} returns true for -@emph{same-screen-p}, the returned @emph{x} and @emph{y} are -relative to the origin of window. The @emph{child} is the child of -the window containing the pointer, if any. The @emph{state-mask} -returned gives the current state of the modifier keys and pointer -buttons. The returned @emph{root} is the root window currently -containing the pointer. The returned @emph{root-x} and -@emph{root-y} specify the pointer coordinates relative to -@emph{root}. -@table @var -@item x -Type @var{int16}. -@item y -Type @var{int16}. -@item same-screen-p -Type @var{boolean}. -@item child -Type @var{window} or @var{null}. -@item state-mask -Type @var{card16}. -@item root-x -Type @var{int16}. -@item root-y -Type @var{int16}. -@item root -Type @var{window}. -@end table - -@end defun - - -@defun global-pointer-position display - -@table @var -@item display -A @var{display}. -@end table - - -Returns the @emph{root} window currently containing the @emph{display} pointer and the current -position of the pointer relative to the @emph{root}. -@table @var -@item root-x -Type @var{int16}. -@item root-y -Type @var{int16}. -@item root -Type @var{window}. -@end table - -@end defun - - -@defun pointer-position window - -@table @var -@item window -A @var{window} specifying the coordinate system for the returned position. -@end table - - -Returns the current pointer coordinates relative to the given -@emph{window}. If @var{pointer-position} returns @var{nil} for -@emph{same-screen-p}, the pointer is not on the same screen as the -@emph{window}. In this case, @var{pointer-position} returns a -value of @var{nil} for @emph{child} and a value of zero for -@emph{x} and @emph{y}. If @var{pointer-position} returns true for -@emph{same-screen-p}, the returned @emph{x} and @emph{y} are -relative to the origin of @emph{window}. -@table @var -@item x -Type @var{int16}. -@item y -Type @var{int16}. -@item same-screen-p -Type @var{boolean}. -@item child -Type @var{window} or @var{null}. -@end table - -@end defun - - -@defun motion-events window &key :start :stop (:result-type 'list) - -@table @var -@item window -The @var{window} containing the returned motion events. -@item :start -@itemx :stop -@var{timestamp} values for the time interval for returned motion events. -@item :result-type -The form of the returned motion events. -@end table - - -Many X server implementations maintain a more precise history of -pointer motion between event notifications. The pointer position -at each pointer hardware interrupt can be stored into a buffer for -later retrieval.This is called the @emph{motion history buffer}. A -paint program, for example, may want to have a precise history of -where the pointer traveled, even though for most other -applications this amount of detail is grossly excessive. - -The @var{motion-events} function returns all events in the motion -history buffer that fall between the specified @var{:start} and -@var{:stop} timestamps (inclusive) and have coordinates that lie -within the specified @emph{window} (including borders) at its -present placement. If the @var{:start} time is later than the -@var{:stop} time or if the @var{:start} time is in the future, -no events are returned. -@table @var -@item motion-events -Type @code{(repeat-seq (int16 x) (int16 y) (timestamp time))}. -@end table - -@end defun - - -@defun warp-pointer destination destination-x destination-y - -@table @var -@item destination -The @var{window} into which the pointer is moved. -@item destination-x -@itemx destination-y -The new position of the pointer relative to the destination. -@end table - -Moves the pointer to the given coordinates relative to the -@emph{destination} window. @var{warp-pointer} should be rarely be -used since the user should normally be in control of the pointer -position. @var{warp-pointer} generates events just as if the user -had instantaneously moved the pointer from one position to another. - -@var{warp-pointer} cannot move the pointer outside the confine-to -window of an active pointer grab; an attempt to do so only moves the -pointer as far as the closest edge of the confine-to window. - - -@end defun - - -@defun warp-pointer-relative display x-offset y-offset - -@table @var -@item display -A @var{display}. -@item x-offset -@itemx y-offset -The offsets used to adjust the pointer position. -@end table - -Moves the pointer by the given offsets. This function should rarely -be used since the user should normally be in control of the pointer -position. @var{warp-pointer-relative} generates events just as if -the user had instantaneously moved the pointer from one position to -another. - -@var{warp-pointer-relative} cannot move the pointer outside the -confine-to window of an active pointer grab; an attempt to do so -only moves the pointer as far as the closest edge of the confine-to -window. - - -@end defun - - -@defun warp-pointer-if-inside destination destination-x destination-y source source-x source-y &optional (source-width 0) (source-height 0) - -@table @var -@item destination -The @var{window} into which the pointer is moved. -@item destination-x -@itemx destination-y -The new position of the pointer relative to the @emph{destination}. -@item source -The @var{window} that must currently contain the pointer. -@item source-x -@itemx source-y -@itemx source-width -@itemx source-height -The source rectangle that must currently contain the pointer. -@end table - -Moves the pointer to the given position relative to the -@emph{destination} window. However, the move can only take place if -the pointer is currently contained in a visible portion of the -specified rectangle of the @emph{source} window. If -@emph{source-height} is zero, it is replaced with the current height -of @emph{source} window minus @emph{source-y}. If -@emph{source-width} is zero, it is replaced with the current width -of @emph{source} window minus @emph{source-x}. - -@var{warp-pointer-if-inside} generates events just as if the user -had instantaneously moved the pointer from one position to -another. @var{warp-pointer-if-inside} cannot move the pointer -outside the confine-to window of an active pointer grab; an attempt -to do so only moves the pointer as far as the closest edge of the -confine-to window. - - -@end defun - -@defun warp-pointer-relative-if-inside x-offset y-offset source source-x source-y &optional (source-width 0) (source-height 0) - -@table @var -@item x-offset -@itemx y-offset -The offsets used to adjust the pointer position. -@item source -The @var{window} that must currently contain the pointer. -@item source-x -@itemx source-y -@itemx source-width -@itemx source-height -The source rectangle that must currently contain the pointer. -@end table - -Moves the pointer by the given offsets. However, the move can only -take place if the pointer is currently contained in a visible -portion of the specified rectangle of the @emph{source} window. If -@emph{source-height} is zero, it is replaced with the current height -of @emph{source-window} minus @emph{source-y}. If -@emph{source-width} is zero, it is replaced with the current width -of @emph{source-window} minus @emph{source-x}. - -@var{warp-pointer-relative-if-inside} generates events just as if -the user had instantaneously moved the pointer from one position to -another. @var{warp-pointer-relative-if-inside} cannot move the -pointer outside the confine-to window of an active pointer grab; an -attempt to do so only moves the pointer as far as the closest edge -of the confine-to window. - - - -@end defun - - -@node Managing Input Focus, Grabbing the Pointer, Pointer Position, Events and Input -@section Managing Input Focus - - -CLX provides the @var{set-focus-input} and @var{focus-input} functions -to set and get the keyboard input focus window. - -@defun set-input-focus display focus revert-to &optional time - -@table @var -@item display -A @var{display}. -@item focus -The new input focus @var{window}. -@item revert-to -The focus @var{window} when focus is no longer viewable. -@item time -A @var{timestamp}. -@end table - -Changes the keyboard input focus and the last-focus-change -time. The function has no effect if the specified @emph{time} is -earlier than the current last-focus-change time or is later than -the current server time; otherwise, the last-focus-change time is -set to the specified @emph{time}. The @var{set-input-focus} -function causes the X server to generate @var{:focus-in} and -@var{:focus-out} events. - -If @var{:none} is specified as the @emph{focus}, all keyboard -events are discarded until a new focus window is set. In this -case, the @emph{revert-to} argument is ignored. - -If a window is specified as the @emph{focus} argument, it becomes -the keyboard's focus window. If a generated keyboard event would -normally be reported to this window or one of its inferiors, the -event is reported normally; otherwise, the event is reported with -respect to the focus window. - -If @var{:pointer-root} is specified as the @emph{focus} argument, -the input focus window is set to the root window of the screen -containing the pointer when each keyboard event occurs. In this -case, the @emph{revert-to} argument is ignored. - -The specified @emph{focus} window must be viewable at the time of -the request. If the @emph{focus} window later becomes not -viewable, the new focus window depends on the @emph{revert-to} -argument. If @emph{revert-to} is specified as @var{:parent}, the -@emph{focus} reverts to the parent (or the closest viewable -ancestor) and the new @emph{revert-to} value is take to be -@var{:none}. If @emph{revert-to} is @var{:pointer-root} or -@var{:none}, the @emph{focus} reverts to that value. When the -@emph{focus} reverts, @var{:focus-in} and @var{:focus-out} -events are generated, but the last-focus-change time is not -affected. - - -@end defun - - -@defun input-focus display - -@table @var -@item display -A @var{display}. -@end table - - -Returns the @emph{focus} window, @var{:pointer-root}, or -@var{:none}, depending on the current state of the focus -window. @emph{revert-to} returns the current focus revert-to -state. -@table @var -@item focus -Type (@var{or window} (@var{member :none :pointer-root})). -@item revert-to -Type (@var{or window} (@var{member :none :pointer-root :parent})). -@end table - -@end defun - - -@node Grabbing the Pointer, Grabbing a Button, Managing Input Focus, Events and Input -@section Grabbing the Pointer - - -CLX provides the @var{grab-pointer} and @var{ungrab-pointer} functions -for grabbing and releasing pointer control. - -@defun grab-pointer window event-mask &key :owner-p :sync-pointer-p :sync-keyboard-p :confine-to :cursor :time - -@table @var -@item window -The @var{window} grabbing the pointer. -@item event-mask -A @var{pointer-event-mask}. -@item :owner-p -If true, all client windows receive pointer events normally. -@item :sync-pointer-p -Indicates whether the pointer is in synchronous or asynchronous mode. -@item :sync-keyboard-p -Indicates whether the keyboard is in synchronous or asynchronous mode. -@item :confine-to -A @var{window} to which the pointer is confined. -@item :cursor -A @var{cursor}. -@item :time -A @var{timestamp}. A @var{nil} value means the current server time is used. -@end table - - -Actively grabs control of the pointer. Further pointer events are -only reported to the grabbing client. The request overrides any -active pointer grab by this client. - -If @var{:owner-p} is @var{nil}, all generated pointer events are -reported with respect to @emph{window}, and are only reported if -selected by @emph{event-mask}. If @var{:owner-p} is true, and if a -generated pointer event would normally be reported to this client, -it is reported normally; otherwise the event is reported with -respect to the @emph{window}, and is only reported if selected by -@emph{event-mask}. For either value of @var{:owner-p}, unreported -events are simply discarded. - -If @var{:sync-pointer-p} is @var{nil}, pointer event processing -continues normally (asynchronously); if the pointer is currently -frozen by this client, then processing of pointer events is -resumed. If @var{:sync-pointer-p} is true (indicating a synchronous -action), the pointer (as seen via the protocol) appears to freeze, -and no further pointer events are generated by the server until the -grabbing client issues a releasing @var{allow-events} request. -Actual pointer changes are not lost while the pointer is frozen; -they are simply queued for later processing. - -If @var{:sync-keyboard-p} is @var{nil}, keyboard event processing -is unaffected by activation of the grab. If @var{:sync-keyboard-p} -is true, the keyboard (as seen via the protocol) appears to freeze, -and no further keyboard events are generated by the server until the -grabbing client issues a releasing @var{allow-events} -request. Actual keyboard changes are not lost while the keyboard is -frozen; they are simply queued for later processing. - -If @var{:cursor} is specified, it is displayed regardless of what -window the pointer is in. Otherwise, the normal cursor for the -@emph{window} is displayed. - -If a @var{:confine-to} window is specified, the pointer is -restricted to stay within that window. The @var{:confine-to} -window does not need to have any relationship to the -@emph{window}. If the pointer is not initially in the -@var{:confine-to} window, it is warped automatically to the closest -edge (with @var{:enter}/@var{:leave-events} generated normally) -just before the grab activates. If the @var{:confine-to} window is -subsequently reconfigured, the pointer is warped automatically as -necessary to keep it contained in the window. - -@var{grab-pointer} generates @var{:enter-notify} and -@var{:leave-notify} events. @var{grab-pointer} can fail with a -status of: -@itemize @bullet - -@item -@var{:already-grabbed} if the pointer is actively grabbed by some -other client - -@item -@var{:frozen} if the pointer is frozen by an active grab of -another client - -@item -@var{:not-viewable} if the @emph{window} or the -@var{:confine-to} window is not viewable, or if the -@var{:confine-to} window lies completely outside the boundaries -of the root window. - -@item -@var{:invalid-time} if the specified time is earlier than the -last-pointer-grab time or later than the current server -time. Otherwise, the last-pointer-grab time is set to the -specified time, with current-time replaced by the current server -time, and a value of @var{:success} is returned by -@var{grab-pointer}. -@end itemize -@table @var -@item grab-status -One of @var{:already-grabbed}, @var{:frozen}, @var{:invalid-time}, -@var{:not-viewable}, or @var{:success}. -@end table - -@end defun - - -@defun ungrab-pointer display &key :time - -@table @var -@item display -A @var{display}. -@item :time -A @var{timestamp}. -@end table - -Releases the pointer if this client has it actively grabbed (from -either @var{grab-pointer}, @var{grab-button}, or from a normal -button press), and releases any queued events. The request has no -effect if the specified @var{:time} is earlier than the -last-pointer-grab time or is later than the current server time. An -@var{ungrabpointer} is performed automatically if the event window -or @var{:confine-to} window for an active pointer grab becomes not -viewable. - -This request generates @var{:enter-notify} and @var{:leave-notify} -events. - - -@end defun - - -@defun change-active-pointer-grab display event-mask &optional cursor time - -@table @var -@item display -A @var{display}. -@item event-mask -A @var{pointer-event-mask}. -@item cursor -A @var{cursor} or @var{nil}. -@item time -A @var{timestamp}. -@end table - -Changes the specified dynamic parameters if the pointer is actively -grabbed by the client and the specified @emph{time} is no earlier -than the last-pointer-grab time and no later than the current server -time. The interpretation of @emph{event-mask} and @emph{cursor} are -as in @var{grab-pointer}. @var{change-active-pointer-grab} has no -effect on the passive parameters of a @var{grab-button}. - - -@end defun - - -@node Grabbing a Button, Grabbing the Keyboard, Grabbing the Pointer, Events and Input -@section Grabbing a Button - - -CLX provides the @var{grab-button} and @var{ungrab-button} functions -for passively grabbing and releasing pointer control. - -@defun grab-button window button event-mask &key (:modifiers 0) :owner-p :sync-pointer-p :sync-keyboard-p :confine-to :cursor - -@table @var -@item window -A @var{window}. -@item button -The button (type @var{card8}) pressed or @var{:any}. -@item event-mask -A @var{pointer-event-mask}. -@item :modifiers -A @var{modifier-mask}. -@item :owner-p -If true, all client windows receive pointer events normally. -@item :sync-pointer-p -Indicates whether the pointer is handled in a synchronous or asynchronous fashion. -@item :sync-keyboard-p -Indicates whether the keyboard is in synchronous or asynchronous mode. -@item :confine-to -A @var{window} to which the pointer is confined. -@item :cursor -A @var{cursor}. -@end table - -This request establishes a passive grab. If the specified -@emph{button} is pressed when the specified modifier keys are down -(and no other buttons or modifier keys are down), and: -@itemize @bullet - -@item @emph{window} contains the pointer - -@item The @var{:confine-to} window (if any) is viewable - -@item These constraints are not satisfied for any ancestor of @emph{window} -@end itemize - -then: -@itemize @bullet - -@item -The pointer is actively grabbed as described with -@var{grab-pointer} - -@item -The last-pointer-grab time is set to the time that the button was -pressed (as transmitted in the @var{:button-press} event) - -@item -The @var{:button-press} event is reported -@end itemize - -The interpretation of the remaining arguments is the same as with -@var{grab-pointer}. The active grab is terminated automatically -when all buttons are released (independent of the state of modifier -keys). - -A zero @emph{modifier} mask is equivalent to issuing the request for -all possible modifier-key combinations (including the combination of -no modifiers). It is not required that all specified modifiers have -currently assigned keycodes. A @emph{button} of @var{:any} is -equivalent to issuing the request for all possible -buttons. Otherwise, it is not required that the specified -@emph{button} currently be assigned to a physical button. - - -@end defun - - -@defun ungrab-button window button &key (:modifiers 0) - -@table @var -@item window -A @var{window}. -@item button -The button (type @var{card8}) that is released or @var{:any}. -@item :modifiers -A @var{modifier-mask}. -@end table - -Releases the passive button/key combination on the specified -@emph{window} if it was grabbed by this client. A zero -@emph{modifier} mask is equivalent to issuing the request for all -possible modifier combinations including the combination of no -modifiers. A @emph{button} of @var{:any} is equivalent to issuing -the request for all possible buttons. This has no effect on an -active grab. - - -@end defun - - -@node Grabbing the Keyboard, Grabbing a Key, Grabbing a Button, Events and Input -@section Grabbing the Keyboard - - -CLX provides the @var{grab-keyboard} and @var{ungrab-keyboard} -functions for actively grabbing and releasing control of the keyboard. - -@defun grab-keyboard window &key :owner-p :sync-pointer-p :sync-keyboard-p :time - -@table @var -@item window -A @var{window}. -@item :owner-p -If true, all client windows receive keyboard input normally. -@item :sync-pointer-p -Indicates whether the pointer is in synchronous or asynchronous mode. -@item :sync-keyboard-p -Indicates whether the keyboard is in synchronous or asynchronous mode. -@item :time -A @var{timestamp}. -@end table - - -Actively grabs control of the keyboard. Further key events are -reported only to the grabbing client. The request overrides any -active keyboard grab by this client. @var{grab-keyboard} generates -@var{:focus-in} and @var{:focus-out} events. - -If @var{:owner-p} is @var{nil}, all generated key events are -reported with respect to @emph{window}. If @var{:owner-p} is true, -then a generated key event that would normally be reported to this -client is reported normally; otherwise the event is reported with -respect to the @emph{window}. Both @var{:key-press} and -@var{:key-release} events are always reported, independent of any -event selection made by the client. - -If @var{:sync-keyboard-p} is @var{nil}, keyboard event processing -continues normally (asynchronously); if the keyboard is currently -frozen by this client, then processing of keyboard events is -resumed. If @var{:sync-keyboard-p} is true, the keyboard (as seen -via the protocol) appears to freeze, and no further keyboard events -are generated by the server until the grabbing client issues a -releasing @var{allow-events} request. Actual keyboard changes are -not lost while the keyboard is frozen; they are simply queued for -later processing. - -If @var{:sync-pointer-p} is @var{nil}, pointer event processing is -unaffected by activation of the grab. If @var{:sync-pointer-p} is -true, the pointer (as seen via the protocol) appears to freeze, and -no further pointer events are generated by the server until the -grabbing client issues a releasing @var{allow-events} -request. Actual pointer changes are not lost while the pointer is -frozen; they are simply queued for later processing. - -The grab can fail with a status of: -@itemize @bullet - -@item -@var{:already-grabbed} if the keyboard is actively grabbed by -some other client - -@item -@var{:frozen} if the keyboard is frozen by an active grab from -another client - -@item -@var{:not-viewable} if @emph{window} is not viewable - -@item -@var{:invalid-time} if the specified time is earlier than the -last-keyboard-grab time or later than the current server -time. Otherwise, @var{grab-keyboard} returns a status of -@var{:success} and last-keyboard-grab time is set to the -specified time, with current-time replaced by current server time. -@end itemize -@table @var -@item grab-status -One of @var{:already-grabbed}, @var{:frozen}, @var{:invalid-time}, -@var{:not-viewable}, or @var{:success}. -@end table - -@end defun - - -@defun ungrab-keyboard display &key :time - -@table @var -@item display -A @var{display}. -@item :time -A @var{timestamp}. -@end table - -Releases the keyboard if this client has it actively grabbed (from -either @var{grab-keyboard} or @var{grab-key}), and releases any -queued events. The request has no effect if the specified time is -earlier than the last-keyboard-grab time or is later than the -current server time. An @var{ungrab-keyboard} is performed -automatically if the event window for an active keyboard grab -becomes not viewable. - - -@end defun - - -@node Grabbing a Key, Event Types, Grabbing the Keyboard, Events and Input -@section Grabbing a Key - - -The following paragraphs describe the functions used for passively -grabbing and releasing the keyboard. - -@defun grab-key window key &key (:modifiers 0) :owner-p :sync-pointer-p :sync-keyboard-p :time - -@table @var -@item window -A @var{window}. -@item key -The key (type @var{card8}) to be grabbed or @var{:any}. -@item :modifiers -A @var{modifier-mask}. -@item :owner-p -If true, all client windows receive keyboard input normally. -@item :sync-pointer-p -Indicates whether the pointer is in synchronous or asynchronous mode. -@item :sync-keyboard-p -Indicates whether the keyboard is in synchronous or asynchronous mode. -@item :time -A @var{timestamp}. -@end table - -This request establishes a passive grab on the keyboard. If the -specified @emph{key} (which can also be a modifier key) is pressed -(whether or not any specified modifier keys are down), and either of -the following is true: -@itemize @bullet - -@item -@emph{window} is an ancestor of (or is) the focus window - -@item -@emph{window} is a descendant of the focus window and contains the -pointer - -@item -These constraints are not satisfied for any ancestor of -@emph{window}, then the following occurs: -@itemize @bullet - -@item -The keyboard is actively grabbed as described in -@var{grab-keyboard} - -@item -The last-keyboard-grab time is set to the time that the -@emph{key} was pressed (as transmitted in the -@var{:key-press} event) - -@item -The @var{:key-press} event is reported -@end itemize -@end itemize -The interpretation of the remaining arguments is as for -@var{grab-keyboard}. The active grab is terminated automatically when -the specified @emph{key} has been released, independent of the state -of the modifier keys. - -A zero modifier mask is equivalent to issuing the request for all -possible modifier combinations (including the combination of no -modifiers). It is not required that all specified modifiers have -currently assigned keycodes. A @emph{key} of @var{:any} is -equivalent to issuing the request for all possible -keycodes. Otherwise, the @emph{key} must be in the range specified -by @var{display-min-keycode} and @var{display-max-keycode} in the -connection setup. - - -@end defun - - -@defun ungrab-key window key &key (:modifiers 0) - -@table @var -@item window -A @var{window}. -@item key -The key (type @var{card8}) to be released or @var{:any}. -@item :modifiers -A @var{modifier-mask}. -@end table - -Releases the @emph{key} combination on the specified @emph{window} -if it was grabbed by this client. A zero modifier mask of -@var{:any} is equivalent to issuing the request for all possible -modifier combinations (including the combination of no modifiers). A -@emph{key} of @var{:any} is equivalent to issuing the request for -all possible keycodes. @var{ungrab-key} has no effect on an active -grab. - - -@end defun - - -@node Event Types, Releasing Queued Events, Grabbing a Key, Events and Input -@section Event Types - - -The following paragraphs contain detailed descriptions of the contents -of each event type. In CLX, events are not actually represented by -structures, but rather by lists of keyword values passed to handler -functions or by values bound to symbols within the clauses of -@var{event-case} and @var{event-cond} forms. Nevertheless, it is -convenient to describe event contents in terms of slots and to -identify the components of events with slot name symbols. In fact, CLX -uses the @var{declare-event} macro to define event slot symbols and to -map these symbols to specific event data items returned by the X -server (@pxref{Declaring Event Types}). - -The following paragraphs describe each event type, listing its -@var{event-key} keyword symbol and its slot name symbols. An event -keyword symbol identifies a specific event type. An event keyword -symbol can be given as an argument to @var{send-event} or to an event -handler function; it can also appear in the @emph{event-match} form of -an @var{event-case} clause. An event slot name symbol identifies a -specific event data item. Event slot names appear as keywords with -associated values among the arguments passed to @var{send-event} or to -an event handler function; as non-keyword symbols, they can also be in -the @emph{event-slots} form of an @var{event-case} clause. - -In certain cases, more than one name symbol is defined for the same -event slot. For example, in @var{:key-press} events, the symbols -@emph{window} and @emph{event-window} both refer to the same event data -item. - -@menu -* Keyboard and Pointer Events:: -* Input Focus Events:: -* Keyboard and Pointer State Events:: -* Exposure Events:: -* Window State Events:: -* Structure Control Events:: -* Client Communications Events:: -* Declaring Event Types:: -@end menu - -@node Keyboard and Pointer Events, Input Focus Events, Event Types, Event Types -@subsection Keyboard and Pointer Events - - -The keyboard and pointer events are: @var{:key-press} @var{:key-release}, -@var{:button-press}, @var{:button-release}, @var{:motion-notify}, -@var{:enter-notify}, and @var{:leave-notify}. - -@deftp {Event Type} :key-press -@deftpx {Event Type} :key-release -@deftpx {Event Type} :button-press -@deftpx {Event Type} :button-release - -Selected by @var{:key-press}, @var{:key-release}, @var{:button-press}, -or @var{:button-release}. - -@var{:key-press}, and @var{:key-release} events are generated when -a key or pointer button changes state. Note that @var{:key-press} -and @var{:key-release} are generated for all keys, even those -mapped to modifiers. All of these event types have the same -slots. The window containing the pointer at the time of the event is -referred to as the @emph{source} window. The @emph{event} -@emph{window} is the window to which the event is actually -reported. The event window is found by starting with the source -window and looking up the hierarchy for the first window on which -any client has selected interest in the event (provided no -intervening window prohibits event generation by including the event -type in its do-not-propagate-mask). The actual window used for -reporting can be modified by active grabs and, in the case of -keyboard events, can be modified by the focus window. - -A @var{:button-press} event has the effect of a temporary -@var{grab-button}. When a pointer button is pressed and no active -pointer grab is in progress, the ancestors of the source window are -searched from the @emph{root} down, looking for a passive grab to -activate. If no matching passive grab on the button exists, then an -active grab is started automatically for the client receiving the -@var{:button-press} event, and the last-pointer-grab time is set to -the current server time. The effect is essentially equivalent to -calling @var{grab-button} with the following arguments: - -@table @var -@item @emph{window} -The event window. -@item @emph{button} -The button that was pressed. -@item @emph{event-mask} -The client's selected pointer events on the event window. -@item @var{:modifiers} -0 -@item @var{:owner-p} -@var{t} if the client has @var{:owner-grab-button} selected on the event window; otherwise @var{nil}. -@item @var{:sync-pointer-p} -@var{nil} -@item @var{:sync-keyboard-p} -@var{nil} -@item @var{:confine-to} -@var{nil} -@item @var{:cursor} -@var{nil} -@end table - - -The @var{:button-press} grab is terminated automatically when all -buttons are released. The functions @var{ungrab-pointer} and -@var{change-active-pointer-grab} can both be used to modify the -@var{:button-press} grab. - -@table @var -@item window -@item event-window -Type @var{window}. - -The window receiving the event. - -@item code -Type @var{card8}. - -The @emph{code} argument varies with the event type. For @var{:key-press} and -@var{:key-release}, @emph{code} is the keycode (@pxref{Keyboard Encodings}). For -@var{:button-press} and @var{:button-release}, @emph{code} is the pointer button number. - -@item x -Type @var{int16}. - -If @emph{event-window} is on the same screen as root, then @emph{x} and @emph{y} are the pointer -coordinates relative to the @emph{event-window}; otherwise @emph{x} and @emph{y} are zero. - -@item y -Type @var{int16}. - -If @emph{event-window} is on the same screen as root, then @emph{x} and @emph{y} are the pointer -coordinates relative to the @emph{event-window}; otherwise @emph{x} and @emph{y} are zero. - -@item state -Type @var{card16}. - -A mask that gives the state of the buttons and modifier keys just before the -event. - -@item time -Type @var{card32}. - -A timestamp for the moment when the event occurred. - -@item root -Type @var{window}. - -The root window of the source window. - -@item root-x -Type @var{int16}. - -The x coordinate of the pointer position relative to root at the time of the event. - -@item root-y -Type @var{int16}. - -The y coordinate of the pointer position relative to root at the time of the event@emph{.} - -@item child -Type (@var{or null window}). - -If the source window is an inferior of the @emph{event-window}, @emph{child} is set to the child -of @emph{event-window} that is an ancestor of (or is) the source window; otherwise, it is -set to @var{nil}@emph{.} - -@item same-screen-p -Type @var{boolean}. - -True if @emph{event-window} and root are on the same screen. -@end table - -@end deftp - - -@deftp {Event Type} :motion-notify - -Selected by: @var{:button-1-motion}, @var{:button-2-motion}, -@var{:button-3-motion}, @var{:button-4-motion}, -@var{:button-5-motion}, @var{:button-motion}, or -@var{:pointer-motion}. - - -The @var{:motion-notify} event is generated when the pointer -moves. A @var{:motion-notify} event has the same slots as -@var{:button-press} @var{:button-release}, @var{:key-press}, and -@var{:key-release} events, with the exception that the @emph{code} -slot is replaced by the @emph{hint-p} slot. As with these other -events, the event window for @var{:motion-notify} is found by -starting with the source window and looking up the hierarchy for the -first window on which any client has selected interest in the event -(provided no intervening window prohibits event generation by -including @var{:motion-notify} in its do-not-propagate-mask).The -actual window used for reporting can be modified by active grabs. - -@var{:motion-notify} events are generated only when the motion -begins and ends in the window. The granularity of motion events is -not guaranteed, but a client selecting for motion events is -guaranteed to get at least one event when the pointer moves and -comes to rest. Selecting @var{:pointer-motion} generates -@var{:motion-notify} events regardless of the state of the pointer -buttons. By selecting some subset of @var{:button[1-5]-motion} -instead, @var{:motion-notify} events are only received when one or -more of the specified buttons are pressed. By selecting -@var{:button-motion}, @var{:motion-notify} events are only -received when at least one button is pressed. If -@var{:pointer-motion-hint} is also selected, the server is free to -send only one @var{:motion-notify}, until either the key or button -state changes, the pointer leaves the event window, or the client -calls @var{query-pointer} or @var{motion-events}. - -@table @var -@item hint-p -Type @var{boolean}. - -True if the event is a hint generated by selecting @var{:pointer-motion-hint}. -@end table - -@end deftp - - - -@deftp {Event Type} :enter-notify -@deftpx {Event Type} :leave-notify -@anchor{:enter-notify} - -Selected by: @var{:enter-window} or @var{:leave-window}. - -If pointer motion or a window hierarchy change causes the pointer to -be in a different window than before, @var{:enter-notify} and -@var{:leave-notify} events are generated instead of a -@var{:motion-notify} event. All @var{:enter-notify} and -@var{:leave-notify} events caused by a hierarchy change are -generated after any hierarchy event (@var{:unmap-notify}, -@var{:map-notify}, @var{:configure-notify}, -@var{:gravity-notify}, or @var{:circulate-notify}) caused by that -change, but the ordering of @var{:enter-notify} and -@var{:leave-notify} events with respect to @var{:focus-out}, -@var{:visibility-notify}, and @var{:exposure} events is not -constrained by the X protocol. An @var{:enter-notify} or -@var{:leave-notify} event can also be generated when a client -application calls @var{change-active-pointer-grab}, -@var{grab-pointer}, or @var{ungrab-pointer}. - -@table @var -@item window -@itemx event-window -Type @var{window}. - -The window receiving the event. - -@item x -Type @var{int16}. - -The final pointer position. If @emph{event-window} is on the same screen as root, then @emph{x} -and @emph{y} are the pointer coordinates relative to the @emph{event-window}; otherwise @emph{x} and -@emph{y} are zero. - -@item y -Type @var{int16}. - -The final pointer position. If @emph{event-window} is on the same screen as root, then @emph{x} -and @emph{y} are the pointer coordinates relative to the @emph{event-window}; otherwise @emph{x} and -@emph{y} are zero. - -@item mode -Type (@var{member :normal :grab :ungrab}). - -Events caused when the pointer is actively grabbed have mode @var{:grab}. Events -caused when an active pointer grab deactivates have mode @var{:ungrab}. In all -other cases, mode is @var{:normal}. - -@item kind -Type (@var{member :ancestor :virtual :inferior :nonlinear} @var{:nonlinear-virtual}). - -When the pointer moves from window A to window B, and A is an inferior of -B: -@itemize @bullet - -@item -@var{:leave-notify} with @emph{kind} @var{:ancestor} is generated on A - -@item -@var{:leave-notify} with @emph{kind} @var{:virtual} is generated on each window between A -and B exclusive (in that order) - -@item -@var{:enter-notify} with @emph{kind} @var{:inferior} is generated on B -@end itemize - -When the pointer moves from window A to window B, and -B is an inferior of A: -@itemize @bullet - -@item -@var{:leave-notify} with @emph{kind} @var{:inferior} is generated on A - -@item -@var{:enter-notify} with @emph{kind} -@var{:virtual} is generated on each window between -A and B exclusive (in that order) - -@item -@var{:enter-notify} with @emph{kind} @var{:ancestor} is generated on B -@end itemize - -When the pointer moves from window A to window B, with -window C being their least common ancestor: -@itemize @bullet - -@item -@var{:leave-notify} with @emph{kind} @var{:nonlinear} is generated on A - -@item -@var{:leave-notify} with @emph{kind} -@var{:nonlinear-virtual} is generated on each -window between A and C exclusive (in that order) - -@item -@var{:enter-notify} with @emph{kind} -@var{:nonlinear-virtual} is generated on each -window between C and B exclusive (in that order) - -@item -@var{:enter-notify} with @emph{kind} -@var{:nonlinear} is generated on B -@end itemize - -When the pointer moves from window A to window B, on different screens: -@itemize @bullet - -@item -@var{:leave-notify} with @emph{kind} @var{:nonlinear} is generated on A - -@item -If A is not a root window, @var{:leave-notify} with @emph{kind} @var{:nonlinear-virtual} is -generated on each window above A up to and including its root (in order) - -@item -If B is not a root window, @var{:enter-notify} with -@emph{kind} @var{:nonlinear-virtual} is generated -on each window from B's root down to but not -including B (in order) - -@item -@var{:enter-notify} with @emph{kind} @var{:nonlinear} is generated on B -@end itemize - -When a pointer grab activates (but after any initial warp into a -confine-to window, and before generating any actual -@var{:button-press} event that activates the grab), with -@emph{G} the @var{grab-window} for the grab and @emph{P} the -window the pointer is in, then @var{:enter-notify} and -@var{:leave-notify} events with mode @var{:grab} are generated -(as for @var{:normal} above) as if the pointer were to suddenly -warp from its current position in @emph{P} to some position in -@emph{G}. However, the pointer does not warp, and the pointer -position is used as both the @emph{initial} and @emph{final} -positions for the events. - -When a pointer grab deactivates (but after generating any actual -@var{:button-release} event that deactivates the grab), with -@emph{G} the @var{grab-window} for the grab and @emph{P} the -window the pointer is in, then @var{:enter-notify} and -@var{:leave-notify} events with mode @var{:ungrab} are -generated (as for @var{:normal} above) as if the pointer were -to suddenly warp from from some position in @emph{G} to its -current position in @emph{P}. However, the pointer does not -warp, and the current pointer position is used as both the -@emph{initial} and @emph{final} positions for the events. - -@item focus-p -Type @var{boolean}. - -If @emph{event-window} is the focus window or an inferior of the focus window, then -@emph{focus-p} is @var{t}; otherwise, @emph{focus-p} is @var{nil}. - -@item state -Type @var{card16}. - -A mask that gives the state of the buttons and modifier keys just before the -event. - -@item time -Type @var{card32}. - -A timestamp for the moment when the event occurred. - -@item root -Type @var{window}. - -The root window containing the final pointer position. - -@item root-x -Type @var{int16}. - -The x coordinate of the pointer position relative to root at the time of the event. - -@item root-y -Type @var{int16}. - -The y coordinate of the pointer position relative to root at the time of the event. - -@item child -Type (@var{or null window}). - -In a @var{:leave-notify} event, if a child of the @emph{event-window} contains the initial -position of the pointer, the @emph{child} slot is set to that child; otherwise, the @emph{child} slot is -@var{nil}. For an @var{:enter-notify} event, if a child of the @emph{event-window} contains the final -pointer position, the @emph{child} slot is set to that child; otherwise, the @emph{child} slot is @var{nil}. - -@item same-screen-p -Type @var{boolean}. - -True if @emph{event-window} and root are on the same screen. -@end table - -@end deftp - - -@node Input Focus Events, Keyboard and Pointer State Events, Keyboard and Pointer Events, Event Types -@subsection Input Focus Events - - -The input focus events are @var{:focus-in} and @var{:focus-out}. - -@deftp {Event Type} :focus-in -@deftpx {Event Type} :focus-out - -Selected by: @var{:focus-change}. - -@var{:focus-in} and @var{:focus-out} events are generated when the -input focus changes. All @var{:focus-out} events caused by a window -@var{:unmap} are generated after any @var{:unmap-notify} event, -but the ordering of @var{:focus-out} with respect to generated -@var{:enter-notify}, @var{:leave-notify}, -@var{:visibility-notify}, and @var{:expose} events is not -constrained. - -@table @var -@item window -@itemx event-window -Type @var{window}. - -For @var{:focus-in}, the new input focus window. For @var{:focus-out}, the previous input -focus window. - -@item mode -Type @code{(member :normal :while-grabbed :grab :ungrab)}. - -Events generated by @var{set-input-focus} when the keyboard is not grabbed have -mode @var{:normal}. Events generated by @var{set-input-focus} when the keyboard is -grabbed have mode @var{:while-grabbed}. Events generated when a keyboard grab -activates have mode @var{:grab}, and events generated when a keyboard grab -deactivates have mode @var{:ungrab}. - -@item kind -Type (@var{member :ancestor :virtual :inferior :nonlinear :nonlinear-virtual :pointer :pointer-root :none}). - -When the focus moves from window A to window B, and A is an inferior of B, -with the pointer in window P: -@itemize @bullet - -@item -@var{:focus-out} with @emph{kind} @var{:ancestor} is -generated on A - -@item -@var{:focus-out} with @emph{kind} @var{:virtual} is -generated on each window between A and B exclusive (in that -order) - -@item -@var{:focus-in} with @emph{kind} @var{:inferior} is -generated on B - -@item -If P is an inferior of B, but P is not A or an inferior of -A or an ancestor of A, @var{:focus-in} with @emph{kind} -@var{:pointer} is generated on each window below B down -to and including P (in order) -@end itemize - -When the focus moves from window A to window B, and B is an inferior of A, -with the pointer in window P: -@itemize @bullet - -@item -If P is an inferior of A, but P is not A or an inferior of -B or an ancestor of B, @var{:focus-out} with @emph{kind} -@var{:pointer} is generated on each window from P up to -but not including A (in order) - -@item -@var{:focus-out} with @emph{kind} @var{:inferior} is -generated on A - -@item -@var{:focus-in} with @emph{kind} @var{:virtual} is -generated on each window between A and B exclusive (in -that order) - -@item -@var{:focus-in} with @emph{kind} @var{:ancestor} is -generated on B -@end itemize - -When the focus moves from window A to window B, with window C being -their least common ancestor, and with the pointer in window P: -@itemize @bullet - -@item -If P is an inferior of A, @var{:focus-out} with -@emph{kind} @var{:pointer} is generated on each window -from P up to but not including A (in order) - -@item -@var{:focus-out} with @emph{kind} @var{:nonlinear} is -generated on A - -@item -@var{:focus-out} with @emph{kind} -@var{:nonlinear-virtual} is generated on each window -between A and C exclusive (in that order) - -@item -@var{:focus-in} with @emph{kind} -@var{:nonlinear-virtual} is generated on each window -between C and B exclusive (in that order) - -@item -:focus-in with @emph{kind} @var{:nonlinear} is generated -on B - -@item -If P is an inferior of B, @var{:focus-in} with -@emph{kind} @var{:pointer} is generated on each window -below B down to and including P (in order) -@end itemize - -When the focus moves from window A to window B, on different -screens, with the pointer in window P: -@itemize @bullet - -@item -If P is an inferior of A, @var{:focus-out} with -@emph{kind} @var{:pointer} is generated on each window -from P up to but not including A (in order) - -@item -@var{:focus-out} with @emph{kind} @var{:nonlinear} is -generated on A - -@item -If A is not a root window, @var{:focus-out} with -@emph{kind} @var{:nonlinear-virtual} is generated on each -window above A up to and including its root (in order) - -@item -If B is not a root window, @var{:focus-in} with -@emph{kind} @var{:nonlinear-virtual} is generated on each -window from B's root down to but not including B (in -order) - -@item -@var{:focus-in} with @emph{kind} @var{:nonlinear} is -generated on B - -@item -If P is an inferior of B, @var{:focus-in} with -@emph{kind} @var{:pointer} is generated on each window -below B down to and including P (in order) -@end itemize - -When the focus moves from window A to @var{:pointer-root} -(or @var{:none}), with the pointer in window P: -@itemize @bullet - -@item -If P is an inferior of A, @var{:focus-out} with -@emph{kind} @var{:pointer} is generated on each window -from P up to but not including A (in order) - -@item -@var{:focus-out} with @emph{kind} @var{:nonlinear} is -generated on A - -@item -If A is not a root window, @var{:focus-out} with -@emph{kind} @var{:nonlinear-virtual} is generated on each -window above A up to and including its root (in order) - -@item -@var{:focus-in} with @emph{kind} @var{:pointer-root} (or -@var{:none}) is generated on all root windows - -@item -If the new focus is @var{:pointer-root}, @var{:focus-in} -with @emph{kind} @var{:pointer} is generated on each -window from P's root down to and including P (in order) -@end itemize - -When the focus moves from @var{:pointer-root} (or -@var{:none}) to window A, with the pointer in window P: -@itemize @bullet - -@item -If the old focus is @var{:pointer-root}, -@var{:focus-out} with @emph{kind} @var{:pointer} is -generated on each window from P up to and including P's -root (in order) - -@item -@var{:focus-out} with @emph{kind} @var{:pointer-root} -(or @var{:none}) is generated on all root windows - -@item -If A is not a root window, @var{:focus-in} with -@emph{kind} @var{:nonlinear-virtual} is generated on each -window from A's root down to but not including A (in -order) - -@item -@var{:focus-in} with @emph{kind} @var{:nonlinear} is -generated on A - -@item -If P is an inferior of A, @var{:focus-in} with -@emph{kind} @var{:pointer} is generated on each window -below A down to and including P (in order) -@end itemize - -When the focus moves from @var{:pointer-root} to -@var{:none} (or vice versa), with the pointer in window P: -@itemize @bullet - -@item -If the old focus is @var{:pointer-root}, -@var{:focus-out} with @emph{kind} @var{:pointer} is -generated on each window from P up to and including P's -root (in order) - -@item -@var{:focus-out} with @emph{kind} @var{:pointer-root} -(or @var{:none}) is generated on all root windows - -@item -@var{:focus-in} with @emph{kind} @var{:none} (or -@var{:pointer-root}) is generated on all root windows - -@item -If the new focus is @var{:pointer-root}, @var{:focus-in} -with @emph{kind} @var{:pointer} is generated on each -window from P's root down to and including P (in order) -@end itemize -@end table - - -When a keyboard grab activates (but before generating any actual -@var{:key-press} event that activates the grab), with @emph{G} -the @var{grab-window} for the grab and @emph{F} the current -focus, then @var{:focus-in} and @var{:focus-out} events with -mode @var{:grab} are generated (as for @var{:normal} above) as -if the focus were to change from @emph{F} to @emph{G}. - -When a keyboard grab deactivates (but after generating any -actual @var{:key-release} event that deactivates the grab), -with @emph{G} the @var{grab-window} for the grab and @emph{F} -the current focus, then @var{:focus-in} and @var{:focus-out} -events with mode @var{:ungrab} are generated (as for -@var{:normal} above) as if the focus were to change from -@emph{G} to @emph{F}. -@end deftp - -@node Keyboard and Pointer State Events, Exposure Events, Input Focus Events, Event Types -@subsection Keyboard and Pointer State Events - - -The keyboard and pointer state events are @var{:keymap-notify} and @var{:mapping-notify}. - -@deftp {Event Type} :keymap-notify - - -Selected by: @var{:keymap-state}. - -The @var{:keymap-notify} event returns the current state of the -keyboard. @var{:keymap-notify} is generated immediately after every -@var{:enter-notify} and @var{:focus-in}. - -@table @var -@item window -@itemx event-window -Type @var{window}. - -The window receiving an @var{:enter-notify} or @var{:focus-in} event. - -@item keymap -Type (@var{bit-vector 256}). - -A bit-vector containing the logical state of the keyboard. Each bit set to 1 -indicates that the corresponding key is currently pressed. The vector is represented -as 32 bytes. For @emph{n} from 0 to 7, byte @emph{n} (from 0) contains the bits for keys 8@emph{n} to -8@emph{n}+7, with the least significant bit in the byte representing key 8@emph{n}. -@end table - -@end deftp - - -@deftp {Event Type} :mapping-notify - -The X server reports @var{:mapping-notify} events to all -clients. There is no mechanism to express disinterest in this -event. The X server generates this event type whenever a client -application calls one of the following: -@itemize @bullet - -@item -@var{set-modifier-mapping} to indicate which keycodes to use as -modifiers (the status reply must be @var{:mapping-success}) - -@item -@var{change-keyboard-mapping} to change the keyboard mapping - -@item -@var{set-pointer-mapping} to set the pointer mapping (the status -reply must be @var{:mapping-success}) -@end itemize - -@table @var -@item request -Type (@code{member :modifier :keyboard :pointer}). - -Indicates the kind of change that occurred--@var{:modifier} for a successful -@var{set-modifier-mapping}, @var{:keyboard} for a successful @var{change-keyboard-mapping}, -and @var{:pointer} for a successful @var{set-pointer-mapping}. - -@item start -Type @var{card8}. - -If request is @var{:keyboard}, then @emph{start} and @emph{count} indicate the range of altered -keycodes. - -@item count -Type @var{card8}. - -If request is @var{:keyboard}, then @emph{start} and @emph{count} indicate the range of altered -keycodes. -@end table -@end deftp - - -@node Exposure Events, Window State Events, Keyboard and Pointer State Events, Event Types -@subsection Exposure Events - - -The X server cannot guarantee that a window's content is preserved when -the window is obscured or reconfigured. X requires client applications -to be capable of restoring the contents of a previously-invisible window -region whenever it is exposed. Therefore, the X server sends events -describing the exposed window and its exposed region. For a simple -window, a client can choose to redraw the entire content whenever any -region is exposed. For a complex window, a client can redraw only the -exposed region. - -@deftp {Event Type} :exposure -@anchor{:exposure} - -Selected by: @var{:exposure}. - -An @var{:exposure} event is sent when redisplay is needed for a -window region whose content has been lost. Redisplay is needed -when one of the following occurs: -@itemize @bullet - -@item -A region is exposed for a window and the X server has no backing -store for the region - -@item -A region of a viewable window is obscured and the X server -begins to honor the window's backing-store attribute of -@var{:always} or @var{:when-mapped} - -@item -The X server begins to honor an unviewable window's -backing-store attribute of @var{:always} or -@var{:when-mapped}. -@end itemize - -The regions needing redisplay are decomposed into an arbitrary set -of rectangles, and an @var{:exposure} event is generated for each -rectangle. For a given action causing @var{:exposure} events, the -set of events for a given window are guaranteed to be reported -contiguously. - -@var{:exposure} events are never generated for @var{:input-only} -windows. - -All @var{:exposure} events caused by a hierarchy change are -generated after any hierarchy event (@var{:unmap-notify}, -@var{:map-notify}, -@var{:configure-notify},@var{:gravity-notify}, or -@var{:circulate-notify}) caused by that change. All -@var{:exposure} events on a given window are generated after any -@var{:visibility-notify} event on that window, but it is not -required that all @var{:exposure} events on all windows be -generated after all visibility events on all windows. The ordering -of @var{:exposure} events with respect to @var{:focus-out}, -@var{:enter-notify}, and @var{:leave-notify} events is not -constrained. - -@table @var -@item window -@itemx event-window -Type @var{window}. - -The window needing redisplay. - -@item x -Type @var{card16}. - -The position of the left edge of the region to redisplay, relative to the -@emph{event-window}. - -@item y -Type @var{card16}. - -The position of the top edge of the region to redisplay, relative to the -@emph{event-window}. - -@item width -Type @var{card16}. - -The width of the region to redisplay. - -@item height -Type @var{card16}. - -The height of the region to redisplay. - -@item count -Type @var{card16}. - -If count is zero, then no more @var{:exposure} events for this window follow. If -count is nonzero, then at least that many more @var{:exposure} events for this -window follow (and possibly more). -@end table - -@end deftp - - -@deftp {Event Type} :graphics-exposure - -A @var{:graphics-exposure} event is generated by a call to -@var{copy-area} or @var{copy-plane} when the exposures attribute -of the graphics context is @var{:on}. A @var{:graphics-exposure} -event reports a destination region whose content cannot be computed -because the content of the corresponding source region has been -lost. For example, the missing source region may be obscured or may -lie outside the current source drawable size. For a given action -causing @var{:graphics-exposure} events, the set of events for a -given destination are guaranteed to be reported contiguously. - -@table @var -@item drawable -@itemx event-window -Type @var{drawable}. - -The destination drawable for the @var{copy-area} or @var{copy-plane} function. - -@item x -Type @var{card16}. - -The position of the left edge of the destination region, relative to the @emph{drawable}. - -@item y -Type @var{card16}. - -The position of the top edge of the destination region, relative to the @emph{drawable}. - -@item width -Type @var{card16}. - -The width of the destination region. - -@item height -Type @var{card16}. - -The height of the destination region. - -@item count -Type @var{card16}. - -If count is zero then no more @var{:graphics-exposure} events for the @emph{drawable} -follow. If count is nonzero then at least that many more @var{:graphics-exposure} -events for the @emph{drawable} follow (and possibly more). - -@item major -Type @var{card8}. - -The major opcode for the graphics request generating the event -(62 for @var{copy-area}, 63 for @var{copy-plane}). - -@item minor -Type @var{card16}. - -The minor opcode for the graphics request generating the event -(0 for both @var{copy-area} and @var{copy-plane}). -@end table - -@end deftp - - -@deftp {Event Type} :no-exposure - -A @var{:no-exposure} event is generated by a call to -@var{copy-area} or @var{copy-plane} when the exposures attribute -of the graphics context is @var{:on}. If no -@var{:graphics-exposure} events are generated, then a single -@var{:no-exposure} event is sent. - -@table @var -@item drawable -@itemx event-window -Type @var{drawable}. - -The destination drawable for the @var{copy-area} or @var{copy-plane} function. - -@item major -Type @var{card8}. - -The major opcode for the graphics request generating the event -(62 for @var{copy-area}, 63 for @var{copy-plane}). - -@item minor -Type @var{card16}. - -The minor opcode for the graphics request generating the event -(0 for both @var{copy-area} and @var{copy-plane}). -@end table - -@end deftp - - -@node Window State Events, Structure Control Events, Exposure Events, Event Types -@subsection Window State Events - - -The following paragraphs describe the events that can be received when a -window becomes: -@itemize @bullet - -@item Created - -@item Destroyed - -@item Invisible - -@item Mapped - -@item Moved - -@item Reparented - -@item Resized - -@item Restacked - -@item Unmapped - -@item Visible -@end itemize - -@deftp {Event Type} :circulate-notify - -Selected by: @var{:structure-notify} on a window or @var{:substructure-notify} on its parent. - -A @var{:circulate-notify} event is generated whenever a window is -actually restacked as a result of a client application calling -@var{circulate-window-up} or @var{circulate-window-down}. - -@table @var -@item event-window -Type @var{window}. - -The window receiving the event. - -@item window -Type @var{window}. - -The window that was restacked. - -@item place -Type (@var{member :top :bottom}). - -If place is @var{:top}, the @emph{window} is now on top of all siblings. Otherwise, it is below -all siblings. -@end table - -@end deftp - - -@deftp {Event Type} :configure-notify - -Selected by: @var{:structure-notify} on a window or -@var{:substructure-notify} on its parent. - - -The @var{:configure-notify} event is generated when the position or -size of a window actually changes as a result of a client -application setting its @emph{x}, @emph{y}, @emph{width}, -@emph{height}, or @emph{border-width} attributes. - -@table @var -@item event-window -Type @var{window}. - -The window receiving the event. - -@item window -Type @var{window}. - -The window that was moved or resized. - -@item x -Type @var{int16}. - -@emph{x} and @emph{y} specify the new upper-left corner position of the @emph{window} relative to its -parent. - -@item y -Type @var{int16}. - -@emph{x} and @emph{y} specify the new upper-left corner position of the @emph{window} relative to its -parent. - -@item width -Type @var{card16}. - -@emph{width} and @emph{height} specify the new size of the @emph{window} interior. - -@item height -Type @var{card16}. - -@emph{width} and @emph{height} specify the new size of the @emph{window} interior. - -@item border-width -Type @var{card16}. - -The new @emph{window} border width. - -@item above-sibling -Type (@var{or null window}). - -The sibling immediately below the @emph{window}. If above-sibling is @var{nil}, then the -@emph{window} is below all of its siblings. - -@item override-redirect-p -Type @var{boolean}. - -@emph{override-redirect-p} is true if the override-redirect attribute of the @emph{window} is -@var{:on}; otherwise, it is @var{nil}. See @var{window-override-redirect} in @ref{Window Attributes}. -@end table - - -The X server can report @var{:create-notify} events to clients -wanting information about creation of windows. The X server -generates this event whenever a client application creates a window -by calling @var{create-window}. - -To receive this event type in a client application, you @code{setf} -the @var{:substructure-notify} as the event-mask in the parent -window's event-mask slot. - -@end deftp - - -@deftp {Event Type} :create-notify - -Selected by: @var{:substructure-notify}. - - -The @var{:create-notify} event is generated when a @emph{window} is -created and is sent to the @emph{parent} window. - -@table @var -@item parent -@itemx event-window -Type @var{window}. - -The parent window receiving the event. - -@item window -Type @var{window}. - -The new window created. - -@item x -Type @var{int16}. - -@emph{x} and @emph{y} specify the initial upper-left corner position of the @emph{window} relative to -the parent. - -@item y -Type @var{int16}. - -@emph{x} and @emph{y} specify the initial upper-left corner position of the @emph{window} relative to -the parent. - -@item width -Type @var{card16}. - -@emph{width} and @emph{height} specify the initial size of the @emph{window} interior. - -@item height -Type @var{card16}. - -@emph{width} and @emph{height} specify the initial size of the @emph{window} interior. - -@item border-width -Type @var{card16}. - -The initial @emph{window} border width. - -@item override-redirect-p -Type @var{boolean}. - -@emph{override-redirect-p} is true if the override-redirect attribute of the @emph{window} is -@var{:on}; otherwise, it is @var{nil}. See @var{window-override-redirect} in @ref{Window Attributes}. - -@end table - -@end deftp - - -@deftp {Event Type} :destroy-notify - -Selected by: @var{:structure-notify} on a window or @var{:substructure-notify} on its parent. - -The @var{:destroy-notify} event is generated when a @emph{window} -is destroyed. The ordering of the @var{:destroy-notify} events is -such that for any given window, @var{:destroy-notify} is generated -on all inferiors of a window before @var{:destroy-notify} is -generated on the @emph{window}. The ordering among siblings and -across subhierarchies is not otherwise constrained. - -@table @var -@item event-window -Type @var{window}. - -The window receiving the event. - -@item window -Type @var{window}. - -The window that was destroyed. -@end table - -@end deftp - - -@deftp {Event Type} :gravity-notify - -Selected by: @var{:structure-notify} on a window or @var{:substructure-notify} on its parent. - -The X server can report @var{:gravity-notify} events to clients -wanting information about when a @emph{window} is moved because of a -change in the size of its parent. The X server generates this event -whenever a client application actually moves a child window as a -result of resizing its parent by calling @var{with-state} with the -appropriate arguments set. - -@table @var -@item event-window -Type @var{window}. - -The window receiving the event. - -@item window -Type @var{window}. - -The window that was moved. - -@item x -Type @var{int16}. - -x and y specify the new upper-left corner position of the @emph{window} relative to its -parent. - -@item y -Type @var{int16}. - -x and y specify the new upper-left corner position of the @emph{window} relative to its -parent. -@end table - -@end deftp - - -@deftp {Event Type} :map-notify - -Selected by: @var{:structure-notify} on a window or @var{:substructure-notify} on its parent. - -The X server can report @var{:map-notify} events to clients wanting -information about which windows are mapped. The X server generates -this event type whenever a client application changes the -@emph{window}'s state from unmapped to mapped by calling -@var{map-window} or @var{map-subwindow}. - -To receive this event type, you @var{setf :structure-notify} as the -event-mask on the @emph{window}'s @var{event-mask} slot. You can -also receive this event type by @code{setf}ing the -@var{:substructure-notify} event-mask on the parent window. - -@table @var -@item event-window -Type @var{window}. - -The window receiving the event. - -@item window -Type @var{window}. - -The window that was mapped. - -@item override-redirect-p -Type @var{boolean}. - -@emph{override-redirect-p} is true if the override-redirect attribute of the @emph{window} is -@var{:on}; otherwise, it is @var{nil}. See @var{window-override-redirect} in @ref{Window Attributes}. -@end table - -@end deftp - - -@deftp {Event Type} :reparent-notify -Selected by: @var{:structure-notify} on a window or @var{:substructure-notify} on its old or new parent. - -The @var{:reparent-notify} event is generated when a @emph{window} -is reparented. - -@table @var -@item event-window -Type @var{window}. - -The window receiving the event. - -@item window -Type @var{window}. - -The window that was reparented. - -@item parent -Type @var{window}. - -The new parent of the @emph{window}. - -@item x -Type @var{int16}. - -x and y specify the upper-left corner position of the @emph{window} relative to its new -@emph{parent}. - -@item y -Type @var{int16}. - -x and y specify the upper-left corner position of the @emph{window} relative to its new -@emph{parent}. - -@item override-redirect-p -Type @var{boolean}. - -@emph{override-redirect-p} is true if the override-redirect attribute -of the @emph{window} is @var{:on}; otherwise, it is @var{nil}. See -@var{window-override-redirect} in @ref{Window Attributes}. -@end table - -@end deftp - - -@deftp {Event Type} :unmap-notify - -Selected by: @var{:structure-notify} on a window or @var{:substructure-notify} on its parent. - -The @var{:unmap-notify} event is generated when a mapped -@emph{window} is unmapped. - -@table @var -@item event-window -Type @var{window}. - -The window receiving the event. - -@item window -Type @var{window}. - -The window that was unmapped. - -@item configure-p -Type @var{boolean}. - -@emph{configure-p} is true if the @emph{window} has a win-gravity -attribute of @var{:unmap}, and the event was generated because -@emph{window}'s parent was resized. -@end table - -@end deftp - - -@deftp {Event Type} :visibility-notify - -Selected by: @var{:visibility-change}. - -The @var{:visibility-notify} event is sent when the visibility of a -@emph{window} changes. @var{:visibility-notify} events are never -generated on @var{:input-only} windows. For the purposes of this -event, the visibility of the @emph{window} is not affected by its -subwindows. - -All @var{:visibility-notify} events caused by a hierarchy change -are generated after any hierarchy event caused by that change (for -example, @var{:unmap-notify}, @var{:map-notify}, -@var{:configure-notify}, @var{:gravity-notify}, or -@var{:circulate-notify}). Any @var{:visibility-notify} event on a -given window is generated before any @var{:exposure} events on that -window, but it is not required that all @var{:visibility-notify} -events on all windows be generated before all @var{:exposure} -events on all windows. The ordering of @var{:visibility-notify} -events with respect to @var{:focus-out}, @var{:enter-notify}, and -@var{:leave-notify} events is not constrained. - -@table @var -@item window -@itemx event-window -Type @var{window}. - -The window that changed in visibility. - -@item state -Type (@var{member :unobscured :partially-obscured} @var{:fully-obscured}). - -When the @emph{window} was either unviewable or it was viewable and at least -partially obscured, and the @emph{window} changed to viewable and completely -unobscured, then @emph{state} is @var{:unobscured}. - -When the @emph{window} was either unviewable or it was viewable and completely -obscured, and the @emph{window} changed to viewable and partially obscured, then -@emph{state} is @var{:partially-obscured}. - -When the @emph{window} was either unviewable or it was at least partially visible, and -the @emph{window} changed to viewable and completely obscured, then @emph{state} is -@var{:fully-obscured}. -@end table - -@end deftp - - -@node Structure Control Events, Client Communications Events, Window State Events, Event Types -@subsection Structure Control Events - - -The following paragraphs describe events used to @emph{redirect} -client requests that reconfigure, restack, or map a window. Structure -control events are typically used only by window managers and not by -ordinary client applications. Structure control events report -redirected requests, allowing a window manager to modify the requests -before they are actually performed. However, if the override-redirect -attribute of a window is @var{:on}, then no requests are redirected -and no structure control events are generated. - -@deftp {Event Type} :circulate-request - -The @var{:circulate-request} event is generated when a client -application calls @var{circulate-window-up} or -@var{circulate-window-down} with a window that has the -override-redirect attribute @var{:off}. The @emph{window} argument -specifies the window to be restacked, and @emph{place} specifies -what the new position in the stacking order should be (either -@var{:top} or @var{:bottom}). - -Selected by: @var{:substructure-redirect} on @emph{parent}. - -@table @var -@item parent -@itemx event-window -Type @var{window}. - -The window receiving the event. The receiving client must have selected -@var{:substructure-redirect} on this window. - -@item window -Type @var{window}. - -The window to be restacked. - -@item place -Type @code{(member :top :bottom)}. - -The new stacking priority requested for @emph{window}. -@end table - -@end deftp - - -@deftp {Event Type} :colormap-notify -Selected by: @var{:colormap-change}. - -The @var{:colormap-notify} event is generated with @emph{new-p} -@var{t} when the @emph{colormap} associated with a @emph{window} is -changed, installed, or uninstalled. - -@table @var -@item window -@itemx event-window -Type @var{window}. - -The window receiving the event. - -@item colormap -Type @code{(or null colormap)}. - -The colormap attribute of the window. - -@item new-p -Type @var{boolean}. - -If @emph{new-p} is true, then the @emph{window}'s colormap attribute has changed to the given -@emph{colormap}. Otherwise, the @emph{window}'s colormap attribute has not, but the -@emph{colormap} has been installed or uninstalled. - -@item installed-p -Type @var{boolean}. - -If @emph{installed-p} is true, then the @emph{colormap} is currently installed. -@end table - -@end deftp - - -@deftp {Event Type} :configure-request - -Selected by:@var{:substructure-redirect} on parent. - -The @var{:configure-request} event is generated when a client -program sets the @emph{x}, @emph{y}, @emph{width}, @emph{heigh}t, -@emph{border-width} or stacking priority attributes of a window that -has the override-redirect attribute @var{:off}. - -@table @var -@item parent -@itemx event-window -Type @var{window}. - -The window receiving the event. The receiving client must have selected -@var{:substructure-redirect} on this window. - -@item window -Type @var{window}. - -The window to be reconfigured. - -@item x -Type @var{int16}. - -@emph{x} and @emph{y} specify the requested upper-left corner position of the @emph{window} relative -to the parent. If either @emph{x} or @emph{y} is not specified in the value-mask, then it is set to -the current window position. - -@item y -Type @var{int16}. - -@emph{x} and @emph{y} specify the requested upper-left corner position of the @emph{window} relative -to the @emph{parent}. If either @emph{x} or @emph{y} is not specified in the @emph{value-mask}, then it is set to -the current window position. - -@item width -@itemx height -Type @var{card16}. - -@emph{width} and @emph{height} specify the requested size of the @emph{window} interior. If either -@emph{width} or @emph{height} is not specified in the @emph{value-mask}, then it is set to the current -window size. - -@item border-width -Type @var{card16} - -The requested @emph{window} border width. If @emph{border-width} is not specified in the -@emph{value-mask}, then it is set to the current window @emph{border-width}. - -@item stack-mode -Type @code{(member :above :below :top-if :bottom-if :opposite)}. - -@emph{stack-mode} and @emph{above-sibling} specify the requested stacking priority of the -@emph{window}. If @emph{stack-mode} is not specified in the @emph{value-mask}, then it is set to -@var{:above}. - -@item above-sibling -Type (@var{or null window}). - -@emph{stack-mode} and @emph{above-sibling} specify the requested stacking priority of the -@emph{window}. If @emph{above-sibling} is not specified in the @emph{value-mask}, then it is set to @var{nil}. - -@item value-mask -Type @var{mask16}. - -Specifies the changed @emph{window} attributes contained in the redirected client -request. Each 1 bit specifies that the corresponding attribute was changed. -@end table - -@end deftp - - -@deftp {Event Type} :map-request - -Selected by: @var{:substructure-redirect} on parent. - -The @var{:map-request} event is generated when a client application -maps a @emph{window} that has the override-redirect attribute -@var{:off}. - -@table @var -@item parent -@itemx event-window -Type @var{window}. - -The window receiving the event. The receiving client must have selected -@var{:substructure-redirect} on this window. - -@item window -Type @var{window}. - -The window to be mapped. -@end table - -@end deftp - - -@deftp {Event Type} :resize-request - -Selected by: @var{:resize-redirect}. - -The @var{:resize-request} event is generated when a client program -sets the @emph{width} or @emph{height} attributes of a @emph{window} -that has the override-redirect attribute @var{:off}. - -@table @var -@item window -@itemx event-window -Type @var{window}. - -The window to be resized. - -@item width -@itemx height -Type @var{card16}. - -@emph{width} and @emph{height} specify the requested size of the wi@emph{ndow} interior. If either -@emph{width} or @emph{height} was unchanged in the client request, then it is set to the current -window size. -@end table - -@end deftp - - -@node Client Communications Events, Declaring Event Types, Structure Control Events, Event Types -@subsection Client Communications Events - - -The client communications events discussed in the following paragraphs -are: @var{:client-message}, @var{:property-notify}, -@var{:selection-clear}, @var{:selection-request}, and -@var{:selection-notify}. - -@deftp {Event Type} :client-message - -The @var{:client-message} event is generated exclusively by client -calls to @var{send-event}. The X server places no interpretation on -the @emph{type} or content of @emph{data} sent in a -@var{:client-message}. A client can neither select -@var{:client-message} events nor avoid receiving them. - -@table @var -@item window -@itemx event-window -Type @var{window}. - -The window receiving the event. - -@item type -Type @var{keyword}. - -An xatom keyword that specifies the type of client message. Interpretation of -the type is determined solely by agreement between the sending and receiving -clients. - -@item format -Type (@var{member 8 16 32}). - -An integer that specifies whether @emph{data} should be viewed as a sequence of 8-bit, -16-bit, or 32-bit quantities. - -@item data -Type @code{(sequence integer)}. - -The data content of the client message. @emph{data} always consists of 160 bytes -- -depending on format, either 20 8-bit values, 10 16-bit values or 5 32-bit values. -The amount of this data actually used by a particular client message depends on -the type. -@end table - -@end deftp - - -@deftp {Event Type} :property-notify -Selected by: @var{:property-change}. - -The @var{:property-notify} event is generated when a window -property is changed or deleted. - -@table @var -@item window -@itemx event-window -Type @var{window}. - -The window receiving the event. - -@item atom -Type @var{keyword}. - -The property that was changed or deleted. - -@item state -Type @code{(member :new-value :deleted)}. - -@emph{state} is @var{:new-value} if the property was changed using @var{change-property} or -@var{rotate-properties}, even if zero-length data was added or if all or part of the -property was replaced with identical data. @emph{state} is @var{:deleted} if the property was -deleted using @var{delete-property} or @var{get-property}. - -@item time -Type @var{timestamp}. - -The server time when the property was changed or deleted. -@end table - -@end deftp - - -@deftp {Event Type} :selection-clear - -The @var{:selection-clear} event is reported to the previous owner -of a @emph{selection} when the owner of the @emph{selection} is -changed. The selection owner is changed by a client using -@code{setf}. A client can neither select @var{:selection-clear} -events nor avoid receiving them. -@table @var -@item window -@itemx event-window -Type @var{window}. - -The window losing ownership of the @emph{selection}. - -@item selection -Type @var{keyword}. - -The name of the selection. - -@item time -Type @var{timestamp}. - -The last-change time recorded for the @emph{selection}. -@end table - -@end deftp - -@deftp {Event Type} :selection-notify - -The @var{:selection-notify} event is sent to a client calling -@var{convert-selection}. @var{:selection-notify} reports the -result of the client request to return the current value of a -@emph{selection} into a particular form. @var{:selection-notify} is -sent using @var{send-event} by the owner of the selection or (if no -owner exists) by the X server. A client can neither select -@var{:selection-notify} events nor avoid receiving them. - -@var{NOTE:} Standard conventions for inter-client communication require the following -additional steps in processing a @var{:selection-notify} event: - -@enumerate - -@item -The client receiving this event should call @var{get-property} to -return the converted selection value. - -@item -After receiving the selection value, the property should then be -deleted (either by using the @var{:delete-p} argument to -@var{get-property} or by calling @var{delete-property}). -@end enumerate - -@table @var -@item window -@itemx event-window -Type @var{window}. - -The requestor window given in the call to @var{convert-selection}. - -@item selection -Type @var{keyword}. - -The selection to be converted. - -@item target -Type @var{keyword}. - -An @var{xatom} specifying the type of the converted selection value. This is the same -target type given in the call to @var{convert-selection}. - -@item property -Type @code{(or null keyword)}. - -The window property containing the converted selection. If the property is @var{nil}, -then either the @emph{selection} has no owner or the owner could not perform the -conversion to the @emph{target} type. - -@item time -Type @var{timestamp}. - -The timestamp from the client call to @var{convert-selection}. -@end table - -@end deftp - - -@deftp {Event Type} :selection-request - -The @var{:selection-request} event is reported to the owner of a -selection when a client calls @var{convert-selection}. This event -requests the selection owner to convert the current value of a -@emph{selection} into a specified form and to return it to the -requestor. A client can neither select @var{:selection-request} -events nor avoid receiving them. - -The selection owner should respond to a @var{:selection-request} event by performing the -following steps: - -@enumerate - -@item -Convert the current @emph{selection} value to the @emph{target} -type. - -@item -Store the converted selection value in the @emph{property}. If -@emph{property} is @var{nil}, then the owner should choose the -@emph{property}. - -@item -Call @var{send-event} to send a @var{:selection-notify} event to -the @emph{requestor} containing the @emph{property} with the -converted value. If the @emph{selection} could not be converted to -the @emph{target} type, then a @var{nil} @emph{property} should -be sent. The @var{:selection}, @var{:target}, and @var{:time} -arguments to @var{send-event} should be the same as those -received in the @var{:selection-request} event. The event-mask -argument to @var{send-event} should be @var{nil}; that is, the -@var{:selection-notify} event should be sent to client that -created the @emph{requestor}. -@end enumerate - - -@var{NOTE:} Standard conventions for inter-client communication -require the following additional steps in processing a -@var{:selection-request} event: - -@enumerate - -@item -The property used to store the selection value must belong to the -requestor. - -@item -If the property is @var{nil}, the target type @var{atom} should -be used as the property name. - -@item -If the window did not actually own the selection at the given -time, the request should be refused, just as if it could not be -converted to the target type. -@end enumerate - -@table @var -@item window -@itemx event-window -Type @var{window}. - -The selection owner receiving the event. - -@item requestor -Type @var{window}. - -The window requesting the converted @emph{selection}. - -@item selection -Type @var{keyword}. - -The selection to be converted. - -@item target -Type @var{keyword}. - -An @var{xatom} specifying the type of the converted @emph{selection} value. - -@item property -Type @code{(or null keyword)}. - -A requestor window property. - -@item time -Type @var{timestamp}. - -The timestamp sent in the client @var{convert-selection} request. -@end table - -@end deftp - - -@node Declaring Event Types, , Client Communications Events, Event Types -@subsection Declaring Event Types - - -CLX uses the @var{declare-event} macro to define the event slot symbols -that access the contents of X events. Most client applications do not -need to use @var{declare-event} because the declarations for all core X -events are already defined by CLX. Programmers using extensions to the -X protocol can use @var{declare-event} to allow CLX to handle new event -types returned by an extended X server. - -@defmac declare-event event-codes &rest slot-declarations - -Defines a mapping between event slot symbols and the data items in -event messages received from an X server. - -The @emph{event-codes} argument gives the event type keyword for the -event described. If several event types share the same slots, then -@emph{event-codes} can be a list of event type -keywords. @emph{slot-declarations} is a list containing an element -for each event data item. The order of @emph{slot-declarations} -corresponds to the order of event data items defined by the X -protocol. - -Each element of @emph{slot-declarations} is a list of the form -(@emph{type slot-name}*), where @emph{type} is a Common Lisp type -specifier and @emph{slot-name} is a slot name symbol. The effect of -such a list is to declare that the next data items in the event have -the given data @emph{type} and are associated with the given -@emph{slot-name} symbols. @emph{slot-name} can also be a list of -slot name symbols; in this case, each symbol in the list is an alias -that refers to the same event data item. - -@table @var -@item event-codes -An event type keyword or a list of event type keywords. -@item slot-declarations -A list of clauses defining event slot symbols. -@end table - -@end defmac - - -@node Releasing Queued Events, , Event Types, Events and Input -@section Releasing Queued Events - - -A client grabbing the keyboard or pointer can freeze the reporting of -events on that device. When an input device is thus frozen, the server -queues events until explicitly requested to release them by the grabbing -client. CLX programs can use the @var{allow-events} function to release -queued events from a frozen input device. - -@defun allow-events display mode &optional time - -@table @var -@item display -A @var{display}. - -@item mode -One of: @var{:async-pointer}, @var{:sync-pointer}, -@var{:reply-pointer}, @var{:async-keyboard}, @var{:sync-keyboard}, -@var{:replay-keyboard}, @var{:async-both}, @var{:sync-both}. - -@item time -A @var{timestamp}. -@end table - -Releases some queued events if the client has caused a device to -freeze. The request has no effect if the @emph{time} is earlier than -the last-grab time of the most recent active grab for the client, or -if the @emph{time} is later than the current server time. If -@emph{time} is @var{nil}, the current server time is used. The -effect of this function depends on the specified @emph{mode}. -@itemize @bullet - -@item -@var{:async-pointer} -- If the pointer is frozen by the client, -pointer event processing continues normally. If the pointer is -frozen twice by the client on behalf of two separate grabs, -@var{:async-pointer} releases events for both -grab@emph{s}. @var{:async-pointer} has no effect if the pointer -is not frozen by the client, but the pointer need not be grabbed -by the client. - -@item -@var{:sync-pointer} -- If the pointer is frozen and actively -grabbed by the client, pointer event processing continues normally -until the next @var{:button-press} or @var{:button-release} -event is reported to the client, at which time the pointer again -appears to freeze. However, if the reported event causes the -pointer grab to be released, the pointer does not -freeze. @var{:sync-pointer} has no effect if the pointer is not -frozen by the client, or if the pointer is not grabbed by the -client. - -@item -@var{:replay-pointer} -- If the pointer is actively grabbed by -the client and is frozen as the result of an event having been -sent to the client (either from the activation of a -@var{grab-button}, or from a previous @var{allow-events} with -mode @var{:sync-pointer}, but not from a @var{grab-pointer}), -the pointer grab is released and that event is completely -reprocessed, but this time ignoring any passive grabs at or above -(towards the root) the @var{grab-window} of the grab just -released. The request has no effect if the pointer is not grabbed -by the client, or if the pointer is not frozen as the result of an -event. - -@item -@var{:async-keyboard} -- If the keyboard is frozen by the client, -keyboard event processing continues normally. If the keyboard is -frozen twice by the client on behalf of two separate grabs, -@var{:async-keyboard} releases events for both grabs. -@var{:async-keyboard} has no effect if the keyboard is not frozen -by the client, but the keyboard need not be grabbed by the client. - -@item -@var{:sync-keyboard} -- If the keyboard is frozen and actively -grabbed by the client, keyboard event processing continues -normally until the next @var{:key-press} or @var{:key-release} -event is reported to the client, at which time the keyboard again -appears to freeze. However if the reported event causes the -keyboard grab to be released, the keyboard does not -freeze. @var{:sync-keyboard} has no effect if the keyboard is not -frozen by the client, or if the keyboard is not grabbed by the -client. - -@item -@var{:replay-keyboard} -- If the keyboard is actively grabbed by -the client and is frozen as the result of an event having been -sent to the client (either from the activation of a grab-key, or -from a previous @var{allow-events} with mode -@var{:sync-keyboard}, but not from a @var{grab-keyboard}), the -keyboard grab is released and that event is completely -reprocessed, but this time ignoring any passive grabs at or above -(towards the root) the @var{grab-window} of the grab just -released. The request has no effect if the keyboard is not grabbed -by the client, or if the keyboard is not frozen as the result of -an event. - -@item -@var{:sync-both} -- If both pointer and keyboard are frozen by -the client, event processing (for both devices) continues normally -until the next @var{:button-press}, @var{:button-release}, -@var{:key-press}, or @var{:key-release} event is reported to the -client for a grabbed device (button event for the pointer, key -event for the keyboard). At this time, the devices again appear to -freeze. If the reported event causes the grab to be released, the -devices do not freeze. However, if the other device is still -grabbed, then a subsequent event for it will still cause both -devices to freeze. @var{:sync-both} has no effect unless both -pointer and keyboard are frozen by the client. If the pointer of -keyboard is frozen twice by the client on behalf of two separate -grabs, @var{:sync-both} @emph{thaws} for both, but a subsequent -freeze for @var{:sync-both} will only freeze each device once. - -@item -@var{:async-both} -- If the pointer and the keyboard are frozen -by the client, event processing for both devices continues -normally. If a device is frozen twice by the client on behalf of -two separate grabs, @var{:async-both} @emph{thaws} for -both. @var{:async-both} has no effect unless both pointer and -keyboard are frozen by the client. -@end itemize - -@var{:async-pointer}, @var{:sync-pointer}, and -@var{:replay-pointer} have no effect on processing of keyboard -events. @var{:async-keyboard}, @var{:sync-keyboard}, and -@var{:replay-keyboard} have no effect on processing of pointer -events. - -It is possible for both a pointer grab and a keyboard grab to be -active simultaneously by the same or different clients. When a -device is frozen on behalf of either grab, no event processing is -performed for the device. It is possible for a single device to be -frozen due to both grabs. In this case, the freeze must be released -on behalf of both grabs before events can again be processed. - - - -@end defun - -@node Resources, Control Functions, Events and Input, Top -@chapter Resources - -Users need a way to specify preferences for various user interface -values (for example, colors, fonts, title strings, and so -forth). Applications need a consistent method for determining the -default interface values that are specific to them. It is also useful if -application interface values can be modified by users without changes to -the program code. For example, this capability can make it easy to -change the color scheme of a user interface. In CLX, such interface -values are referred to as @emph{resources}. CLX defines functions for -storing and retrieving interface resources from a resource database. A -user can store various user interface values as resources in a resource -database; a CLX application can then read these resource values and -modify its user interface accordingly. - -@var{NOTE:} The general term @emph{resource} refers to any application -user interface value stored in a resource database. The term @emph{server -resource} is used more specifically to refer to the types of objects -allocated by an X server and referenced by clients (for example, -windows, fonts, graphics contexts, and so forth). - -@menu -* Resource Binings:: -* Basic Resource Database Functions:: -* Accessing Resource Values:: -* Resource Database Files:: -@end menu - -@node Resource Binings, Basic Resource Database Functions, Resources, Resources -@section Resource Binings - - -Conceptually, a resource database is a set of resource name-value pairs -(or @emph{resource bindings}). The name in a resource binding is a list -that is the concatenation of a @emph{path list} and an @emph{attribute -name}. - -A path list is a list of symbols (or strings) that corresponds to a path -through a tree-structured hierarchy. For example, the path: - -@lisp -'(top middle bottom) -@end lisp - - -corresponds to a three-level hierarchy in which @code{middle} is -the child of @code{top}, and @code{bottom} is the child of -@code{middle}. - -Typically, the path of a resource name corresponds to a path in a -hierarchy of windows, and each symbol/string names a window in the -hierarchy. However, the first element of the path can also represent the -overall name of the entire program, and subsequent path elements can -refer to an application-specific hierarchy of resource names not -strictly related to windows. In addition, a resource name can contain a -partially-specified path list. The asterisk symbol (*) is a wildcard -that can correspond to any sequence of levels in the hierarchy -(including the null sequence). For example, the path: - -@lisp -'(top * bottom) -@end lisp - - -corresponds to a hierarchy of two or more levels in which -@code{top} is at the top level and @code{bot-} -@code{tom} is at the bottom level. An element of a path list can -be the name of an individual window or the name of a class of windows. - -The final element of a resource name list is an attribute name. This -symbol (or string) identifies a specific attribute of the object(s) -named by the preceding path list. The attribute name can also be the -symbol * or the string "*", in which case the resource name refers to -all attributes of the path object(s). However, this form of resource -name is rarely useful. - -Some examples of resource bindings are shown below. In these examples, -assume that @code{mail} is the resource name of a mail reading -application. @code{mail} uses a window of the class -@code{button} whose name is @code{reply}. - -@multitable {Resource Name} {Resource Value} -@item @code{(mail screen-1 reply background)} @tab @code{'green} -@item @code{(mail * background)} @tab @code{'red} -@item @code{(* button background)} @tab @code{'blue} -@end multitable - -These resource bindings specify the following: -@itemize @bullet - -@item -The @code{background} attribute resource of @code{mail} -application@emph{'}s @code{reply} button has the value of -@code{green} on @code{screen-1}. - -@item -The @code{background} attribute for the rest of the -@code{mail} application is always @code{red} on all -screens. - -@item -In general, the @code{background} attribute for all -@code{button} windows is @code{blue}. -@end itemize - -@node Basic Resource Database Functions, Accessing Resource Values, Resource Binings, Resources -@section Basic Resource Database Functions - - -A @var{resource-database} structure is a CLX object that represents a -set of resource bindings. The following paragraphs describe the CLX -functions used to: -@itemize @bullet - -@item Create a resource database - -@item Add a resource binding - -@item Remove a resource binding - -@item Merge two resource databases - -@item Map a function over the contents of a resource database -@end itemize - -@defun make-resource-database - -@table @var -@item resource-database -Type @var{resource-database}. -@end table - -Returns an empty resource database. -@end defun - - -@defun add-resource database name-list value - -@table @var -@item database -The @var{resource-database} for the new resource binding. -@item name-list -A list containing strings or symbols specifying the name for the resource binding. -@item value -The value associated with the @emph{name-list} in the resource binding. This can be an object of any type. -@end table - -Adds the resource binding specified by @emph{name-list} and -@emph{value} to the given @emph{database}. Only one value can be -associated with the @emph{name-list} in the @emph{database}. This -function replaces any value previously associated with the -@emph{name-list}. - - - -@end defun - - -@defun delete-resource database name-list - -@table @var -@item database -The @var{resource-database} containing the resource binding. -@item name-list -A list containing strings or symbols specifying the name for the deleted resource binding. -@end table - -Removes the resource binding specified by @emph{name-list} from the given @emph{database}. - - - -@end defun - - -@defun map-resource database function &rest args - -@table @var -@item database -A @var{resource-database}. -@item function -A @var{function} object or function symbol. -@item args -A list of arguments to the @emph{function}. -@end table - -Calls the function for each resource binding in the -@emph{database}. For each resource binding consisting of a -@emph{name-list} and a @emph{value}, the form -(@var{apply} @emph{function name-list value args}) -is executed. - - - -@end defun - - -@defun merge-resources from-database to-database - -@table @var -@item from-database -The @var{resource-database} from which resource bindings are read. -@item to-database -The @var{resource-database} to which resource bindings are added. -@end table - - -Merges the contents of the @emph{from-database} with the -@emph{to-database}. @var{map-resource} invokes @var{add-resource} -in order to add each resource binding in the @emph{from-database} to -the @emph{to-database}. The updated @emph{to-database} is returned. - -@table @var -@item to-database -Type @var{resource-database}. -@end table - -@end defun - - -@node Accessing Resource Values, Resource Database Files, Basic Resource Database Functions, Resources -@section Accessing Resource Values - - -The power and flexibility of resource management is the result of the -way resource values in a resource database are accessed. A resource -binding binding stored in the database generally contains only a partial -resource name consisting of a mixture of name and class identifiers and -wildcard elements (that is, *). To look up a resource value, an -application program starts with two resource name lists of the same -length containing no wildcard elements -- a @emph{complete resource -name} and a @emph{complete} @emph{resource class}. The lookup -algorithm returns the value for the resource binding whose resource name -is the closest match to the complete name and class given. The -definition of @emph{closest match} takes into account the top-down, -parent-child hierarchy of resource names and also the distinction -between individual names and class names. - -@menu -* Complete Names and Classes:: -* Matching Resource Names:: -* Resource Access Functions:: -@end menu - -@node Complete Names and Classes, Matching Resource Names, Accessing Resource Values, Accessing Resource Values -@subsection Complete Names and Classes - -A resource binding contains a resource name list that can contain names, -class names, or a mixture of both. A class name is a symbol or string -that represents a group of related objects. The set of names used as -class names are not specified by CLX. Instead, class names are defined -by agreement between those who use class names when creating resource -bindings (that is, users) and those who use class names when accessing -resource values (that is, application programmers). - -In order to access a value in a resource database, an application uses a -key consisting of two items: a @emph{complete resource name} and a -@emph{complete resource class}. A complete resource name is a resource -name list containing no wildcard elements. A complete resource class is -a list of exactly the same form. The distinction between a complete -resource name and a complete resource class lies in how they are used to -access resource bindings. The elements of a complete resource name are -interpreted as names of individual objects; the elements of a complete -resource class are interpreted as names of object classes. The complete -resource name and class lists used in a resource database access must -have the same length. - -Like any resource name list, a complete resource name consists of a path -list and an attribute name. The first path list element is typically a -symbol (or string) identifying the application as a whole. The second -element can be a screen root identifier. Subsequent elements can be -identifiers for each ancestor window of an application window. Thus, a -path list typically identifies a specific window by tracing a path to it -through the application window hierarchy. The final element of a -complete resource name (its attribute name) is typically the name of a -specific attribute of the window given by the path list (for example, -@code{'background}). An attribute name can refer to a feature -associated with the window by the application but not by the X server -(for example, a font identifier). Similarly, a complete resource class -typically represents a path to a window in the application window -hierarchy and a specific window attribute. However, a complete resource -class contains the class name for each window and for the window -attribute. - -For instance, in the previous example, the @code{mail} application -can attempt to look up the value of the @code{background} resource -for the @code{reply button} window by using the following complete -resource name: - -@lisp -(mail screen-1 reply background) -@end lisp - -and the following complete resource class: - -@lisp -(application root button fill) -@end lisp - - -This complete resource name contains a path list identifying the reply -button window -- @code{(mail screen-1 reply)} -- and an attribute -name for the window background. The corresponding resource class -contains the class names for the same path list and window attribute. - -@node Matching Resource Names, Resource Access Functions, Complete Names and Classes, Accessing Resource Values -@subsection Matching Resource Names - - -The resource lookup algorithm searches a specified resource data base -and returns the value for the resource binding whose resource name is -the closest match to a given complete resource name and class. The -intent of the lookup algorithm is to formalize an intuitive notion of -the closest match. - -Precedence is given to a match which begins @emph{higher} in the -parent-child contact hierarchy. This allows a resource binding with a -partial name to define a resource value shared by all members of a -window subtree. For example, suppose the resource database contained the -following resource bindings: - -@multitable {Resource Name} {Resource Value} -@item @code{(mail * background)} @tab @code{'red} -@item @code{(* reply background)} @tab @code{'blue} -@end multitable - - -Suppose an application program searched by using the following complete -resource name: - -@lisp -(mail screen-1 reply background) -@end lisp - - -then the closest matching value returned would be @code{'red}. - -Precedence is given to the more specific match. A name match is more -specific than a class match. Either a name or class match is more -specific than a wildcard match. For example, suppose the resource -database contained the following resource bindings: - -@multitable {Resource Name} {Resource Value} -@item @code{(mail * background)} @tab @code{'red} -@item @code{(mail * fill)} @tab @code{'blue} -@end multitable - - -Suppose an application program searched by using the following complete -resource name and complete resource class: - -@lisp -(mail screen-1 reply background) -(application root button fill) -@end lisp - - -then the closest matching value returned would be -@code{'red}. However, suppose the resource database contained the -following resource bindings: - -@multitable {Resource Name} {Resource Value} -@item @code{(mail * background)} @tab @code{'red} -@item @code{(mail * button background)} @tab @code{'blue} -@end multitable - - -then the closest matching value returned would be @code{'blue}. - -@node Resource Access Functions, , Matching Resource Names, Accessing Resource Values -@subsection Resource Access Functions - - -The following paragraphs describe the CLX functions used to return a -value from a resource database. - -@defun get-resource database attribute-name attribute-class path-name path-class - -@table @var -@item database -A @var{resource-database}. -@item attribute-name -A string or symbol giving an attribute name from a complete resource name. -@item attribute-class -A string or symbol giving an attribute class name from a complete resource class. -@item path-name -The path list from a complete resource name. @emph{path-name} and @emph{path-class} must have the same length. -@item path-class -The path list from a complete resource class. @emph{path-name} and @emph{path-class} must have the same length. -@end table - - -Returns the value of the resource binding in the @emph{database} -whose resource name most closely matches the complete resource -name/class given by the @emph{path-name}, @emph{path-class}, -@emph{attribute-name}, and @emph{attribute-class}. The lookup -algorithm implements the precedence rules described previously to -determine the closest match. When comparing name elements, case is -significant only if both elements are strings; otherwise, element -matching is case-insensitive. - -@table @var -@item value -Type @var{t}. -@end table - -@end defun - - - - - -@defun get-search-table database path-name path-class - -@table @var -@item database -A @var{resource-database}. -@item path-name -The path list from a complete resource name. @emph{path-name} and @emph{path-class}must have the same length. -@item path-class -The path list from a complete resource class. @emph{path-name} and @emph{path-class} must have the same length. -@end table - - -Returns a table containing the subset of the @emph{database} that -matches the @emph{path-name} and @emph{path-class}. Resources using -the same @emph{path-name} and @emph{path-class} can be accessed much -more efficiently by using this table as an argument to -@var{get-search-resource}. - -@table @var -@item search-table -Type @var{list}. -@end table - -@end defun - - -@defun get-search-resource table attribute-name attribute-class - -@table @var -@item table -A search table returned by @var{get-search-table}. -@item attribute-name -A string or symbol giving an attribute name from a complete resource name. -@item attribute-class -A string or symbol giving an attribute class name from a complete resource class. -@end table - - -Returns the value of the resource binding in the search @emph{table} -that most closely matches the @emph{attribute-name} and -@emph{attribute-class}. The @emph{table} is computed by -@var{get-search-table} and represents a set of resource -bindings. The closest match is determined by the same algorithm used -in @var{get-resource}. - -The following two forms are functionally equivalent: - -@lisp -(get-resource - database attribute-name attribute-class path-name path-class) - -(get-search-resource - (get-search-table database path-name path-class) - attribute-name attribute-class) -@end lisp - - -However, the hard part of the search is done by -@var{get-search-table}. Looking up values for several resource -attributes that share the same path list can be done much more -efficiently with calls to @var{get-search-resource}. -@table @var -@item value -Type @var{t}. -@end table - -@end defun - -@node Resource Database Files, , Accessing Resource Values, Resources -@section Resource Database Files - - -X users and application programs can save resource bindings in a file, -using a standard file format shared by all X clients. The following -paragraphs describe the CLX functions used to convert between the -standard external format of resource files and the internal -resource-database format used by application programs. - -@defun read-resources database pathname &key :key :test :test-not - -@table @var -@item database -The @var{resource-database} to merge. -@item pathname -A pathname for the resource file to read. -@item :key -A function used to convert a value from the resource file into a resource binding value. -@item :test -@itemx :test-not -Functions used to select which resource bindings from the resource file are merged with the @emph{database}. -@end table - - - - -Reads resource bindings from a resource file in standard X11 format -and merges them with the given resource @emph{database}. The -@var{:key} function is called to convert a file resource value into -the value stored in the @emph{database}. By default, @var{:key} is -@var{#'identity}. The @var{:test} and @var{:test-not} functions -are predicates that select resource bindings to merge, based on the -result of the @var{:key} function. For each file resource binding -consisting of a @emph{resource-name} and a @emph{resource-value}, -the @var{:test} (or @var{:test-not}) function is called with the -arguments @emph{resource-name} and (@var{funcall} @emph{key -resource-value}). - -@table @var -@item database -Type @var{resource-database}. -@end table - -@end defun - - -@defun write-resources database pathname &key :write :test :test-not - -@table @var -@item database -The @var{resource-database} to write. -@item pathname -A pathname of the file to write. -@item :write -A function for writing resource values. -@item :test -@itemx :test-not -Functions used to select which resource bindings from the resource file are merged with the @emph{database}. -@end table - -Writes resource bindings found in the @emph{database} to the file -given by the @emph{pathname}. The output file is written in the -standard X11 format. The @var{:write} function is used for writing -resource values; the default is @var{#'princ}. The @var{:write} -function is passed two arguments: a @emph{resource-value} and a -@emph{stream}. The @var{:test} and @var{:test-not} functions are -predicates which select resource bindings to write. For each -resource binding consisting of a @emph{resource-name} and a -@emph{resource-value}, the @var{:test} (or @var{:test-not}) -function is called with the arguments @emph{resource-name} and -@emph{resource-value}. - - -@end defun - - -@node Control Functions, Extensions, Resources, Top -@chapter Control Functions - -@menu -* Grabbing the Server:: -* Pointer Control:: -* Keyboard Control:: -* Keyboard Encodings:: -* Client Termination:: -* Managing Host Access:: -* Screen Saver:: -@end menu - -@node Grabbing the Server, Pointer Control, Control Functions, Control Functions -@section Grabbing the Server - - -Certain cases may require that a client demand exclusive access to the -server, causing the processing for all other clients to be -suspended. Such exclusive access is referred to as @emph{grabbing the -server}. CLX provides functions to grab and release exclusive access -to the server. These function should be used rarely and always with -extreme caution, since they have the potential to disrupt the entire -window system for all clients. - -@defun grab-server display - -@table @var -@item display -A @var{display}. -@end table - -Disables processing of requests and close-downs on all connections -other than the one on which this request arrived. - - -@end defun - -@defun ungrab-server display - -@table @var -@item display -A @var{display}. -@end table - -Restarts processing of requests and close-downs on other -connections. - - -@end defun - - -@defmac with-server-grabbed display &body body - -Grabs the @emph{display} server only within the dynamic extent of -the @emph{body}. @var{ungrab-server} is automatically called upon -exit from the @emph{body}. This macro provides the most reliable way -for CLX clients to grab the server. - -@table @var -@item display -A @var{display}. -@item body -The forms to execute while the server is grabbed. -@end table - -@end defmac - - -@node Pointer Control, Keyboard Control, Grabbing the Server, Control Functions -@section Pointer Control - - -The following paragraphs describe the CLX functions used to: -@itemize @bullet - -@item Return or change the pointer acceleration and acceleration threshold - -@item Return or change the mapping of pointer button numbers -@end itemize - -@defun change-pointer-control display &key :acceleration :threshold - -@table @var -@item display -A @var{display}. -@item :acceleration -A number for the acceleration ratio. -@item :threshold -The number of pixels required for acceleration to take effect. -@end table - -Changes the acceleration and/or the acceleration threshold of the -pointer for the @emph{display}. The @var{:acceleration} number is -used as a multiplier, typically specified as a rational number of -the form @emph{C/P}, where @emph{C} is the number of pixel positions -of cursor motion displayed for @emph{P} units of pointer device -motion. The acceleration only occurs if the pointer moves more that -@var{:threshold} pixels at once, and only applies to the motion -beyond the @var{:threshold}. Either @var{:acceleration} or -@var{:threshold} can be set to @var{:default}, that restores the -default settings of the server. - - -@end defun - - -@defun pointer-control display - -@table @var -@item display -A @var{display}. -@end table - - -Returns the acceleration and threshold for the @emph{display} -pointer. -@table @var -@item acceleration -@itemx threshold -Type @var{number}. -@end table - -@end defun - - -@defun pointer-mapping display &key (:result-type 'list) - -@table @var -@item display -A @var{display}. -@item :result-type -The type of sequence to return. -@end table - - -Returns or (with @code{setf}) changes the mapping of button numbers -for the @emph{display} pointer. The @var{:result-type} is not used -when changing the mapping. If element @emph{i} of the mapping -sequence is @emph{j}, then the events from pointer button @emph{j} -are reported by the server as events for button @emph{i}+1. (Note -that pointer buttons are numbered beginning with one, while the -mapping sequence itself is indexed normally from zero.) If element -@emph{i} of the mapping sequence is zero, then button @emph{i}+1 is -disabled and can no longer generate input events. No two elements of -the mapping can have the same non-zero value. - -The length of the mapping sequence indicates the actual number of -buttons on the device. When changing the mapping, the new mapping -must have this same length. -@table @var -@item mapping -Type @var{sequence} or @var{card8}@emph{.} -@end table - -@end defun - - -@node Keyboard Control, Keyboard Encodings, Pointer Control, Control Functions -@section Keyboard Control - - -The following paragraphs describe the CLX functions used to: -@itemize @bullet - -@item Return or change keyboard controls - -@item Ring the keyboard bell - -@item Return or change the mapping of modifiers - -@item Return the current up/down state of all keys -@end itemize - -@defun bell display &optional (percent-from-normal 0) - -@table @var -@item display -A @var{display}. -@item percent-from-normal -An integer (-100 through 100). -@end table - -Rings the bell on the keyboard at a volume relative to the base volume for the keyboard, -if possible. Percent can range from -100 to 100 inclusive, or else a Value error occurs. -The following is the bell volume when percent is non-negative: - -@lisp -(- (+ @emph{base percent}) (@var{quotient} (* @emph{base percent}) 100)) -@end lisp - -and when percent is negative: - -@lisp -(+ @emph{base} (@var{quotient} (* @emph{base percent}) 100)) -@end lisp - - - -@end defun - - -@defun change-keyboard-control display &key :key-click-percent :bell-percent :bell-pitch :bell-duration :led :led-mode :key :auto-repeat-mode - -@table @var -@item display -A @var{display}. -@item :key-click-percent -An integer (0 100). -@item :bell-percent -An integer (0 100). -@item :bell-pitch -A @var{card16}. -@item :bell-duration -A @var{card16}. -@item :led -A @var{card8}. -@item :led-mode -Either @var{:on} or @var{:off}. -@item :key -A @var{card8} keycode. -@item :auto-repeat-mode -Either @var{:on}, @var{:off}, or @var{:default}. -@end table - -Changes the various aspects of the keyboard. The keyword arguments -specify which controls to change. - -The @var{:key-click-percent} keyword sets the volume for key -clicks, if possible. A value of 0 implies off, while a value of 100 -implies loud. Setting @var{:key-click-percent} to @var{:default} -restores the default value. - -The @var{:bell-percent} sets the base volume for the bell between 0 -(off) and 100 (loud) if possible. Setting @var{:bell-percent} to -@var{:default} restores the default value. - -The @var{:bell-pitch} sets the pitch (specified in Hz) of the bell, -if possible. Setting the @var{:bell-pitch} to @var{:default} -restores the default value. The @var{:bell-duration} sets the -duration ( specified in milliseconds) of the bell, if -possible. Setting @var{:bell-pitch} to @var{:default} restores the -default. Note that a bell generator connected with the console but -not directly on the keyboard is treated as if it were part of the -keyboard. - -If both @var{:led-mode} and @var{:led} are specified, then the -state of that LED is changed, if possible. If only @var{:led-mode} -is specified, the state of all LEDs are changed, if possible. At -most 32 LEDs are supported, numbered from one. No standard -interpretation of the LEDs are defined. - -If both @var{:auto-repeat-mode} and @var{:key} are specified, the -auto-repeat mode of that key is changed, if possible. If only -@var{:auto-repeat-mode} is specified, the global auto-repeat mode -for the entire keyboard is changed, if possible, without affecting -the per-key settings. An error occurs if @var{:key} is specified -without @var{:auto-repeat-mode}. - - -@end defun - - -@defun keyboard-control display - -@table @var -@item display -A @var{display}. -@end table - - -Returns the current control values for the keyboard. For the LEDs, -the least significant bit of @emph{led-mask} corresponds to LED one, -and each one bit in @emph{led-mask} indicates an LED that is -lit. @emph{auto-repeats} is a bit vector; each one bit indicates -that auto-repeat is enabled for the corresponding key. The vector is -represented as 32 bytes. Byte @emph{n} (from 0) contains the bits -for keys 8@emph{n} to 8@emph{n}+7, with the least significant bit in -the byte representing key 8@emph{n}. -@table @var -@item key-click-percent -@itemx bell-percent -Type @var{card8}. -@item bell-pitch -@itemx bell-duration -Type @var{card16}. -@item led-mask -Type @var{card32}. -@item global-auto-repeat -Either @var{:on} or @var{:off}. -@item auto-repeats -Type @var{bit-vector}. -@end table - -@end defun - - -@defun modifier-mapping display - -@table @var -@item display -A @var{display}. -@end table - - -Returns the set of keycodes used for each modifier on the -@emph{display} keyboard. Each return value is a list of the -@var{card8} keycodes used for each modifier key. The order of -keycodes within each list is server-dependent. -@table @var -@item shift-keycodes -@itemx lock-keycodes -@itemx control-keycodes -@itemx mod1-keycodes -@itemx mod2-keycodes -@itemx mod3-keycodes -@itemx mod4-keycodes -@itemx mod5-keycodes -Type @var{list} of @var{card8}. -@end table - -@end defun - - -@defun query-keymap display - -@table @var -@item display -A @var{display}. -@end table - -Returns a bit vector that describes the state of the keyboard. Each -one bit indicates that the corresponding key is currently -pressed. The vector is represented as 32 bytes. Byte @emph{n} (from -0) contains the bits for keys 8@emph{n} to 8@emph{n}+7, with the -least significant bit in the byte representing key 8@emph{n}. -@table @var -@item keymap -Type @var{bit-vector} 256. -@end table - -@end defun - - -@defun set-modifier-mapping display &key :shift :lock :control :mod1 :mod2 :mod3 :mod4 :mod5 - -@table @var -@item display -A @var{display}. -@item :shift -@itemx :lock -@itemx :control -@itemx :mod1 -@itemx :mod2 -@itemx :mod3 -@itemx :mod4 -@itemx :mod5 -A sequence of @var{card8} keycodes for the given modifier. -@end table - - -Changes the set of keycodes mapped to the specified modifier keys on -the @emph{display} keyboard. Each keyword argument contains a -sequence of new @var{card8} keycodes for a specific modifier. The -return value indicates whether the change was completed -successfully. - -A status of @var{:failed} is returned if hardware limitations -prevent the requested change. For example, multiple keycodes per -modifier may not be supported, up transitions on a given keycode may -not be supported, or autorepeat may be mandatory for a given -keycode. If @var{:failed} is returned, the mappings for all -modifiers remain unchanged. - -A status of @var{:device-busy} is returned if a new keycode given -for a modifier was not previously mapped to that modifier and is -currently in the down state. In this case, the mappings for all -modifiers remain unchanged. -@table @var -@item status -One of @var{:success}, @var{:failed}, or @var{:device-busy}. -@end table - -@end defun - - -@node Keyboard Encodings, Client Termination, Keyboard Control, Control Functions -@section Keyboard Encodings - - -Handling the great diversity of keyboard devices and international -language character encodings is a difficult problem for interactive -programs that need to receive text input but must also be portable. The -X Window System solves this problem by using different sets of encodings -for device keys (@emph{keycodes}) and for character symbols -(@emph{keysyms}). Each X server maintains a @emph{keyboard mapping} that -associates keycodes and keysyms, and which can be returned or changed by -client programs. - -To handle text input, a CLX client program must follow these steps: -@enumerate - -@item -Receive a @var{:key-press} (or @var{:key-release}) event containing -a keycode. - -@item -Convert the keycode into its corresponding keysym, based on the -current keyboard mapping. See @var{keycode->keysym}. - -@item -Convert the keysym into the corresponding Common Lisp character. See -@var{keysym->character}. -@end enumerate - -@menu -* Keycodes and Keysyms:: -* Keyboard Mapping:: -* Using Keycodes and Keysyms:: -@end menu - -@node Keycodes and Keysyms, Keyboard Mapping, Keyboard Encodings, Keyboard Encodings -@subsection Keycodes and Keysyms - - -A @emph{keycode} represents a physical (or logical) key. In CLX, -keycodes are values of type (@var{integer} 8 255). A keycode value -carries no intrinsic information, although server implementors may -attempt to encode geometry (for example, matrix) information in some -fashion so it can be interpreted in a server- dependent fashion. The -mapping between keys and keycodes cannot be changed. - -A @emph{keysym} is an encoding of a symbol on the cap of a key. In CLX, -keysyms are values of type @var{card32}. The set of defined keysyms -include the ISO Latin character sets (1-4), Katakana, Arabic, Cyrillic, -Greek, Technical, Special, Publishing, APL, Hebrew, and miscellaneous -keys found on keyboards (RETURN, HELP, TAB, and so on). The encoding of -keysyms is defined by the X Protocol. - -A list of keysyms is associated with each keycode. The length of the -list can vary with each keycode. The list is intended to convey the set -of symbols on the corresponding key. By convention, if the list contains -a single keysym and if that keysym is alphabetic and case distinction is -relevant, then it should be treated as equivalent to a two-element list -of the lowercase and uppercase keysyms. For example, if the list -contains the single keysym for uppercase A, the client should treat it -as if it were a pair with lowercase as the first keysym and uppercase A -as the second keysym. - -For any keycode, the first keysym in the list should be chosen as the -interpretation of a key press when no modifier keys are down. The second -keysym in the list normally should be chosen when the @var{:shift} -modifier is on, or when the @var{:lock} modifier is on and @var{:lock} -is interpreted as @var{:shift-lock}. When the @var{:lock} modifier is -on and is interpreted as @var{:caps-lock}, it is suggested that the -@var{:shift} modifier first be applied to choose a keysym, but if that -keysym is lowercase alphabetic, the corresponding uppercase keysym -should be used instead. - -Other interpretations of @var{:caps-lock} are possible; for example, it -may be viewed as equivalent to @var{:shift-lock}, but only applying -when the first keysym is lowercase alphabetic and the second keysym is -the corresponding uppercase alphabetic. No interpretation of keysyms -beyond the first two in a list is suggested here. No spatial geometry of -the symbols on the key is defined by their order in the keysym list, -although a geometry might be defined on a vendor-specific basis. The X -server does not use the mapping between keycodes and keysyms. Rather, -the X server stores the mapping merely for reading and writing by -clients. - -@node Keyboard Mapping, Using Keycodes and Keysyms, Keycodes and Keysyms, Keyboard Encodings -@subsection Keyboard Mapping - -The X server maintains a keyboard mapping that associates each keycode -with one or more keysyms. The following paragraphs describe the CLX -functions used to return or change the mapping of keycodes. - -@defun change-keyboard-mapping display keysyms &key (:start 0) :end - -@table @var -@item display -A @var{display}. -@item keysyms -A two-dimensional array of keysym (@var{card32}) values. -@item :start -@itemx :end -Indexes for the subsequence of @emph{keysyms} used. -@item :first-keycode -A @var{card8} defining the first keycode mapping changed. -@end table - -(@var{:first-keycode :start}) - -Changes the mapping of keycodes to @emph{keysyms}. A -@var{:mapping-notify} event is generated for all clients. - -The new @emph{keysyms} are specified as a two-dimensional array in -which: - -(@var{aref} @emph{keysyms} (+ @var{:start} @emph{i}) @emph{j}) - -is @emph{keysym j} associated with keycode (+ @var{:first-keycode} -@emph{i}). The maximum number of @emph{keysyms} associated with any -one keycode is given by: - -(@var{array-dimension} @emph{keysyms} 1) - -@emph{keysyms} should contain @var{nil} elements to represent those -keysyms that are undefined for a given keycode. @var{:start} and -@var{:end} define the subsequence of the @emph{keysyms} array that -defines the new mapping, and the number of keycode mappings -changed. By default, @var{:end} is given by: - -(@var{array-dimension} @emph{keysyms} 0) - -The keycodes whose mappings are changed are given by -@var{:first-keycode} through the following: - -(+ @var{:first-keycode} (- @var{:end :start}) -1) - -keycodes outside this range of are not -affected. @var{:first-keycode} must not be less than -(@var{display-min-keycode} @emph{display}), and the last keycode -modified must not be greater than (@var{display-max-keycode} -@emph{display}). - - -@end defun - - - -@defun keyboard-mapping display &key :first-keycode :start :end :data - -@table @var -@item display -A @var{display}. -@item :first-keycode -A @var{card8} defining the first keycode mapping returned. -@item :start -@itemx :end -Indexes for the subsequence of the returned array which is modified. -@item :data -If given, a two-dimensional array to receive the returned keysyms. -@end table -Returns the keysyms mapped to the given range of keycodes for the -@emph{display} keyboard. The mappings are returned in the form of a -two-dimensional array of @var{card32} keysym values. The -@var{:data} argument, if given, must be a two-dimensional array in -which the returned mappings will be stored. In this case: - -(@var{array-dimension :data} 1) - -defines the maximum number of keysyms returned for any -keycode. Otherwise, a new array is created and returned. - -Upon return: - -(@var{aref} @emph{mappings} (+ @emph{:start i}) @emph{j}) - -will contain keysym @emph{j} associated with keycode (+ -@var{:first-keycode i}) (or @var{nil}, if keysym @emph{j} is -undefined for that keycode). - -@var{:first-keycode} specifies the first keycode whose mapping is -returned; by default, @var{:first-keycode} is -(@var{display-min-keycode} @emph{display}). @var{:start} and -@var{:end} define the subsequence of the returned array in which -the returned mappings are stored. By default, @var{:start} is given -by @var{:first-keycode} and @var{:end} is given by: - -(1+ (@var{display-max-keycode} @emph{display})) - -@var{:first-keycode} must not be less than -(@var{display-min-keycode} @emph{display}), and the last keycode -returned must not be greater than (@var{display-max-keycode} -@emph{display}). -@table @var -@item mappings -Type (@var{array card32} (* *)). -@end table - -@end defun - - -@node Using Keycodes and Keysyms, , Keyboard Mapping, Keyboard Encodings -@subsection Using Keycodes and Keysyms - - -The following paragraphs describe the CLX functions used to: -@itemize @bullet - -@item Convert a keycode into a keysym - -@item Convert a keysym into a character -@end itemize - -@defun keycode->keysym display keycode keysym-index - -@table @var -@item display -A @var{display}. -@item keycode -A @var{card8}. -@item keysym-index -A @var{card8}. -@end table - - -Returns the @emph{keysym} at the given @emph{keysym-index} from the -keysym list for the @emph{keycode} in the current keyboard mapping -for the @emph{display} server. -@emph{This function was called keycode-keysym in X11R4 and older versions of CLX.} -@table @var -@item keysym -Type @var{keysym}. -@end table - -@end defun - - -@defun keysym->character display keysym &optional (state 0) - -@table @var -@item display -A @var{display}. -@item keysym -A @var{keysym}. -@item state -A @var{mask16}. -@end table - -Returns the @emph{character} associated with the @emph{keysym} and -the @emph{state}. The @emph{state} is a @var{mask16} bit mask -representing the state of the @emph{display} modifier keys and -pointer buttons. See @var{state-mask-key} in @ref{Data Types}. If the @emph{keysym} does not represent a Common Lisp -character, then @var{nil} is returned. -@emph{This function was called keysym-character in X11R4 and older versions of CLX.} - -The @emph{state} determines the bits attribute of the returned -@emph{character}, as follows: -@table @var -@item :control -@var{char-control-bit} -@item :mod-1 -@var{char-meta-bit} -@item :mod-2 -@var{char-super-bit} -@item :mod-3 -@var{char-hyper-bit} -@end table - -@c Of course *we* know that this mapping is bull shit! -@table @var -@item character -Type @var{character} or @var{null}. -@end table - -@end defun - - -@node Client Termination, Managing Host Access, Keyboard Encodings, Control Functions -@section Client Termination - - -The CLX functions affecting client termination are discussed in the -following paragraphs. - -When a display connection to an X server is closed, whether by an -explicit call to @var{close-display} or by some external condition, the -server automatically performs a sequence of operations to clean up -server state information associated with the closed connection. The -effect of these operations depends the @emph{close-down mode} and the -@emph{save-set} that the client has specified for the closed display -connection. The close-down mode of a display determines whether server -resources allocated by the connection are freed or not. The save-set -identifies windows that will remain after the connection is closed. - -The display save-set is used primarily by window managers that reparent -the top-level windows of other clients. For example, such a window -manager can automatically create a frame window that encloses a -top-level client window, along with a set of controls used for window -management. Ordinarily, termination of the window manager client would -then destroy all client windows! However, the window manager can prevent -this by adding to its save-set those windows created by other clients -that should be preserved. - -When a display connection closes, an X server performs the following -operations: -@enumerate - -@item -For each selection owned by a window created on the connection, the -selection owner is set to @var{nil}. - -@item -An active or passive grab established for a window created on the -connection is released. - -@item -If the connection has grabbed the server, the server is ungrabbed. - -@item -Server resources and colormap cells allocated by the connection are -freed and destroyed, depending on the close-down mode, as follows: -@itemize @bullet - -@item -@var{:retain-permanent} -- All resources are marked -@emph{permanent}, and no resources are destroyed. These resources -can later be destroyed by a call to @var{kill-client}. - -@item -@var{:retain-temporary} -- All resources are marked -@emph{temporary}, and no resources are destroyed. These resources -can later be destroyed by a call to @var{kill-client} or -@var{kill-temporary-clients}. - -@item -@var{:destroy} -- All resources are destroyed. -@end itemize -@end enumerate - -When server resources allocated by a display connection are destroyed -- -whether by closing the connection with close-down mode @var{:destroy} -or by later calling @var{kill-client} or @var{kill-temporary-clients} --- then an X server performs the following operations on each member of -the save-set before actually destroying resources. -@enumerate - -@item -If the save-set window is a descendant of a window created on the -connection, the save-set window is reparented. The new parent is the -closest ancestor such that the save-set window is no longer a -descendant of any window created on the connection. The position of -the reparented window with respect to its parent remains unchanged. - -@item -If the save-set window is unmapped, then it is mapped. -@end enumerate - -If the last connection open to an X server is closed with close-down -mode @var{:destroy}, the server resets its state to restore all initial -defaults. The server state after reset is the same as its initial state -when first started. When an X server resets, it performs the following -operations: -@itemize @bullet - -@item -All permanent and temporary server resources from previously-closed -connections are destroyed. - -@item -All but the predefined atoms are deleted. - -@item -All root window properties are deleted. - -@item -All device control attributes and mappings are restored to their -original default values. - -@item -The default background and cursor for all root windows are restored. - -@item -The default font path is restored. - -@item -The input focus is set to @var{:pointer-root}. - -@item -The access control list is reset. -@end itemize - -The following paragraphs describe the CLX functions used to: -@itemize @bullet - -@item -Add or remove a window from a display save-set. - -@item -Return or change the display close-down mode. - -@item -Force a connection to be closed or all its server resources to be -destroyed. - -@item -Force a connection to be closed and all temporary resources to be -destroyed. -@end itemize - -@defun add-to-save-set window - -@table @var -@item window -A @var{window}. -@end table - -Adds the specified @emph{window} to the save-set of the -@emph{window} display. The @emph{window} must have been created by -some other display. Windows are removed automatically from the -save-set when they are destroyed. - - -@end defun - - -@defun close-down-mode display - -@table @var -@item display -A @var{display}. -@end table -Returns and (with @code{setf}) sets the close-down mode of the -client's resources at connection close. -@table @var -@item mode -One of @var{:destroy}, @var{:retain-permanent}, or @var{:retain-temporary}. -@end table - -@end defun - - -@defun kill-client display resource-id - -@table @var -@item display -A @var{display}. -@item resource-id -A valid @var{card29} resource ID. -@end table - -Closes the display connection which created the given -@emph{resource-id}. The @emph{resource-id} must be valid, but need -not belong to the given @emph{display}. - -If the closed connection was previously open, the connection is -closed according to its close-down mode. Otherwise, if the -connection had been previously terminated with close-down mode -@var{:retain-permanent} or @var{:retain-temporary}, then all its -retained server resources -- both permanent and temporary -- are -destroyed. - - -@end defun - - -@defun kill-temporary-clients display - -@table @var -@item display -A @var{display}. -@end table - -Closes the @emph{display} connection and destroys all retained -temporary server resources for this and all previously-terminated -connections. - -If the @emph{display} connection was previously open, the connection -is closed according to its close-down mode. Otherwise, if the -@emph{display} connection had been previously terminated with -close-down mode @var{:retain-permanent} or -@var{:retain-temporary}, then all its retained server resources -- -both permanent and temporary -- are destroyed. - - -@end defun - - -@defun remove-from-save-set window - -@table @var -@item window -A @var{window}. -@end table - -Removes the specified @emph{window} from the save-set of the -@emph{window} display. The @emph{window} must have been created by -some other display. Windows are removed automatically from the -save-set when they are destroyed. - - -@end defun - - -@node Managing Host Access, Screen Saver, Client Termination, Control Functions -@section Managing Host Access - - -An X server maintains a list of hosts from which client programs can be -run. Only clients executing on hosts that belong to this @emph{access -control list} are allowed to open a connection to the -server. Typically, the access control list can be changed by clients -running on the same host as the server. Some server implementations can -also implement other authorization mechanisms in addition to, or in -place of, this mechanism. The action of this mechanism can be -conditional based on the authorization protocol name and data received -by the server at connection setup. - -The following paragraphs describe the CLX functions used to: -@itemize @bullet - -@item Add or remove hosts on the access control list. - -@item Return the hosts on the access control list. - -@item Return or change the state of the access control list mechanism -@end itemize - -@defun access-control display - -@table @var -@item display -A @var{display}. -@end table -Returns and (with @code{setf}) changes the state of the access -control list mechanism for the @emph{display} server. Returns true -if access control is enabled; otherwise, @var{nil} is returned. If -enabled, the access control list is used to validate each client -during connection setup. - -Only a client running on the same host as the server is allowed to -enable or disable the access control list mechanism. -@table @var -@item enabled-p -Type @var{boolean}. -@end table - -@end defun - - -@defun access-hosts display &key (:result-type 'list) - -@table @var -@item display -A @var{display}. -@item :result-type -The type of hosts sequence to return. -@end table -Returns a sequence containing the @emph{hosts} that belong to the -access control list of the @emph{display} server. Elements of the -returned @emph{hosts} sequence are either strings or some other type -of object recognized as a host name by @var{add-access-host} and -@var{remove-access-host}. The second returned value specifies -whether the access control list mechanism is currently enabled or -disabled (see @var{access-control}). -@table @var -@item hosts -@var{sequence} of @var{string}. -@item enabled-p -Type @var{boolean}. -@end table - -@end defun - - -@defun add-access-host display host - -@table @var -@item display -A @var{display}. -@item host -A host name. Either a string or some other implementation-dependent type. -@end table - -Adds the specified @emph{host} to the access control list. Only a -client running on the same host as the server can change the access -control list. - - -@end defun - - -@defun remove-access-host display host - -@table @var -@item display -A @var{display}. -@item host -A host name. Either a string or some other implementation-dependent type. -@end table - -Removes the specified @emph{host} from the access control list. Only -a client running on the same host as the server can change the -access control list. - - -@end defun - - -@node Screen Saver, , Managing Host Access, Control Functions -@section Screen Saver - - -To prevent monitor damage, an X server implements a screen saver -function which blanks screens during periods of unuse. The screen saver -can be in one of three states: -@itemize @bullet - -@item -Disabled -- No screen blanking is done and screen content remains unchanged. - -@item -Deactivated -- The server is being used. When the server input devices -are unused for a specific amount of time, the screen saver becomes -activated. - -@item -Activated -- The server input devices are unused. The screen saver -blanks all server screens or displays a server-dependent image. As -soon as an input event from either the pointer or the keyboard occurs, -the screen saver is deactivated and its timer is reset. -@end itemize - -The following paragraphs describe the CLX functions used to: -@itemize @bullet - -@item -Return or change screen saver control values. - -@item -Activate or reset the screen saver -@end itemize - -@defun activate-screen-saver display - -@table @var -@item display -A @var{display}. -@end table - -Activates the screen saver for the @emph{display} server. - - -@end defun - - -@defun reset-screen-saver display - -@table @var -@item display -A @var{display}. -@end table - -Deactivates the screen saver for the @emph{display} server (if -necessary) and resets its timer, just as if a pointer or keyboard -event had occurred. - - -@end defun - - -@defun screen-saver display - -@table @var -@item display -A @var{display}. -@end table -Returns the current control values for the @emph{display} server -screen saver. See @var{set-screen-saver}. -@table @var -@item timeout -@itemx period -Type @var{int16}. -@item blanking -@itemx exposures -One of @var{:yes} or @var{:no}. -@end table - -@end defun - - -@defun set-screen-saver display timeout period blanking exposures - -@table @var -@item display -A @var{display}. -@item timeout -Specifies the delay until timeout takes over. -@item period -Specifies the periodic change interval, if used. -@item blanking -Specifies whether the blanking option is available. -@item exposures -Specifies whether exposures are allowed during blanking. -@end table - -Changes the current control values for the @emph{display} server -screen saver. The screen saver is reset. The screen saver is also -disabled if: -@itemize @bullet - -@item -@emph{timeout} is zero, or - -@item -Both @emph{blanking} and @emph{exposures} are disabled and the -server cannot regenerate the screen contents without sending -@var{:exposure} events. -@end itemize - -The @emph{timeout} specifies the (non-negative) number of seconds of -input device inactivity that must elapse before the screen saver is -activated. The @emph{timeout} can be set to @var{:default} to -restore the server default timeout interval. - -If @emph{blanking} is @var{:yes} and the screen hardware supports -blanking, blanking is enabled; that is, the screen saver will simply -blank all screens when it is activated. @emph{blanking} can be set -to @var{:default} to restore the server default state for blanking. - -If @emph{exposures} is @var{:yes}, exposures are enabled. If -exposures are enabled, or if the server is capable of regenerating -screen contents without sending @var{:exposure} events, the screen -saver will display some server-dependent image when -activated. Frequently, this image will consist of a repeating -animation sequence, in which case @emph{period} specifies the ( -non-negative) number of seconds for each repetition. A @emph{period} -of zero is a hint that no repetition should occur. - - -@end defun - - - -@node Extensions, Errors, Control Functions, Top -@chapter Extensions -@menu -* Extensions (Extensions):: -* SHAPE - The X11 Nonrectangular Window Shape Extension:: -* RENDER - A new rendering system for X11:: -* DPMS - The X11 Display Power Management Signaling Extension:: -* BIG-REQUESTS - Big Requests Extension:: -@end menu - -@node Extensions (Extensions), SHAPE - The X11 Nonrectangular Window Shape Extension, Extensions, Extensions -@section Extensions - - -The X Window System is based on a core protocol which can be extended to -provide new functionality. An extension is generally represented by an -additional set of requests or event types that are implemented by an X -server supporting the extension. By definition, a client program using -an extension may not be portable to other servers. However, extensions -allow different server implementations and different sites to add their -own special features to X, without disrupting clients that rely only on -the core protocol. - -Extensions are identified by assigning them unique name strings and -major protocol numbers. A client program can request an X server to use -a protocol extension by furnishing the extension protocol number as an -argument to @var{open-display}. The X Consortium maintains a registry -of standard extension names and protocol numbers. - -The following paragraphs describe the CLX functions used to: -@itemize @bullet - -@item List all supported extensions. - -@item Find out if a given extension is supported. -@end itemize - - -@defun list-extensions display &key (:result-type 'list) - -@table @var -@item display -A @var{display}. -@item :result-type -The type of name sequence to return. -@end table -Returns a sequence containing the @emph{names} of all extensions -supported by the @emph{display} server. -@table @var -@item names -Type @var{sequence} of @var{string}. -@end table - -@end defun - - -@defun query-extension display name - -@table @var -@item display -A @var{display}. -@item name -An extension name string. -@end table - - -Returns the @emph{major-opcode} for the given extension @emph{name} -support by the @emph{display} server. If the extension is not -supported, only @var{nil} values are returned. The extension -@emph{name} must contain only ISO Latin-1 characters; case is -significant. - -If the extension involves additional event types, the -@emph{first-event} returned is the base event type code for new -events; otherwise, the @emph{first-event} is @var{nil}. If the -extension involves additional error codes, the @emph{first-error} -returned is the base code for new errors; otherwise, the -@emph{first-error} is @var{nil}. The formats of error and event -messages sent by the server are completely defined by the extension. -@table @var -@item major-opcode -@itemx first-event -@itemx first-error -Type @var{card8} or @var{null}. -@end table - -@end defun - - -@node SHAPE - The X11 Nonrectangular Window Shape Extension, RENDER - A new rendering system for X11, Extensions (Extensions), Extensions -@section SHAPE - The X11 Nonrectangular Window Shape Extension - - -This documentation is yet to be written. - -@node RENDER - A new rendering system for X11, DPMS - The X11 Display Power Management Signaling Extension, SHAPE - The X11 Nonrectangular Window Shape Extension, Extensions -@section RENDER - A new rendering system for X11 - - -XRENDER is an experimental step in building a newer and modern graphics rendering -system that can keep up with the demands of visual appearance on current user -interfaces. - -The X Rendering Extension (Render) introduces digital image composition as -the foundation of a new rendering model within the X Window System. -Rendering geometric figures is accomplished by client-side tesselation into -either triangles or trapezoids. Text is drawn by loading glyphs into the -server and rendering sets of them. - -@menu -* Picture formats:: -* The picture object:: -* Glyphs and Glyphsets:: -* Using glyphs:: -* Errors (Extensions):: -@end menu - -@node Picture formats, The picture object, RENDER - A new rendering system for X11, RENDER - A new rendering system for X11 -@subsection Picture formats - -The following is what the X protocol rendering spec has to say about picture formats. -@url{http://www.xfree86.org/~keithp/render/protocol.html} - - -The @var{picture-format} object holds information needed to translate pixel values -into red, green, blue and alpha channels. The server has a list of picture -formats corresponding to the various visuals on the screen. There are two -classes of formats, Indexed and Direct. Indexed picture-formats hold a list of -pixel values and RGBA values while Direct picture-formats hold bit masks for each -of R, G, B and A. - - -The server must support a direct @var{picture-format} with 8 bits each of red, green, -blue and alpha as well as a direct @var{picture-format} with 8 bits of red, green and -blue and 0 bits of alpha. The server must also support direct @var{picture-format}s -with 1, 4 and 8 bits of alpha and 0 bits of r, g and b. - - -Pixel component values lie in the closed range [0,1]. These values are -encoded in a varying number of bits. Values are encoded in a straight -forward manner. For a component encoded in m bits, a binary encoding b -is equal to a component value of b/(2^m-1). - - -A direct @var{picture-format} with zero bits of alpha component is declared to have -alpha == 1 everywhere. A direct @var{picture-format} with zero bits of red, green and -blue is declared to have red, green, blue == 0 everywhere. If any of red, -green or blue components are of zero size, all are of zero size. Direct -@var{picture-format}s never have colormaps and are therefore screen independent. - - -Indexed @var{picture-format}s never have alpha channels and the direct component is all -zeros. Indexed @var{picture-format}s always have a colormap in which the specified -colors are allocated read- only and are therefore screen dependent. - -These are valid accessors for picture-format objects. - -@table @var -@item picture-format-display -A display -@item picture-format-id -The X protocol @var{resource-id} -@item picture-format-type -@code{(member :indexed :direct)} -@item picture-format-depth -Bitdepth as @var{card8} -@item picture-format-red-byte -A bitmask -@item picture-format-green-byte -@itemx picture-format-blue-byte -@itemx picture-format-alpha-byte -@itemx picture-format-colormap -A @var{colormap} or nil -@end table - -@node The picture object, Glyphs and Glyphsets, Picture formats, RENDER - A new rendering system for X11 -@subsection The picture object - - -The @var{picture} object contains a @var{drawable}, a @var{picture-format} and some -rendering state. More than one @var{picture} can refer to the same @var{drawable}. - - -A @var{picture} is almost like a @var{gcontext}, except that it is tied in use to -a single @var{drawable}. Another similarity it has with @var{gcontext} is that it is -a cached object. Updates are not processed until the @var{picture} is used. This also -makes it possible to query state, as there is no such request in XRENDER to do so. - - -The @var{picture} object is also a lot like a @var{drawable}, in that it is used as a -target for graphics operations. Or at least that it occurs where you would expect a -drawable in XRENDER requests. - -@defun render-create-picture drawable &key format picture ... - -@table @var -@item drawable -A @var{Drawable} -@item format -A @var{picture-format} -@item picture -An existing @var{picture} object to use, -one is created if not specified. -@item repeat -@code{(member :off :on)} -@item alpha-map -A @var{picture} or @var{:none} -@item alpha-x-origin -@var{int16} -@item alpha-y-origin -@var{int16} -@item clip-x-origin -@var{int16} -@item clip-y-origin -@var{int16} -@item clip-mask -A @var{Pixmap} or @var{:none} -@item graphics-exposures -@code{(member :off :on)} -@item subwindow-mode -@code{(member :clip-by-children :include-inferiors)} -@item poly-edge -@code{(member :sharp :smooth)} -@item poly-mode -@code{(member :precise :imprecise)} -@item dither -@var{xatom} or @var{:none} -@item component-alpha -@code{(member :off :on)} -@end table -This request creates a Picture object. If the @emph{drawable} is a Window -then the Red, Green and Blue masks must match those in the visual for the -window else a Match error is generated. - -@table @var -@item picture -A @var{picture} -@end table - -@end defun - - - -@defun render-free-picture picture This request deletes all server resources associated with the picture object. - -@table @var -@item picture -The @var{picture} object to free -@end table - - - -@end defun - -@node Glyphs and Glyphsets, Using glyphs, The picture object, RENDER - A new rendering system for X11 -@subsection Glyphs and Glyphsets - - -A glyph in XRENDER is an alpha mask and an associated orgin, advancement and numeric id. The application refers to them -by the numeric id. - -Glyphs are stored in a glyph-set. The client is responsible for making sure the glyphs it uses are stored in -the glyph-set, or there will be a Glyph-error. - -@defun render-create-glyph-set format &key glyph-set - -@table @var -@item format -A @var{picture-format} for the alpha masks that this font will use. -@item glyph-set -An optional @var{glyph-set} object to initialize with a server side glyphset resource. -@end table - - - -Creates an initially empty glyph-set for the client to use. -@emph{Format} must be a Direct format. When it contains RGB values, the glyphs are composited using -component-alpha True, otherwise they are composited using component-alpha False. -@end defun - - -@defun render-reference-glyph-set existing-glyph-set &key glyph-set - -@table @var -@item existing-glyph-set -An existing @var{glyph-set} -@item glyph-set -An optional @var{glyph-set}, just like in @var{render-create-glyph-set} -@end table - - - -Creates a new id refering to the existing-glyph-set. The glyph-set itself will not be freed until all -ids has been removed. -@end defun - -@defun render-free-glyph-set glyph-set - -@table @var -@item glyph-set -A glyphset resource to free -@end table - -Removes an id to a glyph-set. When all ids have been removed the glyph-set itself is removed. - - - -@end defun - -@defun render-add-glyph glyph-set id &key x-origin y-origin x-advance y-advance data - -@table @var -@item glyph-set -A @var{glyph-set} -@item id -@var{card32} -@item x-orgin -@var{int16} -@item y-orgin -@var{int16} -@item x-advance -@var{int16} -@item y-advance -@var{int16} -@item data -An @var{array} of @var{card8} bytes. -@end table - -Associates id with the given description of a glyph. An existing glyph -with the same id is replaced. - -At the time of writing, only 8bit alpha masks are -supported. Experimentation with glyph-sets in other pict-formats -needed. - - - -@end defun - -@defun render-add-glyph-from-picture glyph-set picture &key x-origin y-origin x-advance y-advance width height - -@table @var -@item glyph-set -glyph-set -@item picture -picture -@item x-origin -int16 -@item y-origin -int16 -@item x-advance -int16 -@item y-advance -int16 -@item x -int16 -@item y -int16 -@item width -card16 -@item height -card16 -@end table - - - -This request add a glyph to @emph{glyph-set} by copying it from the @emph{x,y} location in the @emph{picture}. - -Existing glyphs with the same names are replaced. -The source @emph{picture} may be in a different @var{picture-format} than @emph{glyph-set}, in which case the images are converted to the glyph-set's format. -@end defun - -@defun render-free-glyphs glyph-set glyphs - -@table @var -@item glyph-set -A @var{glyph-set} -@item glyphs -sequence of @var{card32} -@end table - - - - -This request removes @emph{glyphs} from @emph{glyph-set}. -Each glyph must exist in @emph{glyph-set} (else a @var{Match} error results). -@end defun - -@node Using glyphs, Errors (Extensions), Glyphs and Glyphsets, RENDER - A new rendering system for X11 -@subsection Using glyphs - -@defun render-composite-glyph dest glyph-set source dest-x dest-y sequence &key op src-x src-y mask-format start end - -@table @var -@item dest -picture -@item glyph-set -glyph-set -@item source -picture -@item dest-x -int16 -@item dest-y -int16 -@item sequence - -@item op -(member clear :src :dst :over :over-reverse :in :in-reverse :out :out-reverse :atop :atop-reverse :xor :add :saturate :maximum) -@item src-x -int16 -@item src-y -iny16 -@item mask-format -picture-format -@item start -blah -@item end -blah -@end table - - - - -Requests the sequence of glyphs to be drawn with the glyph-set. -@end defun - - - -@node Errors (Extensions), , Using glyphs, RENDER - A new rendering system for X11 -@subsection Errors - -What new errors Xrender defines... - - -@node DPMS - The X11 Display Power Management Signaling Extension, BIG-REQUESTS - Big Requests Extension, RENDER - A new rendering system for X11, Extensions -@section DPMS - The X11 Display Power Management Signaling Extension - -@defun dpms-get-version display &optional (major-version 1) (minor-version 1) -@table @var -@item display -@var{display} -@item major-version -@var{card16} -@item minor-version -@var{card16} -@end table - - -Return two values: the major and minor version of the DPMS -implementation the server supports. - -If supplied, the @var{major-version} and @var{minor-version} -indicate what version of the protocol the client wants the server to -implement. -@end defun - -@defun dpms-capable display -@table @var -@item display -@var{display} -@end table - - -True if the currently running server's devices are capable of DPMS -operations. - -The truth value of this request is implementation defined, but is -generally based on the capabilities of the graphic card and monitor -combination. Also, the return value in the case of heterogeneous -multi-head servers is implementation defined. -@end defun - - -@defun dpms-get-timeouts display -@table @var -@item display -@var{display} -@end table - - -Return three values: the current values of the DPMS timeout values. -The timeout values are (in order returned): standby, suspend and off. -All values are in units of seconds. A value of zero for any timeout -value indicates that the mode is disabled. -@end defun - -@defun dpms-set-timeouts display standby suspend off -@table @var -@item display -@var{display} -@item standby -@var{card16} -@item suspend -@var{card16} -@item off -@var{card16} -@end table - - -Set the values of the DPMS timeouts. All values are in units of -seconds. A value of zero for any timeout value disables that mode. -@end defun - -@defun dpms-enable display -@table @var -@item display -@var{display} -@end table - - -Enable the DPMS characteristics of the server using the server's -currently stored timeouts. If DPMS is already enabled, no change is -affected. -@end defun - -@defun dpms-disable display -@table @var -@item display -@var{display} -@end table - - -Disable the DPMS characteristics of the server. It does not affect -the core or extension screen savers. If DPMS is already disabled, no -change is effected. - -This request is provided so that DPMS may be disabled without damaging -the server's stored timeout values. -@end defun - -@defun dpms-force-level display power-level -@table @var -@item display -@var{display} -@item power-level -(member :dpms-mode-on :dpms-mode-standby :dpms-mode-suspend :dpms-mode-off) -@end table - - -Forces a specific DPMS level on the server. -@end defun - -@defun dpms-info display -@table @var -@item display -@var{display} -@end table - - -Returns two values: the DPMS power-level and state value for the -display. - -State is one of the keywords DPMS-ENABLED or DPMS-DISABLED. - -If state is DPMS-ENABLED, then power-level is returned as one of the -keywords DPMS-MODE-ON, DPMS-MODE-STANDBY, DPMS-MODE-SUSPEND or -DPMS-MODE-OFF. If state is DPMS-DISABLED, then power-level is -undefined and returned as NIL. -@end defun - -@node BIG-REQUESTS - Big Requests Extension, , DPMS - The X11 Display Power Management Signaling Extension, Extensions -@section BIG-REQUESTS - Big Requests Extension - -@defun display-extended-max-request-length display -@end defun -@defun enable-big-requests display -@end defun - -@chapter Errors -@node Errors, Undocumented, Extensions, Top - -@menu -* Introduction (Errors):: -@end menu - -@node Introduction (Errors), , Errors, Errors -@section Introduction - -CLX error conditions are hierarchial. The base error condition is -@var{x-error}, and all other conditions are built on top of -@var{x-error}. @var{x-error} can be built on a lower-level condition -that is implementation dependent (this is probably the @var{error} -condition). - -@defmac define-condition name (parent-types*) [({slot-specifier*}) {option*}] - -Any new condition type must be defined with the -@var{define-condition} macro. A condition type has a name, parent -types, report message, and any number of slot items. See the -@emph{Lisp} @emph{Reference} manual for further information -regarding @var{define-condition}. - -The following are the predefined error conditions that can occur in CLX. -@end defmac - - -@deftp {Condition} access-error - -An @var{access-error} can occur for several reasons: -@itemize @bullet - -@item -A client attempted to grab a key/button combination already -grabbed by another client - -@item -A client attempted to free a colormap entry that it did not already allocate - -@item -A client attempted to store into a read-only colormap entry - -@item -A client attempted to modify the access control list from other -than the local (or otherwise authorized) host - -@item -A client attempted to select an event type that another client -has already selected, and, that at most, one client can select -at a time -@end itemize - -An @var{access-error} is a special case of the more general -@var{request-error} (@pxref{request-error}). -@end deftp - - -@deftp {Condition} alloc-error - -The server failed to allocate the requested resource or server memory. - -An @var{alloc-error} is a special case of the more general -@var{request-error} (@pxref{request-error}). -@end deftp - - -@deftp {Condition} atom-error - -A value for an @emph{atom} argument does not name a defined atom. - -An @var{atom-error} is a special case of the more general -@var{request-error} (@pxref{request-error}). -@end deftp - - -@deftp {Condition} closed-display - -The @var{closed-display} condition is signaled when trying to read -or write a closed display (that is, @var{close-display} has been -called on the @var{display} object, or a server-disconnect -occurred). The @var{closed-display} object is reported with the -error. - -A @var{closed-display} condition is a special case of the more -general @var{x-error} (@pxref{x-error}). -@end deftp - - -@deftp {Condition} colormap-error - -A value for a @emph{colormap} argument does not name a defined -colormap. - -A @var{colormap-error} is a special case of the more general -@var{resource-error} (@pxref{resource-error}). -@end deftp - - -@deftp {Condition} connection-failure - -Signaled when an X11 server refuses a connection. The following -items are reported along with the error: -@itemize @bullet - -@item @emph{major-version} -- The major version of the X server code. - -@item @emph{minor-version} -- The minor version of the X server code. - -@item @emph{host} -- The host name for the X server. - -@item @emph{display} -- The display on which the error occurred. - -@item @emph{reason} -- A string indicating why the connection failed. -@end itemize - -A @var{connection-failure} is a special case of the more general -@var{x-error} (@pxref{x-error}). -@end deftp - - -@deftp {Condition} cursor-error - -A value for a @emph{cursor} argument does not name a defined cursor. - -A @var{cursor-error} is a special case of the more general -@var{resource-error} (@pxref{resource-error}). -@end deftp - - -@deftp {Condition} device-busy - -Signaled by (@code{setf} (@var{pointer-mapping} @emph{display}) -@var{mapping}) when the @var{set-pointer-mapping} request returns -a busy status. A similar condition occurs in -@var{set-modifier-mapping}, but in this case, it returns a boolean -indicating success, rather than signaling an error. The -@var{device-busy} condition returns the display object as part of -the error. - -A @var{device-busy} condition is a special case of the more general -@var{x-error} (@pxref{x-error}). -@end deftp - - -@deftp {Condition} drawable-error - -A value for a @emph{drawable} argument does not name a defined window or pixmap. - -A @var{drawable-error} is a special case of the more general @var{resource-error} (@pxref{resource-error}). -@end deftp - - -@deftp {Condition} font-error - -A value for a @emph{font} or @emph{gcontext} argument does not name a defined font. - -A @var{font-error} is a special case of the more general -@var{resource-error} (@pxref{resource-error}). -@end deftp - - -@deftp {Condition} gcontext-error - -A value for a @emph{gcontext} argument does not name a defined GContext. - -A @var{gcontext-error} is a special case of the more general -@var{resource-error} (@pxref{resource-error}). -@end deftp - - -@deftp {Condition} id-choice-error - -The value chosen for a resource identifier is either not included in -the range assigned to the client or is already in use. Under normal -circumstances, this cannot occur and should be considered a server -or CLX library error. - -An @var{id-choice-error} is a special case of the more general -@var{resource-error} (@pxref{resource-error}). -@end deftp - - -@deftp {Condition} implementation-error - -The server does not implement some aspect of the request. A server -that generates this error for a core request is deficient. As such, -this error is not listed for any of the requests. However, clients -should be prepared to receive such errors and either handle or -discard them. - -An @var{implementation-error} is a special case of the more general -@var{resource-error} (@pxref{resource-error}). -@end deftp - - -@deftp {Condition} length-error - -The length of a request is shorter or longer than that minimally -required to contain the arguments. This usually means an internal -CLX error. - -A @var{length-error} is a special case of the more general -@var{resource-error} (@pxref{resource-error}). -@end deftp - - -@deftp {Condition} lookup-error - -CLX has the option of caching different resource types (see -@var{*clx-cached-types*}) in a hash table by resource ID. When -looking up an object in the hash table, if the type of the object is -wrong, a @var{lookup-error} is signaled. - -For example: The cursor with ID 123 is interned in the hash -table. An event is received with a field for window 123. When 123 is -looked up in the hash table, a cursor is found. Since a window was -expected, a @var{lookup-error} is signaled. This error indicates a -problem with the extension code being used. The following items are -reported along with the error: -@itemize @bullet - -@item @emph{id} -- The resource ID. - -@item @emph{display} -- The display being used. - -@item @emph{type} -- The resource type. - -@item @emph{object} -- The @var{resource} object. -@end itemize - -A @var{lookup-error} is a special case of the more general -@var{x-error} (@pxref{x-error}). -@end deftp - - -@deftp {Condition} match-error - -In a graphics request, the root and depth of the GContext does not -match that of the drawable. An @var{:input-only} window is used as -a drawable. Some argument or pair of arguments has the correct type -and range but fails to match in some other way required by the -request. An @var{:input-only} window locks this attribute. The -values do not exist for an @var{:input-only} window. - -A @var{match-error} is a special case of the more general -@var{request-error} (@pxref{request-error}). -@end deftp - - -@deftp {Condition} missing-parameter - -One or more of the required keyword parameters is missing or -@var{nil}. The missing parameters are reported along with the -error. - -A @var{missing-parameter} condition is a special case of the more -general @var{x-error} (@pxref{x-error}). -@end deftp - - -@deftp {Condition} name-error - -A font or color of the specified name does not exist. - -A @var{name-error} is a special case of the more general -@var{request-error} (@pxref{request-error}). -@end deftp - - -@deftp {Condition} pixmap-error - -A value for a @emph{pixmap} argument does not name a defined pixmap. - -A @var{pixmap-error} is a special case of the more general -@var{resource-error}. (@pxref{resource-error}.) -@end deftp - - -@deftp {Condition} reply-length-error (x-error) (slots*) - -The reply to a request has an unexpected length. The following items -are reported along with the error: -@itemize @bullet - -@item @emph{reply-length} -- The actual reply length. - -@item @emph{expected-length} -- The expected reply length. - -@item @emph{display} -- The display on which the error occurred. -@end itemize - -A @var{reply-length-error} is a special case of the more general -@var{x-error} (@pxref{x-error}). -@end deftp - - -@deftp {Condition} reply-timeout - -The @var{*reply-timeout*} parameter specifies the maximum number of -seconds to wait for a request reply, or @var{nil} to wait forever -(the default). When a reply has not been received after -*@var{reply-timeout}* seconds, the @var{reply-timeout} condition -is signaled. The @emph{timeout} @emph{period} and @emph{display} are -reported along with the error. - -A @var{reply-timeout} condition is a special case of the more -general @var{x-error} (@pxref{x-error}). -@end deftp - - -@deftp {Condition} request-error -@anchor{request-error} - -The following items are reported along with the error: - -The major or minor opcode does not specify a valid request. -@itemize @bullet - -@item @emph{display} -- The display on which the error occurred. - -@item @emph{error-key} -- The error (sub)type. - -@item @emph{major} -- The major opcode. - -@item @emph{minor} -- The minor opcode. - -@item @emph{sequence} -- The actual sequence number. - -@item @emph{current-sequence} -- The current sequence number. -@end itemize - -A @var{request-error} condition is a special case of the more -general @var{x-error} (@pxref{x-error}). -@end deftp - -@deftp {Condition} resource-error -@anchor{resource-error} - -All X11 errors for incorrect resource IDs are built on top of -@var{resource-error}. These are @var{colormap-error}, -@var{cursor-error}, @var{drawable-error}, @var{font-error}, -@var{gcontext-error}, @var{id-choice-error}, @var{pixmap-error} -and @var{window-error}. @var{resource-error} is never signaled -directly. - -A @var{resource-error} is a special case of the more general -@var{request-error} (@pxref{request-error}). -@end deftp - - -@deftp {Condition} sequence-error - -All X11 request replies contain the sequence number of their -request. If a reply's sequence does not match the request count, a -@var{sequence-error} is signaled. A @var{sequence-error} usually -indicates a locking problem with a multi-processing Lisp. The -following items are reported along with the error: -@itemize @bullet - -@item @emph{display} -- The display on which the error occurred. - -@item @emph{req-sequence} -- The sequence number in the reply. - -@item @emph{msg-sequence} -- The current sequence number. -@end itemize - -A @var{sequence-error} condition is a special case of the more -general @var{x-error}. (@pxref{x-error}) -@end deftp - - -@deftp {Condition} server-disconnect - -The connection to the server was lost. The display on which the -error occurred is reported along with the error. - -A @var{server-disconnect} condition is a special case of the more -general @var{x-error}. (@pxref{x-error}) -@end deftp - - -@deftp {Condition} unexpected-reply - -A reply was found when none was expected. This indicates a problem -with the extension code. The following items are reported along with -the error: - -@table @code -@item display -The display on which the error occurred. - -@item req-sequence -The sequence number in the reply. - -@item msg-sequence -The current sequence number. - -@item length -The message length of the reply. -@end table - - -An @var{unexpected-reply} condition is a special case of the more general -@var{x-error}. (@pxref{x-error}.) -@end deftp - - -@deftp {Condition} unknown-error (request-error) (error-code) - -An error was received from the server with an unknown error -code. This indicates a problem with the extension code. The -undefined error code is reported. - -An @var{unknown-error} is a special case of the more general -@var{request-error}. (@pxref{request-error}) -@end deftp - - -@deftp {Condition} value-error (request-error) (value) - -Some numeric value falls outside the range of values accepted by the -request. Unless a specific range is specified for an argument, the -full range defined by the argument's type is accepted. Any argument -defined as a set of alternatives can generate this error. The -erroneous value is reported. - -A @var{value-error} is a special case of the more general -@var{request-error}. (@pxref{request-error}) -@end deftp - - -@deftp {Condition} window-error (resource-error) - - -A value for a @emph{window} argument does not name a defined window. - -A @var{window-error} is a special case of the more general -@var{resource-error}. (@pxref{resource-error}.) -@end deftp - - -@deftp {Condition} x-error -@anchor{x-error} - -This is the most general error condition upon which all other conditions are defined. -@end deftp - - - -@ignore -@var{PROTOCOL VS. CLX FUNCTIONAL} - -@var{CROSS-REFERENCE LISTING} - -@var{X11 Request Name CLX Function Name} - -AllocColor @var{alloc-color} -AllocColorCells @var{alloc-color-cells} -AllocColorPlanes@var{alloc-color-planes} -AllocNamedColor @var{alloc-color} -AllowEvents @var{allow-events} -Bell @var{bell} -ChangeAccessControl (@code{setf} (@var{access-control} @emph{display}) -ChangeActivePointerGrab @var{change-active-pointer-grab} -ChangeCloseDownMode (@code{setf} (@var{close-down-mode} @emph{display})) -ChangeGC @var{force-gcontext-changes} -(See @var{with-gcontext}) -(@code{setf} (@var{gcontext-function} @emph{gc})) -(@code{setf} (@var{gcontext-plane-mask} @emph{gc})) -(@code{setf} (@var{gcontext-foreground} @emph{gc})) -(@code{setf} (@var{gcontext-background} @emph{gc})) -(@code{setf} (@var{gcontext-line-width} @emph{gc})) -(@code{setf} (@var{gcontext-line-style} @emph{gc})) -(@code{setf} (@var{gcontext-cap-style} @emph{gc})) -(@code{setf} (@var{gcontext-join-style} @emph{gc})) -(@code{setf} (@var{gcontext-fill-style} @emph{gc})) -(@code{setf} (@var{gcontext-fill-rule} @emph{gc})) -(@code{setf} (@var{gcontext-tile} @emph{gc})) -(@code{setf} (@var{gcontext-stipple} @emph{gc})) -(@code{setf} (@var{gcontext-ts-x} @emph{gc})) -(@code{setf} (@var{gcontext-ts-y} @emph{gc})) -(@code{setf} (@var{gcontext-font} @emph{gc} &optional -@var{metrics-p})) -(@code{setf} (@var{gcontext-subwindow-mode} @emph{gc})) -(@code{setf} (@var{gcontext-exposures} @emph{gc}))) -(@code{setf} (@var{gcontext-clip-x} @emph{gc})) -(@code{setf} (@var{gcontext-clip-y} @emph{gc})) -(@code{setf} (@var{gcontext-clip-mask} @emph{gc} -&optional @var{ordering})) -(@code{setf} (@var{gcontext-dash-offset} @emph{gc})) -(@code{setf} (@var{gcontext-dashes} @emph{gc})) -(@code{setf} (@var{gcontext-arc-mode} @emph{gc})) -(@code{setf} (@var{gcontext-clip-ordering} @emph{gc})) - -@var{X11 Request Name CLX Function Name} - -ChangeHosts @var{add-access-host} -ChangeHosts @var{remove-access-host} -ChangeKeyboardControl @var{change-keyboard-control} -ChangePointerControl @var{change-pointer-control} -ChangeProperty @var{change-property} -ChangeSaveSet @var{remove-from-save-set} -ChangeSaveSet @var{add-to-save-set} -ChangeWindowAttributes (See @var{with-state}) -(@code{setf} (@var{window-background} @emph{window})) -(@code{setf} (@var{window-border} @emph{window})) -(@code{setf} (@var{window-bit-gravity} @emph{window})) -(@code{setf} (@var{window-gravity} @emph{window})) -(@code{setf} (@var{window-backing-store} @emph{window})) -(@code{setf} (@var{window-backing-planes} @emph{window})) -(@code{setf} (@var{window-backing-pixel} @emph{window})) -(@code{setf} (@var{window-override-redirect} @emph{window}) -@code{(setf (window-save-under} @emph{window}@var{))} -(@code{setf} (@var{window-colormap} @emph{window})) -(@code{setf} (@var{window-cursor} @emph{window})) -(@code{setf} (@var{window-event-mask} @emph{window})) -(@code{setf} (@var{window-do-not-propagate-mask} -@emph{window})) -CirculateWindow @var{circulate-window-down} -CirculateWindow @var{circulate-window-up} -ClearToBackground @var{clear-area} -CloseFont @var{close-font} -ConfigureWindow (See @var{with-state}) -(@code{setf} (@var{drawable-x} @emph{drawable})) -(@code{setf} (@var{drawable-y} @emph{drawabl}e)) -(@code{setf} (@var{drawable-width} @emph{drawable})) -(@code{setf} (@var{drawable-height} @emph{drawable})) -(@code{setf} (@var{drawable-depth} @emph{drawable})) -(@code{setf} (@var{drawable-border-width} @emph{drawable})) -(@code{setf} (@var{window-priority} @emph{window} &optional -@var{sibling})) -ConvertSelection@var{convert-selection} -CopyArea @var{copy-area} -CopyColormapAndFree @var{copy-colormap-and-free} -CopyGC@var{copy-gcontext} -CopyGC@var{copy-gcontext-components} -CopyPlane @var{copy-plane} -CreateColormap @var{create-colormap} -CreateCursor @var{create-cursor} -CreateGC @var{create-gcontext} -CreateGlyphCursor @var{create-glyph-cursor} -CreatePixmap @var{create-pixmap} -CreateWindow @var{create-window} -DeleteProperty @var{delete-property} -DestroySubwindows @var{destroy-subwindows} -DestroyWindow @var{destroy-window} -FillPoly @var{draw-lines} -ForceScreenSaver@var{reset-screen-saver} -ForceScreenSaver@var{activate-screen-saver} -FreeColormap @var{free-colormap} -FreeColors @var{free-colors} -FreeCursor @var{free-cursor} - -@var{X11 Request Name CLX Function Name} - -FreeGC@var{free-gcontext} -FreePixmap @var{free-pixmap} -GetAtomName @var{atom-name} -GetFontPath @var{font-path} -GetGeometry (See @var{with-state}) -@var{drawable-root} -@var{drawable-x} -@var{drawable-y} -@var{drawable-width} -@var{drawable-height} -@var{drawable-depth} -@var{drawable-border-width} -GetImage @var{get-raw-image} -GetInputFocus @var{input-focus} -GetKeyboardControl @var{keyboard-control} -GetKeyboardMapping @var{keyboard-mapping} -GetModifierMapping @var{modifier-mapping} -GetMotionEvents @var{motion-events} -GetPointerControl @var{pointer-control} -GetPointerMapping @var{pointer-mapping} -GetProperty @var{get-property} -GetScreenSaver @var{screen-saver} -GetSelectionOwner @var{selection-owner} -GetWindowAttributes (See @var{with-state}) -@var{window-visual} -@var{window-class} -@var{window-bit-gravity} -@var{window-gravity} -@var{window-backing-store} -@var{window-backing-planes} -@var{window-backing-pixel} -@var{window-save-under} -@var{window-override-redirect} -@var{window-event-mask} -@var{window-do-not-propagate-mask} -@var{window-colormap} -@var{window-colormap-installed-p} -@var{window-all-event-masks} -@var{window-map-state} -GrabButton @var{grab-button} -GrabKey @var{grab-key} -GrabKeyboard @var{grab-keyboard} -GrabPointer @var{grab-pointer} -GrabServer @var{grab-server} -ImageText16 @var{draw-image-glyphs} -ImageText16 @var{draw-image-glyph} -ImageText8 @var{draw-image-glyphs} -InstallColormap @var{install-colormap} -InternAtom @var{find-atom} -InternAtom @var{intern-atom} -KillClient @var{kill-temporary-clients} -KillClient @var{kill-client} -ListExtensions @var{list-extensions} -ListFonts @var{list-font-names} -ListFontsWithInfo @var{list-fonts} -ListHosts @var{access-control} - -@var{X11 Request Name CLX Function Name} - -ListHosts @var{access-hosts} -ListInstalledColormaps @var{installed-colormaps} -ListProperties @var{list-properties} -LookupColor @var{lookup-color} -MapSubwindows @var{map-subwindows} -MapWindow @var{map-window} -OpenFont @var{open-font} -PolyArc @var{draw-arc} -PolyArc @var{draw-arcs} -PolyFillArc @var{draw-arc} -PolyFillArc @var{draw-arcs} -PolyFillRectangle @var{draw-rectangle} -PolyFillRectangle @var{draw-rectangles} -PolyLine @var{draw-line} -PolyLine @var{draw-lines} -PolyPoint @var{draw-point} -PolyPoint @var{draw-points} -PolyRectangle @var{draw-rectangle} -PolyRectangle @var{draw-rectangles} -PolySegment @var{draw-segments} -PolyText16 @var{draw-glyph} -PolyText16 @var{draw-glyphs} -PolyText8 @var{draw-glyphs} -PutImage @var{put-raw-image} -QueryBestSize @var{query-best-cursor} -QueryBestSize @var{query-best-stipple} -QueryBestSize @var{query-best-tile} -QueryColors @var{query-colors} -QueryExtension @var{query-extension} -QueryFont @var{font-name} -@var{font-name} -@var{font-direction} -@var{font-min-char} -@var{font-max-char} -@var{font-min-byte1} -@var{font-max-byte1} -@var{font-min-byte2} -@var{font-max-byte2} -@var{font-all-chars-exist-p} -@var{font-default-char} -@var{font-ascent} -@var{font-descent} -@var{font-properties} -@var{font-property} -@var{char-left-bearing} -@var{char-right-bearing} -@var{char-width} -@var{char-ascent} -@var{char-descent} -@var{char-attributes} -@var{min-char-left-bearing} -@var{min-char-right-bearing} -@var{min-char-width} -@var{min-char-ascent} -@var{min-char-descent} -@var{min-char-attributes} - -@var{X11 Request Name CLX Function Name} - -@var{max-char-left-bearing} -@var{max-char-right-bearing} -@var{max-char-width} -@var{max-char-ascent} -@var{max-char-descent} -@var{max-char-attributes} -QueryKeymap @var{query-keymap} -QueryPointer @var{global-pointer-position} -QueryPointer @var{pointer-position} -QueryPointer @var{query-pointer} -QueryTextExtents@var{text-extents} -QueryTextExtents@var{text-width} -QueryTree @var{query-tree} -RecolorCursor @var{recolor-cursor} -ReparentWindow @var{reparent-window} -RotateProperties@var{rotate-properties} -SendEvent @var{send-event} -SetClipRectangles @var{force-gcontext-changes} -(See @var{with-gcontext}) -(@code{setf} (@var{gcontext-clip-x} @emph{gc})) -(@code{setf} (@var{gcontext-clip-y} @emph{gc})) -(@code{setf} (@var{gcontext-clip-mask} @emph{gc} &optional -@var{ordering})) -(@code{setf} (@var{gcontext-clip-ordering} @emph{gc})) -SetDashes @var{force-gcontext-changes} -(See @var{with-gcontext}) -(@code{setf} (@var{gcontext-dash-offset} @emph{gc})) -(@code{setf} (@var{gcontext-dashes} @emph{gc})) -SetFontPath (@code{setf} (@var{font-path} @emph{font}) -SetInputFocus @var{set-input-focus} -SetKeyboardMapping @var{change-keyboard-mapping} -SetModifierMapping @var{set-modifier-mapping} -SetPointerMapping @var{set-pointer-mapping} -SetScreenSaver @var{set-screen-saver} -SetSelectionOwner @var{set-selection-owner} -StoreColors @var{store-color} -StoreColors @var{store-colors} -StoreNamedColor @var{store-color} -StoreNamedColor @var{store-colors} -TranslateCoords @var{translate-coordinates} -UngrabButton @var{ungrab-button} -UngrabKey @var{ungrab-key} -UngrabKeyboard @var{ungrab-keyboard} -UngrabPointer @var{ungrab-pointer} -UngrabServer @var{ungrab-server} -UninstallColormap @var{uninstall-colormap} -UnmapSubwindows @var{unmap-subwindows} -UnmapWindow @var{unmap-window} -WarpPointer @var{warp-pointer} -WarpPointer @var{warp-pointer-if-inside} -WarpPointer @var{warp-pointer-relative} -WarpPointer @var{warp-pointer-relative-if-inside} -ListHosts @var{access-control} -ListHosts @var{access-hosts} -ForceScreenSaver@var{activate-screen-saver} -ChangeHosts @var{add-access-host} - -@var{X11 Request Name CLX Function Name} - -ChangeSaveSet @var{add-to-save-set} -AllocColor @var{alloc-color} -AllocNamedColor @var{alloc-color} -AllocColorCells @var{alloc-color-cells} -AllocColorPlanes@var{alloc-color-planes} -AllowEvents @var{allow-events} -GetAtomName @var{atom-name} -Bell @var{bell} -ChangeActivePointerGrab @var{change-active-pointer-grab} -ChangeKeyboardControl @var{change-keyboard-control} -SetKeyboardMapping @var{change-keyboard-mapping} -ChangePointerControl @var{change-pointer-control} -ChangeProperty @var{change-property} -QueryFont @var{char-ascent} -QueryFont @var{char-attributes} -QueryFont @var{char-descent} -QueryFont @var{char-left-bearing} -QueryFont @var{char-right-bearing} -QueryFont @var{char-width} -CirculateWindow @var{circulate-window-down} -CirculateWindow @var{circulate-window-up} -ClearToBackground @var{clear-area} -CloseFont @var{close-font} -ConvertSelection@var{convert-selection} -CopyArea @var{copy-area} -CopyColormapAndFree @var{copy-colormap-and-free} -CopyGC@var{copy-gcontext} -CopyGC@var{copy-gcontext-components} -CopyPlane @var{copy-plane} -CreateColormap @var{create-colormap} -CreateCursor @var{create-cursor} -CreateGC @var{create-gcontext} -CreateGlyphCursor @var{create-glyph-cursor} -CreatePixmap @var{create-pixmap} -CreateWindow @var{create-window} -DeleteProperty @var{delete-property} -DestroySubwindows @var{destroy-subwindows} -DestroyWindow @var{destroy-window} -PolyArc @var{draw-arc} -PolyArc @var{draw-arcs} -PolyText16 @var{draw-glyph} -PolyText16 @var{draw-glyphs} -PolyText8 @var{draw-glyphs} -ImageText16 @var{draw-image-glyph} -ImageText16 @var{draw-image-glyphs} -ImageText8 @var{draw-image-glyphs} -PolyLine @var{draw-line} -PolyLine @var{draw-lines} -PolyPoint @var{draw-point} -PolyPoint @var{draw-points} -PolyFillRectangle @var{draw-rectangle} -PolyRectangle @var{draw-rectangle} -PolyFillRectangle @var{draw-rectangles} -PolyRectangle @var{draw-rectangles} -PolySegment @var{draw-segments} -GetGeometry @var{drawable-border-width} - -@var{X11 Request Name CLX Function Name} - -GetGeometry @var{drawable-depth} -GetGeometry @var{drawable-height} -GetGeometry @var{drawable-root} -GetGeometry @var{drawable-width} -GetGeometry @var{drawable-x} -GetGeometry @var{drawable-y} -FillPoly @var{fill-polygon} -InternAtom @var{find-atom} -QueryFont @var{font-all-chars-exist-p} -QueryFont @var{font-ascent} -QueryFont @var{font-default-char} -QueryFont @var{font-descent} -QueryFont @var{font-direction} -QueryFont @var{font-max-byte1} -QueryFont @var{font-max-byte2} -QueryFont @var{font-max-char} -QueryFont @var{font-min-byte1} -QueryFont @var{font-min-byte2} -QueryFont @var{font-min-char} -QueryFont @var{font-name} -QueryFont @var{font-name} -GetFontPath @var{font-path} -QueryFont @var{font-properties} -QueryFont @var{font-property} -ChangeGC @var{force-gcontext-changes} -SetClipRectangles @var{force-gcontext-changes} -SetDashes @var{force-gcontext-changes} -FreeColormap @var{free-colormap} -FreeColors @var{free-colors} -FreeCursor @var{free-cursor} -FreeGC@var{free-gcontext} -FreePixmap @var{free-pixmap} -GetProperty @var{get-property} -GetImage @var{get-raw-image} -QueryPointer @var{global-pointer-position} -GrabButton @var{grab-button} -GrabKey @var{grab-key} -GrabKeyboard @var{grab-keyboard} -GrabPointer @var{grab-pointer} -GrabServer @var{grab-server} -GrabServer @var{with-server-grabbed} -GetInputFocus @var{input-focus} -InstallColormap @var{install-colormap} -ListInstalledColormaps @var{installed-colormaps} -InternAtom @var{intern-atom} -GetKeyboardControl @var{keyboard-control} -GetKeyboardMapping @var{keyboard-mapping} -KillClient @var{kill-client} -KillClient @var{kill-temporary-clients} -ListExtensions @var{list-extensions} -ListFonts @var{list-font-names} -ListFontsWithInfo @var{list-fonts} -ListProperties @var{list-properties} -LookupColor @var{lookup-color} -MapSubwindows @var{map-subwindows} -MapWindow @var{map-window} - -@var{X11 Request Name CLX Function Name} - -QueryFont @var{max-char-ascent} -QueryFont @var{max-char-attributes} -QueryFont @var{max-char-descent} -QueryFont @var{max-char-left-bearing} -QueryFont @var{max-char-right-bearing} -QueryFont @var{max-char-width} -QueryFont @var{min-char-ascent} -QueryFont @var{min-char-attributes} -QueryFont @var{min-char-descent} -QueryFont @var{min-char-left-bearing} -QueryFont @var{min-char-right-bearing} -QueryFont @var{min-char-width} -GetModifierMapping @var{modifier-mapping} -GetMotionEvents @var{motion-events} -OpenFont @var{open-font} -GetPointerControl @var{pointer-control} -GetPointerMapping @var{pointer-mapping} -QueryPointer @var{pointer-position} -PutImage @var{put-raw-image} -QueryBestSize @var{query-best-cursor} -QueryBestSize @var{query-best-stipple} -QueryBestSize @var{query-best-tile} -QueryColors @var{query-colors} -QueryExtension @var{query-extension} -QueryKeymap @var{query-keymap} -QueryPointer @var{query-pointer} -QueryTree @var{query-tree} -RecolorCursor @var{recolor-cursor} -ChangeHosts @var{remove-access-host} -ChangeSaveSet @var{remove-from-save-set} -ReparentWindow @var{reparent-window} -ForceScreenSaver@var{reset-screen-saver} -RotateProperties@var{rotate-properties} -GetScreenSaver @var{screen-saver} -GetSelectionOwner @var{selection-owner} -SendEvent @var{send-event} -ChangeAccessControl @var{set-access-control} -ChangeCloseDownMode @var{set-close-down-mode} -SetInputFocus @var{set-input-focus} -SetModifierMapping @var{set-modifier-mapping} -SetPointerMapping @var{set-pointer-mapping} -SetScreenSaver @var{set-screen-saver} -SetSelectionOwner @var{set-selection-owner} -StoreColors @var{store-color} -StoreColors @var{store-colors} -StoreNamedColor @var{store-color} -StoreNamedColor @var{store-colors} -QueryTextExtents@var{text-extents} -QueryTextExtents@var{text-width} -TranslateCoords @var{translate-coordinates} -UngrabButton @var{ungrab-button} -UngrabKey @var{ungrab-key} -UngrabKeyboard @var{ungrab-keyboard} -UngrabPointer @var{ungrab-pointer} -UngrabServer @var{ungrab-server} -UngrabServer @var{with-server-grabbed} - -@var{X11 Request Name CLX Function Name} - -UninstallColormap @var{uninstall-colormap} -UnmapSubwindows @var{unmap-subwindows} -UnmapWindow @var{unmap-window} -WarpPointer @var{warp-pointer} -WarpPointer @var{warp-pointer-if-inside} -WarpPointer @var{warp-pointer-relative} -WarpPointer @var{warp-pointer-relative-if-inside} -GetWindowAttributes @var{window-all-event-masks} -GetWindowAttributes @var{window-backing-pixel} -GetWindowAttributes @var{window-backing-planes} -GetWindowAttributes @var{window-backing-store} -GetWindowAttributes @var{window-bit-gravity} -GetWindowAttributes @var{window-class} -GetWindowAttributes @var{window-colormap} -GetWindowAttributes @var{window-colormap-installed-p} -GetWindowAttributes @var{window-do-not-propagate-mask} -GetWindowAttributes @var{window-event-mask} -GetWindowAttributes @var{window-gravity} -GetWindowAttributes @var{window-map-state} -GetWindowAttributes @var{window-override-redirect} -GetWindowAttributes @var{window-save-under} -GetWindowAttributes @var{window-visual} -ConfigureWindow (@code{setf} (@var{drawable-border-width} @emph{drawable})) -ConfigureWindow (@code{setf} (@var{drawable-depth} @emph{drawable})) -ConfigureWindow (@code{setf} (@var{drawable-height} @emph{drawable})) -ConfigureWindow (@code{setf} (@var{drawable-width} @emph{drawabl}e)) -ConfigureWindow (@code{setf} (@var{drawable-x} @emph{drawable})) -ConfigureWindow (@code{setf} (@var{drawable-y} @emph{drawable})) -SetFontPath (@code{setf} (@var{font-path} @emph{font}) @var{paths}) -ChangeGC (@code{setf} (@var{gcontext-arc-mode} @emph{gc})) -ChangeGC (@code{setf} (@var{gcontext-background} @emph{gc})) -ChangeGC (@code{setf} (@var{gcontext-cap-style} @emph{gc})) -SetClipRectangles (@code{setf} (@var{gcontext-clip-mask} @emph{gc} &optional -@var{ordering})) -SetClipRectangles (@code{setf} (@var{gcontext-clip-ordering} @emph{gc})) -SetClipRectangles (@code{setf} (@var{gcontext-clip-x} @emph{gc})) -SetClipRectangles (@code{setf} (@var{gcontext-clip-y} @emph{gc})) -SetDashes (@code{setf} (@var{gcontext-dash-offset} @emph{gc})) -SetDashes (@code{setf} (@var{gcontext-dashes} @emph{gc})) -ChangeGC (@code{setf} (@var{gcontext-exposures} @emph{gc})) -ChangeGC (@code{setf} (@var{gcontext-fill-rule} @emph{gc}) @var{keyword}) -ChangeGC (@code{setf} (@var{gcontext-fill-style} @emph{gc}) @var{keyword}) -ChangeGC (@code{setf} (@var{gcontext-font} @emph{gc} &optional -@var{metrics-p}) -ChangeGC (@code{setf} (@var{gcontext-foreground} @emph{gc}) @var{card32}) -ChangeGC (@code{setf} (@var{gcontext-function} @emph{gc})) -ChangeGC (@code{setf} (@var{gcontext-join-style} @emph{gc}) @var{keyword}) -ChangeGC (@code{setf} (@var{gcontext-line-style} @emph{gc}) @var{keyword}) -ChangeGC (@code{setf} (@var{gcontext-line-width} @emph{gc}) @var{card16}) -ChangeGC (@code{setf} (@var{gcontext-plane-mask} @emph{gc}) @var{card32}) -ChangeGC (@code{setf} (@var{gcontext-stipple} @emph{gc}) @var{pixmap}) -ChangeGC (@code{setf} (@var{gcontext-subwindow-mode} @emph{gc})) -ChangeGC (@code{setf} (@var{gcontext-tile} @emph{gc})) -ChangeGC (@code{setf} (@var{gcontext-ts-x} @emph{gc})) -ChangeGC (@code{setf} (@var{gcontext-ts-y} @emph{gc})) -ChangeWindowAttributes (@code{setf} (@var{window-background} @emph{window})) - -@var{X11 Request Name CLX Function Name} - -ChangeWindowAttributes (@code{setf} (@var{window-backing-pixel} @emph{window})) -ChangeWindowAttributes (@code{setf} (@var{window-backing-planes} @emph{window})) -ChangeWindowAttributes (@code{setf} (@var{window-backing-store} @emph{window})) -ChangeWindowAttributes (@code{setf} (@var{window-bit-gravity} @emph{window})) -ChangeWindowAttributes (@code{setf} (@var{window-border} @emph{window})) -ChangeWindowAttributes (@code{setf} (@var{window-colormap} @emph{window})) -ChangeWindowAttributes (@code{setf} (@var{window-cursor} @emph{window})) -ChangeWindowAttributes (@code{setf} (@var{window-do-not-propagate-mask} -@emph{window})) -ChangeWindowAttributes (@code{setf} (@var{window-event-mask} @emph{window})) -ChangeWindowAttributes (@code{setf} (@var{window-gravity} @emph{window})) -ChangeWindowAttributes (@code{setf} (@var{window-override-redirect} @emph{window})) -ConfigureWindow (@code{setf} (@var{window-priority} @emph{window} &optional -@var{sibling})) -ChangeWindowAttributes (@code{setf} (@var{window-save-under} @emph{window})) -@end ignore - -@node Undocumented, Glossary, Errors, Top -@chapter Undocumented - -This section just lists all symbols exported from the -@var{XLIB} package but not documented in this manual. - -@defun bitmap-image &optional plist &rest patterns -@end defun - - -@defun character->keysyms character &optional display -@end defun - - -@defun character-in-map-p display character keymap - -@table @var -@item display -A @var{display}. -@end table - -@end defun - -@defun decode-core-error display event &optional arg -@end defun - -@defun default-error-handler display error-key &rest key-vals &key asynchronous &allow-other-keys -@end defun - -@defun default-keysym-index display keycode state -@end defun - -@defun default-keysym-translate display state object -@end defun - -@defun define-keysym object keysym &key lowercase translate modifiers mask display -@end defun - -@defun define-keysym-set set first-keysym last-keysym -@end defun - -@defun display-invoke-after-function display - - -Explicitly invokes the @emph{after-function} of the display. -(see @var{display-after-function}). This function is -internally called after every request. -@end defun - -@defun display-nscreens display -@end defun - -@defun display-release-number object -@end defun - -@defun event-handler handlers event-key -@end defun - -@defun get-external-event-code display event -@end defun - -@defun get-standard-colormap window property -@end defun - -@defun get-wm-class window -@end defun - -@defun icon-sizes window -@end defun - -@defun iconify-window window screen -@end defun - -@defun keysym->keycodes display keysym -@end defun - -@defun keysym-in-map-p display keysym keymap -@end defun - -@defun keysym-set keysym -@end defun - -@defun mapping-notify display request start count - -Called on a @var{:mapping-notify} event to update -the keyboard-mapping cache in @emph{display}. -@end defun - -@defun no-operation display -@end defun - -@defun parse-color colormap spec -@end defun - -@defun resource-database-timestamp database -@end defun - -@defun resource-key stringable -@end defun - -@defun rgb-colormaps window property -@end defun - -@defun root-resources screen &key database key test test-not - -Returns a resource database containing the contents of the -root window @var{RESOURCE_MANAGER} property for the given -@emph{screen}. If @emph{screen} is a display, then its -default screen is used. If an existing @emph{database} is -given, then resource values are merged with the -@emph{database} and the modified @emph{database} is -returned. - -@emph{test} and @emph{test-not} are predicates for selecting -which resources are read. Arguments are a resource name list -and a resource value. The @emph{key} function, if given, is -called to convert a resource value string to the value given -to @emph{test} or @emph{test-not}. -@end defun - -@defun rotate-cut-buffers display &optional (delta 1) (careful-p t) -@end defun - -@defun set-access-control display enabled-p -@end defun - -@defun set-close-down-mode display mode -@anchor{set-close-down-mode} -@end defun - -@defun set-pointer-mapping display map -@end defun - -@defun set-selection-owner display selection owner &optional time -@end defun - -@defun set-standard-colormap window property colormap base-pixel max-color mult-color -@end defun - -@defun set-standard-properties window &rest options -@end defun - -@defun set-wm-class window resource-name resource-class -@end defun - -@defun set-wm-properties window &rest options &key name icon-name resource-name resource-class command client-machine hints normal-hints zoom-hints (user-specified-position-p nil usppp) (user-specified-size-p nil usspp) (program-specified-position-p nil psppp) (program-specified-size-p nil psspp) x y width height min-width min-height max-width max-height width-inc height-inc min-aspect max-aspect base-width base-height win-gravity input initial-state icon-pixmap icon-window icon-x icon-y icon-mask window-group -@end defun - -@defun set-wm-resources database window &key write test test-not -@end defun - -@defun transient-for window -@end defun - -@defun translate-default src src-start src-end font dst dst-start -@end defun - -@defun undefine-keysym object keysym &key display modifiers &allow-other-keys -@end defun - -@defun visual-info-blue-mask object -@end defun - -@defun visual-info-green-mask object -@end defun - -@defun visual-info-red-mask object -@end defun - -@defun window-cursor window -@end defun - -@defun window-visual-info window -@end defun - -@defun withdraw-window window screen -@end defun - -@defun wm-client-machine window -@end defun - -@defun wm-colormap-windows window -@end defun - -@defun wm-command window -@end defun - -@defun wm-hints window -@end defun - -@defun wm-hints-flags object -@end defun - -@defun wm-icon-name window -@end defun - -@defun wm-name window -@end defun - -@defun wm-normal-hints window -@end defun - -@defun wm-protocols window -@end defun - -@defun wm-resources database window &key key test test-not -@end defun - -@defun wm-zoom-hints window -@end defun - -@ignore -XLIB:STATE-KEYSYM-P is undocumented. -XLIB:*VERSION* is undocumented. -XLIB:BITMAP-FORMAT-LSB-FIRST-P ??? [Function] -XLIB:BITMAP-FORMAT-P ??? [Function] -XLIB:BITMAP-FORMAT-PAD ???[Function] -XLIB:BITMAP-FORMAT-UNIT ??? [Function] -XLIB:CARD8->CHAR (card8) [Function] -XLIB:CHAR->CARD8 (char) [Function] -XLIB:COLORMAP-VISUAL-INFO ??? [Function] -XLIB:CUT-BUFFER (display &key (buffer 0) (type :string) (result-type 'string) -(transform #'card8->char) (start 0) end) [Function] -XLIB:DEFINE-ERROR ??? [Function] -XLIB:DEFINE-EXTENSION ??? [Function] -XLIB:DEFINE-GCONTEXT-ACCESSOR ??? [Function] -XLIB:DISPLAY-DEFAULT-SCREEN ??? [Function] -XLIB:DISPLAY-HOST ??? [Function] -XLIB:DISPLAY-REPORT-ASYNCHRONOUS-ERRORS ??? [Function] -XLIB:DISPLAY-XDEFAULTS ???[Function] -XLIB:EXTENSION-OPCODE ??? [Function] -XLIB:GCONTEXT-CLIP-ORDERING is undocumented. -XLIB:GENERALIZED-BOOLEAN is undocumented. -XLIB:ILLEGAL-REQUEST-ERROR is undocumented. -XLIB:IMAGE is undocumented. -XLIB:IMAGE-PIXMAP (drawable image &key gcontext width height depth) [Function] -XLIB:IMAGE-X is undocumented. -XLIB:IMAGE-X-P ??? [Function] -XLIB:IMAGE-XY is undocumented. -XLIB:IMAGE-XY-P ??? [Function] -XLIB:IMAGE-Z is undocumented. -XLIB:IMAGE-Z-P ??? [Function] -XLIB:INVALID-FONT is undocumented. -XLIB:KEYCODE->CHARACTER (display keycode state &key keysym-index -(keysym-index-function #'default-keysym-index)) [Function] -XLIB:MAKE-EVENT-HANDLERS (&key (type 'array) default) [Function] -XLIB:MAKE-WM-HINTS (&key ((:input #:g0) nil) ((:initial-state #:g1) nil) ((:icon-pixmap #:g2) nil) -((:icon-window #:g3) nil) ((:icon-x #:g4) nil) ((:icon-y #:g5) nil) -((:icon-mask #:g6) nil) ((:window-group #:g7) nil) ((:flags #:g8) 0)) [Function] -XLIB:MAKE-WM-SIZE-HINTS (&key ((:user-specified-position-p #:g0) nil) -((:user-specified-size-p #:g1) nil) ((:x #:g2) nil) ((:y #:g3) nil) -((:width #:g4) nil) ((:height #:g5) nil) ((:min-width #:g6) nil) -((:min-height #:g7) nil) ((:max-width #:g8) nil) ((:max-height #:g9) nil) -((:width-inc #:g10) nil) ((:height-inc #:g11) nil) ((:min-aspect #:g12) nil) -((:max-aspect #:g13) nil) ((:base-width #:g14) nil) ((:base-height #:g15) nil) -((:win-gravity #:g16) nil) ((:program-specified-position-p #:g17) nil) -((:program-specified-size-p #:g18) nil)) [Function] -XLIB:PIXMAP-FORMAT-BITS-PER-PIXEL ??? [Function] -XLIB:PIXMAP-FORMAT-DEPTH ??? [Function] -XLIB:PIXMAP-FORMAT-P ??? [Function] -XLIB:PIXMAP-FORMAT-SCANLINE-PAD ??? [Function] -XLIB:RESOURCE-DATABASE is undocumented. -XLIB:SCREEN-ROOT-VISUAL-INFO ??? [Function] -XLIB:TRANSLATION-FUNCTION is undocumented. -XLIB:VISUAL-INFO-BITS-PER-RGB ??? [Function] -XLIB:VISUAL-INFO-CLASS ???[Function] -XLIB:VISUAL-INFO-COLORMAP-ENTRIES ??? [Function] -XLIB:VISUAL-INFO-DISPLAY ??? [Function] -XLIB:VISUAL-INFO-ID ??? [Function] -XLIB:VISUAL-INFO-P ??? [Function] -XLIB:VISUAL-INFO-PLIST ???[Function] -XLIB:WINDOW-BACKGROUND is undocumented. -XLIB:WINDOW-BORDER is undocumented. -XLIB:WINDOW-PRIORITY is undocumented. -XLIB:WM-HINTS-ICON-MASK ??? [Function] -XLIB:WM-HINTS-ICON-PIXMAP ??? [Function] -XLIB:WM-HINTS-ICON-WINDOW ??? [Function] -XLIB:WM-HINTS-ICON-X ??? [Function] -XLIB:WM-HINTS-ICON-Y ??? [Function] -XLIB:WM-HINTS-INITIAL-STATE ??? [Function] -XLIB:WM-HINTS-INPUT ??? [Function] -XLIB:WM-HINTS-P ??? [Function] -XLIB:WM-HINTS-WINDOW-GROUP ??? [Function] -XLIB:WM-SIZE-HINTS is undocumented. -XLIB:WM-SIZE-HINTS-BASE-HEIGHT ??? [Function] -XLIB:WM-SIZE-HINTS-BASE-WIDTH ??? [Function] -XLIB:WM-SIZE-HINTS-HEIGHT ??? [Function] -XLIB:WM-SIZE-HINTS-HEIGHT-INC ??? [Function] -XLIB:WM-SIZE-HINTS-MAX-ASPECT ??? [Function] -XLIB:WM-SIZE-HINTS-MAX-HEIGHT ??? [Function] -XLIB:WM-SIZE-HINTS-MAX-WIDTH ??? [Function] -XLIB:WM-SIZE-HINTS-MIN-ASPECT ??? [Function] -XLIB:WM-SIZE-HINTS-MIN-HEIGHT ??? [Function] -XLIB:WM-SIZE-HINTS-MIN-WIDTH ??? [Function] -XLIB:WM-SIZE-HINTS-P ??? [Function] -XLIB:WM-SIZE-HINTS-USER-SPECIFIED-POSITION-P ??? [Function] -XLIB:WM-SIZE-HINTS-USER-SPECIFIED-SIZE-P ??? [Function] -XLIB:WM-SIZE-HINTS-WIDTH ??? [Function] -XLIB:WM-SIZE-HINTS-WIDTH-INC ??? [Function] -XLIB:WM-SIZE-HINTS-WIN-GRAVITY ??? [Function] -XLIB:WM-SIZE-HINTS-X ??? [Function] -XLIB:WM-SIZE-HINTS-Y ??? [Function] -@end ignore - -@node Glossary, Function Index, Undocumented, Top -@appendix Glossary - -@table @asis -@item access control list -X maintains a list of hosts from which client programs can be run. By -default, only programs on the local host can use the display, plus any -hosts specified in an initial list read by the server. This @emph{access -control list} can be changed by clients on the local host. Some -server implementations can also implement other authorization -mechanisms in addition to or in place of this mechanism. The action of -this mechanism can be conditional based on the authorization protocol -name and data received by the server at connection setup. - -@item action -A function that is designed to handle an input event. CLUE input -processing consists of matching an event with an event specification -found in a contact's @var{event-translations} slot and then calling -actions associated with the matching event specification. - -@item active grab -A grab is @emph{active} when the pointer or keyboard is actually owned -by the single grabbing client. - -@item ancestors -If W is an inferior of A, then A is an @emph{ancestor} of W. - -@item atom -A unique ID corresponding to a string name. Atoms are used to identify -properties, types, and selections. - -@item backing store -When a server maintains the contents of a window, the off-screen saved -pixels are known as a @emph{backing store}. - -@item before action -An action of a @var{contact-display} that is called when an event is -dispatched to a contact, but before any other contact input processing -is performed. - -@item bit gravity -When a window is resized, the contents of the window are not -necessarily discarded. It is possible to request the server to -relocate the previous contents to some region of the window. This -attraction of window contents for some location of a window is known -as @emph{bit} @emph{gravity}. - -@item bitmap -A pixmap of depth one. - -@item button grabbing -Buttons on the pointer can be passively @emph{grabbed} by a -client. When the button is pressed, the pointer is then actively -grabbed by the client. - -@item byte order -For image (pixmap/bitmap) data, byte order is defined by the server, -and clients with different native byte ordering must swap bytes as -necessary. For all other parts of the protocol, the byte order is -defined by the client, and the server swaps bytes as necessary. - -@item callback -A function that represents a connection between a contact and the rest -of an application program. A contact calls a callback function in -order to report the results of the user interface component that it -represents. - -@item children -First-level subwindows of a window. - -@item class event -Event translations that belong to all instances of a contact class. A -class event @var{translations} translation is created by the -@var{defevent} macro. - -@item class resources -Resources defined for each instance of a contact class. Also see -constraint resources. - -@item click -A @var{:button-press} event followed immediately by a -@var{:button-release} event for the same button, with no intervening -change in pointer position or modifier key state. - -@item client -An application program connects to the window system server by some -interprocess communication (IPC) path, such as a TCP connection or a -shared memory buffer. This program is referred to as a @emph{client} -of the window system server. More precisely, the client is the IPC -path itself. A program with multiple paths open to the server is -viewed as multiple clients by the protocol. Resource lifetimes are -controlled by connection lifetimes, not by program lifetimes. - -@item clipping regions -In a graphics context, a bitmap or list of rectangles can be specified -to restrict output to a particular region of the window. The image -defined by the bitmap or rectangles is called a @emph{clipping -region}. - -@item colormap -A set of entries defining color values. The colormap associated with a -window is used to display the contents of the window. Each pixel value -indexes the colormap to produce RGB values that drive the guns of a -monitor. Depending on hardware limitations, one or more colormaps can -be installed at one time, such that windows associated with those maps -display with correct colors. - -@item composite -A subclass of @var{contact} representing contacts that are the -parents of other contacts. A composite provides geometry management -and input focus management services for the contacts that are its -children. - -@item complete resource class -A list of symbols containing the class of the contact, the class of -the contact's @var{parent} (and so on), and the class of the -@var{contact-display} to which the contact belongs. The complete -resource class is one of the two items used as a key by a CLUE -application in order to access a contact resource value in a resource -database. - -@item complete resource name -A list of symbols containing the @var{name} of the contact, the -@var{name} of the contact's @var{parent} (and so on), and the name -of the @var{contact-display} to which the contact belongs. The -complete resource name is one of the two items used as a key by a CLUE -application in order to access a contact resource value in a resource -database. - -@item connection -The IPC path between the server and client program. A client program -typically has one connection to the server over which requests and -events are sent. - -@item constraint resources -Resources defined for each child belonging to a member of a composite -class. Constraint resources are typically used to control the -parent's geometry management policy. Also see class resources. - -@item contact -The basic CLUE object for programming a user interface. - -@item contact-display -The CLUE object type that represents a connection to an X server and -that supports an event loop for application input. - -@item contact initialization -The process of collecting initial values for all contact -attributes. No server resources (windows and so on) are actually -allocated until contact realization. - -@item contact realization -The process of allocating contact resources. This process completes -contact creation. - -@item containment -A window contains the pointer if the window is viewable and the hot -spot of the cursor is within a visible region of the window or a -visible region of one of its inferiors. The border of the window is -included as part of the window for containment. The pointer is in a -window if the window contains the pointer but no inferior contains the -pointer. - -@item content -The single child of a shell. The basic geometry management policy -implemented by the @var{shell} class constrains a shell and its -content to have the same width and height; size changes to one are -automatically applied to the other. - -@item coordinate system -The coordinate system has x horizontal and y vertical, with the origin -[0, 0] at the upper left. Coordinates are discrete and are in terms of -pixels. Each window and pixmap has its own coordinate system. For a -window, the origin is at the inside upper left, inside the border. - -@item cursor -The visible shape of the pointer on a screen. It consists of a -hot-spot, a source bitmap, a shape bitmap, and a pair of colors. The -cursor defined for a window controls the visible appearance when the -pointer is in that window. - -@item depth -The depth of a window or pixmap is number of bits per pixel it -has. The depth of a graphics context is the depth of the drawables it -can be used in conjunction with for graphics output. - -@item descendant -If W is an inferior of A, then W is a @emph{descendant} of A. - -@item device -Keyboards, mice, tablets, track-balls, button boxes, and so forth, are -all collectively known as input @emph{devices}. The core protocol only -deals with two devices: the keyboard and the pointer. - -@item direct color -A class of colormap in which a pixel value is decomposed into three -separate subfields for indexing. One subfield indexes an array to -produce red intensity values, the second subfield indexes a second -array to produce blue intensity values, and the third subfield indexes -a third array to produce green intensity values. The RGB values can be -changed dynamically. - -@item dispatching an event -The process of finding the appropriate contact and its actions. - -@item double-click -A sequence of two clicks of the same button in rapid succession. - -@item drawable -Both windows and pixmaps can be used as sources and destinations in -graphics operations. These are collectively known as -@emph{drawables}. However, an @var{:input-only} window cannot be used -as a source or destination in a graphics operation. - -@item event -Clients receive information asynchronously via @emph{events}. These -events can be either asynchronously generated from devices, or -generated as side effects of client requests. Events are grouped into -types; events are never sent to a client by the server unless the -client has specifically asked to be informed of that type of event, -but clients can force events to be sent to other clients. Events are -typically reported relative to a window. - -@item event compression -Ignoring (or compressing) certain redundant input events. Compression -of redundant events is controlled by the class slots -@var{compress-exposures} and @var{compress-motion}, which are shared -by all instances of a contact class. - -@item event loop -The fundamental application control structure: wait for an event, -figure out how to handle it, process the event, then go back and wait -for the next one. In CLUE, the event loop is implemented using the -@var{process-next-event} function. - -@item event mask -Events are requested relative to a window. The set of event types a -client requests relative to a window are described using an @emph{event -mask}. - -@item event propagation -Device-related events @emph{propagate} from the source window to -ancestor windows until some client has expressed interest in handling -that type of event, or until the event is discarded explicitly. - -@item event specification -A notation for describing a certain sort of event. CLUE input -processing consists of matching an event with an event specification -found in a contact's @var{event-translations} slot and then calling -actions associated with the matching event specification. - -@item event synchronization -Certain race conditions are possible when demultiplexing device events -to clients (in particular deciding where pointer and keyboard events -should be sent when in the middle of window management -operations). The event synchronization mechanism allows synchronous -processing of device events. - -@item event source -The smallest window containing the pointer is the @emph{source} of a -device related event. - -@item event translation -The process of determining which contact action functions will be -executed. An event translation is a list found in a contact's -@var{event-translations} slot associating an event specification with -one or more action names. Also see class event translations. - -@item exposure event -Servers do not guarantee to preserve the contents of windows when -windows are obscured or reconfigured. @emph{Exposure} events are sent -to clients to inform them when contents of regions of windows have -been lost. - -@item extension -Named @emph{extensions} to the core protocol can be defined to extend -the system. Extension to output requests, resources, and event types -are all possible, and expected. - -@item focus window -Another term for the input focus. - -@item font -A matrix of glyphs (typically characters). The protocol does no -translation or interpretation of character sets. The client simply -indicates values used to index the glyph array. A font contains -additional metric information to determine inter-glyph and inter-line -spacing. - -@item geometry management -The process whereby a composite controls the geometrical properties of -its child contacts; the composite is referred to as the geometry -manager. - -@item glyph -An image, typically of a character, in a font. - -@item grab -Keyboard keys, the keyboard, pointer buttons, the pointer, and the -server can be @emph{grabbed} for exclusive use by a client. In -general, these facilities are not intended to be used by normal -applications but are intended for various input and window managers to -implement various styles of user interfaces. - -@item gcontext -Shorthand for graphics context. - -@item graphics context -Various information for graphics output is stored in a @emph{graphics -context} (or gcontext), such as foreground pixel, background pixel, -line width, clipping region, and so forth. A graphics context can only -be used with drawables that have the same root and the same depth as -the graphics context. - -@item gray scale -A degenerate case of pseudo color, in which the red, green, and blue -values in any given colormap entry are equal, thus producing shades of -gray. The gray values can be changed dynamically. - -@item hot spot -A cursor has an associated @emph{hot spot} that defines a point in the -cursor that corresponds to the coordinates reported for the pointer. - -@item identifier -Each resource has an @emph{identifier}, a unique value associated with -it that clients use to name the resource. An identifier can be used -over any connection to name the resource. - -@item inferiors -All of the subwindows nested below a window: the children, the -children's children, and so on. - -@item initialization -See contact initialization. - -@item input event -See event. - -@item input focus -Normally a window defining the scope for processing of keyboard -input. If a generated keyboard event would normally be reported to -this window or one of its inferiors, the event is reported normally; -otherwise, the event is reported with respect to the focus window. The -input focus also can be set such that all keyboard events are -discarded and that the focus window is dynamically taken to be the -root window of whatever screen the pointer is on at each keyboard -event. - -@item input-only window -A window that cannot be used for graphics requests. @emph{input-only} -windows are invisible, and can be used to control such things as -cursors, input event generation, and grabbing. @emph{input-only} -windows cannot have @emph{input/output} windows as inferiors. - -@item input/output window -The normal kind of opaque window, used for both input and -output. Input/output windows can have both @emph{input/output} and -input-only windows as inferiors. - -@item insensitivity -See sensitivity. - -@item interactive-stream -A contact subclass designed to integrate CLUE with the conventional -stream-based I/O of Common Lisp. - -@item key grabbing -Keys on the keyboard can be passively @emph{grabbed} by a client. When -the key is pressed, the keyboard is then actively grabbed by the -client. - -@item keyboard grabbing -A client can actively @emph{grab} control of the keyboard, and key -events will be sent to that client rather than the client to which the -events would normally have been sent. - -@item keysym -An encoding of a symbol on a keycap on a keyboard. - -@item managed -A contact under geometry management control. - -@item mapped -A window is said to be @emph{mapped} if a map call has been performed -on it. Unmapped windows and their inferiors are never viewable or -visible. - -@item modifier keys -SHIFT, CONTROL, META, SUPER, HYPER, ALT, Compose, Apple, CAPS LOCK, -Shift Lock, and similar keys are called @emph{modifier keys}. - -@item monochrome -A special case of static gray, in which there are only two colormap -entries. - -@item obscure -A window is @emph{obscured} if some other window obscures it. For -example, window A obscures window B if: -@itemize @bullet - -@item Both windows are viewable @var{:input-output} windows - -@item Window A is higher in the global stacking order than window B - -@item The rectangle defined by the outside edges of window A intersects the rectangle -defined by the outside edges of window B -@end itemize - -Notice that window borders are included in the calculation, and that a window can be -obscured and yet still have visible regions. See occlude (there is a fine distinction -between obscure and occlude). - -@item occlude -A window is @emph{occluded} if some other window occludes it. For -example, window A occludes window B if: -@itemize @bullet - -@item Both windows are mapped - -@item Window A is higher in the global stacking order than window B - -@item The rectangle defined by the outside edges of window A intersects the rectangle -defined by the outside edges of window B -@end itemize - -Notice that window borders are included in the calculation. See -obscure (there is a fine distinction between occlude and obscure). - -@item override-shell -A subclass of @var{shell} used to override the window manager. This -subclass contains pop-up menus and other temporary objects that the -user can never resize and so on. - -@item padding -Some padding bytes are inserted in the data stream to maintain -alignment of the protocol requests on natural boundaries. This -increases ease of portability to some machine architectures. - -@item parent window -If C is a child of P, then P is the @emph{parent} of C. - -@item passive grab -Grabbing a key or button is a @emph{passive grab}. The grab activates -when the key or button is actually pressed. - -@item pixel value -An @emph{n}-bit value, where @emph{n} is the number of bit planes used -in (that is, the depth of) a particular window or pixmap. For a -window, a pixel value indexes a colormap to derive an actual color to -be displayed. - -@item pixmap -A three dimensional array of bits. A pixmap is normally thought of as -a two dimensional array of pixels, where each pixel can be a value -from 0 to (2@emph{n})-1, where @emph{n} is the depth (z axis) of -the pixmap. A pixmap can also be thought of as a stack of @emph{n} -bitmaps. - -@item plane -When a pixmap or window is thought of as a stack of bitmaps, each -bitmap is called a @emph{plane} or @emph{bit plane}. - -@item plane mask -Graphics operations can be restricted to only affect a subset of bit -planes of a destination. A @emph{plane mask} is a bit mask describing -which planes are to be modified, and it is stored in a graphics -context. - -@item pointer -The pointing device attached to the cursor and tracked on the screens. - -@item pointer grabbing -A client can actively @emph{grab} control of the pointer, and button -and motion events will be sent to that client rather than the client -to which the events would normally have been sent. - -@item pointing device -Typically a mouse or tablet, or some other device with effective -dimensional motion. There is only one visible cursor defined by the -core protocol, and it tracks whatever pointing device is attached as -the pointer. - -@item pop-up -One of the uses of a top-level shell (for example, a menu that pops up -when a command button contact is activated). Setting the @var{state} -of a shell to @var{:mapped} is sometimes referred to as -@emph{mapping} or @emph{popping up} the shell. Setting the -@var{state} of a shell to @var{:withdrawn} or @var{:iconic} is -sometimes referred to as @emph{unmapping} or @emph{popping down} the -shell. - -@item property -Windows can have associated @emph{properties}, consisting of a name, a -type, a data format, and some data. The protocol places no -interpretation on properties; they are intended as a general-purpose -naming mechanism for clients. For example, clients might share -information such as resize hints, program names, and icon formats with -a window manager via properties. - -@item property list -The list of properties that have been defined for a window. - -@item pseudo color -A class of colormap in which a pixel value indexes the colormap to -produce independent red, green, and blue values. That is, the colormap -is viewed as an array of triples (RGB values). The RGB values can be -changed dynamically. - -@item realization -See contact realization. - -@item redirecting control -Window managers (or client programs) may choose to enforce window -layout policy in various ways. When a client attempts to change the -size or position of a window, the operation can be @emph{redirected} -to a specified client, rather than the operation actually being -performed. - -@item reply -Information requested by a client program is sent back to the client -with a @emph{reply}. Both events and replies are multiplexed on the -same connection. Most requests do not generate replies. However, some -requests generate multiple replies. - -@item representation type -The type of representation of a resource value. For example, a color -value might be represented either as a namestring ("red"), a pixel -value, an RGB triplet, an HSV triplet, and so on. - -@item request -A command to the server is called a @emph{request}. It is a single -block of data sent over a connection. - -@item resource -A value of the user interface that can be changed by the user in a -resource database via CLX functions @var{add-resource}, -@var{get-resource}, and so forth. See server resource. - -@item resource class, complete -See complete resource class. - -@item resource database -Conceptually, a set of resource name/value pairs (or resource -bindings). CLX defines functions for storing and retrieving interface -resources from a resource database. - -@item resource name, complete -See complete resource name. - -@item RGB values -@emph{Red}, @emph{green}, and @emph{blue} intensity values used to -define color. These values are always represented as 16-bit unsigned -numbers, with zero being the minimum intensity and 65535 being the -maximum intensity. The values are scaled by the server to match the -display hardware. - -@item root -A special composite contact used to represent an entire display -screen. - -@item root window -Each screen has a @emph{root window} covering it. It cannot be -reconfigured or unmapped, but otherwise acts as a full-fledged -window. A root window has no parent. - -@item save set -The @emph{save set} of a client is a list of other client's windows -that, if they are inferiors of one of the client's windows at -connection close, should not be destroyed and that should be remapped -if it is unmapped. Save sets are typically used by window managers to -avoid lost windows if the manager should terminate abnormally. - -@item scanline -A list of pixel or bit values viewed as a horizontal row (all values -having the same y coordinate) of an image, with the values ordered by -increasing x coordinate. - -@item scanline order -An image represented in @emph{scanline order} contains scanlines -ordered by increasing y coordinate. - -@item screen -A server can provide several independent @emph{screens}, which -typically have physically independent monitors. This would be the -expected configuration when there is only a single keyboard and -pointer shared among the screens. - -@item selection - -A @emph{selection} can be thought of as an indirect property with -dynamic type. That is, rather than having the property stored in the -server, it is maintained by some client (the @emph{owner}). A -selection is global in nature, being thought of as belonging to the -user (but maintained by clients), rather than being private to a -particular window subhierarchy or a particular set of clients. When -a client asks for the contents of a selection, it specifies a -selection @emph{target type}. This target type can be used to -control the transmitted representation of the contents. - -For example, if the selection is "the last thing the user clicked -on" and that is currently an image, then the target type might -specify whether the contents of the image should be sent in XY -Format or Z Format. The target type can also be used to control the -class of contents transmitted; that is, asking for the looks (fonts, -line spacing, indentation, and so forth) of a paragraph selection, -rather than the text of the paragraph. The target type can also be -used for other purposes; the semantics is not constrained by the -protocol. - -@item sensitivity -A condition in which a user interface component of an application will -accept input. Conversely, when a contact is insensitive, events of -particular types are not dispatched to the contact and are ignored. - -@item server -The @emph{server} provides the basic windowing mechanism. It handles -IPC connections from clients, demultiplexes graphics requests onto the -screens, and multiplexes input back to the appropriate clients. - -@item server grabbing -The server can be @emph{grabbed} by a single client for exclusive -use. This prevents processing of any requests from other client -connections until the grab is complete. This is typically only a -transient state for such things as rubber-banding and pop-up menus, or -to execute requests indivisibly. - -@item server resource -Windows, pixmaps, cursors, fonts, gcontexts, and colormaps are known -as resources. They all have unique identifiers associated with them -for naming purposes. The lifetime of a resource is bounded by the -lifetime of the connection over which the resource was created. See -resource. - -@item shell -A composite that handles the duties required by standard conventions -for top-level X windows. - -@item sibling -Children of the same parent window are known as @emph{sibling} -windows. - -@item static color -A degenerate case of pseudo color in which the RGB values are -predefined and read-only. - -@item static gray -A degenerate case of gray scale in which the gray values are -predefined and read-only. The values are typically (near-)linear -increasing ramps. - -@item stacking order -Sibling windows can @emph{stack} on top of each other. Windows above -both obscure and occlude lower windows. This is similar to paper on a -desk. The relationship between sibling windows is known as the -@emph{stacking order}. - -@item state -A slot of @var{contact} that controls the visual effect of the -contact. - -@item stipple -A bitmap that is used to tile a region to serve as an additional clip -mask for a fill operation with the foreground color. - -@item tile -A pixmap can be replicated in two dimensions to @emph{tile} a -region. The pixmap itself is also known as a tile. - -@item timer -A CLUE object that provides support for animation and other types of -time-sensitive user interfaces. A timer causes @var{:timer} events to -be dispatched to a specific contact for processing. - -@item timestamp -A time value, expressed in milliseconds, typically since the last -server reset. Timestamp values wrap around (after about 49.7 -days). The server, given its current time is represented by timestamp -T, always interprets timestamps from clients by treating half of the -timestamp space as being earlier in time than T and half of the -timestamp space as being later in time than T. One timestamp value -(named CurrentTime) is never generated by the server; this value is -reserved for use in requests to represent the current server time. - -@item top-level contact -A contact whose parent is a root. A top-level contact is usually a -composite at the top of a hierarchy of other contacts created by an -application program. - -@item top-level-session -A subclass of @var{shell} that is used to communicate with a session -manager. - -@item top-level-shell -A subclass of @var{shell} that provides full window manager -interaction. - -@item transient-shell -A subclass of @var{shell} that a window manager typically will unmap -when its owner becomes unmapped or iconified and will not allow to be -individually iconified. - -@item true color -A degenerate case of direct color in which the subfields in the pixel -value directly encode the corresponding RGB values. That is, the -colormap has predefined read-only RGB values. The values are typically -(near-)linear increasing ramps. - -@item type -An arbitrary atom used to identify the interpretation of property -data. Types are completely uninterpreted by the server; they are -solely for the benefit of clients. - -@item unmanaged -A contact that is not under geometry management control. - -@item user interface -A set of abstract interface objects used to control the dialog between -an application and its human user. - -@item viewable -A window is @emph{viewable} if it and all of its ancestors are -mapped. This does not imply that any portion of the window is actually -visible. Graphics requests can be performed on a window when it is not -viewable, but output will not be retained unless the server is -maintaining backing store. - -@item visible -A region of a window is @emph{visible} if someone looking at the screen -can actually see it; that is, the window is viewable and the region is -not occluded by any other window. - -@item window gravity -When windows are resized, subwindows can be repositioned automatically -relative to some position in the window. This attraction of a subwindow -to some part of its parent is known as @emph{window gravity}. - -@item window manager -Manipulation of windows on the screen, and much of the user interface -(policy) is typically provided by a @emph{window manager} client. - -@item window manager shell -A subclass of @var{shell} called @var{wm-shell} that interacts with -the window manager. - -@item XY Format -The data for a pixmap is said to be in @emph{XY Format} if it is -organized as a set of bitmaps representing individual bit planes, with -the planes appearing from most to least significant in bit order. - -@item Z Format -The data for a pixmap is said to be in @emph{Z Format} if it is -organized as a set of pixel values in scanline order. -@end table - -@node Function Index, Type Index, Glossary, Top -@appendix Function Index - -@printindex fn - -@node Type Index, , Function Index, Top -@appendix Type Index - -@printindex tp - -@bye diff -Nru ecl-16.1.2/src/clx/NEWS ecl-16.1.3+ds/src/clx/NEWS --- ecl-16.1.2/src/clx/NEWS 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/NEWS 1970-01-01 00:00:00.000000000 +0000 @@ -1,164 +0,0 @@ --*- Text -*- --- Changes in telent CLX 0.7.3, Tue Mar 28 2006 --- - -Support for Allegro CL (6.2 and later) (Mikel Evins) -Latin 1 keysyms (Christophe Rhodes) -Some protocol fixes (Douglas Crosher) -Define a RENDER-OP typ (Douglas Crosher) - ---- Changes in SBCL CLX 0.7.2, Tue Jan 10 2006 --- - -OpenMCL fixes -DPMS extension support -Xauthority ipv6 parsing fixes - -Thanks to Bryan O'Connor, Matthew Kennedy, Christophe Rhodes - ---- Changes in SBCL CLX 0.7.1, Wed Aug 24 2005 --- - -Works in SBCL 0.9.2 and newer. - ---- Changes in SBCL CLX 0.7.0, Sun May 1 2005 --- - -The SBCL support now depends on version 0.9.0 or greater. - ---- Changes in SBCL CLX 0.6.1, Mon Mar 28 2005 --- - -experimental GLX extension support (from Janis Dzerins) - -The ICCCM-compliant selection handling in demo/clipboard.lisp is now -more ICCCM-compliant. - -The implementation of the RENDER client protocol has been -enhanced. (Gilbert Baumann) - -Bug fix: CIRCULATE-NOTIFY, CIRCULATE-REQUEST and PROPERTY-NOTIFY input -event descriptions have been fixed. - ---- Changes in SBCL CLX 0.6, Tue Nov 16 2004 --- - -A port to ECL has been merged (Juan Jose Garcia Ripoll) - -With the addition of an implementation of DYNAMIC-EXTENT &REST lists -to SBCL, various functions (e.g. READ-INPUT, QUEUE-EVENT) in CLX -should cons less. - -A Texinfo version of the CLX manual has been added (in manual/), thanks -to the work of Gilbert Baumann and Shawn Betts. - -The portable-clx mailing list has been created for development discussion -and bug reports. See -http://lists.metacircles.com/cgi-bin/mailman/listinfo/portable-clx - -A demonstration of ICCCM-compliant selection handling for select and paste -has been included in demo/clipboard.lisp - -Bug fix: change the sizes of certain fields in a WM-SIZE-HINT to be 32 -bits wide, as per the ICCCM specifications. Fixes a problem seen with -the MacOS X11 window manger, that uses very large hint values. -(Patch from Eric Marsden) - -Bug fix: +POINTER-EVENT-MASK-VECTOR+ is supposed to be a vector of -keywords. It wasn't, but it is now. (Milan Zamazal) - -Bug fix: xrender now compiles properly when *DEF-CLX-CLASS-USE-DEFCLASS* -(Milan again) - ---- Changes in SBCL CLX 0.5.4, Tue Nov 11 00:02:43 2003 --- - -A change in the implementation of PROCESS-BLOCK and PROCESS-WAKEUP -under multithreaded SBCL. Previous versions used queues and condition -variables, but this seems to have undesireable performance -characteristics; the newer version uses a polling loop calling -sched_yield() inside, which greatly improves responsiveness, but is -more CPU-hungry (as perceived by top(1), at least; in theory it -only hogs the CPU when nobody else wants it). - - ---- Changes in SBCL CLX 0.5.3, Sat Sep 6 12:14:39 UTC 2003 --- - -We allow a PIXMAP-DEPTH of 12 in clx.lisp, despite not having any -image routines for it, to allow clx to load when running under eXceed. -Image routines are unlikely to work in such circumstances. - -Bug fixes - - * ERROR idiom (xvidmode.lisp) - * Add timestamp in NEWS file - ---- Changes in SBCL CLX 0.5.2, about twenty minutes before 0.5.3 --- - -OPEN-DEFAULT-DISPLAY now takes an optional argument for the display -name, which has the same "protocol/host:display.screen" format as used -by the C libX11 (XOpenDisplay). OPEN-DISPLAY is not actively -deprecated, but is much less useful by comparison - -Inclusion of two new tests/demos (from Ingvar Mattson): - * demo/clclock: a simple clock application; - * demo/mandel: a Mandelbrot set viewer. - -Bug fixes - - * Fix bad type declarations in TEXT-EXTENTS-SERVER and - TEXT-WIDTH-SERVER (text.lisp) - * Fix FORMAT argument mismatch error in WRITE-BITMAP-FILE (image.lisp) - ---- Changes in SBCL CLX 0.5.1, Wed Jun 25 14:20:31 BST 2003 --- - -experimental RENDER extension support (from Gilbert Baumann) - note: the API to this is as yet unfinalized, as indeed the protocol - and specification appear to be in flux. Nevertheless, - feedback is welcome to the portable-clx-devel mailing list. - -Bug fixes - - * fix bugs in the image test: always draw glyphs in white on black - (not 1 on 0 -- i.e. dark red/blue on black in 24 bit truecolour); - don't abuse the X-HOT and Y-HOT slots for communicating persistent - information any more. - - * Disable the "optimized" pixarray read/write routines, on the basis - that the newly fixed image test reveals that they are broken. - - * fix type bugs in DEFINE-GCONTEXT-ACCESSOR, which previously - signalled a type error if :COPY-FUNCTION was not provided, and a - different type error if it was. - -Other notes - - * we use the SBCL extensions to the condition system to customize - compiler behaviour. As such, the system will only build without - breaking into the debugger using the supplied .asd, as we inhibit - error signalling from DEFCONSTANT; the benefits of this are easier - code sharing, as we minimize divergence within the clx source - proper from other implementations. - - * we also use an SBCL extension to maximize efficiency: we set - SB-EXT:*DERIVE-FUNCTION-TYPES* to true for the duration of the - compilation of the clx library. Should functions in CLX be - redefined in a type-incompatible way, their callers in CLX (but not - outside) will need to be recompiled. - ---- Changes in SBCL CLX 0.5, Fri May 30 01:16:34 BST 2003 --- - -XFree86-VidModeExtension extension support (courtesy of Iban Hatchondo) - -OPEN-DEFAULT-DISPLAY (opens display in $DISPLAY environment variable) exported - -Implement CLX MP dependencies for SBCL: HOLDING-LOCK, PROCESS-BLOCK, etc - -Many bug fixes - - * asking for text extents on unchached fonts could potentially deadlock - http://article.gmane.org/gmane.lisp.clx.devel/16 - - * lots of compiler warnings, style-warnings, notes cleared up - - -Style and ANSI cleanups - - * Much renaming of constants from *foo* to +foo+ - - * Change old-style COMPILE LOAD EVAL to new-style :COMPILE-TOPLEVEL - :LOAD-TOPLEVEL :EXECUTE in EVAL-WHENs. - diff -Nru ecl-16.1.2/src/clx/package.lisp ecl-16.1.3+ds/src/clx/package.lisp --- ecl-16.1.2/src/clx/package.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/package.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,397 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase: Yes; -*- - -;;; Copyright 1990 Massachusetts Institute of Technology, Cambridge, -;;; Massachusetts. All Rights Reserved. -;;; -;;; Permission to use, copy, modify, and distribute this software and its -;;; documentation for any purpose and without fee is hereby granted, provided -;;; that the above copyright notice appear in all copies and that both that -;;; copyright notice and this permission notice appear in supporting -;;; documentation, and that the name MIT not be used in advertising or -;;; publicity pertaining to distribution of the software without specific, -;;; written prior permission. - -;;; The CLtL way - -#-clx-ansi-common-lisp -(lisp:in-package :xlib :use '(:lisp)) - -#+(and (or kcl ibcl) (not clx-ansi-common-lisp)) -(shadow - '( - rational - )) - -#+(and CMU (not clx-ansi-common-lisp)) -(shadow '(define-condition)) - -#+(and lispm (not clx-ansi-common-lisp)) -(import - '( - sys:arglist - sys:with-stack-list - sys:with-stack-list* - )) - -#+(and Genera (not clx-ansi-common-lisp)) -(import - '( - future-common-lisp:print-unreadable-object - future-common-lisp:with-standard-io-syntax - zwei:indentation - )) - -#+(and lcl3.0 (not clx-ansi-common-lisp)) -(import - '( - lcl:arglist - lcl:dynamic-extent - lcl:type-error - lucid::type-error-datum - lucid::type-error-expected-type - )) - -#+(and excl (not clx-ansi-common-lisp)) -(import - '( - excl::arglist - excl::dynamic-extent - excl::type-error - excl::type-error-datum - excl::type-error-expected-type - )) - -#+(and allegro (not clx-ansi-common-lisp)) -(import - '( - excl::without-interrupts - )) - -#-clx-ansi-common-lisp -(export - '( - *version* access-control access-error access-hosts - activate-screen-saver add-access-host add-resource add-to-save-set - alist alloc-color alloc-color-cells alloc-color-planes alloc-error - allow-events angle arc-seq array-index atom-error atom-name - bell bit-gravity bitmap bitmap-format bitmap-format-lsb-first-p - bitmap-format-p bitmap-format-pad bitmap-format-unit bitmap-image - boole-constant boolean card16 card29 card32 card8 - card8->char change-active-pointer-grab change-keyboard-control - change-keyboard-mapping change-pointer-control change-property - char->card8 char-ascent char-attributes char-descent - char-left-bearing char-right-bearing char-width character->keysyms - character-in-map-p circulate-window-down circulate-window-up clear-area - close-display close-down-mode close-font closed-display color - color-blue color-green color-p color-red color-rgb colormap - colormap-display colormap-equal colormap-error colormap-id colormap-p - colormap-plist colormap-visual-info connection-failure convert-selection - copy-area copy-colormap-and-free copy-gcontext copy-gcontext-components - copy-image copy-plane create-colormap create-cursor - create-gcontext create-glyph-cursor create-image create-pixmap - create-window cursor cursor-display cursor-equal cursor-error - cursor-id cursor-p cursor-plist cut-buffer declare-event decode-core-error - default-error-handler default-keysym-index default-keysym-translate - define-error define-extension define-gcontext-accessor - define-keysym define-keysym-set delete-property delete-resource - destroy-subwindows destroy-window device-busy device-event-mask - device-event-mask-class discard-current-event discard-font-info display - display-after-function display-authorization-data display-authorization-name - display-bitmap-format display-byte-order display-default-screen - display-display display-error-handler - display-extended-max-request-length display-finish-output - display-force-output display-host display-image-lsb-first-p - display-invoke-after-function display-keycode-range display-max-keycode - display-max-request-length display-min-keycode display-motion-buffer-size - display-nscreens display-p display-pixmap-formats display-plist - display-protocol-major-version display-protocol-minor-version - display-protocol-version display-release-number - display-report-asynchronous-errors display-resource-id-base - display-resource-id-mask display-roots display-vendor - display-vendor-name display-xdefaults display-xid draw-arc - draw-arcs draw-direction draw-glyph draw-glyphs draw-image-glyph - draw-image-glyphs draw-line draw-lines draw-point draw-points - draw-rectangle draw-rectangles draw-segments drawable - drawable-border-width drawable-depth drawable-display drawable-equal - drawable-error drawable-height drawable-id drawable-p - drawable-plist drawable-root drawable-width drawable-x drawable-y - error-key event-case event-cond event-handler event-key - event-listen event-mask event-mask-class extension-opcode - find-atom font font-all-chars-exist-p font-ascent - font-default-char font-descent font-direction font-display - font-equal font-error font-id font-max-byte1 font-max-byte2 - font-max-char font-min-byte1 font-min-byte2 font-min-char - font-name font-p font-path font-plist font-properties - font-property fontable force-gcontext-changes free-colormap - free-colors free-cursor free-gcontext free-pixmap gcontext - gcontext-arc-mode gcontext-background - gcontext-cache-p gcontext-cap-style - gcontext-clip-mask gcontext-clip-ordering gcontext-clip-x - gcontext-clip-y gcontext-dash-offset gcontext-dashes gcontext-display - gcontext-equal gcontext-error gcontext-exposures gcontext-fill-rule - gcontext-fill-style gcontext-font gcontext-foreground gcontext-function - gcontext-id gcontext-join-style gcontext-key gcontext-line-style - gcontext-line-width gcontext-p gcontext-plane-mask gcontext-plist - gcontext-stipple gcontext-subwindow-mode gcontext-tile gcontext-ts-x - gcontext-ts-y generalized-boolean get-external-event-code get-image get-property - get-raw-image get-resource get-search-resource get-search-table - get-standard-colormap get-wm-class global-pointer-position grab-button - grab-key grab-keyboard grab-pointer grab-server grab-status - icon-sizes iconify-window id-choice-error illegal-request-error - image image-blue-mask image-depth image-green-mask image-height - image-name image-pixmap image-plist image-red-mask image-width - image-x image-x-hot image-x-p image-xy image-xy-bitmap-list - image-xy-p image-y-hot image-z image-z-bits-per-pixel image-z-p - image-z-pixarray implementation-error input-focus install-colormap - installed-colormaps int16 int32 int8 intern-atom invalid-font - keyboard-control keyboard-mapping keycode->character keycode->keysym - keysym keysym->character keysym->keycodes keysym-in-map-p - keysym-set kill-client kill-temporary-clients length-error - list-extensions list-font-names list-fonts list-properties - lookup-color lookup-error make-color make-event-handlers - make-event-keys make-event-mask make-resource-database make-state-keys - make-state-mask make-wm-hints make-wm-size-hints map-resource - map-subwindows map-window mapping-notify mask16 mask32 - match-error max-char-ascent max-char-attributes max-char-descent - max-char-left-bearing max-char-right-bearing max-char-width - merge-resources min-char-ascent min-char-attributes min-char-descent - min-char-left-bearing min-char-right-bearing min-char-width - missing-parameter modifier-key modifier-mapping modifier-mask - motion-events name-error no-operation open-display open-font - pixarray pixel pixmap pixmap-display pixmap-equal - pixmap-error pixmap-format pixmap-format-bits-per-pixel - pixmap-format-depth pixmap-format-p pixmap-format-scanline-pad - pixmap-id pixmap-p pixmap-plist point-seq pointer-control - pointer-event-mask pointer-event-mask-class pointer-mapping - pointer-position process-event put-image put-raw-image - query-best-cursor query-best-stipple query-best-tile query-colors - query-extension query-keymap query-pointer query-tree queue-event - read-bitmap-file read-resources recolor-cursor rect-seq - remove-access-host remove-from-save-set reparent-window repeat-seq - reply-length-error reply-timeout request-error reset-screen-saver - resource-database resource-database-timestamp resource-error - resource-id resource-key rgb-colormaps rgb-val root-resources - rotate-cut-buffers rotate-properties screen screen-backing-stores - screen-black-pixel screen-default-colormap screen-depths - screen-event-mask-at-open screen-height screen-height-in-millimeters - screen-max-installed-maps screen-min-installed-maps screen-p - screen-plist screen-root screen-root-depth screen-root-visual - screen-root-visual-info screen-save-unders-p screen-saver - screen-white-pixel screen-width screen-width-in-millimeters seg-seq - selection-owner send-event sequence-error set-access-control - set-close-down-mode set-input-focus set-modifier-mapping - set-pointer-mapping set-screen-saver set-selection-owner - set-standard-colormap set-standard-properties set-wm-class - set-wm-properties set-wm-resources state-keysym-p state-mask-key - store-color store-colors stringable text-extents text-width - timestamp transient-for translate-coordinates translate-default - translation-function type-error undefine-keysym unexpected-reply - ungrab-button ungrab-key ungrab-keyboard ungrab-pointer - ungrab-server uninstall-colormap unknown-error unmap-subwindows - unmap-window value-error visual-info visual-info-bits-per-rgb - visual-info-blue-mask visual-info-class visual-info-colormap-entries - visual-info-display visual-info-green-mask visual-info-id visual-info-p - visual-info-plist visual-info-red-mask warp-pointer - warp-pointer-if-inside warp-pointer-relative warp-pointer-relative-if-inside - win-gravity window window-all-event-masks window-background - window-backing-pixel window-backing-planes window-backing-store - window-bit-gravity window-border window-class window-colormap - window-colormap-installed-p window-cursor window-display - window-do-not-propagate-mask window-equal window-error - window-event-mask window-gravity window-id window-map-state - window-override-redirect window-p window-plist window-priority - window-save-under window-visual window-visual-info with-display - with-event-queue with-gcontext with-server-grabbed with-state - withdraw-window wm-client-machine wm-colormap-windows wm-command - wm-hints wm-hints-flags wm-hints-icon-mask wm-hints-icon-pixmap - wm-hints-icon-window wm-hints-icon-x wm-hints-icon-y - wm-hints-initial-state wm-hints-input wm-hints-p wm-hints-window-group - wm-icon-name wm-name wm-normal-hints wm-protocols wm-resources - wm-size-hints wm-size-hints-base-height wm-size-hints-base-width - wm-size-hints-height wm-size-hints-height-inc wm-size-hints-max-aspect - wm-size-hints-max-height wm-size-hints-max-width wm-size-hints-min-aspect - wm-size-hints-min-height wm-size-hints-min-width wm-size-hints-p - wm-size-hints-user-specified-position-p wm-size-hints-user-specified-size-p - wm-size-hints-width wm-size-hints-width-inc wm-size-hints-win-gravity - wm-size-hints-x wm-size-hints-y wm-zoom-hints write-bitmap-file - write-resources xatom - )) - - -;;; The ANSI Common Lisp way - -#+(and Genera clx-ansi-common-lisp) -(eval-when (:compile-toplevel :load-toplevel :execute) - (setf *readtable* si:*ansi-common-lisp-readtable*)) - -#+clx-ansi-common-lisp -(common-lisp:in-package :common-lisp-user) - -#+ecl -(eval-when (#-stage1 :compile-toplevel :load-toplevel #-stage1 :execute) - (require 'sockets)) - - -#+clx-ansi-common-lisp -(defpackage xlib - (:use common-lisp) - (:size 3000) - #+(or kcl ibcl) (:shadow rational) - #+allegro (:use cltl1) - #+allegro (:import-from excl without-interrupts) - #+excl (:import-from excl arglist) - #+Genera (:import-from zwei indentation) - #+lcl3.0 (:import-from lcl arglist) - #+lispm (:import-from lisp char-bit) - #+lispm (:import-from sys arglist with-stack-list with-stack-list*) - #+(or sbcl ecl) (:use sb-bsd-sockets) - (:export - *version* access-control access-error access-hosts - activate-screen-saver add-access-host add-resource add-to-save-set - alist alloc-color alloc-color-cells alloc-color-planes alloc-error - allow-events angle arc-seq array-index atom-error atom-name - bell bit-gravity bitmap bitmap-format bitmap-format-lsb-first-p - bitmap-format-p bitmap-format-pad bitmap-format-unit bitmap-image - boole-constant boolean card16 card29 card32 card8 - card8->char change-active-pointer-grab change-keyboard-control - change-keyboard-mapping change-pointer-control change-property - char->card8 char-ascent char-attributes char-descent - char-left-bearing char-right-bearing char-width character->keysyms - character-in-map-p circulate-window-down circulate-window-up clear-area - close-display close-down-mode close-font closed-display color - color-blue color-green color-p color-red color-rgb colormap - colormap-display colormap-equal colormap-error colormap-id colormap-p - colormap-plist colormap-visual-info connection-failure convert-selection - copy-area copy-colormap-and-free copy-gcontext copy-gcontext-components - copy-image copy-plane create-colormap create-cursor - create-gcontext create-glyph-cursor create-image create-pixmap - create-window cursor cursor-display cursor-equal cursor-error - cursor-id cursor-p cursor-plist cut-buffer declare-event decode-core-error - default-error-handler default-keysym-index default-keysym-translate - define-error define-extension define-gcontext-accessor - define-keysym define-keysym-set delete-property delete-resource - destroy-subwindows destroy-window device-busy device-event-mask - device-event-mask-class discard-current-event discard-font-info display - display-after-function display-authorization-data display-authorization-name - display-bitmap-format display-byte-order display-default-screen - display-display display-error-handler - display-extended-max-request-length display-finish-output - display-force-output display-host display-image-lsb-first-p - display-invoke-after-function display-keycode-range display-max-keycode - display-max-request-length display-min-keycode display-motion-buffer-size - display-nscreens display-p display-pixmap-formats display-plist - display-protocol-major-version display-protocol-minor-version - display-protocol-version display-release-number - display-report-asynchronous-errors display-resource-id-base - display-resource-id-mask display-roots display-vendor - display-vendor-name display-xdefaults display-xid draw-arc - draw-arcs draw-direction draw-glyph draw-glyphs draw-image-glyph - draw-image-glyphs draw-line draw-lines draw-point draw-points - draw-rectangle draw-rectangles draw-segments drawable - drawable-border-width drawable-depth drawable-display drawable-equal - drawable-error drawable-height drawable-id drawable-p - drawable-plist drawable-root drawable-width drawable-x drawable-y - error-key event-case event-cond event-handler event-key - event-listen event-mask event-mask-class extension-opcode - find-atom font font-all-chars-exist-p font-ascent - font-default-char font-descent font-direction font-display - font-equal font-error font-id font-max-byte1 font-max-byte2 - font-max-char font-min-byte1 font-min-byte2 font-min-char - font-name font-p font-path font-plist font-properties - font-property fontable force-gcontext-changes free-colormap - free-colors free-cursor free-gcontext free-pixmap gcontext - gcontext-arc-mode gcontext-background - gcontext-cache-p gcontext-cap-style - gcontext-clip-mask gcontext-clip-ordering gcontext-clip-x - gcontext-clip-y gcontext-dash-offset gcontext-dashes gcontext-display - gcontext-equal gcontext-error gcontext-exposures gcontext-fill-rule - gcontext-fill-style gcontext-font gcontext-foreground gcontext-function - gcontext-id gcontext-join-style gcontext-key gcontext-line-style - gcontext-line-width gcontext-p gcontext-plane-mask gcontext-plist - gcontext-stipple gcontext-subwindow-mode gcontext-tile gcontext-ts-x - gcontext-ts-y generalized-boolean get-external-event-code get-image get-property - get-raw-image get-resource get-search-resource get-search-table - get-standard-colormap get-wm-class global-pointer-position grab-button - grab-key grab-keyboard grab-pointer grab-server grab-status - icon-sizes iconify-window id-choice-error illegal-request-error - image image-blue-mask image-depth image-green-mask image-height - image-name image-pixmap image-plist image-red-mask image-width - image-x image-x-hot image-x-p image-xy image-xy-bitmap-list - image-xy-p image-y-hot image-z image-z-bits-per-pixel image-z-p - image-z-pixarray implementation-error input-focus install-colormap - installed-colormaps int16 int32 int8 intern-atom invalid-font - keyboard-control keyboard-mapping keycode->character keycode->keysym - keysym keysym->character keysym->keycodes keysym-in-map-p - keysym-set kill-client kill-temporary-clients length-error - list-extensions list-font-names list-fonts list-properties - lookup-color lookup-error make-color make-event-handlers - make-event-keys make-event-mask make-resource-database make-state-keys - make-state-mask make-wm-hints make-wm-size-hints map-resource - map-subwindows map-window mapping-notify mask16 mask32 - match-error max-char-ascent max-char-attributes max-char-descent - max-char-left-bearing max-char-right-bearing max-char-width - merge-resources min-char-ascent min-char-attributes min-char-descent - min-char-left-bearing min-char-right-bearing min-char-width - missing-parameter modifier-key modifier-mapping modifier-mask - motion-events name-error no-operation - open-default-display open-display open-font - pixarray pixel pixmap pixmap-display pixmap-equal - pixmap-error pixmap-format pixmap-format-bits-per-pixel - pixmap-format-depth pixmap-format-p pixmap-format-scanline-pad - pixmap-id pixmap-p pixmap-plist point-seq pointer-control - pointer-event-mask pointer-event-mask-class pointer-mapping - pointer-position process-event put-image put-raw-image - query-best-cursor query-best-stipple query-best-tile query-colors - query-extension query-keymap query-pointer query-tree queue-event - read-bitmap-file read-resources recolor-cursor rect-seq - remove-access-host remove-from-save-set reparent-window repeat-seq - reply-length-error reply-timeout request-error reset-screen-saver - resource-database resource-database-timestamp resource-error - resource-id resource-key rgb-colormaps rgb-val root-resources - rotate-cut-buffers rotate-properties screen screen-backing-stores - screen-black-pixel screen-default-colormap screen-depths - screen-event-mask-at-open screen-height screen-height-in-millimeters - screen-max-installed-maps screen-min-installed-maps screen-p - screen-plist screen-root screen-root-depth screen-root-visual - screen-root-visual-info screen-save-unders-p screen-saver - screen-white-pixel screen-width screen-width-in-millimeters seg-seq - selection-owner send-event sequence-error set-access-control - set-close-down-mode set-input-focus set-modifier-mapping - set-pointer-mapping set-screen-saver set-selection-owner - set-standard-colormap set-standard-properties set-wm-class - set-wm-properties set-wm-resources state-keysym-p state-mask-key - store-color store-colors stringable text-extents text-width - timestamp transient-for translate-coordinates translate-default - translation-function undefine-keysym unexpected-reply - ungrab-button ungrab-key ungrab-keyboard ungrab-pointer - ungrab-server uninstall-colormap unknown-error unmap-subwindows - unmap-window value-error visual-info visual-info-bits-per-rgb - visual-info-blue-mask visual-info-class visual-info-colormap-entries - visual-info-display visual-info-green-mask visual-info-id visual-info-p - visual-info-plist visual-info-red-mask warp-pointer - warp-pointer-if-inside warp-pointer-relative warp-pointer-relative-if-inside - win-gravity window window-all-event-masks window-background - window-backing-pixel window-backing-planes window-backing-store - window-bit-gravity window-border window-class window-colormap - window-colormap-installed-p window-cursor window-display - window-do-not-propagate-mask window-equal window-error - window-event-mask window-gravity window-id window-map-state - window-override-redirect window-p window-plist window-priority - window-save-under window-visual window-visual-info with-display - with-event-queue with-gcontext with-server-grabbed with-state - withdraw-window wm-client-machine wm-colormap-windows wm-command - wm-hints wm-hints-flags wm-hints-icon-mask wm-hints-icon-pixmap - wm-hints-icon-window wm-hints-icon-x wm-hints-icon-y - wm-hints-initial-state wm-hints-input wm-hints-p wm-hints-window-group - wm-icon-name wm-name wm-normal-hints wm-protocols wm-resources - wm-size-hints wm-size-hints-base-height wm-size-hints-base-width - wm-size-hints-height wm-size-hints-height-inc wm-size-hints-max-aspect - wm-size-hints-max-height wm-size-hints-max-width wm-size-hints-min-aspect - wm-size-hints-min-height wm-size-hints-min-width wm-size-hints-p - wm-size-hints-user-specified-position-p wm-size-hints-user-specified-size-p - wm-size-hints-width wm-size-hints-width-inc wm-size-hints-win-gravity - wm-size-hints-x wm-size-hints-y wm-zoom-hints write-bitmap-file - write-resources xatom)) - - - diff -Nru ecl-16.1.2/src/clx/provide.lisp ecl-16.1.3+ds/src/clx/provide.lisp --- ecl-16.1.2/src/clx/provide.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/provide.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,56 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase: Yes; Package: USER; -*- - -;;;; Module definition for CLX - -;;; This file is a Common Lisp Module description, but you will have to edit -;;; it to meet the needs of your site. - -;;; Ideally, this file (or a file that loads this file) should be -;;; located in the system directory that REQUIRE searches. Thus a user -;;; would say -;;; (require :clx) -;;; to load CLX. If there is no such registry, then the user must -;;; put in a site specific -;;; (require :clx ) -;;; - -#-clx-ansi-common-lisp -(in-package :user) - -#+clx-ansi-common-lisp -(in-package :common-lisp-user) - -#-clx-ansi-common-lisp -(provide :clx) - -(defvar *clx-source-pathname* - (pathname "/src/local/clx/*.l")) - -(defvar *clx-binary-pathname* - (let ((lisp - (or #+lucid "lucid" - #+akcl "akcl" - #+kcl "kcl" - #+ibcl "ibcl" - (error "Can't provide CLX for this lisp."))) - (architecture - (or #+(or sun3 (and sun (or mc68000 mc68020))) "sun3" - #+(or sun4 sparc) "sparc" - #+(and hp (or mc68000 mc68020)) "hp9000s300" - #+vax "vax" - #+prime "prime" - #+sunrise "sunrise" - #+ibm-rt-pc "ibm-rt-pc" - #+mips "mips" - #+prism "prism" - (error "Can't provide CLX for this architecture.")))) - (pathname (format nil "/src/local/clx/~A.~A/" lisp architecture)))) - -(defvar *compile-clx* - nil) - -(load (merge-pathnames "defsystem" *clx-source-pathname*)) - -(if *compile-clx* - (compile-clx *clx-source-pathname* *clx-binary-pathname*) - (load-clx *clx-binary-pathname*)) diff -Nru ecl-16.1.2/src/clx/README ecl-16.1.3+ds/src/clx/README --- ecl-16.1.2/src/clx/README 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/README 1970-01-01 00:00:00.000000000 +0000 @@ -1,112 +0,0 @@ -This directory contains CLX, an X11 client library for Common -Lisp. The code was originally taken from a CMUCL distribution, was -modified somewhat in order to make it compile and run under SBCL, then -a selection of patches were added from other CLXes around the net. - -= Features - - - SHAPE extension support (Gilbert Baumann) - - XFREE86-VIDMODE extension support (Iban Hatchondo) - - experimental RENDER extension support - (Gilbert Baumann and Christian Sunesson) - - X authority support that works with ssh forwarding (Eric Marsden via CMUCL) - - OPEN-DEFAULT-DISPLAY function which, as the name suggests, does that (dan) - - various bug fixes (Iban Hatchondo and a cast of several) - - a manual in texinfo format (Shawn Betts, Gilbert Baumann) - -= Compatibility - -This CLX distribution is intended to work under the latest released -version of SBCL - please report the bug if it doesn't. It should -usually also work with earlier versions back to 0.9.0, and possibly -earlier still, but may need manual adjustment to the clx.asd file (to -remove use of newly-introduced features). - -It has also been used as a basis for CLX ports on other Lisp -implementations, but these instructions are only good for SBCL. If -you're running something else, you need to know (a) that it builds -with asdf (and asdf-install, if the planets are in alignment) and -(b) what asdf is anyway. http://www.weitz.de/asdf-install/ might help -you there. If you've installed this using some non-SBCL Lisp, please -send mail describing the process so that future versions can incorporate -your instructions. - -If you are following SBCL CVS and this CLX does not run in it, please -check the darcs repositor{y,ies} for this CLX distribution to see if -your bug has been fixed already. - -darcs get http://verisons.telent.net/clx # version from which releases are made - http://common-lisp.net/~crhodes/clx # patches merged by Christophe - http://monday-monkey.com/repos/clx/ # OpenMCL tree by bryan o'connor? - -= Building using asdf-install - -* (require 'asdf) -* (require 'asdf-install) -* (asdf-install:install 'clx) ; download and install automatically, or -* (asdf-install:install "clx-x.y.z.tar.gz") ; if you've downloaded already - -= Building by hand - -If you don't trust asdf-install, here's how to do it manually - - -1. Untar this tree somewhere - -2. Add a symlink to clx.asd from one of the directories listed in your - asdf:*central-registry* - - If that makes no sense to you yet, choose one of - - - 2a. personal installation: - - $ cd $HOME/.sbcl/systems # you may have to create this directory - $ ln -s /path/to/clx/source/clx.asd . - - 2b. systemwide installations: you need to ask SBCL where it lives - - $ sbcl --noinform --eval '(format t "~A~%" (posix-getenv "SBCL_HOME"))' -ASDFized version and ongoing by Daniel Barlow -and (mostly, these days) Christophe Rhodes diff -Nru ecl-16.1.2/src/clx/README-R5 ecl-16.1.3+ds/src/clx/README-R5 --- ecl-16.1.2/src/clx/README-R5 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/README-R5 1970-01-01 00:00:00.000000000 +0000 @@ -1,52 +0,0 @@ - -Original CLX README, retained for historical information - ---- -These files contain beta code, but they have been tested to some extent under -Symbolics, TI, Lucid and Franz. The files have been given .l suffixes to keep -them within 12 characters, to keep SysV sites happy. Please rename them with -more appropriate suffixes for your system. - - -For Franz systems, see exclREADME. - - -For Symbolics systems, first rename all the .l files to .lisp. Then edit your -sys.translations file so that sys:x11;clx; points to this directory and put a -clx.system file in your sys:site;directory that has the form - - (si:set-system-source-file "clx" "sys:x11;clx;defsystem.lisp") - -in it. After that CLX can be compiled with the "Compile System CLX" command -and loaded with the "Load System CLX" command. - - - -For TI systems, rename all the .l files to .lisp, and make a clx.translations -file in your sys:site; directory pointing to this directory and a -sys:site;clx.system file like the one described for symbolics systems above, -but with the defsystem file being in the clx:clx; directory. Then CLX can be -compiled with (make-system "CLX" :compile :noconfirm) and loaded with -(make-system "CLX" :noconfirm). - - - -For Lucid systems, you should rename all the .l files to .lisp too (This might -not be possible on SysV systems). After loading the defsystem.l file, CLX can -be compiled with the (compile-clx) function and loaded with the -(load-clx) form. - -The ms-patch.uu file is a patch to Lucid version 2 systems. You probably -don't need it, as you are probably running Lucid version 3 or later, but if -you are still using Lucid version 2, you need this patch. You'll need to -uudecode it to produce the binary. - - - -For kcl systems, after loading the defsystem.l file, CLX can be compiled with -the (compile-clx) function and loaded with the (load-clx) form. - - - -For more information, see defsystem.l and provide.l. - diff -Nru ecl-16.1.2/src/clx/requests.lisp ecl-16.1.3+ds/src/clx/requests.lisp --- ecl-16.1.2/src/clx/requests.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/requests.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,1491 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(defun create-window (&key - window - (parent (required-arg parent)) - (x (required-arg x)) - (y (required-arg y)) - (width (required-arg width)) - (height (required-arg height)) - (depth 0) (border-width 0) - (class :copy) (visual :copy) - background border - bit-gravity gravity - backing-store backing-planes backing-pixel save-under - event-mask do-not-propagate-mask override-redirect - colormap cursor) - ;; Display is obtained from parent. Only non-nil attributes are passed on in - ;; the request: the function makes no assumptions about what the actual protocol - ;; defaults are. Width and height are the inside size, excluding border. - (declare (type (or null window) window) - (type window parent) ; required - (type int16 x y) ;required - (type card16 width height) ;required - (type card16 depth border-width) - (type (member :copy :input-output :input-only) class) - (type (or (member :copy) visual-info resource-id) visual) - (type (or null (member :none :parent-relative) pixel pixmap) background) - (type (or null (member :copy) pixel pixmap) border) - (type (or null bit-gravity) bit-gravity) - (type (or null win-gravity) gravity) - (type (or null (member :not-useful :when-mapped :always)) backing-store) - (type (or null pixel) backing-planes backing-pixel) - (type (or null event-mask) event-mask) - (type (or null device-event-mask) do-not-propagate-mask) - (type (or null (member :on :off)) save-under override-redirect) - (type (or null (member :copy) colormap) colormap) - (type (or null (member :none) cursor) cursor)) - (declare (clx-values window)) - (let* ((display (window-display parent)) - (window (or window (make-window :display display))) - (wid (allocate-resource-id display window 'window)) - back-pixmap back-pixel - border-pixmap border-pixel) - (declare (type display display) - (type window window) - (type resource-id wid) - (type (or null resource-id) back-pixmap border-pixmap) - (type (or null pixel) back-pixel border-pixel)) - (setf (window-id window) wid) - (case background - ((nil) nil) - (:none (setq back-pixmap 0)) - (:parent-relative (setq back-pixmap 1)) - (otherwise - (if (type? background 'pixmap) - (setq back-pixmap (pixmap-id background)) - (if (integerp background) - (setq back-pixel background) - (x-type-error background - '(or null (member :none :parent-relative) integer pixmap)))))) - (case border - ((nil) nil) - (:copy (setq border-pixmap 0)) - (otherwise - (if (type? border 'pixmap) - (setq border-pixmap (pixmap-id border)) - (if (integerp border) - (setq border-pixel border) - (x-type-error border '(or null (member :copy) integer pixmap)))))) - (when event-mask - (setq event-mask (encode-event-mask event-mask))) - (when do-not-propagate-mask - (setq do-not-propagate-mask (encode-device-event-mask do-not-propagate-mask))) - - ;Make the request - (with-buffer-request (display +x-createwindow+) - (data depth) - (resource-id wid) - (window parent) - (int16 x y) - (card16 width height border-width) - ((member16 :copy :input-output :input-only) class) - (resource-id (cond ((eq visual :copy) - 0) - ((typep visual 'resource-id) - visual) - (t - (visual-info-id visual)))) - (mask (card32 back-pixmap back-pixel border-pixmap border-pixel) - ((member-vector +bit-gravity-vector+) bit-gravity) - ((member-vector +win-gravity-vector+) gravity) - ((member :not-useful :when-mapped :always) backing-store) - (card32 backing-planes backing-pixel) - ((member :off :on) override-redirect save-under) - (card32 event-mask do-not-propagate-mask) - ((or (member :copy) colormap) colormap) - ((or (member :none) cursor) cursor))) - window)) - -(defun destroy-window (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-destroywindow+) - (window window))) - -(defun destroy-subwindows (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-destroysubwindows+) - (window window))) - -(defun add-to-save-set (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-changesaveset+) - (data 0) - (window window))) - -(defun remove-from-save-set (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-changesaveset+) - (data 1) - (window window))) - -(defun reparent-window (window parent x y) - (declare (type window window parent) - (type int16 x y)) - (with-buffer-request ((window-display window) +x-reparentwindow+) - (window window parent) - (int16 x y))) - -(defun map-window (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-mapwindow+) - (window window))) - -(defun map-subwindows (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-mapsubwindows+) - (window window))) - -(defun unmap-window (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-unmapwindow+) - (window window))) - -(defun unmap-subwindows (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-unmapsubwindows+) - (window window))) - -(defun circulate-window-up (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-circulatewindow+) - (data 0) - (window window))) - -(defun circulate-window-down (window) - (declare (type window window)) - (with-buffer-request ((window-display window) +x-circulatewindow+) - (data 1) - (window window))) - -(defun query-tree (window &key (result-type 'list)) - (declare (type window window) - (type t result-type)) ;;type specifier - (declare (clx-values (clx-sequence window) parent root)) - (let ((display (window-display window))) - (multiple-value-bind (root parent sequence) - (with-buffer-request-and-reply (display +x-querytree+ nil :sizes (8 16 32)) - ((window window)) - (values - (window-get 8) - (resource-id-get 12) - (sequence-get :length (card16-get 16) :result-type result-type - :index +replysize+))) - ;; Parent is NIL for root window - (setq parent (and (plusp parent) (lookup-window display parent))) - (dotimes (i (length sequence)) ; Convert ID's to window's - (setf (elt sequence i) (lookup-window display (elt sequence i)))) - (values sequence parent root)))) - -;; Although atom-ids are not visible in the normal user interface, atom-ids might -;; appear in window properties and other user data, so conversion hooks are needed. - -(defun intern-atom (display name) - (declare (type display display) - (type xatom name)) - (declare (clx-values resource-id)) - (let ((name (if (or (null name) (keywordp name)) - name - (kintern (string name))))) - (declare (type symbol name)) - (or (atom-id name display) - (let ((string (symbol-name name))) - (declare (type string string)) - (multiple-value-bind (id) - (with-buffer-request-and-reply (display +x-internatom+ 12 :sizes 32) - ((data 0) - (card16 (length string)) - (pad16 nil) - (string string)) - (values - (resource-id-get 8))) - (declare (type resource-id id)) - (setf (atom-id name display) id) - id))))) - -(defun find-atom (display name) - ;; Same as INTERN-ATOM, but with the ONLY-IF-EXISTS flag True - (declare (type display display) - (type xatom name)) - (declare (clx-values (or null resource-id))) - (let ((name (if (or (null name) (keywordp name)) - name - (kintern (string name))))) - (declare (type symbol name)) - (or (atom-id name display) - (let ((string (symbol-name name))) - (declare (type string string)) - (multiple-value-bind (id) - (with-buffer-request-and-reply (display +x-internatom+ 12 :sizes 32) - ((data 1) - (card16 (length string)) - (pad16 nil) - (string string)) - (values - (or-get 8 null resource-id))) - (declare (type (or null resource-id) id)) - (when id - (setf (atom-id name display) id)) - id))))) - -(defun atom-name (display atom-id) - (declare (type display display) - (type resource-id atom-id)) - (declare (clx-values keyword)) - (if (zerop atom-id) - nil - (or (id-atom atom-id display) - (let ((keyword - (kintern - (with-buffer-request-and-reply - (display +x-getatomname+ nil :sizes (16)) - ((resource-id atom-id)) - (values - (string-get (card16-get 8) +replysize+)))))) - (declare (type keyword keyword)) - (setf (atom-id keyword display) atom-id) - keyword)))) - -;;; For binary compatibility with older code -(defun lookup-xatom (display atom-id) - (declare (type display display) - (type resource-id atom-id)) - (atom-name display atom-id)) - -(defun change-property (window property data type format - &key (mode :replace) (start 0) end transform) - ; Start and end affect sub-sequence extracted from data. - ; Transform is applied to each extracted element. - (declare (type window window) - (type xatom property type) - (type (member 8 16 32) format) - (type sequence data) - (type (member :replace :prepend :append) mode) - (type array-index start) - (type (or null array-index) end) - (type (or null (function (t) integer)) transform)) - (unless end (setq end (length data))) - (let* ((display (window-display window)) - (length (index- end start)) - (property-id (intern-atom display property)) - (type-id (intern-atom display type))) - (declare (type display display) - (type array-index length) - (type resource-id property-id type-id)) - (with-buffer-request (display +x-changeproperty+) - ((data (member :replace :prepend :append)) mode) - (window window) - (resource-id property-id type-id) - (card8 format) - (card32 length) - (progn - (ecase format - (8 (sequence-put 24 data :format card8 - :start start :end end :transform transform)) - (16 (sequence-put 24 data :format card16 - :start start :end end :transform transform)) - (32 (sequence-put 24 data :format card32 - :start start :end end :transform transform))))))) - -(defun delete-property (window property) - (declare (type window window) - (type xatom property)) - (let* ((display (window-display window)) - (property-id (intern-atom display property))) - (declare (type display display) - (type resource-id property-id)) - (with-buffer-request (display +x-deleteproperty+) - (window window) - (resource-id property-id)))) - -(defun get-property (window property - &key type (start 0) end delete-p (result-type 'list) transform) - ;; Transform is applied to each integer retrieved. - (declare (type window window) - (type xatom property) - (type (or null xatom) type) - (type array-index start) - (type (or null array-index) end) - (type generalized-boolean delete-p) - (type t result-type) ;a sequence type - (type (or null (function (integer) t)) transform)) - (declare (clx-values data (or null type) format bytes-after)) - (let* ((display (window-display window)) - (property-id (intern-atom display property)) - (type-id (and type (intern-atom display type)))) - (declare (type display display) - (type resource-id property-id) - (type (or null resource-id) type-id)) - (multiple-value-bind (reply-format reply-type bytes-after data) - (with-buffer-request-and-reply (display +x-getproperty+ nil :sizes (8 32)) - (((data boolean) delete-p) - (window window) - (resource-id property-id) - ((or null resource-id) type-id) - (card32 start) - (card32 (index- (or end 64000) start))) - (let ((reply-format (card8-get 1)) - (reply-type (card32-get 8)) - (bytes-after (card32-get 12)) - (nitems (card32-get 16))) - (values - reply-format - reply-type - bytes-after - (and (plusp nitems) - (ecase reply-format - (0 nil) ;; (make-sequence result-type 0) ;; Property not found. - (8 (sequence-get :result-type result-type :format card8 - :length nitems :transform transform - :index +replysize+)) - (16 (sequence-get :result-type result-type :format card16 - :length nitems :transform transform - :index +replysize+)) - (32 (sequence-get :result-type result-type :format card32 - :length nitems :transform transform - :index +replysize+))))))) - (values data - (and (plusp reply-type) (atom-name display reply-type)) - reply-format - bytes-after)))) - -(defun rotate-properties (window properties &optional (delta 1)) - ;; Positive rotates left, negative rotates right (opposite of actual protocol request). - (declare (type window window) - (type sequence properties) ;; sequence of xatom - (type int16 delta)) - (let* ((display (window-display window)) - (length (length properties)) - (sequence (make-array length))) - (declare (type display display) - (type array-index length)) - (with-vector (sequence vector) - ;; Atoms must be interned before the RotateProperties request - ;; is started to allow InternAtom requests to be made. - (dotimes (i length) - (setf (aref sequence i) (intern-atom display (elt properties i)))) - (with-buffer-request (display +x-rotateproperties+) - (window window) - (card16 length) - (int16 (- delta)) - ((sequence :end length) sequence)))) - nil) - -(defun list-properties (window &key (result-type 'list)) - (declare (type window window) - (type t result-type)) ;; a sequence type - (declare (clx-values (clx-sequence keyword))) - (let ((display (window-display window))) - (multiple-value-bind (seq) - (with-buffer-request-and-reply (display +x-listproperties+ nil :sizes 16) - ((window window)) - (values - (sequence-get :result-type result-type :length (card16-get 8) - :index +replysize+))) - ;; lookup the atoms in the sequence - (if (listp seq) - (do ((elt seq (cdr elt))) - ((endp elt) seq) - (setf (car elt) (atom-name display (car elt)))) - (dotimes (i (length seq) seq) - (setf (aref seq i) (atom-name display (aref seq i)))))))) - -(defun selection-owner (display selection) - (declare (type display display) - (type xatom selection)) - (declare (clx-values (or null window))) - (let ((selection-id (intern-atom display selection))) - (declare (type resource-id selection-id)) - (multiple-value-bind (window) - (with-buffer-request-and-reply (display +x-getselectionowner+ 12 :sizes 32) - ((resource-id selection-id)) - (values - (resource-id-or-nil-get 8))) - (and window (lookup-window display window))))) - -(defun set-selection-owner (display selection owner &optional time) - (declare (type display display) - (type xatom selection) - (type (or null window) owner) - (type timestamp time)) - (let ((selection-id (intern-atom display selection))) - (declare (type resource-id selection-id)) - (with-buffer-request (display +x-setselectionowner+) - ((or null window) owner) - (resource-id selection-id) - ((or null card32) time)) - owner)) - -(defsetf selection-owner (display selection &optional time) (owner) - ;; A bit strange, but retains setf form. - `(set-selection-owner ,display ,selection ,owner ,time)) - -(defun convert-selection (selection type requestor &optional property time) - (declare (type xatom selection type) - (type window requestor) - (type (or null xatom) property) - (type timestamp time)) - (let* ((display (window-display requestor)) - (selection-id (intern-atom display selection)) - (type-id (intern-atom display type)) - (property-id (and property (intern-atom display property)))) - (declare (type display display) - (type resource-id selection-id type-id) - (type (or null resource-id) property-id)) - (with-buffer-request (display +x-convertselection+) - (window requestor) - (resource-id selection-id type-id) - ((or null resource-id) property-id) - ((or null card32) time)))) - -(defun send-event (window event-key event-mask &rest args - &key propagate-p display &allow-other-keys) - ;; Additional arguments depend on event-key, and are as specified further below - ;; with declare-event, except that both resource-ids and resource objects are - ;; accepted in the event components. The display argument is only required if the - ;; window is :pointer-window or :input-focus. - (declare (type (or window (member :pointer-window :input-focus)) window) - (type event-key event-key) - (type (or null event-mask) event-mask) - (type generalized-boolean propagate-p) - (type (or null display) display) - (dynamic-extent args)) - (unless event-mask (setq event-mask 0)) - (unless display (setq display (window-display window))) - (let ((internal-event-code (get-event-code event-key)) - (external-event-code (get-external-event-code display event-key))) - (declare (type card8 internal-event-code external-event-code)) - ;; Ensure keyword atom-id's are cached - (dolist (arg (cdr (assoc event-key '((:property-notify :atom) - (:selection-clear :selection) - (:selection-request :selection :target :property) - (:selection-notify :selection :target :property) - (:client-message :type)) - :test #'eq))) - (let ((keyword (getf args arg))) - (intern-atom display keyword))) - ;; Make the sendevent request - (with-buffer-request (display +x-sendevent+) - ((data boolean) propagate-p) - (length 11) ;; 3 word request + 8 words for event = 11 - ((or (member :pointer-window :input-focus) window) window) - (card32 (encode-event-mask event-mask)) - (card8 external-event-code) - (progn - (apply (svref *event-send-vector* internal-event-code) display args) - (setf (buffer-boffset display) (index+ buffer-boffset 44)))))) - -(defun grab-pointer (window event-mask - &key owner-p sync-pointer-p sync-keyboard-p confine-to cursor time) - (declare (type window window) - (type pointer-event-mask event-mask) - (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) - (type (or null window) confine-to) - (type (or null cursor) cursor) - (type timestamp time)) - (declare (clx-values grab-status)) - (let ((display (window-display window))) - (with-buffer-request-and-reply (display +x-grabpointer+ nil :sizes 8) - (((data boolean) owner-p) - (window window) - (card16 (encode-pointer-event-mask event-mask)) - (boolean (not sync-pointer-p) (not sync-keyboard-p)) - ((or null window) confine-to) - ((or null cursor) cursor) - ((or null card32) time)) - (values - (member8-get 1 :success :already-grabbed :invalid-time :not-viewable :frozen))))) - -(defun ungrab-pointer (display &key time) - (declare (type timestamp time)) - (with-buffer-request (display +x-ungrabpointer+) - ((or null card32) time))) - -(defun grab-button (window button event-mask - &key (modifiers :any) - owner-p sync-pointer-p sync-keyboard-p confine-to cursor) - (declare (type window window) - (type (or (member :any) card8) button) - (type modifier-mask modifiers) - (type pointer-event-mask event-mask) - (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) - (type (or null window) confine-to) - (type (or null cursor) cursor)) - (with-buffer-request ((window-display window) +x-grabbutton+) - ((data boolean) owner-p) - (window window) - (card16 (encode-pointer-event-mask event-mask)) - (boolean (not sync-pointer-p) (not sync-keyboard-p)) - ((or null window) confine-to) - ((or null cursor) cursor) - (card8 (if (eq button :any) 0 button)) - (pad8 1) - (card16 (encode-modifier-mask modifiers)))) - -(defun ungrab-button (window button &key (modifiers :any)) - (declare (type window window) - (type (or (member :any) card8) button) - (type modifier-mask modifiers)) - (with-buffer-request ((window-display window) +x-ungrabbutton+) - (data (if (eq button :any) 0 button)) - (window window) - (card16 (encode-modifier-mask modifiers)))) - -(defun change-active-pointer-grab (display event-mask &optional cursor time) - (declare (type display display) - (type pointer-event-mask event-mask) - (type (or null cursor) cursor) - (type timestamp time)) - (with-buffer-request (display +x-changeactivepointergrab+) - ((or null cursor) cursor) - ((or null card32) time) - (card16 (encode-pointer-event-mask event-mask)))) - -(defun grab-keyboard (window &key owner-p sync-pointer-p sync-keyboard-p time) - (declare (type window window) - (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) - (type timestamp time)) - (declare (clx-values grab-status)) - (let ((display (window-display window))) - (with-buffer-request-and-reply (display +x-grabkeyboard+ nil :sizes 8) - (((data boolean) owner-p) - (window window) - ((or null card32) time) - (boolean (not sync-pointer-p) (not sync-keyboard-p))) - (values - (member8-get 1 :success :already-grabbed :invalid-time :not-viewable :frozen))))) - -(defun ungrab-keyboard (display &key time) - (declare (type display display) - (type timestamp time)) - (with-buffer-request (display +x-ungrabkeyboard+) - ((or null card32) time))) - -(defun grab-key (window key &key (modifiers 0) owner-p sync-pointer-p sync-keyboard-p) - (declare (type window window) - (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) - (type (or (member :any) card8) key) - (type modifier-mask modifiers)) - (with-buffer-request ((window-display window) +x-grabkey+) - ((data boolean) owner-p) - (window window) - (card16 (encode-modifier-mask modifiers)) - (card8 (if (eq key :any) 0 key)) - (boolean (not sync-pointer-p) (not sync-keyboard-p)))) - -(defun ungrab-key (window key &key (modifiers 0)) - (declare (type window window) - (type (or (member :any) card8) key) - (type modifier-mask modifiers)) - (with-buffer-request ((window-display window) +x-ungrabkey+) - (data (if (eq key :any) 0 key)) - (window window) - (card16 (encode-modifier-mask modifiers)))) - -(defun allow-events (display mode &optional time) - (declare (type display display) - (type (member :async-pointer :sync-pointer :replay-pointer - :async-keyboard :sync-keyboard :replay-keyboard - :async-both :sync-both) - mode) - (type timestamp time)) - (with-buffer-request (display +x-allowevents+) - ((data (member :async-pointer :sync-pointer :replay-pointer - :async-keyboard :sync-keyboard :replay-keyboard - :async-both :sync-both)) - mode) - ((or null card32) time))) - -(defun grab-server (display) - (declare (type display display)) - (with-buffer-request (display +x-grabserver+))) - -(defun ungrab-server (display) - (with-buffer-request (display +x-ungrabserver+))) - -(defmacro with-server-grabbed ((display) &body body) - ;; The body is not surrounded by a with-display. - (let ((disp (if (symbolp display) display (gensym)))) - `(let ((,disp ,display)) - (declare (type display ,disp)) - (unwind-protect - (progn - (grab-server ,disp) - ,@body) - (ungrab-server ,disp))))) - -(defun query-pointer (window) - (declare (type window window)) - (declare (clx-values x y same-screen-p child mask root-x root-y root)) - (let ((display (window-display window))) - (with-buffer-request-and-reply (display +x-querypointer+ 26 :sizes (8 16 32)) - ((window window)) - (values - (int16-get 20) - (int16-get 22) - (boolean-get 1) - (or-get 12 null window) - (card16-get 24) - (int16-get 16) - (int16-get 18) - (window-get 8))))) - -(defun pointer-position (window) - (declare (type window window)) - (declare (clx-values x y same-screen-p)) - (let ((display (window-display window))) - (with-buffer-request-and-reply (display +x-querypointer+ 24 :sizes (8 16)) - ((window window)) - (values - (int16-get 20) - (int16-get 22) - (boolean-get 1))))) - -(defun global-pointer-position (display) - (declare (type display display)) - (declare (clx-values root-x root-y root)) - (with-buffer-request-and-reply (display +x-querypointer+ 20 :sizes (16 32)) - ((window (screen-root (first (display-roots display))))) - (values - (int16-get 16) - (int16-get 18) - (window-get 8)))) - -(defun motion-events (window &key start stop (result-type 'list)) - (declare (type window window) - (type timestamp start stop) - (type t result-type)) ;; a type specifier - (declare (clx-values (repeat-seq (integer x) (integer y) (timestamp time)))) - (let ((display (window-display window))) - (with-buffer-request-and-reply (display +x-getmotionevents+ nil :sizes 32) - ((window window) - ((or null card32) start stop)) - (values - (sequence-get :result-type result-type :length (index* (card32-get 8) 3) - :index +replysize+))))) - -(defun translate-coordinates (src src-x src-y dst) - ;; Returns NIL when not on the same screen - (declare (type window src) - (type int16 src-x src-y) - (type window dst)) - (declare (clx-values dst-x dst-y child)) - (let ((display (window-display src))) - (with-buffer-request-and-reply (display +x-translatecoords+ 16 :sizes (8 16 32)) - ((window src dst) - (int16 src-x src-y)) - (and (boolean-get 1) - (values - (int16-get 12) - (int16-get 14) - (or-get 8 null window)))))) - -(defun warp-pointer (dst dst-x dst-y) - (declare (type window dst) - (type int16 dst-x dst-y)) - (with-buffer-request ((window-display dst) +x-warppointer+) - (resource-id 0) ;; None - (window dst) - (int16 0 0) - (card16 0 0) - (int16 dst-x dst-y))) - -(defun warp-pointer-relative (display x-off y-off) - (declare (type display display) - (type int16 x-off y-off)) - (with-buffer-request (display +x-warppointer+) - (resource-id 0) ;; None - (resource-id 0) ;; None - (int16 0 0) - (card16 0 0) - (int16 x-off y-off))) - -(defun warp-pointer-if-inside (dst dst-x dst-y src src-x src-y - &optional src-width src-height) - ;; Passing in a zero src-width or src-height is a no-op. - ;; A null src-width or src-height translates into a zero value in the protocol request. - (declare (type window dst src) - (type int16 dst-x dst-y src-x src-y) - (type (or null card16) src-width src-height)) - (unless (or (eql src-width 0) (eql src-height 0)) - (with-buffer-request ((window-display dst) +x-warppointer+) - (window src dst) - (int16 src-x src-y) - (card16 (or src-width 0) (or src-height 0)) - (int16 dst-x dst-y)))) - -(defun warp-pointer-relative-if-inside (x-off y-off src src-x src-y - &optional src-width src-height) - ;; Passing in a zero src-width or src-height is a no-op. - ;; A null src-width or src-height translates into a zero value in the protocol request. - (declare (type window src) - (type int16 x-off y-off src-x src-y) - (type (or null card16) src-width src-height)) - (unless (or (eql src-width 0) (eql src-height 0)) - (with-buffer-request ((window-display src) +x-warppointer+) - (window src) - (resource-id 0) ;; None - (int16 src-x src-y) - (card16 (or src-width 0) (or src-height 0)) - (int16 x-off y-off)))) - -(defun set-input-focus (display focus revert-to &optional time) - (declare (type display display) - (type (or (member :none :pointer-root) window) focus) - (type (member :none :pointer-root :parent) revert-to) - (type timestamp time)) - (with-buffer-request (display +x-setinputfocus+) - ((data (member :none :pointer-root :parent)) revert-to) - ((or window (member :none :pointer-root)) focus) - ((or null card32) time))) - -(defun input-focus (display) - (declare (type display display)) - (declare (clx-values focus revert-to)) - (with-buffer-request-and-reply (display +x-getinputfocus+ 16 :sizes (8 32)) - () - (values - (or-get 8 window (member :none :pointer-root)) - (member8-get 1 :none :pointer-root :parent)))) - -(defun query-keymap (display &optional bit-vector) - (declare (type display display) - (type (or null (bit-vector 256)) bit-vector)) - (declare (clx-values (bit-vector 256))) - (with-buffer-request-and-reply (display +x-querykeymap+ 40 :sizes 8) - () - (values - (bit-vector256-get 8 8 bit-vector)))) - -(defun create-pixmap (&key - pixmap - (width (required-arg width)) - (height (required-arg height)) - (depth (required-arg depth)) - (drawable (required-arg drawable))) - (declare (type (or null pixmap) pixmap) - (type card8 depth) ;; required - (type card16 width height) ;; required - (type drawable drawable)) ;; required - (declare (clx-values pixmap)) - (let* ((display (drawable-display drawable)) - (pixmap (or pixmap (make-pixmap :display display))) - (pid (allocate-resource-id display pixmap 'pixmap))) - (setf (pixmap-id pixmap) pid) - (with-buffer-request (display +x-createpixmap+) - (data depth) - (resource-id pid) - (drawable drawable) - (card16 width height)) - pixmap)) - -(defun free-pixmap (pixmap) - (declare (type pixmap pixmap)) - (let ((display (pixmap-display pixmap))) - (with-buffer-request (display +x-freepixmap+) - (pixmap pixmap)) - (deallocate-resource-id display (pixmap-id pixmap) 'pixmap))) - -(defun clear-area (window &key (x 0) (y 0) width height exposures-p) - ;; Passing in a zero width or height is a no-op. - ;; A null width or height translates into a zero value in the protocol request. - (declare (type window window) - (type int16 x y) - (type (or null card16) width height) - (type generalized-boolean exposures-p)) - (unless (or (eql width 0) (eql height 0)) - (with-buffer-request ((window-display window) +x-cleartobackground+) - ((data boolean) exposures-p) - (window window) - (int16 x y) - (card16 (or width 0) (or height 0))))) - -(defun copy-area (src gcontext src-x src-y width height dst dst-x dst-y) - (declare (type drawable src dst) - (type gcontext gcontext) - (type int16 src-x src-y dst-x dst-y) - (type card16 width height)) - (with-buffer-request ((drawable-display src) +x-copyarea+ :gc-force gcontext) - (drawable src dst) - (gcontext gcontext) - (int16 src-x src-y dst-x dst-y) - (card16 width height))) - -(defun copy-plane (src gcontext plane src-x src-y width height dst dst-x dst-y) - (declare (type drawable src dst) - (type gcontext gcontext) - (type pixel plane) - (type int16 src-x src-y dst-x dst-y) - (type card16 width height)) - (with-buffer-request ((drawable-display src) +x-copyplane+ :gc-force gcontext) - (drawable src dst) - (gcontext gcontext) - (int16 src-x src-y dst-x dst-y) - (card16 width height) - (card32 plane))) - -(defun create-colormap (visual-info window &optional alloc-p) - (declare (type (or visual-info resource-id) visual-info) - (type window window) - (type generalized-boolean alloc-p)) - (declare (clx-values colormap)) - (let ((display (window-display window))) - (when (typep visual-info 'resource-id) - (setf visual-info (visual-info display visual-info))) - (let* ((colormap (make-colormap :display display :visual-info visual-info)) - (id (allocate-resource-id display colormap 'colormap))) - (setf (colormap-id colormap) id) - (with-buffer-request (display +x-createcolormap+) - ((data boolean) alloc-p) - (card29 id) - (window window) - (card29 (visual-info-id visual-info))) - colormap))) - -(defun free-colormap (colormap) - (declare (type colormap colormap)) - (let ((display (colormap-display colormap))) - (with-buffer-request (display +x-freecolormap+) - (colormap colormap)) - (deallocate-resource-id display (colormap-id colormap) 'colormap))) - -(defun copy-colormap-and-free (colormap) - (declare (type colormap colormap)) - (declare (clx-values colormap)) - (let* ((display (colormap-display colormap)) - (new-colormap (make-colormap :display display - :visual-info (colormap-visual-info colormap))) - (id (allocate-resource-id display new-colormap 'colormap))) - (setf (colormap-id new-colormap) id) - (with-buffer-request (display +x-copycolormapandfree+) - (resource-id id) - (colormap colormap)) - new-colormap)) - -(defun install-colormap (colormap) - (declare (type colormap colormap)) - (with-buffer-request ((colormap-display colormap) +x-installcolormap+) - (colormap colormap))) - -(defun uninstall-colormap (colormap) - (declare (type colormap colormap)) - (with-buffer-request ((colormap-display colormap) +x-uninstallcolormap+) - (colormap colormap))) - -(defun installed-colormaps (window &key (result-type 'list)) - (declare (type window window) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence colormap))) - (let ((display (window-display window))) - (flet ((get-colormap (id) - (lookup-colormap display id))) - (with-buffer-request-and-reply (display +x-listinstalledcolormaps+ nil :sizes 16) - ((window window)) - (values - (sequence-get :result-type result-type :length (card16-get 8) - :transform #'get-colormap :index +replysize+)))))) - -(defun alloc-color (colormap color) - (declare (type colormap colormap) - (type (or stringable color) color)) - (declare (clx-values pixel screen-color exact-color)) - (let ((display (colormap-display colormap))) - (etypecase color - (color - (with-buffer-request-and-reply (display +x-alloccolor+ 20 :sizes (16 32)) - ((colormap colormap) - (rgb-val (color-red color) - (color-green color) - (color-blue color)) - (pad16 nil)) - (values - (card32-get 16) - (make-color :red (rgb-val-get 8) - :green (rgb-val-get 10) - :blue (rgb-val-get 12)) - color))) - (stringable - (let* ((string (string color)) - (length (length string))) - (with-buffer-request-and-reply (display +x-allocnamedcolor+ 24 :sizes (16 32)) - ((colormap colormap) - (card16 length) - (pad16 nil) - (string string)) - (values - (card32-get 8) - (make-color :red (rgb-val-get 18) - :green (rgb-val-get 20) - :blue (rgb-val-get 22)) - (make-color :red (rgb-val-get 12) - :green (rgb-val-get 14) - :blue (rgb-val-get 16))))))))) - -(defun alloc-color-cells (colormap colors &key (planes 0) contiguous-p (result-type 'list)) - (declare (type colormap colormap) - (type card16 colors planes) - (type generalized-boolean contiguous-p) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence pixel) (clx-sequence mask))) - (let ((display (colormap-display colormap))) - (with-buffer-request-and-reply (display +x-alloccolorcells+ nil :sizes 16) - (((data boolean) contiguous-p) - (colormap colormap) - (card16 colors planes)) - (let ((pixel-length (card16-get 8)) - (mask-length (card16-get 10))) - (values - (sequence-get :result-type result-type :length pixel-length :index +replysize+) - (sequence-get :result-type result-type :length mask-length - :index (index+ +replysize+ (index* pixel-length 4)))))))) - -(defun alloc-color-planes (colormap colors - &key (reds 0) (greens 0) (blues 0) - contiguous-p (result-type 'list)) - (declare (type colormap colormap) - (type card16 colors reds greens blues) - (type generalized-boolean contiguous-p) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence pixel) red-mask green-mask blue-mask)) - (let ((display (colormap-display colormap))) - (with-buffer-request-and-reply (display +x-alloccolorplanes+ nil :sizes (16 32)) - (((data boolean) contiguous-p) - (colormap colormap) - (card16 colors reds greens blues)) - (let ((red-mask (card32-get 12)) - (green-mask (card32-get 16)) - (blue-mask (card32-get 20))) - (values - (sequence-get :result-type result-type :length (card16-get 8) :index +replysize+) - red-mask green-mask blue-mask))))) - -(defun free-colors (colormap pixels &optional (plane-mask 0)) - (declare (type colormap colormap) - (type sequence pixels) ;; Sequence of integers - (type pixel plane-mask)) - (with-buffer-request ((colormap-display colormap) +x-freecolors+) - (colormap colormap) - (card32 plane-mask) - (sequence pixels))) - -(defun store-color (colormap pixel spec &key (red-p t) (green-p t) (blue-p t)) - (declare (type colormap colormap) - (type pixel pixel) - (type (or stringable color) spec) - (type generalized-boolean red-p green-p blue-p)) - (let ((display (colormap-display colormap)) - (flags 0)) - (declare (type display display) - (type card8 flags)) - (when red-p (setq flags 1)) - (when green-p (incf flags 2)) - (when blue-p (incf flags 4)) - (etypecase spec - (color - (with-buffer-request (display +x-storecolors+) - (colormap colormap) - (card32 pixel) - (rgb-val (color-red spec) - (color-green spec) - (color-blue spec)) - (card8 flags) - (pad8 nil))) - (stringable - (let* ((string (string spec)) - (length (length string))) - (with-buffer-request (display +x-storenamedcolor+) - ((data card8) flags) - (colormap colormap) - (card32 pixel) - (card16 length) - (pad16 nil) - (string string))))))) - -(defun store-colors (colormap specs &key (red-p t) (green-p t) (blue-p t)) - ;; If stringables are specified for colors, it is unspecified whether all - ;; stringables are first resolved and then a single StoreColors protocol request is - ;; issued, or whether multiple StoreColors protocol requests are issued. - (declare (type colormap colormap) - (type sequence specs) - (type generalized-boolean red-p green-p blue-p)) - (etypecase specs - (list - (do ((spec specs (cddr spec))) - ((endp spec)) - (store-color colormap (car spec) (cadr spec) :red-p red-p :green-p green-p :blue-p blue-p))) - (vector - (do ((i 0 (+ i 2)) - (len (length specs))) - ((>= i len)) - (store-color colormap (aref specs i) (aref specs (1+ i)) :red-p red-p :green-p green-p :blue-p blue-p))))) - -(defun query-colors (colormap pixels &key (result-type 'list)) - (declare (type colormap colormap) - (type sequence pixels) ;; sequence of integer - (type t result-type)) ;; a type specifier - (declare (clx-values (clx-sequence color))) - (let ((display (colormap-display colormap))) - (with-buffer-request-and-reply (display +x-querycolors+ nil :sizes (8 16)) - ((colormap colormap) - (sequence pixels)) - (let ((sequence (make-sequence result-type (card16-get 8)))) - (advance-buffer-offset +replysize+) - (dotimes (i (length sequence) sequence) - (setf (elt sequence i) - (make-color :red (rgb-val-get 0) - :green (rgb-val-get 2) - :blue (rgb-val-get 4))) - (advance-buffer-offset 8)))))) - -(defun lookup-color (colormap name) - (declare (type colormap colormap) - (type stringable name)) - (declare (clx-values screen-color true-color)) - (let* ((display (colormap-display colormap)) - (string (string name)) - (length (length string))) - (with-buffer-request-and-reply (display +x-lookupcolor+ 20 :sizes 16) - ((colormap colormap) - (card16 length) - (pad16 nil) - (string string)) - (values - (make-color :red (rgb-val-get 14) - :green (rgb-val-get 16) - :blue (rgb-val-get 18)) - (make-color :red (rgb-val-get 8) - :green (rgb-val-get 10) - :blue (rgb-val-get 12)))))) - -(defun create-cursor (&key - (source (required-arg source)) - mask - (x (required-arg x)) - (y (required-arg y)) - (foreground (required-arg foreground)) - (background (required-arg background))) - (declare (type pixmap source) ;; required - (type (or null pixmap) mask) - (type card16 x y) ;; required - (type (or null color) foreground background)) ;; required - (declare (clx-values cursor)) - (let* ((display (pixmap-display source)) - (cursor (make-cursor :display display)) - (cid (allocate-resource-id display cursor 'cursor))) - (setf (cursor-id cursor) cid) - (with-buffer-request (display +x-createcursor+) - (resource-id cid) - (pixmap source) - ((or null pixmap) mask) - (rgb-val (color-red foreground) - (color-green foreground) - (color-blue foreground)) - (rgb-val (color-red background) - (color-green background) - (color-blue background)) - (card16 x y)) - cursor)) - -(defun create-glyph-cursor (&key - (source-font (required-arg source-font)) - (source-char (required-arg source-char)) - mask-font - mask-char - (foreground (required-arg foreground)) - (background (required-arg background))) - (declare (type font source-font) ;; Required - (type card16 source-char) ;; Required - (type (or null font) mask-font) - (type (or null card16) mask-char) - (type color foreground background)) ;; required - (declare (clx-values cursor)) - (let* ((display (font-display source-font)) - (cursor (make-cursor :display display)) - (cid (allocate-resource-id display cursor 'cursor)) - (source-font-id (font-id source-font)) - (mask-font-id (if mask-font (font-id mask-font) 0))) - (setf (cursor-id cursor) cid) - (unless mask-char (setq mask-char 0)) - (with-buffer-request (display +x-createglyphcursor+) - (resource-id cid source-font-id mask-font-id) - (card16 source-char) - (card16 mask-char) - (rgb-val (color-red foreground) - (color-green foreground) - (color-blue foreground)) - (rgb-val (color-red background) - (color-green background) - (color-blue background))) - cursor)) - -(defun free-cursor (cursor) - (declare (type cursor cursor)) - (let ((display (cursor-display cursor))) - (with-buffer-request (display +x-freecursor+) - (cursor cursor)) - (deallocate-resource-id display (cursor-id cursor) 'cursor))) - -(defun recolor-cursor (cursor foreground background) - (declare (type cursor cursor) - (type color foreground background)) - (with-buffer-request ((cursor-display cursor) +x-recolorcursor+) - (cursor cursor) - (rgb-val (color-red foreground) - (color-green foreground) - (color-blue foreground)) - (rgb-val (color-red background) - (color-green background) - (color-blue background)) - )) - -(defun query-best-cursor (width height drawable) - (declare (type card16 width height) - (type (or drawable display) drawable)) - (declare (clx-values width height)) - ;; Drawable can be a display for compatibility. - (multiple-value-bind (display drawable) - (if (type? drawable 'drawable) - (values (drawable-display drawable) drawable) - (values drawable (screen-root (display-default-screen drawable)))) - (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16) - ((data 0) - (window drawable) - (card16 width height)) - (values - (card16-get 8) - (card16-get 10))))) - -(defun query-best-tile (width height drawable) - (declare (type card16 width height) - (type drawable drawable)) - (declare (clx-values width height)) - (let ((display (drawable-display drawable))) - (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16) - ((data 1) - (drawable drawable) - (card16 width height)) - (values - (card16-get 8) - (card16-get 10))))) - -(defun query-best-stipple (width height drawable) - (declare (type card16 width height) - (type drawable drawable)) - (declare (clx-values width height)) - (let ((display (drawable-display drawable))) - (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16) - ((data 2) - (drawable drawable) - (card16 width height)) - (values - (card16-get 8) - (card16-get 10))))) - -(defun query-extension (display name) - (declare (type display display) - (type stringable name)) - (declare (clx-values major-opcode first-event first-error)) - (let ((string (string name))) - (with-buffer-request-and-reply (display +x-queryextension+ 12 :sizes 8) - ((card16 (length string)) - (pad16 nil) - (string string)) - (and (boolean-get 8) ;; If present - (values - (card8-get 9) - (card8-get 10) - (card8-get 11)))))) - -(defun list-extensions (display &key (result-type 'list)) - (declare (type display display) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence string))) - (with-buffer-request-and-reply (display +x-listextensions+ size :sizes 8) - () - (values - (read-sequence-string - buffer-bbuf (index- size +replysize+) (card8-get 1) result-type +replysize+)))) - -(defun change-keyboard-control (display &key key-click-percent - bell-percent bell-pitch bell-duration - led led-mode key auto-repeat-mode) - (declare (type display display) - (type (or null (member :default) int16) key-click-percent - bell-percent bell-pitch bell-duration) - (type (or null card8) led key) - (type (or null (member :on :off)) led-mode) - (type (or null (member :on :off :default)) auto-repeat-mode)) - (when (eq key-click-percent :default) (setq key-click-percent -1)) - (when (eq bell-percent :default) (setq bell-percent -1)) - (when (eq bell-pitch :default) (setq bell-pitch -1)) - (when (eq bell-duration :default) (setq bell-duration -1)) - (with-buffer-request (display +x-changekeyboardcontrol+ :sizes (32)) - (mask - (integer key-click-percent bell-percent bell-pitch bell-duration) - (card32 led) - ((member :off :on) led-mode) - (card32 key) - ((member :off :on :default) auto-repeat-mode)))) - -(defun keyboard-control (display) - (declare (type display display)) - (declare (clx-values key-click-percent bell-percent bell-pitch bell-duration - led-mask global-auto-repeat auto-repeats)) - (with-buffer-request-and-reply (display +x-getkeyboardcontrol+ 32 :sizes (8 16 32)) - () - (values - (card8-get 12) - (card8-get 13) - (card16-get 14) - (card16-get 16) - (card32-get 8) - (member8-get 1 :off :on) - (bit-vector256-get 20)))) - -;; The base volume should -;; be considered to be the "desired" volume in the normal case; that is, a -;; typical application should call XBell with 0 as the percent. Rather -;; than using a simple sum, the percent argument is instead used as the -;; percentage of the remaining range to alter the base volume by. That is, -;; the actual volume is: -;; if percent>=0: base - [(base * percent) / 100] + percent -;; if percent<0: base + [(base * percent) / 100] - -(defun bell (display &optional (percent-from-normal 0)) - ;; It is assumed that an eventual audio extension to X will provide more complete control. - (declare (type display display) - (type int8 percent-from-normal)) - (with-buffer-request (display +x-bell+) - (data (int8->card8 percent-from-normal)))) - -(defun pointer-mapping (display &key (result-type 'list)) - (declare (type display display) - (type t result-type)) ;; CL type - (declare (clx-values sequence)) ;; Sequence of card - (with-buffer-request-and-reply (display +x-getpointermapping+ nil :sizes 8) - () - (values - (sequence-get :length (card8-get 1) :result-type result-type :format card8 - :index +replysize+)))) - -(defun set-pointer-mapping (display map) - ;; Can signal device-busy. - (declare (type display display) - (type sequence map)) ;; Sequence of card8 - (when (with-buffer-request-and-reply (display +x-setpointermapping+ 2 :sizes 8) - ((data (length map)) - ((sequence :format card8) map)) - (values - (boolean-get 1))) - (x-error 'device-busy :display display)) - map) - -(defsetf pointer-mapping set-pointer-mapping) - -(defun change-pointer-control (display &key acceleration threshold) - ;; Acceleration is rationalized if necessary. - (declare (type display display) - (type (or null (member :default) number) acceleration) - (type (or null (member :default) integer) threshold)) - (flet ((rationalize16 (number) - ;; Rationalize NUMBER into the ratio of two signed 16 bit numbers - (declare (type number number)) - (declare (clx-values numerator denominator)) - (do* ((rational (rationalize number)) - (numerator (numerator rational) (ash numerator -1)) - (denominator (denominator rational) (ash denominator -1))) - ((or (= numerator 1) - (and (< (abs numerator) #x8000) - (< denominator #x8000))) - (values - numerator (min denominator #x7fff)))))) - (declare (inline rationalize16)) - (let ((acceleration-p 1) - (threshold-p 1) - (numerator 0) - (denominator 1)) - (declare (type card8 acceleration-p threshold-p) - (type int16 numerator denominator)) - (cond ((eq acceleration :default) (setq numerator -1)) - (acceleration (multiple-value-setq (numerator denominator) - (rationalize16 acceleration))) - (t (setq acceleration-p 0))) - (cond ((eq threshold :default) (setq threshold -1)) - ((null threshold) (setq threshold -1 - threshold-p 0))) - (with-buffer-request (display +x-changepointercontrol+) - (int16 numerator denominator threshold) - (card8 acceleration-p threshold-p))))) - -(defun pointer-control (display) - (declare (type display display)) - (declare (clx-values acceleration threshold)) - (with-buffer-request-and-reply (display +x-getpointercontrol+ 16 :sizes 16) - () - (values - (/ (card16-get 8) (card16-get 10)) ; Should we float this? - (card16-get 12)))) - -(defun set-screen-saver (display timeout interval blanking exposures) - ;; Timeout and interval are in seconds, will be rounded to minutes. - (declare (type display display) - (type (or (member :default) int16) timeout interval) - (type (member :on :off :default :yes :no) blanking exposures)) - (case blanking (:yes (setq blanking :on)) (:no (setq blanking :off))) - (case exposures (:yes (setq exposures :on)) (:no (setq exposures :off))) - (when (eq timeout :default) (setq timeout -1)) - (when (eq interval :default) (setq interval -1)) - (with-buffer-request (display +x-setscreensaver+) - (int16 timeout interval) - ((member8 :on :off :default) blanking exposures))) - -(defun screen-saver (display) - ;; Returns timeout and interval in seconds. - (declare (type display display)) - (declare (clx-values timeout interval blanking exposures)) - (with-buffer-request-and-reply (display +x-getscreensaver+ 14 :sizes (8 16)) - () - (values - (card16-get 8) - (card16-get 10) - (member8-get 12 :on :off :default) - (member8-get 13 :on :off :default)))) - -(defun activate-screen-saver (display) - (declare (type display display)) - (with-buffer-request (display +x-forcescreensaver+) - (data 1))) - -(defun reset-screen-saver (display) - (declare (type display display)) - (with-buffer-request (display +x-forcescreensaver+) - (data 0))) - -(defun add-access-host (display host &optional (family :internet)) - ;; A string must be acceptable as a host, but otherwise the possible types for - ;; host are not constrained, and will likely be very system dependent. - ;; This implementation uses a list whose car is the family keyword - ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes. - (declare (type display display) - (type (or stringable list) host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (change-access-host display host family nil)) - -(defun remove-access-host (display host &optional (family :internet)) - ;; A string must be acceptable as a host, but otherwise the possible types for - ;; host are not constrained, and will likely be very system dependent. - ;; This implementation uses a list whose car is the family keyword - ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes. - (declare (type display display) - (type (or stringable list) host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (change-access-host display host family t)) - -(defun change-access-host (display host family remove-p) - (declare (type display display) - (type (or stringable list) host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (unless (consp host) - (setq host (host-address host family))) - (let ((family (car host)) - (address (cdr host))) - (with-buffer-request (display +x-changehosts+) - ((data boolean) remove-p) - (card8 (encode-type (or null (member :internet :decnet :chaos) card32) family)) - (card16 (length address)) - ((sequence :format card8) address)))) - -(defun access-hosts (display &optional (result-type 'list)) - ;; The type of host objects returned is not constrained, except that the hosts must - ;; be acceptable to add-access-host and remove-access-host. - ;; This implementation uses a list whose car is the family keyword - ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes. - (declare (type display display) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence host) enabled-p)) - (with-buffer-request-and-reply (display +x-listhosts+ nil :sizes (8 16)) - () - (let* ((enabled-p (boolean-get 1)) - (nhosts (card16-get 8)) - (sequence (make-sequence result-type nhosts))) - (advance-buffer-offset +replysize+) - (dotimes (i nhosts) - (let ((family (card8-get 0)) - (len (card16-get 2))) - (setf (elt sequence i) - (cons (if (< family 3) - (svref '#(:internet :decnet :chaos) family) - family) - (sequence-get :length len :format card8 :result-type 'list - :index (+ buffer-boffset 4)))) - (advance-buffer-offset (+ 4 (* 4 (ceiling len 4)))))) - (values - sequence - enabled-p)))) - -(defun access-control (display) - (declare (type display display)) - (declare (clx-values generalized-boolean)) ;; True when access-control is ENABLED - (with-buffer-request-and-reply (display +x-listhosts+ 2 :sizes 8) - () - (boolean-get 1))) - -(defun set-access-control (display enabled-p) - (declare (type display display) - (type generalized-boolean enabled-p)) - (with-buffer-request (display +x-changeaccesscontrol+) - ((data boolean) enabled-p)) - enabled-p) - -(defsetf access-control set-access-control) - -(defun close-down-mode (display) - ;; setf'able - ;; Cached locally in display object. - (declare (type display display)) - (declare (clx-values (member :destroy :retain-permanent :retain-temporary nil))) - (display-close-down-mode display)) - -(defun set-close-down-mode (display mode) - ;; Cached locally in display object. - (declare (type display display) - (type (member :destroy :retain-permanent :retain-temporary) mode)) - (setf (display-close-down-mode display) mode) - (with-buffer-request (display +x-changeclosedownmode+ :sizes (32)) - ((data (member :destroy :retain-permanent :retain-temporary)) mode)) - mode) - -(defsetf close-down-mode set-close-down-mode) - -(defun kill-client (display resource-id) - (declare (type display display) - (type resource-id resource-id)) - (with-buffer-request (display +x-killclient+) - (resource-id resource-id))) - -(defun kill-temporary-clients (display) - (declare (type display display)) - (with-buffer-request (display +x-killclient+) - (resource-id 0))) - -(defun no-operation (display) - (declare (type display display)) - (with-buffer-request (display +x-nooperation+))) diff -Nru ecl-16.1.2/src/clx/resource.lisp ecl-16.1.3+ds/src/clx/resource.lisp --- ecl-16.1.2/src/clx/resource.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/resource.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,700 +0,0 @@ -;;; -*- Mode:Common-Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- - -;; RESOURCE - Lisp version of XLIB's Xrm resource manager - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -;; The C version of this uses a 64 entry hash table at each entry. -;; Small hash tables lose in Lisp, so we do linear searches on lists. - -(defstruct (resource-database (:copier nil) (:predicate nil) - (:print-function print-resource-database) - (:constructor make-resource-database-internal) - #+explorer (:callable-constructors nil) - ) - (name nil :type stringable :read-only t) - (value nil) - (tight nil :type list) ;; List of resource-database - (loose nil :type list) ;; List of resource-database - ) - -(defun print-resource-database (database stream depth) - (declare (type resource-database database) - (ignore depth)) - (print-unreadable-object (database stream :type t) - (write-string (string (resource-database-name database)) stream) - (when (resource-database-value database) - (write-string " " stream) - (prin1 (resource-database-value database) stream)))) - -;; The value slot of the top-level resource-database structure is used for a -;; time-stamp. - -(defun make-resource-database () - ;; Make a resource-database with initial timestamp of 0 - (make-resource-database-internal :name "Top-Level" :value 0)) - -(defun resource-database-timestamp (database) - (declare (type resource-database database)) - (resource-database-value database)) - -(defun incf-resource-database-timestamp (database) - ;; Increment the timestamp - (declare (type resource-database database)) - (let ((timestamp (resource-database-value database))) - (setf (resource-database-value database) - (if (= timestamp most-positive-fixnum) - most-negative-fixnum - (1+ timestamp))))) - -;; DEBUG FUNCTION (not exported) -(defun print-db (entry &optional (level 0) type) - ;; Debug function to print a resource database - (format t "~%~v@t~s~:[~; *~]~@[ Value ~s~]" - level - (resource-database-name entry) - (eq type 'loose) - (resource-database-value entry)) - (when (resource-database-tight entry) - (dolist (tight (resource-database-tight entry)) - (print-db tight (+ 2 level) 'tight))) - (when (resource-database-loose entry) - (dolist (loose (resource-database-loose entry)) - (print-db loose (+ 2 level) 'loose)))) - -;; DEBUG FUNCTION -#+comment -(defun print-search-table (table) - (terpri) - (dolist (dbase-list table) - (format t "~%~s" dbase-list) - (dolist (db dbase-list) - (print-db db) - (dolist (dblist table) - (unless (eq dblist dbase-list) - (when (member db dblist) - (format t " duplicate at ~s" db)))) - ))) - -;; -;; If this is true, resource symbols will be compared in a case-insensitive -;; manner, and converting a resource string to a keyword will uppercaseify it. -;; -(defparameter *uppercase-resource-symbols* nil) - -(defun resource-key (stringable) - ;; Ensure STRINGABLE is a keyword. - (declare (type stringable stringable)) - (etypecase stringable - (symbol - (if (keywordp (the symbol stringable)) - stringable - (kintern (symbol-name (the symbol stringable))))) - (string - (if *uppercase-resource-symbols* - (setq stringable (#-allegro string-upcase #+allegro correct-case - (the string stringable)))) - (kintern (the string stringable))))) - -(defun stringable-equal (a b) - ;; Compare two stringables. - ;; Ignore case when comparing to a symbol. - (declare (type stringable a b)) - (declare (clx-values generalized-boolean)) - (etypecase a - (string - (etypecase b - (string - (string= (the string a) (the string b))) - (symbol - (if *uppercase-resource-symbols* - (string-equal (the string a) - (the string (symbol-name (the symbol b)))) - (string= (the string a) - (the string (symbol-name (the symbol b)))))))) - (symbol - (etypecase b - (string - (if *uppercase-resource-symbols* - (string-equal (the string (symbol-name (the symbol a))) - (the string b)) - (string= (the string (symbol-name (the symbol a))) - (the string b)))) - (symbol - (string= (the string (symbol-name (the symbol a))) - (the string (symbol-name (the symbol b))))))))) - - -;;;----------------------------------------------------------------------------- -;;; Add/delete resource - -(defun add-resource (database name-list value) - ;; name-list is a list of either strings or symbols. If a symbol, - ;; case-insensitive comparisons will be used, if a string, - ;; case-sensitive comparisons will be used. The symbol '* or - ;; string "*" are used as wildcards, matching anything or nothing. - (declare (type resource-database database) - (type (clx-list stringable) name-list) - (type t value)) - (unless value (error "Null resource values are ignored")) - (incf-resource-database-timestamp database) - (do* ((list name-list (cdr list)) - (name (car list) (car list)) - (node database) - (loose-p nil)) - ((endp list) - (setf (resource-database-value node) value)) - ;; Key is the first name that isn't * - (if (stringable-equal name "*") - (setq loose-p t) - ;; find the entry associated with name - (progn - (do ((entry (if loose-p - (resource-database-loose node) - (resource-database-tight node)) - (cdr entry))) - ((endp entry) - ;; Entry not found - create a new one - (setq entry (make-resource-database-internal :name name)) - (if loose-p - (push entry (resource-database-loose node)) - (push entry (resource-database-tight node))) - (setq node entry)) - (when (stringable-equal name (resource-database-name (car entry))) - ;; Found entry - use it - (return (setq node (car entry))))) - (setq loose-p nil))))) - - -(defun delete-resource (database name-list) - (declare (type resource-database database) - (type list name-list)) - (incf-resource-database-timestamp database) - (delete-resource-internal database name-list)) - -(defun delete-resource-internal (database name-list) - (declare (type resource-database database) - (type (clx-list stringable) name-list)) - (do* ((list name-list (cdr list)) - (string (car list) (car list)) - (node database) - (loose-p nil)) - ((endp list) nil) - ;; Key is the first name that isn't * - (if (stringable-equal string "*") - (setq loose-p t) - ;; find the entry associated with name - (progn - (do* ((first-entry (if loose-p - (resource-database-loose node) - (resource-database-tight node))) - (entry-list first-entry (cdr entry-list)) - (entry (car entry-list) (car entry-list))) - ((endp entry-list) - ;; Entry not found - exit - (return-from delete-resource-internal nil)) - (when (stringable-equal string (resource-database-name entry)) - (when (cdr list) (delete-resource-internal entry (cdr list))) - (when (and (null (resource-database-loose entry)) - (null (resource-database-tight entry))) - (if loose-p - (setf (resource-database-loose node) - (delete entry (resource-database-loose node) - :test #'eq :count 1)) - (setf (resource-database-tight node) - (delete entry (resource-database-tight node) - :test #'eq :count 1)))) - (return-from delete-resource-internal t))) - (setq loose-p nil))))) - -;;;----------------------------------------------------------------------------- -;;; Get Resource - -(defun get-resource (database value-name value-class full-name full-class) - ;; Return the value of the resource in DATABASE whose partial name - ;; most closely matches (append full-name (list value-name)) and - ;; (append full-class (list value-class)). - (declare (type resource-database database) - (type stringable value-name value-class) - (type (clx-list stringable) full-name full-class)) - (declare (clx-values value)) - (let ((names (append full-name (list value-name))) - (classes (append full-class (list value-class)))) - (let* ((result (get-entry (resource-database-tight database) - (resource-database-loose database) - names classes))) - (when result - (resource-database-value result))))) - -(defun get-entry-lookup (table name names classes) - (declare (type list table names classes) - (symbol name)) - (dolist (entry table) - (declare (type resource-database entry)) - (when (stringable-equal name (resource-database-name entry)) - (if (null (cdr names)) - (return entry) - (let ((result (get-entry (resource-database-tight entry) - (resource-database-loose entry) - (cdr names) (cdr classes)))) - (declare (type (or null resource-database) result)) - (when result - (return result) - )))))) - -(defun get-entry (tight loose names classes &aux result) - (declare (type list tight loose names classes)) - (let ((name (car names)) - (class (car classes))) - (declare (type symbol name class)) - (cond ((and tight - (get-entry-lookup tight name names classes))) - ((and loose - (get-entry-lookup loose name names classes))) - ((and tight - (not (stringable-equal name class)) - (get-entry-lookup tight class names classes))) - ((and loose - (not (stringable-equal name class)) - (get-entry-lookup loose class names classes))) - (loose - (loop - (pop names) (pop classes) - (unless (and names classes) (return nil)) - (setq name (car names) - class (car classes)) - (when (setq result (get-entry-lookup loose name names classes)) - (return result)) - (when (and (not (stringable-equal name class)) - (setq result - (get-entry-lookup loose class names classes))) - (return result)) - ))))) - - -;;;----------------------------------------------------------------------------- -;;; Get-resource with search-table - -(defun get-search-resource (table name class) - ;; (get-search-resource (get-search-table database full-name full-class) - ;; value-name value-class) - ;; is equivalent to - ;; (get-resource database value-name value-class full-name full-class) - ;; But since most of the work is done by get-search-table, - ;; get-search-resource is MUCH faster when getting several resources with - ;; the same full-name/full-class - (declare (type list table) - (type stringable name class)) - (let ((do-class (and class (not (stringable-equal name class))))) - (dolist (dbase-list table) - (declare (type list dbase-list)) - (dolist (dbase dbase-list) - (declare (type resource-database dbase)) - (when (stringable-equal name (resource-database-name dbase)) - (return-from get-search-resource - (resource-database-value dbase)))) - (when do-class - (dolist (dbase dbase-list) - (declare (type resource-database dbase)) - (when (stringable-equal class (resource-database-name dbase)) - (return-from get-search-resource - (resource-database-value dbase)))))))) - -(defvar *get-table-result*) - -(defun get-search-table (database full-name full-class) - ;; Return a search table for use with get-search-resource. - (declare (type resource-database database) - (type (clx-list stringable) full-name full-class)) - (declare (clx-values value)) - (let* ((tight (resource-database-tight database)) - (loose (resource-database-loose database)) - (result (cons nil nil)) - (*get-table-result* result)) - (declare (type list tight loose) - (type cons result)) - (when (or tight loose) - (when full-name - (get-tables tight loose full-name full-class)) - - ;; Pick up bindings of the form (* name). These are the elements of - ;; top-level loose without further tight/loose databases. - ;; - ;; (Hack: these bindings belong in ANY search table, so recomputing them - ;; is a drag. True fix involves redesigning entire lookup - ;; data-structure/algorithm.) - ;; - (let ((universal-bindings - (remove nil loose :test-not #'eq - :key #'(lambda (database) - (or (resource-database-tight database) - (resource-database-loose database)))))) - (when universal-bindings - (setf (cdr *get-table-result*) (list universal-bindings))))) - (cdr result))) - -(defun get-tables-lookup (dbase name names classes) - (declare (type list dbase names classes) - (type symbol name)) - (declare (optimize speed)) - (dolist (entry dbase) - (declare (type resource-database entry)) - (when (stringable-equal name (resource-database-name entry)) - (let ((tight (resource-database-tight entry)) - (loose (resource-database-loose entry))) - (declare (type list tight loose)) - (when (or tight loose) - (if (cdr names) - (get-tables tight loose (cdr names) (cdr classes)) - (when tight - (let ((result *get-table-result*)) - ;; Put tight at end of *get-table-result* - (setf (cdr result) - (setq *get-table-result* (cons tight nil)))))) - (when loose - (let ((result *get-table-result*)) - ;; Put loose at end of *get-table-result* - (setf (cdr result) - (setq *get-table-result* (cons loose nil)))))))))) - -(defun get-tables (tight loose names classes) - (declare (type list tight loose names classes)) - (let ((name (car names)) - (class (car classes))) - (declare (type symbol name class)) - (when tight - (get-tables-lookup tight name names classes)) - (when loose - (get-tables-lookup loose name names classes)) - (when (and tight (not (stringable-equal name class))) - (get-tables-lookup tight class names classes)) - (when (and loose (not (stringable-equal name class))) - (get-tables-lookup loose class names classes)) - (when loose - (loop - (pop names) (pop classes) - (unless (and names classes) (return nil)) - (setq name (car names) - class (car classes)) - (get-tables-lookup loose name names classes) - (unless (stringable-equal name class) - (get-tables-lookup loose class names classes)) - )))) - - -;;;----------------------------------------------------------------------------- -;;; Utility functions - -(defun map-resource (database function &rest args) - ;; Call FUNCTION on each resource in DATABASE. - ;; FUNCTION is called with arguments (name-list value . args) - (declare (type resource-database database) - (type (function (list t &rest t) t) function) - #+clx-ansi-common-lisp - (dynamic-extent function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg function) - (dynamic-extent args)) - (declare (clx-values nil)) - (labels ((map-resource-internal (database function args name) - (declare (type resource-database database) - (type (function (list t &rest t) t) function) - (type list name) - #+clx-ansi-common-lisp - (dynamic-extent function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg function)) - (let ((tight (resource-database-tight database)) - (loose (resource-database-loose database))) - (declare (type list tight loose)) - (dolist (resource tight) - (declare (type resource-database resource)) - (let ((value (resource-database-value resource)) - (name (append - name - (list (resource-database-name resource))))) - (if value - (apply function name value args) - (map-resource-internal resource function args name)))) - (dolist (resource loose) - (declare (type resource-database resource)) - (let ((value (resource-database-value resource)) - (name (append - name - (list "*" (resource-database-name resource))))) - (if value - (apply function name value args) - (map-resource-internal resource function args name))))))) - (map-resource-internal database function args nil))) - -(defun merge-resources (database with-database) - (declare (type resource-database database with-database)) - (declare (clx-values resource-database)) - (map-resource - database - #'(lambda (name value database) - (add-resource database name value)) - with-database) - with-database) - -(defun char-memq (key char) - ;; Used as a test function for POSITION - (declare (type base-char char)) - (member char key)) - -(defmacro resource-with-open-file ((stream pathname &rest options) &body body) - ;; Private WITH-OPEN-FILE, which, when pathname is a stream, uses it as the - ;; stream - (let ((abortp (gensym)) - (streamp (gensym))) - `(let* ((,abortp t) - (,streamp (streamp pathname)) - (,stream (if ,streamp pathname (open ,pathname ,@options)))) - (unwind-protect - (multiple-value-prog1 - (progn ,@body) - (setq ,abortp nil)) - (unless ,streamp - (close stream :abort ,abortp)))))) - -(defun read-resources (database pathname &key key test test-not) - ;; Merges resources from a file in standard X11 format with DATABASE. - ;; KEY is a function used for converting value-strings, the default is - ;; identity. TEST and TEST-NOT are predicates used for filtering - ;; which resources to include in the database. They are called with - ;; the name and results of the KEY function. - (declare (type resource-database database) - (type (or pathname string stream) pathname) - (type (or null (function (string) t)) key) - (type (or null (function (list t) generalized-boolean)) - test test-not)) - (declare (clx-values resource-database)) - (resource-with-open-file (stream pathname) - (loop - (let ((string (read-line stream nil :eof))) - (declare (type (or string keyword) string)) - (when (eq string :eof) (return database)) - (let* ((end (length string)) - (i (position '(#\tab #\space) string - :test-not #'char-memq :end end)) - (term nil)) - (declare (type array-index end) - (type (or null array-index) i term)) - (when i ;; else blank line - (case (char string i) - (#\! nil) ;; Comment - skip - ;;(#.(card8->char 0) nil) ;; terminator for C strings - skip - (#\# ;; Include - (setq term (position '(#\tab #\space) string :test #'char-memq - :start i :end end)) - (when (string-equal string "#INCLUDE" :start1 i :end1 term) - (let ((path (merge-pathnames - (string-trim '(#\tab #\space #\") - (subseq string (1+ term))) - (truename stream)))) - (read-resources database path - :key key :test test :test-not test-not)))) - (otherwise - (multiple-value-bind (name-list value) - (parse-resource string i end) - (when name-list - (when key (setq value (funcall key value))) - (when - (cond (test (funcall test name-list value)) - (test-not (not (funcall test-not name-list value))) - (t t)) - (add-resource database name-list value)))))))))))) - -(defun parse-resource (string &optional (start 0) end) - ;; Parse a resource specfication string into a list of names and a value - ;; string - (declare (type string string) - (type array-index start) - (type (or null array-index) end)) - (declare (clx-values name-list value)) - (do ((i start) - (end (or end (length string))) - (term) - (name-list)) - ((>= i end)) - (declare (type array-index end) - (type (or null array-index) i term)) - (setq term (position '(#\. #\* #\:) string - :test #'char-memq :start i :end end)) - (case (and term (char string term)) - ;; Name seperator - (#\. (when (> term i) - (push (subseq string i term) name-list))) - ;; Wildcard seperator - (#\* (when (> term i) - (push (subseq string i term) name-list)) - (push '* name-list)) - ;; Value separator - (#\: - (push (subseq string i term) name-list) - (return - (values - (nreverse name-list) - (string-trim '(#\tab #\space) (subseq string (1+ term)))))) - (otherwise - (return - (values - (nreverse name-list) - (subseq string i term))))) - (setq i (1+ term)))) - -(defun write-resources (database pathname &key write test test-not) - ;; Write resources to PATHNAME in the standard X11 format. - ;; WRITE is a function used for writing values, the default is #'princ - ;; TEST and TEST-NOT are predicates used for filtering which resources - ;; to include in the database. They are called with the name and value. - (declare (type resource-database database) - (type (or pathname string stream) pathname) - (type (or null (function (string stream) t)) write) - (type (or null (function (list t) generalized-boolean)) - test test-not)) - (resource-with-open-file (stream pathname :direction :output) - (map-resource - database - #'(lambda (name-list value stream write test test-not) - (when - (cond (test (funcall test name-list value)) - (test-not (not (funcall test-not name-list value))) - (t t)) - (let ((previous (car name-list))) - (princ previous stream) - (dolist (name (cdr name-list)) - (unless (or (stringable-equal name "*") - (stringable-equal previous "*")) - (write-char #\. stream)) - (setq previous name) - (princ name stream))) - (write-string ": " stream) - (funcall write value stream) - (terpri stream))) - stream (or write #'princ) test test-not)) - database) - -(defun wm-resources (database window &key key test test-not) - ;; Takes the resources associated with the RESOURCE_MANAGER property - ;; of WINDOW (if any) and merges them with DATABASE. - ;; KEY is a function used for converting value-strings, the default is - ;; identity. TEST and TEST-NOT are predicates used for filtering - ;; which resources to include in the database. They are called with - ;; the name and results of the KEY function. - (declare (type resource-database database) - (type window window) - (type (or null (function (string) t)) key) - (type (or null (function (list t) generalized-boolean)) - test test-not)) - (declare (clx-values resource-database)) - (let ((string (get-property window :RESOURCE_MANAGER :type :STRING - :result-type 'string - :transform #'xlib::card8->char))) - (when string - (with-input-from-string (stream string) - (read-resources database stream - :key key :test test :test-not test-not))))) - -(defun set-wm-resources (database window &key write test test-not) - ;; Sets the resources associated with the RESOURCE_MANAGER property - ;; of WINDOW. - ;; WRITE is a function used for writing values, the default is #'princ - ;; TEST and TEST-NOT are predicates used for filtering which resources - ;; to include in the database. They are called with the name and value. - (declare (type resource-database database) - (type window window) - (type (or null (function (string stream) t)) write) - (type (or null (function (list t) generalized-boolean)) - test test-not)) - (xlib::set-string-property - window :RESOURCE_MANAGER - (with-output-to-string (stream) - (write-resources database stream :write write - :test test :test-not test-not)))) - -(defun root-resources (screen &key database key test test-not) - "Returns a resource database containing the contents of the root window - RESOURCE_MANAGER property for the given SCREEN. If SCREEN is a display, - then its default screen is used. If an existing DATABASE is given, then - resource values are merged with the DATABASE and the modified DATABASE is - returned. - - TEST and TEST-NOT are predicates for selecting which resources are - read. Arguments are a resource name list and a resource value. The KEY - function, if given, is called to convert a resource value string to the - value given to TEST or TEST-NOT." - - (declare (type (or screen display) screen) - (type (or null resource-database) database) - (type (or null (function (string) t)) key) - (type (or null (function (list t) generalized-boolean)) test test-not) - (clx-values resource-database)) - (let* ((screen (if (type? screen 'display) - (display-default-screen screen) - screen)) - (window (screen-root screen)) - (database (or database (make-resource-database)))) - (wm-resources database window :key key :test test :test-not test-not) - database)) - -(defun set-root-resources (screen &key test test-not (write #'princ) database) - "Changes the contents of the root window RESOURCE_MANAGER property for the - given SCREEN. If SCREEN is a display, then its default screen is used. - - TEST and TEST-NOT are predicates for selecting which resources from the - DATABASE are written. Arguments are a resource name list and a resource - value. The WRITE function is used to convert a resource value into a - string stored in the property." - - (declare (type (or screen display) screen) - (type (or null resource-database) database) - (type (or null (function (list t) generalized-boolean)) test test-not) - (type (or null (function (string stream) t)) write) - (clx-values resource-database)) - (let* ((screen (if (type? screen 'display) - (display-default-screen screen) - screen)) - (window (screen-root screen))) - (set-wm-resources database window - :write write :test test :test-not test-not) - database)) - -(defsetf root-resources (screen &key test test-not (write #'princ))(database) - `(set-root-resources - ,screen :test ,test :test-not ,test-not :write ,write :database ,database)) - -(defun initialize-resource-database (display) - ;; This function is (supposed to be) equivalent to the Xlib initialization - ;; code. - (declare (type display display)) - (let ((rdb (make-resource-database)) - (rootwin (screen-root (car (display-roots display))))) - ;; First read the server defaults if present, otherwise from the default - ;; resource file - (if (get-property rootwin :RESOURCE_MANAGER) - (xlib:wm-resources rdb rootwin) - (let ((path (default-resources-pathname))) - (when (and path (probe-file path)) - (read-resources rdb path)))) - ;; Next read from the resources file - (let ((path (resources-pathname))) - (when (and path (probe-file path)) - (read-resources rdb path))) - (setf (display-xdefaults display) rdb))) diff -Nru ecl-16.1.2/src/clx/screensaver.lisp ecl-16.1.3+ds/src/clx/screensaver.lisp --- ecl-16.1.2/src/clx/screensaver.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/screensaver.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,69 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- -;;; --------------------------------------------------------------------------- -;;; Title: X11 MIT Screensaver extension -;;; Created: 2005-08-28 01:41 -;;; Author: Istvan Marko -;;; --------------------------------------------------------------------------- -;;; (c) copyright 2005 by Istvan Marko - -;;; -;;; Permission is granted to any individual or institution to use, -;;; copy, modify, and distribute this software, provided that this -;;; complete copyright and permission notice is maintained, intact, in -;;; all copies and supporting documentation. -;;; -;;; 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. -;;; - -;;; Description: -;;; -;;; This is a partial interface to the MIT-SCREEN-SAVER -;;; extension. Only the ScreenSaverQueryVersion and -;;; ScreenSaverQueryInfo requests are implemented because I couldn't -;;; think of a use for the rest. In fact, the only use I see for this -;;; extension is screen-saver-get-idle which provides and easy way to -;;; find out how long has it been since the last keyboard or mouse -;;; activity. - -;;; A description of this extension can be found at -;;; doc/hardcopy/saver/saver.PS.gz in the X11 distribution. - -(in-package :xlib) - -(export '(screen-saver-query-version - screen-saver-query-info - screen-saver-get-idle) - :xlib) - -(define-extension "MIT-SCREEN-SAVER") - -(defun screen-saver-query-version (display) - (with-buffer-request-and-reply (display (extension-opcode display "MIT-SCREEN-SAVER") - nil) - ((data 0) - (card8 1) ;client major version - (card8 0) ;client minor version - (card16 0)) ; unused - (values - (card16-get 8) ; server major version - (card16-get 10)))) ; server minor version - -(defun screen-saver-query-info (display drawable) - (with-buffer-request-and-reply (display (extension-opcode display "MIT-SCREEN-SAVER") - nil) - ((data 1) - (drawable drawable)) - (values - (card8-get 1) ; state: off, on, disabled - (window-get 8) ; screen saver window if active - (card32-get 12) ; tilorsince msecs. how soon before the screen saver kicks in or how long has it been active - (card32-get 16) ; idle msecs - (card8-get 24)))) ; kind: Blanked, Internal, External - -(defun screen-saver-get-idle (display drawable) - "How long has it been since the last keyboard or mouse input" - (multiple-value-bind (state window tilorsince idle kind) (screen-saver-query-info display drawable) - (declare (ignore state window kind)) - (values idle tilorsince))) diff -Nru ecl-16.1.2/src/clx/shape.lisp ecl-16.1.3+ds/src/clx/shape.lisp --- ecl-16.1.2/src/clx/shape.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/shape.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,192 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- -;;; --------------------------------------------------------------------------- -;;; Title: X11 Shape extension -;;; Created: 1999-05-14 11:31 -;;; Author: Gilbert Baumann -;;; --------------------------------------------------------------------------- -;;; (c) copyright 1999 by Gilbert Baumann - -;;; -;;; Permission is granted to any individual or institution to use, -;;; copy, modify, and distribute this software, provided that this -;;; complete copyright and permission notice is maintained, intact, in -;;; all copies and supporting documentation. -;;; -;;; 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. -;;; - -;;; Use xc/doc/hardcopy/Xext/shape.PS.gz obtainable from e.g. -;; ftp://ftp.xfree86.org/pub/XFree86/current/untarred/xc/hardcopy/Xext/shape.PS.gz - -(in-package :xlib) - -(export '(shape-query-version - shape-rectangles - shape-mask - shape-combine - shape-offset - shape-query-extents - shape-select-input - shape-input-selected-p - shape-get-rectangles) - :xlib) - -(define-extension "SHAPE" - :events (:shape-notify)) - -(declare-event :shape-notify - ((data (member8 :bounding :clip)) kind) ;shape kind - (card16 sequence) - (window (window event-window)) ;affected window - (int16 x) ;extents - (int16 y) - (card16 width) - (card16 height) - ((or null card32) time) ;timestamp - (boolean shaped-p)) - -(defun encode-shape-kind (kind) - (ecase kind - (:bounding 0) - (:clip 1))) - -(defun encode-shape-operation (operation) - (ecase operation - (:set 0) - (:union 1) - (:interset 2) - (:subtract 3) - (:invert 4))) - -(defun encode-shape-rectangle-ordering (ordering) - (ecase ordering - ((:unsorted :un-sorted nil) 0) - ((:y-sorted) 1) - ((:yx-sorted) 2) - ((:yx-banded) 3))) - -(defun shape-query-version (display) - (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") - nil :sizes 16) - ((data 0)) - (values - (card16-get 8) - (card16-get 10)))) - -(defun shape-rectangles (window rectangles - &key (kind :bounding) - (x-offset 0) - (y-offset 0) - (operation :set) - (ordering :unsorted)) - (let* ((display (xlib:window-display window))) - (with-buffer-request (display (extension-opcode display "SHAPE")) - (data 1) - (card8 (encode-shape-operation operation)) - (card8 (encode-shape-kind kind)) - (card8 (encode-shape-rectangle-ordering ordering)) - (card8 0) ;unused - (window window) - (int16 x-offset) - (int16 y-offset) - ((sequence :format int16) rectangles)))) - -(defun shape-mask (window pixmap - &key (kind :bounding) - (x-offset 0) - (y-offset 0) - (operation :set)) - (let* ((display (xlib:window-display window))) - (with-buffer-request (display (extension-opcode display "SHAPE")) - (data 2) - (card8 (encode-shape-operation operation)) - (card8 (encode-shape-kind kind)) - (card16 0) ;unused - (window window) - (int16 x-offset) - (int16 y-offset) - ((or pixmap (member :none)) pixmap)))) - -(defun shape-combine (window source-window - &key (kind :bounding) - (source-kind :bounding) - (x-offset 0) - (y-offset 0) - (operation :set)) - (let* ((display (xlib:window-display window))) - (with-buffer-request (display (extension-opcode display "SHAPE")) - (data 3) - (card8 (encode-shape-operation operation)) - (card8 (encode-shape-kind kind)) - (card8 (encode-shape-kind source-kind)) - (card8 0) ;unused - (window window) - (int16 x-offset) - (int16 y-offset) - (window source-window)))) - -(defun shape-offset (window &key (kind :bounding) (x-offset 0) (y-offset 0)) - (let* ((display (xlib:window-display window))) - (with-buffer-request (display (extension-opcode display "SHAPE")) - (data 4) - (card8 (encode-shape-kind kind)) - (card8 0) (card8 0) (card8 0) ;unused - (window window) - (int16 x-offset) - (int16 y-offset)))) - -(defun shape-query-extents (window) - (let* ((display (xlib:window-display window))) - (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") - nil :sizes (8 16 32)) - ((data 5) - (window window)) - (values - (boolean-get 8) ;bounding shaped - (boolean-get 9) ;clip shaped - (int16-get 12) ;bounding shape extents x - (int16-get 14) ;bounding shape extents y - (card16-get 16) ;bounding shape extents width - (card16-get 18) ;bounding shape extents height - (int16-get 20) ;clip shape extents x - (int16-get 22) ;clip shape extents y - (card16-get 24) ;clip shape extents width - (card16-get 26))))) ;clip shape extents height - -(defun shape-select-input (window selected-p) - (let* ((display (window-display window))) - (with-buffer-request (display (extension-opcode display "SHAPE")) - (data 6) - (window window) - (boolean selected-p)) )) - -(defun shape-input-selected-p (window) - (let* ((display (window-display window))) - (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") - nil :sizes (8)) - ((data 7) ;also wrong in documentation - (window window)) - (boolean-get 1)))) - -(defun shape-get-rectangles (window &optional (kind :bounding) - (result-type 'list)) - (let* ((display (window-display window))) - (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") - nil :sizes (8 16 32)) - ((data 8) ;this was wrong in the specification - (window window) - (card8 (ecase kind - (:bounding 0) - (:clip 1)))) - (values - (sequence-get :length (print (* 4 (card32-get 8))) - :result-type result-type - :format int16 - :index +replysize+) - (ecase (card8-get 1) - (0 :unsorted) - (1 :y-sorted) - (2 :yx-sorted) - (3 :yx-banded) ))))) diff -Nru ecl-16.1.2/src/clx/sockcl.lisp ecl-16.1.3+ds/src/clx/sockcl.lisp --- ecl-16.1.2/src/clx/sockcl.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/sockcl.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,163 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;;; Server Connection for kcl and ibcl - -;;; Copyright (C) 1987, 1989 Massachussetts Institute of Technology -;;; -;;; Permission is granted to any individual or institution to use, copy, -;;; modify, and distribute this software, provided that this complete -;;; copyright and permission notice is maintained, intact, in all copies and -;;; supporting documentation. -;;; -;;; Massachussetts Institute of Technology provides this software "as is" -;;; without express or implied warranty. -;;; - -;;; Adapted from code by Roman Budzianowski - Project Athena/MIT - -;;; make-two-way-stream is probably not a reasonable thing to do. -;;; A close on a two way stream probably does not close the substreams. -;;; I presume an :io will not work (maybe because it uses 1 buffer?). -;;; There should be some fast io (writes and reads...). - -;;; Compile this file with compile-file. -;;; Load it with (si:faslink "sockcl.o" "socket.o -lc") - -(in-package :xlib) - -;;; The cmpinclude.h file does not have this type definition from -;;; /h/object.h. We include it here so the -;;; compile-file will work without figuring out where the distribution -;;; directory is located. -;;; -(CLINES " -enum smmode { /* stream mode */ - smm_input, /* input */ - smm_output, /* output */ - smm_io, /* input-output */ - smm_probe, /* probe */ - smm_synonym, /* synonym */ - smm_broadcast, /* broadcast */ - smm_concatenated, /* concatenated */ - smm_two_way, /* two way */ - smm_echo, /* echo */ - smm_string_input, /* string input */ - smm_string_output, /* string output */ - smm_user_defined /* for user defined */ -}; -") - -#-akcl -(CLINES " -struct stream { - short t, m; - FILE *sm_fp; /* file pointer */ - object sm_object0; /* some object */ - object sm_object1; /* some object */ - int sm_int0; /* some int */ - int sm_int1; /* some int */ - short sm_mode; /* stream mode */ - /* of enum smmode */ -}; -") - - -;;;; Connect to the server. - -;;; A lisp string is not a reasonable type for C, so copy the characters -;;; out and then call connect_to_server routine defined in socket.o - -(CLINES " -int -konnect_to_server(host,display) - object host; /* host name */ - int display; /* display number */ -{ - int fd; /* file descriptor */ - int i; - char hname[BUFSIZ]; - FILE *fout, *fin; - - if (host->st.st_fillp > BUFSIZ - 1) - too_long_file_name(host); - for (i = 0; i < host->st.st_fillp; i++) - hname[i] = host->st.st_self[i]; - hname[i] = '\\0'; /* doubled backslash for lisp */ - - fd = connect_to_server(hname,display); - - return(fd); -} -") - -(defentry konnect-to-server (object int) (int "konnect_to_server")) - - -;;;; Make a one-way stream from a file descriptor. - -(CLINES " -object -konnect_stream(host,fd,flag,elem) - object host; /* not really used */ - int fd; /* file descriptor */ - int flag; /* 0 input, 1 output */ - object elem; /* 'string-char */ -{ - struct stream *stream; - char *mode; /* file open mode */ - FILE *fp; /* file pointer */ - enum smmode smm; /* lisp mode (a short) */ - vs_mark; - - switch(flag){ - case 0: - smm = smm_input; - mode = \"r\"; - break; - case 1: - smm = smm_output; - mode = \"w\"; - break; - default: - FEerror(\"konnect_stream : wrong mode\"); - } - - fp = fdopen(fd,mode); - - if (fp == NULL) { - stream = Cnil; - vs_push(stream); - } else { - stream = alloc_object(t_stream); - stream->sm_mode = (short)smm; - stream->sm_fp = fp; - stream->sm_object0 = elem; - stream->sm_object1 = host; - stream->sm_int0 = stream->sm.sm_int1 = 0; - vs_push(stream); - setbuf(fp, alloc_contblock(BUFSIZ)); - } - vs_reset; - return(stream); -} -") - -(defentry konnect-stream (object int int object) (object "konnect_stream")) - - -;;;; Open an X stream - -(defun open-socket-stream (host display) - (when (not (and (typep host 'string) ; sanity check the arguments - (typep display 'fixnum))) - (error "Host ~s or display ~s are bad." host display)) - - (let ((fd (konnect-to-server host display))) ; get a file discriptor - (if (< fd 0) - NIL - (let ((stream-in (konnect-stream host fd 0 'string-char)) ; input - (stream-out (konnect-stream host fd 1 'string-char))) ; output - (if (or (null stream-in) (null stream-out)) - (error "Could not make i/o streams for fd ~d." fd)) - (make-two-way-stream stream-in stream-out)) - ))) diff -Nru ecl-16.1.2/src/clx/socket.c ecl-16.1.3+ds/src/clx/socket.c --- ecl-16.1.2/src/clx/socket.c 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/socket.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,156 +0,0 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ - -/* Copyright Massachusetts Institute of Technology 1988 */ -/* - * THIS IS AN OS DEPENDENT FILE! It should work on 4.2BSD derived - * systems. VMS and System V should plan to have their own version. - * - * This code was cribbed from lib/X/XConnDis.c. - * Compile using - * % cc -c socket.c -DUNIXCONN - */ - -#include -#include -#include -#include -#include -#include -#include -#include -#ifndef hpux -#include -#endif - -extern int errno; /* Certain (broken) OS's don't have this */ - /* decl in errno.h */ - -#ifdef UNIXCONN -#include -#ifndef X_UNIX_PATH -#ifdef hpux -#define X_UNIX_PATH "/usr/spool/sockets/X11/" -#define OLD_UNIX_PATH "/tmp/.X11-unix/X" -#else /* hpux */ -#define X_UNIX_PATH "/tmp/.X11-unix/X" -#endif /* hpux */ -#endif /* X_UNIX_PATH */ -#endif /* UNIXCONN */ - -#ifndef hpux -void bcopy(); -#endif /* hpux */ - -/* - * Attempts to connect to server, given host and display. Returns file - * descriptor (network socket) or 0 if connection fails. - */ - -int connect_to_server (host, display) - char *host; - int display; -{ - struct sockaddr_in inaddr; /* INET socket address. */ - struct sockaddr *addr; /* address to connect to */ - struct hostent *host_ptr; - int addrlen; /* length of address */ -#ifdef UNIXCONN - struct sockaddr_un unaddr; /* UNIX socket address. */ -#endif - extern char *getenv(); - extern struct hostent *gethostbyname(); - int fd; /* Network socket */ - { -#ifdef UNIXCONN - if ((host[0] == '\0') || (strcmp("unix", host) == 0)) { - /* Connect locally using Unix domain. */ - unaddr.sun_family = AF_UNIX; - (void) strcpy(unaddr.sun_path, X_UNIX_PATH); - (void) sprintf(&unaddr.sun_path[strlen(unaddr.sun_path)], "%d", display); - addr = (struct sockaddr *) &unaddr; - addrlen = strlen(unaddr.sun_path) + 2; - /* - * Open the network connection. - */ - if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0) { -#ifdef hpux /* this is disgusting */ /* cribbed from X11R4 xlib source */ - if (errno == ENOENT) { /* No such file or directory */ - (void) sprintf(unaddr.sun_path, "%s%d", OLD_UNIX_PATH, display); - addrlen = strlen(unaddr.sun_path) + 2; - if ((fd = socket ((int) addr->sa_family, SOCK_STREAM, 0)) < 0) - return(-1); /* errno set by most recent system call. */ - } else -#endif /* hpux */ - return(-1); /* errno set by system call. */ - } - } else -#endif /* UNIXCONN */ - { - /* Get the statistics on the specified host. */ - if ((inaddr.sin_addr.s_addr = inet_addr(host)) == -1) - { - if ((host_ptr = gethostbyname(host)) == NULL) - { - /* No such host! */ - errno = EINVAL; - return(-1); - } - /* Check the address type for an internet host. */ - if (host_ptr->h_addrtype != AF_INET) - { - /* Not an Internet host! */ - errno = EPROTOTYPE; - return(-1); - } - /* Set up the socket data. */ - inaddr.sin_family = host_ptr->h_addrtype; -#ifdef hpux - (void) memcpy((char *)&inaddr.sin_addr, - (char *)host_ptr->h_addr, - sizeof(inaddr.sin_addr)); -#else /* hpux */ - (void) bcopy((char *)host_ptr->h_addr, - (char *)&inaddr.sin_addr, - sizeof(inaddr.sin_addr)); -#endif /* hpux */ - } - else - { - inaddr.sin_family = AF_INET; - } - addr = (struct sockaddr *) &inaddr; - addrlen = sizeof (struct sockaddr_in); - inaddr.sin_port = display + X_TCP_PORT; - inaddr.sin_port = htons(inaddr.sin_port); - /* - * Open the network connection. - */ - if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0){ - return(-1); /* errno set by system call. */} - /* make sure to turn off TCP coalescence */ -#ifdef TCP_NODELAY - { - int mi = 1; - setsockopt (fd, IPPROTO_TCP, TCP_NODELAY, &mi, sizeof (int)); - } -#endif - } - - /* - * Changed 9/89 to retry connection if system call was interrupted. This - * is necessary for multiprocessing implementations that use timers, - * since the timer results in a SIGALRM. -- jdi - */ - while (connect(fd, addr, addrlen) == -1) { - if (errno != EINTR) { - (void) close (fd); - return(-1); /* errno set by system call. */ - } - } - } - /* - * Return the id if the connection succeeded. - */ - return(fd); -} diff -Nru ecl-16.1.2/src/clx/test/.cvsignore ecl-16.1.3+ds/src/clx/test/.cvsignore --- ecl-16.1.2/src/clx/test/.cvsignore 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/test/.cvsignore 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -*.fasl diff -Nru ecl-16.1.2/src/clx/test/image.lisp ecl-16.1.3+ds/src/clx/test/image.lisp --- ecl-16.1.2/src/clx/test/image.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/test/image.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,160 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- - -;;; Tests image code by randomly reading, copying and then writing images to -;;; the exact same place on the screen. If everything works, just the borders -;;; of the image windows appear. If one of these image windows is garbled, -;;; then somewhere something is broken. Entry point is the function -;;; IMAGE-TEST - -(in-package :xlib) - -(export '(image-test)) - -(defvar *image-test-host* "") - -(defvar *image-test-nimages* 25) - -(defvar *image-test-copy* t) - -(defvar *image-test-copy-random-subimage* t) - -(defvar *image-test-put-random-subimage* t) - -(defvar *image-test-get-image-result-type-choices* - '(image-x image-x image-xy image-z)) - -(defvar *image-test-get-image-image-x-format-choices* - '(:xy-pixmap :z-pixmap)) - -(defun image-test - (&key - (host *image-test-host*) - (nimages *image-test-nimages*) - (copy *image-test-copy*) - (copy-random-subimage *image-test-copy-random-subimage*) - (put-random-subimage *image-test-put-random-subimage*) - (get-image-result-type-choices - *image-test-get-image-result-type-choices*) - (get-image-image-x-format-choices - *image-test-get-image-image-x-format-choices*)) - (declare (ignore host)) - (let* ((display nil) - (abort t) - (images nil)) - (loop - (setq images nil) - (unwind-protect - (progn - (setq display (open-default-display)) - (let* ((screen (display-default-screen display)) - (window (screen-root screen)) - (gcontext (create-gcontext - :foreground (screen-white-pixel screen) - :background (screen-black-pixel screen) - :drawable window - :font (open-font display "fixed")))) - (dotimes (i nimages) - (let ((image (image-test-get-image - window - get-image-result-type-choices - get-image-image-x-format-choices))) - (format t "~&Image=~S~%" image) - (let ((copy (if copy - (image-test-copy-image - image - copy-random-subimage) - image))) - (format t "~&Copy=~S~%" copy) - (push (list image copy) images) - (image-test-put-image - screen gcontext copy - (concatenate - 'string (image-info image) (image-info copy)) - put-random-subimage)))) - (unless (y-or-n-p "More ") (return)) - (setq abort nil))) - (close-display (shiftf display nil) :abort abort)) - (sleep 10)) - (reverse images))) - -(defun image-test-choose (list) - (nth (random (length list)) list)) - -(defun image-test-get-image (window result-type-choices image-x-format-choices) - (let* ((x (random (floor (drawable-width window) 3))) - (y (random (floor (drawable-height window) 3))) - (hw (floor (- (drawable-width window) x) 3)) - (hh (floor (- (drawable-height window) y) 3)) - (width (+ hw hw (random hw))) - (height (+ hh hh (random hh))) - (result-type (image-test-choose result-type-choices)) - (format - (ecase result-type - (image-x (image-test-choose image-x-format-choices)) - (image-xy :xy-pixmap) - (image-z :z-pixmap))) - (image (get-image window :x x :y y :width width :height height - :format format :result-type result-type))) - (setf (getf (image-plist image) :root-x) x) - (setf (getf (image-plist image) :root-y) y) - image)) - -(defun image-test-subimage-parameters (image random-subimage-p) - (if random-subimage-p - (let* ((x (random (floor (image-width image) 3))) - (y (random (floor (image-height image) 3))) - (hw (floor (- (image-width image) x) 3)) - (hh (floor (- (image-height image) y) 3)) - (width (+ hw hw (random hw))) - (height (+ hh hh (random hh)))) - (values x y width height)) - (values 0 0 (image-width image) (image-height image)))) - -(defun image-test-copy-image (image random-subimage-p) - (let ((result-type - (if (zerop (random 2)) - (type-of image) - (etypecase image - (image-x (ecase (image-x-format image) - (:xy-pixmap 'image-xy) - (:z-pixmap 'image-z))) - ((or image-xy image-z) 'image-x))))) - (multiple-value-bind (x y width height) - (image-test-subimage-parameters image random-subimage-p) - (incf (getf (image-plist image) :root-x) x) - (incf (getf (image-plist image) :root-y) y) - (copy-image image :x x :y y :width width :height height - :result-type result-type)))) - -(defun image-test-put-image (screen gcontext image info random-subimage-p) - (multiple-value-bind (src-x src-y width height) - (image-test-subimage-parameters image random-subimage-p) - (let* ((border-width 1) - (root-x (getf (image-plist image) :root-x)) - (root-y (getf (image-plist image) :root-y)) - (x (+ src-x root-x (- border-width))) - (y (+ src-y root-y (- border-width)))) - (unless (or (zerop width) (zerop height)) - (let ((window - (create-window - :parent (screen-root screen) :x x :y y - :width width :height height - :border-width border-width - :background (screen-white-pixel screen) - :override-redirect :on))) - (map-window window) - (display-finish-output (drawable-display window)) - (put-image window gcontext image - :x 0 :y 0 :src-x src-x :src-y src-y - :width width :height height) - (draw-image-glyphs window gcontext 0 (1- height) info) - (display-finish-output (drawable-display window)) - window))))) - -(defun image-info (image) - (etypecase image - (image-x (ecase (image-x-format image) - (:xy-pixmap "XXY") - (:z-pixmap "XZ "))) - (image-xy "XY ") - (image-z "Z "))) diff -Nru ecl-16.1.2/src/clx/test/trapezoid.lisp ecl-16.1.3+ds/src/clx/test/trapezoid.lisp --- ecl-16.1.2/src/clx/test/trapezoid.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/test/trapezoid.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,72 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- - -;;; CLX trapezoid Extension test program - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - - -(defun zoid-test () - ;; Display the part picture in /extensions/test/datafile - (let* ((display (open-default-display)) - (width 400) - (height 400) - (screen (display-default-screen display)) - (black (screen-black-pixel screen)) - (white (screen-white-pixel screen)) - (win (create-window - :parent (screen-root screen) - :background black - :border white - :border-width 1 - :colormap (screen-default-colormap screen) - :bit-gravity :center - :event-mask '(:exposure :key-press) - :x 20 :y 20 - :width width :height height)) - (gc (create-gcontext - :drawable win - :background black - :foreground white))) - (initialize-extensions display) - - (map-window win) ; Map the window - ;; Handle events - (unwind-protect - (loop - (event-case (display :force-output-p t) - (exposure ;; Come here on exposure events - (window count) - (when (zerop count) ;; Ignore all but the last exposure event - (clear-area window) - ;; NOT VERY INTERESTING, BUT CHECKS ALL THE POSSIBILITIES - (draw-filled-trapezoids window gc '(10 20 30 40 100 200)) - (setf (gcontext-trapezoid-alignment gc) :y) - (draw-filled-trapezoids window gc #(10 20 30 40 100 200)) - (with-gcontext (gc :trapezoid-alignment :x) - (draw-filled-trapezoids window gc '(40 50 60 70 140 240))) - (setf (gcontext-trapezoid-alignment gc) :x) - (draw-filled-trapezoids window gc #(40 50 60 70 80 90)) - (with-gcontext (gc :trapezoid-alignment :y) - (draw-filled-trapezoids window gc #(40 50 60 70 140 240))) - - (draw-glyphs window gc 10 10 "Press any key to exit") - ;; Returning non-nil causes event-case to exit - t)) - (key-press () (return-from zoid-test t)))) - (close-display display)))) diff -Nru ecl-16.1.2/src/clx/text.lisp ecl-16.1.3+ds/src/clx/text.lisp --- ecl-16.1.2/src/clx/text.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/text.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,1084 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; CLX text keyboard and pointer requests - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -;; Strings are broken up into chunks of this size -(defparameter *max-string-size* 254) - -;; In the functions below, the transform is used to convert an element of the -;; sequence into a font index. The transform is applied to each element of the -;; (sub)sequence, until either the transform returns nil or the end of the -;; (sub)sequence is reached. If transform returns nil for an element, the -;; index of that element in the sequence is returned, otherwise nil is -;; returned. - -(deftype translation-function () - #+explorer t - #-explorer - '(function (sequence array-index array-index (or null font) vector array-index) - (values array-index (or null int16 font) (or null int32)))) - -;; In the functions below, if width is specified, it is assumed to be the pixel -;; width of whatever string of glyphs is actually drawn. Specifying width will -;; allow for appending the output of subsequent calls to the same protocol -;; request, provided gcontext has not been modified in the interim. If width -;; is not specified, appending of subsequent output might not occur. -;; Specifying width is simply a hint, for performance. Note that specifying -;; width may be difficult if transform can return nil. - -(defun translate-default (src src-start src-end font dst dst-start) - ;; dst is guaranteed to have room for (- src-end src-start) integer elements, - ;; starting at dst-start; whether dst holds 8-bit or 16-bit elements depends - ;; on context. font is the current font, if known. The function should - ;; translate as many elements of src as possible into indexes in the current - ;; font, and store them into dst. - ;; - ;; The first return value should be the src index of the first untranslated - ;; element. If no further elements need to be translated, the second return - ;; value should be nil. If a horizontal motion is required before further - ;; translation, the second return value should be the delta in x coordinate. - ;; If a font change is required for further translation, the second return - ;; value should be the new font. If known, the pixel width of the translated - ;; text can be returned as the third value; this can allow for appending of - ;; subsequent output to the same protocol request, if no overall width has - ;; been specified at the higher level. - ;; (returns values: ending-index - ;; (OR null horizontal-motion font) - ;; (OR null translated-width)) - (declare (type sequence src) - (type array-index src-start src-end dst-start) - (type (or null font) font) - (type vector dst) - (inline graphic-char-p)) - (declare (clx-values integer (or null integer font) (or null integer))) - - (let ((min-char-index (and font (xlib:font-min-char font))) - (max-char-index (and font (xlib:font-max-char font)))) - (if (stringp src) - (do ((i src-start (index+ i 1)) - (j dst-start (index+ j 1)) - (char)) - ((index>= i src-end) - i) - (declare (type array-index i j)) - (setf char (char->card8 (char src i))) - (if (and font (or (< char min-char-index) (> char max-char-index))) - (return i) - (setf (aref dst j) char))) - (do ((i src-start (index+ i 1)) - (j dst-start (index+ j 1)) - (elt)) - ((index>= i src-end) - i) - (declare (type array-index i j)) - (setq elt (elt src i)) - (when (characterp elt) (setq elt (char->card8 elt))) - (if (or (not (integerp elt)) - (and font - (< elt min-char-index) - (> elt max-char-index))) - (return i) - (setf (aref dst j) elt)))))) - -;; There is a question below of whether translate should always be required, or -;; if not, what the default should be or where it should come from. For -;; example, the default could be something that expected a string as src and -;; translated the CL standard character set to ASCII indexes, and ignored fonts -;; and bits. Or the default could expect a string but otherwise be "system -;; dependent". Or the default could be something that expected a vector of -;; integers and did no translation. Or the default could come from the -;; gcontext (but what about text-extents and text-width?). - -(defun text-extents (font sequence &key (start 0) end translate) - ;; If multiple fonts are involved, font-ascent and font-descent will be the - ;; maximums. If multiple directions are involved, the direction will be nil. - ;; Translate will always be called with a 16-bit dst buffer. - (declare (type sequence sequence) - (type (or font gcontext) font)) - (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) - (declare (clx-values width ascent descent left right - font-ascent font-descent direction - (or null array-index))) - (when (type? font 'gcontext) - (force-gcontext-changes font) - (setq font (gcontext-font font t))) - (check-type font font) - (let* ((left-bearing 0) - (right-bearing 0) - ;; Sum of widths - (width 0) - (ascent 0) - (descent 0) - (overall-ascent (font-ascent font)) - (overall-descent (font-descent font)) - (overall-direction (font-direction font)) - (next-start nil) - (display (font-display font))) - (declare (type int16 ascent descent overall-ascent overall-descent) - (type int32 left-bearing right-bearing width) - (type (or null array-index) next-start) - (type display display)) - (with-display (display) - (do* ((wbuf (display-tbuf16 display)) - (src-end (or end (length sequence))) - (src-start start (index+ src-start buf-end)) - (end (index-min src-end (index+ src-start +buffer-text16-size+)) - (index-min src-end (index+ src-start +buffer-text16-size+))) - (buf-end 0) - (new-font) - (font-ascent 0) - (font-descent 0) - (font-direction) - (stop-p nil)) - ((or stop-p (index>= src-start src-end)) - (when (index< src-start src-end) - (setq next-start src-start))) - (declare (type buffer-text16 wbuf) - (type array-index src-start src-end end buf-end) - (type int16 font-ascent font-descent) - (type generalized-boolean stop-p)) - ;; Translate the text - (multiple-value-setq (buf-end new-font) - (funcall (or translate #'translate-default) - sequence src-start end font wbuf 0)) - (setq buf-end (- buf-end src-start)) - (cond ((null new-font) (setq stop-p t)) - ((integerp new-font) (incf width (the int32 new-font)))) - - (let (w a d l r) - (if (or (font-char-infos-internal font) (font-local-only-p font)) - ;; Calculate text extents locally - (progn - (multiple-value-setq (w a d l r) - (text-extents-local font wbuf 0 buf-end nil)) - (setq font-ascent (the int16 (font-ascent font)) - font-descent (the int16 (font-descent font)) - font-direction (font-direction font))) - ;; Let the server calculate text extents - (multiple-value-setq - (w a d l r font-ascent font-descent font-direction) - (text-extents-server font wbuf 0 buf-end))) - (incf width (the int32 w)) - (cond ((index= src-start start) - (setq left-bearing (the int32 l)) - (setq right-bearing (the int32 r)) - (setq ascent (the int16 a)) - (setq descent (the int16 d))) - (t - (setq left-bearing (the int32 (min left-bearing (the int32 l)))) - (setq right-bearing (the int32 (max right-bearing (the int32 r)))) - (setq ascent (the int16 (max ascent (the int16 a)))) - (setq descent (the int16 (max descent (the int16 d))))))) - - (when (type? new-font 'font) - (setq font new-font)) - - (setq overall-ascent (the int16 (max overall-ascent font-ascent))) - (setq overall-descent (the int16 (max overall-descent font-descent))) - (case overall-direction - (:unknown (setq overall-direction font-direction)) - (:left-to-right (unless (eq font-direction :left-to-right) - (setq overall-direction nil))) - (:right-to-left (unless (eq font-direction :right-to-left) - (setq overall-direction nil)))))) - - (values width - ascent - descent - left-bearing - right-bearing - overall-ascent - overall-descent - overall-direction - next-start))) - -(defun text-width (font sequence &key (start 0) end translate) - ;; Translate will always be called with a 16-bit dst buffer. - (declare (type sequence sequence) - (type (or font gcontext) font) - (type array-index start) - (type (or null array-index) end)) - (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) - (declare (clx-values integer (or null integer))) - (when (type? font 'gcontext) - (force-gcontext-changes font) - (setq font (gcontext-font font t))) - (check-type font font) - (let* ((width 0) - (next-start nil) - (display (font-display font))) - (declare (type int32 width) - (type (or null array-index) next-start) - (type display display)) - (with-display (display) - (do* ((wbuf (display-tbuf16 display)) - (src-end (or end (length sequence))) - (src-start start (index+ src-start buf-end)) - (end (index-min src-end (index+ src-start +buffer-text16-size+)) - (index-min src-end (index+ src-start +buffer-text16-size+))) - (buf-end 0) - (new-font) - (stop-p nil)) - ((or stop-p (index>= src-start src-end)) - (when (index< src-start src-end) - (setq next-start src-start))) - (declare (type buffer-text16 wbuf) - (type array-index src-start src-end end buf-end) - (type generalized-boolean stop-p)) - ;; Translate the text - (multiple-value-setq (buf-end new-font) - (funcall (or translate #'translate-default) - sequence src-start end font wbuf 0)) - (setq buf-end (- buf-end src-start)) - (cond ((null new-font) (setq stop-p t)) - ((integerp new-font) (incf width (the int32 new-font)))) - - (incf width - (if (or (font-char-infos-internal font) (font-local-only-p font)) - (text-extents-local font wbuf 0 buf-end :width-only) - (text-width-server font wbuf 0 buf-end))) - (when (type? new-font 'font) - (setq font new-font)))) - (values width next-start))) - -(defun text-extents-server (font sequence start end) - (declare (type font font) - (type sequence sequence) - (type array-index start end)) - (declare (clx-values width ascent descent left right font-ascent font-descent direction)) - (let ((display (font-display font)) - (length (index- end start)) - (font-id (font-id font))) - (declare (type display display) - (type array-index length) - (type resource-id font-id)) - (with-buffer-request-and-reply (display +x-querytextextents+ 28 :sizes (8 16 32)) - (((data boolean) (oddp length)) - (length (index+ (index-ceiling length 2) 2)) - (resource-id font-id) - ((sequence :format char2b :start start :end end :appending t) - sequence)) - (values - (integer-get 16) - (int16-get 12) - (int16-get 14) - (integer-get 20) - (integer-get 24) - (int16-get 8) - (int16-get 10) - (member8-get 1 :left-to-right :right-to-left))))) - -(defun text-width-server (font sequence start end) - (declare (type (or font gcontext) font) - (type sequence sequence) - (type array-index start end)) - (declare (clx-values integer)) - (let ((display (font-display font)) - (length (index- end start)) - (font-id (font-id font))) - (declare (type display display) - (type array-index length) - (type resource-id font-id)) - (with-buffer-request-and-reply (display +x-querytextextents+ 28 :sizes 32) - (((data boolean) (oddp length)) - (length (index+ (index-ceiling length 2) 2)) - (resource-id font-id) - ((sequence :format char2b :start start :end end :appending t) - sequence)) - (values (integer-get 16))))) - -(defun text-extents-local (font sequence start end width-only-p) - (declare (type font font) - (type sequence sequence) - (type integer start end) - (type generalized-boolean width-only-p)) - (declare (clx-values width ascent descent overall-left overall-right)) - (let* ((char-infos (font-char-infos font)) - (font-info (font-font-info font))) - (declare (type font-info font-info)) - (declare (type (simple-array int16 (*)) char-infos)) - (if (zerop (length char-infos)) - ;; Fixed width font - (let* ((font-width (max-char-width font)) - (font-ascent (max-char-ascent font)) - (font-descent (max-char-descent font)) - (width (* (index- end start) font-width))) - (declare (type int16 font-width font-ascent font-descent) - (type int32 width)) - (if width-only-p - width - (values width - font-ascent - font-descent - (max-char-left-bearing font) - (+ width (- font-width) (max-char-right-bearing font))))) - - ;; Variable-width font - (let* ((first-col (font-info-min-byte2 font-info)) - (num-cols (1+ (- (font-info-max-byte2 font-info) first-col))) - (first-row (font-info-min-byte1 font-info)) - (last-row (font-info-max-byte1 font-info)) - (num-rows (1+ (- last-row first-row)))) - (declare (type card8 first-col first-row last-row) - (type card16 num-cols num-rows)) - (if (or (plusp first-row) (plusp last-row)) - - ;; Matrix (16 bit) font - (macrolet ((char-info-elt (sequence elt) - `(let* ((char (the card16 (elt ,sequence ,elt))) - (row (- (ash char -8) first-row)) - (col (- (logand char #xff) first-col))) - (declare (type card16 char) - (type int16 row col)) - (if (and (< -1 row num-rows) (< -1 col num-cols)) - (index* 6 (index+ (index* row num-cols) col)) - -1)))) - (if width-only-p - (do ((i start (index1+ i)) - (width 0)) - ((index>= i end) width) - (declare (type array-index i) - (type int32 width)) - (let ((n (char-info-elt sequence i))) - (declare (type fixnum n)) - (unless (minusp n) ;; Ignore characters not in the font - (incf width (the int16 (aref char-infos (index+ 2 n))))))) - ;; extents - (do ((i start (index1+ i)) - (width 0) - (ascent #x-7fff) - (descent #x-7fff) - (left #x7fff) - (right #x-7fff)) - ((index>= i end) - (values width ascent descent left right)) - (declare (type array-index i) - (type int16 ascent descent) - (type int32 width left right)) - (let ((n (char-info-elt sequence i))) - (declare (type fixnum n)) - (unless (minusp n) ;; Ignore characters not in the font - (setq left (min left (+ width (aref char-infos n)))) - (setq right (max right (+ width (aref char-infos (index1+ n))))) - (incf width (aref char-infos (index+ 2 n))) - (setq ascent (max ascent (aref char-infos (index+ 3 n)))) - (setq descent (max descent (aref char-infos (index+ 4 n))))))))) - - ;; Non-matrix (8 bit) font - ;; The code here is identical to the above, except for the following macro: - (macrolet ((char-info-elt (sequence elt) - `(let ((col (- (the card16 (elt ,sequence ,elt)) first-col))) - (declare (type int16 col)) - (if (< -1 col num-cols) - (index* 6 col) - -1)))) - (if width-only-p - (do ((i start (index1+ i)) - (width 0)) - ((index>= i end) width) - (declare (type array-index i) - (type int32 width)) - (let ((n (char-info-elt sequence i))) - (declare (type fixnum n)) - (unless (minusp n) ;; Ignore characters not in the font - (incf width (the int16 (aref char-infos (index+ 2 n))))))) - ;; extents - (do ((i start (index1+ i)) - (width 0) - (ascent #x-7fff) - (descent #x-7fff) - (left #x7fff) - (right #x-7fff)) - ((index>= i end) - (values width ascent descent left right)) - (declare (type array-index i) - (type int16 ascent descent) - (type int32 width left right)) - (let ((n (char-info-elt sequence i))) - (declare (type fixnum n)) - (unless (minusp n) ;; Ignore characters not in the font - (setq left (min left (+ width (aref char-infos n)))) - (setq right (max right (+ width (aref char-infos (index1+ n))))) - (incf width (aref char-infos (index+ 2 n))) - (setq ascent (max ascent (aref char-infos (index+ 3 n)))) - (setq descent (max descent (aref char-infos (index+ 4 n))))) - )))) - ))))) - -;;----------------------------------------------------------------------------- - -;; This controls the element size of the dst buffer given to translate. If -;; :default is specified, the size will be based on the current font, if known, -;; and otherwise 16 will be used. [An alternative would be to pass the buffer -;; size to translate, and allow it to return the desired size if it doesn't -;; like the current size. The problem is that the protocol doesn't allow -;; switching within a single request, so to allow switching would require -;; knowing the width of text, which isn't necessarily known. We could call -;; text-width to compute it, but perhaps that is doing too many favors?] [An -;; additional possibility is to allow an index-size of :two-byte, in which case -;; translate would be given a double-length 8-bit array, and translate would be -;; expected to store first-byte/second-byte instead of 16-bit integers.] - -(deftype index-size () '(member :default 8 16)) - -;; In the functions below, if width is specified, it is assumed to be the total -;; pixel width of whatever string of glyphs is actually drawn. Specifying -;; width will allow for appending the output of subsequent calls to the same -;; protocol request, provided gcontext has not been modified in the interim. -;; If width is not specified, appending of subsequent output might not occur -;; (unless translate returns the width). Specifying width is simply a hint, -;; for performance. - -(defun draw-glyph (drawable gcontext x y elt - &key translate width (size :default)) - ;; Returns true if elt is output, nil if translate refuses to output it. - ;; Second result is width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type (or null int32) width) - (type index-size size)) - (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) - (declare (clx-values generalized-boolean (or null int32))) - (let* ((display (gcontext-display gcontext)) - (result t) - (opcode +x-polytext8+)) - (declare (type display display)) - (let ((vector (allocate-gcontext-state))) - (declare (type gcontext-state vector)) - (setf (aref vector 0) elt) - (multiple-value-bind (new-start new-font translate-width) - (funcall (or translate #'translate-default) - vector 0 1 (gcontext-font gcontext nil) vector 1) - ;; Allow translate to set a new font - (when (type? new-font 'font) - (setf (gcontext-font gcontext) new-font) - (multiple-value-setq (new-start new-font translate-width) - (funcall translate vector 0 1 new-font vector 1))) - ;; If new-start is zero, translate refuses to output it - (setq result (index-plusp new-start) - elt (aref vector 1)) - (deallocate-gcontext-state vector) - (when translate-width (setq width translate-width)))) - (when result - (when (eql size 16) - (setq opcode +x-polytext16+) - (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt)))) - (with-buffer-request (display opcode :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (card8 1 0) - (card8 (ldb (byte 8 0) elt)) - (card8 (ldb (byte 8 8) elt))) - (values t width)))) - -(defun draw-glyphs (drawable gcontext x y sequence - &key (start 0) end translate width (size :default)) - ;; First result is new start, if end was not reached. Second result is - ;; overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type sequence sequence) - (type (or null array-index) end) - (type (or null int32) width) - (type index-size size)) - (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) - (declare (clx-values (or null array-index) (or null int32))) - (unless end (setq end (length sequence))) - (ecase size - ((:default 8) (draw-glyphs8 drawable gcontext x y sequence start end - (or translate #'translate-default) width)) - (16 (draw-glyphs16 drawable gcontext x y sequence start end - (or translate #'translate-default) width)))) - -(defun draw-glyphs8 (drawable gcontext x y sequence start end translate width) - ;; First result is new start, if end was not reached. Second result is - ;; overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type sequence sequence) - (type (or null array-index) end) - (type (or null int32) width)) - (declare (clx-values (or null array-index) (or null int32))) - (declare (type translation-function translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg translate)) - (let* ((src-start start) - (src-end (or end (length sequence))) - (next-start nil) - (length (index- src-end src-start)) - (request-length (* length 2)) ; Leave lots of room for font shifts. - (display (gcontext-display gcontext)) - (font (gcontext-font gcontext nil))) - (declare (type array-index src-start src-end length) - (type (or null array-index) next-start) - (type display display)) - (with-buffer-request (display +x-polytext8+ :gc-force gcontext :length request-length) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (progn - ;; Don't let any flushes happen since we manually set the request - ;; length when we're done. - (with-buffer-flush-inhibited (display) - (do* ((boffset (index+ buffer-boffset 16)) - (src-chunk 0) - (dst-chunk 0) - (offset 0) - (overall-width 0) - (stop-p nil)) - ((or stop-p (zerop length)) - ;; Ensure terminated with zero bytes - (do ((end (the array-index (lround boffset)))) - ((index>= boffset end)) - (setf (aref buffer-bbuf boffset) 0) - (index-incf boffset)) - (length-put 2 (index-ash (index- boffset buffer-boffset) -2)) - (setf (buffer-boffset display) boffset) - (unless (index-zerop length) (setq next-start src-start)) - (when overall-width (setq width overall-width))) - - (declare (type array-index src-chunk dst-chunk offset) - (type (or null int32) overall-width) - (type generalized-boolean stop-p)) - (setq src-chunk (index-min length *max-string-size*)) - (multiple-value-bind (new-start new-font translated-width) - (funcall translate - sequence src-start (index+ src-start src-chunk) - font buffer-bbuf (index+ boffset 2)) - (setq dst-chunk (index- new-start src-start) - length (index- length dst-chunk) - src-start new-start) - (if translated-width - (when overall-width (incf overall-width translated-width)) - (setq overall-width nil)) - (when (index-plusp dst-chunk) - (setf (aref buffer-bbuf boffset) dst-chunk) - (setf (aref buffer-bbuf (index+ boffset 1)) offset) - (incf boffset (index+ dst-chunk 2))) - (setq offset 0) - (cond ((null new-font) - ;; Don't stop if translate copied whole chunk - (unless (index= src-chunk dst-chunk) - (setq stop-p t))) - ((integerp new-font) (setq offset new-font)) - ((type? new-font 'font) - (setq font new-font) - (let ((font-id (font-id font)) - (buffer-boffset boffset)) - (declare (type resource-id font-id) - (type array-index buffer-boffset)) - ;; This changes the gcontext font in the server - ;; Update the gcontext cache (both local and server state) - (let ((local-state (gcontext-local-state gcontext)) - (server-state (gcontext-server-state gcontext))) - (declare (type gcontext-state local-state server-state)) - (setf (gcontext-internal-font-obj server-state) font - (gcontext-internal-font server-state) font-id) - (without-interrupts - (setf (gcontext-internal-font-obj local-state) font - (gcontext-internal-font local-state) font-id))) - (card8-put 0 #xff) - (card8-put 1 (ldb (byte 8 24) font-id)) - (card8-put 2 (ldb (byte 8 16) font-id)) - (card8-put 3 (ldb (byte 8 8) font-id)) - (card8-put 4 (ldb (byte 8 0) font-id))) - (index-incf boffset 5))) - ))))) - (values next-start width))) - -;; NOTE: After the first font change by the TRANSLATE function, characters are no-longer -;; on 16bit boundaries and this function garbles the bytes. -(defun draw-glyphs16 (drawable gcontext x y sequence start end translate width) - ;; First result is new start, if end was not reached. Second result is - ;; overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type sequence sequence) - (type (or null array-index) end) - (type (or null int32) width)) - (declare (clx-values (or null array-index) (or null int32))) - (declare (type translation-function translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg translate)) - (let* ((src-start start) - (src-end (or end (length sequence))) - (next-start nil) - (length (index- src-end src-start)) - (request-length (* length 3)) ; Leave lots of room for font shifts. - (display (gcontext-display gcontext)) - (font (gcontext-font gcontext nil)) - (buffer (display-tbuf16 display))) - (declare (type array-index src-start src-end length) - (type (or null array-index) next-start) - (type display display) - (type buffer-text16 buffer)) - (with-buffer-request (display +x-polytext16+ :gc-force gcontext :length request-length) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (progn - ;; Don't let any flushes happen since we manually set the request - ;; length when we're done. - (with-buffer-flush-inhibited (display) - (do* ((boffset (index+ buffer-boffset 16)) - (src-chunk 0) - (dst-chunk 0) - (offset 0) - (overall-width 0) - (stop-p nil)) - ((or stop-p (zerop length)) - ;; Ensure terminated with zero bytes - (do ((end (lround boffset))) - ((index>= boffset end)) - (setf (aref buffer-bbuf boffset) 0) - (index-incf boffset)) - (length-put 2 (index-ash (index- boffset buffer-boffset) -2)) - (setf (buffer-boffset display) boffset) - (unless (zerop length) (setq next-start src-start)) - (when overall-width (setq width overall-width))) - - (declare (type array-index boffset src-chunk dst-chunk offset) - (type (or null int32) overall-width) - (type generalized-boolean stop-p)) - (setq src-chunk (index-min length *max-string-size*)) - (multiple-value-bind (new-start new-font translated-width) - (funcall translate - sequence src-start (index+ src-start src-chunk) - font buffer 0) - (setq dst-chunk (index- new-start src-start) - length (index- length dst-chunk) - src-start new-start) - (write-sequence-char2b display (index+ boffset 2) buffer 0 dst-chunk) - (if translated-width - (when overall-width (incf overall-width translated-width)) - (setq overall-width nil)) - (when (index-plusp dst-chunk) - (setf (aref buffer-bbuf boffset) dst-chunk) - (setf (aref buffer-bbuf (index+ boffset 1)) offset) - (index-incf boffset (index+ dst-chunk dst-chunk 2))) - (setq offset 0) - (cond ((null new-font) - ;; Don't stop if translate copied whole chunk - (unless (index= src-chunk dst-chunk) - (setq stop-p t))) - ((integerp new-font) (setq offset new-font)) - ((type? new-font 'font) - (setq font new-font) - (let ((font-id (font-id font)) - (buffer-boffset boffset)) - (declare (type resource-id font-id) - (type array-index buffer-boffset)) - ;; This changes the gcontext font in the SERVER - ;; Update the gcontext cache (both local and server state) - (let ((local-state (gcontext-local-state gcontext)) - (server-state (gcontext-server-state gcontext))) - (declare (type gcontext-state local-state server-state)) - (setf (gcontext-internal-font-obj server-state) font - (gcontext-internal-font server-state) font-id) - (without-interrupts - (setf (gcontext-internal-font-obj local-state) font - (gcontext-internal-font local-state) font-id))) - (card8-put 0 #xff) - (card8-put 1 (ldb (byte 8 24) font-id)) - (card8-put 2 (ldb (byte 8 16) font-id)) - (card8-put 3 (ldb (byte 8 8) font-id)) - (card8-put 4 (ldb (byte 8 0) font-id))) - (index-incf boffset 5))) - ))))) - (values next-start width))) - -(defun draw-image-glyph (drawable gcontext x y elt - &key translate width (size :default)) - ;; Returns true if elt is output, nil if translate refuses to output it. - ;; Second result is overall width, if known. An initial font change is - ;; allowed from translate. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type (or null int32) width) - (type index-size size)) - (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) - (declare (clx-values generalized-boolean (or null int32))) - (let* ((display (gcontext-display gcontext)) - (result t) - (opcode +x-imagetext8+)) - (declare (type display display)) - (let ((vector (allocate-gcontext-state))) - (declare (type gcontext-state vector)) - (setf (aref vector 0) elt) - (multiple-value-bind (new-start new-font translate-width) - (funcall (or translate #'translate-default) - vector 0 1 (gcontext-font gcontext nil) vector 1) - ;; Allow translate to set a new font - (when (type? new-font 'font) - (setf (gcontext-font gcontext) new-font) - (multiple-value-setq (new-start new-font translate-width) - (funcall translate vector 0 1 new-font vector 1))) - ;; If new-start is zero, translate refuses to output it - (setq result (index-plusp new-start) - elt (aref vector 1)) - (deallocate-gcontext-state vector) - (when translate-width (setq width translate-width)))) - (when result - (when (eql size 16) - (setq opcode +x-imagetext16+) - (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt)))) - (with-buffer-request (display opcode :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - (data 1) ;; 1 character - (int16 x y) - (card8 (ldb (byte 8 0) elt)) - (card8 (ldb (byte 8 8) elt))) - (values t width)))) - -(defun draw-image-glyphs (drawable gcontext x y sequence - &key (start 0) end translate width (size :default)) - ;; An initial font change is allowed from translate, but any subsequent font - ;; change or horizontal motion will cause termination (because the protocol - ;; doesn't support chaining). [Alternatively, font changes could be accepted - ;; as long as they are accompanied with a width return value, or always - ;; accept font changes and call text-width as required. However, horizontal - ;; motion can't really be accepted, due to semantics.] First result is new - ;; start, if end was not reached. Second result is overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type (or null array-index) end) - (type sequence sequence) - (type (or null int32) width) - (type index-size size)) - (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) - (declare (clx-values (or null array-index) (or null int32))) - (setf end (index-min (index+ start 255) (or end (length sequence)))) - (ecase size - ((:default 8) - (draw-image-glyphs8 drawable gcontext x y sequence start end translate width)) - (16 - (draw-image-glyphs16 drawable gcontext x y sequence start end translate width)))) - -(defun draw-image-glyphs8 (drawable gcontext x y sequence start end translate width) - ;; An initial font change is allowed from translate, but any subsequent font - ;; change or horizontal motion will cause termination (because the protocol - ;; doesn't support chaining). [Alternatively, font changes could be accepted - ;; as long as they are accompanied with a width return value, or always - ;; accept font changes and call text-width as required. However, horizontal - ;; motion can't really be accepted, due to semantics.] First result is new - ;; start, if end was not reached. Second result is overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type sequence sequence) - (type (or null array-index) end) - (type (or null int32) width)) - (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg translate)) - (declare (clx-values (or null array-index) (or null int32))) - (do* ((display (gcontext-display gcontext)) - (length (index- end start)) - (font (gcontext-font gcontext nil)) - (font-change nil) - (new-start) (translated-width) (chunk)) - (nil) ;; forever - (declare (type display display) - (type array-index length) - (type (or null array-index) new-start chunk)) - - (when font-change - (setf (gcontext-font gcontext) font)) - (block change-font - (with-buffer-request (display +x-imagetext8+ :gc-force gcontext :length length) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (progn - ;; Don't let any flushes happen since we manually set the request - ;; length when we're done. - (with-buffer-flush-inhibited (display) - ;; Translate the sequence into the buffer - (multiple-value-setq (new-start font translated-width) - (funcall (or translate #'translate-default) sequence start end - font buffer-bbuf (index+ buffer-boffset 16))) - ;; Number of glyphs translated - (setq chunk (index- new-start start)) - ;; Check for initial font change - (when (and (index-zerop chunk) (type? font 'font)) - (setq font-change t) ;; Loop around changing font - (return-from change-font)) - ;; Quit when nothing translated - (when (index-zerop chunk) - (return-from draw-image-glyphs8 new-start)) - ;; Update buffer pointers - (data-put 1 chunk) - (let ((blen (lround (index+ 16 chunk)))) - (length-put 2 (index-ash blen -2)) - (setf (buffer-boffset display) (index+ buffer-boffset blen)))))) - ;; Normal exit - (return-from draw-image-glyphs8 - (values (if (index= chunk length) nil new-start) - (or translated-width width)))))) - -(defun draw-image-glyphs16 (drawable gcontext x y sequence start end translate width) - ;; An initial font change is allowed from translate, but any subsequent font - ;; change or horizontal motion will cause termination (because the protocol - ;; doesn't support chaining). [Alternatively, font changes could be accepted - ;; as long as they are accompanied with a width return value, or always - ;; accept font changes and call text-width as required. However, horizontal - ;; motion can't really be accepted, due to semantics.] First result is new - ;; start, if end was not reached. Second result is overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type sequence sequence) - (type (or null array-index) end) - (type (or null int32) width)) - (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg translate)) - (declare (clx-values (or null array-index) (or null int32))) - (do* ((display (gcontext-display gcontext)) - (length (index- end start)) - (font (gcontext-font gcontext nil)) - (font-change nil) - (new-start) (translated-width) (chunk) - (buffer (buffer-tbuf16 display))) - (nil) ;; forever - - (declare (type display display) - (type array-index length) - (type (or null array-index) new-start chunk) - (type buffer-text16 buffer)) - (when font-change - (setf (gcontext-font gcontext) font)) - - (block change-font - (with-buffer-request (display +x-imagetext16+ :gc-force gcontext :length length) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (progn - ;; Don't let any flushes happen since we manually set the request - ;; length when we're done. - (with-buffer-flush-inhibited (display) - ;; Translate the sequence into the buffer - (multiple-value-setq (new-start font translated-width) - (funcall (or translate #'translate-default) sequence start end - font buffer 0)) - ;; Number of glyphs translated - (setq chunk (index- new-start start)) - ;; Check for initial font change - (when (and (index-zerop chunk) (type? font 'font)) - (setq font-change t) ;; Loop around changing font - (return-from change-font)) - ;; Quit when nothing translated - (when (index-zerop chunk) - (return-from draw-image-glyphs16 new-start)) - (write-sequence-char2b display (index+ buffer-boffset 16) buffer 0 chunk) - ;; Update buffer pointers - (data-put 1 chunk) - (let ((blen (lround (index+ 16 (index-ash chunk 1))))) - (length-put 2 (index-ash blen -2)) - (setf (buffer-boffset display) (index+ buffer-boffset blen)))))) - ;; Normal exit - (return-from draw-image-glyphs16 - (values (if (index= chunk length) nil new-start) - (or translated-width width)))))) - - -;;----------------------------------------------------------------------------- - -(defun display-keycode-range (display) - (declare (type display display)) - (declare (clx-values min max)) - (values (display-min-keycode display) - (display-max-keycode display))) - -;; Should this signal device-busy like the pointer-mapping setf, and return a -;; generalized-boolean instead (true for success)? Alternatively, should the -;; pointer-mapping setf be changed to set-pointer-mapping with a (member -;; :success :busy) result? - -(defun set-modifier-mapping (display &key shift lock control mod1 mod2 mod3 mod4 mod5) - ;; Setf ought to allow multiple values. - (declare (type display display) - (type sequence shift lock control mod1 mod2 mod3 mod4 mod5)) - (declare (clx-values (member :success :busy :failed))) - (let* ((keycodes-per-modifier (index-max (length shift) - (length lock) - (length control) - (length mod1) - (length mod2) - (length mod3) - (length mod4) - (length mod5))) - (data (make-array (index* 8 keycodes-per-modifier) - :element-type 'card8 - :initial-element 0))) - (replace data shift) - (replace data lock :start1 keycodes-per-modifier) - (replace data control :start1 (index* 2 keycodes-per-modifier)) - (replace data mod1 :start1 (index* 3 keycodes-per-modifier)) - (replace data mod2 :start1 (index* 4 keycodes-per-modifier)) - (replace data mod3 :start1 (index* 5 keycodes-per-modifier)) - (replace data mod4 :start1 (index* 6 keycodes-per-modifier)) - (replace data mod5 :start1 (index* 7 keycodes-per-modifier)) - (with-buffer-request-and-reply (display +x-setmodifiermapping+ 4 :sizes 8) - ((data keycodes-per-modifier) - ((sequence :format card8) data)) - (values (member8-get 1 :success :busy :failed))))) - -(defun modifier-mapping (display) - ;; each value is a list of integers - (declare (type display display)) - (declare (clx-values shift lock control mod1 mod2 mod3 mod4 mod5)) - (let ((lists nil)) - (with-buffer-request-and-reply (display +x-getmodifiermapping+ nil :sizes 8) - () - (do* ((keycodes-per-modifier (card8-get 1)) - (advance-by +replysize+ keycodes-per-modifier) - (keys nil nil) - (i 0 (index+ i 1))) - ((index= i 8)) - (advance-buffer-offset advance-by) - (dotimes (j keycodes-per-modifier) - (let ((key (read-card8 j))) - (unless (zerop key) - (push key keys)))) - (push (nreverse keys) lists))) - (values-list (nreverse lists)))) - -;; Either we will want lots of defconstants for well-known values, or perhaps -;; an integer-to-keyword translation function for well-known values. - -(defun change-keyboard-mapping - (display keysyms &key (start 0) end (first-keycode start)) - ;; start/end give subrange of keysyms - ;; first-keycode is the first-keycode to store at - (declare (type display display) - (type array-index start) - (type card8 first-keycode) - (type (or null array-index) end) - (type (array * (* *)) keysyms)) - (let* ((keycode-end (or end (array-dimension keysyms 0))) - (keysyms-per-keycode (array-dimension keysyms 1)) - (length (index- keycode-end start)) - (size (index* length keysyms-per-keycode)) - (request-length (index+ size 2))) - (declare (type array-index keycode-end keysyms-per-keycode length request-length)) - (with-buffer-request (display +x-setkeyboardmapping+ - :length (index-ash request-length 2) - :sizes (32)) - (data length) - (length request-length) - (card8 first-keycode keysyms-per-keycode) - (progn - (do ((limit (index-ash (buffer-size display) -2)) - (w (index+ 2 (index-ash buffer-boffset -2))) - (i start (index+ i 1))) - ((index>= i keycode-end) - (setf (buffer-boffset display) (index-ash w 2))) - (declare (type array-index limit w i)) - (when (index> w limit) - (buffer-flush display) - (setq w (index-ash (buffer-boffset display) -2))) - (do ((j 0 (index+ j 1))) - ((index>= j keysyms-per-keycode)) - (declare (type array-index j)) - (card29-put (index* w 4) (aref keysyms i j)) - (index-incf w))))))) - -(defun keyboard-mapping (display &key first-keycode start end data) - ;; First-keycode specifies which keycode to start at (defaults to min-keycode). - ;; Start specifies where (in result) to put first-keycode. (defaults to first-keycode) - ;; (- end start) is the number of keycodes to get. (End defaults to (1+ max-keycode)). - ;; If DATA is specified, the results are put there. - (declare (type display display) - (type (or null card8) first-keycode) - (type (or null array-index) start end) - (type (or null (array * (* *))) data)) - (declare (clx-values (array * (* *)))) - (unless first-keycode (setq first-keycode (display-min-keycode display))) - (unless start (setq start first-keycode)) - (unless end (setq end (1+ (display-max-keycode display)))) - (with-buffer-request-and-reply (display +x-getkeyboardmapping+ nil :sizes (8 32)) - ((card8 first-keycode (index- end start))) - (do* ((keysyms-per-keycode (card8-get 1)) - (bytes-per-keycode (* keysyms-per-keycode 4)) - (advance-by +replysize+ bytes-per-keycode) - (keycode-count (floor (card32-get 4) keysyms-per-keycode) - (index- keycode-count 1)) - (result (if (and (arrayp data) - (= (array-rank data) 2) - (>= (array-dimension data 0) (index+ start keycode-count)) - (>= (array-dimension data 1) keysyms-per-keycode)) - data - (make-array `(,(index+ start keycode-count) ,keysyms-per-keycode) - :element-type 'keysym :initial-element 0))) - (i start (1+ i))) - ((zerop keycode-count) (setq data result)) - (advance-buffer-offset advance-by) - (dotimes (j keysyms-per-keycode) - (setf (aref result i j) (card29-get (* j 4)))))) - data) diff -Nru ecl-16.1.2/src/clx/translate.lisp ecl-16.1.3+ds/src/clx/translate.lisp --- ecl-16.1.2/src/clx/translate.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/translate.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,562 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES -*- - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(defvar *keysym-sets* nil) ;; Alist of (name first-keysym last-keysym) - -(defun define-keysym-set (set first-keysym last-keysym) - ;; Define all keysyms from first-keysym up to and including - ;; last-keysym to be in SET (returned from the keysym-set function). - ;; Signals an error if the keysym range overlaps an existing set. - (declare (type keyword set) - (type keysym first-keysym last-keysym)) - (when (> first-keysym last-keysym) - (rotatef first-keysym last-keysym)) - (setq *keysym-sets* (delete set *keysym-sets* :key #'car)) - (dolist (set *keysym-sets*) - (let ((first (second set)) - (last (third set))) - (when (or (<= first first-keysym last) - (<= first last-keysym last)) - (error "Keysym range overlaps existing set ~s" set)))) - (push (list set first-keysym last-keysym) *keysym-sets*) - set) - -(defun keysym-set (keysym) - ;; Return the character code set name of keysym - (declare (type keysym keysym) - (clx-values keyword)) - (dolist (set *keysym-sets*) - (let ((first (second set)) - (last (third set))) - (when (<= first keysym last) - (return (first set)))))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro keysym (keysym &rest bytes) - ;; Build a keysym. - ;; - ;; If KEYSYM is an integer, it is used as the most significant - ;; bits of the keysym, and BYTES are used to specify low order - ;; bytes. The last parameter is always byte4 of the keysym. If - ;; KEYSYM is not an integer, the keysym associated with KEYSYM is - ;; returned. - ;; - ;; This is a macro and not a function macro to promote - ;; compile-time lookup. All arguments are evaluated. - ;; - ;; FIXME: The above means that this shouldn't really be a macro at - ;; all, but a compiler macro. Probably, anyway. - (declare (type t keysym) - (type list bytes) - (clx-values keysym)) - (typecase keysym - ((integer 0 *) - (dolist (b bytes keysym) (setq keysym (+ (ash keysym 8) b)))) - (otherwise - (or (car (character->keysyms keysym)) - (error "~s Isn't the name of a keysym" keysym)))))) - -(defvar *keysym->character-map* - (make-hash-table :test (keysym->character-map-test) :size 400)) - -;; Keysym-mappings are a list of the form (object translate lowercase modifiers mask) -;; With the following accessor macros. Everything after OBJECT is optional. - -(defmacro keysym-mapping-object (keysym-mapping) - ;; Parameter to translate - `(first ,keysym-mapping)) - -(defmacro keysym-mapping-translate (keysym-mapping) - ;; Function to be called with parameters (display state OBJECT) - ;; when translating KEYSYM and modifiers and mask are satisfied. - `(second ,keysym-mapping)) - -(defmacro keysym-mapping-lowercase (keysym-mapping) - ;; LOWERCASE is used for uppercase alphabetic keysyms. The value - ;; is the associated lowercase keysym. - `(third ,keysym-mapping)) - -(defmacro keysym-mapping-modifiers (keysym-mapping) - ;; MODIFIERS is either a modifier-mask or list containing intermixed - ;; keysyms and state-mask-keys specifying when to use this - ;; keysym-translation. - `(fourth ,keysym-mapping)) - -(defmacro keysym-mapping-mask (keysym-mapping) - ;; MASK is either a modifier-mask or list containing intermixed - ;; keysyms and state-mask-keys specifying which modifiers to look at - ;; (i.e. modifiers not specified are don't-cares) - `(fifth ,keysym-mapping)) - -(defvar *default-keysym-translate-mask* - (the (or (member :modifiers) mask16 (clx-list (or keysym state-mask-key))) - (logand #xff (lognot (make-state-mask :lock)))) - "Default keysym state mask to use during keysym-translation.") - -(defun define-keysym (object keysym &key lowercase translate modifiers mask display) - ;; Define the translation from keysym/modifiers to a (usually - ;; character) object. ANy previous keysym definition with - ;; KEYSYM and MODIFIERS is deleted before adding the new definition. - ;; - ;; MODIFIERS is either a modifier-mask or list containing intermixed - ;; keysyms and state-mask-keys specifying when to use this - ;; keysym-translation. The default is NIL. - ;; - ;; MASK is either a modifier-mask or list containing intermixed - ;; keysyms and state-mask-keys specifying which modifiers to look at - ;; (i.e. modifiers not specified are don't-cares). - ;; If mask is :MODIFIERS then the mask is the same as the modifiers - ;; (i.e. modifiers not specified by modifiers are don't cares) - ;; The default mask is *default-keysym-translate-mask* - ;; - ;; If DISPLAY is specified, the translation will be local to DISPLAY, - ;; otherwise it will be the default translation for all displays. - ;; - ;; LOWERCASE is used for uppercase alphabetic keysyms. The value - ;; is the associated lowercase keysym. This information is used - ;; by the keysym-both-case-p predicate (for caps-lock computations) - ;; and by the keysym-downcase function. - ;; - ;; TRANSLATE will be called with parameters (display state OBJECT) - ;; when translating KEYSYM and modifiers and mask are satisfied. - ;; [e.g (zerop (logxor (logand state (or mask *default-keysym-translate-mask*)) - ;; (or modifiers 0))) - ;; when mask and modifiers aren't lists of keysyms] - ;; The default is #'default-keysym-translate - ;; - (declare (type (or base-char t) object) - (type keysym keysym) - (type (or null mask16 (clx-list (or keysym state-mask-key))) - modifiers) - (type (or null (member :modifiers) mask16 (clx-list (or keysym state-mask-key))) - mask) - (type (or null display) display) - (type (or null keysym) lowercase) - (type (or null (function (display card16 t) t)) translate)) - (flet ((merge-keysym-mappings (new old) - ;; Merge new keysym-mapping with list of old mappings. - ;; Ensure that the mapping with no modifiers or mask comes first. - (let* ((key (keysym-mapping-modifiers new)) - (merge (delete key old :key #'cadddr :test #'equal))) - (if key - (nconc merge (list new)) - (cons new merge)))) - (mask-check (mask) - (unless (or (numberp mask) - (dolist (element mask t) - (unless (or (find element +state-mask-vector+) - (gethash element *keysym->character-map*)) - (return nil)))) - (x-type-error mask '(or mask16 (clx-list (or modifier-key modifier-keysym))))))) - (let ((entry - ;; Create with a single LIST call, to ensure cdr-coding - (cond - (mask - (unless (eq mask :modifiers) - (mask-check mask)) - (when (or (null modifiers) (and (numberp modifiers) (zerop modifiers))) - (error "Mask with no modifiers")) - (list object translate lowercase modifiers mask)) - (modifiers (mask-check modifiers) - (list object translate lowercase modifiers)) - (lowercase (list object translate lowercase)) - (translate (list object translate)) - (t (list object))))) - (if display - (let ((previous (assoc keysym (display-keysym-translation display)))) - (if previous - (setf (cdr previous) (merge-keysym-mappings entry (cdr previous))) - (push (list keysym entry) (display-keysym-translation display)))) - (setf (gethash keysym *keysym->character-map*) - (merge-keysym-mappings entry (gethash keysym *keysym->character-map*))))) - object)) - -(defun undefine-keysym (object keysym &key display modifiers &allow-other-keys) - ;; Undefine the keysym-translation translating KEYSYM to OBJECT with MODIFIERS. - ;; If DISPLAY is non-nil, undefine the translation for DISPLAY if it exists. - (declare (type (or base-char t) object) - (type keysym keysym) - (type (or null mask16 (clx-list (or keysym state-mask-key))) - modifiers) - (type (or null display) display)) - (flet ((match (key entry) - (let ((object (car key)) - (modifiers (cdr key))) - (or (eql object (keysym-mapping-object entry)) - (equal modifiers (keysym-mapping-modifiers entry)))))) - (let* (entry - (previous (if display - (cdr (setq entry (assoc keysym (display-keysym-translation display)))) - (gethash keysym *keysym->character-map*))) - (key (cons object modifiers))) - (when (and previous (find key previous :test #'match)) - (setq previous (delete key previous :test #'match)) - (if display - (setf (cdr entry) previous) - (setf (gethash keysym *keysym->character-map*) previous)))))) - -(defun keysym-downcase (keysym) - ;; If keysym has a lower-case equivalent, return it, otherwise return keysym. - (declare (type keysym keysym)) - (declare (clx-values keysym)) - (let ((translations (gethash keysym *keysym->character-map*))) - (or (and translations (keysym-mapping-lowercase (first translations))) keysym))) - -(defun keysym-uppercase-alphabetic-p (keysym) - ;; Returns T if keysym is uppercase-alphabetic. - ;; I.E. If it has a lowercase equivalent. - (declare (type keysym keysym)) - (declare (clx-values (or null keysym))) - (let ((translations (gethash keysym *keysym->character-map*))) - (and translations - (keysym-mapping-lowercase (first translations))))) - -(defun character->keysyms (character &optional display) - ;; Given a character, return a list of all matching keysyms. - ;; If DISPLAY is given, translations specific to DISPLAY are used, - ;; otherwise only global translations are used. - ;; Implementation dependent function. - ;; May be slow [i.e. do a linear search over all known keysyms] - (declare (type t character) - (type (or null display) display) - (clx-values (clx-list keysym))) - (let ((result nil)) - (when display - (dolist (mapping (display-keysym-translation display)) - (when (eql character (second mapping)) - (push (first mapping) result)))) - (maphash #'(lambda (keysym mappings) - (dolist (mapping mappings) - (when (eql (keysym-mapping-object mapping) character) - (pushnew keysym result)))) - *keysym->character-map*) - result)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant character-set-switch-keysym (keysym 255 126)) - (defconstant left-shift-keysym (keysym 255 225)) - (defconstant right-shift-keysym (keysym 255 226)) - (defconstant left-control-keysym (keysym 255 227)) - (defconstant right-control-keysym (keysym 255 228)) - (defconstant caps-lock-keysym (keysym 255 229)) - (defconstant shift-lock-keysym (keysym 255 230)) - (defconstant left-meta-keysym (keysym 255 231)) - (defconstant right-meta-keysym (keysym 255 232)) - (defconstant left-alt-keysym (keysym 255 233)) - (defconstant right-alt-keysym (keysym 255 234)) - (defconstant left-super-keysym (keysym 255 235)) - (defconstant right-super-keysym (keysym 255 236)) - (defconstant left-hyper-keysym (keysym 255 237)) - (defconstant right-hyper-keysym (keysym 255 238))) - - -;;----------------------------------------------------------------------------- -;; Keysym mapping functions - -(defun display-keyboard-mapping (display) - (declare (type display display)) - (declare (clx-values (simple-array keysym (display-max-keycode keysyms-per-keycode)))) - (or (display-keysym-mapping display) - (setf (display-keysym-mapping display) (keyboard-mapping display)))) - -(defun keycode->keysym (display keycode keysym-index) - (declare (type display display) - (type card8 keycode) - (type card8 keysym-index) - (clx-values keysym)) - (let* ((mapping (display-keyboard-mapping display)) - (keysym (aref mapping keycode keysym-index))) - (declare (type (simple-array keysym (* *)) mapping) - (type keysym keysym)) - ;; The keysym-mapping is brain dammaged. - ;; Mappings for both-case alphabetic characters have the - ;; entry for keysym-index zero set to the uppercase keysym - ;; (this is normally where the lowercase keysym goes), and the - ;; entry for keysym-index one is zero. - (cond ((zerop keysym-index) ; Lowercase alphabetic keysyms - (keysym-downcase keysym)) - ((and (zerop keysym) (plusp keysym-index)) ; Get the uppercase keysym - (aref mapping keycode 0)) - (t keysym)))) - -(defun keysym->character (display keysym &optional (state 0)) - ;; Find the character associated with a keysym. - ;; STATE can be used to set character attributes. - ;; Implementation dependent function. - (declare (type display display) - (type keysym keysym) - (type card16 state)) - (declare (clx-values (or null character))) - (let* ((display-mappings (cdr (assoc keysym (display-keysym-translation display)))) - (mapping (or ;; Find the matching display mapping - (dolist (mapping display-mappings) - (when (mapping-matches-p display state mapping) - (return mapping))) - ;; Find the matching static mapping - (dolist (mapping (gethash keysym *keysym->character-map*)) - (when (mapping-matches-p display state mapping) - (return mapping)))))) - (when mapping - (funcall (or (keysym-mapping-translate mapping) 'default-keysym-translate) - display state (keysym-mapping-object mapping))))) - -(defun mapping-matches-p (display state mapping) - ;; Returns T when the modifiers and mask in MAPPING satisfies STATE for DISPLAY - (declare (type display display) - (type mask16 state) - (type list mapping)) - (declare (clx-values generalized-boolean)) - (flet - ((modifiers->mask (display-mapping modifiers errorp &aux (mask 0)) - ;; Convert MODIFIERS, which is a modifier mask, or a list of state-mask-keys into a mask. - ;; If ERRORP is non-nil, return NIL when an unknown modifier is specified, - ;; otherwise ignore unknown modifiers. - (declare (type list display-mapping) ; Alist of (keysym . mask) - (type (or mask16 list) modifiers) - (type mask16 mask)) - (declare (clx-values (or null mask16))) - (if (numberp modifiers) - modifiers - (dolist (modifier modifiers mask) - (declare (type symbol modifier)) - (let ((bit (position modifier (the simple-vector +state-mask-vector+) :test #'eq))) - (setq mask - (logior mask - (if bit - (ash 1 bit) - (or (cdr (assoc modifier display-mapping)) - ;; bad modifier - (if errorp - (return-from modifiers->mask nil) - 0)))))))))) - - (let* ((display-mapping (get-display-modifier-mapping display)) - (mapping-modifiers (keysym-mapping-modifiers mapping)) - (modifiers (or (modifiers->mask display-mapping (or mapping-modifiers 0) t) - (return-from mapping-matches-p nil))) - (mapping-mask (or (keysym-mapping-mask mapping) ; If no mask, use the default. - (if mapping-modifiers ; If no modifiers, match anything. - *default-keysym-translate-mask* - 0))) - (mask (if (eq mapping-mask :modifiers) - modifiers - (modifiers->mask display-mapping mapping-mask nil)))) - (declare (type mask16 modifiers mask)) - (= (logand state mask) modifiers)))) - -(defun default-keysym-index (display keycode state) - ;; Returns a keysym-index for use with keycode->character - (declare (clx-values card8)) - (macrolet ((keystate-p (state keyword) - `(logbitp ,(position keyword +state-mask-vector+) ,state))) - (let* ((mapping (display-keyboard-mapping display)) - (keysyms-per-keycode (array-dimension mapping 1)) - (symbolp (and (> keysyms-per-keycode 2) - (state-keysymp display state character-set-switch-keysym))) - (result (if symbolp 2 0))) - (declare (type (simple-array keysym (* *)) mapping) - (type generalized-boolean symbolp) - (type card8 keysyms-per-keycode result)) - (when (and (< result keysyms-per-keycode) - (keysym-shift-p display state (keysym-uppercase-alphabetic-p - (aref mapping keycode 0)))) - (incf result)) - result))) - -(defun keysym-shift-p (display state uppercase-alphabetic-p &key - shift-lock-xors - (control-modifiers - '#.(list left-meta-keysym left-super-keysym left-hyper-keysym))) - (declare (type display display) - (type card16 state) - (type generalized-boolean uppercase-alphabetic-p) - (type generalized-boolean shift-lock-xors));;; If T, both SHIFT-LOCK and SHIFT is the same - ;;; as neither if the character is alphabetic. - (declare (clx-values generalized-boolean)) - (macrolet ((keystate-p (state keyword) - `(logbitp ,(position keyword +state-mask-vector+) ,state))) - (let* ((controlp (or (keystate-p state :control) - (dolist (modifier control-modifiers) - (when (state-keysymp display state modifier) - (return t))))) - (shiftp (keystate-p state :shift)) - (lockp (keystate-p state :lock)) - (alphap (or uppercase-alphabetic-p - (not (state-keysymp display #.(make-state-mask :lock) - caps-lock-keysym))))) - (declare (type generalized-boolean controlp shiftp lockp alphap)) - ;; Control keys aren't affected by lock - (unless controlp - ;; Not a control character - check state of lock modifier - (when (and lockp - alphap - (or (not shiftp) shift-lock-xors)) ; Lock doesn't unshift unless shift-lock-xors - (setq shiftp (not shiftp)))) - shiftp))) - -;;; default-keysym-index implements the following tables: -;;; -;;; control shift caps-lock character character -;;; 0 0 0 #\a #\8 -;;; 0 0 1 #\A #\8 -;;; 0 1 0 #\A #\* -;;; 0 1 1 #\A #\* -;;; 1 0 0 #\control-A #\control-8 -;;; 1 0 1 #\control-A #\control-8 -;;; 1 1 0 #\control-shift-a #\control-* -;;; 1 1 1 #\control-shift-a #\control-* -;;; -;;; control shift shift-lock character character -;;; 0 0 0 #\a #\8 -;;; 0 0 1 #\A #\* -;;; 0 1 0 #\A #\* -;;; 0 1 1 #\A #\8 -;;; 1 0 0 #\control-A #\control-8 -;;; 1 0 1 #\control-A #\control-* -;;; 1 1 0 #\control-shift-a #\control-* -;;; 1 1 1 #\control-shift-a #\control-8 - -(defun keycode->character (display keycode state &key keysym-index - (keysym-index-function #'default-keysym-index)) - ;; keysym-index defaults to the result of keysym-index-function which - ;; is called with the following parameters: - ;; (char0 state caps-lock-p keysyms-per-keycode) - ;; where char0 is the "character" object associated with keysym-index 0 and - ;; caps-lock-p is non-nil when the keysym associated with the lock - ;; modifier is for caps-lock. - ;; STATE can also used for setting character attributes. - ;; Implementation dependent function. - (declare (type display display) - (type card8 keycode) - (type card16 state) - (type (or null card8) keysym-index) - (type (or null (function (base-char card16 generalized-boolean card8) card8)) - keysym-index-function)) - (declare (clx-values (or null character))) - (let* ((index (or keysym-index - (funcall keysym-index-function display keycode state))) - (keysym (if index (keycode->keysym display keycode index) 0))) - (declare (type (or null card8) index) - (type keysym keysym)) - (when (plusp keysym) - (keysym->character display keysym state)))) - -(defun get-display-modifier-mapping (display) - (labels ((keysym-replace (display modifiers mask &aux result) - (dolist (modifier modifiers result) - (push (cons (keycode->keysym display modifier 0) mask) result)))) - (or (display-modifier-mapping display) - (multiple-value-bind (shift lock control mod1 mod2 mod3 mod4 mod5) - (modifier-mapping display) - (setf (display-modifier-mapping display) - (nconc (keysym-replace display shift #.(make-state-mask :shift)) - (keysym-replace display lock #.(make-state-mask :lock)) - (keysym-replace display control #.(make-state-mask :control)) - (keysym-replace display mod1 #.(make-state-mask :mod-1)) - (keysym-replace display mod2 #.(make-state-mask :mod-2)) - (keysym-replace display mod3 #.(make-state-mask :mod-3)) - (keysym-replace display mod4 #.(make-state-mask :mod-4)) - (keysym-replace display mod5 #.(make-state-mask :mod-5)))))))) - -(defun state-keysymp (display state keysym) - ;; Returns T when a modifier key associated with KEYSYM is on in STATE - (declare (type display display) - (type card16 state) - (type keysym keysym)) - (declare (clx-values generalized-boolean)) - (let* ((mapping (get-display-modifier-mapping display)) - (mask (assoc keysym mapping))) - (and mask (plusp (logand state (cdr mask)))))) - -(defun mapping-notify (display request start count) - ;; Called on a mapping-notify event to update - ;; the keyboard-mapping cache in DISPLAY - (declare (type display display) - (type (member :modifier :keyboard :pointer) request) - (type card8 start count) - (ignore count start)) - ;; Invalidate the keyboard mapping to force the next key translation to get it - (case request - (:modifier - (setf (display-modifier-mapping display) nil)) - (:keyboard - (setf (display-keysym-mapping display) nil)))) - -(defun keysym-in-map-p (display keysym keymap) - ;; Returns T if keysym is found in keymap - (declare (type display display) - (type keysym keysym) - (type (bit-vector 256) keymap)) - (declare (clx-values generalized-boolean)) - ;; The keysym may appear in the keymap more than once, - ;; So we have to search the entire keysym map. - (do* ((min (display-min-keycode display)) - (max (display-max-keycode display)) - (map (display-keyboard-mapping display)) - (jmax (min 2 (array-dimension map 1))) - (i min (1+ i))) - ((> i max)) - (declare (type card8 min max jmax) - (type (simple-array keysym (* *)) map)) - (when (and (plusp (aref keymap i)) - (dotimes (j jmax) - (when (= keysym (aref map i j)) (return t)))) - (return t)))) - -(defun character-in-map-p (display character keymap) - ;; Implementation dependent function. - ;; Returns T if character is found in keymap - (declare (type display display) - (type character character) - (type (bit-vector 256) keymap)) - (declare (clx-values generalized-boolean)) - ;; Check all one bits in keymap - (do* ((min (display-min-keycode display)) - (max (display-max-keycode display)) - (jmax (array-dimension (display-keyboard-mapping display) 1)) - (i min (1+ i))) - ((> i max)) - (declare (type card8 min max jmax)) - (when (and (plusp (aref keymap i)) - ;; Match when character is in mapping for this keycode - (dotimes (j jmax) - (when (eql character (keycode->character display i 0 :keysym-index j)) - (return t)))) - (return t)))) - -(defun keysym->keycodes (display keysym) - ;; Return keycodes for keysym, as multiple values - (declare (type display display) - (type keysym keysym)) - (declare (clx-values (or null keycode) (or null keycode) (or null keycode))) - ;; The keysym may appear in the keymap more than once, - ;; So we have to search the entire keysym map. - (do* ((min (display-min-keycode display)) - (max (display-max-keycode display)) - (map (display-keyboard-mapping display)) - (jmax (min 2 (array-dimension map 1))) - (i min (1+ i)) - (result nil)) - ((> i max) (values-list result)) - (declare (type card8 min max jmax) - (type (simple-array keysym (* *)) map)) - (dotimes (j jmax) - (when (= keysym (aref map i j)) - (push i result))))) diff -Nru ecl-16.1.2/src/clx/xinerama.lisp ecl-16.1.3+ds/src/clx/xinerama.lisp --- ecl-16.1.2/src/clx/xinerama.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/xinerama.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,93 +0,0 @@ -;;; -*- Mode: Lisp -*- -;;; -;;; Copyright (C) 2008, Julian Stecklina -;;; -;;; (( -;;; )) This file is COFFEEWARE. As long as you retain this notice -;;; | |o) you can do whatever you want with this code. If you think, -;;; |___|jgs it's worth it, you may buy the author a coffee in return. -;;; -;;; Description: -;;; -;;; This is an implementation of the XINERAMA extension. It does not -;;; include the obsolete PanoramiX calls. - -(defpackage "XLIB.XINERAMA" - (:use "COMMON-LISP" "XLIB") - (:nicknames "XINERAMA") - (:import-from "XLIB" - "WITH-BUFFER-REQUEST" - "WITH-BUFFER-REQUEST-AND-REPLY" - "DATA" - "BOOLEAN" "BOOLEAN-GET" - "CARD8" "CARD8-GET" - "CARD16" "CARD16-GET" - "CARD32" "CARD32-GET" - "INT16" "INT16-GET") - (:export "SCREEN-INFO" - "SCREEN-INFO-NUMBER" - "SCREEN-INFO-X" - "SCREEN-INFO-Y" - "SCREEN-INFO-WIDTH" - "SCREEN-INFO-HEIGHT" - "XINERAMA-QUERY-VERSION" - "XINERAMA-IS-ACTIVE" - "XINERAMA-QUERY-SCREENS")) -(in-package "XINERAMA") - -(define-extension "XINERAMA") - -(defun xinerama-opcode (display) - (extension-opcode display "XINERAMA")) - -(defconstant +major-version+ 1) -(defconstant +minor-version+ 1) - -(defconstant +get-version+ 0) -(defconstant +get-state+ 1) -(defconstant +get-screen-count+ 2) -(defconstant +get-screen-size+ 3) -(defconstant +is-active+ 4) -(defconstant +query-screens+ 5) - -(defstruct screen-info - (number 0 :type (unsigned-byte 32)) - (x 0 :type (signed-byte 16)) - (y 0 :type (signed-byte 16)) - (width 0 :type (unsigned-byte 16)) - (height 0 :type (unsigned-byte 16))) - -(defun xinerama-query-version (display) - (with-buffer-request-and-reply (display (xinerama-opcode display) nil) - ((data +get-version+) - (card8 +major-version+) - (card8 +minor-version+)) - (values - (card16-get 8) ; server major version - (card16-get 10)))) ; server minor version - -(defun xinerama-is-active (display) - "Returns T, iff Xinerama is supported and active." - (with-buffer-request-and-reply (display (xinerama-opcode display) nil) - ((data +is-active+)) - (values - ;; XCB says this is actually a CARD32, but why?! - (boolean-get 8)))) - -(defun xinerama-query-screens (display) - "Returns a list of screen-info structures." - (with-buffer-request-and-reply (display (xinerama-opcode display) nil) - ((data +query-screens+)) - (values - (loop - with index = 32 - for number from 0 below (card32-get 8) - collect (prog1 - (make-screen-info :number number - :x (int16-get index) - :y (int16-get (+ index 2)) - :width (card16-get (+ index 4)) - :height (card16-get (+ index 6))) - (incf index 8)))))) - -;;; EOF diff -Nru ecl-16.1.2/src/clx/xrender.lisp ecl-16.1.3+ds/src/clx/xrender.lisp --- ecl-16.1.2/src/clx/xrender.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/xrender.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,1154 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- -;;; --------------------------------------------------------------------------- -;;; Title: The X Render Extension -;;; Created: 2002-08-03 -;;; Author: Gilbert Baumann -;;; $Id: xrender.lisp,v 1.5 2004/12/06 11:48:57 csr21 Exp $ -;;; --------------------------------------------------------------------------- -;;; -;;; (c) copyright 2002, 2003 by Gilbert Baumann -;;; (c) copyright 2002 by Christian Sunesson -;;; -;;; Permission is granted to any individual or institution to use, -;;; copy, modify, and distribute this software, provided that this -;;; complete copyright and permission notice is maintained, intact, in -;;; all copies and supporting documentation. -;;; -;;; 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. -;;; - -;;; NOTE: we need to watch maximum request sizes and somehow work -;;; around them. Sometimes e.g. in AddGlyphs this is not possible, -;;; which is a design failure. - -;;; TODO - -;; - some request are still to be implemented at all. -;; + Can they not wait? Xrender seems to be in flux as the specification -;; isn't even conforming to the acctual protocol. However backwards -;; wierd that sound. --noss - -;; - we need to invent something for the color values of e.g. -;; fill-rectangles; I would prefer some generic functions, so that -;; we later can map CLIM design directly to colors. - -;; - we want some conviencene function to turn graphics contexts into -;; render pictures. --GB 2002-08-21 - -;; - also: uniform-alpha-picture display alpha-value -;; uniform-color-picture display red green blue -;; --GB 2002-08-21 - -;; - maybe we should aim for a higher level interface to -;; color-trapzoids and color-triangles and offer a low level [raw] -;; interface also for high performance apps? - -;; - Write tests. - -;;;; API issues - -;; - On one hand we want convenience functions like RENDER-TRIANGLE or -;; WITH-UNIFORM-COLOR-PICTURE. On the other hand if you are up to -;; write a full rasterization library you obviously want high -;; performance entry points as RENDER-TRIANGLES-1. - -;; - We want to extend XLIB:COLOR into something with alpha channel. -;; How to name it? - -;; - WITH-UNIFORM-COLOR-PICTURE (var picture r g b &optional alpha) &body body -;; -;; Example: -;; (WITH-UNIFORM-COLOR-PICTURE (color dest 1.0 1.0 0.0) -;; (RENDER-TRIANGLE dest color ...)) - -;; - Pose the filter and the transform slots of a picture. - -;; - Also introduce a PICTURE-DEFAULT-MASK-FORMAT? - -;; - COPY-PICTURE? - -;; - WITH-PICTURE-OPTIONS ? -;; -;; (WITH-PICTURE-OPTIONS (pic :repeat :on) ...) - -;; - WITH-PICTURE ? -;; -;; (WITH-PICTURE (picture drawable ...) ...) - -;; - -(in-package :xlib) - -;; Beginning to collect the external interface for documentation. -(export '(render-create-picture - render-free-picture - - render-create-glyph-set - render-reference-glyph-set - render-free-glyph-set - - render-add-glyph - render-add-glyph-from-picture - render-free-glyph - render-fill-rectangle - - picture-format-display - picture-format-id - picture-format-type - picture-format-depth - picture-format-red-byte - picture-format-green-byte - picture-format-blue-byte - picture-format-alpha-byte - picture-format-colormap - - ;; picture object - picture-repeat - picture-alpha-map - picture-alpha-x-origin - picture-alpha-y-origin - picture-clip-x-origin - picture-clip-y-origin - picture-clip-mask - picture-graphics-exposures - picture-subwindow-mode - picture-poly-edge - picture-poly-mode - picture-dither - picture-component-alpha - picture-drawable - - find-matching-picture-formats - find-window-picture-format - render-free-picture - render-free-glyph-set - render-query-version - ;; render-query-picture-formats - render-fill-rectangle - render-composite - render-create-glyph-set - render-reference-glyph-set - render-composite-glyphs - render-add-glyph - render-add-glyph-from-picture - render-free-glyphs)) - -(pushnew :clx-ext-render *features*) - -(define-extension "RENDER") - -;;;; Request constants - -;; Note: Although version numbers are given render.h where the request -;; numbers are defined, render-query-version returns 0.0 all displays -;; i tested. --GB 2004-07-21 - -(defconstant +X-RenderQueryVersion+ 0) ;done -(defconstant +X-RenderQueryPictFormats+ 1) -(defconstant +X-RenderQueryPictIndexValues+ 2) ;0.7 -(defconstant +X-RenderQueryDithers+ 3) -(defconstant +X-RenderCreatePicture+ 4) ;done -(defconstant +X-RenderChangePicture+ 5) ;done -(defconstant +X-RenderSetPictureClipRectangles+ 6) ;done -(defconstant +X-RenderFreePicture+ 7) ;done -(defconstant +X-RenderComposite+ 8) ;we need better arglist -(defconstant +X-RenderScale+ 9) -(defconstant +X-RenderTrapezoids+ 10) ;low-level done -(defconstant +X-RenderTriangles+ 11) ;low-level done -(defconstant +X-RenderTriStrip+ 12) -(defconstant +X-RenderTriFan+ 13) -(defconstant +X-RenderColorTrapezoids+ 14) ;nyi in X server, not mentioned in renderproto.h -(defconstant +X-RenderColorTriangles+ 15) ;nyi in X server, not mentioned in renderproto.h -(defconstant +X-RenderTransform+ 16) ;commented out in render.h -(defconstant +X-RenderCreateGlyphSet+ 17) ;done -(defconstant +X-RenderReferenceGlyphSet+ 18) ;done -(defconstant +X-RenderFreeGlyphSet+ 19) ;done -(defconstant +X-RenderAddGlyphs+ 20) ;done, untested -(defconstant +X-RenderAddGlyphsFromPicture+ 21) ;done, untested -(defconstant +X-RenderFreeGlyphs+ 22) ;done, untested -(defconstant +X-RenderCompositeGlyphs8+ 23) ;done -(defconstant +X-RenderCompositeGlyphs16+ 24) ;done -(defconstant +X-RenderCompositeGlyphs32+ 25) ;done - -;; >= 0.1 - -(defconstant +X-RenderFillRectangles+ 26) ;single rectangle version done - -;; >= 0.5 - -(defconstant +X-RenderCreateCursor+ 27) - -;; >= 0.6 - -(defconstant +X-RenderSetPictureTransform+ 28) ;I don't understand what this one should do. -(defconstant +X-RenderQueryFilters+ 29) ;seems to be there on server side - ; some guts of its implementation there. -(defconstant +X-RenderSetPictureFilter+ 30) -(defconstant +X-RenderCreateAnimCursor+ 31) ;What has render to do with cursors? - -;;;; - -;; Sanity measures: - -;; We do away with the distinction between pict-format and -;; picture-format-info. That is we cache picture-format-infos. - -(defstruct render-info - major-version - minor-version - picture-formats) - -(defun display-render-info (display) - (getf (xlib:display-plist display) 'render-info)) - -(defun (setf display-render-info) (new-value display) - (setf (getf (xlib:display-plist display) 'render-info) - new-value)) - -(defun ensure-render-initialized (display) - "Ensures that the RENDER extension is initialized. Should be called -by every function, which attempts to generate RENDER requests." - ;; xxx locking? - (unless (display-render-info display) - (let ((q (make-render-info))) - (multiple-value-bind (maj min) (render-query-version display) - (setf (render-info-major-version q) maj - (render-info-minor-version q) min) - (setf (render-info-picture-formats q) - (make-hash-table :test #'eql)) - (dolist (pf (render-query-picture-formats display)) - (setf (gethash (picture-format-id pf) (render-info-picture-formats q)) - pf)) - (setf (display-render-info display) q))))) - -(defun find-matching-picture-formats - (display - &key depth-min depth-max depth - red-min red-max red - green-min green-max green - blue-min blue-max blue - alpha-min alpha-max alpha - type - colormap) - ;; - (ensure-render-initialized display) - (let ((res nil)) - (maphash (lambda (k f) - (declare (ignore k)) - (when (and - (or (null type) (eql (picture-format-type f) type)) - (or (null colormap) (eql (picture-format-colormap f) colormap)) - ;; min - (or (null depth-min) (>= (picture-format-depth f) depth-min)) - (or (null red-min) (>= (byte-size (picture-format-red-byte f)) red-min)) - (or (null green-min) (>= (byte-size (picture-format-green-byte f)) green-min)) - (or (null blue-min) (>= (byte-size (picture-format-blue-byte f)) blue-min)) - (or (null alpha-min) (>= (byte-size (picture-format-alpha-byte f)) alpha-min)) - ;; max - (or (null depth-max) (<= (picture-format-depth f) depth-max)) - (or (null red-max) (<= (byte-size (picture-format-red-byte f)) red-max)) - (or (null green-max) (<= (byte-size (picture-format-green-byte f)) green-max)) - (or (null blue-max) (<= (byte-size (picture-format-blue-byte f)) blue-max)) - (or (null alpha-max) (<= (byte-size (picture-format-alpha-byte f)) alpha-max)) - ;; match - (or (null depth) (= (picture-format-depth f) depth)) - (or (null red) (= (byte-size (picture-format-red-byte f)) red)) - (or (null green) (= (byte-size (picture-format-green-byte f)) green)) - (or (null blue) (= (byte-size (picture-format-blue-byte f)) blue)) - (or (null alpha) (= (byte-size (picture-format-alpha-byte f)) alpha))) - (pushnew f res))) - (render-info-picture-formats - (display-render-info display))) - res)) - -(defun find-window-picture-format (window) - "Find the picture format which matches the given window." - (let* ((vi (window-visual-info window)) - (display (window-display window))) - (ensure-render-initialized display) - (case (visual-info-class vi) - ((:true-color) - (maphash (lambda (k f) - (declare (ignore k)) - (when (and (eql (picture-format-type f) :direct) - (eql (picture-format-depth f) (drawable-depth window)) - (eql (dpb -1 (picture-format-red-byte f) 0) - (visual-info-red-mask vi)) - (eql (dpb -1 (picture-format-green-byte f) 0) - (visual-info-green-mask vi)) - (eql (dpb -1 (picture-format-blue-byte f) 0) - (visual-info-blue-mask vi)) - (eql (byte-size (picture-format-alpha-byte f)) 0)) - (return-from find-window-picture-format f))) - (render-info-picture-formats - (display-render-info display)))) - (t - )))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (define-accessor picture (32) - ((index) index :blip) - ((index thing) `(resource-id-put ,index (picture-id ,thing)))) - (define-accessor glyph-set (32) - ((index) index :blip) - ((index thing) `(resource-id-put ,index (glyph-set-id ,thing))))) - -;;; picture format - -(defstruct picture-format - display - (id 0 :type (unsigned-byte 29)) - type - depth - red-byte - green-byte - blue-byte - alpha-byte - colormap) - -(defmethod print-object ((object picture-format) stream) - (let ((abbrev - (with-output-to-string (bag) - ;; build an abbreviated representation of the format - (let ((bytes (sort (list (cons "r" (picture-format-red-byte object)) - (cons "g" (picture-format-green-byte object)) - (cons "b" (picture-format-blue-byte object)) - (cons "a" (picture-format-alpha-byte object))) - #'> - :key #'(lambda (x) (byte-position (cdr x)))))) - (dolist (k bytes) - (unless (zerop (byte-size (cdr k))) - (format bag " ~A~D" (car k) (byte-size (cdr k))))))))) - (print-unreadable-object (object stream :type t :identity nil) - (format stream "~D ~S ~S ~S~A" - (picture-format-id object) - (picture-format-colormap object) - (picture-format-depth object) - (picture-format-type object) abbrev)))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (define-accessor picture-format (32) - ((index) `(gethash (read-card32 ,index) - (render-info-picture-formats (display-render-info .display.)))) - ((index thing) `(write-card32 ,index (picture-format-id ,thing)))) - (define-accessor render-op (8) - ((index) `(member8-get ,index - :clear :src :dst :over :over-reverse :in :in-reverse - :out :out-reverse :atop :atop-reverse :xor :add :saturate - '#:undefined-pict-op-Eh '#:undefined-pict-op-Fh - :disjoint-clear :disjoint-src :disjoint-dst :disjoint-over - :disjoint-over-reverse :disjoint-in :disjoint-in-reverse - :disjoint-out :disjoint-out-reverse :disjoint-atop - :disjoint-atop-reverse :disjoint-xor - '#:undefined-pict-op-1Ch '#:undefined-pict-op-1Dh - '#:undefined-pict-op-1Eh '#:undefined-pict-op-1Fh - :conjoint-clear :conjoint-src :conjoint-dst :conjoint-over - :conjoint-over-reverse :conjoint-in :conjoint-in-reverse - :conjoint-out :conjoint-out-reverse :conjoint-atop - :conjoint-atop-reverse :conjoint-xor)) - ((index thing) `(member8-put ,index ,thing - :clear :src :dst :over :over-reverse :in :in-reverse - :out :out-reverse :atop :atop-reverse :xor :add :saturate - '#:undefined-pict-op-Eh '#:undefined-pict-op-Fh - :disjoint-clear :disjoint-src :disjoint-dst :disjoint-over - :disjoint-over-reverse :disjoint-in :disjoint-in-reverse - :disjoint-out :disjoint-out-reverse :disjoint-atop - :disjoint-atop-reverse :disjoint-xor - '#:undefined-pict-op-1Ch '#:undefined-pict-op-1Dh - '#:undefined-pict-op-1Eh '#:undefined-pict-op-1Fh - :conjoint-clear :conjoint-src :conjoint-dst :conjoint-over - :conjoint-over-reverse :conjoint-in :conjoint-in-reverse - :conjoint-out :conjoint-out-reverse :conjoint-atop - :conjoint-atop-reverse :conjoint-xor))) - (deftype render-op () - '(member :clear :src :dst :over :over-reverse :in :in-reverse - :out :out-reverse :atop :atop-reverse :xor :add :saturate - :disjoint-clear :disjoint-src :disjoint-dst :disjoint-over - :disjoint-over-reverse :disjoint-in :disjoint-in-reverse - :disjoint-out :disjoint-out-reverse :disjoint-atop - :disjoint-atop-reverse :disjoint-xor - :conjoint-clear :conjoint-src :conjoint-dst :conjoint-over - :conjoint-over-reverse :conjoint-in :conjoint-in-reverse - :conjoint-out :conjoint-out-reverse :conjoint-atop - :conjoint-atop-reverse :conjoint-xor))) - -;; Now these pictures objects are like graphics contexts. I was about -;; to introduce a synchronous mode, realizing that the RENDER protocol -;; provides no provision to actually query a picture object's values. -;; *sigh* - -(def-clx-class (picture (:copier nil)) - (id 0 :type resource-id) - (display nil :type (or null display)) - (plist nil :type list) ; Extension hook - (format) - (%changed-p) - (%server-values) - (%values) - (%drawable)) - -(defun picture-drawable (picture) - (picture-%drawable picture)) - -;; xx make id, display, format readonly - -(defun %render-change-picture-clip-rectangles (picture rectangles) - "Dont call me, use (SETF PICTURE-CLIP-MASK) instead." - (declare (optimize (speed 0))) - (let ((display (picture-display picture))) - (ensure-render-initialized display) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderSetPictureClipRectangles+) - (picture picture) - (int16 (picture-clip-x-origin picture)) - (int16 (picture-clip-y-origin picture)) - ((sequence :format int16) rectangles)))) - -(macrolet ((foo (&rest specs) - `(progn - ,@(loop for (type slot default) in specs - for index from 0 - collect - `(progn - (defun ,(xintern 'picture- slot) (picture) - (aref (picture-%values picture) ,index)) - (defun (setf ,(xintern 'picture- slot)) (new-value picture) - (setf (picture-%changed-p picture) t) - (setf (aref (picture-%values picture) ,index) new-value)))) - - (defun synchronise-picture-state (picture) - (when (picture-%changed-p picture) - (let ((display (picture-display picture))) - (ensure-render-initialized display) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderChangePicture+) - (picture picture) - (mask - ,@(loop for (type slot default) in specs - for index from 0 - collect - `(,type (and - ,(cond ((eql slot 'clip-mask) - `(not (typep (aref (picture-%values picture) ,index) - 'sequence))) - (t - 't)) - (not (eq (aref (picture-%values picture) ,index) - (aref (picture-%server-values picture) ,index))) - (setf (aref (picture-%server-values picture) ,index) - (aref (picture-%values picture) ,index)))))))) - ,(let ((index (position 'clip-mask specs :key #'second))) - `(unless (eql (aref (picture-%values picture) ,index) - (aref (picture-%server-values picture) - ,index)) - (%render-change-picture-clip-rectangles - picture (aref (picture-%values picture) ,index)) - (setf (aref (picture-%server-values picture) ,index) - (aref (picture-%values picture) ,index)))) - - (setf (picture-%changed-p picture) nil))) - - (defun render-create-picture - (drawable - &key format - (picture (make-picture :display (drawable-display drawable))) - ,@(loop for (type slot default-value) in specs - collect (cond ((eql slot 'clip-mask) - `(clip-mask :none)) - (t - slot))) - ) - ;; xxx also offer to give a colormap instead of a picture-format - ;; values! - (let ((display (drawable-display drawable))) - (ensure-render-initialized display) - (unless format - ;; xxx check for drawable being a window - (setf format (find-window-picture-format drawable))) - (let ((pid (allocate-resource-id display picture 'picture))) - (setf (picture-id picture) pid) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderCreatePicture+) - (resource-id pid) - (drawable drawable) - (picture-format format) - (mask - ,@(loop for (type slot default) in specs - collect - (cond ((eql slot 'clip-mask) - (list type `(and - (not (typep clip-mask 'sequence)) - clip-mask))) - (t - (list type slot))))))) - (when (typep clip-mask 'sequence) - (%render-change-picture-clip-rectangles picture clip-mask)) - (setf (picture-format picture) format) - (setf (picture-%server-values picture) - (vector ,@(loop for (type slot default) in specs - collect - `(or ,slot ,default)))) - (setf (picture-%values picture) (copy-seq (picture-%server-values picture))) - (setf (picture-%drawable picture) drawable) - picture)) - - (defconstant +picture-state-length+ - ,(length specs)) ))) - - (foo ((member :off :on) repeat :off) - ((or (member :none) picture) alpha-map :none) - (int16 alpha-x-origin 0) - (int16 alpha-y-origin 0) - (int16 clip-x-origin 0) - (int16 clip-y-origin 0) - ;; ### Now that is not correct is it?: - ((or (member :none) pixmap) clip-mask :none) - ((member :off :on) graphics-exposures :on) - ((member :clip-by-children :include-inferiors) subwindow-mode :clip-by-children) - ((member :sharp :smooth) poly-edge :smooth) - ((member :precise :imprecise) poly-mode :precise) - ((or (member :none) #||xatom||#) dither :none) - ((member :off :on) component-alpha :off))) - -(defun render-free-picture (picture) - (let ((display (picture-display picture))) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderFreePicture+) - (picture picture)))) - -(defun render-free-glyph-set (glyph-set) - (let ((display (glyph-set-display glyph-set))) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderFreeGlyphSet+) - (glyph-set glyph-set)))) - -(defun render-query-version (display) - (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil) - ((data +X-RenderQueryVersion+) - (card32 0) - (card32 1)) - (values - (card32-get 8) - (card32-get 12) ))) - -(defun render-query-picture-formats (display) - (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil) - ((data +X-RenderQueryPictFormats+)) - (let ((n-picture-formats (card32-get 8)) - (n-screens (card32-get 12)) - (n-depths (card32-get 16)) - (n-visuals (card32-get 20)) - (n-subpixel (card32-get 24))) - (declare (ignore n-screens n-depths n-visuals n-subpixel)) - (loop for i below n-picture-formats - collect - (let ((off (+ (* 8 4) - (* i 28)))) ;size of picture-format-info - (make-picture-format - :display display - :id (card32-get (+ off 0)) - :type (member8-get (+ off 4) :indexed :direct) - :depth (card8-get (+ off 5)) - :red-byte (byte (integer-length (card16-get (+ off 10))) - (card16-get (+ off 8))) - :green-byte (byte (integer-length (card16-get (+ off 14))) - (card16-get (+ off 12))) - :blue-byte (byte (integer-length (card16-get (+ off 18))) - (card16-get (+ off 16))) - :alpha-byte (byte (integer-length (card16-get (+ off 22))) - (card16-get (+ off 20))) - :colormap (let ((cmid (card32-get (+ off 24)))) - (unless (zerop cmid) - (lookup-colormap display cmid))))))))) - -(defun render-fill-rectangle (picture op color x1 y1 w h) - (let ((display (picture-display picture))) - (ensure-render-initialized display) - (synchronise-picture-state picture) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderFillRectangles+) - (render-op op) ;op - (card8 0) ;pad - (card16 0) ;pad - (resource-id (picture-id picture)) - (card16 (elt color 0)) (card16 (elt color 1)) (card16 (elt color 2)) (card16 (elt color 3)) - (int16 x1) (int16 y1) (card16 w) (card16 h)))) - -;; fill rectangles, colors. - -(defun render-triangles-1 (picture op source src-x src-y format coord-sequence) - ;; For performance reasons we do a special typecase on (simple-array - ;; (unsigned-byte 32) (*)), so that it'll be possible to have high - ;; performance rasters. - (macrolet ((guts () - '(let ((display (picture-display picture))) - (synchronise-picture-state picture) - (synchronise-picture-state source) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderTriangles+) - (render-op op) ;op - (card8 0) ;pad - (card16 0) ;pad - (resource-id (picture-id source)) - (resource-id (picture-id picture)) - (picture-format format) - (int16 src-x) - (int16 src-y) - ((sequence :format int32) coord-sequence) )))) - (typecase coord-sequence - ((simple-array (unsigned-byte 32) (*)) - (locally - (declare (type (simple-array (unsigned-byte 32) (*)) coord-sequence)) - (guts))) - (t - (guts))))) - -#|| -(defun render-set-picture-transform (picture mxx mxy dx mxy myy dy &optional (mwx 0) (mwy 0) (dw 1)) - ...) -||# - -(defun render-set-picture-transform (picture a b c d e f p q r) - (let ((display (picture-display picture))) - (ensure-render-initialized display) - (synchronise-picture-state picture) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderSetPictureTransform+) - #| - (card8 0) ;; render-op op) ;op - (card8 0) ;pad - (card16 0) ;pad - |# - (resource-id (picture-id picture)) - - (card32 a) - (card32 b) - (card32 c) - - (card32 d) - (card32 e) - (card32 f) - - (card32 p) - (card32 q) - (card32 r)))) - -(defun render-query-filters (drawable) - (let ((display (drawable-display drawable))) - (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil) - ((data +X-RenderQueryFilters+) - (drawable drawable)) - (let* ((len (card32-get 4)) - (n-aliases (card32-get 8)) - (n-filters (card32-get 12)) - (off (+ (* 8 4) (* 4 (ceiling (* 2 n-aliases) 4))))) - (print (list :aliases - (loop for i below n-aliases collect (card16-get (+ (* 8 4) (* i 2)))))) - (print (list :foo len n-aliases n-filters - (loop for i below len - collect (card8-get (+ off 0 (* 4 i))) - collect (card8-get (+ off 1 (* 4 i))) - collect (card8-get (+ off 2 (* 4 i))) - collect (card8-get (+ off 3 (* 4 i)))))) - (print - (labels ((grab-string (j) - (let ((n (card8-get j))) - (incf j) - (values - (map 'string #'code-char (loop repeat n collect (card8-get j) do (incf j))) - j)))) - (loop repeat n-filters collect - (multiple-value-bind (s j) (grab-string off) - (setf off j) - (intern (string-upcase s) :keyword))))) - #+NIL - (loop for i below n-picture-formats - collect - (let ((off (+ (* 8 4) - (* i 28)))) ;size of picture-format-info - (make-picture-format - :display display - :id (card32-get (+ off 0)) - :type (member8-get (+ off 4) :indexed :direct) - :depth (card8-get (+ off 5)) - :red-byte (byte (integer-length (card16-get (+ off 10))) - (card16-get (+ off 8))) - :green-byte (byte (integer-length (card16-get (+ off 14))) - (card16-get (+ off 12))) - :blue-byte (byte (integer-length (card16-get (+ off 18))) - (card16-get (+ off 16))) - :alpha-byte (byte (integer-length (card16-get (+ off 22))) - (card16-get (+ off 20))) - :colormap (let ((cmid (card32-get (+ off 24)))) - (unless (zerop cmid) - (lookup-colormap display cmid)))))))))) - -(defun render-set-filter (picture filter) - (let ((display (picture-display picture))) - (ensure-render-initialized display) - (synchronise-picture-state picture) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderSetPictureFilter+) - (resource-id (picture-id picture)) - (card16 (length filter)) - (card16 0) ;pad - ((sequence :format card8) (map 'vector #'char-code filter))))) - - - -#|| -(defun render-triangle (destination source x1 y1 x2 y2 x3 y3 &key (src-x 0) (src-y 0) (format nil) (op :over)) - (render-triangles-1 destination op source ...) - ) -||# - -(defun render-trapezoids-1 (picture op source src-x src-y mask-format coord-sequence) - ;; coord-sequence is top bottom - ;; line-1-x1 line-1-y1 line-1-x2 line-1-y2 - ;; line-2-x1 line-2-y1 line-2-x2 line-2-y2 ... - ;; - (let ((display (picture-display picture))) - (synchronise-picture-state picture) - (synchronise-picture-state source) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderTrapezoids+) - (render-op op) ;op - (card8 0) ;pad - (card16 0) ;pad - (resource-id (picture-id source)) - (resource-id (picture-id picture)) - ((or (member :none) picture-format) mask-format) - (int16 src-x) - (int16 src-y) - ((sequence :format int32) coord-sequence) ))) - -(defun render-composite (op - source mask dest - src-x src-y mask-x mask-y dst-x dst-y - width height) - (let ((display (picture-display source))) - (synchronise-picture-state source) - (when mask (synchronise-picture-state mask)) - (synchronise-picture-state dest) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderComposite+) - (render-op op) ;op - (card8 0) ;pad - (card16 0) ;pad - (resource-id (picture-id source)) - (resource-id (if mask (picture-id mask) 0)) - (resource-id (picture-id dest)) - (int16 src-x) - (int16 src-y) - (int16 mask-x) - (int16 mask-y) - (int16 dst-x) - (int16 dst-y) - (card16 width) - (card16 height)))) - -(def-clx-class (glyph-set (:copier nil) - ) - (id 0 :type resource-id) - (display nil :type (or null display)) - (plist nil :type list) ; Extension hook - (format)) - -(defun render-create-glyph-set (format &key glyph-set) - (let ((display (picture-format-display format))) - (let* ((glyph-set (or glyph-set (make-glyph-set :display display))) - (gsid (setf (glyph-set-id glyph-set) - (allocate-resource-id display glyph-set 'glyph-set)))) - (declare (ignore gsid)) - (setf (glyph-set-format glyph-set) format) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderCreateGlyphSet+) - (glyph-set glyph-set) - (picture-format format)) - glyph-set))) - -(defun render-reference-glyph-set (existing-glyph-set &key glyph-set) - (let ((display (glyph-set-display existing-glyph-set))) - (let* ((glyph-set (or glyph-set (make-glyph-set :display display))) - (gsid (setf (glyph-set-id glyph-set) - (allocate-resource-id display glyph-set 'glyph-set)))) - (declare (ignore gsid)) - (setf (glyph-set-format glyph-set) - (glyph-set-format existing-glyph-set)) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderReferenceGlyphSet+) - (glyph-set glyph-set) - (glyph-set existing-glyph-set)) - glyph-set))) - -(defun render-composite-glyphs-8 (dest glyph-set source dest-x dest-y sequence - &key (op :over) - (alu op) ;for the fun of it - (src-x 0) - (src-y 0) - (mask-format :none) - (start 0) - (end (length sequence))) - (let ((display (picture-display dest))) - (ensure-render-initialized display) - (synchronise-picture-state dest) - (synchronise-picture-state source) - (when (stringp sequence) - ;; lazy me, but then you should not confuse glyphs with - ;; characters anyway. - (setf sequence (map 'vector #'char-code sequence))) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderCompositeGlyphs8+) - (render-op alu) - (card8 0) (card16 0) ;padding - (picture source) - (picture dest) - ((or (member :none) picture-format) mask-format) - (glyph-set glyph-set) - (int16 src-x) (int16 src-y) - (card8 (- end start)) ;length of glyph elt - (card8 0) (card16 0) ;padding - (int16 dest-x) (int16 dest-y) ;dx, dy - ((sequence :format card8) sequence)))) - -(defmacro %render-composite-glyphs - (opcode type transform display dest glyph-set source dest-x dest-y sequence - alu src-x src-y mask-format start end) - (let ((size (ecase type (card8 1) (card16 2) (card32 4))) - ;; FIXME: the last chunk for CARD8 can be 254. - (chunksize (ecase type (card8 252) (card16 254) (card32 254)))) - `(multiple-value-bind (nchunks leftover) - (floor (- end start) ,chunksize) - (let* ((payloadsize (+ (* nchunks (+ 8 (* ,chunksize ,size))) - (if (> leftover 0) - (+ 8 (* 4 (ceiling (* leftover ,size) 4))) - 0))) - (request-length (+ 7 (/ payloadsize 4)))) - (declare (integer request-length)) - (with-buffer-request (,display (extension-opcode ,display "RENDER") :length (* 4 request-length)) - (data ,opcode) - (length request-length) - (render-op ,alu) - (card8 0) (card16 0) ;padding - (picture ,source) - (picture ,dest) - ((or (member :none) picture-format) ,mask-format) - (glyph-set ,glyph-set) - (int16 ,src-x) (int16 ,src-y) - (progn - (let ((boffset (+ buffer-boffset 28)) - (start ,start) - (end ,end) - (dest-x ,dest-x) - (dest-y ,dest-y)) - (dotimes (i nchunks) - (set-buffer-offset boffset) - (put-items (0) - (card8 ,chunksize) - (card8 0) - (card16 0) - (int16 dest-x) - (int16 dest-y) - ((sequence :start start :end (+ start ,chunksize) :format ,type :transform ,transform :appending t) ,sequence)) - (setq dest-x 0 dest-y 0) - (incf boffset (+ 8 (* ,chunksize ,size))) - (incf start ,chunksize)) - (when (> leftover 0) - (set-buffer-offset boffset) - (put-items (0) - (card8 leftover) - (card8 0) - (card16 0) - (int16 dest-x) - (int16 dest-y) - ((sequence :start start :end end :format ,type :transform ,transform :appending t) ,sequence)) - ;; padding? - (incf boffset (+ 8 (* 4 (ceiling (* leftover ,size) 4))))) - (setf (buffer-boffset ,display) boffset)))))))) - -(defun render-composite-glyphs (dest glyph-set source dest-x dest-y sequence - &key (op :over) - (alu op) ;for the fun of it - (src-x 0) - (src-y 0) - (mask-format :none) - (start 0) - (end (length sequence))) - ;; xxx do we want to go with some translate function as draw-glyphs? - (declare (type array-index start end)) - (let ((display (picture-display dest))) - (ensure-render-initialized display) - (synchronise-picture-state dest) - (synchronise-picture-state source) - ;; hmm find out the element size - (typecase sequence - ((array (unsigned-byte 8) (*)) - (%render-composite-glyphs +X-RenderCompositeGlyphs8+ card8 nil - display dest glyph-set source dest-x dest-y sequence alu src-x - src-y mask-format start end)) - ((array (unsigned-byte 16) (*)) - (%render-composite-glyphs +X-RenderCompositeGlyphs16+ card16 nil - display dest glyph-set source dest-x dest-y sequence alu src-x - src-y mask-format start end)) - ((array (unsigned-byte 32) (*)) - (%render-composite-glyphs +X-RenderCompositeGlyphs32+ card32 nil - display dest glyph-set source dest-x dest-y sequence alu src-x - src-y mask-format start end)) - (string - (%render-composite-glyphs #.(cond ((<= char-code-limit (expt 2 8)) '+X-RenderCompositeGlyphs8+) - ((<= char-code-limit (expt 2 16)) '+X-RenderCompositeGlyphs16+) - ((<= char-code-limit (expt 2 32)) '+X-RenderCompositeGlyphs32+) - (t - (error "Wow!"))) - #.(cond ((<= char-code-limit (expt 2 8)) 'card8) - ((<= char-code-limit (expt 2 16)) 'card16) - ((<= char-code-limit (expt 2 32)) 'card32) - (t - (error "Wow!"))) - #'char-code - display dest glyph-set source dest-x dest-y sequence alu src-x - src-y mask-format start end)) - (t - ;; should we bother testing the array element type? - (%render-composite-glyphs +X-RenderCompositeGlyphs32+ card32 - #'(lambda (elt) - (if (characterp elt) - (char-code elt) - elt)) - display dest glyph-set source dest-x dest-y sequence alu src-x - src-y mask-format start end))) )) - -;; --- idea: Allow data to be an image to avoid unecessary consing? - noss -(defun render-add-glyph (glyph-set id &key x-origin y-origin x-advance y-advance data) - (let ((display (glyph-set-display glyph-set))) - (ensure-render-initialized display) - (let* ((w (array-dimension data 1)) - (h (array-dimension data 0)) - (bitmap-format (display-bitmap-format display)) - (unit (bitmap-format-unit bitmap-format)) - (byte-lsb-first-p (display-image-lsb-first-p display)) - (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) - (let* ((byte-per-line (* 4 (ceiling - (* w (picture-format-depth (glyph-set-format glyph-set))) - 32))) - (request-length (+ 28 - (* h byte-per-line)))) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderAddGlyphs+) - (length (ceiling request-length 4)) - (glyph-set glyph-set) - (card32 1) ;number glyphs - (card32 id) ;id - (card16 w) - (card16 h) - (int16 x-origin) - (int16 y-origin) - (int16 x-advance) - (int16 y-advance) - (progn - (setf (buffer-boffset display) (advance-buffer-offset 28)) - (let ((im (create-image :width w :height h :depth 8 :data data))) - (write-image-z display im 0 0 w h - byte-per-line ;padded bytes per line - unit byte-lsb-first-p bit-lsb-first-p)) ))) ))) - -(defun render-add-glyph-from-picture (glyph-set picture - &key x-origin y-origin x-advance y-advance - x y width height) - ;; untested, the duplication of x-origin seems bogus. - ;; Still untested, but these modifications seem to be more likely, (x,y) would be the offset into the picture. - ;; and orgin advance would be properties of the defined glyph. - (let ((display (glyph-set-display glyph-set))) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderAddGlyphsFromPicture+) - (glyph-set glyph-set) - (picture picture) - (card16 width) - (card16 height) - (card16 x-origin) - (card16 y-origin) - (card16 x-advance) - (card16 y-advance) - (card16 x) - (card16 y)))) - -;; untested -(defun render-free-glyphs (glyph-set glyphs) - "This request removes glyphs from glyph-set. Each glyph must exist in glyph-set (else a Match error results)." - (let ((display (glyph-set-display glyph-set))) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderFreeGlyphs+) - (glyph-set glyph-set) - ((sequence :format card32) glyphs)))) - - -#|| -;;; -------------------------------------------------------------------------------- - -;; testing code: - -(defun x (op) - (let ((dpy (open-display ""))) - (render-query-version dpy) - (unwind-protect - (let* ((win (screen-root (first (display-roots dpy)))) - (display dpy) - (pf (find-window-picture-format win)) - (pm (xlib:create-pixmap - :depth (xlib:drawable-depth win) - :drawable win :width 1 :height 1)) - (pm.p (render-create-picture pm - :format pf - :repeat :on)) - (win.p (render-create-picture win :format pf)) - (gs (render-create-glyph-set (first - (find-matching-picture-formats - dpy - :alpha 8 - :red-max 0 - :green-max 0 - :blue-max 0))))) - (xlib:clear-area win) - (render-fill-rectangle pm.p :src (list #xFFFF 0 0 0) 0 0 100 100) - (render-add-glyph gs 18 - :data (make-array (list 3 3) - :initial-contents '((255 000 000) - (000 255 000) - (000 000 255)) - :element-type '(unsigned-byte 8)) - :x-advance 4 - :y-advance 0 - :x-origin 0 - :y-origin 0) - (let ((w 50) - (h 50)) - (let ((data (make-array (list h w) :element-type '(unsigned-byte 8) :initial-element 0))) - (dotimes (i w) - (dotimes (j h) - (setf (aref data i j) (* 3 i)))) - (render-add-glyph gs 17 - :data data - :x-advance (+ w 2) - :y-advance 0 - :x-origin 0 - :y-origin 0))) - - (render-composite-glyphs-8 win.p gs pm.p - 200 330 - (vector 17 18 18 17 17 17 17 17 17 17) - :alu op - ) - ;; - (display-finish-output dpy) - (close-display dpy))))) - -(defun z (op) - (let ((dpy (open-display ""))) - (unwind-protect - (let* ((win (screen-root (first (display-roots dpy)))) - (pic (render-create-picture win)) - (fmt (first (find-matching-picture-formats - dpy - :red-min 8 - :green-min 8 - :blue-min 8 - :alpha-min 8))) - (px (xlib:create-pixmap :width 256 :height 256 :depth (picture-format-depth fmt) - :drawable win)) - (px.pic (render-create-picture px :format fmt)) - (px.gc (xlib:create-gcontext :drawable px))) - (xlib:clear-area win) - ;; - (render-fill-rectangle px.pic :src - (list #x8000 #x0000 #x8000 #xFFFF) - 0 0 256 256) - - (render-composite :src pic pic px.pic - 350 350 350 350 0 0 256 256) - ;; - (render-fill-rectangle px.pic :over - (list #x8000 #x8000 #x8000 #x8000) - 0 0 100 100) - (render-composite :src - px.pic px.pic pic - 0 0 0 0 350 350 - 256 256) - (render-fill-rectangle pic op (list #x0 #x0 #x0 #x8000) 200 200 800 800) - (display-finish-output dpy)) - (close-display dpy)))) - -;;; ---------------------------------------------------------------------------------------------------- - -(defun y (op) - (let ((dpy (open-display ""))) - (render-query-version dpy) - (unwind-protect - (let* ((win (screen-root (first (display-roots dpy)))) - (pic - (render-create-picture win)) - (px (xlib:create-pixmap :drawable win - :width 256 - :height 256 - :depth 32)) - (px.gc (xlib:create-gcontext :drawable px))) - (dotimes (x 256) - (dotimes (y 256) - (setf (xlib:gcontext-foreground px.gc) - (dpb x (byte 8 24) - (dpb y (byte 8 16) - (dpb y (byte 8 8) - y)))) - (xlib:draw-point px px.gc x y) - )) - (xlib:clear-area win) - (let ((q (render-create-picture px - :format - (first (find-matching-picture-formats - dpy - :depth 32 - :alpha 8 :red 8 :green 8 :blue 8)) - :component-alpha :on - :repeat :off))) - (render-composite op - q - q - pic - 0 0 - 0 0 - 100 100 - 400 400)) - (let () - ;;(render-fill-rectangle pic op (list 255 255 255 255) 100 100 200 200) - (display-finish-output dpy))) - (close-display dpy)))) - -(defun zz () - (let* ((dpy (xlib:open-display "")) - (win (screen-root (first (display-roots dpy)))) - (pic (render-create-picture win))) - (xlib:clear-area win) - (setf (picture-clip-mask pic) (list 100 100 200 2000)) - (render-fill-rectangle pic :over (list #xFFFF 0 0 #x400) 0 0 2000 2000) - (display-finish-output dpy) - (close-display dpy))) -||# - - -;;;; Cursors - -(defun render-create-cursor (picture &optional (x 0) (y 0)) - (let ((display (picture-display picture))) - (ensure-render-initialized display) - (synchronise-picture-state picture) - (let* ((cursor (make-cursor :display display)) - (cid (allocate-resource-id display cursor 'cursor))) - (setf (cursor-id cursor) cid) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderCreateCursor+) - (resource-id cid) - (resource-id (picture-id picture)) - (card16 x) - (card16 y)) - cursor))) diff -Nru ecl-16.1.2/src/clx/xtest.lisp ecl-16.1.3+ds/src/clx/xtest.lisp --- ecl-16.1.2/src/clx/xtest.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/xtest.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,154 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- -;;; -;;; Implementation of the XTest extension as described by -;;; http://www.x.org/docs/Xext/xtest.pdf -;;; -;;; Written by Lionel Flandrin in july -;;; 2008 and placed in the public domain. -;;; -;;; TODO: -;;; * Implement XTestSetVisualIDOfVisual and XTestDiscard -;;; * Add the missing (declare (type ... - -(defpackage :xtest - (:use :common-lisp :xlib) - (:import-from :xlib - #:data - #:card8 - #:card8-get - #:card16 - #:card16-get - #:card32 - #:card32-get - #:extension-opcode - #:define-extension - #:gcontext - #:resource-id - #:window-id - #:cursor - #:make-cursor - #:with-buffer-request-and-reply - #:with-buffer-request - #:display) - (:export - ;; Constants - #:+major-version+ - #:+minor-version+ - - ;; Functions - #:set-gc-context-of-gc - #:get-version - #:compare-cursor - #:fake-motion-event - #:fake-button-event - #:fake-key-event - #:grab-control)) - -(in-package :xtest) - -(define-extension "XTEST") - -(defmacro opcode (display) - `(extension-opcode ,display "XTEST")) - -;;; The version we implement -(defconstant +major-version+ 2) -(defconstant +minor-version+ 2) - -(defconstant +none+ 0) -(defconstant +current-cursor+ 1) - -;;; XTest opcodes -(defconstant +get-version+ 0) -(defconstant +compare-cursor+ 1) -(defconstant +fake-input+ 2) -(defconstant +grab-control+ 3) - -;;; Fake events -(defconstant +fake-key-press+ 2) -(defconstant +fake-key-release+ 3) -(defconstant +fake-button-press+ 4) -(defconstant +fake-button-release+ 5) -(defconstant +fake-motion-notify+ 6) - -;;; Client operations -(defun set-gc-context-of-gc (gcontext gcontext-id) - (declare (type gcontext gcontext) - (type resource-id gcontext-id)) - (setf (gcontext-id gcontext) gcontext-id)) - -;;; Server requests -(defun get-version (display &optional (major +major-version+) (minor +minor-version+)) - "Returns the major and minor version of the server's XTest implementation" - (declare (type display display)) - (with-buffer-request-and-reply (display (opcode display) nil) - ((data +get-version+) - (card8 major) - (card16 minor)) - (values (card8-get 1) - (card16-get 8)))) - -(defun compare-cursor (display window &optional (cursor-id +current-cursor+)) - (declare (type display display) - (type resource-id cursor-id) - (type window window)) - (with-buffer-request-and-reply (display (opcode display) nil) - ((data +compare-cursor+) - (resource-id (window-id window)) - (resource-id cursor-id)) - (values (card8-get 1)))) - -(defun fake-motion-event (display x y &key (delay 0) relative (root-window-id 0)) - "Move the mouse pointer at coordinates (x, y). If :relative is t, -the movement is relative to the pointer's current position" - (declare (type display display)) - (with-buffer-request (display (opcode display)) - (data +fake-input+) - (card8 +fake-motion-notify+) - (card8 (if relative 1 0)) - (pad16 0) - (card32 delay) - (card32 root-window-id) - (pad32 0 0) - (card16 x) - (card16 y) - (pad32 0 0))) - -(defun fake-button-event (display button pressed &key (delay 0)) - "Send a fake button event (button pressed or released) to the -server. Most of the time, button 1 is the left one, 2 the middle and 3 -the right one but it's not always the case." - (declare (type display display)) - (with-buffer-request (display (opcode display)) - (data +fake-input+) - (card8 (if pressed +fake-button-press+ +fake-button-release+)) - (card8 button) - (pad16 0) - (card32 delay) - (pad32 0 0 0 0 0 0))) - -(defun fake-key-event (display keycode pressed &key (delay 0)) - "Send a fake key event (key pressed or released) to the server based -on its keycode." - (declare (type display display)) - (with-buffer-request (display (opcode display)) - (data +fake-input+) - (card8 (if pressed +fake-key-press+ +fake-key-release+)) - (card8 keycode) - (pad16 0) - (card32 delay) - (pad32 0 0 0 0 0 0))) - -(defun grab-control (display grab?) - "Make the client grab the server, that is allow it to make requests -even when another client grabs the server." - (declare (type display display)) - (with-buffer-request (display (opcode display)) - (data +grab-control+) - (card8 (if grab? 1 0)) - (pad8 0) - (pad16 0))) - -;;; Local Variables: -;;; indent-tabs-mode: nil -;;; End: diff -Nru ecl-16.1.2/src/clx/xvidmode.lisp ecl-16.1.3+ds/src/clx/xvidmode.lisp --- ecl-16.1.2/src/clx/xvidmode.lisp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/clx/xvidmode.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,730 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- -;;; --------------------------------------------------------------------------- -;;; Title: XFree86 video mode extension -;;; Created: 2003 03 28 15:28 -;;; Author: Iban Hatchondo -;;; --------------------------------------------------------------------------- -;;; (c) copyright 2003 by Iban Hatchondo - -;;; -;;; Permission is granted to any individual or institution to use, -;;; copy, modify, and distribute this software, provided that this -;;; complete copyright and permission notice is maintained, intact, in -;;; all copies and supporting documentation. -;;; -;;; 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. -;;; - -;;; THIS IS NOT AN X CONSORTIUM STANDARD OR AN X PROJECT TEAM SPECIFICATION - -;;; DESCRIPTION -;;; -;;; These functions provide an interface to the server extension -;;; XFree86-VidModeExtension which allows the video modes to be -;;; queried, adjusted dynamically and the mode switching to be -;;; controlled. - -;;; [ personal notes ] -;;; -;;; The documentation on this extension is very poor, probably, -;;; because it is not an X standard nor an X project team spec. -;;; Because of that, it need to be tested on some XFree 3.3.6, -;;; and XFree 4.3.x to ensure that all request are correctly -;;; constructed as well as to indentify any obsolete/wrong -;;; functions I made. - -(in-package :xlib) - -(export '(mode-info - mode-info-dotclock - mode-info-hdisplay - mode-info-hsyncstart - mode-info-hsyncend - mode-info-htotal - mode-info-hskew - mode-info-vdisplay - mode-info-vsyncstart - mode-info-vsyncend - mode-info-vtotal - mode-info-flags - mode-info-privsize - mode-info-private - make-mode-info - - xfree86-vidmode-query-version - xfree86-vidmode-set-client-version - xfree86-vidmode-get-permissions - xfree86-vidmode-mod-mode-line - xfree86-vidmode-get-mode-line - xfree86-vidmode-get-all-mode-lines - xfree86-vidmode-add-mode-line - xfree86-vidmode-delete-mode-line - xfree86-vidmode-validate-mode-line - xfree86-vidmode-get-gamma - xfree86-vidmode-set-gamma - xfree86-vidmode-get-gamma-ramp - xfree86-vidmode-set-gamma-ramp - xfree86-vidmode-get-gamma-ramp-size - xfree86-vidmode-lock-mode-switch - xfree86-vidmode-switch-to-mode - xfree86-vidmode-switch-mode - xfree86-vidmode-select-next-mode - xfree86-vidmode-select-prev-mode - xfree86-vidmode-get-monitor - xfree86-vidmode-get-viewport - xfree86-vidmode-set-viewport - xfree86-vidmode-get-dotclocks) - :xlib) - -;; current version numbers -;; -;; major 0 == uses parameter-to-wire functions in XFree86 libXxf86vm. -;; major 1 == uses parameter-to-wire functions hard-coded in xvidtune client. -;; major 2 == uses new protocol version in XFree86 4.0. -(defconstant +xf86vidmode-major-version+ 2) -(defconstant +xf86vidmode-minor-version+ 2) - -;; requests number. -(defconstant +query-version+ 0) -(defconstant +get-mode-line+ 1) -(defconstant +mod-mode-line+ 2) -(defconstant +switch-mode+ 3) -(defconstant +get-monitor+ 4) -(defconstant +lock-mode-switch+ 5) -(defconstant +get-all-mode-lines+ 6) -(defconstant +add-mode-line+ 7) -(defconstant +delete-mode-line+ 8) -(defconstant +validate-mode-line+ 9) -(defconstant +switch-to-mode+ 10) -(defconstant +get-viewport+ 11) -(defconstant +set-viewport+ 12) - -;; new for version 2.x of this extension. -(defconstant +get-dot-clocks+ 13) -(defconstant +set-client-version+ 14) -(defconstant +set-gamma+ 15) -(defconstant +get-gamma+ 16) -(defconstant +get-gamma-ramp+ 17) -(defconstant +set-gamma-ramp+ 18) -(defconstant +get-gamma-ramp-size+ 19) -(defconstant +get-permisions+ 20) - -(define-extension "XFree86-VidModeExtension" - :events (:xfree86-vidmode-notify) - :errors (xf86-vidmode-bad-clock - xf86-vidmode-bad-htimings - xf86-vidmode-bad-vtimings - xf86-vidmode-mode-unsuitable - xf86-vidmode-extension-disabled - xf86-vidmode-client-not-local - xf86-vidmode-zoom-locked)) - -(define-condition xf86-vidmode-bad-clock (request-error) ()) -(define-condition xf86-vidmode-bad-htimings (request-error) ()) -(define-condition xf86-vidmode-bad-vtimings (request-error) ()) -(define-condition xf86-vidmode-mode-unsuitable (request-error) ()) -(define-condition xf86-vidmode-extension-disabled (request-error) ()) -(define-condition xf86-vidmode-client-not-local (request-error) ()) -(define-condition xf86-vidmode-zoom-locked (request-error) ()) - -(define-error xf86-vidmode-bad-clock decode-core-error) -(define-error xf86-vidmode-bad-htimings decode-core-error) -(define-error xf86-vidmode-bad-vtimings decode-core-error) -(define-error xf86-vidmode-mode-unsuitable decode-core-error) -(define-error xf86-vidmode-extension-disabled decode-core-error) -(define-error xf86-vidmode-client-not-local decode-core-error) -(define-error xf86-vidmode-zoom-locked decode-core-error) - -(declare-event :XFree86-VidMode-notify - (card16 sequence) - (window (window event-window)) ; the root window of event screen - (int16 state) ; what happend - (int16 kind) ; what happend - (boolean forced-p) ; extents of a new region - ((or null card32) time)) ; event timestamp - -(defstruct mode-info - (dotclock 0 :type card32) - (hdisplay 0 :type card16) - (hsyncstart 0 :type card16) - (hsyncend 0 :type card16) - (htotal 0 :type card16) - (hskew 0 :type card32) - (vdisplay 0 :type card16) - (vsyncstart 0 :type card16) - (vsyncend 0 :type card16) - (vtotal 0 :type card16) - (flags 0 :type card32) - (privsize 0 :type card32) - (private nil :type sequence)) - -(defmacro vidmode-opcode (display) - `(extension-opcode ,display "XFree86-VidModeExtension")) - -(declaim (inline screen-position)) -(defun screen-position (screen display) - (declare (type display display) - (type screen screen)) - (declare (clx-values position)) - (let ((position (position screen (xlib:display-roots display)))) - (if (not (numberp position)) - (error "screen ~A not found in display ~A" screen display) - position))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; ;;;; -;;;; public XFree86-VidMode Extension routines ;;;; -;;;; ;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun xfree86-vidmode-query-version (display) - "Determine the version of the extension built into the server. -return two values major-version and minor-version in that order." - (declare (type display display)) - (with-buffer-request-and-reply - (display (vidmode-opcode display) nil :sizes 16) - ((data +query-version+)) - (let ((major (card16-get 8)) - (minor (card16-get 10))) - (declare (type card16 major minor)) - (when (>= major 2) - (XFree86-VidMode-set-client-version display)) - (values major minor)))) - -(defun xfree86-vidmode-set-client-version (display) - (declare (type display display)) - (with-buffer-request (display (vidmode-opcode display)) - (data +set-client-version+) - (card16 +xf86vidmode-major-version+) - (card16 +xf86vidmode-minor-version+))) - -(defun xfree86-vidmode-get-permissions (dpy screen) - (declare (type display dpy) - (type screen screen)) - (with-buffer-request-and-reply - (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) - ((data +get-permisions+) - (card16 (screen-position screen dpy)) - (card16 0)) - (values - (card32-get 8)))) - -(defun xfree86-vidmode-mod-mode-line (display screen mode-line) - "Change the settings of the current video mode provided the -requested settings are valid (e.g. they don't exceed the -capabilities of the monitor)." - (declare (type display display) - (type screen screen)) - (let* ((major (xfree86-vidmode-query-version display)) - (v (mode-info->v-card16 mode-line major))) - (declare (type card16 major) - (type simple-vector v)) - (with-buffer-request (display (vidmode-opcode display)) - (data +mod-mode-line+) - (card32 (screen-position screen display)) - ((sequence :format card16 :start 2) v)))) - -(defun xfree86-vidmode-get-mode-line (display screen) - "Query the settings for the currently selected video mode. -return a mode-info structure fields with the server answer. -If there are any server private values (currently only -applicable to the S3 server) the function will store it -into the returned structure." - (declare (clx-values mode-info) - (type display display) - (type screen screen)) - (let ((major (xfree86-vidmode-query-version display)) - (offset 8)) - (declare (type fixnum offset) - (type card16 major)) - (with-buffer-request-and-reply - (display (vidmode-opcode display) nil :sizes (8 16 32)) - ((data +get-mode-line+) - (card16 (screen-position screen display)) - (card16 0)) - (let ((mode-info - (make-mode-info - :dotclock (card32-get offset) - :hdisplay (card16-get (incf offset 4)) - :hsyncstart (card16-get (incf offset 2)) - :hsyncend (card16-get (incf offset 2)) - :htotal (card16-get (incf offset 2)) - :hskew (if (< major 2) 0 (card16-get (incf offset 2))) - :vdisplay (card16-get (incf offset 2)) - :vsyncstart (card16-get (incf offset 2)) - :vsyncend (card16-get (incf offset 2)) - :vtotal (card16-get (incf offset 2)) - :flags (card32-get (incf offset (if (< major 2) 2 4))))) - (size (card32-get (incf offset (if (< major 2) 4 16))))) - (declare (type card32 size)) - (incf offset 4) - (setf (mode-info-privsize mode-info) size - (mode-info-private mode-info) - (sequence-get :format card32 :index offset - :length size :result-type 'list)) - mode-info)))) - -(defun xfree86-vidmode-get-all-mode-lines (dpy screen) - "Returns a list containing all video modes (as mode-info structure). -The first element of the list corresponds to the current video mode." - (declare (type display dpy) - (type screen screen)) - (multiple-value-bind (major minor) (xfree86-vidmode-query-version dpy) - (declare (type card16 major minor)) - (with-buffer-request-and-reply - (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) - ((data +get-all-mode-lines+) - (card16 (screen-position screen dpy))) - (values - ;; Note: There was a bug in the protocol implementation in versions - ;; 0.x with x < 8 (the .private field wasn't being passed over the wire). - ;; Check the server's version, and accept the old format if appropriate. - (loop with bug-p = (and (= major 0) (< minor 8)) - with offset of-type fixnum = 32 - for i of-type card32 from 0 below (or (card32-get 8) 0) - collect - (let ((mode-info - (make-mode-info - :dotclock (card32-get offset) - :hdisplay (card16-get (incf offset 4)) - :hsyncstart (card16-get (incf offset 2)) - :hsyncend (card16-get (incf offset 2)) - :htotal (card16-get (incf offset 2)) - :hskew (if (< major 2) 0 (card32-get (incf offset 2))) - :vdisplay (card16-get (incf offset 4)) - :vsyncstart (card16-get (incf offset 2)) - :vsyncend (card16-get (incf offset 2)) - :vtotal (card16-get (incf offset 2)) - :flags (card32-get (incf offset (if (< major 2) 2 6))))) - (size (card32-get (incf offset (if (< major 2) 4 16))))) - (declare (type card32 size)) - (incf offset 4) - (when bug-p - (setf size 0)) - (setf (mode-info-privsize mode-info) size - (mode-info-private mode-info) - (sequence-get :format card32 :index offset - :length size :result-type 'list)) - (incf offset (* 4 size)) - mode-info)))))) - -(defun xfree86-vidmode-add-mode-line (dpy scr new &key (after (make-mode-info))) - (declare (type display dpy) - (type screen scr)) - (let* ((private (mode-info-private new)) - (privsize (mode-info-privsize new)) - (major (xfree86-vidmode-query-version dpy)) - (i (if (< major 2) 14 22)) - (v (make-array (- (+ (* 2 i) (* 2 privsize)) 2) :initial-element 0))) - (declare (type card32 privsize) - (type fixnum i) - (type card16 major) - (type simple-vector v)) - (mode-info->v-card16 new major :encode-private nil :data v) - (mode-info->v-card16 after major :encode-private nil :data v :index i) - (setf i (- (* 2 i) 2)) - ;; strore private info (sequence card32) according clx bytes order. - (loop for card of-type card32 in private - do (multiple-value-bind (w1 w2) (__card32->card16__ card) - (setf (svref v (incf i)) w1 - (svref v (incf i)) w2))) - - (with-buffer-request (dpy (vidmode-opcode dpy)) - (data +add-mode-line+) - (card32 (screen-position scr dpy)) - ((sequence :format card16) v)))) - -(defun xfree86-vidmode-delete-mode-line (dpy scr mode-info) - "Delete mode argument. The specified mode must match an existing mode. -To be considered a match, all of the fields of the given mode-info -structure must match, except the privsize and private fields. -If the mode to be deleted is the current mode, a mode switch to the next -mode will occur first. The last remaining mode can not be deleted." - (declare (type display dpy) - (type screen scr)) - (let* ((major (xfree86-vidmode-query-version dpy)) - (v (mode-info->v-card16 mode-info major))) - (declare (type card16 major) - (type simple-vector v)) - (with-buffer-request (dpy (vidmode-opcode dpy)) - (data +delete-mode-line+) - (card32 (screen-position scr dpy)) - ((sequence :format card16) v)))) - -(defconstant +mode-status+ - '#(:MODE_BAD ; unspecified reason - :MODE_ERROR ; error condition - :MODE_OK ; Mode OK - :MODE_HSYNC ; hsync out of range - :MODE_VSYNC ; vsync out of range - :MODE_H_ILLEGAL ; mode has illegal horizontal timings - :MODE_V_ILLEGAL ; mode has illegal horizontal timings - :MODE_BAD_WIDTH ; requires an unsupported linepitch - :MODE_NO_MODE ; no mode with a maching name - :MODE_NO_INTERLACE ; interlaced mode not supported - :MODE_NO_DBLESCAN ; doublescan mode not supported - :MODE_NO_VSCAN ; multiscan mode not supported - :MODE_MEM ; insufficient video memory - :MODE_VIRTUAL_X ; mode width too large for specified virtual size - :MODE_VIRTUAL_Y ; mode height too large for specified virtual size - :MODE_MEM_VIRT ; insufficient video memory given virtual size - :MODE_NOCLOCK ; no fixed clock available - :MODE_CLOCK_HIGH ; clock required is too high - :MODE_CLOCK_LOW ; clock required is too low - :MODE_CLOCK_RANGE ; clock/mode isn't in a ClockRange - :MODE_BAD_HVALUE ; horizontal timing was out of range - :MODE_BAD_VVALUE ; vertical timing was out of range - :MODE_BAD_VSCAN ; VScan value out of range - :MODE_HSYNC_NARROW ; horizontal sync too narrow - :MODE_HSYNC_WIDE ; horizontal sync too wide - :MODE_HBLANK_NARROW ; horizontal blanking too narrow - :MODE_HBLANK_WIDE ; horizontal blanking too wide - :MODE_VSYNC_NARROW ; vertical sync too narrow - :MODE_VSYNC_WIDE ; vertical sync too wide - :MODE_VBLANK_NARROW ; vertical blanking too narrow - :MODE_VBLANK_WIDE ; vertical blanking too wide - :MODE_PANEL ; exceeds panel dimensions - :MODE_INTERLACE_WIDTH ; width too large for interlaced mode - :MODE_ONE_WIDTH ; only one width is supported - :MODE_ONE_HEIGHT ; only one height is supported - :MODE_ONE_SIZE ; only one resolution is supported - )) - -(defun decode-status-mode (status) - (declare (type int32 status)) - (svref +mode-status+ (+ status 2))) - -(defun xfree86-vidmode-validate-mode-line (dpy scr mode-info) - "Checked the validity of a mode-info argument. If the specified mode can be -used by the server (i.e. meets all the constraints placed upon a mode by the -combination of the server, card, and monitor) the function returns :mode_ok -otherwise it returns a keyword indicating the reason why the mode is -invalid." - (declare (type display dpy) - (type screen scr)) - (let* ((major (xfree86-vidmode-query-version dpy)) - (v (mode-info->v-card16 mode-info major))) - (declare (type card16 major) - (type simple-vector v)) - (with-buffer-request-and-reply - (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) - ((data +validate-mode-line+) - (card32 (screen-position scr dpy)) - ((sequence :format card16) v)) - (let ((status (integer-get 8))) - (declare (type int32 status)) - (when status (decode-status-mode status)))))) - -(defun xfree86-vidmode-get-gamma (display screen) - (declare (type display display) - (type screen screen)) - (with-buffer-request-and-reply - (display (vidmode-opcode display) nil :sizes (8 16 32)) - ((data +get-gamma+) - (card16 (screen-position screen display)) - (card16 0) - (card32 0) (card32 0) - (card32 0) (card32 0) - (card32 0) (card32 0)) - (values - (/ (the card32 (or (card32-get 8) 0)) 10000.0) - (/ (the card32 (or (card32-get 12) 0)) 10000.0) - (/ (the card32 (or (card32-get 16) 0)) 10000.0)))) - -(defun xfree86-vidmode-set-gamma (dpy scr &key (red 1.0) (green 1.0) (blue 1.0)) - (declare (type display dpy) - (type screen scr) - (type (single-float 0.100f0 10.000f0) red green blue)) - (with-buffer-request (dpy (vidmode-opcode dpy)) - (data +set-gamma+) - (card16 (screen-position scr dpy)) - (card16 0) - (card32 (truncate (* red 10000))) - (card32 (truncate (* green 10000))) - (card32 (truncate (* blue 10000))) - (card32 0) - (card32 0) - (card32 0))) - -(defun xfree86-vidmode-get-gamma-ramp (dpy scr size) - (declare (type display dpy) - (type screen scr) - (type card16 size)) - (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) - ((data +get-gamma-ramp+) - (card16 (screen-position scr dpy)) - (card16 size)) - (let ((rep-size (* (the card16 (or (card16-get 8) 0)) 2))) - (declare (type fixnum rep-size)) - (unless (zerop rep-size) - (let* ((off1 (+ 32 rep-size (* 2 (mod rep-size 2)))) - (off2 (+ off1 rep-size (* 2 (mod rep-size 2))))) - (declare (type fixnum off1 off2)) - (values - (sequence-get :format card16 :length (card16-get 8) - :index 32 :result-type 'list) - (sequence-get :format card16 :length (card16-get 8) - :index off1 :result-type 'list) - (sequence-get :format card16 :length (card16-get 8) - :index off2 :result-type 'list))))))) - -(defun xfree86-vidmode-set-gamma-ramp (dpy scr size &key red green blue) - (declare (type (or null simple-vector) red green blue) - (type card16 size) - (type display dpy) - (type screen scr)) - (with-buffer-request (dpy (vidmode-opcode dpy)) - (data +set-gamma-ramp+) - (card16 (screen-position scr dpy)) - (card16 size) - ((sequence :format card16) - (if (zerop (mod size 2)) - (concatenate 'vector red green blue) - (concatenate 'vector red '#(0) green '#(0) blue '#(0)))))) - -(defun xfree86-vidmode-get-gamma-ramp-size (dpy screen) - (declare (type display dpy) - (type screen screen)) - (with-buffer-request-and-reply - (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) - ((data +get-gamma-ramp-size+) - (card16 (screen-position screen dpy)) - (card16 0)) - (card16-get 8))) - -(defun xfree86-vidmode-lock-mode-switch (display screen lock-p) - "Allow or disallow mode switching whether the request to switch -modes comes from a call to the mode switching functions or from one -of the mode switch key sequences (e.g. Ctrl-Alt-+ Ctrl-Alt--)." - (declare (type display display) - (type screen screen) - (type boolean lock-p)) - (with-buffer-request (display (vidmode-opcode display)) - (data +lock-mode-switch+) - (card16 (screen-position screen display)) - (card16 (if lock-p 1 0)))) - -(defun xfree86-vidmode-switch-to-mode (display screen mode-info) - "Switch directly to the specified mode. The specified mode must match -an existing mode. Matching is as specified in the description of the -xf86-vidmode-delete-mode-line function." - (declare (type display display) - (type screen screen)) - (multiple-value-bind (major minor) (xfree86-vidmode-query-version display) - (declare (type card16 major minor)) - ;; Note: There was a bug in the protocol implementation in versions - ;; 0.x with x < 8 (the .private field wasn't being passed over the wire). - ;; Check the server's version, and accept the old format if appropriate. - (let ((bug-p (and (= major 0) (< minor 8))) - (privsize (mode-info-privsize mode-info))) - (declare (type boolean bug-p)) - (and bug-p (setf (mode-info-privsize mode-info) 0)) - (let ((v (mode-info->v-card16 mode-info major :encode-private bug-p))) - (declare (type simple-vector v)) - (and bug-p (setf (mode-info-privsize mode-info) privsize)) - (with-buffer-request (display (vidmode-opcode display)) - (data +switch-to-mode+) - (card32 (screen-position screen display)) - ((sequence :format card16) v)))))) - -(defun xfree86-vidmode-switch-mode (display screen zoom) - "Change the video mode to next (or previous) video mode, depending -of zoom sign. If positive, switch to next mode, else switch to prev mode." - (declare (type display display) - (type screen screen) - (type card16 zoom)) - (with-buffer-request (display (vidmode-opcode display)) - (data +switch-mode+) - (card16 (screen-position screen display)) - (card16 zoom))) - -(defun xfree86-vidmode-select-next-mode (display screen) - "Change the video mode to next video mode" - (declare (type display display) - (type screen screen)) - (with-buffer-request (display (vidmode-opcode display)) - (data +switch-mode+) - (card16 (screen-position screen display)) - (card16 1))) - -(defun xfree86-vidmode-select-prev-mode (display screen) - "Change the video mode to previous video mode" - (declare (type display display) - (type screen screen)) - (with-buffer-request (display (vidmode-opcode display)) - (data +switch-mode+) - (card16 (screen-position screen display)) - (card16 #xFFFF))) - -(defun xfree86-vidmode-get-monitor (dpy screen) - "Information known to the server about the monitor is returned. -Multiple value return: - hsync (list of hi, low, ...) - vsync (list of hi, low, ...) - vendor name - model name - -The hi and low values will be equal if a discreate value was given -in the XF86Config file." - (declare (type display dpy) - (type screen screen)) - (with-buffer-request-and-reply - (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) - ((data +get-monitor+) - (card16 (screen-position screen dpy)) - (card16 0)) - (let* ((vendor-name-length (card8-get 8)) - (model-name-length (card8-get 9)) - (pad (- 4 (mod vendor-name-length 4))) - (nhsync (card8-get 10)) - (nvsync (card8-get 11)) - (vindex (+ 32 (* 4 (+ nhsync nvsync)))) - (mindex (+ vindex vendor-name-length pad)) - (hsync (sequence-get :length nhsync :index 32 :result-type 'list)) - (vsync (sequence-get :length nvsync :index (+ 32 (* nhsync 4)) - :result-type 'list))) - (declare (type card8 nhsync nvsync vendor-name-length model-name-length) - (type fixnum pad vindex mindex)) - (values - (loop for i of-type card32 in hsync - collect (/ (ldb (byte 16 0) i) 100.) - collect (/ (ldb (byte 32 16) i) 100.)) - (loop for i of-type card32 in vsync - collect (/ (ldb (byte 16 0) i) 100.) - collect (/ (ldb (byte 32 16) i) 100.)) - (string-get vendor-name-length vindex) - (string-get model-name-length mindex))))) - -(defun xfree86-vidmode-get-viewport (dpy screen) - "Query the location of the upper left corner of the viewport into -the virtual screen. The upper left coordinates will be returned as -a multiple value." - (declare (type display dpy) - (type screen screen)) - (multiple-value-bind (major minor) (xfree86-vidmode-query-version dpy) - (declare (type card16 major minor)) - ;; Note: There was a bug in the protocol implementation in versions - ;; 0.x with x < 8 (no reply was sent, so the client would hang) - ;; Check the server's version, and don't wait for a reply with older - ;; versions. - (when (and (= major 0) (< minor 8)) - (format cl:*error-output* - "running an old version ~a ~a~%" - major minor) - (return-from xfree86-vidmode-get-viewport nil)) - (with-buffer-request-and-reply - (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) - ((data +get-viewport+) - (card16 (screen-position screen dpy)) - (card16 0)) - (values - (card32-get 8) - (card32-get 12))))) - -(defun xfree86-vidmode-set-viewport (dpy screen &key (x 0) (y 0)) - "Set upper left corner of the viewport into the virtual screen to the -x and y keyword parameters value (zero will be theire default value)." - (declare (type display dpy) - (type screen screen) - (type card32 x y)) - (with-buffer-request (dpy (vidmode-opcode dpy)) - (data +set-viewport+) - (card16 (screen-position screen dpy)) - (card16 0) - (card32 x) - (card32 y))) - -(defun xfree86-vidmode-get-dotclocks (dpy screen) - "Returns as a multiple value return the server dotclock informations: - flags - maxclocks - clock list" - (declare (type display dpy) - (type screen screen)) - (with-buffer-request-and-reply - (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) - ((data +get-dot-clocks+) - (card16 (screen-position screen dpy)) - (card16 0)) - (values - (card32-get 8) ; flags - (card32-get 16) ; max clocks - (sequence-get :length (card32-get 12) :format card32 - :index 32 :result-type 'list)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; ;;;; -;;;; private utility routines ;;;; -;;;; ;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun mode-info->v-card16 - (mode-info major &key (encode-private t) (index 0) data) - (declare (type integer index) - (type card16 major) - (type boolean encode-private) - (type (or null simple-vector) data)) - (let ((dotclock (mode-info-dotclock mode-info)) - (hdisplay (mode-info-hdisplay mode-info)) - (hsyncstart (mode-info-hsyncstart mode-info)) - (hsyncend (mode-info-hsyncend mode-info)) - (htotal (mode-info-htotal mode-info)) - (hskew (mode-info-hskew mode-info)) - (vdisplay (mode-info-vdisplay mode-info)) - (vsyncstart (mode-info-vsyncstart mode-info)) - (vsyncend (mode-info-vsyncend mode-info)) - (vtotal (mode-info-vtotal mode-info)) - (flags (mode-info-flags mode-info)) - (privsize (mode-info-privsize mode-info)) - (private (mode-info-private mode-info))) - (declare (type card16 hdisplay hsyncstart hsyncend htotal hskew) - (type card16 vdisplay vsyncstart vsyncend vtotal) - (type card32 dotclock flags privsize) - (type (or null sequence) private)) - (let* ((size (+ (if (< major 2) 14 22) (* privsize 2))) - (v (or data (make-array size :initial-element 0)))) - (declare (type fixnum size) - (type simple-vector v)) - ;; store dotclock (card32) according clx bytes order. - (multiple-value-bind (w1 w2) (__card32->card16__ dotclock) - (setf (svref v index) w1 - (svref v (incf index)) w2)) - (setf (svref v (incf index)) hdisplay - (svref v (incf index)) hsyncstart - (svref v (incf index)) hsyncend - (svref v (incf index)) htotal) - (unless (< major 2) - (setf (svref v (incf index)) hskew)) - (setf (svref v (incf index)) vdisplay - (svref v (incf index)) vsyncstart - (svref v (incf index)) vsyncend - (svref v (incf index)) vtotal) - (unless (< major 2) - (incf index)) - ;; strore flags (card32) according clx bytes order. - (multiple-value-bind (w1 w2) (__card32->card16__ flags) - (setf (svref v (incf index)) w1 - (svref v (incf index)) w2)) - ;; strore privsize (card32) according clx bytes order. - (multiple-value-bind (w1 w2) (__card32->card16__ privsize) - (setf (svref v (incf index)) w1 - (svref v (incf index)) w2)) - ;; reserverd byte32 1 2 3 - (unless (< major 2) (incf index 6)) - ;; strore private info (sequence card32) according clx bytes order. - (when encode-private - (loop for i of-type int32 in private - do (multiple-value-bind (w1 w2) (__card32->card16__ i) - (setf (svref v (incf index)) w1 - (svref v (incf index)) w2)))) - v))) - -(declaim (inline __card32->card16__)) -(defun __card32->card16__ (i) - (declare (type card32 i)) - #+clx-little-endian - (progn (values (ldb (byte 16 0) i) (ldb (byte 32 16) i))) - #-clx-little-endian - (progn (values (ldb (byte 32 16) i) (ldb (byte 16 0) i)))) diff -Nru ecl-16.1.2/src/cmp/cmpcall.lsp ecl-16.1.3+ds/src/cmp/cmpcall.lsp --- ecl-16.1.2/src/cmp/cmpcall.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/cmp/cmpcall.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -268,7 +268,8 @@ (env nil)) (case (fun-closure fun) (CLOSURE - (setf env (environment-accessor fun))) + (when (plusp *max-env*) + (setf env (environment-accessor fun)))) (LEXICAL (let ((lex-lvl (fun-level fun))) (dotimes (n lex-lvl) diff -Nru ecl-16.1.2/src/cmp/cmpcbk.lsp ecl-16.1.3+ds/src/cmp/cmpcbk.lsp --- ecl-16.1.2/src/cmp/cmpcbk.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/cmp/cmpcbk.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -43,7 +43,7 @@ (si::put-sysprop ',name :callback (list (ffi:c-inline () () :object - ,(format nil "ecl_make_foreign_data(@':pointer-void,0,~a)" c-name) + ,(format nil "ecl_make_foreign_data(@':pointer-void,0,(void*)~a)" c-name) :one-liner t))))) ))) @@ -96,7 +96,7 @@ return-type))) (let ((return-type-name (rep-type->c-name (ffi::%convert-to-arg-type return-type))) (fmod (case call-type - (:cdecl "") + ((:cdecl :default) "") (:stdcall "__stdcall ") (t (cmperr "DEFCALLBACK does not support ~A as calling convention" call-type))))) @@ -126,7 +126,7 @@ (wt-nl "ecl_stack_frame_push(frame,ecl_foreign_data_ref_elt(&var" n "," ct "));") (wt-nl "ecl_stack_frame_push(frame,ecl_make_foreign_data(&var" - n "," ct "," (ffi:size-of-foreign-type type) "));"))) + n "," ct ", (void*)" (ffi:size-of-foreign-type type) "));"))) (wt-nl "aux = ecl_apply_from_stack_frame(frame," "ecl_fdefinition(" c-name-constant "));") (wt-nl "ecl_stack_frame_close(frame);") diff -Nru ecl-16.1.2/src/cmp/cmpc-machine.lsp ecl-16.1.3+ds/src/cmp/cmpc-machine.lsp --- ecl-16.1.2/src/cmp/cmpc-machine.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/cmp/cmpc-machine.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -14,7 +14,7 @@ ;;;; CMPC-MACHINE -- Abstract target machine details ;;;; -(in-package #-new-cmp "COMPILER" #+new-cmp "C-BACKEND") +(in-package "COMPILER") (defconstant +representation-types+ '(;; These types can be used by ECL to unbox data diff -Nru ecl-16.1.2/src/cmp/cmpct.lsp ecl-16.1.3+ds/src/cmp/cmpct.lsp --- ecl-16.1.2/src/cmp/cmpct.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/cmp/cmpct.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -152,22 +152,24 @@ (LEAST-NEGATIVE-DOUBLE-FLOAT "-DBL_MIN") (LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT "-DBL_MIN") - (SHORT-FLOAT-POSITIVE-INFINITY "INFINITY") - (SINGLE-FLOAT-POSITIVE-INFINITY "INFINITY") - (DOUBLE-FLOAT-POSITIVE-INFINITY "INFINITY") + #+ieee-floating-point + ,@'((SHORT-FLOAT-POSITIVE-INFINITY "INFINITY") + (SINGLE-FLOAT-POSITIVE-INFINITY "INFINITY") + (DOUBLE-FLOAT-POSITIVE-INFINITY "INFINITY") - (SHORT-FLOAT-NEGATIVE-INFINITY "-INFINITY") - (SINGLE-FLOAT-NEGATIVE-INFINITY "-INFINITY") - (DOUBLE-FLOAT-NEGATIVE-INFINITY "-INFINITY") + (SHORT-FLOAT-NEGATIVE-INFINITY "-INFINITY") + (SINGLE-FLOAT-NEGATIVE-INFINITY "-INFINITY") + (DOUBLE-FLOAT-NEGATIVE-INFINITY "-INFINITY")) #+long-float - ,@'( - (MOST-POSITIVE-LONG-FLOAT "LDBL_MAX") + ,@'((MOST-POSITIVE-LONG-FLOAT "LDBL_MAX") (MOST-NEGATIVE-LONG-FLOAT "-LDBL_MAX") (LEAST-POSITIVE-LONG-FLOAT "LDBL_MIN") (LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" LDBL_MIN") (LEAST-NEGATIVE-LONG-FLOAT "-LDBL_MIN") (LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT "-LDBL_MIN") + #+ieee-floating-point (LONG-FLOAT-POSITIVE-INFINITY "INFINITY") + #+ieee-floating-point (LONG-FLOAT-NEGATIVE-INFINITY "-INFINITY") ))))) diff -Nru ecl-16.1.2/src/cmp/cmpc-wt.lsp ecl-16.1.3+ds/src/cmp/cmpc-wt.lsp --- ecl-16.1.2/src/cmp/cmpc-wt.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/cmp/cmpc-wt.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -14,7 +14,7 @@ ;;;; CMPC-WT -- Routines for writing code to C files. ;;;; -(in-package #-new-cmp "COMPILER" #+new-cmp "C-BACKEND") +(in-package "COMPILER") (defun wt1 (form) (cond ((not (floatp form)) @@ -109,16 +109,12 @@ ;;; (defun wt-go (label) - #-new-cmp (setf (cdr label) t label (car label)) (wt "goto L" label ";")) (defun wt-label (label) - #-new-cmp - (when (cdr label) (wt-nl1 "L" (car label) ":;")) - #+new-cmp - (wt-nl1 "L" label ":;")) + (when (cdr label) (wt-nl1 "L" (car label) ":;"))) ;;; ;;; C/C++ COMMENTS diff -Nru ecl-16.1.2/src/cmp/cmpdefs.lsp ecl-16.1.3+ds/src/cmp/cmpdefs.lsp --- ecl-16.1.2/src/cmp/cmpdefs.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/cmp/cmpdefs.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -52,9 +52,6 @@ (t "~A -I. \"-I~A\" ~A ~:[~*~;~A~] -w -c \"~A\" -o \"~A\"~{ '~A'~}"))) -(defvar *cc-is-cxx* @CC_IS_CXX@ - "ECL's compiler is really the C++ compiler, not a C compiler.") - #-dlopen (defvar *ld-flags* "@LDFLAGS@ -lecl @CORE_LIBS@ @FASL_LIBS@ @LIBS@") #+dlopen @@ -76,8 +73,9 @@ (defvar +object-file-extension+ "@OBJEXT@") (defvar +executable-file-format+ "~a@EXEEXT@") -(defvar *ecl-include-directory* @includedir\@) -(defvar *ecl-library-directory* @libdir\@) +(defvar *ecl-include-directory* "@includedir\@/") +(defvar *ecl-library-directory* "@libdir\@/") +(defvar *ecl-data-directory* "@ecldir\@/") (defvar *ld-rpath* (let ((x "@ECL_LDRPATH@")) diff -Nru ecl-16.1.2/src/cmp/cmpenv-api.lsp ecl-16.1.3+ds/src/cmp/cmpenv-api.lsp --- ecl-16.1.2/src/cmp/cmpenv-api.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/cmp/cmpenv-api.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -14,7 +14,7 @@ ;;;; CMPENVAPI -- API for creating and manipulating environments ;;;; -(in-package #-new-cmp "COMPILER" #+new-cmp "C-ENV") +(in-package "COMPILER") (defun cmp-env-root (&optional (env *cmp-env-root*)) "Provide a root environment for toplevel forms storing all declarations @@ -31,7 +31,6 @@ (defmacro cmp-env-functions (&optional (env '*cmp-env*)) `(cdr ,env)) -#-new-cmp (defun cmp-env-cleanups (env) (loop with specials = '() with end = (cmp-env-variables env) diff -Nru ecl-16.1.2/src/cmp/cmpenv-fun.lsp ecl-16.1.3+ds/src/cmp/cmpenv-fun.lsp --- ecl-16.1.2/src/cmp/cmpenv-fun.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/cmp/cmpenv-fun.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -14,7 +14,7 @@ ;;;; CMPTYPE-PROP -- Type propagation basic routines and database ;;;; -(in-package #-new-cmp "COMPILER" #+new-cmp "C-ENV") +(in-package "COMPILER") (defun function-arg-types (arg-types &aux (types nil)) (do ((al arg-types (cdr al))) diff -Nru ecl-16.1.2/src/cmp/cmpform.lsp ecl-16.1.3+ds/src/cmp/cmpform.lsp --- ecl-16.1.2/src/cmp/cmpform.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/cmp/cmpform.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -114,7 +114,6 @@ (defun c1form-primary-type (form) (values-type-primary-type (c1form-type form))) -#-new-cmp (defun location-primary-type (form) (c1form-primary-type form)) diff -Nru ecl-16.1.2/src/cmp/cmpglobals.lsp ecl-16.1.3+ds/src/cmp/cmpglobals.lsp --- ecl-16.1.2/src/cmp/cmpglobals.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/cmp/cmpglobals.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -14,7 +14,7 @@ ;;;; CMPGLOBALS -- Global variables and flag definitions ;;;; -(in-package #-new-cmp "COMPILER" #+new-cmp "C-DATA") +(in-package "COMPILER") ;;; ;;; VARIABLES @@ -24,7 +24,6 @@ ;;; ;;; Empty info struct ;;; -#-new-cmp (defvar *info* (make-info)) (defvar *inline-blocks* 0) (defvar *opened-c-braces* 0) @@ -110,9 +109,7 @@ (defvar *lcl* 0) ; number of local variables -#-new-cmp (defvar *temp* 0) ; number of temporary variables -#-new-cmp (defvar *max-temp* 0) ; maximum *temp* reached (defvar *level* 0) ; nesting level for local functions @@ -123,12 +120,9 @@ (defvar *env* 0) ; number of variables in current form (defvar *max-env* 0) ; maximum *env* in whole function (defvar *env-lvl* 0) ; number of levels of environments -#-new-cmp (defvar *aux-closure* nil) ; stack allocated closure needed for indirect calls -#-new-cmp (defvar *ihs-used-p* nil) ; function must be registered in IHS? -#-new-cmp (defvar *next-cmacro* 0) ; holds the last cmacro number used. (defvar *next-cfun* 0) ; holds the last cfun used. @@ -229,7 +223,6 @@ (defvar *compiler-phase* nil) (defvar *volatile*) -#-new-cmp (defvar *setjmps* 0) (defvar *compile-toplevel* T @@ -241,7 +234,6 @@ lines are inserted, but the order is preserved") (defvar *compile-time-too* nil) -#-new-cmp (defvar *not-compile-time* nil) (defvar *permanent-data* nil) ; detemines whether we use *permanent-objects* @@ -310,11 +302,8 @@ (*callbacks* nil) (*cmp-env-root* (copy-tree *cmp-env-root*)) (*cmp-env* nil) - #-new-cmp (*max-temp* 0) - #-new-cmp (*temp* 0) - #-new-cmp (*next-cmacro* 0) (*next-cfun* 0) (*last-label* 0) @@ -336,18 +325,6 @@ (*clines-string-list* '()) (*inline-blocks* 0) (*open-c-braces* 0) - #+new-cmp - (*type-and-cache* (type-and-empty-cache)) - #+new-cmp - (*type-or-cache* (type-or-empty-cache)) - #+new-cmp - (*values-type-or-cache* (values-type-or-empty-cache)) - #+new-cmp - (*values-type-and-cache* (values-type-and-empty-cache)) - #+new-cmp - (*values-type-primary-type-cache* (values-type-primary-type-empty-cache)) - #+new-cmp - (*values-type-to-n-types-cache* (values-type-to-n-types-empty-cache)) (si::*defun-inline-hook* 'maybe-install-inline-function) (*machine* (or *machine* +default-machine+)) (*optimizable-constants* (make-optimizable-constants *machine*)) diff -Nru ecl-16.1.2/src/cmp/cmpmac.lsp ecl-16.1.3+ds/src/cmp/cmpmac.lsp --- ecl-16.1.2/src/cmp/cmpmac.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/cmp/cmpmac.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -5,13 +5,9 @@ ;;; ---------------------------------------------------------------------- ;;; Macros only used in the code of the compiler itself: -#-new-cmp (in-package "COMPILER") -#-new-cmp (import 'sys::arglist "COMPILER") (import 'sys::with-clean-symbols "COMPILER") -#+new-cmp -(in-package "C-DATA") ;; ---------------------------------------------------------------------- ;; CACHED FUNCTIONS diff -Nru ecl-16.1.2/src/cmp/cmpmain.lsp ecl-16.1.3+ds/src/cmp/cmpmain.lsp --- ecl-16.1.2/src/cmp/cmpmain.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/cmp/cmpmain.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -57,7 +57,7 @@ ((:static-library :library :lib) (setf format +static-library-format+)) (:data (setf extension "data")) (:sdata (setf extension "sdat")) - (:c (setf extension (if (not *cc-is-cxx*) "c" "cxx"))) + (:c (setf extension (if (member :cxx-core *features*) "cxx" "c"))) (:h (setf extension "eclh")) (:object (setf extension +object-file-extension+)) (:program (setf format +executable-file-format+)) @@ -73,7 +73,7 @@ #+msvc (defun delete-msvc-generated-files (output-pathname) - (loop for i in '("implib" "exp" "ilk" "pdb") + (loop for i in '("implib" "exp" "ilk" ) for full = (make-pathname :type i :defaults output-pathname) for truename = (probe-file full) when truename @@ -132,7 +132,9 @@ ,@object-files ,@(split-program-options *ld-rpath*) ,@(split-program-options *user-ld-flags*) - ,@ld-flags)) + ,@ld-flags + ,(if (eq type :program) + (concatenate 'string "/IMPLIB:prog" (file-namestring o-pathname) ".lib") "" ))) (embed-manifest-file o-pathname type) (delete-msvc-generated-files o-pathname)) @@ -234,6 +236,7 @@ extern \"C\" #endif +ECL_DLLEXPORT void ~A(cl_object cblock) { /* @@ -363,9 +366,9 @@ (brief-namestring pathname)) ((:fasl :fas) nil) - ((:static-library :lib :standalone-static-library :standalone-lib) + ((:static-library :lib) (brief-namestring pathname)) - ((:shared-library :dll :standalone-shared-library :standalone-dll) + ((:shared-library :dll) (brief-namestring pathname)) ((:program) nil) @@ -412,6 +415,7 @@ &aux (*suppress-compiler-messages* (or *suppress-compiler-messages* (not *compile-verbose*))) + (target (normalize-build-target-name target)) (output-name (if (or (symbolp output-name) (stringp output-name)) (compile-file-pathname output-name :type target) output-name)) @@ -484,10 +488,17 @@ (pathname item) (string (parse-namestring item)))) (kind (guess-kind path))) - (unless (member kind '(:shared-library :dll :static-library :lib - :object :c)) - (error "C::BUILDER does not accept a file ~s of kind ~s" item kind)) - (let* ((init-fn (guess-init-name path (guess-kind path))) + + ;; Shared and static libraries may be linked in a program or + ;; fasl, but if we try to create a `static-library' from two + ;; static libraries we will end with broken binary because + ;; `ar' works fine only with object files. See #274. + (unless (member kind `(,@(unless (eql target :static-library) + '(:shared-library :static-library)) + :object :c)) + (error "C::BUILDER does not accept a file ~s of kind ~s for target ~s" item kind target)) + + (let* ((init-fn (guess-init-name path kind)) (flags (guess-ld-flags path))) ;; We should give a warning that we cannot link this module in (when flags (push flags ld-flags)) @@ -504,14 +515,16 @@ (format c-file +lisp-program-init+ init-name init-tag "" submodules "") - (format c-file #+:win32 (ecase system (:console +lisp-program-main+) - (:windows +lisp-program-winmain+)) + (format c-file + #+:win32 (ecase system + (:console +lisp-program-main+) + (:windows +lisp-program-winmain+)) #-:win32 +lisp-program-main+ prologue-code init-name epilogue-code) (close c-file) (compiler-cc c-name o-name) (linker-cc output-name (list* (namestring o-name) ld-flags))) - ((:library :static-library :lib) + (:static-library (format c-file +lisp-program-init+ init-name init-tag prologue-code submodules epilogue-code) (format c-file +lisp-init-wrapper+ wrap-init-name init-name) @@ -522,7 +535,7 @@ (when (probe-file output-name) (delete-file output-name)) (linker-ar output-name o-name ld-flags)) #+dlopen - ((:shared-library :dll) + (:shared-library (format c-file +lisp-program-init+ init-name init-tag prologue-code submodules epilogue-code) (format c-file +lisp-init-wrapper+ wrap-init-name init-name) diff -Nru ecl-16.1.2/src/cmp/cmpname.lsp ecl-16.1.3+ds/src/cmp/cmpname.lsp --- ecl-16.1.2/src/cmp/cmpname.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/cmp/cmpname.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -18,10 +18,7 @@ ;;;; functions. This initialization function has a C name which needs ;;;; to be unique. This file has functions to create such names. -#-new-cmp (in-package "COMPILER") -#+new-cmp -(in-package "C-TAGS") (defun encode-number-in-name (number) ;; Encode a number in an alphanumeric identifier which is a valid C name. @@ -103,12 +100,14 @@ (let ((name (read-name stream))) name))) #+pnacl - (let* ((pnacl-dis (or (ext:getenv "PNACL_DIS") - (error "please set the PNACL_DIS environment variable to your toolchain's pnacl-dis location"))) + (let* ((pnacl-dis + (or (ext:getenv "PNACL_DIS") + (error "Please set the PNACL_DIS environment variable to your ~ + toolchain's pnacl-dis location"))) (stream (ext:run-program pnacl-dis (list (namestring (translate-logical-pathname file))) - :wait nil :input NIL :output :STREAM :error :OUTPUT))) + :wait nil :input nil :output :stream :error :output))) (unless stream (error "Unable to disasemble file ~a" file)) (when (search-tag stream tag) diff -Nru ecl-16.1.2/src/cmp/cmpos-features.lsp ecl-16.1.3+ds/src/cmp/cmpos-features.lsp --- ecl-16.1.2/src/cmp/cmpos-features.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/cmp/cmpos-features.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -47,7 +47,9 @@ output) (setf word nil)) (push c word)) - finally (return output))) + finally (return (push (make-array (length word) :element-type 'base-char + :initial-contents (nreverse word)) + output)))) (defconstant +known-keywords+ '("sparc*" "x86*" "*-bit" "32*" "64*" "*32" "*64" @@ -131,13 +133,16 @@ (gather-keywords (apply #'run-and-collect args) +known-keywords+)) (defun gather-system-features (&key (executable - #+(or windows cygwin) "sys:ecl_min.exe" - #-(or windows cygwin) "sys:ecl_min")) + #+(or windows cygwin mingw32) "sys:ecl_min.exe" + #-(or windows cygwin mingw32) "sys:ecl_min")) (let* ((ecl-binary (namestring (truename executable))) (executable-features #-windows (run-and-collect-keywords "file" (list ecl-binary))) - (compiler-version (run-and-collect-keywords c::*cc* '("--version"))) + (compiler-version (run-and-collect-keywords c::*cc* + (if (search "xlc" c::*cc*) + '("-qversion") + '("--version")))) (compiler-features (reduce #'append (mapcar #'rest (compiler-defines +compiler-macros+))))) @@ -152,8 +157,8 @@ #+ecl-min (update-compiler-features :executable - #+(or windows cygwin) "build:ecl_min.exe" - #-(or windows cygwin) "build:ecl_min") + #+(or windows cygwin mingw32) "build:ecl_min.exe" + #-(or windows cygwin mingw32) "build:ecl_min") #+ecl-min (format t ";;; System features: ~A~%" *compiler-features*) diff -Nru ecl-16.1.2/src/cmp/cmpos-run.lsp ecl-16.1.3+ds/src/cmp/cmpos-run.lsp --- ecl-16.1.2/src/cmp/cmpos-run.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/cmp/cmpos-run.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -54,7 +54,10 @@ (cmpnote "Invoking external command:~% ~A ~{~A ~}" program args) (multiple-value-bind (stream result process) (let* ((*standard-output* ext:+process-standard-output+) - (*error-output* ext:+process-error-output+)) + (*error-output* ext:+process-error-output+) + (program (split-program-options program)) + (args `(,@(cdr program) ,@args)) + (program (car program))) (with-current-directory #-(and cygwin (not ecl-min)) (ext:run-program program args :input nil :output t :error t :wait t) diff -Nru ecl-16.1.2/src/cmp/cmppackage.lsp ecl-16.1.3+ds/src/cmp/cmppackage.lsp --- ecl-16.1.2/src/cmp/cmppackage.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/cmp/cmppackage.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -28,8 +28,6 @@ "*CC-OPTIMIZE*" "*USER-CC-FLAGS*" "*USER-LD-FLAGS*" - "*SUPPRESS-COMPILER-NOTES*" - "*SUPPRESS-COMPILER-WARNINGS*" "*SUPPRESS-COMPILER-MESSAGES*" "BUILD-ECL" "BUILD-PROGRAM" @@ -46,8 +44,6 @@ "COMPILER-MESSAGE-FILE" "COMPILER-MESSAGE-FILE-POSITION" "COMPILER-MESSAGE-FORM" - "*SUPPRESS-COMPILER-WARNINGS*" - "*SUPPRESS-COMPILER-NOTES*" "*SUPPRESS-COMPILER-MESSAGES*" "INSTALL-C-COMPILER" "UPDATE-COMPILER-FEATURES") diff -Nru ecl-16.1.2/src/cmp/cmppolicy.lsp ecl-16.1.3+ds/src/cmp/cmppolicy.lsp --- ecl-16.1.2/src/cmp/cmppolicy.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/cmp/cmppolicy.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -14,7 +14,7 @@ ;;;; CMPPOLICY -- Code generation choices ;;;; -(in-package #-new-cmp "COMPILER" #+new-cmp "C-ENV") +(in-package "COMPILER") (eval-when (:compile-toplevel :execute) (defconstant +optimization-quality-orders+ '(debug safety speed space))) diff -Nru ecl-16.1.2/src/cmp/cmptop.lsp ecl-16.1.3+ds/src/cmp/cmptop.lsp --- ecl-16.1.2/src/cmp/cmptop.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/cmp/cmptop.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -436,14 +436,17 @@ ;; should definitely keep this in memory. (when (plusp *max-lex*) (wt-nl "volatile cl_object lex" *level* "[" *max-lex* "];")) - (when (plusp *max-env*) - (unless (eq closure-type 'CLOSURE) - (wt-nl "cl_object " *volatile* "env0;")) - ;; Note that the closure structure has to be marked volatile - ;; or else GCC may optimize away writes into it because it - ;; does not know it shared with the rest of the world. + + (unless (eq closure-type 'CLOSURE) + (wt-nl "cl_object " *volatile* "env0;")) + + (when (plusp *max-env*) + ;; Closure structure has to be marked volatile or else GCC may + ;; optimize away writes into it because it does not know it shared + ;; with the rest of the world. (when *aux-closure* (wt-nl "volatile struct ecl_cclosure aux_closure;")) + (wt-nl "cl_object " *volatile*) (loop for i from 0 below *max-env* for comma = "" then ", " diff -Nru ecl-16.1.2/src/cmp/cmptype-arith.lsp ecl-16.1.3+ds/src/cmp/cmptype-arith.lsp --- ecl-16.1.2/src/cmp/cmptype-arith.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/cmp/cmptype-arith.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -14,7 +14,7 @@ ;;;; CMPTYPE-ARITH -- Operations upon and among types -(in-package #-new-cmp "COMPILER" #+new-cmp "C-TYPES") +(in-package "COMPILER") ;;; CL-TYPE is any valid type specification of Common Lisp. ;;; @@ -49,7 +49,6 @@ ;;; Check if THING is an object of the type TYPE. ;;; Depends on the implementation of TYPE-OF. ;;; (only used for saving constants?) -#-new-cmp (defun object-type (thing) (let ((type (if thing (type-of thing) 'SYMBOL))) (case type diff -Nru ecl-16.1.2/src/cmp/cmptype-prop.lsp ecl-16.1.3+ds/src/cmp/cmptype-prop.lsp --- ecl-16.1.2/src/cmp/cmptype-prop.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/cmp/cmptype-prop.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -14,7 +14,7 @@ ;;;; CMPTYPE-PROP -- Type propagation basic routines and database ;;;; -(in-package #-new-cmp "COMPILER" #+new-cmp "C-TYPES") +(in-package "COMPILER") (defun infer-arg-and-return-types (fname forms &optional (env *cmp-env*)) (let ((found (gethash fname *p0-dispatch-table*)) @@ -56,7 +56,6 @@ (unless intersection (cmpwarn-style "The argument ~d of function ~a has type~&~4T~A~&instead of expected~&~4T~A" i fname actual-type expected-type)) - #-new-cmp (when (zerop (cmp-env-optimization 'safety)) (setf (c1form-type value) intersection)))))))) diff -Nru ecl-16.1.2/src/cmp/cmptypes.lsp ecl-16.1.3+ds/src/cmp/cmptypes.lsp --- ecl-16.1.2/src/cmp/cmptypes.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/cmp/cmptypes.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -14,7 +14,7 @@ ;;;; CMPTYPES -- Data types for the Lisp core structures ;;;; -(in-package #-new-cmp "COMPILER" #+new-cmp "C-DATA") +(in-package "COMPILER") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -78,12 +78,8 @@ ;;; lex-ndx is the index within the array for this env. ;;; For SPECIAL and GLOBAL: the vv-index for variable name. (type t) ;;; Type of the variable. - #-new-cmp (index -1) ;;; position in *vars*. Used by similar. - #-new-cmp (ignorable nil) ;;; Whether there was an IGNORABLE/IGNORE declaration - #+new-cmp - read-only-p ;;; T for variables that are assigned only once. ) ;;; A function may be compiled into a CFUN, CCLOSURE or CCLOSURE+LISP_CLOSURE @@ -131,10 +127,6 @@ ; ref-clb ;;; Unused. ; read-nodes ;;; Nodes (c1forms) in which the reference occurs cfun ;;; The cfun for the function. - #+new-cmp - (last-lcl 0) ;;; Number of local variables (just to bookkeep names) - #+new-cmp - (last-label 0) ;;; Number of generated labels (same as last-lcl) (level 0) ;;; Level of lexical nesting for a function. (env 0) ;;; Size of env of closure. (global nil) ;;; Global lisp function. @@ -147,17 +139,12 @@ closure ;;; During Pass2, T if env is used inside the function var ;;; the variable holding the funob description ;;; Text for the object, in case NAME == NIL. - #+new-cmp - lambda-list ;;; List of (requireds optionals rest-var keywords-p - ;;; keywords allow-other-keys-p) lambda ;;; Lambda c1-form for this function. lambda-expression ;;; LAMBDA or LAMBDA-BLOCK expression (minarg 0) ;;; Min. number arguments that the function receives. (maxarg call-arguments-limit) ;;; Max. number arguments that the function receives. (return-type '(VALUES &REST T)) - #+new-cmp - doc ;;; Documentation (parent *current-function*) ;;; Parent function, NIL if global. (local-vars nil) ;;; List of local variables created here. @@ -166,16 +153,10 @@ ;;; We only register direct calls, not calls via object. (referencing-funs nil);;; Functions that reference this one (child-funs nil) ;;; List of local functions defined here. - #+new-cmp - (debug 0) ;;; Debug quality (file (car ext:*source-location*)) ;;; Source file or NIL (file-position (or (cdr ext:*source-location*) *compile-file-position*)) ;;; Top-level form number in source file - #+new-cmp - (toplevel-form *current-toplevel-form*) - #+new-cmp - code-gen-props ;;; Extra properties for code generation (cmp-env (cmp-env-copy)) ;;; Environment required-lcls ;;; Names of the function arguments ) @@ -195,10 +176,7 @@ exit ;;; Where to return. A label. destination ;;; Where the value of the block to go. var ;;; Variable containing the block ID. - #-new-cmp (type '(VALUES &REST T)) ;;; Estimated type. - #+new-cmp - env ;;; Block environment. ) (defstruct (tag (:include ref)) @@ -213,13 +191,10 @@ unwind-exit ;;; Where to unwind-no-exit. var ;;; Variable containing frame ID. index ;;; An integer denoting the label. - #+new-cmp - env ;;; Tag environment. ) (defstruct (info) (local-vars nil) ;;; List of var-objects created directly in the form. - #-new-cmp (type '(VALUES &REST T)) ;;; Type of the form. (sp-change nil) ;;; Whether execution of the form may change ;;; the value of a special variable. @@ -244,9 +219,6 @@ (:constructor do-make-c1form)) (name nil) (parents nil) - #+new-cmp - (env (c-env:cmp-env-copy)) ;; Environment in which this form was compiled - #-new-cmp (env (cmp-env-copy)) ;; Environment in which this form was compiled (args '()) (side-effects nil) ;;; Does it have side effects diff -Nru ecl-16.1.2/src/cmp/cmputil.lsp ecl-16.1.3+ds/src/cmp/cmputil.lsp --- ecl-16.1.2/src/cmp/cmputil.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/cmp/cmputil.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -14,10 +14,7 @@ ;;;; ;;;; See file '../Copyright' for full details. -#-new-cmp (in-package "COMPILER") -#+new-cmp -(in-package "C-LOG") #+cmu-format (progn @@ -45,6 +42,12 @@ #-windows (enough-namestring (si::coerce-to-filename path))) +(defun normalize-build-target-name (target) + (ecase target + ((:shared-library :dll :standalone-shared-library :standalone-dll) :shared-library) + ((:static-library :lib :standalone-static-library :standalone-lib) :static-library) + ((:fasl :program) target))) + (defun innermost-non-expanded-form (form) (when (listp form) (loop with output = nil @@ -306,7 +309,6 @@ (defun cmpnote (string &rest args) (do-cmpwarn 'compiler-note :format-control string :format-arguments args)) -#-new-cmp (defun cmpdebug (string &rest args) (do-cmpwarn 'compiler-debug-note :format-control string :format-arguments args)) @@ -383,12 +385,8 @@ (rem-sysprop symbol 't1) (rem-sysprop symbol 't2) (rem-sysprop symbol 't3) - #-new-cmp(rem-sysprop symbol 'c1) - #-new-cmp(rem-sysprop symbol 'c2) - #-new-cmp(rem-sysprop symbol 'c1conditional) (rem-sysprop symbol 'lfun)) -#-new-cmp (defun lisp-to-c-name (obj) "Translate Lisp object prin1 representation to valid C identifier name" (and obj diff -Nru ecl-16.1.2/src/cmp/proclamations.lsp ecl-16.1.3+ds/src/cmp/proclamations.lsp --- ecl-16.1.2/src/cmp/proclamations.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/cmp/proclamations.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -48,7 +48,7 @@ (name arg-types return-type &rest properties) (when (sys:get-sysprop name 'proclaimed-arg-types) (warn "Duplicate proclamation for ~A" name)) - (#-new-cmp proclaim-function #+new-cmp c-env::proclaim-function + (proclaim-function name (list arg-types return-type)) (loop for p in properties do (case p @@ -1329,6 +1329,7 @@ (values (or null two-way-stream) (or null integer) ext:external-process)) +(proclamation ext:terminate-process (t &optional gen-bool) null) (proclamation ext:make-weak-pointer (t) ext:weak-pointer :no-side-effects) (proclamation ext:weak-pointer-value (ext:weak-pointer) t) diff -Nru ecl-16.1.2/src/compile.lsp.in ecl-16.1.3+ds/src/compile.lsp.in --- ecl-16.1.2/src/compile.lsp.in 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/compile.lsp.in 2016-12-19 10:25:00.000000000 +0000 @@ -317,56 +317,13 @@ (load "ext:encodings;generate.lisp") ;;; -;;; * Compile the portable CLX library. +;;; * Package locks ;;; - -#+WANTS-CLX -(let* ((*features* (cons :clx-ansi-common-lisp *features*)) - (+clx-src-files+ '("src:clx;package.lisp" - "src:clx;depdefs.lisp" - "src:clx;clx.lisp" - "src:clx;dependent.lisp" - "src:clx;macros.lisp" - "src:clx;bufmac.lisp" - "src:clx;buffer.lisp" - "src:clx;display.lisp" - "src:clx;gcontext.lisp" - "src:clx;input.lisp" - "src:clx;requests.lisp" - "src:clx;fonts.lisp" - "src:clx;graphics.lisp" - "src:clx;text.lisp" - "src:clx;attributes.lisp" - "src:clx;translate.lisp" - "src:clx;keysyms.lisp" - "src:clx;manager.lisp" - "src:clx;image.lisp" - "src:clx;resource.lisp" - "src:clx;shape.lisp" - "src:clx;big-requests.lisp" - "src:clx;xvidmode.lisp" - "src:clx;xrender.lisp" - "src:clx;glx.lisp" - "src:clx;gl.lisp" - "src:clx;dpms.lisp" - "src:clx;xtest.lisp" - "src:clx;screensaver.lisp" - "src:clx;xinerama.lisp" - "build:clx;module.lisp")) - #+:msvc - (c::*cc-flags* (concatenate 'string c::*cc-flags* " -Zm150"))) - (let ((filename "build:clx;module.lisp")) - (ensure-directories-exist filename) - (with-open-file (s filename :direction :output :if-exists :overwrite - :if-does-not-exist :create) - (print '(provide :clx) s))) - (unless (find-package "SB-BSD-SOCKETS") - (load "ext:sockets;package.lisp")) - (mapcar #'load +clx-src-files+) - (build-module "clx" +clx-src-files+ :dir "build:clx;" :prefix "CLX" - :builtin - #+(OR (NOT :WANTS-DLOPEN) :BUILTIN-CLX) t - #-(OR (NOT :WANTS-DLOPEN) :BUILTIN-CLX) nil)) +(build-module "package-locks" + '("ext:package-locks;package-locks.lisp") + :dir "build:ext;" + :prefix "EXT" + :builtin nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; diff -Nru ecl-16.1.2/src/configure ecl-16.1.3+ds/src/configure --- ecl-16.1.2/src/configure 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/configure 2016-12-19 10:25:00.000000000 +0000 @@ -1,7 +1,7 @@ #! /bin/sh # From configure.ac Revision. # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.69 for ecl 16.1.2. +# Generated by GNU Autoconf 2.69 for ecl 16.1.3. # # # Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. @@ -578,8 +578,8 @@ # Identity of this package. PACKAGE_NAME='ecl' PACKAGE_TARNAME='ecl' -PACKAGE_VERSION='16.1.2' -PACKAGE_STRING='ecl 16.1.2' +PACKAGE_VERSION='16.1.3' +PACKAGE_STRING='ecl 16.1.3' PACKAGE_BUGREPORT='' PACKAGE_URL='' @@ -626,8 +626,6 @@ ECL_EXTRA_LISP_FILES CHAR_CODE_LIMIT ECL_CHARACTER -CLX_INFO -CC_IS_CXX ECL_CC POW_LIB LIBOBJS @@ -767,20 +765,22 @@ enable_boehm enable_libatomic enable_soname -with_gmp +enable_gmp with_C_gmp with_system_gmp +with_gmp +with_gmp_args with_gmp_prefix with_gmp_incdir with_gmp_libdir -enable_local_gmp with_libffi_prefix +with_libffi_incdir +with_libffi_libdir with___thread enable_opcode8 with_cxx with_tcp with_serve_event -with_clx with_clos_streams with_cmuformat with_asdf @@ -805,7 +805,6 @@ enable_debug with_debug_cflags with_profile_cflags -with_newcmp with_extra_files with_init_form with_unicode_names @@ -1366,7 +1365,7 @@ # 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 ecl 16.1.2 to adapt to many kinds of systems. +\`configure' configures ecl 16.1.3 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1435,7 +1434,7 @@ if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of ecl 16.1.2:";; + short | recursive ) echo "Configuration of ecl 16.1.3:";; esac cat <<\_ACEOF @@ -1454,9 +1453,10 @@ (auto|included|system, default=auto) --enable-soname link and install the library using version numbers (no|yes, default=yes) - --enable-local-gmp Deprecated! See --with-system-gmp - --enable-opcode8 interpreter uses 8-bit codes (default=NO, only works - on Intel) + --enable-gmp version of the GMP library + (portable|included|system|auto, default=auto) + --enable-opcode8 Deprecated! interpreter uses 8-bit codes + (default=NO, only works on Intel) --enable-unicode={yes|no|32} enable support for unicode (default=YES) --enable-longdouble include support for long double (yes|no|auto, @@ -1478,14 +1478,19 @@ --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) --with-cross-config=f supply configuration for a cross compiler - --with-gmp=args supply arguments for configuring GMP library - --with-C-gmp=args configure GMP to build using portable C - --with-system-gmp use already installed GMP library (default=auto) + --with-C-gmp Deprecated! See --enable-gmp + --with-system-gmp Derpecated! See --enable-gmp + --with-gmp=args Deprecated! See --with-gmp-args + --with-gmp-args=args supply arguments for configuring GMP library --with-gmp-prefix=path prefix for system GMP includes and libraries --with-gmp-incdir=path path to system GMP includes (overrides prefix) --with-gmp-libdir=path path to system GMP libraries (overrides prefix) --with-libffi-prefix=path prefix for system LIBFFI includes and libraries + --with-libffi-incdir=path + path to system LIBFFI includes (overrides prefix) + --with-libffi-libdir=path + path to system LIBFFI libraries (overrides prefix) --with-__thread Enable __thread thread-local variables (yes|NO|auto) (supported by NPTL-aware glibc and maybe Windows) --with-cxx build ECL using C++ compiler (default=NO) @@ -1493,7 +1498,6 @@ default=YES) --with-serve-event include serve-event module (yes|builtin|no, default=YES) - --with-clx include CLX library (yes|builtin|no, default=NO) --with-clos-streams user defined stream objects (yes|builtin|no, default=YES) --with-cmuformat use CMUCL's FORMAT routine (default=YES) @@ -1523,7 +1527,6 @@ (yes,no,actual flags,default=YES) --with-profile-cflags add profiling flags to the compiler invocation (yes,no,actual flags,default=NO) - --with-newcmp new compiler (yes|no, default=NO) --with-extra-files list of additional source files (default="") --with-init-form lisp forms to execute at startup (default="(si::top-level t)") @@ -1611,7 +1614,7 @@ test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -ecl configure 16.1.2 +ecl configure 16.1.3 generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc. @@ -2198,7 +2201,7 @@ This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by ecl $as_me 16.1.2, which was +It was created by ecl $as_me 16.1.3, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ @@ -2644,12 +2647,11 @@ fi - -# Check whether --with-gmp was given. -if test "${with_gmp+set}" = set; then : - withval=$with_gmp; +# Check whether --enable-gmp was given. +if test "${enable_gmp+set}" = set; then : + enableval=$enable_gmp; else - with_gmp="" + enable_gmp=auto fi @@ -2672,6 +2674,24 @@ +# Check whether --with-gmp was given. +if test "${with_gmp+set}" = set; then : + withval=$with_gmp; +else + with_gmp_args="" +fi + + + +# Check whether --with-gmp-args was given. +if test "${with_gmp_args+set}" = set; then : + withval=$with_gmp_args; +else + with_gmp_args="" +fi + + + # Check whether --with-gmp-prefix was given. if test "${with_gmp_prefix+set}" = set; then : withval=$with_gmp_prefix; GMP_INCDIR="$withval/include"; GMP_LIBDIR="$withval/lib" @@ -2692,14 +2712,6 @@ fi -# Check whether --enable-local-gmp was given. -if test "${enable_local_gmp+set}" = set; then : - enableval=$enable_local_gmp; { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: --with-local-gmp is deprecated, use --with-system-gmp instead!" >&5 -$as_echo "$as_me: WARNING: --with-local-gmp is deprecated, use --with-system-gmp instead!" >&2;} - with_system_gmp="${enableval}" -fi - - # Check whether --with-libffi-prefix was given. if test "${with_libffi_prefix+set}" = set; then : @@ -2708,6 +2720,20 @@ +# Check whether --with-libffi-incdir was given. +if test "${with_libffi_incdir+set}" = set; then : + withval=$with_libffi_incdir; LIBFFI_INCDIR="$withval" +fi + + + +# Check whether --with-libffi-libdir was given. +if test "${with_libffi_libdir+set}" = set; then : + withval=$with_libffi_libdir; LIBFFI_LIBDIR="$withval" +fi + + + # Check whether --with-__thread was given. if test "${with___thread+set}" = set; then : withval=$with___thread; @@ -2752,15 +2778,6 @@ -# Check whether --with-clx was given. -if test "${with_clx+set}" = set; then : - withval=$with_clx; -else - with_clx=no -fi - - - # Check whether --with-clos-streams was given. if test "${with_clos_streams+set}" = set; then : withval=$with_clos_streams; @@ -2966,15 +2983,6 @@ -# Check whether --with-newcmp was given. -if test "${with_newcmp+set}" = set; then : - withval=$with_newcmp; -else - with_newcmp=no -fi - - - # Check whether --with-extra-files was given. if test "${with_extra_files+set}" = set; then : withval=$with_extra_files; with_extra_files="${withval}" @@ -3012,8 +3020,7 @@ TARGETS='bin/ecl$(EXE)' -SUBDIRS=c - LSP_FEATURES='*features*' + LSP_FEATURES='*features*' # Make sure we can run config.sub. @@ -4868,8 +4875,8 @@ THREAD_LIBS='' THREAD_GC_FLAGS='--enable-threads=posix' INSTALL_TARGET='install' -THREAD_OBJ="$THREAD_OBJ threads/process threads/queue threads/mutex threads/condition_variable threads/semaphore threads/barrier threads/mailbox" -clibs='' +THREAD_OBJ="$THREAD_OBJ c/threads/process c/threads/queue c/threads/mutex c/threads/condition_variable c/threads/semaphore c/threads/barrier c/threads/mailbox" +clibs='-lm' SONAME='' SONAME_LDFLAGS='' case "${host_os}" in @@ -4880,11 +4887,9 @@ SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH='-Wl,--rpath,~A' - clibs="-ldl" + clibs="-ldl ${clibs}" # Maybe CFLAGS="-D_ISOC99_SOURCE ${CFLAGS}" ??? - CFLAGS="-D_GNU_SOURCE -D_FILE_OFFSET_BITS=64 -DANDROID -DPLATFORM_ANDROID -DUSE_GET_STACKBASE_FOR_MAIN -DIGNORE_DYNAMIC_LOADING -DAO_REQUIRE_CAS ${CFLAGS}" - SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION" - SONAME_LDFLAGS="-Wl,-soname,SONAME" + CFLAGS="-D_GNU_SOURCE -D_FILE_OFFSET_BITS=64 -DPLATFORM_ANDROID -DUSE_GET_STACKBASE_FOR_MAIN -DIGNORE_DYNAMIC_LOADING ${CFLAGS}" LSP_FEATURES="(cons :android ${LSP_FEATURES})" @@ -4898,7 +4903,7 @@ SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH='-Wl,--rpath,~A' - clibs="-ldl" + clibs="-ldl ${clibs}" # Maybe CFLAGS="-D_ISOC99_SOURCE ${CFLAGS}" ??? CFLAGS="-D_GNU_SOURCE -D_FILE_OFFSET_BITS=64 ${CFLAGS}" SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION" @@ -4911,7 +4916,7 @@ SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH='-Wl,--rpath,~A' - clibs="-ldl" + clibs="-ldl ${clibs}" CFLAGS="-D_GNU_SOURCE ${CFLAGS}" SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION" SONAME_LDFLAGS="-Wl,-soname,SONAME" @@ -4923,7 +4928,7 @@ SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH='-Wl,--rpath,~A' - clibs="-ldl" + clibs="-ldl ${clibs}" CFLAGS="-D_GNU_SOURCE ${CFLAGS}" SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION" SONAME_LDFLAGS="-Wl,-soname,SONAME" @@ -4934,7 +4939,7 @@ SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH="-Wl,--rpath,~A" - clibs="" + clibs="${clibs}" SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION" SONAME_LDFLAGS="-Wl,-soname,SONAME" ;; @@ -4944,7 +4949,7 @@ SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH="-Wl,--rpath,~A" - clibs="" + clibs="${clibs}" SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION" SONAME_LDFLAGS="-Wl,-soname,SONAME" ;; @@ -4954,7 +4959,7 @@ SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH="-Wl,--rpath,~A" - clibs="" + clibs="${clibs}" SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION" SONAME_LDFLAGS="-Wl,-soname,SONAME" ;; @@ -4965,7 +4970,7 @@ SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH="-Wl,--rpath,~A" - clibs="-lpthread -lm" + clibs="-lpthread ${clibs}" SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION" SONAME_LDFLAGS="-Wl,-soname,SONAME" ;; @@ -4976,9 +4981,9 @@ BUNDLE_LDFLAGS="-dy -G ${LDFLAGS}" ECL_LDRPATH='-Wl,-R,~A' TCPLIBS='-lsocket -lnsl -lintl' - clibs='-ldl' - SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION" - SONAME_LDFLAGS="-Wl,-soname,SONAME" + clibs='${clibs} -ldl' + SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION" + SONAME_LDFLAGS="-Wl,-soname,SONAME" if test "x$GCC" = "xyes"; then CFLAGS="${CFLAGS} -std=gnu99 -D_XOPEN_SOURCE=600 -D__EXTENSIONS__" SHARED_LDFLAGS="-shared $SHARED_LDFLAGS" @@ -4986,8 +4991,8 @@ fi ;; cygwin*) - enable_threads='no' thehost='cygwin' + #enable_threads='no' shared='yes' THREAD_CFLAGS='-D_THREAD_SAFE' THREAD_LIBS='-lpthread' @@ -5004,6 +5009,8 @@ ;; mingw*) thehost='mingw32' + with_ieee_fp='no' + with_fpe='no' clibs='' shared='yes' enable_threads='yes' @@ -5062,8 +5069,28 @@ SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH='-Wld=\"-rld_l ~A\"' - clibs="-Wld=-lrld" + clibs="-Wld=-lrld ${clibs}" ;; + haiku*) + thehost='haiku' + THREAD_LIBS='' + SHARED_LDFLAGS="-shared ${LDFLAGS}" + BUNDLE_LDFLAGS="-shared ${LDFLAGS}" + ECL_LDRPATH="-Wl,--rpath,~A" + clibs="-lnetwork" + SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION" + SONAME_LDFLAGS="-Wl,-soname,SONAME" + ;; + aix*) + PICFLAG='-DPIC' + thehost="aix" + THREAD_LIBS='-lpthread' + SHARED_LDFLAGS="-G -bsvr4 -brtl ${LDFLAGS}" + BUNDLE_LDFLAGS="-G -bsvr4 -brtl ${LDFLAGS}" + ECL_LDRPATH="-Wl,-R~A" + SONAME="${SHAREDPREFIX}ecl.${SHAREDEXT}.SOVERSION" + SONAME_LDFLAGS="-bsvr4 -brtl" + ;; *) thehost="$host_os" shared="no" @@ -5232,8 +5259,15 @@ CPPFLAGS="$CPPFLAGS $GMP_CPPFLAGS" LDFLAGS="$LDFLAGS $GMP_LDFLAGS" -if test ${with_system_gmp} = "auto"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for __gmpz_init in -lgmp" >&5 +case ${enable_gmp} in #( + portable) : + with_system_gmp=no; with_c_gmp=yes ;; #( + included) : + with_system_gmp=no ;; #( + system) : + with_system_gmp=yes ;; #( + *) : + { $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 ${ac_cv_lib_gmp___gmpz_init+:} false; then : $as_echo_n "(cached) " >&6 @@ -5274,8 +5308,8 @@ else with_system_gmp=no fi - -fi + ;; +esac ECL_GMP_HEADER= if test "${with_system_gmp}" = "yes"; then @@ -5604,7 +5638,7 @@ fi -EXTRA_OBJS="${EXTRA_OBJS} big.o" +EXTRA_OBJS="${EXTRA_OBJS} c/big.o" if test "x${with_system_gmp}" = "xno" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: Configuring included GMP library:" >&5 $as_echo "$as_me: Configuring included GMP library:" >&6;} @@ -5626,13 +5660,15 @@ else GMP_ABI="ABI=$ABI" fi + # Crosscompilation for Android on Darwin requires replacing 'NM=nm' + # below with 'NM=$PLATFORM_PREFIX/bin/arm-linux-androideabi-nm'. mkdir gmp (destdir=`${PWDCMD}`; cd gmp && CC="${CC} ${PICFLAG}" \ - NM=nm $srcdir/gmp/configure --disable-shared --prefix=${destdir} \ + $srcdir/gmp/configure --disable-shared --prefix=${destdir} \ -infodir=${destdir}/doc --includedir=${destdir}/ecl --with-pic \ --libdir=${destdir} --build=${gmp_build} --host=${host_alias} \ CFLAGS="$CFLAGS" LDFLAGS="$LDFLAGS" CPPFLAGS="$CPPFLAGS" CC="${CC} ${PICFLAG}" \ - "$GMP_ABI" $with_gmp) + "$GMP_ABI" $with_gmp_args) if test ! -f gmp/config.status; then as_fn_error $? "Failed to configure the GMP library." "$LINENO" 5 fi @@ -5691,7 +5727,6 @@ LDFLAGS="$LDFLAGS $LIBFFI_LDFLAGS" -LIBS="${LIBS} -lm" { $as_echo "$as_me:${as_lineno-$LINENO}: checking for getpwnam in -lsun" >&5 $as_echo_n "checking for getpwnam in -lsun... " >&6; } if ${ac_cv_lib_sun_getpwnam+:} false; then : @@ -5812,11 +5847,7 @@ LDFLAGS="$with_profile_cflags $LDFLAGS" fi -if test "${with_newcmp}" = "yes"; then - ECL_CMPDIR=new-cmp -else - ECL_CMPDIR=cmp -fi +ECL_CMPDIR=cmp if test "${enable_threads}" = "auto"; then @@ -5842,6 +5873,14 @@ ac_fn_c_check_func "$LINENO" "pthread_rwlock_init" "ac_cv_func_pthread_rwlock_init" if test "x$ac_cv_func_pthread_rwlock_init" = xyes; then : + ac_fn_c_check_type "$LINENO" "pthread_rwlock_t" "ac_cv_type_pthread_rwlock_t" "$ac_includes_default" +if test "x$ac_cv_type_pthread_rwlock_t" = xyes; then : + +cat >>confdefs.h <<_ACEOF +#define HAVE_PTHREAD_RWLOCK_T 1 +_ACEOF + + $as_echo "#define ECL_RWLOCK /**/" >>confdefs.h @@ -5851,7 +5890,10 @@ fi -THREAD_OBJ="$THREAD_OBJ threads/rwlock" + +fi + +THREAD_OBJ="$THREAD_OBJ c/threads/rwlock" boehm_configure_flags="${boehm_configure_flags} ${THREAD_GC_FLAGS}" for k in $THREAD_OBJ; do EXTRA_OBJS="$EXTRA_OBJS ${k}.${OBJEXT}"; done @@ -6118,7 +6160,7 @@ fi else FASL_LIBS="${FASL_LIBS} -lgc" - EXTRA_OBJS="${EXTRA_OBJS} alloc_2.${OBJEXT}" + EXTRA_OBJS="${EXTRA_OBJS} c/alloc_2.${OBJEXT}" $as_echo "#define GBC_BOEHM 1" >>confdefs.h @@ -6147,7 +6189,7 @@ ECL_BOEHM_GC_HEADER='ecl/gc/gc.h' SUBDIRS="${SUBDIRS} gc" CORE_LIBS="-leclgc ${CORE_LIBS}" - EXTRA_OBJS="${EXTRA_OBJS} alloc_2.${OBJEXT}" + EXTRA_OBJS="${EXTRA_OBJS} c/alloc_2.${OBJEXT}" if test "${enable_shared}" = "no"; then LIBRARIES="${LIBRARIES} ${LIBPREFIX}eclgc.${LIBEXT}" fi @@ -6281,7 +6323,7 @@ ECL_LIBFFI_HEADER='ecl/ffi.h' SUBDIRS="${SUBDIRS} libffi" CORE_LIBS="-leclffi ${CORE_LIBS}" - EXTRA_OBJS="${EXTRA_OBJS} alloc_2.${OBJEXT}" + EXTRA_OBJS="${EXTRA_OBJS} c/alloc_2.${OBJEXT}" if test "${enable_shared}" = "no"; then LIBRARIES="${LIBRARIES} ${LIBPREFIX}eclffi.${LIBEXT}" fi @@ -7285,6 +7327,7 @@ cat >>confdefs.h <<_ACEOF #define ECL_LONG_LONG_BITS $ECL_LONG_LONG_BITS _ACEOF + fi @@ -8058,7 +8101,7 @@ fi if test "$enable_longdouble" != "no" ; then -for ac_func in sinl cosl tanl logl expl +for ac_func in sinl cosl tanl logl expl ldexpl frexpl 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" @@ -9267,6 +9310,18 @@ done +for ac_func in feenableexcept +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" +if eval test \"x\$"$as_ac_var"\" = x"yes"; then : + cat >>confdefs.h <<_ACEOF +#define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 +_ACEOF + +fi +done + for ac_func in expf logf sqrtf cosf sinf tanf sinhf coshf tanhf \ floorf ceilf fabsf frexpf ldexpf log1p log1pf log1pl \ @@ -9354,12 +9409,11 @@ if test ${with_cxx} = "no" ; then ECL_CC=${CC} - CC_IS_CXX="nil" - else ECL_CC=${CXX} - CC_IS_CXX="t" + +$as_echo "#define ECL_CXX_CORE 1" >>confdefs.h boehm_configure_flags="${boehm_configure_flags} --enable-cplusplus" fi @@ -9500,32 +9554,6 @@ fi - -if test "${with_clx}" = "builtin"; then - - -LSP_FEATURES="(cons :builtin-clx ${LSP_FEATURES})" - - - - -LSP_FEATURES="(cons :builtin-sockets ${LSP_FEATURES})" - - - with_clx=yes -fi -if test ${with_clx} = "yes"; then - tcp="yes" - - -LSP_FEATURES="(cons :wants-clx ${LSP_FEATURES})" - - - CLX_INFO="clx.${INFOEXT}" -else - CLX_INFO="" -fi - if test "${with_tcp}" = "builtin"; then @@ -9538,7 +9566,7 @@ $as_echo "#define TCP 1" >>confdefs.h - EXTRA_OBJS="${EXTRA_OBJS} tcp.${OBJEXT}" + EXTRA_OBJS="${EXTRA_OBJS} c/tcp.${OBJEXT}" LSP_FEATURES="(cons :wants-sockets ${LSP_FEATURES})" @@ -9664,13 +9692,13 @@ CHAR_CODE_LIMIT=1114112 ECL_CHARACTER=$ECL_INT32_T - EXTRA_OBJS="$EXTRA_OBJS unicode/ucd.o unicode/ucd-0000.o unicode/ucd-0016.o unicode/ucd-0032.o unicode/ucd-0048.o unicode/ucd-0064.o unicode/ucd-0080.o unicode/ucd-0096.o" + EXTRA_OBJS="$EXTRA_OBJS c/unicode/ucd.o c/unicode/ucd-0000.o c/unicode/ucd-0016.o c/unicode/ucd-0032.o c/unicode/ucd-0048.o c/unicode/ucd-0064.o c/unicode/ucd-0080.o c/unicode/ucd-0096.o" fi if test "${with_unicode_names}" = "yes"; then $as_echo "#define ECL_UNICODE_NAMES 1" >>confdefs.h - EXTRA_OBJS="$EXTRA_OBJS unicode/ucd_names_char.o unicode/ucd_names_codes.o unicode/ucd_names_pair.o unicode/ucd_names_str.o" + EXTRA_OBJS="$EXTRA_OBJS c/unicode/ucd_names_char.o c/unicode/ucd_names_codes.o c/unicode/ucd_names_pair.o c/unicode/ucd_names_str.o" fi else CHAR_CODE_LIMIT=256 @@ -9698,10 +9726,13 @@ fi -ac_config_files="$ac_config_files bare.lsp lsp/load.lsp clos/load.lsp cmp/load.lsp new-cmp/load.lsp ../Makefile Makefile c/Makefile doc/Makefile doc/ecl.man doc/ecl-config.man ecl/configpre.h:h/config.h.in bin/ecl-config.pre:util/ecl-config lsp/config.pre:lsp/config.lsp.in compile.pre:compile.lsp.in cmp/cmpdefs.pre:cmp/cmpdefs.lsp tests/config.lsp tests/Makefile" +ac_config_files="$ac_config_files bare.lsp lsp/load.lsp clos/load.lsp cmp/load.lsp ../Makefile Makefile doc/Makefile doc/ecl.man doc/ecl-config.man ecl/configpre.h:h/config.h.in ecl/configpre-int.h:h/config-internal.h.in bin/ecl-config.pre:util/ecl-config lsp/config.lsp:lsp/config.lsp.in compile.pre:compile.lsp.in cmp/cmpdefs.pre:cmp/cmpdefs.lsp tests/config.lsp tests/Makefile" + ac_config_headers="$ac_config_headers ecl/config.h:ecl/configpre.h" +ac_config_headers="$ac_config_headers ecl/config-internal.h:ecl/configpre-int.h" + 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 @@ -10209,7 +10240,7 @@ # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by ecl $as_me 16.1.2, which was +This file was extended by ecl $as_me 16.1.3, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -10271,7 +10302,7 @@ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ -ecl config.status 16.1.2 +ecl config.status 16.1.3 configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" @@ -10397,21 +10428,21 @@ "lsp/load.lsp") CONFIG_FILES="$CONFIG_FILES lsp/load.lsp" ;; "clos/load.lsp") CONFIG_FILES="$CONFIG_FILES clos/load.lsp" ;; "cmp/load.lsp") CONFIG_FILES="$CONFIG_FILES cmp/load.lsp" ;; - "new-cmp/load.lsp") CONFIG_FILES="$CONFIG_FILES new-cmp/load.lsp" ;; "../Makefile") CONFIG_FILES="$CONFIG_FILES ../Makefile" ;; "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; - "c/Makefile") CONFIG_FILES="$CONFIG_FILES c/Makefile" ;; "doc/Makefile") CONFIG_FILES="$CONFIG_FILES doc/Makefile" ;; "doc/ecl.man") CONFIG_FILES="$CONFIG_FILES doc/ecl.man" ;; "doc/ecl-config.man") CONFIG_FILES="$CONFIG_FILES doc/ecl-config.man" ;; "ecl/configpre.h") CONFIG_FILES="$CONFIG_FILES ecl/configpre.h:h/config.h.in" ;; + "ecl/configpre-int.h") CONFIG_FILES="$CONFIG_FILES ecl/configpre-int.h:h/config-internal.h.in" ;; "bin/ecl-config.pre") CONFIG_FILES="$CONFIG_FILES bin/ecl-config.pre:util/ecl-config" ;; - "lsp/config.pre") CONFIG_FILES="$CONFIG_FILES lsp/config.pre:lsp/config.lsp.in" ;; + "lsp/config.lsp") CONFIG_FILES="$CONFIG_FILES lsp/config.lsp:lsp/config.lsp.in" ;; "compile.pre") CONFIG_FILES="$CONFIG_FILES compile.pre:compile.lsp.in" ;; "cmp/cmpdefs.pre") CONFIG_FILES="$CONFIG_FILES cmp/cmpdefs.pre:cmp/cmpdefs.lsp" ;; "tests/config.lsp") CONFIG_FILES="$CONFIG_FILES tests/config.lsp" ;; "tests/Makefile") CONFIG_FILES="$CONFIG_FILES tests/Makefile" ;; "ecl/config.h") CONFIG_HEADERS="$CONFIG_HEADERS ecl/config.h:ecl/configpre.h" ;; + "ecl/config-internal.h") CONFIG_HEADERS="$CONFIG_HEADERS ecl/config-internal.h:ecl/configpre-int.h" ;; *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; esac @@ -10998,4 +11029,5 @@ $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi -for i in $srcdir/c/*/; do mkdir c/`basename $i`; done + +for i in $srcdir/c/*/; do mkdir -p c/`basename $i`; done diff -Nru ecl-16.1.2/src/configure.ac ecl-16.1.3+ds/src/configure.ac --- ecl-16.1.2/src/configure.ac 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/configure.ac 2016-12-19 10:25:00.000000000 +0000 @@ -8,7 +8,7 @@ dnl Giuseppe Attardi 25.1.1994 dnl -AC_INIT([ecl],[16.1.2],[]) +AC_INIT([ecl],[16.1.3],[]) AC_REVISION([$Revision$]) AC_CONFIG_SRCDIR([bare.lsp.in]) AC_CONFIG_AUX_DIR([gmp]) @@ -62,21 +62,33 @@ [(no|yes, default=yes)]), [], [enable_soname=yes] ) -AC_ARG_WITH(gmp, - AS_HELP_STRING( [--with-gmp=args], - [supply arguments for configuring GMP library]), - [], [with_gmp=""]) +AC_ARG_ENABLE(gmp, + AS_HELP_STRING( [--enable-gmp], + [version of the GMP library] + [(portable|included|system|auto, default=auto)] ), + [], [enable_gmp=auto] ) +dnl GMP library options AC_ARG_WITH(C-gmp, - AS_HELP_STRING( [--with-C-gmp=args], - [configure GMP to build using portable C]), + AS_HELP_STRING( [--with-C-gmp], + [Deprecated! See --enable-gmp]), [with_c_gmp=yes; with_system_gmp=no], [with_c_gmp=no]) AC_ARG_WITH(system-gmp, AS_HELP_STRING( [--with-system-gmp], - [use already installed GMP library (default=auto)]), + [Derpecated! See --enable-gmp]), [], [with_system_gmp="auto"]) +AC_ARG_WITH(gmp, + AS_HELP_STRING( [--with-gmp=args], + [Deprecated! See --with-gmp-args]), + [], [with_gmp_args=""]) + +AC_ARG_WITH(gmp-args, + AS_HELP_STRING( [--with-gmp-args=args], + [supply arguments for configuring GMP library]), + [], [with_gmp_args=""]) + AC_ARG_WITH(gmp-prefix, AS_HELP_STRING( [--with-gmp-prefix=path], [prefix for system GMP includes and libraries] ), @@ -92,18 +104,23 @@ [path to system GMP libraries (overrides prefix)] ), [GMP_LIBDIR="$withval"], []) -AC_ARG_ENABLE(local-gmp, - AS_HELP_STRING( [--enable-local-gmp], - [Deprecated! See --with-system-gmp]), - [AC_MSG_WARN( - [--with-local-gmp is deprecated, use --with-system-gmp instead!]) - with_system_gmp="${enableval}"]) - +dnl LIBFFI library options AC_ARG_WITH(libffi-prefix, AS_HELP_STRING( [--with-libffi-prefix=path], [prefix for system LIBFFI includes and libraries] ), [LIBFFI_INCDIR="$withval/include"; LIBFFI_LIBDIR="$withval/lib"], []) +AC_ARG_WITH(libffi-incdir, + AS_HELP_STRING( [--with-libffi-incdir=path], + [path to system LIBFFI includes (overrides prefix)] ), + [LIBFFI_INCDIR="$withval"], []) + +AC_ARG_WITH(libffi-libdir, + AS_HELP_STRING( [--with-libffi-libdir=path], + [path to system LIBFFI libraries (overrides prefix)] ), + [LIBFFI_LIBDIR="$withval"], []) + +dnl AC_ARG_WITH(__thread, AS_HELP_STRING( [--with-__thread], [Enable __thread thread-local variables (yes|NO|auto)] @@ -112,8 +129,7 @@ AC_ARG_ENABLE(opcode8, AS_HELP_STRING( [--enable-opcode8], - [interpreter uses 8-bit codes] - [(default=NO, only works on Intel)]), + [Deprecated! interpreter uses 8-bit codes (default=NO, only works on Intel)]), [opcode8=${enableval}], [opcode8=no]) AC_ARG_WITH(cxx, @@ -131,11 +147,6 @@ [include serve-event module (yes|builtin|no, default=YES)]), [], [with_serve_event=${enable_shared}]) -AC_ARG_WITH(clx, - AS_HELP_STRING( [--with-clx], - [include CLX library (yes|builtin|no, default=NO)]), - [], [with_clx=no]) - AC_ARG_WITH(clos-streams, AS_HELP_STRING( [--with-clos-streams], [user defined stream objects (yes|builtin|no, default=YES)]), @@ -274,11 +285,6 @@ [(yes,no,actual flags,default=NO)]), [],[with_profile_cflags="no"]) -AC_ARG_WITH(newcmp, - AS_HELP_STRING( [--with-newcmp], - [new compiler (yes|no, default=NO)]), - [], [with_newcmp=no]) - AC_ARG_WITH(extra-files, AS_HELP_STRING( [--with-extra-files], [list of additional source files (default="")]), @@ -323,14 +329,14 @@ AC_SUBST(BUNDLE_LDFLAGS) dnl Flags for FASL files linker AC_SUBST(EXTRA_OBJS) dnl Extra *.o files to be compiled into libecl.a AC_SUBST(TARGETS, ['bin/ecl$(EXE)'])dnl Versions of ECL to be built -AC_SUBST(SUBDIRS, [c]) dnl Subdirectories that make should process +AC_SUBST(SUBDIRS, []) dnl Subdirectories that make should process AC_SUBST(LIBRARIES, []) dnl GMP, Boehm's GC, etc AC_SUBST(LSP_LIBRARIES) dnl Libraries produced by lisp translator AC_SUBST(LSP_FEATURES, ['*features*']) dnl Symbols to add to *FEATURES* for conditional compilation dnl ----------------------------------------------------------------------- -dnl Guess operating system of host. We do not allow cross-compiling. +dnl Guess operating system of host. AC_CANONICAL_BUILD AC_CANONICAL_HOST @@ -387,10 +393,13 @@ CPPFLAGS="$CPPFLAGS $GMP_CPPFLAGS" LDFLAGS="$LDFLAGS $GMP_LDFLAGS" -if test ${with_system_gmp} = "auto"; then - AC_CHECK_LIB( [gmp], [__gmpz_init], - [with_system_gmp=yes], [with_system_gmp=no] ) -fi +AS_CASE([${enable_gmp}], + [portable], [with_system_gmp=no; with_c_gmp=yes], + [included], [with_system_gmp=no], + [system], [with_system_gmp=yes], + [AC_CHECK_LIB( [gmp], [__gmpz_init], + [with_system_gmp=yes], + [with_system_gmp=no] )]) ECL_GMP_HEADER= if test "${with_system_gmp}" = "yes"; then @@ -412,7 +421,7 @@ dnl ---------------------------------------------------------------------- dnl Configure local GMP if needed AC_SUBST(ECL_GMP_HEADER) -EXTRA_OBJS="${EXTRA_OBJS} big.o" +EXTRA_OBJS="${EXTRA_OBJS} c/big.o" if test "x${with_system_gmp}" = "xno" ; then AC_MSG_NOTICE(Configuring included GMP library:) test -d gmp && rm -rf gmp @@ -433,14 +442,16 @@ else GMP_ABI="ABI=$ABI" fi + # Crosscompilation for Android on Darwin requires replacing 'NM=nm' + # below with 'NM=$PLATFORM_PREFIX/bin/arm-linux-androideabi-nm'. mkdir gmp dnl Notice we need -DPIC to force the assembler to generate PIC code (destdir=`${PWDCMD}`; cd gmp && CC="${CC} ${PICFLAG}" \ - NM=nm $srcdir/gmp/configure --disable-shared --prefix=${destdir} \ + $srcdir/gmp/configure --disable-shared --prefix=${destdir} \ -infodir=${destdir}/doc --includedir=${destdir}/ecl --with-pic \ --libdir=${destdir} --build=${gmp_build} --host=${host_alias} \ CFLAGS="$CFLAGS" LDFLAGS="$LDFLAGS" CPPFLAGS="$CPPFLAGS" CC="${CC} ${PICFLAG}" \ - "$GMP_ABI" $with_gmp) + "$GMP_ABI" $with_gmp_args) if test ! -f gmp/config.status; then AC_MSG_ERROR([Failed to configure the GMP library.]) fi @@ -480,7 +491,6 @@ dnl ===================================================================== dnl Checks for libraries -LIBS="${LIBS} -lm" AC_CHECK_LIB(sun, getpwnam) # on IRIX adds -lsun AC_SEARCH_LIBS([strerror],[cposix]) @@ -507,11 +517,7 @@ dnl ---------------------------------------------------------------------- dnl Version of the compiler -if test "${with_newcmp}" = "yes"; then - ECL_CMPDIR=new-cmp -else - ECL_CMPDIR=cmp -fi +ECL_CMPDIR=cmp AC_SUBST(ECL_CMPDIR) dnl ---------------------------------------------------------------------- @@ -717,7 +723,7 @@ [lstat mkstemp sigprocmask isatty tzset] \ [gettimeofday getrusage] ) -dnl AC_CHECK_FUNCS( [ feenableexcept ] ) +AC_CHECK_FUNCS( [ feenableexcept ] ) AC_CHECK_FUNCS( [expf logf sqrtf cosf sinf tanf sinhf coshf tanhf] \ [floorf ceilf fabsf frexpf ldexpf log1p log1pf log1pl] \ @@ -746,10 +752,10 @@ dnl Do we use C or C++ compiler to compile ecl? if test ${with_cxx} = "no" ; then AC_SUBST([ECL_CC], [${CC}]) - AC_SUBST([CC_IS_CXX], ["nil"]) else AC_SUBST([ECL_CC], [${CXX}]) - AC_SUBST([CC_IS_CXX], ["t"]) + AC_DEFINE([ECL_CXX_CORE], [1], + [Do we use C or C++ compiler to compile ecl?]) boehm_configure_flags="${boehm_configure_flags} --enable-cplusplus" fi @@ -797,27 +803,13 @@ ECL_ADD_LISP_MODULE([cmp]) fi -AC_SUBST(CLX_INFO) -if test "${with_clx}" = "builtin"; then - ECL_ADD_BUILTIN_MODULE([clx]) - ECL_ADD_BUILTIN_MODULE([sockets]) - with_clx=yes -fi -if test ${with_clx} = "yes"; then - tcp="yes" - ECL_ADD_LISP_MODULE([clx]) - CLX_INFO="clx.${INFOEXT}" -else - CLX_INFO="" -fi - if test "${with_tcp}" = "builtin"; then ECL_ADD_BUILTIN_MODULE([sockets]) with_tcp=yes fi if test "${with_tcp}" = "yes"; then AC_DEFINE(TCP, [1], [Network streams]) - EXTRA_OBJS="${EXTRA_OBJS} tcp.${OBJEXT}" + EXTRA_OBJS="${EXTRA_OBJS} c/tcp.${OBJEXT}" ECL_ADD_LISP_MODULE([sockets]) LIBS="${LIBS} ${TCPLIBS}" fi @@ -887,11 +879,11 @@ AC_DEFINE([ECL_UNICODE], [21], [Support for Unicode]) CHAR_CODE_LIMIT=1114112 ECL_CHARACTER=$ECL_INT32_T - EXTRA_OBJS="$EXTRA_OBJS unicode/ucd.o unicode/ucd-0000.o unicode/ucd-0016.o unicode/ucd-0032.o unicode/ucd-0048.o unicode/ucd-0064.o unicode/ucd-0080.o unicode/ucd-0096.o" + EXTRA_OBJS="$EXTRA_OBJS c/unicode/ucd.o c/unicode/ucd-0000.o c/unicode/ucd-0016.o c/unicode/ucd-0032.o c/unicode/ucd-0048.o c/unicode/ucd-0064.o c/unicode/ucd-0080.o c/unicode/ucd-0096.o" fi if test "${with_unicode_names}" = "yes"; then AC_DEFINE([ECL_UNICODE_NAMES], [1], [Link in the database of Unicode names]) - EXTRA_OBJS="$EXTRA_OBJS unicode/ucd_names_char.o unicode/ucd_names_codes.o unicode/ucd_names_pair.o unicode/ucd_names_str.o" + EXTRA_OBJS="$EXTRA_OBJS c/unicode/ucd_names_char.o c/unicode/ucd_names_codes.o c/unicode/ucd_names_pair.o c/unicode/ucd_names_str.o" fi else CHAR_CODE_LIMIT=256 @@ -918,13 +910,27 @@ fi AC_CONFIG_FILES([ - bare.lsp lsp/load.lsp clos/load.lsp cmp/load.lsp new-cmp/load.lsp - ../Makefile Makefile c/Makefile doc/Makefile doc/ecl.man doc/ecl-config.man - ecl/configpre.h:h/config.h.in bin/ecl-config.pre:util/ecl-config - lsp/config.pre:lsp/config.lsp.in compile.pre:compile.lsp.in + bare.lsp + lsp/load.lsp + clos/load.lsp + cmp/load.lsp + ../Makefile + Makefile + doc/Makefile + doc/ecl.man + doc/ecl-config.man + ecl/configpre.h:h/config.h.in + ecl/configpre-int.h:h/config-internal.h.in + bin/ecl-config.pre:util/ecl-config + lsp/config.lsp:lsp/config.lsp.in + compile.pre:compile.lsp.in cmp/cmpdefs.pre:cmp/cmpdefs.lsp - tests/config.lsp tests/Makefile + tests/config.lsp + tests/Makefile ]) + AC_CONFIG_HEADERS([ecl/config.h:ecl/configpre.h]) +AC_CONFIG_HEADERS([ecl/config-internal.h:ecl/configpre-int.h]) AC_OUTPUT -for i in $srcdir/c/*/; do mkdir c/`basename $i`; done + +for i in $srcdir/c/*/; do mkdir -p c/`basename $i`; done diff -Nru ecl-16.1.2/src/doc/cl-implentations.org ecl-16.1.3+ds/src/doc/cl-implentations.org --- ecl-16.1.2/src/doc/cl-implentations.org 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/cl-implentations.org 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,123 @@ + +* Common Lisp implementations +** Free implementations +*** CLISP Common Lisp +:PROPERTIES: +:last-check: [2016-05-06 Fri] +:END: + +- Homepage :: http://clisp.org/ +- Repository :: http://hg.code.sf.net/p/clisp/clisp +- History :: [[http://clisp.org/summary.html][CLISP Common Lisp Summary]] +- License :: GPL-2.0+ (readline is GPL-3.0 now, so the combined work + with the upstream version is GPLv3, but CLISP may be built with + the older version I suppose). +- Author(s) :: Bruno Haible, Michael Stoll, Marcus Daniels, Pierpaolo + Bernardi, Sam Steingold +- Initial release date :: April 1987 +- Last release :: 2.49 / July 7, 2010 +- Last activity :: 2015-05-31 +*** +Armed Bead Common Lisp +UABCL +Carnegie Mellon University Common Lisp +Clozure Common Lisp +Corman Lisp +Poplog +Steel Bank Common Lisp +Ufasoft +Embeddable Common-Lisp + +** Commercial implementations +Allegro +HCL +LispWorks +Liquid +mocl +Open Genera +Scieneer + +** Incomplete implementations +XCL +Movitz +Mezzano +JSCL +SICL +CLASP +CLforJava +GNU Common Lisp +*** WCL +:PROPERTIES: +:last-check: [2016-05-06 Fri] +:END: + +- Homepage :: [[http://pgc.com/commonlisp/]] +- Repository :: [[https://github.com/wadehennessey/wcl]] +- Author(s) :: Wade L. Hennessey +- License :: Apache-2.0 +- Initial release :: 1990 +- Last release :: 3.0 / ??? +- Last activity :: 2016-04-15 + + +** Subset implementations +Lisp800 +XLISP-PLUS +Parenscript +Acheron +emacs-cl + +** Obsolete implementations +*** partials +- Lisp500 +- XLISP +- SubL +- Software Engineer Common Lisp +- LinkLisp +- L +- ThinLisp +- Lisp-to-C +- Exper +- NanoLISP +- muLISP-90 +- RefLisp +- CLiCC + +*** full (?) +- TI Explorer +- CLOE +- Utah +- Codemist +- Top Level +- Procyon +- FreeLisp +- Ibuki +- Delphi +- Star Sapphire +- Golden +- Eclipse +- Butterfly +- Medley 2.0 +- Lucid +- Genera +- MACL +- Kyoto Common Lisp +- AKCL +- ECoLisp +- ECL Spain +- Coral +- VAX Common Lisp +- PowerLisp +- RMCL +- MCL +- OpenMCL + +*** Data General Common Lisp + +Data General Common Lisp debuted (Mary Poppins ed.) 1984. Dev'd in +RTP, derived from a Dybvig Scheme at UNC. + +Kent Dybvig was a PhD student at UNC and did some of the initial +development. + +Source: Patrick Logan diff -Nru ecl-16.1.2/src/doc/ecl.man.in ecl-16.1.3+ds/src/doc/ecl.man.in --- ecl-16.1.2/src/doc/ecl.man.in 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/ecl.man.in 2016-12-19 10:25:00.000000000 +0000 @@ -1,146 +1,221 @@ -.TH ECL 1 2013-06-09 +.TH ECL 1 2016-09-17 .UC 4 .SH NAME ecl \- Embeddable Common Lisp .SH SYNOPSIS + \fBecl\fP -[\fB\-dir\fP \fIdir\fP] -[\fB\-load\fP \fIfile\fP] -[\fB\-eval\fP \fIexpr\fP] -.br -[\fB\-compile\fP \fIfile\fP -.br -[\fB\-o\fP \fIofile\fP] -[\fB\-c\fP [\fIcfile\fP]] -[\fB\-h\fP [\fIhfile\fP]] -[\fB\-data\fP [\fIdatafile\fP]] -[\fB\-s\fP] [\fB\-q\fP]] +[\fB-?\fP | \fB--help\fP] +.br +[\fB--dir\fP \fIdir\fP] [\fB--load\fP \fIfile\fP] [\fB--shell\fP \fIfile\fP] [\fB--eval\fP \fIexpr\fP] +.br +[\fB--norc\fP] [\fB--hp\fP | \fB--nohp\fP] +.br +[\fB--debug\fP | \fB--nodevbug\fP] +.br +[\fB--c-stack\fP \fIsize\fP] [\fB--lisp-stack\fP \fIsize\fP] +.br +[\fB--heap-size\fP \fIsize\fP] [\fB--frame-stack\fP \fIsize\fP] +.br +[[\fB-o\fP \fIofile\fP] [\fB-c\fP [\fIcfile\fP]] [\fB-h\fP [\fIhfile\fP]] [\fB--data\fP [\fIdatafile\fP]] +.br + [\fB-s\fP] [\fB-q\fP] \fB--compile\fP \fIfile\fP] +.br +[[\fB-o\fP \fIofile\fP] \fB--link\fP \fIfile\fP+] +.br +[\fB--input-encoding\fP \fIexternal-format\fP] [\fB--output-encoding\fP \fIexternal-format\fP] +.br +[\fB--error-encoding\fP \fIexternal-format\fP] [\fB--encoding\fP \fIexternal-format\fP] +.br +\fBDEPRECATION NOTE:\fP one-dash versions of long flags(e.g. \fB-eval\fP or \fB-data\fP) are deprecated; you should use two-dash versions (e.g. \fB--eval\fP or \fB--data\fP) now. + .SH DESCRIPTION .sp -ECL stands for Embeddable Common Lisp. -The ECL project is an effort to modernize -Giuseppe Attardi's ECL environment to -produce an implementation of the Common Lisp -language which complies to the ANSI X3J13 -definition of the language. +ECL (Embeddable Common-Lisp) is an interpreter of the Common-Lisp language as described in the X3J13 Ansi specification, +featuring CLOS (Common-Lisp Object System), conditions, loops, +etc. plus a translator to C, which can produce standalone executables. + +ECL supports the operating systems Linux, FreeBSD, NetBSD, OpenBSD, OS X, Solaris and Windows, running on top of the Intel, Sparc, Alpha, PowerPC and ARM processors. .PP The current ECL implementation features: .IP \(bu -A bytecodes compiler and interpreter. +A bytecode compiler and interpreter. .IP \(bu -A translator to C. +Compiles Lisp also with any C/C++ compiler .IP \(bu -An interface to foreign functions. +Can build standalone executables and libraries .IP \(bu -A dynamic loader. +ASDF, Sockets, Gray streams, MOP, and other useful components .IP \(bu -The possibility to build standalone executables. +Extremely portable .IP \(bu -The Common Lisp Object System (CLOS). -.IP \(bu -Conditions and restarts for handling errors. -.IP \(bu -Sockets as ordinary streams. -.IP \(bu -The Gnu Multiprecision library for fast bignum operations. -.IP \(bu -A simple conservative mark & sweep garbage collector. -.IP \(bu -The Boehm-Weiser garbage collector. - +A reasonable license .PP -\fBecl\fP without any argument gives you the -interactive lisp. +\fBecl\fP without any argument starts the interactive lisp session. + .SH OPTIONS .TP 1i -.BI \-shell " file" -Executes the given file and exits, without providing a read-eval-print loop. -If you want to use lisp as a scripting language, you can write -.BR "#!@bindir@/ecl -shell" -on the first line of the file to be executed, and then ECL will be -automatically invoked. + +.B \-?, \-\-help +Shows the help prompt without running the ECL. .TP -.B \-norc -Do not try to load the file -.I ~/.eclrc -at startup. +.BI \-\-norc +Do not load configuration files at startup. .TP -.B \-dir -Use -.I dir -as system directory. +.BI \-\-version +Prints the current version of ECL, without running the ECL. +.TP +.BI \-debug +Turned on by default, this enables the debugging in the setup phase, +so that you can debug your files. .TP -.BI \-load " file" -Loads +.BI \-\-nodebug +Run without debugging setup phase, meaning that errors prevent ECL from starting up. +.TP +.BI \-\-eval " file" +Evaluate the .I file -before entering the read-eval-print loop. +before loading the .rc file and starting the Top Level. .TP -.BI \-eval " expr" -Evaluates -.I expr -before entering the read-eval-print loop. +.BI \-\-shell " file" +Executes the given +.I file +and exits, without providing a read-eval-print loop. +If you want to use lisp as a scripting language, you can write +.BR "#!@bindir@/ecl --shell" +on the first line of the file to be executed, and then ECL will be +automatically invoked. .TP -.BI \-compile " file" -Translates +.BI \-\-load " file" +Load source .I file -to C and invokes the local C compiler to produce a -shared library with .fas as extension per default. +before loading the .rc file and starting the Top Level. .TP -.BI \-o " ofile" -When compiling +.BI \-\-dir " directory" +Use +.I directory +as a system directory. +.TP +.BI \-\-heap-size " size" +Specify heap +.I size +in kilobytes. +.TP +.BI \-\-lisp-stack " size" +Specify stack +.I size +in kilobytes for lisp system. +.TP +.BI \-\-frame-stack " size" +Specify frame stack +.I size +in kilobytes. +.TP +.BI \-\-c-stack " size" +Specify stack +.I size +in kilobytes for C compiler. +.TP +.BI \-\-trap-fpe +Make ECL debugger catch floating point exception. +.TP +.BI \-\-no-trap-fpe +Make ECL debugger not catch floating point exception. +.TP +.BI \-\-encoding " encoding" +Specify the external +.I encoding +for standard input, output, trace and error. +.TP +.BI \-\-input-encoding " encoding" +Specify the external +.I encoding +for standard input. +.TP +.BI \-\-output-encoding " encoding" +Specify the external +.I encoding +for standard output. +.TP +.BI \-\-error-encoding " encoding" +Specify the external +.I encoding +for standard error. +.TP + +.BI \-o " file" +Provide the output target .I file -name the resulting shared library -\fIofile\fP. +for compilation. .TP .BI \-c " cfile" When compiling name the intermediary C file .I cfile and do not delete it afterwards. .TP -.BI \-h " hfile" -When compiling name the intermediary C header -.I hfile +.BI \-h " cfile" +When compiling name the intermediary C file +.I cfile and do not delete it afterwards. .TP -.BI \-data " [datafile]" +.BI \-\-data " [datafile]" Dumps compiler data into \fIdatafile\fP or, if not supplied, into a file named after the source file, but with .data as extension. .TP -.B \-s +.BI \-\-compile " file" +Translates +.I file +to C and invokes the local C compiler to produce a +native code program. +.TP +.BI \-q +Short for quiet - produce less notes. +.TP +.BI \-\-hp +This option is deprecated and doesn't do anything. +.TP +.BI \-\-nodp +This option is deprecated and doesn't do anything. +.TP +.BI \-s Produce a linkable object file. It cannot be loaded with load, but it can be used to build libraries or standalone executable programs. .TP -.B \-q -Produce less notes when compiling. -.PP -The options -.B \-load, -.B \-shell, -and -.B \-eval -may appear any number of times, and they are combined and processed from left -to right. .SH AUTHORS -The original version was developed by Giuseppe Attardi starting from the Kyoto -Common Lisp implementation by Taiichi Yuasa and Masami Hagiya. The current -maintainer of ECL is Juan Jose Garcia Ripoll, who can be reached at the ECL -mailing list. + +The original version was developed by Giuseppe Attardi starting from +the Kyoto Common Lisp implementation by Taiichi Yuasa, Masami +Hagiya. Further development was lead by Juan Jose Garcia Ripoll. The +current maintainer of ECL is Daniel Kochmański, who can be reached at +the ECL mailing list. + .SH FILES .TP .BR "~/.ecl, ~/.eclrc" Default initialization files loaded at startup unless the option -.BR \-norc +.BR \-\-norc is provided. (if they exist). + .SH SEE ALSO -.IP "" -ANSI Common Lisp standard X3.226-1994 -.IP "" -The Common Lisp HyperSpec +.IP ANSI Common Lisp standard X3.226-1994 +.IP The Common Lisp HyperSpec + .SH "BUGS" -Probably some. Report them! +Unfortunately it is possible that there are some bugs in the program. +In case you find any bug, please report it as an issue (after making sure that it hasn't been reported or fixed) +to official gitlab repository: https://gitlab.com/embeddable-common-lisp/ecl/issues . + +.SH "LICENSE" +ECL 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; see file 'Copying'. +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 Library General Public License for more details. + +You should have received a copy of the GNU Library General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +Please report bugs, comments, suggestions to the ecl mailing list: +.B ecl-devel@common-lisp.net +(or use gitlab). diff -Nru ecl-16.1.2/src/doc/help.lsp ecl-16.1.3+ds/src/doc/help.lsp --- ecl-16.1.2/src/doc/help.lsp 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/help.lsp 2016-12-19 10:25:00.000000000 +0000 @@ -629,7 +629,7 @@ However, if the argument is a symbol, it is interpreted as the name of a lisp library of FASL code. You should use symbols to call in optional parts of the -interpreter, such as the compiler 'CMP or the 'CLX library (not yet available) +interpreter, such as the compiler 'CMP (not yet available) For example: (compile-file \"my-code.lsp\" :system-p) diff -Nru ecl-16.1.2/src/doc/Makefile.in ecl-16.1.3+ds/src/doc/Makefile.in --- ecl-16.1.2/src/doc/Makefile.in 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/Makefile.in 2016-12-19 10:25:00.000000000 +0000 @@ -6,6 +6,7 @@ infodir = @infodir@ mandir=@mandir@ docdir=@docdir@ +datarootdir = @datarootdir@ manext=1 INFOEXT = @INFOEXT@ @@ -15,7 +16,7 @@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_INFO = @INSTALL_INFO@ mkinstalldirs = $(top_srcdir)/bdwgc/install-sh -d -INFO_FILES = ecl.$(INFOEXT) ecldev.$(INFOEXT) @CLX_INFO@ +INFO_FILES = ecl.$(INFOEXT) ecldev.$(INFOEXT) HTML_FILES = index.html license.html lgpl.html news.html benchmark.html \ install.html download.html cvs.html @@ -33,15 +34,11 @@ tex $(srcdir)/user.txi ecldev.dvi: $(srcdir)/devel.txi $(srcdir)/macros.txi clisp.sty ecl.sty tex $(srcdir)/devel.txi -clx.dvi: clx.texinfo - tex clx.texinfo ecl.ps: ecl.dvi $(srcdir)/macros.txi dvips -o $@ ecl.dvi ecldev.ps: ecldev.dvi $(srcdir)/macros.txi dvips -o $@ ecldev.dvi -clx.ps: clx.dvi - dvips -o $@ clx.dvi install: all $(mkinstalldirs) $(DESTDIR)$(infodir) @@ -52,7 +49,7 @@ fi; \ done $(mkinstalldirs) $(DESTDIR)$(docdir) - for i in Copyright LGPL; do \ + for i in LICENSE LGPL; do \ $(INSTALL_DATA) $(top_srcdir)/../$$i $(DESTDIR)$(docdir); \ done $(mkinstalldirs) $(DESTDIR)$(mandir)/man$(manext) @@ -73,7 +70,7 @@ $(mkinstalldirs) $(DESTDIR)$(docdir)/ecldev; \ for i in ecldev/*; do $(INSTALL_DATA) $$i $(DESTDIR)$(docdir)/ecldev/; done; \ fi - for i in Copyright LGPL; do \ + for i in LICENSE LGPL; do \ $(INSTALL_DATA) $(top_srcdir)/../$$i $(DESTDIR)$(docdir); \ done for i in *.html; do $(INSTALL_DATA) $$i $(DESTDIR)$(docdir)/; done @@ -99,16 +96,10 @@ gzip < ecl.info > ecl.info.gz ecldev.info.gz: ecldev.info gzip < ecldev.info > ecldev.info.gz -clx.info.gz: clx.info - gzip < clx.info > clx.info.gz ecl.info: $(srcdir)/user.txi $(srcdir)/macros.txi makeinfo -I $(srcdir) --no-split $(srcdir)/user.txi ecldev.info: $(srcdir)/devel.txi $(srcdir)/macros.txi makeinfo -I $(srcdir) --no-split $(srcdir)/devel.txi -clx.info: clx.texinfo - -makeinfo --no-split clx.texinfo -clx.texinfo: $(top_srcdir)/clx/manual/clx.texinfo - cp $(top_srcdir)/clx/manual/clx.texinfo . download.html: $(srcdir)/download.in.html head cat head $(srcdir)/download.in.html $(srcdir)/end | $(FILTER) > $@ diff -Nru ecl-16.1.2/src/doc/new-doc/developer-guide/contributing-code-standards.txi ecl-16.1.3+ds/src/doc/new-doc/developer-guide/contributing-code-standards.txi --- ecl-16.1.2/src/doc/new-doc/developer-guide/contributing-code-standards.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/developer-guide/contributing-code-standards.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,107 @@ +@node Coding standards +@subsection Coding standards + +@cindex Coding conventions + +@subsubheading Lisp conventions +Lisp code should follow the standard conventions used in the +community. + +If the function is local to the file it's used in, then it should be +declared as c-local: + +@exindex Lisp convention: local functions +@lisp +(defun command-arg-error (str &rest fmt-args) + ;; Format an error message and quit + (declare (si::c-local)) + (apply #'format *error-output* str fmt-args) + (princ *help-message* *error-output*) + (quit 1)) +@end lisp + +@subsubheading C/C++ conventions + +ECL internal C files are preprocessed with the [@ref{Defun +preprocessor}]. This results in the ability to use somewhat unusual +syntax in the C source files like @verb{|defun|} with the +@verb{|&optional|}, @verb{|&rest|}, @verb{|&key|} and @verb{|&aux|} +arguments as well as returning multiple values from the funciton using +@verb{|@(return)|}.. + +Style used in C/C++ files is 2 space indent, no tabs, similar to +@url{https://gcc.gnu.org/codingconventions.html}. Programmer may depend +on emacs default indentation (C-. gnu). Lines should be wrapped to 78 +lines. + +Important note: @verb{|@(return foo bar)|} is expanded to the code +block, so if put inside the if statement it should be enclosed in +braces: + +@exindex C/C++ convention: sample function +@verbatim +static cl_object +file_truename(cl_object pathname, cl_object filename, int flags) +{ + cl_object kind; + if (Null(pathname)) { + if (Null(filename)) { + ecl_internal_error("file_truename:" + " both FILENAME and PATHNAME are null!"); + } + pathname = cl_pathname(filename); + } else if (Null(filename)) { + filename = ecl_namestring(pathname, ECL_NAMESTRING_FORCE_BASE_STRING); + if (Null(filename)) { + FEerror("Unprintable pathname ~S found in TRUENAME", 1, pathname); + } + } + kind = file_kind((char*)filename->base_string.self, FALSE); + if (kind == ECL_NIL) { + FEcannot_open(filename); +#ifdef HAVE_LSTAT + } else if (kind == @':link' && (flags & FOLLOW_SYMLINKS)) { + /* The link might be a relative pathname. In that case + * we have to merge with the original pathname. On + * the other hand, if the link is broken – return file + * truename "as is". */ + struct stat filestatus; + if (safe_stat(filename->base_string.self, &filestatus) < 0) { + @(return pathname kind); + } + filename = si_readlink(filename); + pathname = ecl_make_pathname(pathname->pathname.host, + pathname->pathname.device, + pathname->pathname.directory, + ECL_NIL, ECL_NIL, ECL_NIL, @':local'); + pathname = ecl_merge_pathnames(filename, pathname, @':default'); + return cl_truename(pathname); +#endif + } else if (kind == @':directory'){ + /* If the pathname is a directory but we have supplied + a file name, correct the type by appending a directory + separator and re-parsing again the namestring */ + if (pathname->pathname.name != ECL_NIL || + pathname->pathname.type != ECL_NIL) { + pathname = si_base_string_concatenate + (2, filename, + make_constant_base_string("/")); + pathname = cl_truename(pathname); + } + } + /* ECL does not contemplate version numbers + in directory pathnames */ + if (pathname->pathname.name == ECL_NIL && + pathname->pathname.type == ECL_NIL) { + /* We have to destructively change the + * pathname version here. Otherwise + * merge_pathnames will not do it. It is + * safe because coerce_to_file_pathname + * created a copy. */ + pathname->pathname.version = ECL_NIL; + } else { + pathname->pathname.version = @':newest'; + } + @(return pathname kind); +} +@end verbatim diff -Nru ecl-16.1.2/src/doc/new-doc/developer-guide/contributing-documentation.txi ecl-16.1.3+ds/src/doc/new-doc/developer-guide/contributing-documentation.txi --- ecl-16.1.2/src/doc/new-doc/developer-guide/contributing-documentation.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/developer-guide/contributing-documentation.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,198 @@ +@node Documentation +@subsection Documentation + +It is not an accident, that the documentation is the first chapter on +contributing to the @ecl – we believe that writing good documentation is +a cornerstone of any reliable software. + +The second assumption is that people learn most from the examples, so +each concept should have illustration in code with a special entry in +the examples index. + +@subsubsection Indexes +For the purpose of this manual we maintain a few indexes listed +below. They are meant to help navigate and search for information by the +reader. + +@itemize @bullet +@item Concept index – concept covered by a documentation +@exindex Concept index +@verb{|@cindex User extensible streams|} + +@item Configure option index – options available in configure script + +Mark the default option with capital letters: +@exindex Configure option index +@verb{$--enable-clos-streams [YES|builtin|no]$} + +@item Feature index – description of an item in @code{*FEATURES*} + +@exindex Feature index +@verb{|@ftindex GRAY-STREAMS|} + +@item Example index – example illustrating some use-case + +@exindex Example index +@verb{|@exindex @code{gray:close} specializing function on @code{T}|} + +@item Function index – covers both Lisp and C/C++ functions + +Implicitly added by @verb{|@defun|}, @verb{|@defmac|} etc. + +@item Variable index – covers both Lisp and C/C++ variables + +Implicitly added by @verb{|@defvar|} etc. + +@item Type index – both C/C++ and Lisp + +@exindex Type indexes + +Adding C/C++ type: +@verb{|@deftp {@cind} cl_env_struct|} + +Adding Lisp type: +@verb{|@deftp {@lind} trivial-process|} + +@item Common Lisp symbols – list of defined CL symbols (functions, variables etc.) + +@exindex Common Lisp symbol index +@verb{|@lspindex gray:close|} +@verb{|@lspindex ffi:*has-dffi*|} + +@item C/C++ index + +@exindex C/C++ name index +@verb{|@cppindex cl_env_struct|} + +@end itemize + +@subsubheading Functions, macros and special forms + +If function is from the Lisp ``world'', then we add it to the +@verb{|@lspindex|}, if from C/C++, then to the @verb{|@cppindex|}. + +@exindex Documenting lisp operator +@verbatim +@lspindex ext:run-program +@defun ext:run-program ... +Short description +@table @var +@item arg-1 +description +@item arg-2 +description +@item returns +One value? More? +@end table +@subsubheading Description +Description here +@subsubheading Examples @c Omit section if none +Comment on the example if necessary. +@exindex @code{package:function} short summary +@lisp +(some-code-demonstrating-the-functionality) +@end lisp +@subsubheading Side effects @c Omit section if none +Side effects listed +@subsubheading Affected by @c Omit section if none +For instance: if the user has some privigiles on the system +@end defun +@end verbatim + +@subsubheading Typed functions + +@exindex Documenting typed function +@verbatim +@deftypefun return-type name (type arg)* +description +@end deftypefun +@end verbatim + +@subsubheading Variables + +@exindex Documenting variables +@verbatim +@defvr {Constant} MOST_NEGATIVE_FIXNUM +@defvrx {Constant} MOST_POSITIVE_FIXNUM +These constants mark the limits of a fixnum. +@end defvr +@defvr {FFI} *use-dffi* +Description. +@end defvr +@end verbatim + +@subsubheading Deprecated, obsolete and unused functions/variables + +These shouldn't appear in the function index nor the variable index, but +should be listed in the C/C++ symbol index or/and Lisp index. Their +status should be marked with the @strong{keyword}. + +@exindex Documenting deprecation and obsolescence +Example: +@verbatim +@cppindex ecl_fix +@cppindex ecl_unfix +@cppindex ecl_make_fixnum +@cppindex ecl_fixnum + +@deftypefun cl_object ecl_fix (cl_fixnum n) +@deftypefunx cl_fixnum ecl_unfix (cl_object o) +@code{ecl_fix} converts from an integer to a lisp object, while the +@code{ecl_unfix} does the opposite (converts lisp object fixnum to integer). + +@itemize @bullet +@item @strong{DEPRECATED} @code{cl_make_fixnum} – equivalent to @code{cl_fix} +@item @strong{DEPRECATED} @code{cl_fixnum} – equivalent to @code{cl_unfix} +@end itemize +@end deftypefun +@end verbatim + +@cindex Deprecation and obsolescence +If symbol is deprecated, it will be marked as obsolete in the next +release, while obsolete symbols will be removed. + +@subsubsection Examples +People learn by examples. New functions should have a usage example +listed in the examples index. When we want to illustrate some lisp code, +we should put it inside the @verb{|@lisp|} and @verb{|@end lisp|} +block, while if the code is in C/C++ put it in @verb{|@example|} and +@verb{|@end example|}. + +Sometimes code contains invalid characters which confuse the texinfo. If +that's a case, then ode should be put additionally inside the +@verb{|@verbatim|} and @verb{|@end verbatim|} pair. + +@exindex Examples in documentation +@verbatim +@lisp +(lambda () T) +@end lisp + +@example +int i = 3; +@end example +@end verbatim + +@subsubsection Concepts +Concepts are arguably the most important topic covered in any +documentation. They reflect the ideas behind the software with the +underlying implementation decisions motivation. + +The main questions answered by the ``concepts'' are: +@itemize +@item What is a purpose of this interface? +@item Why it has been implemented that way? +@end itemize + +@subsubsection Cross-references + +References should be added like as follows: +@verbatim +[@ref{Standards}] +@end verbatim + +Links: +@verbatim +@uref{http://example.org} +@uref{http://example.org, Example website} +@end verbatim diff -Nru ecl-16.1.2/src/doc/new-doc/developer-guide/contributing.txi ecl-16.1.3+ds/src/doc/new-doc/developer-guide/contributing.txi --- ecl-16.1.2/src/doc/new-doc/developer-guide/contributing.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/developer-guide/contributing.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,15 @@ +@node Contributing +@section Contributing + +@menu +@c * Documentation:: Documentation +@c * Coding standards:: Lisp and C/C++ code conventions +@c * Providing tests:: +@c * Submitting patches:: +@c * Reporting issues:: +@c * Financial contributions:: +@c * Other ways to contribute:: +@end menu + +@c @include developer-guide/contributing-documentation.txi +@c @include developer-guide/contributing-code-standards.txi diff -Nru ecl-16.1.2/src/doc/new-doc/developer-guide/dpp.txi ecl-16.1.3+ds/src/doc/new-doc/developer-guide/dpp.txi --- ecl-16.1.2/src/doc/new-doc/developer-guide/dpp.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/developer-guide/dpp.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,61 @@ +@node Defun preprocessor +@section Defun preprocessor + +@cindex Defun preprocessor + +Usage: + dpp [in-file [out-file]] + +The file named in-file is preprocessed and the output will be +written to the file whose name is out-file. If in-file is "-" +program is read from standard input, while if out-file is "-" +C-program is written to standard output. + +The function definition: + +@exindex dpp: function definition +@lisp +@(defun name ({var}* + [&optional {var | (var [initform [svar]])}*] + [&rest var] + [&key {var | + ({var | (keyword var)} [initform [svar]])}* + [&allow_other_keys]] + [&aux {var | (var [initform])}*]) + + C-declaration + +@ { + + C-body + +} @) +@end lisp + + name can be either an identifier or a full C procedure header + enclosed in quotes ('). + + &optional may be abbreviated as &o. + &rest may be abbreviated as &r. + &key may be abbreviated as &k. + &allow_other_keys may be abbreviated as &aok. + &aux may be abbreviated as &a. + + Each variable becomes a C variable. + + Each supplied-p parameter becomes a boolean C variable. + + Initforms are C expressions. + If an expression contains non-alphanumeric characters, + it should be surrounded by backquotes (`). + + + Function return: + + @(return {form}*); + + Return function expands into a lexical block {}, so if it's + used inside IF/ELSE, then it should be enclosed, even if we + use sole @(return);, because ";" will be treated as the next + instruction. + diff -Nru ecl-16.1.2/src/doc/new-doc/developer-guide/environment.txi ecl-16.1.3+ds/src/doc/new-doc/developer-guide/environment.txi --- ecl-16.1.2/src/doc/new-doc/developer-guide/environment.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/developer-guide/environment.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,8 @@ +@node Environment implementation +@section Environment implementation + +@cppindex cl_env_struct + +@c @deftp {@cind} cl_env_struct +@c xxx +@c @end deftp diff -Nru ecl-16.1.2/src/doc/new-doc/developer-guide/index.txi ecl-16.1.3+ds/src/doc/new-doc/developer-guide/index.txi --- ecl-16.1.2/src/doc/new-doc/developer-guide/index.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/developer-guide/index.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,25 @@ +@node Developer's guide +@chapter Developer's guide + +@menu +* Sources structure:: Overview of the source code structure +* Contributing:: How to contribute to the ECL project +@c * Modules hierarchy:: +@c * Testing and benchmarking:: +@c * Defun preprocessor:: Preprocessor for the Lisp constructs in C +* Manipulating Lisp objects:: +* Environment implementation:: +@c * The interpreter:: +@c * The compiler:: +@c * Porting ECL:: +* Removed features:: +@c * Experimental features:: +@c * Current roadmap:: +@end menu + +@include developer-guide/sources.txi +@include developer-guide/contributing.txi +@c @include developer-guide/dpp.txi +@include developer-guide/objects.txi +@include developer-guide/environment.txi +@include developer-guide/removed.txi diff -Nru ecl-16.1.2/src/doc/new-doc/developer-guide/objects.txi ecl-16.1.3+ds/src/doc/new-doc/developer-guide/objects.txi --- ecl-16.1.2/src/doc/new-doc/developer-guide/objects.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/developer-guide/objects.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,809 @@ +@node Manipulating Lisp objects +@section Manipulating Lisp objects + +@menu +* Objects representation:: +* Constructing objects:: +@end menu + +If you want to extend, fix or simply customize ECL for your own needs, +you should understand how the implementation works. + +@cppindex cl_lispunion +@deftp {@cind} cl_lispunion cons big ratio SF DF longfloat complex symbol pack hash array vector base_string string stream random readtable pathname bytecodes bclosure cfun cfunfixed cclosure d instance process queue lock rwlock condition_variable semaphore barrier mailbox cblock foreign frame weak sse + +Union containing all first-class ECL types. +@end deftp + +@node Objects representation +@subsection Objects representation +In ECL a lisp object is represented by a type called +@code{cl_object}. This type is a word which is long enough to host both +an integer and a pointer. The least significant bits of this word, also +called the tag bits, determine whether it is a pointer to a C structure +representing a complex object, or whether it is an immediate data, such +as a fixnum or a character. + +@float Figure,fig:immediate_types +@caption{Immediate types} +@image{figures/immediate-types,,1in} +@end float + +The topic of the immediate values and bit fiddling is nicely described +in +@url{http://www.more-magic.net/posts/internals-data-representation.html, +Peter Bex's blog} describing @url{http://www.call-cc.org/,Chicken +Scheme} internal data representation. We could borrow some ideas from it +(like improving @code{fixnum} bitness and providing more immediate +values). All changes to code related to immediate values should be +carefully @strong{benchmarked}. + +The @code{fixnums} and characters are called immediate data types, +because they require no more than the @code{cl_object} datatype to store +all information. All other ECL objects are non-immediate and they are +represented by a pointer to a cell that is allocated on the heap. Each +cell consists of several words of memory and contains all the +information related to that object. By storing data in multiples of a +word size, we make sure that the least significant bits of a pointer are +zero, which distinguishes pointers from immediate data. + +In an immediate datatype, the tag bits determine the type of the +object. In non-immediate datatypes, the first byte in the cell contains +the secondary type indicator, and distinguishes between different types +of non immediate data. The use of the remaining bytes differs for each +type of object. For instance, a cons cell consists of three words: + +@verbatim ++---------+----------+ +| CONS | | ++---------+----------+ +| car-pointer | ++--------------------+ +| cdr-pointer | ++--------------------+ +@end verbatim + +@cfindex --enable-small-cons [YES|no] + +Note, that this is on of the possible implementations of +@code{cons}. The second one (currently default) uses the immediate value +for the @code{list} and consumes two words instead of three. Such +implementation is more memory and speed efficient (according to the +comments in the source code): + +@verbatim +/* + * CONSES + * + * We implement two variants. The "small cons" type carries the type + * information in the least significant bits of the pointer. We have + * to do some pointer arithmetics to find out the CAR / CDR of the + * cons but the overall result is faster and memory efficient, only + * using two words per cons. + * + * The other scheme stores conses as three-words objects, the first + * word carrying the type information. This is kept for backward + * compatibility and also because the oldest garbage collector does + * not yet support the smaller datatype. + * + * To make code portable and independent of the representation, only + * access the objects using the common macros below (that is all + * except ECL_CONS_PTR or ECL_PTR_CONS). + */ +@end verbatim + +@cppindex cl_object +@deftp {@cind} cl_object +This is the type of a lisp object. For your C/C++ program, a cl_object +can be either a fixnum, a character, or a pointer to a union of +structures (See @code{cl_lispunion} in the header object.h). The actual +interpretation of that object can be guessed with the macro +@code{ecl_t_of}. + +@subsubheading Example +@exindex @code{cl_object} checking the type with @code{ecl_t_of} + +For example, if x is of type cl_object, and it is of type fixnum, we may +retrieve its value: + +@example +if (ecl_t_of(x) == t_fixnum) + printf("Integer value: %d\n", fix(x)); +@end example + +@subsubheading Example +@exindex Accessing underlying @code{cl_object} structure + +If @code{x} is of type cl_object and it does not contain an immediate +datatype, you may inspect the cell associated to the lisp object using +@code{x} as a pointer. For example: + +@example +if (ecl_t_of(x) == t_vector) + printf("Vector's dimension is: %d\n", x->dim); +@end example + +You should see the following sections and the header object.h to learn +how to use the different fields of a cl_object pointer. +@end deftp + +@deftp {@cind} cl_type +Enumeration type which distinguishes the different types of lisp +objects. The most important values are: + +@cppindex t_start +@cppindex t_list +@cppindex t_character +@cppindex t_fixnum +@cppindex t_bignum +@cppindex t_ratio +@c @cppindex t_shortfloat +@cppindex t_singlefloat +@c #ifdef ECL_LONG_FLOAT +@cppindex t_longfloat +@c #endif +@cppindex t_complex +@cppindex t_symbol +@cppindex t_package +@cppindex t_hashtable +@cppindex t_array +@cppindex t_vector +@c #ifdef ECL_UNICODE +@cppindex t_string +@c #endif +@cppindex t_base_string +@cppindex t_bitvector +@cppindex t_stream +@cppindex t_random +@cppindex t_readtable +@cppindex t_pathname +@cppindex t_bytecodes +@cppindex t_bclosure +@cppindex t_cfun +@cppindex t_cfunfixed +@cppindex t_cclosure +@cppindex t_instance +@cppindex t_structure = t_instance +@c #ifdef ECL_THREADS +@cppindex t_process +@cppindex t_lock +@cppindex t_rwlock +@cppindex t_condition_variable +@cppindex t_semaphore +@cppindex t_barrier +@cppindex t_mailbox +@c #endif +@cppindex t_codeblock +@cppindex t_foreign +@cppindex t_frame +@cppindex t_weak_pointer +@c #ifdef ECL_SSE2 +@cppindex t_sse_pack +@c #endif +@cppindex t_end +@cppindex t_other +@cppindex t_contiguous – contiguous block + +@code{t_cons} @code{t_fixnum}, @code{t_character}, @code{t_bignum}, +@code{t_ratio}, @code{t_singlefloat}, @code{t_doublefloat}, +@code{t_complex}, @code{t_symbol}, @code{t_package}, @code{t_hashtable}, +@code{t_array}, @code{t_vector}, @code{t_string}, @code{t_bitvector}, +@code{t_stream}, @code{t_random}, @code{t_readtable}, @code{t_pathname}, +@code{t_bytecodes}, @code{t_cfun}, @code{t_cclosure}, @code{t_gfun}, +@code{t_instance}, @code{t_foreign} and @code{t_thread}. +@end deftp + +@cppindex ecl_t_of +@deftypefun cl_type ecl_t_of (cl_object x) +If @var{x} is a valid lisp object, @code{ecl_t_of(x)} returns an integer +denoting the type that lisp object. That integer is one of the values of +the enumeration type @code{cl_type}. +@end deftypefun + +@c XXX: add all predicate macros to the index +@cppindex ECL_FIXNUMP +@cppindex ECL_CHARACTERP +@cppindex CODE_CHAR_P +@cppindex ECL_BASE_CHAR_P +@cppindex ECL_BASE_CHAR_CODE_P +@cppindex ECL_NUMBER_TYPE_P +@cppindex ECL_REAL_TYPE_P +@cppindex ECL_REAL_TYPE_P +@cppindex ECL_CONSP +@cppindex ECL_LISTP +@cppindex ECL_ATOM +@cppindex ECL_SYMBOLP +@cppindex ECL_ARRAYP +@cppindex ECL_VECTORP +@cppindex ECL_BIT_VECTOR_P +@cppindex ECL_STRINGP + +@deftypefun bool ECL_FIXNUMP (cl_object o) +@deftypefunx bool ECL_CHARACTERP (cl_object o) +@deftypefunx bool ECL_BASE_CHAR_P (cl_object o) +@deftypefunx bool ECL_CODE_CHAR_P (cl_object o) +@deftypefunx bool ECL_BASE_CHAR_CODE_P (cl_object o) +@deftypefunx bool ECL_NUMBER_TYPE_P (cl_object o) +@deftypefunx bool ECL_REAL_TYPE_P (cl_object o) +@deftypefunx bool ECL_CONSP (cl_object o) +@deftypefunx bool ECL_LISTP (cl_object o) +@deftypefunx bool ECL_ATOM (cl_object o) +@deftypefunx bool ECL_SYMBOLP (cl_object o) +@deftypefunx bool ECL_ARRAYP (cl_object o) +@deftypefunx bool ECL_VECTORP (cl_object o) +@deftypefunx bool ECL_BIT_VECTOR_P (cl_object o) +@deftypefunx bool ECL_STRINGP (cl_object o) + +Different macros that check whether @var{o} belongs to the specified +type. These checks have been optimized, and are preferred over several +calls to @code{ecl_t_of}. +@end deftypefun + +@cppindex ECL_IMMEDIATE +@deftypefun bool ECL_IMMEDIATE (cl_object o) +Tells whether @var{x} is an immediate datatype. +@end deftypefun + +@node Constructing objects +@subsection Constructing objects + +On each of the following sections we will document the standard +interface for building objects of different types. For some objects, +though, it is too difficult to make a C interface that resembles all of +the functionality in the lisp environment. In those cases you need to + +@enumerate +@item build the objects from their textual representation, or +@item use the evaluator to build these objects. +@end enumerate + +The first way makes use of a C or Lisp string to construct an +object. The two functions you need to know are the following ones. + +@cppindex c_string_to_object +@cppindex string_to_object +@deftypefun cl_object c_string_to_object (const char *s) +@deftypefunx cl_object string_to_object (cl_object o) +@code{c_string_to_object} builds a lisp object from a C string which +contains a suitable representation of a lisp +object. @code{string_to_object} performs the same task, but uses a lisp +string, and therefore it is less useful. + +@subsubheading Example +@exindex @code{c_string_to_object} constructing Lisp objects in C + +Using a C string +@example +cl_object array1 = c_string_to_object("#(1 2 3 4)"); +@end example + +Using a Lisp string +@example +cl_object string = make_simple_string("#(1 2 3 4)"); +cl_object array2 = string_to_object(string); +@end example +@end deftypefun + +@subheading Integers +Common-Lisp distinguishes two types of integer types: @code{bignum}s and +@code{fixnum}s. A fixnum is a small integer, which ideally occupies only +a word of memory and which is between the values +@code{MOST-NEGATIVE-FIXNUM} and @code{MOST-POSITIVE-FIXNUM}. A +@code{bignum} is any integer which is not a @code{fixnum} and it is only +constrained by the amount of memory available to represent it. + +In ECL a @code{fixnum} is an integer that, together with the tag bits, +fits in a word of memory. The size of a word, and thus the size of a +@code{fixnum}, varies from one architecture to another, and you should +refer to the types and constants in the ecl.h header to make sure that +your C extensions are portable. All other integers are stored as +@code{bignum}s, they are not immediate objects, they take up a variable +amount of memory and the GNU Multiprecision Library is required to +create, manipulate and calculate with them. + +@cppindex cl_fixnum +@deftp {@cind} cl_fixnum +This is a C signed integer type capable of holding a whole @code{fixnum} +without any loss of precision. The opposite is not true, and you may +create a @code{cl_fixnum} which exceeds the limits of a fixnum and +should be stored as a @code{bignum}. +@end deftp + +@cppindex cl_index +@deftp {@cind} cl_index +This is a C unsigned integer type capable of holding a non-negative +@code{fixnum} without loss of precision. Typically, a @code{cl_index} is +used as an index into an array, or into a proper list, etc. +@end deftp + +@cppindex MOST_NEGATIVE_FIXNUM +@cppindex MOST_POSITIVE_FIXNUM +@lspindex MOST-NEGATIVE-FIXNUM +@lspindex MOST-POSITIVE-FIXNUM +@defvr {Constant} MOST_NEGATIVE_FIXNUM +@defvrx {Constant} MOST_POSITIVE_FIXNUM +These constants mark the limits of a @code{fixnum}. +@end defvr + +@cppindex ecl_fixnum_lower +@cppindex ecl_fixnum_greater +@cppindex ecl_fixnum_leq +@cppindex ecl_fixnum_geq +@cppindex ecl_fixnum_plusp +@cppindex ecl_fixnum_minusp +@deftypefun bool ecl_fixnum_lower (cl_fixnum a, cl_fixnum b) +@deftypefunx bool ecl_fixnum_greater (cl_fixnum a, cl_fixnum b) +@deftypefunx bool ecl_fixnum_leq (cl_fixnum a, cl_fixnum b) +@deftypefunx bool ecl_fixnum_geq (cl_fixnum a, cl_fixnum b) +@deftypefunx bool ecl_fixnum_plusp (cl_fixnum a) +@deftypefunx bool ecl_fixnum_minusp (cl_fixnum a) +Operations on @code{fixnums} (comparison and predicates). +@end deftypefun + +@cppindex ecl_make_fixnum +@cppindex ecl_fixnum +@cppindex MAKE_FIXNUM +@cppindex fix +@deftypefun cl_object ecl_make_fixnum (cl_fixnum n) +@deftypefunx cl_fixnum ecl_unfix (cl_object o) +@code{ecl_make_fixnum} converts from an integer to a lisp object, while +the @code{ecl_fixnum} does the opposite (converts lisp object fixnum to +integer). These functions do @strong{not} check their arguments. +@itemize @bullet +@item @strong{DEPRECATED} @code{MAKE_FIXNUM} – equivalent to @code{cl_make_fixnum} +@item @strong{DEPRECATED} @code{fix} – equivalent to @code{cl_fixnum} +@end itemize +@end deftypefun + +@cppindex cl_fixnum +@cppindex cl_index +@deftypefun cl_fixnum fixint (cl_object o) +@deftypefunx cl_index fixnint (cl_object o) +Safe conversion of a lisp @code{fixnum} to a C integer of the +appropriate size. Signals an error if @var{o} is not of fixnum type. + +@code{fixnint} additionally ensure that @var{o} is not negative. +@end deftypefun + +@subheading Characters + +@cfindex --enable-unicode [YES|no|32] + +ECL has two types of characters – one fits in the C type char, while the +other is used when ECL is built with a configure option +@code{--enable-unicode}. + +@cppindex ecl_character +@cppindex ecl_base_char +@deftp {@cind} ecl_character +Immediate type @code{t_character}. If ECL built with Unicode support, +then may be either base or extended character, which may be +distinguished with the predicate @code{ECL_BASE_CHAR_P}. + +Additionally we have @code{ecl_base_char} for base strings, which is an +equivalent to the ordinary char. + +@subsubheading Example +@exindex distinguishing between base and Unicode character +@example +if (ECL_CHARACTERP(o) && ECL_BASE_CHAR_P(o)) + printf("Base character: %c\n", ECL_CHAR_CODE(o)); +@end example +@end deftp + +@cppindex ECL_CHAR_CODE_LIMIT +@cppindex CHAR_CODE_LIMIT +@defvr {Constant} ECL_CHAR_CODE_LIMIT +Each character is assigned an integer code which ranges from 0 to +(ECL_CHAR_CODE_LIMIT-1). +@itemize @bullet +@item @strong{DEPRECATED} @code{CODE_CHAR_LIMIT} – equivalent to @code{ECL_CHAR_CODE_LIMIT} +@end itemize +@end defvr + +@cppindex ecl_char_code +@cppindex ecl_base_char_code +@cppindex ECL_CHAR_CODE +@cppindex ECL_CODE_CHAR +@cppindex CODE_CHAR +@cppindex CHAR_CODE +@deftypefun cl_fixnum ECL_CHAR_CODE (cl_object o) +@deftypefunx cl_fixnum ECL_CODE_CHAR (cl_object o) +@code{ECL_CHAR_CODE}, @code{ecl_char_code} and @code{ecl_base_char_code} +return the integer code associated to a lisp +character. @code{ecl_char_code} and @code{ecl_base_char_code} perform a +safe conversion, while ECL_CHAR_CODE doesn't check it's +argument. @code{ecl_base_char_code} is an optimized version for base +chars. Checks it's argument. + +@code{ECL_CODE_CHAR} returns the lisp character associated to an integer +code. It does not check its arguments. + +@itemize @bullet +@item @strong{DEPRECATED} @code{CHAR_CODE} – equivalent to @code{ECL_CHAR_CODE} +@item @strong{DEPRECATED} @code{CODE_CHAR} – equivalent to @code{ECL_CODE_CHAR} +@end itemize +@end deftypefun + +@cppindex ecl_char_eq +@cppindex ecl_char_equal +@deftypefun bool ecl_char_eq (cl_object x, cl_object y) +@deftypefunx bool ecl_char_equal (cl_object x, cl_object y) +Compare two characters for equality. char_eq take case into account and +char_equal ignores it. +@end deftypefun + +@cppindex ecl_char_cmp +@cppindex ecl_char_compare +@deftypefun bool ecl_char_cmp (cl_object x, cl_object y) +@deftypefunx bool ecl_char_compare (cl_object x, cl_object y) +Compare the relative order of two characters. @code{char_cmp} takes care +of case and @code{char_compare} converts all characters to uppercase +before comparing them. +@end deftypefun + +@subheading Arrays + +An array is an aggregate of data of a common type, which can be accessed +with one or more non-negative indices. ECL stores arrays as a C structure +with a pointer to the region of memory which contains the actual +data. The cell of an array datatype varies depending on whether it is a +vector, a bit-vector, a multidimensional array or a string. + +@cppindex ECL_ADJUSTABLE_ARRAY_P +@cppindex ECL_ARRAY_HAS_FILL_POINTER_P +@deftypefun bool ECL_ADJUSTABLE_ARRAY_P (cl_object x) +@deftypefunx bool ECL_ARRAY_HAS_FILL_POINTER_P (cl_object x) +All arrays (arrays, strings and bit-vectors) may be tested for being +adjustable and whenever they have a fill pointer with this two +functions. +@end deftypefun + +@cppindex ecl_vector +@deftp {@cind} ecl_vector +If @code{x} contains a vector, you can access the following fields: + +@table @code +@item x->vector.elttype +The type of the elements of the vector. +@item x->vector.displaced +Boolean indicating if it is displaced. +@item x->vector.dim +The maximum number of elements. +@item x->vector.fillp +Actual numer of elements in the vector or @code{fill pointer}. +@item x->vector.self +Union of pointers of different types. You should choose the right +pointer depending on @var{x->vector.elttype}. +@end table +@end deftp + +@cppindex ecl_array +@deftp {@cind} ecl_array +If @code{x} contains a multidimensional array, you can access the +following fields: + +@table @code +@item x->array.elttype +The type of the elements of the array. +@item x->array.rank +The number of array dimensions. +@item x->array.displaced +Boolean indicating if it is displaced. +@item x->vector.dim +The maximum number of elements. +@item x->array.dims[] +Array with the dimensions of the array. The elements range from +@code{x->array.dim[0]} to @code{x->array.dim[x->array.rank-1]}. +@item x->array.fillp +Actual numer of elements in the array or @code{fill pointer}. +@item x->array.self +Union of pointers of different types. You should choose the right +pointer depending on @var{x->array.elttype}. +@end table +@end deftp + +@cppindex cl_elttype +@deftp {@cind} cl_elttype ecl_aet_object ecl_aet_sf ecl_aet_df ecl_aet_bit ecl_aet_fix ecl_aet_index ecl_aet_b8 ecl_aet_i8 ecl_aet_b16 ecl_aet_i16 ecl_aet_b32 ecl_aet_i32 ecl_aet_b64 ecl_aet_i64 ecl_aet_ch ecl_aet_bc + +Each array is of an specialized type which is the type of the elements +of the array. ECL has arrays only a few following specialized types, and +for each of these types there is a C integer which is the corresponding +value of @code{x->array.elttype} or @code{x->vector.elttype}. We list +some of those types together with the C constant that denotes that type: + +@table @var +@item T +@code{ecl_aet_object} +@item BASE-CHAR +@code{ecl_aet_object} +@item SIGNLE-FLOAT +@code{ecl_aet_sf} +@item DOUBLE-FLOAT +@code{ecl_aet_df} +@item BIT +@code{ecl_aet_bit} +@item FIXNUM +@code{ecl_aet_fix} +@item INDEX +@code{ecl_aet_index} +@item CHARACTER +@code{ecl_aet_ch} +@item BASE-CHAR +@code{ecl_aet_bc} +@end table +@end deftp + +@cppindex ecl_array_elttype +@deftypefun cl_elttype ecl_array_elttype (cl_object array) +Returns the element type of the array @code{o}, which can be a string, a +bit-vector, vector, or a multidimensional array. + +@subsubheading Example +@exindex @code{ecl_array_elttype} different types of objects +For example, the code + +@example +ecl_array_elttype(c_string_to_object("\"AAA\"")); /* returns ecl_aet_ch */ +ecl_array_elttype(c_string_to_object("#(A B C)")); /* returns ecl_aet_object */ +@end example +@end deftypefun + +@cppindex ecl_aref +@cppindex ecl_aset +@deftypefun cl_object ecl_aref (cl_object x, cl_index index) +@deftypefunx cl_object ecl_aset (cl_object x, cl_index index, cl_object value) +These functions are used to retrieve and set the elements of an +array. The elements are accessed with one index, index, as in the lisp +function ROW-MAJOR-AREF. + +@subsubheading Example +@exindex @code{ecl_aref} and @code{ecl_aset} accessing arrays +@example +cl_object array = c_string_to_object("#2A((1 2) (3 4))"); +cl_object x = aref(array, 3); +cl_print(1, x); /* Outputs 4 */ +aset(array, 3, MAKE_FIXNUM(5)); +cl_print(1, array); /* Outputs #2A((1 2) (3 5)) */ +@end example +@end deftypefun + +@cppindex ecl_aref1 +@cppindex ecl_aset1 +@deftypefun cl_object ecl_aref (cl_object x, cl_index index) +@deftypefunx cl_object ecl_aset (cl_object x, cl_index index, cl_object value) +These functions are similar to aref and aset, but they operate on vectors. + +@subsubheading Example +@exindex @code{ecl_aref1} and @code{ecl_aset1} accessing vectors +@example +cl_object array = c_string_to_object("#(1 2 3 4)"); +cl_object x = aref1(array, 3); +cl_print(1, x); /* Outputs 4 */ +aset1(array, 3, MAKE_FIXNUM(5)); +cl_print(1, array); /* Outputs #(1 2 3 5) */ +@end example +@end deftypefun + +@subheading Strings + +A string, both in Common-Lisp and in ECL is nothing but a vector of +characters. Therefore, almost everything mentioned in the section of +arrays remains valid here. + +The only important difference is that ECL stores the base-strings +(non-Unicode version of a string) as a lisp object with a pointer to a +zero terminated C string. Thus, if a string has n characters, ECL will +reserve n+1 bytes for the base-string. This allows us to pass the +base-string self pointer to any C routine. + +@cppindex ecl_string +@cppindex ecl_base_string +@deftp {@cind} ecl_string +@deftpx {@cind} ecl_base_string +If @code{x} is a lisp object of type string or a base-string, we can +access the following fields: +@table @code +@item x->string.dim x->base_string.dim +Actual number of characters in the string. +@item x->string.fillp x->base_string.fillp +Actual number of characters in the string. +@item x->string.self x->base_string.self +Pointer to the characters (appropriately integers and chars). +@end table +@end deftp + +@cppindex ECL_EXTENDED_STRING_P +@cppindex ECL_BASE_STRING_P +@deftypefun bool ECL_EXTENDED_STRING_P (cl_object object) +@deftypefunx bool ECL_BASE_STRING_P (cl_object object) + +Verifies if an objects is an extended or base string. If Unicode isn't +supported, then @code{ECL_EXTENDED_STRING_P} always returns 0. +@end deftypefun + +@subheading Bit-vectors + +Bit-vector operations are implemented in file +@code{src/c/array.d}. Bit-vector shares the structure with a vector, +therefore, almost everything mentioned in the section of arrays remains +valid here. + +@subheading Streams + +Streams implementation is a broad topic. Most of the implementation is +done in the file @code{src/c/file.d}. Stream handling may have different +implementations referred by a member pointer @code{ops}. + +Additionally on top of that we have implemented @emph{Gray Streams} (in +portable Common Lisp) in file @code{src/clos/streams.lsp}, which may be +somewhat slower (we need to benchmark it!). This implementation is in a +separate package @var{GRAY}. We may redefine functions in the +@var{COMMON-LISP} package with a function @code{redefine-cl-functions} +at run-time. + +@cppindex ecl_file_pos +@deftp {@cind} ecl_file_ops write_* read_* unread_* peek_* listen clear_input clear_output finish_output force_output input_p output_p interactive_p element_type length get_position set_position column close +@end deftp + +@cppindex ecl_stream +@deftp {@cind} ecl_stream +@table @code +@item ecl_smmode mode +Stream mode (in example @code{ecl_smm_string_input}). +@item int closed +Whenever stream is closed or not. +@item ecl_file_ops *ops +Pointer to the structure containing operation implementations (dispatch +table). +@item union file +Union of ANSI C streams (FILE *stream) and POSIX files interface +(cl_fixnum descriptor). +@item cl_object object0, object1 +Some objects (may be used for a specific implementation purposes). +@item cl_object byte_stack +Buffer for unread bytes. +@item cl_index column +File column. +@item cl_fixnum last_char +Last character read. +@item cl_fixnum last_code[2] +Actual composition of the last character. +@item cl_fixnum int0 int1 +Some integers (may be used for a specific implementation purposes). +@item cl_index byte_size +Size of byte in binary streams. +@item cl_fixnum last_op +0: unknown, 1: reading, -1: writing +@item char *buffer +Buffer for FILE +@item cl_object format +external format +@item cl_eformat_encoder encoder +@item cl_eformat_encoder decoder +@item cl_object format_table +@item in flags +Character table, flags, etc +@item ecl_character eof_character +@end table +@end deftp + +@cppindex ECL_ANSI_STREAM_P +@deftypefun bool ECL_ANSI_STREAM_P (cl_object o) +Predicate determining if @code{o} is a first-class stream +object. Doesn't check type of it's argument. +@end deftypefun + +@cppindex ECL_ANSI_STREAM_TYPE_P +@deftypefun bool ECL_ANSI_STREAM_TYPE_P (cl_object o, ecl_smmode m) +Predicate determining if @code{o} is a first-class stream +object of type @code{m}. +@end deftypefun + +@subheading Structures + +Structures and instances share the same datatype @code{t_instance} ( +with a few exceptions. Structure implementation details are the file +@code{src/c/structure.d}. + +@cppindex ECL_STRUCT_TYPE +@cppindex ECL_STRUCT_SLOTS +@cppindex ECL_STRUCT_LENGTH +@cppindex ECL_STRUCT_SLOT +@cppindex ECL_STRUCT_NAME +@deftypefun cl_object ECL_STRUCT_TYPE (cl_object x) +@deftypefunx cl_object ECL_STRUCT_SLOTS (cl_object x) +@deftypefunx cl_object ECL_STRUCT_LENGTH (cl_object x) +@deftypefunx cl_object ECL_STRUCT_SLOT (cl_object x, cl_index i) +@deftypefunx cl_object ECL_STRUCT_NAME (cl_object x) +Convenience functions for the structures. +@end deftypefun + +@subheading Instances + +@cppindex ECL_CLASS_OF +@cppindex ECL_SPEC_FLAG +@cppindex ECL_SPEC_OBJECT +@cppindex ECL_CLASS_NAME +@cppindex ECL_CLASS_SUPERIORS +@cppindex ECL_CLASS_INFERIORS +@cppindex ECL_CLASS_SLOTS +@cppindex ECL_CLASS_CPL +@cppindex ECL_INSTANCEP + +@deftypefun cl_object ECL_CLASS_OF (cl_object x) +@deftypefunx cl_object ECL_SPEC_FLAG (cl_object x) +@deftypefunx cl_object ECL_SPEC_OBJECT (cl_object x) +@deftypefunx cl_object ECL_CLASS_NAME (cl_object x) +@deftypefunx cl_object ECL_CLASS_SUPERIORS (cl_object x) +@deftypefunx cl_object ECL_CLASS_INFERIORS (cl_object x) +@deftypefunx cl_object ECL_CLASS_SLOTS (cl_object x) +@deftypefunx cl_object ECL_CLASS_CPL (cl_object x) +@deftypefunx bool ECL_INSTANCEP (cl_object x) +Convenience functions for the structures. +@end deftypefun + +@subheading Bytecodes + +A bytecodes object is a lisp object with a piece of code that can be +interpreted. The objects of type t_bytecode are implicitly constructed +by a call to eval, but can also be explicitly constructed with the +make_lambda function. + +@cppindex si_safe_eval +@cppindex cl_safe_eval +@cppindex cl_eval +@deftypefun cl_object si_safe_eval (cl_object form, cl_object env, ...) + +@code{si_safe_eval} evaluates @code{form} in the lexical environment +@code{env}, which can be @var{ECL_NIL}. Before evaluating it, the +expression form must be bytecompiled. + +@table @code +@item @strong{DEPRECATED} cl_object cl_eval (cl_object form) +@code{cl_eval} is the equivalent of @code{si_safe_eval} but without +environment and with err_value set to nil. It exists only for +compatibility with previous versions. +@item @strong{DEPRECATED} cl_object cl_safe_eval (cl_object form) +Equivalent of @code{si_safe_eval} (macro define). +@end table + +@subheading Exmaple +@exindex @code{cl_safe_eval} +@example +si_object form = c_string_to_object("(print 1)"); +si_safe_eval(form, ECL_NIL); +si_safe_eval(form, ECL_NIL, 3); /* on error function will return 3 */ +@end example +@end deftypefun + +@cppindex si_make_lambda +@deftypefun cl_object si_make_lambda (cl_object name, cl_object def) +Builds an interpreted lisp function with name given by the symbol name +and body given by def. + +@subheading Example +@exindex @code{si_make_lambda} building functions + +For instance, we would achieve the equivalent of + +@lisp +(funcall #'(lambda (x y) + (block foo (+ x y))) + 1 2) +@end lisp + +with the following code + +@example +cl_object def = c_string_to_object("((x y) (+ x y))"); +cl_object name = _intern("foo") +cl_object fun = si_make_lambda(name, def); +return funcall(fun, MAKE_FIXNUM(1), MAKE_FIXNUM(2)); +@end example + +Notice that @code{si_make_lambda} performs a bytecodes compilation of +the definition and thus it may signal some errors. Such errors are not +handled by the routine itself so you might consider using +@code{si_safe_eval} instead. +@end deftypefun diff -Nru ecl-16.1.2/src/doc/new-doc/developer-guide/removed.txi ecl-16.1.3+ds/src/doc/new-doc/developer-guide/removed.txi --- ecl-16.1.2/src/doc/new-doc/developer-guide/removed.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/developer-guide/removed.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,57 @@ +@node Removed features +@section Removed features + +@c @menu +@c * In-house DFFI:: Hand-written FFI assembly +@c * In-house GC:: ECL's own GC +@c * Green threads:: Lightweight processes +@c * Compiler newcmp:: Experimental compiler architecture +@c * In-house bignum implementation:: +@c * Possibility to build without bignums:: +@c @end menu + +@c @node In-house DFFI +@subheading In-house DFFI + +Commit @code{10bd3b613fd389da7640902c2b88a6e36088c920}. Native DFFI was +replaced by a @code{libffi} long time ago, but we have maintained the +code as a fallback. Due to small number of supported platforms and no +real use it has been removed in 2016. + +@c @node In-house GC +@subheading In-house GC +Commit @code{61500316b7ea17d0e42f5ca127f2f9fa3e6596a8}. Broken GC is +replaced by BoehmGC library. This may be added back as a fallback in +the near future. + +@code{3bd9799a2fef21cc309472e604a46be236b155c7} removes a leftover +(apparently gbc.d wasn't bdwgc glue). + +@c @node Green threads +@subheading Green threads +Commit @code{41923d5927f31f4dd702f546b9caee74e98a2080}. Green threads +(aka light weight processes) has been replaced with native threads +implementation. There is an ongoing effort to bring them back as an +alternative interface. + +@c @node Compiler newcmp +@subheading Compiler newcmp +Commit @code{9b8258388487df8243e2ced9c784e569c0b34c4f} This was +abandoned effort of changing the compiler architecture. Some clever +ideas and a compiler package hierarchy. Some of these things should be +incorporated during the evolution of the primary compiler. + +@subheading Old MIT loop +Commit @code{5042589043a7be853b7f85fd7a996747412de6b4}. This old loop +implementation has got superseeded by the one incorporated from +Symbolics LOOP in 2001. + +@subheading Support for bignum arithmetic (earith.d) +Commit @code{edfc2ba785d6a64667e89c869ef0a872d7b9704b}. Removes +pre-gmp bignum code. Name comes probably from ``extended arithmetic'', +contains multiplication and division routines (assembler and a +portable implementation). + +@subheading Unification module +Commit @code{6ff5d20417a21a76846c4b28e532aac097f03109}. Old unifiction +module (logic programming) from EcoLisp times. diff -Nru ecl-16.1.2/src/doc/new-doc/developer-guide/sources.txi ecl-16.1.3+ds/src/doc/new-doc/developer-guide/sources.txi --- ecl-16.1.2/src/doc/new-doc/developer-guide/sources.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/developer-guide/sources.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,262 @@ +@node Sources structure +@section Sources structure + +@subsection src/c + +@multitable {aaaaaaaaaaaaaaa}{aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa} +@item alloc_2.d +@tab memory allocation based on the Boehm GC + +@item all_symbols.d +@tab name mangler and symbol initialization + +@item apply.d +@tab interface to C call mechanism + +@item arch/* +@tab architecture dependant code + +@item array.d +@tab array routines + +@item assignment.c +@tab assignment + +@item backq.d +@tab backquote mechanism + +@item big.d +@tab bignum routines based on the GMP + +@item big_ll.d +@tab bignum emulation with long long + +@item cfun.d +@tab compiled functions + +@item cfun_dispatch.d +@tab trampolines for functions + +@item character.d +@tab character routines + +@item char_ctype.d +@tab character properties. + +@item cinit.d +@tab lisp initialization + +@item clos/accessor.d +@tab dispatch for slots + +@item clos/cache.d +@tab thread-local cache for a variety of operations + +@item cmpaux.d +@tab auxiliaries used in compiled Lisp code + +@item compiler.d +@tab bytecode compiler + +@item disassembler.d +@tab bytecodes disassembler utilities + +@item dpp.c +@tab defun preprocessor + +@item ecl_constants.h +@tab contstant values for all_symbols.d + +@item features.h +@tab names of features compiled into ECL + +@item error.d +@tab error handling + +@item eval.d +@tab evaluation + +@item ffi/backtrace.d +@tab C backtraces + +@item ffi/cdata.d +@tab data for compiled files + +@item ffi/libraries.d +@tab shared library and bundle opening / copying / closing + +@item ffi/mmap.d +@tab mapping of binary files + +@item ffi.d +@tab user defined data types and foreign functions interface + +@item file.d +@tab file interface (implementation dependent) + +@item format.d +@tab format (this isn't ANSI compliant, we need it for bootstrapping though) + +@item gfun.d +@tab dispatch for generic functions + +@item hash.d +@tab hash tables + +@item instance.d +@tab CLOS interface + +@item interpreter.d +@tab bytecode interpreter + +@item iso_latin_names.h +@tab character names in ISO-LATIN-1 + +@item list.d +@tab list manipulating routines + +@item load.d +@tab binary loader (contains also open_fasl_data) + +@item macros.d +@tab macros and environment + +@item main.d +@tab ecl boot proccess + +@item Makefile.in +@tab Makefile for ECL core library + +@item mapfun.d +@tab mapping + +@item newhash.d +@tab hashing routines + +@item num_arith.d +@tab arithmetic operations + +@item number.d +@tab constructing numbers + +@c these files need to be cleaned +@item numbers/*.d +@tab arithmetic operations (abs, atan, plusp etc) + +@item num_co.d +@tab operations on floating-point numbers (implementation dependent) + +@item num_log.d +@tab logical operations on numbers + +@item num_pred.d +@tab predicates on numbers + +@item num_rand.d +@tab random numbers + +@item package.d +@tab packages (OS dependent) + +@item pathname.d +@tab pathnames + +@item predicate.d +@tab predicates + +@item print.d +@tab print + +@item printer/*.d +@tab printer utilities and object representations + +@item read.d +@tab read.d - reader + +@item reader/parse_integer.d +@item reader/parse_number.d + +@item reference.d +@tab reference in Constants and Variables + +@item sequence.d +@tab sequence routines + +@item serialize.d +@tab serialize a bunch of lisp data + +@item sse2.d +@tab SSE2 vector type support + +@item stacks.d +@tab binding/history/frame stacks + +@item string.d +@tab string routines + +@item structure.d +@tab structure interface + +@item symbol.d +@tab symbols + +@item symbols_list.h +@item symbols_list2.h +@tab The latter is generated from the first. The first has to contain all +symbols on the system which aren't local. + +@item tcp.d +@tab stream interface to TCP + +@item time.d +@tab time routines + +@item typespec.d +@tab type specifier routines + +@item unicode/* +@tab unicode definitions + +@item unixfsys.d +@tab Unix file system interface + +@item unixsys.d +@tab Unix shell interface + +@item vector_push.d +@tab vector optimizations + +@headitem threads/ + +@item atomic.d +@tab atomic operations + +@item barrier.d +@tab wait barriers + +@item condition_variable.d +@tab condition variables for native threads +@c implement me: @code{mp_condition_variable_timedwait} + +@item ecl_atomics.h +@tab alternative definitions for atomic operations + +@item mailbox.d +@tab thread communication queue + +@item mutex.d +@tab mutually exclusive locks. + +@item process.d +@tab native threads + +@item queue.d +@tab waiting queue for threads + +@item rwlock.d +@tab POSIX read-write locks + +@item semaphore.d +@tab POSIX-like semaphores + +@end multitable diff -Nru ecl-16.1.2/src/doc/new-doc/ecl.css ecl-16.1.3+ds/src/doc/new-doc/ecl.css --- ecl-16.1.2/src/doc/new-doc/ecl.css 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/ecl.css 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,55 @@ +html { background: #FFF; } +body { + margin: 1em 125px 0 10%; + line-height: 1.5em; + padding: 0 2em 1em 2em; + background: #FFF; + font: 12px Verdana,Arial, sans-serif +} +ul, dd, dl, dt { margin-top: 0; margin-bottom: 0; } +p, code, td, dl, dt { + line-height: 1.5em; +} +table { + font: inherit; +} +th, td { + vertical-align: top; +} +h1, h2, h3, h4, h5 { background: #EEE; } +code, pre { + font-size: 1em; + font-family: fixed; +} +pre { + line-height: 1em; + overflow: auto; +} +pre.screen { + font-weight: bold; + background: #EEE; + border: 1px solid black; + padding: 0.5em; +} +pre.programlisting { + background: #EEEEEE; + border-left: 1px solid black; + border-top: 1px solid black; + padding: 0.5em; +} +a { color: #000; font-weight: bold; } +div p { padding: 0 2em } +li p { padding: 0; margin: 0 } +hr { display: none; } +div.funcsynopsis p { + text-indent: -2em; +} +div.variablelist { + padding: 0 2em; +} +.type, .funcsynopsis, .symbol { + font-family: fixed; +} +.type, .symbol, .replaceable { + white-space: nowrap; +} diff -Nru ecl-16.1.2/src/doc/new-doc/extensions/building.txi ecl-16.1.3+ds/src/doc/new-doc/extensions/building.txi --- ecl-16.1.2/src/doc/new-doc/extensions/building.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/extensions/building.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,284 @@ + +@node System building +@section System building + +@menu +* Compiling with ECL:: +@c * Compiling with Matroska:: +@c * Compiling with ASDF:: +@end menu + +@cindex System building +@cindex Creating executables and libraries + +@node Compiling with ECL +@subsection Compiling with ECL + +In this section we will introduce topics on compiling Lisp programs. ECL +is especially powerful on combining lisp programs with C programs. You +can embed ECL as a lisp engine in C programs, or call C functions via +@ref{Foreign Function Interface}. We explain file types generated by +some compilation approaches. GNU/Linux system and gcc as a development +environment are assumed. + +You can generate following files with ECL. + +@enumerate +@item Portable FASL file (.fasc) +@item Native FASL file (.fas, .fasb) +@item Object file (.o) +@item Static library +@item Shared library +@item Executable file +@end enumerate + +Relations among them are depicted below: + +@float Figure,fig:file_types +@caption{Build file types} +@image{figures/file-types} +@end float + +@node Portable FASL (fasc) +@subsubsection Portable FASL +@cindex Portable FASL + +ECL provides two compilers (bytecodes compiler, and C/C++ +compieler). Portable FASL files are build from source lisp files by the +bytecodes compiler. Generally FASC files are portable across +architectures and operating systems providing convenient way of shipping +portable modules. Portable FASL files may be concatenated, what leads to +bundles. FASC files are faster to compile, but generally slower to run. + +@exindex Building Portable FASL file +@lisp +;; install bytecodes compiler +(ext:install-bytecodes-compiler) + +;; compile hello.lisp file to hello.fasc +(compile-file "hello1.lisp") +(compile-file "hello2.lisp") + +;; reinitialize C/C++ compiler back +(ext:install-c-compiler) + +;; FASC file may be loaded dynamically from lisp program +(load "hello1.fasc") + +;; ... concatenated into a bundle with other FASC +(with-open-file (output "hello.fasc" + :direction :output + :if-exists :supersede) + (ext:run-program + "cat" '("hello1.fasc" "hello2.fasc") :output output)) + +;; ... and loaded dynamically from lisp program +(load "hello.fasc") +@end lisp + +@node Native FASL +@subsubsection Native FASL + +@cindex Native FASL +@ftindex DLOPEN +@cfindex --enable-shared [YES|no]] + + +If you want to make a library which is loaded dynamically from lisp +program, you should choose fasl file format. Under the hood native fasls +are just a shared library files. + +This means you can load fasl files with @code{dlopen} and initialize it +by calling a init function from C programs, but this is not an intended +usage. Recommended usage is loading fasl files by calling load lisp +function. To work with @emph{Native FASL files} ECL has to be compiled +with @code{--enable-shared} configure option (enabled by default). + +Creating a fasl file from one lisp file is very easy. + +@lisp +(compile-file "hello.lisp") +@end lisp + +To create a fasl file from more lisp files, firstly you have to compile +each lisp file into an object file, and then combine them with +c:build-fasl. + +@exindex Building native FASL +@lisp +;; generates hello.o +(compile-file "hello.lisp" :system-p t) +;; generates goodbye.o +(compile-file "goodbye.lisp" :system-p t) + +;; generates hello-goodbye.fas +(c:build-fasl "hello-goodbye" + :lisp-files '("hello.o" "goodbye.o")) + +;; fasls may be built from mix of objects and libraries (both shared and +;; static) +(c:build-fasl "mixed-bundle" + :lisp-files '("hello1.o" "hello2.a" "hello3.so")) +@end lisp + +@node Object file +@subsubsection Object file + +Object file works as an intermediate file format. If you want to compile +more than two lisp files, you might better to compile with a :system-p t +option, which generates object files (instead of a fasl). + +On linux systems, ECL invokes gcc -c for generating object files. + +An object file consists of some functions in C: + +@itemize +@item Functions corresponding to Lisp functions +@item The initialization function which registers defined functions on the lisp environment +@end itemize + +Consider the example below. + +@lisp +(defun say-hello () + (print "Hello, world")) +@end lisp + +@cindex Object file internal layout +During compilation, this simple lisp program is translated into the C +program, and then compiled into the object file. The C program contains +two functions: + +@itemize + +@item @code{static cl_object L1say_hello}: +'say-hello' function + +@item @code{ECL_DLLEXPORT void _eclwm2nNauJEfEnD_CLSxi0z(cl_object flag)}: +initialization function + +@end itemize + +In order to use these object files from your C program, you have to call +initialization functions before using lisp functions (such as +@code{say-hello}). However the name of an init function is seemed to be +randomized and not user-friendly. This is because object files are not +intended to be used directly. + +ECL provides other user-friendly ways to generate compiled lisp programs +(as static/shared libraries or executable), and in each approach, object +files act as intermediate files. + +@node Static library +@subsubsection Static library + +ECL can compile lisp programs to static libraries, which can be linked +with C programs. A static library is created by c:build-static-library +with some compiled object files. + +@exindex Building static library +@lisp +;; generates hello.o +(compile-file "hello.lsp" :system-p t) +;; generates goodbye.o +(compile-file "goodbye.lsp" :system-p t) + +;; generates libhello-goodbye.a +(c:build-static-library "hello-goodbye" + :lisp-files '("hello.o" "goodbye.o") + :init-name "init_hello_goodbye") +@end lisp + +When you use static/shared library, you have to call init functions. The +name of the function is specified by @code{:init-name} option. In this +example, @code{init_hello_goodbye} is it. The usage of this function is +shown below: + +@exindex Initializing static/shared library in C/C++ +@example +@verbatim +#include +extern void init_hello_goodbye(cl_object cblock); + +int +main(int argc, char **argv) +{ + /* setup the lisp runtime */ + cl_boot(argc, argv); + + /* call the init function via read_VV */ + read_VV(OBJNULL, init_hello_goodbye); + + /* ... */ + + /* shutdown the lisp runtime */ + cl_shutdown(); + + return 0; +} +@end verbatim +@end example + +Because the program itself does not know the type of the init function, +a prototype declaration is inserted. After booting up the lisp +environment, invoke @code{init_hello_goodbye} via +@code{read_VV}. @code{init_hello_goodbye} takes a argument, and read_VV +supplies an appropriate one. Now that the initialization is finished, we +can use functions and other stuffs defined in the library. + +@node Shared library +@subsubsection Shared library + +Almost the same as the case of static library. User has to use +@code{c:build-shared-library}: + +@exindex Building shared library +@lisp +;; generates hello.o +(compile-file "hello.lsp" :system-p t) +;; generates goodbye.o +(compile-file "goodbye.lsp" :system-p t) + +;; generates libhello-goodbye.so +(c:build-shared-library "hello-goodbye" + :lisp-files '("hello.o" "goodbye.o") + :init-name "init_hello_goodbye") +@end lisp + +@node Executable +@subsubsection Executable + +ECL supports executable file generation. To create a standalone +executable from lisp programs, compile all lisp files to object +files. After that, calling @code{c:build-program} creates the +executable. + +@exindex Building executable +@lisp +;; generates hello.o +(compile-file "hello.lsp" :system-p t) +;; generates goodbye.o +(compile-file "goodbye.lsp" :system-p t) + +;; generates hello-goodbye +(c:build-program "hello-goodbye" + :lisp-files '("hello.o" "goodbye.o")) +@end lisp + +Like native FASL, program may be built also from libraries. + +@node Summary +@subsubsection Summary + +In this post, some file types that can be compiled to with ECL were introduced. Each file type has adequate purpose: + +@itemize +@item Object file: intermediate file format for others +@item Fasl files: loaded dynamically via load lisp function +@item Static library: linked with and used from C programs +@item Shared library: loaded dynamically and used from C programs +@item Executable: standalone executable +@end itemize + +ECL provides a high-level interface @code{c:build-*} for each native +format. In case of @emph{Portable FASL} bytecodes compiler is needed. diff -Nru ecl-16.1.2/src/doc/new-doc/extensions/ffi_dffi.txi ecl-16.1.3+ds/src/doc/new-doc/extensions/ffi_dffi.txi --- ecl-16.1.2/src/doc/new-doc/extensions/ffi_dffi.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/extensions/ffi_dffi.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,9 @@ +@node DFFI Reference +@subsection DFFI Reference +@cindex Dynamic foreign function interface + +@lspindex ffi:*use-dffi* +@defvr {FFI} {*use-dffi*} +This variable controls whether @code{DFFI} is used or not. +@end defvr + diff -Nru ecl-16.1.2/src/doc/new-doc/extensions/ffi_sffi.txi ecl-16.1.3+ds/src/doc/new-doc/extensions/ffi_sffi.txi --- ecl-16.1.2/src/doc/new-doc/extensions/ffi_sffi.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/extensions/ffi_sffi.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,301 @@ +@node SFFI Reference +@subsection SFFI Reference +@cindex C/C++ code inlining +@cindex Static foreign function interface + +@subsubheading Reference + +@lspindex ffi:clines +@defspec ffi:clines c/c++-code* + +Insert C declarations and definitions + +@table @var +@item c/c++-code +One or more strings with C definitions. Not evaluated. +@item returns +No value. +@end table + +@subsubheading Description +This special form inserts C code from strings passed in the +@var{arguments} directly in the file that results from compiling lisp +sources. Contrary to @code{ffi:c-inline}, this function may have no +executable statements, accepts no input value and returns no value. + +The main use of @code{FFI:CLINES} is to declare or define C variables +and functions that are going to be used later in other FFI +statements. All statements from @var{arguments} are grouped at the +beginning of the produced header file. + +@code{FFI:CLINES} is a special form that can only be used in lisp +compiled files as a toplevel form. Other uses will lead to an error +being signaled, either at the compilation time or when loading the file. + +@subsubheading Examples +@exindex @code{ffi:clines} adding c toplevel declarations +In this example the FFI:CLINES statement is required to get access to +the C function @code{cos}: +@lisp +(ffi:clines "#include ") +(defun cos (x) + (ffi:c-inline (x) (:double) :double "cos(#0)" :on-liner t)) +@end lisp +@end defspec + +@lspindex ffi:c-inline +@defspec ffi:c-inline (lisp-values) (arg-c-types) return-type c/c++-code @ + &key (side-effects t) (one-liner nil) + +Inline C code in a lisp form + +@table @var +@item lisp-values +One or more lisp expressions. Evaluated. +@item arg-c-types +One or more valid FFI types. Evaluated. +@item return-type +Valid FFI type or (VALUES ffi-type*). +@item c/c++-code +String containing valid C code plus some valid escape forms. +@item one-liner +Boolean indicating, if the expression is a valid R-value. Defaults to +NIL. +@item side-effects +Boolean indicating, if the expression causes side effects. Defaults to +T. +@item returns +One or more lisp values. +@end table + +@subsubheading Description +This is a special form which can be only used in compiled code and whose +purpose is to execute some C code getting and returning values from and +to the lisp environment. + +The first argument @var{lisp-values} is a list of lisp forms. These +forms are going to be evaluated and their lisp values will be +transformed to the corresponding C types denoted by the elements in the +list @var{arg-c-types}. + +The input values are used to create a valid C expression using the +template in @var{C/C++-code}. This is a string of arbitrary size which +mixes C expressions with two kind of escape forms. + +The first kind of escape form are made of a hash and a letter or a +number, as in: @code{#0}, @code{#1}, ..., until @code{#z}. These codes +are replaced by the corresponding input values. The second kind of +escape form has the format @verb{|@(return [n])|}, it can be used as +lvalue in a C expression and it is used to set the n-th output value of +the @code{ffi:c-inline} form. + +When the parameter @var{one-liner} is true, then the C template must be +a simple C statement that outputs a value. In this case the use of +@verb{|@(return)|} is not allowed. When the parameter @var{one-liner} is +false, then the C template may be a more complicated block form, with +braces, conditionals, loops and spanning multiple lines. In this case +the output of the form can only be set using @verb{|@(return)|}. + +Parameter @var{side-effects} set to true will indicate, that the +functions causes no side-effects. This information is used by the +compiler to optimize the resulting code. If @var{side-effects} is set to +true, but the function may cause the side effects, then results are +undefined. + +Note that the conversion between lisp arguments and FFI types is +automatic. Note also that @code{ffi:c-inline} cannot be used in +interpreted or bytecompiled code! Such usage will signal an error. + +@subsubheading Examples +@exindex @code{ffi:c-inline} inlining c code +The following example implements the transcendental function SIN using +the C equivalent: + +@lisp +(ffi:c-lines "#include ") +(defun mysin (x) + (ffi:c-inline (x) (:double) :double + "sin(#0)" + :one-liner t + :side-effects nil)) +@end lisp + +This function can also be implemented using the @verb{|@(return)|} form +as follows: + +@lisp +@verbatim +(defun mysin (x) + (ffi:c-inline (x) (:double) :double + "@(return)=sin(#0);" + :side-effects nil)) +@end verbatim +@end lisp + +The following example is slightly more complicated as it involves loops +and two output values: + +@exindex @code{ffi:c-inline} returning multiple values +@lisp +@verbatim +(defun sample (x) + (ffi:c-inline (x (+ x 2)) (:int :int) (values :int :int) "{ + int n1 = #0, n2 = #1, out1 = 0, out2 = 1; + while (n1 <= n2) { + out1 += n1; + out2 *= n1; + n1++; + } + @(return 0)= out1; + @(return 1)= out2; + }" + :side-effects nil)) +@end verbatim +@end lisp +@end defspec + +@lspindex ffi:c-progn +@defspec ffi:c-progn args &body body + +Interleave C statements with the Lisp code + +@table @var +@item args +Lisp arguments. Evaluated. +@item returns +No value. +@end table + +@subsubheading Description +This form is used for it's side effects. It allows for interleaving C +statements with the Lisp code. The argument types doesn't have to be +declared – in such case the objects type in the C world will be +@code{cl_object}. + +@subsubheading Examples +@exindex @code{ffi:c-progn} interleaving c and lisp code +@lisp +@verbatim +(lambda (i) + (let* ((limit i) + (iterator 0) + (custom-var (cons 1 2))) + (declare (:int limit iterator)) + (ffi:c-progn (limit iterator custom-var) + "cl_object cv = #2;" + "ecl_print(cv, ECL_T);" + "for (#1 = 0; #1 < #0; #1++) {" + (format t "~&Iterator: ~A, I: ~A~%" iterator i) + "}"))) +@end verbatim +@end lisp +@end defspec + +@c XXX: SFFI returns one-element list pointer, while DFFI returns just a +@c pointer. This is probably a bug. + +@lspindex ffi:defcallback +@defspec ffi:defcallback name ret-type arg-desc &body body + +@table @var +@item name +Name of the lisp function. +@item ret-type +Declaration of the return type which function returns. +@item arg-desc +List of pairs @code{(arg-name arg-type)}. +@item body +Function body. +@item returns +Pointer to the defined callback. +@end table + +@subsubheading Description +Defines Lisp function and generates a callback for the C world, which +may be passed to these functions. Note, that this special operator has +also a dynamic variant (with the same name and interface). +@end defspec + +@lspindex ffi:defcbody +@defmac ffi:defcbody name arg-types result-type c-expression + +Define C function under the lisp name + +@table @var +@item name +Defined function name. +@item arg-types +Argument types of the defined Lisp function. +@item result-type +Result type of the C function (may be @code{(values ...)}. +@item returns +Defined function name. +@end table + +@subsubheading Description +The compiler defines a Lisp function named by NAME whose body consists +of the C code of the string C-EXPRESSION. In the C-EXPRESSION one can +reference the arguments of the function as @code{#0}, @code{#1}, etc. + +The interpreter ignores this form. +@end defmac + +@lspindex ffi:defentry +@defmac ffi:defentry name arg-types c-name &key no-interrupts + +@table @var +@item name +Lisp name for the function. + +@item arg-types +Argument types of the C function (one of the symbols OBJECT, INT, CHAR, +CHAR*, FLOAT, DOUBLE). + +@item c-name +If @var{C-NAME} is a list, then C function result type is declared as +@code{(CAR C-NAME)} and its name is @code{(STRING (CDR C-NAME))}. + +If it's an atom, then the result type is @code{OBJECT}, and function +name is @code{(STRING C-NAME)}. + +@item returns +Lisp function @code{NAME}. +@end table + +@subsubheading Description +The compiler defines a Lisp function named by NAME whose body consists +of a calling sequence to the C language function named by FUNCTION-NAME. + +The interpreter ignores this form. ARG-TYPES are argument types of the +C function and RESULT-TYPE is its return type. Symbols OBJECT, INT, +CHAR, CHAR*, FLOAT, DOUBLE are allowed for these types. +@end defmac + +@c XXX> note sure if this works +@c @subsubheading @code{definline} +@c @lspindex ffi:definline +@c @defmac ffi:definline fun arg-types result-type code +@c @table @var +@c @item args +@c Lisp arguments. Evaluated. +@c @item returns +@c No value. +@c @end table +@c @end defmac + +@c @subsubheading Description +@c DEFINLINE behaves like a DEFCBODY (see), but also instructs the LISP +@c compiler to expand inline any call to function SYMBOL into code +@c corresponding to the C language expression C/C++-CODE, whenever it can +@c determine that the actual arguments are of the specified type. +@c =v2.0 is provided by cffi-uffi-compat system +shipped with CFFI). Code designed for UFFI library should run mostly +unchanged with ECL. Note, that api resides in ffi package, not uffi, to +prevent conflicts with cffi-uffi-compat. New code shouldn't use this +interface preferring CFFI. +@item +The CFFI library features a complete backend for ECL. This method of +interfacing with the foreign libraries is preferred over using UFFI. +@item +ECL's own low level interface. Only to be used if ECL is your deployment +platform. It features some powerful constructs that allow you to mix +arbitrary C and lisp code. +@end itemize + +In the following two subsections we will discuss two practical examples of using the native +UFFI and the CFFI library. + +@c XXX: we should describe here, how to use SFFI for interactive C/C++ development +@c @node Lower level interfaces + +@subsubheading UFFI example +@exindex UFFI usage + +The example below shows how to use UFFI in an application. There are several important +ingredients: + +@itemize @bullet +@item +You need to specify the libraries you use and do it at the toplevel, so +that the compiler may include them at link time. +@item +Every function you will use has to be declared using +@code{ffi:def-function}. +@end itemize + +@lisp +#| +Build and load this module with (compile-file "uffi.lsp" :load t) +|# +;; +;; This toplevel statement notifies the compiler that we will +;; need this shared library at runtime. We do not need this +;; statement in windows. +;; +#-(or ming32 windows) +(ffi:load-foreign-library #+darwin "/usr/lib/libm.dylib" + #-darwin "/usr/lib/libm.so") +;; +;; With this other statement, we import the C function sin(), +;; which operates on IEEE doubles. +;; +(ffi:def-function ("sin" c-sin) ((arg :double)) + :returning :double) +;; +;; We now use this function and compare with the lisp version. +;; +(format t "~%Lisp sin:~t~d~%C sin:~t~d~%Difference:~t~d" + (sin 1.0d0) (c-sin 1.0d0) (- (sin 1.0d0) (c-sin 1.0d0))) +@end lisp + +@subsubheading CFFI example +@exindex CFFI usage + +The CFFI library is an independent project and it is not shipped with +ECL. If you wish to use it you can go to their homepage, download the +code and build it using ASDF. + +CFFI differs slightly from UFFI in that functions may be used even +without being declared beforehand. + +@lisp +#| +Build and load this module with (compile-file "cffi.lsp" :load t) +|# +;; +;; This toplevel statement notifies the compiler that we will +;; need this shared library at runtime. We do not need this +;; statement in windows. +;; +#-(or ming32 windows) +(cffi:load-foreign-library #+darwin "/usr/lib/libm.dylib" + #-darwin "/usr/lib/libm.so") +;; +;; With this other statement, we import the C function sin(), +;; which operates on IEEE doubles. +;; +(cffi:defcfun ("sin" c-sin) :double '(:double)) +;; +;; We now use this function and compare with the lisp version. +;; +(format t "~%Lisp sin:~t~d~%C sin:~t~d~%Difference:~t~d" + (sin 1.0d0) (c-sin 1.0d0) (- (sin 1.0d0) (c-sin 1.0d0))) +;; +;; The following also works: no declaration! +;; +(let ((c-cos (cffi:foreign-funcall "cos" :double 1.0d0 :double))) + (format t "~%Lisp cos:~t~d~%C cos:~t~d~%Difference:~t~d" + (cos 1.0d0) c-cos (- (cos 1.0d0) c-cos))) +@end lisp + +@subsubheading SFFI example (low level inlining) +@exindex SFFI usage + +To compare with the previous pieces of code, we show how the previous programs would be +written using @code{ffi:clines} and @code{ffi:c-inline}. + +@lisp +#| +Build and load this module with (compile-file "ecl.lsp" :load t) +|# +;; +;; With this other statement, we import the C function sin(), which +;; operates on IEEE doubles. Notice that we include the C header to +;; get the full declaration. +;; +(defun c-sin (x) + (ffi:clines "#include ") + (ffi:c-inline (x) (:double) :double "sin(#0)" :one-liner t)) +;; +;; We now use this function and compare with the lisp version. +;; +(format t "~%Lisp sin:~t~d~%C sin:~t~d~%Difference:~t~d" + (sin 1.0d0) (c-sin 1.0d0) (- (sin 1.0d0) (c-sin 1.0d0))) +@end lisp + +@include extensions/ffi_sffi.txi +@c @include extensions/ffi_dffi.txi +@include extensions/ffi_uffi.txi diff -Nru ecl-16.1.2/src/doc/new-doc/extensions/ffi_uffi.txi ecl-16.1.3+ds/src/doc/new-doc/extensions/ffi_uffi.txi --- ecl-16.1.2/src/doc/new-doc/extensions/ffi_uffi.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/extensions/ffi_uffi.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,1188 @@ +@node UFFI Reference +@subsection UFFI Reference +@cindex Universal foreign function interface + +@menu +* Primitive Types:: +* Aggregate Types:: +* Foreign Objects:: +* Foreign Strings:: +* Functions and Libraries:: +@end menu + +@node Primitive Types +@subsubsection Primitive Types +@cindex Foreign primitive types + +Primitive types have a single value, these include characters, numbers, +and pointers. They are all symbols in the keyword package. + +@lspindex :char +@lspindex :unsigned-char +@lspindex :byte +@lspindex :unsigned-byte +@lspindex :short +@lspindex :unsigned-short +@lspindex :int +@lspindex :unsigned-int +@lspindex :long +@lspindex :unsigned-long +@lspindex :int16_t +@lspindex :uint16_t +@lspindex :int32_t +@lspindex :uint32_t +@lspindex :int64_t +@lspindex :uint64_t +@lspindex :float +@lspindex :double +@c @lspindex :long-double +@lspindex :cstring +@lspindex :void +@lspindex :pointer-void +@lspindex :* + +@ftindex LONG-LONG +@ftindex UINT16-T +@ftindex UINT32-T +@ftindex UINT64-T +@ftindex LONG-FLOAT + +@table @samp +@item :char +@itemx :unsigned-char +Signed/unsigned 8-bits. Dereferenced pointer returns a character. +@item :byte +@itemx :unsigned-byte +Signed/unsigned 8-bits. Dereferenced pointer returns an integer. +@item :short +@itemx :unsigned-short +@itemx :int +@itemx :unsigned-int +@itemx :long +@itemx :unsigned-long +Standard integer types (16-bit, 32-bit and 32/64-bit). +@item :int16_t +@itemx :uint16_t +@itemx :int32_t +@itemx :uint32_t +@itemx :int64_t +@itemx :uint64_t +Integer types with guaranteed bitness. + +@item :float +@itemx :double +Floating point numerals (32-bit and 64-bit). +@c XXX> +@c @item :long-double +@c Floating point numeral (usually 80-bit, at least 64-bit, exact +@c bitness is compiler/architecture/platform dependant). +@c XXX< +@item :cstring +A @code{NULL} terminated string used for passing and returning +characters strings with a C function. +@item :void +The absence of a value. Used to indicate that a function does not return +a value. +@item :pointer-void +Points to a generic object. +@item * +Used to declare a pointer to an object. +@end table + +@subsubheading Reference + +@lspindex ffi:def-constant +@defmac ffi:def-constant name value &key (export nil) + +Binds a symbol to a constant. + +@table @var +@item name +A symbol that will be bound to the value. +@item value +An evaluated form that is bound the the name. +@item export +When @code{T}, the name is exported from the current package. Defaults +to @code{NIL}. +@item returns +Constant name. +@end table + +@subsubheading Description +This is a thin wrapper around @code{defconstant}. It evaluates at +compile-time and optionally exports the symbol from the package. + +@subsubheading Examples +@exindex @code{ffi:def-constant} defining constants +@lisp +(ffi:def-constant pi2 (* 2 pi)) +(ffi:def-constant exported-pi2 (* 2 pi) :export t) +@end lisp + +@subsubheading Side Effects +Creats a new special variable. +@end defmac + + + +@lspindex ffi:def-foreign-type +@defmac ffi:def-foreign-type name definition + +Defines a new foreign type + +@table @var +@item name +A symbol naming the new foreign type. +@item value +A form that is not evaluated that defines the new foreign type. +@item returns +Foreign type designator (@var{value}). +@end table + +@subsubheading Description +Defines a new foreign type + +@subsubheading Examples +@exindex @code{ffi:def-foreign-type} examples +@lisp +(def-foreign-type my-generic-pointer :pointer-void) +(def-foreign-type a-double-float :double-float) +(def-foreign-type char-ptr (* :char)) +@end lisp + +@subsubheading Side effects +Defines a new foreign type. +@end defmac + + + +@lspindex ffi:null-char-p +@defun ffi:null-char-p char + +Tests a character for NULL value + +@table @var +@item char +A character or integer. +@item returns +A boolean flag indicating if @var{char} is a NULL value. +@end table + +@subsubheading Description +A predicate testing if a character or integer is NULL. This abstracts +the difference in implementations where some return a character and some +return a integer whence dereferencing a C character pointer. + +@subsubheading Examples +@exindex @code{ffi:null-char-p} example +@lisp +(ffi:def-array-pointer ca :unsigned-char) + (let ((fs (ffi:convert-to-foreign-string "ab"))) + (values (ffi:null-char-p (ffi:deref-array fs 'ca 0)) + (ffi:null-char-p (ffi:deref-array fs 'ca 2)))) +;; => NIL T +@end lisp +@end defun + + + +@node Aggregate Types +@subsubsection Aggregate Types +@cindex Foreign aggregate types + +@subsubheading Overview +Aggregate types are comprised of one or more primitive types. + +@subsubheading Reference + +@lspindex ffi:def-enum +@defmac ffi:def-enum name fields &key separator-key + +Defines a C enumeration + +@table @var +@item name +A symbol that names the enumeration. +@item fields +A list of field defintions. Each definition can be a symbol or a list of +two elements. Symbols get assigned a value of the current counter which +starts at 0 and increments by 1 for each subsequent symbol. It the field +definition is a list, the first position is the symbol and the second +position is the value to assign the the symbol. The current counter gets +set to 1+ this value. +@item returns +A string that governs the creation of constants. The default is "#". +@end table + +@subsubheading Description +Declares a C enumeration. It generates constants with integer values for +the elements of the enumeration. The symbols for the these constant +values are created by the concatenation of the enumeration name, +separator-string, and field symbol. Also creates a foreign type with the +name name of type :int. + +@subsubheading Examples +@exindex @code{ffi:def-enum} sample enumerations +@lisp +(ffi:def-enum abc (:a :b :c)) +;; Creates constants abc#a (1), abc#b (2), abc#c (3) and defines +;; the foreign type "abc" to be :int + +(ffi:def-enum efoo (:e1 (:e2 10) :e3) :separator-string "-") +;; Creates constants efoo-e1 (1), efoo-e2 (10), efoo-e3 (11) and defines +;; the foreign type efoo to be :int +@end lisp + +@subsubheading Side effects +Creates a @code{:int} foreign type, defines constants. +@end defmac + + + +@defmac ffi:def-struct name &rest fields + +Defines a C structure + +@table @var +@item name +A symbol that names the structure. +@item fields +A variable number of field defintions. Each definition is a list +consisting of a symbol naming the field followed by its foreign type. +@end table + +@subsubheading Description +Declares a structure. A special type is available as a slot in the +field. It is a pointer that points to an instance of the parent +structure. It's type is @code{:pointer-self}. + +@subsubheading Examples +@exindex @code{ffi:def-struct} defining C structure +@lisp +(ffi:def-struct foo (a :unsigned-int) + (b (* :char)) + (c (:array :int 10)) + (next :pointer-self)) +@end lisp + +@subsubheading Side effects +Creates a foreign type. +@end defmac + + + +@lspindex ffi:get-slot-value +@defun ffi:get-slot-value obj type field + +Retrieves a value from a slot of a structure + +@table @var +@item obj +A pointer to the foreign structure. +@item type +A name of the foreign structure. +@item field +A name of the desired field in foreign structure. +@item returns +The value of the @code{field} in the structure @code{obj}. +@end table + +@subsubheading Description +Accesses a slot value from a structure. This is generalized and can be +used with @code{SETF}-able. + +@subsubheading Examples +@exindex @code{ffi:get-slot-value} manipulating a struct field +@lisp +(get-slot-value foo-ptr 'foo-structure 'field-name) +(setf (get-slot-value foo-ptr 'foo-structure 'field-name) 10) +@end lisp +@end defun + + + +@lspindex ffi:get-slot-pointer +@defun ffi:get-slot-pointer obj type field + +Retrieves a pointer from a slot of a structure + +@table @var +@item obj +A pointer to the foreign structure. +@item type +A name of the foreign structure. +@item field +A name of the desired field in foreign structure. +@item returns +The value of the pointer @var{field} in the structure @var{obj}. +@end table + +@subsubheading Description +This is similar to get-slot-value. It is used when the value of a slot +is a pointer type. + +@subsubheading Examples +@exindex @code{ffi:get-slot-value} usage +@lisp +(get-slot-pointer foo-ptr 'foo-structure 'my-char-ptr) +@end lisp +@end defun + + + +@lspindex ffi:def-array-pointer +@defmac ffi:def-array-pointer name type + +Defines a pointer to an array of @var{type} + +@table @var +@item name +A name of the new foreign type. +@item type +The foreign type of the array elements. +@end table + +@subsubheading Description +Defines a type that is a pointer to an array of @var{type}. + +@subsubheading Examples +@exindex @code{ffi:def-array-pointer} usage +@lisp +(def-array-pointer byte-array-pointer :unsigned-char) +@end lisp + +@subsubheading Side effects +Defines a new foreign type. +@end defmac + + + +@lspindex ffi:deref-array +@defun ffi:deref-array array type position + +Deference an array + +@table @var +@item array +A foreign array. +@item type +The foreign type of the @var{array}. +@item position +An integer specifying the position to retrieve from the @var{array}. +@item returns +The value stored in the @var{position} of the @var{array}. +@end table + +@subsubheading Description +Dereferences (retrieves) the value of the foreign array +element. @code{SETF}-able. + +@subsubheading Examples +@exindex @code{ffi:deref-array} retrieving array element +(ffi:def-array-pointer ca :char) + (let ((fs (ffi:convert-to-foreign-string "ab"))) + (values (ffi:null-char-p (ffi:deref-array fs 'ca 0)) + (ffi:null-char-p (ffi:deref-array fs 'ca 2)))) +;; => NIL T +@lisp +@end lisp +@end defun + + + +@lspindex ffi:def-union +@defmac ffi:def-union name &rest fields + +Defines a foreign union type + +@table @var +@item name +A name of the new union type. +@item fields +A list of fields of the union in form @code{(field-name fields-type)}. +@end table + +@subsubheading Description +Defines a foreign union type. + +@subsubheading Examples +@exindex @code{ffi:def-union} union definition and usage +@lisp +(ffi:def-union test-union + (a-char :char) + (an-int :int)) + +(let ((u (ffi:allocate-foreign-object 'test-union))) + (setf (ffi:get-slot-value u 'test-union 'an-int) (+ 65 (* 66 256))) + (prog1 + (ffi:ensure-char-character (ffi:get-slot-value u 'test-union 'a-char)) + (ffi:free-foreign-object u))) +;; => #\A +@end lisp + +@subsubheading Side effects +Defines a new foreign type. +@end defmac + +@node Foreign Objects +@subsubsection Foreign Objects +@cindex Foreign objects + +@subsubheading Overview +Objects are entities that can allocated, referred to by pointers, and +can be freed. + +@subsubheading Reference + +@lspindex ffi:allocate-foreign-object +@defun ffi:allocate-foreign-object type &optional size + +Allocates an instance of a foreign object + +@table @var +@item type +The type of foreign object to allocate. This parameter is evaluated. +@item size +An optional size parameter that is evaluated. If specified, allocates +and returns an array of @var{type} that is @var{size} members long. This +parameter is evaluated. +@item returns +A pointer to the foreign object. +@end table + +@subsubheading Description +Allocates an instance of a foreign object. It returns a pointer to the +object. + +@subsubheading Examples +@exindex @code{ffi:allocate-foreign-object} allocating structure object +@lisp +(ffi:def-struct ab (a :int) (b :double)) +;; => (:STRUCT (A :INT) (B :DOUBLE)) +(ffi:allocate-foreign-object 'ab) +;; => # +@end lisp +@end defun + +@lspindex ffi:free-foreign-object +@defun ffi:free-foreign-object ptr + +Frees memory that was allocated for a foreign object + +@table @var +@item ptr +A pointer to the allocated foreign object to free. +@end table + +@subsubheading Description +Frees memory that was allocated for a foreign object. +@end defun + +@lspindex ffi:with-foreign-object +@defmac ffi:with-foreign-object (var type) &body body + +Wraps the allocation, binding and destruction of a foreign object around +a body of code + +@table @var +@item var +Variable name to bind. +@item type +Type of foreign object to allocate. This parameter is evaluated. +@item body +Code to be evaluated. +@item returns +The result of evaluating the body. +@end table + +@subsubheading Description +This function wraps the allocation, binding, and destruction of a +foreign object around the body of code. + +@subsubheading Examples +@exindex @code{ffi:with-foreign-object} macro usage +@lisp +(defun gethostname2 () + "Returns the hostname" + (ffi:with-foreign-object (name '(:array :unsigned-char 256)) + (if (zerop (c-gethostname (ffi:char-array-to-pointer name) 256)) + (ffi:convert-from-foreign-string name) + (error "gethostname() failed.")))) +@end lisp +@end defmac + +@lspindex ffi:size-of-foreign-type +@defmac ffi:size-of-foreign-type ftype + +Returns the number of data bytes used by a foreign object type + +@table @var +@item ftype +A foreign type specifier. This parameter is evaluated. +@item returns +Number of data bytes used by a foreign object @var{ftype}. +@end table + +@subsubheading Description +Returns the number of data bytes used by a foreign object type. This +does not include any Lisp storage overhead. + +@subsubheading Examples +@exindex @code{ffi:size-of-foreign-type} +@lisp +(ffi:size-of-foreign-type :unsigned-byte) +;; => 1 +(ffi:size-of-foreign-type 'my-100-byte-vector-type) +;; => 100 +@end lisp +@end defmac + +@lspindex ffi:pointer-address +@defun ffi:pointer-address ptr + +Returns the address of a pointer + +@table @var +@item ptr +A pointer to a foreign object. +@item returns +An integer representing the pointer's address. +@end table + +@subsubheading Description +Returns the address as an integer of a pointer. +@end defun + +@lspindex ffi:deref-pointer +@defun ffi:deref-pointer ptr ftype + +Deferences a pointer + +@table @var +@item ptr +Pointer to a foreign object. +@item ftype +Foreign type of the object being pointed to. +@item returns +The value of the object where the pointer points. +@end table + +@subsubheading Description +Returns the object to which a pointer points. @code{SETF}-able. + +@subsubheading Notes +Casting of the pointer may be performed with @code{WITH-CAST-POINTER} +together with the @code{DEREF-POINTER}/@code{DEREF-ARRAY}. + +@subsubheading Examples +@exindex @code{ffi:deref-pointer} +@lisp +(let ((intp (ffi:allocate-foreign-object :int))) + (setf (ffi:deref-pointer intp :int) 10) + (prog1 + (ffi:deref-pointer intp :int) + (ffi:free-foreign-object intp))) +;; => 10 +@end lisp +@end defun + +@lspindex ffi:ensure-char-character +@defun ffi:ensure-char-character object + +Ensures that a dereferenced @code{:char} pointer is a character + +@table @var +@item object +Either a character or a integer specifying a character code. +@item returns +A character. +@end table + +@subsubheading Description +Ensures that an objects obtained by dereferencing @code{:char} and +@code{:unsigned-char} pointers are a lisp character. + +@subsubheading Examples +@exindex @code{ffi:ensure-char-character} +@lisp +(let ((fs (ffi:convert-to-foreign-string "a"))) + (prog1 + (ffi:ensure-char-character (ffi:deref-pointer fs :char)) + (ffi:free-foreign-object fs))) +;; => #\a +@end lisp + +@subsubheading Exceptional Situations +Depending upon the implementation and what UFFI expects, this macro may +signal an error if the object is not a character or integer. +@end defun + +@lspindex ffi:ensure-char-integer +@defun ffi:ensure-char-integer object + +Ensures that a dereferenced @code{:char} pointer is an integer + +@table @var +@item object +Either a character or a integer specifying a character code. +@item returns +An integer. +@end table + +@subsubheading Description +Ensures that an objects obtained by dereferencing @code{:char} and +@code{:unsigned-char} pointers is a lisp integer. + +@subsubheading Examples +@exindex @code{ffi:ensure-char-integer} +@lisp +(let ((fs (ffi:convert-to-foreign-string "a"))) + (prog1 + (ffi:ensure-char-integer (ffi:deref-pointer fs :char)) + (ffi:free-foreign-object fs))) +;; => 96 +@end lisp + +@subsubheading Exceptional Situations +Depending upon the implementation and what UFFI expects, this macro may +signal an error if the object is not a character or integer. +@end defun + +@lspindex ffi:make-null-pointer +@defun ffi:make-null-pointer ftype + +Create a NULL pointer of a specified type + +@table @var +@item ftype +A type of object to which the pointer refers. +@item returns +The NULL pointer of type @var{ftype}. +@end table +@end defun + +@lspindex ffi:null-pointer-p +@defun ffi:null-pointer-p ptr + +Tests a pointer for NULL value + +@table @var +@item ptr +A foreign object pointer. +@item returns +The boolean flag. +@end table +@end defun + +@lspindex ffi:+null-cstring-pointer+ +@defvr {FFI} {+null-cstring-pointer+} +A NULL cstring pointer. This can be used for testing if a cstring +returned by a function is NULL. +@end defvr + +@lspindex ffi:with-cast-pointer +@defmac ffi:with-cast-pointer (var ptr ftype) &body body + +Wraps a body of code with a pointer cast to a new type + +@table @var +@item var +Symbol which will be bound to the casted object. +@item ptr +Pointer to a foreign object. +@item ftype +A foreign type of the object being pointed to. +@item returns +The value of the object where the pointer points. +@end table + +@subsubheading Description +Executes @var{BODY} with @var{PTR} cast to be a pointer to type +@var{FTYPE}. @var{VAR} is will be bound to this value during the +execution of @var{BODY}. + +@subsubheading Examples +@exindex @code{ffi:with-cast-pointer} +@lisp +(ffi:with-foreign-object (size :int) + ;; FOO is a foreign function returning a :POINTER-VOID + (let ((memory (foo size))) + (when (mumble) + ;; at this point we know for some reason that MEMORY points + ;; to an array of unsigned bytes + (ffi:with-cast-pointer (memory :unsigned-byte) + (dotimes (i (deref-pointer size :int)) + (do-something-with + (ffi:deref-array memory '(:array :unsigned-byte) i))))))) +@end lisp +@end defmac + +@lspindex ffi:def-foreign-var +@defmac ffi:def-foreign-var name type module + +Defines a symbol macro to access a variable in foreign code + +@table @var +@item name +A string or list specificying the symbol macro's name. If it is a +string, that names the foreign variable. A Lisp name is created by +translating @code{#\_} to @code{#\-} and by converting to upper-case in +case-insensitive Lisp implementations. + +If it is a list, the first item is a string specifying the foreign +variable name and the second it is a symbol stating the Lisp name. +@item type +A foreign type of the foreign variable. +@item module +A string specifying the module (or library) the foreign variable resides +in. +@end table + +@subsubheading Description +Defines a symbol macro which can be used to access (get and set) the +value of a variable in foreign code. + +@subsubheading Examples +@exindex @code{ffi:def-foreign-var} places in foreign world + +C code defining foreign structure, standalone integer and the accessor: +@example +@verbatim +int baz = 3; + +typedef struct { + int x; + double y; +} foo_struct; + +foo_struct the_struct = { 42, 3.2 }; + +int foo () { + return baz; +} +@end verbatim +@end example + +Lisp code defining C structure, function and a variable: +@lisp +(ffi:def-struct foo-struct + (x :int) + (y :double)) + +(ffi:def-function ("foo" foo) () + :returning :int + :module "foo") + +(ffi:def-foreign-var ("baz" *baz*) :int "foo") +(ffi:def-foreign-var ("the_struct" *the-struct*) foo-struct "foo") + +*baz* ;; => 3 +(incf *baz*) ;; => 4 +(foo) ;; => 4 +@end lisp +@end defmac + +@node Foreign Strings +@subsubsection Foreign Strings +@cindex Foreign strings + +@subsubheading Overview +@cindex @code{cstring} and @code{foreign string} differences + +UFFI has functions to two types of C-compatible strings: @code{cstring} +and foreign strings. @code{cstrings} are used only as parameters to and +from functions. In some implementations a @code{cstring} is not a +foreign type but rather the Lisp string itself. On other platforms a +cstring is a newly allocated foreign vector for storing characters. The +following is an example of using cstrings to both send and return a +value. + +@exindex @code{cstring} used to send and return a value +@lisp +(ffi:def-function ("getenv" c-getenv) + ((name :cstring)) + :returning :cstring) + +(defun my-getenv (key) + "Returns an environment variable, or NIL if it does not exist" + (check-type key string) + (ffi:with-cstring (key-native key) + (ffi:convert-from-cstring (c-getenv key-native)))) +@end lisp + +In contrast, foreign strings are always a foreign vector of characters +which have memory allocated. Thus, if you need to allocate memory to +hold the return value of a string, you must use a foreign string and not +a cstring. The following is an example of using a foreign string for a +return value. + +@exindex @code{foreign string} used to send and return a value +@lisp +(ffi:def-function ("gethostname" c-gethostname) + ((name (* :unsigned-char)) + (len :int)) + :returning :int) + +(defun gethostname () + "Returns the hostname" + (let* ((name (ffi:allocate-foreign-string 256)) + (result-code (c-gethostname name 256)) + (hostname (when (zerop result-code) + (ffi:convert-from-foreign-string name)))) + ;; UFFI does not yet provide a universal way to free + ;; memory allocated by C's malloc. At this point, a program + ;; needs to call C's free function to free such memory. + (unless (zerop result-code) + (error "gethostname() failed.")))) +@end lisp + +Foreign functions that return pointers to freshly allocated strings +should in general not return @code{cstring}s, but @code{foreign +strings}. (There is no portable way to release such @code{cstring}s from +Lisp.) The following is an example of handling such a function. + +@exindex Conversion between @code{foreign string} and @code {cstring} +@lisp +(ffi:def-function ("readline" c-readline) + ((prompt :cstring)) + :returning (* :char)) + +(defun readline (prompt) + "Reads a string from console with line-editing." + (ffi:with-cstring (c-prompt prompt) + (let* ((c-str (c-readline c-prompt)) + (str (ffi:convert-from-foreign-string c-str))) + (ffi:free-foreign-object c-str) + str))) +@end lisp + +@subsubheading Reference + +@lspindex ffi:convert-from-cstring +@defmac ffi:convert-from-cstring object +Converts a @code{cstring} to a Lisp string +@table @var +@item object +@code{cstring} +@item returns +Lisp string +@end table + +@subsubheading Description +Converts a Lisp string to a cstring. This is most often used when +processing the results of a foreign function that returns a cstring. +@end defmac + +@lspindex ffi:convert-to-cstring +@defmac ffi:convert-to-cstring object +Converts a Lisp string to a @code{cstring} +@table @var +@item object +Lisp string +@item returns +@code{cstring} +@end table + +@subsubheading Description +Converts a Lisp string to a cstring. The cstring should be freed with +free-cstring. +@subsubheading Side Effects +This function allocates memory. +@end defmac + + +@lspindex ffi:free-cstring +@defmac ffi:convert-from-cstring cstring +Free memory used by @var{cstring} +@table @var +@item cstring +@code{cstring} to be freed. +@end table +@subsubheading Description +Frees any memory possibly allocated by convert-to-cstring. On ECL, a +cstring is just the Lisp string itself. +@end defmac + + +@lspindex ffi:with-cstring +@defmac ffi:with-cstring (cstring string) &body body +Binds a newly created @code{cstring} +@table @var +@item cstring +A symbol naming the @code{cstring} to be created. +@item string +A Lisp string that will be translated to a @code{cstring}. +@item body +The body of where the @var{cstring} will be bound. +@item returns +Result of evaluating the @var{body}. +@end table +@subsubheading Description +Binds a symbol to a @code{cstring} created from conversion of a +@var{string}. Automatically frees the @var{cstring}. +@subsubheading Examples +@exindex @code{with-cstring} +@lisp +(ffi:def-function ("getenv" c-getenv) + ((name :cstring)) + :returning :cstring) + +(defun getenv (key) + "Returns an environment variable, or NIL if it does not exist" + (check-type key string) + (ffi:with-cstring (key-cstring key) + (ffi:convert-from-cstring (c-getenv key-cstring)))) +@end lisp +@end defmac + +@lspindex ffi:with-cstrings +@defmac ffi:with-cstrings bindings &body body +Binds a newly created @code{cstrings} +@table @var +@item bindings +List of pairs @var{(cstring string)}, where @var{cstring} is a name +for a @code{cstring} translated from Lisp string @var{string}. +@item body +The body of where the @var{bindings} will be bound. +@item returns +Result of evaluating the @var{body}. +@end table +@subsubheading Description +Binds a symbols to a @code{cstring}s created from conversion of a +@var{string}s. Automatically frees the @var{cstring}s. This macro works +similar to @code{LET*}. Based on @code{with-cstring}. +@end defmac + +@lspindex ffi:convert-from-foreign-string +@defmac ffi:convert-from-foreign-string foreign-string &key length (null-terminated-p t) +Converts a foreign string into a Lisp string +@table @var +@item foreign-string +A foreign string. +@item length +The length of the foreign string to convert. The default is the length +of the string until a NULL character is reached. +@item null-terminated-p +A boolean flag with a default value of T When true, the string is +converted until the first NULL character is reached. +@item returns +A Lisp string. +@end table +@subsubheading Description +Returns a Lisp string from a foreign string. Can translated ASCII and +binary strings. +@end defmac + +@lspindex ffi:convert-to-foreign-string +@defmac ffi:convert-to-foreign-string +Converts a Lisp string to a foreign string +@table @var +@item string +A Lisp string. +@item returns +A foreign string. +@end table +@subsubheading Description +Converts a Lisp string to a foreign string. Memory should be freed with +free-foreign-object. +@end defmac + +@lspindex ffi:allocate-foreign-string +@defmac ffi:allocate-foreign-string size &key unsigned +Allocates space for a foreign string +@table @var +@item size +The size of the space to be allocated in bytes. +@item unsigned +A boolean flag with a default value of T. When true, marks the pointer +as an :unsigned-char. +@item returns +A foreign string which has undefined contents. +@end table +@subsubheading Description +Allocates space for a foreign string. Memory should be freed with +free-foreign-object. +@end defmac + +@lspindex ffi:with-foreign-string +@defmac ffi:with-foreign-string (foreign-string string) &body body +Binds a newly allocated @code{foreign-string} +@table @var +@item foreign-string +A symbol naming the @code{foreign string} to be created. +@item string +A Lisp string that will be translated to a @code{foreign string}. +@item body +The body of where the @var{foreign-string} will be bound. +@item returns +Result of evaluating the @var{body}. +@end table +@subsubheading Description +Binds a symbol to a @code{foreign-string} created from conversion of a +@var{string}. Automatically deallocates the @var{foreign-string}. +@subsubheading Examples +@end defmac + +@lspindex ffi:with-foreign-strings +@defmac ffi:with-foreign-strings bindings &body body +Binds a newly created @code{foreign string} +@table @var +@item bindings +List of pairs @var{(foreign-string string)}, where @var{foreign-string} +is a name for a @code{foreign string} translated from Lisp string +@var{string}. +@item body +The body of where the @var{bindings} will be bound. +@item returns +Result of evaluating the @var{body}. +@end table +@subsubheading Description +Binds a symbols to a @code{foreign-string}s created from conversion of a +@var{string}s. Automatically frees the @var{foreign-string}s. This macro +works similar to @code{LET*}. Based on @code{with-foreign-string}. +@end defmac + +@node Functions and Libraries +@subsubsection Functions and Libraries +@cindex Foreign functions and libraries + +@subsubheading Reference + +@lspindex ffi:def-function +@defmac ffi:def-function name args &key module (returning :void) (call :cdecl) +@table @var +@item name +A string or list specificying the function name. If it is a string, that +names the foreign function. A Lisp name is created by translating +@code{#\_} to @code{#\-} and by converting to upper-case in +case-insensitive Lisp implementations. If it is a list, the first item +is a string specifying the foreign function name and the second it is a +symbol stating the Lisp name. +@item args +A list of argument declarations. If @code{NIL}, indicates that the function +does not take any arguments. +@item module +A string specifying which module (or library) that the foreign function +resides. +@item call +Function calling convention. May be one of @code{:default}, @code +{:cdecl}, @code{:sysv}, @code{:stdcall}, @code{:win64} and +@code{unix64}. + +This argument is used only when we're using the dynamic function +interface. If ECL is built without the DFFI support, then it uses SFFI +the @var{call} argument is ignored. +@item returning +A declaration specifying the result type of the foreign function. If +@code{:void} indicates module does not return any value. +@end table +@subsubheading Description +Declares a foreign function. +@subsubheading Examples +@exindex @code{ffi:def-function} +@lisp +(def-function "gethostname" + ((name (* :unsigned-char)) + (len :int)) + :returning) :int) +@end lisp +@end defmac + +@lspindex ffi:load-foreign-library +@defmac ffi:load-foreign-library filename &key module supporting-libraries force-load system-library +@table @var +@item filename +A string or pathname specifying the library location in the filesystem. +@item module +@strong{IGNORED} A string designating the name of the module to apply to +functions in this library. +@item supporting-libraries +@strong{IGNORED} A list of strings naming the libraries required to link +the foreign library. +@item force-load +@strong{IGNORED} Forces the loading of the library if it has been +previously loaded. +@item system-library +Denotes if the loaded library is a system library (accessible with the +correct linker flags). If @code{T}, then SFFI is used and the linking is +performed after compilation of the module. Otherwise (default) both SFFI +and DFFI are used, but SFFI only during the compilation. +@item returns +A generalized boolean @emph{true} if the library was able to be loaded +successfully or if the library has been previously loaded, otherwise +NIL. +@end table +@subsubheading Description +Loads a foreign library. Ensures that a library is only loaded once +during a session. +@subsubheading Examples +@exindex @code{ffi:load-foreign-library} +@lisp +(ffi:load-foreign-library #p"/usr/lib/libmagic.so.1") +;; => # +@end lisp +@subsubheading Side Effects +Loads the foreign code into the Lisp system. +@subsubheading Affected by +Ability to load the file. +@end defmac + +@lspindex ffi:find-foreign-library +@defun ffi:find-foreign-library names directories &key drive-letters types +Finds a foreign library file +@table @var +@item names +A string or list of strings containing the base name of the library +file. +@item directories +A string or list of strings containing the directory the library file. +@item drive-letters +A string or list of strings containing the drive letters for the library +file. +@item types +A string or list of strings containing the file type of the library +file. Default is NIL. If NIL, will use a default type based on the +currently running implementation. +@item returns +A path containing the path to the @emph{first} file found, or NIL if the +library file was not found. +@end table +@subsubheading Description +Finds a foreign library by searching through a number of possible +locations. Returns the path of the first found file. +@subsubheading Examples +@exindex @code{ffi:find-foreign-library} +@lisp +(ffi:find-foreign-library '("libz" "libmagic") + '("/usr/local/lib/" "/usr/lib/") + :types '("so" "dll")) +;; => #P"/usr/lib/libz.so.1.2.8" +@end lisp +@end defun + +@c @lspindex ffi: +@c @defmac ffi: + +@c desc + +@c @table @var +@c @item arg-1 +@c description +@c @item arg-2 +@c description +@c @item returns +@c One value? More? +@c @end table + +@c @subsubheading Description +@c Description here + +@c @subsubheading Examples +@c @exindex @code{ffi:} sample run +@c @lisp + +@c @end lisp + +@c @subsubheading Side effects +@c foo bar +@c @end defmac diff -Nru ecl-16.1.2/src/doc/new-doc/extensions/gray-streams.txi ecl-16.1.3+ds/src/doc/new-doc/extensions/gray-streams.txi --- ecl-16.1.2/src/doc/new-doc/extensions/gray-streams.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/extensions/gray-streams.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,9 @@ +@node Gray streams +@section Gray streams + +@defun{close} {@var{stream} @keys{} :abort} + +If @var{stream} isn't a stream close will ``let to specialize +itself''. This decision ahs been taken mainly for the compatibility +reasons with some libraries. +@end defun diff -Nru ecl-16.1.2/src/doc/new-doc/extensions/index.txi ecl-16.1.3+ds/src/doc/new-doc/extensions/index.txi --- ecl-16.1.2/src/doc/new-doc/extensions/index.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/extensions/index.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,69 @@ +@node Extensions +@chapter Extensions + +@menu +* System building:: +* Operating System Interface:: +* Foreign Function Interface:: +* Native threads:: +@c * Green Threads:: +* Signals and Interrupts:: +@c Networking:: +* Memory Management:: +* Meta-Object Protocol (MOP):: +@c * Continuations:: +@c * Extensible Sequences:: +* Gray Streams:: +@c * TCP Streams:: +@c * Series:: +* Tree walker:: +@c * Local package nicknames:: +@c * Hierarchical packages:: +* Package locks:: +* CDR Extensions:: +@end menu + +@ System building +@include extensions/building.txi + +@node Operating System Interface +@section Operating System Interface + +@c Foreign function interface +@include extensions/ffi.txi + +@c Native threads +@include extensions/mp.txi + +@c @node Green Threads +@c @section Green Threads + +@node Signals and Interrupts +@section Signals and Interrupts + +@node Memory Management +@section Memory Management + +@node Meta-Object Protocol (MOP) +@section Meta-Object Protocol (MOP) + +@c @node Continuations +@c @section Continuations + +@c @node Extensible Sequences +@c @section Extensible Sequences + +@node Gray Streams +@section Gray Streams + +@c @node Series +@c @section Series + +@node Tree walker +@section Tree walker + +@c Package extensions +@include extensions/packages.txi + +@node CDR Extensions +@section CDR Extensions diff -Nru ecl-16.1.2/src/doc/new-doc/extensions/mp_ref_atomic.txi ecl-16.1.3+ds/src/doc/new-doc/extensions/mp_ref_atomic.txi --- ecl-16.1.2/src/doc/new-doc/extensions/mp_ref_atomic.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/extensions/mp_ref_atomic.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,9 @@ +@node Atomic operations +@subsubsection Atomic operations +/* threads/atomic.c */ + +cl_object ecl_atomic_get(cl_object *slot); +void ecl_atomic_push(cl_object *slot, cl_object o); +void ecl_atomic_nconc(cl_object l, cl_object *slot); +cl_object ecl_atomic_pop(cl_object *slot); +cl_index ecl_atomic_index_incf(cl_index *slot); diff -Nru ecl-16.1.2/src/doc/new-doc/extensions/mp_ref_barrier.txi ecl-16.1.3+ds/src/doc/new-doc/extensions/mp_ref_barrier.txi --- ecl-16.1.2/src/doc/new-doc/extensions/mp_ref_barrier.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/extensions/mp_ref_barrier.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,45 @@ +@node Barriers +@subsubsection Barriers + +@cindex Barriers (synchronization) + + +@cppindex ecl_make_barrier +cl_object ecl_make_barrier (cl_object name, cl_index count) + + +@lspindex mp:make-barrier +mp:make-barrier count &key name + + +@cppindex mp_barrier_count +@lspindex mp:barrier-count + +cl_object mp_barrier_count (cl_object barrier) +mp:barrier-count + + +@cppindex mp_barrier_name +@lspindex mp:barrier-name + +cl_object mp_barrier_name (cl_object) +mp:barrier_name + + +@cppindex mp_barrier_arrivers_count +n@lspindex mp:barrier-arrivers-count + +cl_object mp_barrier_arrivers_count(cl_object barrier); +mp:barrier_arrivers_count barrier + + +@cppindex mp_barrier_wait +@lspindex mp:barrier-wait + +mp:barrier-wait barrier +cl_object mp_barrier_wait (cl_object barrier); + + +@lspindex mp:barrier-unblock +mp:barrier-unblock barrier &key reset_count disable kill-waiting + diff -Nru ecl-16.1.2/src/doc/new-doc/extensions/mp_ref_cv.txi ecl-16.1.3+ds/src/doc/new-doc/extensions/mp_ref_cv.txi --- ecl-16.1.2/src/doc/new-doc/extensions/mp_ref_cv.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/extensions/mp_ref_cv.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,71 @@ +@node Condition variables +@subsection Condition variables + +Condition variables are used to wait for a particular condition becoming +true (e.g new client connects to the server). + +@node Condition variables dictionary +@subsection Condition variables dictionary + + +@cppindex mp_make_condition_variable +@lspindex mp:make-condition-variable + +@deftypefun cl_object mp_make_condition_variable () +@end deftypefun + +@defun mp:make-condition-variable +Creates a condition variable. +@end defun + + +@cppindex mp_condition_variable_wait +@lspindex mp:condition-variable-wait + +@deftypefun cl_object mp_condition_variable_wait (cl_object cv, cl_object lock) +@end deftypefun + +@defun mp:condition-variable-wait cv lock +Release @code{lock} and suspend thread until condition +@code{mp:condition-variable-signal} is called on @code{cv}. When thread +resumes re-aquire @code{lock}. +@end defun + + +@cppindex mp_condition_variable_timedwait +@lspindex mp:condition-variable-timedwait + +@deftypefun cl_object mp_condition_variable_timedwait (cl_object cv, cl_object lock, cl_object seconds) +@end deftypefun + +@defun mp:condition-variable-timedwait cv lock seconds +@code{mp:condition-variable-wait} which timeouts after @code{seconds} +seconds. +@end defun + + +@cppindex mp_condition_variable_signal +@lspindex mp:condition-variable-signal + +@deftypefun cl_object mp_condition_variable_signal (cl_object cv) +@end deftypefun + +@defun mp:condition-variable-signal cv +Signal @code{cv} (wakes up only one waiter). After signal, signaling +thread keeps lock, waking thread goes on the queue waiting for the lock. + +See @code{mp:condition-variable-wait}. +@end defun + + +@cppindex mp_condition_variable-broadcast +@lspindex mp:condition-variable-broadcast + +@deftypefun cl_object mp_condition_variable_broadcast (cl_object cv) +@end deftypefun + +@defun mp:condition-variable-broadcast cv +Signal @code{cv} (wakes up all waiters). + +See @code{mp:condition-variable-wait}. +@end defun diff -Nru ecl-16.1.2/src/doc/new-doc/extensions/mp_ref_mailbox.txi ecl-16.1.3+ds/src/doc/new-doc/extensions/mp_ref_mailbox.txi --- ecl-16.1.2/src/doc/new-doc/extensions/mp_ref_mailbox.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/extensions/mp_ref_mailbox.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,82 @@ +@node Mailboxes +@subsubsection Mailboxes +/* threads/mailbox.d */ + +@lspindex mp:make_mailbox +@lspindex mp_make_mailbox +@defun mp:make_mailbox +@table @var +@item returns +??? +@item C/C++ signature +cl_object mp_make_mailbox _ECL_ARGS((cl_narg, ...)); +@end table +@end defun + +@lspindex mp:mailbox_name +@lspindex mp_mailbox_name +@defun mp:mailbox_name +@table @var +@item returns +??? +@item C/C++ signature +cl_object mp_mailbox_name(cl_object mailbox); +@end table +@end defun + +@lspindex mp:mailbox_count +@lspindex mp_mailbox_count +@defun mp:mailbox_count +@table @var +@item returns +??? +@item C/C++ signature +cl_object mp_mailbox_count(cl_object mailbox); +@end table +@end defun + +@lspindex mp:mailbox_empty_p +@lspindex mp_mailbox_empty_p +@defun mp:mailbox_empty_p +@table @var +@item returns +??? +@item C/C++ signature +cl_object mp_mailbox_empty_p(cl_object); +@end table +@end defun + +@lspindex mp:mailbox_read +@lspindex mp_mailbox_read +@defun mp:mailbox_read +@table @var +@item returns +??? +@item C/C++ signature +cl_object mp_mailbox_read(cl_object mailbox); +@end table +@end defun + +@lspindex mp:mailbox_try_read +@lspindex mp_mailbox_try_read +@defun mp:mailbox_try_read +@table @var +@item returns +??? +@item C/C++ signature +cl_object mp_mailbox_try_read(cl_object mailbox); +@end table +@end defun + +@lspindex mp:mailbox_send +@lspindex mp_mailbox_send +@defun mp:mailbox_send +@table @var +@item returns +??? +@item C/C++ signature +cl_object mp_mailbox_send(cl_object mailbox, cl_object msg); +@end table +@end defun + +cl_object mp_mailbox_try_send(cl_object mailbox, cl_object msg); diff -Nru ecl-16.1.2/src/doc/new-doc/extensions/mp_ref_mutex.txi ecl-16.1.3+ds/src/doc/new-doc/extensions/mp_ref_mutex.txi --- ecl-16.1.2/src/doc/new-doc/extensions/mp_ref_mutex.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/extensions/mp_ref_mutex.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,137 @@ +@node Locks (mutexes) +@subsection Locks (mutexes) + +Locks are used to synchronize access to the shared data. Lock may be +owned only by a single thread at any given time. Recursive locks may be +re-acquired by the same thread multiple times (and non-recursive locks +can't). + +@node Locks dictionary +@subsection Locks dictionary + + +@cppindex ecl_make_lock + +@deftypefun ecl_make_lock (cl_object name, bool recursive) +C/C++ equivalent of @code{mp:make-lock} without @code{key} arguments. + +See @code{mp:make-lock}. +@end deftypefun + + +@lspindex mp:make-lock + +@defun mp:make-lock &key name (recursive nil) +Creates a lock @code{name}. If @code{recursive} isn't @code{nil}, then +the created lock is recursive. +@end defun + + +@cppindex mp_recursive_lock_p +@lspindex mp:recursive-lock-p + +@deftypefun cl_object mp_recursive_lock_p (cl_object lock) +@end deftypefun + +@defun mp:recursive-lock-p lock +Predicate verifying if @code{lock} is recursive. +@end defun + + +@cppindex mp_holding_lock_p +@lspindex mp:holding-lock-p + +@deftypefun cl_object mp_holding_lock_p (cl_object lock) +@end deftypefun + +@defun mp:holding-lock-p lock +Predicate verifying if the current thread holds @code{lock}. +@end defun + + +@cppindex mp_lock_name +@lspindex mp:lock-name + +@deftypefun cl_object mp_lock_name (cl_object lock) +@end deftypefun + +@defun mp:lock_name lock +Returns @code{lock} name. +@end defun + + +@lspindex mp_lock_owner +@lspindex mp:lock-owner + +@deftypefun cl_object mp_lock_owner (cl_object lock) +@end deftypefun + +@defun mp:lock_owner lock +Returns process owning @code{lock} (or @code{nil} if it is free). For +testing whether the current thread is holding a lock see +@code{holding-lock-p}. +@end defun + + +@cppindex mp_lock_count +@lspindex mp:lock-count + +@deftypefun cl_object mp_lock_count (cl_object lock) +@end deftypefun + +@defun mp:lock-count lock +Returns number of processes waiting for @code{lock}. +@end defun + + +@cppindex mp_get_lock_wait +@cppindex mp_get_lock_nowait +@lspindex mp:get-lock + +@deftypefun cl_object mp_get_lock_wait (cl_object lock) +Grabs a lock (blocking if @code{lock} is already takene). Returns +@code{ECL_T}. +@end deftypefun + +@deftypefun cl_object mp_get_lock_nowait +Grabs a lock if free (non-blocking). If @code{lock} is already taken +returns @code{ECL_NIL}, otherwise @code{ECL_T}. +@end deftypefun + +@defun mp:get-lock lock &optional (wait t) +Tries to acquire a lock. @code{wait} indicates whenever function should +block or give up if @code{lock} is already taken. If @code{wait} is +@code{nil} and @code{lock} can't be acquired returns +@code{nil}. Succesful operation returns @code{t}. +@end defun + + +@cppindex mp_giveup_lock +@lspindex mp:giveup-lock + +@deftypefun cl_object mp_giveup_lock (cl_object lock) +@end deftypefun + +@defun mp:giveup_lock +Releases @code{lock}. +@end defun + + +@lspindex mp:with-lock + +@defmac mp:with-lock (lock-form) &body body +Acquire lock for the dynamic scope of @code{body}, which is executed +with the lock held by current thread, and @code{with-lock} returns the +values of body. + +@c (lock-form &key wait-p timeout) + +@c If wait-p is true (the default), and the mutex is not immediately +@c available, sleep until it is available. + +@c If timeout is given, it specifies a relative timeout, in seconds, on how +@c long the system should try to acquire the lock in the contested case. + +@c If the mutex isn’t acquired successfully due to either wait-p or +@c timeout, the body is not executed, and with-mutex returns nil. +@end defmac diff -Nru ecl-16.1.2/src/doc/new-doc/extensions/mp_ref_process.txi ecl-16.1.3+ds/src/doc/new-doc/extensions/mp_ref_process.txi --- ecl-16.1.2/src/doc/new-doc/extensions/mp_ref_process.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/extensions/mp_ref_process.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,376 @@ +@node Processes (native threads) +@subsection Processes (native threads) + +Process is a primitive representing native thread. + +@node Processes dictionary +@subsection Processes dictionary + +@cppindex mp_all_processes +@lspindex mp:all-processes + +@deftypefun cl_object mp_all_processes () +@end deftypefun + +@defun mp:all-processes + +Returns the list of processes associated to running tasks. The list is a +fresh new one and can be destructively modified. However, it may happen +that the output list is not up to date, because some of the tasks has +expired before this copy is returned. + +@end defun + + +@cppindex mp_exit_process +@lspindex mp:exit-process + +@deftypefun cl_object mp_all_processes () ecl_attr_noreturn +@end deftypefun + +@defun mp:exit_process + +When called from a running task, this function immediately causes the +task to finish. When invoked from the main thread, it is equivalent to +invoking @code{ext:quit} with exit code 0. + +@end defun + + +@cppindex mp_interrupt_process +@lspindex mp:interrupt-process + +@deftypefun cl_object mp_interrupt_process (cl_object process, cl_object function) +@end deftypefun + +@defun mp:interrupt_process process function + +Interrupt a task. This @code{function} sends a signal to a running +@code{process}. When the task is free to process that signal, it will +stop whatever it is doing and execute the given function. + +@exindex Process interruption +Example: + +Kill a task that is doing nothing (See @code{mp:process-kill}). + +@lisp +(flet ((task-to-be-killed () + ;; Infinite loop + (loop (sleep 1)))) + (let ((task (mp:process-run-function 'background #'task-to-be-killed))) + (sleep 10) + (mp:interrupt-process task 'mp:exit-process))) +@end lisp + +@end defun + + +@cppindex mp_make_process +@lspindex mp:make-process + +@deftypefun cl_object mp_make_process (cl_narg narg, ...) +@end deftypefun + +@defun mp:make-process &key name initial-bindings + +Create a new thread. This function creates a separate task with a name +set to @code {name}, set of variable bindings @code{initial-bindings} +and no function to run. See also @code{mp:process-run-function}. Returns +newly created process. + +@end defun + + +@cppindex mp_process_active_p +@lspindex mp:process-active-p + +@deftypefun cl_object mp_make_process (cl_object process) +@end deftypefun + +@defun mp:process-active-p process + +Returns @code{t} when @code{process} is active, @code {nil} +otherwise. Signals an error if @code{process} doesn't designate a valid +process. + +@end defun + + +@cppindex mp_process_enable +@lspindex mp:process-enable + +@deftypefun cl_object mp_process_enable (cl_object process) +@end deftypefun + +@defun mp:process-enable process + +The argument to this function should be a process created by +@code{mp:make-process}, which has a function associated as per +@code{mp:process-preset} but which is not yet running. After invoking +this function a new thread will be created in which the associated +function will be executed. + +@exindex Possible implementation of @code{mp:process-run-function}: + +@lisp +(defun process-run-function (process-name process-function &rest args) + (let ((process (mp:make-process name))) + (apply #'mp:process-preset process function args) + (mp:process-enable process))) +@end lisp +@end defun + + +@cppindex mp_process_yield +@lspindex mp:process_yield + +@deftypefun cl_object mp_process_yield () +@end deftypefun + +@defun mp:process-yield +Yield the processor to other threads. +@end defun + + +@cppindex mp_process-join +@lspindex mp:process_join + +@deftypefun cl_object mp_process_join (cl_object process) +@end deftypefun + +@defun mp:process-join process +Suspend current thread until @code{process} exits. Return the result +values of the @code{process} function. If @code{process} is the current +thread, signal an error with. +@end defun + + +@cppindex mp_process_kill +@lspindex mp:process-kill + +@deftypefun cl_object mp_process_kill (cl_object process) +@end deftypefun + +@defun mp:process-kill process +Try to stop a running task. Killing a process may fail if the task has +disabled interrupts. + +@exindex Killing process +Example: + +Kill a task that is doing nothing +@lisp +(flet ((task-to-be-killed () + ;; Infinite loop + (loop (sleep 1)))) + (let ((task (mp:process-run-function 'background #'task-to-be-killed))) + (sleep 10) + (mp:process-kill task))) +@end lisp +@end defun + + +@cppindex mp_process_suspend +@lspindex mp:process-suspend + +@deftypefun cl_object mp_process_suspend (cl_object process) +@end deftypefun + +@defun mp:process-suspend process +Suspend a running @code{process}. May be resumed with +@code{mp:process-resume}. + +@exindex Suspend and resume process +Example: + +@lisp +(flet ((ticking-task () + ;; Infinite loop + (loop + (sleep 1) + (print :tick)))) + (print "Running task (one tick per second)") + (let ((task (mp:process-run-function 'background #'ticking-task))) + (sleep 5) + (print "Suspending task for 5 seconds") + (mp:process-suspend task) + (sleep 5) + (print "Resuming task for 5 seconds") + (mp:process-resume task) + (sleep 5) + (print "Killing task") + (mp:process-kill task))) +@end lisp +@end defun + + +@cppindex mp_process_resume +@lspindex mp:process-resume + +@deftypefun cl_object mp_process_resume (cl_object process) +@end deftypefun + +@defun mp:process-resume process +Resumes a suspended @code{process}. See example in +@code{mp:process-suspend}. +@end defun + + +@cppindex mp_process_name +@lspindex mp:process-name + +@deftypefun cl_object mp_process_name (cl_object process) +@end deftypefun + +@defun mp:process-name process +Returns the name of a @code{process} (if any). +@end defun + + +@cppindex mp_process_preset +@lspindex mp:process-preset + +@deftypefun cl_object mp_process_preset (cl_narg narg, cl_object process, cl_object function, ...) +@end deftypefun + +@defun mp:process-preset process function &rest function-args + +Associates a @code{function} to call with the arguments +@code{function-args}, with a stopped @code{process}. The function will +be the entry point when the task is enabled in the future. + +See @code{mp:enable-process} and @code{mp:process-run-function}. + +@end defun + + +@cppindex mp_process_run_function +@lspindex mp:process-run-function + +@deftypefun cl_object mp_process_run_function (cl_narg narg, cl_object name, cl_object function, ...) +@end deftypefun + +@defun mp:process_run_function name function &rest funciton-args +Create a new process using @code{mp:make-process}, associate a function +to it and start it using @code{mp:process-preset}. + +@exindex mp:process-run-funciton usage +Example: + +@lisp +(flet ((count-numbers (end-number) + (dotimes (i end-number) + (format t "~%;;; Counting: ~i" i) + (terpri) + (sleep 1)))) + (mp:process-run-function 'counter #'count-numbers 10)) +@end lisp +@end defun + + +@cppindex mp_current_process +@lspindex mp:current_process + +@deftypefun cl_object mp_current_process () +@end deftypefun + +@defun mp:current-process +Returns the current process of a caller. +@end defun + + +@cppindex mp_block_signals +@lspindex mp:block-signals + +@deftypefun cl_object mp_block_signals () +@end deftypefun + +@defun mp:block-signals +Blocks process for interrupts and returns the previous sigmask. + +See @code{mp:interrupt-process}. +@end defun + + +@cppindex mp_restore_signals +@lspindex mp:restore-signals + +@deftypefun cl_object mp_restore_signals (cl_object sigmask) +@end deftypefun + +@defun mp:restor-signals sigmask +Enables the interrupts from @code{sigmask}. + +See @code{mp:interrupt-process}. +@end defun + + +@lspindex mp:without-interrupts +@lspindex allow-with-interrupts +@lspindex with-local-interrupts +@lspindex with-restored-interrupts + +@defmac mp:without-interrupts &body body + +Executes @code{body} with all deferrable interrupts disabled. Deferrable +interrupts arriving during execution of the @code{body} take effect +after @code{body} has been executed. + +Deferrable interrupts include most blockable POSIX signals, and +@code{mp:interrupt-thread}. Does not interfere with garbage collection, +and unlike in many traditional Lisps using userspace threads, in ECL +@code{mp:without-interrupts} does not inhibit scheduling of other +threads. + +Binds @code{allow-with-interrupts}, @code{with-local-interrupts} and +@code{with-restored-interrupts} as a local macros. + +@code{with-restored-interrupts} executes the body with interrupts enabled if +and only if the @code{without-interrupts} was in an environment in which +interrupts were allowed. + +@code{allow-with-interrupts} allows the @code{with-interrupts} to take +effect during the dynamic scope of its body, unless there is an outer +@code{without-interrupts} without a corresponding +@code{allow-with-interrupts}. + +@code{with-local-interrupts} executes its body with interrupts enabled +provided that for there is an @code{allow-with-interrupts} for every +@code{without-interrupts} surrounding the current +one. @code{with-local-interrupts} is equivalent to: + +@lisp +(allow-with-interrupts (with-interrupts ...)) +@end lisp + +Care must be taken not to let either @code{allow-with-interrupts} or +@code{with-local-interrupts} appear in a function that escapes from +inside the @code{without-interrupts} in: + +@lisp +(without-interrupts + ;; The body of the lambda would be executed with WITH-INTERRUPTS allowed + ;; regardless of the interrupt policy in effect when it is called. + (lambda () (allow-with-interrupts ...))) + +(without-interrupts + ;; The body of the lambda would be executed with interrupts enabled + ;; regardless of the interrupt policy in effect when it is called. + (lambda () (with-local-interrupts ...))) +@end lisp +@end defmac + + +@lspindex mp:with-interrupts +@defmac mp:with-interrupts &body body +Executes @code{body} with deferrable interrupts conditionally +enabled. If there are pending interrupts they take effect prior to +executing @code{body}. + +As interrupts are normally allowed @code{with-interrupts} only makes +sense if there is an outer @code{without-interrupts} with a +corresponding @code{allow-with-interrupts}: interrupts are not enabled +if any outer @code{without-interrupts} is not accompanied by +@code{allow-with-interrupts}. +@end defmac diff -Nru ecl-16.1.2/src/doc/new-doc/extensions/mp_ref_rwlock.txi ecl-16.1.3+ds/src/doc/new-doc/extensions/mp_ref_rwlock.txi --- ecl-16.1.2/src/doc/new-doc/extensions/mp_ref_rwlock.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/extensions/mp_ref_rwlock.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,115 @@ +@node Readers-writer locks +@subsection Readers-writer locks + +@ftindex ecl-read-write-lock +@cindex Readers-writer locks +@cindex Shared-exclusive locks + +Readers-writer (or shared-exclusive ) lock allows concurrent access for +read-only operations and write operations require exclusive +access. @code{mp:rwlock} is non-recursive. + + +@node Readers-writer locks dictionary +@subsection Read-Write locks dictionary + + +@cppindex ecl_make_rwlock + +@deftypefun ecl_make_rwlock (cl_object name) +C/C++ equivalent of @code{mp:make-rwlock} without @code{key} arguments. + +See @code{mp:make-rwlock}. +@end deftypefun + + +@lspindex mp:make_rwlock + +@defun mp:make_rwlock &key name +Creates a rwlock with @code{name}. +@end defun + + +@cppindex mp_rwlock_name +@lspindex mp:rwlock-name + +@deftypefun cl_object mp_rwlock_name (cl_object lock) +@end deftypefun + +@defun mp:rwlock_name lock +Returns @code{lock} name. +@end defun + + +@cppindex mp_get_rwlock_read_wait +@cppindex mp_get_rwlock_read_nowait +@lspindex mp:get-rwlock-read + +@deftypefun cl_object mp_get_rwlock_read_wait (cl_object lock) +Acquires @code{lock} (blocks if @code{lock} is already taken with +@code{mp:get-rwlock-write}. Lock may be acquired by multiple +readers). Returns @code{ECL_T}. +@end deftypefun + +@deftypefun cl_object mp_get_rwlock_read_nowait +Tries to acquire @code{lock}. if @code{lock} is already taken with +@code{mp:get-rwlock-write} returns @code{ECL_NIL}, otherwise +@code{ECL_T}. +@end deftypefun + +@defun mp:get-rwlock-read lock &optional (wait t) +Tries to acquire @code{lock}. @code{wait} indicates whenever function +should block or give up if @code{lock} is already taken with +@code{mp:get-rwlock-write}. +@end defun + + +@cppindex mp_get_rwlock_write_wait +@cppindex mp_get_rwlock_write_nowait +@lspindex mp:get-rwlock-write + +@deftypefun cl_object mp_get_rwlock_write_wait (cl_object lock) +Acquires @code{lock} (blocks if @code{lock} is already taken). Returns +@code{ECL_T}. +@end deftypefun + +@deftypefun cl_object mp_get_rwlock_write_nowait +Tries to acquire @code{lock}. If @code{lock} is already taken returns +@code{ECL_NIL}, otherwise @code{ECL_T}. +@end deftypefun + +@defun mp:get-rwlock-write lock &optional (wait t) +Tries to acquire @code{lock}. @code{wait} indicates whenever function +should block or give up if @code{lock} is already taken. +@end defun + + +@cppindex mp_giveup_rwlock_read +@cppindex mp_giveup_rwlock_write + +@lspindex mp:giveup-rwlock-read +@lspindex mp:giveup-rwlock-write + + +@deftypefun cl_object mp_giveup_rwlock_read (cl_object lock) +@end deftypefun +@deftypefun cl_object mp_giveup_rwlock_write (cl_object lock) +@end deftypefun + +@defun mp:giveup_rwlock_read lock +@end defun +@defun mp:giveup_rwlock_write lock +Release @code{lock}. +@end defun + + +@lspindex mp:with-rwlock + +@defmac mp:with-rwlock (lock op) &body body +Acquire rwlock for the dynamic scope of @code{body} for operation +@code{op}, which is executed with the lock held by current thread, and +@code{with-rwlock} returns the values of body. + +Valid values of argument @code{op} are @code{:read} or @code{:write} +(for reader and writer access accordingly). +@end defmac diff -Nru ecl-16.1.2/src/doc/new-doc/extensions/mp_ref_sem.txi ecl-16.1.3+ds/src/doc/new-doc/extensions/mp_ref_sem.txi --- ecl-16.1.2/src/doc/new-doc/extensions/mp_ref_sem.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/extensions/mp_ref_sem.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,96 @@ +@node Semaphores +@subsection Semaphores + +Semaphores are objects which allow an arbitrary resource +count. Semaphores are used for shared access to resources where number +of concurrent threads allowed to access it is limited. + +@node Semaphores dictionary +@subsection Semaphores dictionary + + +@cppindex ecl_make_semaphore +@deftypefun cl_object ecl_make_semaphore (cl_object name, cl_fixnum count) +C/C++ equivalent of @code{mp:make-sempahore} without @code{key} +arguments. + +See @code{mp:make-sempahore}. +@end deftypefun + + +@cppindex mp_make_semaphore +@lspindex mp:make_semaphore + +@defun mp:make-semaphore &key name count +Creates a counting semaphore @code{name} with a resource count +@code{count}. +@end defun + + +@cppindex mp_semaphore_name +@lspindex mp:semaphore-name + +@deftypefun cl_object mp_semaphore_name (cl_object semaphore) +@end deftypefun + +@defun mp:semaphore-name semaphore +Returns @code{semaphore} name. +@end defun + + +@cppindex mp_semaphore_count +@lspindex mp:semaphore-count + +@deftypefun cl_object mp_semaphore_count (cl_object semaphore) +@end deftypefun + +@defun mp:semaphore-count semaphore +Returns @code{semaphore} count of resources. +@end defun + + +@cppindex mp_semaphore_wait_count +@lspindex mp:semaphore-wait-count + +@deftypefun cl_object mp_semaphore_wait_count (cl_object semaphore) +@end deftypefun + +@defun mp:semaphore-wait-count semaphore +Returns number of threads waiting on @code{semaphore}. +@end defun + + +@cppindex mp_wait_on_semaphore +@lspindex mp:wait-on-semaphore + +@deftypefun cl_object mp_wait_on_semaphore (cl_object semaphore) +@end deftypefun + +@defun mp:wait-on-semaphore semaphore +Waits on semaphore until it can grab the resource (blocking). Returns +resource count before semaphore was acquired. +@end defun + + +@cppindex mp_try_get_semaphore +@lspindex mp:try-get-semaphore + +@deftypefun cl_object mp_try_get_semaphore (cl_object semaphore) +@end deftypefun + +@defun mp:try_get_semaphore semaphore +Tries to get a semaphore (non-blocking). If there is no resource left +returns @code{NIL}, otherwise returns resource count before semaphore +was acquired. +@end defun + + +@lspindex mp_signal_semaphore +@lspindex mp:signal-semaphore + +@deftypefun cl_object mp_signal_semaphore (cl_narg n, cl_object sem, ...); +@end deftypefun + +@defun mp:signal-semaphore semaphore &optional (count 1) +Releases @code{count} units of a resource on @code{semaphore}. +@end defun diff -Nru ecl-16.1.2/src/doc/new-doc/extensions/mp.txi ecl-16.1.3+ds/src/doc/new-doc/extensions/mp.txi --- ecl-16.1.2/src/doc/new-doc/extensions/mp.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/extensions/mp.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,62 @@ +@node Native threads +@section Native threads +@cindex Native threads +@ftindex THREADS +@cfindex --enable-threads [yes|no|AUTO] + +@menu +* Introduction to native threads:: +* Processes (native threads):: +* Processes dictionary:: +* Locks (mutexes):: +* Locks dictionary:: +* Readers-writer locks:: +* Readers-writer locks dictionary:: +* Condition variables:: +* Condition variables dictionary:: +* Semaphores:: +* Semaphores dictionary:: +@end menu + +@node Introduction to native threads +@subsection Tasks, threads or processes + +On most platforms, ECL supports native multithreading. That means there +can be several tasks executing lisp code on parallel and sharing memory, +variables and files. The interface for multitasking in ECL, like those +of most other implementations, is based on a set of functions and types +that resemble the multiprocessing capabilities of old Lisp Machines. + +This backward compatibility is why tasks or threads are called +"processes". However, they should not be confused with operating system +processes, which are made of programs running in separate contexts and +without access to each other's memory. + +The implementation of threads in ECL is purely native and based on Posix +Threads wherever avaiable. The use of native threads has +advantanges. For instance, they allow for non-blocking file operations, +so that while one task is reading a file, a different one is performing +a computation. + +As mentioned above, tasks share the same memory, as well as the set of +open files and sockets. This manifests on two features. First of all, +different tasks can operate on the same lisp objects, reading and +writing their slots, or manipulating the same arrays. Second, while +threads share global variables, constants and function definitions they +can also have thread-local bindings to special variables that are not +seen by other tasks. + +The fact that different tasks have access to the same set of data allows +both for flexibility and a greater risk. In order to control access to +different resources, ECL provides the user with locks, as explained in +the next section. + +@include extensions/mp_ref_process.txi +@include extensions/mp_ref_mutex.txi +@include extensions/mp_ref_rwlock.txi +@include extensions/mp_ref_cv.txi +@include extensions/mp_ref_sem.txi + +@c @include extensions/mp_ref_barrier.txi +@c @include extensions/mp_ref_mailbox.txi +@c @include extensions/mp_ref_atomic.txi diff -Nru ecl-16.1.2/src/doc/new-doc/extensions/packages.txi ecl-16.1.3+ds/src/doc/new-doc/extensions/packages.txi --- ecl-16.1.2/src/doc/new-doc/extensions/packages.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/extensions/packages.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,154 @@ +@c @node Local package nicknames +@c @section Local package nicknames + +@c @node Hierarchical packages +@c @section Hierarchical packages + +@node Package locks +@section Package locks + +@menu +* Package Locking Overview:: +* Operations Violating Package Locks:: +* Package Lock Dictionary:: +@end menu + +@cindex Package locks +@ftindex PACKAGE-LOCKS + +@node Package Locking Overview +@subsection Package Locking Overview + +ECL borrows parts of the protocol and documentation from SBCL for +compatibility. Interface is the same except that the home package for +locking is ext and that ECL doesn't implement Implementation Packages +and a few constructs. To load the extension you need to require +@code{package-locks}: + +@lisp +(require '#:package-locks) +@end lisp + +Package locks protect against unintentional modifications of a package: +they provide similar protection to user packages as is mandated to +@code{common-lisp} package by the ANSI specification. They are not, and +should not be used as, a security measure. + +Newly created packages are by default unlocked (see the @code{:lock} +option to @code{defpackage}). + +The package @code{common-lisp} and ECL internal implementation packages +are locked by default, including @code{ext}. + +It may be beneficial to lock @code{common-lisp-user} as well, to +ensure that various libraries don't pollute it without asking, +but this is not currently done by default. + +@node Operations Violating Package Locks +@subsection Operations Violating Package Locks + +The following actions cause a package lock violation if the package +operated on is locked, and @code{*package*} is not an implementation +package of that package, and the action would cause a change in the +state of the package (so e.g. exporting already external symbols is +never a violation). Package lock violations caused by these operations +signal errors of type @code{package-error}. + +@enumerate +@item +Shadowing a symbol in a package. + +@item +Importing a symbol to a package. + +@item +Uninterning a symbol from a package. + +@item +Exporting a symbol from a package. + +@item +Unexporting a symbol from a package. + +@item +Changing the packages used by a package. + +@item +Renaming a package. + +@item +Deleting a package. + +@item +Attempting to redefine a function in a locked package. + +@item +Adding a new package local nickname to a package. + +@item +Removing an existing package local nickname to a package. + +@end enumerate + +@node Package Lock Dictionary +@subsection Package Lock Dictionary + +@lspindex ext:package-locked-p +@defun ext:package-locked-p package +Returns @code{t} when @code{package} is locked, @code{nil} +otherwise. Signals an error if @code{package} doesn’t designate a valid +package. +@end defun + +@lspindex ext:lock-package +@defun ext:lock-package package +Locks @code{package} and returns @code{t}. Has no effect if package was +already locked. Signals an error if package is not a valid +@code{package} designator +@end defun + +@lspindex ext:unlock-package +@defun ext:unlock-package package +Unlocks @code{package} and returns @code{t}. Has no effect if +@code{package} was already unlocked. Signals an error if @code{package} +is not a valid package designator. +@end defun + +@lspindex ext:without-package-locks +@defmac ext:without-package-locks &body body +Ignores all runtime package lock violations during the execution of +body. Body can begin with declarations. +@end defmac + +@lspindex ext:with-unlocked-packages +@defmac ext:with-unlocked-packages (&rest packages) &body body +Unlocks @code{packages} for the dynamic scope of the +@code{body}. Signals an error if any of @code{packages} is not a valid +package designator. +@end defmac + +@defmac cl:defpackage name [[option]]* @result{} package + +Options are extended to include the following: + +@itemize +@item +@code{:lock} @var{boolean} + +If the argument to @code{:lock} is @code{t}, the package is initially +locked. If @code{:lock} is not provided it defaults to @code{nil}. + +@end itemize + +@exindex Defpackage @code{:lock} option +Example: + +@lisp +(defpackage "FOO" (:export "BAR") (:lock t)) + +;;; is equivalent to + +(defpackage "FOO") (:export "BAR")) +(lock-package "FOO") +@end lisp +@end defmac diff -Nru ecl-16.1.2/src/doc/new-doc/figures/all-hierarchy.svg ecl-16.1.3+ds/src/doc/new-doc/figures/all-hierarchy.svg --- ecl-16.1.2/src/doc/new-doc/figures/all-hierarchy.svg 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/figures/all-hierarchy.svg 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,3838 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + image/svg+xml + + + + + + + + + + + SBCL + + + ECLs + + + ECoLisp + + + MKCL + + + CLASP + + + KCL + + + CMU CL + + + ECL + + + GCL + + + AKCL + + + Codemist + + + Ibuki + + + Procyon + + + FreeLisp + + + LinkLisp + + + Eclipse + + + Butterfly + + + Utah + + + VAX + + + Golden + + + Exper + + + Lisp-to-C + + + Medley2.0 + + + L + + + Delphi + + + StarSapphire + + + Top Level + + + LispWorks + + + Allegro + + + Corman + + + ThinLisp + + + Lucid + + + Liquid Common Lisp(TM) +Version 5.0 +Relese date 9 JUN 1997 +Not active (maintenance mode) +http://www.lispworks.com/documentation/lcl50/rin/relnotes-1.html +[revised 2016-02-12] + + Liquid + + + Scieneer Common Lisp +Version 1.3.9 +November 14, 2008 +Still sold and provides support +https://www.scieneer.com/scl/ +[revised 2016-02-12] + + Scieneer + + + OpenGenera + + + Genera + + + TI Explorer + + + PowerLisp + + + CLOE + + + SICL + + + MCL + + + RMCL + + + OpenMCL + + + Clozure + + + Poplog + + + JSCL + + + Movitz + + + Mezzano + + + emacs-cl + + + WCL + + + MACL + + + + Coral + + + + XLISP + + + XLISP-PLUS + + + + HCL + + + + + + Obsolete + + + + Bit-rot + + + + Stalled + + + + Active + + + + A + + + + B + + + + A + + + + B + + + + A + + + + B + + + B is a fork of A A has been renamed to B + + B shares some code with A + + + + ANSI compliant + Working towardsANSI compliance + Explicitly marked as a Common-Lisp subset + Other (no info orobsolete) + (C) 2016 Daniel Kochmański CC-BY-4.0 + + + + Lisp500 + + + + Lisp800 + + + + muLISP-90 + + + SoftwareEngineer + + + NanoLISP + + + RefLisp + + + SubL + + + + + + + + + + + Acheron + + + Parenscript + + Data General Common Lisp + Data General Common Lisp debuted (Mary Poppins ed.) 1984. Dev'd in RTP, derived from a Dybvig Scheme at UNC. + +Kent Dybvig was a PhD student at UNC and did some of the initial development. + +Source: Patrick Logan + + DataGeneral + + + + + + + + + + + + + + + + + + + + + + + + + + ABCL + + + XCL +License GPL-2.0 +Version 0.0.0.291 +Oct 12 2010 +Last commit 13 Aug 2011 +http://armedbear.org/ +https://github.com/gnooth/xcl +[revised 2016-02-12] + + XCL + + + UABCL + + + CLISP +Version 2.49 +2010-07-07 +Last commit 2015-05-31 (cosmetic one) +Looking for maintainer +http://clisp.org/ +[revised 2016-02-12] + + CLISP + + + Ufasoft Common Lisp +Version 4.37 +2010-??-?? +Repository last activity 2015-02-11 +http://ufasoft.com/lisp/ +https://github.com/ufasoft/lisp +[revised 2016-02-12] + + Ufasoft + + + CLforJava + + + + + CLiCC + + + mocl + + + + + + + + Binary files /tmp/tmpfunQtY/cpZiCsfjgs/ecl-16.1.2/src/doc/new-doc/figures/ffi.png and /tmp/tmpfunQtY/Q2gw5PRUPc/ecl-16.1.3+ds/src/doc/new-doc/figures/ffi.png differ diff -Nru ecl-16.1.2/src/doc/new-doc/figures/ffi.svg ecl-16.1.3+ds/src/doc/new-doc/figures/ffi.svg --- ecl-16.1.2/src/doc/new-doc/figures/ffi.svg 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/figures/ffi.svg 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,203 @@ + + + +image/svg+xmlC +compiler +Foreign +data +Assembler +C-INLINE +DFFI +UFFI + \ No newline at end of file Binary files /tmp/tmpfunQtY/cpZiCsfjgs/ecl-16.1.2/src/doc/new-doc/figures/file-types.png and /tmp/tmpfunQtY/Q2gw5PRUPc/ecl-16.1.3+ds/src/doc/new-doc/figures/file-types.png differ diff -Nru ecl-16.1.2/src/doc/new-doc/figures/file-types.svg ecl-16.1.3+ds/src/doc/new-doc/figures/file-types.svg --- ecl-16.1.2/src/doc/new-doc/figures/file-types.svg 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/figures/file-types.svg 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,763 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + image/svg+xml + + + + + + + + lisp files + + + + + + + + + + + + + object files + + + + + + + + + + + + + + fasl file + + + + + + + + + + + + + + static libraryshared library + + + + + + + + + + + + + + executable + + + + + + + + + + + + + + build-program + build-static-librarybuild-shared-library + build-fasl + compile-file + + compile-file + build-program + build-fasl + + + + + + + + fasc file + + + + + + + + + + + + + + + compile-file + + Binary files /tmp/tmpfunQtY/cpZiCsfjgs/ecl-16.1.2/src/doc/new-doc/figures/immediate-types.png and /tmp/tmpfunQtY/Q2gw5PRUPc/ecl-16.1.3+ds/src/doc/new-doc/figures/immediate-types.png differ diff -Nru ecl-16.1.2/src/doc/new-doc/figures/immediate-types.svg ecl-16.1.3+ds/src/doc/new-doc/figures/immediate-types.svg --- ecl-16.1.2/src/doc/new-doc/figures/immediate-types.svg 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/figures/immediate-types.svg 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,1216 @@ + + + + + + + + + + + + + + + + + + image/svg+xml + + + + + + + + Po + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 0 + + + + 0 + + + Pointer + Fixnum + + + + + + + + + + 1 + + + + 1 + + + Character + + + + + + + + + + 1 + + + + 0 + + + + + + + + + + + + 1 + + + + 0 + + + List + + + Binary files /tmp/tmpfunQtY/cpZiCsfjgs/ecl-16.1.2/src/doc/new-doc/figures/kcl-hierarchy.png and /tmp/tmpfunQtY/Q2gw5PRUPc/ecl-16.1.3+ds/src/doc/new-doc/figures/kcl-hierarchy.png differ diff -Nru ecl-16.1.2/src/doc/new-doc/figures/kcl-hierarchy.svg ecl-16.1.3+ds/src/doc/new-doc/figures/kcl-hierarchy.svg --- ecl-16.1.2/src/doc/new-doc/figures/kcl-hierarchy.svg 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/figures/kcl-hierarchy.svg 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,1747 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + image/svg+xml + + + + + + + + + + + SBCL + + + ECLs + + + ECoLisp + + + MKCL + + + CLASP + + + KCL + + + CMU CL + + + ECL + + + GCL + + + AKCL + + + Ibuki + + + Delphi + + + SICL + + + + HCL + + + + + + + + + A + + + + B + + + + A + + + + B + + + + A + + + + B + + + B is a fork of A A has been renamed to B + + B shares some code with A + + + ANSI compliant + Working towardsANSI compliance + Other (no info orobsolete) + (C) 2016 Daniel Kochmański CC-BY-4.0 + Maintained + Obsolete + + + + + + + + + + + + + + + + + + diff -Nru ecl-16.1.2/src/doc/new-doc/.gitignore ecl-16.1.3+ds/src/doc/new-doc/.gitignore --- ecl-16.1.2/src/doc/new-doc/.gitignore 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/.gitignore 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1 @@ +*.html \ No newline at end of file diff -Nru ecl-16.1.2/src/doc/new-doc/indexes/index.txi ecl-16.1.3+ds/src/doc/new-doc/indexes/index.txi --- ecl-16.1.2/src/doc/new-doc/indexes/index.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/indexes/index.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,50 @@ +@node Indexes +@unnumbered Indexes + +@menu +* Concept index:: +* Configure option index:: +* Feature index:: +* Example index:: +* Function index:: +* Variable index:: +* Type index:: +* Common Lisp symbols:: +* C/C++ index:: +@end menu + +@node Concept index +@section Concept index +@printindex cp + +@node Configure option index +@section Configure option index +@printindex cf + +@node Feature index +@section Feature index +@printindex ft + +@node Example index +@section Example index +@printindex ex + +@node Function index +@section Function index +@printindex fn + +@node Variable index +@section Variable index +@printindex vr + +@node Type index +@section Type index +@printindex tp + +@node Common Lisp symbols +@section Common Lisp symbols +@printindex lsp + +@node C/C++ index +@section C/C++ index +@printindex cpp diff -Nru ecl-16.1.2/src/doc/new-doc/introduction/about_ecl.txi ecl-16.1.3+ds/src/doc/new-doc/introduction/about_ecl.txi --- ecl-16.1.2/src/doc/new-doc/introduction/about_ecl.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/introduction/about_ecl.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,35 @@ +@node What is ECL +@section What is ECL + +@clisp{} is a general purpose programming language. It lays its roots in +the @acronym{LISP} programming language @bibcite{LISP1.5} developed by +John McCarthy in the 80s. @clisp{} as we know it @ansi{} is the result +of an standarization process aimed at unifying the multiple lisp +dialects that were born from that language. + +@ecl{} is an implementation of the @clisp{} language. As such it derives +from the implementation of the same name developed by Giuseppe Attardi, +which itself was built using code from the Kyoto Common-Lisp +@bibcite{Yasa:85}. @ref{History} for the history of the code you are +about to use. + +@ecl{} (ECL for short) uses standard C calling conventions for Lisp +compiled functions, which allows C programs to easily call Lisp +functions and vice versa. No foreign function interface is required: +data can be exchanged between C and Lisp with no need for conversion. + +ECL is based on a Common Runtime Support (CRS) which provides basic +facilities for memory management, dynamic loading and dumping of binary +images, support for multiple threads of execution. The CRS is built into +a library that can be linked with the code of the application. ECL is +modular: main modules are the program development tools (top level, +debugger, trace, stepper), the compiler, and CLOS. A native +implementation of CLOS is available in ECL. A runtime version of ECL can +be built with just the modules which are required by the application. + +The ECL compiler compiles from Lisp to C, and then invokes the C +compiler to produce binaries. Additionally portable bytecode compiler is +provided for machines which doesn't have C compiler. While former +releases of ECL adhere to the the reference of the language given in +@cltl2{} @bibcite{Steele90}, the ECL is now compliant with X3J13 ANSI +Common Lisp @bibcite{ANSI}. diff -Nru ecl-16.1.2/src/doc/new-doc/introduction/about_man.txi ecl-16.1.3+ds/src/doc/new-doc/introduction/about_man.txi --- ecl-16.1.2/src/doc/new-doc/introduction/about_man.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/introduction/about_man.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,47 @@ +@node About this book +@section About this book + +This manual is part of the ECL software system. It documents deviations +of ECL from various standards (@bibcite{ANSI}, @bibcite{AMOP},...), +extensions, daily working process (compiling files, loading sources, +creating programs, etc) and the internals of this implementation. + +It is not intended as a source to learn Common Lisp. There are other +tutorials and textbooks available in the Net which serve this +purpose. The homepage of the +@uref{https://common-lisp.net,Common-Lisp.net} contains a good list of +links of such teaching and learning material. + +This book is structure into four parts: + +@subsection User's guide +We begin with [@ref{User's guide}] which provides introductory material +showing the user how to build and use ECL and some of its unique +features. This part assumes some basic Common Lisp knowledge and is +suggested as an entry point for a new users who want to start using +@ecl{}. + +@subsection Developer's guide +[@ref{Developer's guide}] documents @ecl{} implementation details. This +part isn not meant for normal users but rather for the ECL developers +and other people who want to contribute to @ecl{}. This section is prone +to change due to the dynamic nature of a software. Covered topics +include source code structure, contributing guide, internal +implementation details and many other topics relevant to the development +process. + +@subsection Standards +[@ref{Standards}] documents all parts of the standard which are left as +implementation specific or to which ECL doesn't adhere. For instance, +precision of floating point numbers, available character sets, actual +input/output protocols, etc. + +Section covers also @emph{C Reference} as a description of @ansi{} from +the C/C++ programmer perspective and @emph{ANSI Dictionary} for @clisp{} +constructs available from C/C++. + +@subsection Extensions +[@ref{Extensions}] introduces all features which are specific to ECL and +which lay outside the standard. This includes configuring, building and +installing ECL multiprocessing capabilities, graphics libraries, +interfacing with the operating system, etc. diff -Nru ecl-16.1.2/src/doc/new-doc/introduction/copyrights.txi ecl-16.1.3+ds/src/doc/new-doc/introduction/copyrights.txi --- ecl-16.1.2/src/doc/new-doc/introduction/copyrights.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/introduction/copyrights.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,81 @@ +@node Copyrights +@section Copyrights + +@subsection Copyright of ECL + +ECL is distributed under the GNU LGPL, which allows for commercial uses +of the software. A more precise description is given in the Copyright +notice which is shipped with ECL. + +@verbatim +---- BEGINNING OF COPYRIGHT FOR THE ECL CORE ENVIRONMENT ------------ + +Copyright (c) 2015, Daniel Kochmański +Copyright (c) 2000, Juan Jose Garcia Ripoll +Copyright (c) 1990, 1991, 1993 Giuseppe Attardi +Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya +All Rights Reserved + +ECL 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; see file 'Copying'. + +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 Library General Public License for more details. + +You should have received a copy of the GNU Library General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +PLEASE NOTE THAT: + +This license covers all of the ECL program except for the files +src/lsp/loop2.lsp ; Symbolic's LOOP macro +src/lsp/pprint.lsp ; CMUCL's pretty printer +src/lsp/format.lsp ; CMUCL's format +and the directories +contrib/ ; User contributed extensions +examples/ ; Examples for the ECL usage +Look the precise copyright of these extensions in the corresponding +files. + +Examples are licensed under: (SPDX-License-Identifier) BSD-2-Clause + +Report bugs, comments, suggestions to the ecl mailing list: +ecl-devel@common-lisp.net. + +---- END OF COPYRIGHT FOR THE ECL CORE ENVIRONMENT ------------------ +@end verbatim + +@subsection Copyright of this manual + +@itemize Copyright +@item +Daniel Kochmański, 2016 +@item +Juan José García-Ripoll, 2006 +@item +Kevin M. Rosenberg, 2002-2003 (UFFI Reference) +@end itemize + +@itemize Trademark +@item +AllegroCL is a registered trademark of Franz Inc. +@item +Lispworks is a registered trademark of Xanalys Inc. +@item +Microsoft Windows is a registered trademark of Microsoft Inc. +@item +Other brand or product names are the registered trademarks or trademarks +of their respective holders. +@end itemize + +Permission is granted to copy, distribute and/or modify this document +under the terms of the GNU Free Documentation License, Version 1.3 or +any later version published by the Free Software Foundation; with no +Invariant Sections, with the no Front-Cover Texts, and with no +Back-Cover Texts. Exact text of the license is available at +@uref{https://www.gnu.org/copyleft/fdl.html}. diff -Nru ecl-16.1.2/src/doc/new-doc/introduction/credits.txi ecl-16.1.3+ds/src/doc/new-doc/introduction/credits.txi --- ecl-16.1.2/src/doc/new-doc/introduction/credits.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/introduction/credits.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,57 @@ +@node Credits +@section Credits + +The @ecl{} project is an implementation of the @clisp{} language that +aims to comply with the @ansi{} standard. The first ECL implementations +were developed by Giuseppe Attardi's who produced an interpreter and +compiler fully conformat with the Common-Lisp as reported in +@cite{Steele:84}. ECL derives itself mostly from Kyoto @clisp{}, an +implementation developed at the Research Institute for Mathematical +Sciences (RIMS), Kyoto University, with the cooperation of Nippon Data +General Corporation. The main developers of Kyoto @clisp{} were Taiichi +Yuasa and Masami Hagiya, of the Research Institute for Mathematical +Sciences, at Kyoto University. + +We must thank Giuseppe Attardi, Yuasa and Hagiya and Juan Jose Garcia +Ripoll for their wonderful work with preceding implementations and for +putting them in the Public Domain under the GNU General Public License +as published by the Free Software Foundation. Without them this product +would have never been possible. + +This document is an update of the original ECL documentation, which was +based in part on the material in @bibcite{Yuasa:85} + +The following people or organizations must be credited for support in +the development of Kyoto @clisp{}: Prof. Reiji Nakajima at RIMS, Kyoto +University; Nippon Data General Corporation; Teruo Yabe; Toshiyasu +Harada; Takashi Suzuki; Kibo Kurokawa; Data General Corporation; Richard +Gabriel; Daniel Weinreb; Skef Wholey; Carl Hoffman; Naruhiko Kawamura; +Takashi Sakuragawa; Akinori Yonezawa; Etsuya Shibayama; Hagiwara +Laboratory; Shuji Doshita; Takashi Hattori. + +William F. Schelter improved KCL in several areas and developed Austin +Kyoto @clisp{} (AKCL). Many ideas and code from AKCL have been +incorporated in @ecl{}. + +The following is the partial list of contributors to ECL: Taiichi Yuasa +and Masami Hagiya (KCL), William F. Schelter (Dynamic loader, +conservative Gc), Giuseppe Attardi (Top-level, trace, stepper, compiler, +CLOS, multithread), Marcus Daniels (Linux port) Cornelis van der Laan +(FreeBSD port) David Rudloff (NeXT port) Dan Stanger, Don Cohen, and +Brian Spilsbury. + +We have to thank for the following pieces of software that have helped +in the development of @ecl{} +@table @sc +@item Bruno Haible +For the Cltl2-compliance test +@item Peter Van Eynde +For the ANSI-compliance test +@item Symbolic's Inc. +For the ANSI-compliant LOOP macro. +@end table + +The @ecl{} project also owes a lot to the people who have tested this +program and contributed with suggestions, error messages and +documentation: Eric Marsden, Hannu Koivisto, Jeff Bowden and Yuto +Hayamizu, and others whose name we may have omitted. diff -Nru ecl-16.1.2/src/doc/new-doc/introduction/history.txi ecl-16.1.3+ds/src/doc/new-doc/introduction/history.txi --- ecl-16.1.2/src/doc/new-doc/introduction/history.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/introduction/history.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,63 @@ +@node History +@section History + +The ECL project is an implementation of the Common Lisp language +inherits from many other previous projects, as shown in +@ref{fig:hierarchy}. The oldest ancestor is the Kyoto Common Lisp, an +implementation developed at the the Research Institute for Mathematical +Sciences, Kyoto University @bibcite{Yasa:85}. This implementation was +developed partially in C and partially in Common Lisp itself and +featured a lisp to C translator. + +@float Figure,fig:hierarchy +@caption{ECL's family tree} +@image{figures/kcl-hierarchy,,4.5in} +@end float + +The KCL implementation remained a propietary project for some +time. During this time, William F. Schelter improved KCL in several +areas and developed Austin Kyoto Common-Lisp (AKCL). However, those +changes had to be distributed as patches over the propietary KCL +implementation and it was not until much later that both KCL and AKCL +became freely available and gave rise to the GNU Common Lisp project, +GCL. + +Around the 90's, Giusseppe Attardi worked on the KCL and AKCL code basis +to produce an implementation of Common Lisp that could be embedded in +other C programs @bibcite{Attardi:95}. The result was an implementation +sometimes known as ECL and sometimes as ECoLisp, which achieved rather +good compliance to the informal specification of the language in CLTL2 +@bibcite{Steele:90}, and which run on a rather big number of platforms. + +The ECL project stagnated a little bit in the coming years. In +particular, certain dependencies such as object binary formats, word +sizes and some C quirks made it difficult to port it to new +platforms. Furthermore, ECL was not compliant with the ANSI +specification, a goal that other Common Lisps were struggling to +achieve. + +This is where the ECLS or ECL-Spain project began. Juanjo García-Ripoll +took the ECoLisp sources and worked on them, with some immediate goals +in mind: increase portability, make the code 64-bit clean, make it able +to build itself from scratch, without other implementation of Common +Lisp and restore the ability to link ECL with other C programs. + +Those goals were rather quickly achieved. ECL became ported to a number +of platforms and with the years also compatibility with the ANSI +specification became a more important goal. At some point the fork ECLS, +with agreement of Prof. Attardi, took over the original ECL +implementation and it became what it is nowadays, a community project. + +In 2013 once again project got unmaintained. In 2015 Daniel Kochmański +took the position of a maintainer with consent of Juanjo García-Ripoll. + +The ECL project owes a lot to different people who have contributed in +many different aspects, from pointing out bugs and incompatibilities of +ECL with other programs and specifications, to actually solving these +bugs and porting ECL to new platforms. + +Current development of ECL is still driven by Daniel Kochmański with +main focus on improving ANSI compliance and compatibility with the +Common Lisp libraries ecosystem, fixing bugs, improving speed and the +portability. The project homepage is located at +@uref{https://common-lisp.net/project/ecl/}. diff -Nru ecl-16.1.2/src/doc/new-doc/introduction/index.txi ecl-16.1.3+ds/src/doc/new-doc/introduction/index.txi --- ecl-16.1.2/src/doc/new-doc/introduction/index.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/introduction/index.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,16 @@ +@node Introduction +@unnumbered Introduction + +@menu +* About this book:: Information about the manual +* What is ECL:: Information about the implementation +* History:: ECL from the history perspective +* Credits:: Non-exhaustive list of contributors +* Copyrights:: Copyright of the manual and implementation +@end menu + +@include introduction/about_man.txi +@include introduction/about_ecl.txi +@include introduction/history.txi +@include introduction/credits.txi +@include introduction/copyrights.txi diff -Nru ecl-16.1.2/src/doc/new-doc/macros.txi ecl-16.1.3+ds/src/doc/new-doc/macros.txi --- ecl-16.1.2/src/doc/new-doc/macros.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/macros.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,123 @@ +@macro myctrl {a} +^\a\@c +@end macro +@c @rmacro mopt {a} +@c [\a\]@c +@c @end rmacro +@macro mchoice {a} +<\a\>@c +@end macro +@c @rmacro mstar {a} +@c @{\a\@}*@c +@c @end rmacro +@c @rmacro mplus {a} +@c @{\a\@}+@c +@c @end rmacro +@c @rmacro mgroup {a} +@c @{\a\@},@c +@c @end rmacro + +@macro kwd{a} +@var{:\a\}@c +@end macro + +@macro pxlref{a} +\a\@c +@end macro + +@macro defec{a} +@defun \a\ +@end macro + +@macro aux +&aux@c +@end macro +@macro keys +&key@c +@end macro +@macro rest +&rest@c +@end macro +@macro optional +&optional@c +@end macro +@macro allow +&allow-other-keys@c +@end macro + +@macro macref{foo} +\foo\@c +@end macro +@macro tindexed{foo} +\foo\@c +@end macro +@macro cindexed{foo} +\foo\@c +@end macro +@macro vindexed{foo} +\foo\@c +@end macro +@ifhtml +@macro bibcite{foo} +[@pxref{Bibliography, \foo\}] +@end macro +@end ifhtml +@ifnothtml +@macro bibcite{foo} +[\foo\, @pxref{Bibliography}] +@end macro +@end ifnothtml + +@macro back +\\ +@end macro + +@macro nil +() +@end macro + +@macro true +@var{T} +@end macro + +@macro ansi +@r{ANSI Common-Lisp} +@end macro +@macro ecl +@b{@r{Embeddable Common Lisp}} +@end macro +@macro clisp +@r{Common-Lisp} +@end macro +@macro llisp +@b{@r{Lisp}} +@end macro +@macro cltl +@emph{@clisp{}: The Language} +@end macro +@macro cltl2 +@emph{@clisp{}: The Language II} +@end macro + +@c --- TAGS --- @ + +@macro cind +C/C++ identifier +@end macro +@macro lind +Common Lisp symbol +@end macro +@macro ocl +@emph{Only in Common Lisp} +@end macro + +@c --- Helpers --- @ +@macro clhs{end,name} +@url{http://www.lispworks.com/documentation/HyperSpec/Body/\end\,,\name\} +@end macro + +@macro ansidict{left,right} +@item +\left\ +@tab \right\ +@end macro diff -Nru ecl-16.1.2/src/doc/new-doc/Makefile ecl-16.1.3+ds/src/doc/new-doc/Makefile --- ecl-16.1.2/src/doc/new-doc/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/Makefile 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,21 @@ +FILES= *.txi */*.txi figures/* + +.PHONY: all pdf info html + +all: pdf info html + +pdf: new-doc.pdf +info: ecldoc.info +html: new-doc.html + +new-doc.pdf: $(FILES) + texi2pdf new-doc.txi + +ecldoc.info: $(FILES) + makeinfo new-doc.txi + +new-doc.html: $(FILES) + makeinfo --html --css-include=ecl.css --split=chapter new-doc.txi + +clean: + rm -rf *.{aux,cf,cfs,cp,cpp,cpps,cps,ex,exs,fn,fns,ft,fts,log,lsp,lsps,toc,tp,tps,vr,vrs,pdf,info,html} diff -Nru ecl-16.1.2/src/doc/new-doc/new-doc.txi ecl-16.1.3+ds/src/doc/new-doc/new-doc.txi --- ecl-16.1.2/src/doc/new-doc/new-doc.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/new-doc.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,142 @@ +\input texinfo @c -*-texinfo-*- +@c %**start of header +@setfilename ecldoc.info +@settitle ECL User's Guide +@setchapternewpage odd +@paragraphindent none +@defcodeindex cpp +@defcodeindex lsp +@defcodeindex cf +@defcodeindex ft +@defindex ex +@documentencoding UTF-8 +@c %**end of header + +@c Entries for @command{install-info} to use +@dircategory Lisp Programming +@direntry +* ecl: (ecl). Embeddable Common Lisp (ECL) User's Manual +@end direntry + +@include macros.txi + +@ifinfo +@ecl{} is an implementation of @clisp{} designed for being +@emph{embeddable} into C based applications. + +@noindent +Copyright @copyright{} 2015, Daniel Kochmański +@noindent +Copyright @copyright{} 2000, Juan Jose Garcia-Ripoll +@noindent +Copyright @copyright{} 1990, Giuseppe Attardi +@end ifinfo + +@titlepage +@title ECL User's Guide +@author Giuseppe Attardi +@author Juan Jose Garcia Ripoll (revised version) +@author Daniel Kochmański (revised revised version) + +@page +@vskip 0pt plus 1filll +Copyright @copyright{} 1990, Giuseppe Attardi + +Copyright @copyright{} 2000, Juan Jose Garcia Ripoll + +Copyright @copyright{} 2015, Daniel Kochmański +@end titlepage + +@contents + +@c ************************ TOP NODE ************************** + +@ifnottex +@node Top +@top Top +@end ifnottex + +@iftex +@page +@titlefont{Preface} +@vskip 1cm +@end iftex + +@ecl{} is an implementation of @clisp{} originally designed for being +@emph{embeddable} into C based applications. This document describes +the @ecl{} implementation and how it differs from @bibcite{ANSI} and +@bibcite{Steele:84}. @ref{Developer's guide} and @ref{User's guide} for +the details about the implementation and how to interface with other +languages. + +@menu +* Introduction:: What @ecl{} is +* User's guide:: Guide for the programmers using ECL +* Developer's guide:: Guide for the ECL developers +* Standards:: Deviations and clarifications of the standard +* Extensions:: ECL-specific features and extensions +* Indexes:: Concepts, functions, variables, types and C/C++ + +* Bibliography:: Some interesting books. +@c * List of Figures:: +@c * List of Tables:: +@end menu + +@include introduction/index.txi +@include user-guide/index.txi +@include developer-guide/index.txi +@include standards/index.txi +@include extensions/index.txi +@include indexes/index.txi + +@node Bibliography +@unnumbered Bibliography + +@table @b +@item ANSI +ANSI @clisp{} Specification, 1986. + +@item AMOP +Gregor Kickzales et al. ``The Art of the Metaobject Protocol'' The +M.I.T. Press, Massachussets Institute of Technology, 1999 + +@item LISP1.5 +John McCarthy et al. ``Lisp 1.5 Programmer's Manual 2nd ed'' The +M.I.T. Press, Massachussets Institute of Technology, 1985 + +@item Steele:84 +Guy L. Steele Jr. et al. ``Common Lisp: the Language'', +Digital Press, 1984. + +@item Steele:90 +Guy L. Steele Jr. at al. ``Common Lisp: the Language II'', second edition, +Digital Press, 1990. + +@item Yasa:85 +Taiichi Yuasa and Masami Hagiya ``Kyoto @clisp{} Report'', +Research Institute for Mathematical Sciences, Kyoto University, 1988. + +@item Attardi:95 +Giusseppe Attardi ``Embeddable @clisp{}'', ACM Lisp Pointers, 8(1), +30-41, 1995 + +@item Smith:84 +B.C. Smith and J. des Rivieres ``The Implementation of +Procedurally Reflective Languages'', @emph{Proc. of the 1984 ACM +Symposium on LISP and Functional Programming}, 1984. +@end table + +@bye + +@c * Input and output:: Accessing files with ECL. +@c * Memory management:: Bits and bytes of every object. +@c * Program development:: Tracing, steppping, error handling, etc. +@c * The interpreter:: The guts behind ECL. +@c * The compiler:: When you need speed@dots{} +@c * Declarations:: Helping the compiler +@c * OS interface:: Operating system interface. +@c * Macros:: Implementation dependent features of macros. +@c * CLOS:: Common-Lisp's Object System. +@c * Multithread:: Lisp lightweight processes or threads. +@c * Bibliography:: Some interesting books. + diff -Nru ecl-16.1.2/src/doc/new-doc/standards/data_and_control_flow.txi ecl-16.1.3+ds/src/doc/new-doc/standards/data_and_control_flow.txi --- ecl-16.1.2/src/doc/new-doc/standards/data_and_control_flow.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/standards/data_and_control_flow.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,137 @@ +@node Data and control flow +@section Data and control flow + +@node Shadowed bindings +@cindex Shadowed bindings in LET, FLET, LABELS and lambda-list +@subsection Shadowed bindings +ANSI doesn't specify what should happen if any of the @code{LET}, +@code{FLET} and @code{LABELS} special operators contain many bindings +sharing the same name. Because the behavior varies between the +implementations and the programmer can't rely on the spec ECL signals an +error if such situation occur. + +Moreover, while ANSI defines lambda list parameters in the terms of +@code{LET*}, when used in function context programmer can't provide an +initialization forms for required parameters. If required parameters +share the same name the error is signalled. + +Described behavior is present in ECL since version 16.0.0. Previously +the @code{LET} operator were using first binding. Both @code{FLET} and +@code{LABELS} were signalling an error if C compiler was used and used +the last binding as a visible one when the byte compiler was used. + +@node Minimal compilation +@cindex Bytecodes eager compilation +@lspindex si::make-lambda +@subsection Minimal compilation +Former versions of ECL, as well as many other lisps, used linked lists +to represent code. Executing code thus meant traversing these lists and +performing code transformations, such as macro expansion, every time +that a statement was to be executed. The result was a slow and memory +hungry interpreter. + +Beginning with version 0.3, ECL was shipped with a bytecodes compiler +and interpreter which circumvent the limitations of linked lists. When +you enter code at the lisp prompt, or when you load a source file, ECL +begins a process known as minimal compilation. Barely this process +consists on parsing each form, macroexpanding it and translating it into +an intermediate language made of bytecodes. + +The bytecodes compiler is implemented in src/c/compiler.d. The main +entry point is the lisp function si::make-lambda, which takes a name for +the function and the body of the lambda lists, and produces a lisp +object that can be invoked. For instance, + +@exindex @code{si::make-lambda} usage (bytecodes compilation) +@lisp +> (defvar fun (si::make-lambda 'f '((x) (1+ x)))) +*FUN* +> (funcall fun 2) +3 +@end lisp + +ECL can only execute bytecodes. When a list is passed to EVAL it must be +first compiled to bytecodes and, if the process succeeds, the resulting +bytecodes are passed to the interpreter. Similarly, every time a +function object is created, such as in DEFUN or DEFMACRO, the compiler +processes the lambda form to produce a suitable bytecodes object. + +@cindex Eager compilation implications + +The fact that ECL performs this eager compilation means that changes on +a macro are not immediately seen in code which was already +compiled. This has subtle implications. Take the following code: + +@exindex Eager compilation impact on macros +@lisp +> (defmacro f (a b) `(+ ,a ,b)) +F +> (defun g (x y) (f x y)) +G +> (g 1 2) +3 +> (defmacro f (a b) `(- ,a ,b)) +F +> (g 1 2) +3 +@end lisp + +The last statement always outputs 3 while in former implementations +based on simple list traversal it would produce -1. + +@node Function types +@subsection Function types + +Functions in ECL can be of two types: they are either compiled to +bytecodes or they have been compiled to machine code using a lisp to C +translator and a C compiler. To the first category belong function +loaded from lisp source files or entered at the toplevel. To the second +category belong all functions in the ECL core environment and functions +in files processed by compile or compile-file. + +The output of (symbol-function fun) is one of the following: +@itemize +@item a function object denoting the definition of the function fun, +@item a list of the form (macro . function-object) when fun denotes a macro, +@item or simply 'special, when fun denotes a special form, such as block, if, etc. +@end itemize + +@cindex @code{disassemble} and @code{compile} on defined functions +@exindex Keeping lambda definitions with @code{si:*keep-definitions} + +ECL usually drops the source code of a function unless the global +variable si:*keep-definitions* was true when the function was translated +into bytecodes. Therefore, if you wish to use compile and disassemble on +defined functions, you should issue @code{(setq si:*keep-definitions* +t)} at the beginning of your session. + +@lspindex si:*keep-definitions* +@defvr {SI} {*keep-definitions*} +If set to @code{T} ECL will preserve the compiled function source code +for disassembly and recompilation. +@end defvr + +@cindex Common Lisp functions limits +@lspindex call-arguments-limit +@lspindex lambda-parameters-limit +@lspindex multiple-values-limit +@lspindex lambda-list-keywords + +In @ref{tab:fun-const} we list all Common Lisp values related to the limits of functions. +@float Table,tab:fun-const +@caption{Function related constants} +@multitable @columnfractions 0.3 0.7 +@item call-arguments-limit +@tab 65536 + +@item lambda-parameters-limit +@tab @code{call-arguments-limit} + +@item multiple-values-limit +@tab 64 + +@item lambda-list-keywords +@tab @code{(&optional &rest &key &allow-other-keys &aux &whole &environment &body)} +@end multitable +@end float + diff -Nru ecl-16.1.2/src/doc/new-doc/standards/evaluation.txi ecl-16.1.3+ds/src/doc/new-doc/standards/evaluation.txi --- ecl-16.1.2/src/doc/new-doc/standards/evaluation.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/standards/evaluation.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,165 @@ +@node Evaluation and compilation +@section Evaluation and compilation + +@subsection Compiler declaration @code{OPTIMIZE} +@cindex Compiler declarations +@lspindex optimize +@lspindex debug +@lspindex speed +@lspindex safety +@lspindex space + +The @code{OPTIMIZE} declaration includes three concepts: @code{DEBUG}, +@code{SPEED}, @code{SAFETY} and @code{SPACE}. Each of these declarations +can take one of the integer values 0, 1, 2 and 3. According to these +values, the implementation may decide how to compie or interpret a given +lisp form. + +ECL currently does not use all these declarations, but some of them +definitely affect the speed and behavior of compiled functions. For +instance, the @code{DEBUG} declaration, as shown in +@ref{tab:optimize-debug}, the value of debugging is zero, the function +will not appear in the debugger and, if redefined, some functions might +not see the redefinition. + +@float Table, tab:optimize-debug +@caption{Behavior for different levels of @code{DEBUG}} +@multitable {aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa} {a} {a} {a} {a} +@headitem Behavior +@tab 0 +@tab 1 +@tab 2 +@tab 3 + +@item Compiled functions in the same source file are called directly +@tab Y +@tab Y +@tab N +@tab N + +@item Compiled function appears in debugger backtrace +@tab N +@tab N +@tab Y +@tab Y + +@item All functions get a global entry (SI:C-LOCAL is ignored) +@tab N +@tab N +@tab Y +@tab Y + +@end multitable +@end float + +A bit more critical is the value of @code{SAFETY} because as shown in +@ref{tab:optimize-safety}, it may affect the safety checks generated by +the compiler. In particular, in some circumstances the compiler may +assume that the arguments to a function are properly typed. For +instance, if you compile with a low value of @code{SAFETY}, and invoke +@code{RPLACA}, the consequences are unspecified. + +@float Table, tab:optimize-safety +@caption{Behavior for different levels of @code{SAFETY}} +@multitable {aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa} {a} {a} {a} {a} +@headitem Behavior +@tab 0 +@tab 1 +@tab 2 +@tab 3 + +@item The compiler generates type checks for the arguments of a lambda form, thus enforcing any type declaration written by the user. +@tab N +@tab Y +@tab Y +@tab Y + +@item The value of an expression or a variable declared by the user is assumed to be right. +@tab Y +@tab Y +@tab N +@tab N + +@item We believe type declarations and type inference and, if the type of a form is inferred to be right for a function, slot accessor, etc, this may be inlined. Affects functions like @code{CAR}, @code{CDR}, etc +@tab Y +@tab Y +@tab N +@tab N + +@item We believe types defined before compiling a file not change before the compiled code is loaded. +@tab Y +@tab Y +@tab N +@tab N + +@item Arguments in a lisp form are assumed to have the appropriate types so that the form will not fail. +@tab Y +@tab N +@tab N +@tab N + +@item The slots or fields in a lisp object are accessed directly without type checks even if the type of the object could not be inferred (see line above). Affects functions like @code{PATHNAME-TYPE}, @code{CAR}, @code{REST}, etc. +@tab Y +@tab N +@tab N +@tab N + +@end multitable +@end float + +@subsection C Reference + +@cppindex ecl_process_env +@deftypefn {@cind{}} cl_object cl_env_ptr () +ECL stores information about each thread on a dedicated structure, which +is the process environment. A pointer to this structure can be retrieved +using the function or macro above. This pointer can be used for a +variety of tasks, such as defining special variable bindings, +controlling interrupts, retrieving function output values, etc. +@end deftypefn + +@subsection ANSI Dictionary + +@multitable @columnfractions 0.4 0.6 +@headitem Lisp symbol +@tab C/C++ function + +@ansidict{@clhs{f_cmp.htm,compile},@ocl{}} + +@lspindex eval +@cppindex cl_eval +@ansidict{@clhs{f_eval.htm,eval}, +@code{cl_object cl_eval (cl_object form)}} + +@lspindex compiler-macro-function +@ansidict{@clhs{f_cmp_ma.htm,compiler-macro-function},@ocl{}} + +@lspindex macro-function +@cppindex cl_macro_function +@ansidict{@clhs{f_macro_.htm,macro-function}, +@code{cl_object cl_macro_function(cl_narg narg, cl_object symbol, ...)}} + +@lspindex macroexpand +@cppindex cl_macroexpand +@ansidict{@clhs{f_mexp_.htm,macroexpand}, +@code{cl_object cl_macroexpand(cl_narg narg, cl_object form, ...)}} + +@lspindex macroexpand-1 +@cppindex cl_macroexpand_1 +@ansidict{@clhs{f_mexp_.htm,macroexpand-1}, +@code{cl_object cl_macroexpand_1(cl_narg narg, cl_object form, ...)}} + +@lspindex proclaim +@ansidict{@clhs{f_procla.htm,proclaim},@ocl{}} + +@lspindex special-operator-p +@cppindex cl_special_operator_p +@ansidict{@clhs{f_specia.htm,special-operator-p}, +@code{cl_object cl_special_operator_p(cl_object form)}} + +@lspindex constantp +@cppindex cl_constantp +@ansidict{@clhs{f_consta.htm,constantp}, +@code{cl_object cl_constantp(cl_narg narg, cl_object form, ...)}} + +@end multitable diff -Nru ecl-16.1.2/src/doc/new-doc/standards/index.txi ecl-16.1.3+ds/src/doc/new-doc/standards/index.txi --- ecl-16.1.2/src/doc/new-doc/standards/index.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/standards/index.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,149 @@ +@node Standards +@chapter Standards + +@menu +* Overview:: +* Syntax:: +* Evaluation and compilation:: +* Types and classes:: +* Data and control flow:: +* Iteration:: +* Objects:: +* Structures:: +* Conditions:: +* Symbols:: +* Packages:: +* Numbers:: +* Characters:: +* Conses:: +* Arrays:: +* Strings:: +* Sequences:: +* Hash tables:: +* Filenames:: +* Files:: +* Streams:: +* Printer:: +* Reader:: +* System construction:: +* Environment:: +* Glossary:: +@end menu + +@include standards/overview.txi + +@c No changes regarding the standard +@node Syntax +@section Syntax + +@include standards/evaluation.txi +@include standards/types_and_classes.txi +@include standards/data_and_control_flow.txi + +@node Iteration +@section Iteration + +@node Objects +@section Objects + +@node Structures +@section Structures + +@node Conditions +@section Conditions + +@node Symbols +@section Symbols + +@node Packages +@section Packages + +@node Numbers +@section Numbers +@c build option --with-ieee-fp={yes|no} +@c si::trap-fpe +@c si::nan +@c ext:{short,single,double,long}-float-{positive,negative}-infinity +@c ext:float-nan-p +@c ext:float-infinity-p +@c ext:float-nan-string +@c ext:float-infinity-string + +@c make-random-state fixnum|array +@c ext:random-state-array +@c #$ macro + +@node Characters +@section Characters + +@node Conses +@section Conses + +@node Arrays +@section Arrays + +@node Strings +@section Strings + +@node Sequences +@section Sequences + +@node Hash tables +@section Hash tables +@c weakness in hash tables +@c ext:hash-table-content +@c ext:hash-table-fill +@c ext:hash-table-weakness + +@node Filenames +@section Filenames + +@node Files +@section Files + +@node Streams +@section Streams + +@node Printer +@section Printer + +@node Reader +@section Reader +@c #$ - random state + +@node System construction +@section System construction +@c ext:*load-hooks*, si::*load-search-list* variable: + +@c EXT:*LOAD-HOOKS* is an assoc array of form ((TYPE . LOAD-FUNCTION)), +@c where TYPE is either a string (i.e "lisp", "fasb" etc.), wildcard +@c :WILD (matching any extension) and NIL for no +@c extension. LOAD-FUNCTION is a symbol of a function used to load the +@c file of the TYPE type. + +@c If the argument SOURCE of LOAD is a stream, it is read as an ordinary +@c lisp source code, otherwise it should a pathname (or a string which +@c may be coerced to it). + +@c If pathname doesn't have a directory, host nor device components, +@c then file is looked in the `:SEARCH-LIST` directories (defaulting to +@c si::*load-search-list*) and if found – loaded with LOAD (with +@c pathname with a directory merged from the search-list). + +@c Otherwise (if a pathname does have a directory or the file can't be +@c found in the SEARCH-LIST) and the file type is neither NIL or :WILD, +@c then the assoc value of the TYPE is looked up in EXT:*LOAD-HOOKS* and +@c funcalled on the file (if the TYPE doesn't exist, we load a file as a source code). + +@c If file type is NIL or :WILD, then we try to "guess" it's extension +@c trying extensions from the EXT:*LOAD-HOOKS* in order in which they +@c appear on the list. By default, first entry is (NIL +@c . SI:LOAD-SOURCE), so if there is a file without extension in the +@c directory, it will be treated as a source code. Otherwise we'll try +@c known extensions. + +@node Environment +@section Environment + +@node Glossary +@section Glossary diff -Nru ecl-16.1.2/src/doc/new-doc/standards/overview.txi ecl-16.1.3+ds/src/doc/new-doc/standards/overview.txi --- ecl-16.1.2/src/doc/new-doc/standards/overview.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/standards/overview.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,191 @@ +@node Overview +@section Overview + +@subsection Reading this manual + +@subsubheading Common Lisp users +@ecl{} supports all Common-Lisp data types exactly as defined in the +@bibcite{ANSI}. All functions and macros are expected to behave as +described in that document and in the HyperSpec @bibcite{HyperSpec} +which is the online version of @bibcite{ANSI}. In other words, the +Standard is the basic reference for Common Lisp and also for @ecl{}, and +this part of the manual just complements it, describing +implementation-specific features such as: + +@itemize +@item +Platform dependent limits. +@item +Behavior which is marked as @emph{implementation specific} in the +standard. +@item +Some corner cases which are not described in @bibcite{ANSI}. +@item +The philosophy behind certain implementation choices, etc. +@end itemize + +In order to aid in locating these differences, this first part of +the manual copies the structure of the @ansi{} standard, having +the same number of chapters, each one with a set of sections +documenting the implementation-specific details. + +@subsubheading C/C++ programmers +The second goal of this document is to provide a reference for C +programmers that want to create, manipulate and operate with Common Lisp +programs at a lower level, or simply embedding @ecl{} as a library. + +The C/C++ reference evolves in parallel with the Common Lisp one, in the +form of one section with the name "C Reference" for each chapter of the +@ansi{} standard. Much of what is presented in those sections is +redundant with the Common Lisp specification. In particular, there is a +one-to-one mapping between types and functions which should be obvious +given the rules explained in the next section @emph{C Reference}. + +We must remark that the reference in this part of the manual is not +enough to know how to embed @ecl{} in a program. In practice the user or +developer will also have to learn how to build programs (@ref{System +building}), interface with foreign libraries (@ref{Foreign Function +Interface}), manage memory (@ref{Memory Management}), etc. These +concepts are explained in a different (@ref{Embedding ECL}) part of the +book. + +@subsection C Reference +@subsubheading One type for everything: @code{cl_object} +@cindex One type for everything: @code{cl_object} + +ECL is designed around the basic principle that Common Lisp already +provides everything that a programmer could need, orienting itself +around the creation and manipulation of Common Lisp objects: conses, +arrays, strings, characters, ... When embedding ECL there should be no +need to use other C/C++ types, except when interfacing data to and from +those other languages. + +All Common Lisp objects are represented internally through the same C +type, @code{cl_object}, which is either a pointer to a union type or an +integer, depending on the situation. While the inner guts of this type +are exposed through various headers, the user should never rely on these +details but rather use the macros and functions that are listed in this +manual. + +There are two types of Common Lisp objects: immediate and memory +allocated ones. Immediate types fit in the bits of the @code{cl_object} +word, and do not require the garbage collector to be created. The list +of such types may depend on the platform, but it includes at least the +@code{fixnum} and @code{character} types. + +Memory allocated types on the other hand require the use of the garbage +collector to be created. ECL abstracts this from the user providing +enough constructors, either in the form of Common Lisp functions +(@code{cl_make_array()}, @code{cl_complex()},...), or in the form of +C/C++ constructors (@code{ecl_make_symbol()}, etc). + +Memory allocated types must always be kept alive so that the garbage +collector does not reclaim them. This involves referencing the object +from one of the places that the collector scans: + +@itemize +@item +The fields of an object (array, structure, etc) which is itself +alive. +@item +A special variable or a constant. +@item +The C stack (i.e. automatic variables in a function). +@item +Global variables or pointers that have been registered with the garbage +collector. +@end itemize + +For memory allocation details @xref{Memory Management}. +For object implementation details @xref{Manipulating Lisp objects}. + +@subsubheading Naming conventions +As explained in the introduction, each of the chapters in the Common +Lisp standard can also be implemented using C functions and types. The +mapping between both languages is done using a small set of rules +described below. + +@itemize +@item +Functions in the Common Lisp (@code{CL}) package are prefixed with the +characters @code{cl_}, functions in the System (@code{SI}) package are +prefix with @code{si_}, etc, etc. + +@item +If a function takes only a fixed number of arguments, it is mapped to a +C function with also a fixed number of arguments. For instance, +@code{COS} maps to @code{cl_object cl_cos(cl_object)}, which takes a +single Lisp object and returns a Lisp object of type @code{FLOAT}. + +@item +If the function takes a variable number of arguments, its signature +consists on an integer with the number of arguments and zero or more of +required arguments and then a C vararg. This is the case of +@code{cl_object cl_list(cl_narg narg, ...)}, which can be invoked +without arguments, as in @code{cl_list(0)}, with one, @code{cl_list(1, +a)}, etc. + +@item +Functions return at least one value, which is either the first value +output by the function, or @code{NIL}. The extra values may be retrieved +immediately after the function call using the function +@code{ecl_nth_value}. +@end itemize + +In addition to the Common Lisp core functions (@code{cl_*}), there exist +functions which are devoted only to C/C++ programming, with tasks such +as coercion of objects to and from C types, optimized functions, inlined +macroexpansions, etc. These functions and macros typically carry the +prefix @code{ecl_} or @code{ECL_} and only return one value, if any. + +@cindex ANSI Dictionary +Most (if not all) Common Lisp functions and constructs available from +C/C++ are available in ``ANSI Dictionary'' sections which are part of +the [@ref{Standards}] entries. + +@subsubheading Only in Common Lisp +@cindex Only in Common Lisp + +Some parts of the language are not available as C functions, even though +they can be used in Common Lisp programs. These parts are either marked +in the ``ANSI Dictionary'' sections using the tag @ocl{}, or they are +simply not mentioned (macros and special constructs). This typically +happens with non-translatable constructs such as + +@itemize +@item +Common Lisp macros such as @code{with-open-files} + +@item +Common Lisp special forms, such as @code{cond} + +@item +Common Lisp generic functions, which cannot be written in C because of +their dynamical dispatch and automatic redefinition properties. +@end itemize + +In most of those cases there exist straightforward alternatives using +the constructs and functions in ECL. For example, @code{unwind-protect} +can be implemented using a C macro which is provided by ECL + +@verbatim +cl_env_ptr env = ecl_process_env(); +CL_UNWIND_PROTECT_BEGIN(env) { + /* protected code goes here */ +} CL_UNWIND_PROTECT_EXIT { + /* exit code goes here */ +} CL_UNWIND_PROTECT_END; +@end verbatim + +Common Lisp generic functions can be directly accessed using +@code{funcall} or @code{apply} and the function name, as shown in the +code below + +@example +cl_object name = ecl_make_symbol("MY-GENERIC-FUNCTION","CL-USER"); +cl_object output = cl_funcall(2, name, argument); +@end example + +Identifying these alternatives requires some knowledge of Common Lisp, +which is why it is recommended to approach the embeddable components in +ECL only when there is some familiarity with the language. diff -Nru ecl-16.1.2/src/doc/new-doc/standards/types_and_classes.txi ecl-16.1.3+ds/src/doc/new-doc/standards/types_and_classes.txi --- ecl-16.1.2/src/doc/new-doc/standards/types_and_classes.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/standards/types_and_classes.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,44 @@ +@node Types and classes +@section Types and classes + +ECL defines the following additional built-in classes in the @code{CL} package: + +@itemize +@item @code{single-float} +@item @code{double-float} +@end itemize + +@subsection C Reference + +@subsection ANSI Dictionary +@multitable @columnfractions 0.3 0.7 +@headitem Lisp symbol +@tab C/C++ function + +@lspindex coerce +@cppindex cl_coerce +@ansidict{@clhs{f_coerce.htm,coerce}, +@code{cl_object cl_coerce (cl_object object, cl_object result-type)}} + +@lspindex subtypep +@cppindex cl_subtypep +@ansidict{@clhs{f_subtpp.htm,subtypep}, +@code{cl_object cl_subtypep (cl_narg narg, cl_object type1, cl_object type2, ...)}} + +@lspindex type-of +@cppindex cl_type-of +@ansidict{@clhs{f_tp_of.htm,type-of}, +@code{cl_object cl_type-of (cl_object object)}} + +@lspindex typep +@cppindex cl_typep +@ansidict{@clhs{f_typep.htm,typep}, +@code{cl_object cl_typep (cl_narg narg, cl_object object, cl_object type_specifier, ...)}} + +@lspindex type-error-datum +@ansidict{@clhs{f_tp_err.htm,type-error-datum}, @ocl{}} + +@lspindex type-error-expected-type +@ansidict{@clhs{f_tp_err.htm,type-error-expected-type}, @ocl{}} + +@end multitable diff -Nru ecl-16.1.2/src/doc/new-doc/user-guide/break-loop.txi ecl-16.1.3+ds/src/doc/new-doc/user-guide/break-loop.txi --- ecl-16.1.2/src/doc/new-doc/user-guide/break-loop.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/user-guide/break-loop.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,2 @@ +@node The break loop +@section The break loop diff -Nru ecl-16.1.2/src/doc/new-doc/user-guide/building.txi ecl-16.1.3+ds/src/doc/new-doc/user-guide/building.txi --- ecl-16.1.2/src/doc/new-doc/user-guide/building.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/user-guide/building.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,105 @@ +@node Building ECL +@section Building ECL + +Due to its portable nature ECL works on every (at least) 32-bit +architecture which provides a proper C99 compliant compiler. + +Operating systems on which ECL is reported to work: Linux, Darwin (Mac +OS X), Solaris, FreeBSD, NetBSD, OpenBSD, DragonFly BSD, Windows and +Android. On each of them ECL supports native threads. + +In the past Juanjo José García-Ripoll maintained test farm which +performed ECL tests for each release on number of platforms and +architectures. Due to lack of the resources we can't afford such doing, +however each release is tested by volunteers with an excellent package +@uref{https://common-lisp.net/project/cl-test-grid,cl-test-grid} created +and maintained by Anton Vodonosov. + +@subsection Autoconf based configuration + +ECL, like many other FOSS programs, can be built and installed with a +GNU tool called Autoconf. This is a set of automatically generated +scripts that detect the features of your machine, such as the compiler +type, existing libraries, desired installation path, and configures ECL +accordingly. The following procedure describes how to build ECL using +this procedure and it applies to all platforms except for the Windows +ports using Microsoft Visual Studio compilers (however you may build ECL +with cygwin or mingw using the autoconf as described here). + +To build @ecl{} you need to + +@enumerate +@item +Extract the source code and enter it's directory + +@example +$ tar -xf ecl-xx.x.x.tgz +$ cd ecl-xx.x.x +@end example + +@item +Run the configuration file, build the program and install it + +@example +$ ./configure --prefix=/usr/local +$ make # -jX if you have X cores +$ make install +@end example + +@item +Make sure the program is installed and ready to run: + +@example +$ /usr/local/bin/ecl + +ECL (Embeddable Common-Lisp) 16.0.0 +Copyright (C) 1984 Taiichi Yuasa and Masami Hagiya +Copyright (C) 1993 Giuseppe Attardi +Copyright (C) 2000 Juan J. Garcia-Ripoll +Copyright (C) 2015 Daniel Kochmanski +ECL is free software, and you are welcome to redistribute it +under certain conditions; see file 'Copyright' for details. +Type :h for Help. +Top level in: #. +> +@end example +@end enumerate + +@subsection Platform specific instructions +@subsubsection MSVC based configuration + +If you have a commercial version of Microsoft Visual Studio, the steps +are simple: + +@enumerate +@item +Change to the msvc directory. +@item +Run nmake to build ECL. +@item +Run nmake install prefix=d:\Software\ECL where the prefix is the +directory where you want to install ECL. +@item +Optionally, if you want to build a self-installing executable, you can +install NSIS and run nmake windows-nsi. +@end enumerate + +If you want to build ECL using the free Microsoft Visual Studio Express +2013 or better, you should follow these before building ECL as sketched +before: + +@enumerate +@item +Download and install Microsoft Visual Studio C++ Compiler. +@item +Download and install the Windows SDK +@item +Open the Windows SDK terminal, which will set up the appropriate paths +and environment variables. +@end enumerate + +@c @node BSD systems +@c @subsubsection BSD systems + +@c @node Android +@c @subsubsection Android diff -Nru ecl-16.1.2/src/doc/new-doc/user-guide/embedding.txi ecl-16.1.3+ds/src/doc/new-doc/user-guide/embedding.txi --- ecl-16.1.2/src/doc/new-doc/user-guide/embedding.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/user-guide/embedding.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,2 @@ +@node Embedding ECL +@section Embedding ECL diff -Nru ecl-16.1.2/src/doc/new-doc/user-guide/index.txi ecl-16.1.3+ds/src/doc/new-doc/user-guide/index.txi --- ecl-16.1.2/src/doc/new-doc/user-guide/index.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/user-guide/index.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,23 @@ +@node User's guide +@chapter User's guide + +@menu +* Building ECL:: Building @ecl{} from sources. +* Invoking ECL:: Basic skills. +@c * The top-level loop:: +@c * The tracer:: +@c * The stepper:: +@c * Errors:: +* The break loop:: +@c * Describe and inspect:: +@c * The profiler:: +@c * Online help:: +@c * Building programs:: +@c * User-accessible hooks:: +* Embedding ECL:: +@end menu + +@include user-guide/building.txi +@include user-guide/invoking.txi +@include user-guide/break-loop.txi +@include user-guide/embedding.txi diff -Nru ecl-16.1.2/src/doc/new-doc/user-guide/invoking.txi ecl-16.1.3+ds/src/doc/new-doc/user-guide/invoking.txi --- ecl-16.1.2/src/doc/new-doc/user-guide/invoking.txi 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/new-doc/user-guide/invoking.txi 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,152 @@ +@node Invoking ECL +@section Entering and leaving @ecl{} + +@ecl{} is invoked by the command @code{ecl}. + +@example +% ecl +ECL (Embeddable Common-Lisp) 0.0e +Copyright (C) 1984 Taiichi Yuasa and Masami Hagiya +Copyright (C) 1993 Giuseppe Attardi +Copyright (C) 2000 Juan J. Garcia-Ripoll +Copyright (C) 2015 Daniel Kochmanski +ECL is free software, and you are welcome to redistribute it +under certain conditions; see file 'Copyright' for details. +Type :h for Help. Top level. +Top level in: #. +> +@end example + +When invoked, @ecl{} will print the banner and initialize the system. +The number in the @ecl{} banner identifies the revision of +@ecl{}. @code{0.0e} is the value of the function +@code{lisp-implementation-version}. + +Unless user specifies @code{-norc} flag when invoking the @ecl{}, it +will look for the initialization files @file{~/.ecl} and +@file{~/.eclrc}. If he wants to load his own file from the current +directory, then he should pass the file path to the @code{-load} +parameter: +@example +% ecl -norc -load init.lisp +@end example + +After the initialization, @ecl{} enters the @dfn{top-level loop} and +prints the prompt `@code{>}'. + +@example +Type :h for Help. Top level. +> +@end example + +The prompt indicates that @ecl{} is now ready to receive a form from the +terminal and to evaluate it. + +Usually, the current package (i.e., the value of @var{*package*}) is the +user package, and the prompt appears as above. If, however, the current +package is other than the user package, then the prompt will be prefixed +with the package name. + +@example +> (in-package "CL") +#<"COMMON-LISP" package> +COMMON-LISP> (in-package "SYSTEM") +#<"SI" package> +SI> +@end example + +To exit from @ecl{}, call the function @code{quit}. + +@example +> (quit) +% +@end example + +Alternatively, you may type @myctrl{D} , i.e. press the key @key{D} +while pressing down the control key (@key{Ctrl}). + +@example +> @myctrl{D} + +% +@end example + +The top-level loop of @ecl{} is almost the same as that defined in +Section 20.2 of @bibcite{Steele:84}. Since the input from the terminal +is in line mode, each top-level form should be followed by a newline. +If more than one value is returned by the evaluation of the top-level +form, the values will be printed successively. If no value is returned, +then nothing will be printed. +@example +> (values 1 2) +1 +2 +> (values) + +> +@end example + +When an error is signalled, control will enter the break loop. +@example +> (defun foo (x) (bar x)) +foo + +> (defun bar (y) (bee y y)) + +bar +> (foo 'lish) +Condition of type: UNDEFINED-FUNCTION +The function BAR is undefined. + +Available restarts: + +1. (RESTART-TOPLEVEL) Go back to Top-Level REPL. + +Broken at FOO. In: #. +>> +@end example + +@c @vskip 1em + +`@code{>>}' in the last line is the prompt of the break loop. Like in +the top-level loop, the prompt will be prefixed by the current package +name, if the current package is other than the @code{user} package. + +To go back to the top-level loop, type @code{:q} + +@example +>>:q + +Top level in: #. +> +@end example + +If more restarts are present, user may invoke them with by typing +@code{:rN}, where @key{N} is the restart number. For instance to pick +the restart number two, type @code{:r2}. + +See [@ref{The break loop}] for the details of the break loop. + +The terminal interrupt (usually caused by typing @myctrl{C} +(Control-@code{C})) is a kind of error. It breaks the running program +and calls the break level loop. + +Example: +@example +> (defun foo () (do () (nil))) +foo + +> (foo) +@myctrl{C} + +Condition of type: INTERACTIVE-INTERRUPT +Console interrupt. + +Available restarts: + +1. (CONTINUE) CONTINUE +2. (RESTART-TOPLEVEL) Go back to Top-Level REPL. + +Broken at FOO. In: #. +>> +@end example diff -Nru ecl-16.1.2/src/doc/status.org ecl-16.1.3+ds/src/doc/status.org --- ecl-16.1.2/src/doc/status.org 1970-01-01 00:00:00.000000000 +0000 +++ ecl-16.1.3+ds/src/doc/status.org 2016-12-19 10:25:00.000000000 +0000 @@ -0,0 +1,78 @@ +* Toplevel +- [X] Makefile + +* Introduction +- [ ] About ECL +- [ ] History +- [ ] Credits +- [ ] Copyrights + +* User's guide +- [-] Building ECL +- [X] Basic skills +- [ ] Top-level loop +- [ ] Tracer +- [ ] Stepper +- [ ] Errors +- [ ] The break loop +- [ ] Describe and inspect +- [ ] Online help +- [ ] Building programs +- [ ] User accessible hooks +- [ ] Embedding ECL + +* Developer's guide +- [ ] Source code structure +- [ ] Contributing + - Source documentation +- [ ] Modules hierarchy +- [ ] Testing and benchmarking +- [ ] Manipulating Lisp objects +- [ ] Environment implementation +- [ ] The interpreter +- [ ] The compiler +- [ ] Porting ECL +- [ ] Experimental features +- [ ] Current roadmap + +* Standards +Many nodes, moderate amount of content (deviations from the standard) + +* Extensions +- [ ] System building (ASDF, builder) +- [ ] OS interface +- [X] FFI + - [X] General info and examples + - [X] SFFI :: Static FFI +# - [ ] LFFI :: Library FFI :: (?) /dlopen etc./ +# - [ ] DFFI :: Dynamic FFI + - [X] UFFI +- [ ] Multithreading +- [ ] Signals and Interrupts +- [ ] Networking +- [ ] Memory managament +- [ ] MOP +- [ ] Green threads +- [ ] Continuations +- [ ] Extensible Sequences +- [ ] Gray streams +- [ ] Series +- [ ] Tree walker +- [ ] Local package nicknames +- [ ] CDR Extensions + +* Not documented yet +#+BEGIN_SRC lisp + (when (>= ext:+ecl-version-number+ 160102) + foo + bar) + + (ext:with-backend + :bytecodes fib + :c/c++ fact) + + (ffi:definline …) +#+END_SRC + +* Things to fix +- [ ] Add :long-double to the UFFI interface diff -Nru ecl-16.1.2/src/ecl/configpre.h ecl-16.1.3+ds/src/ecl/configpre.h --- ecl-16.1.2/src/ecl/configpre.h 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/ecl/configpre.h 2016-12-19 10:25:00.000000000 +0000 @@ -15,6 +15,9 @@ /* Use CMU Common-Lisp's FORMAT routine */ #undef ECL_CMU_FORMAT +/* Do we use C or C++ compiler to compile ecl? */ +#undef ECL_CXX_CORE + /* Stack grows downwards */ #undef ECL_DOWN_STACK @@ -27,7 +30,7 @@ /* ECL_LONG_FLOAT */ #undef ECL_LONG_FLOAT -/* ECL_LOING_LONG_BITS */ +/* ECL_LONG_LONG_BITS */ #undef ECL_LONG_LONG_BITS /* Define if your newline is CR */ @@ -129,6 +132,9 @@ /* Define to 1 if you have the header file. */ #undef HAVE_FCNTL_H +/* Define to 1 if you have the `feenableexcept' function. */ +#undef HAVE_FEENABLEEXCEPT + /* Define to 1 if you have the header file. */ #undef HAVE_FENV_H @@ -150,6 +156,9 @@ /* Define to 1 if you have the `frexpf' function. */ #undef HAVE_FREXPF +/* Define to 1 if you have the `frexpl' function. */ +#undef HAVE_FREXPL + /* Define to 1 if you have the `fseeko' function. */ #undef HAVE_FSEEKO @@ -183,6 +192,9 @@ /* Define to 1 if you have the `ldexpf' function. */ #undef HAVE_LDEXPF +/* Define to 1 if you have the `ldexpl' function. */ +#undef HAVE_LDEXPL + /* HAVE_LIBFFI */ #undef HAVE_LIBFFI @@ -259,6 +271,9 @@ /* HAVE_POSIX_RWLOCK */ #undef HAVE_POSIX_RWLOCK +/* Define to 1 if the system has the type `pthread_rwlock_t'. */ +#undef HAVE_PTHREAD_RWLOCK_T + /* Define to 1 if the system has the type `ptrdiff_t'. */ #undef HAVE_PTRDIFF_T diff -Nru ecl-16.1.2/src/gmp/acinclude.m4 ecl-16.1.3+ds/src/gmp/acinclude.m4 --- ecl-16.1.2/src/gmp/acinclude.m4 2016-02-25 07:06:19.000000000 +0000 +++ ecl-16.1.3+ds/src/gmp/acinclude.m4 1970-01-01 00:00:00.000000000 +0000 @@ -1,3797 +0,0 @@ -dnl GMP specific autoconf macros - - -dnl Copyright 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software -dnl Foundation, Inc. -dnl -dnl This file is part of the GNU MP Library. -dnl -dnl The GNU MP Library is free software; you can redistribute it and/or modify -dnl it under the terms of the GNU Lesser General Public License as published -dnl by the Free Software Foundation; either version 2.1 of the License, or (at -dnl your option) any later version. -dnl -dnl The GNU MP Library is distributed in the hope that it will be useful, but -dnl WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -dnl or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public -dnl License for more details. -dnl -dnl You should have received a copy of the GNU Lesser General Public License -dnl along with the GNU MP Library; see the file COPYING.LIB. If not, write to -dnl the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, -dnl MA 02110-1301, USA. - - -dnl Some tests use, or must delete, the default compiler output. The -dnl possible filenames are based on what autoconf looks for, namely -dnl -dnl a.out - normal unix style -dnl b.out - i960 systems, including gcc there -dnl a.exe - djgpp -dnl a_out.exe - OpenVMS DEC C called via GNV wrapper (gnv.sourceforge.net) -dnl conftest.exe - various DOS compilers - - -define(IA64_PATTERN, -[[ia64*-*-* | itanium-*-* | itanium2-*-*]]) - -dnl Need to be careful not to match m6811, m6812, m68hc11 and m68hc12, all -dnl of which config.sub accepts. (Though none of which are likely to work -dnl with GMP.) -dnl -define(M68K_PATTERN, -[[m68k-*-* | m68[0-9][0-9][0-9]-*-*]]) - -define(POWERPC64_PATTERN, -[[powerpc64-*-* | powerpc64le-*-* | powerpc620-*-* | powerpc630-*-* | powerpc970-*-* | power[3-9]-*-*]]) - -define(X86_PATTERN, -[[i?86*-*-* | k[5-8]*-*-* | pentium*-*-* | athlon-*-* | viac3*-*-*]]) - - -dnl GMP_FAT_SUFFIX(DSTVAR, DIRECTORY) -dnl --------------------------------- -dnl Emit code to set shell variable DSTVAR to the suffix for a fat binary -dnl routine from DIRECTORY. DIRECTORY can be a shell expression like $foo -dnl etc. -dnl -dnl The suffix is directory separators / or \ changed to underscores, and -dnl if there's more than one directory part, then the first is dropped. -dnl -dnl For instance, -dnl -dnl x86 -> x86 -dnl x86/k6 -> k6 -dnl x86/k6/mmx -> k6_mmx - -define(GMP_FAT_SUFFIX, -[[$1=`echo $2 | sed -e '/\//s:^[^/]*/::' -e 's:[\\/]:_:g'`]]) - - -dnl GMP_REMOVE_FROM_LIST(listvar,item) -dnl ---------------------------------- -dnl Emit code to remove any occurance of ITEM from $LISTVAR. ITEM can be a -dnl shell expression like $foo if desired. - -define(GMP_REMOVE_FROM_LIST, -[remove_from_list_tmp= -for remove_from_list_i in $[][$1]; do - if test $remove_from_list_i = [$2]; then :; - else - remove_from_list_tmp="$remove_from_list_tmp $remove_from_list_i" - fi -done -[$1]=$remove_from_list_tmp -]) - - -dnl GMP_STRIP_PATH(subdir) -dnl ---------------------- -dnl Strip entries */subdir from $path and $fat_path. - -define(GMP_STRIP_PATH, -[GMP_STRIP_PATH_VAR(path, [$1]) -GMP_STRIP_PATH_VAR(fat_path, [$1]) -]) - -define(GMP_STRIP_PATH_VAR, -[tmp_path= -for i in $[][$1]; do - case $i in - */[$2]) ;; - *) tmp_path="$tmp_path $i" ;; - esac -done -[$1]="$tmp_path" -]) - - -dnl GMP_INCLUDE_GMP_H -dnl ----------------- -dnl Expand to the right way to #include gmp-h.in. This must be used -dnl instead of gmp.h, since that file isn't generated until the end of the -dnl configure. -dnl -dnl Dummy values for __GMP_BITS_PER_MP_LIMB and GMP_LIMB_BITS are enough -dnl for all current configure-time uses of gmp.h. -dnl -dnl Replaced $srcdir/gmp-h.in -> gmp-h.in + copying JJGR -dnl -define(GMP_INCLUDE_GMP_H, -[[#define __GMP_WITHIN_CONFIGURE 1 /* ignore template stuff */ -#define GMP_NAIL_BITS $GMP_NAIL_BITS -#define __GMP_BITS_PER_MP_LIMB 123 /* dummy for GMP_NUMB_BITS etc */ -#define GMP_LIMB_BITS 123 -$DEFN_LONG_LONG_LIMB -#include "gmp-h.in"] -]) - - -dnl GMP_HEADER_GETVAL(NAME,FILE) -dnl ---------------------------- -dnl Expand at autoconf time to the value of a "#define NAME" from the given -dnl FILE. The regexps here aren't very rugged, but are enough for gmp. -dnl /dev/null as a parameter prevents a hang if $2 is accidentally omitted. - -define(GMP_HEADER_GETVAL, -[patsubst(patsubst( -esyscmd([grep "^#define $1 " $2 /dev/null 2>/dev/null]), -[^.*$1[ ]+],[]), -[[ - ]*$],[])]) - - -dnl GMP_VERSION -dnl ----------- -dnl The gmp version number, extracted from the #defines in gmp-h.in at -dnl autoconf time. Two digits like 3.0 if patchlevel <= 0, or three digits -dnl like 3.0.1 if patchlevel > 0. - -define(GMP_VERSION, -[GMP_HEADER_GETVAL(__GNU_MP_VERSION,gmp-h.in)[]dnl -.GMP_HEADER_GETVAL(__GNU_MP_VERSION_MINOR,gmp-h.in)[]dnl -ifelse(m4_eval(GMP_HEADER_GETVAL(__GNU_MP_VERSION_PATCHLEVEL,gmp-h.in) > 0),1, -[.GMP_HEADER_GETVAL(__GNU_MP_VERSION_PATCHLEVEL,gmp-h.in)])]) - - -dnl GMP_SUBST_CHECK_FUNCS(func,...) -dnl ------------------------------ -dnl Setup an AC_SUBST of HAVE_FUNC_01 for each argument. - -AC_DEFUN([GMP_SUBST_CHECK_FUNCS], -[m4_if([$1],,, -[_GMP_SUBST_CHECK_FUNCS(ac_cv_func_[$1],HAVE_[]m4_translit([$1],[a-z],[A-Z])_01) -GMP_SUBST_CHECK_FUNCS(m4_shift($@))])]) - -dnl Called: _GMP_SUBST_CHECK_FUNCS(cachevar,substvar) -AC_DEFUN([_GMP_SUBST_CHECK_FUNCS], -[case $[$1] in -yes) AC_SUBST([$2],1) ;; -no) [$2]=0 ;; -esac -]) - - -dnl GMP_SUBST_CHECK_HEADERS(foo.h,...) -dnl ---------------------------------- -dnl Setup an AC_SUBST of HAVE_FOO_H_01 for each argument. - -AC_DEFUN([GMP_SUBST_CHECK_HEADERS], -[m4_if([$1],,, -[_GMP_SUBST_CHECK_HEADERS(ac_cv_header_[]m4_translit([$1],[./],[__]), -HAVE_[]m4_translit([$1],[a-z./],[A-Z__])_01) -GMP_SUBST_CHECK_HEADERS(m4_shift($@))])]) - -dnl Called: _GMP_SUBST_CHECK_HEADERS(cachevar,substvar) -AC_DEFUN([_GMP_SUBST_CHECK_HEADERS], -[case $[$1] in -yes) AC_SUBST([$2],1) ;; -no) [$2]=0 ;; -esac -]) - - -dnl GMP_COMPARE_GE(A1,B1, A2,B2, ...) -dnl --------------------------------- -dnl Compare two version numbers A1.A2.etc and B1.B2.etc. Set -dnl $gmp_compare_ge to yes or no accoring to the result. The A parts -dnl should be variables, the B parts fixed numbers. As many parts as -dnl desired can be included. An empty string in an A part is taken to be -dnl zero, the B parts should be non-empty and non-zero. -dnl -dnl For example, -dnl -dnl GMP_COMPARE($major,10, $minor,3, $subminor,1) -dnl -dnl would test whether $major.$minor.$subminor is greater than or equal to -dnl 10.3.1. - -AC_DEFUN([GMP_COMPARE_GE], -[gmp_compare_ge=no -GMP_COMPARE_GE_INTERNAL($@) -]) - -AC_DEFUN([GMP_COMPARE_GE_INTERNAL], -[ifelse(len([$3]),0, -[if test -n "$1" && test "$1" -ge $2; then - gmp_compare_ge=yes -fi], -[if test -n "$1"; then - if test "$1" -gt $2; then - gmp_compare_ge=yes - else - if test "$1" -eq $2; then - GMP_COMPARE_GE_INTERNAL(m4_shift(m4_shift($@))) - fi - fi -fi]) -]) - - -dnl GMP_PROG_AR -dnl ----------- -dnl GMP additions to $AR. -dnl -dnl A cross-"ar" may be necessary when cross-compiling since the build -dnl system "ar" might try to interpret the object files to build a symbol -dnl table index, hence the use of AC_CHECK_TOOL. -dnl -dnl A user-selected $AR is always left unchanged. AC_CHECK_TOOL is still -dnl run to get the "checking" message printed though. -dnl -dnl If extra flags are added to AR, then ac_cv_prog_AR and -dnl ac_cv_prog_ac_ct_AR are set too, since libtool (cvs 2003-03-31 at -dnl least) will do an AC_CHECK_TOOL and that will AR from one of those two -dnl cached variables. (ac_cv_prog_AR is used if there's an ac_tool_prefix, -dnl or ac_cv_prog_ac_ct_AR is used otherwise.) FIXME: This is highly -dnl dependent on autoconf internals, perhaps it'd work to put our extra -dnl flags into AR_FLAGS instead. -dnl -dnl $AR_FLAGS is set to "cq" rather than leaving it to libtool "cru". The -dnl latter fails when libtool goes into piecewise mode and is unlucky -dnl enough to have two same-named objects in separate pieces, as happens -dnl for instance to random.o (and others) on vax-dec-ultrix4.5. Naturally -dnl a user-selected $AR_FLAGS is left unchanged. -dnl -dnl For reference, $ARFLAGS is used by automake (1.8) for its ".a" archive -dnl file rules. This doesn't get used by the piecewise linking, so we -dnl leave it at the default "cru". -dnl -dnl FIXME: Libtool 1.5.2 has its own arrangments for "cq", but that version -dnl is broken in other ways. When we can upgrade, remove the forcible -dnl AR_FLAGS=cq. - -AC_DEFUN([GMP_PROG_AR], -[dnl Want to establish $AR before libtool initialization. -AC_BEFORE([$0],[AC_PROG_LIBTOOL]) -gmp_user_AR=$AR -AC_CHECK_TOOL(AR, ar, ar) -if test -z "$gmp_user_AR"; then - eval arflags=\"\$ar${abi1}_flags\" - test -n "$arflags" || eval arflags=\"\$ar${abi2}_flags\" - if test -n "$arflags"; then - AC_MSG_CHECKING([for extra ar flags]) - AR="$AR $arflags" - ac_cv_prog_AR="$AR $arflags" - ac_cv_prog_ac_ct_AR="$AR $arflags" - AC_MSG_RESULT([$arflags]) - fi -fi -if test -z "$AR_FLAGS"; then - AR_FLAGS=cq -fi -]) - - -dnl GMP_PROG_M4 -dnl ----------- -dnl Find a working m4, either in $PATH or likely locations, and setup $M4 -dnl and an AC_SUBST accordingly. If $M4 is already set then it's a user -dnl choice and is accepted with no checks. GMP_PROG_M4 is like -dnl AC_PATH_PROG or AC_CHECK_PROG, but tests each m4 found to see if it's -dnl good enough. -dnl -dnl See mpn/asm-defs.m4 for details on the known bad m4s. - -AC_DEFUN([GMP_PROG_M4], -[AC_ARG_VAR(M4,[m4 macro processor]) -AC_CACHE_CHECK([for suitable m4], - gmp_cv_prog_m4, -[if test -n "$M4"; then - gmp_cv_prog_m4="$M4" -else - cat >conftest.m4 <<\EOF -dnl Must protect this against being expanded during autoconf m4! -dnl Dont put "dnl"s in this as autoconf will flag an error for unexpanded -dnl macros. -[define(dollarhash,``$][#'')ifelse(dollarhash(x),1,`define(t1,Y)', -``bad: $][# not supported (SunOS /usr/bin/m4) -'')ifelse(eval(89),89,`define(t2,Y)', -`bad: eval() doesnt support 8 or 9 in a constant (OpenBSD 2.6 m4) -')ifelse(t1`'t2,YY,`good -')] -EOF -dnl ' <- balance the quotes for emacs sh-mode - echo "trying m4" >&AC_FD_CC - gmp_tmp_val=`(m4 conftest.m4) 2>&AC_FD_CC` - echo "$gmp_tmp_val" >&AC_FD_CC - if test "$gmp_tmp_val" = good; then - gmp_cv_prog_m4="m4" - else - IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":" -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="$PATH:/usr/5bin" - for ac_dir in $ac_dummy; do - test -z "$ac_dir" && ac_dir=. - echo "trying $ac_dir/m4" >&AC_FD_CC - gmp_tmp_val=`($ac_dir/m4 conftest.m4) 2>&AC_FD_CC` - echo "$gmp_tmp_val" >&AC_FD_CC - if test "$gmp_tmp_val" = good; then - gmp_cv_prog_m4="$ac_dir/m4" - break - fi - done - IFS="$ac_save_ifs" - if test -z "$gmp_cv_prog_m4"; then - AC_MSG_ERROR([No usable m4 in \$PATH or /usr/5bin (see config.log for reasons).]) - fi - fi - rm -f conftest.m4 -fi]) -M4="$gmp_cv_prog_m4" -AC_SUBST(M4) -]) - - -dnl GMP_M4_M4WRAP_SPURIOUS -dnl ---------------------- -dnl Check for spurious output from m4wrap(), as described in mpn/asm-defs.m4. -dnl -dnl The following systems have been seen with the problem. -dnl -dnl - Unicos alpha, but its assembler doesn't seem to mind. -dnl - MacOS X Darwin, its assembler fails. -dnl - NetBSD 1.4.1 m68k, and gas 1.92.3 there gives a warning and ignores -dnl the bad last line since it doesn't have a newline. -dnl - NetBSD 1.4.2 alpha, but its assembler doesn't seem to mind. -dnl - HP-UX ia64. -dnl -dnl Enhancement: Maybe this could be in GMP_PROG_M4, and attempt to prefer -dnl an m4 with a working m4wrap, if it can be found. - -AC_DEFUN([GMP_M4_M4WRAP_SPURIOUS], -[AC_REQUIRE([GMP_PROG_M4]) -AC_CACHE_CHECK([if m4wrap produces spurious output], - gmp_cv_m4_m4wrap_spurious, -[# hide the d-n-l from autoconf's error checking -tmp_d_n_l=d""nl -cat >conftest.m4 <&AC_FD_CC -cat conftest.m4 >&AC_FD_CC -tmp_chars=`$M4 conftest.m4 | wc -c` -echo produces $tmp_chars chars output >&AC_FD_CC -rm -f conftest.m4 -if test $tmp_chars = 0; then - gmp_cv_m4_m4wrap_spurious=no -else - gmp_cv_m4_m4wrap_spurious=yes -fi -]) -GMP_DEFINE_RAW(["define(,<$gmp_cv_m4_m4wrap_spurious>)"]) -]) - - -dnl GMP_PROG_NM -dnl ----------- -dnl GMP additions to libtool AC_PROG_NM. -dnl -dnl Note that if AC_PROG_NM can't find a working nm it still leaves -dnl $NM set to "nm", so $NM can't be assumed to actually work. -dnl -dnl A user-selected $NM is always left unchanged. AC_PROG_NM is still run -dnl to get the "checking" message printed though. -dnl -dnl Perhaps it'd be worthwhile checking that nm works, by running it on an -dnl actual object file. For instance on sparcv9 solaris old versions of -dnl GNU nm don't recognise 64-bit objects. Checking would give a better -dnl error message than just a failure in later tests like GMP_ASM_W32 etc. -dnl -dnl On the other hand it's not really normal autoconf practice to take too -dnl much trouble over detecting a broken set of tools. And libtool doesn't -dnl do anything at all for say ranlib or strip. So for now we're inclined -dnl to just demand that the user provides a coherent environment. - -AC_DEFUN([GMP_PROG_NM], -[dnl Make sure we're the first to call AC_PROG_NM, so our extra flags are -dnl used by everyone. -AC_BEFORE([$0],[AC_PROG_NM]) -gmp_user_NM=$NM -AC_PROG_NM - -# FIXME: When cross compiling (ie. $ac_tool_prefix not empty), libtool -# defaults to plain "nm" if a "${ac_tool_prefix}nm" is not found. In this -# case run it again to try the native "nm", firstly so that likely locations -# are searched, secondly so that -B or -p are added if necessary for BSD -# format. This is necessary for instance on OSF with "./configure -# --build=alphaev5-dec-osf --host=alphaev6-dec-osf". -# -if test -z "$gmp_user_NM" && test -n "$ac_tool_prefix" && test "$NM" = nm; then - $as_unset lt_cv_path_NM - gmp_save_ac_tool_prefix=$ac_tool_prefix - ac_tool_prefix= - NM= - AC_PROG_NM - ac_tool_prefix=$gmp_save_ac_tool_prefix -fi - -if test -z "$gmp_user_NM"; then - eval nmflags=\"\$nm${abi1}_flags\" - test -n "$nmflags" || eval nmflags=\"\$nm${abi2}_flags\" - if test -n "$nmflags"; then - AC_MSG_CHECKING([for extra nm flags]) - NM="$NM $nmflags" - AC_MSG_RESULT([$nmflags]) - fi -fi -]) - - -dnl GMP_PROG_CC_WORKS(cc+cflags,[ACTION-IF-WORKS][,ACTION-IF-NOT-WORKS]) -dnl -------------------------------------------------------------------- -dnl Check if cc+cflags can compile and link. -dnl -dnl This test is designed to be run repeatedly with different cc+cflags -dnl selections, so the result is not cached. -dnl -dnl For a native build, meaning $cross_compiling == no, we require that the -dnl generated program will run. This is the same as AC_PROG_CC does in -dnl _AC_COMPILER_EXEEXT_WORKS, and checking here will ensure we don't pass -dnl a CC/CFLAGS combination that it rejects. -dnl -dnl sparc-*-solaris2.7 can compile ABI=64 but won't run it if the kernel -dnl was booted in 32-bit mode. The effect of requiring the compiler output -dnl will run is that a plain native "./configure" falls back on ABI=32, but -dnl ABI=64 is still available as a cross-compile. -dnl -dnl The various specific problems we try to detect are done in separate -dnl compiles. Although this is probably a bit slower than one test -dnl program, it makes it easy to indicate the problem in AC_MSG_RESULT, -dnl hence giving the user a clue about why we rejected the compiler. - -AC_DEFUN([GMP_PROG_CC_WORKS], -[AC_MSG_CHECKING([compiler $1]) -gmp_prog_cc_works=yes - -# first see a simple "main()" works, then go on to other checks -GMP_PROG_CC_WORKS_PART([$1], []) - -GMP_PROG_CC_WORKS_PART([$1], [function pointer return], -[/* The following provokes an internal error from gcc 2.95.2 -mpowerpc64 - (without -maix64), hence detecting an unusable compiler */ -void *g() { return (void *) 0; } -void *f() { return g(); } -]) - -GMP_PROG_CC_WORKS_PART([$1], [cmov instruction], -[/* The following provokes an invalid instruction syntax from i386 gcc - -march=pentiumpro on Solaris 2.8. The native sun assembler - requires a non-standard syntax for cmov which gcc (as of 2.95.2 at - least) doesn't know. */ -int n; -int cmov () { return (n >= 0 ? n : 0); } -]) - -GMP_PROG_CC_WORKS_PART([$1], [double -> ulong conversion], -[/* The following provokes a linker invocation problem with gcc 3.0.3 - on AIX 4.3 under "-maix64 -mpowerpc64 -mcpu=630". The -mcpu=630 - option causes gcc to incorrectly select the 32-bit libgcc.a, not - the 64-bit one, and consequently it misses out on the __fixunsdfdi - helper (double -> uint64 conversion). */ -double d; -unsigned long gcc303 () { return (unsigned long) d; } -]) - -GMP_PROG_CC_WORKS_PART([$1], [double negation], -[/* The following provokes an error from hppa gcc 2.95 under -mpa-risc-2-0 if - the assembler doesn't know hppa 2.0 instructions. fneg is a 2.0 - instruction, and a negation like this comes out using it. */ -double fneg_data; -unsigned long fneg () { return -fneg_data; } -]) - -GMP_PROG_CC_WORKS_PART([$1], [double -> float conversion], -[/* The following makes gcc 3.3 -march=pentium4 generate an SSE2 xmm insn - (cvtsd2ss) which will provoke an error if the assembler doesn't recognise - those instructions. Not sure how much of the gmp code will come out - wanting sse2, but it's easiest to reject an option we know is bad. */ -double ftod_data; -float ftod () { return (float) ftod_data; } -]) - -GMP_PROG_CC_WORKS_PART([$1], [gnupro alpha ev6 char spilling], -[/* The following provokes an internal compiler error from gcc version - "2.9-gnupro-99r1" under "-O2 -mcpu=ev6", apparently relating to char - values being spilled into floating point registers. The problem doesn't - show up all the time, but has occurred enough in GMP for us to reject - this compiler+flags. */ -struct try_t -{ - char dst[2]; - char size; - long d0, d1, d2, d3, d4, d5, d6; - char overlap; -}; -struct try_t param[6]; -int -param_init () -{ - struct try_t *p; - memcpy (p, ¶m[ 2 ], sizeof (*p)); - memcpy (p, ¶m[ 2 ], sizeof (*p)); - p->size = 2; - memcpy (p, ¶m[ 1 ], sizeof (*p)); - p->dst[0] = 1; - p->overlap = 2; - memcpy (p, ¶m[ 3 ], sizeof (*p)); - p->dst[0] = 1; - p->overlap = 8; - memcpy (p, ¶m[ 4 ], sizeof (*p)); - memcpy (p, ¶m[ 4 ], sizeof (*p)); - p->overlap = 8; - memcpy (p, ¶m[ 5 ], sizeof (*p)); - memcpy (p, ¶m[ 5 ], sizeof (*p)); - memcpy (p, ¶m[ 5 ], sizeof (*p)); - return 0; -} -]) - -# __builtin_alloca is not available everywhere, check it exists before -# seeing that it works -GMP_PROG_CC_WORKS_PART_TEST([$1],[__builtin_alloca availability], -[int k; int foo () { __builtin_alloca (k); }], - [GMP_PROG_CC_WORKS_PART([$1], [alloca array], -[/* The following provokes an internal compiler error from Itanium HP-UX cc - under +O2 or higher. We use this sort of code in mpn/generic/mul_fft.c. */ -int k; -int foo () -{ - int i, **a; - a = __builtin_alloca (k); - for (i = 0; i <= k; i++) - a[i] = __builtin_alloca (1 << i); -} -])]) - -GMP_PROG_CC_WORKS_PART([$1], [abs int -> double conversion], -[/* The following provokes an internal error from the assembler on - power2-ibm-aix4.3.1.0. gcc -mrios2 compiles to nabs+fcirz, and this - results in "Internal error related to the source program domain". - - For reference it seems to be the combination of nabs+fcirz which is bad, - not either alone. This sort of thing occurs in mpz/get_str.c with the - way double chars_per_bit_exactly is applied in MPN_SIZEINBASE. Perhaps - if that code changes to a scaled-integer style then we won't need this - test. */ - -double fp[1]; -int x; -int f () -{ - int a; - a = (x >= 0 ? x : -x); - return a * fp[0]; -} -]) - -GMP_PROG_CC_WORKS_PART([$1], [long long reliability test 1], -[/* The following provokes a segfault in the compiler on powerpc-apple-darwin. - Extracted from tests/mpn/t-iord_u.c. Causes Apple's gcc 3.3 build 1640 and - 1666 to segfault with e.g., -O2 -mpowerpc64. */ - -#ifdef __GNUC__ -typedef unsigned long long t1;typedef t1*t2; -__inline__ t1 e(t2 rp,t2 up,int n,t1 v0) -{t1 c,x,r;int i;if(v0){c=1;for(i=1;i> tnc; - high_limb = low_limb << cnt; - for (i = n - 1; i != 0; i--) - { - low_limb = *up++; - *rp++ = ~(high_limb | (low_limb >> tnc)); - high_limb = low_limb << cnt; - } - return retval; -} -int -main () -{ - unsigned long cy, rp[2], up[2]; - up[0] = ~ 0L; - up[1] = 0; - cy = lshift_com (rp, up, 2L, 1); - if (cy != 1L) - return 1; - return 0; -} -]) - -GMP_PROG_CC_WORKS_PART_MAIN([$1], [mpn_lshift_com optimization 2], -[/* The following is mis-compiled by Intel ia-64 icc version 1.8 under - "icc -O3", After several calls, the function writes parial garbage to - the result vector. Perhaps relates to the chk.a.nc insn. This code needs - to be run to show the problem, but that's fine, the offending cc is a - native-only compiler so we don't have to worry about cross compiling. */ - -#include -void -lshift_com (rp, up, n, cnt) - unsigned long *rp; - unsigned long *up; - long n; - unsigned cnt; -{ - unsigned long high_limb, low_limb; - unsigned tnc; - long i; - up += n; - rp += n; - tnc = 8 * sizeof (unsigned long) - cnt; - low_limb = *--up; - high_limb = low_limb << cnt; - for (i = n - 1; i != 0; i--) - { - low_limb = *--up; - *--rp = ~(high_limb | (low_limb >> tnc)); - high_limb = low_limb << cnt; - } - *--rp = ~high_limb; -} -int -main () -{ - unsigned long *r, *r2; - unsigned long a[88 + 1]; - long i; - for (i = 0; i < 88 + 1; i++) - a[i] = ~0L; - r = malloc (10000 * sizeof (unsigned long)); - r2 = r; - for (i = 0; i < 528; i += 22) - { - lshift_com (r2, a, - i / (8 * sizeof (unsigned long)) + 1, - i % (8 * sizeof (unsigned long))); - r2 += 88 + 1; - } - if (r[2048] != 0 || r[2049] != 0 || r[2050] != 0 || r[2051] != 0 || - r[2052] != 0 || r[2053] != 0 || r[2054] != 0) - abort (); - return 0; -} -]) - - -# A certain _GLOBAL_OFFSET_TABLE_ problem in past versions of gas, tickled -# by recent versions of gcc. -# -if test "$gmp_prog_cc_works" = yes; then - case $host in - X86_PATTERN) - # this problem only arises in PIC code, so don't need to test when - # --disable-shared. We don't necessarily have $enable_shared set to - # yes at this point, it will still be unset for the default (which is - # yes); hence the use of "!= no". - if test "$enable_shared" != no; then - GMP_PROG_CC_X86_GOT_EAX_EMITTED([$1], - [GMP_ASM_X86_GOT_EAX_OK([$1],, - [gmp_prog_cc_works="no, bad gas GOT with eax"])]) - fi - ;; - esac -fi - -AC_MSG_RESULT($gmp_prog_cc_works) -case $gmp_prog_cc_works in - yes) - [$2] - ;; - *) - [$3] - ;; -esac -]) - -dnl Called: GMP_PROG_CC_WORKS_PART(CC+CFLAGS,FAIL-MESSAGE [,CODE]) -dnl A dummy main() is appended to the CODE given. -dnl -AC_DEFUN([GMP_PROG_CC_WORKS_PART], -[GMP_PROG_CC_WORKS_PART_MAIN([$1],[$2], -[$3] -[int main () { return 0; }]) -]) - -dnl Called: GMP_PROG_CC_WORKS_PART_MAIN(CC+CFLAGS,FAIL-MESSAGE,CODE) -dnl CODE must include a main(). -dnl -AC_DEFUN([GMP_PROG_CC_WORKS_PART_MAIN], -[GMP_PROG_CC_WORKS_PART_TEST([$1],[$2],[$3], - [], - gmp_prog_cc_works="no[]m4_if([$2],,,[[, ]])[$2]", - gmp_prog_cc_works="no[]m4_if([$2],,,[[, ]])[$2][[, program does not run]]") -]) - -dnl Called: GMP_PROG_CC_WORKS_PART_TEST(CC+CFLAGS,TITLE,[CODE], -dnl [ACTION-GOOD],[ACTION-BAD][ACTION-NORUN]) -dnl -AC_DEFUN([GMP_PROG_CC_WORKS_PART_TEST], -[if test "$gmp_prog_cc_works" = yes; then - # remove anything that might look like compiler output to our "||" expression - rm -f conftest* a.out b.out a.exe a_out.exe - cat >conftest.c <&AC_FD_CC - gmp_compile="$1 conftest.c >&AC_FD_CC" - if AC_TRY_EVAL(gmp_compile); then - cc_works_part=yes - if test "$cross_compiling" = no; then - if AC_TRY_COMMAND([./a.out || ./b.out || ./a.exe || ./a_out.exe || ./conftest]); then :; - else - cc_works_part=norun - fi - fi - else - cc_works_part=no - fi - if test "$cc_works_part" != yes; then - echo "failed program was:" >&AC_FD_CC - cat conftest.c >&AC_FD_CC - fi - rm -f conftest* a.out b.out a.exe a_out.exe - case $cc_works_part in - yes) - $4 - ;; - no) - $5 - ;; - norun) - $6 - ;; - esac -fi -]) - - -dnl GMP_PROG_CC_WORKS_LONGLONG(cc+cflags,[ACTION-YES][,ACTION-NO]) -dnl -------------------------------------------------------------- -dnl Check that cc+cflags accepts "long long". -dnl -dnl This test is designed to be run repeatedly with different cc+cflags -dnl selections, so the result is not cached. - -AC_DEFUN([GMP_PROG_CC_WORKS_LONGLONG], -[AC_MSG_CHECKING([compiler $1 has long long]) -cat >conftest.c <&AC_FD_CC - cat conftest.c >&AC_FD_CC -fi -rm -f conftest* a.out b.out a.exe a_out.exe -AC_MSG_RESULT($gmp_prog_cc_works) -if test $gmp_prog_cc_works = yes; then - ifelse([$2],,:,[$2]) -else - ifelse([$3],,:,[$3]) -fi -]) - - -dnl GMP_C_TEST_SIZEOF(cc/cflags,test,[ACTION-GOOD][,ACTION-BAD]) -dnl ------------------------------------------------------------ -dnl The given cc/cflags compiler is run to check the size of a type -dnl specified by the "test" argument. "test" can either be a string, or a -dnl variable like $foo. The value should be for instance "sizeof-long-4", -dnl to test that sizeof(long)==4. -dnl -dnl This test is designed to be run for different compiler and/or flags -dnl combinations, so the result is not cached. -dnl -dnl The idea for making an array that has a negative size if the desired -dnl condition test is false comes from autoconf AC_CHECK_SIZEOF. The cast -dnl to "long" in the array dimension also follows autoconf, apparently it's -dnl a workaround for a HP compiler bug. - -AC_DEFUN([GMP_C_TEST_SIZEOF], -[echo "configure: testlist $2" >&AC_FD_CC -[gmp_sizeof_type=`echo "$2" | sed 's/sizeof-\([a-z]*\).*/\1/'`] -[gmp_sizeof_want=`echo "$2" | sed 's/sizeof-[a-z]*-\([0-9]*\).*/\1/'`] -AC_MSG_CHECKING([compiler $1 has sizeof($gmp_sizeof_type)==$gmp_sizeof_want]) -cat >conftest.c <conftest.c <